Commit a820566c authored by Andrey Mokhov's avatar Andrey Mokhov
Browse files

Minor revision

parent ae35b2b2
{-# 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 ]
......
......@@ -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
......@@ -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"] ]
......@@ -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"
......
......@@ -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"
......
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