uuagc-0.9.51: src-ag/ExecutionPlan2Hs.ag
INCLUDE "ExecutionPlan.ag"
INCLUDE "Patterns.ag"
INCLUDE "Expression.ag"
INCLUDE "HsToken.ag"
imports
{
import ExecutionPlan
import Pretty
import PPUtil
import Options
import Data.Monoid(mappend,mempty)
import Data.Maybe
import Debug.Trace
import System.IO
import System.Directory
import System.FilePath
import UU.Scanner.Position
import TokenDef
import HsToken
import ErrorMessages
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Sequence(Seq)
import qualified Data.Sequence as Seq
import Data.Foldable(toList)
}
ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule EChildren EChild
[ importBlocks : PP_Doc
pragmaBlocks : String
textBlocks : PP_Doc
moduleHeader : {String -> String -> String -> Bool -> String}
mainFile : String
mainName : String | | ]
-------------------------------------------------------------------------------
-- Options
-------------------------------------------------------------------------------
ATTR ExecutionPlan
ENonterminals ENonterminal
EProductions EProduction
ERules ERule
EChildren EChild
Expression
HsToken HsTokens HsTokensRoot
Pattern Patterns
Visits Visit
VisitSteps VisitStep [ options : {Options} | | ]
ATTR EProductions EProduction [ rename : {Bool} | | ]
SEM ENonterminal
| ENonterminal prods.rename = rename @lhs.options
-------------------------------------------------------------------------------
-- Context info (nonterminal ident, constructor ident, nonterm params, etc.)
-------------------------------------------------------------------------------
ATTR Visit Visits EProduction EProductions EChildren EChild ERules ERule [ nt : NontermIdent | | ]
SEM ENonterminal
| ENonterminal prods.nt = @nt
ATTR EChildren EChild ERules ERule Visits Visit
[ con : ConstructorIdent | | ]
SEM EProduction
| EProduction children.con = @con
rules.con = @con
visits.con = @con
ATTR EProductions EProduction Visits Visit [ params : {[Identifier]} | | ]
SEM ENonterminal | ENonterminal
prods.params = @params
ATTR EProductions EProduction [ classCtxs : ClassContext | | ]
SEM ENonterminal | ENonterminal
prods.classCtxs = @classCtxs
-------------------------------------------------------------------------------
-- Default output
-------------------------------------------------------------------------------
ATTR ExecutionPlan [ | | output : {PP_Doc} ]
SEM ExecutionPlan
| ExecutionPlan lhs.output = @nonts.output >-< @loc.commonExtra >-< @loc.wrappersExtra
ATTR ENonterminal ENonterminals [ wrappers : {Set NontermIdent}
| | output USE {>-<} {empty} : {PP_Doc} ]
SEM ExecutionPlan
| ExecutionPlan nonts.wrappers = @wrappers
SEM ENonterminal
| ENonterminal lhs.output = ("-- " ++ getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-')
>-< (if dataTypes @lhs.options
then "-- data"
>-< @loc.datatype
>-< ""
else empty)
>-< (if @loc.hasWrapper
then "-- wrapper"
>-< @loc.wr_inh
>-< @loc.wr_syn
>-< @loc.wrapper
>-< ""
else empty)
>-< (if folds @lhs.options
then "-- cata"
>-< @loc.sem_nt
>-< ""
else empty)
>-< (if semfuns @lhs.options
then "-- semantic domain"
>-< @loc.t_init
>-< @loc.t_states
>-< @loc.k_states
>-< @prods.t_visits
>-< @prods.sem_prod
>-< ""
else empty)
loc.hasWrapper = @nt `Set.member` @lhs.wrappers
-------------------------------------------------------------------------------
-- Nonterminal datatype
-------------------------------------------------------------------------------
ATTR ENonterminal ENonterminals [ typeSyns : {TypeSyns}
derivings : {Derivings} | | ]
SEM ExecutionPlan
| ExecutionPlan nonts.typeSyns = @typeSyns
nonts.derivings = @derivings
SEM ENonterminal
| ENonterminal loc.classPP = ppClasses $ classCtxsToDocs @classCtxs
loc.aliasPre = "type" >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "="
loc.datatype = case lookup @nt @lhs.typeSyns of
Nothing -> "data" >#< @loc.classPP >#< @nt >#< @loc.t_params
>-< ( if null @prods.datatype
then empty
else indent 2 $ vlist $ ( ("=" >#< head @prods.datatype)
: (map ("|" >#<) $ tail @prods.datatype))
)
>-< indent 2 @loc.derivings
Just (List t) -> @loc.aliasPre >#< "[" >#< show t >#< "]"
Just (Maybe t) -> @loc.aliasPre >#< "Maybe" >#< pp_parens (show t)
Just (Tuple ts) -> @loc.aliasPre >#< pp_parens (ppCommas $ map (show . snd) ts)
Just (Either l r) -> @loc.aliasPre >#< "Either" >#< pp_parens (show l) >#< pp_parens (show r)
Just (Map k v) -> @loc.aliasPre >#< "Data.Map" >#< pp_parens (show k) >#< pp_parens (show v)
Just (IntMap t) -> @loc.aliasPre >#< "Data.IntMap.IntMap" >#< pp_parens (show t)
Just (OrdSet t) -> @loc.aliasPre >#< "Data.Set.Set" >#< pp_parens (show t)
Just IntSet -> @loc.aliasPre >#< "Data.IntSet.IntSet"
-- Just x -> error $ "Type " ++ show x ++ " is not supported"
loc.derivings = case Map.lookup @nt @lhs.derivings of
Nothing -> empty
Just s -> if Set.null s
then empty
else "deriving" >#< (pp_parens $ ppCommas $ map pp $ Set.toList s)
{
classCtxsToDocs :: ClassContext -> [PP_Doc]
classCtxsToDocs = map toDoc where
toDoc (ident,args) = (ident >#< ppSpaced (map pp_parens args))
classConstrsToDocs :: [Type] -> [PP_Doc]
classConstrsToDocs = map ppTp
ppClasses :: [PP_Doc] -> PP_Doc
ppClasses [] = empty
ppClasses xs = pp_block "(" ")" "," xs >#< "=>"
ppQuants :: [Identifier] -> PP_Doc
ppQuants [] = empty
ppQuants ps = "forall" >#< ppSpaced ps >#< "."
}
ATTR EProduction [ | | datatype : {PP_Doc} ]
ATTR EProductions [ | | datatype USE {:} {[]} : {[PP_Doc]} ]
-- we generate the data type in the type-class style instead of the GADT style
-- the GADT extension may be required if equality constraints are used
SEM EProduction
| EProduction lhs.datatype = @loc.quantPP1 >#< @loc.classPP1
>#< conname @lhs.rename @lhs.nt @con
>#< ppConFields (dataRecords @lhs.options) @children.datatype
loc.classPP1 = ppClasses (classConstrsToDocs @constraints)
loc.quantPP1 = ppQuants @params
{
-- first parameter indicates: generate a record or not
ppConFields :: Bool -> [PP_Doc] -> PP_Doc
ppConFields True flds = ppListSep "{" "}" ", " $ filter (not . isEmpty) flds
ppConFields False flds = ppSpaced flds
}
ATTR EChild [ | | datatype : {PP_Doc} ]
ATTR EChildren [ | | datatype USE {:} {[]} : {[PP_Doc]} ]
-- Note: the child may be a higher-order attribute, and its semantics may be deforested
SEM EChild
| EChild ETerm
loc.tpDoc = @loc.addStrict $ pp_parens $ ppTp $ removeDeforested @tp
loc.strNm = recordFieldname @lhs.nt @lhs.con @name
loc.field = if dataRecords @lhs.options
then @loc.strNm >#< "::" >#< @loc.tpDoc
else @loc.tpDoc
loc.addStrict = \x -> if strictData @lhs.options then "!" >|< x else x
| EChild lhs.datatype = case @kind of
ChildAttr -> empty -- higher order attributes are not part of the data type
_ -> @loc.field
| ETerm lhs.datatype = @loc.field
{
ppTp :: Type -> PP_Doc
ppTp = text . typeToHaskellString Nothing []
}
-------------------------------------------------------------------------------
-- Nonterminal semantic function
-------------------------------------------------------------------------------
SEM ENonterminal
| ENonterminal loc.fsemname = \x -> "sem_" ++ show x
loc.semname = @loc.fsemname @nt
loc.frecarg = \t x -> case t of
NT nt _ _ -> pp_parens (@fsemname nt >#< x)
_ -> pp x
-- The sem_NT function is lazy in the AST: it depends on the application of "child"
-- rules to which extend the AST needs to be constructed.
loc.sem_tp = @loc.quantPP >#< @loc.classPP >#< @nt >#< @loc.t_params >#< "->" >#< @loc.t_type >#< @loc.t_params
loc.quantPP = ppQuants @params
loc.sem_nt = @loc.semPragma
>-< @loc.semname >#< "::" >#< @loc.sem_tp
>-< case lookup @nt @lhs.typeSyns of
Nothing -> @prods.sem_nt
Just (List t) -> @loc.semname >#< "list" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Cons"
>#< @loc.semname >|< "_Nil"
>#< case t of
NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt >#< "list")
_ -> pp "list"
Just (Maybe t) -> @loc.semname >#< "Prelude.Nothing" >#< "=" >#< @loc.semname >|< "_Nothing"
>-< @loc.semname >#< pp_parens ("Prelude.Just just") >#< "="
>#< @loc.semname >|< "_Just" >#< @frecarg t "just"
Just (Tuple ts) -> @loc.semname >#< pp_parens (ppCommas $ map fst ts) >#< "="
>#< @loc.semname >|< "_Tuple" >#< ppSpaced (map (\t -> @frecarg (snd t) (show $ fst t)) ts)
Just (Either l r) -> @loc.semname >#< "(Prelude.Left left)" >#< "=" >#< @loc.semname >|< "_Left" >#< @frecarg l "left"
>-< @loc.semname >#< "(Prelude.Right right)" >#< "=" >#< @loc.semname >|< "_Right" >#< @frecarg r "right"
Just (Map k v) -> @loc.semname >#< "m" >#< "=" >#< "Data.Map.foldrWithKey"
>#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"
>#< case v of
NT nt _ _ -> pp_parens ("Data.Map.map" >#< @fsemname nt >#< "m")
_ -> pp "m"
Just (IntMap v) -> @loc.semname >#< "m" >#< "=" >#< "Data.IntMap.foldWithKey"
>#< @loc.semname >|< "_Entry" >#< @loc.semname >|< "_Nil"
>#< case v of
NT nt _ _ -> pp_parens ("Data.IntMap.map" >#< @fsemname nt >#< "m")
_ -> pp "m"
Just (OrdSet t) -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry"
>#< @loc.semname >|< "_Nil"
>#< pp_parens (
( case t of
NT nt _ _ -> pp_parens ("Prelude.map" >#< @fsemname nt)
_ -> empty
) >#< pp_parens ("Data.IntSet.elems" >#< "s")
)
Just IntSet -> @loc.semname >#< "s" >#< "=" >#< "Prelude.foldr" >#< @loc.semname >|< "_Entry"
>#< @loc.semname >|< "_Nil"
>#< pp_parens ("Data.IntSet.elems" >#< "s")
-- Just x -> error $ "Type " ++ show x ++ " is not supported yet" -- TODO: other typeSyns
-- precise inlining strategies for inlining
loc.inlineNt = not (lateHigherOrderBinding @lhs.options) && not @recursive && (@prods.count == 1 || (aggressiveInlinePragmas @lhs.options && not @loc.hasWrapper)) -- lucrative for inlining
loc.semPragma = if noInlinePragmas @lhs.options
then empty
else if @loc.inlineNt
then ppInline @loc.semname
else if helpInlining @lhs.options && not (lateHigherOrderBinding @lhs.options)
then ppInlinable @loc.semname
else ppNoInline @loc.semname
-- The number of productions
ATTR EProductions EProduction [ | | count USE {+} {0} : {Int} ]
SEM EProduction | EProduction lhs.count = {1}
-- The per-production cases for the sem_NT function
ATTR EProduction EProductions [ | | sem_nt USE {>-<} {empty} : {PP_Doc} ]
SEM EProduction
| EProduction lhs.sem_nt = "sem_" >|< @lhs.nt >#< "(" >#< conname @lhs.rename @lhs.nt @con >#< ppSpaced @children.argpats >#< ")"
>#< "=" >#< "sem_" >|< @lhs.nt >|< "_" >|< @con >#< ppSpaced @children.argnamesw
ATTR EChild [ | | argnamesw : { PP_Doc } ]
ATTR EChildren [ | | argnamesw USE {:} {[]} : {[PP_Doc]} ]
SEM EChild
| EChild lhs.argnamesw = case @kind of
ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")"
ChildAttr -> empty -- no sem-case for a higher-order child
ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")"
| ETerm lhs.argnamesw = text $ fieldname @name
-------------------------------------------------------------------------------
-- Types of attributes
-------------------------------------------------------------------------------
ATTR ExecutionPlan
ENonterminals
ENonterminal [ inhmap : {Map NontermIdent Attributes}
synmap : {Map NontermIdent Attributes} | | ]
ATTR EProductions EProduction
ERules ERule
Patterns Pattern
Visits
Visit [ inhmap : {Attributes}
synmap : {Attributes}
allInhmap : {Map NontermIdent Attributes}
allSynmap : {Map NontermIdent Attributes} | | ]
SEM ENonterminal
| ENonterminal (Just prods.inhmap) = Map.lookup @nt @lhs.inhmap
(Just prods.synmap) = Map.lookup @nt @lhs.synmap
prods.allInhmap = @lhs.inhmap
prods.allSynmap = @lhs.synmap
-------------------------------------------------------------------------------
-- State datatypes
-------------------------------------------------------------------------------
{type VisitStateState = (VisitIdentifier,StateIdentifier, StateIdentifier)}
ATTR Visit [ | | allvisits : { VisitStateState }]
ATTR Visits [ | | allvisits USE {:} {[]} : {[VisitStateState]}]
ATTR EProduction
EProductions [ | | allvisits: {[VisitStateState]}]
SEM Visit
| Visit lhs.allvisits = (@ident, @from, @to)
SEM EProductions
| Cons lhs.allvisits = @hd.allvisits -- just pick the first production
| Nil lhs.allvisits = error "Every nonterminal should have at least 1 production"
-- type of tree in a given state s
SEM ENonterminal
| ENonterminal loc.outedges = Set.fromList $ map (\(_,f,_) -> f) @prods.allvisits
loc.inedges = Set.fromList $ map (\(_,_,t) -> t) @prods.allvisits
loc.allstates = Set.insert @initial $ @loc.inedges `Set.union` @loc.outedges
loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @prods.allvisits
loc.t_type = "T_" >|< @nt
loc.t_params = ppSpaced @params
loc.t_init = "newtype" >#< @loc.t_type >#< @loc.t_params >#< "=" >#< @loc.t_type >#<
pp_braces (
"attach_">|< @loc.t_type >#< "::"
>#< ppMonadType @lhs.options >#< pp_parens (@loc.t_type >|< "_s" >|< @initial >#< @loc.t_params))
loc.t_states = vlist $ map (\st ->
let nt_st = @nt >|< "_s" >|< st
t_st = "T_" >|< nt_st
k_st = "K_" >|< nt_st
c_st = "C_" >|< nt_st
inv_st = "inv_" >|< nt_st
nextVisit = Map.findWithDefault ManyVis st @nextVisits
in case nextVisit of
NoneVis -> "data" >#< t_st >#< @loc.t_params >#< "=" >#< c_st -- empty semantics
OneVis vId -> "newtype" >#< t_st >#< @loc.t_params >#< "=" >#< c_st
>#< (pp_braces $ inv_st >#< "::" >#< pp_parens (conNmTVisit @nt vId >#< @loc.t_params))
ManyVis -> "data" >#< t_st >#< @loc.t_params >#< "where" >#< c_st >#< "::"
>#< (pp_braces $ inv_st >#< "::" >#< "!" >|< pp_parens ("forall t." >#< k_st >#< @loc.t_params >#< "t" >#< "->" >#< "t"))
>#< "->" >#< t_st >#< @loc.t_params -- this is a conventional data type, but declared with GADT syntax
) $ Set.toList @loc.allstates
-- type of a key which identifies a visit v from state s
SEM ENonterminal
| ENonterminal loc.k_type = "K_" ++ show @nt
loc.k_states = vlist $ map (\st ->
let nt_st = @nt >|< "_s" >|< st
k_st = "K_" >|< nt_st
outg = filter (\(v,f,t) -> f == st) @prods.allvisits
visitlist = vlist $ map (\(v,f,t) ->
@loc.k_type >|< "_v" >|< v >#< "::" >#< k_st >#< @loc.t_params >#< pp_parens (@loc.t_type >|< "_v" >|< v >#< @loc.t_params)
) outg
nextVisit = Map.findWithDefault ManyVis st @nextVisits
decl = "data" >#< k_st >#< "k" >#< @loc.t_params >#< "where" >-< indent 3 visitlist
in case nextVisit of
NoneVis -> empty
OneVis _ -> empty
ManyVis -> decl
) $ Set.toList @loc.allstates
-- type of a visit v, with continuation as new state s
ATTR Visit Visits EProduction EProductions [ | | t_visits USE {>-<} {empty} : {PP_Doc} ]
SEM EProductions
| Cons lhs.t_visits = @hd.t_visits -- just pick the first production
SEM Visit
| Visit loc.nameT_visit = conNmTVisit @lhs.nt @ident
loc.nameTIn_visit = conNmTVisitIn @lhs.nt @ident
loc.nameTOut_visit = conNmTVisitOut @lhs.nt @ident
loc.nameTNext_visit = conNmTNextVisit @lhs.nt @to
loc.nextVisitInfo = Map.findWithDefault ManyVis @to @lhs.nextVisits -- which visits can we do after we reach the @to state?
loc.typecon = case @kind of
VisitPure _ -> empty
VisitMonadic -> ppMonadType @lhs.options
loc.t_params = ppSpaced @lhs.params
lhs.t_visits = "type" >#< @loc.nameT_visit >#< @loc.t_params >#< "=" >#<
pp_parens (@loc.nameTIn_visit >#< @loc.t_params)
>#< ( if dummyTokenVisit @lhs.options
then "->" >#< dummyType @lhs.options True -- Additional (unused though) argument
else empty
)
>#< "->" >#< @loc.typecon >#< pp_parens (@loc.nameTOut_visit >#< @loc.t_params)
>-< "data" >#< @loc.nameTIn_visit >#< @loc.t_params >#< "=" >#< @loc.nameTIn_visit >#<
@loc.inhpart
>-< "data" >#< @loc.nameTOut_visit >#< @loc.t_params >#< "=" >#< @loc.nameTOut_visit >#<
@loc.synpart >#< case @loc.nextVisitInfo of
NoneVis -> empty -- don't return a continuation at all
_ -> @loc.addbang1 $ pp_parens (@loc.nameTNext_visit >#< @loc.t_params) -- normal route: select the next semantics
loc.inhpart = @loc.ppTypeList @inh @lhs.inhmap
loc.synpart = @loc.ppTypeList @syn @lhs.synmap
loc.ppTypeList = \s m -> ppSpaced $ map (\i -> @loc.addbang1 $ pp_parens $ case Map.lookup i m of
Just tp -> ppTp tp ) $ Set.toList s
{
conNmTVisit nt vId = "T_" >|< nt >|< "_v" >|< vId
conNmTVisitIn nt vId = "T_" >|< nt >|< "_vIn" >|< vId
conNmTVisitOut nt vId = "T_" >|< nt >|< "_vOut" >|< vId
conNmTNextVisit nt stId = "T_" >|< nt >|< "_s" >|< stId
ppMonadType :: Options -> PP_Doc
ppMonadType opts
| parallelInvoke opts = text "IO"
| otherwise = text "Identity"
}
-------------------------------------------------------------------------------
-- Inh and Syn wrappers
-------------------------------------------------------------------------------
SEM ENonterminal
| ENonterminal loc.wr_inh = @loc.genwrap "Inh" @loc.wr_inhs
loc.wr_syn = @loc.genwrap "Syn" @loc.wr_syns
loc.genwrap = \nm attr -> "data" >#< nm >|< "_" >|< @nt >#< @loc.t_params >#< "=" >#< nm >|< "_" >|< @nt >#< "{"
>#< (ppCommas $ map (\(i,t) -> i >|< "_" >|< nm >|< "_" >|< @nt >#< "::"
>#< (@loc.addbang $ pp_parens $ typeToHaskellString (Just @nt) [] t)) attr) >#< "}"
loc.synAttrs = fromJust $ Map.lookup @nt @lhs.inhmap
loc.wr_inhs = Map.toList $ @loc.wr_filter $ @loc.synAttrs
loc.wr_inhs1 = Map.toList @loc.synAttrs
loc.wr_filter = if lateHigherOrderBinding @lhs.options
then Map.delete idLateBindingAttr
else id
loc.wr_syns = Map.toList $ fromJust $ Map.lookup @nt @lhs.synmap
loc.inhlist = map (lhsname @lhs.options True . fst) @loc.wr_inhs
loc.inhlist1 = map (lhsname @lhs.options True . fst) @loc.wr_inhs1
loc.synlist = map (lhsname @lhs.options False . fst) @loc.wr_syns
loc.wrapname = "wrap_" ++ show @nt
loc.inhname = "Inh_" ++ show @nt
loc.synname = "Syn_" ++ show @nt
loc.firstVisitInfo = Map.findWithDefault ManyVis @initial @nextVisits
loc.wrapper = @loc.wrapPragma
>-< (@loc.wrapname >#< "::" >#< @loc.quantPP >#< @loc.classPP >#< @loc.t_type >#< @loc.t_params >#< "->"
>#< @loc.inhname >#< @loc.t_params >#< "->" >#< ( if monadicWrappers @lhs.options then ppMonadType @lhs.options else empty) >#< pp_parens (@loc.synname >#< @loc.t_params))
>-< (@loc.wrapname >#< (@loc.addbang $ pp_parens (@loc.t_type >#< pp "act"))
>#< (@loc.addbang $ pp_parens (@loc.inhname
>#< (ppSpaced $ map (@loc.addbangWrap . pp) @loc.inhlist)) >#< "="))
>-<
indent 3 (case @initialv of
-- case where there are no inherited or synthesized attributes
[] -> @loc.synname >#< " { }"
initvs@(initv:_) ->
let extra = if dummyTokenVisit @lhs.options
then pp $ dummyArg @lhs.options True
else empty
unMonad | monadicWrappers @lhs.options = empty
| otherwise = unMon @lhs.options
genSteps _ [] = []
genSteps curst (curv:nextvs) = setarg : dovis : genSteps nextst nextvs where
inCon = conNmTVisitIn @nt curv
outCon = conNmTVisitOut @nt curv
pat = @loc.addbang $ pp_parens $ pat0
pat0 = outCon >#< ppSpaced (map (lhsname @lhs.options False) syns) >#< cont
cont | null nextvs = empty
| otherwise = pp "sem"
inhs = Set.toList $ Map.findWithDefault Set.empty curv @prods.visituses
syns = Set.toList $ Map.findWithDefault Set.empty curv @prods.visitdefs
arg = inCon >#< ppSpaced (map (lhsname @lhs.options True) inhs)
setarg = "let" >#< @loc.addbangWrap (pp "arg" >|< curv) >#< "=" >#< arg
ind = case Map.findWithDefault ManyVis curst @nextVisits of
NoneVis -> error "wrapper: initial state should have a next visit but it has none"
OneVis _ -> empty
ManyVis -> @loc.k_type >|< "_v" >|< initv
nextst = curst + 1 -- This is not correct, but works both for KW and AOAG
-- Should be lookup up based on visit
convert = case Map.lookup curv @lhs.allVisitKinds of
Just kind -> case kind of
VisitPure _ -> text "return"
VisitMonadic -> empty
dovis = pat >#< "<-" >#< convert >#< pp_parens
("inv_" >|< @nt >|< "_s" >|< curst >#< "sem" >#< ind
>#< "arg" >|< curv >#< extra)
in unMonad >#< "("
>-< indent 2 (
"do" >#< ( @loc.addbang (pp "sem") >#< "<-" >#< "act" -- run the per-node monadic code to get the initial state (of the root)
>-< vlist (genSteps @initial initvs)
>-< "return" >#< pp_parens (@loc.synname >#< ppSpaced @loc.synlist)
)
)
>-< ")" )
>-< if lateHigherOrderBinding @lhs.options
then indent 2 ("where" >#< lhsname @lhs.options True idLateBindingAttr >#< "=" >#< lateBindingFieldNm @lhs.mainName)
else empty
loc.wrapPragma = if parallelInvoke @lhs.options && not (monadicWrappers @lhs.options)
then ppNoInline @loc.wrapname -- required for the use of unsafePerformIO in case of the IO monad
else if noInlinePragmas @lhs.options
then empty
else ppInlinable @loc.wrapname -- ensure that the wrapper is exposed as inlinable
-------------------------------------------------------------------------------
-- Collection of NT / Production sem funs references
-------------------------------------------------------------------------------
ATTR ENonterminals ENonterminal EProductions EProduction [ | | semFunBndDefs, semFunBndTps USE {Seq.><} {Seq.empty} : {Seq PP_Doc} ]
SEM ENonterminal | ENonterminal
lhs.semFunBndDefs = @loc.semFunBndDef Seq.<| @prods.semFunBndDefs
lhs.semFunBndTps = @loc.semFunBndTp Seq.<| @prods.semFunBndTps
loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname
loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp
loc.semFunBndNm = lateSemNtLabel @nt
SEM EProduction | EProduction
lhs.semFunBndDefs = Seq.singleton @loc.semFunBndDef
lhs.semFunBndTps = Seq.singleton @loc.semFunBndTp
loc.semFunBndDef = @loc.semFunBndNm >#< "=" >#< @loc.semname
loc.semFunBndTp = @loc.semFunBndNm >#< "::" >#< @loc.sem_tp
loc.semFunBndNm = lateSemConLabel @lhs.nt @con
-- Generate a dictionary that contains the semantics of all semantic functions
SEM ExecutionPlan | ExecutionPlan
loc.wrappersExtra = if lateHigherOrderBinding @lhs.options
then @loc.lateSemBndDef
else empty
loc.commonExtra = if lateHigherOrderBinding @lhs.options
then @loc.lateSemBndTp
else empty
loc.lateSemBndTp = "data" >#< lateBindingTypeNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName
>-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndTps)
loc.lateSemBndDef = ( if noInlinePragmas @lhs.options
then empty
else if helpInlining @lhs.options && Set.size @wrappers == 1
then ppInline $ lateBindingFieldNm @lhs.mainName -- inline in the single wrapper
else ppNoInline $ lateBindingFieldNm @lhs.mainName
)
>-< lateBindingFieldNm @lhs.mainName >#< "::" >#< lateBindingTypeNm @lhs.mainName
>-< lateBindingFieldNm @lhs.mainName >#< "=" >#< lateBindingTypeNm @lhs.mainName
>-< (indent 2 $ pp_block "{" "}" "," $ toList @nonts.semFunBndDefs )
-------------------------------------------------------------------------------
-- Production semantic functions
-------------------------------------------------------------------------------
ATTR EProduction [ | | sem_prod : {PP_Doc} ]
ATTR EProductions [ | | sem_prod USE {>-<} {empty} : {PP_Doc} ]
ATTR EProduction EProductions [ initial : {StateIdentifier}
allstates : {Set StateIdentifier} | | ]
SEM ENonterminal
| ENonterminal prods.initial = @initial
prods.allstates = @loc.allstates
ATTR EChild [ | | argtps : { PP_Doc }
argpats : { PP_Doc } ]
ATTR EChildren [ | | argtps USE {:} {[]} : { [PP_Doc] }
argpats USE {:} {[]} : { [PP_Doc] } ]
SEM EChild
| EChild lhs.argtps = case @kind of
ChildSyntax -> ppDefor @tp >#< "->"
ChildReplace tp -> ppDefor tp >#< "->"
_ -> empty -- higher order attribute
loc.argpats = case @kind of
ChildSyntax -> @name >|< "_" -- no strictification of children semantics to allow infinite trees
ChildReplace _ -> @name >|< "_"
_ -> empty
| ETerm lhs.argtps = (pp_parens $ show @tp) >#< "->"
loc.argpats = @loc.addbang $ text $ fieldname @name -- terminals may be strict (perhaps this should become an option)
{
ppDefor :: Type -> PP_Doc
ppDefor (NT nt args _) = "T_" >|< nt >#< ppSpaced (map pp_parens args)
ppDefor (Haskell s) = text s
}
SEM EProduction
| EProduction loc.t_type = "T_" >|< @lhs.nt
loc.t_params = ppSpaced @lhs.params
loc.usedArgs = @children.usedArgs `Set.union` @visits.usedArgs `Set.union` @rules.usedArgs
-- A bit ugly, but this code renames arguments and puts an underscore when the argument
-- is never used. This avoids compiler warnings of unused variables.
loc.args = map (\x -> let (name,arg) = case show x of
"" -> ("", empty)
'!':name -> ("arg_" ++ name, "!arg_" >|< name)
name -> ("arg_" ++ name, "arg_" >|< name)
in if null name || name `Set.member` @loc.usedArgs
then arg
else text "_") @children.argpats
loc.semname = "sem_" ++ show @lhs.nt ++ "_" ++ show @con
loc.sem_tp = @loc.quantPP2 >#< @loc.classPP2 >#< ppSpaced @children.argtps >#< @loc.t_type >#< @loc.t_params
loc.classPP2 = ppClasses (classCtxsToDocs @lhs.classCtxs ++ classConstrsToDocs @constraints)
loc.quantPP2 = ppQuants (@lhs.params ++ @params)
loc.sem_prod = @loc.semInlinePragma
>-< @loc.semname >#< "::" >#< @loc.sem_tp
>-< @loc.mkSemBody (@loc.semname >#< ppSpaced @loc.args >#< "=" >#< @loc.scc >#< @loc.t_type)
@loc.mbInitializer @loc.outerlet ("return" >#< "st" >|< @lhs.initial)
loc.mkSemBody = \prefix mbInit outerlet ret ->
case mbInit of
Nothing -> prefix >#< pp_parens ret >#< "where"
>-< indent 3 outerlet -- code for states and visits
Just m -> prefix >#< "(" >#< "do"
>-< indent 1 (
m
>-< "let"
>-< indent 2 outerlet -- code for the states and visits
>-< ret )
>-< indent 1 ")"
loc.mbInitializer = --some monadic actions, performed upon attaching a child, can
-- be specified here. The resulting bindings of these actions are
-- in scope of the rules of the production
if parallelInvoke @lhs.options
then (Nothing :: Maybe PP_Doc) -- perhaps do some per-node registation, etc. For now: nothing
else Nothing -- nothing special here
loc.scc = if genCostCentres @lhs.options
then ppCostCentre @loc.semname
else empty
loc.semInlinePragma = if noInlinePragmas @lhs.options
then empty
else ppNoInline @loc.semname -- prevent the semantic functions of constructors to be inlined (e.g. in the nt sem-funs)
loc.outerlet = vlist @loc.statefns >-< @rules.sem_rules
loc.statefns = map @loc.genstfn $ Set.toList @lhs.allstates
loc.genstfn = \st -> let nextVisitInfo = Map.findWithDefault ManyVis st @lhs.nextVisits
prevVisitInfo = Map.findWithDefault ManyVis st @lhs.prevVisits
stNm = "st" >|< st
lhs = pragma >-< bang stNm >#< "=" >#<
( -- generating a lambda for the same reasons as generating
-- a lambda for rules: to ensure that overloading is
-- resolved for all visit functions and rules together.
if st == @lhs.initial
then empty
else "\\" >#< @loc.stargs st >#< "->"
)
pragma = if noInlinePragmas @lhs.options
then empty
else if helpInlining @lhs.options
then case prevVisitInfo of
ManyVis -> ppNoInline stNm
OneVis _ -> if aggressiveInlinePragmas @lhs.options
then ppInline stNm
else ppInlinable stNm
NoneVis -> if st /= @lhs.initial
then error ("State " ++ show st ++ " is not reachable from the initial state.")
else if aggressiveInlinePragmas @lhs.options
then ppInline stNm -- first state can be inlined
else ppInlinable stNm
else ppNoInline stNm
cCon = "C_" >|< @lhs.nt >|< "_s" >|< st
bang | st == @lhs.initial = @loc.addbang -- initial state is not parameterized
| otherwise = id
-- note about the initial state: the initial state should be the only
-- state-binding that is not a function. It is non-recursive and not needed
-- anywhere except delivered as initial result. This binding therefore does
-- not end up needlessly in any closure.
in case nextVisitInfo of
NoneVis -> -- the (empty) closure of a (non-initial) end state is not referenced
-- thus generating it is not needed (and omitting it may catch some small mistakes).
if st == @lhs.initial
then lhs >#< cCon -- empty state
else empty -- no state generated
OneVis vId -> mklet lhs (@loc.stvs st False) (cCon >#< "v" >|< vId)
ManyVis -> mklet lhs (@loc.stks st >-< @loc.stvs st True) (cCon >#< "k" >|< st)
loc.stargs = \st -> let attrs = maybe Map.empty id $ Map.lookup st @visits.intramap
in ppSpaced [ let match | str `Set.member` @loc.lazyIntras = pp str
| otherwise = @loc.addbang (pp str)
in case mbAttr of
Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->
case Map.lookup nm @loc.localAttrTypes of
Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp)
Nothing -> match
Just attr | not (noPerStateTypeSigs @lhs.options) ->
case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @loc.childTypes of
Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc)
Nothing -> match
_ -> match
| (str,mbAttr) <- Map.assocs attrs
] >#< dummyPat @lhs.options (Map.null attrs)
loc.stks = \st -> if null (@loc.stvisits st)
then empty
else ( if not (noInlinePragmas @lhs.options) && helpInlining @lhs.options
then ppNoInline ("k" >|< st)
else empty
)
>-< "k" >|< st >#< "::" >#< "K_" >|< @lhs.nt >|< "_s" >|< st >#< @loc.t_params >#< "t" >#< "->" >#< "t"
>-< vlist (map (\(v,f,t) -> "k" >|< st >#< "K_" >|< @lhs.nt >|< "_v" >|< v >#< "="
>#< "v" >|< v) $ @loc.stvisits st)
loc.stvisits = \st -> filter (\(v,f,t) -> f == st) @visits.allvisits
loc.stvs = \st inlinePragma -> vlist [ppf inlinePragma | (f,ppf) <- @visits.sem_visit, f == st]
visits.mrules = @rules.mrules
{
mklet :: (PP a, PP b, PP c) => a -> b -> c -> PP_Doc
mklet prefix defs body =
prefix >#< "let"
>-< indent 3 defs
>-< indent 2 "in" >#< body
}
-------------------------------------------------------------------------------
-- Visit semantic functions
-------------------------------------------------------------------------------
ATTR Visit [ | | sem_visit : { (StateIdentifier,Bool -> PP_Doc) } ]
ATTR Visits [ | | sem_visit USE {:} {[]} : { [(StateIdentifier,Bool -> PP_Doc)] } ]
SEM Visit
| Visit lhs.sem_visit = ( @from
, \addInlinePragma ->
( if noInlinePragmas @lhs.options
then empty
else if addInlinePragma && aggressiveInlinePragmas @lhs.options
then ppInline @loc.vname
else if helpInlining @lhs.options
then ppNoInline @loc.vname
else empty
)
>-< "v" >|< @ident >#< "::" >#< @loc.nameT_visit >#< @loc.t_params
-- generate a lambda here as well instead of a function definition
>-< "v" >|< @ident >#< "=" >#< "\\" >#< (@loc.addbang $ pp_parens (@loc.nameTIn_visit >#< @loc.inhpats))
>#< ( if dummyTokenVisit @lhs.options
then pp $ dummyPat @lhs.options True -- extra (but unused) argument
else empty
)
>#< "->"
>#< ( if genCostCentres @lhs.options
then ppCostCentre (@loc.vname >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con)
else empty
) >#< "(" >#< @loc.stepsInitial
>-< indent 3 (@steps.sem_steps >-< @loc.stepsClosing >#< ")")
)
loc.stepsInitial = case @kind of
VisitPure False -> text "let"
VisitPure True -> empty
VisitMonadic -> text "do"
loc.stepsClosing = let decls = @loc.nextStBuild
>-< @loc.addbang (pp resultValName) >#< "=" >#< @loc.resultval
in case @kind of
VisitPure False -> decls
>-< "in" >#< resultValName
VisitPure True -> "let" >#< decls
>-< indent 1 ("in" >#< resultValName)
VisitMonadic -> "let" >#< decls
>-< "return" >#< resultValName
loc.vname = "v" >|< @ident
loc.inhpats = ppSpaced $ map (\arg -> {-@loc.addbang $-} pp $ attrname @lhs.options True _LHS arg) $ Set.toList @inh
loc.inhargs = \chn -> ppSpaced $ map (attrname @lhs.options False chn) $ Set.toList @inh
loc.synargs = ppSpaced $ map (\arg -> attrname @lhs.options False _LHS arg) $ Set.toList @syn
loc.nextargsMp = maybe Map.empty id $ Map.lookup @to @lhs.allintramap
loc.nextargs = ppSpaced $ Map.keys $ @loc.nextargsMp
loc.nextst = "st" >|< @to >#< @loc.nextargs >#< dummyArg @lhs.options (Map.null @loc.nextargsMp)
loc.resultval = @loc.nameTOut_visit >#< @loc.synargs >#< @loc.nextStRef
(loc.nextStBuild, loc.nextStRef)
= case @loc.nextVisitInfo of
NoneVis -> (empty, empty)
_ -> (@loc.addbang (pp nextStName) >#< "=" >#< @loc.nextst, pp nextStName)
{
resultValName :: String
resultValName = "__result_"
nextStName :: String
nextStName = "__st_"
}
-- Propagate the visit kind to the steps
ATTR VisitStep VisitSteps [ kind : VisitKind | | ]
SEM Visit | Visit steps.kind = @kind
-- the steps in this group should be executed in a pure fashion
SEM VisitStep | PureGroup
steps.kind = VisitPure @ordered
ATTR Visits Visit VisitStep VisitSteps [ mrules : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} | | ]
ATTR VisitStep VisitSteps [ | | sem_steps USE {>-<} {empty} : {PP_Doc} ]
SEM VisitStep
| Sem loc.ruleItf = Map.findWithDefault (error $ "Rule " ++ show @name ++ " not found") @name @lhs.mrules
(lhs.errors, loc.sem_steps) = case @loc.ruleItf @lhs.kind @lhs.fmtMode of
Left e -> (Seq.singleton e, empty)
Right stmt -> (Seq.empty, stmt)
| ChildIntro loc.attachItf = Map.findWithDefault (error $ "Child " ++ show @child ++ " not found") @child @lhs.childintros
(lhs.errors,lhs.sem_steps,lhs.defs,lhs.uses)
= case @loc.attachItf @lhs.kind @lhs.fmtMode of
Left e -> (Seq.singleton e, empty, Set.empty, Map.empty)
Right (code, defs, uses) -> (Seq.empty, code, defs, uses)
| ChildVisit loc.visitItf = Map.findWithDefault (error $ "Visit " ++ show @visit ++ " not found") @visit @lhs.allchildvisit
(lhs.errors, loc.patPP, loc.exprPP) = case @loc.visitItf @child @lhs.kind of
Left e -> (Seq.singleton e, empty, empty)
Right (pat,expr) -> (Seq.empty, pat, expr)
loc.useParallel = @lhs.useParallel && not @lhs.isLast
lhs.sem_steps = if @loc.useParallel -- assumes to be in a monadic do-expression
then @loc.addbang ("sync_" >|< @lhs.index) >#< "<- newEmptyMVar"
>-< "forkIO" >#< pp_parens (@loc.convToMonad >#< pp_parens @loc.exprPP >#< ">>= \\" >#< @loc.addbang (pp parResultName) >#< " -> putMVar sync_" >|< @lhs.index >#< parResultName) -- parResultName is guaranteed to be evaluated
else let decl = case @lhs.kind of
VisitPure _ -> @loc.patPP >#< "=" >#< @loc.exprPP
VisitMonadic -> @loc.patPP >#< "<-" >#< @loc.exprPP
in fmtDecl False @lhs.fmtMode decl
loc.convToMonad = case @loc.callKind of
VisitPure _ -> text "return"
VisitMonadic -> empty
loc.callKind = Map.findWithDefault (error "visit kind should be in the map") @visit @lhs.allVisitKinds
| Sim lhs.sem_steps = @steps.sem_steps >-< @steps.sync_steps
| PureGroup lhs.sem_steps = case @lhs.fmtMode of
FormatDo -> "let" >#< @steps.sem_steps -- formatted as a let-block (not a line-let)
_ -> @steps.sem_steps
ATTR VisitSteps VisitStep [ | | sync_steps USE {>-<} {empty} : {PP_Doc} ]
SEM VisitStep | ChildVisit
lhs.sync_steps = if @loc.useParallel
then @loc.patPP >#< "<-" >#< "takeMVar sync_" >|< @lhs.index
else empty
-- The fmtMode indicates in what kind of expression (do/let/line-lets) we are printing
-- declarations, because that determines how we need to wrap declarations
-- Invariant: @lhs.kind == VisitMonadic ---> @lhs.fmtMode == FormatDo
ATTR VisitSteps VisitStep [ fmtMode : FormatMode | | ]
SEM Visit | Visit
steps.fmtMode = case @kind of
VisitPure False -> FormatLetDecl
VisitPure True -> FormatLetLine
VisitMonadic -> FormatDo
SEM VisitStep | PureGroup
steps.fmtMode = case @lhs.fmtMode of
FormatDo -> FormatLetDecl
mode -> mode
{
parResultName :: String
parResultName = "__outcome_"
fmtDecl :: PP a => Bool -> FormatMode -> a -> PP_Doc
fmtDecl declPure fmt decl = case fmt of
FormatLetDecl -> pp decl
FormatLetLine -> "let" >#< decl >#< "in"
FormatDo | declPure -> "let" >#< decl
| otherwise -> pp decl
}
--
-- Some properties of VisitStep(s)
--
-- Used arguments
ATTR VisitSteps VisitStep Visit Visits EChild EChildren ERule ERules [ | | usedArgs USE {`Set.union`} {Set.empty} : {Set String} ]
SEM ERule
| ERule +usedArgs = Set.union $ Map.keysSet $ Map.mapKeys (\a -> "arg_" ++ a) $ Map.filter isNothing @rhs.attrs
SEM EChild
| EChild +usedArgs = \s -> case @kind of
ChildSyntax -> Set.insert ("arg_" ++ show @name ++ "_") s
_ -> s
-- Number of steps in a 'Sim' block
ATTR VisitSteps [ | | size : Int ]
SEM VisitSteps
| Nil lhs.size = 0
| Cons lhs.size = 1 + @tl.size
-- Number the steps in a 'Sim' block
ATTR VisitSteps VisitStep [ | index : Int | ]
SEM VisitSteps | Cons
hd.index = @lhs.index -- copy rule
tl.index = 1 + @lhs.index
lhs.index = @tl.index -- copy rule
SEM Visit | Visit steps.index = 0
SEM VisitStep | Sim steps.index = 0
lhs.index = @lhs.index -- needed for if we ever allow nested Sims
-- Biggest number of steps in previous blocks that used parallel invocation
-- This number - 1 (minimum 0) is the number of references for parallel invocation created
ATTR VisitSteps VisitStep [ | prevMaxSimRefs : Int | ]
SEM Visit | Visit steps.prevMaxSimRefs = 0
SEM VisitStep | Sim
lhs.prevMaxSimRefs = if @loc.useParallel
then @lhs.prevMaxSimRefs `max` (@steps.index - 1) -- possibly new references made
else @lhs.prevMaxSimRefs -- no references created
-- Is this the last step?
ATTR VisitSteps VisitStep [ | | isLast : Bool ]
ATTR VisitStep [ isLast : Bool | | ]
SEM VisitSteps
| Nil lhs.isLast = True
| Cons lhs.isLast = False
hd.isLast = @tl.isLast
-- Use parallel invocation: only when option enabled and there is more than one visit to a child
SEM VisitSteps VisitStep [ useParallel : Bool | | ]
SEM Visit | Visit steps.useParallel = False
SEM VisitStep | Sim loc.useParallel = parallelInvoke @lhs.options && @steps.size > 1 && @loc.isMonadic
loc.isMonadic = case @lhs.kind of
VisitMonadic -> True
_ -> False
-- Child introduction
ATTR EChild EChildren [ | | childintros USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} ]
ATTR Visits Visit
VisitSteps VisitStep [ childintros : {Map Identifier (VisitKind -> FormatMode -> Either Error (PP_Doc, Set String, Map String (Maybe NonLocalAttr)))} | | ]
SEM EProduction
| EProduction visits.childintros = @children.childintros
SEM EChild
| ETerm lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty))
| EChild lhs.childintros = Map.singleton @name @loc.introcode
loc.isDefor = case @tp of
NT _ _ defor -> defor
_ -> False
loc.valcode = case @kind of
ChildSyntax -> "arg_" >|< @name >|< "_"
ChildAttr -> -- decide if we need to invoke the sem-function under the hood
let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options -- when sepsemmods is not enabled, the indirection can be optimized away
then lateSemNtLabel @loc.nt >#< lhsname @lhs.options True idLateBindingAttr
else "sem_" >|< @loc.nt
| otherwise = empty -- no need to intro a terminal
in pp_parens (prefix >#< instname @name)
ChildReplace _ -> -- the higher-order attribute is actually a function that transforms
-- the semantics of the child (always deforested)
pp_parens (instname @name >#< @name >|< "_")
loc.aroundcode = if @hasAround
then locname @lhs.options @name >|< "_around"
else empty
loc.introcode = \kind fmtMode ->
let pat = text $ stname @name @loc.initSt
patStrict = @loc.addbang pat
attach = "attach_T_" >|< @loc.nt >#< pp_parens (@loc.aroundcode >#< @loc.valcode)
runAttach = unMon @lhs.options >#< pp_parens attach
decl = case kind of
VisitPure False -> pat >#< "=" >#< runAttach
VisitPure True -> patStrict >#< "=" >#< runAttach
VisitMonadic -> patStrict >#< "<-" >#< attach
in if compatibleAttach kind @loc.nt @lhs.options
then Right ( fmtDecl False fmtMode decl
, Set.singleton (stname @name @loc.initSt) -- variables defined by the child intro
, case @kind of -- variables used by the child introduction
ChildAttr -> Map.insert (instname @name) Nothing $ -- the sem attr
( if @loc.isDefor || not (lateHigherOrderBinding @lhs.options)
then id -- the sem dictionary attr is not used
else Map.insert (lhsname @lhs.options True idLateBindingAttr) (Just $ AttrInh _LHS idLateBindingAttr)
) $
( if @hasAround
then Map.insert (locname @lhs.options (@name) ++ "_around") Nothing
else id
) $ Map.empty
ChildReplace _ -> Map.singleton (instname @name) Nothing -- uses the transformation function
ChildSyntax -> Map.empty
)
else Left $ IncompatibleAttachKind @name kind
loc.nt = extractNonterminal @tp
{
stname :: Identifier -> Int -> String
stname child st = "_" ++ getName child ++ "X" ++ show st
-- should actually return some conversion info
compatibleAttach :: VisitKind -> NontermIdent -> Options -> Bool
compatibleAttach _ _ _ = True
unMon :: Options -> PP_Doc
unMon options
| parallelInvoke options = text "System.IO.Unsafe.unsafePerformIO" -- IO monad
| otherwise = text "Control.Monad.Identity.runIdentity" -- identity monad
}
-- rules
ATTR ERules ERule [ | | sem_rules USE {>-<} {empty} : {PP_Doc}
mrules USE {`Map.union`} {Map.empty} : {Map Identifier (VisitKind -> FormatMode -> Either Error PP_Doc)} ]
SEM ERule | ERule
lhs.sem_rules = if @loc.used == 0
then empty
else @loc.rulePragma >-< @loc.rulecode
loc.rulecode = ( if @loc.genpragma
then @loc.pragma -- this additional pragma *may* help to give some AG source location in the presence of
-- type errors in the rule. It will definitely not be precise, and may take some additional
-- source space, but let's see if it's worth it in practice.
else empty
)
>-< @loc.lambda >#< @loc.scc
>-< indent ((column @rhs.pos - 2) `max` 2)
( if @loc.genpragma
then @loc.pragma >-< @rhs.semfunc >-< @loc.endpragma
else @rhs.semfunc
)
loc.rulePragma = ( let reallyInlineStr = "INLINE"
reallyNoInlineStr = "NOINLINE"
in if noInlinePragmas @lhs.options
then empty
else if @loc.used == 1
then ppPragmaBinding reallyInlineStr @name -- always inline if used exactly once
else if helpInlining @lhs.options
then if not @explicit && @loc.used <= reallyOftenUsedThreshold
then ppPragmaBinding "INLINE[1]" @name -- inline if copy rule
else if @loc.used > ruleInlineThresholdSoft && @explicit -- noinline if it passes the threshold and is not a copy rule
then if @loc.used > ruleInlineThresholdHard
then ppPragmaBinding reallyNoInlineStr @name -- used too often: force ghc not to inline it
else if aggressiveInlinePragmas @lhs.options
then ppPragmaBinding "NOINLINE[2]" @name -- allow inlining but only late in the process
else ppNoInline @name
else if aggressiveInlinePragmas @lhs.options
then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first)
else ppNoInline @name
else if not @explicit || @loc.used <= ruleInlineThresholdSoft
then ppPragmaBinding "NOINLINE[1]" @name -- otherwise, let GHC decide (but do other inlining first)
else ppNoInline @name
)
loc.scc = if genCostCentres @lhs.options && @explicit && @pure && not (noPerRuleCostCentres @lhs.options)
then ppCostCentre (@name >|< "_" >|< line @rhs.pos >|< "_" >|< @lhs.nt >|< "_" >|< @lhs.con)
else empty
loc.pragma = "{-# LINE" >#< show (line @rhs.pos) >#< show (file @rhs.pos) >#< "#-}"
loc.endpragma = ppWithLineNr (\ln -> "{-# LINE " ++ show (ln+1) ++ " " ++ show @lhs.mainFile ++ "#-}")
loc.genpragma = genLinePragmas @lhs.options && @explicit && @loc.haspos
loc.haspos = line @rhs.pos > 0 && column @rhs.pos >= 0 && not (null (file @rhs.pos))
-- we generate a simple pattern binding because of overloading-resolving during the type inference process.
-- The types of the rules are not generalized (nor do we want that - rules are used in a single typing-context).
-- If overloading is resolved separately, it may not be clear which dictionaries to use. For that all rules have
-- to be considered together, which is done when we use simple pattern bindings with a lambda expression instead
-- of a function definition.
-- Note: we also ensure that all rules are lambda expressions, so that they are not made part of any closures
-- but are lambda-lifted instead.
loc.lambda = @name >#< "=" >#< "\\" >#< @loc.argPats >#< dummyPat @lhs.options (Map.null @rhs.attrs) >#< "->"
loc.argPats = ppSpaced [ let match | str `Set.member` @lhs.lazyIntras = pp str
| otherwise = @loc.addbang1 (pp str)
in case mbAttr of
Just (AttrSyn child nm) | child == _LOC && not (noPerStateTypeSigs @lhs.options) ->
case Map.lookup nm @lhs.localAttrTypes of
Just tp -> pp_parens (pp_parens match >#< "::" >#< ppTp tp)
Nothing -> match
Just attr | not (noPerRuleTypeSigs @lhs.options) ->
case lookupAttrType attr @lhs.allInhmap @lhs.allSynmap @lhs.childTypes of
Just tpDoc -> pp_parens (pp_parens match >#< "::" >#< tpDoc)
Nothing -> match
_ -> match
| (str,mbAttr) <- Map.assocs @rhs.attrs
]
loc.argExprs = ppSpaced [ case mbAttr of
Nothing -> "arg_" >|< str
_ -> text str
| (str,mbAttr) <- Map.assocs @rhs.attrs
]
loc.stepcode = \kind fmtMode -> if kind `compatibleRule` @pure
then Right $ let oper | @pure = "="
| otherwise = "<-"
decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs)
tp = if @pure && not (noPerRuleTypeSigs @lhs.options)
then @pattern.attrTypes
else empty
in fmtDecl @pure fmtMode (tp >-< decl)
else Left $ IncompatibleRuleKind @name kind
lhs.mrules = Map.singleton @name @loc.stepcode
ATTR Expression [ | | tks : {[HsToken]} ]
SEM Expression
| Expression lhs.tks = @tks
{
dummyPat :: Options -> Bool -> PP_Doc
dummyPat opts noArgs
| not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples
| tupleAsDummyToken opts = if strictDummyToken opts
then text "()"
else text "(_ :: ())"
| otherwise = let match | strictDummyToken opts = "!_"
| otherwise = "_"
in pp_parens (match >#< "::" >#< dummyType opts noArgs)
where match | strictDummyToken opts = "(!_)"
| otherwise = "_"
dummyArg :: Options -> Bool -> PP_Doc
dummyArg opts noArgs
| not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples
| tupleAsDummyToken opts = text "()"
| otherwise = text "GHC.Prim.realWorld#"
dummyType :: Options -> Bool -> PP_Doc
dummyType opts noArgs
| not noArgs && tupleAsDummyToken opts = empty -- no unnecessary tuples
| tupleAsDummyToken opts = text "()"
| otherwise = text "(GHC.Prim.State# GHC.Prim.RealWorld)"
}
{
-- rules are "deinlined" to prevent needless code duplication.
-- if there is only a bit of duplication, we allow ghc to decide if it is worth it.
-- if the duplication crosses this threshold, however, we tell ghc definitely not to inline it.
ruleInlineThresholdSoft :: Int
ruleInlineThresholdSoft = 3
ruleInlineThresholdHard :: Int
ruleInlineThresholdHard = 5
reallyOftenUsedThreshold :: Int
reallyOftenUsedThreshold = 12
}
ATTR Expression [ | | pos : {Pos} ]
SEM Expression | Expression lhs.pos = @pos
-- pattern and expression semantics
ATTR Pattern [ | | sem_lhs : { PP_Doc } ]
ATTR Patterns [ | | sem_lhs USE {:} {[]} : {[PP_Doc]} ]
ATTR Pattern Patterns [ | | ]
SEM Pattern
| Alias loc.varPat = text $ attrname @lhs.options False @field @attr
loc.patExpr = if @pat.isUnderscore
then @loc.varPat
else @loc.varPat >|< "@" >|< @pat.sem_lhs
lhs.sem_lhs = @loc.addbang1 @loc.patExpr
| Product lhs.sem_lhs = @loc.addbang1 $ pp_block "(" ")" "," @pats.sem_lhs
| Constr lhs.sem_lhs = @loc.addbang1 $ pp_parens $ @name >#< hv_sp @pats.sem_lhs
| Underscore lhs.sem_lhs = text "_"
| Irrefutable lhs.sem_lhs = text "~" >|< pp_parens @pat.sem_lhs
-- Check if a pattern is just an underscore
ATTR Pattern [ | | isUnderscore:{Bool}]
SEM Pattern
| Constr lhs.isUnderscore = False
| Product lhs.isUnderscore = False
| Alias lhs.isUnderscore = False
| Underscore lhs.isUnderscore = True
-- Collect the attributes defined by a pattern
ATTR Pattern Patterns [ | | attrs USE {`Set.union`} {Set.empty} : {Set String} ]
SEM Pattern | Alias
lhs.attrs = Set.insert (attrname @lhs.options False @field @attr) @pat.attrs
-- All attribute types of this pattern
ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ]
SEM Pattern | Alias
loc.mbTp = if @field == _LHS
then Map.lookup @attr @lhs.synmap
else if @field == _LOC
then Map.lookup @attr @lhs.localAttrTypes
else Nothing
lhs.attrTypes = maybe empty (\tp -> (attrname @lhs.options False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp
>-< @pat.attrTypes
-- Collect the attributes used by the right-hand side
ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]
SEM HsToken
| AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing
| AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST'
then Nothing -- should not be used in the first place
else Just $ mkNonLocalAttr (@field == _LHS) @field @attr
lhs.attrs = Map.singleton (attrname @lhs.options True @field @attr) @loc.mbAttr
{
data NonLocalAttr
= AttrInh Identifier Identifier
| AttrSyn Identifier Identifier deriving Show
mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr
mkNonLocalAttr True = AttrInh -- True: inherited attr
mkNonLocalAttr False = AttrSyn
lookupAttrType :: NonLocalAttr -> Map Identifier Attributes -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
lookupAttrType (AttrInh child name) inhs _ = lookupType child name inhs
lookupAttrType (AttrSyn child name) _ syns = lookupType child name syns
-- Note: if the child takes type parameters, the type of an attribute of this child may refer to these parameters. This means that
-- the actual type of the attribute needs to have its type parameters substituted with the actual type argument of the child.
-- However, for now we simply decide to return Nothing in this case, which skips the type annotation.
lookupType :: Identifier -> Identifier -> Map Identifier Attributes -> Map Identifier Type -> Maybe PP_Doc
lookupType child name attrMp childMp
| noParameters childTp = Just ppDoc
| otherwise = Nothing
where
attrTp = Map.findWithDefault (error "lookupType: the attribute is not in the attrs of the child") name childAttrs
childAttrs = Map.findWithDefault (error "lookupType: the attributes of the nonterm are not in the map") nonterm attrMp
nonterm = extractNonterminal childTp
childTp = Map.findWithDefault (error ("lookupType: the child " ++ show child ++ "is not in the appropriate map")) child childMp
ppDoc = ppTp attrTp
noParameters :: Type -> Bool
noParameters (Haskell _) = True
noParameters (NT _ args _) = null args
}
ATTR Expression [ | | semfunc : {PP_Doc} ]
SEM Expression
| Expression lhs.attrs = Map.unions $ map (\tok -> attrs_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks
lhs.semfunc = vlist $ showTokens $ map (\tok -> tok_Syn_HsToken (wrap_HsToken (sem_HsToken tok) @loc.inhhstoken)) @tks
loc.inhhstoken = Inh_HsToken @lhs.options
-- child visit map
ATTR Visit
Visits
EProduction
EProductions
ENonterminal
ENonterminals [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))}
| | childvisit USE {`Map.union`} {Map.empty} : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} ]
ATTR VisitSteps VisitStep [ allchildvisit : {Map VisitIdentifier (Identifier -> VisitKind -> Either Error (PP_Doc, PP_Doc))} | | ]
SEM ExecutionPlan
| ExecutionPlan nonts.allchildvisit = @nonts.childvisit
SEM Visit
| Visit
loc.prevVisitInfo = Map.findWithDefault ManyVis @from @lhs.nextVisits
lhs.childvisit = Map.singleton @ident @loc.invokecode
loc.invokecode = \chn kind -> -- "chn" is the name of the child at the place of invocation, and "kind" the kind of the calling visit
if kind `compatibleKind` @kind
then Right $
let pat | isLazyKind @kind = pat0
| otherwise = @loc.addbang pat0
pat0 = pp_parens pat1
pat1 = @loc.nameTOut_visit >#< (ppSpaced $ map (attrname @lhs.options True chn) $ Set.toList @syn)
>#< cont
cont = case @loc.nextVisitInfo of
NoneVis -> empty
_ -> ch1
ch0 = text $ stname chn @from
ch1 = text $ stname chn @to
expr = case (kind, @kind) of
(VisitPure _, VisitPure _) -> expr0
(VisitPure _, VisitMonadic) -> unMon @lhs.options >#< expr0
(VisitMonadic, VisitPure _) -> "return" >#< expr0
(VisitMonadic, VisitMonadic) -> expr0
expr0 = case @loc.prevVisitInfo of
NoneVis -> error "error: invocation of a visit from a state that has no next visits"
OneVis _ -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0 >#< args
ManyVis -> "inv_" >|< @lhs.nt >|< "_s" >|< @from >#< ch0
>#< "K_" >|< @lhs.nt >|< "_v" >|< @ident >#< args
args = pp_parens args0 >#< args1
args0 = @loc.nameTIn_visit >#< @loc.inhargs chn
args1 | dummyTokenVisit @lhs.options = pp $ dummyArg @lhs.options True
| otherwise = empty
in (pat, expr) -- pretty print of the pattern and the expression part
else Left $ IncompatibleVisitKind chn @ident kind @kind
{
-- a `compatibleKind` b means: can kind b be invoked from a
compatibleKind :: VisitKind -> VisitKind -> Bool
compatibleKind _ _ = True
compatibleRule :: VisitKind -> Bool -> Bool
compatibleRule (VisitPure _) False = False
compatibleRule _ _ = True
}
-------------------------------------------------------------------------------
-- Properties of rules
-------------------------------------------------------------------------------
-- Construct an environment that counts how often certain rules are used
ATTR Visits Visit VisitSteps VisitStep [ | | ruleUsage USE {`unionWithSum`} {Map.empty} : {Map Identifier Int} ]
ATTR ERules ERule [ usageInfo : {Map Identifier Int} | | ]
SEM EProduction | EProduction rules.usageInfo = @visits.ruleUsage
SEM VisitStep | Sem lhs.ruleUsage = Map.singleton @name 1
SEM ERule | ERule loc.used = Map.findWithDefault 0 @name @lhs.usageInfo
{
unionWithSum = Map.unionWith (+)
}
-- Collect in what visit-kinds a rule is used
ATTR Visits Visit VisitSteps VisitStep [ | | ruleKinds USE {`unionWithMappend`} {Map.empty} : {Map Identifier (Set VisitKind)} ]
SEM VisitStep | Sem
lhs.ruleKinds = Map.singleton @name (Set.singleton @lhs.kind)
ATTR ERules ERule [ ruleKinds : {Map Identifier (Set VisitKind)} | | ]
SEM EProduction | EProduction
rules.ruleKinds = @visits.ruleKinds
SEM ERule | ERule
loc.kinds = Map.findWithDefault Set.empty @name @lhs.ruleKinds
loc.anyLazyKind = Set.fold (\k r -> isLazyKind k || r) False @loc.kinds
ATTR Pattern Patterns [ anyLazyKind : Bool | | ]
-------------------------------------------------------------------------------
-- Intra attributes
-------------------------------------------------------------------------------
{
uwSetUnion :: (Ord a, Ord b) => Map a (Set b) -> Map a (Set b) -> Map a (Set b)
uwSetUnion = Map.unionWith Set.union
uwMapUnion :: (Ord a, Ord b) => Map a (Map b c) -> Map a (Map b c) -> Map a (Map b c)
uwMapUnion = Map.unionWith Map.union
}
ATTR Visit Visits [ allintramap : {Map StateIdentifier (Map String (Maybe NonLocalAttr))}
| | intramap USE {`uwMapUnion`} {Map.empty} : {Map StateIdentifier (Map String (Maybe NonLocalAttr))} ]
ATTR Visit Visits [ terminaldefs : {Set String} | | ]
ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ]
SEM EChild | ETerm
lhs.terminaldefs = Set.singleton $ fieldname @name
SEM EProduction | EProduction
visits.allintramap = @visits.intramap
visits.terminaldefs = @children.terminaldefs
SEM Visit
| Visit loc.thisintra = (@loc.uses `Map.union` @loc.nextintra) `Map.difference` @loc.defsAsMap
lhs.intramap = Map.singleton @from @loc.thisintra
loc.nextintra = maybe Map.empty id $ Map.lookup @to @lhs.allintramap
loc.uses = let mp1 = @steps.uses
mp2 = Map.fromList [ (lhsname @lhs.options False i, Just (AttrSyn _LHS i)) | i <- Set.elems @syn ]
in mp1 `Map.union` mp2
loc.inhVarNms = Set.map (lhsname @lhs.options True) @inh
loc.defs = @steps.defs `Set.union` @loc.inhVarNms `Set.union` @lhs.terminaldefs
loc.defsAsMap = Map.fromList [ (a, Nothing) | a <- Set.elems @loc.defs ]
ATTR ERule ERules [ | | ruledefs USE {`uwSetUnion`} {Map.empty} : {Map Identifier (Set String)}
ruleuses USE {`uwMapUnion`} {Map.empty} : {Map Identifier (Map String (Maybe NonLocalAttr))} ]
ATTR Visit Visits
VisitSteps VisitStep [ ruledefs : {Map Identifier (Set String)}
ruleuses : {Map Identifier (Map String (Maybe NonLocalAttr))} | | ]
SEM ERule
| ERule lhs.ruledefs = Map.singleton @name @pattern.attrs
lhs.ruleuses = Map.singleton @name @rhs.attrs
SEM EProduction
| EProduction visits.ruledefs = @rules.ruledefs
visits.ruleuses = @rules.ruleuses
ATTR Visit Visits
EProduction
EProductions
ENonterminal
ENonterminals [ | | visitdefs USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)}
visituses USE {`uwSetUnion`} {Map.empty} : {Map VisitIdentifier (Set Identifier)} ]
SEM Visit
| Visit lhs.visitdefs = Map.singleton @ident @syn
lhs.visituses = Map.singleton @ident @inh
ATTR Visit Visits
VisitSteps VisitStep
EProduction EProductions
ENonterminal ENonterminals [ avisitdefs : {Map VisitIdentifier (Set Identifier)}
avisituses : {Map VisitIdentifier (Set Identifier)} | | ]
SEM ExecutionPlan
| ExecutionPlan nonts.avisitdefs = @nonts.visitdefs
nonts.avisituses = @nonts.visituses
ATTR VisitSteps VisitStep [ | | defs USE {`Set.union`} {Set.empty} : {Set String}
uses USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ]
SEM VisitStep
| Sem lhs.defs = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruledefs
lhs.uses = maybe (error "Rule not found") id $ Map.lookup @name @lhs.ruleuses
| ChildVisit lhs.defs = Set.insert (stname @child @to) $ maybe (error "Visit not found") (Set.map $ attrname @lhs.options True @child) $ Map.lookup @visit @lhs.avisitdefs
lhs.uses = let convert attrs = Map.fromList [ (attrname @lhs.options False @child attr, Just $ mkNonLocalAttr True @child attr) | attr <- Set.elems attrs ]
in Map.insert (stname @child @from) Nothing $ convert $
maybe (error "Visit not found") id $ Map.lookup @visit @lhs.avisituses
-------------------------------------------------------------------------------
-- Identification of lazy intra defs within a production
--
-- These identifiers will not be marked as strict in rules and state closures
-------------------------------------------------------------------------------
ATTR Visits Visit VisitSteps VisitStep [ | | lazyIntras USE {`Set.union`} {Set.empty} : {Set String} ]
ATTR ERules ERule [ lazyIntras : {Set String} | | ]
SEM Visit | Visit
loc.lazyIntrasInh = case @kind of
VisitPure False -> @loc.inhVarNms `Set.union` @steps.defs
_ -> Set.empty
lhs.lazyIntras = @loc.lazyIntrasInh `Set.union` @steps.lazyIntras
SEM VisitStep | PureGroup
lhs.lazyIntras = if @ordered
then @steps.lazyIntras
else @steps.defs
SEM EProduction | EProduction
loc.lazyIntras = @visits.lazyIntras
-------------------------------------------------------------------------------
-- Pretty printing of haskell code
-------------------------------------------------------------------------------
SEM HsTokens [ || tks : {[(Pos,String)]} ]
| Cons lhs.tks = @hd.tok : @tl.tks
| Nil lhs.tks = []
SEM HsToken
| AGLocal loc.tok = (@pos,fieldname @var)
SEM HsToken [ || tok:{(Pos,String)}]
| AGField
loc.addTrace = case @rdesc of
Just d -> \x -> "(trace " ++ show (d ++ " -> " ++ show @field ++ "." ++ show @attr) ++ " (" ++ x ++ "))"
Nothing -> id
lhs.tok = (@pos, @loc.addTrace $ attrname @lhs.options True @field @attr)
| HsToken lhs.tok = (@pos, @value)
| CharToken lhs.tok = (@pos, if null @value
then ""
else showCharShort (head @value)
)
| StrToken lhs.tok = (@pos, showStrShort @value)
| Err lhs.tok = (@pos, "")
-------------------------------------------------------------------------------
-- Alternative code generation (sepsemmods)
-------------------------------------------------------------------------------
ATTR ExecutionPlan [ mainBlocksDoc : PP_Doc textBlockMap : {Map BlockInfo PP_Doc}
| | genIO : {IO ()} ]
SEM ExecutionPlan
| ExecutionPlan lhs.genIO = do @loc.genMainModule
@loc.genCommonModule
@nonts.genProdIO
loc.mainModuleFile = @lhs.mainFile
loc.ppMonadImports = ( if tupleAsDummyToken @lhs.options
then empty
else pp "import GHC.Prim"
)
>-< if parallelInvoke @lhs.options
then pp "import qualified System.IO.Unsafe(unsafePerformIO)"
>-< pp "import System.IO(IO)"
>-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"
else pp "import Control.Monad.Identity"
loc.genMainModule = writeModule @loc.mainModuleFile
( [ warrenFlagsPP @lhs.options
, pp $ @lhs.pragmaBlocks
, pp $ @lhs.moduleHeader @lhs.mainName "" "" False
, @loc.ppMonadImports
, pp $ "import " ++ @lhs.mainName ++ "_common"
]
++ @nonts.imports
++ [@lhs.mainBlocksDoc]
++ [@loc.wrappersExtra]
++ @nonts.appendMain
)
loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common")
loc.genCommonModule = writeModule @loc.commonFile
( [ pp $ "{-# LANGUAGE Rank2Types, GADTs #-}" -- the common module only needs GADTs and Rank2Types
, pp $ @lhs.pragmaBlocks
, pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True
, @loc.ppMonadImports
, @lhs.importBlocks
, @lhs.textBlocks
, @loc.commonExtra
]
++ @nonts.appendCommon
)
ATTR ENonterminal [ | | appendCommon, appendMain : { PP_Doc } ]
ATTR ENonterminals [ | | appendCommon, appendMain USE {:} {[]} : {[PP_Doc]} ]
SEM ENonterminal
| ENonterminal lhs.appendMain = (if @nt `Set.member` @lhs.wrappers
then @loc.wr_inh
>-< @loc.wr_syn
>-< @loc.wrapper
else empty)
>-< @loc.sem_nt
lhs.appendCommon = (if dataTypes @lhs.options then @loc.datatype else empty)
>-< @loc.t_init
>-< @loc.t_states
>-< @loc.k_states
>-< @prods.t_visits
ATTR EProduction EProductions
ENonterminal ENonterminals [ | | imports USE {++} {[]} : {[PP_Doc]}
genProdIO USE {>>} {return ()} : {IO ()} ]
SEM EProduction
| EProduction lhs.imports = [pp $ "import " ++ @loc.moduleName]
loc.moduleName = @lhs.mainName ++ @loc.suffix
loc.suffix = "_" ++ show @lhs.nt ++ "_" ++ show @con
loc.outputfile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ @loc.suffix)
loc.ppMonadImports = if parallelInvoke @lhs.options
then pp "import qualified System.IO.Unsafe(unsafePerformIO)"
>-< pp "import System.IO(IO)"
>-< pp "import Control.Concurrent(newEmptyMVar,forkIO,putMVar,takeMVar)"
else pp "import Control.Monad.Identity"
lhs.genProdIO = writeModule @loc.outputfile
[ warrenFlagsPP @lhs.options
, pp $ @lhs.pragmaBlocks
, pp $ @lhs.moduleHeader @lhs.mainName @loc.suffix @loc.semname True
, @lhs.importBlocks
, @loc.ppMonadImports
, ( if tupleAsDummyToken @lhs.options
then empty
else pp "import GHC.Prim" -- need it to pass State#
)
, pp $ "import " ++ @lhs.mainName ++ "_common"
, @loc.sem_prod
]
{
renderDocs :: [PP_Doc] -> String
renderDocs pps = foldr (.) id (map (\d -> (disp d 50000) . ( '\n':) ) pps) ""
writeModule :: FilePath -> [PP_Doc] -> IO ()
writeModule path docs
= do bExists <- doesFileExist path
if bExists
then do input <- readFile path
seq (length input) (return ())
if input /= output
then dumpIt
else return ()
else dumpIt
where
output = renderDocs docs
dumpIt = writeFile path output
}
--
-- Bang pattern usage
--
SEM ERule | ERule loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
SEM Visit | Visit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
SEM ENonterminal | ENonterminal loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
SEM EProduction | EProduction loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
SEM EChild | EChild loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
SEM EChild | ETerm loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
SEM VisitStep | ChildVisit loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
SEM Pattern | Alias Constr Product loc.addbang = \x -> if bangpats @lhs.options then "!" >|< x else x
SEM Visit | Visit loc.addbang1 = if isLazyKind @kind then id else @loc.addbang
SEM ENonterminal | ENonterminal loc.addbangWrap = id --if strictWrap @lhs.options then @loc.addbang else id
SEM ERule | ERule loc.addbang1 = if @loc.anyLazyKind then id else @loc.addbang
SEM Pattern | Alias Constr Product loc.addbang1 = if @lhs.anyLazyKind then id else @loc.addbang
--
-- Distribute single-visit-next map downward
--
ATTR EProductions EProduction Visits Visit
[ prevVisits, nextVisits : {Map StateIdentifier StateCtx} | | ]
SEM ENonterminal | ENonterminal
prods.nextVisits = @nextVisits
prods.prevVisits = @prevVisits
--
-- Collect and distribute the from/to states of a visit
--
ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit
[ | | fromToStates USE {`mappend`} {mempty} : {Map VisitIdentifier (Int,Int)} ]
ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep
[ allFromToStates : {Map VisitIdentifier (Int,Int)} | | ]
SEM Visit | Visit
lhs.fromToStates = Map.singleton @ident (@from, @to)
SEM ExecutionPlan | ExecutionPlan
nonts.allFromToStates = @nonts.fromToStates
SEM VisitStep | ChildVisit
(loc.from, loc.to) = Map.findWithDefault (error "visit not in allFromToStates") @visit @lhs.allFromToStates
--
-- Collect and distribute the actual types of children of productions
--
ATTR EChildren EChild [ | | childTypes USE {`mappend`} {mempty} : {Map Identifier Type} ]
ATTR ERules ERule Visits Visit VisitSteps VisitStep [ childTypes : {Map Identifier Type} | | ]
SEM EProduction | EProduction
loc.childTypes = Map.singleton _LHS @lhs.ntType `Map.union` @children.childTypes
SEM EChild | EChild ETerm
lhs.childTypes = Map.singleton @name @tp
--
-- Distribute types of local attributes
--
ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ]
ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ]
ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ]
SEM ENonterminal | ENonterminal
prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes
SEM EProduction | EProduction
loc.localAttrTypes = Map.findWithDefault Map.empty @con @lhs.localAttrTypes
--
-- Collect and distribute visit kinds
--
ATTR ENonterminals ENonterminal EProductions EProduction Visits Visit VisitSteps VisitStep
[ allVisitKinds : {Map VisitIdentifier VisitKind} | | visitKinds USE {`mappend`} {mempty} : {Map VisitIdentifier VisitKind} ]
SEM Visit | Visit
lhs.visitKinds = Map.singleton @ident @kind
SEM ExecutionPlan | ExecutionPlan
nonts.allVisitKinds = @nonts.visitKinds
--
-- Collect and distribute the initial state of nonterminals
--
ATTR ENonterminals ENonterminal [ | | initStates USE {`mappend`} {mempty} : {Map NontermIdent Int} ]
ATTR ENonterminals ENonterminal EProductions EProduction EChildren EChild Visits Visit VisitSteps VisitStep
[ allInitStates : {Map NontermIdent Int} | | ]
SEM ENonterminal | ENonterminal
lhs.initStates = Map.singleton @nt @initial
SEM ExecutionPlan | ExecutionPlan
nonts.allInitStates = @nonts.initStates
SEM EChild | EChild
loc.initSt = Map.findWithDefault (error "nonterminal not in allInitStates map") @loc.nt @lhs.allInitStates
--
-- Push the nonterminal type downward
--
ATTR EProductions EProduction [ ntType : Type | | ]
SEM ENonterminal | ENonterminal
loc.ntType = NT @nt (map show @params) False
--
-- Collect errors contained in rules that should be yielded when the
-- rules are scheduled.
--
ATTR ExecutionPlan ENonterminals ENonterminal EProductions EProduction ERules ERule Visits Visit VisitSteps VisitStep [ | | errors USE {Seq.><} {Seq.empty} : {Seq Error} ]
SEM ERule | ERule
lhs.errors = case @mbError of
Just e | @loc.used > 0 -> Seq.singleton e
_ -> Seq.empty
-- Some pretty printing utility functions
{
ppNoInline :: PP a => a -> PP_Doc
ppNoInline = ppPragmaBinding "NOINLINE"
ppInline :: PP a => a -> PP_Doc
ppInline = ppPragmaBinding "INLINE"
ppInlinable :: PP a => a -> PP_Doc
ppInlinable = ppPragmaBinding "INLINABLE"
ppPragmaBinding :: (PP a, PP b) => a -> b -> PP_Doc
ppPragmaBinding pragma nm = "{-#" >#< pragma >#< nm >#< "#-}"
ppCostCentre :: PP a => a -> PP_Doc
ppCostCentre nm = "{-#" >#< "SCC" >#< "\"" >|< nm >|< "\"" >#< "#-}"
warrenFlagsPP :: Options -> PP_Doc
warrenFlagsPP options = vlist
[ pp "{-# LANGUAGE Rank2Types, GADTs #-}"
, if bangpats options
then pp "{-# LANGUAGE BangPatterns #-}"
else empty
, if noPerRuleTypeSigs options && noPerStateTypeSigs options
then empty
else pp "{-# LANGUAGE ScopedTypeVariables #-}"
, if tupleAsDummyToken options
then empty
else pp "{-# LANGUAGE ScopedTypeVariables, MagicHash #-}"
, -- not that the meaning of "unbox" is here that strict fields in data types may be
-- unboxed if possible. This may affect user-defined data types declared in the module.
-- Unfortunately, we cannot turn it on for only the AG generated data types without
-- causing a zillion of warnings.
if unbox options && bangpats options
then pp $ "{-# OPTIONS_GHC -funbox-strict-fields -fstrictness #-}"
else empty
, if parallelInvoke options && not (noEagerBlackholing options)
then pp $ "{-# OPTIONS_GHC -feager-blackholing #-}"
else empty
]
}