{-# 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
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 '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 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 ''HFunctor) 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 t c.
(Name, [[t]])
-> Q (Q Exp, Pat, (t -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
      [Q 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
hfmapDecl <- Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'hfmap (((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 :: * -> *} {a} {e} {f}.
(Foldable t, Eq t, Num t, Quote m, Quote m) =>
(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')
  [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
hfmapDecl]]
      where isFarg :: Type -> (a, Cxt, Maybe Type) -> (a, [[Int]])
isFarg Type
fArg (a
constr, Cxt
args, Maybe Type
ty) = (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
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
_ = [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 (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 ([[t]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [[t]]
args) [Char]
"x"
                   (Q Exp, Pat, (t -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
 [Q Exp], [(t, Name)])
-> Q (Q Exp, Pat, (t -> Q Exp -> c) -> (Q Exp -> c) -> [c], Bool,
      [Q Exp], [(t, Name)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Q Exp
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 -> [[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 -> Q Exp -> c
f t
d (Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
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 -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q 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))
            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 <- [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) -> (a -> a) -> 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 [|fmap|] m Exp
f m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` m Exp
x) a -> a
forall a. a -> a
id
                   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
foldl m Exp -> m Exp -> m Exp
forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE 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) []