Minor revision
authorAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 27 Aug 2018 23:33:13 +0000 (00:33 +0100)
committerAndrey Mokhov <andrey.mokhov@gmail.com>
Mon, 27 Aug 2018 23:33:13 +0000 (00:33 +0100)
src/Oracles/ModuleFiles.hs
src/Settings/Builders/Cabal.hs
src/Settings/Builders/Ghc.hs
src/Settings/Builders/Haddock.hs
src/Settings/Packages.hs

index cb2011c..ee7c9bd 100644 (file)
@@ -1,10 +1,10 @@
 {-# LANGUAGE TypeFamilies #-}
 module Oracles.ModuleFiles (
-    decodeModule, encodeModule, findGenerator, hsSources, hsObjects, moduleFilesOracle
+    decodeModule, encodeModule, findGenerator, hsSources, hsObjects,
+    moduleFilesOracle
     ) where
 
 import qualified Data.HashMap.Strict as Map
-
 import Hadrian.Haskell.Cabal.PackageData as PD
 
 import Base
@@ -13,6 +13,8 @@ import Context
 import Expression
 import Packages
 
+type ModuleName = String
+
 newtype ModuleFiles = ModuleFiles (Stage, Package)
     deriving (Binary, Eq, Hashable, NFData, Show, Typeable)
 type instance RuleResult ModuleFiles = [Maybe FilePath]
@@ -42,21 +44,21 @@ moduleFilePatterns stage = map ("*" ++) $ haskellExtensions ++ map fst (otherExt
 determineBuilder :: Stage -> FilePath -> Maybe Builder
 determineBuilder stage file = lookup (takeExtension file) (otherExtensions stage)
 
--- | Given a module name extract the directory and file name, e.g.:
+-- | Given a non-empty module name extract the directory and file name, e.g.:
 --
 -- > decodeModule "Data.Functor.Identity" == ("Data/Functor", "Identity")
 -- > decodeModule "Prelude"               == ("", "Prelude")
-decodeModule :: String -> (FilePath, String)
-decodeModule modName = (intercalate "/" (init xs), last xs)
+decodeModule :: ModuleName -> (FilePath, String)
+decodeModule moduleName = (intercalate "/" (init xs), last xs)
   where
-    xs = words $ replaceEq '.' ' ' modName
+    xs = words $ replaceEq '.' ' ' moduleName
 
 -- | Given the directory and file name find the corresponding module name, e.g.:
 --
 -- > encodeModule "Data/Functor" "Identity.hs" == "Data.Functor.Identity"
 -- > encodeModule "" "Prelude"                 == "Prelude"
 -- > uncurry encodeModule (decodeModule name)  == name
-encodeModule :: FilePath -> String -> String
+encodeModule :: FilePath -> String -> ModuleName
 encodeModule dir file
     | dir == "" =                                takeBaseName file
     | otherwise = replaceEq '/' '.' dir ++ '.' : takeBaseName file
@@ -94,19 +96,18 @@ hsObjects context = do
     mapM (objectPath context . moduleSource) modules
 
 -- | Generated module files live in the 'Context' specific build directory.
-generatedFile :: Context -> String -> Action FilePath
-generatedFile context moduleName = do
-    path <- buildPath context
-    return $ path -/- moduleSource moduleName
+generatedFile :: Context -> ModuleName -> Action FilePath
+generatedFile context moduleName = buildPath context <&> (-/- moduleSource moduleName)
 
-moduleSource :: String -> FilePath
+-- | Turn a module name (e.g. @Data.Functor@) to a path (e.g. @Data/Functor.hs@).
+moduleSource :: ModuleName -> FilePath
 moduleSource moduleName = replaceEq '.' '/' moduleName <.> "hs"
 
 -- | Module files for a given 'Context'.
-contextFiles :: Context -> Action [(String, Maybe FilePath)]
+contextFiles :: Context -> Action [(ModuleName, Maybe FilePath)]
 contextFiles context@Context {..} = do
     modules <- fmap sort . interpretInContext context $
-      getPackageData PD.modules
+        getPackageData PD.modules
     zip modules <$> askOracle (ModuleFiles (stage, package))
 
 -- | This is an important oracle whose role is to find and cache module source
@@ -143,21 +144,21 @@ moduleFilesOracle = void $ do
                     found = intersectOrd cmp files mFiles
                 return (map (fullDir -/-) found, mDir)
 
-        -- For a BuildInfo, it may be a library, which deosn't have the `Main`
-        -- module, or an executable, which must have the `Main` module and the
-        -- file path of `Main` module is indicated by the `main-is` field in it's
-        -- .cabal file.
+        -- For a BuildInfo, it may be a library, which doesn't have the @Main@
+        -- module, or an executable, which must have the @Main@ module and the
+        -- file path of @Main@ module is indicated by the @main-is@ field in its
+        -- Cabal file.
         --
-        -- For `Main` module, the file name may not be `Main.hs`, unlike other
+        -- For the Main module, the file name may not be @Main.hs@, unlike other
         -- exposed modules. We could get the file path by the module name for
-        -- other exposed modules, but for `Main`, we must resolve the file path
-        -- via the `main-is` field in the .cabal file.
+        -- other exposed modules, but for @Main@ we must resolve the file path
+        -- via the @main-is@ field in the Cabal file.
         mainpairs <- case mainIs of
             Just (mod, filepath) ->
                 concatForM dirs $ \dir -> do
                     found <- doesFileExist (dir -/- filepath)
                     return [(mod, unifyPath $ dir -/- filepath) | found]
-            Nothing              -> return []
+            Nothing -> return []
 
         let pairs = sort $ mainpairs ++ [ (encodeModule d f, f) | (fs, d) <- result, f <- fs ]
             multi = [ (m, f1, f2) | (m, f1):(n, f2):_ <- tails pairs, m == n ]
index 685b84f..c314f26 100644 (file)
@@ -133,7 +133,7 @@ withBuilderKey b = case b of
     GhcPkg _ _ -> "--with-ghc-pkg="
     _          -> error $ "withBuilderKey: not supported builder " ++ show b
 
--- Adds arguments to builders if needed.
+-- | Add arguments to builders if needed.
 withBuilderArgs :: Builder -> Args
 withBuilderArgs b = case b of
     GhcPkg _ stage -> do
@@ -142,15 +142,14 @@ withBuilderArgs b = case b of
       notStage0 ? arg ("--ghc-pkg-option=--global-package-db=" ++ top -/- pkgDb)
     _          -> return [] -- no arguments
 
-
--- Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
+-- | Expression 'with Alex' appends "--with-alex=/path/to/alex" and needs Alex.
 with :: Builder -> Args
 with b = do
     path <- getBuilderPath b
-    if (null path) then mempty else do
-        top  <- expr topDirectory
+    if null path then mempty else do
+        top <- expr topDirectory
         expr $ needBuilder b
-        arg $ withBuilderKey b ++ unifyPath (top </> path)
+        arg  $ withBuilderKey b ++ unifyPath (top </> path)
 
 withStaged :: (Stage -> Builder) -> Args
 withStaged sb = with . sb =<< getStage
index 4d6aa67..1eb31a0 100644 (file)
@@ -67,27 +67,24 @@ findHsDependencies = builder (Ghc FindHsDependencies) ? do
 haddockGhcArgs :: Args
 haddockGhcArgs = mconcat [ commonGhcArgs, getPackageData PD.hcOpts ]
 
--- Used in ghcBuilderArgs, ghcCBuilderArgs, ghcMBuilderArgs and haddockGhcArgs.
+-- | Common GHC command line arguments used in 'ghcBuilderArgs',
+-- 'ghcCBuilderArgs', 'ghcMBuilderArgs' and 'haddockGhcArgs'.
 commonGhcArgs :: Args
 commonGhcArgs = do
-    way     <- getWay
-    path    <- getBuildPath
-    pkg     <- getPackage
-    ghcVersion <- expr $ ghcVersionH
+    way  <- getWay
+    path <- getBuildPath
+    ghcVersion <- expr ghcVersionH
     mconcat [ arg "-hisuf", arg $ hisuf way
             , arg "-osuf" , arg $  osuf way
             , arg "-hcsuf", arg $ hcsuf way
             , wayGhcArgs
             , packageGhcArgs
             , includeGhcArgs
-            -- when compiling the rts for stage1 or stage2
-            -- we do not have the rts in the package db at
-            -- the time of builind it.  As such we need to
-            -- explicity supply the path to the ghc-version
-            -- file, to prevent ghc from trying to open the
-            -- rts package from the package db, and failing
-            -- over while doing so.
-            , (pkg == rts) ? notStage0 ? arg ("-ghcversion-file=" ++ ghcVersion)
+            -- When compiling RTS for Stage1 or Stage2 we do not have it (yet)
+            -- in the package database. We therefore explicity supply the path
+            -- to the @ghc-version@ file, to prevent GHC from trying to open the
+            -- RTS package in the package database and failing.
+            , package rts ? notStage0 ? arg ("-ghcversion-file=" ++ ghcVersion)
             , map ("-optc" ++) <$> getStagedSettingList ConfCcArgs
             , map ("-optP" ++) <$> getStagedSettingList ConfCppArgs
             , map ("-optP" ++) <$> getPackageData PD.cppOpts
@@ -133,4 +130,4 @@ includeGhcArgs = do
             , cIncludeArgs
             , arg $      "-I" ++ root -/- generatedDir
             , arg $ "-optc-I" ++ root -/- generatedDir
-            , pure [ "-optP-include", "-optP" ++ autogen -/- "cabal_macros.h" ] ]
+            , pure ["-optP-include", "-optP" ++ autogen -/- "cabal_macros.h"] ]
index 2486569..a81e3fe 100644 (file)
@@ -11,6 +11,7 @@ import Settings.Builders.Ghc
 versionToInt :: String -> Int
 versionToInt = read . dropWhile (=='0') . filter (/='.')
 
+-- TODO: Get rid of partiality (see @Just foo <- @).
 haddockBuilderArgs :: Args
 haddockBuilderArgs = withHsPackage $ \ctx -> mconcat
     [ builder (Haddock BuildIndex) ? do
@@ -30,16 +31,16 @@ haddockBuilderArgs = withHsPackage $ \ctx -> mconcat
                      ++ "," ++ haddock | haddock <- inputs ] ]
 
     , builder (Haddock BuildPackage) ? do
-        output   <- getOutput
-        pkg      <- getPackage
-        root     <- getBuildRoot
-        path     <- getBuildPath
+        output        <- getOutput
+        pkg           <- getPackage
+        root          <- getBuildRoot
+        path          <- getBuildPath
         Just version  <- expr $ pkgVersion  ctx
         Just synopsis <- expr $ pkgSynopsis ctx
-        deps     <- getPackageData PD.depNames
-        haddocks <- expr . haddockDependencies =<< getContext
+        deps          <- getPackageData PD.depNames
+        haddocks      <- expr . haddockDependencies =<< getContext
         Just hVersion <- expr $ pkgVersion ctx
-        ghcOpts  <- haddockGhcArgs
+        ghcOpts       <- haddockGhcArgs
         mconcat
             [ arg "--verbosity=0"
             , arg $ "-B" ++ root -/- "stage1" -/- "lib"
index a1c156a..5249c5a 100644 (file)
@@ -11,13 +11,12 @@ import Settings
 -- | Package-specific command-line arguments.
 packageArgs :: Args
 packageArgs = do
-    intLib            <- getIntegerPackage
-    stage             <- getStage
-    path              <- getBuildPath
-    rtsWays           <- getRtsWays
-    compilerBuildPath <- expr $ buildPath (vanillaContext stage compiler)
-    gmpBuildPath      <- expr gmpBuildPath
-
+    stage        <- getStage
+    rtsWays      <- getRtsWays
+    path         <- getBuildPath
+    intLib       <- getIntegerPackage
+    compilerPath <- expr $ buildPath (vanillaContext stage compiler)
+    gmpBuildPath <- expr gmpBuildPath
     let includeGmp = "-I" ++ gmpBuildPath -/- "include"
 
     mconcat
@@ -85,7 +84,7 @@ packageArgs = do
 
         ---------------------------------- ghc ---------------------------------
         , package ghc ? mconcat
-          [ builder Ghc ? arg ("-I" ++ compilerBuildPath)
+          [ builder Ghc ? arg ("-I" ++ compilerPath)
 
           , builder (Cabal Flags) ? mconcat
             [ ghcWithInterpreter ? notStage0 ? arg "ghci"