{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Multi.Derive.HFunctor
-- Copyright   :  (c) 2011 Patrick Bahr
-- License     :  BSD3
-- Maintainer  :  Patrick Bahr <paba@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Automatically derive instances of @HFunctor@.
--
--------------------------------------------------------------------------------

module Data.Comp.Multi.Derive.HFunctor
    (
     HFunctor,
     makeHFunctor
    ) where

import Control.Monad
import Data.Comp.Derive.Utils
import Data.Comp.Multi.HFunctor
import Data.Maybe
import Language.Haskell.TH
import Prelude hiding (mapM)
import qualified Prelude as P (mapM)

iter :: t -> Q Exp -> Q Exp -> Q Exp
iter 0 _ e :: Q Exp
e = Q Exp
e
iter n :: t
n f :: Q Exp
f e :: Q Exp
e = t -> Q Exp -> Q Exp -> Q Exp
iter (t
nt -> t -> t
forall a. Num a => a -> a -> a
-1) Q Exp
f (Q Exp
f Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
e)

{-| Derive an instance of 'HFunctor' for a type constructor of any higher-order
  kind taking at least two arguments. -}
makeHFunctor :: Name -> Q [Dec]
makeHFunctor :: Name -> Q [Dec]
makeHFunctor fname :: Name
fname = do
  Just (DataInfo _cxt :: Cxt
_cxt name :: Name
name args :: [TyVarBndr]
args constrs :: [Con]
constrs _deriving :: [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ (Q Info -> Q (Maybe DataInfo)) -> Q Info -> Q (Maybe DataInfo)
forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
  let args' :: [TyVarBndr]
args' = [TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
args
      fArg :: Type
fArg = Name -> Type
VarT (Name -> Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tyVarBndrName (TyVarBndr -> Type) -> TyVarBndr -> Type
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
args'
      argNames :: Cxt
argNames = (TyVarBndr -> Type) -> [TyVarBndr] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
tyVarBndrName) ([TyVarBndr] -> [TyVarBndr]
forall a. [a] -> [a]
init [TyVarBndr]
args')
      complType :: Type
complType = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
argNames
      classType :: Type
classType = Type -> Type -> Type
AppT (Name -> Type
ConT ''HFunctor) Type
complType
  [(Q Exp, Pat,
  (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
  [Q Exp], [(Int, Name)])]
constrs' <- (Con
 -> Q (Q Exp, Pat,
       (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
       [Q Exp], [(Int, Name)]))
-> [Con]
-> Q [(Q Exp, Pat,
       (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
       [Q Exp], [(Int, Name)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
P.mapM ((Name, [[Int]])
-> Q (Q Exp, Pat,
      (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
      [Q Exp], [(Int, Name)])
forall a c.
(Name, [[a]])
-> Q (Q Exp, Pat, (a -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
      [Q Exp], [(a, Name)])
mkPatAndVars ((Name, [[Int]])
 -> Q (Q Exp, Pat,
       (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
       [Q Exp], [(Int, Name)]))
-> ((Name, Cxt, Maybe Type) -> (Name, [[Int]]))
-> (Name, Cxt, Maybe Type)
-> Q (Q Exp, Pat,
      (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
      [Q Exp], [(Int, Name)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> (Name, Cxt, Maybe Type) -> (Name, [[Int]])
forall a. Type -> (a, Cxt, Maybe Type) -> (a, [[Int]])
isFarg Type
fArg ((Name, Cxt, Maybe Type)
 -> Q (Q Exp, Pat,
       (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
       [Q Exp], [(Int, Name)]))
-> (Con -> Q (Name, Cxt, Maybe Type))
-> Con
-> Q (Q Exp, Pat,
      (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
      [Q Exp], [(Int, Name)])
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Con -> Q (Name, Cxt, Maybe Type)
normalConExp) [Con]
constrs
  Dec
hfmapDecl <- Name -> [ClauseQ] -> DecQ
funD 'hfmap (((Q Exp, Pat,
  (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
  [Q Exp], [(Int, Name)])
 -> ClauseQ)
-> [(Q Exp, Pat,
     (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
     [Q Exp], [(Int, Name)])]
-> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (Q Exp, Pat,
 (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
 [Q Exp], [(Int, Name)])
-> ClauseQ
forall (t :: * -> *) t a e f.
(Foldable t, Eq t, Num t) =>
(Q Exp, Pat, (t -> Q Exp -> Q Exp) -> (a -> a) -> t (Q Exp), Bool,
 e, f)
-> ClauseQ
hfmapClause [(Q Exp, Pat,
  (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
  [Q Exp], [(Int, Name)])]
constrs')
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD [] Type
classType [Dec
hfmapDecl]]
      where isFarg :: Type -> (a, Cxt, Maybe Type) -> (a, [[Int]])
isFarg fArg :: Type
fArg (constr :: a
constr, args :: Cxt
args, ty :: Maybe Type
ty) = (a
constr, (Type -> [Int]) -> Cxt -> [[Int]]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> [Int]
`containsType'` Type -> Maybe Type -> Type
getBinaryFArg Type
fArg Maybe Type
ty) Cxt
args)
            filterVar :: (t -> t -> p) -> (t -> p) -> [t] -> t -> p
filterVar _ nonFarg :: t -> p
nonFarg [] x :: t
x  = t -> p
nonFarg t
x
            filterVar farg :: t -> t -> p
farg _ [depth :: t
depth] x :: t
x = t -> t -> p
farg t
depth t
x
            filterVar _ _ _ _ = [Char] -> p
forall a. HasCallStack => [Char] -> a
error "functor variable occurring twice in argument type"
            filterVars :: [[t]] -> [t] -> (t -> t -> c) -> (t -> c) -> [c]
filterVars args :: [[t]]
args varNs :: [t]
varNs farg :: t -> t -> c
farg nonFarg :: t -> c
nonFarg = ([t] -> t -> c) -> [[t]] -> [t] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((t -> t -> c) -> (t -> c) -> [t] -> t -> c
forall t t p. (t -> t -> p) -> (t -> p) -> [t] -> t -> p
filterVar t -> t -> c
farg t -> c
nonFarg) [[t]]
args [t]
varNs
            mkCPat :: Name -> [Name] -> Pat
mkCPat constr :: Name
constr varNs :: [Name]
varNs = Name -> [Pat] -> Pat
ConP Name
constr ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
mkPat [Name]
varNs
            mkPat :: Name -> Pat
mkPat = Name -> Pat
VarP
            mkPatAndVars :: (Name, [[a]])
-> Q (Q Exp, Pat, (a -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
      [Q Exp], [(a, Name)])
mkPatAndVars (constr :: Name
constr, args :: [[a]]
args) =
                do [Name]
varNs <- Int -> [Char] -> Q [Name]
newNames ([[a]] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
args) "x"
                   (Q Exp, Pat, (a -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
 [Q Exp], [(a, Name)])
-> Q (Q Exp, Pat, (a -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
      [Q Exp], [(a, Name)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Q Exp
conE Name
constr, Name -> [Name] -> Pat
mkCPat Name
constr [Name]
varNs,
                           \ f :: a -> Q Exp -> c
f g :: Q Exp -> c
g -> [[a]] -> [Name] -> (a -> Name -> c) -> (Name -> c) -> [c]
forall t t c. [[t]] -> [t] -> (t -> t -> c) -> (t -> c) -> [c]
filterVars [[a]]
args [Name]
varNs (\ d :: a
d x :: Name
x -> a -> Q Exp -> c
f a
d (Name -> Q Exp
varE Name
x)) (Q Exp -> c
g (Q Exp -> c) -> (Name -> Q Exp) -> Name -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
varE),
                           ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]]
args, (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
varNs, [Maybe (a, Name)] -> [(a, Name)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (a, Name)] -> [(a, Name)])
-> [Maybe (a, Name)] -> [(a, Name)]
forall a b. (a -> b) -> a -> b
$ [[a]]
-> [Name]
-> (a -> Name -> Maybe (a, Name))
-> (Name -> Maybe (a, Name))
-> [Maybe (a, Name)]
forall t t c. [[t]] -> [t] -> (t -> t -> c) -> (t -> c) -> [c]
filterVars [[a]]
args [Name]
varNs (((a, Name) -> Maybe (a, Name)) -> a -> Name -> Maybe (a, Name)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (a, Name) -> Maybe (a, Name)
forall a. a -> Maybe a
Just) (Maybe (a, Name) -> Name -> Maybe (a, Name)
forall a b. a -> b -> a
const Maybe (a, Name)
forall a. Maybe a
Nothing))
            hfmapClause :: (Q Exp, Pat, (t -> Q Exp -> Q Exp) -> (a -> a) -> t (Q Exp), Bool,
 e, f)
-> ClauseQ
hfmapClause (con :: Q Exp
con, pat :: Pat
pat,vars' :: (t -> Q Exp -> Q Exp) -> (a -> a) -> t (Q Exp)
vars',hasFargs :: Bool
hasFargs,_,_) =
                do Name
fn <- [Char] -> Q Name
newName "f"
                   let f :: Q Exp
f = Name -> Q Exp
varE Name
fn
                       fp :: Pat
fp = if Bool
hasFargs then Name -> Pat
VarP Name
fn else Pat
WildP
                       vars :: t (Q Exp)
vars = (t -> Q Exp -> Q Exp) -> (a -> a) -> t (Q Exp)
vars' (\d :: t
d x :: Q Exp
x -> t -> Q Exp -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp -> Q Exp -> Q Exp
iter t
d [|fmap|] Q Exp
f Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
x) a -> a
forall a. a -> a
id
                   Exp
body <- (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> t (Q Exp) -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Exp -> Q Exp -> Q Exp
appE Q Exp
con t (Q Exp)
vars
                   Clause -> ClauseQ
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> ClauseQ) -> Clause -> ClauseQ
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
fp, Pat
pat] (Exp -> Body
NormalB Exp
body) []