1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE RankNTypes #-}
3{-# LANGUAGE RecordWildCards #-}
4module Stack.SourceMap
5    ( mkProjectPackage
6    , snapToDepPackage
7    , additionalDepPackage
8    , loadVersion
9    , getPLIVersion
10    , loadGlobalHints
11    , DumpedGlobalPackage
12    , actualFromGhc
13    , actualFromHints
14    , checkFlagsUsedThrowing
15    , globalCondCheck
16    , pruneGlobals
17    , globalsFromHints
18    , getCompilerInfo
19    , immutableLocSha
20    , loadProjectSnapshotCandidate
21    , SnapshotCandidate
22    , globalsFromDump
23    ) where
24
25import Data.ByteString.Builder (byteString)
26import qualified Data.Conduit.List as CL
27import qualified Distribution.PackageDescription as PD
28import Distribution.System (Platform(..))
29import Pantry
30import qualified Pantry.SHA256 as SHA256
31import qualified RIO
32import qualified RIO.Map as Map
33import qualified RIO.Set as Set
34import RIO.Process
35import Stack.PackageDump
36import Stack.Prelude
37import Stack.Types.Build
38import Stack.Types.Compiler
39import Stack.Types.Config
40import Stack.Types.SourceMap
41
42-- | Create a 'ProjectPackage' from a directory containing a package.
43mkProjectPackage ::
44       forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
45    => PrintWarnings
46    -> ResolvedPath Dir
47    -> Bool
48    -> RIO env ProjectPackage
49mkProjectPackage printWarnings dir buildHaddocks = do
50   (gpd, name, cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)
51   return ProjectPackage
52     { ppCabalFP = cabalfp
53     , ppResolvedDir = dir
54     , ppCommon = CommonPackage
55                  { cpGPD = gpd printWarnings
56                  , cpName = name
57                  , cpFlags = mempty
58                  , cpGhcOptions = mempty
59                  , cpCabalConfigOpts = mempty
60                  , cpHaddocks = buildHaddocks
61                  }
62     }
63
64-- | Create a 'DepPackage' from a 'PackageLocation', from some additional
65-- to a snapshot setting (extra-deps or command line)
66additionalDepPackage
67  :: forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
68  => Bool
69  -> PackageLocation
70  -> RIO env DepPackage
71additionalDepPackage buildHaddocks pl = do
72  (name, gpdio) <-
73    case pl of
74      PLMutable dir -> do
75        (gpdio, name, _cabalfp) <- loadCabalFilePath (resolvedAbsolute dir)
76        pure (name, gpdio NoPrintWarnings)
77      PLImmutable pli -> do
78        let PackageIdentifier name _ = packageLocationIdent pli
79        run <- askRunInIO
80        pure (name, run $ loadCabalFileImmutable pli)
81  return DepPackage
82    { dpLocation = pl
83    , dpHidden = False
84    , dpFromSnapshot = NotFromSnapshot
85    , dpCommon = CommonPackage
86                  { cpGPD = gpdio
87                  , cpName = name
88                  , cpFlags = mempty
89                  , cpGhcOptions = mempty
90                  , cpCabalConfigOpts = mempty
91                  , cpHaddocks = buildHaddocks
92                  }
93    }
94
95snapToDepPackage ::
96       forall env. (HasPantryConfig env, HasLogFunc env, HasProcessContext env)
97    => Bool
98    -> PackageName
99    -> SnapshotPackage
100    -> RIO env DepPackage
101snapToDepPackage buildHaddocks name SnapshotPackage{..} = do
102  run <- askRunInIO
103  return DepPackage
104    { dpLocation = PLImmutable spLocation
105    , dpHidden = spHidden
106    , dpFromSnapshot = FromSnapshot
107    , dpCommon = CommonPackage
108                  { cpGPD = run $ loadCabalFileImmutable spLocation
109                  , cpName = name
110                  , cpFlags = spFlags
111                  , cpGhcOptions = spGhcOptions
112                  , cpCabalConfigOpts = [] -- No spCabalConfigOpts, not present in snapshots
113                  , cpHaddocks = buildHaddocks
114                  }
115    }
116
117loadVersion :: MonadIO m => CommonPackage -> m Version
118loadVersion common = do
119    gpd <- liftIO $ cpGPD common
120    return (pkgVersion $ PD.package $ PD.packageDescription gpd)
121
122getPLIVersion :: PackageLocationImmutable -> Version
123getPLIVersion (PLIHackage (PackageIdentifier _ v) _ _) = v
124getPLIVersion (PLIArchive _ pm) = pkgVersion $ pmIdent pm
125getPLIVersion (PLIRepo _ pm) = pkgVersion $ pmIdent pm
126
127globalsFromDump ::
128       (HasLogFunc env, HasProcessContext env)
129    => GhcPkgExe
130    -> RIO env (Map PackageName DumpedGlobalPackage)
131globalsFromDump pkgexe = do
132    let pkgConduit =
133            conduitDumpPackage .|
134            CL.foldMap (\dp -> Map.singleton (dpGhcPkgId dp) dp)
135        toGlobals ds =
136          Map.fromList $ map (pkgName . dpPackageIdent &&& id) $ Map.elems ds
137    toGlobals <$> ghcPkgDump pkgexe [] pkgConduit
138
139globalsFromHints ::
140       HasConfig env
141    => WantedCompiler
142    -> RIO env (Map PackageName Version)
143globalsFromHints compiler = do
144    mglobalHints <- loadGlobalHints compiler
145    case mglobalHints of
146        Just hints -> pure hints
147        Nothing -> do
148            logWarn $ "Unable to load global hints for " <> RIO.display compiler
149            pure mempty
150
151type DumpedGlobalPackage = DumpPackage
152
153actualFromGhc ::
154       (HasConfig env, HasCompiler env)
155    => SMWanted
156    -> ActualCompiler
157    -> RIO env (SMActual DumpedGlobalPackage)
158actualFromGhc smw ac = do
159    globals <- view $ compilerPathsL.to cpGlobalDump
160    return
161        SMActual
162        { smaCompiler = ac
163        , smaProject = smwProject smw
164        , smaDeps = smwDeps smw
165        , smaGlobal = globals
166        }
167
168actualFromHints ::
169       (HasConfig env)
170    => SMWanted
171    -> ActualCompiler
172    -> RIO env (SMActual GlobalPackageVersion)
173actualFromHints smw ac = do
174    globals <- globalsFromHints (actualToWanted ac)
175    return
176        SMActual
177        { smaCompiler = ac
178        , smaProject = smwProject smw
179        , smaDeps = smwDeps smw
180        , smaGlobal = Map.map GlobalPackageVersion globals
181        }
182
183-- | Simple cond check for boot packages - checks only OS and Arch
184globalCondCheck :: (HasConfig env) => RIO env (PD.ConfVar -> Either PD.ConfVar Bool)
185globalCondCheck = do
186  Platform arch os <- view platformL
187  let condCheck (PD.OS os') = pure $ os' == os
188      condCheck (PD.Arch arch') = pure $ arch' == arch
189      condCheck c = Left c
190  return condCheck
191
192checkFlagsUsedThrowing ::
193       (MonadIO m, MonadThrow m)
194    => Map PackageName (Map FlagName Bool)
195    -> FlagSource
196    -> Map PackageName ProjectPackage
197    -> Map PackageName DepPackage
198    -> m ()
199checkFlagsUsedThrowing packageFlags source prjPackages deps = do
200    unusedFlags <-
201        forMaybeM (Map.toList packageFlags) $ \(pname, flags) ->
202            getUnusedPackageFlags (pname, flags) source prjPackages deps
203    unless (null unusedFlags) $
204        throwM $ InvalidFlagSpecification $ Set.fromList unusedFlags
205
206getUnusedPackageFlags ::
207       MonadIO m
208    => (PackageName, Map FlagName Bool)
209    -> FlagSource
210    -> Map PackageName ProjectPackage
211    -> Map PackageName DepPackage
212    -> m (Maybe UnusedFlags)
213getUnusedPackageFlags (name, userFlags) source prj deps =
214    let maybeCommon =
215          fmap ppCommon (Map.lookup name prj) <|>
216          fmap dpCommon (Map.lookup name deps)
217    in case maybeCommon  of
218        -- Package is not available as project or dependency
219        Nothing ->
220            pure $ Just $ UFNoPackage source name
221        -- Package exists, let's check if the flags are defined
222        Just common -> do
223            gpd <- liftIO $ cpGPD common
224            let pname = pkgName $ PD.package $ PD.packageDescription gpd
225                pkgFlags = Set.fromList $ map PD.flagName $ PD.genPackageFlags gpd
226                unused = Map.keysSet $ Map.withoutKeys userFlags pkgFlags
227            if Set.null unused
228                    -- All flags are defined, nothing to do
229                    then pure Nothing
230                    -- Error about the undefined flags
231                    else pure $ Just $ UFFlagsNotDefined source pname pkgFlags unused
232
233pruneGlobals ::
234       Map PackageName DumpedGlobalPackage
235    -> Set PackageName
236    -> Map PackageName GlobalPackage
237pruneGlobals globals deps =
238  let (prunedGlobals, keptGlobals) =
239        partitionReplacedDependencies globals (pkgName . dpPackageIdent)
240            dpGhcPkgId dpDepends deps
241  in Map.map (GlobalPackage . pkgVersion . dpPackageIdent) keptGlobals <>
242     Map.map ReplacedGlobalPackage prunedGlobals
243
244getCompilerInfo :: (HasConfig env, HasCompiler env) => RIO env Builder
245getCompilerInfo = view $ compilerPathsL.to (byteString . cpGhcInfo)
246
247immutableLocSha :: PackageLocationImmutable -> Builder
248immutableLocSha = byteString . treeKeyToBs . locationTreeKey
249  where
250    locationTreeKey (PLIHackage _ _ tk) = tk
251    locationTreeKey (PLIArchive _ pm) = pmTreeKey pm
252    locationTreeKey (PLIRepo _ pm) = pmTreeKey pm
253    treeKeyToBs (TreeKey (BlobKey sha _)) = SHA256.toHexBytes sha
254
255type SnapshotCandidate env
256     = [ResolvedPath Dir] -> RIO env (SMActual GlobalPackageVersion)
257
258loadProjectSnapshotCandidate ::
259       (HasConfig env)
260    => RawSnapshotLocation
261    -> PrintWarnings
262    -> Bool
263    -> RIO env (SnapshotCandidate env)
264loadProjectSnapshotCandidate loc printWarnings buildHaddocks = do
265    (snapshot, _, _) <- loadAndCompleteSnapshotRaw loc Map.empty Map.empty
266    deps <- Map.traverseWithKey (snapToDepPackage False) (snapshotPackages snapshot)
267    let wc = snapshotCompiler snapshot
268    globals <- Map.map GlobalPackageVersion <$> globalsFromHints wc
269    return $ \projectPackages -> do
270        prjPkgs <- fmap Map.fromList . for projectPackages $ \resolved -> do
271            pp <- mkProjectPackage printWarnings resolved buildHaddocks
272            pure (cpName $ ppCommon pp, pp)
273        compiler <- either throwIO pure $ wantedToActual
274                  $ snapshotCompiler snapshot
275        return SMActual
276              { smaCompiler = compiler
277              , smaProject = prjPkgs
278              , smaDeps = Map.difference deps prjPkgs
279              , smaGlobal = globals
280              }
281