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

module Data.Comp.Multi.Derive.HFoldable
    (
     HFoldable,
     makeHFoldable
    )where

import Control.Monad
import Data.Comp.Derive.Utils
import Data.Comp.Multi.HFoldable
import Data.Comp.Multi.HFunctor
import Data.Foldable
import Data.Maybe
import Data.Monoid
import Language.Haskell.TH
import Prelude hiding (foldl, foldl1, foldr)
import qualified Prelude as P (foldl, foldl1, foldr)


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)

iterSp :: p -> m Exp -> m Exp -> m Exp -> m Exp
iterSp p
n m Exp
f m Exp
g m Exp
e = p -> m Exp -> m Exp
run p
n m Exp
e
    where run :: p -> m Exp -> m Exp
run p
0 m Exp
e = m Exp
e
          run p
m 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 (p
mforall a. Num a => a -> a -> a
-p
1) [|fmap|] (if p
n forall a. Eq a => a -> a -> Bool
== p
m then m Exp
g else m Exp
f)
                    in p -> m Exp -> m Exp
run (p
mforall a. Num a => a -> a -> a
-p
1) (m Exp
f' forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
e)

{-| Derive an instance of 'HFoldable' for a type constructor of any higher-order
  kind taking at least two arguments. -}
makeHFoldable :: Name -> Q [Dec]
makeHFoldable :: Name -> Q [Dec]
makeHFoldable 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
P.foldl Type -> Type -> Type
AppT (Name -> Type
ConT Name
name) Cxt
argNames
      classType :: Type
classType = Type -> Type -> Type
AppT (Name -> Type
ConT ''HFoldable) 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 'hfold (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {p}.
(Quote m, Eq p, Num p) =>
(Pat, [(p, m Exp)]) -> m Clause
foldClause [(Pat, [(Int, Q Exp)])]
constrs')
  Dec
foldMapDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'hfoldMap (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 'hfoldl (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 'hfoldr (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')
  forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD [] Type
classType [Dec
foldDecl,Dec
foldMapDecl,Dec
foldlDecl,Dec
foldrDecl]]
      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 :: [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, [(p, m Exp)]) -> m Clause
foldClause (Pat
pat,[(p, m Exp)]
vars) =
                do let conApp :: (p, m Exp) -> m Exp
conApp (p
0,m Exp
x) = [|unK $x|]
                       conApp (p
d,m Exp
x) = forall {p} {m :: * -> *}.
(Eq p, Num p, Quote m) =>
p -> m Exp -> m Exp -> m Exp -> m Exp
iterSp p
d [|fold|] [| foldMap unK |] m Exp
x
                   Exp
body <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(p, 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 forall {p} {m :: * -> *}.
(Eq p, Num p, Quote m) =>
(p, m Exp) -> m Exp
conApp [(p, 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) []