Improved CurryBuilder

  * Code refactoring
  * Extended status output

src/Base/Messages.hs

@@ -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 ()

src/CurryBuilder.hs

@@ -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