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

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)

{-| Derive an instance of 'Foldable' for a type constructor of any first-order
  kind taking at least one argument. -}
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) []