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/Distribution/Simple/UUAGC.hs b/src/Distribution/Simple/UUAGC.hs --- a/src/Distribution/Simple/UUAGC.hs +++ b/src/Distribution/Simple/UUAGC.hs @@ -1,6 +1,6 @@ module Distribution.Simple.UUAGC(uuagcUserHook ,uuagcUserHook' - ,uuagc) where + ,uuagc + ,uuagcLibUserHook) where import Distribution.Simple.UUAGC.UUAGC - diff --git a/src/Distribution/Simple/UUAGC/AbsSyn.hs b/src/Distribution/Simple/UUAGC/AbsSyn.hs --- a/src/Distribution/Simple/UUAGC/AbsSyn.hs +++ b/src/Distribution/Simple/UUAGC/AbsSyn.hs @@ -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 diff --git a/src/Distribution/Simple/UUAGC/Options.hs b/src/Distribution/Simple/UUAGC/Options.hs deleted file mode 100644 --- a/src/Distribution/Simple/UUAGC/Options.hs +++ /dev/null @@ -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" diff --git a/src/Distribution/Simple/UUAGC/Parser.hs b/src/Distribution/Simple/UUAGC/Parser.hs --- a/src/Distribution/Simple/UUAGC/Parser.hs +++ b/src/Distribution/Simple/UUAGC/Parser.hs @@ -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 diff --git a/src/Distribution/Simple/UUAGC/UUAGC.hs b/src/Distribution/Simple/UUAGC/UUAGC.hs --- a/src/Distribution/Simple/UUAGC/UUAGC.hs +++ b/src/Distribution/Simple/UUAGC/UUAGC.hs @@ -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 diff --git a/uuagc-cabal.cabal b/uuagc-cabal.cabal --- a/uuagc-cabal.cabal +++ b/uuagc-cabal.cabal @@ -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 @@ -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