Minor revision

src/Builder.hs

@@ -22,7 +22,7 @@ import Stage
 data CompilerMode = Compile
                   | FindDependencies
                   | Link
-                  deriving (Show, Eq, Generic)
+                  deriving (Eq, Generic, Show)
 
 -- TODO: Do we really need HsCpp builder? Can't we use Cc instead?
 -- | A 'Builder' is an external command invoked in separate process using 'Shake.cmd'
@@ -57,7 +57,7 @@ data Builder = Alex
              | Ranlib
              | Tar
              | Unlit
-             deriving (Show, Eq, Generic)
+             deriving (Eq, Generic, Show)
 
 -- | Some builders are built by this very build system, in which case
 -- 'builderProvenance' returns the corresponding build 'Context' (which includes
@@ -93,7 +93,7 @@ isOptional = \case
     Objdump  -> True
     _        -> False
 
--- TODO: get rid of fromJust
+-- TODO: Get rid of fromJust.
 -- | Determine the location of a 'Builder'.
 builderPath :: Builder -> Action FilePath
 builderPath builder = case builderProvenance builder of
@@ -121,14 +121,14 @@ builderPath builder = case builderProvenance builder of
         _ -> error $ "Cannot determine builderPath for " ++ show builder
   where
     fromKey key = do
-        path <- askConfigWithDefault key . error $ "\nCannot find path to "
-            ++ quote key ++ " in system.config file. Did you skip configure?"
+        let unpack = fromMaybe . error $ "Cannot find path to builder "
+                ++ quote key ++ " in system.config file. Did you skip configure?"
+        path <- unpack <$> askConfig key
         if null path
         then do
-            if isOptional builder
-            then return ""
-            else error $ "Builder " ++ quote key ++ " is not specified in"
-                ++ " system.config file. Cannot proceed without it."
+            unless (isOptional builder) . error $ "Non optional builder "
+                ++ quote key ++ " is not specified in system.config file."
+            return "" -- TODO: Use a safe interface.
         else fixAbsolutePathOnWindows =<< lookupInPath path
 
 getBuilderPath :: Builder -> ReaderT a Action FilePath
@@ -141,6 +141,7 @@ builderEnvironment variable builder = do
     path <- builderPath builder
     return $ AddEnv variable path
 
+-- | Was the path to a given 'Builder' specified in configuration files?
 specified :: Builder -> Action Bool
 specified = fmap (not . null) . builderPath
 
@@ -152,7 +153,7 @@ needBuilder = \case
         path <- builderPath builder
         need [path]
 
--- Instances for storing in the Shake database
+-- | Instances for storing in the Shake database.
 instance Binary CompilerMode
 instance Hashable CompilerMode
 instance NFData CompilerMode

src/Expression.hs

-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, LambdaCase #-}
 module Expression (
     -- * Expressions
     Expr, DiffExpr, fromDiffExpr,
@@ -207,8 +207,6 @@ getOutput = do
         "getOutput: exactly one output file expected in target " ++ show target
 
 getSingleton :: Expr [a] -> String -> Expr a
-getSingleton expr msg = do
-    xs <- expr
-    case xs of
-        [res] -> return res
-        _     -> error msg
+getSingleton expr msg = expr >>= \case
+    [res] -> return res
+    _     -> error msg

src/Oracles/Config.hs

 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Oracles.Config (askConfig, askConfigWithDefault, configOracle) where
+module Oracles.Config (askConfig, unsafeAskConfig, configOracle) where
 
 import qualified Data.HashMap.Strict as Map
 import Development.Shake.Config
@@ -9,23 +9,19 @@ import Base
 newtype ConfigKey = ConfigKey String
     deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
 
-askConfig :: String -> Action String
-askConfig key = askConfigWithDefault key . error
-    $ "Cannot find key " ++ quote key ++ " in configuration files."
+unsafeAskConfig :: String -> Action String
+unsafeAskConfig key = (fromMaybe $ error msg) <$> askConfig key
+  where
+    msg = "Key " ++ quote key ++ " not found in configuration files."
 
-askConfigWithDefault :: String -> Action String -> Action String
-askConfigWithDefault key defaultAction = do
-    maybeValue <- askOracle $ ConfigKey key
-    case maybeValue of
-        Just value -> return value
-        Nothing    -> defaultAction
+askConfig :: String -> Action (Maybe String)
+askConfig = askOracle . ConfigKey
 
 -- Oracle for configuration files
 configOracle :: Rules ()
-configOracle = do
+configOracle = void $ do
     cfg <- newCache $ \() -> do
         need [configFile]
         putLoud $ "Reading " ++ configFile ++ "..."
         liftIO $ readConfigFile configFile
-    _ <- addOracle $ \(ConfigKey key) -> Map.lookup key <$> cfg ()
-    return ()
+    addOracle $ \(ConfigKey key) -> Map.lookup key <$> cfg ()

src/Oracles/Config/Flag.hs

@@ -25,23 +25,21 @@ data Flag = ArSupportsAtFile
 -- fragile, but some flags do behave like this, e.g. GccIsClang.
 flag :: Flag -> Action Bool
 flag f = do
-    key <- return $ case f of
-        ArSupportsAtFile   -> "ar-supports-at-file"
-        CrossCompiling     -> "cross-compiling"
-        GccIsClang         -> "gcc-is-clang"
-        GccLt46            -> "gcc-lt-46"
-        GhcUnregisterised  -> "ghc-unregisterised"
-        LeadingUnderscore  -> "leading-underscore"
-        SolarisBrokenShld  -> "solaris-broken-shld"
-        SplitObjectsBroken -> "split-objects-broken"
-        SupportsThisUnitId -> "supports-this-unit-id"
-        WithLibdw          -> "with-libdw"
-        UseSystemFfi       -> "use-system-ffi"
-    value <- askConfigWithDefault key . error
-        $ "\nFlag " ++ quote key ++ " not set in configuration files."
-    unless (value == "YES" || value == "NO" || value == "") . error
-        $ "\nFlag " ++ quote key ++ " is set to " ++ quote value
-        ++ " instead of 'YES' or 'NO'."
+    let key = case f of
+            ArSupportsAtFile   -> "ar-supports-at-file"
+            CrossCompiling     -> "cross-compiling"
+            GccIsClang         -> "gcc-is-clang"
+            GccLt46            -> "gcc-lt-46"
+            GhcUnregisterised  -> "ghc-unregisterised"
+            LeadingUnderscore  -> "leading-underscore"
+            SolarisBrokenShld  -> "solaris-broken-shld"
+            SplitObjectsBroken -> "split-objects-broken"
+            SupportsThisUnitId -> "supports-this-unit-id"
+            WithLibdw          -> "with-libdw"
+            UseSystemFfi       -> "use-system-ffi"
+    value <- unsafeAskConfig key
+    when (value `notElem` ["YES", "NO", ""]) . error $ "Configuration flag "
+        ++ quote (key ++ " = " ++ value) ++ "cannot be parsed."
     return $ value == "YES"
 
 getFlag :: Flag -> ReaderT a Action Bool

src/Oracles/Config/Setting.hs

@@ -59,7 +59,7 @@ data SettingList = ConfCcArgs Stage
                  | HsCppArgs
 
 setting :: Setting -> Action String
-setting key = askConfig $ case key of
+setting key = unsafeAskConfig $ case key of
     BuildArch          -> "build-arch"
     BuildOs            -> "build-os"
     BuildPlatform      -> "build-platform"
@@ -96,7 +96,7 @@ setting key = askConfig $ case key of
     IconvLibDir        -> "iconv-lib-dir"
 
 settingList :: SettingList -> Action [String]
-settingList key = fmap words $ askConfig $ case key of
+settingList key = fmap words $ unsafeAskConfig $ case key of
     ConfCcArgs        stage -> "conf-cc-args-"         ++ stageString stage
     ConfCppArgs       stage -> "conf-cpp-args-"        ++ stageString stage
     ConfGccLinkerArgs stage -> "conf-gcc-linker-args-" ++ stageString stage

src/Oracles/Dependencies.hs

@@ -41,18 +41,11 @@ newtype PkgDepsKey = PkgDepsKey String
 -- compute package dependencies we scan package cabal files, see "Rules.Cabal".
 contextDependencies :: Context -> Action [Context]
 contextDependencies context@Context {..} = do
-    maybeDeps <- askOracle . PkgDepsKey $ pkgNameString package
-    deps <- case maybeDeps of
-        Nothing -> error $ "Context dependencies not found for " ++ show context
-        Just ds -> return $ map PackageName ds
     let pkgContext = \pkg -> Context (min stage Stage1) pkg way
-    pkgs <- interpretInContext (pkgContext package) getPackages
-    return . map pkgContext $ matchPackageNames (sort pkgs) deps
-
--- | Given a sorted list of packages and a sorted list of package names, returns
--- packages whose names appear in the list of names.
-matchPackageNames :: [Package] -> [PackageName] -> [Package]
-matchPackageNames = intersectOrd (\pkg name -> compare (pkgName pkg) name)
+        unpack     = fromMaybe . error $ "No dependencies for " ++ show context
+    deps <- unpack <$> askOracle (PkgDepsKey $ pkgNameString package)
+    pkgs <- sort <$> interpretInContext (pkgContext package) getPackages
+    return . map pkgContext $ intersectOrd (compare . pkgNameString) pkgs deps
 
 -- | Coarse-grain 'need': make sure given contexts are fully built.
 needContext :: [Context] -> Action ()
@@ -71,14 +64,13 @@ needContext cs = do
 -- | Oracles for the package dependencies and 'path/dist/.dependencies' files.
 dependenciesOracles :: Rules ()
 dependenciesOracles = do
-    deps <- newCache $ \file -> do
-        putLoud $ "Reading dependencies from " ++ file ++ "..."
-        contents <- map words <$> readFileLines file
-        return . Map.fromList $ map (\(x:xs) -> (x, xs)) contents
+    deps <- newCache readDependencies
     void $ addOracle $ \(ObjDepsKey (file, obj)) -> Map.lookup obj <$> deps file
 
-    pkgDeps <- newCache $ \_ -> do
-        putLoud $ "Reading package dependencies..."
-        contents <- readFileLines packageDependencies
-        return $ Map.fromList [ (p, ps) | s <- contents, let p:ps = words s ]
+    pkgDeps <- newCache $ \_ -> readDependencies packageDependencies
     void $ addOracle $ \(PkgDepsKey pkg) -> Map.lookup pkg <$> pkgDeps ()
+  where
+    readDependencies file = do
+        putLoud $ "Reading dependencies from " ++ file ++ "..."
+        contents <- map words <$> readFileLines file
+        return $ Map.fromList [ (key, values) | (key:values) <- contents ]

src/Oracles/LookupInPath.hs

@@ -17,9 +17,7 @@ lookupInPath name
 lookupInPathOracle :: Rules ()
 lookupInPathOracle = void $
     addOracle $ \(LookupInPath name) -> do
-        maybePath <- liftIO $ findExecutable name
-        path <- case maybePath of
-            Just value -> return $ unifyPath value
-            Nothing    -> error $ "Cannot find executable '" ++ name ++ "'."
+        let unpack = fromMaybe . error $ "Cannot find executable " ++ quote name
+        path <- unifyPath <$> unpack <$> liftIO (findExecutable name)
         putLoud $ "Executable found: " ++ name ++ " => " ++ path
         return path

src/Oracles/ModuleFiles.hs

@@ -78,7 +78,7 @@ haskellSources context = do
     let autogen = buildPath context -/- "autogen"
     -- Generated source files live in buildPath and have extension "hs", except
     -- for GHC/Prim.hs that lives in autogen. TODO: fix the inconsistency?
-    let modFile ("GHC.Prim", _) = autogen -/- "GHC/Prim.hs"
+        modFile ("GHC.Prim", _) = autogen -/- "GHC/Prim.hs"
         modFile (m, Nothing   ) = generatedFile context m
         modFile (m, Just file )
             | takeExtension file `elem` haskellExtensions = file

src/Oracles/PackageData.hs

@@ -38,10 +38,7 @@ askPackageData :: FilePath -> String -> Action String
 askPackageData path key = do
     let fullKey = replaceSeparators '_' $ path ++ "_" ++ key
         file    = path -/- "package-data.mk"
-    maybeValue <- askOracle $ PackageDataKey (file, fullKey)
-    case maybeValue of
-        Nothing    -> return ""
-        Just value -> return value
+    fromMaybe "" <$> askOracle (PackageDataKey (file, fullKey))
 
 -- | 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

src/Predicate.hs

-{-# LANGUAGE LambdaCase, FlexibleInstances #-}
+{-# LANGUAGE FlexibleInstances, LambdaCase #-}
 -- | Convenient predicates
 module Predicate (
-    module Expression,
-    stage, stage0, stage1, stage2, notStage0,
-    package, notPackage, builder, input, output, way
+    module Expression, stage, stage0, stage1, stage2, notStage0, builder,
+    package, notPackage, input, output, way
     ) where
 
 import Base

src/Rules/Generate.hs

@@ -107,10 +107,8 @@ generatePackageCode context@(Context stage pkg _) =
         file <~ gen = generate file context gen
     in do
         generated ?> \file -> do
-            maybeValue <- findGenerator context file
-            (src, builder) <- case maybeValue of
-                Nothing    -> error $ "No generator for " ++ file ++ "."
-                Just value -> return value
+            let unpack = fromMaybe . error $ "No generator for " ++ file ++ "."
+            (src, builder) <- unpack <$> findGenerator context file
             need [src]
             build $ Target context builder [src] [file]
             let srcBoot = src -<.> "hs-boot"

src/Rules/Gmp.hs

@@ -54,7 +54,7 @@ gmpRules = do
             -- That's because the doc/ directory contents are under the GFDL,
             -- which causes problems for Debian.
             tarballs <- getDirectoryFiles "" [gmpBase -/- "tarball/gmp*.tar.bz2"]
-            tarball  <- case tarballs of
+            tarball  <- case tarballs of -- TODO: Drop code duplication.
                 [file] -> return $ unifyPath file
                 _      -> error $ "gmpRules: exactly one tarball expected"
                           ++ "(found: " ++ show tarballs ++ ")."
@@ -70,11 +70,10 @@ gmpRules = do
                     copyFile src patchPath
                     applyPatch tmp patch
 
-                let name = dropExtension . dropExtension $ takeFileName tarball
-                libName <- case stripSuffix "-nodoc-patched" name of
-                    Just rest -> return rest
-                    Nothing   -> error $ "gmpRules: expected suffix "
+                let name    = dropExtension . dropExtension $ takeFileName tarball
+                    unpack  = fromMaybe . error $ "gmpRules: expected suffix "
                         ++ "-nodoc-patched (found: " ++ name ++ ")."
+                    libName = unpack $ stripSuffix "-nodoc-patched" name
 
                 moveDirectory (tmp -/- libName) gmpBuildPath
 

src/Rules/Libffi.hs

@@ -72,7 +72,7 @@ libffiRules = do
             createDirectory $ buildRootPath -/- stageString Stage0
 
             tarballs <- getDirectoryFiles "" ["libffi-tarballs/libffi*.tar.gz"]
-            tarball  <- case tarballs of
+            tarball  <- case tarballs of -- TODO: Drop code duplication.
                 [file] -> return $ unifyPath file
                 _      -> error $ "libffiRules: exactly one tarball expected"
                           ++ "(found: " ++ show tarballs ++ ")."

src/Settings/Builders/GhcCabal.hs

@@ -114,7 +114,7 @@ withBuilderKey b = case b of
     Happy    -> "--with-happy="
     GhcPkg _ -> "--with-ghc-pkg="
     HsColour -> "--with-hscolour="
-    _        -> error "withBuilderKey: not supported builder"
+    _        -> error $ "withBuilderKey: not supported builder " ++ show b
 
 -- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
 with :: Builder -> Args