{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Derive.SmartAConstructors
-- Copyright   :  (c) 2011 Patrick Bahr, Tom Hvitved
-- License     :  BSD3
-- Maintainer  :  Tom Hvitved <hvitved@diku.dk>
-- Stability   :  experimental
-- Portability :  non-portable (GHC Extensions)
--
-- Automatically derive smart constructors with annotations.
--
--------------------------------------------------------------------------------

module Data.Comp.Derive.SmartAConstructors
    (
     smartAConstructors
    ) where

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

{-| Derive smart constructors with products for a type constructor of any
  parametric kind taking at least one argument. The smart constructors are
  similar to the ordinary constructors, but an 'injectA' is automatically
  inserted. -}
smartAConstructors :: Name -> Q [Dec]
smartAConstructors :: Name -> Q [Dec]
smartAConstructors 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, Int) -> Q [Dec]
genSmartConstr [(Name, Int)]
cons
        where genSmartConstr :: (Name, Int) -> Q [Dec]
genSmartConstr   (Name
name, Int
args) = do
                let bname :: String
bname = Name -> String
nameBase Name
name
                Name -> Name -> Int -> Q [Dec]
genSmartConstr'  (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
"iA" forall a. [a] -> [a] -> [a]
++ String
bname) Name
name Int
args
              genSmartConstr' :: Name -> Name -> Int -> Q [Dec]
genSmartConstr'  Name
sname Name
name Int
args = do
                [Name]
varNs <- Int -> String -> Q [Name]
newNames Int
args String
"x"
                Name
varPr <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"_p"
                let pats :: [Q Pat]
pats = forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Pat
varP (Name
varPr forall a. a -> [a] -> [a]
: [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 (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|injectA $(varE varPr)|] forall a b. (a -> b) -> a -> b
$
                          forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
appE [|inj|] forall a b. (a -> b) -> a -> b
$ 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
                    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 [|Term $val|]) []]]
                forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Q Dec]
function