diff --git a/src-options/Options.hs b/src-options/Options.hs --- a/src-options/Options.hs +++ b/src-options/Options.hs @@ -5,6 +5,8 @@ import UU.Scanner.Position(Pos,noPos) import Data.List(intercalate) import qualified Data.Set as Set +import System.IO +import System.Exit -- From CommonTypes data Identifier = Ident { getName::String, getPos::Pos } @@ -115,7 +117,7 @@ , 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 [] ["ocaml"] (NoArg ocamlOpt) (boolOpt ocaml) "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" @@ -142,6 +144,8 @@ , 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" + , MyOpt [] ["noincludes"] (NoArg noIncludesOpt) (boolOpt noIncludes) "Ignore include directives in .ag files" + , MyOpt [] ["quiet"] (NoArg beQuietOpt) (boolOpt beQuiet) "Dont print some compilation information" ] -- For compatibility @@ -193,6 +197,7 @@ , dumpgrammar :: Bool , dumpcgrammar :: Bool , sepSemMods :: Bool + , allowSepSemMods :: Bool , genFileDeps :: Bool , genLinePragmas :: Bool , genvisage :: Bool @@ -216,6 +221,11 @@ , nocatas :: Set NontermIdent , noOptimizations :: Bool , reference :: Bool + , noIncludes :: Bool + , outputStr :: String -> IO () + , failWithCode :: Int -> IO () + , mainFilename :: Maybe String + , beQuiet :: Bool -- KW code path , kennedyWarren :: Bool @@ -240,7 +250,7 @@ , helpInlining :: Bool , noInlinePragmas :: Bool , aggressiveInlinePragmas :: Bool - } deriving (Eq, Show) + } -- deriving (Eq, Show) noOptions = Options { moduleName = NoName , dataTypes = False @@ -281,6 +291,7 @@ , dumpgrammar = False , dumpcgrammar = False , sepSemMods = False + , allowSepSemMods = True , genFileDeps = False , genLinePragmas = False , genvisage = False @@ -304,6 +315,11 @@ , nocatas = Set.empty , noOptimizations = False , reference = False + , noIncludes = False + , outputStr = hPutStr stderr + , failWithCode = exitWith . ExitFailure + , mainFilename = Nothing + , beQuiet = False -- defaults for the KW-code path , kennedyWarren = False @@ -377,7 +393,7 @@ genTracesOpt opts = opts{genTraces = True} genUseTracesOpt opts = opts{genUseTraces = True} genCostCentresOpt opts = opts{genCostCentres = True} -sepSemModsOpt opts = opts{sepSemMods = True} +sepSemModsOpt opts = opts{sepSemMods = allowSepSemMods opts} genFileDepsOpt opts = opts{genFileDeps = True} genLinePragmasOpt opts = opts{genLinePragmas = True} genVisageOpt opts = opts{genvisage = True } @@ -420,7 +436,7 @@ haskellSyntaxOpt = lcKeywordsOpt . doubleColonsOpt . genLinePragmasOpt monadicOpt opts = opts { monadic = True } parallelOpt opts = opts { parallelInvoke = True } -ocamlOpt opts = opts { ocaml = True } +ocamlOpt opts = opts { ocaml = True, kennedyWarren = True, withCycle = True, visit = True } visitorsOutputOpt opts = opts { visitorsOutput = True } statisticsOpt nm opts = opts { statsFile = Just nm } breadthfirstOpt opts = opts { breadthFirst = True } @@ -453,6 +469,8 @@ else [nm, intercalate ":" (searchPath opts)] allOpt = moduleOpt Nothing . dataOpt . cataOpt . semfunsOpt . signaturesOpt . prettyOpt . renameOpt . dataRecOpt optimizeOpt = visitOpt . casesOpt +noIncludesOpt opts = opts { noIncludes = True } +beQuietOpt opts = opts { beQuiet = True } condDisableOptimizations opts | noOptimizations opts = 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,3 @@ -module Distribution.Simple.UUAGC(uuagcUserHook - ,uuagcUserHook' - ,uuagc - ,uuagcLibUserHook) where +module Distribution.Simple.UUAGC(module Distribution.Simple.UUAGC.UUAGC) 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 @@ -6,10 +6,8 @@ data AGFileOption = AGFileOption {filename :: String, fileClasses :: [String], opts :: Options} - deriving (Show, Eq) data AGOptionsClass = AGOptionsClass {className :: String, opts' :: Options} - deriving (Show, Eq) type AGFileOptions = [AGFileOption] 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 @@ -2,7 +2,8 @@ module Distribution.Simple.UUAGC.UUAGC(uuagcUserHook, uuagcUserHook', uuagc, - uuagcLibUserHook + uuagcLibUserHook, + uuagcFromString ) where import Distribution.Simple.BuildPaths (autogenModulesDir) @@ -24,7 +25,7 @@ import Distribution.Verbosity import System.Process( CreateProcess(..), createProcess, CmdSpec(..) , StdStream(..), runProcess, waitForProcess - , proc) + , shell) import System.Directory(getModificationTime ,doesFileExist ,removeFile) @@ -35,7 +36,8 @@ joinPath, dropFileName, addExtension, - dropExtension) + dropExtension, + splitDirectories) import System.Exit (ExitCode(..)) import System.IO( openFile, IOMode(..), @@ -84,8 +86,9 @@ -- | 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])) +uuagcFromString uuagcPath args file = do + let argline = uuagcPath ++ concatMap (' ':) (args ++ [file]) + (_, Just ppOutput, Just ppError, ph) <- createProcess (shell argline) { std_in = Inherit , std_out = CreatePipe , std_err = CreatePipe @@ -96,7 +99,7 @@ do fls <- processContent ppOutput return (ExitSuccess, fls) (ExitFailure exc) -> - do hPutStrLn stderr (show exc) + do hPutStrLn stderr (uuagcPath ++ ": " ++ show exc) putErrorInfo ppOutput putErrorInfo ppError return (ExitFailure exc, []) @@ -147,13 +150,6 @@ withExe pkgDescr $ \ theExe -> f $ buildDir lbi exeName theExe exeName theExe ++ "-tmp" --- Creates the output file given the main preprocessed file and the buildtmp folder -tmpFile :: FilePath -> FilePath -> FilePath -tmpFile buildTmp = (buildTmp ) - . (`addExtension` "hs") - . dropExtension - . takeFileName - -- | 'updateAGFile' search into the uuagc options file for a list of all -- 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 @@ -176,12 +172,17 @@ when ((not.null) flsC) $ do flsmt <- mapM getModificationTime flsC let maxModified = maximum flsmt - removeTmpFile f = do - exists <- doesFileExist f - when exists $ do - fmt <- getModificationTime f - when (maxModified > fmt) $ removeFile f - withBuildTmpDir pkgDescr lbi $ removeTmpFile . (`tmpFile` f) + removeTmpFile f buildTmp = + do + -- For src/a/b/c.ag and build, this creates ["build/src/a/b/c.hs","build/a/b/c.hs","build/b/c.hs","build/c.hs"] + -- Problem is we don't know what prefix of the filename is src directory and what part is in the classname + -- There must be a better solution for this... + let files = map (buildTmp ) . scanr1 () . splitDirectories . (`addExtension` "hs") . dropExtension $ f + forM_ files $ \f -> do + exists <- doesFileExist f + when exists $ do fmt <- getModificationTime f + when (maxModified > fmt) $ removeFile f + withBuildTmpDir pkgDescr lbi $ removeTmpFile f (ExitFailure exc) -> do hPutStrLn stderr (show exc) 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.2.0 +version: 1.0.3.0 license: BSD3 license-file: LICENSE maintainer: Arie Middelkoop