{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Multi.Derive.SmartConstructors
-- Copyright   :  (c) 2011 Patrick Bahr
-- License     :  BSD3
-- Maintainer  :  Patrick Bahr <paba@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Automatically derive smart constructors for mutually recursive types.
--
--------------------------------------------------------------------------------

module Data.Comp.Multi.Derive.SmartConstructors
    (
     smartConstructors
    ) where

import Control.Arrow ((&&&))
import Control.Monad
import Data.Comp.Derive.Utils
import Data.Comp.Multi.Sum
import Data.Comp.Multi.Term
import Language.Haskell.TH hiding (Cxt)

{-| Derive smart constructors for a type constructor of any higher-order kind
 taking at least two arguments. The smart constructors are similar to the
 ordinary constructors, but an 'inject' is automatically inserted. -}
smartConstructors :: Name -> Q [Dec]
smartConstructors :: Name -> Q [Dec]
smartConstructors fname :: Name
fname = do
    Just (DataInfo _cxt :: Cxt
_cxt tname :: Name
tname targs :: [TyVarBndr]
targs 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 iVar :: Name
iVar = TyVarBndr -> Name
tyVarBndrName (TyVarBndr -> Name) -> TyVarBndr -> Name
forall a b. (a -> b) -> a -> b
$ [TyVarBndr] -> TyVarBndr
forall a. [a] -> a
last [TyVarBndr]
targs
    let cons :: [((Name, Int), Maybe Type)]
cons = (Con -> ((Name, Int), Maybe Type))
-> [Con] -> [((Name, Int), Maybe Type)]
forall a b. (a -> b) -> [a] -> [b]
map (Con -> (Name, Int)
abstractConType (Con -> (Name, Int))
-> (Con -> Maybe Type) -> Con -> ((Name, Int), Maybe Type)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& Name -> Con -> Maybe Type
iTp Name
iVar) [Con]
constrs
    ([[Dec]] -> [Dec]) -> Q [[Dec]] -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [[Dec]] -> [Dec]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (Q [[Dec]] -> Q [Dec]) -> Q [[Dec]] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ (((Name, Int), Maybe Type) -> Q [Dec])
-> [((Name, Int), Maybe Type)] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Name] -> Name -> ((Name, Int), Maybe Type) -> Q [Dec]
genSmartConstr ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
targs) Name
tname) [((Name, Int), Maybe Type)]
cons
        where iTp :: Name -> Con -> Maybe Type
iTp iVar :: Name
iVar (ForallC _ cxt :: Cxt
cxt _) =
                  -- Check if the GADT phantom type is constrained
                  case [Type
y | Just (x :: Type
x, y :: Type
y) <- (Type -> Maybe (Type, Type)) -> Cxt -> [Maybe (Type, Type)]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Maybe (Type, Type)
isEqualP Cxt
cxt, Type
x Type -> Type -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> Type
VarT Name
iVar] of
                    [] -> Maybe Type
forall a. Maybe a
Nothing
                    tp :: Type
tp:_ -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
tp
              iTp _ _ = Maybe Type
forall a. Maybe a
Nothing
              genSmartConstr :: [Name] -> Name -> ((Name, Int), Maybe Type) -> Q [Dec]
genSmartConstr targs :: [Name]
targs tname :: Name
tname ((name :: Name
name, args :: Int
args), miTp :: Maybe Type
miTp) = do
                let bname :: String
bname = Name -> String
nameBase Name
name
                [Name] -> Name -> Name -> Name -> Int -> Maybe Type -> Q [Dec]
genSmartConstr' [Name]
targs Name
tname (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ 'i' Char -> String -> String
forall a. a -> [a] -> [a]
: String
bname) Name
name Int
args Maybe Type
miTp
              genSmartConstr' :: [Name] -> Name -> Name -> Name -> Int -> Maybe Type -> Q [Dec]
genSmartConstr' targs :: [Name]
targs tname :: Name
tname sname :: Name
sname name :: Name
name args :: Int
args miTp :: Maybe Type
miTp = do
                [Name]
varNs <- Int -> String -> Q [Name]
newNames Int
args "x"
                let pats :: [PatQ]
pats = (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
varNs
                    vars :: [ExpQ]
vars = (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
varNs
                    val :: ExpQ
val = (ExpQ -> ExpQ -> ExpQ) -> ExpQ -> [ExpQ] -> ExpQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl ExpQ -> ExpQ -> ExpQ
appE (Name -> ExpQ
conE Name
name) [ExpQ]
vars
                    sig :: [Q Dec]
sig = [Name] -> Name -> Name -> Int -> Maybe Type -> [Q Dec]
forall a.
(Eq a, Num a) =>
[Name] -> Name -> Name -> a -> Maybe Type -> [Q Dec]
genSig [Name]
targs Name
tname Name
sname Int
args Maybe Type
miTp
                    function :: [Q Dec]
function = [Name -> [ClauseQ] -> Q Dec
funD Name
sname [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ]
pats (ExpQ -> BodyQ
normalB [|inject $val|]) []]]
                [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([Q Dec] -> Q [Dec]) -> [Q Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Q Dec]
sig [Q Dec] -> [Q Dec] -> [Q Dec]
forall a. [a] -> [a] -> [a]
++ [Q Dec]
function
              genSig :: [Name] -> Name -> Name -> a -> Maybe Type -> [Q Dec]
genSig targs :: [Name]
targs tname :: Name
tname sname :: Name
sname 0 miTp :: Maybe Type
miTp = (Q Dec -> [Q Dec] -> [Q Dec]
forall a. a -> [a] -> [a]
:[]) (Q Dec -> [Q Dec]) -> Q Dec -> [Q Dec]
forall a b. (a -> b) -> a -> b
$ do
                Name
fvar <- String -> Q Name
newName "f"
                Name
hvar <- String -> Q Name
newName "h"
                Name
avar <- String -> Q Name
newName "a"
                Name
ivar <- String -> Q Name
newName "i"
                let targs' :: [Name]
targs' = [Name] -> [Name]
forall a. [a] -> [a]
init ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name] -> [Name]
forall a. [a] -> [a]
init [Name]
targs
                    vars :: [Name]
vars = Name
hvarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
fvarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
avarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:[Name] -> (Type -> [Name]) -> Maybe Type -> [Name]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Name
ivar] ([Name] -> Type -> [Name]
forall a b. a -> b -> a
const []) Maybe Type
miTp[Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++[Name]
targs'
                    f :: TypeQ
f = Name -> TypeQ
varT Name
fvar
                    h :: TypeQ
h = Name -> TypeQ
varT Name
hvar
                    a :: TypeQ
a = Name -> TypeQ
varT Name
avar
                    i :: TypeQ
i = Name -> TypeQ
varT Name
ivar
                    ftype :: TypeQ
ftype = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT Name
tname) ((Name -> TypeQ) -> [Name] -> [TypeQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TypeQ
varT [Name]
targs')
                    constr :: TypeQ
constr = Name -> [TypeQ] -> TypeQ
classP ''(:<:) [TypeQ
ftype, TypeQ
f]
                    typ :: TypeQ
typ = (TypeQ -> TypeQ -> TypeQ) -> TypeQ -> [TypeQ] -> TypeQ
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl TypeQ -> TypeQ -> TypeQ
appT (Name -> TypeQ
conT ''Cxt) [TypeQ
h, TypeQ
f, TypeQ
a, TypeQ -> (Type -> TypeQ) -> Maybe Type -> TypeQ
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TypeQ
i Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Type
miTp]
                    typeSig :: TypeQ
typeSig = [TyVarBndr] -> CxtQ -> TypeQ -> TypeQ
forallT ((Name -> TyVarBndr) -> [Name] -> [TyVarBndr]
forall a b. (a -> b) -> [a] -> [b]
map Name -> TyVarBndr
PlainTV [Name]
vars) ([TypeQ] -> CxtQ
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [TypeQ
constr]) TypeQ
typ
                Name -> TypeQ -> Q Dec
sigD Name
sname TypeQ
typeSig
              genSig _ _ _ _ _ = []