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