module GTA.Util.GenericSemiringStructureTemplate (genAlgebraDecl, genMapFunctionsDecl, genInstanceDecl, genAllDecl) where
import Language.Haskell.TH
import GTA.Util.TypeInfo
import Data.Char
genAlgebraDecl :: Name -> Q [Dec]
genAlgebraDecl typName =
do (typeName,typeParams,constructors) <- typeInfo typName
alg <- genAlgebraRecord typeName typeParams constructors
return ([alg])
genMapFunctionsDecl :: Name -> Q [Dec]
genMapFunctionsDecl typName =
do (typeName,typeParams,constructors) <- typeInfo typName
alg <- genMapFunctionsRecord typeName typeParams constructors
return ([alg])
genInstanceDecl :: Name -> Q [Dec]
genInstanceDecl typName =
do (typeName,typeParams,constructors) <- typeInfo typName
inst <- genSemiringInstance typeName typeParams constructors
return ([inst])
genAllDecl :: Name -> Q [Dec]
genAllDecl typName =
do alg <- genAlgebraDecl typName
mf <- genMapFunctionsDecl typName
inst <- genInstanceDecl typName
return (alg ++ mf ++ inst)
genAlgebraRecord :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genAlgebraRecord typeName typeParams constructors =
let a = mkName "gta"
newParams = typeParams++[PlainTV a]
dataName = algebraName typeName
funs = map genFun constructors
con = recC dataName funs
genFun (name, params) =
varStrictType (funcName name)
(strictType notStrict (arrowConcat (map (\(VarT a) -> varT a) (replace freeType (VarT a) (map (\(_, t) -> t) params ++[VarT a])))))
freeType = genFreeType typeName typeParams
in dataD (cxt []) dataName newParams [con] []
genMapFunctionsRecord :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genMapFunctionsRecord typeName typeParams constructors =
let a = mkName "gta"
newParams = typeParams++[PlainTV a]
mapName = mapFunctionsName typeName
funs = map genFun constructors'
con = recC mapName funs
funcName' = mfFuncName . funcName
constructors' = filter (\(_, x) -> length x > 0) (map dropFreeType constructors)
dropFreeType (name, params) = (name, filter (/=freeType) (map (\(_, t) -> t) params))
genFun (name, params) =
varStrictType (funcName' name)
(strictType notStrict (mkTupleType (map (\(VarT b) -> appT (appT arrowT (varT b)) (varT a)) params)))
freeType = genFreeType typeName typeParams
in dataD (cxt []) mapName newParams [con] []
mkTupleType :: [TypeQ] -> TypeQ
mkTupleType [a] = a
mkTupleType x = foldl appT (tupleT (length x)) x
genSemiringInstance :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genSemiringInstance typeName typeParams constructors =
let className = mkName "GenericSemiringStructure"
appfold e = foldl appT e . map (\(PlainTV a) -> varT a)
instanceType = appT (appT (appT (conT className) (appfold (conT dataName) typeParams)) (appfold (conT typeName) typeParams)) (appfold (conT mapName) typeParams)
dataName = algebraName typeName
mapName = mapFunctionsName typeName
funcs = [genFreeAlgebra typeName typeParams constructors,
genHom typeName typeParams constructors,
genPairAlgebra typeName typeParams constructors,
genMakeAlgebra typeName typeParams constructors,
genFoldingAlgebra typeName typeParams constructors]
in instanceD (cxt []) instanceType funcs
genFreeAlgebra :: forall t t1. Name -> t -> [(Name, t1)] -> DecQ
genFreeAlgebra typeName _ constructors =
let
freeAlgebraName = (mkName "freeAlgebra")
fieldEs = genWildcardFieldExp (map (\(n, _) -> funcName n) constructors)
e = recConE (algebraName typeName) fieldEs
decls = map genFunDecl constructors
genFunDecl (n, _) = funD (funcName n) [clause [] (normalB (conE n)) []]
in funD freeAlgebraName [clause [] (normalB e) decls]
genPairAlgebra :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genPairAlgebra typeName typeParams constructors =
let
alg1 = mkName "algebra1"
alg2 = mkName "algebra2"
vps = map varP [alg1, alg2]
fs = map (\(n, _)->funcName n) constructors
binds = [recBind (algebraName typeName) fs (varE alg1) (name 1),
recBind (algebraName typeName) fs (varE alg2) (name 2)]
name i = mkName . (++show i) . nameBase
bindExp ve = ve
bindPat a = tupP [varP (name 1 a), varP (name 2 a)]
newAlgebraName = (mkName "pairAlgebra")
genBody _ n' pbs = tupE [foldl1 appE (varE (name 1 n'):vars 1), foldl1 appE (varE (name 2 n'):vars 2)]
where
varnames f = map (\(b, VarT a) -> case b of Just (VarT c) -> f c
otherwise -> a) pbs
vars i = map varE (varnames (name i))
in genAlgebraDec' typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genBody
genMakeAlgebra :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genMakeAlgebra typeName typeParams constructors =
let
m = mkName "m"
alg = mkName "alg"
frec = mkName "frec"
fsingle = mkName "fsingle"
vps = map varP [m, alg, frec, fsingle]
fs = map (\(n, _)->funcName n) constructors
binds = [recBind (algebraName typeName) fs (varE alg) name,
monoidBind (varE m)]
name = mkName . (++"gta") . nameBase
bindExp ve = appE (varE frec) ve
bindPat a = varP a
newAlgebraName = (mkName "makeAlgebra")
genComprBody _ n' pbs = appE (varE fsingle) (foldl1 appE (varE (name n'):vars))
where vars = map (\(b, VarT a) -> case b of Just (VarT c) -> varE c
otherwise -> varE a) pbs
in genAlgebraDec typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genComprBody
genFoldingAlgebra :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genFoldingAlgebra typeName typeParams constructors =
let
mf = mkName "mf"
op = mkName "op"
iop = mkName "iop"
vps = map varP [op, iop, mf]
constructors' = filter hasNonRec constructors
hasNonRec (_, ps) = length (filter (\(_, t) -> t /=freeType) ps) > 0
fs = map (\(n, _)->mfFuncName(funcName n)) constructors'
binds = [recBind (mapFunctionsName typeName) fs (varE mf) id]
freeType = genFreeType typeName typeParams
newAlgebraName = (mkName "foldingAlgebra")
funcs _ n' pbs = let
nonrecs = map (\(b, VarT _) -> case b of Just (VarT _) -> 0
otherwise -> 1) pbs
ids = tail(scanl (+) 0 nonrecs)
f 0 _ a = Left a
f 1 i b = Right (name i (mfFuncName n'), b)
in zipWith3 f nonrecs ids pbs
name i = mkName . (++show i) . nameBase
genVarbinds n n' pbs =
let funs = funcs n n' pbs
ns = map (\(Right (n, _)) -> varP n) (filter fr funs)
fr (Left _) = False
fr (Right _) = True
in if length ns == 0 then [] else [valD (tupP ns) (normalB (varE (mfFuncName n'))) []]
genBody n n' pbs = if pbs == [] then varE iop else foldl1 (\a b -> appE (appE (varE op) a) b) vars
where
funs = funcs n n' pbs
vars = map f funs
f (Left (_, VarT a)) = varE a
f (Right (fn, (_, VarT a))) = appE (varE fn) (varE a)
in genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds
genHom :: forall t.Name -> [TyVarBndr] -> [(Name, [(t, Type)])] -> DecQ
genHom typeName typeParams constructors =
let
fs = map (\(n, _)->funcName n) constructors
vps = [recPat (algebraName typeName) fs id]
freeType = genFreeType typeName typeParams
decls = [funD h (map genClause constructors)]
h = mkName "h"
genClause (n, ps) = let
n' = funcName n
ts = map (\(_, t) -> t) ps
pbs = zipWith mkpb ts (newVars "rv")
mkpb t v = if t == freeType then (Just (), v) else (Nothing, t)
pats = [conP n (map (\(_, VarT a) -> varP a) pbs)]
subes = map (\(b, VarT a) -> case b of Just () -> appE (varE h) (varE a)
otherwise -> varE a) pbs
b = foldl appE (varE n') subes
in clause pats (normalB b) []
in funD (mkName "hom") [clause vps (normalB (varE h)) decls]
genAlgebraDec :: forall t.
Name
-> [TyVarBndr]
-> [(Name, [(t, Type)])]
-> [DecQ]
-> Name
-> [PatQ]
-> (ExpQ -> ExpQ)
-> (Name -> PatQ)
-> (Name -> Name -> [(Maybe Type, Type)] -> ExpQ)
-> DecQ
genAlgebraDec typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genComprBody =
let
genVarbinds _ _ _ = []
genBody n n' pbs =
if and (map ((==Nothing).fst) pbs)
then
genComprBody n n' pbs
else
let
bigOp = foldl1 appE (map (varE.mkName) ["foldr", "oplus", "identity"])
varbinds = map bind (filter ((/=Nothing).fst) pbs)
bind (Just(VarT a),VarT b) = bindS (bindPat a) (bindExp (varE b))
compr = compE (varbinds++[noBindS (genComprBody n n' pbs)])
in appE bigOp compr
in genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds
genAlgebraDec' :: forall t.
Name
-> [TyVarBndr]
-> [(Name, [(t, Type)])]
-> [DecQ]
-> Name
-> [PatQ]
-> (ExpQ -> ExpQ)
-> (Name -> PatQ)
-> (Name -> Name -> [(Maybe Type, Type)] -> ExpQ)
-> DecQ
genAlgebraDec' typeName typeParams constructors binds newAlgebraName vps bindExp bindPat genBody =
let genVarbinds _ _ pbs = map bind (filter ((/=Nothing).fst) pbs)
where bind (Just(VarT a),VarT b) = valD (bindPat a) (normalB (bindExp (varE b))) []
in genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds
genAlgebraDec'' :: forall t.
Name
-> [TyVarBndr]
-> [(Name, [(t, Type)])]
-> [DecQ]
-> Name
-> [PatQ]
-> (Name -> Name -> [(Maybe Type, Type)] -> ExpQ)
-> (Name -> Name -> [(Maybe Type, Type)] -> [DecQ])
-> DecQ
genAlgebraDec'' typeName typeParams constructors binds newAlgebraName vps genBody genVarbinds =
let fieldEs = genWildcardFieldExp (map (\(n, _) -> funcName n) constructors)
e = recConE (algebraName typeName) fieldEs
freeType = genFreeType typeName typeParams
decls = map genFunDecl constructors ++ binds
genFunDecl (n, ps) =
let n' = funcName n
ts = map (\(_, t) -> t) ps
pbs = zipWith3 mkpb ts (newVars "rv") (newVars "rvi")
mkpb t v vv = if t == freeType then (Just vv, v) else (Nothing, t)
pats = map (\(_, VarT a) -> varP a) pbs
b = genBody n n' pbs
varbinds = genVarbinds n n' pbs
in funD n' [clause pats (normalB b) varbinds]
in funD newAlgebraName [clause vps (normalB e) decls]
replace :: forall b. Eq b => b -> b -> [b] -> [b]
replace a b x = map (\c -> if c == a then b else c) x
arrowConcat :: [TypeQ] -> TypeQ
arrowConcat = foldr1 (\v x -> appT (appT arrowT v) x)
funcName :: Name -> Name
funcName = mkName . unCapalize . nameBase
unCapalize :: [Char] -> [Char]
unCapalize (x:y) = (toLower x):y
algebraName :: Name -> Name
algebraName typeName = mkName (nameBase typeName++"Algebra")
mapFunctionsName :: Name -> Name
mapFunctionsName typeName = mkName (nameBase typeName++"MapFs")
mfFuncName :: Name -> Name
mfFuncName = mkName . (++"F") . nameBase
monoidBind :: ExpQ -> DecQ
monoidBind e = recBind (mkName "CommutativeMonoid") [mkName "oplus", mkName "identity"] e id
recBind :: Name -> [Name] -> ExpQ -> (Name -> Name) -> DecQ
recBind n fs e f = valD (recPat n fs f) (normalB e) []
recPat :: Name -> [Name] -> (Name -> Name) -> PatQ
recPat n fs f = recP n (genWildcardFieldPat f fs)
genFreeType :: Name -> [TyVarBndr] -> Type
genFreeType typeName typeParams = foldl1 AppT (ConT typeName:typeParams'')
where typeParams'' = map (\(PlainTV a) -> VarT a) typeParams
genWildcardFieldExp :: [Name] -> [Q (Name, Exp)]
genWildcardFieldExp = map (\n -> fieldExp n (varE n))
genWildcardFieldPat :: (Name -> Name) -> [Name] -> [FieldPatQ]
genWildcardFieldPat f = map (\n -> fieldPat n (varP (f n)))
newVars :: [Char] -> [Type]
newVars s = g 0 where g i = VarT (mkName (s ++ show i)) : g (i+1)