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

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

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

{-| Derive smart constructors for a type constructor of any first-order kind
 taking at least one argument. The smart constructors are similar to the
 ordinary constructors, but an 'inject' is automatically inserted. -}
smartConstructors :: Name -> Q [Dec]
smartConstructors :: Name -> Q [Dec]
smartConstructors Name
fname = do
    Just (DataInfo Cxt
_cxt Name
tname [TyVarBndr]
targs [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 cons :: [(Name, Int)]
cons = (Con -> (Name, Int)) -> [Con] -> [(Name, Int)]
forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, Int)
abstractConType [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) -> Q [Dec]) -> [(Name, Int)] -> Q [[Dec]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Name] -> Name -> (Name, Int) -> Q [Dec]
genSmartConstr ((TyVarBndr -> Name) -> [TyVarBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map TyVarBndr -> Name
tyVarBndrName [TyVarBndr]
targs) Name
tname) [(Name, Int)]
cons
        where genSmartConstr :: [Name] -> Name -> (Name, Int) -> Q [Dec]
genSmartConstr [Name]
targs Name
tname (Name
name, Int
args) = do
                let bname :: String
bname = Name -> String
nameBase Name
name
                [Name] -> Name -> Name -> Name -> Int -> Q [Dec]
genSmartConstr' [Name]
targs Name
tname (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ Char
'i' Char -> String -> String
forall a. a -> [a] -> [a]
: String
bname) Name
name Int
args
              genSmartConstr' :: [Name] -> Name -> Name -> Name -> Int -> Q [Dec]
genSmartConstr' [Name]
targs Name
tname Name
sname Name
name Int
args = do
                [Name]
varNs <- Int -> String -> Q [Name]
newNames Int
args String
"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 :: [DecQ]
sig = [Name] -> Name -> Name -> Int -> [DecQ]
forall a. (Eq a, Num a) => [Name] -> Name -> Name -> a -> [DecQ]
genSig [Name]
targs Name
tname Name
sname Int
args
                    function :: [DecQ]
function = [Name -> [ClauseQ] -> DecQ
funD Name
sname [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ]
pats (ExpQ -> BodyQ
normalB [|inject $val|]) []]]
                [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([DecQ] -> Q [Dec]) -> [DecQ] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [DecQ]
sig [DecQ] -> [DecQ] -> [DecQ]
forall a. [a] -> [a] -> [a]
++ [DecQ]
function
              genSig :: [Name] -> Name -> Name -> a -> [DecQ]
genSig [Name]
targs Name
tname Name
sname a
0 = (DecQ -> [DecQ] -> [DecQ]
forall a. a -> [a] -> [a]
:[]) (DecQ -> [DecQ]) -> DecQ -> [DecQ]
forall a b. (a -> b) -> a -> b
$ do
                let fvar :: Name
fvar = String -> Name
mkName String
"f"
                    hvar :: Name
hvar = String -> Name
mkName String
"h"
                    avar :: Name
avar = String -> Name
mkName String
"a"
                    targs' :: [Name]
targs' = [Name] -> [Name]
forall a. [a] -> [a]
init [Name]
targs
                    vars :: [Name]
vars = Name
fvarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
hvarName -> [Name] -> [Name]
forall a. a -> [a] -> [a]
:Name
avarName -> [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
                    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
conT ''(:<:) TypeQ -> TypeQ -> TypeQ
`appT` TypeQ
ftype) TypeQ -> TypeQ -> TypeQ
`appT` 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]
                    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 -> DecQ
sigD Name
sname TypeQ
typeSig
              genSig [Name]
_ Name
_ Name
_ a
_ = []