Commit 6387b29b authored by Björn Peemöller 's avatar Björn Peemöller

Improved CurryBuilder

  * Code refactoring
  * Extended status output
parent 2ea95c75
......@@ -45,7 +45,7 @@ warn opts msgs = when (wnWarn opts && not (null msgs)) $ do
-- |Print a message on 'stdout'
putMsg :: MonadIO m => String -> m ()
putMsg msg = liftIO $ putStrLn $ msg ++ " ..."
putMsg = liftIO . putStrLn
-- |Print an error message on 'stderr'
putErrLn :: MonadIO m => String -> m ()
......
......@@ -3,7 +3,7 @@
Description : Build tool for compiling multiple Curry modules
Copyright : (c) 2005 Martin Engelke
2007 Sebastian Fischer
2011 - 2013 Björn Peemöller
2011 - 2014 Björn Peemöller
License : OtherLicense
Maintainer : bjp@informatik.uni-kiel.de
......@@ -32,16 +32,15 @@ import CurryDeps (Source (..), flatDeps)
import Modules (compileModule)
-- |Compile the Curry module in the given source file including all imported
-- modules, depending on the 'Options'.
-- modules w.r.t. the given 'Options'.
buildCurry :: Options -> String -> CYIO ()
buildCurry opts s = do
fn <- findCurry opts s
srcs <- flatDeps opts fn
makeCurry (defaultToFlatCurry opts) srcs fn
deps <- flatDeps opts fn
makeCurry opts' deps
where
defaultToFlatCurry opt
| null $ optTargetTypes opt = opt { optTargetTypes = [FlatCurry] }
| otherwise = opt
opts' | null $ optTargetTypes opts = opts { optTargetTypes = [FlatCurry] }
| otherwise = opts
-- |Search for a compilation target identified by the given 'String'.
findCurry :: Options -> String -> CYIO FilePath
......@@ -72,65 +71,73 @@ findCurry opts s = do
Nothing -> second
justFn -> return justFn
-- |Compiles the given source modules, which must be in topological order
makeCurry :: Options -> [(ModuleIdent, Source)] -> FilePath -> CYIO ()
makeCurry opts srcs targetFile = mapM_ (process . snd) srcs
-- |Compiles the given source modules, which must be in topological order.
makeCurry :: Options -> [(ModuleIdent, Source)] -> CYIO ()
makeCurry opts srcs = mapM_ process' (zip [1 ..] srcs)
where
process :: Source -> CYIO ()
process (Source fn deps) = do
let isFinalFile = dropExtension targetFile == dropExtension fn
isDump = not $ null $ dbDumpLevels $ optDebugOpts opts
isEnforced = optForce opts || isDump
destFiles = if isFinalFile then destNames fn else [getFlatName fn]
depFiles = fn : mapMaybe curryInterface deps
actOutdated = if isFinalFile then compileFinal else compile
actUpToDate = if isFinalFile then skipFinal else skip
interfaceExists <- liftIO $ doesModuleExist $ interfName fn
if interfaceExists && not (isEnforced && isFinalFile)
then smake destFiles depFiles (actOutdated fn) (actUpToDate fn)
else actOutdated fn
process _ = return ()
compileFinal f = do
status opts $ "generating " ++ (normalise $ head $ destNames f)
compileModule opts f
compile f = do
status opts $ "compiling " ++ normalise f
compileModule (opts { optTargetTypes = [FlatCurry]
, optDebugOpts = defaultDebugOpts }) f
skipFinal f = status opts $ "skipping " ++ normalise f
skip f = info opts $ "skipping " ++ normalise f
destNames fn = [ gen fn | (tgt, gen) <- nameGens
, tgt `elem` optTargetTypes opts]
where nameGens =
[ (FlatCurry , flatName )
, (ExtendedFlatCurry , extFlatName )
, (FlatXml , xmlName )
, (AbstractCurry , acyName )
, (UntypedAbstractCurry , uacyName )
, (Parsed , sourceRepName)
]
curryInterface m = case lookup m srcs of
Just (Source fn _) -> Just $ interfName fn
Just (Interface fn) -> Just $ interfName fn
_ -> Nothing
getFlatName = if ExtendedFlatCurry `elem` optTargetTypes opts
then extFlatName
else flatName
total = length srcs
process' :: (Int, (ModuleIdent, Source)) -> CYIO ()
process' (n, (m, Source fn is)) = process opts' (n, total) m fn deps
where
opts' | n == total = opts { optForce = optForce opts || isDump }
| otherwise = opts { optTargetTypes = [flatTarget]
, optForce = False
, optDebugOpts = defaultDebugOpts
}
isDump = not $ null $ dbDumpLevels $ optDebugOpts opts
flatTarget = if ExtendedFlatCurry `elem` optTargetTypes opts
then ExtendedFlatCurry else FlatCurry
deps = fn : mapMaybe curryInterface is
curryInterface i = case lookup i srcs of
Just (Source fn' _) -> Just $ interfName fn'
Just (Interface fn') -> Just $ interfName fn'
_ -> Nothing
process' _ = return ()
-- |Compile a single source module.
process :: Options -> (Int, Int)
-> ModuleIdent -> FilePath -> [FilePath] -> CYIO ()
process opts idx m fn deps
| optForce opts = compile
| otherwise = smake (interfName fn : destFiles) deps compile skip
where
skip = status opts $ compMessage idx "Skipping" m (fn, head destFiles)
compile = do
status opts $ compMessage idx "Compiling" m (fn, head destFiles)
compileModule opts fn
destFiles = [ addCurrySubdir (optUseSubdir opts) (gen fn)
| (tgt, gen) <- nameGens, tgt `elem` optTargetTypes opts]
nameGens =
[ (FlatCurry , flatName )
, (ExtendedFlatCurry , extFlatName )
, (FlatXml , xmlName )
, (AbstractCurry , acyName )
, (UntypedAbstractCurry , uacyName )
, (Parsed , sourceRepName)
]
-- |Create a status message like
-- @[m of n] Compiling Module ( M.curry, .curry/M.fcy )@
compMessage :: (Int, Int) -> String -> ModuleIdent
-> (FilePath, FilePath) -> String
compMessage (curNum, maxNum) what m (src, dst)
= '[' : lpad (length sMaxNum) (show curNum) ++ " of " ++ sMaxNum ++ "]"
++ ' ' : rpad 9 what ++ ' ' : rpad 16 (show m)
++ " ( " ++ normalise src ++ ", " ++ normalise dst ++ " )"
where
sMaxNum = show maxNum
lpad n s = replicate (n - length s) ' ' ++ s
rpad n s = s ++ replicate (n - length s) ' '
-- |A simple make function
smake :: [FilePath] -- ^ destination files
-> [FilePath] -- ^ dependency files
-> CYIO a -- ^ action to perform if depedency files are newer
-> CYIO a -- ^ action to perform if destination files are newer
-> CYIO a -- ^ action to perform if depedency files are newer
-> CYIO a -- ^ action to perform if destination files are newer
-> CYIO a
smake dests deps actOutdated actUpToDate = do
destTimes <- catMaybes `liftM` mapM (liftIO . getModuleModTime) dests
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment