module ForSyDe.Process.ProcType (
EnumAlgTy(..),
ProcType(..),
genTupInstances) where
import Control.Monad (replicateM)
import Data.List (intersperse)
import Data.Data
import Data.Set (Set, union)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (Lift(..))
import Text.ParserCombinators.ReadP
data EnumAlgTy = EnumAlgTy String [String]
deriving Show
instance Eq EnumAlgTy where
(EnumAlgTy d1 _) == (EnumAlgTy d2 _) = d1 == d2
instance Ord EnumAlgTy where
(EnumAlgTy d1 _) `compare` (EnumAlgTy d2 _) = d1 `compare` d2
class (Data a, Lift a) => ProcType a where
getEnums :: a -> Set EnumAlgTy
readProcType :: ReadP a
genTupInstances :: Int
-> Q [Dec]
genTupInstances n = do
outNames <- replicateM n (newName "o")
let tupType = foldl accumApp (tupleT n) outNames
accumApp accumT vName = accumT `appT` varT vName
if n <= 7
then sequence [genProcTypeIns outNames tupType]
else sequence [genTypeableIns outNames tupType,
genDataIns outNames tupType]
where
undef t = sigE [| undefined |] (varT t)
genProcTypeIns :: [Name] -> Q Type -> Q Dec
genProcTypeIns names tupType = do
let getEnumsExpr =
foldr1 (\e1 e2 -> infixE (Just e1)
(varE 'union)
(Just e2) )
(map (\n -> varE 'getEnums `appE` undef n) names)
getEnumsD = funD 'getEnums [clause [wildP] (normalB getEnumsExpr) []]
readProcTypeExpr = doE $
bindS wildP [| skipSpaces >> char '(' |] :
(intersperse (bindS wildP [| skipSpaces >> char ',' |])
(map (\n -> bindS (varP n) [| readProcType |]) names) ++
[bindS wildP [| skipSpaces >> char ')' |],
noBindS [| return $(tupE $ map varE names) |] ] )
readProcTypeD = funD 'readProcType
[clause [] (normalB readProcTypeExpr) []]
procTypeCxt = map (\vName -> return $ ClassP ''ProcType [VarT vName]) names ++
map (\vName -> return $ ClassP ''Data [VarT vName]) names ++
map (\vName -> return $ ClassP ''Lift [VarT vName]) names
instanceD (cxt procTypeCxt)
(conT ''ProcType `appT` tupType)
[getEnumsD, readProcTypeD]
genDataIns :: [Name] -> Q Type -> Q Dec
genDataIns names tupType = do
k <- newName "k"
c <- newName "c"
z <- newName "z"
a <- newName "a"
let tupCons = conE tupName
tupName = tupleDataName n
gfoldlExpr = foldl (\acum n -> infixE (Just acum)
(varE k)
(Just $ varE n))
(varE z`appE` tupCons)
names
gfoldlD = funD 'gfoldl
[clause [varP k, varP z, tupP (map varP names)]
(normalB gfoldlExpr) []]
gunfoldExpr = let nKs 0 = (varE z `appE` tupCons)
nKs n = varE k `appE` (nKs (n1))
in nKs n
gunfoldD = funD 'gunfold
[clause [varP k, varP z, wildP] (normalB gunfoldExpr) []]
toConstrExpr = [| mkConstr (dataTypeOf $(varE a))
$(litE $ stringL (nameBase tupName))
[]
Prefix |]
toConstrD = funD 'toConstr
[clause [varP a] (normalB toConstrExpr) []]
dataTypeOfExpr = [| mkDataType $(litE $ stringL (show tupName))
[toConstr $(varE a)] |]
dataTypeOfD = funD 'dataTypeOf
[clause [varP a] (normalB dataTypeOfExpr) []]
dataCxt = map (\vName -> return $ ClassP ''Data [VarT vName]) names
instanceD (cxt dataCxt)
(conT ''Data `appT` tupType)
[gfoldlD, gunfoldD, toConstrD, dataTypeOfD]
genTypeableIns :: [Name] -> Q Type -> Q Dec
genTypeableIns names tupType = do
let strRep = '(':replicate (n1) ','++")"
typeOfExpr = [| mkTyCon
$(litE $ stringL strRep)
`mkTyConApp`
$(listE $ map (\n -> varE 'typeOf `appE` undef n) names)
|]
typeOfD = funD 'typeOf
[clause [wildP] (normalB typeOfExpr) []]
typeableCxt = map (\vName -> return $ ClassP ''Typeable [VarT vName]) names
instanceD (cxt typeableCxt)
(conT ''Typeable `appT` tupType)
[typeOfD]
genLiftIns :: [Name] -> Q Type -> Q Dec
genLiftIns names tupType = do
let liftExpr =
varE 'tupE `appE` listE (map (\n -> varE 'lift `appE` varE n) names)
liftD = funD 'lift
[clause [tupP (map varP names)] (normalB liftExpr) []]
liftCxt = map (\vName -> return $ ClassP ''Lift [VarT vName]) names
instanceD (cxt liftCxt)
(conT ''Lift `appT` tupType)
[liftD]