{-# LANGUAGE TemplateHaskell #-}
--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Comp.Multi.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.Multi.Derive.SmartAConstructors
    (
     smartAConstructors
    ) where

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

{-| Derive smart constructors with products for a type constructor of any
  parametric kind taking at least two arguments. 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]
_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, 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 (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String
"iA" String -> String -> String
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 <- String -> Q Name
newName String
"_p"
                let pats :: [PatQ]
pats = (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP (Name
varPr Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [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
appE [|injectA $(varE varPr)|] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$
                          ExpQ -> ExpQ -> ExpQ
appE [|inj|] (ExpQ -> ExpQ) -> ExpQ -> ExpQ
forall a b. (a -> b) -> a -> b
$ (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
                    function :: [DecQ]
function = [Name -> [ClauseQ] -> DecQ
funD Name
sname [[PatQ] -> BodyQ -> [DecQ] -> ClauseQ
clause [PatQ]
pats (ExpQ -> BodyQ
normalB [|Term $val|]) []]]
                [DecQ] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [DecQ]
function