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

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
nt -> t -> t
forall a. Num a => a -> a -> a
-t
1) m Exp
f (m Exp
f m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
e)


{-| Derive an instance of 'HTraversable' for a type constructor of any
  higher-order kind taking at least two arguments. -}
makeHTraversable :: Name -> Q [Dec]
makeHTraversable :: Name -> Q [Dec]
makeHTraversable Name
fname = do
  Just (DataInfo Cxt
_cxt Name
name [TyVarBndr BndrVis]
args [Con]
constrs [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 BndrVis]
args' = [TyVarBndr BndrVis] -> [TyVarBndr BndrVis]
forall a. HasCallStack => [a] -> [a]
init [TyVarBndr BndrVis]
args
      fArg :: Type
fArg = Name -> Type
VarT (Name -> Type)
-> (TyVarBndr BndrVis -> Name) -> TyVarBndr BndrVis -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr BndrVis -> Name
tyVarBndrName (TyVarBndr BndrVis -> Type) -> TyVarBndr BndrVis -> Type
forall a b. (a -> b) -> a -> b
$ [TyVarBndr BndrVis] -> TyVarBndr BndrVis
forall a. HasCallStack => [a] -> a
last [TyVarBndr BndrVis]
args'
      argNames :: Cxt
argNames = (TyVarBndr BndrVis -> Type) -> [TyVarBndr BndrVis] -> Cxt
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Type
VarT (Name -> Type)
-> (TyVarBndr BndrVis -> Name) -> TyVarBndr BndrVis -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr BndrVis -> Name
tyVarBndrName) ([TyVarBndr BndrVis] -> [TyVarBndr BndrVis]
forall a. HasCallStack => [a] -> [a]
init [TyVarBndr BndrVis]
args')
      complType :: Type
complType = (Type -> Type -> Type) -> Type -> Cxt -> Type
forall b a. (b -> a -> b) -> b -> [a] -> b
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' <- (Con
 -> Q (Q Exp, Pat,
       (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
       [Q Exp], [(Int, Name)]))
-> [Con]
-> Q [(Q Exp, Pat,
       (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
       [Q Exp], [(Int, Name)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
P.mapM ((Name, [[Int]])
-> Q (Q Exp, Pat,
      (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
      [Q Exp], [(Int, Name)])
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 ((Name, [[Int]])
 -> Q (Q Exp, Pat,
       (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
       [Q Exp], [(Int, Name)]))
-> ((Name, Cxt, Maybe Type) -> (Name, [[Int]]))
-> (Name, Cxt, Maybe Type)
-> Q (Q Exp, Pat,
      (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
      [Q Exp], [(Int, Name)])
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 (Q Exp, Pat,
       (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
       [Q Exp], [(Int, Name)]))
-> (Con -> Q (Name, Cxt, Maybe Type))
-> Con
-> Q (Q Exp, Pat,
      (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
      [Q Exp], [(Int, Name)])
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 <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'htraverse (((Q Exp, Pat,
  (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
  [Q Exp], [(Int, Name)])
 -> Q Clause)
-> [(Q Exp, Pat,
     (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
     [Q Exp], [(Int, Name)])]
-> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Q Exp, Pat,
 (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
 [Q Exp], [(Int, Name)])
-> Q Clause
forall {t :: * -> *} {t} {m :: * -> *} {m :: * -> *} {m :: * -> *}
       {e} {f}.
(Foldable t, Eq t, Num t, Quote m, 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 <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'hmapM (((Q Exp, Pat,
  (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
  [Q Exp], [(Int, Name)])
 -> Q Clause)
-> [(Q Exp, Pat,
     (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
     [Q Exp], [(Int, Name)])]
-> [Q Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Q Exp, Pat,
 (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
 [Q Exp], [(Int, Name)])
-> Q Clause
forall {t} {t :: * -> *} {t :: * -> *} {m :: * -> *} {c}.
(Eq t, Num t, Foldable 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')
  [Dec] -> Q [Dec]
forall a. a -> Q a
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, (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 :: (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
_ = [Char] -> 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 = ([t] -> b -> c) -> [[t]] -> [b] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((t -> b -> c) -> (b -> c) -> [t] -> b -> c
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 [] ([Pat] -> Pat) -> [Pat] -> Pat
forall a b. (a -> b) -> a -> b
$ (Name -> Pat) -> [Name] -> [Pat]
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 ([[t]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[t]]
args) [Char]
"x"
                   (m Exp, Pat, (t -> m Exp -> c) -> (m Exp -> c) -> [c], Bool,
 [m Exp], [(t, Name)])
-> Q (m Exp, Pat, (t -> m Exp -> c) -> (m Exp -> c) -> [c], Bool,
      [m Exp], [(t, Name)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> m Exp
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 -> [[t]] -> [Name] -> (t -> Name -> c) -> (Name -> c) -> [c]
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 (Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)) (m Exp -> c
g (m Exp -> c) -> (Name -> m Exp) -> Name -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE),
                           ([t] -> Bool) -> [[t]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> ([t] -> Bool) -> [t] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [t] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[t]]
args, (Name -> m Exp) -> [Name] -> [m Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varNs, [Maybe (t, Name)] -> [(t, Name)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (t, Name)] -> [(t, Name)])
-> [Maybe (t, Name)] -> [(t, Name)]
forall a b. (a -> b) -> a -> b
$ [[t]]
-> [Name]
-> (t -> Name -> Maybe (t, Name))
-> (Name -> Maybe (t, Name))
-> [Maybe (t, Name)]
forall {t} {b} {c}.
[[t]] -> [b] -> (t -> b -> c) -> (b -> c) -> [c]
filterVars [[t]]
args [Name]
varNs (((t, Name) -> Maybe (t, Name)) -> t -> Name -> Maybe (t, Name)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (t, Name) -> Maybe (t, Name)
forall a. a -> Maybe a
Just) (Maybe (t, Name) -> Name -> Maybe (t, Name)
forall a b. a -> b -> a
const Maybe (t, Name)
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 <- [Char] -> m Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
                   let f :: m Exp
f = Name -> m Exp
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 -> t -> m Exp -> m Exp -> m Exp
forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter t
d [|traverse|] m Exp
f m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
x) (\m Exp
x -> [|pure $m Exp
x|])
                   Exp
body <- (m Exp -> m Exp -> m Exp) -> m Exp -> t (m Exp) -> m Exp
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl (\ m Exp
x m Exp
y -> [|$m Exp
x <*> $m Exp
y|]) [|pure $m Exp
con|] t (m Exp)
vars
                   Clause -> m Clause
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> m Clause) -> Clause -> m Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
fp, Pat
pat] (Exp -> Body
NormalB Exp
body) []
            -- Note: the monadic versions are not defined
            -- applicatively, as this results in a considerable
            -- performance penalty (by factor 2)!
            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 <- [Char] -> m Name
forall (m :: * -> *). Quote m => [Char] -> m Name
newName [Char]
"f"
                   let f :: m Exp
f = Name -> m Exp
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 = (m Exp -> m Exp -> m Exp) -> m Exp -> t (m Exp) -> m Exp
forall b a. (b -> a -> b) -> b -> t a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl m Exp -> m Exp -> m Exp
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 = [| $(t -> m Exp -> m Exp -> m Exp
forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter t
d [|mapM|] m Exp
f) $(Name -> m Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)  >>= $([m Pat] -> m Exp -> m Exp
forall (m :: * -> *). Quote m => [m Pat] -> m Exp -> m Exp
lamE [Name -> m Pat
forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
x] m Exp
y)|]
                   Exp
body <- ((t, Name) -> m Exp -> m Exp) -> m Exp -> t (t, Name) -> m Exp
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
P.foldr (t, Name) -> m Exp -> m Exp
forall {t}. (Eq t, Num t) => (t, Name) -> m Exp -> m Exp
conBind [|return $m Exp
conAp|] t (t, Name)
fvars
                   Clause -> m Clause
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> m Clause) -> Clause -> m Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
fp, Pat
pat] (Exp -> Body
NormalB Exp
body) []