module GenerateCode where
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,intersect,(\\))
import Data.Maybe(fromJust,isJust)
import Debug.Trace
import Patterns
import CommonTypes
import Data.Map(Map)
import Data.Set(Set)
import UU.Scanner.Position(Pos)
import CommonTypes (ConstructorIdent,Identifier)
import Code (Decl,Expr)
cleanupArg :: String -> String
cleanupArg s
= case idEvalType (SimpleType s) of
SimpleType s' -> s'
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
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"
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 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
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)
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
typeToCodeType :: Maybe NontermIdent -> [String] -> Type -> Code.Type
typeToCodeType mbNt params tp
= case tp of
NT nt tps defor -> NontermType (getName nt) tps defor
Haskell t -> SimpleType t
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
isFirstOrder :: ChildKind -> Type -> Maybe Type
isFirstOrder ChildSyntax tp = Just tp
isFirstOrder ChildAttr _ = Nothing
isFirstOrder (ChildReplace tp) _ = Just tp
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++"}") tp
in ( what ++ " " ++ x ++ replicate ((width length x) `max` 0) ' ' ++ " : " ++ y )
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 _ _) exp = Case rhs [CaseAlt left exp]
oneCase (Resume _ nt left rhs) exp = ResumeExpr nt rhs left exp
oneCase _ exp = exp
funname field 0 = show field ++ "_"
funname field nr = show field ++ "_" ++ show nr
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
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)
visitname :: String -> NontermIdent -> Int -> String
visitname pre nt n = pre ++ getName nt ++ "_" ++ show n
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
sem_CGrammar :: CGrammar ->
T_CGrammar
sem_CGrammar (CGrammar _typeSyns _derivings _wrappers _nonts _pragmas _paramMap _contextMap _quantMap _aroundsMap _mergeMap _multivisit) =
(sem_CGrammar_CGrammar _typeSyns _derivings _wrappers (sem_CNonterminals _nonts) _pragmas _paramMap _contextMap _quantMap _aroundsMap _mergeMap _multivisit)
newtype T_CGrammar = T_CGrammar (Options ->
( (Seq Error),Program))
data Inh_CGrammar = Inh_CGrammar {options_Inh_CGrammar :: !(Options)}
data Syn_CGrammar = Syn_CGrammar {errors_Syn_CGrammar :: !((Seq Error)),output_Syn_CGrammar :: !(Program)}
wrap_CGrammar :: T_CGrammar ->
Inh_CGrammar ->
Syn_CGrammar
wrap_CGrammar (T_CGrammar sem) (Inh_CGrammar _lhsIoptions) =
(let ( _lhsOerrors,_lhsOoutput) = sem _lhsIoptions
in (Syn_CGrammar _lhsOerrors _lhsOoutput))
sem_CGrammar_CGrammar :: TypeSyns ->
Derivings ->
(Set NontermIdent) ->
T_CNonterminals ->
PragmaMap ->
ParamMap ->
ContextMap ->
QuantMap ->
(Map NontermIdent (Map ConstructorIdent (Set Identifier))) ->
(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier,[Identifier])))) ->
Bool ->
T_CGrammar
sem_CGrammar_CGrammar typeSyns_ derivings_ wrappers_ (T_CNonterminals nonts_) pragmas_ paramMap_ contextMap_ quantMap_ aroundsMap_ mergeMap_ multivisit_ =
(T_CGrammar (\ _lhsIoptions ->
(let _nontsOo_sig :: Bool
_nontsOo_cata :: Bool
_nontsOo_sem :: Bool
_nontsOo_newtypes :: Bool
_nontsOo_unbox :: Bool
_nontsOo_case :: Bool
_nontsOo_pretty :: Bool
_nontsOo_rename :: Bool
_nontsOo_strictwrap :: Bool
_nontsOo_splitsems :: Bool
_nontsOo_data :: (Maybe Bool)
_nontsOprefix :: String
_nontsOo_traces :: Bool
_nontsOo_costcentre :: Bool
_nontsOo_linePragmas :: Bool
_nontsOo_monadic :: Bool
_nontsOallPragmas :: PragmaMap
_nontsOparamMap :: ParamMap
_nontsOcontextMap :: ContextMap
_nontsOquantMap :: QuantMap
_nontsOallNts :: (Set NontermIdent)
_nontsOwith_sig :: Bool
_lhsOerrors :: (Seq Error)
_lhsOoutput :: Program
_nontsOtypeSyns :: TypeSyns
_nontsOderivings :: Derivings
_nontsOwrappers :: (Set NontermIdent)
_nontsOaroundMap :: (Map NontermIdent (Map ConstructorIdent (Set Identifier)))
_nontsOmergeMap :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))))
_nontsOoptions :: Options
_nontsOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_nontsIchunks :: Chunks
_nontsIgathNts :: (Set NontermIdent)
_nontsIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_nontsOo_sig =
(
typeSigs _lhsIoptions
)
_nontsOo_cata =
(
folds _lhsIoptions
)
_nontsOo_sem =
(
semfuns _lhsIoptions
)
_nontsOo_newtypes =
(
newtypes _lhsIoptions
)
_nontsOo_unbox =
(
unbox _lhsIoptions
)
_nontsOo_case =
(
cases _lhsIoptions
)
_nontsOo_pretty =
(
attrInfo _lhsIoptions
)
_nontsOo_rename =
(
rename _lhsIoptions
)
_nontsOo_strictwrap =
(
strictWrap _lhsIoptions
)
_nontsOo_splitsems =
(
splitSems _lhsIoptions
)
_nontsOo_data =
(
if dataTypes _lhsIoptions then Just (strictData _lhsIoptions) else Nothing
)
_nontsOprefix =
(
prefix _lhsIoptions
)
_nontsOo_traces =
(
genTraces _lhsIoptions
)
_nontsOo_costcentre =
(
genCostCentres _lhsIoptions
)
_nontsOo_linePragmas =
(
genLinePragmas _lhsIoptions
)
_nontsOo_monadic =
(
monadic _lhsIoptions
)
_options =
(
_lhsIoptions { breadthFirst = breadthFirst _lhsIoptions && visit _lhsIoptions && cases _lhsIoptions && multivisit_ }
)
_nontsOallPragmas =
(
pragmas_
)
_nontsOparamMap =
(
paramMap_
)
_nontsOcontextMap =
(
contextMap_
)
_nontsOquantMap =
(
quantMap_
)
_nontsOallNts =
(
_nontsIgathNts
)
_aroundMap =
(
aroundsMap_
)
_mergeMap =
(
mergeMap_
)
_unfoldSemDom =
(
\nt nr repl ->
let (params, tp) = Map.findWithDefault (error ("No such semantic domain: " ++ show nt)) (nt, nr) _nontsIsemDomUnfoldGath
replMap = Map.fromList (zip params repl)
replace k = Map.findWithDefault ('@':k) k replMap
in evalType replace tp
)
_nontsOwith_sig =
(
typeSigs _lhsIoptions
)
_lhsOerrors =
(
Seq.empty
)
_lhsOoutput =
(
Program _nontsIchunks multivisit_
)
_nontsOtypeSyns =
(
typeSyns_
)
_nontsOderivings =
(
derivings_
)
_nontsOwrappers =
(
wrappers_
)
_nontsOaroundMap =
(
_aroundMap
)
_nontsOmergeMap =
(
_mergeMap
)
_nontsOoptions =
(
_options
)
_nontsOunfoldSemDom =
(
_unfoldSemDom
)
( _nontsIchunks,_nontsIgathNts,_nontsIsemDomUnfoldGath) =
nonts_ _nontsOallNts _nontsOallPragmas _nontsOaroundMap _nontsOcontextMap _nontsOderivings _nontsOmergeMap _nontsOo_case _nontsOo_cata _nontsOo_costcentre _nontsOo_data _nontsOo_linePragmas _nontsOo_monadic _nontsOo_newtypes _nontsOo_pretty _nontsOo_rename _nontsOo_sem _nontsOo_sig _nontsOo_splitsems _nontsOo_strictwrap _nontsOo_traces _nontsOo_unbox _nontsOoptions _nontsOparamMap _nontsOprefix _nontsOquantMap _nontsOtypeSyns _nontsOunfoldSemDom _nontsOwith_sig _nontsOwrappers
___node =
(Syn_CGrammar _lhsOerrors _lhsOoutput)
in ( _lhsOerrors,_lhsOoutput))))
sem_CInterface :: CInterface ->
T_CInterface
sem_CInterface (CInterface _seg) =
(sem_CInterface_CInterface (sem_CSegments _seg))
newtype T_CInterface = T_CInterface (Attributes ->
NontermIdent ->
Bool ->
Bool ->
Bool ->
(Maybe Bool) ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Options ->
ParamMap ->
String ->
Attributes ->
( ([String]),([Decl]),(Map (NontermIdent, Int) ([String], Code.Type)),Decls))
data Inh_CInterface = Inh_CInterface {inh_Inh_CInterface :: !(Attributes),nt_Inh_CInterface :: !(NontermIdent),o_case_Inh_CInterface :: !(Bool),o_cata_Inh_CInterface :: !(Bool),o_costcentre_Inh_CInterface :: !(Bool),o_data_Inh_CInterface :: !((Maybe Bool)),o_linePragmas_Inh_CInterface :: !(Bool),o_monadic_Inh_CInterface :: !(Bool),o_newtypes_Inh_CInterface :: !(Bool),o_pretty_Inh_CInterface :: !(Bool),o_rename_Inh_CInterface :: !(Bool),o_sem_Inh_CInterface :: !(Bool),o_sig_Inh_CInterface :: !(Bool),o_splitsems_Inh_CInterface :: !(Bool),o_strictwrap_Inh_CInterface :: !(Bool),o_traces_Inh_CInterface :: !(Bool),o_unbox_Inh_CInterface :: !(Bool),options_Inh_CInterface :: !(Options),paramMap_Inh_CInterface :: !(ParamMap),prefix_Inh_CInterface :: !(String),syn_Inh_CInterface :: !(Attributes)}
data Syn_CInterface = Syn_CInterface {comments_Syn_CInterface :: !(([String])),semDom_Syn_CInterface :: !(([Decl])),semDomUnfoldGath_Syn_CInterface :: !((Map (NontermIdent, Int) ([String], Code.Type))),wrapDecls_Syn_CInterface :: !(Decls)}
wrap_CInterface :: T_CInterface ->
Inh_CInterface ->
Syn_CInterface
wrap_CInterface (T_CInterface sem) (Inh_CInterface _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn) =
(let ( _lhsOcomments,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls) = sem _lhsIinh _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn
in (Syn_CInterface _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls))
sem_CInterface_CInterface :: T_CSegments ->
T_CInterface
sem_CInterface_CInterface (T_CSegments seg_) =
(T_CInterface (\ _lhsIinh
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamMap
_lhsIprefix
_lhsIsyn ->
(let _segOnr :: Int
_lhsOsemDom :: ([Decl])
_lhsOcomments :: ([String])
_lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_lhsOwrapDecls :: Decls
_segOinh :: Attributes
_segOnt :: NontermIdent
_segOo_case :: Bool
_segOo_cata :: Bool
_segOo_costcentre :: Bool
_segOo_data :: (Maybe Bool)
_segOo_linePragmas :: Bool
_segOo_monadic :: Bool
_segOo_newtypes :: Bool
_segOo_pretty :: Bool
_segOo_rename :: Bool
_segOo_sem :: Bool
_segOo_sig :: Bool
_segOo_splitsems :: Bool
_segOo_strictwrap :: Bool
_segOo_traces :: Bool
_segOo_unbox :: Bool
_segOoptions :: Options
_segOparamMap :: ParamMap
_segOprefix :: String
_segOsyn :: Attributes
_segIcomments :: ([String])
_segIisNil :: Bool
_segIsemDom :: ([Decl])
_segIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_segIwrapDecls :: Decls
_segOnr =
(
0
)
_lhsOsemDom =
(
Comment "semantic domain" : _segIsemDom
)
_lhsOcomments =
(
_segIcomments
)
_lhsOsemDomUnfoldGath =
(
_segIsemDomUnfoldGath
)
_lhsOwrapDecls =
(
_segIwrapDecls
)
_segOinh =
(
_lhsIinh
)
_segOnt =
(
_lhsInt
)
_segOo_case =
(
_lhsIo_case
)
_segOo_cata =
(
_lhsIo_cata
)
_segOo_costcentre =
(
_lhsIo_costcentre
)
_segOo_data =
(
_lhsIo_data
)
_segOo_linePragmas =
(
_lhsIo_linePragmas
)
_segOo_monadic =
(
_lhsIo_monadic
)
_segOo_newtypes =
(
_lhsIo_newtypes
)
_segOo_pretty =
(
_lhsIo_pretty
)
_segOo_rename =
(
_lhsIo_rename
)
_segOo_sem =
(
_lhsIo_sem
)
_segOo_sig =
(
_lhsIo_sig
)
_segOo_splitsems =
(
_lhsIo_splitsems
)
_segOo_strictwrap =
(
_lhsIo_strictwrap
)
_segOo_traces =
(
_lhsIo_traces
)
_segOo_unbox =
(
_lhsIo_unbox
)
_segOoptions =
(
_lhsIoptions
)
_segOparamMap =
(
_lhsIparamMap
)
_segOprefix =
(
_lhsIprefix
)
_segOsyn =
(
_lhsIsyn
)
( _segIcomments,_segIisNil,_segIsemDom,_segIsemDomUnfoldGath,_segIwrapDecls) =
seg_ _segOinh _segOnr _segOnt _segOo_case _segOo_cata _segOo_costcentre _segOo_data _segOo_linePragmas _segOo_monadic _segOo_newtypes _segOo_pretty _segOo_rename _segOo_sem _segOo_sig _segOo_splitsems _segOo_strictwrap _segOo_traces _segOo_unbox _segOoptions _segOparamMap _segOprefix _segOsyn
___node =
(Syn_CInterface _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls)
in ( _lhsOcomments,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls))))
sem_CNonterminal :: CNonterminal ->
T_CNonterminal
sem_CNonterminal (CNonterminal _nt _params _inh _syn _prods _inter) =
(sem_CNonterminal_CNonterminal _nt _params _inh _syn (sem_CProductions _prods) (sem_CInterface _inter))
newtype T_CNonterminal = T_CNonterminal ((Set NontermIdent) ->
PragmaMap ->
(Map NontermIdent (Map ConstructorIdent (Set Identifier))) ->
ContextMap ->
Derivings ->
(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))) ->
Bool ->
Bool ->
Bool ->
(Maybe Bool) ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Options ->
ParamMap ->
String ->
QuantMap ->
TypeSyns ->
(NontermIdent -> Int -> [String] -> Code.Type) ->
Bool ->
(Set NontermIdent) ->
( Chunks,(Set NontermIdent),(Map (NontermIdent, Int) ([String], Code.Type))))
data Inh_CNonterminal = Inh_CNonterminal {allNts_Inh_CNonterminal :: !((Set NontermIdent)),allPragmas_Inh_CNonterminal :: !(PragmaMap),aroundMap_Inh_CNonterminal :: !((Map NontermIdent (Map ConstructorIdent (Set Identifier)))),contextMap_Inh_CNonterminal :: !(ContextMap),derivings_Inh_CNonterminal :: !(Derivings),mergeMap_Inh_CNonterminal :: !((Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))))),o_case_Inh_CNonterminal :: !(Bool),o_cata_Inh_CNonterminal :: !(Bool),o_costcentre_Inh_CNonterminal :: !(Bool),o_data_Inh_CNonterminal :: !((Maybe Bool)),o_linePragmas_Inh_CNonterminal :: !(Bool),o_monadic_Inh_CNonterminal :: !(Bool),o_newtypes_Inh_CNonterminal :: !(Bool),o_pretty_Inh_CNonterminal :: !(Bool),o_rename_Inh_CNonterminal :: !(Bool),o_sem_Inh_CNonterminal :: !(Bool),o_sig_Inh_CNonterminal :: !(Bool),o_splitsems_Inh_CNonterminal :: !(Bool),o_strictwrap_Inh_CNonterminal :: !(Bool),o_traces_Inh_CNonterminal :: !(Bool),o_unbox_Inh_CNonterminal :: !(Bool),options_Inh_CNonterminal :: !(Options),paramMap_Inh_CNonterminal :: !(ParamMap),prefix_Inh_CNonterminal :: !(String),quantMap_Inh_CNonterminal :: !(QuantMap),typeSyns_Inh_CNonterminal :: !(TypeSyns),unfoldSemDom_Inh_CNonterminal :: !((NontermIdent -> Int -> [String] -> Code.Type)),with_sig_Inh_CNonterminal :: !(Bool),wrappers_Inh_CNonterminal :: !((Set NontermIdent))}
data Syn_CNonterminal = Syn_CNonterminal {chunks_Syn_CNonterminal :: !(Chunks),gathNts_Syn_CNonterminal :: !((Set NontermIdent)),semDomUnfoldGath_Syn_CNonterminal :: !((Map (NontermIdent, Int) ([String], Code.Type)))}
wrap_CNonterminal :: T_CNonterminal ->
Inh_CNonterminal ->
Syn_CNonterminal
wrap_CNonterminal (T_CNonterminal sem) (Inh_CNonterminal _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIderivings _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) =
(let ( _lhsOchunks,_lhsOgathNts,_lhsOsemDomUnfoldGath) = sem _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIderivings _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers
in (Syn_CNonterminal _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath))
sem_CNonterminal_CNonterminal :: NontermIdent ->
([Identifier]) ->
Attributes ->
Attributes ->
T_CProductions ->
T_CInterface ->
T_CNonterminal
sem_CNonterminal_CNonterminal nt_ params_ inh_ syn_ (T_CProductions prods_) (T_CInterface inter_) =
(T_CNonterminal (\ _lhsIallNts
_lhsIallPragmas
_lhsIaroundMap
_lhsIcontextMap
_lhsIderivings
_lhsImergeMap
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamMap
_lhsIprefix
_lhsIquantMap
_lhsItypeSyns
_lhsIunfoldSemDom
_lhsIwith_sig
_lhsIwrappers ->
(let _interOinh :: Attributes
_interOsyn :: Attributes
_interOnt :: NontermIdent
_prodsOinh :: Attributes
_prodsOsyn :: Attributes
_prodsOnt :: NontermIdent
_lhsOgathNts :: (Set NontermIdent)
_lhsOchunks :: Chunks
_lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_prodsOallNts :: (Set NontermIdent)
_prodsOallPragmas :: PragmaMap
_prodsOaroundMap :: (Map ConstructorIdent (Set Identifier))
_prodsOcontextMap :: ContextMap
_prodsOmergeMap :: (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))
_prodsOo_case :: Bool
_prodsOo_cata :: Bool
_prodsOo_costcentre :: Bool
_prodsOo_data :: (Maybe Bool)
_prodsOo_linePragmas :: Bool
_prodsOo_monadic :: Bool
_prodsOo_newtypes :: Bool
_prodsOo_pretty :: Bool
_prodsOo_rename :: Bool
_prodsOo_sem :: Bool
_prodsOo_sig :: Bool
_prodsOo_splitsems :: Bool
_prodsOo_strictwrap :: Bool
_prodsOo_traces :: Bool
_prodsOo_unbox :: Bool
_prodsOoptions :: Options
_prodsOparamMap :: ParamMap
_prodsOprefix :: String
_prodsOquantMap :: QuantMap
_prodsOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_prodsOwith_sig :: Bool
_prodsOwrappers :: (Set NontermIdent)
_interOo_case :: Bool
_interOo_cata :: Bool
_interOo_costcentre :: Bool
_interOo_data :: (Maybe Bool)
_interOo_linePragmas :: Bool
_interOo_monadic :: Bool
_interOo_newtypes :: Bool
_interOo_pretty :: Bool
_interOo_rename :: Bool
_interOo_sem :: Bool
_interOo_sig :: Bool
_interOo_splitsems :: Bool
_interOo_strictwrap :: Bool
_interOo_traces :: Bool
_interOo_unbox :: Bool
_interOoptions :: Options
_interOparamMap :: ParamMap
_interOprefix :: String
_prodsIcataAlts :: Decls
_prodsIcomments :: ([String])
_prodsIdataAlts :: DataAlts
_prodsIdecls :: Decls
_prodsIsemNames :: ([String])
_interIcomments :: ([String])
_interIsemDom :: ([Decl])
_interIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_interIwrapDecls :: Decls
(_interOinh,_interOsyn,_interOnt) =
(
(inh_,syn_,nt_)
)
(_prodsOinh,_prodsOsyn,_prodsOnt) =
(
(inh_,syn_,nt_)
)
_lhsOgathNts =
(
Set.singleton nt_
)
_aroundMap =
(
Map.findWithDefault Map.empty nt_ _lhsIaroundMap
)
_mergeMap =
(
Map.findWithDefault Map.empty nt_ _lhsImergeMap
)
_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 _lhsIo_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 _lhsIo_strictwrap
mkdata n attrs = Data n params' [Record n [mkstrict (getName f++"_"++n) $ evalTp $ typeToCodeType (Just nt_) params' $ removeDeforested t | (f,t) <- attrs]] False []
datas = [mkdata inhNT inhAttrs, mkdata synNT synAttrs]
in datas ++ [ typeSig
, Decl (Fun wrapNT [varPat, App inhNT inhVars])
(Let _interIwrapDecls (App synNT synVars))
Set.empty Set.empty
]
)
_comment =
(
Comment . unlines . map ind $ ( _interIcomments ++ ("alternatives:" : map ind _prodsIcomments) )
)
_lhsOchunks =
(
[ Chunk (getName nt_)
(Comment (getName nt_ ++ " " ++ replicate (60 length (getName nt_)) '-'))
(if _lhsIo_pretty then [_comment ] else [])
(if isJust _lhsIo_data then [_dataDef ] else [])
(if _lhsIo_cata && _genCata then _cataFun else [])
(if _lhsIo_sig then _interIsemDom else [])
(if nt_ `Set.member` _lhsIwrappers then _semWrapper else [])
(if _lhsIo_sem then _prodsIdecls else [])
(if _lhsIo_sem then _prodsIsemNames else [])
]
)
_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
]
in Code.Type (getName nt_) params' (idEvalType theType)
derivings = maybe [] (map getName . Set.toList) (Map.lookup nt_ _lhsIderivings)
dataDef = Data (getName nt_) (map getName params_) _prodsIdataAlts (maybe False id _lhsIo_data) derivings
in maybe dataDef typeSyn $ lookup nt_ _lhsItypeSyns
)
_genCata =
(
not (nt_ `Set.member` nocatas _lhsIoptions)
)
_cataFun =
(
let appParams nm = TypeApp (SimpleType nm) (map SimpleType (map getName params_))
evalTp | null params_ = id
| otherwise = idEvalType
tSig = TSig (cataname _lhsIprefix nt_)
(appQuant _lhsIquantMap nt_ $ appContext _lhsIcontextMap nt_ $ evalTp $ appParams (getName nt_) `Arr` appParams (sdtype nt_))
special typ = case typ of
CommonTypes.List tp ->
let cons = SimpleExpr (semname _lhsIprefix nt_ (identifier "Cons"))
nil = SimpleExpr (semname _lhsIprefix nt_ (identifier "Nil" ))
arg = SimpleExpr "list"
rarg = case tp of
NT t _ _ -> let t' = maybe t id (deforestedNt t)
in SimpleExpr ("(Prelude.map " ++ (cataname _lhsIprefix t') ++ " list)")
_ -> arg
lhs = Fun (cataname _lhsIprefix nt_) [arg]
rhs = (App "Prelude.foldr" [cons,nil,rarg])
in [Decl lhs rhs Set.empty Set.empty]
CommonTypes.Maybe tp ->
let just = semname _lhsIprefix nt_ (identifier "Just")
nothing = semname _lhsIprefix nt_ (identifier "Nothing" )
arg = SimpleExpr "x"
rarg = case tp of
NT t _ _ -> let t' = maybe t id (deforestedNt t)
in App (cataname _lhsIprefix t') [arg]
_ -> arg
lhs a = Fun (cataname _lhsIprefix 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 _lhsIprefix nt_ (identifier "Left")
right = semname _lhsIprefix nt_ (identifier "Right" )
arg = SimpleExpr "x"
rarg0 = case tp1 of
NT t _ _ -> let t' = maybe t id (deforestedNt t)
in App (cataname _lhsIprefix t') [arg]
_ -> arg
rarg1 = case tp2 of
NT t _ _ -> let t' = maybe t id (deforestedNt t)
in App (cataname _lhsIprefix t') [arg]
_ -> arg
lhs a = Fun (cataname _lhsIprefix 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 _lhsIprefix nt_ (identifier "Entry"))
nil = SimpleExpr (semname _lhsIprefix 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 _lhsIprefix t', arg]
_ -> arg
lhs = Fun (cataname _lhsIprefix 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 _lhsIprefix nt_ (identifier "Entry"))
nil = SimpleExpr (semname _lhsIprefix 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 _lhsIprefix t', arg]
_ -> arg
lhs = Fun (cataname _lhsIprefix nt_) [arg]
rhs = App "Data.IntMap.foldWithKey" [entry,nil,rarg]
in [Decl lhs rhs Set.empty Set.empty]
CommonTypes.Tuple tps ->
let con = semname _lhsIprefix 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 _lhsIprefix t') [n]
_ -> n
lhs = Fun (cataname _lhsIprefix nt_) [TupleExpr (map fst tps')]
rhs = App con rargs
in [Decl lhs rhs Set.empty Set.empty]
in Comment "cata" :
(if _lhsIo_sig then [tSig] else []) ++
maybe _prodsIcataAlts special (lookup nt_ _lhsItypeSyns)
)
_lhsOsemDomUnfoldGath =
(
_interIsemDomUnfoldGath
)
_prodsOallNts =
(
_lhsIallNts
)
_prodsOallPragmas =
(
_lhsIallPragmas
)
_prodsOaroundMap =
(
_aroundMap
)
_prodsOcontextMap =
(
_lhsIcontextMap
)
_prodsOmergeMap =
(
_mergeMap
)
_prodsOo_case =
(
_lhsIo_case
)
_prodsOo_cata =
(
_lhsIo_cata
)
_prodsOo_costcentre =
(
_lhsIo_costcentre
)
_prodsOo_data =
(
_lhsIo_data
)
_prodsOo_linePragmas =
(
_lhsIo_linePragmas
)
_prodsOo_monadic =
(
_lhsIo_monadic
)
_prodsOo_newtypes =
(
_lhsIo_newtypes
)
_prodsOo_pretty =
(
_lhsIo_pretty
)
_prodsOo_rename =
(
_lhsIo_rename
)
_prodsOo_sem =
(
_lhsIo_sem
)
_prodsOo_sig =
(
_lhsIo_sig
)
_prodsOo_splitsems =
(
_lhsIo_splitsems
)
_prodsOo_strictwrap =
(
_lhsIo_strictwrap
)
_prodsOo_traces =
(
_lhsIo_traces
)
_prodsOo_unbox =
(
_lhsIo_unbox
)
_prodsOoptions =
(
_lhsIoptions
)
_prodsOparamMap =
(
_lhsIparamMap
)
_prodsOprefix =
(
_lhsIprefix
)
_prodsOquantMap =
(
_lhsIquantMap
)
_prodsOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_prodsOwith_sig =
(
_lhsIwith_sig
)
_prodsOwrappers =
(
_lhsIwrappers
)
_interOo_case =
(
_lhsIo_case
)
_interOo_cata =
(
_lhsIo_cata
)
_interOo_costcentre =
(
_lhsIo_costcentre
)
_interOo_data =
(
_lhsIo_data
)
_interOo_linePragmas =
(
_lhsIo_linePragmas
)
_interOo_monadic =
(
_lhsIo_monadic
)
_interOo_newtypes =
(
_lhsIo_newtypes
)
_interOo_pretty =
(
_lhsIo_pretty
)
_interOo_rename =
(
_lhsIo_rename
)
_interOo_sem =
(
_lhsIo_sem
)
_interOo_sig =
(
_lhsIo_sig
)
_interOo_splitsems =
(
_lhsIo_splitsems
)
_interOo_strictwrap =
(
_lhsIo_strictwrap
)
_interOo_traces =
(
_lhsIo_traces
)
_interOo_unbox =
(
_lhsIo_unbox
)
_interOoptions =
(
_lhsIoptions
)
_interOparamMap =
(
_lhsIparamMap
)
_interOprefix =
(
_lhsIprefix
)
( _prodsIcataAlts,_prodsIcomments,_prodsIdataAlts,_prodsIdecls,_prodsIsemNames) =
prods_ _prodsOallNts _prodsOallPragmas _prodsOaroundMap _prodsOcontextMap _prodsOinh _prodsOmergeMap _prodsOnt _prodsOo_case _prodsOo_cata _prodsOo_costcentre _prodsOo_data _prodsOo_linePragmas _prodsOo_monadic _prodsOo_newtypes _prodsOo_pretty _prodsOo_rename _prodsOo_sem _prodsOo_sig _prodsOo_splitsems _prodsOo_strictwrap _prodsOo_traces _prodsOo_unbox _prodsOoptions _prodsOparamMap _prodsOprefix _prodsOquantMap _prodsOsyn _prodsOunfoldSemDom _prodsOwith_sig _prodsOwrappers
( _interIcomments,_interIsemDom,_interIsemDomUnfoldGath,_interIwrapDecls) =
inter_ _interOinh _interOnt _interOo_case _interOo_cata _interOo_costcentre _interOo_data _interOo_linePragmas _interOo_monadic _interOo_newtypes _interOo_pretty _interOo_rename _interOo_sem _interOo_sig _interOo_splitsems _interOo_strictwrap _interOo_traces _interOo_unbox _interOoptions _interOparamMap _interOprefix _interOsyn
___node =
(Syn_CNonterminal _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath)
in ( _lhsOchunks,_lhsOgathNts,_lhsOsemDomUnfoldGath))))
sem_CNonterminals :: CNonterminals ->
T_CNonterminals
sem_CNonterminals list =
(Prelude.foldr sem_CNonterminals_Cons sem_CNonterminals_Nil (Prelude.map sem_CNonterminal list))
newtype T_CNonterminals = T_CNonterminals ((Set NontermIdent) ->
PragmaMap ->
(Map NontermIdent (Map ConstructorIdent (Set Identifier))) ->
ContextMap ->
Derivings ->
(Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))) ->
Bool ->
Bool ->
Bool ->
(Maybe Bool) ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Options ->
ParamMap ->
String ->
QuantMap ->
TypeSyns ->
(NontermIdent -> Int -> [String] -> Code.Type) ->
Bool ->
(Set NontermIdent) ->
( Chunks,(Set NontermIdent),(Map (NontermIdent, Int) ([String], Code.Type))))
data Inh_CNonterminals = Inh_CNonterminals {allNts_Inh_CNonterminals :: !((Set NontermIdent)),allPragmas_Inh_CNonterminals :: !(PragmaMap),aroundMap_Inh_CNonterminals :: !((Map NontermIdent (Map ConstructorIdent (Set Identifier)))),contextMap_Inh_CNonterminals :: !(ContextMap),derivings_Inh_CNonterminals :: !(Derivings),mergeMap_Inh_CNonterminals :: !((Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))))),o_case_Inh_CNonterminals :: !(Bool),o_cata_Inh_CNonterminals :: !(Bool),o_costcentre_Inh_CNonterminals :: !(Bool),o_data_Inh_CNonterminals :: !((Maybe Bool)),o_linePragmas_Inh_CNonterminals :: !(Bool),o_monadic_Inh_CNonterminals :: !(Bool),o_newtypes_Inh_CNonterminals :: !(Bool),o_pretty_Inh_CNonterminals :: !(Bool),o_rename_Inh_CNonterminals :: !(Bool),o_sem_Inh_CNonterminals :: !(Bool),o_sig_Inh_CNonterminals :: !(Bool),o_splitsems_Inh_CNonterminals :: !(Bool),o_strictwrap_Inh_CNonterminals :: !(Bool),o_traces_Inh_CNonterminals :: !(Bool),o_unbox_Inh_CNonterminals :: !(Bool),options_Inh_CNonterminals :: !(Options),paramMap_Inh_CNonterminals :: !(ParamMap),prefix_Inh_CNonterminals :: !(String),quantMap_Inh_CNonterminals :: !(QuantMap),typeSyns_Inh_CNonterminals :: !(TypeSyns),unfoldSemDom_Inh_CNonterminals :: !((NontermIdent -> Int -> [String] -> Code.Type)),with_sig_Inh_CNonterminals :: !(Bool),wrappers_Inh_CNonterminals :: !((Set NontermIdent))}
data Syn_CNonterminals = Syn_CNonterminals {chunks_Syn_CNonterminals :: !(Chunks),gathNts_Syn_CNonterminals :: !((Set NontermIdent)),semDomUnfoldGath_Syn_CNonterminals :: !((Map (NontermIdent, Int) ([String], Code.Type)))}
wrap_CNonterminals :: T_CNonterminals ->
Inh_CNonterminals ->
Syn_CNonterminals
wrap_CNonterminals (T_CNonterminals sem) (Inh_CNonterminals _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIderivings _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) =
(let ( _lhsOchunks,_lhsOgathNts,_lhsOsemDomUnfoldGath) = sem _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIderivings _lhsImergeMap _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsItypeSyns _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers
in (Syn_CNonterminals _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath))
sem_CNonterminals_Cons :: T_CNonterminal ->
T_CNonterminals ->
T_CNonterminals
sem_CNonterminals_Cons (T_CNonterminal hd_) (T_CNonterminals tl_) =
(T_CNonterminals (\ _lhsIallNts
_lhsIallPragmas
_lhsIaroundMap
_lhsIcontextMap
_lhsIderivings
_lhsImergeMap
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamMap
_lhsIprefix
_lhsIquantMap
_lhsItypeSyns
_lhsIunfoldSemDom
_lhsIwith_sig
_lhsIwrappers ->
(let _lhsOchunks :: Chunks
_lhsOgathNts :: (Set NontermIdent)
_lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_hdOallNts :: (Set NontermIdent)
_hdOallPragmas :: PragmaMap
_hdOaroundMap :: (Map NontermIdent (Map ConstructorIdent (Set Identifier)))
_hdOcontextMap :: ContextMap
_hdOderivings :: Derivings
_hdOmergeMap :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))))
_hdOo_case :: Bool
_hdOo_cata :: Bool
_hdOo_costcentre :: Bool
_hdOo_data :: (Maybe Bool)
_hdOo_linePragmas :: Bool
_hdOo_monadic :: Bool
_hdOo_newtypes :: Bool
_hdOo_pretty :: Bool
_hdOo_rename :: Bool
_hdOo_sem :: Bool
_hdOo_sig :: Bool
_hdOo_splitsems :: Bool
_hdOo_strictwrap :: Bool
_hdOo_traces :: Bool
_hdOo_unbox :: Bool
_hdOoptions :: Options
_hdOparamMap :: ParamMap
_hdOprefix :: String
_hdOquantMap :: QuantMap
_hdOtypeSyns :: TypeSyns
_hdOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_hdOwith_sig :: Bool
_hdOwrappers :: (Set NontermIdent)
_tlOallNts :: (Set NontermIdent)
_tlOallPragmas :: PragmaMap
_tlOaroundMap :: (Map NontermIdent (Map ConstructorIdent (Set Identifier)))
_tlOcontextMap :: ContextMap
_tlOderivings :: Derivings
_tlOmergeMap :: (Map NontermIdent (Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))))
_tlOo_case :: Bool
_tlOo_cata :: Bool
_tlOo_costcentre :: Bool
_tlOo_data :: (Maybe Bool)
_tlOo_linePragmas :: Bool
_tlOo_monadic :: Bool
_tlOo_newtypes :: Bool
_tlOo_pretty :: Bool
_tlOo_rename :: Bool
_tlOo_sem :: Bool
_tlOo_sig :: Bool
_tlOo_splitsems :: Bool
_tlOo_strictwrap :: Bool
_tlOo_traces :: Bool
_tlOo_unbox :: Bool
_tlOoptions :: Options
_tlOparamMap :: ParamMap
_tlOprefix :: String
_tlOquantMap :: QuantMap
_tlOtypeSyns :: TypeSyns
_tlOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_tlOwith_sig :: Bool
_tlOwrappers :: (Set NontermIdent)
_hdIchunks :: Chunks
_hdIgathNts :: (Set NontermIdent)
_hdIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_tlIchunks :: Chunks
_tlIgathNts :: (Set NontermIdent)
_tlIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_lhsOchunks =
(
_hdIchunks ++ _tlIchunks
)
_lhsOgathNts =
(
_hdIgathNts `Set.union` _tlIgathNts
)
_lhsOsemDomUnfoldGath =
(
_hdIsemDomUnfoldGath `Map.union` _tlIsemDomUnfoldGath
)
_hdOallNts =
(
_lhsIallNts
)
_hdOallPragmas =
(
_lhsIallPragmas
)
_hdOaroundMap =
(
_lhsIaroundMap
)
_hdOcontextMap =
(
_lhsIcontextMap
)
_hdOderivings =
(
_lhsIderivings
)
_hdOmergeMap =
(
_lhsImergeMap
)
_hdOo_case =
(
_lhsIo_case
)
_hdOo_cata =
(
_lhsIo_cata
)
_hdOo_costcentre =
(
_lhsIo_costcentre
)
_hdOo_data =
(
_lhsIo_data
)
_hdOo_linePragmas =
(
_lhsIo_linePragmas
)
_hdOo_monadic =
(
_lhsIo_monadic
)
_hdOo_newtypes =
(
_lhsIo_newtypes
)
_hdOo_pretty =
(
_lhsIo_pretty
)
_hdOo_rename =
(
_lhsIo_rename
)
_hdOo_sem =
(
_lhsIo_sem
)
_hdOo_sig =
(
_lhsIo_sig
)
_hdOo_splitsems =
(
_lhsIo_splitsems
)
_hdOo_strictwrap =
(
_lhsIo_strictwrap
)
_hdOo_traces =
(
_lhsIo_traces
)
_hdOo_unbox =
(
_lhsIo_unbox
)
_hdOoptions =
(
_lhsIoptions
)
_hdOparamMap =
(
_lhsIparamMap
)
_hdOprefix =
(
_lhsIprefix
)
_hdOquantMap =
(
_lhsIquantMap
)
_hdOtypeSyns =
(
_lhsItypeSyns
)
_hdOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_hdOwith_sig =
(
_lhsIwith_sig
)
_hdOwrappers =
(
_lhsIwrappers
)
_tlOallNts =
(
_lhsIallNts
)
_tlOallPragmas =
(
_lhsIallPragmas
)
_tlOaroundMap =
(
_lhsIaroundMap
)
_tlOcontextMap =
(
_lhsIcontextMap
)
_tlOderivings =
(
_lhsIderivings
)
_tlOmergeMap =
(
_lhsImergeMap
)
_tlOo_case =
(
_lhsIo_case
)
_tlOo_cata =
(
_lhsIo_cata
)
_tlOo_costcentre =
(
_lhsIo_costcentre
)
_tlOo_data =
(
_lhsIo_data
)
_tlOo_linePragmas =
(
_lhsIo_linePragmas
)
_tlOo_monadic =
(
_lhsIo_monadic
)
_tlOo_newtypes =
(
_lhsIo_newtypes
)
_tlOo_pretty =
(
_lhsIo_pretty
)
_tlOo_rename =
(
_lhsIo_rename
)
_tlOo_sem =
(
_lhsIo_sem
)
_tlOo_sig =
(
_lhsIo_sig
)
_tlOo_splitsems =
(
_lhsIo_splitsems
)
_tlOo_strictwrap =
(
_lhsIo_strictwrap
)
_tlOo_traces =
(
_lhsIo_traces
)
_tlOo_unbox =
(
_lhsIo_unbox
)
_tlOoptions =
(
_lhsIoptions
)
_tlOparamMap =
(
_lhsIparamMap
)
_tlOprefix =
(
_lhsIprefix
)
_tlOquantMap =
(
_lhsIquantMap
)
_tlOtypeSyns =
(
_lhsItypeSyns
)
_tlOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_tlOwith_sig =
(
_lhsIwith_sig
)
_tlOwrappers =
(
_lhsIwrappers
)
( _hdIchunks,_hdIgathNts,_hdIsemDomUnfoldGath) =
hd_ _hdOallNts _hdOallPragmas _hdOaroundMap _hdOcontextMap _hdOderivings _hdOmergeMap _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_monadic _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOoptions _hdOparamMap _hdOprefix _hdOquantMap _hdOtypeSyns _hdOunfoldSemDom _hdOwith_sig _hdOwrappers
( _tlIchunks,_tlIgathNts,_tlIsemDomUnfoldGath) =
tl_ _tlOallNts _tlOallPragmas _tlOaroundMap _tlOcontextMap _tlOderivings _tlOmergeMap _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_monadic _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOoptions _tlOparamMap _tlOprefix _tlOquantMap _tlOtypeSyns _tlOunfoldSemDom _tlOwith_sig _tlOwrappers
___node =
(Syn_CNonterminals _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath)
in ( _lhsOchunks,_lhsOgathNts,_lhsOsemDomUnfoldGath))))
sem_CNonterminals_Nil :: T_CNonterminals
sem_CNonterminals_Nil =
(T_CNonterminals (\ _lhsIallNts
_lhsIallPragmas
_lhsIaroundMap
_lhsIcontextMap
_lhsIderivings
_lhsImergeMap
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamMap
_lhsIprefix
_lhsIquantMap
_lhsItypeSyns
_lhsIunfoldSemDom
_lhsIwith_sig
_lhsIwrappers ->
(let _lhsOchunks :: Chunks
_lhsOgathNts :: (Set NontermIdent)
_lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_lhsOchunks =
(
[]
)
_lhsOgathNts =
(
Set.empty
)
_lhsOsemDomUnfoldGath =
(
Map.empty
)
___node =
(Syn_CNonterminals _lhsOchunks _lhsOgathNts _lhsOsemDomUnfoldGath)
in ( _lhsOchunks,_lhsOgathNts,_lhsOsemDomUnfoldGath))))
sem_CProduction :: CProduction ->
T_CProduction
sem_CProduction (CProduction _con _visits _children _terminals) =
(sem_CProduction_CProduction _con (sem_CVisits _visits) _children _terminals)
newtype T_CProduction = T_CProduction ((Set NontermIdent) ->
PragmaMap ->
(Map ConstructorIdent (Set Identifier)) ->
ContextMap ->
Attributes ->
(Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))) ->
NontermIdent ->
Bool ->
Bool ->
Bool ->
(Maybe Bool) ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Options ->
ParamMap ->
String ->
QuantMap ->
Attributes ->
(NontermIdent -> Int -> [String] -> Code.Type) ->
Bool ->
(Set NontermIdent) ->
( Decl,([String]),DataAlt,Decls,([String])))
data Inh_CProduction = Inh_CProduction {allNts_Inh_CProduction :: !((Set NontermIdent)),allPragmas_Inh_CProduction :: !(PragmaMap),aroundMap_Inh_CProduction :: !((Map ConstructorIdent (Set Identifier))),contextMap_Inh_CProduction :: !(ContextMap),inh_Inh_CProduction :: !(Attributes),mergeMap_Inh_CProduction :: !((Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))),nt_Inh_CProduction :: !(NontermIdent),o_case_Inh_CProduction :: !(Bool),o_cata_Inh_CProduction :: !(Bool),o_costcentre_Inh_CProduction :: !(Bool),o_data_Inh_CProduction :: !((Maybe Bool)),o_linePragmas_Inh_CProduction :: !(Bool),o_monadic_Inh_CProduction :: !(Bool),o_newtypes_Inh_CProduction :: !(Bool),o_pretty_Inh_CProduction :: !(Bool),o_rename_Inh_CProduction :: !(Bool),o_sem_Inh_CProduction :: !(Bool),o_sig_Inh_CProduction :: !(Bool),o_splitsems_Inh_CProduction :: !(Bool),o_strictwrap_Inh_CProduction :: !(Bool),o_traces_Inh_CProduction :: !(Bool),o_unbox_Inh_CProduction :: !(Bool),options_Inh_CProduction :: !(Options),paramMap_Inh_CProduction :: !(ParamMap),prefix_Inh_CProduction :: !(String),quantMap_Inh_CProduction :: !(QuantMap),syn_Inh_CProduction :: !(Attributes),unfoldSemDom_Inh_CProduction :: !((NontermIdent -> Int -> [String] -> Code.Type)),with_sig_Inh_CProduction :: !(Bool),wrappers_Inh_CProduction :: !((Set NontermIdent))}
data Syn_CProduction = Syn_CProduction {cataAlt_Syn_CProduction :: !(Decl),comments_Syn_CProduction :: !(([String])),dataAlt_Syn_CProduction :: !(DataAlt),decls_Syn_CProduction :: !(Decls),semNames_Syn_CProduction :: !(([String]))}
wrap_CProduction :: T_CProduction ->
Inh_CProduction ->
Syn_CProduction
wrap_CProduction (T_CProduction sem) (Inh_CProduction _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIinh _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) =
(let ( _lhsOcataAlt,_lhsOcomments,_lhsOdataAlt,_lhsOdecls,_lhsOsemNames) = sem _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIinh _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers
in (Syn_CProduction _lhsOcataAlt _lhsOcomments _lhsOdataAlt _lhsOdecls _lhsOsemNames))
sem_CProduction_CProduction :: ConstructorIdent ->
T_CVisits ->
([(Identifier,Type,ChildKind)]) ->
([Identifier]) ->
T_CProduction
sem_CProduction_CProduction con_ (T_CVisits visits_) children_ terminals_ =
(T_CProduction (\ _lhsIallNts
_lhsIallPragmas
_lhsIaroundMap
_lhsIcontextMap
_lhsIinh
_lhsImergeMap
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamMap
_lhsIprefix
_lhsIquantMap
_lhsIsyn
_lhsIunfoldSemDom
_lhsIwith_sig
_lhsIwrappers ->
(let _visitsOcon :: ConstructorIdent
_visitsOterminals :: ([Identifier])
_visitsOvisitedSet :: (Set Identifier)
_visitsOnr :: Int
_visitsOchildren :: ([(Identifier,Type, ChildKind)])
_visitsOinstVisitNrs :: (Map Identifier Int)
_lhsOcomments :: ([String])
_lhsOdataAlt :: DataAlt
_lhsOcataAlt :: Decl
_lhsOdecls :: Decls
_lhsOsemNames :: ([String])
_visitsOallNts :: (Set NontermIdent)
_visitsOallPragmas :: PragmaMap
_visitsOaroundMap :: (Set Identifier)
_visitsOcontextMap :: ContextMap
_visitsOinh :: Attributes
_visitsOmergeMap :: (Map Identifier (Identifier, [Identifier]))
_visitsOnt :: NontermIdent
_visitsOo_case :: Bool
_visitsOo_cata :: Bool
_visitsOo_costcentre :: Bool
_visitsOo_data :: (Maybe Bool)
_visitsOo_linePragmas :: Bool
_visitsOo_monadic :: Bool
_visitsOo_newtypes :: Bool
_visitsOo_pretty :: Bool
_visitsOo_rename :: Bool
_visitsOo_sem :: Bool
_visitsOo_sig :: Bool
_visitsOo_splitsems :: Bool
_visitsOo_strictwrap :: Bool
_visitsOo_traces :: Bool
_visitsOo_unbox :: Bool
_visitsOoptions :: Options
_visitsOparamInstMap :: (Map Identifier (NontermIdent, [String]))
_visitsOparamMap :: ParamMap
_visitsOprefix :: String
_visitsOquantMap :: QuantMap
_visitsOsyn :: Attributes
_visitsOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_visitsOwith_sig :: Bool
_visitsOwrappers :: (Set NontermIdent)
_visitsIcomments :: ([String])
_visitsIdecls :: Decls
_visitsIgatherInstVisitNrs :: (Map Identifier Int)
_visitsIintra :: Exprs
_visitsIintraVars :: (Set String)
_visitsIisNil :: Bool
_visitsIsemNames :: ([String])
_visitsIvisitedSet :: (Set Identifier)
_visitsOcon =
(
con_
)
_visitsOterminals =
(
terminals_
)
_paramInstMap =
(
Map.fromList [(nm, (extractNonterminal tp, tps)) | (nm,tp,_) <- children_, let tps = map cleanupArg $ nontermArgs tp, not (null tps) ]
)
_visitsOvisitedSet =
(
Set.empty
)
_visitsOnr =
(
0
)
_visitsOchildren =
(
children_
)
_visitsOinstVisitNrs =
(
_visitsIgatherInstVisitNrs
)
_aroundMap =
(
Map.findWithDefault Set.empty con_ _lhsIaroundMap
)
_mergeMap =
(
Map.findWithDefault Map.empty con_ _lhsImergeMap
)
_firstOrderChildren =
(
[ (nm,fromJust mb,virt) | (nm,tp,virt) <- children_, let mb = isFirstOrder virt tp, isJust mb ]
)
_lhsOcomments =
(
("alternative " ++ getName con_ ++ ":")
: map ind ( map (\(x,y,_) -> makeLocalComment 14 "child" x (Just y)) _firstOrderChildren
++ _visitsIcomments
)
)
_params =
(
map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap
)
_lhsOdataAlt =
(
let conNm = conname _lhsIo_rename _lhsInt con_
mkFields f = map (\(nm,t,_) -> f _lhsInt con_ nm (typeToCodeType (Just _lhsInt) _params $ removeDeforested t)) _firstOrderChildren
in if dataRecords _lhsIoptions
then Record conNm $ mkFields $ toNamedType (strictData _lhsIoptions)
else DataAlt conNm $ mkFields $ \_ _ _ t -> t
)
_lhsOcataAlt =
(
let lhs = Fun (cataname _lhsIprefix _lhsInt) [lhs_pat]
lhs_pat = App (conname _lhsIo_rename _lhsInt con_)
(map (\(n,_,_) -> SimpleExpr $ locname $ n) _firstOrderChildren )
rhs = App (semname _lhsIprefix _lhsInt con_)
(map argument _firstOrderChildren )
argument (nm,NT tp _ _,_) = App (cataname _lhsIprefix tp)
[SimpleExpr (locname nm)]
argument (nm, _,_) = SimpleExpr (locname nm)
in Decl lhs rhs Set.empty Set.empty
)
_lhsOdecls =
(
_visitsIdecls
)
_lhsOsemNames =
(
_visitsIsemNames
)
_visitsOallNts =
(
_lhsIallNts
)
_visitsOallPragmas =
(
_lhsIallPragmas
)
_visitsOaroundMap =
(
_aroundMap
)
_visitsOcontextMap =
(
_lhsIcontextMap
)
_visitsOinh =
(
_lhsIinh
)
_visitsOmergeMap =
(
_mergeMap
)
_visitsOnt =
(
_lhsInt
)
_visitsOo_case =
(
_lhsIo_case
)
_visitsOo_cata =
(
_lhsIo_cata
)
_visitsOo_costcentre =
(
_lhsIo_costcentre
)
_visitsOo_data =
(
_lhsIo_data
)
_visitsOo_linePragmas =
(
_lhsIo_linePragmas
)
_visitsOo_monadic =
(
_lhsIo_monadic
)
_visitsOo_newtypes =
(
_lhsIo_newtypes
)
_visitsOo_pretty =
(
_lhsIo_pretty
)
_visitsOo_rename =
(
_lhsIo_rename
)
_visitsOo_sem =
(
_lhsIo_sem
)
_visitsOo_sig =
(
_lhsIo_sig
)
_visitsOo_splitsems =
(
_lhsIo_splitsems
)
_visitsOo_strictwrap =
(
_lhsIo_strictwrap
)
_visitsOo_traces =
(
_lhsIo_traces
)
_visitsOo_unbox =
(
_lhsIo_unbox
)
_visitsOoptions =
(
_lhsIoptions
)
_visitsOparamInstMap =
(
_paramInstMap
)
_visitsOparamMap =
(
_lhsIparamMap
)
_visitsOprefix =
(
_lhsIprefix
)
_visitsOquantMap =
(
_lhsIquantMap
)
_visitsOsyn =
(
_lhsIsyn
)
_visitsOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_visitsOwith_sig =
(
_lhsIwith_sig
)
_visitsOwrappers =
(
_lhsIwrappers
)
( _visitsIcomments,_visitsIdecls,_visitsIgatherInstVisitNrs,_visitsIintra,_visitsIintraVars,_visitsIisNil,_visitsIsemNames,_visitsIvisitedSet) =
visits_ _visitsOallNts _visitsOallPragmas _visitsOaroundMap _visitsOchildren _visitsOcon _visitsOcontextMap _visitsOinh _visitsOinstVisitNrs _visitsOmergeMap _visitsOnr _visitsOnt _visitsOo_case _visitsOo_cata _visitsOo_costcentre _visitsOo_data _visitsOo_linePragmas _visitsOo_monadic _visitsOo_newtypes _visitsOo_pretty _visitsOo_rename _visitsOo_sem _visitsOo_sig _visitsOo_splitsems _visitsOo_strictwrap _visitsOo_traces _visitsOo_unbox _visitsOoptions _visitsOparamInstMap _visitsOparamMap _visitsOprefix _visitsOquantMap _visitsOsyn _visitsOterminals _visitsOunfoldSemDom _visitsOvisitedSet _visitsOwith_sig _visitsOwrappers
___node =
(Syn_CProduction _lhsOcataAlt _lhsOcomments _lhsOdataAlt _lhsOdecls _lhsOsemNames)
in ( _lhsOcataAlt,_lhsOcomments,_lhsOdataAlt,_lhsOdecls,_lhsOsemNames))))
sem_CProductions :: CProductions ->
T_CProductions
sem_CProductions list =
(Prelude.foldr sem_CProductions_Cons sem_CProductions_Nil (Prelude.map sem_CProduction list))
newtype T_CProductions = T_CProductions ((Set NontermIdent) ->
PragmaMap ->
(Map ConstructorIdent (Set Identifier)) ->
ContextMap ->
Attributes ->
(Map ConstructorIdent (Map Identifier (Identifier, [Identifier]))) ->
NontermIdent ->
Bool ->
Bool ->
Bool ->
(Maybe Bool) ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Options ->
ParamMap ->
String ->
QuantMap ->
Attributes ->
(NontermIdent -> Int -> [String] -> Code.Type) ->
Bool ->
(Set NontermIdent) ->
( Decls,([String]),DataAlts,Decls,([String])))
data Inh_CProductions = Inh_CProductions {allNts_Inh_CProductions :: !((Set NontermIdent)),allPragmas_Inh_CProductions :: !(PragmaMap),aroundMap_Inh_CProductions :: !((Map ConstructorIdent (Set Identifier))),contextMap_Inh_CProductions :: !(ContextMap),inh_Inh_CProductions :: !(Attributes),mergeMap_Inh_CProductions :: !((Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))),nt_Inh_CProductions :: !(NontermIdent),o_case_Inh_CProductions :: !(Bool),o_cata_Inh_CProductions :: !(Bool),o_costcentre_Inh_CProductions :: !(Bool),o_data_Inh_CProductions :: !((Maybe Bool)),o_linePragmas_Inh_CProductions :: !(Bool),o_monadic_Inh_CProductions :: !(Bool),o_newtypes_Inh_CProductions :: !(Bool),o_pretty_Inh_CProductions :: !(Bool),o_rename_Inh_CProductions :: !(Bool),o_sem_Inh_CProductions :: !(Bool),o_sig_Inh_CProductions :: !(Bool),o_splitsems_Inh_CProductions :: !(Bool),o_strictwrap_Inh_CProductions :: !(Bool),o_traces_Inh_CProductions :: !(Bool),o_unbox_Inh_CProductions :: !(Bool),options_Inh_CProductions :: !(Options),paramMap_Inh_CProductions :: !(ParamMap),prefix_Inh_CProductions :: !(String),quantMap_Inh_CProductions :: !(QuantMap),syn_Inh_CProductions :: !(Attributes),unfoldSemDom_Inh_CProductions :: !((NontermIdent -> Int -> [String] -> Code.Type)),with_sig_Inh_CProductions :: !(Bool),wrappers_Inh_CProductions :: !((Set NontermIdent))}
data Syn_CProductions = Syn_CProductions {cataAlts_Syn_CProductions :: !(Decls),comments_Syn_CProductions :: !(([String])),dataAlts_Syn_CProductions :: !(DataAlts),decls_Syn_CProductions :: !(Decls),semNames_Syn_CProductions :: !(([String]))}
wrap_CProductions :: T_CProductions ->
Inh_CProductions ->
Syn_CProductions
wrap_CProductions (T_CProductions sem) (Inh_CProductions _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIinh _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers) =
(let ( _lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOsemNames) = sem _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIcontextMap _lhsIinh _lhsImergeMap _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIunfoldSemDom _lhsIwith_sig _lhsIwrappers
in (Syn_CProductions _lhsOcataAlts _lhsOcomments _lhsOdataAlts _lhsOdecls _lhsOsemNames))
sem_CProductions_Cons :: T_CProduction ->
T_CProductions ->
T_CProductions
sem_CProductions_Cons (T_CProduction hd_) (T_CProductions tl_) =
(T_CProductions (\ _lhsIallNts
_lhsIallPragmas
_lhsIaroundMap
_lhsIcontextMap
_lhsIinh
_lhsImergeMap
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamMap
_lhsIprefix
_lhsIquantMap
_lhsIsyn
_lhsIunfoldSemDom
_lhsIwith_sig
_lhsIwrappers ->
(let _lhsOdataAlts :: DataAlts
_lhsOcataAlts :: Decls
_lhsOcomments :: ([String])
_lhsOdecls :: Decls
_lhsOsemNames :: ([String])
_hdOallNts :: (Set NontermIdent)
_hdOallPragmas :: PragmaMap
_hdOaroundMap :: (Map ConstructorIdent (Set Identifier))
_hdOcontextMap :: ContextMap
_hdOinh :: Attributes
_hdOmergeMap :: (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))
_hdOnt :: NontermIdent
_hdOo_case :: Bool
_hdOo_cata :: Bool
_hdOo_costcentre :: Bool
_hdOo_data :: (Maybe Bool)
_hdOo_linePragmas :: Bool
_hdOo_monadic :: Bool
_hdOo_newtypes :: Bool
_hdOo_pretty :: Bool
_hdOo_rename :: Bool
_hdOo_sem :: Bool
_hdOo_sig :: Bool
_hdOo_splitsems :: Bool
_hdOo_strictwrap :: Bool
_hdOo_traces :: Bool
_hdOo_unbox :: Bool
_hdOoptions :: Options
_hdOparamMap :: ParamMap
_hdOprefix :: String
_hdOquantMap :: QuantMap
_hdOsyn :: Attributes
_hdOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_hdOwith_sig :: Bool
_hdOwrappers :: (Set NontermIdent)
_tlOallNts :: (Set NontermIdent)
_tlOallPragmas :: PragmaMap
_tlOaroundMap :: (Map ConstructorIdent (Set Identifier))
_tlOcontextMap :: ContextMap
_tlOinh :: Attributes
_tlOmergeMap :: (Map ConstructorIdent (Map Identifier (Identifier, [Identifier])))
_tlOnt :: NontermIdent
_tlOo_case :: Bool
_tlOo_cata :: Bool
_tlOo_costcentre :: Bool
_tlOo_data :: (Maybe Bool)
_tlOo_linePragmas :: Bool
_tlOo_monadic :: Bool
_tlOo_newtypes :: Bool
_tlOo_pretty :: Bool
_tlOo_rename :: Bool
_tlOo_sem :: Bool
_tlOo_sig :: Bool
_tlOo_splitsems :: Bool
_tlOo_strictwrap :: Bool
_tlOo_traces :: Bool
_tlOo_unbox :: Bool
_tlOoptions :: Options
_tlOparamMap :: ParamMap
_tlOprefix :: String
_tlOquantMap :: QuantMap
_tlOsyn :: Attributes
_tlOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_tlOwith_sig :: Bool
_tlOwrappers :: (Set NontermIdent)
_hdIcataAlt :: Decl
_hdIcomments :: ([String])
_hdIdataAlt :: DataAlt
_hdIdecls :: Decls
_hdIsemNames :: ([String])
_tlIcataAlts :: Decls
_tlIcomments :: ([String])
_tlIdataAlts :: DataAlts
_tlIdecls :: Decls
_tlIsemNames :: ([String])
_lhsOdataAlts =
(
_hdIdataAlt : _tlIdataAlts
)
_lhsOcataAlts =
(
_hdIcataAlt : _tlIcataAlts
)
_lhsOcomments =
(
_hdIcomments ++ _tlIcomments
)
_lhsOdecls =
(
_hdIdecls ++ _tlIdecls
)
_lhsOsemNames =
(
_hdIsemNames ++ _tlIsemNames
)
_hdOallNts =
(
_lhsIallNts
)
_hdOallPragmas =
(
_lhsIallPragmas
)
_hdOaroundMap =
(
_lhsIaroundMap
)
_hdOcontextMap =
(
_lhsIcontextMap
)
_hdOinh =
(
_lhsIinh
)
_hdOmergeMap =
(
_lhsImergeMap
)
_hdOnt =
(
_lhsInt
)
_hdOo_case =
(
_lhsIo_case
)
_hdOo_cata =
(
_lhsIo_cata
)
_hdOo_costcentre =
(
_lhsIo_costcentre
)
_hdOo_data =
(
_lhsIo_data
)
_hdOo_linePragmas =
(
_lhsIo_linePragmas
)
_hdOo_monadic =
(
_lhsIo_monadic
)
_hdOo_newtypes =
(
_lhsIo_newtypes
)
_hdOo_pretty =
(
_lhsIo_pretty
)
_hdOo_rename =
(
_lhsIo_rename
)
_hdOo_sem =
(
_lhsIo_sem
)
_hdOo_sig =
(
_lhsIo_sig
)
_hdOo_splitsems =
(
_lhsIo_splitsems
)
_hdOo_strictwrap =
(
_lhsIo_strictwrap
)
_hdOo_traces =
(
_lhsIo_traces
)
_hdOo_unbox =
(
_lhsIo_unbox
)
_hdOoptions =
(
_lhsIoptions
)
_hdOparamMap =
(
_lhsIparamMap
)
_hdOprefix =
(
_lhsIprefix
)
_hdOquantMap =
(
_lhsIquantMap
)
_hdOsyn =
(
_lhsIsyn
)
_hdOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_hdOwith_sig =
(
_lhsIwith_sig
)
_hdOwrappers =
(
_lhsIwrappers
)
_tlOallNts =
(
_lhsIallNts
)
_tlOallPragmas =
(
_lhsIallPragmas
)
_tlOaroundMap =
(
_lhsIaroundMap
)
_tlOcontextMap =
(
_lhsIcontextMap
)
_tlOinh =
(
_lhsIinh
)
_tlOmergeMap =
(
_lhsImergeMap
)
_tlOnt =
(
_lhsInt
)
_tlOo_case =
(
_lhsIo_case
)
_tlOo_cata =
(
_lhsIo_cata
)
_tlOo_costcentre =
(
_lhsIo_costcentre
)
_tlOo_data =
(
_lhsIo_data
)
_tlOo_linePragmas =
(
_lhsIo_linePragmas
)
_tlOo_monadic =
(
_lhsIo_monadic
)
_tlOo_newtypes =
(
_lhsIo_newtypes
)
_tlOo_pretty =
(
_lhsIo_pretty
)
_tlOo_rename =
(
_lhsIo_rename
)
_tlOo_sem =
(
_lhsIo_sem
)
_tlOo_sig =
(
_lhsIo_sig
)
_tlOo_splitsems =
(
_lhsIo_splitsems
)
_tlOo_strictwrap =
(
_lhsIo_strictwrap
)
_tlOo_traces =
(
_lhsIo_traces
)
_tlOo_unbox =
(
_lhsIo_unbox
)
_tlOoptions =
(
_lhsIoptions
)
_tlOparamMap =
(
_lhsIparamMap
)
_tlOprefix =
(
_lhsIprefix
)
_tlOquantMap =
(
_lhsIquantMap
)
_tlOsyn =
(
_lhsIsyn
)
_tlOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_tlOwith_sig =
(
_lhsIwith_sig
)
_tlOwrappers =
(
_lhsIwrappers
)
( _hdIcataAlt,_hdIcomments,_hdIdataAlt,_hdIdecls,_hdIsemNames) =
hd_ _hdOallNts _hdOallPragmas _hdOaroundMap _hdOcontextMap _hdOinh _hdOmergeMap _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_monadic _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOoptions _hdOparamMap _hdOprefix _hdOquantMap _hdOsyn _hdOunfoldSemDom _hdOwith_sig _hdOwrappers
( _tlIcataAlts,_tlIcomments,_tlIdataAlts,_tlIdecls,_tlIsemNames) =
tl_ _tlOallNts _tlOallPragmas _tlOaroundMap _tlOcontextMap _tlOinh _tlOmergeMap _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_monadic _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOoptions _tlOparamMap _tlOprefix _tlOquantMap _tlOsyn _tlOunfoldSemDom _tlOwith_sig _tlOwrappers
___node =
(Syn_CProductions _lhsOcataAlts _lhsOcomments _lhsOdataAlts _lhsOdecls _lhsOsemNames)
in ( _lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOsemNames))))
sem_CProductions_Nil :: T_CProductions
sem_CProductions_Nil =
(T_CProductions (\ _lhsIallNts
_lhsIallPragmas
_lhsIaroundMap
_lhsIcontextMap
_lhsIinh
_lhsImergeMap
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamMap
_lhsIprefix
_lhsIquantMap
_lhsIsyn
_lhsIunfoldSemDom
_lhsIwith_sig
_lhsIwrappers ->
(let _lhsOdataAlts :: DataAlts
_lhsOcataAlts :: Decls
_lhsOcomments :: ([String])
_lhsOdecls :: Decls
_lhsOsemNames :: ([String])
_lhsOdataAlts =
(
[]
)
_lhsOcataAlts =
(
[]
)
_lhsOcomments =
(
[]
)
_lhsOdecls =
(
[]
)
_lhsOsemNames =
(
[]
)
___node =
(Syn_CProductions _lhsOcataAlts _lhsOcomments _lhsOdataAlts _lhsOdecls _lhsOsemNames)
in ( _lhsOcataAlts,_lhsOcomments,_lhsOdataAlts,_lhsOdecls,_lhsOsemNames))))
sem_CRule :: CRule ->
T_CRule
sem_CRule (CChildVisit _name _nt _nr _inh _syn _isLast) =
(sem_CRule_CChildVisit _name _nt _nr _inh _syn _isLast)
sem_CRule (CRule _name _isIn _hasCode _nt _con _field _childnt _tp _pattern _rhs _defines _owrt _origin _uses _explicit _mbNamed) =
(sem_CRule_CRule _name _isIn _hasCode _nt _con _field _childnt _tp (sem_Pattern _pattern) _rhs _defines _owrt _origin _uses _explicit _mbNamed)
newtype T_CRule = T_CRule ((Set NontermIdent) ->
(Set Identifier) ->
([(Identifier,Type,ChildKind)]) ->
ConstructorIdent ->
([Decl]) ->
Attributes ->
(Map Identifier Int) ->
(Map Identifier (Identifier, [Identifier])) ->
Int ->
NontermIdent ->
Bool ->
Bool ->
Bool ->
(Maybe Bool) ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Options ->
(Map Identifier (NontermIdent, [String])) ->
ParamMap ->
String ->
Attributes ->
([Identifier]) ->
(NontermIdent -> Int -> [String] -> Code.Type) ->
(Set Identifier) ->
String ->
( Bool,(DeclBlocks -> DeclBlocks),([String]),Decls,([Decl]),([Identifier]),Exprs,([Decl]),([Type]),(Set String),(Set Identifier)))
data Inh_CRule = Inh_CRule {allNts_Inh_CRule :: !((Set NontermIdent)),aroundMap_Inh_CRule :: !((Set Identifier)),children_Inh_CRule :: !(([(Identifier,Type,ChildKind)])),con_Inh_CRule :: !(ConstructorIdent),declsAbove_Inh_CRule :: !(([Decl])),inh_Inh_CRule :: !(Attributes),instVisitNrs_Inh_CRule :: !((Map Identifier Int)),mergeMap_Inh_CRule :: !((Map Identifier (Identifier, [Identifier]))),nr_Inh_CRule :: !(Int),nt_Inh_CRule :: !(NontermIdent),o_case_Inh_CRule :: !(Bool),o_cata_Inh_CRule :: !(Bool),o_costcentre_Inh_CRule :: !(Bool),o_data_Inh_CRule :: !((Maybe Bool)),o_linePragmas_Inh_CRule :: !(Bool),o_monadic_Inh_CRule :: !(Bool),o_newtypes_Inh_CRule :: !(Bool),o_pretty_Inh_CRule :: !(Bool),o_rename_Inh_CRule :: !(Bool),o_sem_Inh_CRule :: !(Bool),o_sig_Inh_CRule :: !(Bool),o_splitsems_Inh_CRule :: !(Bool),o_strictwrap_Inh_CRule :: !(Bool),o_traces_Inh_CRule :: !(Bool),o_unbox_Inh_CRule :: !(Bool),options_Inh_CRule :: !(Options),paramInstMap_Inh_CRule :: !((Map Identifier (NontermIdent, [String]))),paramMap_Inh_CRule :: !(ParamMap),prefix_Inh_CRule :: !(String),syn_Inh_CRule :: !(Attributes),terminals_Inh_CRule :: !(([Identifier])),unfoldSemDom_Inh_CRule :: !((NontermIdent -> Int -> [String] -> Code.Type)),visitedSet_Inh_CRule :: !((Set Identifier)),what_Inh_CRule :: !(String)}
data Syn_CRule = Syn_CRule {allTpsFound_Syn_CRule :: !(Bool),bldBlocksFun_Syn_CRule :: !((DeclBlocks -> DeclBlocks)),comments_Syn_CRule :: !(([String])),decls_Syn_CRule :: !(Decls),declsAbove_Syn_CRule :: !(([Decl])),definedInsts_Syn_CRule :: !(([Identifier])),exprs_Syn_CRule :: !(Exprs),tSigs_Syn_CRule :: !(([Decl])),tps_Syn_CRule :: !(([Type])),usedVars_Syn_CRule :: !((Set String)),visitedSet_Syn_CRule :: !((Set Identifier))}
wrap_CRule :: T_CRule ->
Inh_CRule ->
Syn_CRule
wrap_CRule (T_CRule sem) (Inh_CRule _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat) =
(let ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars,_lhsOvisitedSet) = sem _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat
in (Syn_CRule _lhsOallTpsFound _lhsObldBlocksFun _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet))
sem_CRule_CChildVisit :: Identifier ->
NontermIdent ->
Int ->
Attributes ->
Attributes ->
Bool ->
T_CRule
sem_CRule_CChildVisit name_ nt_ nr_ inh_ syn_ isLast_ =
(T_CRule (\ _lhsIallNts
_lhsIaroundMap
_lhsIchildren
_lhsIcon
_lhsIdeclsAbove
_lhsIinh
_lhsIinstVisitNrs
_lhsImergeMap
_lhsInr
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamInstMap
_lhsIparamMap
_lhsIprefix
_lhsIsyn
_lhsIterminals
_lhsIunfoldSemDom
_lhsIvisitedSet
_lhsIwhat ->
(let _lhsOexprs :: Exprs
_lhsOusedVars :: (Set String)
_lhsOtSigs :: ([Decl])
_lhsOtps :: ([Type])
_lhsOdeclsAbove :: ([Decl])
_lhsObldBlocksFun :: (DeclBlocks -> DeclBlocks)
_lhsOallTpsFound :: Bool
_lhsOcomments :: ([String])
_lhsOdecls :: Decls
_lhsOdefinedInsts :: ([Identifier])
_lhsOvisitedSet :: (Set Identifier)
_visitedSet =
(
Set.insert name_ _lhsIvisitedSet
)
_costCentreDescr =
(
show _lhsInt ++ ":" ++ show _lhsIcon ++ ":" ++ show name_ ++ ":" ++ show nt_ ++ ":" ++ show nr_
)
_addCostCentre =
(
\v -> if _lhsIo_costcentre
then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v
else v
)
_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 _lhsIo_newtypes then typeName nt_ (nr_ + 1) ++ " " else ""
tuple | isMerging = TupleLhs [locname name_ ++ "_comp"]
| otherwise = mkTupleLhs _lhsIo_unbox (null $ Map.keys inh_) lhsVars
rhs = _addCostCentre $ Code.InvokeExpr (typeName nt_ nr_) (SimpleExpr fun) (map SimpleExpr rhsVars)
isVirtual _ [] = False
isVirtual nm ((n,t,kind) : r)
| nm == n = case kind of
ChildAttr -> True
_ -> False
| otherwise = isVirtual nm r
isMerged = name_ `Map.member` _lhsImergeMap
isMerging = name_ `elem` concatMap (\(_,cs) -> cs) (Map.elems _lhsImergeMap)
merges = [ (c,cs) | (c,(_,cs)) <- Map.assocs _lhsImergeMap, all (`Set.member` _visitedSet ) cs, name_ `elem` (c:cs) ]
baseNm = if nr_ == 0 && isVirtual name_ _lhsIchildren
then Ident (getName name_ ++ "_inst") (getPos name_)
else name_
fun | nr_ == 0 && Set.member name_ _lhsIaroundMap
= locname name_ ++ "_around " ++ funname baseNm 0
| otherwise = funname baseNm nr_
outDecls | isMerged = []
| otherwise =
if isMerging
then [mkDecl _lhsIo_monadic tuple rhs Set.empty Set.empty]
else [Resume _lhsIo_monadic (typeName nt_ nr_) tuple rhs]
outMerged | null merges || nr_ /= 0 = []
| otherwise = let (c,cs) = head merges
tuple' = mkTupleLhs _lhsIo_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 _lhsIo_monadic (typeName nt_ nr_) tuple' rhs']
in
(outDecls ++ outMerged)
)
_isSuperfluousHigherOrderIntra =
(
_lhsInr <= Map.findWithDefault (1) name_ _lhsIinstVisitNrs
)
_names =
(
if _isSuperfluousHigherOrderIntra
then []
else [funname name_ (nr_+1)]
)
_lhsOexprs =
(
let wrap = if _lhsIo_newtypes then \x -> App (typeName nt_ (nr_ + 1)) [x] else id
addType expr | null _instParams = expr
| otherwise = TypedExpr expr (_lhsIunfoldSemDom nt_ (nr_+1) _instParams )
in map (wrap . addType . SimpleExpr) _names
)
_lhsOusedVars =
(
Set.fromList _names
)
_mkTp =
(
_evalTp . typeToCodeType (Just nt_) _orgParams . removeDeforested
)
_definedTps =
(
[ TSig (attrname True name_ a) (_mkTp tp) | (a,tp) <- Map.toList syn_ ]
)
_nextTp =
(
typeName nt_ (nr_+1)
)
_lhsOtSigs =
(
(if isLast_ then id else (TSig (funname name_ (nr_+1)) (TypeApp (SimpleType _nextTp) (map SimpleType _instParams )) :)) _definedTps
)
_orgParams =
(
map getName $ Map.findWithDefault [] nt_ _lhsIparamMap
)
_instParams =
(
snd $ Map.findWithDefault (nt_,[]) name_ _lhsIparamInstMap
)
_replParamMap =
(
Map.fromList (zip _orgParams _instParams )
)
_replace =
(
\k -> Map.findWithDefault k k _replParamMap
)
_evalTp =
(
if null _orgParams then id else evalType _replace
)
_lhsOtps =
(
if _isSuperfluousHigherOrderIntra
then []
else [NT (ntOfVisit nt_ (nr_+1)) _instParams False]
)
_lhsOdeclsAbove =
(
[]
)
_lhsObldBlocksFun =
(
DeclBlock _lhsIdeclsAbove (head _decls )
)
_lhsOallTpsFound =
(
True
)
_lhsOcomments =
(
[]
)
_lhsOdecls =
(
_decls
)
_lhsOdefinedInsts =
(
[]
)
_lhsOvisitedSet =
(
_visitedSet
)
___node =
(Syn_CRule _lhsOallTpsFound _lhsObldBlocksFun _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet)
in ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars,_lhsOvisitedSet))))
sem_CRule_CRule :: Identifier ->
Bool ->
Bool ->
NontermIdent ->
ConstructorIdent ->
Identifier ->
(Maybe NontermIdent) ->
(Maybe Type) ->
T_Pattern ->
([String]) ->
(Map Int (Identifier,Identifier,Maybe Type)) ->
Bool ->
String ->
(Set (Identifier, Identifier)) ->
Bool ->
(Maybe Identifier) ->
T_CRule
sem_CRule_CRule name_ isIn_ hasCode_ nt_ con_ field_ childnt_ tp_ (T_Pattern pattern_) rhs_ defines_ owrt_ origin_ uses_ explicit_ mbNamed_ =
(T_CRule (\ _lhsIallNts
_lhsIaroundMap
_lhsIchildren
_lhsIcon
_lhsIdeclsAbove
_lhsIinh
_lhsIinstVisitNrs
_lhsImergeMap
_lhsInr
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamInstMap
_lhsIparamMap
_lhsIprefix
_lhsIsyn
_lhsIterminals
_lhsIunfoldSemDom
_lhsIvisitedSet
_lhsIwhat ->
(let _lhsOexprs :: Exprs
_lhsOusedVars :: (Set String)
_lhsOtSigs :: ([Decl])
_lhsOtps :: ([Type])
_lhsOallTpsFound :: Bool
_lhsOdeclsAbove :: ([Decl])
_lhsObldBlocksFun :: (DeclBlocks -> DeclBlocks)
_lhsOcomments :: ([String])
_lhsOdecls :: Decls
_lhsOdefinedInsts :: ([Identifier])
_lhsOvisitedSet :: (Set Identifier)
_patternIcopy :: Pattern
_patternIdefinedInsts :: ([Identifier])
_patternIpatternAttributes :: ([(Identifier, Identifier)])
_instTypes =
(
[ (n, (t, mb, for)) | (n, NT t _ for, mb) <- _lhsIchildren ]
)
_originComment =
(
if _lhsIo_pretty
then (Comment origin_:)
else id
)
_instDecls =
(
[ mkDecl _lhsIo_monadic (Pattern3 (Alias _INST' inst (Underscore (getPos inst))))
( let (nm,mb,defor) = fromJust $ inst `lookup` _instTypes
in unwrapSem _lhsIo_newtypes nm
$ case mb of
ChildReplace tp' -> App instLocFieldName [SimpleExpr $ fieldname inst]
_ ->
if defor
then SimpleExpr instLocFieldName
else App (cataname _lhsIprefix nm)
[SimpleExpr instLocFieldName]
)
(Set.singleton instSemFieldName)
(Set.singleton instLocFieldName)
| inst <- _definedInsts
, let instLocFieldName = attrname True _INST inst
instSemFieldName = attrname False _INST' inst
]
)
_patDescr =
(
if isIn_
then "_"
else concat $ intersperse "," (map (\(f,a) -> show f ++ "." ++ show a) _patternIpatternAttributes)
)
_traceDescr =
(
(maybe "" (\nm -> show nm ++ ":") mbNamed_) ++ show nt_ ++ " :: " ++ show con_ ++ " :: " ++ _patDescr
)
_addTrace =
(
\v -> if _lhsIo_traces
then Trace _traceDescr v
else v
)
_costCentreDescr =
(
show nt_ ++ ":" ++ show con_ ++ ":" ++ _patDescr
)
_addCostCentre =
(
\v -> if _lhsIo_costcentre
then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v
else v
)
_addLinePragma =
(
\v -> let p = getPos name_
hasPos = line p > 0 && column p >= 0 && not (null (file p))
in if _lhsIo_linePragmas && hasPos
then PragmaExpr True True ("LINE " ++ show (line p) ++ " " ++ show (file p))
$ LineExpr
$ v
else v
)
_decls =
(
if hasCode_
then _originComment ( mkDecl (_lhsIo_monadic && explicit_) (Pattern3 _patternIcopy) (_addTrace $ _addCostCentre $ _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_])
: _instDecls )
else _instDecls
)
_definedInsts =
(
if isIn_ then [] else _patternIdefinedInsts
)
_rulename =
(
if field_ == _LOC && name_ `elem` _lhsIterminals
then funname name_ 0
else attrname isIn_ field_ name_
)
_lhsOexprs =
(
[SimpleExpr _rulename ]
)
_lhsOusedVars =
(
Set.singleton _rulename
)
_mkTp =
(
typeToCodeType (Just _lhsInt) _orgParams
)
_lhsOtSigs =
(
[ TSig (attrname False field attr) tp'
| (field,attr,tp) <- Map.elems defines_, isJust tp
, let tp1 = _evalTp field $ _mkTp (fromJust tp)
tp' = case findOrigType attr _lhsIchildren of
Just tp' -> let tp2 = _evalTp field $ _mkTp tp'
in Arr tp2 tp1
Nothing -> tp1
findOrigType nm [] = Nothing
findOrigType nm ((n,_,kind) : r)
| nm == n = case kind of
ChildReplace orig -> Just orig
_ -> Nothing
| otherwise = findOrigType nm r
]
)
_orgParams =
(
map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap
)
_evalTp =
(
\field tp -> let orgFldParams = map getName $ Map.findWithDefault [] childNt _lhsIparamMap
(childNt,instParams) = Map.findWithDefault (_lhsInt,[]) field _lhsIparamInstMap
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
)
(_lhsOtps,_lhsOallTpsFound) =
(
maybe ([],False) (\tp -> ([tp],True)) tp_
)
_lhsOdeclsAbove =
(
_lhsIdeclsAbove ++ _decls
)
_lhsObldBlocksFun =
(
id
)
_lhsOcomments =
(
[ makeLocalComment 11 _lhsIwhat name tp | (field,name,tp) <- Map.elems defines_, field == _LOC ]
++ [ makeLocalComment 11 "inst " name tp | (field,name,tp) <- Map.elems defines_, field == _INST ]
)
_lhsOdecls =
(
_decls
)
_lhsOdefinedInsts =
(
_definedInsts
)
_lhsOvisitedSet =
(
_lhsIvisitedSet
)
( _patternIcopy,_patternIdefinedInsts,_patternIpatternAttributes) =
pattern_
___node =
(Syn_CRule _lhsOallTpsFound _lhsObldBlocksFun _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet)
in ( _lhsOallTpsFound,_lhsObldBlocksFun,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars,_lhsOvisitedSet))))
sem_CSegment :: CSegment ->
T_CSegment
sem_CSegment (CSegment _inh _syn) =
(sem_CSegment_CSegment _inh _syn)
newtype T_CSegment = T_CSegment (Attributes ->
Bool ->
Int ->
NontermIdent ->
Bool ->
Bool ->
Bool ->
(Maybe Bool) ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Options ->
ParamMap ->
String ->
Attributes ->
( ([String]),([Decl]),(Map (NontermIdent, Int) ([String], Code.Type)),Decls))
data Inh_CSegment = Inh_CSegment {inh_Inh_CSegment :: !(Attributes),isLast_Inh_CSegment :: !(Bool),nr_Inh_CSegment :: !(Int),nt_Inh_CSegment :: !(NontermIdent),o_case_Inh_CSegment :: !(Bool),o_cata_Inh_CSegment :: !(Bool),o_costcentre_Inh_CSegment :: !(Bool),o_data_Inh_CSegment :: !((Maybe Bool)),o_linePragmas_Inh_CSegment :: !(Bool),o_monadic_Inh_CSegment :: !(Bool),o_newtypes_Inh_CSegment :: !(Bool),o_pretty_Inh_CSegment :: !(Bool),o_rename_Inh_CSegment :: !(Bool),o_sem_Inh_CSegment :: !(Bool),o_sig_Inh_CSegment :: !(Bool),o_splitsems_Inh_CSegment :: !(Bool),o_strictwrap_Inh_CSegment :: !(Bool),o_traces_Inh_CSegment :: !(Bool),o_unbox_Inh_CSegment :: !(Bool),options_Inh_CSegment :: !(Options),paramMap_Inh_CSegment :: !(ParamMap),prefix_Inh_CSegment :: !(String),syn_Inh_CSegment :: !(Attributes)}
data Syn_CSegment = Syn_CSegment {comments_Syn_CSegment :: !(([String])),semDom_Syn_CSegment :: !(([Decl])),semDomUnfoldGath_Syn_CSegment :: !((Map (NontermIdent, Int) ([String], Code.Type))),wrapDecls_Syn_CSegment :: !(Decls)}
wrap_CSegment :: T_CSegment ->
Inh_CSegment ->
Syn_CSegment
wrap_CSegment (T_CSegment sem) (Inh_CSegment _lhsIinh _lhsIisLast _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn) =
(let ( _lhsOcomments,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls) = sem _lhsIinh _lhsIisLast _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn
in (Syn_CSegment _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls))
sem_CSegment_CSegment :: Attributes ->
Attributes ->
T_CSegment
sem_CSegment_CSegment inh_ syn_ =
(T_CSegment (\ _lhsIinh
_lhsIisLast
_lhsInr
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamMap
_lhsIprefix
_lhsIsyn ->
(let _lhsOsemDom :: ([Decl])
_lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_lhsOwrapDecls :: Decls
_lhsOcomments :: ([String])
_altSemForm =
(
breadthFirst _lhsIoptions
)
_tp =
(
if _altSemForm
then TypeApp (SimpleType "Child") [SimpleType "EvalInfo", _indexExpr ]
else foldr Arr _synTps _inhTps
)
_inhTps =
(
[typeToCodeType (Just _lhsInt) _params tp | tp <- Map.elems inh_]
)
_inhTup =
(
mkTupleType _lhsIo_unbox (null _inhTps ) _inhTps
)
_synTps =
(
mkTupleType _lhsIo_unbox (null _inhTps ) ([typeToCodeType (Just _lhsInt) _params tp | tp <- Map.elems syn_] ++ _continuation )
)
_curTypeName =
(
typeName _lhsInt _lhsInr
)
_nextTypeName =
(
typeName _lhsInt (_lhsInr + 1)
)
_indexName =
(
"I_" ++ _curTypeName
)
_dataIndex =
(
Code.Data _indexName _params [DataAlt _indexName []] False []
)
_indexExpr =
(
TypeApp (SimpleType _indexName ) (map (SimpleType . ('@':)) _params )
)
_indexStr =
(
"(" ++ _indexName ++ concatMap (\p -> " " ++ p) _params ++ ")"
)
_inhInstance =
(
Code.Data "instance Inh" [_indexStr ] [DataAlt (typeName _lhsInt _lhsInr ++ "_Inh") [_inhTup ] ] False []
)
_synInstance =
(
Code.Data "instance Syn" [_indexStr ] [DataAlt (typeName _lhsInt _lhsInr ++ "_Syn") [_synTps ] ] False []
)
_continuation =
(
if _lhsIisLast
then []
else [TypeApp (SimpleType _nextTypeName ) (map (SimpleType . ('@':)) _params )]
)
_params =
(
map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap
)
_lhsOsemDom =
(
let name = typeName _lhsInt _lhsInr
evalTp | null _params = id
| otherwise = idEvalType
in ( if _lhsIo_newtypes
then [ Code.NewType name _params name (evalTp _tp ) ]
else [ Code.Type name _params (evalTp _tp ) ] )
++ ( if _altSemForm
then [_dataIndex , _inhInstance , _synInstance ]
else [] )
)
_lhsOsemDomUnfoldGath =
(
Map.singleton (_lhsInt, _lhsInr) (_params , _tp )
)
_lhsOwrapDecls =
(
let lhsVars = map (lhsname False) (Map.keys syn_)
++ if _lhsIisLast then [] else [unwrap ++ sem (_lhsInr+1)]
rhsVars = map (lhsname True) (Map.keys inh_)
rhs = map SimpleExpr rhsVars
unwrap = if _lhsIo_newtypes then typeName _lhsInt (_lhsInr + 1) ++ " " else ""
var = "sem"
sem 0 = var
sem n = var ++ "_" ++ show n
ntt = typeName _lhsInt _lhsInr
in [ EvalDecl ntt (mkTupleLhs _lhsIo_unbox (null $ Map.keys inh_) lhsVars) (InvokeExpr ntt (SimpleExpr $ sem _lhsInr) rhs) ]
)
_lhsOcomments =
(
let body = map ind (showsSegment (CSegment inh_ syn_))
in if null body
then []
else ("visit " ++ show _lhsInr ++ ":") : body
)
___node =
(Syn_CSegment _lhsOcomments _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls)
in ( _lhsOcomments,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls))))
sem_CSegments :: CSegments ->
T_CSegments
sem_CSegments list =
(Prelude.foldr sem_CSegments_Cons sem_CSegments_Nil (Prelude.map sem_CSegment list))
newtype T_CSegments = T_CSegments (Attributes ->
Int ->
NontermIdent ->
Bool ->
Bool ->
Bool ->
(Maybe Bool) ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Options ->
ParamMap ->
String ->
Attributes ->
( ([String]),Bool,([Decl]),(Map (NontermIdent, Int) ([String], Code.Type)),Decls))
data Inh_CSegments = Inh_CSegments {inh_Inh_CSegments :: !(Attributes),nr_Inh_CSegments :: !(Int),nt_Inh_CSegments :: !(NontermIdent),o_case_Inh_CSegments :: !(Bool),o_cata_Inh_CSegments :: !(Bool),o_costcentre_Inh_CSegments :: !(Bool),o_data_Inh_CSegments :: !((Maybe Bool)),o_linePragmas_Inh_CSegments :: !(Bool),o_monadic_Inh_CSegments :: !(Bool),o_newtypes_Inh_CSegments :: !(Bool),o_pretty_Inh_CSegments :: !(Bool),o_rename_Inh_CSegments :: !(Bool),o_sem_Inh_CSegments :: !(Bool),o_sig_Inh_CSegments :: !(Bool),o_splitsems_Inh_CSegments :: !(Bool),o_strictwrap_Inh_CSegments :: !(Bool),o_traces_Inh_CSegments :: !(Bool),o_unbox_Inh_CSegments :: !(Bool),options_Inh_CSegments :: !(Options),paramMap_Inh_CSegments :: !(ParamMap),prefix_Inh_CSegments :: !(String),syn_Inh_CSegments :: !(Attributes)}
data Syn_CSegments = Syn_CSegments {comments_Syn_CSegments :: !(([String])),isNil_Syn_CSegments :: !(Bool),semDom_Syn_CSegments :: !(([Decl])),semDomUnfoldGath_Syn_CSegments :: !((Map (NontermIdent, Int) ([String], Code.Type))),wrapDecls_Syn_CSegments :: !(Decls)}
wrap_CSegments :: T_CSegments ->
Inh_CSegments ->
Syn_CSegments
wrap_CSegments (T_CSegments sem) (Inh_CSegments _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn) =
(let ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls) = sem _lhsIinh _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamMap _lhsIprefix _lhsIsyn
in (Syn_CSegments _lhsOcomments _lhsOisNil _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls))
sem_CSegments_Cons :: T_CSegment ->
T_CSegments ->
T_CSegments
sem_CSegments_Cons (T_CSegment hd_) (T_CSegments tl_) =
(T_CSegments (\ _lhsIinh
_lhsInr
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamMap
_lhsIprefix
_lhsIsyn ->
(let _tlOnr :: Int
_lhsOisNil :: Bool
_hdOisLast :: Bool
_lhsOcomments :: ([String])
_lhsOsemDom :: ([Decl])
_lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_lhsOwrapDecls :: Decls
_hdOinh :: Attributes
_hdOnr :: Int
_hdOnt :: NontermIdent
_hdOo_case :: Bool
_hdOo_cata :: Bool
_hdOo_costcentre :: Bool
_hdOo_data :: (Maybe Bool)
_hdOo_linePragmas :: Bool
_hdOo_monadic :: Bool
_hdOo_newtypes :: Bool
_hdOo_pretty :: Bool
_hdOo_rename :: Bool
_hdOo_sem :: Bool
_hdOo_sig :: Bool
_hdOo_splitsems :: Bool
_hdOo_strictwrap :: Bool
_hdOo_traces :: Bool
_hdOo_unbox :: Bool
_hdOoptions :: Options
_hdOparamMap :: ParamMap
_hdOprefix :: String
_hdOsyn :: Attributes
_tlOinh :: Attributes
_tlOnt :: NontermIdent
_tlOo_case :: Bool
_tlOo_cata :: Bool
_tlOo_costcentre :: Bool
_tlOo_data :: (Maybe Bool)
_tlOo_linePragmas :: Bool
_tlOo_monadic :: Bool
_tlOo_newtypes :: Bool
_tlOo_pretty :: Bool
_tlOo_rename :: Bool
_tlOo_sem :: Bool
_tlOo_sig :: Bool
_tlOo_splitsems :: Bool
_tlOo_strictwrap :: Bool
_tlOo_traces :: Bool
_tlOo_unbox :: Bool
_tlOoptions :: Options
_tlOparamMap :: ParamMap
_tlOprefix :: String
_tlOsyn :: Attributes
_hdIcomments :: ([String])
_hdIsemDom :: ([Decl])
_hdIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_hdIwrapDecls :: Decls
_tlIcomments :: ([String])
_tlIisNil :: Bool
_tlIsemDom :: ([Decl])
_tlIsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_tlIwrapDecls :: Decls
_tlOnr =
(
_lhsInr + 1
)
_lhsOisNil =
(
False
)
_hdOisLast =
(
_tlIisNil
)
_lhsOcomments =
(
_hdIcomments ++ _tlIcomments
)
_lhsOsemDom =
(
_hdIsemDom ++ _tlIsemDom
)
_lhsOsemDomUnfoldGath =
(
_hdIsemDomUnfoldGath `Map.union` _tlIsemDomUnfoldGath
)
_lhsOwrapDecls =
(
_hdIwrapDecls ++ _tlIwrapDecls
)
_hdOinh =
(
_lhsIinh
)
_hdOnr =
(
_lhsInr
)
_hdOnt =
(
_lhsInt
)
_hdOo_case =
(
_lhsIo_case
)
_hdOo_cata =
(
_lhsIo_cata
)
_hdOo_costcentre =
(
_lhsIo_costcentre
)
_hdOo_data =
(
_lhsIo_data
)
_hdOo_linePragmas =
(
_lhsIo_linePragmas
)
_hdOo_monadic =
(
_lhsIo_monadic
)
_hdOo_newtypes =
(
_lhsIo_newtypes
)
_hdOo_pretty =
(
_lhsIo_pretty
)
_hdOo_rename =
(
_lhsIo_rename
)
_hdOo_sem =
(
_lhsIo_sem
)
_hdOo_sig =
(
_lhsIo_sig
)
_hdOo_splitsems =
(
_lhsIo_splitsems
)
_hdOo_strictwrap =
(
_lhsIo_strictwrap
)
_hdOo_traces =
(
_lhsIo_traces
)
_hdOo_unbox =
(
_lhsIo_unbox
)
_hdOoptions =
(
_lhsIoptions
)
_hdOparamMap =
(
_lhsIparamMap
)
_hdOprefix =
(
_lhsIprefix
)
_hdOsyn =
(
_lhsIsyn
)
_tlOinh =
(
_lhsIinh
)
_tlOnt =
(
_lhsInt
)
_tlOo_case =
(
_lhsIo_case
)
_tlOo_cata =
(
_lhsIo_cata
)
_tlOo_costcentre =
(
_lhsIo_costcentre
)
_tlOo_data =
(
_lhsIo_data
)
_tlOo_linePragmas =
(
_lhsIo_linePragmas
)
_tlOo_monadic =
(
_lhsIo_monadic
)
_tlOo_newtypes =
(
_lhsIo_newtypes
)
_tlOo_pretty =
(
_lhsIo_pretty
)
_tlOo_rename =
(
_lhsIo_rename
)
_tlOo_sem =
(
_lhsIo_sem
)
_tlOo_sig =
(
_lhsIo_sig
)
_tlOo_splitsems =
(
_lhsIo_splitsems
)
_tlOo_strictwrap =
(
_lhsIo_strictwrap
)
_tlOo_traces =
(
_lhsIo_traces
)
_tlOo_unbox =
(
_lhsIo_unbox
)
_tlOoptions =
(
_lhsIoptions
)
_tlOparamMap =
(
_lhsIparamMap
)
_tlOprefix =
(
_lhsIprefix
)
_tlOsyn =
(
_lhsIsyn
)
( _hdIcomments,_hdIsemDom,_hdIsemDomUnfoldGath,_hdIwrapDecls) =
hd_ _hdOinh _hdOisLast _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_monadic _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOoptions _hdOparamMap _hdOprefix _hdOsyn
( _tlIcomments,_tlIisNil,_tlIsemDom,_tlIsemDomUnfoldGath,_tlIwrapDecls) =
tl_ _tlOinh _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_monadic _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOoptions _tlOparamMap _tlOprefix _tlOsyn
___node =
(Syn_CSegments _lhsOcomments _lhsOisNil _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls)
in ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls))))
sem_CSegments_Nil :: T_CSegments
sem_CSegments_Nil =
(T_CSegments (\ _lhsIinh
_lhsInr
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamMap
_lhsIprefix
_lhsIsyn ->
(let _lhsOisNil :: Bool
_lhsOcomments :: ([String])
_lhsOsemDom :: ([Decl])
_lhsOsemDomUnfoldGath :: (Map (NontermIdent, Int) ([String], Code.Type))
_lhsOwrapDecls :: Decls
_lhsOisNil =
(
True
)
_lhsOcomments =
(
[]
)
_lhsOsemDom =
(
[]
)
_lhsOsemDomUnfoldGath =
(
Map.empty
)
_lhsOwrapDecls =
(
[]
)
___node =
(Syn_CSegments _lhsOcomments _lhsOisNil _lhsOsemDom _lhsOsemDomUnfoldGath _lhsOwrapDecls)
in ( _lhsOcomments,_lhsOisNil,_lhsOsemDom,_lhsOsemDomUnfoldGath,_lhsOwrapDecls))))
sem_CVisit :: CVisit ->
T_CVisit
sem_CVisit (CVisit _inh _syn _vss _intra _ordered) =
(sem_CVisit_CVisit _inh _syn (sem_Sequence _vss) (sem_Sequence _intra) _ordered)
newtype T_CVisit = T_CVisit ((Set NontermIdent) ->
PragmaMap ->
(Set Identifier) ->
([(Identifier,Type, ChildKind)]) ->
ConstructorIdent ->
ContextMap ->
Decls ->
Attributes ->
(Map Identifier Int) ->
Bool ->
(Map Identifier (Identifier, [Identifier])) ->
Exprs ->
(Set String) ->
Int ->
NontermIdent ->
Bool ->
Bool ->
Bool ->
(Maybe Bool) ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Options ->
(Map Identifier (NontermIdent, [String])) ->
ParamMap ->
String ->
QuantMap ->
Attributes ->
([Identifier]) ->
(NontermIdent -> Int -> [String] -> Code.Type) ->
(Set Identifier) ->
Bool ->
(Set NontermIdent) ->
( ([String]),Decls,(Map Identifier Int),Exprs,(Set String),([String]),(Set Identifier)))
data Inh_CVisit = Inh_CVisit {allNts_Inh_CVisit :: !((Set NontermIdent)),allPragmas_Inh_CVisit :: !(PragmaMap),aroundMap_Inh_CVisit :: !((Set Identifier)),children_Inh_CVisit :: !(([(Identifier,Type, ChildKind)])),con_Inh_CVisit :: !(ConstructorIdent),contextMap_Inh_CVisit :: !(ContextMap),decls_Inh_CVisit :: !(Decls),inh_Inh_CVisit :: !(Attributes),instVisitNrs_Inh_CVisit :: !((Map Identifier Int)),isLast_Inh_CVisit :: !(Bool),mergeMap_Inh_CVisit :: !((Map Identifier (Identifier, [Identifier]))),nextIntra_Inh_CVisit :: !(Exprs),nextIntraVars_Inh_CVisit :: !((Set String)),nr_Inh_CVisit :: !(Int),nt_Inh_CVisit :: !(NontermIdent),o_case_Inh_CVisit :: !(Bool),o_cata_Inh_CVisit :: !(Bool),o_costcentre_Inh_CVisit :: !(Bool),o_data_Inh_CVisit :: !((Maybe Bool)),o_linePragmas_Inh_CVisit :: !(Bool),o_monadic_Inh_CVisit :: !(Bool),o_newtypes_Inh_CVisit :: !(Bool),o_pretty_Inh_CVisit :: !(Bool),o_rename_Inh_CVisit :: !(Bool),o_sem_Inh_CVisit :: !(Bool),o_sig_Inh_CVisit :: !(Bool),o_splitsems_Inh_CVisit :: !(Bool),o_strictwrap_Inh_CVisit :: !(Bool),o_traces_Inh_CVisit :: !(Bool),o_unbox_Inh_CVisit :: !(Bool),options_Inh_CVisit :: !(Options),paramInstMap_Inh_CVisit :: !((Map Identifier (NontermIdent, [String]))),paramMap_Inh_CVisit :: !(ParamMap),prefix_Inh_CVisit :: !(String),quantMap_Inh_CVisit :: !(QuantMap),syn_Inh_CVisit :: !(Attributes),terminals_Inh_CVisit :: !(([Identifier])),unfoldSemDom_Inh_CVisit :: !((NontermIdent -> Int -> [String] -> Code.Type)),visitedSet_Inh_CVisit :: !((Set Identifier)),with_sig_Inh_CVisit :: !(Bool),wrappers_Inh_CVisit :: !((Set NontermIdent))}
data Syn_CVisit = Syn_CVisit {comments_Syn_CVisit :: !(([String])),decls_Syn_CVisit :: !(Decls),gatherInstVisitNrs_Syn_CVisit :: !((Map Identifier Int)),intra_Syn_CVisit :: !(Exprs),intraVars_Syn_CVisit :: !((Set String)),semNames_Syn_CVisit :: !(([String])),visitedSet_Syn_CVisit :: !((Set Identifier))}
wrap_CVisit :: T_CVisit ->
Inh_CVisit ->
Syn_CVisit
wrap_CVisit (T_CVisit sem) (Inh_CVisit _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIdecls _lhsIinh _lhsIinstVisitNrs _lhsIisLast _lhsImergeMap _lhsInextIntra _lhsInextIntraVars _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwith_sig _lhsIwrappers) =
(let ( _lhsOcomments,_lhsOdecls,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOsemNames,_lhsOvisitedSet) = sem _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIdecls _lhsIinh _lhsIinstVisitNrs _lhsIisLast _lhsImergeMap _lhsInextIntra _lhsInextIntraVars _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwith_sig _lhsIwrappers
in (Syn_CVisit _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOsemNames _lhsOvisitedSet))
sem_CVisit_CVisit :: Attributes ->
Attributes ->
T_Sequence ->
T_Sequence ->
Bool ->
T_CVisit
sem_CVisit_CVisit inh_ syn_ (T_Sequence vss_) (T_Sequence intra_) ordered_ =
(T_CVisit (\ _lhsIallNts
_lhsIallPragmas
_lhsIaroundMap
_lhsIchildren
_lhsIcon
_lhsIcontextMap
_lhsIdecls
_lhsIinh
_lhsIinstVisitNrs
_lhsIisLast
_lhsImergeMap
_lhsInextIntra
_lhsInextIntraVars
_lhsInr
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamInstMap
_lhsIparamMap
_lhsIprefix
_lhsIquantMap
_lhsIsyn
_lhsIterminals
_lhsIunfoldSemDom
_lhsIvisitedSet
_lhsIwith_sig
_lhsIwrappers ->
(let _lhsOintra :: Exprs
_lhsOintraVars :: (Set String)
_vssOlastExpr :: Expr
_intraOlastExpr :: Expr
_lhsOdecls :: Decls
_lhsOgatherInstVisitNrs :: (Map Identifier Int)
_vssOdeclsAbove :: ([Decl])
_intraOdeclsAbove :: ([Decl])
_lhsOcomments :: ([String])
_vssOwhat :: String
_intraOwhat :: String
_lhsOsemNames :: ([String])
_lhsOvisitedSet :: (Set Identifier)
_vssOallNts :: (Set NontermIdent)
_vssOaroundMap :: (Set Identifier)
_vssOchildren :: ([(Identifier,Type,ChildKind)])
_vssOcon :: ConstructorIdent
_vssOinh :: Attributes
_vssOinstVisitNrs :: (Map Identifier Int)
_vssOmergeMap :: (Map Identifier (Identifier, [Identifier]))
_vssOnr :: Int
_vssOnt :: NontermIdent
_vssOo_case :: Bool
_vssOo_cata :: Bool
_vssOo_costcentre :: Bool
_vssOo_data :: (Maybe Bool)
_vssOo_linePragmas :: Bool
_vssOo_monadic :: Bool
_vssOo_newtypes :: Bool
_vssOo_pretty :: Bool
_vssOo_rename :: Bool
_vssOo_sem :: Bool
_vssOo_sig :: Bool
_vssOo_splitsems :: Bool
_vssOo_strictwrap :: Bool
_vssOo_traces :: Bool
_vssOo_unbox :: Bool
_vssOoptions :: Options
_vssOparamInstMap :: (Map Identifier (NontermIdent, [String]))
_vssOparamMap :: ParamMap
_vssOprefix :: String
_vssOsyn :: Attributes
_vssOterminals :: ([Identifier])
_vssOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_vssOvisitedSet :: (Set Identifier)
_intraOallNts :: (Set NontermIdent)
_intraOaroundMap :: (Set Identifier)
_intraOchildren :: ([(Identifier,Type,ChildKind)])
_intraOcon :: ConstructorIdent
_intraOinh :: Attributes
_intraOinstVisitNrs :: (Map Identifier Int)
_intraOmergeMap :: (Map Identifier (Identifier, [Identifier]))
_intraOnr :: Int
_intraOnt :: NontermIdent
_intraOo_case :: Bool
_intraOo_cata :: Bool
_intraOo_costcentre :: Bool
_intraOo_data :: (Maybe Bool)
_intraOo_linePragmas :: Bool
_intraOo_monadic :: Bool
_intraOo_newtypes :: Bool
_intraOo_pretty :: Bool
_intraOo_rename :: Bool
_intraOo_sem :: Bool
_intraOo_sig :: Bool
_intraOo_splitsems :: Bool
_intraOo_strictwrap :: Bool
_intraOo_traces :: Bool
_intraOo_unbox :: Bool
_intraOoptions :: Options
_intraOparamInstMap :: (Map Identifier (NontermIdent, [String]))
_intraOparamMap :: ParamMap
_intraOprefix :: String
_intraOsyn :: Attributes
_intraOterminals :: ([Identifier])
_intraOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_intraOvisitedSet :: (Set Identifier)
_vssIallTpsFound :: Bool
_vssIblockDecls :: DeclBlocks
_vssIcomments :: ([String])
_vssIdecls :: Decls
_vssIdeclsAbove :: ([Decl])
_vssIdefinedInsts :: ([Identifier])
_vssIexprs :: Exprs
_vssItSigs :: ([Decl])
_vssItps :: ([Type])
_vssIusedVars :: (Set String)
_vssIvisitedSet :: (Set Identifier)
_intraIallTpsFound :: Bool
_intraIblockDecls :: DeclBlocks
_intraIcomments :: ([String])
_intraIdecls :: Decls
_intraIdeclsAbove :: ([Decl])
_intraIdefinedInsts :: ([Identifier])
_intraIexprs :: Exprs
_intraItSigs :: ([Decl])
_intraItps :: ([Type])
_intraIusedVars :: (Set String)
_intraIvisitedSet :: (Set Identifier)
_lhsOintra =
(
_intraIexprs
)
_lhsOintraVars =
(
_intraIusedVars
)
(_higherOrderChildren,_firstOrderChildren) =
(
partition (\(_,_,virt) -> isHigherOrder virt) _lhsIchildren
)
_firstOrderOrig =
(
map pickOrigType _firstOrderChildren
)
_funcname =
(
seqSemname _lhsIprefix _lhsInt _lhsIcon _lhsInr
)
_nextVisitName =
(
if _lhsIisLast then [] else [visitname _lhsIprefix _lhsInt (_lhsInr+1)]
)
_nextVisitDecl =
(
let lhs = TupleLhs _nextVisitName
rhs = Let _lhsIdecls (SimpleExpr fun)
fun = seqSemname _lhsIprefix _lhsInt _lhsIcon (_lhsInr+1)
in if _lhsIisLast
then []
else [Decl lhs rhs (Set.fromList _nextVisitName) _lhsInextIntraVars]
)
_isOneVisit =
(
_lhsIisLast && _lhsInr == 0
)
_hasWrappers =
(
_lhsInt `Set.member` _lhsIwrappers
)
_refDecls =
(
if _isOneVisit && _hasWrappers && reference _lhsIoptions
then let synAttrs = Map.toList syn_
synNT = "Syn" ++ "_" ++ getName _lhsInt
synVars = [ SimpleExpr (attrname False _LHS a) | (a,_) <- synAttrs ]
rhs = App synNT synVars
lhs = Fun "___node" []
in [Decl lhs rhs Set.empty Set.empty]
else []
)
_decls =
(
_typeSigs ++ _vssIdecls ++ _nextVisitDecl ++ _refDecls
)
_vssOlastExpr =
(
mkTupleExpr _lhsIo_unbox (null $ Map.keys inh_) $ map (SimpleExpr . lhsname False) (Map.keys syn_) ++ map SimpleExpr _nextVisitName
)
_intraOlastExpr =
(
error "lastExpr: not used here"
)
_lastExprVars =
(
map (lhsname False) (Map.keys syn_) ++ _nextVisitName
)
(_blockFunDecls,_blockFirstFunCall) =
(
mkPartitionedFunction _funcname _o_case _nextVisitDecl _lastExprVars _vssIblockDecls
)
_costCentreDescr =
(
"b" ++ ":" ++ show _lhsInt ++ ":" ++ show _lhsIcon ++ ":" ++ show _lhsInr
)
_addCostCentre =
(
\v -> if _lhsIo_costcentre
then PragmaExpr True False ("SCC \"" ++ _costCentreDescr ++ "\"") v
else v
)
_params =
(
map getName $ Map.findWithDefault [] _lhsInt _lhsIparamMap
)
_semFun =
(
let lhs = Fun _funcname lhs_args
lhs_args = if _lhsInr == 0 then map field _firstOrderOrig else []
field (name,NT tp tps _,_) = let unwrap | _lhsIo_newtypes = \x -> App (sdtype tp) [x]
| otherwise = id
addType expr | null tps = expr
| otherwise = TypedExpr expr (_lhsIunfoldSemDom tp 0 tps)
in unwrap $ addType $ SimpleExpr $ funname name 0
field (name,tp,_) = let expr = SimpleExpr (funname name 0)
in if null _params
then expr
else TypedExpr expr (idEvalType $ typeToCodeType (Just _lhsInt) _params $ removeDeforested tp)
mbEvalTp | null _params = const Nothing
| otherwise = Just . idEvalType
rhs = wrap
. mkSemFun _lhsInt _lhsInr [mkLambdaArg (lhsname True nm) (mbEvalTp $ typeToCodeType (Just _lhsInt) _params $ removeDeforested tp) | (nm,tp) <- Map.assocs inh_]
$ _addCostCentre
$ if ordered_ && _o_splitsems
then _blockFirstFunCall
else mkDecls _declsType _decls
. ResultExpr (typeName _lhsInt _lhsInr)
. mkTupleExpr _lhsIo_unbox (null $ Map.keys inh_)
$ map (SimpleExpr . lhsname False) (Map.keys syn_) ++ map SimpleExpr _nextVisitName
wrap = if _lhsIo_newtypes
then \x -> App (typeName _lhsInt _lhsInr) [x]
else id
in Decl lhs rhs Set.empty Set.empty
)
_tsig =
(
TSig _funcname _semType
)
_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
evalTp | null _params = id
| otherwise = idEvalType
in appQuant _lhsIquantMap _lhsInt $ appContext _lhsIcontextMap _lhsInt $ evalTp $
if _lhsInr == 0
then foldr argType (typeAppStrs (sdtype _lhsInt ) _params ) (map (\(_,t,_) -> t) _firstOrderOrig )
else foldr argType (typeAppStrs (typeName _lhsInt _lhsInr) _params ) []
)
_lhsOdecls =
(
( if _lhsIwith_sig
then [_tsig, _semFun]
else [_semFun]
) ++
( if ordered_ && _o_splitsems
then _blockFunDecls
else []
)
)
_typeSigs =
(
if _lhsIo_sig && not _o_case
then _vssItSigs
else []
)
_o_do =
(
ordered_ && _lhsIo_monadic
)
_o_case =
(
not _o_do && _lhsIo_case && ordered_ && not (hasPragma _lhsIallPragmas _lhsInt _lhsIcon _NOCASE)
)
_declsType =
(
if _o_do
then DeclsDo
else if _o_case
then DeclsCase
else DeclsLet
)
_o_splitsems =
(
ordered_ && _lhsIo_splitsems
)
_lhsOgatherInstVisitNrs =
(
Map.fromList [(i,_lhsInr) | i <- _vssIdefinedInsts]
)
_vssOdeclsAbove =
(
[]
)
_intraOdeclsAbove =
(
error "declsAbove: not used here"
)
_lhsOcomments =
(
let body = map ind (_vssIcomments ++ _intraIcomments)
in if null body
then []
else ("visit " ++ show _lhsInr ++ ":") : body
)
_vssOwhat =
(
"local"
)
_intraOwhat =
(
"intra"
)
_lhsOsemNames =
(
[_funcname ]
)
_lhsOvisitedSet =
(
_intraIvisitedSet
)
_vssOallNts =
(
_lhsIallNts
)
_vssOaroundMap =
(
_lhsIaroundMap
)
_vssOchildren =
(
_lhsIchildren
)
_vssOcon =
(
_lhsIcon
)
_vssOinh =
(
_lhsIinh
)
_vssOinstVisitNrs =
(
_lhsIinstVisitNrs
)
_vssOmergeMap =
(
_lhsImergeMap
)
_vssOnr =
(
_lhsInr
)
_vssOnt =
(
_lhsInt
)
_vssOo_case =
(
_o_case
)
_vssOo_cata =
(
_lhsIo_cata
)
_vssOo_costcentre =
(
_lhsIo_costcentre
)
_vssOo_data =
(
_lhsIo_data
)
_vssOo_linePragmas =
(
_lhsIo_linePragmas
)
_vssOo_monadic =
(
_lhsIo_monadic
)
_vssOo_newtypes =
(
_lhsIo_newtypes
)
_vssOo_pretty =
(
_lhsIo_pretty
)
_vssOo_rename =
(
_lhsIo_rename
)
_vssOo_sem =
(
_lhsIo_sem
)
_vssOo_sig =
(
_lhsIo_sig
)
_vssOo_splitsems =
(
_o_splitsems
)
_vssOo_strictwrap =
(
_lhsIo_strictwrap
)
_vssOo_traces =
(
_lhsIo_traces
)
_vssOo_unbox =
(
_lhsIo_unbox
)
_vssOoptions =
(
_lhsIoptions
)
_vssOparamInstMap =
(
_lhsIparamInstMap
)
_vssOparamMap =
(
_lhsIparamMap
)
_vssOprefix =
(
_lhsIprefix
)
_vssOsyn =
(
_lhsIsyn
)
_vssOterminals =
(
_lhsIterminals
)
_vssOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_vssOvisitedSet =
(
_lhsIvisitedSet
)
_intraOallNts =
(
_lhsIallNts
)
_intraOaroundMap =
(
_lhsIaroundMap
)
_intraOchildren =
(
_lhsIchildren
)
_intraOcon =
(
_lhsIcon
)
_intraOinh =
(
_lhsIinh
)
_intraOinstVisitNrs =
(
_lhsIinstVisitNrs
)
_intraOmergeMap =
(
_lhsImergeMap
)
_intraOnr =
(
_lhsInr
)
_intraOnt =
(
_lhsInt
)
_intraOo_case =
(
_o_case
)
_intraOo_cata =
(
_lhsIo_cata
)
_intraOo_costcentre =
(
_lhsIo_costcentre
)
_intraOo_data =
(
_lhsIo_data
)
_intraOo_linePragmas =
(
_lhsIo_linePragmas
)
_intraOo_monadic =
(
_lhsIo_monadic
)
_intraOo_newtypes =
(
_lhsIo_newtypes
)
_intraOo_pretty =
(
_lhsIo_pretty
)
_intraOo_rename =
(
_lhsIo_rename
)
_intraOo_sem =
(
_lhsIo_sem
)
_intraOo_sig =
(
_lhsIo_sig
)
_intraOo_splitsems =
(
_o_splitsems
)
_intraOo_strictwrap =
(
_lhsIo_strictwrap
)
_intraOo_traces =
(
_lhsIo_traces
)
_intraOo_unbox =
(
_lhsIo_unbox
)
_intraOoptions =
(
_lhsIoptions
)
_intraOparamInstMap =
(
_lhsIparamInstMap
)
_intraOparamMap =
(
_lhsIparamMap
)
_intraOprefix =
(
_lhsIprefix
)
_intraOsyn =
(
_lhsIsyn
)
_intraOterminals =
(
_lhsIterminals
)
_intraOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_intraOvisitedSet =
(
_vssIvisitedSet
)
( _vssIallTpsFound,_vssIblockDecls,_vssIcomments,_vssIdecls,_vssIdeclsAbove,_vssIdefinedInsts,_vssIexprs,_vssItSigs,_vssItps,_vssIusedVars,_vssIvisitedSet) =
vss_ _vssOallNts _vssOaroundMap _vssOchildren _vssOcon _vssOdeclsAbove _vssOinh _vssOinstVisitNrs _vssOlastExpr _vssOmergeMap _vssOnr _vssOnt _vssOo_case _vssOo_cata _vssOo_costcentre _vssOo_data _vssOo_linePragmas _vssOo_monadic _vssOo_newtypes _vssOo_pretty _vssOo_rename _vssOo_sem _vssOo_sig _vssOo_splitsems _vssOo_strictwrap _vssOo_traces _vssOo_unbox _vssOoptions _vssOparamInstMap _vssOparamMap _vssOprefix _vssOsyn _vssOterminals _vssOunfoldSemDom _vssOvisitedSet _vssOwhat
( _intraIallTpsFound,_intraIblockDecls,_intraIcomments,_intraIdecls,_intraIdeclsAbove,_intraIdefinedInsts,_intraIexprs,_intraItSigs,_intraItps,_intraIusedVars,_intraIvisitedSet) =
intra_ _intraOallNts _intraOaroundMap _intraOchildren _intraOcon _intraOdeclsAbove _intraOinh _intraOinstVisitNrs _intraOlastExpr _intraOmergeMap _intraOnr _intraOnt _intraOo_case _intraOo_cata _intraOo_costcentre _intraOo_data _intraOo_linePragmas _intraOo_monadic _intraOo_newtypes _intraOo_pretty _intraOo_rename _intraOo_sem _intraOo_sig _intraOo_splitsems _intraOo_strictwrap _intraOo_traces _intraOo_unbox _intraOoptions _intraOparamInstMap _intraOparamMap _intraOprefix _intraOsyn _intraOterminals _intraOunfoldSemDom _intraOvisitedSet _intraOwhat
___node =
(Syn_CVisit _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOsemNames _lhsOvisitedSet)
in ( _lhsOcomments,_lhsOdecls,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOsemNames,_lhsOvisitedSet))))
sem_CVisits :: CVisits ->
T_CVisits
sem_CVisits list =
(Prelude.foldr sem_CVisits_Cons sem_CVisits_Nil (Prelude.map sem_CVisit list))
newtype T_CVisits = T_CVisits ((Set NontermIdent) ->
PragmaMap ->
(Set Identifier) ->
([(Identifier,Type, ChildKind)]) ->
ConstructorIdent ->
ContextMap ->
Attributes ->
(Map Identifier Int) ->
(Map Identifier (Identifier, [Identifier])) ->
Int ->
NontermIdent ->
Bool ->
Bool ->
Bool ->
(Maybe Bool) ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Options ->
(Map Identifier (NontermIdent, [String])) ->
ParamMap ->
String ->
QuantMap ->
Attributes ->
([Identifier]) ->
(NontermIdent -> Int -> [String] -> Code.Type) ->
(Set Identifier) ->
Bool ->
(Set NontermIdent) ->
( ([String]),Decls,(Map Identifier Int),Exprs,(Set String),Bool,([String]),(Set Identifier)))
data Inh_CVisits = Inh_CVisits {allNts_Inh_CVisits :: !((Set NontermIdent)),allPragmas_Inh_CVisits :: !(PragmaMap),aroundMap_Inh_CVisits :: !((Set Identifier)),children_Inh_CVisits :: !(([(Identifier,Type, ChildKind)])),con_Inh_CVisits :: !(ConstructorIdent),contextMap_Inh_CVisits :: !(ContextMap),inh_Inh_CVisits :: !(Attributes),instVisitNrs_Inh_CVisits :: !((Map Identifier Int)),mergeMap_Inh_CVisits :: !((Map Identifier (Identifier, [Identifier]))),nr_Inh_CVisits :: !(Int),nt_Inh_CVisits :: !(NontermIdent),o_case_Inh_CVisits :: !(Bool),o_cata_Inh_CVisits :: !(Bool),o_costcentre_Inh_CVisits :: !(Bool),o_data_Inh_CVisits :: !((Maybe Bool)),o_linePragmas_Inh_CVisits :: !(Bool),o_monadic_Inh_CVisits :: !(Bool),o_newtypes_Inh_CVisits :: !(Bool),o_pretty_Inh_CVisits :: !(Bool),o_rename_Inh_CVisits :: !(Bool),o_sem_Inh_CVisits :: !(Bool),o_sig_Inh_CVisits :: !(Bool),o_splitsems_Inh_CVisits :: !(Bool),o_strictwrap_Inh_CVisits :: !(Bool),o_traces_Inh_CVisits :: !(Bool),o_unbox_Inh_CVisits :: !(Bool),options_Inh_CVisits :: !(Options),paramInstMap_Inh_CVisits :: !((Map Identifier (NontermIdent, [String]))),paramMap_Inh_CVisits :: !(ParamMap),prefix_Inh_CVisits :: !(String),quantMap_Inh_CVisits :: !(QuantMap),syn_Inh_CVisits :: !(Attributes),terminals_Inh_CVisits :: !(([Identifier])),unfoldSemDom_Inh_CVisits :: !((NontermIdent -> Int -> [String] -> Code.Type)),visitedSet_Inh_CVisits :: !((Set Identifier)),with_sig_Inh_CVisits :: !(Bool),wrappers_Inh_CVisits :: !((Set NontermIdent))}
data Syn_CVisits = Syn_CVisits {comments_Syn_CVisits :: !(([String])),decls_Syn_CVisits :: !(Decls),gatherInstVisitNrs_Syn_CVisits :: !((Map Identifier Int)),intra_Syn_CVisits :: !(Exprs),intraVars_Syn_CVisits :: !((Set String)),isNil_Syn_CVisits :: !(Bool),semNames_Syn_CVisits :: !(([String])),visitedSet_Syn_CVisits :: !((Set Identifier))}
wrap_CVisits :: T_CVisits ->
Inh_CVisits ->
Syn_CVisits
wrap_CVisits (T_CVisits sem) (Inh_CVisits _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwith_sig _lhsIwrappers) =
(let ( _lhsOcomments,_lhsOdecls,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames,_lhsOvisitedSet) = sem _lhsIallNts _lhsIallPragmas _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIcontextMap _lhsIinh _lhsIinstVisitNrs _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIquantMap _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwith_sig _lhsIwrappers
in (Syn_CVisits _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOisNil _lhsOsemNames _lhsOvisitedSet))
sem_CVisits_Cons :: T_CVisit ->
T_CVisits ->
T_CVisits
sem_CVisits_Cons (T_CVisit hd_) (T_CVisits tl_) =
(T_CVisits (\ _lhsIallNts
_lhsIallPragmas
_lhsIaroundMap
_lhsIchildren
_lhsIcon
_lhsIcontextMap
_lhsIinh
_lhsIinstVisitNrs
_lhsImergeMap
_lhsInr
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamInstMap
_lhsIparamMap
_lhsIprefix
_lhsIquantMap
_lhsIsyn
_lhsIterminals
_lhsIunfoldSemDom
_lhsIvisitedSet
_lhsIwith_sig
_lhsIwrappers ->
(let _tlOnr :: Int
_lhsOisNil :: Bool
_hdOisLast :: Bool
_hdOnextIntra :: Exprs
_hdOnextIntraVars :: (Set String)
_lhsOintra :: Exprs
_lhsOintraVars :: (Set String)
_lhsOdecls :: Decls
_hdOdecls :: Decls
_lhsOcomments :: ([String])
_lhsOgatherInstVisitNrs :: (Map Identifier Int)
_lhsOsemNames :: ([String])
_lhsOvisitedSet :: (Set Identifier)
_hdOallNts :: (Set NontermIdent)
_hdOallPragmas :: PragmaMap
_hdOaroundMap :: (Set Identifier)
_hdOchildren :: ([(Identifier,Type, ChildKind)])
_hdOcon :: ConstructorIdent
_hdOcontextMap :: ContextMap
_hdOinh :: Attributes
_hdOinstVisitNrs :: (Map Identifier Int)
_hdOmergeMap :: (Map Identifier (Identifier, [Identifier]))
_hdOnr :: Int
_hdOnt :: NontermIdent
_hdOo_case :: Bool
_hdOo_cata :: Bool
_hdOo_costcentre :: Bool
_hdOo_data :: (Maybe Bool)
_hdOo_linePragmas :: Bool
_hdOo_monadic :: Bool
_hdOo_newtypes :: Bool
_hdOo_pretty :: Bool
_hdOo_rename :: Bool
_hdOo_sem :: Bool
_hdOo_sig :: Bool
_hdOo_splitsems :: Bool
_hdOo_strictwrap :: Bool
_hdOo_traces :: Bool
_hdOo_unbox :: Bool
_hdOoptions :: Options
_hdOparamInstMap :: (Map Identifier (NontermIdent, [String]))
_hdOparamMap :: ParamMap
_hdOprefix :: String
_hdOquantMap :: QuantMap
_hdOsyn :: Attributes
_hdOterminals :: ([Identifier])
_hdOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_hdOvisitedSet :: (Set Identifier)
_hdOwith_sig :: Bool
_hdOwrappers :: (Set NontermIdent)
_tlOallNts :: (Set NontermIdent)
_tlOallPragmas :: PragmaMap
_tlOaroundMap :: (Set Identifier)
_tlOchildren :: ([(Identifier,Type, ChildKind)])
_tlOcon :: ConstructorIdent
_tlOcontextMap :: ContextMap
_tlOinh :: Attributes
_tlOinstVisitNrs :: (Map Identifier Int)
_tlOmergeMap :: (Map Identifier (Identifier, [Identifier]))
_tlOnt :: NontermIdent
_tlOo_case :: Bool
_tlOo_cata :: Bool
_tlOo_costcentre :: Bool
_tlOo_data :: (Maybe Bool)
_tlOo_linePragmas :: Bool
_tlOo_monadic :: Bool
_tlOo_newtypes :: Bool
_tlOo_pretty :: Bool
_tlOo_rename :: Bool
_tlOo_sem :: Bool
_tlOo_sig :: Bool
_tlOo_splitsems :: Bool
_tlOo_strictwrap :: Bool
_tlOo_traces :: Bool
_tlOo_unbox :: Bool
_tlOoptions :: Options
_tlOparamInstMap :: (Map Identifier (NontermIdent, [String]))
_tlOparamMap :: ParamMap
_tlOprefix :: String
_tlOquantMap :: QuantMap
_tlOsyn :: Attributes
_tlOterminals :: ([Identifier])
_tlOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_tlOvisitedSet :: (Set Identifier)
_tlOwith_sig :: Bool
_tlOwrappers :: (Set NontermIdent)
_hdIcomments :: ([String])
_hdIdecls :: Decls
_hdIgatherInstVisitNrs :: (Map Identifier Int)
_hdIintra :: Exprs
_hdIintraVars :: (Set String)
_hdIsemNames :: ([String])
_hdIvisitedSet :: (Set Identifier)
_tlIcomments :: ([String])
_tlIdecls :: Decls
_tlIgatherInstVisitNrs :: (Map Identifier Int)
_tlIintra :: Exprs
_tlIintraVars :: (Set String)
_tlIisNil :: Bool
_tlIsemNames :: ([String])
_tlIvisitedSet :: (Set Identifier)
_tlOnr =
(
_lhsInr + 1
)
_lhsOisNil =
(
False
)
_hdOisLast =
(
_tlIisNil
)
_hdOnextIntra =
(
_tlIintra
)
_hdOnextIntraVars =
(
_tlIintraVars
)
_lhsOintra =
(
_hdIintra
)
_lhsOintraVars =
(
_hdIintraVars
)
_lhsOdecls =
(
_hdIdecls
)
_hdOdecls =
(
_tlIdecls
)
_lhsOcomments =
(
_hdIcomments ++ _tlIcomments
)
_lhsOgatherInstVisitNrs =
(
_hdIgatherInstVisitNrs `Map.union` _tlIgatherInstVisitNrs
)
_lhsOsemNames =
(
_hdIsemNames ++ _tlIsemNames
)
_lhsOvisitedSet =
(
_tlIvisitedSet
)
_hdOallNts =
(
_lhsIallNts
)
_hdOallPragmas =
(
_lhsIallPragmas
)
_hdOaroundMap =
(
_lhsIaroundMap
)
_hdOchildren =
(
_lhsIchildren
)
_hdOcon =
(
_lhsIcon
)
_hdOcontextMap =
(
_lhsIcontextMap
)
_hdOinh =
(
_lhsIinh
)
_hdOinstVisitNrs =
(
_lhsIinstVisitNrs
)
_hdOmergeMap =
(
_lhsImergeMap
)
_hdOnr =
(
_lhsInr
)
_hdOnt =
(
_lhsInt
)
_hdOo_case =
(
_lhsIo_case
)
_hdOo_cata =
(
_lhsIo_cata
)
_hdOo_costcentre =
(
_lhsIo_costcentre
)
_hdOo_data =
(
_lhsIo_data
)
_hdOo_linePragmas =
(
_lhsIo_linePragmas
)
_hdOo_monadic =
(
_lhsIo_monadic
)
_hdOo_newtypes =
(
_lhsIo_newtypes
)
_hdOo_pretty =
(
_lhsIo_pretty
)
_hdOo_rename =
(
_lhsIo_rename
)
_hdOo_sem =
(
_lhsIo_sem
)
_hdOo_sig =
(
_lhsIo_sig
)
_hdOo_splitsems =
(
_lhsIo_splitsems
)
_hdOo_strictwrap =
(
_lhsIo_strictwrap
)
_hdOo_traces =
(
_lhsIo_traces
)
_hdOo_unbox =
(
_lhsIo_unbox
)
_hdOoptions =
(
_lhsIoptions
)
_hdOparamInstMap =
(
_lhsIparamInstMap
)
_hdOparamMap =
(
_lhsIparamMap
)
_hdOprefix =
(
_lhsIprefix
)
_hdOquantMap =
(
_lhsIquantMap
)
_hdOsyn =
(
_lhsIsyn
)
_hdOterminals =
(
_lhsIterminals
)
_hdOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_hdOvisitedSet =
(
_lhsIvisitedSet
)
_hdOwith_sig =
(
_lhsIwith_sig
)
_hdOwrappers =
(
_lhsIwrappers
)
_tlOallNts =
(
_lhsIallNts
)
_tlOallPragmas =
(
_lhsIallPragmas
)
_tlOaroundMap =
(
_lhsIaroundMap
)
_tlOchildren =
(
_lhsIchildren
)
_tlOcon =
(
_lhsIcon
)
_tlOcontextMap =
(
_lhsIcontextMap
)
_tlOinh =
(
_lhsIinh
)
_tlOinstVisitNrs =
(
_lhsIinstVisitNrs
)
_tlOmergeMap =
(
_lhsImergeMap
)
_tlOnt =
(
_lhsInt
)
_tlOo_case =
(
_lhsIo_case
)
_tlOo_cata =
(
_lhsIo_cata
)
_tlOo_costcentre =
(
_lhsIo_costcentre
)
_tlOo_data =
(
_lhsIo_data
)
_tlOo_linePragmas =
(
_lhsIo_linePragmas
)
_tlOo_monadic =
(
_lhsIo_monadic
)
_tlOo_newtypes =
(
_lhsIo_newtypes
)
_tlOo_pretty =
(
_lhsIo_pretty
)
_tlOo_rename =
(
_lhsIo_rename
)
_tlOo_sem =
(
_lhsIo_sem
)
_tlOo_sig =
(
_lhsIo_sig
)
_tlOo_splitsems =
(
_lhsIo_splitsems
)
_tlOo_strictwrap =
(
_lhsIo_strictwrap
)
_tlOo_traces =
(
_lhsIo_traces
)
_tlOo_unbox =
(
_lhsIo_unbox
)
_tlOoptions =
(
_lhsIoptions
)
_tlOparamInstMap =
(
_lhsIparamInstMap
)
_tlOparamMap =
(
_lhsIparamMap
)
_tlOprefix =
(
_lhsIprefix
)
_tlOquantMap =
(
_lhsIquantMap
)
_tlOsyn =
(
_lhsIsyn
)
_tlOterminals =
(
_lhsIterminals
)
_tlOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_tlOvisitedSet =
(
_hdIvisitedSet
)
_tlOwith_sig =
(
_lhsIwith_sig
)
_tlOwrappers =
(
_lhsIwrappers
)
( _hdIcomments,_hdIdecls,_hdIgatherInstVisitNrs,_hdIintra,_hdIintraVars,_hdIsemNames,_hdIvisitedSet) =
hd_ _hdOallNts _hdOallPragmas _hdOaroundMap _hdOchildren _hdOcon _hdOcontextMap _hdOdecls _hdOinh _hdOinstVisitNrs _hdOisLast _hdOmergeMap _hdOnextIntra _hdOnextIntraVars _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_monadic _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOoptions _hdOparamInstMap _hdOparamMap _hdOprefix _hdOquantMap _hdOsyn _hdOterminals _hdOunfoldSemDom _hdOvisitedSet _hdOwith_sig _hdOwrappers
( _tlIcomments,_tlIdecls,_tlIgatherInstVisitNrs,_tlIintra,_tlIintraVars,_tlIisNil,_tlIsemNames,_tlIvisitedSet) =
tl_ _tlOallNts _tlOallPragmas _tlOaroundMap _tlOchildren _tlOcon _tlOcontextMap _tlOinh _tlOinstVisitNrs _tlOmergeMap _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_monadic _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOoptions _tlOparamInstMap _tlOparamMap _tlOprefix _tlOquantMap _tlOsyn _tlOterminals _tlOunfoldSemDom _tlOvisitedSet _tlOwith_sig _tlOwrappers
___node =
(Syn_CVisits _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOisNil _lhsOsemNames _lhsOvisitedSet)
in ( _lhsOcomments,_lhsOdecls,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames,_lhsOvisitedSet))))
sem_CVisits_Nil :: T_CVisits
sem_CVisits_Nil =
(T_CVisits (\ _lhsIallNts
_lhsIallPragmas
_lhsIaroundMap
_lhsIchildren
_lhsIcon
_lhsIcontextMap
_lhsIinh
_lhsIinstVisitNrs
_lhsImergeMap
_lhsInr
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamInstMap
_lhsIparamMap
_lhsIprefix
_lhsIquantMap
_lhsIsyn
_lhsIterminals
_lhsIunfoldSemDom
_lhsIvisitedSet
_lhsIwith_sig
_lhsIwrappers ->
(let _lhsOisNil :: Bool
_lhsOintra :: Exprs
_lhsOintraVars :: (Set String)
_lhsOdecls :: Decls
_lhsOcomments :: ([String])
_lhsOgatherInstVisitNrs :: (Map Identifier Int)
_lhsOsemNames :: ([String])
_lhsOvisitedSet :: (Set Identifier)
_lhsOisNil =
(
True
)
_lhsOintra =
(
[]
)
_lhsOintraVars =
(
Set.empty
)
_lhsOdecls =
(
[]
)
_lhsOcomments =
(
[]
)
_lhsOgatherInstVisitNrs =
(
Map.empty
)
_lhsOsemNames =
(
[]
)
_lhsOvisitedSet =
(
_lhsIvisitedSet
)
___node =
(Syn_CVisits _lhsOcomments _lhsOdecls _lhsOgatherInstVisitNrs _lhsOintra _lhsOintraVars _lhsOisNil _lhsOsemNames _lhsOvisitedSet)
in ( _lhsOcomments,_lhsOdecls,_lhsOgatherInstVisitNrs,_lhsOintra,_lhsOintraVars,_lhsOisNil,_lhsOsemNames,_lhsOvisitedSet))))
sem_DeclBlocks :: DeclBlocks ->
T_DeclBlocks
sem_DeclBlocks (DeclBlock _defs _visit _next) =
(sem_DeclBlocks_DeclBlock _defs _visit (sem_DeclBlocks _next))
sem_DeclBlocks (DeclTerminator _defs _result) =
(sem_DeclBlocks_DeclTerminator _defs _result)
newtype T_DeclBlocks = T_DeclBlocks (Int ->
([String]) ->
([Decl]) ->
Bool ->
String ->
( Expr,([Decl]),([String])))
data Inh_DeclBlocks = Inh_DeclBlocks {blockNr_Inh_DeclBlocks :: !(Int),lastExprVars_Inh_DeclBlocks :: !(([String])),nextVisitDecls_Inh_DeclBlocks :: !(([Decl])),optCase_Inh_DeclBlocks :: !(Bool),prefix_Inh_DeclBlocks :: !(String)}
data Syn_DeclBlocks = Syn_DeclBlocks {callExpr_Syn_DeclBlocks :: !(Expr),decls_Syn_DeclBlocks :: !(([Decl])),freeVars_Syn_DeclBlocks :: !(([String]))}
wrap_DeclBlocks :: T_DeclBlocks ->
Inh_DeclBlocks ->
Syn_DeclBlocks
wrap_DeclBlocks (T_DeclBlocks sem) (Inh_DeclBlocks _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix) =
(let ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars) = sem _lhsIblockNr _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix
in (Syn_DeclBlocks _lhsOcallExpr _lhsOdecls _lhsOfreeVars))
sem_DeclBlocks_DeclBlock :: ([Decl]) ->
Decl ->
T_DeclBlocks ->
T_DeclBlocks
sem_DeclBlocks_DeclBlock defs_ visit_ (T_DeclBlocks next_) =
(T_DeclBlocks (\ _lhsIblockNr
_lhsIlastExprVars
_lhsInextVisitDecls
_lhsIoptCase
_lhsIprefix ->
(let _nextOblockNr :: Int
_lhsOcallExpr :: Expr
_lhsOdecls :: ([Decl])
_lhsOfreeVars :: ([String])
_nextOlastExprVars :: ([String])
_nextOnextVisitDecls :: ([Decl])
_nextOoptCase :: Bool
_nextOprefix :: String
_nextIcallExpr :: Expr
_nextIdecls :: ([Decl])
_nextIfreeVars :: ([String])
_nextOblockNr =
(
_lhsIblockNr + 1
)
_lambdaName =
(
_lhsIprefix ++ "_block" ++ show _lhsIblockNr
)
_pragmaDecl =
(
PragmaDecl ("NOINLINE " ++ _lambdaName )
)
_lhsOcallExpr =
(
App _lambdaName (map SimpleExpr _freeVars )
)
_freeVars =
(
freevars _nextIfreeVars (visit_ : defs_)
)
_decl =
(
mkBlockLambda _lhsIoptCase _lambdaName _freeVars (defs_ ++ [visit_]) _nextIcallExpr
)
_lhsOdecls =
(
(if _lhsIblockNr > 1 then [_pragmaDecl ] else []) ++ [_decl ] ++ _nextIdecls
)
_lhsOfreeVars =
(
_freeVars
)
_nextOlastExprVars =
(
_lhsIlastExprVars
)
_nextOnextVisitDecls =
(
_lhsInextVisitDecls
)
_nextOoptCase =
(
_lhsIoptCase
)
_nextOprefix =
(
_lhsIprefix
)
( _nextIcallExpr,_nextIdecls,_nextIfreeVars) =
next_ _nextOblockNr _nextOlastExprVars _nextOnextVisitDecls _nextOoptCase _nextOprefix
___node =
(Syn_DeclBlocks _lhsOcallExpr _lhsOdecls _lhsOfreeVars)
in ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars))))
sem_DeclBlocks_DeclTerminator :: ([Decl]) ->
Expr ->
T_DeclBlocks
sem_DeclBlocks_DeclTerminator defs_ result_ =
(T_DeclBlocks (\ _lhsIblockNr
_lhsIlastExprVars
_lhsInextVisitDecls
_lhsIoptCase
_lhsIprefix ->
(let _lhsOcallExpr :: Expr
_lhsOdecls :: ([Decl])
_lhsOfreeVars :: ([String])
_lambdaName =
(
_lhsIprefix ++ "_block" ++ show _lhsIblockNr
)
_pragmaDecl =
(
PragmaDecl ("NOINLINE " ++ _lambdaName )
)
_lhsOcallExpr =
(
App _lambdaName (map SimpleExpr _freeVars )
)
_freeVars =
(
freevars _lhsIlastExprVars (defs_ ++ _lhsInextVisitDecls)
)
_lhsOdecls =
(
[ mkBlockLambda _lhsIoptCase _lambdaName _freeVars (defs_ ++ _lhsInextVisitDecls) result_ ]
)
_lhsOfreeVars =
(
_freeVars
)
___node =
(Syn_DeclBlocks _lhsOcallExpr _lhsOdecls _lhsOfreeVars)
in ( _lhsOcallExpr,_lhsOdecls,_lhsOfreeVars))))
sem_DeclBlocksRoot :: DeclBlocksRoot ->
T_DeclBlocksRoot
sem_DeclBlocksRoot (DeclBlocksRoot _blocks) =
(sem_DeclBlocksRoot_DeclBlocksRoot (sem_DeclBlocks _blocks))
newtype T_DeclBlocksRoot = T_DeclBlocksRoot (([String]) ->
([Decl]) ->
Bool ->
String ->
( Expr,([Decl])))
data Inh_DeclBlocksRoot = Inh_DeclBlocksRoot {lastExprVars_Inh_DeclBlocksRoot :: !(([String])),nextVisitDecls_Inh_DeclBlocksRoot :: !(([Decl])),optCase_Inh_DeclBlocksRoot :: !(Bool),prefix_Inh_DeclBlocksRoot :: !(String)}
data Syn_DeclBlocksRoot = Syn_DeclBlocksRoot {firstCall_Syn_DeclBlocksRoot :: !(Expr),lambdas_Syn_DeclBlocksRoot :: !(([Decl]))}
wrap_DeclBlocksRoot :: T_DeclBlocksRoot ->
Inh_DeclBlocksRoot ->
Syn_DeclBlocksRoot
wrap_DeclBlocksRoot (T_DeclBlocksRoot sem) (Inh_DeclBlocksRoot _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix) =
(let ( _lhsOfirstCall,_lhsOlambdas) = sem _lhsIlastExprVars _lhsInextVisitDecls _lhsIoptCase _lhsIprefix
in (Syn_DeclBlocksRoot _lhsOfirstCall _lhsOlambdas))
sem_DeclBlocksRoot_DeclBlocksRoot :: T_DeclBlocks ->
T_DeclBlocksRoot
sem_DeclBlocksRoot_DeclBlocksRoot (T_DeclBlocks blocks_) =
(T_DeclBlocksRoot (\ _lhsIlastExprVars
_lhsInextVisitDecls
_lhsIoptCase
_lhsIprefix ->
(let _lhsOlambdas :: ([Decl])
_lhsOfirstCall :: Expr
_blocksOblockNr :: Int
_blocksOlastExprVars :: ([String])
_blocksOnextVisitDecls :: ([Decl])
_blocksOoptCase :: Bool
_blocksOprefix :: String
_blocksIcallExpr :: Expr
_blocksIdecls :: ([Decl])
_blocksIfreeVars :: ([String])
_lhsOlambdas =
(
_blocksIdecls
)
_lhsOfirstCall =
(
_blocksIcallExpr
)
_blocksOblockNr =
(
1
)
_blocksOlastExprVars =
(
_lhsIlastExprVars
)
_blocksOnextVisitDecls =
(
_lhsInextVisitDecls
)
_blocksOoptCase =
(
_lhsIoptCase
)
_blocksOprefix =
(
_lhsIprefix
)
( _blocksIcallExpr,_blocksIdecls,_blocksIfreeVars) =
blocks_ _blocksOblockNr _blocksOlastExprVars _blocksOnextVisitDecls _blocksOoptCase _blocksOprefix
___node =
(Syn_DeclBlocksRoot _lhsOfirstCall _lhsOlambdas)
in ( _lhsOfirstCall,_lhsOlambdas))))
sem_Pattern :: Pattern ->
T_Pattern
sem_Pattern (Alias _field _attr _pat) =
(sem_Pattern_Alias _field _attr (sem_Pattern _pat))
sem_Pattern (Constr _name _pats) =
(sem_Pattern_Constr _name (sem_Patterns _pats))
sem_Pattern (Irrefutable _pat) =
(sem_Pattern_Irrefutable (sem_Pattern _pat))
sem_Pattern (Product _pos _pats) =
(sem_Pattern_Product _pos (sem_Patterns _pats))
sem_Pattern (Underscore _pos) =
(sem_Pattern_Underscore _pos)
newtype T_Pattern = T_Pattern (( Pattern,([Identifier]),([(Identifier, Identifier)])))
data Inh_Pattern = Inh_Pattern {}
data Syn_Pattern = Syn_Pattern {copy_Syn_Pattern :: !(Pattern),definedInsts_Syn_Pattern :: !(([Identifier])),patternAttributes_Syn_Pattern :: !(([(Identifier, Identifier)]))}
wrap_Pattern :: T_Pattern ->
Inh_Pattern ->
Syn_Pattern
wrap_Pattern (T_Pattern sem) (Inh_Pattern) =
(let ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes) = sem
in (Syn_Pattern _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes))
sem_Pattern_Alias :: Identifier ->
Identifier ->
T_Pattern ->
T_Pattern
sem_Pattern_Alias field_ attr_ (T_Pattern pat_) =
(T_Pattern (let _lhsOdefinedInsts :: ([Identifier])
_lhsOpatternAttributes :: ([(Identifier, Identifier)])
_lhsOcopy :: Pattern
_patIcopy :: Pattern
_patIdefinedInsts :: ([Identifier])
_patIpatternAttributes :: ([(Identifier, Identifier)])
_lhsOdefinedInsts =
(
(if field_ == _INST then [attr_] else []) ++ _patIdefinedInsts
)
_lhsOpatternAttributes =
(
(field_,attr_) : _patIpatternAttributes
)
_copy =
(
Alias field_ attr_ _patIcopy
)
_lhsOcopy =
(
_copy
)
( _patIcopy,_patIdefinedInsts,_patIpatternAttributes) =
pat_
___node =
(Syn_Pattern _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes)
in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)))
sem_Pattern_Constr :: ConstructorIdent ->
T_Patterns ->
T_Pattern
sem_Pattern_Constr name_ (T_Patterns pats_) =
(T_Pattern (let _lhsOdefinedInsts :: ([Identifier])
_lhsOpatternAttributes :: ([(Identifier, Identifier)])
_lhsOcopy :: Pattern
_patsIcopy :: Patterns
_patsIdefinedInsts :: ([Identifier])
_patsIpatternAttributes :: ([(Identifier, Identifier)])
_lhsOdefinedInsts =
(
_patsIdefinedInsts
)
_lhsOpatternAttributes =
(
_patsIpatternAttributes
)
_copy =
(
Constr name_ _patsIcopy
)
_lhsOcopy =
(
_copy
)
( _patsIcopy,_patsIdefinedInsts,_patsIpatternAttributes) =
pats_
___node =
(Syn_Pattern _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes)
in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)))
sem_Pattern_Irrefutable :: T_Pattern ->
T_Pattern
sem_Pattern_Irrefutable (T_Pattern pat_) =
(T_Pattern (let _lhsOdefinedInsts :: ([Identifier])
_lhsOpatternAttributes :: ([(Identifier, Identifier)])
_lhsOcopy :: Pattern
_patIcopy :: Pattern
_patIdefinedInsts :: ([Identifier])
_patIpatternAttributes :: ([(Identifier, Identifier)])
_lhsOdefinedInsts =
(
_patIdefinedInsts
)
_lhsOpatternAttributes =
(
_patIpatternAttributes
)
_copy =
(
Irrefutable _patIcopy
)
_lhsOcopy =
(
_copy
)
( _patIcopy,_patIdefinedInsts,_patIpatternAttributes) =
pat_
___node =
(Syn_Pattern _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes)
in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)))
sem_Pattern_Product :: Pos ->
T_Patterns ->
T_Pattern
sem_Pattern_Product pos_ (T_Patterns pats_) =
(T_Pattern (let _lhsOdefinedInsts :: ([Identifier])
_lhsOpatternAttributes :: ([(Identifier, Identifier)])
_lhsOcopy :: Pattern
_patsIcopy :: Patterns
_patsIdefinedInsts :: ([Identifier])
_patsIpatternAttributes :: ([(Identifier, Identifier)])
_lhsOdefinedInsts =
(
_patsIdefinedInsts
)
_lhsOpatternAttributes =
(
_patsIpatternAttributes
)
_copy =
(
Product pos_ _patsIcopy
)
_lhsOcopy =
(
_copy
)
( _patsIcopy,_patsIdefinedInsts,_patsIpatternAttributes) =
pats_
___node =
(Syn_Pattern _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes)
in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)))
sem_Pattern_Underscore :: Pos ->
T_Pattern
sem_Pattern_Underscore pos_ =
(T_Pattern (let _lhsOdefinedInsts :: ([Identifier])
_lhsOpatternAttributes :: ([(Identifier, Identifier)])
_lhsOcopy :: Pattern
_lhsOdefinedInsts =
(
[]
)
_lhsOpatternAttributes =
(
[]
)
_copy =
(
Underscore pos_
)
_lhsOcopy =
(
_copy
)
___node =
(Syn_Pattern _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes)
in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)))
sem_Patterns :: Patterns ->
T_Patterns
sem_Patterns list =
(Prelude.foldr sem_Patterns_Cons sem_Patterns_Nil (Prelude.map sem_Pattern list))
newtype T_Patterns = T_Patterns (( Patterns,([Identifier]),([(Identifier, Identifier)])))
data Inh_Patterns = Inh_Patterns {}
data Syn_Patterns = Syn_Patterns {copy_Syn_Patterns :: !(Patterns),definedInsts_Syn_Patterns :: !(([Identifier])),patternAttributes_Syn_Patterns :: !(([(Identifier, Identifier)]))}
wrap_Patterns :: T_Patterns ->
Inh_Patterns ->
Syn_Patterns
wrap_Patterns (T_Patterns sem) (Inh_Patterns) =
(let ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes) = sem
in (Syn_Patterns _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes))
sem_Patterns_Cons :: T_Pattern ->
T_Patterns ->
T_Patterns
sem_Patterns_Cons (T_Pattern hd_) (T_Patterns tl_) =
(T_Patterns (let _lhsOdefinedInsts :: ([Identifier])
_lhsOpatternAttributes :: ([(Identifier, Identifier)])
_lhsOcopy :: Patterns
_hdIcopy :: Pattern
_hdIdefinedInsts :: ([Identifier])
_hdIpatternAttributes :: ([(Identifier, Identifier)])
_tlIcopy :: Patterns
_tlIdefinedInsts :: ([Identifier])
_tlIpatternAttributes :: ([(Identifier, Identifier)])
_lhsOdefinedInsts =
(
_hdIdefinedInsts ++ _tlIdefinedInsts
)
_lhsOpatternAttributes =
(
_hdIpatternAttributes ++ _tlIpatternAttributes
)
_copy =
(
(:) _hdIcopy _tlIcopy
)
_lhsOcopy =
(
_copy
)
( _hdIcopy,_hdIdefinedInsts,_hdIpatternAttributes) =
hd_
( _tlIcopy,_tlIdefinedInsts,_tlIpatternAttributes) =
tl_
___node =
(Syn_Patterns _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes)
in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)))
sem_Patterns_Nil :: T_Patterns
sem_Patterns_Nil =
(T_Patterns (let _lhsOdefinedInsts :: ([Identifier])
_lhsOpatternAttributes :: ([(Identifier, Identifier)])
_lhsOcopy :: Patterns
_lhsOdefinedInsts =
(
[]
)
_lhsOpatternAttributes =
(
[]
)
_copy =
(
[]
)
_lhsOcopy =
(
_copy
)
___node =
(Syn_Patterns _lhsOcopy _lhsOdefinedInsts _lhsOpatternAttributes)
in ( _lhsOcopy,_lhsOdefinedInsts,_lhsOpatternAttributes)))
sem_Sequence :: Sequence ->
T_Sequence
sem_Sequence list =
(Prelude.foldr sem_Sequence_Cons sem_Sequence_Nil (Prelude.map sem_CRule list))
newtype T_Sequence = T_Sequence ((Set NontermIdent) ->
(Set Identifier) ->
([(Identifier,Type,ChildKind)]) ->
ConstructorIdent ->
([Decl]) ->
Attributes ->
(Map Identifier Int) ->
Expr ->
(Map Identifier (Identifier, [Identifier])) ->
Int ->
NontermIdent ->
Bool ->
Bool ->
Bool ->
(Maybe Bool) ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Bool ->
Options ->
(Map Identifier (NontermIdent, [String])) ->
ParamMap ->
String ->
Attributes ->
([Identifier]) ->
(NontermIdent -> Int -> [String] -> Code.Type) ->
(Set Identifier) ->
String ->
( Bool,DeclBlocks,([String]),Decls,([Decl]),([Identifier]),Exprs,([Decl]),([Type]),(Set String),(Set Identifier)))
data Inh_Sequence = Inh_Sequence {allNts_Inh_Sequence :: !((Set NontermIdent)),aroundMap_Inh_Sequence :: !((Set Identifier)),children_Inh_Sequence :: !(([(Identifier,Type,ChildKind)])),con_Inh_Sequence :: !(ConstructorIdent),declsAbove_Inh_Sequence :: !(([Decl])),inh_Inh_Sequence :: !(Attributes),instVisitNrs_Inh_Sequence :: !((Map Identifier Int)),lastExpr_Inh_Sequence :: !(Expr),mergeMap_Inh_Sequence :: !((Map Identifier (Identifier, [Identifier]))),nr_Inh_Sequence :: !(Int),nt_Inh_Sequence :: !(NontermIdent),o_case_Inh_Sequence :: !(Bool),o_cata_Inh_Sequence :: !(Bool),o_costcentre_Inh_Sequence :: !(Bool),o_data_Inh_Sequence :: !((Maybe Bool)),o_linePragmas_Inh_Sequence :: !(Bool),o_monadic_Inh_Sequence :: !(Bool),o_newtypes_Inh_Sequence :: !(Bool),o_pretty_Inh_Sequence :: !(Bool),o_rename_Inh_Sequence :: !(Bool),o_sem_Inh_Sequence :: !(Bool),o_sig_Inh_Sequence :: !(Bool),o_splitsems_Inh_Sequence :: !(Bool),o_strictwrap_Inh_Sequence :: !(Bool),o_traces_Inh_Sequence :: !(Bool),o_unbox_Inh_Sequence :: !(Bool),options_Inh_Sequence :: !(Options),paramInstMap_Inh_Sequence :: !((Map Identifier (NontermIdent, [String]))),paramMap_Inh_Sequence :: !(ParamMap),prefix_Inh_Sequence :: !(String),syn_Inh_Sequence :: !(Attributes),terminals_Inh_Sequence :: !(([Identifier])),unfoldSemDom_Inh_Sequence :: !((NontermIdent -> Int -> [String] -> Code.Type)),visitedSet_Inh_Sequence :: !((Set Identifier)),what_Inh_Sequence :: !(String)}
data Syn_Sequence = Syn_Sequence {allTpsFound_Syn_Sequence :: !(Bool),blockDecls_Syn_Sequence :: !(DeclBlocks),comments_Syn_Sequence :: !(([String])),decls_Syn_Sequence :: !(Decls),declsAbove_Syn_Sequence :: !(([Decl])),definedInsts_Syn_Sequence :: !(([Identifier])),exprs_Syn_Sequence :: !(Exprs),tSigs_Syn_Sequence :: !(([Decl])),tps_Syn_Sequence :: !(([Type])),usedVars_Syn_Sequence :: !((Set String)),visitedSet_Syn_Sequence :: !((Set Identifier))}
wrap_Sequence :: T_Sequence ->
Inh_Sequence ->
Syn_Sequence
wrap_Sequence (T_Sequence sem) (Inh_Sequence _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat) =
(let ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars,_lhsOvisitedSet) = sem _lhsIallNts _lhsIaroundMap _lhsIchildren _lhsIcon _lhsIdeclsAbove _lhsIinh _lhsIinstVisitNrs _lhsIlastExpr _lhsImergeMap _lhsInr _lhsInt _lhsIo_case _lhsIo_cata _lhsIo_costcentre _lhsIo_data _lhsIo_linePragmas _lhsIo_monadic _lhsIo_newtypes _lhsIo_pretty _lhsIo_rename _lhsIo_sem _lhsIo_sig _lhsIo_splitsems _lhsIo_strictwrap _lhsIo_traces _lhsIo_unbox _lhsIoptions _lhsIparamInstMap _lhsIparamMap _lhsIprefix _lhsIsyn _lhsIterminals _lhsIunfoldSemDom _lhsIvisitedSet _lhsIwhat
in (Syn_Sequence _lhsOallTpsFound _lhsOblockDecls _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet))
sem_Sequence_Cons :: T_CRule ->
T_Sequence ->
T_Sequence
sem_Sequence_Cons (T_CRule hd_) (T_Sequence tl_) =
(T_Sequence (\ _lhsIallNts
_lhsIaroundMap
_lhsIchildren
_lhsIcon
_lhsIdeclsAbove
_lhsIinh
_lhsIinstVisitNrs
_lhsIlastExpr
_lhsImergeMap
_lhsInr
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamInstMap
_lhsIparamMap
_lhsIprefix
_lhsIsyn
_lhsIterminals
_lhsIunfoldSemDom
_lhsIvisitedSet
_lhsIwhat ->
(let _lhsOblockDecls :: DeclBlocks
_lhsOallTpsFound :: Bool
_lhsOcomments :: ([String])
_lhsOdecls :: Decls
_lhsOdefinedInsts :: ([Identifier])
_lhsOexprs :: Exprs
_lhsOtSigs :: ([Decl])
_lhsOtps :: ([Type])
_lhsOusedVars :: (Set String)
_lhsOdeclsAbove :: ([Decl])
_lhsOvisitedSet :: (Set Identifier)
_hdOallNts :: (Set NontermIdent)
_hdOaroundMap :: (Set Identifier)
_hdOchildren :: ([(Identifier,Type,ChildKind)])
_hdOcon :: ConstructorIdent
_hdOdeclsAbove :: ([Decl])
_hdOinh :: Attributes
_hdOinstVisitNrs :: (Map Identifier Int)
_hdOmergeMap :: (Map Identifier (Identifier, [Identifier]))
_hdOnr :: Int
_hdOnt :: NontermIdent
_hdOo_case :: Bool
_hdOo_cata :: Bool
_hdOo_costcentre :: Bool
_hdOo_data :: (Maybe Bool)
_hdOo_linePragmas :: Bool
_hdOo_monadic :: Bool
_hdOo_newtypes :: Bool
_hdOo_pretty :: Bool
_hdOo_rename :: Bool
_hdOo_sem :: Bool
_hdOo_sig :: Bool
_hdOo_splitsems :: Bool
_hdOo_strictwrap :: Bool
_hdOo_traces :: Bool
_hdOo_unbox :: Bool
_hdOoptions :: Options
_hdOparamInstMap :: (Map Identifier (NontermIdent, [String]))
_hdOparamMap :: ParamMap
_hdOprefix :: String
_hdOsyn :: Attributes
_hdOterminals :: ([Identifier])
_hdOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_hdOvisitedSet :: (Set Identifier)
_hdOwhat :: String
_tlOallNts :: (Set NontermIdent)
_tlOaroundMap :: (Set Identifier)
_tlOchildren :: ([(Identifier,Type,ChildKind)])
_tlOcon :: ConstructorIdent
_tlOdeclsAbove :: ([Decl])
_tlOinh :: Attributes
_tlOinstVisitNrs :: (Map Identifier Int)
_tlOlastExpr :: Expr
_tlOmergeMap :: (Map Identifier (Identifier, [Identifier]))
_tlOnr :: Int
_tlOnt :: NontermIdent
_tlOo_case :: Bool
_tlOo_cata :: Bool
_tlOo_costcentre :: Bool
_tlOo_data :: (Maybe Bool)
_tlOo_linePragmas :: Bool
_tlOo_monadic :: Bool
_tlOo_newtypes :: Bool
_tlOo_pretty :: Bool
_tlOo_rename :: Bool
_tlOo_sem :: Bool
_tlOo_sig :: Bool
_tlOo_splitsems :: Bool
_tlOo_strictwrap :: Bool
_tlOo_traces :: Bool
_tlOo_unbox :: Bool
_tlOoptions :: Options
_tlOparamInstMap :: (Map Identifier (NontermIdent, [String]))
_tlOparamMap :: ParamMap
_tlOprefix :: String
_tlOsyn :: Attributes
_tlOterminals :: ([Identifier])
_tlOunfoldSemDom :: (NontermIdent -> Int -> [String] -> Code.Type)
_tlOvisitedSet :: (Set Identifier)
_tlOwhat :: String
_hdIallTpsFound :: Bool
_hdIbldBlocksFun :: (DeclBlocks -> DeclBlocks)
_hdIcomments :: ([String])
_hdIdecls :: Decls
_hdIdeclsAbove :: ([Decl])
_hdIdefinedInsts :: ([Identifier])
_hdIexprs :: Exprs
_hdItSigs :: ([Decl])
_hdItps :: ([Type])
_hdIusedVars :: (Set String)
_hdIvisitedSet :: (Set Identifier)
_tlIallTpsFound :: Bool
_tlIblockDecls :: DeclBlocks
_tlIcomments :: ([String])
_tlIdecls :: Decls
_tlIdeclsAbove :: ([Decl])
_tlIdefinedInsts :: ([Identifier])
_tlIexprs :: Exprs
_tlItSigs :: ([Decl])
_tlItps :: ([Type])
_tlIusedVars :: (Set String)
_tlIvisitedSet :: (Set Identifier)
_lhsOblockDecls =
(
_hdIbldBlocksFun _tlIblockDecls
)
_lhsOallTpsFound =
(
_hdIallTpsFound && _tlIallTpsFound
)
_lhsOcomments =
(
_hdIcomments ++ _tlIcomments
)
_lhsOdecls =
(
_hdIdecls ++ _tlIdecls
)
_lhsOdefinedInsts =
(
_hdIdefinedInsts ++ _tlIdefinedInsts
)
_lhsOexprs =
(
_hdIexprs ++ _tlIexprs
)
_lhsOtSigs =
(
_hdItSigs ++ _tlItSigs
)
_lhsOtps =
(
_hdItps ++ _tlItps
)
_lhsOusedVars =
(
_hdIusedVars `Set.union` _tlIusedVars
)
_lhsOdeclsAbove =
(
_tlIdeclsAbove
)
_lhsOvisitedSet =
(
_tlIvisitedSet
)
_hdOallNts =
(
_lhsIallNts
)
_hdOaroundMap =
(
_lhsIaroundMap
)
_hdOchildren =
(
_lhsIchildren
)
_hdOcon =
(
_lhsIcon
)
_hdOdeclsAbove =
(
_lhsIdeclsAbove
)
_hdOinh =
(
_lhsIinh
)
_hdOinstVisitNrs =
(
_lhsIinstVisitNrs
)
_hdOmergeMap =
(
_lhsImergeMap
)
_hdOnr =
(
_lhsInr
)
_hdOnt =
(
_lhsInt
)
_hdOo_case =
(
_lhsIo_case
)
_hdOo_cata =
(
_lhsIo_cata
)
_hdOo_costcentre =
(
_lhsIo_costcentre
)
_hdOo_data =
(
_lhsIo_data
)
_hdOo_linePragmas =
(
_lhsIo_linePragmas
)
_hdOo_monadic =
(
_lhsIo_monadic
)
_hdOo_newtypes =
(
_lhsIo_newtypes
)
_hdOo_pretty =
(
_lhsIo_pretty
)
_hdOo_rename =
(
_lhsIo_rename
)
_hdOo_sem =
(
_lhsIo_sem
)
_hdOo_sig =
(
_lhsIo_sig
)
_hdOo_splitsems =
(
_lhsIo_splitsems
)
_hdOo_strictwrap =
(
_lhsIo_strictwrap
)
_hdOo_traces =
(
_lhsIo_traces
)
_hdOo_unbox =
(
_lhsIo_unbox
)
_hdOoptions =
(
_lhsIoptions
)
_hdOparamInstMap =
(
_lhsIparamInstMap
)
_hdOparamMap =
(
_lhsIparamMap
)
_hdOprefix =
(
_lhsIprefix
)
_hdOsyn =
(
_lhsIsyn
)
_hdOterminals =
(
_lhsIterminals
)
_hdOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_hdOvisitedSet =
(
_lhsIvisitedSet
)
_hdOwhat =
(
_lhsIwhat
)
_tlOallNts =
(
_lhsIallNts
)
_tlOaroundMap =
(
_lhsIaroundMap
)
_tlOchildren =
(
_lhsIchildren
)
_tlOcon =
(
_lhsIcon
)
_tlOdeclsAbove =
(
_hdIdeclsAbove
)
_tlOinh =
(
_lhsIinh
)
_tlOinstVisitNrs =
(
_lhsIinstVisitNrs
)
_tlOlastExpr =
(
_lhsIlastExpr
)
_tlOmergeMap =
(
_lhsImergeMap
)
_tlOnr =
(
_lhsInr
)
_tlOnt =
(
_lhsInt
)
_tlOo_case =
(
_lhsIo_case
)
_tlOo_cata =
(
_lhsIo_cata
)
_tlOo_costcentre =
(
_lhsIo_costcentre
)
_tlOo_data =
(
_lhsIo_data
)
_tlOo_linePragmas =
(
_lhsIo_linePragmas
)
_tlOo_monadic =
(
_lhsIo_monadic
)
_tlOo_newtypes =
(
_lhsIo_newtypes
)
_tlOo_pretty =
(
_lhsIo_pretty
)
_tlOo_rename =
(
_lhsIo_rename
)
_tlOo_sem =
(
_lhsIo_sem
)
_tlOo_sig =
(
_lhsIo_sig
)
_tlOo_splitsems =
(
_lhsIo_splitsems
)
_tlOo_strictwrap =
(
_lhsIo_strictwrap
)
_tlOo_traces =
(
_lhsIo_traces
)
_tlOo_unbox =
(
_lhsIo_unbox
)
_tlOoptions =
(
_lhsIoptions
)
_tlOparamInstMap =
(
_lhsIparamInstMap
)
_tlOparamMap =
(
_lhsIparamMap
)
_tlOprefix =
(
_lhsIprefix
)
_tlOsyn =
(
_lhsIsyn
)
_tlOterminals =
(
_lhsIterminals
)
_tlOunfoldSemDom =
(
_lhsIunfoldSemDom
)
_tlOvisitedSet =
(
_hdIvisitedSet
)
_tlOwhat =
(
_lhsIwhat
)
( _hdIallTpsFound,_hdIbldBlocksFun,_hdIcomments,_hdIdecls,_hdIdeclsAbove,_hdIdefinedInsts,_hdIexprs,_hdItSigs,_hdItps,_hdIusedVars,_hdIvisitedSet) =
hd_ _hdOallNts _hdOaroundMap _hdOchildren _hdOcon _hdOdeclsAbove _hdOinh _hdOinstVisitNrs _hdOmergeMap _hdOnr _hdOnt _hdOo_case _hdOo_cata _hdOo_costcentre _hdOo_data _hdOo_linePragmas _hdOo_monadic _hdOo_newtypes _hdOo_pretty _hdOo_rename _hdOo_sem _hdOo_sig _hdOo_splitsems _hdOo_strictwrap _hdOo_traces _hdOo_unbox _hdOoptions _hdOparamInstMap _hdOparamMap _hdOprefix _hdOsyn _hdOterminals _hdOunfoldSemDom _hdOvisitedSet _hdOwhat
( _tlIallTpsFound,_tlIblockDecls,_tlIcomments,_tlIdecls,_tlIdeclsAbove,_tlIdefinedInsts,_tlIexprs,_tlItSigs,_tlItps,_tlIusedVars,_tlIvisitedSet) =
tl_ _tlOallNts _tlOaroundMap _tlOchildren _tlOcon _tlOdeclsAbove _tlOinh _tlOinstVisitNrs _tlOlastExpr _tlOmergeMap _tlOnr _tlOnt _tlOo_case _tlOo_cata _tlOo_costcentre _tlOo_data _tlOo_linePragmas _tlOo_monadic _tlOo_newtypes _tlOo_pretty _tlOo_rename _tlOo_sem _tlOo_sig _tlOo_splitsems _tlOo_strictwrap _tlOo_traces _tlOo_unbox _tlOoptions _tlOparamInstMap _tlOparamMap _tlOprefix _tlOsyn _tlOterminals _tlOunfoldSemDom _tlOvisitedSet _tlOwhat
___node =
(Syn_Sequence _lhsOallTpsFound _lhsOblockDecls _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet)
in ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars,_lhsOvisitedSet))))
sem_Sequence_Nil :: T_Sequence
sem_Sequence_Nil =
(T_Sequence (\ _lhsIallNts
_lhsIaroundMap
_lhsIchildren
_lhsIcon
_lhsIdeclsAbove
_lhsIinh
_lhsIinstVisitNrs
_lhsIlastExpr
_lhsImergeMap
_lhsInr
_lhsInt
_lhsIo_case
_lhsIo_cata
_lhsIo_costcentre
_lhsIo_data
_lhsIo_linePragmas
_lhsIo_monadic
_lhsIo_newtypes
_lhsIo_pretty
_lhsIo_rename
_lhsIo_sem
_lhsIo_sig
_lhsIo_splitsems
_lhsIo_strictwrap
_lhsIo_traces
_lhsIo_unbox
_lhsIoptions
_lhsIparamInstMap
_lhsIparamMap
_lhsIprefix
_lhsIsyn
_lhsIterminals
_lhsIunfoldSemDom
_lhsIvisitedSet
_lhsIwhat ->
(let _lhsOblockDecls :: DeclBlocks
_lhsOallTpsFound :: Bool
_lhsOcomments :: ([String])
_lhsOdecls :: Decls
_lhsOdefinedInsts :: ([Identifier])
_lhsOexprs :: Exprs
_lhsOtSigs :: ([Decl])
_lhsOtps :: ([Type])
_lhsOusedVars :: (Set String)
_lhsOdeclsAbove :: ([Decl])
_lhsOvisitedSet :: (Set Identifier)
_lhsOblockDecls =
(
DeclTerminator _lhsIdeclsAbove _lhsIlastExpr
)
_lhsOallTpsFound =
(
True
)
_lhsOcomments =
(
[]
)
_lhsOdecls =
(
[]
)
_lhsOdefinedInsts =
(
[]
)
_lhsOexprs =
(
[]
)
_lhsOtSigs =
(
[]
)
_lhsOtps =
(
[]
)
_lhsOusedVars =
(
Set.empty
)
_lhsOdeclsAbove =
(
_lhsIdeclsAbove
)
_lhsOvisitedSet =
(
_lhsIvisitedSet
)
___node =
(Syn_Sequence _lhsOallTpsFound _lhsOblockDecls _lhsOcomments _lhsOdecls _lhsOdeclsAbove _lhsOdefinedInsts _lhsOexprs _lhsOtSigs _lhsOtps _lhsOusedVars _lhsOvisitedSet)
in ( _lhsOallTpsFound,_lhsOblockDecls,_lhsOcomments,_lhsOdecls,_lhsOdeclsAbove,_lhsOdefinedInsts,_lhsOexprs,_lhsOtSigs,_lhsOtps,_lhsOusedVars,_lhsOvisitedSet))))