diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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) diff --git a/src-ag/AG2AspectAG.ag b/src-ag/AG2AspectAG.ag --- a/src-ag/AG2AspectAG.ag +++ b/src-ag/AG2AspectAG.ag @@ -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} | | ] diff --git a/src-ag/DefaultRules.ag b/src-ag/DefaultRules.ag --- a/src-ag/DefaultRules.ag +++ b/src-ag/DefaultRules.ag @@ -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 } diff --git a/src-ag/DistChildAttr.ag b/src-ag/DistChildAttr.ag --- a/src-ag/DistChildAttr.ag +++ b/src-ag/DistChildAttr.ag @@ -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 diff --git a/src-ag/ExecutionPlan2Hs.ag b/src-ag/ExecutionPlan2Hs.ag --- a/src-ag/ExecutionPlan2Hs.ag +++ b/src-ag/ExecutionPlan2Hs.ag @@ -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 diff --git a/src-ag/GenerateCode.ag b/src-ag/GenerateCode.ag --- a/src-ag/GenerateCode.ag +++ b/src-ag/GenerateCode.ag @@ -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 ] diff --git a/src-ag/HsToken.ag b/src-ag/HsToken.ag --- a/src-ag/HsToken.ag +++ b/src-ag/HsToken.ag @@ -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 diff --git a/src-ag/KWOrder.ag b/src-ag/KWOrder.ag --- a/src-ag/KWOrder.ag +++ b/src-ag/KWOrder.ag @@ -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) diff --git a/src-ag/Order.ag b/src-ag/Order.ag --- a/src-ag/Order.ag +++ b/src-ag/Order.ag @@ -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 ------------------------------------------------------------------ diff --git a/src-ag/PrintCode.ag b/src-ag/PrintCode.ag --- a/src-ag/PrintCode.ag +++ b/src-ag/PrintCode.ag @@ -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 ()} ] diff --git a/src-ag/ResolveLocals.ag b/src-ag/ResolveLocals.ag --- a/src-ag/ResolveLocals.ag +++ b/src-ag/ResolveLocals.ag @@ -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. -- diff --git a/src-ag/SemHsTokens.ag b/src-ag/SemHsTokens.ag --- a/src-ag/SemHsTokens.ag +++ b/src-ag/SemHsTokens.ag @@ -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 diff --git a/src-main/Main.hs b/src-main/Main.hs new file mode 100644 --- /dev/null +++ b/src-main/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import UU.UUAGC (uuagcMain) + +main :: IO () +main = uuagcMain diff --git a/src-options/Options.hs b/src-options/Options.hs new file mode 100644 --- /dev/null +++ b/src-options/Options.hs @@ -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 "") 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 diff --git a/src/Ag.hs b/src/Ag.hs --- a/src/Ag.hs +++ b/src/Ag.hs @@ -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 diff --git a/src/CommonTypes.hs b/src/CommonTypes.hs --- a/src/CommonTypes.hs +++ b/src/CommonTypes.hs @@ -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" diff --git a/src/Options.hs b/src/Options.hs deleted file mode 100644 --- a/src/Options.hs +++ /dev/null @@ -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 "") "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 diff --git a/src/Scanner.hs b/src/Scanner.hs --- a/src/Scanner.hs +++ b/src/Scanner.hs @@ -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)) diff --git a/src/UU/UUAGC.hs b/src/UU/UUAGC.hs new file mode 100644 --- /dev/null +++ b/src/UU/UUAGC.hs @@ -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 diff --git a/uuagc.cabal b/uuagc.cabal --- a/uuagc.cabal +++ b/uuagc.cabal @@ -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 @@ -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