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

module Data.Comp.Multi.Derive.HFunctor
    (
     HFunctor,
     makeHFunctor
    ) where

import Control.Monad
import Data.Comp.Derive.Utils
import Data.Comp.Multi.HFunctor
import Data.Maybe
import Language.Haskell.TH
import Prelude hiding (mapM)
import qualified Prelude as P (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
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)

{-| Derive an instance of 'HFunctor' for a type constructor of any higher-order
  kind taking at least two arguments. -}
makeHFunctor :: Name -> Q [Dec]
makeHFunctor :: Name -> Q [Dec]
makeHFunctor Name
fname = do
  Just (DataInfo Cxt
_cxt Name
name [TyVarBndr ()]
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 ()]
args' = forall a. [a] -> [a]
init [TyVarBndr ()]
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 ()]
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 ()]
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 ''HFunctor) Type
complType
  [(Q Exp, Pat,
  (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
  [Q Exp], [(Int, Name)])]
constrs' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
P.mapM (forall t c.
(Name, [[t]])
-> Q (Q Exp, Pat, (t -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
      [Q Exp], [(t, Name)])
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
hfmapDecl <- forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'hfmap (forall a b. (a -> b) -> [a] -> [b]
map forall {m :: * -> *} {t :: * -> *} {m :: * -> *} {t} {a} {e} {f}.
(Quote m, Foldable t, Quote m, Eq t, Num t) =>
(m Exp, Pat, (t -> m Exp -> m Exp) -> (a -> a) -> t (m Exp), Bool,
 e, f)
-> m Clause
hfmapClause [(Q Exp, Pat,
  (Int -> Q Exp -> Q Exp) -> (Q Exp -> Q Exp) -> [Q Exp], Bool,
  [Q Exp], [(Int, Name)])]
constrs')
  forall (m :: * -> *) a. Monad m => a -> m a
return [Cxt -> Type -> [Dec] -> Dec
mkInstanceD [] Type
classType [Dec
hfmapDecl]]
      where isFarg :: Type -> (a, Cxt, Maybe Type) -> (a, [[Int]])
isFarg Type
fArg (a
constr, Cxt
args, Maybe Type
ty) = (a
constr, forall a b. (a -> b) -> [a] -> [b]
map (Type -> Type -> [Int]
`containsType'` Type -> Maybe Type -> Type
getBinaryFArg Type
fArg Maybe Type
ty) 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
_ = 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 = forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (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 [] forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Name -> Pat
mkPat [Name]
varNs
            mkPat :: Name -> Pat
mkPat = Name -> Pat
VarP
            mkPatAndVars :: (Name, [[t]]) -> Q (Q Exp, Pat, (t -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool, [Q Exp], [(t, Name)])
            mkPatAndVars :: forall t c.
(Name, [[t]])
-> Q (Q Exp, Pat, (t -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
      [Q Exp], [(t, Name)])
mkPatAndVars (Name
constr, [[t]]
args) =
                do [Name]
varNs <- Int -> [Char] -> Q [Name]
newNames (forall (t :: * -> *) a. Foldable t => t a -> Int
length [[t]]
args) [Char]
"x"
                   forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
constr, Name -> [Name] -> Pat
mkCPat Name
constr [Name]
varNs,
                           \ t -> Q Exp -> c
f Q Exp -> c
g -> forall {t} {b} {c}.
[[t]] -> [b] -> (t -> b -> c) -> (b -> c) -> [c]
filterVars [[t]]
args [Name]
varNs (\ t
d Name
x -> t -> Q Exp -> c
f t
d (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x)) (Q Exp -> c
g forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). Quote m => Name -> m Exp
varE),
                           forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[t]]
args, forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varNs, forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall {t} {b} {c}.
[[t]] -> [b] -> (t -> b -> c) -> (b -> c) -> [c]
filterVars [[t]]
args [Name]
varNs (forall a b c. ((a, b) -> c) -> a -> b -> c
curry forall a. a -> Maybe a
Just) (forall a b. a -> b -> a
const forall a. Maybe a
Nothing))
            hfmapClause :: (m Exp, Pat, (t -> m Exp -> m Exp) -> (a -> a) -> t (m Exp), Bool,
 e, f)
-> m Clause
hfmapClause (m Exp
con, Pat
pat,(t -> m Exp -> m Exp) -> (a -> a) -> t (m Exp)
vars',Bool
hasFargs,e
_,f
_) =
                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 = if Bool
hasFargs then Name -> Pat
VarP Name
fn else Pat
WildP
                       vars :: t (m Exp)
vars = (t -> m Exp -> m Exp) -> (a -> a) -> t (m Exp)
vars' (\t
d m Exp
x -> forall {t} {m :: * -> *}.
(Eq t, Num t, Quote m) =>
t -> m Exp -> m Exp -> m Exp
iter t
d [|fmap|] m Exp
f forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
x) forall a. a -> a
id
                   Exp
body <- forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE m Exp
con 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) []