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


{-| 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 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
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)
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 a c.
(Name, [[a]])
-> Q (Q Exp, Pat, (a -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
      [Q Exp], [(a, 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 -> [ClauseQ] -> DecQ
funD 'htraverse (((Q Exp, Pat,
  (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
  [Q Exp], [(Int, Name)])
 -> ClauseQ)
-> [(Q Exp, Pat,
     (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
     [Q Exp], [(Int, Name)])]
-> [ClauseQ]
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)])
-> ClauseQ
forall (t :: * -> *) t e f.
(Foldable t, Eq t, Num t) =>
(Q Exp, Pat,
 (t -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> t (Q Exp), Bool, e, f)
-> ClauseQ
traverseClause [(Q Exp, Pat,
  (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
  [Q Exp], [(Int, Name)])]
constrs')
  Dec
mapMDecl <- Name -> [ClauseQ] -> DecQ
funD 'hmapM (((Q Exp, Pat,
  (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
  [Q Exp], [(Int, Name)])
 -> ClauseQ)
-> [(Q Exp, Pat,
     (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
     [Q Exp], [(Int, Name)])]
-> [ClauseQ]
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)])
-> ClauseQ
forall (t :: * -> *) t (t :: * -> *) c.
(Foldable t, Eq t, Num t, Foldable t) =>
(Q Exp, Pat, c, Bool, t (Q Exp), t (t, Name)) -> ClauseQ
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 (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 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 :: (t -> t -> p) -> (t -> p) -> [t] -> t -> p
filterVar _ nonFarg :: t -> p
nonFarg [] x :: t
x  = t -> p
nonFarg t
x
            filterVar farg :: t -> t -> p
farg _ [depth :: t
depth] x :: t
x = t -> t -> p
farg t
depth t
x
            filterVar _ _ _ _ = [Char] -> p
forall a. HasCallStack => [Char] -> a
error "functor variable occurring twice in argument type"
            filterVars :: [[t]] -> [t] -> (t -> t -> c) -> (t -> c) -> [c]
filterVars args :: [[t]]
args varNs :: [t]
varNs farg :: t -> t -> c
farg nonFarg :: t -> c
nonFarg = ([t] -> t -> c) -> [[t]] -> [t] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((t -> t -> c) -> (t -> c) -> [t] -> t -> c
forall t t p. (t -> t -> p) -> (t -> p) -> [t] -> t -> p
filterVar t -> t -> c
farg t -> c
nonFarg) [[t]]
args [t]
varNs
            mkCPat :: Name -> [Name] -> Pat
mkCPat constr :: Name
constr varNs :: [Name]
varNs = Name -> [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, [[a]])
-> Q (Q Exp, Pat, (a -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
      [Q Exp], [(a, Name)])
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"
                   (Q Exp, Pat, (a -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
 [Q Exp], [(a, Name)])
-> Q (Q Exp, Pat, (a -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
      [Q Exp], [(a, Name)])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Q Exp
conE Name
constr, Name -> [Name] -> Pat
mkCPat Name
constr [Name]
varNs,
                           \f :: a -> Q Exp -> c
f g :: Q Exp -> c
g -> [[a]] -> [Name] -> (a -> Name -> c) -> (Name -> c) -> [c]
forall t t c. [[t]] -> [t] -> (t -> t -> c) -> (t -> c) -> [c]
filterVars [[a]]
args [Name]
varNs (\ d :: a
d x :: Name
x -> a -> Q Exp -> c
f a
d (Name -> Q Exp
varE Name
x)) (Q Exp -> c
g (Q Exp -> c) -> (Name -> Q Exp) -> Name -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Q Exp
varE),
                           ([a] -> Bool) -> [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not (Bool -> Bool) -> ([a] -> Bool) -> [a] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[a]]
args, (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE [Name]
varNs, [Maybe (a, Name)] -> [(a, Name)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (a, Name)] -> [(a, Name)])
-> [Maybe (a, Name)] -> [(a, Name)]
forall a b. (a -> b) -> a -> b
$ [[a]]
-> [Name]
-> (a -> Name -> Maybe (a, Name))
-> (Name -> Maybe (a, Name))
-> [Maybe (a, Name)]
forall t t c. [[t]] -> [t] -> (t -> t -> c) -> (t -> c) -> [c]
filterVars [[a]]
args [Name]
varNs (((a, Name) -> Maybe (a, Name)) -> a -> Name -> Maybe (a, Name)
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (a, Name) -> Maybe (a, Name)
forall a. a -> Maybe a
Just) (Maybe (a, Name) -> Name -> Maybe (a, Name)
forall a b. a -> b -> a
const Maybe (a, Name)
forall a. Maybe a
Nothing))
            traverseClause :: (Q Exp, Pat,
 (t -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> t (Q Exp), Bool, e, f)
-> ClauseQ
traverseClause (con :: Q Exp
con, pat :: Pat
pat,vars' :: (t -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> t (Q Exp)
vars',hasFargs :: Bool
hasFargs,_,_) =
                do Name
fn <- [Char] -> Q Name
newName "f"
                   let f :: Q Exp
f = Name -> Q Exp
varE Name
fn
                       fp :: Pat
fp = if Bool
hasFargs then Name -> Pat
VarP Name
fn else Pat
WildP
                       vars :: t (Q Exp)
vars = (t -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> t (Q Exp)
vars' (\d :: t
d x :: Q Exp
x -> t -> Q Exp -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => t -> Q Exp -> Q Exp -> Q Exp
iter t
d [|traverse|] Q Exp
f Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
x) (\x :: Q Exp
x -> [|pure $x|])
                   Exp
body <- (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> t (Q Exp) -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl (\ x :: Q Exp
x y :: Q Exp
y -> [|$x <*> $y|]) [|pure $con|] 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) []
            -- Note: the monadic versions are not defined
            -- applicatively, as this results in a considerable
            -- performance penalty (by factor 2)!
            mapMClause :: (Q Exp, Pat, c, Bool, t (Q Exp), t (t, Name)) -> ClauseQ
mapMClause (con :: Q Exp
con, pat :: Pat
pat,_,hasFargs :: Bool
hasFargs,allVars :: t (Q Exp)
allVars, fvars :: t (t, Name)
fvars) =
                do Name
fn <- [Char] -> Q Name
newName "f"
                   let f :: Q Exp
f = Name -> Q Exp
varE Name
fn
                       fp :: Pat
fp = if Bool
hasFargs then Name -> Pat
VarP Name
fn else Pat
WildP
                       conAp :: Q Exp
conAp = (Q Exp -> Q Exp -> Q Exp) -> Q Exp -> t (Q Exp) -> Q Exp
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
P.foldl Q Exp -> Q Exp -> Q Exp
appE Q Exp
con t (Q Exp)
allVars
                       conBind :: (t, Name) -> Q Exp -> Q Exp
conBind (d :: t
d,x :: Name
x) y :: Q Exp
y = [| $(iter d [|mapM|] f) $(varE x)  >>= $(lamE [varP x] y)|]
                   Exp
body <- ((t, Name) -> Q Exp -> Q Exp) -> Q Exp -> t (t, Name) -> Q Exp
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
P.foldr (t, Name) -> Q Exp -> Q Exp
forall t. (Eq t, Num t) => (t, Name) -> Q Exp -> Q Exp
conBind [|return $conAp|] t (t, Name)
fvars
                   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) []