Refactor oracles, add comments.

src/Builder.hs

@@ -11,9 +11,6 @@ import Oracles.Base
 import Oracles.Flag
 import Oracles.Setting
 import GHC.Generics
-import Development.Shake
-import Development.Shake.Classes
-import Development.Shake.FilePath
 
 -- A Builder is an external command invoked in separate process using Shake.cmd
 --

src/Expression.hs

@@ -20,7 +20,6 @@ import Oracles.Base
 import Data.List
 import Data.Monoid
 import Control.Monad.Reader hiding (liftIO)
-import Development.Shake
 
 -- Expr a is a computation that produces a value of type Action a and can read
 -- parameters of the current build Target.

src/Main.hs

 import Rules
-import Config
 import Development.Shake
 
 main = shakeArgs shakeOptions{shakeFiles="_build/"} $ do

src/Oracles.hs

-module Oracles (
-    module Oracles.Base,
-    configOracle, packageDataOracle, dependencyOracle
-    ) where
-
-import Util
-import Config
-import Oracles.Base
-import Oracles.PackageData
-import Oracles.DependencyList
-import Data.List
-import Data.Function
-import qualified Data.HashMap.Strict as M
-import Control.Applicative
-import Control.Monad.Extra
-import Development.Shake
-import Development.Shake.Util
-import Development.Shake.Config
-import Development.Shake.FilePath
-
--- Oracle for configuration files
-configOracle :: Rules ()
-configOracle = do
-    let configFile = cfgPath </> "system.config"
-    cfg <- newCache $ \() -> do
-        unlessM (doesFileExist $ configFile <.> "in") $
-            redError_ $ "\nConfiguration file '" ++ (configFile <.> "in")
-                      ++ "' is missing; unwilling to proceed."
-        need [configFile]
-        putOracle $ "Reading " ++ unifyPath configFile ++ "..."
-        liftIO $ readConfigFile configFile
-    addOracle $ \(ConfigKey key) -> M.lookup key <$> cfg ()
-    return ()
-
--- Oracle for 'package-data.mk' files
-packageDataOracle :: Rules ()
-packageDataOracle = do
-    pkgData <- newCache $ \file -> do
-        need [file]
-        putOracle $ "Reading " ++ file ++ "..."
-        liftIO $ readConfigFile file
-    addOracle $ \(PackageDataKey (file, key)) ->
-        M.lookup key <$> pkgData (unifyPath file)
-    return ()
-
-bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
-bimap f g (x, y) = (f x, g y)
-
--- Oracle for 'path/dist/*.deps' files
-dependencyOracle :: Rules ()
-dependencyOracle = do
-    deps <- newCache $ \file -> do
-        need [file]
-        putOracle $ "Reading " ++ file ++ "..."
-        contents <- parseMakefile <$> (liftIO $ readFile file)
-        return $ M.fromList
-               $ map (bimap unifyPath (map unifyPath))
-               $ map (bimap head concat . unzip)
-               $ groupBy ((==) `on` fst)
-               $ sortBy (compare `on` fst) contents
-    addOracle $ \(DependencyListKey (file, obj)) ->
-        M.lookup (unifyPath obj) <$> deps (unifyPath file)
-    return ()
-
--- Make oracle's output more distinguishable
-putOracle :: String -> Action ()
-putOracle = putColoured Blue

src/Oracles/ArgsHash.hs

 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
 
 module Oracles.ArgsHash (
-    ArgsHashKey (..), askArgsHash, argsHashOracle
+    askArgsHash, argsHashOracle
     ) where
 
 import Expression
@@ -11,8 +11,12 @@ import Development.Shake
 import Development.Shake.Classes
 
 newtype ArgsHashKey = ArgsHashKey FullTarget
-                      deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+    deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
 
+-- This is an action that given a full target determines the corresponding
+-- argument list and computes its hash. The resulting value is tracked in a
+-- Shake oracle, hence initiating rebuilts when the hash is changed (a hash
+-- change indicates changes in the build system).
 askArgsHash :: FullTarget -> Action Int
 askArgsHash = askOracle . ArgsHashKey
 

src/Oracles/Base.hs

 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
 
 module Oracles.Base (
-    ConfigKey (..),
-    askConfigWithDefault, askConfig
+    module Development.Shake,
+    module Development.Shake.Util,
+    module Development.Shake.Config,
+    module Development.Shake.Classes,
+    module Development.Shake.FilePath,
+    askConfigWithDefault, askConfig, configOracle,
+    configPath,
+    putOracle
     ) where
 
 import Util
+import Control.Applicative
+import Control.Monad.Extra
 import Development.Shake
+import Development.Shake.Util
+import Development.Shake.Config
 import Development.Shake.Classes
+import Development.Shake.FilePath
+import qualified Data.HashMap.Strict as Map
+
+configPath :: FilePath
+configPath = "shake" </> "cfg"
 
 newtype ConfigKey = ConfigKey String
     deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
@@ -20,5 +35,23 @@ askConfigWithDefault key defaultAction = do
         Nothing    -> defaultAction
 
 askConfig :: String -> Action String
-askConfig key = askConfigWithDefault key $
-    redError $ "Cannot find key '" ++ key ++ "' in configuration files."
+askConfig key = askConfigWithDefault key . redError
+    $ "Cannot find key '" ++ key ++ "' in configuration files."
+
+-- Oracle for configuration files
+configOracle :: Rules ()
+configOracle = do
+    let configFile = configPath </> "system.config"
+    cfg <- newCache $ \() -> do
+        unlessM (doesFileExist $ configFile <.> "in") $
+            redError_ $ "\nConfiguration file '" ++ (configFile <.> "in")
+                      ++ "' is missing; unwilling to proceed."
+        need [configFile]
+        putOracle $ "Reading " ++ unifyPath configFile ++ "..."
+        liftIO $ readConfigFile configFile
+    addOracle $ \(ConfigKey key) -> Map.lookup key <$> cfg ()
+    return ()
+
+-- Make oracle's output more distinguishable
+putOracle :: String -> Action ()
+putOracle = putColoured Blue

src/Oracles/DependencyList.hs

 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
 
 module Oracles.DependencyList (
-    DependencyList (..),
-    DependencyListKey (..),
-    dependencyList
+    dependencyList,
+    dependencyListOracle
     ) where
 
+import Util
+import Oracles.Base
+import Data.List
 import Data.Maybe
-import Development.Shake
-import Development.Shake.Classes
-
-data DependencyList = DependencyList FilePath FilePath
+import Data.Function
+import qualified Data.HashMap.Strict as Map
+import Control.Applicative
 
 newtype DependencyListKey = DependencyListKey (FilePath, FilePath)
-                        deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+    deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+
+-- dependencyList depFile objFile is an action that looks up dependencies of an
+-- object file (objFile) in a generated dependecy file (depFile).
+dependencyList :: FilePath -> FilePath -> Action [FilePath]
+dependencyList depFile objFile = do
+    res <- askOracle $ DependencyListKey (depFile, objFile)
+    return $ fromMaybe [] res
+
+-- Oracle for 'path/dist/*.deps' files
+dependencyListOracle :: Rules ()
+dependencyListOracle = do
+    deps <- newCache $ \file -> do
+        need [file]
+        putOracle $ "Reading " ++ file ++ "..."
+        contents <- parseMakefile <$> (liftIO $ readFile file)
+        return $ Map.fromList
+               $ map (bimap unifyPath (map unifyPath))
+               $ map (bimap head concat . unzip)
+               $ groupBy ((==) `on` fst)
+               $ sortBy (compare `on` fst) contents
+    addOracle $ \(DependencyListKey (file, obj)) ->
+        Map.lookup (unifyPath obj) <$> deps (unifyPath file)
+    return ()
 
-dependencyList :: DependencyList -> Action [FilePath]
-dependencyList (DependencyList file obj) = do
-        res <- askOracle $ DependencyListKey (file, obj)
-        return $ fromMaybe [] res
+bimap :: (a -> b) -> (c -> d) -> (a, c) -> (b, d)
+bimap f g (x, y) = (f x, g y)

src/Oracles/Flag.hs

@@ -5,7 +5,6 @@ module Oracles.Flag (
 
 import Util
 import Oracles.Base
-import Development.Shake
 
 data Flag = LaxDeps
           | DynamicGhcPrograms

src/Oracles/PackageData.hs

 {-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
 
 module Oracles.PackageData (
-    PackageData (..), PackageDataMulti (..),
-    PackageDataKey (..),
-    pkgData, pkgDataMulti
+    PackageData (..), PackageDataList (..),
+    pkgData, pkgDataList, packageDataOracle
     ) where
 
 import Util
+import Oracles.Base
 import Data.List
 import Data.Maybe
-import Development.Shake
-import Development.Shake.Classes
-import Development.Shake.FilePath
+import Control.Applicative
+import qualified Data.HashMap.Strict as Map
 
 -- For each (PackageData path) the file 'path/package-data.mk' contains
 -- a line of the form 'path_VERSION = 1.2.3.4'.
 -- pkgData $ PackageData path is an action that consults the file and
 -- returns "1.2.3.4".
 --
--- PackageDataMulti is used for multiple string options separated by spaces,
+-- PackageDataList is used for multiple string options separated by spaces,
 -- such as 'path_MODULES = Data.Array Data.Array.Base ...'.
--- pkgMultiData Modules therefore returns ["Data.Array", "Data.Array.Base", ...]
-
+-- pkgListData Modules therefore returns ["Data.Array", "Data.Array.Base", ...]
 data PackageData = Version     FilePath
                  | PackageKey  FilePath
                  | Synopsis    FilePath
 
-data PackageDataMulti = Modules        FilePath
-                      | SrcDirs        FilePath
-                      | IncludeDirs    FilePath
-                      | Deps           FilePath
-                      | DepKeys        FilePath
-                      | DepNames       FilePath
-                      | CppArgs        FilePath
-                      | HsArgs         FilePath
-                      | CcArgs         FilePath
-                      | CSrcs          FilePath
-                      | DepIncludeDirs FilePath
+data PackageDataList = Modules        FilePath
+                     | SrcDirs        FilePath
+                     | IncludeDirs    FilePath
+                     | Deps           FilePath
+                     | DepKeys        FilePath
+                     | DepNames       FilePath
+                     | CppArgs        FilePath
+                     | HsArgs         FilePath
+                     | CcArgs         FilePath
+                     | CSrcs          FilePath
+                     | DepIncludeDirs FilePath
 
 newtype PackageDataKey = PackageDataKey (FilePath, String)
-                        deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
+    deriving (Show, Typeable, Eq, Hashable, Binary, NFData)
 
 askPackageData :: FilePath -> String -> Action String
 askPackageData path key = do
@@ -61,8 +59,8 @@ pkgData packageData = do
     return $ fromMaybe
         (error $ "No key '" ++ key ++ "' in " ++ unifyPath pkgData ++ ".") res
 
-pkgDataMulti :: PackageDataMulti -> Action [String]
-pkgDataMulti packageData = do
+pkgDataList :: PackageDataList -> Action [String]
+pkgDataList packageData = do
     let (key, path, defaultValue) = case packageData of
            Modules        path -> ("MODULES"                       , path, "" )
            SrcDirs        path -> ("HS_SRC_DIRS"                   , path, ".")
@@ -84,3 +82,14 @@ pkgDataMulti packageData = do
                             ++ unifyPath pkgData ++ "."
         Just ""    -> defaultValue
         Just value -> value
+
+-- Oracle for 'package-data.mk' files
+packageDataOracle :: Rules ()
+packageDataOracle = do
+    pkgData <- newCache $ \file -> do
+        need [file]
+        putOracle $ "Reading " ++ file ++ "..."
+        liftIO $ readConfigFile file
+    addOracle $ \(PackageDataKey (file, key)) ->
+        Map.lookup key <$> pkgData (unifyPath file)
+    return ()

src/Oracles/Setting.hs

 module Oracles.Setting (
-    Setting (..), SettingMulti (..),
-    setting, settingMulti,
+    Setting (..), SettingList (..),
+    setting, settingList,
     windowsHost
     ) where
 
 import Stage
 import Oracles.Base
-import Development.Shake
 
 -- Each Setting comes from the system.config file, e.g. 'target-os = mingw32'.
 -- setting TargetOs looks up the config file and returns "mingw32".
 --
--- SettingMulti is used for multiple string values separated by spaces, such
+-- SettingList is used for multiple string values separated by spaces, such
 -- as 'src-hc-args = -H32m -O'.
--- settingMulti SrcHcArgs therefore returns a list of strings ["-H32", "-O"].
+-- settingList SrcHcArgs therefore returns a list of strings ["-H32", "-O"].
 data Setting = TargetOs
              | TargetArch
              | TargetPlatformFull
@@ -22,18 +21,18 @@ data Setting = TargetOs
              | ProjectVersion
              | GhcSourcePath
 
-data SettingMulti = SrcHcArgs
-                  | ConfCcArgs Stage
-                  | ConfGccLinkerArgs Stage
-                  | ConfLdLinkerArgs Stage
-                  | ConfCppArgs Stage
-                  | IconvIncludeDirs
-                  | IconvLibDirs
-                  | GmpIncludeDirs
-                  | GmpLibDirs
+data SettingList = SrcHcArgs
+                 | ConfCcArgs Stage
+                 | ConfGccLinkerArgs Stage
+                 | ConfLdLinkerArgs Stage
+                 | ConfCppArgs Stage
+                 | IconvIncludeDirs
+                 | IconvLibDirs
+                 | GmpIncludeDirs
+                 | GmpLibDirs
 
 setting :: Setting -> Action String
-setting s = askConfig $ case s of
+setting key = askConfig $ case key of
     TargetOs           -> "target-os"
     TargetArch         -> "target-arch"
     TargetPlatformFull -> "target-platform-full"
@@ -42,19 +41,17 @@ setting s = askConfig $ case s of
     ProjectVersion     -> "project-version"
     GhcSourcePath      -> "ghc-source-path"
 
-settingMulti :: SettingMulti -> Action [String]
-settingMulti s = fmap words $ askConfig $ case s of
+settingList :: SettingList -> Action [String]
+settingList key = fmap words $ askConfig $ case key of
     SrcHcArgs               -> "src-hc-args"
-    ConfCcArgs        stage -> "conf-cc-args"         ++ showStage stage
-    ConfCppArgs       stage -> "conf-cpp-args"        ++ showStage stage
-    ConfGccLinkerArgs stage -> "conf-gcc-linker-args" ++ showStage stage
-    ConfLdLinkerArgs  stage -> "conf-ld-linker-args"  ++ showStage stage
+    ConfCcArgs        stage -> "conf-cc-args-stage"         ++ show stage
+    ConfCppArgs       stage -> "conf-cpp-args-stage"        ++ show stage
+    ConfGccLinkerArgs stage -> "conf-gcc-linker-args-stage" ++ show stage
+    ConfLdLinkerArgs  stage -> "conf-ld-linker-args-stage"  ++ show stage
     IconvIncludeDirs        -> "iconv-include-dirs"
     IconvLibDirs            -> "iconv-lib-dirs"
     GmpIncludeDirs          -> "gmp-include-dirs"
     GmpLibDirs              -> "gmp-lib-dirs"
-  where
-    showStage = ("-stage" ++) . show
 
 windowsHost :: Action Bool
 windowsHost = do

src/Rules.hs

 module Rules (
     generateTargets, packageRules, oracleRules,
     module Rules.Package,
+    module Rules.Config,
     ) where
 
 import Stage
 import Expression
+import Rules.Config
 import Rules.Package
 import Rules.Oracles
 import Settings.Packages

src/Config.hs → src/Rules/Config.hs

-module Config (
-    autoconfRules, configureRules, cfgPath
+module Rules.Config (
+    autoconfRules, configureRules
     ) where
 
 import Util
-import Development.Shake
-import Development.Shake.FilePath
-
-cfgPath :: FilePath
-cfgPath = "shake" </> "cfg"
+import Oracles.Base
 
 autoconfRules :: Rules ()
 autoconfRules = do
     "configure" %> \out -> do
-        copyFile' (cfgPath </> "configure.ac") "configure.ac"
+        copyFile' (configPath </> "configure.ac") "configure.ac"
         putColoured White $ "Running autoconf..."
         cmd "bash autoconf" -- TODO: get rid of 'bash'
 
 configureRules :: Rules ()
 configureRules = do
-    cfgPath </> "system.config" %> \out -> do
-        need [cfgPath </> "system.config.in", "configure"]
+    configPath </> "system.config" %> \out -> do
+        need [configPath </> "system.config.in", "configure"]
         putColoured White "Running configure..."
         cmd "bash configure" -- TODO: get rid of 'bash'

src/Rules/Oracles.hs

@@ -2,11 +2,12 @@ module Rules.Oracles (
     oracleRules
     ) where
 
-import Oracles
+import Oracles.Base
 import Oracles.ArgsHash
+import Oracles.PackageData
+import Oracles.DependencyList
 import Data.Monoid
-import Development.Shake
 
 oracleRules :: Rules ()
 oracleRules =
-    configOracle <> packageDataOracle <> dependencyOracle <> argsHashOracle
+    configOracle <> packageDataOracle <> dependencyListOracle <> argsHashOracle

src/Settings/GhcCabal.hs

@@ -17,8 +17,6 @@ import Settings.Packages
 import Settings.TargetDirectory
 import Data.List
 import Control.Applicative
-import Development.Shake
-import Development.Shake.FilePath
 
 cabalArgs :: Args
 cabalArgs = builder GhcCabal ? do

src/Settings/Util.hs

@@ -16,7 +16,6 @@ import Stage
 import Builder
 import Oracles.Base
 import Expression
-import Development.Shake
 
 -- A single argument.
 arg :: String -> Args