1{-# LANGUAGE NoImplicitPrelude #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7
8-- | Build the project.
9
10module Stack.Build
11  (build
12  ,buildLocalTargets
13  ,loadPackage
14  ,mkBaseConfigOpts
15  ,queryBuildInfo
16  ,splitObjsWarning
17  ,CabalVersionException(..))
18  where
19
20import           Stack.Prelude hiding (loadPackage)
21import           Data.Aeson (Value (Object, Array), (.=), object)
22import qualified Data.HashMap.Strict as HM
23import           Data.List ((\\), isPrefixOf)
24import           Data.List.Extra (groupSort)
25import qualified Data.List.NonEmpty as NE
26import qualified Data.Map as Map
27import qualified Data.Set as Set
28import qualified Data.Text as T
29import           Data.Text.Encoding (decodeUtf8)
30import qualified Data.Text.IO as TIO
31import           Data.Text.Read (decimal)
32import qualified Data.Vector as V
33import qualified Data.Yaml as Yaml
34import qualified Distribution.PackageDescription as C
35import           Distribution.Types.Dependency (depLibraries)
36import           Distribution.Version (mkVersion)
37import           Path (parent)
38import           Stack.Build.ConstructPlan
39import           Stack.Build.Execute
40import           Stack.Build.Installed
41import           Stack.Build.Source
42import           Stack.Package
43import           Stack.Setup (withNewLocalBuildTargets)
44import           Stack.Types.Build
45import           Stack.Types.Config
46import           Stack.Types.NamedComponent
47import           Stack.Types.Package
48import           Stack.Types.SourceMap
49
50import           Stack.Types.Compiler (compilerVersionText, getGhcVersion)
51import           System.Terminal (fixCodePage)
52
53-- | Build.
54--
55--   If a buildLock is passed there is an important contract here.  That lock must
56--   protect the snapshot, and it must be safe to unlock it if there are no further
57--   modifications to the snapshot to be performed by this build.
58build :: HasEnvConfig env
59      => Maybe (Set (Path Abs File) -> IO ()) -- ^ callback after discovering all local files
60      -> RIO env ()
61build msetLocalFiles = do
62  mcp <- view $ configL.to configModifyCodePage
63  ghcVersion <- view $ actualCompilerVersionL.to getGhcVersion
64  fixCodePage mcp ghcVersion $ do
65    bopts <- view buildOptsL
66    sourceMap <- view $ envConfigL.to envConfigSourceMap
67    locals <- projectLocalPackages
68    depsLocals <- localDependencies
69    let allLocals = locals <> depsLocals
70
71    checkSubLibraryDependencies (Map.elems $ smProject sourceMap)
72
73    boptsCli <- view $ envConfigL.to envConfigBuildOptsCLI
74    -- Set local files, necessary for file watching
75    stackYaml <- view stackYamlL
76    for_ msetLocalFiles $ \setLocalFiles -> do
77      files <-
78        if boptsCLIWatchAll boptsCli
79        then sequence [lpFiles lp | lp <- allLocals]
80        else forM allLocals $ \lp -> do
81          let pn = packageName (lpPackage lp)
82          case Map.lookup pn (smtTargets $ smTargets sourceMap) of
83            Nothing ->
84              pure Set.empty
85            Just (TargetAll _) ->
86              lpFiles lp
87            Just (TargetComps components) ->
88              lpFilesForComponents components lp
89      liftIO $ setLocalFiles $ Set.insert stackYaml $ Set.unions files
90
91    checkComponentsBuildable allLocals
92
93    installMap <- toInstallMap sourceMap
94    (installedMap, globalDumpPkgs, snapshotDumpPkgs, localDumpPkgs) <-
95        getInstalled installMap
96
97    baseConfigOpts <- mkBaseConfigOpts boptsCli
98    plan <- constructPlan baseConfigOpts localDumpPkgs loadPackage sourceMap installedMap (boptsCLIInitialBuildSteps boptsCli)
99
100    allowLocals <- view $ configL.to configAllowLocals
101    unless allowLocals $ case justLocals plan of
102      [] -> return ()
103      localsIdents -> throwM $ LocalPackagesPresent localsIdents
104
105    checkCabalVersion
106    warnAboutSplitObjs bopts
107    warnIfExecutablesWithSameNameCouldBeOverwritten locals plan
108
109    when (boptsPreFetch bopts) $
110        preFetch plan
111
112    if boptsCLIDryrun boptsCli
113        then printPlan plan
114        else executePlan boptsCli baseConfigOpts locals
115                         globalDumpPkgs
116                         snapshotDumpPkgs
117                         localDumpPkgs
118                         installedMap
119                         (smtTargets $ smTargets sourceMap)
120                         plan
121
122buildLocalTargets :: HasEnvConfig env => NonEmpty Text -> RIO env (Either SomeException ())
123buildLocalTargets targets =
124  tryAny $ withNewLocalBuildTargets (NE.toList targets) $ build Nothing
125
126justLocals :: Plan -> [PackageIdentifier]
127justLocals =
128    map taskProvides .
129    filter ((== Local) . taskLocation) .
130    Map.elems .
131    planTasks
132
133checkCabalVersion :: HasEnvConfig env => RIO env ()
134checkCabalVersion = do
135    allowNewer <- view $ configL.to configAllowNewer
136    cabalVer <- view cabalVersionL
137    -- https://github.com/haskell/cabal/issues/2023
138    when (allowNewer && cabalVer < mkVersion [1, 22]) $ throwM $
139        CabalVersionException $
140            "Error: --allow-newer requires at least Cabal version 1.22, but version " ++
141            versionString cabalVer ++
142            " was found."
143    -- Since --exact-configuration is always passed, some old cabal
144    -- versions can no longer be used. See the following link for why
145    -- it's 1.19.2:
146    -- https://github.com/haskell/cabal/blob/580fe6b6bf4e1648b2f66c1cb9da9f1f1378492c/cabal-install/Distribution/Client/Setup.hs#L592
147    when (cabalVer < mkVersion [1, 19, 2]) $ throwM $
148        CabalVersionException $
149            "Stack no longer supports Cabal versions older than 1.19.2, but version " ++
150            versionString cabalVer ++
151            " was found.  To fix this, consider updating the resolver to lts-3.0 or later / nightly-2015-05-05 or later."
152
153newtype CabalVersionException = CabalVersionException { unCabalVersionException :: String }
154    deriving (Typeable)
155
156instance Show CabalVersionException where show = unCabalVersionException
157instance Exception CabalVersionException
158
159-- | See https://github.com/commercialhaskell/stack/issues/1198.
160warnIfExecutablesWithSameNameCouldBeOverwritten
161    :: HasLogFunc env => [LocalPackage] -> Plan -> RIO env ()
162warnIfExecutablesWithSameNameCouldBeOverwritten locals plan = do
163    logDebug "Checking if we are going to build multiple executables with the same name"
164    forM_ (Map.toList warnings) $ \(exe,(toBuild,otherLocals)) -> do
165        let exe_s
166                | length toBuild > 1 = "several executables with the same name:"
167                | otherwise = "executable"
168            exesText pkgs =
169                T.intercalate
170                    ", "
171                    ["'" <> T.pack (packageNameString p) <> ":" <> exe <> "'" | p <- pkgs]
172        (logWarn . display . T.unlines . concat)
173            [ [ "Building " <> exe_s <> " " <> exesText toBuild <> "." ]
174            , [ "Only one of them will be available via 'stack exec' or locally installed."
175              | length toBuild > 1
176              ]
177            , [ "Other executables with the same name might be overwritten: " <>
178                exesText otherLocals <> "."
179              | not (null otherLocals)
180              ]
181            ]
182  where
183    -- Cases of several local packages having executables with the same name.
184    -- The Map entries have the following form:
185    --
186    --  executable name: ( package names for executables that are being built
187    --                   , package names for other local packages that have an
188    --                     executable with the same name
189    --                   )
190    warnings :: Map Text ([PackageName],[PackageName])
191    warnings =
192        Map.mapMaybe
193            (\(pkgsToBuild,localPkgs) ->
194                case (pkgsToBuild,NE.toList localPkgs \\ NE.toList pkgsToBuild) of
195                    (_ :| [],[]) ->
196                        -- We want to build the executable of single local package
197                        -- and there are no other local packages with an executable of
198                        -- the same name. Nothing to warn about, ignore.
199                        Nothing
200                    (_,otherLocals) ->
201                        -- We could be here for two reasons (or their combination):
202                        -- 1) We are building two or more executables with the same
203                        --    name that will end up overwriting each other.
204                        -- 2) In addition to the executable(s) that we want to build
205                        --    there are other local packages with an executable of the
206                        --    same name that might get overwritten.
207                        -- Both cases warrant a warning.
208                        Just (NE.toList pkgsToBuild,otherLocals))
209            (Map.intersectionWith (,) exesToBuild localExes)
210    exesToBuild :: Map Text (NonEmpty PackageName)
211    exesToBuild =
212        collect
213            [ (exe,pkgName')
214            | (pkgName',task) <- Map.toList (planTasks plan)
215            , TTLocalMutable lp <- [taskType task]
216            , exe <- (Set.toList . exeComponents . lpComponents) lp
217            ]
218    localExes :: Map Text (NonEmpty PackageName)
219    localExes =
220        collect
221            [ (exe,packageName pkg)
222            | pkg <- map lpPackage locals
223            , exe <- Set.toList (packageExes pkg)
224            ]
225    collect :: Ord k => [(k,v)] -> Map k (NonEmpty v)
226    collect = Map.map NE.fromList . Map.fromDistinctAscList . groupSort
227
228warnAboutSplitObjs :: HasLogFunc env => BuildOpts -> RIO env ()
229warnAboutSplitObjs bopts | boptsSplitObjs bopts = do
230    logWarn $ "Building with --split-objs is enabled. " <> fromString splitObjsWarning
231warnAboutSplitObjs _ = return ()
232
233splitObjsWarning :: String
234splitObjsWarning = unwords
235     [ "Note that this feature is EXPERIMENTAL, and its behavior may be changed and improved."
236     , "You will need to clean your workdirs before use. If you want to compile all dependencies"
237     , "with split-objs, you will need to delete the snapshot (and all snapshots that could"
238     , "reference that snapshot)."
239     ]
240
241-- | Get the @BaseConfigOpts@ necessary for constructing configure options
242mkBaseConfigOpts :: (HasEnvConfig env)
243                 => BuildOptsCLI -> RIO env BaseConfigOpts
244mkBaseConfigOpts boptsCli = do
245    bopts <- view buildOptsL
246    snapDBPath <- packageDatabaseDeps
247    localDBPath <- packageDatabaseLocal
248    snapInstallRoot <- installationRootDeps
249    localInstallRoot <- installationRootLocal
250    packageExtraDBs <- packageDatabaseExtra
251    return BaseConfigOpts
252        { bcoSnapDB = snapDBPath
253        , bcoLocalDB = localDBPath
254        , bcoSnapInstallRoot = snapInstallRoot
255        , bcoLocalInstallRoot = localInstallRoot
256        , bcoBuildOpts = bopts
257        , bcoBuildOptsCLI = boptsCli
258        , bcoExtraDBs = packageExtraDBs
259        }
260
261-- | Provide a function for loading package information from the package index
262loadPackage
263  :: (HasBuildConfig env, HasSourceMap env)
264  => PackageLocationImmutable
265  -> Map FlagName Bool
266  -> [Text] -- ^ GHC options
267  -> [Text] -- ^ Cabal configure options
268  -> RIO env Package
269loadPackage loc flags ghcOptions cabalConfigOpts = do
270  compiler <- view actualCompilerVersionL
271  platform <- view platformL
272  let pkgConfig = PackageConfig
273        { packageConfigEnableTests = False
274        , packageConfigEnableBenchmarks = False
275        , packageConfigFlags = flags
276        , packageConfigGhcOptions = ghcOptions
277        , packageConfigCabalConfigOpts = cabalConfigOpts
278        , packageConfigCompilerVersion = compiler
279        , packageConfigPlatform = platform
280        }
281  resolvePackage pkgConfig <$> loadCabalFileImmutable loc
282
283-- | Query information about the build and print the result to stdout in YAML format.
284queryBuildInfo :: HasEnvConfig env
285               => [Text] -- ^ selectors
286               -> RIO env ()
287queryBuildInfo selectors0 =
288        rawBuildInfo
289    >>= select id selectors0
290    >>= liftIO . TIO.putStrLn . addGlobalHintsComment . decodeUtf8 . Yaml.encode
291  where
292    select _ [] value = return value
293    select front (sel:sels) value =
294        case value of
295            Object o ->
296                case HM.lookup sel o of
297                    Nothing -> err "Selector not found"
298                    Just value' -> cont value'
299            Array v ->
300                case decimal sel of
301                    Right (i, "")
302                        | i >= 0 && i < V.length v -> cont $ v V.! i
303                        | otherwise -> err "Index out of range"
304                    _ -> err "Encountered array and needed numeric selector"
305            _ -> err $ "Cannot apply selector to " ++ show value
306      where
307        cont = select (front . (sel:)) sels
308        err msg = throwString $ msg ++ ": " ++ show (front [sel])
309    -- Include comments to indicate that this portion of the "stack
310    -- query" API is not necessarily stable.
311    addGlobalHintsComment
312      | null selectors0 = T.replace globalHintsLine ("\n" <> globalHintsComment <> globalHintsLine)
313      -- Append comment instead of pre-pending. The reasoning here is
314      -- that something *could* expect that the result of 'stack query
315      -- global-hints ghc-boot' is just a string literal. Seems easier
316      -- for to expect the first line of the output to be the literal.
317      | ["global-hints"] `isPrefixOf` selectors0 = (<> ("\n" <> globalHintsComment))
318      | otherwise = id
319    globalHintsLine = "\nglobal-hints:\n"
320    globalHintsComment = T.concat
321      [ "# Note: global-hints is experimental and may be renamed / removed in the future.\n"
322      , "# See https://github.com/commercialhaskell/stack/issues/3796"
323      ]
324-- | Get the raw build information object
325rawBuildInfo :: HasEnvConfig env => RIO env Value
326rawBuildInfo = do
327    locals <- projectLocalPackages
328    wantedCompiler <- view $ wantedCompilerVersionL.to (utf8BuilderToText . display)
329    actualCompiler <- view $ actualCompilerVersionL.to compilerVersionText
330    return $ object
331        [ "locals" .= Object (HM.fromList $ map localToPair locals)
332        , "compiler" .= object
333            [ "wanted" .= wantedCompiler
334            , "actual" .= actualCompiler
335            ]
336        ]
337  where
338    localToPair lp =
339        (T.pack $ packageNameString $ packageName p, value)
340      where
341        p = lpPackage lp
342        value = object
343            [ "version" .= CabalString (packageVersion p)
344            , "path" .= toFilePath (parent $ lpCabalFile lp)
345            ]
346
347checkComponentsBuildable :: MonadThrow m => [LocalPackage] -> m ()
348checkComponentsBuildable lps =
349    unless (null unbuildable) $ throwM $ SomeTargetsNotBuildable unbuildable
350  where
351    unbuildable =
352        [ (packageName (lpPackage lp), c)
353        | lp <- lps
354        , c <- Set.toList (lpUnbuildable lp)
355        ]
356
357-- | Find if sublibrary dependency exist in each project
358checkSubLibraryDependencies :: HasLogFunc env => [ProjectPackage] -> RIO env ()
359checkSubLibraryDependencies proj = do
360  forM_ proj $ \p -> do
361    C.GenericPackageDescription _ _ lib subLibs foreignLibs exes tests benches <- liftIO $ cpGPD . ppCommon $ p
362
363    let dependencies = concatMap getDeps subLibs <>
364                       concatMap getDeps foreignLibs <>
365                       concatMap getDeps exes <>
366                       concatMap getDeps tests <>
367                       concatMap getDeps benches <>
368                       maybe [] C.condTreeConstraints lib
369        libraries = concatMap (toList . depLibraries) dependencies
370
371    when (subLibDepExist libraries)
372      (logWarn "SubLibrary dependency is not supported, this will almost certainly fail")
373  where
374    getDeps (_, C.CondNode _ dep _) = dep
375    subLibDepExist lib =
376      any (\x ->
377        case x of
378          C.LSubLibName _ -> True
379          C.LMainLibName  -> False
380      ) lib
381