uuagc 0.9.39.3 → 0.9.40.1
raw patch · 20 files changed
+663/−511 lines, 20 filesdep +uuagcdep ~uuagc-bootstrapdep ~uuagc-cabalsetup-changed
Dependencies added: uuagc
Dependency ranges changed: uuagc-bootstrap, uuagc-cabal
Files
- Setup.hs +3/−2
- src-ag/AG2AspectAG.ag +6/−5
- src-ag/DefaultRules.ag +22/−21
- src-ag/DistChildAttr.ag +1/−1
- src-ag/ExecutionPlan2Hs.ag +35/−15
- src-ag/GenerateCode.ag +1/−1
- src-ag/HsToken.ag +2/−2
- src-ag/KWOrder.ag +2/−2
- src-ag/Order.ag +1/−1
- src-ag/PrintCode.ag +2/−1
- src-ag/ResolveLocals.ag +1/−1
- src-ag/SemHsTokens.ag +15/−10
- src-main/Main.hs +6/−0
- src-options/Options.hs +494/−0
- src/Ag.hs +33/−9
- src/CommonTypes.hs +2/−14
- src/Options.hs +0/−402
- src/Scanner.hs +1/−1
- src/UU/UUAGC.hs +11/−0
- uuagc.cabal +25/−23
Setup.hs view
@@ -2,7 +2,8 @@ import Distribution.Simple import Distribution.Simple.UUAGC+import UU.UUAGC.Bootstrap -- uses the bootstrapped version of uuagc to build itself-compiler = "uuagc-bootstrap"-main = defaultMainWithHooks (uuagcUserHook' compiler)+compiler = uuagcBootstrap+main = defaultMainWithHooks (uuagcLibUserHook compiler)
src-ag/AG2AspectAG.ag view
@@ -201,7 +201,7 @@ | Grammar nonts . derivs = @derivings -ATTR Nonterminals Nonterminal [ | | ppD USE {>-<} {empty} : {PP_Doc} ppDI USE {++} {[]} : {[PP_Doc]} ]+ATTR Nonterminals Nonterminal Production [ | | ppD USE {>-<} {empty} : {PP_Doc} ppDI USE {++} {[]} : {[PP_Doc]} ] SEM Nonterminal | Nonterminal lhs . ppD =@@ -209,10 +209,10 @@ then case (lookup @nt @lhs.tSyns) of -- if it's a data type Nothing -> "data " >|< @loc.ppNt- {- >|< " = " >|< vlist_sep " | " @prods.ppDL >-<+ >|< " = " >|< vlist_sep " | " @prods.ppDL >-< case (Map.lookup @nt @lhs.derivs) of Just ntds -> pp " deriving " >|< (ppListSep "(" ")" ", " $ Set.elems ntds)- Nothing -> empty -}+ Nothing -> empty -- uncommented for testing purposes -- if it's a type synonym Just tp -> "type " >|< @loc.ppNt >|< " = " >|< ppShow tp else empty@@ -221,7 +221,8 @@ if (not $ Set.member @nt @lhs.newNTs) then [ @loc.ppNt ] else [ ]-{-+-- uncommented for testing purposes+ SEM Production | Production lhs . ppD = @loc.conName >|< ppListSep " {" "}" ", " @children.ppDL @@ -240,7 +241,7 @@ | Child lhs . ppDL = case @kind of ChildSyntax -> [ @loc.chName >|< pp " :: " >|< @loc.ppTCh ] _ -> []--}+ ATTR Nonterminals Nonterminal [ tSyns : {TypeSyns} | | ]
src-ag/DefaultRules.ag view
@@ -77,15 +77,18 @@ { fieldName n = '@' : getName n -locName n = '@' : getName n+locName n = "@loc." ++ getName n attrName fld attr- | fld == _LOC = '@' : getName attr+ | fld == _LOC = locName attr+ | fld == _FIELD = fieldName attr | otherwise = '@' : getName fld ++ "." ++ getName attr _ACHILD = Ident "(" noPos -- hack +mkLocVar = AGField _LOC + getConName typeSyns rename nt con1 | nt `elem` map fst typeSyns = synonym | otherwise = normalName@@ -258,7 +261,7 @@ | otherwise = foldr1 (\x y -> x ++ " " ++ op ++ " " ++ y) (map (flip attrName n) elems) - tks | Set.member n locals = [AGLocal n noPos Nothing]+ tks | Set.member n locals = [mkLocVar n noPos Nothing] | null elems = lexTokens noPos e | otherwise = lexTokens noPos str where@@ -272,16 +275,9 @@ Nothing ---selfRule lhsNecLoc attr x- = let expr | lhsNecLoc = locName attr- | otherwise = x-- tks | lhsNecLoc = [AGLocal attr noPos Nothing]- | otherwise = lexTokens noPos x-- in makeRule (if lhsNecLoc then _LHS else _LOC,attr)+selfRule :: Bool -> Identifier -> [HsToken] -> Rule+selfRule lhsNecLoc attr tks+ = makeRule (if lhsNecLoc then _LHS else _LOC,attr) (Expression noPos tks) "self rule" False@@ -358,7 +354,7 @@ loc.(newRls, errs) = let locals = @rules.locals- initenv = Map.fromList ( [ (a,_ACHILD)+ initenv = Map.fromList ( [ (a,_ACHILD) -- _ACHILD is used to mark identifiers in the environment that are terminals | (a,_,_) <- @children.fields ] ++ attrs(_LHS, @lhs.inh)@@ -392,15 +388,20 @@ uRules = map (useRule locals @children.outputs) useAttrs + -- creates a loc.xxx if there is a synthesized attr xxx of type SELF and no+ -- loc.xxx exists yet. If there exists a terminal yyy and a local loc.yyy, then+ -- the local is chosen as value for the terminal. selfLocRules- = [ selfRule False attr (constructor [childSelf attr nm tp | (nm,tp,virt) <- @children.fields, childExists virt])+ = [ selfRule False attr $+ lexTokens noPos $ -- building a string and lexing it again is not so nice... but practical here+ constructor [childSelf attr nm tp | (nm,tp,virt) <- @children.fields, childExists virt] | attr <- Map.keys selfAttrs , not (Set.member attr locals) ] where childSelf self nm tp = case tp of NT nt _ _ -> attrName nm self- _ | nm `Set.member` locals -> locname nm+ _ | nm `Set.member` locals -> locName nm | otherwise -> fieldName nm constructor fs | getName @con == "Tuple" && @lhs.nt `elem` map fst @lhs.typeSyns@@ -412,7 +413,7 @@ childExists _ = True selfRules- = [ selfRule True attr undefined+ = [ selfRule True attr [mkLocVar attr noPos Nothing] | attr <- Map.keys selfAttrs , not (Set.member (_LHS,attr) @rules.definedAttrs) ]@@ -436,8 +437,8 @@ where rule = Rule Nothing (Alias _LHS syn (Underscore noPos)) rhs False "augmented rule" False True False Nothing False rhs = Expression noPos tks- tks = [ HsToken "foldr ($) " noPos, AGLocal substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]- funs = intersperse (HsToken ", " noPos) (map (\n -> AGLocal n noPos Nothing) funNames)+ tks = [ HsToken "foldr ($) " noPos, mkLocVar substSyn noPos Nothing, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]+ funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) substSyn = Ident (show syn ++ "_augmented_syn") (getPos syn) funNames = zipWith (\i _ -> Ident (show syn ++ "_augmented_f" ++ show i) (getPos syn)) [1..] exprs@@ -474,7 +475,7 @@ rule = Rule Nothing (Alias _LOC childLoc (Underscore noPos)) rhs False "around rule" False True False Nothing False rhs = Expression noPos tks tks = [ HsToken "\\s -> foldr ($) s " noPos, HsToken " [" noPos] ++ funs ++ [HsToken "]" noPos]- funs = intersperse (HsToken ", " noPos) (map (\n -> AGLocal n noPos Nothing) funNames)+ funs = intersperse (HsToken ", " noPos) (map (\n -> mkLocVar n noPos Nothing) funNames) childLoc = Ident (show child ++ "_around") (getPos child) funNames = zipWith (\i _ -> Ident (show child ++ "_around_f" ++ show i) (getPos child)) [1..] exprs@@ -605,7 +606,7 @@ alias = Rule Nothing (Alias _LOC (Ident ("_rule_" ++ show nm) pos) (Underscore pos)) expr owrt origin expl pure identity mbErr eager pos = getPos nm expr' = Expression pos tks- tks = [AGLocal (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))]+ tks = [mkLocVar (Ident ("_rule_" ++ show nm) pos) pos (Just ("Indirection to rule " ++ show nm))] r' = Rule Nothing pat expr' owrt origin False True identity Nothing False }
src-ag/DistChildAttr.ag view
@@ -19,6 +19,6 @@ | Child loc.chnt = case @tp of NT nt _ _ -> nt Self -> error ("The type of child " ++ show @name ++ " should not be a Self type.")- Haskell t -> identifier t -- should be ignored because the child is a terminal+ Haskell t -> identifier "" -- should be ignored because the child is a terminal loc.inh = Map.findWithDefault Map.empty @loc.chnt @lhs.inhMap loc.syn = Map.findWithDefault Map.empty @loc.chnt @lhs.synMap
src-ag/ExecutionPlan2Hs.ag view
@@ -299,10 +299,10 @@ SEM EChild | EChild lhs.argnamesw = case @kind of- ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< "field_" >|< @name >#< ")"+ ChildSyntax -> "(" >#< "sem_" >|< @loc.nt >#< @name >|< "_" >#< ")" ChildAttr -> empty -- no sem-case for a higher-order child- ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< "field_" >|< @name >#< ")"- | ETerm lhs.argnamesw = text $ locname @name+ ChildReplace tp -> "(" >#< "sem_" >|< extractNonterminal tp >#< @name >|< "_" >#< ")"+ | ETerm lhs.argnamesw = text $ fieldname @name ------------------------------------------------------------------------------- -- Types of attributes@@ -314,6 +314,7 @@ ATTR EProductions EProduction ERules ERule+ Patterns Pattern Visits Visit [ inhmap : {Attributes} synmap : {Attributes}@@ -569,11 +570,11 @@ ChildReplace tp -> ppDefor tp >#< "->" _ -> empty -- higher order attribute loc.argpats = case @kind of- ChildSyntax -> "field_" >|< @name -- no strictification of children semantics to allow infinite trees- ChildReplace _ -> "field_" >|< @name+ ChildSyntax -> @name >|< "_" -- no strictification of children semantics to allow infinite trees+ ChildReplace _ -> @name >|< "_" _ -> empty | ETerm lhs.argtps = (pp_parens $ show @tp) >#< "->"- loc.argpats = @loc.addbang $ text $ locname @name -- terminals may be strict (perhaps this should become an option)+ loc.argpats = @loc.addbang $ text $ fieldname @name -- terminals may be strict (perhaps this should become an option) { ppDefor :: Type -> PP_Doc@@ -895,12 +896,13 @@ | EProduction visits.childintros = @children.childintros SEM EChild+ | ETerm lhs.childintros = Map.singleton @name (\_ _ -> Right (empty, Set.empty, Map.empty)) | EChild lhs.childintros = Map.singleton @name @loc.introcode loc.isDefor = case @tp of NT _ _ defor -> defor _ -> False loc.valcode = case @kind of- ChildSyntax -> "field_" >|< @name+ ChildSyntax -> @name >|< "_" ChildAttr -> -- decide if we need to invoke the sem-function under the hood let prefix | not @loc.isDefor = if lateHigherOrderBinding @lhs.options -- && sepsemmods @lhs.options -- when sepsemmods is not enabled, the indirection can be optimized away then lateSemNtLabel @loc.nt >#< lhsname True idLateBindingAttr@@ -909,7 +911,7 @@ in pp_parens (prefix >#< instname @name) ChildReplace _ -> -- the higher-order attribute is actually a function that transforms -- the semantics of the child (always deforested)- pp_parens (instname @name >#< "field_" >|< @name)+ pp_parens (instname @name >#< @name >|< "_") loc.aroundcode = if @hasAround then locname @name >|< "_around" else empty@@ -1033,11 +1035,18 @@ then Right $ let oper | @pure = "=" | otherwise = "<-" decl = @pattern.sem_lhs >#< oper >#< @name >#< @loc.argExprs >#< dummyArg @lhs.options (Map.null @rhs.attrs)- in fmtDecl @pure fmtMode decl+ tp = if @pure && not (noPerRuleTypeSigs @lhs.options)+ then @pattern.attrTypes+ else empty+ in fmtDecl @pure fmtMode (tp >-< decl) else Left $ IncompatibleRuleKind @name kind lhs.mrules = Map.singleton @name @loc.stepcode +ATTR Expression [ | | tks : {[HsToken]} ]+SEM Expression+ | Expression lhs.tks = @tks+ { dummyPat :: Options -> Bool -> PP_Doc dummyPat opts noArgs@@ -1110,10 +1119,21 @@ SEM Pattern | Alias lhs.attrs = Set.insert (attrname False @field @attr) @pat.attrs +-- All attribute types of this pattern+ATTR Pattern Patterns [ | | attrTypes USE {>-<} {empty} : {PP_Doc} ]+SEM Pattern | Alias+ loc.mbTp = if @field == _LHS+ then Map.lookup @attr @lhs.synmap+ else if @field == _LOC+ then Map.lookup @attr @lhs.localAttrTypes+ else Nothing+ lhs.attrTypes = maybe empty (\tp -> (attrname False @field @attr) >#< "::" >#< ppTp tp) @loc.mbTp+ >-< @pat.attrTypes+ -- Collect the attributes used by the right-hand side ATTR HsToken Expression [ | | attrs USE {`Map.union`} {Map.empty} : {Map String (Maybe NonLocalAttr)} ] SEM HsToken- | AGLocal lhs.attrs = Map.singleton (locname @var) Nothing+ | AGLocal lhs.attrs = Map.singleton (fieldname @var) Nothing | AGField loc.mbAttr = if @field == _INST || @field == _FIELD || @field == _INST' then Nothing -- should not be used in the first place else Just $ mkNonLocalAttr (@field == _LHS) @field @attr@@ -1122,7 +1142,7 @@ { data NonLocalAttr = AttrInh Identifier Identifier- | AttrSyn Identifier Identifier+ | AttrSyn Identifier Identifier deriving Show mkNonLocalAttr :: Bool -> Identifier -> Identifier -> NonLocalAttr mkNonLocalAttr True = AttrInh -- True: inherited attr@@ -1264,7 +1284,7 @@ ATTR EChild EChildren [ | | terminaldefs USE {`Set.union`} {Set.empty} : {Set String} ] SEM EChild | ETerm- lhs.terminaldefs = Set.singleton $ locname @name+ lhs.terminaldefs = Set.singleton $ fieldname @name SEM EProduction | EProduction visits.allintramap = @visits.intramap@@ -1358,7 +1378,7 @@ | Nil lhs.tks = [] SEM HsToken- | AGLocal loc.tok = (@pos,locname @var)+ | AGLocal loc.tok = (@pos,fieldname @var) SEM HsToken [ || tok:{(Pos,String)}] | AGField@@ -1412,7 +1432,7 @@ ) loc.commonFile = replaceBaseName @lhs.mainFile (takeBaseName @lhs.mainFile ++ "_common") loc.genCommonModule = writeModule @loc.commonFile- ( [ pp $ "{-# LANGUAGE GADTs #-}" -- the common module only needs GADTs+ ( [ pp $ "{-# LANGUAGE Rank2Types, GADTs #-}" -- the common module only needs GADTs and Rank2Types , pp $ @lhs.pragmaBlocks , pp $ @lhs.moduleHeader @lhs.mainName "_common" "" True , @loc.ppMonadImports@@ -1555,7 +1575,7 @@ ATTR ExecutionPlan ENonterminals ENonterminal [ localAttrTypes : {Map NontermIdent (Map ConstructorIdent (Map Identifier Type))} | | ] ATTR EProductions EProduction [ localAttrTypes : {Map ConstructorIdent (Map Identifier Type)} | | ]-ATTR ERules ERule [ localAttrTypes : {Map Identifier Type} | | ]+ATTR ERules ERule Pattern Patterns [ localAttrTypes : {Map Identifier Type} | | ] SEM ENonterminal | ENonterminal prods.localAttrTypes = Map.findWithDefault Map.empty @nt @lhs.localAttrTypes
src-ag/GenerateCode.ag view
@@ -451,7 +451,7 @@ else [Decl lhs rhs (Set.fromList @nextVisitName) @lhs.nextIntraVars] loc.isOneVisit = @lhs.isLast && @lhs.nr == 0 loc.hasWrappers = @lhs.nt `Set.member` @lhs.wrappers- loc.refDecls = if @loc.isOneVisit && @loc.hasWrappers+ loc.refDecls = if @loc.isOneVisit && @loc.hasWrappers && reference @lhs.options then let synAttrs = Map.toList @syn synNT = "Syn" ++ "_" ++ getName @lhs.nt synVars = [ SimpleExpr (attrname False _LHS a) | (a,_) <- synAttrs ]
src-ag/HsToken.ag view
@@ -10,11 +10,11 @@ TYPE HsTokens = [HsToken] DATA HsToken- | AGLocal var : {Identifier}+ | AGLocal var : {Identifier} -- either a local or a terminal pos : {Pos} rdesc : {Maybe String} -- description of the rule the local reference appears in - | AGField field : {Identifier}+ | AGField field : {Identifier} -- Misnomer: this is actually a reference to an attribute, not a terminal! attr : {Identifier} pos : {Pos} rdesc : {Maybe String} -- description of the rule the attribute reference appears in
src-ag/KWOrder.ag view
@@ -190,7 +190,7 @@ -- All vertices from the righthandside of a rule SEM HsToken- | AGLocal lhs.vertices = Set.singleton $ VAttr Loc _LOC @var+ | AGLocal lhs.vertices = Set.singleton $ VChild @var | AGField lhs.vertices = Set.singleton $ VAttr (if @field == _LHS then Inh else if @field == _LOC then Loc else Syn) @field @attr@@ -358,7 +358,7 @@ SEM Grammar | Grammar (lhs.output, lhs.depgraphs, lhs.visitgraph, lhs.errors) = let lazyPlan = kennedyWarrenLazy @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings- in if visit @lhs.options+ in if visit @lhs.options && withCycle @lhs.options then case kennedyWarrenOrder @lhs.options @wrappers @nonts.depinfo @typeSyns @derivings of Left e -> (lazyPlan,empty,empty,Seq.singleton e) Right (o,d,v) -> (o,d,v,Seq.empty)
src-ag/Order.ag view
@@ -585,7 +585,7 @@ , error "No visit sub-sequences for AG with induced cycles" , inducedCycleErrs @attrTable @ruleTable cim errs )- lhs.errors := (if withCycle @lhs.options then Seq.fromList @cyclesErrors else Seq.empty)+ lhs.errors = (if withCycle @lhs.options then Seq.fromList @cyclesErrors else Seq.empty) Seq.>< @nonts.errors ------------------------------------------------------------------
src-ag/PrintCode.ag view
@@ -488,11 +488,12 @@ = [ [@comment.pp] , @dataDef.pps , @semDom.pps+ , if reference @lhs.options then @semWrapper.pps else [] ] lhs.appendMain = [ [@comment.pp] , @cataFun.pps- , @semWrapper.pps+ , if reference @lhs.options then [] else @semWrapper.pps ] ATTR Chunk Chunks [ | | genSems USE {>>} {return ()} : {IO ()} ]
src-ag/ResolveLocals.ag view
@@ -7,7 +7,7 @@ -- -- Checks right-hand sides for missing attributes. -- Attribute references @xxx are now explicitly mapped to @loc.xxx if there is such--- an attribute in scope.+-- an attribute in scope and there is no terminal @xxx. --
src-ag/SemHsTokens.ag view
@@ -60,24 +60,25 @@ } +-- An AGLocal is either a local variable or a terminal SEM HsToken- | AGLocal loc.tkAsLocal = AGLocal @var @pos @rdesc- loc.tkAsField = AGField _LOC @var @pos @rdesc+ | AGLocal loc.tkAsLocal = AGLocal @var @pos @rdesc -- refers to the terminal+ loc.tkAsField = AGField _LOC @var @pos @rdesc -- refers to the (local) attribute loc.(errors,output,tok,usedLocals) =- if @var `elem` @lhs.fieldnames+ if @var `elem` @lhs.fieldnames -- check if @var occurs as a terminal then if isNTname @lhs.allnts (lookup @var (map (\(n,t,_) -> (n,t)) @lhs.allfields)) then (Seq.singleton(ChildAsLocal @lhs.nt @lhs.con @var), @loc.tkAsLocal,(@pos,fieldname @var), [] ) else (Seq.empty, @loc.tkAsLocal, (@pos,fieldname @var), [] ) else if (_LOC,@var) `elem` @lhs.attrs- then (Seq.empty , @loc.tkAsField, (@pos,locname @var), [@var])- else (Seq.singleton(UndefLocal @lhs.nt @lhs.con @var), @loc.tkAsField, (@pos,locname @var), [] )+ then (Seq.empty , @loc.tkAsField, (@pos,locname @var), [@var])+ else (Seq.singleton(UndefLocal @lhs.nt @lhs.con @var), @loc.tkAsField, (@pos,locname @var), [] ) SEM HsToken | AGField lhs.errors = if (@field,@attr) `elem` @lhs.attrs- then Seq.empty- else if not(@field `elem` (_LHS : _LOC: @lhs.fieldnames))- then Seq.singleton (UndefChild @lhs.nt @lhs.con @field)- else Seq.singleton (UndefAttr @lhs.nt @lhs.con @field @attr False)+ then Seq.empty+ else if not(@field `elem` (_LHS : _LOC: @lhs.fieldnames))+ then Seq.singleton (UndefChild @lhs.nt @lhs.con @field)+ else Seq.singleton (UndefAttr @lhs.nt @lhs.con @field @attr False) ------------------------------------------------------------------------------- -- Used variables@@ -87,7 +88,11 @@ usedAttrs USE {++} {[]} : {[(Identifier,Identifier)]} ] SEM HsToken- | AGField lhs.usedAttrs = [(@field,@attr)]+ | AGField (lhs.usedAttrs,lhs.usedLocals)+ = if @field == _LOC+ then ([], [@attr])+ else ([(@field,@attr)], [])+ ------------------------------------------------------------------------------- -- Used fields
+ src-main/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import UU.UUAGC (uuagcMain)++main :: IO ()+main = uuagcMain
+ src-options/Options.hs view
@@ -0,0 +1,494 @@+module Options where++import System.Console.GetOpt+import Data.Set(Set)+import UU.Scanner.Position(Pos,noPos)+import Data.List(intercalate)+import qualified Data.Set as Set++-- From CommonTypes+data Identifier = Ident { getName::String, getPos::Pos }+type NontermIdent = Identifier+identifier x = Ident x noPos++instance Eq Identifier where+ Ident x _ == Ident y _ = x == y++instance Ord Identifier where+ compare (Ident x _) (Ident y _) = compare x y++instance Show Identifier where+ show ident = getName ident+ +-- Make options serializable+data MyOptDescr = MyOpt [Char] [String] (ArgDescr (Options -> Options)) (Options -> String -> [String]) String++fromMyOpt :: MyOptDescr -> OptDescr (Options -> Options)+fromMyOpt (MyOpt sh ln desc _ s) = Option sh ln desc s++noOpt :: Options -> String -> [String]+noOpt _ _ = []++boolOpt :: (Options -> Bool) -> Options -> String -> [String]+boolOpt get opt strArg = let oldVal = get noOptions+ newVal = get opt+ in if oldVal /= newVal+ then [strArg]+ else []++stringOpt :: (Options -> String) -> Options -> String -> [String]+stringOpt get opt strArg = let oldVal = get noOptions+ newVal = get opt+ in if oldVal /= newVal+ then [strArg, newVal]+ else []++mbStringOpt :: (Options -> Maybe String) -> Options -> String -> [String]+mbStringOpt get opts nm = maybe [] (\s -> [nm, s]) (get opts)++serializeOption :: Options -> MyOptDescr -> [String]+serializeOption opt (MyOpt sh ln _ get _) = get opt strArg+ where+ strArg = if null sh+ then '-' : '-' : head ln+ else '-' : head sh : []++-- All options+allOptions :: [MyOptDescr]+allOptions = + [ MyOpt ['m'] [] (NoArg (moduleOpt Nothing)) noOpt "generate default module header"+ , MyOpt [] ["module"] (OptArg moduleOpt "name") moduleOptGet "generate module header, specify module name"+ , MyOpt ['d'] ["data"] (NoArg dataOpt) (boolOpt dataTypes) "generate data type definition"+ , MyOpt [] ["datarecords"] (NoArg dataRecOpt) (boolOpt dataRecords) "generate record data types"+ , MyOpt [] ["strictdata"] (NoArg strictDataOpt) (boolOpt strictData) "generate strict data fields (when data is generated)"+ , MyOpt [] ["strictwrap"] (NoArg strictWrapOpt) (boolOpt strictWrap) "generate strict wrap fields for WRAPPER generated data"+ , MyOpt ['c'] ["catas"] (NoArg cataOpt) (boolOpt folds) "generate catamorphisms"+ , MyOpt ['f'] ["semfuns"] (NoArg semfunsOpt) (boolOpt semfuns) "generate semantic functions"+ , MyOpt ['s'] ["signatures"] (NoArg signaturesOpt) (boolOpt typeSigs) "generate signatures for semantic functions"+ , MyOpt [] ["newtypes"] (NoArg newtypesOpt) (boolOpt newtypes) "use newtypes instead of type synonyms"+ , MyOpt ['p'] ["pretty"] (NoArg prettyOpt) (boolOpt attrInfo) "generate pretty printed list of attributes"+ , MyOpt ['w'] ["wrappers"] (NoArg wrappersOpt) (boolOpt wrappers) "generate wappers for semantic domains"+ , MyOpt ['r'] ["rename"] (NoArg renameOpt) (boolOpt rename) "rename data constructors"+ , MyOpt [] ["modcopy"] (NoArg modcopyOpt) (boolOpt modcopy) "use modified copy rule"+ , MyOpt [] ["nest"] (NoArg nestOpt) (boolOpt nest) "use nested tuples"+ , MyOpt [] ["syntaxmacro"] (NoArg smacroOpt) (boolOpt smacro) "experimental: generate syntax macro code (using knit catas)"+ , MyOpt ['o'] ["output"] (ReqArg outputOpt "file") outputOptGet "specify output file"+ , MyOpt ['v'] ["verbose"] (NoArg verboseOpt) (boolOpt verbose) "verbose error message format"+ , MyOpt ['h','?'] ["help"] (NoArg helpOpt) (boolOpt showHelp) "get (this) usage information"+ , MyOpt ['a'] ["all"] (NoArg allOpt) noOpt ("do everything (-" ++ allc ++ ")")+ , MyOpt ['P'] [""] (ReqArg searchPathOpt "search path") searchPathOptGet ("specify seach path")+ , MyOpt [] ["prefix"] (ReqArg prefixOpt "prefix") (stringOpt prefix) "set prefix for semantic functions"+ , MyOpt [] ["self"] (NoArg selfOpt) (boolOpt withSelf) "generate self attribute"+ , MyOpt [] ["cycle"] (NoArg cycleOpt) (boolOpt withCycle) "check for cyclic definitions"+ , MyOpt [] ["version"] (NoArg versionOpt) (boolOpt showVersion) "get version information"+ , MyOpt ['O'] ["optimize"] (NoArg optimizeOpt) noOpt "optimize generated code (--visit --case)"+ , MyOpt [] ["visit"] (NoArg visitOpt) (boolOpt visit) "try generating visit functions"+ , MyOpt [] ["seq"] (NoArg seqOpt) (boolOpt withSeq) "force evaluation using function seq (visit functions only)"+ , MyOpt [] ["unbox"] (NoArg unboxOpt) (boolOpt unbox) "use unboxed tuples"+ , MyOpt [] ["bangpats"] (NoArg bangpatsOpt) (boolOpt bangpats) "use bang patterns (visit functions only)"+ , MyOpt [] ["case"] (NoArg casesOpt) (boolOpt cases) "Use nested cases instead of let (visit functions only)"+ , MyOpt [] ["strictcase"] (NoArg strictCasesOpt) (boolOpt strictCases) "Force evaluation of the scrutinee of cases (in generated code, visit functions only)"+ , MyOpt [] ["strictercase"] (NoArg stricterCasesOpt) (boolOpt stricterCases) "Force evaluation of all variables bound by a case statement (in generated code)"+ , MyOpt [] ["strictsem"] (NoArg strictSemOpt) (boolOpt strictSems) "Force evaluation of sem-function arguments (in generated code)"+ , MyOpt [] ["localcps"] (NoArg localCpsOpt) (boolOpt localCps) "Apply a local CPS transformation (in generated code, visit functions only)"+ , MyOpt [] ["splitsems"] (NoArg splitSemsOpt) (boolOpt splitSems) "Split semantic functions into smaller pieces"+ , MyOpt [] ["Werrors"] (NoArg werrorsOpt) (boolOpt werrors) "Turn warnings into fatal errors"+ , MyOpt [] ["Wignore"] (NoArg wignoreOpt) (boolOpt wignore) "Ignore warnings"+ , MyOpt [] ["Wmax"] (ReqArg wmaxErrsOpt "<max errs reported>") wmaxErrsOptGet "Sets the maximum number of errors that are reported"+ , MyOpt [] ["dumpgrammar"] (NoArg dumpgrammarOpt) (boolOpt dumpgrammar) "Dump internal grammar representation (in generated code)"+ , MyOpt [] ["dumpcgrammar"] (NoArg dumpcgrammarOpt) (boolOpt dumpcgrammar)"Dump internal cgrammar representation (in generated code)"+ , MyOpt [] ["gentraces"] (NoArg genTracesOpt) (boolOpt genTraces) "Generate trace expressions (in generated code)"+ , MyOpt [] ["genusetraces"] (NoArg genUseTracesOpt) (boolOpt genUseTraces)"Generate trace expressions at attribute use sites (in generated code)"+ , MyOpt [] ["gencostcentres"] (NoArg genCostCentresOpt) (boolOpt genCostCentres) "Generate cost centre pragmas (in generated code)"+ , MyOpt [] ["genlinepragmas"] (NoArg genLinePragmasOpt) (boolOpt genLinePragmas) "Generate GHC LINE pragmas (in generated code)"+ , MyOpt [] ["sepsemmods"] (NoArg sepSemModsOpt) (boolOpt sepSemMods) "Generate separate modules for semantic functions (in generated code)"+ , MyOpt ['M'] ["genfiledeps"] (NoArg genFileDepsOpt) (boolOpt genFileDeps) "Generate a list of dependencies on the input AG files"+ , MyOpt [] ["genvisage"] (NoArg genVisageOpt) (boolOpt genvisage) "Generate output for the AG visualizer Visage"+ , MyOpt [] ["aspectag"] (NoArg genAspectAGOpt) (boolOpt genAspectAG) "Generate AspectAG file"+ , MyOpt [] ["nogroup"] (ReqArg noGroupOpt "attributes") noGroupOptGet "specify the attributes that won't be grouped in AspectAG"+ , MyOpt [] ["extends"] (ReqArg extendsOpt "module") (mbStringOpt extends) "specify a module to be extended"+ , MyOpt [] ["genattrlist"] (NoArg genAttrListOpt) (boolOpt genAttributeList) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)"+ , MyOpt [] ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") (mbStringOpt forceIrrefutables) "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set"+ , MyOpt [] ["uniquedispenser"] (ReqArg uniqueDispenserOpt "name") (stringOpt uniqueDispenser) "The Haskell function to call in the generated code"+ , MyOpt [] ["lckeywords"] (NoArg lcKeywordsOpt) (boolOpt lcKeywords) "Use lowercase keywords (sem, attr) instead of the uppercase ones (SEM, ATTR)"+ , MyOpt [] ["doublecolons"] (NoArg doubleColonsOpt) (boolOpt doubleColons)"Use double colons for type signatures instead of single colons"+ , MyOpt ['H'] ["haskellsyntax"] (NoArg haskellSyntaxOpt) noOpt "Use Haskell like syntax (equivalent to --lckeywords and --doublecolons --genlinepragmas)"+ , MyOpt [] ["reference"] (NoArg referenceOpt) (boolOpt reference) "Use reference attributes"+ , MyOpt [] ["monadic"] (NoArg monadicOpt) (boolOpt monadic) "Experimental: generate monadic code"+ , MyOpt [] ["ocaml"] (NoArg ocamlOpt) (boolOpt ocaml) "Experimental: generate Ocaml code"+ , MyOpt [] ["breadthfirst"] (NoArg breadthfirstOpt) (boolOpt breadthFirst)"Experimental: generate breadth-first code"+ , MyOpt [] ["breadthfirst-strict"] (NoArg breadthfirstStrictOpt) (boolOpt breadthFirstStrict) "Experimental: outermost breadth-first evaluator is strict instead of lazy"+ , MyOpt [] ["visitcode"] (NoArg visitorsOutputOpt) (boolOpt visitorsOutput) "Experimental: generate visitors code"+ , MyOpt [] ["kennedywarren"] (NoArg kennedyWarrenOpt) (boolOpt kennedyWarren) "Experimental: use Kennedy-Warren's algorithm for ordering"+ , MyOpt [] ["statistics"] (ReqArg statisticsOpt "FILE to append to") (mbStringOpt statsFile) "Append statistics to FILE"+ , MyOpt [] ["checkParseRhs"] (NoArg parseHsRhsOpt) (boolOpt checkParseRhs) "Parse RHS of rules with Haskell parser"+ , MyOpt [] ["checkParseTys"] (NoArg parseHsTpOpt) (boolOpt checkParseTy) "Parse types of attrs with Haskell parser"+ , MyOpt [] ["checkParseBlocks"] (NoArg parseHsBlockOpt) (boolOpt checkParseBlock) "Parse blocks with Haskell parser"+ , MyOpt [] ["checkParseHaskell"] (NoArg parseHsOpt) noOpt "Parse Haskell code (recognizer)"+ , MyOpt [] ["nocatas"] (ReqArg nocatasOpt "list of nonterms") nocatasOptGet "Nonterminals not to generate catas for"+ , MyOpt [] ["nooptimize"] (NoArg noOptimizeOpt) (boolOpt noOptimizations) "Disable optimizations"+ , MyOpt [] ["parallel"] (NoArg parallelOpt) (boolOpt parallelInvoke) "Generate a parallel evaluator (if possible)"+ , MyOpt [] ["monadicwrapper"] (NoArg monadicWrappersOpt) (boolOpt monadicWrappers) "Generate monadic wrappers"+ , MyOpt [] ["helpinlining"] (NoArg helpInliningOpt) (boolOpt helpInlining) "Generate inline directives for GHC"+ , MyOpt [] ["dummytokenvisit"] (NoArg dummyTokenVisitOpt) (boolOpt dummyTokenVisit) "Add an additional dummy parameter to visit functions"+ , MyOpt [] ["tupleasdummytoken"] (NoArg tupleAsDummyTokenOpt) (boolOpt tupleAsDummyToken) "Use conventional tuples as dummy parameter instead of a RealWorld state token"+ , MyOpt [] ["stateasdummytoken"] (NoArg stateAsDummyTokenOpt) noOpt "Use RealWorld state token as dummy parameter instead of conventional tuples (default)"+ , MyOpt [] ["strictdummytoken"] (NoArg strictDummyTokenOpt) (boolOpt strictDummyToken) "Strictify the dummy token that makes states and rules functions"+ , MyOpt [] ["noperruletypesigs"] (NoArg noPerRuleTypeSigsOpt) (boolOpt noPerRuleTypeSigs) "Do not generate type sigs for attrs passed to rules"+ , MyOpt [] ["noperstatetypesigs"] (NoArg noPerStateTypeSigsOpt) (boolOpt noPerStateTypeSigs) "Do not generate type sigs for attrs saved in node states"+ , MyOpt [] ["noeagerblackholing"] (NoArg noEagerBlackholingOpt) (boolOpt noEagerBlackholing) "Do not automatically add the eager blackholing feature for parallel programs"+ , MyOpt [] ["noperrulecostcentres"] (NoArg noPerRuleCostCentresOpt) (boolOpt noPerRuleCostCentres) "Do not generate cost centres for rules"+ , MyOpt [] ["nopervisitcostcentres"] (NoArg noPerVisitCostCentresOpt) (boolOpt noPerVisitCostCentres) "Do not generate cost centres for visits"+ , MyOpt [] ["noinlinepragmas"] (NoArg noInlinePragmasOpt) (boolOpt noInlinePragmas) "Definitely not generate inline directives"+ , MyOpt [] ["aggressiveinlinepragmas"] (NoArg aggressiveInlinePragmasOpt) (boolOpt aggressiveInlinePragmas) "Generate more aggressive inline directives"+ , MyOpt [] ["latehigherorderbinding"] (NoArg lateHigherOrderBindingOpt) (boolOpt lateHigherOrderBinding) "Generate an attribute and wrapper for late binding of higher-order attributes"+ ]++-- For compatibility+options :: [OptDescr (Options -> Options)]+options = map fromMyOpt allOptions++allc = "dcfsprm"++data ModuleHeader = NoName+ | Name String+ | Default deriving (Eq, Show)++data Options = Options{ moduleName :: ModuleHeader+ , dataTypes :: Bool+ , dataRecords :: Bool+ , strictData :: Bool+ , strictWrap :: Bool+ , folds :: Bool+ , semfuns :: Bool+ , typeSigs :: Bool+ , attrInfo :: Bool+ , rename :: Bool+ , wrappers :: Bool+ , modcopy :: Bool+ , newtypes :: Bool+ , nest :: Bool+ , smacro :: Bool+ , outputFiles :: [String]+ , searchPath :: [String]+ , verbose :: Bool+ , prefix :: String+ , withSelf :: Bool+ , withCycle :: Bool+ , showHelp :: Bool+ , showVersion :: Bool+ , visit :: Bool+ , withSeq :: Bool+ , unbox :: Bool+ , bangpats :: Bool+ , cases :: Bool+ , strictCases :: Bool+ , stricterCases :: Bool+ , strictSems :: Bool+ , localCps :: Bool+ , splitSems :: Bool+ , werrors :: Bool+ , wignore :: Bool+ , wmaxerrs :: Int+ , dumpgrammar :: Bool+ , dumpcgrammar :: Bool+ , sepSemMods :: Bool+ , genFileDeps :: Bool+ , genLinePragmas :: Bool+ , genvisage :: Bool+ , genAspectAG :: Bool+ , noGroup :: [String]+ , extends :: Maybe String+ , genAttributeList :: Bool+ , forceIrrefutables :: Maybe String+ , uniqueDispenser :: String+ , lcKeywords :: Bool+ , doubleColons :: Bool+ , monadic :: Bool+ , ocaml :: Bool+ , visitorsOutput :: Bool+ , statsFile :: Maybe String+ , breadthFirst :: Bool+ , breadthFirstStrict :: Bool+ , checkParseRhs :: Bool+ , checkParseTy :: Bool+ , checkParseBlock :: Bool+ , nocatas :: Set NontermIdent+ , noOptimizations :: Bool+ , reference :: Bool++ -- KW code path+ , kennedyWarren :: Bool+ , parallelInvoke :: Bool+ , tupleAsDummyToken :: Bool -- use the empty tuple as dummy token instead of State# RealWorld (Lambda State Hack GHC?)+ , dummyTokenVisit :: Bool -- add a dummy argument/pass dummy extra token to visits (should not really have an effect ... Lambda State Hack GHC?)+ , strictDummyToken :: Bool -- make the dummy token strict (to prevent its removal -- should not really have an effect)+ , noPerRuleTypeSigs :: Bool -- do not print type signatures for attributes of rules+ , noPerStateTypeSigs :: Bool -- do not print type signatures for attributes contained in the state+ , noEagerBlackholing :: Bool -- disable the use of eager black holing in the parallel evaluator code+ , lateHigherOrderBinding :: Bool -- generate code to allow late binding of higher-order children semantics+ , monadicWrappers :: Bool++ -- tracing+ , genTraces :: Bool+ , genUseTraces :: Bool+ , genCostCentres :: Bool+ , noPerRuleCostCentres :: Bool+ , noPerVisitCostCentres :: Bool++ -- inline pragma generation+ , helpInlining :: Bool+ , noInlinePragmas :: Bool+ , aggressiveInlinePragmas :: Bool+ } deriving (Eq, Show)++noOptions = Options { moduleName = NoName+ , dataTypes = False+ , dataRecords = False+ , strictData = False+ , strictWrap = False+ , folds = False+ , semfuns = False+ , typeSigs = False+ , attrInfo = False+ , rename = False+ , wrappers = False+ , modcopy = False+ , newtypes = False+ , nest = False+ , smacro = False+ , outputFiles = []+ , searchPath = []+ , verbose = False+ , showHelp = False+ , showVersion = False+ , prefix = "sem_"+ , withSelf = False+ , withCycle = False+ , visit = False+ , withSeq = False+ , unbox = False+ , bangpats = False+ , cases = False+ , strictCases = False+ , stricterCases = False+ , strictSems = False+ , localCps = False+ , splitSems = False+ , werrors = False+ , wignore = False+ , wmaxerrs = 99999+ , dumpgrammar = False+ , dumpcgrammar = False+ , sepSemMods = False+ , genFileDeps = False+ , genLinePragmas = False+ , genvisage = False+ , genAspectAG = False+ , noGroup = []+ , extends = Nothing+ , genAttributeList = False+ , forceIrrefutables = Nothing+ , uniqueDispenser = "nextUnique"+ , lcKeywords = False+ , doubleColons = False+ , monadic = False+ , ocaml = False+ , visitorsOutput = False+ , statsFile = Nothing+ , breadthFirst = False+ , breadthFirstStrict = False+ , checkParseRhs = False+ , checkParseTy = False+ , checkParseBlock = False+ , nocatas = Set.empty+ , noOptimizations = False+ , reference = False++ -- defaults for the KW-code path+ , kennedyWarren = False+ , parallelInvoke = False+ , tupleAsDummyToken = True+ , dummyTokenVisit = False+ , strictDummyToken = False+ , noPerRuleTypeSigs = False+ , noPerStateTypeSigs = False+ , noEagerBlackholing = False+ , lateHigherOrderBinding = False+ , monadicWrappers = False++ -- defaults for tracing+ , genTraces = False+ , genUseTraces = False+ , genCostCentres = False+ , noPerRuleCostCentres = False+ , noPerVisitCostCentres = False++ -- defaults for inline pragma generation+ , helpInlining = False+ , noInlinePragmas = False+ , aggressiveInlinePragmas = False+ }++--Options -> String -> [String]+moduleOpt nm opts = opts{moduleName = maybe Default Name nm}+moduleOptGet opts nm = case moduleName opts of+ NoName -> []+ Name s -> [nm,s]+ Default -> [nm]+dataOpt opts = opts{dataTypes = True}+dataRecOpt opts = opts{dataRecords = True}+strictDataOpt opts = opts{strictData = True}+strictWrapOpt opts = opts{strictWrap = True}+cataOpt opts = opts{folds = True}+semfunsOpt opts = opts{semfuns = True}+signaturesOpt opts = opts{typeSigs = True}+prettyOpt opts = opts{attrInfo = True}+renameOpt opts = opts{rename = True}+wrappersOpt opts = opts{wrappers = True}+modcopyOpt opts = opts{modcopy = True}+newtypesOpt opts = opts{newtypes = True}+nestOpt opts = opts{nest = True}+smacroOpt opts = opts{smacro = True}+verboseOpt opts = opts{verbose = True}+helpOpt opts = opts{showHelp = True}+versionOpt opts = opts{showVersion = True}+prefixOpt pre opts = opts{prefix = pre }+selfOpt opts = opts{withSelf = True}+cycleOpt opts = opts{withCycle = True}+visitOpt opts = opts{visit = True, withCycle = True}+seqOpt opts = opts{withSeq = True}+unboxOpt opts = opts{unbox = True}+bangpatsOpt opts = opts{bangpats = True}+casesOpt opts = opts{cases = True}+strictCasesOpt opts = opts{strictCases = True}+stricterCasesOpt opts = opts{strictCases = True, stricterCases = True}+strictSemOpt opts = opts{strictSems = True}+localCpsOpt opts = opts{localCps = True}+splitSemsOpt opts = opts{splitSems = True}+werrorsOpt opts = opts{werrors = True}+wignoreOpt opts = opts{wignore = True}+wmaxErrsOpt n opts = opts{wmaxerrs = read n}+wmaxErrsOptGet opts nm = if wmaxerrs opts /= wmaxerrs noOptions+ then [nm,show (wmaxerrs opts)]+ else []+dumpgrammarOpt opts = opts{dumpgrammar = True}+dumpcgrammarOpt opts = opts{dumpcgrammar = True}+genTracesOpt opts = opts{genTraces = True}+genUseTracesOpt opts = opts{genUseTraces = True}+genCostCentresOpt opts = opts{genCostCentres = True}+sepSemModsOpt opts = opts{sepSemMods = True}+genFileDepsOpt opts = opts{genFileDeps = True}+genLinePragmasOpt opts = opts{genLinePragmas = True}+genVisageOpt opts = opts{genvisage = True }+genAspectAGOpt opts = opts{genAspectAG = True}++dummyTokenVisitOpt opts = opts { dummyTokenVisit = True }+tupleAsDummyTokenOpt opts = opts { tupleAsDummyToken = True }+stateAsDummyTokenOpt opts = opts { tupleAsDummyToken = False }+strictDummyTokenOpt opts = opts { strictDummyToken = True }+noPerRuleTypeSigsOpt opts = opts { noPerRuleTypeSigs = True }+noPerStateTypeSigsOpt opts = opts { noPerStateTypeSigs = True }+noEagerBlackholingOpt opts = opts { noEagerBlackholing = True }+noPerRuleCostCentresOpt opts = opts { noPerRuleCostCentres = True }+noPerVisitCostCentresOpt opts = opts { noPerVisitCostCentres = True }+helpInliningOpt opts = opts { helpInlining = True }+noInlinePragmasOpt opts = opts { noInlinePragmas = True }+aggressiveInlinePragmasOpt opts = opts { aggressiveInlinePragmas = True }+lateHigherOrderBindingOpt opts = opts { lateHigherOrderBinding = True }+monadicWrappersOpt opts = opts { monadicWrappers = True }+referenceOpt opts = opts { reference = True }++noGroupOpt att opts = opts{noGroup = extract att ++ noGroup opts}+ where extract s = case dropWhile isSeparator s of+ "" -> []+ s' -> w : extract s''+ where (w, s'') =+ break isSeparator s'+ isSeparator x = x == ':'+noGroupOptGet opts nm = if null (noGroup opts)+ then []+ else [nm, intercalate ":" (noGroup opts)]++extendsOpt m opts = opts{extends = Just m }++genAttrListOpt opts = opts { genAttributeList = True }+forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm }+uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm }+lcKeywordsOpt opts = opts { lcKeywords = True }+doubleColonsOpt opts = opts { doubleColons = True }+haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt+monadicOpt opts = opts { monadic = True }+parallelOpt opts = opts { parallelInvoke = True }+ocamlOpt opts = opts { ocaml = True }+visitorsOutputOpt opts = opts { visitorsOutput = True }+statisticsOpt nm opts = opts { statsFile = Just nm }+breadthfirstOpt opts = opts { breadthFirst = True }+breadthfirstStrictOpt opts = opts { breadthFirstStrict = True }+parseHsRhsOpt opts = opts { checkParseRhs = True }+parseHsTpOpt opts = opts { checkParseTy = True }+parseHsBlockOpt opts = opts { checkParseBlock = True }+parseHsOpt = parseHsRhsOpt . parseHsTpOpt . parseHsBlockOpt+kennedyWarrenOpt opts = opts { kennedyWarren = True }+noOptimizeOpt opts = opts { noOptimizations = True }+nocatasOpt str opts = opts { nocatas = set `Set.union` nocatas opts } where+ set = Set.fromList ids+ ids = map identifier lst+ lst = split str++ split str | null p = []+ | otherwise = p : split ps+ where (p,ps) = break (== ',') str+nocatasOptGet opts nm = if Set.null (nocatas opts)+ then []+ else [nm, intercalate "," . map getName . Set.toList . nocatas $ opts]++outputOpt file opts = opts{outputFiles = file : outputFiles opts}+outputOptGet opts nm = concat [ [nm, file] | file <- outputFiles opts]+searchPathOpt path opts = opts{searchPath = extract path ++ searchPath opts}+ where extract xs = let (p,ps) = break (\x -> x == ';' || x == ':') xs+ in if null p then [] else p : extract ps+searchPathOptGet opts nm = if null (searchPath opts)+ then []+ else [nm, intercalate ":" (searchPath opts)]+allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt+optimizeOpt = visitOpt . casesOpt++condDisableOptimizations opts+ | noOptimizations opts =+ opts { strictData = False+ , strictWrap = False+ , withSeq = False+ , unbox = False+ , bangpats = False+ , cases = False+ , strictCases = False+ , stricterCases = False+ , strictSems = False+ , localCps = False+ , splitSems = False+ , breadthFirstStrict = False+ }+ | otherwise = opts+ +-- | Use all parsed options to generate real options+constructOptions :: [Options -> Options] -> Options+constructOptions = foldl (flip ($)) noOptions++-- | Create Options type from string arguments+getOptions :: [String] -> (Options,[String],[String])+getOptions args = let (flags,files,errors) = getOpt Permute options args+ appliedOpts = constructOptions flags+ finOpts = condDisableOptimizations appliedOpts+ in (finOpts,files,errors)++-- | Convert options back to commandline string+optionsToString :: Options -> [String]+optionsToString opt = concatMap (serializeOption opt) allOptions++-- | Combine 2 sets of options+combineOptions :: Options -> Options -> Options+combineOptions o1 o2 = let str1 = optionsToString o1+ str2 = optionsToString o2+ (opt,_,_) = getOptions (str1 ++ str2)+ in opt
src/Ag.hs view
@@ -1,9 +1,9 @@-module Main where+module Ag (uuagcLib, uuagcExe) where import System.Environment (getArgs, getProgName) import System.Exit (exitFailure) import System.Console.GetOpt (usageInfo)-import Data.List (isSuffixOf,nub)+import Data.List (isSuffixOf,nub,partition) import Control.Monad (zipWithM_) import Data.Maybe import System.FilePath@@ -44,9 +44,28 @@ import CommonTypes import ATermWrite +-- Library version+import System.Exit (ExitCode(..)) -main :: IO ()-main+uuagcLib :: [String] -> FilePath -> IO (ExitCode, [FilePath])+uuagcLib args file+ = do let (flags,_,errs) = getOptions args+ if showVersion flags || showHelp flags+ then do putStrLn "Cannot display help or version in library mode."+ return (ExitFailure 1, [])+ else if (not.null) errs+ then do putStrLn "One or more errors occured:"+ mapM_ putStrLn errs+ return (ExitFailure 2, [])+ else if genFileDeps flags+ then do deps <- getDeps flags [file]+ return (ExitSuccess, deps)+ else do compile flags file (head $ outputFiles flags++repeat "")+ return (ExitSuccess, [])++-- Executable version+uuagcExe :: IO ()+uuagcExe = do args <- getArgs progName <- getProgName @@ -112,7 +131,7 @@ errorList = if null parseErrorList then mainErrors- ++ if null mainErrors || null (filter (PrErr.isError flags') mainErrors)+ ++ if null (filter (PrErr.isError flags') mainErrors) then furtherErrors else [] else [head parseErrorList]@@ -193,7 +212,7 @@ then putStr $ "\nPlus " ++ show additionalWarnings ++ " more warning" ++ pluralS additionalWarnings ++ ".\n" else return () - if not (null fatalErrorList)+ if not (null errorsToStopOn) -- note: this may already run quite a part of the compilation... then exitFailure else do@@ -331,8 +350,8 @@ Other ms -> ms errorsToFront :: Options -> [Error] -> [Error]-errorsToFront flags mesgs = filter (PrErr.isError flags) mesgs ++ filter (not.(PrErr.isError flags)) mesgs-+errorsToFront flags mesgs = errs ++ warnings+ where (errs,warnings) = partition (PrErr.isError flags) mesgs moduleHeader :: Options -> String -> String moduleHeader flags input@@ -382,12 +401,17 @@ reportDeps :: Options -> [String] -> IO () reportDeps flags files+ = do deps <- getDeps flags files+ mapM_ putStrLn deps++getDeps :: Options -> [String] -> IO [String]+getDeps flags files = do results <- mapM (depsAG flags (searchPath flags)) files let (fs, mesgs) = foldr combine ([],[]) results let errs = take (min 1 (wmaxerrs flags)) (map message2error mesgs) let ppErrs = PrErr.wrap_Errors (PrErr.sem_Errors errs) PrErr.Inh_Errors {PrErr.options_Inh_Errors = flags, PrErr.dups_Inh_Errors = []} if null errs- then mapM_ putStrLn fs+ then return fs else do putStr . formatErrors $ PrErr.pp_Syn_Errors ppErrs exitFailure where
src/CommonTypes.hs view
@@ -1,6 +1,7 @@-module CommonTypes where+module CommonTypes (module Options, module CommonTypes) where import Pretty+import Options import UU.Scanner.Position(Pos,noPos) import qualified Data.Map as Map import Data.Map(Map)@@ -18,17 +19,6 @@ | BlockOther deriving (Eq, Ord, Show) -data Identifier = Ident { getName::String, getPos::Pos }--instance Eq Identifier where- Ident x _ == Ident y _ = x == y--instance Ord Identifier where- compare (Ident x _) (Ident y _) = compare x y--instance Show Identifier where- show ident = getName ident- instance PP Identifier where pp = text . getName @@ -73,7 +63,6 @@ type ContextMap = Map NontermIdent ClassContext type QuantMap = Map NontermIdent [String] type Strings = [String]-type NontermIdent = Identifier type ConstructorIdent = Identifier type AttrOrderMap = Map NontermIdent (Map ConstructorIdent (Set Dependency)) type VisitIdentifier = Int@@ -88,7 +77,6 @@ , [(Identifier,Identifier)] ) -identifier x = Ident x noPos nullIdent = identifier "" _LHS = identifier "lhs" _SELF = identifier "SELF"
− src/Options.hs
@@ -1,402 +0,0 @@-module Options where--import System.Console.GetOpt-import CommonTypes-import Data.Set(Set)-import qualified Data.Set as Set--options :: [OptDescr (Options -> Options)]-options = [ Option ['m'] [] (NoArg (moduleOpt Nothing)) "generate default module header"- , Option [] ["module"] (OptArg moduleOpt "name") "generate module header, specify module name"- , Option ['d'] ["data"] (NoArg dataOpt) "generate data type definition"- , Option [] ["datarecords"] (NoArg dataRecOpt) "generate record data types"- , Option [] ["strictdata"] (NoArg strictDataOpt) "generate strict data fields (when data is generated)"- , Option [] ["strictwrap"] (NoArg strictWrapOpt) "generate strict wrap fields for WRAPPER generated data"- , Option ['c'] ["catas"] (NoArg cataOpt) "generate catamorphisms"- , Option ['f'] ["semfuns"] (NoArg semfunsOpt) "generate semantic functions"- , Option ['s'] ["signatures"] (NoArg signaturesOpt) "generate signatures for semantic functions"- , Option [] ["newtypes"] (NoArg newtypesOpt) "use newtypes instead of type synonyms"- , Option ['p'] ["pretty"] (NoArg prettyOpt) "generate pretty printed list of attributes"- , Option ['w'] ["wrappers"] (NoArg wrappersOpt) "generate wappers for semantic domains"- , Option ['r'] ["rename"] (NoArg renameOpt) "rename data constructors"- , Option [] ["modcopy"] (NoArg modcopyOpt) "use modified copy rule"- , Option [] ["nest"] (NoArg nestOpt) "use nested tuples"- , Option [] ["syntaxmacro"] (NoArg smacroOpt) "experimental: generate syntax macro code (using knit catas)"- , Option ['o'] ["output"] (ReqArg outputOpt "file") "specify output file"- , Option ['v'] ["verbose"] (NoArg verboseOpt) "verbose error message format"- , Option ['h','?'] ["help"] (NoArg helpOpt) "get (this) usage information"- , Option ['a'] ["all"] (NoArg allOpt) ("do everything (-" ++ allc ++ ")")- , Option ['P'] [""] (ReqArg searchPathOpt "search path") ("specify seach path")- , Option [] ["prefix"] (ReqArg prefixOpt "prefix") "set prefix for semantic functions"- , Option [] ["self"] (NoArg selfOpt) "generate self attribute"- , Option [] ["cycle"] (NoArg cycleOpt) "check for cyclic definitions"- , Option [] ["version"] (NoArg versionOpt) "get version information"- , Option ['O'] ["optimize"] (NoArg optimizeOpt) "optimize generated code (--visit --case)"- , Option [] ["visit"] (NoArg visitOpt) "try generating visit functions"- , Option [] ["seq"] (NoArg seqOpt) "force evaluation using function seq (visit functions only)"- , Option [] ["unbox"] (NoArg unboxOpt) "use unboxed tuples"- , Option [] ["bangpats"] (NoArg bangpatsOpt) "use bang patterns (visit functions only)"- , Option [] ["case"] (NoArg casesOpt) "Use nested cases instead of let (visit functions only)"- , Option [] ["strictcase"] (NoArg strictCasesOpt) "Force evaluation of the scrutinee of cases (in generated code, visit functions only)"- , Option [] ["strictercase"] (NoArg stricterCasesOpt) "Force evaluation of all variables bound by a case statement (in generated code)"- , Option [] ["strictsem"] (NoArg strictSemOpt) "Force evaluation of sem-function arguments (in generated code)"- , Option [] ["localcps"] (NoArg localCpsOpt) "Apply a local CPS transformation (in generated code, visit functions only)"- , Option [] ["splitsems"] (NoArg splitSemsOpt) "Split semantic functions into smaller pieces"- , Option [] ["Werrors"] (NoArg werrorsOpt) "Turn warnings into fatal errors"- , Option [] ["Wignore"] (NoArg wignoreOpt) "Ignore warnings"- , Option [] ["Wmax"] (ReqArg wmaxErrsOpt "<max errs reported>") "Sets the maximum number of errors that are reported"- , Option [] ["dumpgrammar"] (NoArg dumpgrammarOpt) "Dump internal grammar representation (in generated code)"- , Option [] ["dumpcgrammar"] (NoArg dumpcgrammarOpt) "Dump internal cgrammar representation (in generated code)"- , Option [] ["gentraces"] (NoArg genTracesOpt) "Generate trace expressions (in generated code)"- , Option [] ["genusetraces"] (NoArg genUseTracesOpt) "Generate trace expressions at attribute use sites (in generated code)"- , Option [] ["gencostcentres"] (NoArg genCostCentresOpt) "Generate cost centre pragmas (in generated code)"- , Option [] ["genlinepragmas"] (NoArg genLinePragmasOpt) "Generate GHC LINE pragmas (in generated code)"- , Option [] ["sepsemmods"] (NoArg sepSemModsOpt) "Generate separate modules for semantic functions (in generated code)"- , Option ['M'] ["genfiledeps"] (NoArg genFileDepsOpt) "Generate a list of dependencies on the input AG files"- , Option [] ["genvisage"] (NoArg genVisageOpt) "Generate output for the AG visualizer Visage"- , Option [] ["aspectag"] (NoArg genAspectAGOpt) "Generate AspectAG file"- , Option [] ["nogroup"] (ReqArg noGroupOpt "attributes") "specify the attributes that won't be grouped in AspectAG"- , Option [] ["extends"] (ReqArg extendsOpt "module") "specify a module to be extended"- , Option [] ["genattrlist"] (NoArg genAttrListOpt) "Generate a list of all explicitly defined attributes (outside irrefutable patterns)"- , Option [] ["forceirrefutable"] (OptArg forceIrrefutableOpt "file") "Force a set of explicitly defined attributes to be irrefutable, specify file containing the attribute set"- , Option [] ["uniquedispenser"] (ReqArg uniqueDispenserOpt "name") "The Haskell function to call in the generated code"- , Option [] ["lckeywords"] (NoArg lcKeywordsOpt) "Use lowercase keywords (sem, attr) instead of the uppercase ones (SEM, ATTR)"- , Option [] ["doublecolons"] (NoArg doubleColonsOpt) "Use double colons for type signatures instead of single colons"- , Option ['H'] ["haskellsyntax"] (NoArg haskellSyntaxOpt) "Use Haskell like syntax (equivalent to --lckeywords and --doublecolons --genlinepragmas)"- , Option [] ["monadic"] (NoArg monadicOpt) "Experimental: generate monadic code"- , Option [] ["ocaml"] (NoArg ocamlOpt) "Experimental: generate Ocaml code"- , Option [] ["breadthfirst"] (NoArg breadthfirstOpt) "Experimental: generate breadth-first code"- , Option [] ["breadthfirst-strict"] (NoArg breadthfirstStrictOpt) "Experimental: outermost breadth-first evaluator is strict instead of lazy"- , Option [] ["visitcode"] (NoArg visitorsOutputOpt) "Experimental: generate visitors code"- , Option [] ["kennedywarren"] (NoArg kennedyWarrenOpt) "Experimental: use Kennedy-Warren's algorithm for ordering"- , Option [] ["statistics"] (ReqArg statisticsOpt "FILE to append to") "Append statistics to FILE"- , Option [] ["checkParseRhs"] (NoArg parseHsRhsOpt) "Parse RHS of rules with Haskell parser"- , Option [] ["checkParseTys"] (NoArg parseHsTpOpt) "Parse types of attrs with Haskell parser"- , Option [] ["checkParseBlocks"] (NoArg parseHsBlockOpt) "Parse blocks with Haskell parser"- , Option [] ["checkParseHaskell"] (NoArg parseHsOpt) "Parse Haskell code (recognizer)"- , Option [] ["nocatas"] (ReqArg nocatasOpt "list of nonterms") "Nonterminals not to generate catas for"- , Option [] ["nooptimize"] (NoArg noOptimizeOpt) "Disable optimizations"- , Option [] ["parallel"] (NoArg parallelOpt) "Generate a parallel evaluator (if possible)"- , Option [] ["monadicwrapper"] (NoArg monadicWrappersOpt) "Generate monadic wrappers"-- , Option [] ["helpinlining"] (NoArg helpInliningOpt) "Generate inline directives for GHC"- , Option [] ["dummytokenvisit"] (NoArg dummyTokenVisitOpt) "Add an additional dummy parameter to visit functions"- , Option [] ["tupleasdummytoken"] (NoArg tupleAsDummyTokenOpt) "Use conventional tuples as dummy parameter instead of a RealWorld state token"- , Option [] ["stateasdummytoken"] (NoArg stateAsDummyTokenOpt) "Use RealWorld state token as dummy parameter instead of conventional tuples (default)"- , Option [] ["strictdummytoken"] (NoArg strictDummyTokenOpt) "Strictify the dummy token that makes states and rules functions"- , Option [] ["noperruletypesigs"] (NoArg noPerRuleTypeSigsOpt) "Do not generate type sigs for attrs passed to rules"- , Option [] ["noperstatetypesigs"] (NoArg noPerStateTypeSigsOpt) "Do not generate type sigs for attrs saved in node states"- , Option [] ["noeagerblackholing"] (NoArg noEagerBlackholingOpt) "Do not automatically add the eager blackholing feature for parallel programs"- , Option [] ["noperrulecostcentres"] (NoArg noPerRuleCostCentresOpt) "Do not generate cost centres for rules"- , Option [] ["nopervisitcostcentres"] (NoArg noPerVisitCostCentresOpt) "Do not generate cost centres for visits"- , Option [] ["noinlinepragmas"] (NoArg noInlinePragmasOpt) "Definitely not generate inline directives"- , Option [] ["aggressiveinlinepragmas"] (NoArg aggressiveInlinePragmasOpt) "Generate more aggressive inline directives"- , Option [] ["latehigherorderbinding"] (NoArg lateHigherOrderBindingOpt) "Generate an attribute and wrapper for late binding of higher-order attributes"- ]--allc = "dcfsprm"--data Options = Options{ moduleName :: ModuleHeader- , dataTypes :: Bool- , dataRecords :: Bool- , strictData :: Bool- , strictWrap :: Bool- , folds :: Bool- , semfuns :: Bool- , typeSigs :: Bool- , attrInfo :: Bool- , rename :: Bool- , wrappers :: Bool- , modcopy :: Bool- , newtypes :: Bool- , nest :: Bool- , smacro :: Bool- , outputFiles :: [String]- , searchPath :: [String]- , verbose :: Bool- , prefix :: String- , withSelf :: Bool- , withCycle :: Bool- , showHelp :: Bool- , showVersion :: Bool- , visit :: Bool- , withSeq :: Bool- , unbox :: Bool- , bangpats :: Bool- , cases :: Bool- , strictCases :: Bool- , stricterCases :: Bool- , strictSems :: Bool- , localCps :: Bool- , splitSems :: Bool- , werrors :: Bool- , wignore :: Bool- , wmaxerrs :: Int- , dumpgrammar :: Bool- , dumpcgrammar :: Bool- , sepSemMods :: Bool- , genFileDeps :: Bool- , genLinePragmas :: Bool- , genvisage :: Bool- , genAspectAG :: Bool- , noGroup :: [String]- , extends :: Maybe String- , genAttributeList :: Bool- , forceIrrefutables :: Maybe String- , uniqueDispenser :: String- , lcKeywords :: Bool- , doubleColons :: Bool- , monadic :: Bool- , ocaml :: Bool- , visitorsOutput :: Bool- , statsFile :: Maybe String- , breadthFirst :: Bool- , breadthFirstStrict :: Bool- , checkParseRhs :: Bool- , checkParseTy :: Bool- , checkParseBlock :: Bool- , nocatas :: Set NontermIdent-- , noOptimizations :: Bool-- -- KW code path- , kennedyWarren :: Bool- , parallelInvoke :: Bool- , tupleAsDummyToken :: Bool -- use the empty tuple as dummy token instead of State# RealWorld (Lambda State Hack GHC?)- , dummyTokenVisit :: Bool -- add a dummy argument/pass dummy extra token to visits (should not really have an effect ... Lambda State Hack GHC?)- , strictDummyToken :: Bool -- make the dummy token strict (to prevent its removal -- should not really have an effect)- , noPerRuleTypeSigs :: Bool -- do not print type signatures for attributes of rules- , noPerStateTypeSigs :: Bool -- do not print type signatures for attributes contained in the state- , noEagerBlackholing :: Bool -- disable the use of eager black holing in the parallel evaluator code- , lateHigherOrderBinding :: Bool -- generate code to allow late binding of higher-order children semantics- , monadicWrappers :: Bool-- -- tracing- , genTraces :: Bool- , genUseTraces :: Bool- , genCostCentres :: Bool- , noPerRuleCostCentres :: Bool- , noPerVisitCostCentres :: Bool-- -- inline pragma generation- , helpInlining :: Bool- , noInlinePragmas :: Bool- , aggressiveInlinePragmas :: Bool- } deriving Show-noOptions = Options { moduleName = NoName- , dataTypes = False- , dataRecords = False- , strictData = False- , strictWrap = False- , folds = False- , semfuns = False- , typeSigs = False- , attrInfo = False- , rename = False- , wrappers = False- , modcopy = False- , newtypes = False- , nest = False- , smacro = False- , outputFiles = []- , searchPath = []- , verbose = False- , showHelp = False- , showVersion = False- , prefix = "sem_"- , withSelf = False- , withCycle = False- , visit = False- , withSeq = False- , unbox = False- , bangpats = False- , cases = False- , strictCases = False- , stricterCases = False- , strictSems = False- , localCps = False- , splitSems = False- , werrors = False- , wignore = False- , wmaxerrs = 99999- , dumpgrammar = False- , dumpcgrammar = False- , sepSemMods = False- , genFileDeps = False- , genLinePragmas = False- , genvisage = False- , genAspectAG = False- , noGroup = []- , extends = Nothing- , genAttributeList = False- , forceIrrefutables = Nothing- , uniqueDispenser = "nextUnique"- , lcKeywords = False- , doubleColons = False- , monadic = False- , ocaml = False- , visitorsOutput = False- , statsFile = Nothing- , breadthFirst = False- , breadthFirstStrict = False- , checkParseRhs = False- , checkParseTy = False- , checkParseBlock = False- , nocatas = Set.empty- , noOptimizations = False-- -- defaults for the KW-code path- , kennedyWarren = False- , parallelInvoke = False- , tupleAsDummyToken = True- , dummyTokenVisit = False- , strictDummyToken = False- , noPerRuleTypeSigs = False- , noPerStateTypeSigs = False- , noEagerBlackholing = False- , lateHigherOrderBinding = False- , monadicWrappers = False-- -- defaults for tracing- , genTraces = False- , genUseTraces = False- , genCostCentres = False- , noPerRuleCostCentres = False- , noPerVisitCostCentres = False-- -- defaults for inline pragma generation- , helpInlining = False- , noInlinePragmas = False- , aggressiveInlinePragmas = False- }--moduleOpt nm opts = opts{moduleName = maybe Default Name nm}-dataOpt opts = opts{dataTypes = True}-dataRecOpt opts = opts{dataRecords = True}-strictDataOpt opts = opts{strictData = True}-strictWrapOpt opts = opts{strictWrap = True}-cataOpt opts = opts{folds = True}-semfunsOpt opts = opts{semfuns = True}-signaturesOpt opts = opts{typeSigs = True}-prettyOpt opts = opts{attrInfo = True}-renameOpt opts = opts{rename = True}-wrappersOpt opts = opts{wrappers = True}-modcopyOpt opts = opts{modcopy = True}-newtypesOpt opts = opts{newtypes = True}-nestOpt opts = opts{nest = True}-smacroOpt opts = opts{smacro = True}-verboseOpt opts = opts{verbose = True}-helpOpt opts = opts{showHelp = True}-versionOpt opts = opts{showVersion = True}-prefixOpt pre opts = opts{prefix = pre }-selfOpt opts = opts{withSelf = True}-cycleOpt opts = opts{withCycle = True}-visitOpt opts = opts{visit = True, withCycle = True}-seqOpt opts = opts{withSeq = True}-unboxOpt opts = opts{unbox = True}-bangpatsOpt opts = opts{bangpats = True}-casesOpt opts = opts{cases = True}-strictCasesOpt opts = opts{strictCases = True}-stricterCasesOpt opts = opts{strictCases = True, stricterCases = True}-strictSemOpt opts = opts{strictSems = True}-localCpsOpt opts = opts{localCps = True}-splitSemsOpt opts = opts{splitSems = True}-werrorsOpt opts = opts{werrors = True}-wignoreOpt opts = opts{wignore = True}-wmaxErrsOpt n opts = opts{wmaxerrs = read n}-dumpgrammarOpt opts = opts{dumpgrammar = True}-dumpcgrammarOpt opts = opts{dumpcgrammar = True}-genTracesOpt opts = opts{genTraces = True}-genUseTracesOpt opts = opts{genUseTraces = True}-genCostCentresOpt opts = opts{genCostCentres = True}-sepSemModsOpt opts = opts{sepSemMods = True}-genFileDepsOpt opts = opts{genFileDeps = True}-genLinePragmasOpt opts = opts{genLinePragmas = True}-genVisageOpt opts = opts{genvisage = True }-genAspectAGOpt opts = opts{genAspectAG = True}--dummyTokenVisitOpt opts = opts { dummyTokenVisit = True }-tupleAsDummyTokenOpt opts = opts { tupleAsDummyToken = True }-stateAsDummyTokenOpt opts = opts { tupleAsDummyToken = False }-strictDummyTokenOpt opts = opts { strictDummyToken = True }-noPerRuleTypeSigsOpt opts = opts { noPerRuleTypeSigs = True }-noPerStateTypeSigsOpt opts = opts { noPerStateTypeSigs = True }-noEagerBlackholingOpt opts = opts { noEagerBlackholing = True }-noPerRuleCostCentresOpt opts = opts { noPerRuleCostCentres = True }-noPerVisitCostCentresOpt opts = opts { noPerVisitCostCentres = True }-helpInliningOpt opts = opts { helpInlining = True }-noInlinePragmasOpt opts = opts { noInlinePragmas = True }-aggressiveInlinePragmasOpt opts = opts { aggressiveInlinePragmas = True }-lateHigherOrderBindingOpt opts = opts { lateHigherOrderBinding = True }-monadicWrappersOpt opts = opts { monadicWrappers = True }--noGroupOpt att opts = opts{noGroup = extract att ++ noGroup opts}- where extract s = case dropWhile isSeparator s of- "" -> []- s' -> w : extract s''- where (w, s'') =- break isSeparator s'- isSeparator x = x == ':'--extendsOpt m opts = opts{extends = Just m }--genAttrListOpt opts = opts { genAttributeList = True }-forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm }-uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm }-lcKeywordsOpt opts = opts { lcKeywords = True }-doubleColonsOpt opts = opts { doubleColons = True }-haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt-monadicOpt opts = opts { monadic = True }-parallelOpt opts = opts { parallelInvoke = True }-ocamlOpt opts = opts { ocaml = True }-visitorsOutputOpt opts = opts { visitorsOutput = True }-statisticsOpt nm opts = opts { statsFile = Just nm }-breadthfirstOpt opts = opts { breadthFirst = True }-breadthfirstStrictOpt opts = opts { breadthFirstStrict = True }-parseHsRhsOpt opts = opts { checkParseRhs = True }-parseHsTpOpt opts = opts { checkParseTy = True }-parseHsBlockOpt opts = opts { checkParseBlock = True }-parseHsOpt = parseHsRhsOpt . parseHsTpOpt . parseHsBlockOpt-kennedyWarrenOpt opts = opts { kennedyWarren = True }-noOptimizeOpt opts = opts { noOptimizations = True }-nocatasOpt str opts = opts { nocatas = set `Set.union` nocatas opts } where- set = Set.fromList ids- ids = map identifier lst- lst = split str-- split str | null p = []- | otherwise = p : split ps- where (p,ps) = break (== ',') str--outputOpt file opts = opts{outputFiles = file : outputFiles opts}-searchPathOpt path opts = opts{searchPath = extract path ++ searchPath opts}- where extract xs = let (p,ps) = break (\x -> x == ';' || x == ':') xs- in if null p then [] else p : extract ps-allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt-optimizeOpt = visitOpt . casesOpt--condDisableOptimizations opts- | noOptimizations opts =- opts { strictData = False- , strictWrap = False- , withSeq = False- , unbox = False- , bangpats = False- , cases = False- , strictCases = False- , stricterCases = False- , strictSems = False- , localCps = False- , splitSems = False- , breadthFirstStrict = False- }- | otherwise = opts--getOptions args = let (flags,files,errors) = getOpt Permute options args- appliedOpts = foldl (flip ($)) noOptions flags- finOpts = condDisableOptimizations appliedOpts- in (finOpts,files,errors)--data ModuleHeader = NoName- | Name String- | Default deriving Show
src/Scanner.hs view
@@ -10,7 +10,7 @@ import Data.List import Data.Char import UU.Scanner.GenToken -import Options +import Options (Options (..)) data Input = Input !Pos String (Maybe (Token, Input))
+ src/UU/UUAGC.hs view
@@ -0,0 +1,11 @@+module UU.UUAGC (uuagc, uuagcMain) where++import Ag (uuagcLib, uuagcExe)++import System.Exit (ExitCode(..))++uuagc :: [String] -> FilePath -> IO (ExitCode, [FilePath])+uuagc = uuagcLib++uuagcMain :: IO ()+uuagcMain = uuagcExe
uuagc.cabal view
@@ -3,8 +3,8 @@ x-bootstrap-build-type: Simple name: uuagc x-bootstrap-name: uuagc-bootstrap-version: 0.9.39.3-x-bootstrap-version: 0.9.39.3.0+version: 0.9.40.1+x-bootstrap-version: 0.9.40.1 license: BSD3 license-file: LICENSE maintainer: Arie Middelkoop <ariem@cs.uu.nl>@@ -22,15 +22,29 @@ extra-source-files: src-ag/DistChildAttr.ag executable uuagc- build-depends: uuagc-bootstrap >= 0.9.39.1.0- build-depends: uuagc-cabal >= 1.0.0.4- build-depends: base >= 4, base < 5, ghc-prim >= 0.2.0.0- build-depends: containers >= 0.3, directory >= 1.0.1.1, array >= 0.3.0.1- build-depends: uulib >= 0.9.14, mtl >= 1.1.1.1- build-depends: haskell-src-exts >= 1.11.1- build-depends: filepath >= 1.1.0.4- main-is: Ag.hs- other-modules: Ag+ x-bootstrap-build-depends: uuagc-bootstrap == 0.9.40.1+ build-depends: uuagc == 0.9.40.1+ build-depends: base >= 4, base < 5+ main-is: Main.hs+ hs-source-dirs: src-main+ x-bootstrap-hs-source-dirs: src-main++library+ build-depends: uuagc-bootstrap >= 0.9.40.0+ build-depends: uuagc-cabal >= 1.0.2.0+ build-depends: base >= 4, base < 5, ghc-prim >= 0.2.0.0+ build-depends: containers >= 0.3, directory >= 1.0.1.1, array >= 0.3.0.1+ build-depends: uulib >= 0.9.14, mtl >= 1.1.1.1+ build-depends: haskell-src-exts >= 1.11.1+ build-depends: filepath >= 1.1.0.4+ hs-source-dirs: src, src-version, src-ag, src-options+ x-bootstrap-hs-source-dirs: src, src-version, src-derived, src-options+ exposed-modules: UU.UUAGC, UU.UUAGC.Version+ x-bootstrap-exposed-modules: UU.UUAGC.Bootstrap, UU.UUAGC.BootstrapVersion+ extensions: TypeSynonymInstances, MultiParamTypeClasses+ x-bootstrap-other-modules: Paths_uuagc_bootstrap+ other-modules: Paths_uuagc+ , Ag , CommonTypes , GrammarInfo , HsTokenScanner@@ -81,15 +95,3 @@ , KWOrder , ExecutionPlan , ExecutionPlan2Hs- extensions: TypeSynonymInstances, MultiParamTypeClasses- hs-source-dirs: src, src-version, src-ag- x-bootstrap-hs-source-dirs: src, src-version, src-derived--library- build-depends: base >= 4, base < 5- hs-source-dirs: src- x-bootstrap-hs-source-dirs: src- exposed-modules: UU.UUAGC.Version- other-modules: Paths_uuagc- x-bootstrap-other-modules: Paths_uuagc_bootstrap- x-bootstrap-exposed-modules: UU.UUAGC.BootstrapVersion