{-# 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 flag]
targs [Con]
constrs [DerivClause]
_deriving) <- Q Info -> Q (Maybe DataInfo)
abstractNewtypeQ forall a b. (a -> b) -> a -> b
$ Name -> Q Info
reify Name
fname
    let cons :: [(Name, Int)]
cons = forall a b. (a -> b) -> [a] -> [b]
map Con -> (Name, Int)
abstractConType [Con]
constrs
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ 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 (forall a b. (a -> b) -> [a] -> [b]
map forall {flag}. TyVarBndr flag -> Name
tyVarBndrName [TyVarBndr flag]
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 forall a b. (a -> b) -> a -> b
$ Char
'i' 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 :: [Q Pat]
pats = forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP [Name]
varNs
                    vars :: [Q Exp]
vars = forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE [Name]
varNs
                    val :: Q Exp
val = 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 (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
name) [Q Exp]
vars
                    sig :: [Q Dec]
sig = forall {a} {m :: * -> *}.
(Eq a, Num a, Quote m) =>
[Name] -> Name -> Name -> a -> [m Dec]
genSig [Name]
targs Name
tname Name
sname Int
args
                    function :: [Q Dec]
function = [forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD Name
sname [forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [Q Pat]
pats (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB [|inject $val|]) []]]
                forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ [Q Dec]
sig forall a. [a] -> [a] -> [a]
++ [Q Dec]
function
              genSig :: [Name] -> Name -> Name -> a -> [m Dec]
genSig [Name]
targs Name
tname Name
sname a
0 = (forall a. a -> [a] -> [a]
:[]) 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' = forall a. [a] -> [a]
init [Name]
targs
                    vars :: [Name]
vars = Name
fvarforall a. a -> [a] -> [a]
:Name
hvarforall a. a -> [a] -> [a]
:Name
avarforall a. a -> [a] -> [a]
:[Name]
targs'
                    f :: m Type
f = forall (m :: * -> *). Quote m => Name -> m Type
varT Name
fvar
                    h :: m Type
h = forall (m :: * -> *). Quote m => Name -> m Type
varT Name
hvar
                    a :: m Type
a = forall (m :: * -> *). Quote m => Name -> m Type
varT Name
avar
                    ftype :: m Type
ftype = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT Name
tname) (forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Type
varT [Name]
targs')
                    constr :: m Type
constr = (forall (m :: * -> *). Quote m => Name -> m Type
conT ''(:<:) forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` m Type
ftype) forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` m Type
f
                    typ :: m Type
typ = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (forall (m :: * -> *). Quote m => Name -> m Type
conT ''Cxt) [m Type
h, m Type
f, m Type
a]
                    typeSig :: m Type
typeSig = forall (m :: * -> *).
Quote m =>
[TyVarBndr Specificity] -> m Cxt -> m Type -> m Type
forallT (forall a b. (a -> b) -> [a] -> [b]
map (\ Name
v -> forall flag. Name -> flag -> TyVarBndr flag
PlainTV Name
v Specificity
SpecifiedSpec) [Name]
vars) (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [m Type
constr]) m Type
typ
                forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
sigD Name
sname m Type
typeSig
              genSig [Name]
_ Name
_ Name
_ a
_ = []