{-# LANGUAGE TemplateHaskell #-}
module Data.Comp.Multi.Derive.HTraversable
(
HTraversable,
makeHTraversable
) where
import Control.Applicative
import Control.Monad hiding (mapM, sequence)
import Data.Comp.Derive.Utils
import Data.Comp.Multi.HTraversable
import Data.Foldable hiding (any, or)
import Data.Maybe
import Data.Traversable
import Language.Haskell.TH
import Prelude hiding (foldl, foldr, mapM, sequence)
import qualified Prelude as P (foldl, foldr, mapM)
iter :: t -> m Exp -> m Exp -> m Exp
iter t
0 m Exp
_ m Exp
e = m Exp
e
iter t
n m Exp
f m Exp
e = t -> m Exp -> m Exp -> m Exp
iter (t
nforall a. Num a => a -> a -> a
-t
1) m Exp
f (m Exp
f forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
e)
makeHTraversable :: Name -> Q [Dec]
makeHTraversable :: Name -> Q [Dec]
makeHTraversable Name
fname = do
Just (DataInfo Cxt
_cxt Name
name [TyVarBndr flag]
args [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
let args' :: [TyVarBndr flag]
args' = forall a. [a] -> [a]
init [TyVarBndr flag]
args
fArg :: Type
fArg = Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {flag}. TyVarBndr flag -> Name
tyVarBndrName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
last [TyVarBndr flag]
args'
argNames :: Cxt
argNames = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {flag}. TyVarBndr flag -> Name
tyVarBndrName) (forall a. [a] -> [a]
init [TyVarBndr flag]
args')
complType :: Type
complType = 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 ''HTraversable) Type
complType
[(Q Exp, Pat,
(Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
[Q Exp], [(Int, Name)])]
constrs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
P.mapM (forall {m :: * -> *} {m :: * -> *} {m :: * -> *} {m :: * -> *} {t}
{c}.
(Quote m, Quote m, Quote m, Quote m) =>
(Name, [[t]])
-> Q (m Exp, Pat, (t -> m Exp -> c) -> (m Exp -> c) -> [c], Bool,
[m Exp], [(t, Name)])
mkPatAndVars forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a}. Type -> (a, Cxt, Maybe Type) -> (a, [[Int]])
isFarg Type
fArg 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
traverseDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'htraverse (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {t :: * -> *} {m :: * -> *} {t} {m :: * -> *}
{e} {f}.
(Quote m, Foldable t, Eq t, Num t, Quote m, Quote m) =>
(m Exp, Pat,
(t -> m Exp -> m Exp) -> (m Exp -> m Exp) -> t (m Exp), Bool, e, f)
-> m Clause
traverseClause [(Q Exp, Pat,
(Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
[Q Exp], [(Int, Name)])]
constrs')
Dec
mapMDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'hmapM (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {t :: * -> *} {t} {t :: * -> *} {c}.
(Foldable t, Eq t, Num t, Foldable t, Quote m) =>
(m Exp, Pat, c, Bool, t (m Exp), t (t, Name)) -> m Clause
mapMClause [(Q Exp, Pat,
(Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
[Q Exp], [(Int, Name)])]
constrs')
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD [] Type
classType [Dec
traverseDecl, Dec
mapMDecl]]
where isFarg :: Type -> (a, Cxt, Maybe Type) -> (a, [[Int]])
isFarg Type
fArg (a
constr, Cxt
args, Maybe Type
gadtTy) = (a
constr, forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> [Int]
`containsType'` (Type -> Maybe Type -> Type
getBinaryFArg Type
fArg Maybe Type
gadtTy)) Cxt
args)
filterVar :: (t -> t -> t) -> (t -> t) -> [t] -> t -> t
filterVar t -> t -> t
_ t -> t
nonFarg [] t
x = t -> t
nonFarg t
x
filterVar t -> t -> t
farg t -> t
_ [t
depth] t
x = t -> t -> t
farg t
depth t
x
filterVar t -> t -> t
_ t -> t
_ [t]
_ t
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"functor variable occurring twice in argument type"
filterVars :: [[t]] -> [b] -> (t -> b -> c) -> (b -> c) -> [c]
filterVars [[t]]
args [b]
varNs t -> b -> c
farg b -> c
nonFarg = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (forall {t} {t} {t}. (t -> t -> t) -> (t -> t) -> [t] -> t -> t
filterVar t -> b -> c
farg b -> c
nonFarg) [[t]]
args [b]
varNs
mkCPat :: Name -> [Name] -> Pat
mkCPat Name
constr [Name]
varNs = Name -> Cxt -> [Pat] -> Pat
ConP Name
constr [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
mkPat [Name]
varNs
mkPat :: Name -> Pat
mkPat = Name -> Pat
VarP
mkPatAndVars :: (Name, [[t]])
-> Q (m Exp, Pat, (t -> m Exp -> c) -> (m Exp -> c) -> [c], Bool,
[m Exp], [(t, Name)])
mkPatAndVars (Name
constr, [[t]]
args) =
do [Name]
varNs <- Int -> [Char] -> Q [Name]
newNames (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[t]]
args) [Char]
"x"
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
constr, Name -> [Name] -> Pat
mkCPat Name
constr [Name]
varNs,
\t -> m Exp -> c
f m Exp -> c
g -> forall {t} {b} {c}.
[[t]] -> [b] -> (t -> b -> c) -> (b -> c) -> [c]
filterVars [[t]]
args [Name]
varNs (\ t
d Name
x -> t -> m Exp -> c
f t
d (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)) (m Exp -> c
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => Name -> m Exp
varE),
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[t]]
args, forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varNs, forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall {t} {b} {c}.
[[t]] -> [b] -> (t -> b -> c) -> (b -> c) -> [c]
filterVars [[t]]
args [Name]
varNs (forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a. a -> Maybe a
Just) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing))
traverseClause :: (m Exp, Pat,
(t -> m Exp -> m Exp) -> (m Exp -> m Exp) -> t (m Exp), Bool, e, f)
-> m Clause
traverseClause (m Exp
con, Pat
pat,(t -> m Exp -> m Exp) -> (m Exp -> m Exp) -> t (m Exp)
vars',Bool
hasFargs,e
_,f
_) =
do Name
fn <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
let f :: m Exp
f = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fn
fp :: Pat
fp = if Bool
hasFargs then Name -> Pat
VarP Name
fn else Pat
WildP
vars :: t (m Exp)
vars = (t -> m Exp -> m Exp) -> (m Exp -> m Exp) -> t (m Exp)
vars' (\t
d m Exp
x -> forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter t
d [|traverse|] m Exp
f forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
x) (\m Exp
x -> [|pure $x|])
Exp
body <- forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl (\ m Exp
x m Exp
y -> [|$x <*> $y|]) [|pure $con|] t (m Exp)
vars
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
fp, Pat
pat] (Exp -> Body
NormalB Exp
body) []
mapMClause :: (m Exp, Pat, c, Bool, t (m Exp), t (t, Name)) -> m Clause
mapMClause (m Exp
con, Pat
pat,c
_,Bool
hasFargs,t (m Exp)
allVars, t (t, Name)
fvars) =
do Name
fn <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
let f :: m Exp
f = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fn
fp :: Pat
fp = if Bool
hasFargs then Name -> Pat
VarP Name
fn else Pat
WildP
conAp :: m Exp
conAp = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE m Exp
con t (m Exp)
allVars
conBind :: (t, Name) -> m Exp -> m Exp
conBind (t
d,Name
x) m Exp
y = [| $(iter d [|mapM|] f) $(varE x) >>= $(lamE [varP x] y)|]
Exp
body <- forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
P.foldr forall {t}. (Eq t, Num t) => (t, Name) -> m Exp -> m Exp
conBind [|return $conAp|] t (t, Name)
fvars
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
fp, Pat
pat] (Exp -> Body
NormalB Exp
body) []