Base.hs 10.1 KB
Newer Older
1
2
3
4
5
6
{-# LANGUAGE NoImplicitPrelude #-}
module Package.Base (
    module Base,
    module Ways,
    module Util,
    module Oracles,
Andrey Mokhov's avatar
Andrey Mokhov committed
7
    module Settings,
8
    Package (..), Settings (..), TodoItem (..),
9
    defaultSettings, library, customise, updateSettings,
10
    commonCcArgs, commonLdArgs, commonCppArgs, commonCcWarninigArgs,
Andrey Mokhov's avatar
Andrey Mokhov committed
11
12
    pathArgs, packageArgs,
    includeGccArgs, includeGhcArgs, pkgHsSources,
13
    pkgDepHsObjects, pkgLibHsObjects, pkgCObjects,
14
    argSizeLimit,
15
16
17
    sourceDependecies,
    argList, argListWithComment,
    argListPath
18
19
20
21
22
23
    ) where

import Base
import Ways
import Util
import Oracles
Andrey Mokhov's avatar
Andrey Mokhov committed
24
import Settings
Andrey Mokhov's avatar
Andrey Mokhov committed
25
import qualified System.Directory as S
26
27
28

data Settings = Settings
     {
29
30
31
32
33
34
35
36
37
         customConfArgs  :: Args,         -- custom args for configure
         customCcArgs    :: Args,         -- custom args for Gcc
         customLdArgs    :: Args,         -- custom args for Ld
         customCppArgs   :: Args,         -- custom args for C preprocessor
         customDllArgs   :: Args,         -- custom dll args
         registerPackage :: Bool,         -- do we need to call ghc-pkg update?
         ways            :: Action [Way], -- ways to build
         buildWhen       :: Condition     -- skip the package if need be, e.g.
     }                                    -- don't build unix on Windows
38
39

defaultSettings :: Stage -> Settings
40
41
42
43
defaultSettings stage = Settings
                        {
                            customConfArgs  = mempty,
                            customCcArgs    = mempty,
Andrey Mokhov's avatar
Andrey Mokhov committed
44
45
46
                            customLdArgs    = mempty, -- currently not used
                            customCppArgs   = mempty, -- currently not used
                            customDllArgs   = mempty, -- only for compiler
47
48
49
50
                            registerPackage = True,
                            ways            = defaultWays stage,
                            buildWhen       = return True
                        }
51
52

-- Stage is the stage of the GHC that we use to build the package
53
54
55
56
-- FilePath is the directory to put the build results (relative to pkgPath)
-- The typical structure of that directory is:
-- * build/           : contains compiled object code
-- * doc/             : produced by haddock
Andrey Mokhov's avatar
Andrey Mokhov committed
57
-- * package-data.mk  : contains output of ghc-cabal applied to pkgCabal.cabal
58
-- Settings may be different for different combinations of Stage & FilePath
Andrey Mokhov's avatar
Andrey Mokhov committed
59
60
61
62
63
-- TODO: the above may be incorrect, settings seem to *only* depend on the
-- stage. In fact Stage seem to define FilePath and Settings, therefore we
-- can drop the TodoItem and replace it by [Stage] and two functions
--    * distDirectory :: Package -> Stage -> FilePath
--    * settings      :: Package -> Stage -> Settings
64
65
type TodoItem = (Stage, FilePath, Settings)

66
67
68
-- pkgPath is the path to the source code relative to the root
data Package = Package
     {
69
70
         pkgName  :: String,    -- For example: "deepseq"
         pkgPath  :: FilePath,  -- "libraries/deepseq"
71
         pkgCabal :: FilePath,  -- "deepseq"
72
         pkgTodo  :: [TodoItem] -- [(Stage1, "dist-install", defaultSettings)]
73
74
     }

75
76
77
78
79
80
81
82
83
updateSettings :: (Settings -> Settings) -> Package -> Package
updateSettings update (Package name path cabal todo) =
    Package name path cabal (map updateTodo todo)
  where
    updateTodo (stage, filePath, settings) = (stage, filePath, update settings)

customise :: Package -> (Package -> Package) -> Package
customise = flip ($)

84
85
libraryPackage :: String -> String -> [Stage] -> (Stage -> Settings) -> Package
libraryPackage name cabalName stages settings =
86
87
    Package
        name
88
        (unifyPath $ "libraries" </> name)
89
        cabalName
90
        [ (stage
91
        , if stage == Stage0 then "dist-boot" else "dist-install"
92
93
        , settings stage)
        | stage <- stages ]
94

95
96
library :: String -> [Stage] -> Package
library name stages = libraryPackage name name stages defaultSettings
97

98
commonCcArgs :: Args
99
commonCcArgs = when Validating $ args ["-Werror", "-Wall"]
100
101
102
103
104
105
106
107

commonLdArgs :: Args
commonLdArgs = mempty -- TODO: Why empty? Perhaps drop it altogether?

commonCppArgs :: Args
commonCppArgs = mempty -- TODO: Why empty? Perhaps drop it altogether?

commonCcWarninigArgs :: Args
108
109
110
111
112
commonCcWarninigArgs = when Validating $
    args [ when GccIsClang                      $ arg "-Wno-unknown-pragmas"
         , when (not GccIsClang && not GccLt46) $ arg "-Wno-error=inline"
         , when (GccIsClang && not GccLt46 && windowsHost) $
           arg "-Werror=unused-but-set-variable" ]
113

114
pathArgs :: ShowArgs a => String -> FilePath -> a -> Args
115
pathArgs key path as = map (\a -> key ++ unifyPath (path </> a)) <$> args as
116

117
packageArgs :: Stage -> FilePath -> Args
Andrey Mokhov's avatar
Andrey Mokhov committed
118
packageArgs stage pathDist = do
119
    usePackageKey <- SupportsPackageKey || stage /= Stage0
120
121
122
123
124
125
    args [ arg "-hide-all-packages"
         , arg "-no-user-package-db"
         , arg "-include-pkg-deps"
         , when (stage == Stage0) $
           arg "-package-db libraries/bootstrapping.conf"
         , if usePackageKey
126
127
128
129
130
           then productArgs ["-this-package-key"] [arg  $ PackageKey pathDist]
             <> productArgs ["-package-key"     ] [args $ DepKeys    pathDist]
           else productArgs ["-package-name"    ] [arg  $ PackageKey pathDist]
             <> productArgs ["-package"         ] [args $ Deps       pathDist]
         ]
131

Andrey Mokhov's avatar
Andrey Mokhov committed
132
133
134
includeGccArgs :: FilePath -> FilePath -> Args
includeGccArgs path dist =
    let pathDist = path </> dist
135
136
137
        autogen  = pathDist </> "build/autogen"
    in args [ arg $ "-I" ++ unifyPath autogen
            , pathArgs "-I" path $ IncludeDirs pathDist
Andrey Mokhov's avatar
Andrey Mokhov committed
138
139
            , pathArgs "-I" path $ DepIncludeDirs pathDist ]

140
141
includeGhcArgs :: FilePath -> FilePath -> Args
includeGhcArgs path dist =
Andrey Mokhov's avatar
Andrey Mokhov committed
142
    let pathDist = path </> dist
143
        buildDir = unifyPath $ pathDist </> "build"
144
145
146
    in args [ arg "-i"
            , pathArgs "-i" path $ SrcDirs pathDist
            , concatArgs ["-i", "-I"]
147
              [buildDir, unifyPath $ buildDir </> "autogen"]
148
149
            , pathArgs "-I" path $ IncludeDirs pathDist
            , arg "-optP-include" -- TODO: Shall we also add -cpp?
150
151
152
            , concatArgs ["-optP"]
              [unifyPath $ buildDir </> "autogen/cabal_macros.h"]
            ]
153

154
155
pkgHsSources :: FilePath -> FilePath -> Action [FilePath]
pkgHsSources path dist = do
Andrey Mokhov's avatar
Andrey Mokhov committed
156
    let pathDist = path </> dist
Andrey Mokhov's avatar
Andrey Mokhov committed
157
        autogen = pathDist </> "build/autogen"
158
    dirs <- map (path </>) <$> args (SrcDirs pathDist)
Andrey Mokhov's avatar
Andrey Mokhov committed
159
    findModuleFiles pathDist (autogen:dirs) [".hs", ".lhs"]
160

161
162
163
164
165
-- TODO: look for non-{hs,c} objects too

-- Find Haskell objects we depend on (we don't want to depend on split objects)
pkgDepHsObjects :: FilePath -> FilePath -> Way -> Action [FilePath]
pkgDepHsObjects path dist way = do
Andrey Mokhov's avatar
Andrey Mokhov committed
166
167
    let pathDist = path </> dist
        buildDir = pathDist </> "build"
168
169
    dirs <- map (dropWhileEnd isPathSeparator . unifyPath . (path </>))
            <$> args (SrcDirs pathDist)
Andrey Mokhov's avatar
Andrey Mokhov committed
170
    fmap concat $ forM dirs $ \d ->
171
        map (unifyPath . (buildDir ++) . (-<.> osuf way) . drop (length d))
Andrey Mokhov's avatar
Andrey Mokhov committed
172
        <$> (findModuleFiles pathDist [d] [".hs", ".lhs"])
173

174
175
176
177
178
pkgCObjects :: FilePath -> FilePath -> Way -> Action [FilePath]
pkgCObjects path dist way = do
    let pathDist = path </> dist
        buildDir = pathDist </> "build"
    srcs <- args $ CSrcs pathDist
179
    return $ map (unifyPath . (buildDir </>) . (-<.> osuf way)) srcs
180
181
182
183

-- Find Haskell objects that go to library
pkgLibHsObjects :: FilePath -> FilePath -> Stage -> Way -> Action [FilePath]
pkgLibHsObjects path dist stage way = do
Andrey Mokhov's avatar
Andrey Mokhov committed
184
    let pathDist = path </> dist
185
        buildDir = unifyPath $ pathDist </> "build"
186
    split <- splitObjects stage
Andrey Mokhov's avatar
Andrey Mokhov committed
187
    depObjs <- pkgDepHsObjects path dist way
188
189
    if split
    then do
Andrey Mokhov's avatar
Andrey Mokhov committed
190
         need depObjs -- Otherwise, split objects may not yet be available
Andrey Mokhov's avatar
Andrey Mokhov committed
191
192
         let suffix = "_" ++ osuf way ++ "_split/*." ++ osuf way
         findModuleFiles pathDist [buildDir] [suffix]
Andrey Mokhov's avatar
Andrey Mokhov committed
193
    else do return depObjs
194
195

findModuleFiles :: FilePath -> [FilePath] -> [String] -> Action [FilePath]
Andrey Mokhov's avatar
Andrey Mokhov committed
196
findModuleFiles pathDist directories suffixes = do
197
    modPaths <- map (replaceEq '.' pathSeparator) <$> args (Modules pathDist)
Andrey Mokhov's avatar
Andrey Mokhov committed
198
199
200
201
202
203
204
    fileList <- forM [ dir </> modPath ++ suffix
                     | dir     <- directories
                     , modPath <- modPaths
                     , suffix  <- suffixes
                     ] $ \file -> do
                         let dir = takeDirectory file
                         dirExists <- liftIO $ S.doesDirectoryExist dir
205
                         when dirExists $ return $ unifyPath file
Andrey Mokhov's avatar
Andrey Mokhov committed
206
    files <- getDirectoryFiles "" fileList
207
    return $ map unifyPath files
208
209
210
211
212
213
214
215
216
217

-- The argument list has a limited size on Windows. Since Windows 7 the limit
-- is 32768 (theoretically). In practice we use 31000 to leave some breathing
-- space for the builder's path & name, auxiliary flags, and other overheads.
-- Use this function to set limits for other operating systems if necessary.
argSizeLimit :: Action Int
argSizeLimit = do
    windows <- windowsHost
    return $ if windows
             then 31000
218
             else 4194304 -- Cabal needs a bit more than 2MB!
219
220
221
222
223
224
225
226
227
228
229
230

-- List of source files, which need to be tracked by the build system
-- to make sure the argument lists have not changed.
sourceDependecies :: [FilePath]
sourceDependecies = [ "shake/src/Package/Base.hs"
                    , "shake/src/Oracles/Base.hs"
                    , "shake/src/Oracles/Flag.hs"
                    , "shake/src/Oracles/Option.hs"
                    , "shake/src/Oracles/Builder.hs"
                    , "shake/src/Oracles/PackageData.hs"
                    , "shake/src/Ways.hs"
                    , "shake/src/Util.hs"
231
                    , "shake/src/Oracles.hs" ]
232

233
234
235
236
-- Convert Builder's argument list to a printable String
argListWithComment :: String -> Builder -> Args -> Action String
argListWithComment comment builder args = do
    args' <- args
237
    return $ show builder ++ " arguments"
238
239
240
241
242
           ++ (if null comment then "" else " (" ++ comment ++ ")")
           ++ ":\n" ++ concatMap (\s -> "    " ++ s ++ "\n") args'

argList :: Builder -> Args -> Action String
argList = argListWithComment ""
243
244
245

-- Path to argument list for a given Package/Stage combination
argListPath :: FilePath -> Package -> Stage -> FilePath
246
argListPath dir (Package name _ _ _) stage =
247
    dir </> takeBaseName name ++ " (stage " ++ show stage ++ ")" <.> "txt"