uuagc-0.9.42.3: src-ag/GenerateCode.ag
PRAGMA strictwrap
PRAGMA strictdata
INCLUDE "CodeSyntax.ag"
INCLUDE "Patterns.ag"
INCLUDE "DeclBlocks.ag"
imports
{
import CommonTypes
import SequentialTypes
import Code hiding (Type)
import qualified Code
import Options
import CodeSyntax
import ErrorMessages
import GrammarInfo
import DeclBlocks
import qualified Data.Map as Map
import Data.Map(Map)
import qualified Data.Set as Set
import Data.Set(Set)
import qualified Data.Sequence as Seq
import Data.Sequence(Seq)
import UU.Scanner.Position
import TokenDef
import HsToken
import HsTokenScanner
import Data.List(partition,intersperse)
import Data.Maybe(fromJust,isJust)
}
-------------------------------------------------------------------------------
-- Options
-------------------------------------------------------------------------------
ATTR CNonterminals CNonterminal
CProductions CProduction
CVisits CVisit
Sequence CRule
CInterface CSegments CSegment
[ o_unbox,o_sig,o_sem,o_newtypes,o_case,o_pretty,o_rename,o_cata,o_strictwrap,o_splitsems,o_traces,o_costcentre,o_linePragmas,o_monadic : Bool
o_data : {Maybe Bool}
prefix : String
options : Options
| | ]
SEM CGrammar [ options : Options | | ]
| CGrammar nonts.o_sig = typeSigs @lhs.options
.o_cata = folds @lhs.options
.o_sem = semfuns @lhs.options
.o_newtypes = newtypes @lhs.options
.o_unbox = unbox @lhs.options
.o_case = cases @lhs.options
.o_pretty = attrInfo @lhs.options
.o_rename = rename @lhs.options
.o_strictwrap = strictWrap @lhs.options
.o_splitsems = splitSems @lhs.options
.o_data = if dataTypes @lhs.options then Just (strictData @lhs.options) else Nothing
.prefix = prefix @lhs.options
.o_traces = genTraces @lhs.options
.o_costcentre = genCostCentres @lhs.options
.o_linePragmas = genLinePragmas @lhs.options
.o_monadic = monadic @lhs.options
SEM CGrammar | CGrammar
loc.options = @lhs.options { breadthFirst = breadthFirst @lhs.options && visit @lhs.options && cases @lhs.options && @multivisit }
ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ allPragmas : PragmaMap | | ]
SEM CGrammar
| CGrammar nonts.allPragmas = @pragmas
-------------------------------------------------------------------------------
-- Passing information about nonterminal and constructor down
-------------------------------------------------------------------------------
ATTR CProductions CProduction CVisits
CVisit Sequence CRule CInterface
CSegments CSegment [ nt:NontermIdent inh,syn:Attributes | | ]
SEM CNonterminal
| CNonterminal inter.(inh,syn,nt) = (@inh,@syn,@nt)
prods.(inh,syn,nt) = (@inh,@syn,@nt)
ATTR CVisits CVisit Sequence CRule [ con:ConstructorIdent
terminals : {[Identifier]} | | ]
SEM CProduction
| CProduction visits.con = @con
visits.terminals = @terminals
ATTR CNonterminals CNonterminal CSegments CSegment CInterface CProductions CProduction CVisits CVisit Sequence CRule [ paramMap : ParamMap | | ]
SEM CGrammar
| CGrammar nonts.paramMap = @paramMap
ATTR CVisits CVisit Sequence CRule [ paramInstMap : {Map Identifier (NontermIdent, [String])} | | ]
SEM CProduction
| CProduction
loc.paramInstMap = Map.fromList [(nm, (extractNonterminal tp, tps)) | (nm,tp,_) <- @children, let tps = map cleanupArg $ nontermArgs tp, not (null tps) ]
{
-- remove possible @v references in the types of a data type.
cleanupArg :: String -> String
cleanupArg s
= case idEvalType (SimpleType s) of
SimpleType s' -> s'
_ -> error "Only SimpleType supported"
}
ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ contextMap : {ContextMap} quantMap : QuantMap | | ]
SEM CGrammar
| CGrammar
nonts.contextMap = @contextMap
nonts.quantMap = @quantMap
{
appContext :: ContextMap -> NontermIdent -> Code.Type -> Code.Type
appContext mp nt tp
= maybe tp (\ctx -> CtxApp (map (\(n,ns) -> (getName n, ns)) ctx) tp) $ Map.lookup nt mp
appQuant :: QuantMap -> NontermIdent -> Code.Type -> Code.Type
appQuant mp nt tp
= foldr QuantApp tp $ Map.findWithDefault [] nt mp
}
ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ allNts : {Set NontermIdent} | | ]
SEM CGrammar
| CGrammar
nonts.allNts = @nonts.gathNts
ATTR CNonterminals CNonterminal [ | | gathNts USE {`Set.union`} {Set.empty} : {Set NontermIdent} ]
SEM CNonterminal
| CNonterminal
lhs.gathNts = Set.singleton @nt
-- keep track of which children have had their first visit
ATTR CVisits CVisit Sequence CRule [ | visitedSet : {Set Identifier} | ]
SEM CProduction | CProduction visits.visitedSet = Set.empty
SEM CRule | CChildVisit loc.visitedSet = Set.insert @name @lhs.visitedSet
-------------------------------------------------------------------------------
-- Generating declarations from the sequence. We generate the origin
-- comment if pretty printing is requested. A childvisit takes inherited
-- attributes and returns synthesized attributes and the next visit.
-------------------------------------------------------------------------------
ATTR Sequence CRule [ | | decls USE {++} {[]} : {Decls} ]
SEM CRule
| CRule loc.instTypes = [ (n, (t, mb, for)) | (n, NT t _ for, mb) <- @lhs.children ]
loc.originComment = if @lhs.o_pretty
then (Comment @origin:)
else id
loc.instDecls = [ mkDecl @lhs.o_monadic (Pattern3 (Alias _INST' inst (Underscore (getPos inst))))
( let (nm,mb,defor) = fromJust $ inst `lookup` @loc.instTypes
in unwrapSem @lhs.o_newtypes nm
$ case mb of
ChildReplace _ -> App instLocFieldName [SimpleExpr $ fieldname inst]
_ ->
if defor
then SimpleExpr instLocFieldName
else App (cataname @lhs.prefix nm)
[SimpleExpr instLocFieldName]
)
(Set.singleton instSemFieldName)
(Set.singleton instLocFieldName)
| inst <- @loc.definedInsts
, let instLocFieldName = attrname True _INST inst
instSemFieldName = attrname False _INST' inst
]
loc.patDescr = if @isIn
then "_"
else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) @pattern.patternAttributes)
loc.traceDescr = (maybe "" (\nm -> show nm ++ ":") @mbNamed) ++ show @nt ++ " :: " ++ show @con ++ " :: " ++ @loc.patDescr
loc.addTrace = \v -> if @lhs.o_traces
then Trace @loc.traceDescr v
else v
loc.costCentreDescr = show @nt ++ ":" ++ show @con ++ ":" ++ @loc.patDescr
loc.addCostCentre = \v -> if @lhs.o_costcentre
then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v
else v
loc.addLinePragma = \v -> let p = getPos @name
hasPos = line p > 0 && column p >= 0 && not (null (file p))
in if @lhs.o_linePragmas && hasPos
then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p))
$ LineExpr
$ v
else v
loc.decls = if @hasCode
then @originComment ( mkDecl (@lhs.o_monadic && @explicit) (Pattern3 @pattern.copy) (@loc.addTrace $ @loc.addCostCentre $ @loc.addLinePragma $ (TextExpr @rhs))
(Set.fromList [attrname False fld nm | (fld,nm,_) <- Map.elems @defines])
(Set.fromList [attrname True fld nm | (fld,nm) <- Set.toList @uses])
: @loc.instDecls)
else @loc.instDecls
| CChildVisit loc.costCentreDescr = show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @name ++ ":" ++ show @nt ++ ":" ++ show @nr
loc.addCostCentre = \v -> if @lhs.o_costcentre
then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v
else v
loc.decls = let lhsVars = map (attrname True @name) (Map.keys @syn)
++ if @isLast then [] else [unwrap ++ funname @name (@nr+1)]
rhsVars = map (attrname False @name) (Map.keys @inh)
unwrap = if @lhs.o_newtypes then typeName @nt (@nr + 1) ++ " " else ""
tuple | isMerging = TupleLhs [locname @name ++ "_comp"]
| otherwise = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars
rhs = @loc.addCostCentre $ Code.InvokeExpr (typeName @nt @nr) (SimpleExpr fun) (map SimpleExpr rhsVars)
isVirtual _ [] = False
isVirtual nm ((n,_,kind) : r)
| nm == n = case kind of
ChildAttr -> True
_ -> False
| otherwise = isVirtual nm r
isMerged = @name `Map.member` @lhs.mergeMap
isMerging = @name `elem` concatMap (\(_,cs) -> cs) (Map.elems @lhs.mergeMap)
merges = [ (c,cs) | (c,(_,cs)) <- Map.assocs @lhs.mergeMap, all (`Set.member` @loc.visitedSet) cs, @name `elem` (c:cs) ]
baseNm = if @nr == 0 && isVirtual @name @lhs.children
then Ident (getName @name ++ "_inst") (getPos @name)
else @name
fun | @nr == 0 && Set.member @name @lhs.aroundMap
= locname @name ++ "_around " ++ funname baseNm 0
| otherwise = funname baseNm @nr
outDecls | isMerged = [] -- merged variant is only produced after the last visit of the merged children
| otherwise = -- [mkDecl @lhs.o_monadic tuple rhs (Set.fromList lhsVars) (Set.fromList (funname baseNm @nr : rhsVars))]
if isMerging
then [mkDecl @lhs.o_monadic tuple rhs Set.empty Set.empty]
else [Resume @lhs.o_monadic (typeName @nt @nr) tuple rhs]
outMerged | null merges || @nr /= 0 = [] -- no merged child to produce
| otherwise = let (c,cs) = head merges
tuple' = mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars'
lhsVars' = map (attrname True c) (Map.keys @syn)
++ if @isLast then [] else [unwrap ++ funname c (@nr+1)]
rhsVars' = [ locname c' ++ "_comp" | c' <- cs ]
fun' = locname c ++ "_merge"
rhs' = App fun' (map SimpleExpr rhsVars')
in [Resume @lhs.o_monadic (typeName @nt @nr) tuple' rhs']
in -- trace (show @name ++ " # " ++ show @loc.visitedSet ++ " # " ++ show (Map.assocs @lhs.mergeMap) ++ " # " ++ show merges ++ " # " ++ show @nr ++ " # " ++ show (length outMerged)) $
(outDecls ++ outMerged)
{
mkDecl :: Bool -> Lhs -> Expr -> Set String -> Set String -> Decl
mkDecl True lhs rhs _ _ = Bind lhs rhs
mkDecl False lhs rhs s1 s2 = Decl lhs rhs s1 s2
unwrapSem :: Bool -> NontermIdent -> Expr -> Expr
unwrapSem False _ e = e
unwrapSem True nm e = Case e alts
where alts = [CaseAlt left right]
left = Fun (typeName nm 0) [SimpleExpr "x"]
right = SimpleExpr "x"
}
ATTR Sequence CRule [ children : {[(Identifier,Type,ChildKind)]} ||]
ATTR Sequence CRule Pattern Patterns [|| definedInsts USE {++} {[]} : {[Identifier]} ]
SEM Pattern
| Alias lhs.definedInsts = (if @field == _INST then [@attr] else []) ++ @pat.definedInsts
SEM CRule
| CRule loc.definedInsts = if @isIn then [] else @pattern.definedInsts
ATTR Pattern Patterns [ | | patternAttributes USE {++} {[]} : {[(Identifier, Identifier)]} ]
SEM Pattern
| Alias
lhs.patternAttributes = (@field,@attr) : @pat.patternAttributes
-------------------------------------------------------------------------------
-- Numbering the visits
-------------------------------------------------------------------------------
ATTR CVisits CVisit Sequence CRule
CSegments CSegment [ nr : Int | | ]
SEM CProduction
| CProduction visits.nr = 0
SEM CVisits
| Cons tl.nr = @lhs.nr + 1
SEM CInterface
| CInterface seg.nr = 0
SEM CSegments
| Cons tl.nr = @lhs.nr + 1
-------------------------------------------------------------------------------
-- Checking last visit
-------------------------------------------------------------------------------
ATTR CVisit CSegment [ isLast : Bool | | ]
ATTR CVisits CSegments [ | | isNil : Bool ]
SEM CVisits
| Cons lhs.isNil = False
hd.isLast = @tl.isNil
| Nil lhs.isNil = True
SEM CSegments
| Cons lhs.isNil = False
hd.isLast = @tl.isNil
| Nil lhs.isNil = True
-------------------------------------------------------------------------------
-- Getting the next intra-visit dependencies
-------------------------------------------------------------------------------
ATTR CVisit [ nextIntra : {Exprs} nextIntraVars : {Set String} | | ]
ATTR CVisits CVisit [ | | intra : {Exprs} intraVars : {Set String} ]
SEM CVisit
| CVisit lhs.intra = @intra.exprs
lhs.intraVars = @intra.usedVars
SEM CVisits
| Cons hd.nextIntra = @tl.intra
hd.nextIntraVars = @tl.intraVars
lhs.intra = @hd.intra
lhs.intraVars = @hd.intraVars
| Nil lhs.intra = []
lhs.intraVars = Set.empty
-------------------------------------------------------------------------------
-- Superfluous intra-visit dependencies due to higher-order children
-- (higher-order children can only be passed from their moment of creation)
-------------------------------------------------------------------------------
SEM CRule
| CChildVisit
loc.isSuperfluousHigherOrderIntra
= @lhs.nr <= Map.findWithDefault (-1) @name @lhs.instVisitNrs
-------------------------------------------------------------------------------
-- Intra-visit dependencies are expressions that need to be passed
-------------------------------------------------------------------------------
ATTR Sequence CRule [ | | exprs USE {++} {[]} : {Exprs} ]
SEM CRule
| CRule loc.rulename = if @field == _LOC && @name `elem` @lhs.terminals
then funname @name 0
else attrname @isIn @field @name
lhs.exprs = [SimpleExpr @loc.rulename]
| CChildVisit
loc.names = -- do not pass inst-childs as parameter if they are not defined yet
if @loc.isSuperfluousHigherOrderIntra
then []
else [funname @name (@nr+1)]
lhs.exprs = let wrap = if @lhs.o_newtypes then \x -> App (typeName @nt (@nr + 1)) [x] else id
addType expr | null @loc.instParams = expr
| otherwise = TypedExpr expr (@lhs.unfoldSemDom @nt (@nr+1) @loc.instParams)
in map (wrap . addType . SimpleExpr) @loc.names
ATTR Sequence CRule [ | | usedVars USE {`Set.union`} {Set.empty} : {Set String} ]
SEM CRule
| CRule
lhs.usedVars = Set.singleton @loc.rulename
| CChildVisit
lhs.usedVars = Set.fromList @loc.names
-------------------------------------------------------------------------------
-- Type signatures are added to the declarations.
-------------------------------------------------------------------------------
ATTR Sequence CRule [ | | tSigs USE {++} {[]} : {[Decl]} ]
SEM CRule
| CRule loc.mkTp = typeToCodeType (Just @lhs.nt) @loc.orgParams
lhs.tSigs = [ TSig (attrname False field attr) tp'
| (field,attr,tp) <- Map.elems @defines, isJust tp
, let tp1 = @loc.evalTp field $ @mkTp (fromJust tp)
tp' = case findOrigType attr @lhs.children of
Just tp'' -> let tp2 = @loc.evalTp field $ @mkTp tp''
in Arr tp2 tp1
Nothing -> tp1
findOrigType _ [] = Nothing
findOrigType nm ((n,_,kind) : r)
| nm == n = case kind of
ChildReplace orig -> Just orig
_ -> Nothing
| otherwise = findOrigType nm r
]
loc.orgParams = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap
loc.evalTp =
\field tp -> let orgFldParams = map getName $ Map.findWithDefault [] childNt @lhs.paramMap
(childNt,instParams) = Map.findWithDefault (@lhs.nt,[]) field @lhs.paramInstMap
replMap = Map.fromList (zip orgFldParams instParams)
replace k = Map.findWithDefault ('@':k) k replMap
in if null instParams
then if null @orgParams
then tp
else idEvalType tp
else evalType replace tp
| CChildVisit loc.mkTp = @loc.evalTp . typeToCodeType (Just @nt) @loc.orgParams
loc.definedTps = [ TSig (attrname True @name a) (@mkTp tp) | (a,tp) <- Map.toList @syn ]
loc.nextTp = typeName @nt (@nr+1)
lhs.tSigs = (if @isLast then id else (TSig (funname @name (@nr+1)) (TypeApp (SimpleType @nextTp) (map SimpleType @loc.instParams)) :)) @definedTps
loc.orgParams = map getName $ Map.findWithDefault [] @nt @lhs.paramMap
loc.instParams = snd $ Map.findWithDefault (@nt,[]) @name @lhs.paramInstMap
loc.replParamMap = Map.fromList (zip @loc.orgParams @loc.instParams)
loc.replace = \k -> Map.findWithDefault k k @loc.replParamMap
loc.evalTp = if null @loc.orgParams then id else evalType @loc.replace
-------------------------------------------------------------------------------
-- Types of intra-visit dependencies are needed in the type of the
-- semantic function.
-------------------------------------------------------------------------------
ATTR CVisits CVisit [ children : {[(Identifier,Type, ChildKind)]} | | ]
SEM CProduction
| CProduction visits.children = @children
ATTR Sequence CRule [ | | tps USE {++} {[]} : {[Type]}
allTpsFound USE {&&} {True} : Bool ]
SEM CRule
| CRule lhs.(tps,allTpsFound) = maybe ([],False) (\tp -> ([tp],True)) @tp
| CChildVisit lhs.tps = if @loc.isSuperfluousHigherOrderIntra
then []
else [NT (ntOfVisit @nt (@nr+1)) @loc.instParams False]
-------------------------------------------------------------------------------
-- Each visit has its semantic function
-------------------------------------------------------------------------------
ATTR CVisits [ | | decls : {Decls} ]
ATTR CVisit [ | decls : {Decls} | ]
SEM CVisits
| Nil lhs.decls = []
| Cons lhs.decls = @hd.decls
hd.decls = @tl.decls
-- Note: lhs.decls are the decls related to the next visit function. We pass it
-- chained from right to left in order to build the next visit function inside
-- the previous one.
-- Note: intra decls are ignored. The intra-visit variables are not passed on
-- explicitly, but handled automatically due to nesting level.
SEM CVisit
| CVisit (loc.higherOrderChildren,loc.firstOrderChildren) = partition (\(_,_,virt) -> isHigherOrder virt) @lhs.children
loc.firstOrderOrig = map pickOrigType @loc.firstOrderChildren
loc.funcname = seqSemname @lhs.prefix @lhs.nt @lhs.con @lhs.nr
loc.nextVisitName = if @lhs.isLast then [] else [visitname @lhs.prefix @lhs.nt (@lhs.nr+1)]
loc.nextVisitDecl = let lhs = TupleLhs @nextVisitName
-- rhs = App fun @lhs.nextIntra
rhs = Let @lhs.decls (SimpleExpr fun)
fun = seqSemname @lhs.prefix @lhs.nt @lhs.con (@lhs.nr+1)
in if @lhs.isLast
then []
else [Decl lhs rhs (Set.fromList @nextVisitName) @lhs.nextIntraVars]
loc.isOneVisit = @lhs.isLast && @lhs.nr == 0
loc.hasWrappers = @lhs.nt `Set.member` @lhs.wrappers
loc.refDecls = if @loc.isOneVisit && @loc.hasWrappers && reference @lhs.options
then let synAttrs = Map.toList @syn
synNT = "Syn" ++ "_" ++ getName @lhs.nt
synVars = [ SimpleExpr (attrname False _LHS a) | (a,_) <- synAttrs ]
rhs = App synNT synVars
lhs = Fun "___node" []
in [Decl lhs rhs Set.empty Set.empty]
else []
loc.decls = @typeSigs ++ @vss.decls ++ @nextVisitDecl ++ @loc.refDecls
vss.lastExpr = mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh) $ map (SimpleExpr . lhsname False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName
intra.lastExpr = error "lastExpr: not used here"
loc.lastExprVars = map (lhsname False) (Map.keys @syn) ++ @loc.nextVisitName
(loc.blockFunDecls, loc.blockFirstFunCall) = mkPartitionedFunction @loc.funcname @loc.o_case @loc.nextVisitDecl @loc.lastExprVars @vss.blockDecls
loc.costCentreDescr = "b" ++ ":" ++ show @lhs.nt ++ ":" ++ show @lhs.con ++ ":" ++ show @lhs.nr
loc.addCostCentre = \v -> if @lhs.o_costcentre
then PragmaExpr True False ("SCC \"" ++ @loc.costCentreDescr ++ "\"") v
else v
loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap
loc.semFun = let lhs = Fun @funcname lhs_args
lhs_args = if @lhs.nr == 0 then map field @loc.firstOrderOrig else [] -- @intra.exprs
field (name,NT tp tps _,_) = let unwrap | @lhs.o_newtypes = \x -> App (sdtype tp) [x]
| otherwise = id
addType expr | null tps = expr
| otherwise = TypedExpr expr (@lhs.unfoldSemDom tp 0 tps)
in unwrap $ addType $ SimpleExpr $ funname name 0
field (name,tp,_) = let expr = SimpleExpr (funname name 0)
in if null @loc.params
then expr
else TypedExpr expr (idEvalType $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp)
mbEvalTp | null @loc.params = const Nothing
| otherwise = Just . idEvalType
rhs = wrap
. mkSemFun @lhs.nt @lhs.nr [mkLambdaArg (lhsname True nm) (mbEvalTp $ typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested tp) | (nm,tp) <- Map.assocs @inh]
$ @loc.addCostCentre
$ if @ordered && @loc.o_splitsems
then @loc.blockFirstFunCall
else mkDecls @loc.declsType @decls
. ResultExpr (typeName @lhs.nt @lhs.nr)
. mkTupleExpr @lhs.o_unbox (null $ Map.keys @inh)
$ map (SimpleExpr . lhsname False) (Map.keys @syn) ++ map SimpleExpr @nextVisitName
wrap = if @lhs.o_newtypes
then \x -> App (typeName @lhs.nt @lhs.nr) [x]
else id
in Decl lhs rhs Set.empty Set.empty
loc.tsig = TSig @funcname @semType
loc.semType = let argType (NT tp tps _) r | tp /= _SELF = typeAppStrs (sdtype tp) tps `Arr` r
| tp == _SELF = error "GenerateCode: found an intra-type with type SELF, which should have been prevented by CRule.tps"
argType (Haskell tp) r = SimpleType tp `Arr` r
argType _ _ = error "Self type not allowed here"
evalTp | null @loc.params = id
| otherwise = idEvalType
in appQuant @lhs.quantMap @lhs.nt $ appContext @lhs.contextMap @lhs.nt $ evalTp $
if @lhs.nr == 0
then foldr argType (typeAppStrs (sdtype @lhs.nt ) @loc.params) (map (\(_,t,_) -> t) @loc.firstOrderOrig)
else foldr argType (typeAppStrs (typeName @lhs.nt @lhs.nr) @loc.params) [] -- @intra.tps
lhs.decls = ( if @lhs.with_sig
then [@tsig, @semFun]
else [@semFun]
) ++
( if @ordered && @loc.o_splitsems
then @loc.blockFunDecls
else []
)
loc.typeSigs = if @lhs.o_sig && not @o_case
then @vss.tSigs
else []
loc.o_do = @ordered && @lhs.o_monadic
loc.o_case = not @loc.o_do && @lhs.o_case && @ordered && not (hasPragma @lhs.allPragmas @lhs.nt @lhs.con _NOCASE)
loc.declsType = if @loc.o_do
then DeclsDo
else if @loc.o_case
then DeclsCase
else DeclsLet
loc.o_splitsems = @ordered && @lhs.o_splitsems
{
mkLambdaArg :: String -> Maybe Code.Type -> Expr
mkLambdaArg nm Nothing = SimpleExpr nm
mkLambdaArg nm (Just tp) = TypedExpr (SimpleExpr nm) tp
mkLambda :: Exprs -> Expr -> Expr
mkLambda [] e = e
mkLambda xs e = Lambda xs e
mkSemFun :: Identifier -> Int -> Exprs -> Expr -> Expr
mkSemFun nt nr xs e = SemFun (typeName nt nr) xs e
typeAppStrs :: String -> [String] -> Code.Type
typeAppStrs nm params = TypeApp (SimpleType nm) (map SimpleType params)
isHigherOrder :: ChildKind -> Bool
isHigherOrder ChildAttr = True
isHigherOrder _ = False
pickOrigType :: (Identifier, Type, ChildKind) -> (Identifier, Type, ChildKind)
pickOrigType (nm, _, virt@(ChildReplace x)) = (nm, x, virt)
pickOrigType x = x
}
ATTR CVisits CVisit Sequence CRule [ instVisitNrs : {Map Identifier Int} || ]
ATTR CVisits CVisit [|| gatherInstVisitNrs USE {`Map.union`} {Map.empty} : {Map Identifier Int} ]
SEM CProduction
| CProduction
visits.instVisitNrs = @visits.gatherInstVisitNrs
SEM CVisit
| CVisit
lhs.gatherInstVisitNrs = Map.fromList [(i,@lhs.nr) | i <- @vss.definedInsts]
-------------------------------------------------------------------------------
-- Push aroundsMap downward
-------------------------------------------------------------------------------
ATTR CNonterminals CNonterminal
[ aroundMap : {Map NontermIdent (Map ConstructorIdent (Set Identifier))} || ]
ATTR CProductions CProduction
[ aroundMap : {Map ConstructorIdent (Set Identifier)} || ]
ATTR CVisits CVisit Sequence CRule [ aroundMap : {Set Identifier} | | ]
SEM CGrammar | CGrammar loc.aroundMap = @aroundsMap
SEM CNonterminal | CNonterminal loc.aroundMap = Map.findWithDefault Map.empty @nt @lhs.aroundMap
SEM CProduction | CProduction loc.aroundMap = Map.findWithDefault Set.empty @con @lhs.aroundMap
-------------------------------------------------------------------------------
-- Push mergeMap downward
-------------------------------------------------------------------------------
ATTR CNonterminals CNonterminal
[ mergeMap : {Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))} || ]
ATTR CProductions CProduction
[ mergeMap : {Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))} || ]
ATTR CVisits CVisit Sequence CRule [ mergeMap : {Map Identifier (Identifier, [Identifier])} | | ]
SEM CGrammar | CGrammar loc.mergeMap = @mergeMap
SEM CNonterminal | CNonterminal loc.mergeMap = Map.findWithDefault Map.empty @nt @lhs.mergeMap
SEM CProduction | CProduction loc.mergeMap = Map.findWithDefault Map.empty @con @lhs.mergeMap
-------------------------------------------------------------------------------
-- Generate a partitioned version of the sequence of rules
-------------------------------------------------------------------------------
ATTR Sequence [ lastExpr : Expr | | blockDecls : DeclBlocks ]
ATTR Sequence CRule [ | declsAbove : {[Decl]} | ]
SEM CVisit
| CVisit
vss.declsAbove = []
intra.declsAbove = error "declsAbove: not used here"
SEM CRule
| CRule
lhs.declsAbove = @lhs.declsAbove ++ @loc.decls
| CChildVisit
lhs.declsAbove = []
SEM Sequence
| Cons
lhs.blockDecls = @hd.bldBlocksFun @tl.blockDecls
| Nil
lhs.blockDecls = DeclTerminator @lhs.declsAbove @lhs.lastExpr
ATTR CRule [ | | bldBlocksFun : {DeclBlocks -> DeclBlocks} ]
SEM CRule
| CRule
lhs.bldBlocksFun = id
| CChildVisit
lhs.bldBlocksFun = DeclBlock @lhs.declsAbove (head @loc.decls)
{
mkPartitionedFunction :: String -> Bool -> [Decl] -> [String] -> DeclBlocks -> ([Decl], Expr)
mkPartitionedFunction prefix' optCase nextVisitDecls lastExprVars cpsTree
= let inh = Inh_DeclBlocksRoot { prefix_Inh_DeclBlocksRoot = prefix'
, optCase_Inh_DeclBlocksRoot = optCase
, nextVisitDecls_Inh_DeclBlocksRoot = nextVisitDecls
, lastExprVars_Inh_DeclBlocksRoot = lastExprVars
}
sem = sem_DeclBlocksRoot (DeclBlocksRoot cpsTree)
syn = wrap_DeclBlocksRoot sem inh
in (lambdas_Syn_DeclBlocksRoot syn, firstCall_Syn_DeclBlocksRoot syn)
}
WRAPPER DeclBlocksRoot
ATTR DeclBlocksRoot DeclBlocks [ prefix : String optCase : Bool nextVisitDecls : {[Decl]} lastExprVars : {[String]} | | ]
ATTR DeclBlocksRoot [ | | lambdas : {[Decl]} firstCall : Expr ]
SEM DeclBlocksRoot
| DeclBlocksRoot
lhs.lambdas = @blocks.decls
lhs.firstCall = @blocks.callExpr
ATTR DeclBlocks [ blockNr : Int | | ]
SEM DeclBlocksRoot
| DeclBlocksRoot
blocks.blockNr = 1
SEM DeclBlocks
| DeclBlock
next.blockNr = @lhs.blockNr + 1
ATTR DeclBlocks [ | | callExpr : Expr freeVars : {[String]} ]
SEM DeclBlocks
| DeclBlock DeclTerminator
loc.lambdaName = @lhs.prefix ++ "_block" ++ show @lhs.blockNr
loc.pragmaDecl = PragmaDecl ("NOINLINE " ++ @loc.lambdaName)
lhs.callExpr = App @loc.lambdaName (map SimpleExpr @loc.freeVars)
| DeclTerminator
loc.freeVars = freevars @lhs.lastExprVars (@defs ++ @lhs.nextVisitDecls)
| DeclBlock
loc.freeVars = freevars @next.freeVars (@visit : @defs)
ATTR DeclBlocks [ | | decls : {[Decl]} ]
SEM DeclBlocks
| DeclTerminator
lhs.decls = [ mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ @lhs.nextVisitDecls) @result ]
| DeclBlock
loc.decl = mkBlockLambda @lhs.optCase @loc.lambdaName @loc.freeVars (@defs ++ [@visit]) @next.callExpr
lhs.decls = (if @lhs.blockNr > 1 then [@loc.pragmaDecl] else []) ++ [@loc.decl] ++ @next.decls
{
freevars :: [String] -> [Decl] -> [String]
freevars additional decls
= Set.toList (allused `Set.difference` alldefined)
where
allused = Set.unions (Set.fromList additional : map usedvars decls)
alldefined = Set.unions (map definedvars decls)
usedvars (Decl _ _ _ uses) = uses
usedvars _ = Set.empty
definedvars (Decl _ _ defs _) = defs
definedvars _ = Set.empty
mkBlockLambda :: Bool -> String -> [String] -> [Decl] -> Expr -> Decl
mkBlockLambda optCase name args decls expr
= Decl lhs rhs Set.empty Set.empty
where
lhs = Fun name (map SimpleExpr args)
rhs = mkLet optCase decls expr
}
-------------------------------------------------------------------------------
-- The semantic domain is generated from the interface.
-------------------------------------------------------------------------------
ATTR CInterface CSegments CSegment [ | | semDom USE {++} {[]} : {[Decl]} ]
SEM CInterface
| CInterface lhs.semDom = Comment "semantic domain" : @seg.semDom
SEM CSegment
| CSegment loc.altSemForm = breadthFirst @lhs.options
loc.tp = if @loc.altSemForm
then TypeApp (SimpleType "Child") [SimpleType "EvalInfo", @loc.indexExpr ]
else foldr Arr @loc.synTps @loc.inhTps
loc.inhTps = [typeToCodeType (Just @lhs.nt) @loc.params tp | tp <- Map.elems @inh]
loc.inhTup = mkTupleType @lhs.o_unbox (null @loc.inhTps) @loc.inhTps
loc.synTps = mkTupleType @lhs.o_unbox (null @loc.inhTps) ([typeToCodeType (Just @lhs.nt) @loc.params tp | tp <- Map.elems @syn] ++ @loc.continuation)
loc.curTypeName = typeName @lhs.nt @lhs.nr
loc.nextTypeName = typeName @lhs.nt (@lhs.nr + 1)
loc.indexName = "I_" ++ @loc.curTypeName
loc.dataIndex = Code.Data @loc.indexName @loc.params [DataAlt @loc.indexName []] False []
loc.indexExpr = TypeApp (SimpleType @loc.indexName) (map (SimpleType . ('@':)) @loc.params)
loc.indexStr = "(" ++ @loc.indexName ++ concatMap (\p -> " " ++ p) @loc.params ++ ")"
loc.inhInstance = Code.Data "instance Inh" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Inh") [@loc.inhTup] ] False []
loc.synInstance = Code.Data "instance Syn" [@loc.indexStr] [DataAlt (typeName @lhs.nt @lhs.nr ++ "_Syn") [@loc.synTps] ] False []
loc.continuation = if @lhs.isLast
then []
else [TypeApp (SimpleType @loc.nextTypeName) (map (SimpleType . ('@':)) @loc.params)]
loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap
lhs.semDom = let name = typeName @lhs.nt @lhs.nr
evalTp | null @loc.params = id
| otherwise = idEvalType
in ( if @lhs.o_newtypes
then [ Code.NewType name @loc.params name (evalTp @loc.tp) ]
else [ Code.Type name @loc.params (evalTp @loc.tp) ] )
++ ( if @loc.altSemForm
then [@loc.dataIndex, @loc.inhInstance, @loc.synInstance]
else [] )
ATTR CNonterminals CNonterminal CInterface CSegments CSegment [ | | semDomUnfoldGath USE {`Map.union`} {Map.empty} : {Map (NontermIdent, Int) ([String], Code.Type)} ]
SEM CSegment
| CSegment
lhs.semDomUnfoldGath = Map.singleton (@lhs.nt, @lhs.nr) (@loc.params, @loc.tp)
ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit Sequence CRule [ unfoldSemDom : {NontermIdent -> Int -> [String] -> Code.Type} | | ]
SEM CGrammar
| CGrammar
loc.unfoldSemDom =
\nt nr repl ->
let (params, tp) = Map.findWithDefault (error ("No such semantic domain: " ++ show nt)) (nt, nr) @nonts.semDomUnfoldGath
replMap = Map.fromList (zip params repl)
replace k = Map.findWithDefault ('@':k) k replMap
in evalType replace tp
{
typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type
typeToCodeType _ _ tp
= case tp of
NT nt tps defor -> NontermType (getName nt) tps defor
Haskell t -> SimpleType t
Self -> error "Self type not allowed here."
evalType :: (String -> String) -> Code.Type -> Code.Type
evalType replf t'
= chase t'
where
chase t
= case t of
Arr l r -> Arr (chase l) (chase r)
TypeApp f as -> TypeApp (chase f) (map chase as)
TupleType tps -> TupleType (map chase tps)
UnboxedTupleType tps -> UnboxedTupleType (map chase tps)
Code.List tp -> Code.List (chase tp)
SimpleType txt -> let tks = lexTokens (initPos txt) txt
tks' = map replaceTok tks
txt' = unlines . showTokens . tokensToStrings $ tks'
in SimpleType txt'
TMaybe m -> TMaybe (chase m)
TEither l r -> TEither (chase l) (chase r)
TMap k v -> TMap (chase k) (chase v)
TIntMap v -> TIntMap (chase v)
_ -> t
replaceTok t
= case t of
AGLocal v p _ -> HsToken (replf $ getName v) p
_ -> t
idEvalType :: Code.Type -> Code.Type
idEvalType = evalType id
}
-------------------------------------------------------------------------------
-- Wrapper functions
-------------------------------------------------------------------------------
SEM CNonterminal
| CNonterminal loc.semWrapper = let params' = map getName @params
inhAttrs = Map.toList @inh
synAttrs = Map.toList @syn
inhVars = [ SimpleExpr (attrname True _LHS a) | (a,_) <- inhAttrs ]
synVars = [ SimpleExpr (attrname False _LHS a) | (a,_) <- synAttrs ]
var = "sem"
wrapNT = "wrap" ++ "_" ++ getName @nt
inhNT = "Inh" ++ "_" ++ getName @nt
synNT = "Syn" ++ "_" ++ getName @nt
varPat = if @lhs.o_newtypes
then App (sdtype @nt) [SimpleExpr var]
else SimpleExpr var
evalTp | null params' = id
| otherwise = idEvalType
appParams nm = TypeApp (SimpleType nm) (map SimpleType params')
typeSig = TSig wrapNT (evalTp $ appParams (sdtype @nt) `Arr` (appParams inhNT `Arr` appParams synNT))
mkstrict = Named @lhs.o_strictwrap
mkdata n attrs = Data n params' [Record n [mkstrict (getName f++"_"++n) $ evalTp $ typeToCodeType (Just @nt) params' t | (f,t) <- attrs]] False []
datas = [mkdata inhNT inhAttrs, mkdata synNT synAttrs]
in datas ++ [ typeSig
, Decl (Fun wrapNT [varPat, App inhNT inhVars])
(Let @inter.wrapDecls (App synNT synVars))
Set.empty Set.empty
]
ATTR CInterface CSegments CSegment [ | | wrapDecls USE {++} {[]}: {Decls} ]
SEM CSegment
| CSegment lhs.wrapDecls = let lhsVars = map (lhsname False) (Map.keys @syn)
++ if @lhs.isLast then [] else [unwrap ++ sem (@lhs.nr+1)]
rhsVars = map (lhsname True) (Map.keys @inh)
rhs = map SimpleExpr rhsVars
unwrap = if @lhs.o_newtypes then typeName @lhs.nt (@lhs.nr + 1) ++ " " else ""
var = "sem"
sem 0 = var
sem n = var ++ "_" ++ show n
ntt = typeName @lhs.nt @lhs.nr
in [ EvalDecl ntt (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (InvokeExpr ntt (SimpleExpr $ sem @lhs.nr) rhs) ]
-- [ Decl (mkTupleLhs @lhs.o_unbox (null $ Map.keys @inh) lhsVars) (App (sem @lhs.nr) rhs) (Set.fromList lhsVars) (Set.fromList rhsVars) ]
-------------------------------------------------------------------------------
-- Errors for missing type signatures. It's an error when one of the
-- attributes in the intra-visit dependencies does not have a type.
-- UPDATE: it is not an error anymore...
-------------------------------------------------------------------------------
ATTR CNonterminals CNonterminal
CProductions CProduction
CVisits CVisit [ with_sig : Bool | | ]
SEM CGrammar
| CGrammar nonts.with_sig = typeSigs @lhs.options
SEM CGrammar [ | | errors : {Seq Error} ]
| CGrammar lhs.errors = Seq.empty
-------------------------------------------------------------------------------
-- Provide a description of the interfaces as comments
-------------------------------------------------------------------------------
SEM CNonterminal
| CNonterminal loc.comment = Comment . unlines . map ind $ ( @inter.comments ++ ("alternatives:" : map ind @prods.comments) )
ATTR CInterface CSegments CSegment
CProductions CProduction
CVisits CVisit Sequence CRule [ | | comments USE {++} {[]}: {[String]} ]
ATTR Sequence CRule [ what:String | | ]
SEM CSegment
| CSegment lhs.comments = let body = map ind (showsSegment (CSegment @inh @syn))
in if null body
then []
else ("visit " ++ show @lhs.nr ++ ":") : body
SEM CProduction
| CProduction loc.firstOrderChildren = [ (nm,fromJust mb,virt) | (nm,tp,virt) <- @children, let mb = isFirstOrder virt tp, isJust mb ]
lhs.comments = ("alternative " ++ getName @con ++ ":")
: map ind ( map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) @loc.firstOrderChildren
++ @visits.comments
)
{
-- for a virtual child that already existed as a child, returns
isFirstOrder :: ChildKind -> Type -> Maybe Type
isFirstOrder ChildSyntax tp = Just tp
isFirstOrder ChildAttr _ = Nothing
isFirstOrder (ChildReplace tp) _ = Just tp
}
SEM CVisit
| CVisit lhs.comments = let body = map ind (@vss.comments ++ @intra.comments)
in if null body
then []
else ("visit " ++ show @lhs.nr ++ ":") : body
vss.what = "local"
intra.what = "intra"
SEM CRule
| CRule lhs.comments = [ makeLocalComment 11 @lhs.what name tp | (field,name,tp) <- Map.elems @defines, field == _LOC ]
++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems @defines, field == _INST ]
{
makeLocalComment :: Int -> String -> Identifier -> Maybe Type -> String
makeLocalComment width what name tp = let x = getName name
y = maybe "_" (\t -> case t of
(NT nt tps _) -> getName nt ++ " " ++ unwords tps
Haskell t' -> '{' : t' ++ "}"
Self -> error "Self type not allowed here.") tp
in ( what ++ " " ++ x ++ replicate ((width - length x) `max` 0) ' ' ++ " : " ++ y )
}
-------------------------------------------------------------------------------
-- And tie it all together
-------------------------------------------------------------------------------
ATTR CNonterminals CNonterminal [ | | chunks USE {++} {[]} : {Chunks} ]
ATTR CProductions CProduction [ | | decls USE {++} {[]} : {Decls} ]
ATTR CGrammar [ | | output : Program ]
SEM CGrammar
| CGrammar lhs.output = Program @nonts.chunks @multivisit
SEM CNonterminal
| CNonterminal lhs.chunks = [ Chunk (getName @nt)
(Comment (getName @nt ++ " " ++ replicate (60 - length (getName @nt)) '-'))
(if @lhs.o_pretty then [@loc.comment] else [])
(if isJust @lhs.o_data then [@loc.dataDef] else [])
(if @lhs.o_cata && @loc.genCata then @loc.cataFun else [])
(if @lhs.o_sig then @inter.semDom else [])
(if @nt `Set.member` @lhs.wrappers then @loc.semWrapper else [])
(if @lhs.o_sem then @prods.decls else [])
(if @lhs.o_sem then @prods.semNames else [])
]
{
-- Lets or nested Cases?
-- or even a do-expression?
data DeclsType = DeclsLet | DeclsCase | DeclsDo
mkDecls :: DeclsType -> Decls -> Expr -> Expr
mkDecls DeclsLet = mkLet False
mkDecls DeclsCase = mkLet True
mkDecls DeclsDo = \decls -> Do (map toBind decls)
where toBind (Decl lhs rhs _ _) = BindLet lhs rhs
toBind d = d
mkLet :: Bool -> Decls -> Expr -> Expr
mkLet False decls body = Let decls body
mkLet True decls body = foldr oneCase body decls
oneCase :: Decl -> Expr -> Expr
oneCase (Decl left rhs _ _) ex = Case rhs [CaseAlt left ex]
oneCase (Resume _ nt left rhs) ex = ResumeExpr nt rhs left ex
oneCase _ ex = ex
-- Gives the name of the visit function
funname :: Show a => a -> Int -> String
funname field 0 = show field ++ "_"
funname field nr = show field ++ "_" ++ show nr
-- Gives the name of a semantic function
seqSemname :: String -> NontermIdent -> ConstructorIdent -> Int -> String
seqSemname pre nt con 0 = semname pre nt con
seqSemname pre nt con nr = semname pre nt con ++ "_" ++ show nr
-- Gives the name of a type
typeName :: NontermIdent -> Int -> String
typeName nt 0 = "T_" ++ show nt
typeName nt n = "T_" ++ show nt ++ "_" ++ show n
ntOfVisit :: NontermIdent -> Int -> NontermIdent
ntOfVisit nt 0 = nt
ntOfVisit nt n = Ident (show nt ++ "_" ++ show n) (getPos nt)
-- Gives the name of a visit function
visitname :: String -> NontermIdent -> Int -> String
visitname pre nt n = pre ++ getName nt ++ "_" ++ show n
}
-------------------------------------------------------------------------------
-- Datatypes were already present
-------------------------------------------------------------------------------
ATTR CNonterminals CNonterminal [ derivings: {Derivings} typeSyns : {TypeSyns} | | ]
ATTR CNonterminals CNonterminal CProductions CProduction CVisits CVisit [ wrappers:{Set NontermIdent} | | ]
SEM CGrammar
| CGrammar nonts . typeSyns = @typeSyns
. derivings = @derivings
. wrappers = @wrappers
SEM CNonterminal
| CNonterminal loc.dataDef = let params' = map getName @params
typeSyn tp = let theType =
case tp of
CommonTypes.Maybe t -> TMaybe $ typeToCodeType (Just @nt) params' t
CommonTypes.Either t1 t2 -> TEither (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2)
CommonTypes.Map t1 t2 -> TMap (typeToCodeType (Just @nt) params' t1) (typeToCodeType (Just @nt) params' t2)
CommonTypes.IntMap t -> TIntMap $ typeToCodeType (Just @nt) params' t
CommonTypes.List t -> Code.List $ typeToCodeType (Just @nt) params' t
CommonTypes.Tuple ts -> Code.TupleType [typeToCodeType (Just @nt) params' t | (_,t) <- ts ]
tp' -> error $ show tp' ++ " not supported"
in Code.Type (getName @nt) params' (idEvalType theType)
derivings = maybe [] (map getName . Set.toList) (Map.lookup @nt @lhs.derivings)
dataDef = Data (getName @nt) (map getName @params) @prods.dataAlts (maybe False id @lhs.o_data) derivings
in maybe dataDef typeSyn $ lookup @nt @lhs.typeSyns
ATTR CProductions [ | | dataAlts : {DataAlts} ]
ATTR CProduction [ | | dataAlt : {DataAlt} ]
SEM CProductions
| Cons lhs.dataAlts = @hd.dataAlt : @tl.dataAlts
| Nil lhs.dataAlts = []
SEM CProduction
| CProduction loc.params = map getName $ Map.findWithDefault [] @lhs.nt @lhs.paramMap
lhs.dataAlt = let conNm = conname @lhs.o_rename @lhs.nt @con
mkFields :: (NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> a) -> [a]
mkFields f = map (\(nm,t,_) -> f @lhs.nt @con nm (typeToCodeType (Just @lhs.nt) @loc.params $ removeDeforested t)) @loc.firstOrderChildren
in if dataRecords @lhs.options
then Record conNm $ mkFields $ toNamedType (strictData @lhs.options)
else DataAlt conNm $ mkFields $ \_ _ _ t -> t
{
toNamedType :: Bool -> NontermIdent -> ConstructorIdent -> Identifier -> Code.Type -> Code.NamedType
toNamedType genStrict nt con nm tp
= Code.Named genStrict strNm tp
where strNm = recordFieldname nt con nm
}
-------------------------------------------------------------------------------
-- Catamorphism were already present
-------------------------------------------------------------------------------
SEM CNonterminal
| CNonterminal loc.genCata = not (@nt `Set.member` nocatas @lhs.options)
loc.cataFun = let appParams nm = TypeApp (SimpleType nm) (map SimpleType (map getName @params))
evalTp | null @params = id
| otherwise = idEvalType
tSig = TSig (cataname @lhs.prefix @nt)
(appQuant @lhs.quantMap @nt $ appContext @lhs.contextMap @nt $ evalTp $ appParams (getName @nt) `Arr` appParams (sdtype @nt))
special typ = case typ of
CommonTypes.List tp ->
let cons = SimpleExpr (semname @lhs.prefix @nt (identifier "Cons"))
nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil" ))
arg = SimpleExpr "list"
rarg = case tp of
NT t _ _ -> let t' = maybe t id (deforestedNt t)
in SimpleExpr ("(Prelude.map " ++ (cataname @lhs.prefix t') ++ " list)")
_ -> arg
lhs = Fun (cataname @lhs.prefix @nt) [arg]
rhs = (App "Prelude.foldr" [cons,nil,rarg])
in [Decl lhs rhs Set.empty Set.empty]
CommonTypes.Maybe tp ->
let just = semname @lhs.prefix @nt (identifier "Just")
nothing = semname @lhs.prefix @nt (identifier "Nothing" )
arg = SimpleExpr "x"
rarg = case tp of
NT t _ _ -> let t' = maybe t id (deforestedNt t)
in App (cataname @lhs.prefix t') [arg]
_ -> arg
lhs a = Fun (cataname @lhs.prefix @nt) [a]
in [Decl (lhs (App "Prelude.Just" [arg])) (App just [rarg]) Set.empty Set.empty
,Decl (lhs (SimpleExpr "Prelude.Nothing")) (SimpleExpr nothing) Set.empty Set.empty
]
CommonTypes.Either tp1 tp2 ->
let left = semname @lhs.prefix @nt (identifier "Left")
right = semname @lhs.prefix @nt (identifier "Right" )
arg = SimpleExpr "x"
rarg0 = case tp1 of
NT t _ _ -> let t' = maybe t id (deforestedNt t)
in App (cataname @lhs.prefix t') [arg]
_ -> arg
rarg1 = case tp2 of
NT t _ _ -> let t' = maybe t id (deforestedNt t)
in App (cataname @lhs.prefix t') [arg]
_ -> arg
lhs a = Fun (cataname @lhs.prefix @nt) [a]
in [Decl (lhs (App "Prelude.Left" [arg])) (App left [rarg0]) Set.empty Set.empty
,Decl (lhs (App "Prelude.Right" [arg])) (App right [rarg1]) Set.empty Set.empty
]
CommonTypes.Map _ tp ->
let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))
nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil"))
arg = SimpleExpr "m"
rarg = case tp of
NT t _ _ -> let t' = maybe t id (deforestedNt t)
in App "Data.Map.map" [SimpleExpr $ cataname @lhs.prefix t', arg]
_ -> arg
lhs = Fun (cataname @lhs.prefix @nt) [arg]
rhs = App "Data.Map.foldrWithKey" [entry,nil,rarg]
in [Decl lhs rhs Set.empty Set.empty]
CommonTypes.IntMap tp ->
let entry = SimpleExpr (semname @lhs.prefix @nt (identifier "Entry"))
nil = SimpleExpr (semname @lhs.prefix @nt (identifier "Nil"))
arg = SimpleExpr "m"
rarg = case tp of
NT t _ _ -> let t' = maybe t id (deforestedNt t)
in App "Data.IntMap.map" [SimpleExpr $ cataname @lhs.prefix t', arg]
_ -> arg
lhs = Fun (cataname @lhs.prefix @nt) [arg]
rhs = App "Data.IntMap.foldWithKey" [entry,nil,rarg]
in [Decl lhs rhs Set.empty Set.empty]
CommonTypes.Tuple tps ->
let con = semname @lhs.prefix @nt (identifier "Tuple")
tps' = [ (SimpleExpr (getName x),y) | (x,y) <- tps]
rargs = map rarg tps'
rarg (n, tp) = case tp of
NT t _ _ -> let t' = maybe t id (deforestedNt t)
in App (cataname @lhs.prefix t') [n]
_ -> n
lhs = Fun (cataname @lhs.prefix @nt) [TupleExpr (map fst tps')]
rhs = App con rargs
in [Decl lhs rhs Set.empty Set.empty]
_ -> error "TODO"
in Comment "cata" :
(if @lhs.o_sig then [tSig] else []) ++
maybe @prods.cataAlts special (lookup @nt @lhs.typeSyns)
ATTR CProductions [ | | cataAlts : {Decls} ]
ATTR CProduction [ | | cataAlt : {Decl} ]
SEM CProductions
| Cons lhs.cataAlts = @hd.cataAlt : @tl.cataAlts
| Nil lhs.cataAlts = []
SEM CProduction
| CProduction lhs.cataAlt = let lhs = Fun (cataname @lhs.prefix @lhs.nt) [lhs_pat]
lhs_pat = App (conname @lhs.o_rename @lhs.nt @con)
(map (\(n,_,_) -> SimpleExpr $ locname $ n) @loc.firstOrderChildren)
rhs = App (semname @lhs.prefix @lhs.nt @con)
(map argument @loc.firstOrderChildren)
argument (nm,NT tp _ _,_) = App (cataname @lhs.prefix tp)
[SimpleExpr (locname nm)]
argument (nm, _,_) = SimpleExpr (locname nm)
in Decl lhs rhs Set.empty Set.empty
-------------------------------------------------------------------------------
-- Collect names of generated stuff
-------------------------------------------------------------------------------
ATTR CProductions CProduction CVisits CVisit [ | | semNames USE {++} {[]} : {[String]} ]
{-
SEM CProduction
| CProduction
lhs.semNames = [cataname @lhs.prefix @lhs.nt] ++ @visits.semNames
-}
SEM CVisit
| CVisit
lhs.semNames = [@loc.funcname]