pads-haskell-0.0.0.1: Language/Pads/CodeGen.hs
{-# LANGUAGE TupleSections, ViewPatterns, TemplateHaskell, NamedFieldPuns, ScopedTypeVariables,
RecordWildCards, UndecidableInstances #-}
{-# OPTIONS_HADDOCK prune #-}
{-|
Module : Language.Pads.CodeGen
Description : Template Haskell based code generator
Copyright : (c) 2011
Kathleen Fisher <kathleen.fisher@gmail.com>
John Launchbury <john.launchbury@gmail.com>
License : MIT
Maintainer : Karl Cronburg <karl@cs.tufts.edu>
Stability : experimental
To the best of my knowledge, all functions defined herein are only ever run at
compile time. These compile time functions are intended to be used in a
quasiquoted context where the runtime system support modules have been properly
imported. See "Examples.First" for the necessary imports.
The crucial piece of the code generator is 'genParseTy', which translates Pads
syntactic forms into Haskell code for parsing them.
-}
module Language.Pads.CodeGen where
import Language.Pads.Syntax as PS
import Language.Pads.MetaData
import Language.Pads.Generic
import Language.Pads.PadsParser
import Language.Pads.CoreBaseTypes
import Language.Pads.TH
import qualified Language.Pads.Errors as E
import qualified Language.Pads.Source as S
import Language.Pads.PadsPrinter
import Language.Haskell.TH
import Language.Haskell.Syntax
import Data.Data
import Data.Char
import qualified Data.Map as M
import qualified Data.List as List
import qualified Data.Maybe as Maybe
import Control.Monad
import Language.Haskell.TH.Syntax (lift)
import qualified Debug.Trace as D
-- |
type BString = S.RawStream
-- | A function passed into the code generator which gets called on data type
-- declarations and returns a list of standalone-deriving declarations.
-- Presently this is unused by Pads.
type Derivation = Dec -> Q [Dec]
-- | Top level code gen function from Pads decls to Haskell decls
make_pads_declarations :: [PadsDecl] -> Q [Dec]
make_pads_declarations = make_pads_declarations' (const $ return [])
-- | Top level code gen function from Pads decls to Haskell expression with just
-- the PADS AST (no parser codegen)
make_pads_asts :: [PadsDecl] -> Q Exp
make_pads_asts = let
mpa pd@(PadsDeclType n _ _ _) = [| ($(litE $ stringL n), $(lift pd)) |]
mpa pd@(PadsDeclData n _ _ _ _) = [| ($(litE $ stringL n), $(lift pd)) |]
mpa pd@(PadsDeclNew n _ _ _ _) = [| ($(litE $ stringL n), $(lift pd)) |]
mpa pd@(PadsDeclObtain n _ _ _) = [| ($(litE $ stringL n), $(lift pd)) |]
in listE . (map mpa)
-- | Top level code gen function from Pads decls to Haskell decls with the
-- specified list of type classes for all of the generated Pads types to derive.
make_pads_declarations' :: Derivation -> [PadsDecl] -> Q [Dec]
make_pads_declarations' derivation ds = fmap concat (mapM (genPadsDecl derivation) ds)
-------------------------------------------------------------------------------
-- * Generating Declarations and Code from Individual Pads Declarations
genPadsDecl :: Derivation -> PadsDecl -> Q [Dec]
-- ^ Generate all the top level Haskell declarations associated with a single
-- Pads declaration.
genPadsDecl derivation pd@(PadsDeclType name args pat padsTy) = do
let typeDecs = mkTyRepMDDecl name args padsTy
parseM <- genPadsParseM name args pat padsTy
parseS <- genPadsParseS name args pat
printFL <- genPadsPrintFL name args pat padsTy
def <- genPadsDef name args pat padsTy
let sigs = mkPadsSignature name args (fmap patType pat)
ast <- astDecl name pd
return $ typeDecs ++ parseM ++ parseS ++ printFL ++ def ++ sigs
genPadsDecl derivation pd@(PadsDeclData name args pat padsData derives) = do
dataDecs <- mkDataRepMDDecl derivation name args padsData derives
parseM <- genPadsDataParseM name args pat padsData
parseS <- genPadsParseS name args pat
printFL <- genPadsDataPrintFL name args pat padsData
def <- genPadsDataDef name args pat padsData
let instances = mkPadsInstance name args (fmap patType pat)
let sigs = mkPadsSignature name args (fmap patType pat)
ast <- astDecl name pd
return $ dataDecs ++ parseM ++ parseS ++ printFL ++ def ++ instances ++ sigs
genPadsDecl derivation pd@(PadsDeclNew name args pat branch derives) = do
dataDecs <- mkNewRepMDDecl derivation name args branch derives
parseM <- genPadsNewParseM name args pat branch
parseS <- genPadsParseS name args pat
printFL <- genPadsNewPrintFL name args pat branch
def <- genPadsNewDef name args pat branch
let instances = mkPadsInstance name args (fmap patType pat)
let sigs = mkPadsSignature name args (fmap patType pat)
ast <- astDecl name pd
return $ dataDecs ++ parseM ++ parseS ++ printFL ++ def ++ instances ++ sigs
genPadsDecl derivation pd@(PadsDeclObtain name args padsTy exp) = do
let mdDec = mkObtainMDDecl name args padsTy
parseM <- genPadsObtainParseM name args padsTy exp
parseS <- genPadsParseS name args Nothing
printFL <- genPadsObtainPrintFL name args padsTy exp
def <- genPadsObtainDef name args padsTy exp
let sigs = mkPadsSignature name args Nothing
ast <- astDecl name pd
return $ mdDec ++ parseM ++ parseS ++ printFL ++ def ++ sigs
-- | A Haskell declaration containing the literal Pads AST representation of a
-- Pads description (the syntax of Pads encoded as Haskell data constructors)
astDecl name pd = funD (mkName $ "ast_" ++ name) [clause [] (normalB $ lift pd) []]
-- | The Haskell 'Type' of a Haskell pattern 'Pat'.
patType :: Pat -> Type
patType p = case p of
LitP lit -> case lit of
CharL c -> VarT ''Char
StringL s -> VarT ''String
TupP ps -> mkTupleT (map patType ps)
SigP p t -> t
ParensP p -> patType p
otherwise -> error $ show p
-------------------------------------------------------------------------------
-- * Generating Rep/MD Type Declarations
-- | Make the type declarations for the representation and the metadata of a
-- Pads-defined type, @'PadsTy'@.
mkTyRepMDDecl :: UString -> [UString] -> PadsTy -> [Dec]
mkTyRepMDDecl name args ty = [repType, mdType]
where
repType = TySynD (mkRepName name) tyArgs (mkRepTy ty)
mdType = TySynD (mkMDName name) tyArgsMD (mkMDTy False ty)
tyArgs = map (PlainTV . mkName) args
tyArgsMD = map (PlainTV . mkName . (++"_md")) args
-------------------------------------------------------------------------------
-- * Generating Rep/MD Data Declarations
-- | Make the data type declarations for the representation and the metadata of
-- a Pads-defined data type, @'PadsData'@.
mkDataRepMDDecl :: Derivation -> UString -> [LString] -> PadsData -> [QString] -> Q [Dec]
mkDataRepMDDecl derivation name args branches ds = do
bs' <- mapM (return . mkMDUnion) bs
imdDecl <- dataD (cxt []) (mkIMDName name) tyArgsMD Nothing bs' [derive []]
bs'' <- mapM (return . mkRepUnion) bs
--let ds' = map (conT . mkName . qName) ds
dataDecl <- dataD (cxt []) (mkRepName name) tyArgs Nothing bs'' [derive ds]
derivesData <- derivation dataDecl
derivesImd <- derivation imdDecl
let mdName = mkMDName name
--let bT = bangType (mkStrict NotStrict)
--let mdDeclConstr = normalC mdName $ [bT $ return $ mkTupleT [ConT '' Base_md, imdApp]]
--mdDecl <- newtypeD (cxt []) mdName tyArgsMD Nothing mdDeclConstr []
let mdDecl = TySynD (mkMDName name) tyArgsMD (mkTupleT [ConT ''Base_md, imdApp])
return $ [dataDecl, mdDecl, imdDecl] ++ derivesData ++ derivesImd
where
tyArgs = map (PlainTV . mkName) args
tyArgsMD = map (PlainTV . mkName . (++"_md")) args
imdApp = foldl AppT (ConT (mkIMDName name)) (map (VarT . mkName . (++"_md")) args)
bs = case branches of
PUnion bnchs -> bnchs
PSwitch exp pbs -> [b | (p,b) <- pbs]
-- | Convert a Pads strictness annotation into the appropriate Haskell
-- strictness annotation in the template haskell Q monad for splicing.
mkStrict :: PadsStrict -> Q Strict
mkStrict NotStrict = bang noSourceUnpackedness noSourceStrictness -- i.e. notStrict
mkStrict IsStrict = bang noSourceUnpackedness sourceStrict -- i.e. isStrict
-- | Make the Haskell data type *constructor* (@'normalC'@ and @'recC'@) for the
-- given fragment of a Pads type (@'BranchInfo'@).
mkRepUnion :: BranchInfo -> ConQ
mkRepUnion (BConstr c args expM) = normalC (mkConstrName c) reps
where reps = [bangType (mkStrict strict) (return $ mkRepTy ty) | (strict,ty) <- args, hasRep ty]
mkRepUnion (BRecord c fields expM) = recC (mkConstrName c) lreps
where lreps = [ varBangType
(mkName l)
(bangType (mkStrict strict)
(return $ mkRepTy ty))
| (Just l,(strict,ty),_) <- fields, hasRep ty]
-- | Make the 'Con' metadata constructor definition for an individual branch of
-- a Pads type, which gets used to create the Haskell data type declaration for
-- the metadata of a Pads type.
mkMDUnion :: BranchInfo -> Q Con
mkMDUnion (BConstr c args expM) = normalC (mkConstrIMDName c) mds
where
mds = [bangType (mkStrict NotStrict) (return $ mkMDTy False ty) | (_,ty) <- args] --MD , hasRep ty]
mkMDUnion (BRecord c fields expM) = do
{ let lmds = [ do { fn <- genLabMDName "m" lM
; varBangType fn (bangType (mkStrict NotStrict) (return $ mkMDTy False ty))
}
| (lM,(_,ty),_) <- fields
]
; recC (mkConstrIMDName c) lmds
}
--MD lmds <- return [(mkFieldMDName l,NotStrict,mkMDTy ty) | (Just l,(_,ty),_) <- fields, hasRep ty]
-- | Make the type context of a data declaration, consisting of the typeclasses
-- instanced by Pads data types.
--derive :: [QString] -> CxtQ
derive :: [QString] -> DerivClauseQ
derive ds = derivClause Nothing $ map (conT . mkName . qName) ds
++ [conT $ mkName d | d<-["Show","Eq","Typeable","Data","Ord"], not (d `elem` map last ds)]
-------------------------------------------------------------------------------
-- * Generating Rep/MD Newtype Declarations
-- | Construct the newtype Haskell data declaration from a Pads type defined
-- using the "newtype" keyword.
mkNewRepMDDecl :: Derivation -> UString -> [LString] -> BranchInfo -> [QString] -> Q [Dec]
mkNewRepMDDecl derivation name args branch ds = do
imdDecl <- newtypeD (cxt []) (mkIMDName name) tyArgsMD Nothing (mkMDUnion branch) [derive []]
let ds' = map (conT . mkName . qName) ds
dataDecl <- newtypeD (cxt []) (mkRepName name) tyArgs Nothing (mkRepUnion branch) [derive ds]
--[derivClause Nothing ds']
derivesData <- derivation dataDecl
derivesImd <- derivation imdDecl
return $ [dataDecl, mdDecl, imdDecl] ++ derivesData ++ derivesImd
where
mdDecl = TySynD (mkMDName name) tyArgsMD (mkTupleT [ConT ''Base_md, imdApp])
tyArgs = map (PlainTV . mkName) args
tyArgsMD = map (PlainTV . mkName . (++"_md")) args
imdApp = foldl AppT (ConT (mkIMDName name)) (map (VarT . mkName . (++"_md")) args)
-------------------------------------------------------------------------------
-- * Generating MD Type from Obtain Declarations
-- Design decision not to do this.
-- | Construct the Haskell type synonym declaration for a Pads type declared
-- using the "obtain" keyword.
mkObtainMDDecl :: UString -> [UString] -> PadsTy -> [Dec]
mkObtainMDDecl name args ty
= [mdType]
where
mdType = TySynD (mkMDName name) tyArgsMD (mkMDTy False ty)
tyArgsMD = map (PlainTV . mkName . (++"_md")) args
-------------------------------------------------------------------------------
-- * Generating Representation Type of a Type Expression
-- | Make the template haskell 'Type' for the given 'PadsTy' pads type, to be
-- used anywhere in generated Haskell code where the representation type is
-- expected.
mkRepTy :: PadsTy -> Type
mkRepTy ty = case ty of
PPartition pty exp -> mkRepTy pty
PConstrain pat pty exp -> mkRepTy pty
PTransform tySrc tyDest exp -> mkRepTy tyDest
PList ty sep term -> ListT `AppT` mkRepTy ty
PValue exp pty -> mkRepTy pty
PApp tys expM -> foldl1 AppT [mkRepTy ty | ty <- tys, hasRep ty]
PTuple tys -> mkRepTuple tys
PExpression _ -> ConT ''()
PTycon c -> ConT (mkRepQName c)
PTyvar v -> VarT (mkName v)
-- | Make the template haskell 'Type' corresponding to a tuple consisting of the
-- given pads types given in list form at compile time '[PadsTy]'.
mkRepTuple :: [PadsTy] -> Type
mkRepTuple tys = case reps of
[] -> ConT ''()
[ty] -> ty
(t:ts) -> mkTupleT reps
where
reps = [mkRepTy ty | ty <- tys, hasRep ty]
-------------------------------------------------------------------------------
-- * Generating Meta-Data Representation of Type Expression
-- | Make the template haskell 'Type' corresponding to the externally visible
-- metadata of a given 'PadsTy'. The boolean indicates whether or not Pads type
-- variables 'PTyvar's should be put in a 'Meta' constructor or merely stuffed
-- into a 'VarT' and appended with "_md" postfix. Currently we always do the
-- latter (all calls to 'mkMDTy' give False as the boolean).
mkMDTy :: Bool -> PadsTy -> Type
mkMDTy isMeta ty = case ty of
PPartition pty exp -> mkMDTy isMeta pty
PConstrain pat pty exp -> mkMDTy isMeta pty
PTransform src dest exp -> mkMDTy isMeta dest
PList ty sep term -> mkTupleT [ConT ''Base_md, ListT `AppT` mkMDTy isMeta ty]
PValue exp pty -> mkMDTy isMeta pty
PApp tys expM -> foldl1 AppT [mkMDTy isMeta ty | ty <- tys] --MD , hasRep ty]
PTuple tys -> mkMDTuple isMeta tys
PExpression _ -> ConT ''Base_md
PTycon c -> ConT (mkMDQName c)
PTyvar v -> if isMeta
then AppT (ConT ''Meta) (VarT $ mkName v)
else VarT (mkName $ v ++ "_md")
-- | Make the template haskell 'Type' corresponding to a Haskell tuple type
-- consisting of the metadata types for the given Pads types '[PadsTy]'.
mkMDTuple :: Bool -> [PadsTy] -> Type
mkMDTuple isMeta tys = case mds of
[] -> ConT ''Base_md
[m] -> mkTupleT [ConT ''Base_md, m]
(m:ms) -> mkTupleT [ConT ''Base_md, mkTupleT mds]
where
mds = [mkMDTy isMeta ty | ty <- tys] --MD , hasRep ty]
-------------------------------------------------------------------------------
-- * Generating Instance Declarations from Data / New Declarations
-- | Make the following instance and type instance declarations for a Pads data
-- type and new type declaration:
--
-- > [pads| data Foo (Bar1, Bar2, Bar3) = Foo
-- > { i1 :: Bar1
-- > , i2 :: Bar2 i1
-- > , i3 :: Bar3 i2
-- > } |]
--
-- > instance Pads1 (Bar1, Bar2, Bar3) Foo Foo_md where
-- > parsePP1 = foo_parseM
-- > printFL1 = foo_printFL
-- > def1 = foo_def
-- > type instance Meta Foo = Foo_md
-- > type instance PadsArg Foo = (Bar1, Bar2, Bar3)
mkPadsInstance :: UString -> [LString] -> Maybe Type -> [Dec]
mkPadsInstance str args mb@(Nothing)
= buildInst mb str args (ConT ''Pads1 `AppT` TupleT 0)
mkPadsInstance str args mb@(Just ety)
= buildInst mb str args (ConT ''Pads1 `AppT` ety)
-- | See 'mkPadsInstance' above.
buildInst mb str args pads =
[ InstanceD Nothing ctx inst [parsePP_method, printFL_method,def_method]
, TySynInstD ''Meta $ TySynEqn [ty_name] meta_ty
, TySynInstD ''PadsArg $ TySynEqn [ty_name] arg_ty
]
where
arg_ty = case mb of
Nothing -> TupleT 0
Just ety -> ety
mbarg = case mb of
Nothing -> [TupP []]
Just _ -> []
inst = applyT [pads, ty_name, md_ty]
ty_name = applyT (ConT (mkName str) : map fst argpairs)
md_ty = applyT (ConT (mkMDName str) : map snd argpairs)
meta_ty = applyT (ConT (mkMDName str) : metas)
parsePP_method = FunD 'parsePP1 [Clause mbarg (NormalB (applyE (VarE (mkTyParserName str) : [VarE 'parsePP | a <- args]))) []]
printFL_method =
if str == "Entry"
then FunD 'printFL1 [Clause mbarg (NormalB $ VarE $ mkName "undefined") []]
else FunD 'printFL1 [Clause mbarg (NormalB (applyE (VarE (mkTyPrinterName str) : [VarE 'printFL | a <- args]))) []]
def_method = FunD 'def1 [Clause mbarg (NormalB (applyE (VarE (mkTyDefName str) : [VarE 'def | a <- args]))) []]
argpair n = (VarT (mkName n),VarT (mkName $ n++"_md"))
meta n = AppT (ConT ''Meta) (VarT $ mkName n)
argpairs = [argpair a | a <- args]
metas = map meta args
argtyvars = concat [[PlainTV (mkName a), PlainTV (mkName (a++"_md"))] | a <- args]
ctx = [AppT (AppT (ConT ''Pads) r) m | (r,m) <- argpairs]
padsprinter t t_md = AppT (ConT ''PadsPrinter) $ appT2 (TupleT 2) t t_md
printer = case mb of
Nothing -> padsprinter ty_name md_ty
Just ety -> appT2 ArrowT ety (padsprinter ty_name md_ty)
-- | Make the following type signatures, applicable for all the forms of a Pads
-- declaration:
--
-- > foo_printFL :: (Bar1, Bar2, Bar3) -> PadsPrinter (Foo, Foo_md)
-- > foo_def :: (Bar1, Bar2, Bar3) -> Foo
--
-- See 'mkPadsInstance' above for the definition of the Pads type "Foo".
mkPadsSignature :: UString -> [LString] -> Maybe Type -> [Dec]
mkPadsSignature str args mb@(Nothing)
= buildSignature mb str args (ConT ''Pads)
mkPadsSignature str args mb@(Just ety)
= buildSignature mb str args (ConT ''Pads1 `AppT` ety)
-- | See 'mkPadsSignature' above.
buildSignature mb str args pads =
if str == "Entry"
then [def_signature]
else [printFL_signature,def_signature]
where
mbarg = case mb of
Nothing -> [TupP []]
Just _ -> []
inst = applyT [pads, ty_name, md_ty]
ty_name = applyT (ConT (mkName str) : map (\(x,y,z) -> y) argpairs)
md_ty = applyT (ConT (mkMDName str) : map (\(x,y,z) -> z) argpairs)
meta_ty = applyT (ConT (mkMDName str) : metas)
argpair n = (VarT (mkName $ n++"_arg"),VarT (mkName n),VarT (mkName $ n++"_md"))
meta n = AppT (ConT ''Meta) (VarT $ mkName n)
argpairs = [argpair a | a <- args]
metas = map meta args
argtyvars = concat [[PlainTV (mkName (a++"_arg")),PlainTV (mkName a), PlainTV (mkName (a++"_md"))] | a <- args]
printerctx = concat $ [[AppT (ConT ''Data) r, AppT (ConT ''Data) m] | (arg,r,m) <- argpairs]
defctx = concat $ [[AppT (ConT ''Data) r] | (arg,r,m) <- argpairs]
padsprinter t t_md = AppT (ConT ''PadsPrinter) $ appT2 (TupleT 2) t t_md
padsdef t t_md = t
printer = case mb of
Nothing -> padsprinter ty_name md_ty
Just ety -> appT2 ArrowT ety (padsprinter ty_name md_ty)
def = case mb of
Nothing -> padsdef ty_name md_ty
Just ety -> appT2 ArrowT ety (padsdef ty_name md_ty)
printFL_signature = SigD (mkTyPrinterName str) $ ForallT argtyvars printerctx $ foldr (\a t -> let (a_arg,a_rep,a_md) = argpair a in appT2 ArrowT (padsprinter a_rep a_md) t) printer args
def_signature = SigD (mkTyDefName str) $ ForallT argtyvars defctx $ foldr (\a t -> let (a_arg,a_rep,a_md) = argpair a in appT2 ArrowT (padsdef a_rep a_md) t) def args
-------------------------------------------------------------------------------
-- * Generating Parser Declaration from Type / Data / New Declarations
-- | Construct the function body and resulting declaration of the "_parseM"
-- function for a given 'PadsTy' type declaration.
genPadsParseM :: UString -> [LString] -> Maybe Pat -> PadsTy -> Q [Dec]
genPadsParseM name args patM padsTy = do
let body = genParseTy padsTy
mkParserFunction name args patM body
-- | 'PadsData' data declaration flavour of the "_parseM" function.
genPadsDataParseM :: UString -> [LString] -> (Maybe Pat) -> PadsData -> Q [Dec]
genPadsDataParseM name args patM padsData = do
let body = genParseData padsData
mkParserFunction name args patM body
-- | 'BranchInfo' new type declaration flavour of the "_parseM" function.
genPadsNewParseM :: UString -> [LString] -> (Maybe Pat) -> BranchInfo -> Q [Dec]
genPadsNewParseM name args patM branch = do
(dec,exp) <- genParseBranchInfo branch
let body = letE [return dec] (return exp)
mkParserFunction name args patM body
-- | Pads Obtain declaration flavour of the "_parseM" function.
genPadsObtainParseM :: UString -> [LString] -> PadsTy -> Exp -> Q [Dec]
genPadsObtainParseM name args padsTy exp = do
let body = genParseTy (PTransform padsTy (PTycon [name]) exp)
mkParserFunction name args Nothing body
-- | Construct the declaration for a function which monadically parses a Pads
-- type given the body of the function as input.
mkParserFunction :: UString -> [LString] -> Maybe Pat -> Q Exp -> Q [Dec]
mkParserFunction name args patM body
= sequence $ if name == "Entry" then [sig,fun] else [fun]
where
fun = funD parserName [clause parserArgs (normalB body) []]
sig = sigD parserName [t| PadsParser ($(conT $ mkConstrName name), (Base_md, $(conT $ mkConstrIMDName name))) |]
parserName = mkTyParserName name
parserArgs = map (varP . mkVarParserName) args ++ Maybe.maybeToList (return <$> patM)
-------------------------------------------------------------------------------
-- * Generating String-Parser Declaration
-- | Construct the "_parseS" function at compile time such that it makes a call
-- to 'parseStringInput' at runtime.
genPadsParseS :: UString -> [LString] -> Maybe Pat -> Q [Dec]
genPadsParseS name args patM = do
{ body <- [| parseStringInput $(return parserWithArgs) |]
; return [ FunD (mkTyParserSName name) [Clause parserArgs (NormalB body) []] ]
}
where
parserWithArgs = foldl1 AppE (VarE parserName : map patToExp parserArgs)
parserName = mkTyParserName name
parserArgs = map (VarP . mkVarParserName) args ++ Maybe.maybeToList patM
-------------------------------------------------------------------------------
-- * Generating Parser from Type Expression
-- | This function only ever gets called at compile time in order to construct a
-- template haskell expression to be used somewhere in the body of a "_parseM"
-- function. This expression is the meat of the pads-haskell parsing algorithm
-- and semantics - we use metaprogramming to map the Pads syntax onto
-- expressions which return a tuple consisting of the parsed representation
-- followed by the metadata (with parse errors).
genParseTy :: PadsTy -> Q Exp
genParseTy pty = case pty of
PConstrain pat ty exp -> genParseConstrain (return pat) ty (return exp)
PTransform src dest exp -> genParseTyTrans src dest (return exp)
PList ty sep term -> genParseList ty sep term
PPartition ty exp -> genParsePartition ty exp
PValue exp ty -> genParseValue exp
PApp tys argE -> genParseTyApp tys argE
PTuple tys -> genParseTuple tys
PExpression exp -> genParseExp exp
PTycon c -> return $ mkParseTycon c
PTyvar v -> return $ mkParseTyvar v
-- | Simply generate a call to the runtime system function 'parseConstraint'
-- where the first argument is a Haskell expression spliced directly into the
-- call to 'parseConstraint' which parses the thing being constrained and the
-- second argument is the (Haskell) predicate function used to constrain the
-- Pads type.
genParseConstrain :: Q Pat -> PadsTy -> Q Exp -> Q Exp
genParseConstrain patQ ty expQ = [| parseConstraint $(genParseTy ty) $pred |]
where
pred = lamE [patQ, varP (mkName "md")] expQ
-- | Simply generate a call to the runtime system function 'parseTransform'
-- where the first argument is the spliced-in-place parser for the "source" Pads
-- type being transformed and the second argument is the (Haskell)
-- transformation function for producing something of the desired destination
-- type. Note that we can ignore the destination 'PadsTy' at compile time in
-- *this* function because the Haskell type checker will type check the result
-- of 'parseTransform' for us.
genParseTyTrans :: PadsTy -> PadsTy -> Q Exp -> Q Exp
genParseTyTrans src dest expQ
= [| parseTransform $(genParseTy src) (fst $expQ) |]
-- | This compile time function figures out which runtime system support
-- function to generate a call to for parsing a Pads list type based on the
-- given separator Pads type and the desired termination condition 'TermCond'.
genParseList :: PadsTy -> (Maybe PadsTy) -> (Maybe TermCond) -> Q Exp
genParseList ty sep term =
case (sep,term) of
(Nothing, Nothing) -> [| parseListNoSepNoTerm $(genParseTy ty) |]
(Just sep, Nothing) -> [| parseListSepNoTerm $(genParseTy sep) $(genParseTy ty) |]
(Nothing, Just (LLen lenE)) -> [| parseListNoSepLength $(return lenE) $(genParseTy ty) |]
(Just sep, Just (LLen lenE)) -> [| parseListSepLength $(genParseTy sep) $(return lenE) $(genParseTy ty) |]
(Nothing, Just (LTerm term))-> [| parseListNoSepTerm $(genParseTy term) $(genParseTy ty) |]
(Just sep, Just (LTerm term))-> [| parseListSepTerm $(genParseTy sep) $(genParseTy term) $(genParseTy ty) |]
-- | Simply generate a call to the runtime system function 'parsePartition'
-- where the first argument is an expression for parsing the 'PadsTy' pads type
-- we're partitioning on and the second argument is the Haskell expression given
-- in the Pads syntactic form specifying the record discipline with which to
-- partition things. For example the following code:
--
-- > type Foo = (partition [Bar] using none)
--
-- declares a type Foo which is a list of Bars where Bars are separated by
-- nothing.
genParsePartition :: PadsTy -> Exp -> Q Exp
genParsePartition ty disc = [| parsePartition $(genParseTy ty) $(return disc) |]
-- | This compile time function generates code which wraps a Pads Value type's
-- Haskell expression in the appropriate type to be returned for use in the pads
-- parsing monad, namely of type 'PadsParser (rep, md)' where rep and md are the
-- representation and metadata type variables.
genParseValue :: Exp -> Q Exp
genParseValue exp = [| return ($(return exp), cleanBasePD) |]
--genParseValue exp = return $ AppE (VarE 'return) (TupE [exp,VarE 'cleanBasePD])
-- | Construct the sequentially-defined parser for a Pads tuple type.
genParseTuple :: [PadsTy] -> Q Exp
genParseTuple [] = [| return ((), cleanBasePD) |]
genParseTuple tys = do
f_rep_name <- newName "f_rep"
f_md_name <- newName "f_md"
let f_rep = buildF_rep f_rep_name vars_frep
f_rep_sig = buildF_rep_sig f_rep_name sigs_frep
f_md = buildF_md f_md_name vars_fmd
f_md_sig <- buildF_md_sig f_md_name tys
body <- foldl parseNext [| return ($(dyn "f_rep"),$(dyn "f_md")) |] tys
return (LetE [f_rep_sig,f_rep,f_md_sig,f_md] body)
where
vars_frep = [v | (v,t) <- zip vars_fmd tys, hasRep t]
sigs_frep = [t | t <- tys, hasRep t]
vars_fmd = [ mkName ("x"++show n) | n <- [1 .. length tys]]
-- | Glom the generated parser for the given 'PadsTy' onto the given parser
-- using the '=@=' and '=@' runtime system operators.
parseNext :: Q Exp -> PadsTy -> Q Exp
parseNext prog t
| hasRep t = [| $prog =@= $(genParseTy t) |]
| otherwise = [| $prog =@ $(genParseTy t) |]
-- | Construct the "f_rep" let-bound function inside of a Pads tuple type for
-- uncurrying the result of parsing the tuple sequentially at runtime. The
-- "f_rep" function generated by *this* function gets passed into the '=@=' and
-- '=@' runtime system operators which call f_rep on the result of parsing each
-- of the members of the tuple.
buildF_rep :: Name -> [Name] -> Dec
buildF_rep name vars_frep
= FunD name [Clause
(map VarP vars_frep) (NormalB (TupE (map VarE vars_frep))) [] ]
isVarT (VarT _) = True
isVarT _ = False
buildF_md_sig :: Name -> [PadsTy] -> Q Dec
buildF_md_sig name ptys = do
let tys = map (mkMDTy False) ptys
mdRet = foldl AppT (TupleT $ length tys) tys
retTy <- [t| (Base_md, $(return mdRet)) |]
let sigTy = foldr1 (appT2 ArrowT) (tys ++ [retTy])
varTs = filter isVarT tys
varTNames = map (\(VarT t) -> PlainTV t) varTs
sigT' = ForallT varTNames (map (AppT (ConT ''PadsMD)) varTs) sigTy
return (case tys of
[] -> SigD name $ TupleT 0
(t:[]) -> SigD name $ appT2 ArrowT t t
_ -> SigD name $ sigT')
-- | Same as 'buildF_rep' above but for the metadata instead of the parse
-- representation. In this case we need to pull off just the 'Base_md' from the
-- metadata resulting from whatever the parser returned to us for each of the
-- tuple results using the 'get_md_header' type class function provided by the
-- runtime system.
buildF_md :: Name -> [Name] -> Dec
buildF_md f_md_name vars_fmd
= FunD f_md_name [Clause (map VarP vars_fmd) (NormalB body) []]
where
mdHeaders = [ VarE 'get_md_header `AppE` VarE xi | xi <- vars_fmd ]
body = TupE [mkMergeBaseMDs mdHeaders, TupE (map VarE vars_fmd)]
buildF_rep_sig :: Name -> [PadsTy] -> Dec
buildF_rep_sig name ptys = let
tys = map mkRepTy ptys
retTy = foldl AppT (TupleT $ length tys) tys
sigTy = foldr1 (appT2 ArrowT) (tys ++ [retTy])
in (case tys of
[] -> SigD name $ TupleT 0
(t:[]) -> SigD name $ appT2 ArrowT t t
_ -> SigD name $ sigTy)
-- | Generate a call to 'mergeBaseMDs'
mkMergeBaseMDs :: [Exp] -> Exp
mkMergeBaseMDs [e] = e
mkMergeBaseMDs es = VarE 'mergeBaseMDs `AppE` ListE es
-- | Construct a call to the 'litParse' runtime system type class function so
-- that we can parse a literal (Haskell) expression. The type of the expression
-- provided as a Haskell expression must be Literally Parseable ('LitParse' type
-- class), otherwise the code generated by *this* compile time function produces
-- a type error.
genParseExp :: Exp -> Q Exp
genParseExp exp = [| litParse $(return exp) |]
-- | Generate the parser for a Pads type application.
genParseTyApp :: [PadsTy] -> Maybe Exp -> Q Exp
genParseTyApp tys expM = do
fs <- mapM genParseTy tys
return (foldl1 AppE (fs ++ Maybe.maybeToList expM))
-- | Make the parser for a Pads type constructor - just return it as a Haskell
-- variable expression.
mkParseTycon :: QString -> Exp
mkParseTycon ["EOF"] = VarE 'eof_parseM
mkParseTycon ["EOR"] = VarE 'eor_parseM
mkParseTycon c = VarE (mkTyParserQName c)
-- | Make the parser for a Pads type variable - just return it as a Haskell
-- variable expression.
mkParseTyvar :: String -> Exp
mkParseTyvar v = VarE (mkVarParserName v) -- should gensym these, but probably ok
-------------------------------------------------------------------------------
-- * Generating Parsers from Union/Switch Expressions
-- | A data declaration in pads is either a union or a switch expression -
-- generate the template haskell for parsing them.
genParseData :: PadsData -> Q Exp
genParseData (PUnion bs) = genParseUnion bs
genParseData (PSwitch exp pbs) = genParseSwitch exp pbs
-- | Generate the template haskell for parsing a Pads union expression. Namely
-- generate the metadata constructors for each of the branches of the union and
-- stuff them into let-bound functions so that nested parsers have them in
-- scope. Then generate a call to the runtime system function 'choiceP' for
-- choosing among the different parsers.
genParseUnion :: [BranchInfo] -> Q Exp
genParseUnion bs = do
{ (decs,bodies) <- fmap unzip $ mapM genParseBranchInfo bs
; let body = case bodies of
[b] -> b
bs -> (VarE 'choiceP) `AppE` (ListE bs)
; return (LetE decs body)
}
-- | Generate the template haskell case expression from a Pads switch type. This
-- is almost entirely just matching the syntax of a Pads case onto the syntax of
-- a Haskell case expression. Semantically the case just figures out which
-- parser needs to be run by pattern matching on something already parsed from
-- the input.
genParseSwitch :: Exp -> [(Pat,BranchInfo)] -> Q Exp
genParseSwitch exp pbs = do
let (ps,bs) = unzip pbs
(decs,bodies) <- fmap unzip $ mapM genParseBranchInfo bs
let body = CaseE exp [Match p (NormalB b) [] | (p,b) <- zip ps bodies]
return (LetE decs body)
-- | Generate the parser for an individual branch of a Pads new type, Pads
-- union, or Pads switch.
genParseBranchInfo :: BranchInfo -> Q (Dec,Exp)
genParseBranchInfo (BRecord c fields pred) = genParseRecord c fields pred
genParseBranchInfo (BConstr c args pred) = do
{ body <- foldl parseNext [| return ($(conE (mkConstrName c)),$(varE (mkfnMDName c))) |] tys
; return (con_md, body)
}
where
tys = [ty | (strict,ty) <- args]
con_md = buildConstr_md (mkfnMDName c) (ConE (mkConstrIMDName c)) tys
-- | Build the constructor function for tupling together the metadata results of
-- parsing a bunch of Pads types.
buildConstr_md :: Name -> Exp -> [PadsTy] -> Dec
buildConstr_md fnMD conMD tys
= FunD fnMD [Clause (map VarP vars_fmd) (NormalB body) []]
where
vars_fmd = [ mkName ("x"++show n) | n <- [1 .. length tys]]
mdHeaders = [ VarE 'get_md_header `AppE` VarE xi | xi <- vars_fmd ]
body = TupE [mkMergeBaseMDs mdHeaders, applyE (conMD : map VarE vars_conmd)]
vars_conmd = vars_fmd --MD [v | (v,t) <- zip vars_fmd tys, hasRep t]
-------------------------------------------------------------------------------
-- * Generating Parsers from Record Expressions
-- | Generate the template haskell code for parsing a Pads record.
genParseRecord :: UString -> [FieldInfo] -> (Maybe Exp) -> Q (Dec,Exp)
genParseRecord c fields pred = do
c_md <- newName (strToLower c)
let con_md = buildConstr_md c_md (ConE (mkConstrIMDName c))
[ty | (_,(_,ty),_) <- fields]
labMDs <- sequence [genLabMDName "x" l | (l,(_,_),_) <- fields]
let fnMDLabs = applyE $ map VarE (c_md : labMDs)
doStmts <- sequence $ [genParseField f xn | (f,xn) <- zip fields labMDs]
let labs = [mkName lab | (Just lab,(_,ty),_) <- fields, hasRep ty]
let conLabs = applyE (ConE (mkConstrName c) : map VarE labs)
returnStmt <- [| return ($(return conLabs),$(return fnMDLabs)) |]
return (con_md, DoE (concat doStmts ++ [NoBindS returnStmt]))
-- | Generate the name (label?) for the metadata of a field in a record.
genLabMDName :: String -> Maybe String -> Q Name
genLabMDName s (Just lab) = return (mkFieldMDName lab)
genLabMDName s Nothing = liftM mangleName (newName s)
-- | Generate the parser for a field of a Pads record.
genParseField :: FieldInfo -> Name -> Q [Stmt]
genParseField (labM, (strict, ty), expM) xn = do
let parseTy = (case expM of
Nothing -> genParseTy ty
Just exp -> genParseRecConstrain labP (varP xn) ty (return exp))
sequence $
[ bindS (tupP [labP, varP xn]) parseTy
]
where
labP = case labM of
Just lab -> varP (mkName lab)
Nothing -> wildP
-- | Generate the parser for a constrained field on a record.
genParseRecConstrain :: Q Pat -> Q Pat -> PadsTy -> Q Exp -> Q Exp
genParseRecConstrain labP xnP ty exp = [| parseConstraint $(genParseTy ty) $pred |]
where
pred = lamE [labP, xnP] exp
-------------------------------------------------------------------------------
-- Generating Printing Function from a Declaration
-- | Generate the lazy "function list" printer for a given 'PadsTy' Pads type as
-- parsed using Pads' plain-type syntactic form..
genPadsPrintFL :: UString -> [LString] -> Maybe Pat -> PadsTy -> Q [Dec]
genPadsPrintFL name args patM padsTy = do
let rm = [mkName "rep", mkName "md"]
body <- genPrintTy padsTy $ Just $ TupE (map VarE rm)
return [mkPrinterFunction name args rm patM body]
-- | Generate the lazy function list printer for the Pads data-type syntactic
-- form.
genPadsDataPrintFL :: UString -> [LString] -> Maybe Pat -> PadsData -> Q [Dec]
genPadsDataPrintFL name args patM padsData = do
let rm = [mkName "rep", mkName "md"]
body <- genPrintData padsData $ Just $ TupE (map VarE rm)
return [mkPrinterFunction name args rm patM body]
-- | Generate the lazy function list printer for the Pads newtype syntactic form.
genPadsNewPrintFL :: UString -> [LString] -> Maybe Pat -> BranchInfo -> Q [Dec]
genPadsNewPrintFL name args patM branch = do
let rm = [mkName "rep", mkName "md"]
matches <- genPrintBranchInfo False branch
let body = CaseE (TupE (map VarE rm)) matches
return [mkPrinterFunction name args rm patM body]
-- | Generate the lazy function list printer for the Pads obtain syntactic form.
genPadsObtainPrintFL :: UString -> [LString] -> PadsTy -> Exp -> Q [Dec]
genPadsObtainPrintFL name args padsTy exp = do
let rm = [mkName "rep", mkName "md"]
body <- genPrintTy (PTransform padsTy (PTycon [name]) exp) $ Just $ TupE (map VarE rm)
return [mkPrinterFunction name args rm Nothing body]
-- | Make the function declaration for the "lazy function list" printer with the
-- body as generated by 'genPrintTy', 'genPrintData', or 'genPrintBranchInfo' as
-- passed into this function as the last 'Exp' parameter.
mkPrinterFunction :: UString -> [LString] -> [Name] -> Maybe Pat -> Exp -> Dec
mkPrinterFunction name args rm patM body =
FunD printerName [Clause (printerArgs ++ [TupP (map VarP rm)]) (NormalB body) []]
where
printerName = mkTyPrinterName name
printerArgs = map (VarP . mkTyPrinterVarName) args ++ Maybe.maybeToList patM
-------------------------------------------------------------------------------
-- * Generate Printing Function from a Type
-- | Generate the body of the printing function for a Pads type - this function
-- dispatches to the ones below according to the syntactic form being
-- translated.
genPrintTy :: PadsTy -> Maybe Exp -> Q Exp
genPrintTy (PConstrain pat ty exp) rm = genPrintTy ty rm -- XXX: doesn't check the constraint; ideally we should change @printFL@ to account for possible printing errors
genPrintTy (PTransform src dest exp) rm = genPrintTrans src exp rm
genPrintTy (PList ty sepM termM) rm = genPrintList ty sepM termM >>= applyPrintTy rm
genPrintTy (PPartition ty exp) rm = [| (error "genPrintTy PPartition not implemented") |] --genPrintPartition ty exp rm
genPrintTy (PApp tys expM) rm = genPrintTyApp tys expM >>= applyPrintTy rm
genPrintTy (PTuple tys) rm = genPrintTuple tys rm
genPrintTy (PExpression exp) rm = genPrintExp exp rm
genPrintTy (PTycon c) rm = genPrintTycon c >>= applyPrintTy rm
genPrintTy (PTyvar v) rm = genPrintTyVar v >>= applyPrintTy rm
genPrintTy (PValue exp ty) rm = genPrintValue exp rm
-- | Generate the printer for the Pads Value syntactic form 'PValue'. Because a
-- pads value is something that wasn't parsed (it's a way to compute / add an extra
-- field to a parsed Haskell record), we just return the 'nil' printer (prints
-- nothing).
genPrintValue :: Exp -> Maybe Exp -> Q Exp
genPrintValue exp rm = return $ VarE 'nil
-- | Generate the printer for the Pads Transform syntactic form 'PTransform'.
-- This means we need to grab the second function from the tuple provided by the
-- Pads programmer which corresponds to the inverse of the transform function,
-- and print the format of the resulting (source) type. Source here means what's
-- read from a file and destination type means the type for which we have a
-- value that we want to print out. In order for round-trip parsing to work, we
-- need to reverse the transformation because the on-disk format of the source
-- type is usually different from the on-disk format of the destination type.
genPrintTrans :: PadsTy -> Exp -> Maybe Exp -> Q Exp
genPrintTrans tySrc exp Nothing
= genPrintTy tySrc Nothing
genPrintTrans tySrc (TupE [_, fncn]) (Just rm) = do
rm' <- [| $(return fncn) $(return rm) |]
genPrintTy tySrc (Just rm')
genPrintTrans _ tup _ = error ("Template Haskell exp '" ++ show tup ++ "' does not appear to be a two-tuple.")
-- | Some of the printing utilities provided by the runtime system need to know
-- about the representation and the metadata. If the first argument to this
-- function is Nothing, then we don't need to pass the representation and
-- metadata to the expression / utility (e.g. ca case expression printing a
-- union type). Otherwise the first argument contains 'Just' the '(rep, md)'
-- tuple brought into scope as the first parameter to the "*_printFL" functions
-- (e.g. the 'printList' runtime system function needs to know about the rep and
-- md).
applyPrintTy :: Maybe Exp -> Exp -> Q Exp
applyPrintTy rm f = do
case rm of
Nothing -> return f
Just repmdE -> return $ AppE f repmdE
-- | Generate the template haskell code for printing a 'PList' Pads type.
genPrintList :: PadsTy -> Maybe PadsTy -> Maybe TermCond -> Q Exp
genPrintList ty sepOpt termCondOpt = do
(elemRepE, elemRepP) <- doGenPE "elemrep"
(elemMDE, elemMDP) <- doGenPE "elemmd"
parseElemE <- genPrintTy ty $ Just $ TupE [elemRepE,elemMDE]
let parseElemFnE = LamE [TupP [elemRepP, elemMDP]] parseElemE
sepElemE <- case sepOpt of
Nothing -> return (VarE 'printNothing)
Just ty -> do
def <- genDefTy ty
genPrintTy ty $ Just $ TupE [SigE def (mkRepTy ty),SigE (VarE 'myempty) (mkMDTy False ty)]
termElemE <- case termCondOpt of
Nothing -> return (VarE 'printNothing)
Just (LLen _) -> return (VarE 'printNothing)
Just (LTerm (PApp [PTycon ["Try"],_] _)) -> return (VarE 'printNothing)
Just (LTerm (PTuple [PApp [PTycon ["Try"],_] _])) -> return (VarE 'printNothing)
Just (LTerm termTy) -> do
def <- genDefTy termTy
genPrintTy termTy $ Just $ TupE [SigE def (mkRepTy termTy),SigE (VarE 'myempty) (mkMDTy False termTy)]
return $ appE3 (VarE 'printList) parseElemFnE sepElemE termElemE
-- | Generate the template haskell code for printing a Pads type application by
-- recursively calling 'genPrintTy' on the Pads types of each of the arguments to the
-- Pads type constructor.
genPrintTyApp :: [PadsTy] -> Maybe Exp -> Q Exp
genPrintTyApp tys expM = do
prtys <- mapM (flip genPrintTy Nothing) tys
foldl1M (\e1 e2 -> return $ AppE e1 e2) (prtys ++ Maybe.maybeToList expM)
-- | Generate the template haskell code for printing a Pads tuple type.
genPrintTuple :: [PadsTy] -> Maybe Exp -> Q Exp
genPrintTuple tys (Just rm) = do
repNamesM <- genNamesforTuple True "rep" tys
let repVars = map VarE (Maybe.catMaybes repNamesM)
let repPats = map VarP (Maybe.catMaybes repNamesM)
mdNamesM <- genNamesforTuple False "md" tys
let mdVars = map VarE (Maybe.catMaybes mdNamesM)
let mdPats = map VarP (Maybe.catMaybes mdNamesM)
inners <- sequence [genPrintTupleInner t r m | (t,r,m) <- zip3 tys repNamesM mdNamesM{-, hasRep t-}]
return $ CaseE rm
[Match (TupP [TupP $ repPats, TupP [SigP WildP (ConT ''Base_md), (TupP mdPats)]])
(NormalB (VarE 'concatFL `AppE` ListE inners))
[]]
genPrintTuple tys Nothing = do
repName <- newName "rep"
mdName <- newName "md"
liftM (LamE [TupP [VarP repName,VarP mdName]]) $ genPrintTuple tys $ Just $ TupE [VarE repName,VarE mdName]
-- | Filters a second list based on which corresponding Pads types from the
-- first list have an underlying representation in memory (removing the ones
-- that don't have an underlying representation).
filterByHasRep :: [PadsTy] -> [a] -> [a]
filterByHasRep tys xs = map snd $ filter (hasRep . fst) (zip tys xs)
-- | Generate a list of names to be used as Haskell pattern variables and
-- expression variables for a Pads tuple type. If the tuple is for the
-- representation then the given 'Bool' is True and we want to ignore data that
-- doesn't have a representation in memory. Otherwise the tuple is for the
-- metadata meaning the given 'Bool' is False and we want to print *everything*.
genNamesforTuple :: Bool -> String -> [PadsTy] -> Q [Maybe Name]
genNamesforTuple False str tys = sequence [fmap Just (newName str) | ty <- tys]
genNamesforTuple True str tys = sequence [if hasRep ty then fmap Just (newName str) else return Nothing | ty <- tys]
-- | Generate the template haskell print function for some type inside of a
-- tuple based on whether or not that type has an in-memory representation
-- '(Just r)' and a metadata representation '(Just m)'.
genPrintTupleInner t (Just r) (Just m) = genPrintTy t (Just (TupE [VarE r,VarE m]))
genPrintTupleInner t Nothing (Just m) = genDefTy t >>= \def -> genPrintTy t (Just (TupE [def, VarE m]))
genPrintTupleInner t Nothing Nothing = genPrintTy t Nothing
genPrintTupleInner t (Just r) Nothing = error ("genPrintTupleInner: Type '" ++ show t
++ "' has a representation but no metadata.")
-- | Generate the template haskell code for printing the value of a Pads literal
-- (string, character, regex) by simply constructing a runtime system call to
-- 'litPrint' with the code for computing the Haskell value of the literal
-- spliced into the first argument position.
genPrintExp :: Exp -> Maybe Exp -> Q Exp
genPrintExp e _ = [| litPrint $(return e) |]
-- | Generate the printer for a Pads type constructor (hint: it's just the
-- variable name according to 'mkTyPrinterQName'.
genPrintTycon :: QString -> Q Exp
genPrintTycon c = return $ VarE (mkTyPrinterQName c)
-- | Generate the printing expression for a Pads type variable according to
-- 'mkTyPrinterVarName'.
genPrintTyVar :: LString -> Q Exp
genPrintTyVar v = return $ VarE (mkTyPrinterVarName v)
-------------------------------------------------------------------------------
-- Generate Printing Function from a Datatype
-- | Generate the template haskell expression for printing a Haskell value given
-- the Pads data type declaration defining the type of the Haskell value.
genPrintData :: PadsData -> Maybe Exp -> Q Exp
genPrintData (PUnion bs) rm = genPrintUnion bs rm
genPrintData (PSwitch exp pbs) rm = genPrintSwitch exp pbs rm
-- | Generate a Haskell case expression for printing a Pads union type.
genPrintUnion :: [BranchInfo] -> Maybe Exp -> Q Exp
genPrintUnion bs (Just rm) = do
let doDef = if length bs > 1 then True else False
matches <- liftM concat $ mapM (genPrintBranchInfo doDef) bs
return $ CaseE rm matches
genPrintUnion bs Nothing = do
repName <- newName "rep"
mdName <- newName "md"
let doDef = if length bs > 1 then True else False
matches <- liftM concat $ mapM (genPrintBranchInfo doDef) bs
return $ LamE [TupP [VarP repName,VarP mdName]] $ CaseE (TupE [VarE repName,VarE mdName]) matches
-- | Generate the printing function body of an individual branch of a Pads data type.
genPrintBranchInfo :: Bool -> BranchInfo -> Q [Match]
genPrintBranchInfo doDef (BRecord c fields predM) = genPrintRecord c fields predM
genPrintBranchInfo doDef (BConstr c args predM) = genPrintConstr doDef c args predM
-- | Generate the individual 'Match' of the Haskell case expression for matching
-- on a record being printed.
genPrintRecord :: UString -> [FieldInfo] -> Maybe Exp -> Q [Match]
genPrintRecord (mkName -> recName) fields predM = do
(repEs, repPs) <- getPEforFields (\t -> genDefTy t >>= \def -> return $ SigE def (mkRepTy t)) (return . getBranchNameL) fields
(mdEs, mdPs) <- getPEforFields (return . SigE (VarE 'myempty) . mkMDTy False) (return . getBranchMDNameL) fields
let ptys = map (\(n,(_,ty),p) -> ty) fields
let ty_rep_mds = zip3 ptys repEs mdEs
expE <- mapM (\(ty,r,m) -> genPrintTy ty $ Just $ TupE [r,m]) ty_rep_mds
let printItemsE = ListE expE
let caseBody = NormalB (AppE (VarE 'concatFL) printItemsE)
let mdPat = TupP[WildP, RecP (getStructInnerMDName recName) mdPs]
let repPat = RecP recName repPs
let casePat = TupP [repPat, mdPat]
let match = Match casePat caseBody []
return [match]
-- | Get the printer expression for an individual field of a record.
getPEforField :: (PadsTy -> Q Exp) -> (String -> Q Name) -> FieldInfo -> Q (Exp, Maybe FieldPat)
getPEforField def mkFieldNm (nameOpt, (strict,pty), optPred) = case nameOpt of
Nothing -> def pty >>= \d -> return (d,Nothing)
Just str -> do
name <- mkFieldNm str
let (varE, varP) = genPE name
return (varE, Just (name, varP))
-- | Get the printer expressions and corresponding record field pattern
-- matches for each of the given 'FieldInfo's.
getPEforFields :: (PadsTy -> Q Exp) -> (String -> Q Name) -> [FieldInfo] -> Q ([Exp], [FieldPat])
getPEforFields def mkFieldNm fields = do
eps <- mapM (getPEforField def mkFieldNm) fields
let (es, pOpts) = List.unzip eps
ps = Maybe.catMaybes pOpts
return (es, ps)
-- | Generate the template haskell code for matching on and printing the value
-- for a Pads value constructor.
genPrintConstr :: Bool -> String -> [ConstrArg] -> (Maybe Exp) -> Q [Match]
genPrintConstr doDef (mkName -> recName) args predM = do
let fields = map (\c -> (Just "arg",c,Nothing)) args
(repEs, repPs) <- getPEforFields (\t -> genDefTy t >>= \def -> return $ SigE def (mkRepTy t)) newName fields
(mdEs, mdPs) <- getPEforFields (return . SigE (VarE 'myempty) . mkMDTy False) newName fields
let ptys = map (\(n,(s,ty),p) -> ty) fields
let genBody mdEs = (do
{ let genTyRepMd = (\(ty,r,m) -> if hasRep ty then return (ty,r,m) else genDefTy ty >>= (\def -> return (ty,SigE def (mkRepTy ty),m)))
; ty_rep_mds <- mapM genTyRepMd $ zip3 ptys repEs mdEs
; expE <- mapM (\(ty,repE,mdE) -> genPrintTy ty $ Just $ TupE [repE,mdE]) ty_rep_mds
; let printItemsE = ListE expE
; let caseBody = NormalB (AppE (VarE 'concatFL) printItemsE)
; return caseBody
})
let repPat = ConP recName (filterByHasRep ptys $ map snd repPs)
let mdPat = TupP[SigP WildP (ConT ''Base_md), ConP (getStructInnerMDName recName) (map snd mdPs)]
caseBody <- genBody mdEs
let match = Match (TupP [repPat, mdPat]) caseBody []
caseBodyDef <- genBody $ map (\(_,ty) -> SigE (VarE 'myempty) (mkMDTy False ty)) args
let matchDef = Match (TupP [repPat,WildP]) caseBodyDef []
if doDef then return [match,matchDef] else return [match]
-- | Generate the template haskell code for printing a Pads switch type by
-- ignoring the value we're switching on and simply generating the same case
-- expression that 'genPrintUnion' does for a Pads union type.
genPrintSwitch :: Exp -> [(Pat,BranchInfo)] -> Maybe Exp -> Q Exp
genPrintSwitch exp pbs rm = genPrintUnion (map snd pbs) rm
-------------------------------------------------------------------------------
-- * Generating Default Function from a Declaration
-- | Generate the Pads default value for a 'PadsDeclType'
genPadsDef :: UString -> [LString] -> Maybe Pat -> PadsTy -> Q [Dec]
genPadsDef name args patM padsTy = do
body <- genDefTy padsTy
return [mkDefFunction name args patM body]
-- | Generate the Pads default value for a Pads data declaration.
genPadsDataDef :: UString -> [LString] -> Maybe Pat -> PadsData -> Q [Dec]
genPadsDataDef name args patM padsData = do
body <- genDefData padsData
return [mkDefFunction name args patM body]
-- | Generate the Pads default value for a Pads newtype declaration.
genPadsNewDef :: UString -> [LString] -> Maybe Pat -> BranchInfo -> Q [Dec]
genPadsNewDef name args patM branch = do
body <- genDefBranchInfo branch
return [mkDefFunction name args patM body]
-- | Generate the Pads default value for a Pads obtain declaration.
genPadsObtainDef :: UString -> [LString] -> PadsTy -> Exp -> Q [Dec]
genPadsObtainDef name args padsTy exp = do
body <- genDefTy (PTransform padsTy (PTycon [name]) exp)
return [mkDefFunction name args Nothing body]
-- | Generate the Pads default value as a function declaration of the form
-- "foo_def" for a Pads parser named "Foo".
mkDefFunction :: UString -> [LString] -> Maybe Pat -> Exp -> Dec
mkDefFunction name args patM body =
FunD defName [Clause (defArgs) (NormalB body) []]
where
defName = mkTyDefName name
defArgs = map (VarP . mkTyDefVarName) args ++ Maybe.maybeToList patM
-------------------------------------------------------------------------------
-- * Generate Default Function from a Type
-- | Generate the default Haskell value for some Pads type.
genDefTy :: PadsTy -> Q Exp
genDefTy (PConstrain pat ty exp) = genDefTy ty -- XXX: doesn't check the constraint; ideally we should change @printFL@ to account for possible printing errors
genDefTy (PTransform src dest exp) = do
defSrc <- genDefTy src
srcToDest <- [| \rep -> fst $ (fst $(return exp)) S.zeroSpan (rep,(error "TODO defaultMd")) |] -- XXX: fix this undefined, it kind of requires defaultMd to be defined inductively over Pads types as well...
return $ AppE srcToDest defSrc
genDefTy (PList ty sepM termM) = [| [] |]
genDefTy (PPartition ty exp) = genDefTy ty
genDefTy (PApp tys expM) = do
prtys <- mapM genDefTy tys
foldl1M (\e1 e2 -> return $ AppE e1 e2) (prtys ++ Maybe.maybeToList expM)
genDefTy (PTuple tys) = genDefTuple tys
genDefTy (PExpression exp) = return exp
genDefTy (PTycon c) = return $ VarE (mkTyDefQName c)
genDefTy (PTyvar v) = return $ VarE (mkTyDefVarName v)
genDefTy (PValue exp ty) = genDefTy ty
-- | Generate the default Haskell value for a Pads tuple type.
genDefTuple :: [PadsTy] -> Q Exp
genDefTuple tys = case reps of
[] -> [| () |]
[ty] -> genDefTy ty
tys -> do
exps <- mapM genDefTy tys
return $ TupE exps
where
reps = [ty | ty <- tys, hasRep ty]
-------------------------------------------------------------------------------
-- Generate Default Function from a Datatype
-- | Generate the default Haskell value for a Pads data type 'PadsData'.
genDefData :: PadsData -> Q Exp
genDefData (PUnion (b:bs)) = genDefBranchInfo b
genDefData (PSwitch exp (pb:pbs)) = genDefBranchInfo (snd pb)
genDefData (PUnion []) = error "genDefData: empty PUnion."
genDefData (PSwitch exp []) = error "genDefData: empty PSwitch."
-- | Generate the default Haskell value for a single branch of a Pads type,
-- namely either a Pads constructor or record.
genDefBranchInfo :: BranchInfo -> Q Exp
genDefBranchInfo (BConstr c args pred) = do
reps <- sequence $ [genDefTy ty | (strict,ty) <- args, hasRep ty]
return $ foldl1 AppE (ConE (mkConstrName c):reps)
genDefBranchInfo (BRecord c fields expM) = do
reps <- sequence $ [liftM (l,) (genDefTy ty) | (Just l,(strict,ty),_) <- fields, hasRep ty]
let lets = flip map reps $ \(lab,def) -> ValD (VarP $ mkName lab) (NormalB def) []
return $ LetE lets $ foldl1 AppE (ConE (mkConstrName c):map (VarE . mkName . fst) reps)
-------------------------------------------------------------------------------
-- * Name Manipulation Functions
-- ** Naming types, and accessing the names of types
-- | Get the template haskell 'Name' for a given Pads type.
mkRepName :: String -> Name
mkRepName str = mkName str
-- | Make the template haskell 'Name' of a given 'PTycon' with a qualified name.
mkRepQName :: QString -> Name
mkRepQName str = mkName (qName str)
-- | Make externally visible metadata name for a Pads type
mkMDName :: String -> Name
mkMDName str = mkName (str ++ "_md")
-- | Given a Pads type name in the template haskell @Q@ monad, get the metadata
-- type name.
mkMDQName :: QString -> Name
mkMDQName str = mkName (appendTo str "_md")
-- | Make the internal metadata type name for a given Pads type
mkIMDName name = mkName (name ++ "_imd")
-- | Make externally visible metadata name for a Pads variable
mkMDVarName name = mkName (name ++ "_md")
-- ** Naming fields and constructors
-- | Convert Pads source (record) field name into a 'Q' monad name
mkFieldName str = mkName str
-- | Convert Pads source (record) field name into its metadata name in the 'Q'
-- monad.
mkFieldMDName str = mkName (str ++ "_md")
-- | Pads constructor
mkConstrName str = mkName str
mkConstrIMDName str = mkName (str ++ "_imd")
mkfnMDName str = mkName (strToLower str ++ "_md")
-- ** Naming Parsers
mkTyParserName str = mkName (strToLower str ++ "_parseM")
mkTyParserSName str = mkName (strToLower str ++ "_parseS")
mkTyParserQName str = mkName (appendLower str "_parseM")
mkTyParserSQName str = mkName (appendLower str "_parseS")
mkVarParserName str = mkName (strToLower str ++ "__p")
-- ** Naming Printers
getBranchMDNameU str = mkName ((strToUpper str)++"_md")
getBranchMDNameL str = mkName ((strToLower str)++"_md")
getBranchNameU str = mkName (strToUpper str)
getBranchNameL str = mkName (strToLower str)
getStructInnerMDName name = let str = show name in mkName (str++"_imd")
mkTyPrinterName str = mkName (strToLower str ++ "_printFL")
mkTyPrinterQName str = mkName (appendLower str "_printFL")
mkTyPrinterVarName str = mkName (str ++ "__pr")
mkTyDefName str = mkName (strToLower str ++ "_def")
mkTyDefQName str = mkName (appendLower str "_def")
mkTyDefVarName str = mkName (str ++ "__d")
appendTo :: QString -> String -> String
appendTo ms s = qName (init ms ++ [last ms ++ s])
appendLower ms s = qName (init ms ++ [strToLower (last ms) ++ s])
type UString = String
type LString = String
foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a
foldl1M f (x:xs) = foldM f x xs
foldr1M :: Monad m => (a -> a -> m a) -> [a] -> m a
foldr1M f [x] = return x
foldr1M f (x:xs) = f x =<< foldr1M f xs
appT2 f x y = AppT (AppT f x) y
appE3 f x y z = AppE (AppE (AppE f x) y) z