uuagc-cabal 1.0.3.0 → 1.0.4.0
raw patch · 3 files changed
+93/−104 lines, 3 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- src-options/Options.hs +36/−20
- src/Distribution/Simple/UUAGC/UUAGC.hs +55/−82
- uuagc-cabal.cabal +2/−2
src-options/Options.hs view
@@ -11,6 +11,7 @@ -- From CommonTypes data Identifier = Ident { getName::String, getPos::Pos } type NontermIdent = Identifier+identifier :: String -> Identifier identifier x = Ident x noPos instance Eq Identifier where@@ -46,7 +47,7 @@ else [] mbStringOpt :: (Options -> Maybe String) -> Options -> String -> [String]-mbStringOpt get opts nm = maybe [] (\s -> [nm, s]) (get opts)+mbStringOpt get opts nm = maybe [] (\s -> [nm++"="++s]) (get opts) serializeOption :: Options -> MyOptDescr -> [String] serializeOption opt (MyOpt sh ln _ get _) = get opt strArg@@ -152,6 +153,7 @@ options :: [OptDescr (Options -> Options)] options = map fromMyOpt allOptions +allc :: String allc = "dcfsprm" data ModuleHeader = NoName@@ -252,6 +254,7 @@ , aggressiveInlinePragmas :: Bool } -- deriving (Eq, Show) +noOptions :: Options noOptions = Options { moduleName = NoName , dataTypes = False , dataRecords = False@@ -347,11 +350,16 @@ } --Options -> String -> [String]+moduleOpt :: Maybe String -> Options -> Options moduleOpt nm opts = opts{moduleName = maybe Default Name nm}+moduleOptGet :: Options -> String -> [String] moduleOptGet opts nm = case moduleName opts of NoName -> []- Name s -> [nm,s]+ Name s -> [nm++"="++s] Default -> [nm]++dataOpt, dataRecOpt, strictDataOpt, strictWrapOpt, cataOpt, semfunsOpt, signaturesOpt, prettyOpt,renameOpt, wrappersOpt, modcopyOpt, newtypesOpt, nestOpt, smacroOpt, verboseOpt, helpOpt, versionOpt, selfOpt, cycleOpt, visitOpt, seqOpt, unboxOpt, bangpatsOpt, casesOpt, strictCasesOpt, stricterCasesOpt, strictSemOpt, localCpsOpt, splitSemsOpt, werrorsOpt, wignoreOpt, dumpgrammarOpt, dumpcgrammarOpt, genTracesOpt, genUseTracesOpt, genCostCentresOpt, sepSemModsOpt, genFileDepsOpt, genLinePragmasOpt, genVisageOpt, genAspectAGOpt, dummyTokenVisitOpt, tupleAsDummyTokenOpt, stateAsDummyTokenOpt, strictDummyTokenOpt, noPerRuleTypeSigsOpt, noPerStateTypeSigsOpt, noEagerBlackholingOpt, noPerRuleCostCentresOpt, noPerVisitCostCentresOpt, helpInliningOpt, noInlinePragmasOpt, aggressiveInlinePragmasOpt, lateHigherOrderBindingOpt, monadicWrappersOpt, referenceOpt, genAttrListOpt, lcKeywordsOpt, doubleColonsOpt, haskellSyntaxOpt, monadicOpt, parallelOpt, ocamlOpt, visitorsOutputOpt, breadthfirstOpt, breadthfirstStrictOpt, parseHsRhsOpt, parseHsTpOpt, parseHsBlockOpt, parseHsOpt, kennedyWarrenOpt, noOptimizeOpt, allOpt, optimizeOpt, noIncludesOpt, beQuietOpt, condDisableOptimizations :: Options -> Options+ dataOpt opts = opts{dataTypes = True} dataRecOpt opts = opts{dataRecords = True} strictDataOpt opts = opts{strictData = True}@@ -369,6 +377,7 @@ verboseOpt opts = opts{verbose = True} helpOpt opts = opts{showHelp = True} versionOpt opts = opts{showVersion = True}+prefixOpt :: String -> Options -> Options prefixOpt pre opts = opts{prefix = pre } selfOpt opts = opts{withSelf = True} cycleOpt opts = opts{withCycle = True}@@ -384,7 +393,9 @@ splitSemsOpt opts = opts{splitSems = True} werrorsOpt opts = opts{werrors = True} wignoreOpt opts = opts{wignore = True}+wmaxErrsOpt :: String -> Options -> Options wmaxErrsOpt n opts = opts{wmaxerrs = read n}+wmaxErrsOptGet :: Options -> String -> [String] wmaxErrsOptGet opts nm = if wmaxerrs opts /= wmaxerrs noOptions then [nm,show (wmaxerrs opts)] else []@@ -415,21 +426,19 @@ 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 == ':'+noGroupOpt :: String -> Options -> Options+noGroupOpt att opts = opts{noGroup = wordsBy (== ':') att ++ noGroup opts}+noGroupOptGet :: Options -> String -> [String] noGroupOptGet opts nm = if null (noGroup opts) then [] else [nm, intercalate ":" (noGroup opts)]-+extendsOpt :: String -> Options -> Options extendsOpt m opts = opts{extends = Just m } genAttrListOpt opts = opts { genAttributeList = True }+forceIrrefutableOpt :: Maybe String -> Options -> Options forceIrrefutableOpt mbNm opts = opts { forceIrrefutables = mbNm }+uniqueDispenserOpt :: String -> Options -> Options uniqueDispenserOpt nm opts = opts { uniqueDispenser = nm } lcKeywordsOpt opts = opts { lcKeywords = True } doubleColonsOpt opts = opts { doubleColons = True }@@ -438,6 +447,7 @@ parallelOpt opts = opts { parallelInvoke = True } ocamlOpt opts = opts { ocaml = True, kennedyWarren = True, withCycle = True, visit = True } visitorsOutputOpt opts = opts { visitorsOutput = True }+statisticsOpt :: String -> Options -> Options statisticsOpt nm opts = opts { statsFile = Just nm } breadthfirstOpt opts = opts { breadthFirst = True } breadthfirstStrictOpt opts = opts { breadthFirstStrict = True }@@ -447,23 +457,22 @@ parseHsOpt = parseHsRhsOpt . parseHsTpOpt . parseHsBlockOpt kennedyWarrenOpt opts = opts { kennedyWarren = True } noOptimizeOpt opts = opts { noOptimizations = True }+nocatasOpt :: String -> Options -> Options 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+ lst = wordsBy (== ',') str+nocatasOptGet :: Options -> String -> [String] nocatasOptGet opts nm = if Set.null (nocatas opts) then []- else [nm, intercalate "," . map getName . Set.toList . nocatas $ opts]-+ else [nm,intercalate "," . map getName . Set.toList . nocatas $ opts]+outputOpt :: String -> Options -> Options outputOpt file opts = opts{outputFiles = file : outputFiles opts}+outputOptGet :: Options -> String -> [String] 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+searchPathOpt :: String -> Options -> Options+searchPathOpt path opts = opts{searchPath = wordsBy (\x -> x == ';' || x == ':') path ++ searchPath opts}+searchPathOptGet :: Options -> String -> [String] searchPathOptGet opts nm = if null (searchPath opts) then [] else [nm, intercalate ":" (searchPath opts)]@@ -488,6 +497,13 @@ , breadthFirstStrict = False } | otherwise = opts+ +-- | Inverse of intercalate+wordsBy :: (Char -> Bool) -> String -> [String]+wordsBy p = f+ where+ f s = let (x,xs) = break p s+ in if null x then [] else x : f (drop 1 xs) -- | Use all parsed options to generate real options constructOptions :: [Options -> Options] -> Options
src/Distribution/Simple/UUAGC/UUAGC.hs view
@@ -37,6 +37,7 @@ dropFileName, addExtension, dropExtension,+ replaceExtension, splitDirectories) import System.Exit (ExitCode(..))@@ -53,7 +54,9 @@ import Control.Arrow ((&&&), second) import Data.Maybe (maybeToList) import Data.Either (partitionEithers)-import Data.List (nub)+import Data.List (nub,intersperse)+import Data.Map (Map)+import qualified Data.Map as Map {-# DEPRECATED uuagcUserHook, uuagcUserHook', uuagc "Use uuagcLibUserHook instead" #-} @@ -96,7 +99,8 @@ ec <- waitForProcess ph case ec of ExitSuccess ->- do fls <- processContent ppOutput+ do putErrorInfo ppError+ fls <- processContent ppOutput return (ExitSuccess, fls) (ExitFailure exc) -> do hPutStrLn stderr (uuagcPath ++ ": " ++ show exc)@@ -123,69 +127,28 @@ putErrorInfo :: Handle -> IO () putErrorInfo h = hGetContents h >>= hPutStr stderr -addSearch :: String -> [String] -> [String]-addSearch sp fl = let sf = [head pathSeparators]- path = if sp == ""- then '.' : sf- else sp ++ sf- in [normalise (joinPath [sp,f]) | f <- fl]--throwFailure :: IO ()-throwFailure = throwIO $ ExitFailure 1---- The tmp build directory really depends on the type of project.--- In the case executables it uses the name of the generated file for--- the output directory.-withBuildTmpDir- :: PackageDescription- -> LocalBuildInfo- -> (FilePath -> IO ())- -> IO ()-withBuildTmpDir pkgDescr lbi f = do-#if MIN_VERSION_Cabal(1,8,0)- withLib pkgDescr $ \ _ -> f $ buildDir lbi-#else- withLib pkgDescr () $ \ _ -> f $ buildDir lbi-#endif- withExe pkgDescr $ \ theExe ->- f $ buildDir lbi </> exeName theExe </> exeName theExe ++ "-tmp"- -- | '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 -- update the AG File updateAGFile :: ([String] -> FilePath -> IO (ExitCode, [FilePath]))- -> FilePath- -> PackageDescription- -> LocalBuildInfo- -> (FilePath, String)+ -> Map FilePath (Options, Maybe (FilePath, [String]))+ -> (FilePath, (Options, Maybe (FilePath, [String]))) -> IO ()-updateAGFile uuagc classesPath pkgDescr lbi (f, sp) = do- fileOpts <- readFileOptions classesPath- let opts = case lookup f fileOpts of- Nothing -> noOptions- Just x -> x- (ec, fls) <- uuagc (optionsToString $ opts { genFileDeps = True, searchPath = sp : (searchPath opts) }) f+updateAGFile _ _ (_,(_,Nothing)) = return ()+updateAGFile uuagc newOptions (file,(opts,Just (gen,sp))) = do+ (ec, files) <- uuagc (optionsToString $ opts { genFileDeps = True, searchPath = sp }) file case ec of ExitSuccess ->- do let flsC = addSearch sp fls- when ((not.null) flsC) $ do- flsmt <- mapM getModificationTime flsC+ do when ((not.null) files) $ do+ flsmt <- mapM getModificationTime files let maxModified = maximum flsmt- 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+ fmt <- getModificationTime gen+ let newOpts :: Options + newOpts = maybe noOptions fst $ Map.lookup file newOptions+ -- When some dependency is newer or options have changed, we should regenerate+ when (maxModified > fmt || optionsToString newOpts /= optionsToString opts) $ removeFile gen+ ex@(ExitFailure _) -> throwIO ex getAGFileOptions :: [(String, String)] -> IO AGFileOptions getAGFileOptions extra = do@@ -201,20 +164,23 @@ getAGClasses :: [(String, String)] -> IO [AGOptionsClass] getAGClasses = mapM (parseClassAG . snd) . filter ((== agClass) . fst) -writeFileOptions :: FilePath -> [(String, Options)] -> IO ()+writeFileOptions :: FilePath -> Map FilePath (Options, Maybe (FilePath,[String])) -> IO () writeFileOptions classesPath opts = do hClasses <- openFile classesPath WriteMode- hPutStr hClasses $ show [(s,optionsToString opt) | (s,opt) <- opts]+ hPutStr hClasses $ show $ Map.map (\(opt,gen) -> (optionsToString opt, gen)) opts hFlush hClasses hClose hClasses -readFileOptions :: FilePath -> IO [(String, Options)]+readFileOptions :: FilePath -> IO (Map FilePath (Options, Maybe (FilePath,[String]))) readFileOptions classesPath = do- hClasses <- openFile classesPath ReadMode- sClasses <- hGetContents hClasses- classes <- readIO sClasses :: IO [(String, [String])]- hClose hClasses- return $ [(s,opt) | (s,str) <- classes, let (opt,_,_) = getOptions str]+ isFile <- doesFileExist classesPath+ if isFile+ then do hClasses <- openFile classesPath ReadMode+ sClasses <- hGetContents hClasses+ classes <- readIO sClasses :: IO (Map FilePath ([String], Maybe (FilePath,[String])))+ hClose hClasses+ return $ Map.map (\(opt,gen) -> let (opt',_,_) = getOptions opt in (opt', gen)) classes+ else return Map.empty getOptionsFromClass :: [(String, Options)] -> AGFileOption -> ([String], Options) getOptionsFromClass classes fOpt =@@ -263,20 +229,29 @@ -> IO () commonHook uuagc classesPath pd lbi fl = do let verbosity = fromFlagOrDefault normal fl- when (verbosity >= verbose) $ putStrLn ("commonHook: Assuming AG classesPath: " ++ classesPath)+ info verbosity $ "commonHook: Assuming AG classesPath: " ++ classesPath createDirectoryIfMissingVerbose verbosity True (buildDir lbi)+ -- Read already existing options+ -- Map FilePath (Options, Maybe (FilePath,[String]))+ oldOptions <- readFileOptions classesPath+ -- Read options from cabal and settings file let lib = library pd exes = executables pd bis = map libBuildInfo (maybeToList lib) ++ map buildInfo exes classes <- map (className &&& opts') `fmap` (getAGClasses . customFieldsPD $ pd)- options <- getAGFileOptions (bis >>= customFieldsBI)- fileOptions <- forM options (\ opt ->+ configOptions <- getAGFileOptions (bis >>= customFieldsBI)+ -- Construct new options map+ newOptionsL <- forM configOptions (\ opt -> let (notFound, opts) = getOptionsFromClass classes $ opt- 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 uuagc classesPath pd lbi) agflSP+ file = normalise $ filename opt+ gen = maybe Nothing snd $ Map.lookup file oldOptions+ in do info verbosity $ "options for " ++ file ++ ": " ++ unwords (optionsToString opts)+ forM_ notFound (hPutStrLn stderr)+ return (file, (opts, gen)))+ let newOptions = Map.fromList newOptionsL+ writeFileOptions classesPath newOptions+ -- Check if files should be regenerated+ mapM_ (updateAGFile uuagc newOptions) $ Map.toList oldOptions getAGFileList :: AGFileOptions -> [FilePath] getAGFileList = map (normalise . filename)@@ -292,22 +267,20 @@ PreProcessor { platformIndependent = True, runPreProcessor = mkSimplePreProcessor $ \ inFile outFile verbosity ->- do info verbosity $ concat [inFile, " has been preprocessed into ", outFile]- print $ "processing: " ++ inFile ++ " generating: " ++ outFile--- opts <- getAGFileOptions $ customFieldsBI build+ do putStrLn $ "[UUAGC] processing: " ++ inFile ++ " generating: " ++ outFile let classesPath = buildDir lbi </> agClassesFile- when (verbosity >= verbose) $ putStrLn ("uuagc-preprocessor: Assuming AG classesPath: " ++ classesPath)+ info verbosity $ "uuagc-preprocessor: Assuming AG classesPath: " ++ classesPath fileOpts <- readFileOptions classesPath- let opts = case lookup inFile fileOpts of- Nothing -> noOptions- Just x -> x+ let opts = case Map.lookup inFile fileOpts of+ Nothing -> noOptions+ Just (opt,gen) -> opt search = dropFileName inFile- options = opts { searchPath = search : (searchPath opts) + options = opts { searchPath = search : hsSourceDirs build ++ searchPath opts , outputFiles = outFile : (outputFiles opts) } (eCode,_) <- uuagc (optionsToString options) inFile case eCode of- ExitSuccess -> return ()- ExitFailure _ -> throwFailure+ ExitSuccess -> writeFileOptions classesPath (Map.insert inFile (opts, Just (outFile, searchPath options)) fileOpts)+ ex@(ExitFailure _) -> throwIO ex } nouuagc :: BuildInfo -> LocalBuildInfo -> PreProcessor
uuagc-cabal.cabal view
@@ -1,10 +1,10 @@ cabal-version: >=1.8 build-type: Simple name: uuagc-cabal-version: 1.0.3.0+version: 1.0.4.0 license: BSD3 license-file: LICENSE-maintainer: Arie Middelkoop <ariem@cs.uu.nl>+maintainer: Jeroen Bransen <J.Bransen@uu.nl> homepage: http://www.cs.uu.nl/wiki/HUT/WebHome description: Cabal plugin for UUAGC synopsis: Cabal plugin for the Universiteit Utrecht Attribute Grammar System