uuagc-cabal 1.0.0.10 → 1.0.2.0
raw patch · 7 files changed
+594/−368 lines, 7 filesdep +containersPVP ok
version bump matches the API change (PVP)
Dependencies added: containers
API changes (from Hackage documentation)
+ Distribution.Simple.UUAGC: uuagcLibUserHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> UserHooks
Files
- src-options/Options.hs +494/−0
- src/Distribution/Simple/UUAGC.hs +2/−2
- src/Distribution/Simple/UUAGC/AbsSyn.hs +6/−152
- src/Distribution/Simple/UUAGC/Options.hs +0/−61
- src/Distribution/Simple/UUAGC/Parser.hs +19/−87
- src/Distribution/Simple/UUAGC/UUAGC.hs +68/−61
- uuagc-cabal.cabal +5/−5
+ 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/Distribution/Simple/UUAGC.hs view
@@ -1,6 +1,6 @@ module Distribution.Simple.UUAGC(uuagcUserHook ,uuagcUserHook'- ,uuagc) where+ ,uuagc+ ,uuagcLibUserHook) where import Distribution.Simple.UUAGC.UUAGC-
src/Distribution/Simple/UUAGC/AbsSyn.hs view
@@ -1,166 +1,20 @@ module Distribution.Simple.UUAGC.AbsSyn where -import Distribution.Simple.UUAGC.Options+import Options import System.FilePath(normalise) data AGFileOption = AGFileOption {filename :: String, fileClasses :: [String],- opts :: UUAGCOptions}+ opts :: Options} deriving (Show, Eq) -data AGOptionsClass = AGOptionsClass {className :: String, opts' :: UUAGCOptions}- deriving (Show, Read, Eq)+data AGOptionsClass = AGOptionsClass {className :: String, opts' :: Options}+ deriving (Show, Eq) type AGFileOptions = [AGFileOption] -data UUAGCOption = UModuleDefault- | UModule String- | UData- | UStrictData- | UStrictWData- | UCatas- | USemFuns- | USignatures- | UNewTypes- | UPretty- | UWrappers- | URename- | UModCopy- | UNest- | USyntaxMacro- | UOutput FilePath- | UVerbose- | UHelp -- ?- | UAll- | USearchPath FilePath- | UPrefix String- | USelf- | UCycle- | UVersion -- ?- | UVisit- | USeq- | UUnbox -- UUnbox- | UBangPats- | UCase- | UStrictCase- | UStricterCase- | ULocalCPS- | USplitSems- | UWErrors- | UWIgnore- | UWMax Int- | UDumpGrammar- | UDumpCGrammar- | UGenTraces- | UGenUseTraces- | UGenCostCentres- | UGenLinePragmas- | USepSemMods- | UGenFileDeps- | UGenVisage- | UGenAspectAG- | UGenAttrList- | UForceIrrefutable FilePath- | UUniqueDispenser String- | ULCKeyWords- | UOptimize- | UDoubleColons- | UHaskellSyntax- | UStatistics FilePath- | UCheckParseRhs- | UCheckParseTys- | UCheckParseBlocks- | UCheckParseHaskell- | UKennedyWarren- | UParallel- | UGenericBoolFlag String- deriving (Eq, Read, Show)--type UUAGCOptions = [UUAGCOption]--defaultUUAGCOptions :: UUAGCOptions-defaultUUAGCOptions = [UData- ,UCatas- ,USemFuns- ,USignatures- ,UPretty- ,UWrappers- ,URename- ,UModuleDefault- ]--optionTxt = "--"-equalTxt = "="--toLOp s = optionTxt ++ s-toLEOpA s a = (toLOp s) ++ equalTxt ++ a--fromUUAGCOtoArgs :: UUAGCOption -> String-fromUUAGCOtoArgs (UModule s) = toLEOpA omodule s-fromUUAGCOtoArgs UData = toLOp odata-fromUUAGCOtoArgs UStrictData = toLOp ostrictdata-fromUUAGCOtoArgs UStrictWData = toLOp ostrictwrap-fromUUAGCOtoArgs UCatas = toLOp ocatas-fromUUAGCOtoArgs USemFuns = toLOp osemfuns-fromUUAGCOtoArgs USignatures = toLOp osignatures-fromUUAGCOtoArgs UNewTypes = toLOp onewtypes-fromUUAGCOtoArgs UPretty = toLOp opretty-fromUUAGCOtoArgs UWrappers = toLOp owrappers-fromUUAGCOtoArgs URename = toLOp orename-fromUUAGCOtoArgs UModCopy = toLOp omodcopy-fromUUAGCOtoArgs UNest = toLOp onest-fromUUAGCOtoArgs USyntaxMacro = toLOp osyntaxmacro-fromUUAGCOtoArgs (UOutput fp) = toLEOpA ooutput fp-fromUUAGCOtoArgs UVerbose = toLOp overbose-fromUUAGCOtoArgs (USearchPath fp) = toLEOpA "" fp-fromUUAGCOtoArgs (UPrefix p) = toLEOpA oprefix p-fromUUAGCOtoArgs USelf = toLOp oself-fromUUAGCOtoArgs UCycle = toLOp ocycle-fromUUAGCOtoArgs UVersion = toLOp oversion-fromUUAGCOtoArgs UVisit = toLOp ovisit-fromUUAGCOtoArgs USeq = toLOp oseq-fromUUAGCOtoArgs UUnbox = toLOp ounbox-fromUUAGCOtoArgs UBangPats = toLOp obangpats-fromUUAGCOtoArgs UCase = toLOp ocase-fromUUAGCOtoArgs UStrictCase = toLOp ostrictcase-fromUUAGCOtoArgs UStricterCase = toLOp ostrictercase-fromUUAGCOtoArgs ULocalCPS = toLOp olocalcps-fromUUAGCOtoArgs USplitSems = toLOp osplitsems-fromUUAGCOtoArgs UWErrors = toLOp owerrors-fromUUAGCOtoArgs UWIgnore = toLOp owignore-fromUUAGCOtoArgs (UWMax i) = toLEOpA owmax (show i)-fromUUAGCOtoArgs UDumpGrammar = toLOp odumpgrammar-fromUUAGCOtoArgs UDumpCGrammar = toLOp odumpcgrammar-fromUUAGCOtoArgs UGenTraces = toLOp ogentraces-fromUUAGCOtoArgs UGenUseTraces = toLOp ogenusetraces-fromUUAGCOtoArgs UGenCostCentres = toLOp ogencostcentres-fromUUAGCOtoArgs UGenLinePragmas = toLOp ogenlinepragmas-fromUUAGCOtoArgs USepSemMods = toLOp osepsemmods-fromUUAGCOtoArgs UGenFileDeps = toLOp ogenfiledeps-fromUUAGCOtoArgs UGenVisage = toLOp ogenvisage-fromUUAGCOtoArgs UGenAspectAG = toLOp ogenaspectag-fromUUAGCOtoArgs UGenAttrList = toLOp ogenattrlist-fromUUAGCOtoArgs (UForceIrrefutable fp) = toLEOpA oforceirrefutable fp-fromUUAGCOtoArgs (UUniqueDispenser nm) = toLEOpA ouniquedispenser nm-fromUUAGCOtoArgs UOptimize = toLOp ooptimize-fromUUAGCOtoArgs UModuleDefault = toLOp omodule-fromUUAGCOtoArgs UHaskellSyntax = toLOp ohaskellsyntax-fromUUAGCOtoArgs UDoubleColons = toLOp odoublecolons-fromUUAGCOtoArgs ULCKeyWords = toLOp olckeywords-fromUUAGCOtoArgs (UStatistics fp) = toLEOpA ostatistics fp-fromUUAGCOtoArgs UCheckParseRhs = toLOp ocheckparserhs-fromUUAGCOtoArgs UCheckParseTys = toLOp ocheckparsetys-fromUUAGCOtoArgs UCheckParseBlocks = toLOp ocheckparseblocks-fromUUAGCOtoArgs UCheckParseHaskell = toLOp ocheckparsehaskell-fromUUAGCOtoArgs UKennedyWarren = toLOp okennedywarren-fromUUAGCOtoArgs UParallel = toLOp oparallel-fromUUAGCOtoArgs (UGenericBoolFlag fl) = toLOp fl--fromUUAGCOstoArgs :: UUAGCOptions -> [String]-fromUUAGCOstoArgs = map fromUUAGCOtoArgs--lookupFileOptions :: FilePath -> AGFileOptions -> UUAGCOptions-lookupFileOptions s = foldl f defaultUUAGCOptions+lookupFileOptions :: FilePath -> AGFileOptions -> Options+lookupFileOptions s = foldl f noOptions where f e (AGFileOption s' classes opt) | s == (normalise s') = opt | otherwise = e
− src/Distribution/Simple/UUAGC/Options.hs
@@ -1,61 +0,0 @@-module Distribution.Simple.UUAGC.Options where--odata = "data"-ostrictdata = "strictdata"-ostrictwrap = "strictwrap"-ocatas = "catas"-osemfuns = "semfuns"-osignatures = "signatures"-onewtypes = "newtypes"-opretty = "pretty"-owrappers = "wrappers"-orename = "rename"-omodcopy = "modcopy"-onest = "nest"-osyntaxmacro = "syntaxmacro"-overbose = "verbose"-ohelp = "help"-oself = "self"-ocycle = "cycle"-oversion = "version"-ovisit = "visit"-oseq = "seq"-ounbox = "unbox"-obangpats = "bangpats"-ocase = "case"-ostrictcase = "strictcase"-ostrictercase = "strictercase"-olocalcps = "localcps"-osplitsems = "splitsems"-owerrors = "Werrors"-owignore = "Wignore"-owmax = "Wmax"-odumpgrammar = "dumpgrammar"-odumpcgrammar = "dumpcgrammar"-ogentraces = "gentraces"-ogenusetraces = "genusetraces"-ogencostcentres = "gencostcentres"-ogenlinepragmas = "genlinepragmas"-osepsemmods = "sepsemmods"-ogenfiledeps = "genfiledeps"-ogenvisage = "genvisage"-ogenaspectag = "genAspectAG"-ogenattrlist = "genattrlist"-oforceirrefutable = "forceirrefutable"-ouniquedispenser = "uniquedispenser"-olckeywords = "lckeywords"-ooptimize = "optimize"-odoublecolons = "doublecolons"-ohaskellsyntax = "haskellsyntax"-oall = "all"-omodule = "module"-ooutput = "output"-osearch = "path"-oprefix = "prefix"-ostatistics = "statistics"-ocheckparserhs = "checkParseRhs"-ocheckparsetys = "checkParseTys"-ocheckparseblocks = "checkParseBlocks"-ocheckparsehaskell = "checkParseHaskell"-okennedywarren = "kennedywarren"-oparallel = "parallel"
src/Distribution/Simple/UUAGC/Parser.hs view
@@ -9,7 +9,8 @@ import UU.Parsing import UU.Scanner import Distribution.Simple.UUAGC.AbsSyn-import Distribution.Simple.UUAGC.Options+import Options+import System.Console.GetOpt import System.IO.Unsafe(unsafeInterleaveIO) import System.IO(hPutStr,stderr) import Control.Monad.Error@@ -20,53 +21,10 @@ instance Error ParserError where strMsg x = DefParserError x --- Add boolean flags to this list, which will then be handled generically.--- Requires that this flag is also an option of uuagc (case sensitive)-booleanFlags- = [ "helpinlining","dummytokenvisit","tupleasdummytoken","stateasdummytoken","strictdummytoken","noperruletypesigs"- , "noperstatetypesigs", "noeagerblackholing","noperrulecostcentres","nopervisitcostcentres"- , "noinlinepragmas","aggressiveinlinepragmas","latehigherorderbinding", "monadicwrappers"- ]--uFlags = [odata, ostrictdata, ostrictwrap, ocatas, osemfuns, osignatures- ,onewtypes, opretty- ,owrappers, orename, omodcopy, onest, osyntaxmacro, overbose- ,ohelp, ocycle, oversion, ovisit, oseq, ounbox, obangpats- ,ocase, ostrictcase, ostrictercase, olocalcps, osplitsems- ,owerrors, owignore, odumpgrammar, odumpcgrammar, ogentraces- ,ogenusetraces, ogencostcentres, ogenlinepragmas, osepsemmods- ,ogenfiledeps, ogenvisage, ogenaspectag, ogenattrlist, olckeywords- ,odoublecolons, oself- ,ocheckparserhs,ocheckparsetys,ocheckparseblocks,ocheckparsehaskell- ,okennedywarren,oparallel] ++ booleanFlags--uabsFlags = [UData, UStrictData, UStrictWData, UCatas, USemFuns, USignatures- ,UNewTypes, UPretty- ,UWrappers, URename, UModCopy, UNest, USyntaxMacro, UVerbose- ,UHelp, UCycle, UVersion, UVisit, USeq, UUnbox, UBangPats- ,UCase, UStrictCase, UStricterCase, ULocalCPS, USplitSems- ,UWErrors, UWIgnore, UDumpGrammar, UDumpCGrammar, UGenTraces- ,UGenUseTraces, UGenCostCentres, UGenLinePragmas, USepSemMods- ,UGenFileDeps, UGenVisage, UGenAspectAG, UGenAttrList, ULCKeyWords- ,UDoubleColons, USelf- ,UCheckParseRhs, UCheckParseTys, UCheckParseBlocks, UCheckParseHaskell- ,UKennedyWarren,UParallel] ++ [ UGenericBoolFlag fl | fl <- booleanFlags ]--gFlags = [(oall, [odata, ocatas, osemfuns, osignatures, opretty, orename])- ,(ooptimize, [ovisit,ocase])- ,(ohaskellsyntax, [olckeywords, odoublecolons,ogenlinepragmas])- ]--gabsFlags = [UAll, UOptimize, UHaskellSyntax]---aFlags = [omodule, ooutput, osearch, oprefix, owmax, oforceirrefutable, ouniquedispenser, ostatistics]--ugFlags = uFlags ++ (map (fst) gFlags)--ugabsFlags = uabsFlags ++ gabsFlags+uFlags :: [String]+uFlags = concat [ filter (not . null) x | Option _ x _ _ <- options] -kwtxt = uFlags ++ (map fst gFlags) ++ aFlags ++ ["file", "options", "class", "with"]+kwtxt = uFlags ++ ["file", "options", "class", "with"] kwotxt = ["=",":","..","."] sctxt = "..," octxt = "=:.,"@@ -74,42 +32,17 @@ posTxt :: Pos posTxt = Pos 0 0 "" -puFlag :: UUAGCOption -> String -> Parser Token UUAGCOption-puFlag opt sopt = opt <$ pKey sopt---pugFlags :: [Parser Token UUAGCOption]-pugFlags = zipWith puFlag ugabsFlags ugFlags--pModule :: Parser Token UUAGCOption-pModule = UModuleDefault <$ pKey omodule- <|> UModule <$> (pKey omodule *> pString)--pOutput :: Parser Token UUAGCOption-pOutput = UOutput <$> (pKey ooutput *> pString)--pSearch :: Parser Token UUAGCOption-pSearch = USearchPath <$> (pKey osearch *> pString)--pPrefix :: Parser Token UUAGCOption-pPrefix = UPrefix <$> (pKey oprefix *> pString)--pWmax :: Parser Token UUAGCOption-pWmax = f <$> (pKey owmax *> pInteger)- where f x = UWMax (read x)--pForceIrrefutable :: Parser Token UUAGCOption-pForceIrrefutable = UForceIrrefutable <$> (pKey oforceirrefutable *> pString)--pUniqueDispenser :: Parser Token UUAGCOption-pUniqueDispenser = UUniqueDispenser <$> (pKey ouniquedispenser *> pString)--pStatistics :: Parser Token UUAGCOption-pStatistics = UStatistics <$> (pKey ostatistics *> pString)+puFlag :: OptDescr (Options -> Options) -> Parser Token (Options -> Options)+puFlag (Option _ [] _ _) = pFail+puFlag (Option _ kws (NoArg f) _) = pAny (\kw -> const f <$> pKey kw) kws+puFlag (Option _ kws (ReqArg f _) _) = pAny (\kw -> f <$ pKey kw <*> pString) kws+puFlag (Option _ kws (OptArg f _) _) = pAny (\kw -> const (f Nothing) <$> pKey kw+ <|> f . Just <$ pKey kw <*> pString) kws -pAllFlags = pugFlags ++ [pModule,pOutput,pSearch,pPrefix,pWmax,pForceIrrefutable,pUniqueDispenser,pStatistics]+pugFlags :: [Parser Token (Options -> Options)]+pugFlags = map puFlag options -pAnyFlag = pAny id pAllFlags+pAnyFlag = pAny id pugFlags pSep :: Parser Token String pSep = pKey ":" <|> pKey "="@@ -118,17 +51,16 @@ pFileClasses = pKey "with" *> (pCommas pString) <|> pSucceed [] -pLiftOptions :: (String -> [UUAGCOption] -> a) -> String -> Parser Token a-pLiftOptions f n = f <$> (pKey n *> pSep *> pString)- <*> (pKey "options" *> pSep *> pCommas pAnyFlag)- pAGFileOption :: Parser Token AGFileOption-pAGFileOption = AGFileOption <$> (pKey "file" *> pSep *> pString)+pAGFileOption = (\f cl opt -> AGFileOption f cl (constructOptions opt))+ <$> (pKey "file" *> pSep *> pString) <*> pFileClasses <*> (pKey "options" *> pSep *> pCommas pAnyFlag) pAGOptionsClass :: Parser Token AGOptionsClass-pAGOptionsClass = pLiftOptions AGOptionsClass "class"+pAGOptionsClass = (\c opt -> AGOptionsClass c (constructOptions opt))+ <$> (pKey "class" *> pSep *> pString)+ <*> (pKey "options" *> pSep *> pCommas pAnyFlag) pAGFileOptions :: Parser Token AGFileOptions pAGFileOptions = pList pAGFileOption
src/Distribution/Simple/UUAGC/UUAGC.hs view
@@ -1,9 +1,10 @@ {-# LANGUAGE CPP #-}- module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook, uuagcUserHook',- uuagc+ uuagc,+ uuagcLibUserHook ) where+ import Distribution.Simple.BuildPaths (autogenModulesDir) import Debug.Trace import Distribution.Simple@@ -15,15 +16,11 @@ import Distribution.Simple.UUAGC.AbsSyn( AGFileOption(..) , AGFileOptions , AGOptionsClass(..)- , UUAGCOption(..)- , UUAGCOptions- , defaultUUAGCOptions- , fromUUAGCOtoArgs- , fromUUAGCOstoArgs , lookupFileOptions , fileClasses ) import Distribution.Simple.UUAGC.Parser+import Options hiding (verbose) import Distribution.Verbosity import System.Process( CreateProcess(..), createProcess, CmdSpec(..) , StdStream(..), runProcess, waitForProcess@@ -56,31 +53,62 @@ import Data.Either (partitionEithers) import Data.List (nub) +{-# DEPRECATED uuagcUserHook, uuagcUserHook', uuagc "Use uuagcLibUserHook instead" #-}+ -- | 'uuagc' returns the name of the uuagc compiler uuagcn = "uuagc" -- | 'defUUAGCOptions' returns the default names of the uuagc options+defUUAGCOptions :: String defUUAGCOptions = "uuagc_options" -- | File used to store de classes defined in the cabal file.+agClassesFile :: String agClassesFile = "ag_file_options" -- | The prefix used for the cabal file optionsw+agModule :: String agModule = "x-agmodule" -- | The prefix used for the cabal file options used for defining classes+agClass :: String agClass = "x-agclass" +-- | Deprecated userhook uuagcUserHook :: UserHooks uuagcUserHook = uuagcUserHook' uuagcn +-- | Deprecated userhook uuagcUserHook' :: String -> UserHooks-uuagcUserHook' uuagcPath = hooks where+uuagcUserHook' uuagcPath = uuagcLibUserHook (uuagcFromString uuagcPath)++-- | Create uuagc function using shell (old method)+uuagcFromString :: String -> [String] -> FilePath -> IO (ExitCode, [FilePath])+uuagcFromString uuagcPath args file = do + (_, Just ppOutput, Just ppError, ph) <- createProcess $ (proc uuagcPath (args ++ [file]))+ { std_in = Inherit+ , std_out = CreatePipe+ , std_err = CreatePipe+ }+ ec <- waitForProcess ph+ case ec of+ ExitSuccess ->+ do fls <- processContent ppOutput+ return (ExitSuccess, fls)+ (ExitFailure exc) ->+ do hPutStrLn stderr (show exc)+ putErrorInfo ppOutput+ putErrorInfo ppError+ return (ExitFailure exc, [])++-- | Main hook, argument should be uuagc function+uuagcLibUserHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> UserHooks+uuagcLibUserHook uuagc = hooks where hooks = simpleUserHooks { hookedPreProcessors = ("ag", ag):("lag",ag):knownSuffixHandlers- , buildHook = uuagcBuildHook uuagcPath- , sDistHook = uuagcSDistHook uuagcPath+ , buildHook = uuagcBuildHook uuagc+ , sDistHook = uuagcSDistHook uuagc }- ag = uuagc' uuagcPath+ ag = uuagc' uuagc originalPreBuild = preBuild simpleUserHooks originalBuildHook = buildHook simpleUserHooks@@ -130,28 +158,21 @@ -- AG Files and theirs file dependencies in order to see if the latters -- are more updated that the formers, and if this is the case to -- update the AG File-updateAGFile :: FilePath+updateAGFile :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> FilePath -> PackageDescription -> LocalBuildInfo -> (FilePath, String) -> IO ()-updateAGFile uuagcPath classesPath pkgDescr lbi (f, sp) = do+updateAGFile uuagc classesPath pkgDescr lbi (f, sp) = do fileOpts <- readFileOptions classesPath let opts = case lookup f fileOpts of- Nothing -> []+ Nothing -> noOptions Just x -> x- modeOpts = filter isModeOption opts- isModeOption UHaskellSyntax = True- isModeOption ULCKeyWords = True- isModeOption UDoubleColons = True- isModeOption _ = False- (_, Just ppOutput, Just ppError, ph) <- newProcess modeOpts- ec <- waitForProcess ph+ (ec, fls) <- uuagc (optionsToString $ opts { genFileDeps = True, searchPath = sp : (searchPath opts) }) f case ec of ExitSuccess ->- do fls <- processContent ppOutput- let flsC = addSearch sp fls+ do let flsC = addSearch sp fls when ((not.null) flsC) $ do flsmt <- mapM getModificationTime flsC let maxModified = maximum flsmt@@ -163,20 +184,7 @@ withBuildTmpDir pkgDescr lbi $ removeTmpFile . (`tmpFile` f) (ExitFailure exc) -> do hPutStrLn stderr (show exc)- putErrorInfo ppOutput- putErrorInfo ppError throwFailure- where newProcess mopts = createProcess $ (proc uuagcPath- (fromUUAGCOstoArgs mopts ++ ["--genfiledeps"- ,"--=" ++ intercalate ":" [sp]- ,f- ]- )- )- { std_in = Inherit- , std_out = CreatePipe- , std_err = CreatePipe- } getAGFileOptions :: [(String, String)] -> IO AGFileOptions getAGFileOptions extra = do@@ -192,24 +200,24 @@ getAGClasses :: [(String, String)] -> IO [AGOptionsClass] getAGClasses = mapM (parseClassAG . snd) . filter ((== agClass) . fst) -writeFileOptions :: FilePath -> [(String, [UUAGCOption])] -> IO ()+writeFileOptions :: FilePath -> [(String, Options)] -> IO () writeFileOptions classesPath opts = do hClasses <- openFile classesPath WriteMode- hPutStr hClasses $ show opts+ hPutStr hClasses $ show [(s,optionsToString opt) | (s,opt) <- opts] hFlush hClasses hClose hClasses -readFileOptions :: FilePath -> IO [(String, [UUAGCOption])]+readFileOptions :: FilePath -> IO [(String, Options)] readFileOptions classesPath = do hClasses <- openFile classesPath ReadMode sClasses <- hGetContents hClasses- classes <- readIO sClasses :: IO [(String, [UUAGCOption])]+ classes <- readIO sClasses :: IO [(String, [String])] hClose hClasses- return $ classes+ return $ [(s,opt) | (s,str) <- classes, let (opt,_,_) = getOptions str] -getOptionsFromClass :: [(String, [UUAGCOption])] -> AGFileOption -> ([String], [UUAGCOption])+getOptionsFromClass :: [(String, Options)] -> AGFileOption -> ([String], Options) getOptionsFromClass classes fOpt =- second (nub . concat . ((opts fOpt):))+ second (foldl combineOptions (opts fOpt)) . partitionEithers $ do fClass <- fileClasses fOpt case fClass `lookup` classes of@@ -218,41 +226,41 @@ ++ show fClass ++ " is not defined." -uuagcSDistHook :: FilePath+uuagcSDistHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO ()-uuagcSDistHook uuagcPath pd mbLbi uh df = do+uuagcSDistHook uuagc pd mbLbi uh df = do {- case mbLbi of Nothing -> warn normal "sdist: the local buildinfo was not present. Skipping AG initialization. Dist may fail." Just lbi -> let classesPath = buildDir lbi </> agClassesFile- in commonHook uuagcPath classesPath pd lbi (sDistVerbosity df)+ in commonHook uuagc classesPath pd lbi (sDistVerbosity df) originalSDistHook pd mbLbi uh df -} originalSDistHook pd mbLbi (uh { hookedPreProcessors = ("ag", nouuagc):("lag",nouuagc):knownSuffixHandlers }) df -- bypass preprocessors uuagcBuildHook- :: FilePath+ :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO ()-uuagcBuildHook uuagcPath pd lbi uh bf = do+uuagcBuildHook uuagc pd lbi uh bf = do let classesPath = buildDir lbi </> agClassesFile- commonHook uuagcPath classesPath pd lbi (buildVerbosity bf)+ commonHook uuagc classesPath pd lbi (buildVerbosity bf) originalBuildHook pd lbi uh bf -commonHook :: FilePath+commonHook :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> FilePath -> PackageDescription -> LocalBuildInfo -> Flag Verbosity -> IO ()-commonHook uuagcPath classesPath pd lbi fl = do+commonHook uuagc classesPath pd lbi fl = do let verbosity = fromFlagOrDefault normal fl when (verbosity >= verbose) $ putStrLn ("commonHook: Assuming AG classesPath: " ++ classesPath) createDirectoryIfMissingVerbose verbosity True (buildDir lbi)@@ -263,23 +271,23 @@ options <- getAGFileOptions (bis >>= customFieldsBI) fileOptions <- forM options (\ opt -> let (notFound, opts) = getOptionsFromClass classes $ opt- in do when (verbosity >= verbose) $ putStrLn ("options for " ++ filename opt ++ ": " ++ show opts)+ in do when (verbosity >= verbose) $ putStrLn ("options for " ++ filename opt ++ ": " ++ unwords (optionsToString opts)) forM_ notFound (hPutStrLn stderr) >> return (normalise . filename $ opt, opts)) writeFileOptions classesPath fileOptions let agflSP = map (id &&& dropFileName) $ nub $ getAGFileList options- mapM_ (updateAGFile uuagcPath classesPath pd lbi) agflSP+ mapM_ (updateAGFile uuagc classesPath pd lbi) agflSP getAGFileList :: AGFileOptions -> [FilePath] getAGFileList = map (normalise . filename) uuagc :: BuildInfo -> LocalBuildInfo -> PreProcessor-uuagc = uuagc' uuagcn+uuagc = uuagc' (uuagcFromString uuagcn) -uuagc' :: String+uuagc' :: ([String] -> FilePath -> IO (ExitCode, [FilePath])) -> BuildInfo -> LocalBuildInfo -> PreProcessor-uuagc' uuagcPath build lbi =+uuagc' uuagc build lbi = PreProcessor { platformIndependent = True, runPreProcessor = mkSimplePreProcessor $ \ inFile outFile verbosity ->@@ -290,13 +298,12 @@ when (verbosity >= verbose) $ putStrLn ("uuagc-preprocessor: Assuming AG classesPath: " ++ classesPath) fileOpts <- readFileOptions classesPath let opts = case lookup inFile fileOpts of- Nothing -> []+ Nothing -> noOptions Just x -> x search = dropFileName inFile- options = fromUUAGCOstoArgs opts- ++ ["-P" ++ search, "--output=" ++ outFile, inFile]- (_,_,_,ph) <- createProcess (proc uuagcPath options)- eCode <- waitForProcess ph+ options = opts { searchPath = search : (searchPath opts) + , outputFiles = outFile : (outputFiles opts) }+ (eCode,_) <- uuagc (optionsToString options) inFile case eCode of ExitSuccess -> return () ExitFailure _ -> throwFailure
uuagc-cabal.cabal view
@@ -1,7 +1,7 @@ cabal-version: >=1.8 build-type: Simple name: uuagc-cabal-version: 1.0.0.10+version: 1.0.2.0 license: BSD3 license-file: LICENSE maintainer: Arie Middelkoop <ariem@cs.uu.nl>@@ -18,10 +18,10 @@ library build-depends: base >= 4, base < 5, Cabal >= 1.8.0.6, directory >= 1.0.1.1- build-depends: process >= 1.0.1.3, uulib >= 0.9.14, filepath >= 1.1.0.4, mtl >= 2.0.1.0- hs-source-dirs: src+ build-depends: process >= 1.0.1.3, containers >= 0.3, uulib >= 0.9.14, filepath >= 1.1.0.4, mtl >= 2.0.1.0+ hs-source-dirs: src, src-options exposed-modules: Distribution.Simple.UUAGC other-modules: Distribution.Simple.UUAGC.UUAGC,- Distribution.Simple.UUAGC.Parser, Distribution.Simple.UUAGC.AbsSyn,- Distribution.Simple.UUAGC.Options+ Distribution.Simple.UUAGC.Parser,+ Options