{-# LANGUAGE TemplateHaskell #-}
module Data.Comp.Derive.Foldable
(
Foldable,
makeFoldable
) where
import Control.Monad
import Data.Comp.Derive.Utils
import Data.Foldable
import Data.Maybe
import Data.Monoid
import Language.Haskell.TH
import Prelude hiding (foldl, foldl1, foldr, foldr1)
import qualified Prelude as P (foldl, foldl1, foldr, foldr1)
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)
iter' :: t -> m Exp -> m Exp -> m Exp
iter' t
0 m Exp
_ m Exp
e = m Exp
e
iter' t
m m Exp
f m Exp
e = let f' :: m Exp
f' = forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter (t
mforall a. Num a => a -> a -> a
-t
1) [|fmap|] m Exp
f
in t -> m Exp -> m Exp -> m Exp
iter' (t
mforall 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)
makeFoldable :: Name -> Q [Dec]
makeFoldable :: Name -> Q [Dec]
makeFoldable 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 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 ''Foldable) Type
complType
[(Pat, [(Int, Q Exp)])]
constrs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {m :: * -> *} {a}.
Quote m =>
(Name, [[a]]) -> Q (Pat, [(a, m Exp)])
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
foldDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'fold (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {t}.
(Quote m, Eq t, Num t) =>
(Pat, [(t, m Exp)]) -> m Clause
foldClause [(Pat, [(Int, Q Exp)])]
constrs')
Dec
foldMapDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'foldMap (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {t}.
(Num t, Ord t, Quote m) =>
(Pat, [(t, m Exp)]) -> m Clause
foldMapClause [(Pat, [(Int, Q Exp)])]
constrs')
Dec
foldlDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'foldl (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {t :: * -> *} {a}.
(Eq a, Num a, Foldable t, Quote m) =>
(Pat, t (a, m Exp)) -> m Clause
foldlClause [(Pat, [(Int, Q Exp)])]
constrs')
Dec
foldrDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'foldr (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {t :: * -> *} {a}.
(Eq a, Num a, Foldable t, Quote m) =>
(Pat, t (a, m Exp)) -> m Clause
foldrClause [(Pat, [(Int, Q Exp)])]
constrs')
Dec
foldl1Decl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'foldl1 (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {t}.
(Ord t, Num t, Quote m) =>
(Pat, [(t, m Exp)]) -> m Clause
foldl1Clause [(Pat, [(Int, Q Exp)])]
constrs')
Dec
foldr1Decl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'foldr1 (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {t}.
(Ord t, Num t, Quote m) =>
(Pat, [(t, m Exp)]) -> m Clause
foldr1Clause [(Pat, [(Int, Q Exp)])]
constrs')
forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD [] Type
classType [Dec
foldDecl,Dec
foldMapDecl,Dec
foldlDecl,Dec
foldrDecl,Dec
foldl1Decl,Dec
foldr1Decl]]
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
getUnaryFArg Type
fArg Maybe Type
gadtTy)) Cxt
args)
filterVar :: [a] -> Name -> Maybe (a, m Exp)
filterVar [] Name
_ = forall a. Maybe a
Nothing
filterVar [a
d] Name
x =forall a. a -> Maybe a
Just (a
d, forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)
filterVar [a]
_ Name
_ = forall a. HasCallStack => [Char] -> a
error [Char]
"functor variable occurring twice in argument type"
filterVars :: [[a]] -> [Name] -> [(a, m Exp)]
filterVars [[a]]
args [Name]
varNs = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {m :: * -> *} {a}.
Quote m =>
[a] -> Name -> Maybe (a, m Exp)
filterVar [[a]]
args [Name]
varNs
mkCPat :: Name -> [[a]] -> [Name] -> Pat
mkCPat Name
constr [[a]]
args [Name]
varNs = Name -> Cxt -> [Pat] -> Pat
ConP Name
constr [] forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall {a}. [a] -> Name -> Pat
mkPat [[a]]
args [Name]
varNs
mkPat :: [a] -> Name -> Pat
mkPat [] Name
_ = Pat
WildP
mkPat [a]
_ Name
x = Name -> Pat
VarP Name
x
mkPatAndVars :: (Name, [[a]]) -> Q (Pat, [(a, m Exp)])
mkPatAndVars (Name
constr, [[a]]
args) =
do [Name]
varNs <- Int -> [Char] -> Q [Name]
newNames (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[a]]
args) [Char]
"x"
forall (m :: * -> *) a. Monad m => a -> m a
return (forall {a}. Name -> [[a]] -> [Name] -> Pat
mkCPat Name
constr [[a]]
args [Name]
varNs, forall {m :: * -> *} {a}.
Quote m =>
[[a]] -> [Name] -> [(a, m Exp)]
filterVars [[a]]
args [Name]
varNs)
foldClause :: (Pat, [(t, m Exp)]) -> m Clause
foldClause (Pat
pat,[(t, m Exp)]
vars) =
do Exp
body <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(t, m Exp)]
vars
then [|mempty|]
else forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
P.foldl1 (\ m Exp
x m Exp
y -> [|$x `mappend` $y|])
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\(t
d,m Exp
x) -> forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter' t
d [|fold|] m Exp
x) [(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
pat] (Exp -> Body
NormalB Exp
body) []
foldMapClause :: (Pat, [(t, m Exp)]) -> m Clause
foldMapClause (Pat
pat,[(t, m Exp)]
vars) =
do Name
fn <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"y"
let f :: m Exp
f = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fn
f' :: t -> m Exp
f' t
0 = m Exp
f
f' t
n = forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter (t
nforall a. Num a => a -> a -> a
-t
1) [|fmap|] [| foldMap $f |]
fp :: Pat
fp = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(t, m Exp)]
vars then Pat
WildP else Name -> Pat
VarP Name
fn
Exp
body <- case [(t, m Exp)]
vars of
[] -> [|mempty|]
((t, m Exp)
_:[(t, m Exp)]
_) -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
P.foldl1 (\ m Exp
x m Exp
y -> [|$x `mappend` $y|]) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\ (t
d,m Exp
z) -> forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter' (forall a. Ord a => a -> a -> a
max (t
dforall a. Num a => a -> a -> a
-t
1) t
0) [|fold|] (forall {t}. (Eq t, Num t) => t -> m Exp
f' t
d forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
z)) [(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) []
foldlClause :: (Pat, t (a, m Exp)) -> m Clause
foldlClause (Pat
pat,t (a, m Exp)
vars) =
do Name
fn <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
Name
en <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"e"
let f :: m Exp
f = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fn
e :: m Exp
e = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
en
fp :: Pat
fp = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null t (a, m Exp)
vars then Pat
WildP else Name -> Pat
VarP Name
fn
ep :: Pat
ep = Name -> Pat
VarP Name
en
conApp :: m Exp -> (a, m Exp) -> m Exp
conApp m Exp
x (a
0,m Exp
y) = [|$f $x $y|]
conApp m Exp
x (a
1,m Exp
y) = [|foldl $f $x $y|]
conApp m Exp
x (a
d,m Exp
y) = let hidEndo :: m Exp
hidEndo = forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter (a
dforall a. Num a => a -> a -> a
-a
1) [|fmap|] [|Endo . flip (foldl $f)|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
y
endo :: m Exp
endo = forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter' (a
dforall a. Num a => a -> a -> a
-a
1) [|fold|] m Exp
hidEndo
in [| appEndo $endo $x|]
Exp
body <- forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl forall {a}. (Eq a, Num a) => m Exp -> (a, m Exp) -> m Exp
conApp m Exp
e t (a, 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
ep, Pat
pat] (Exp -> Body
NormalB Exp
body) []
foldrClause :: (Pat, t (a, m Exp)) -> m Clause
foldrClause (Pat
pat,t (a, m Exp)
vars) =
do Name
fn <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
Name
en <- forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"e"
let f :: m Exp
f = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
fn
e :: m Exp
e = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
en
fp :: Pat
fp = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null t (a, m Exp)
vars then Pat
WildP else Name -> Pat
VarP Name
fn
ep :: Pat
ep = Name -> Pat
VarP Name
en
conApp :: (a, m Exp) -> m Exp -> m Exp
conApp (a
0,m Exp
x) m Exp
y = [|$f $x $y|]
conApp (a
1,m Exp
x) m Exp
y = [|foldr $f $y $x |]
conApp (a
d,m Exp
x) m Exp
y = let hidEndo :: m Exp
hidEndo = forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter (a
dforall a. Num a => a -> a -> a
-a
1) [|fmap|] [|Endo . flip (foldr $f)|] forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
x
endo :: m Exp
endo = forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter' (a
dforall a. Num a => a -> a -> a
-a
1) [|fold|] m Exp
hidEndo
in [| appEndo $endo $y|]
Exp
body <- forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
P.foldr forall {a}. (Eq a, Num a) => (a, m Exp) -> m Exp -> m Exp
conApp m Exp
e t (a, 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
ep, Pat
pat] (Exp -> Body
NormalB Exp
body) []
foldl1Clause :: (Pat, [(t, m Exp)]) -> m Clause
foldl1Clause (Pat
pat,[(t, m Exp)]
vars) =
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 = case [(t, m Exp)]
vars of
(t
d,m Exp
_):[(t, m Exp)]
r
| t
d forall a. Ord a => a -> a -> Bool
> t
0 Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(t, m Exp)]
r) -> Name -> Pat
VarP Name
fn
[(t, m Exp)]
_ -> Pat
WildP
mkComp :: (t, m Exp) -> m Exp
mkComp (t
d,m Exp
x) = forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter' t
d [|foldl1 $f|] m Exp
x
Exp
body <- case [(t, m Exp)]
vars of
[] -> [|undefined|]
[(t, m Exp)]
_ -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
P.foldl1 (\ m Exp
x m Exp
y -> [|$f $x $y|]) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {t}. (Eq t, Num t) => (t, m Exp) -> m Exp
mkComp [(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) []
foldr1Clause :: (Pat, [(t, m Exp)]) -> m Clause
foldr1Clause (Pat
pat,[(t, m Exp)]
vars) =
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 = case [(t, m Exp)]
vars of
(t
d,m Exp
_):[(t, m Exp)]
r
| t
d forall a. Ord a => a -> a -> Bool
> t
0 Bool -> Bool -> Bool
|| Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(t, m Exp)]
r) -> Name -> Pat
VarP Name
fn
[(t, m Exp)]
_ -> Pat
WildP
mkComp :: (t, m Exp) -> m Exp
mkComp (t
d,m Exp
x) = forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter' t
d [|foldr1 $f|] m Exp
x
Exp
body <- case [(t, m Exp)]
vars of
[] -> [|undefined|]
[(t, m Exp)]
_ -> forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
P.foldr1 (\ m Exp
x m Exp
y -> [|$f $x $y|]) forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall {t}. (Eq t, Num t) => (t, m Exp) -> m Exp
mkComp [(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) []