{-# 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 -> 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)

iter' :: t -> Q Exp -> Q Exp -> Q Exp
iter' 0 _ e :: Q Exp
e = Q Exp
e
iter' m :: t
m f :: Q Exp
f e :: Q Exp
e = let f' :: Q Exp
f' = t -> Q Exp -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp -> Q Exp -> Q Exp
iter (t
mt -> t -> t
forall a. Num a => a -> a -> a
-1) [|fmap|] Q Exp
f
              in t -> Q Exp -> Q Exp -> Q Exp
iter' (t
mt -> 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)

iterSp :: t -> Q Exp -> Q Exp -> Q Exp -> Q Exp
iterSp n :: t
n f :: Q Exp
f g :: Q Exp
g e :: Q Exp
e = t -> Q Exp -> Q Exp
run t
n Q Exp
e
    where run :: t -> Q Exp -> Q Exp
run 0 e :: Q Exp
e = Q Exp
e
          run m :: t
m e :: Q Exp
e = let f' :: Q Exp
f' = t -> Q Exp -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp -> Q Exp -> Q Exp
iter (t
mt -> t -> t
forall a. Num a => a -> a -> a
-1) [|fmap|] (if t
n t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
m then Q Exp
g else Q Exp
f)
                    in t -> Q Exp -> Q Exp
run (t
mt -> t -> t
forall a. Num a => a -> a -> a
-1) (Q Exp
f' Q Exp -> Q Exp -> Q Exp
`appE` Q 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 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
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' <- (Con -> Q (Pat, [(Int, Q Exp)]))
-> [Con] -> Q [(Pat, [(Int, Q Exp)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((Name, [[Int]]) -> Q (Pat, [(Int, Q Exp)])
forall a. (Name, [[a]]) -> Q (Pat, [(a, Q Exp)])
mkPatAndVars ((Name, [[Int]]) -> Q (Pat, [(Int, Q Exp)]))
-> ((Name, Cxt, Maybe Type) -> (Name, [[Int]]))
-> (Name, Cxt, Maybe Type)
-> Q (Pat, [(Int, Q Exp)])
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 (Pat, [(Int, Q Exp)]))
-> (Con -> Q (Name, Cxt, Maybe Type))
-> Con
-> Q (Pat, [(Int, Q Exp)])
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 <- Name -> [ClauseQ] -> DecQ
funD 'hfold (((Pat, [(Int, Q Exp)]) -> ClauseQ)
-> [(Pat, [(Int, Q Exp)])] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (Pat, [(Int, Q Exp)]) -> ClauseQ
forall t. (Eq t, Num t) => (Pat, [(t, Q Exp)]) -> ClauseQ
foldClause [(Pat, [(Int, Q Exp)])]
constrs')
  Dec
foldMapDecl <- Name -> [ClauseQ] -> DecQ
funD 'hfoldMap (((Pat, [(Int, Q Exp)]) -> ClauseQ)
-> [(Pat, [(Int, Q Exp)])] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (Pat, [(Int, Q Exp)]) -> ClauseQ
forall t. (Num t, Ord t) => (Pat, [(t, Q Exp)]) -> ClauseQ
foldMapClause [(Pat, [(Int, Q Exp)])]
constrs')
  Dec
foldlDecl <- Name -> [ClauseQ] -> DecQ
funD 'hfoldl (((Pat, [(Int, Q Exp)]) -> ClauseQ)
-> [(Pat, [(Int, Q Exp)])] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (Pat, [(Int, Q Exp)]) -> ClauseQ
forall (t :: * -> *) a.
(Eq a, Num a, Foldable t) =>
(Pat, t (a, Q Exp)) -> ClauseQ
foldlClause [(Pat, [(Int, Q Exp)])]
constrs')
  Dec
foldrDecl <- Name -> [ClauseQ] -> DecQ
funD 'hfoldr (((Pat, [(Int, Q Exp)]) -> ClauseQ)
-> [(Pat, [(Int, Q Exp)])] -> [ClauseQ]
forall a b. (a -> b) -> [a] -> [b]
map (Pat, [(Int, Q Exp)]) -> ClauseQ
forall (t :: * -> *) a.
(Eq a, Num a, Foldable t) =>
(Pat, t (a, Q Exp)) -> ClauseQ
foldrClause [(Pat, [(Int, Q Exp)])]
constrs')
  [Dec] -> Q [Dec]
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 fArg :: Type
fArg (constr :: a
constr, args :: Cxt
args, gadtTy :: Maybe Type
gadtTy) = (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
gadtTy)) Cxt
args)
            filterVar :: [a] -> Name -> Maybe (a, Q Exp)
filterVar [] _ = Maybe (a, Q Exp)
forall a. Maybe a
Nothing
            filterVar [d :: a
d] x :: Name
x =(a, Q Exp) -> Maybe (a, Q Exp)
forall a. a -> Maybe a
Just (a
d, Name -> Q Exp
varE Name
x)
            filterVar _ _ =  [Char] -> Maybe (a, Q Exp)
forall a. HasCallStack => [Char] -> a
error "functor variable occurring twice in argument type"
            filterVars :: [[a]] -> [Name] -> [(a, Q Exp)]
filterVars args :: [[a]]
args varNs :: [Name]
varNs = [Maybe (a, Q Exp)] -> [(a, Q Exp)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (a, Q Exp)] -> [(a, Q Exp)])
-> [Maybe (a, Q Exp)] -> [(a, Q Exp)]
forall a b. (a -> b) -> a -> b
$ ([a] -> Name -> Maybe (a, Q Exp))
-> [[a]] -> [Name] -> [Maybe (a, Q Exp)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [a] -> Name -> Maybe (a, Q Exp)
forall a. [a] -> Name -> Maybe (a, Q Exp)
filterVar [[a]]
args [Name]
varNs
            mkCPat :: Name -> [[a]] -> [Name] -> Pat
mkCPat constr :: Name
constr args :: [[a]]
args varNs :: [Name]
varNs = Name -> [Pat] -> Pat
ConP Name
constr ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ ([a] -> Name -> Pat) -> [[a]] -> [Name] -> [Pat]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith [a] -> Name -> Pat
forall a. [a] -> Name -> Pat
mkPat [[a]]
args [Name]
varNs
            mkPat :: [a] -> Name -> Pat
mkPat [] _ = Pat
WildP
            mkPat _ x :: Name
x = Name -> Pat
VarP Name
x
            mkPatAndVars :: (Name, [[a]]) -> Q (Pat, [(a, Q Exp)])
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"
                   (Pat, [(a, Q Exp)]) -> Q (Pat, [(a, Q Exp)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [[a]] -> [Name] -> Pat
forall a. Name -> [[a]] -> [Name] -> Pat
mkCPat Name
constr [[a]]
args [Name]
varNs, [[a]] -> [Name] -> [(a, Q Exp)]
forall a. [[a]] -> [Name] -> [(a, Q Exp)]
filterVars [[a]]
args [Name]
varNs)
            foldClause :: (Pat, [(t, Q Exp)]) -> ClauseQ
foldClause (pat :: Pat
pat,vars :: [(t, Q Exp)]
vars) =
                do let conApp :: (t, Q Exp) -> Q Exp
conApp (0,x :: Q Exp
x) = [|unK $x|]
                       conApp (d :: t
d,x :: Q Exp
x) = t -> Q Exp -> Q Exp -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp -> Q Exp -> Q Exp -> Q Exp
iterSp t
d [|fold|] [| foldMap unK |] Q Exp
x
                   Exp
body <- if [(t, Q Exp)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(t, Q Exp)]
vars
                           then [|mempty|]
                           else (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
P.foldl1 (\ x :: Q Exp
x y :: Q Exp
y -> [|$x `mappend` $y|])
                                    ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ((t, Q Exp) -> Q Exp) -> [(t, Q Exp)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (t, Q Exp) -> Q Exp
forall t. (Eq t, Num t) => (t, Q Exp) -> Q Exp
conApp [(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
pat] (Exp -> Body
NormalB Exp
body) []
            foldMapClause :: (Pat, [(t, Q Exp)]) -> ClauseQ
foldMapClause (pat :: Pat
pat,vars :: [(t, Q Exp)]
vars) =
                do Name
fn <- [Char] -> Q Name
newName "y"
                   let f :: Q Exp
f = Name -> Q Exp
varE Name
fn
                       f' :: t -> Q Exp
f' 0 = Q Exp
f
                       f' n :: t
n = t -> Q Exp -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp -> Q Exp -> Q Exp
iter (t
nt -> t -> t
forall a. Num a => a -> a -> a
-1) [|fmap|] [| foldMap $f |]
                       fp :: Pat
fp = if [(t, Q Exp)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(t, Q Exp)]
vars then Pat
WildP else Name -> Pat
VarP Name
fn
                   Exp
body <- case [(t, Q Exp)]
vars of
                             [] -> [|mempty|]
                             (_:_) -> (Q Exp -> Q Exp -> Q Exp) -> [Q Exp] -> Q Exp
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
P.foldl1 (\ x :: Q Exp
x y :: Q Exp
y -> [|$x `mappend` $y|]) ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$
                                      ((t, Q Exp) -> Q Exp) -> [(t, Q Exp)] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\ (d :: t
d,z :: Q Exp
z) -> t -> Q Exp -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp -> Q Exp -> Q Exp
iter' (t -> t -> t
forall a. Ord a => a -> a -> a
max (t
dt -> t -> t
forall a. Num a => a -> a -> a
-1) 0) [|fold|] (t -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp
f' t
d Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
z)) [(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) []
            foldlClause :: (Pat, t (a, Q Exp)) -> ClauseQ
foldlClause (pat :: Pat
pat,vars :: t (a, Q Exp)
vars) =
                do Name
fn <- [Char] -> Q Name
newName "f"
                   Name
en <- [Char] -> Q Name
newName "e"
                   let f :: Q Exp
f = Name -> Q Exp
varE Name
fn
                       e :: Q Exp
e = Name -> Q Exp
varE Name
en
                       fp :: Pat
fp = if t (a, Q Exp) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t (a, Q Exp)
vars then Pat
WildP else Name -> Pat
VarP Name
fn
                       ep :: Pat
ep = Name -> Pat
VarP Name
en
                       conApp :: Q Exp -> (a, Q Exp) -> Q Exp
conApp x :: Q Exp
x (0,y :: Q Exp
y) = [|$f $x $y|]
                       conApp x :: Q Exp
x (1,y :: Q Exp
y) = [|foldl $f $x $y|]
                       conApp x :: Q Exp
x (d :: a
d,y :: Q Exp
y) = let hidEndo :: Q Exp
hidEndo = a -> Q Exp -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp -> Q Exp -> Q Exp
iter (a
da -> a -> a
forall a. Num a => a -> a -> a
-1) [|fmap|] [|Endo . flip (foldl $f)|] Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
y
                                            endo :: Q Exp
endo = a -> Q Exp -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp -> Q Exp -> Q Exp
iter' (a
da -> a -> a
forall a. Num a => a -> a -> a
-1) [|fold|] Q Exp
hidEndo
                                        in [| appEndo $endo $x|]
                   Exp
body <- (Q Exp -> (a, Q Exp) -> Q Exp) -> Q Exp -> t (a, Q Exp) -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl Q Exp -> (a, Q Exp) -> Q Exp
forall a. (Eq a, Num a) => Q Exp -> (a, Q Exp) -> Q Exp
conApp Q Exp
e t (a, 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
ep, Pat
pat] (Exp -> Body
NormalB Exp
body) []
            foldrClause :: (Pat, t (a, Q Exp)) -> ClauseQ
foldrClause (pat :: Pat
pat,vars :: t (a, Q Exp)
vars) =
                do Name
fn <- [Char] -> Q Name
newName "f"
                   Name
en <- [Char] -> Q Name
newName "e"
                   let f :: Q Exp
f = Name -> Q Exp
varE Name
fn
                       e :: Q Exp
e = Name -> Q Exp
varE Name
en
                       fp :: Pat
fp = if t (a, Q Exp) -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null t (a, Q Exp)
vars then Pat
WildP else Name -> Pat
VarP Name
fn
                       ep :: Pat
ep = Name -> Pat
VarP Name
en
                       conApp :: (a, Q Exp) -> Q Exp -> Q Exp
conApp (0,x :: Q Exp
x) y :: Q Exp
y = [|$f $x $y|]
                       conApp (1,x :: Q Exp
x) y :: Q Exp
y = [|foldr $f $y $x |]
                       conApp (d :: a
d,x :: Q Exp
x) y :: Q Exp
y = let hidEndo :: Q Exp
hidEndo = a -> Q Exp -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp -> Q Exp -> Q Exp
iter (a
da -> a -> a
forall a. Num a => a -> a -> a
-1) [|fmap|] [|Endo . flip (foldr $f)|] Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
x
                                            endo :: Q Exp
endo = a -> Q Exp -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp -> Q Exp -> Q Exp
iter' (a
da -> a -> a
forall a. Num a => a -> a -> a
-1) [|fold|] Q Exp
hidEndo
                                        in [| appEndo $endo $y|]
                   Exp
body <- ((a, Q Exp) -> Q Exp -> Q Exp) -> Q Exp -> t (a, Q Exp) -> Q Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
P.foldr (a, Q Exp) -> Q Exp -> Q Exp
forall a. (Eq a, Num a) => (a, Q Exp) -> Q Exp -> Q Exp
conApp Q Exp
e t (a, 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
ep, Pat
pat] (Exp -> Body
NormalB Exp
body) []