Add ghc opts and allow-newer for custom snaps

See #1265, some of the code refactor related to #849 and #863

Author: mgsloan

src/Stack/Build.hs

@@ -273,26 +273,27 @@ withLoadPackage :: ( MonadIO m
                    , MonadLogger m
                    , HasEnvConfig env)
                 => EnvOverride
-                -> ((PackageName -> Version -> Map FlagName Bool -> IO Package) -> m a)
+                -> ((PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -> m a)
                 -> m a
 withLoadPackage menv inner = do
     econfig <- asks getEnvConfig
     withCabalLoader menv $ \cabalLoader ->
-        inner $ \name version flags -> do
+        inner $ \name version flags ghcOptions -> do
             bs <- cabalLoader $ PackageIdentifier name version
 
             -- Intentionally ignore warnings, as it's not really
             -- appropriate to print a bunch of warnings out while
             -- resolving the package index.
-            (_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags) bs
+            (_warnings,pkg) <- readPackageBS (depPackageConfig econfig flags ghcOptions) bs
             return pkg
   where
     -- | Package config to be used for dependencies
-    depPackageConfig :: EnvConfig -> Map FlagName Bool -> PackageConfig
-    depPackageConfig econfig flags = PackageConfig
+    depPackageConfig :: EnvConfig -> Map FlagName Bool -> [Text] -> PackageConfig
+    depPackageConfig econfig flags ghcOptions = PackageConfig
         { packageConfigEnableTests = False
         , packageConfigEnableBenchmarks = False
         , packageConfigFlags = flags
+        , packageConfigGhcOptions = ghcOptions
         , packageConfigCompilerVersion = envConfigCompilerVersion econfig
         , packageConfigPlatform = configPlatform (getConfig econfig)
         }

src/Stack/Build/ConstructPlan.hs

@@ -102,7 +102,7 @@ type M = RWST
 data Ctx = Ctx
     { mbp            :: !MiniBuildPlan
     , baseConfigOpts :: !BaseConfigOpts
-    , loadPackage    :: !(PackageName -> Version -> Map FlagName Bool -> IO Package)
+    , loadPackage    :: !(PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package)
     , combinedMap    :: !CombinedMap
     , toolToPackages :: !(Cabal.Dependency -> Map PackageName VersionRange)
     , ctxEnvConfig   :: !EnvConfig
@@ -129,7 +129,7 @@ constructPlan :: forall env m.
               -> [LocalPackage]
               -> Set PackageName -- ^ additional packages that must be built
               -> [DumpPackage () ()] -- ^ locally registered
-              -> (PackageName -> Version -> Map FlagName Bool -> IO Package) -- ^ load upstream package
+              -> (PackageName -> Version -> Map FlagName Bool -> [Text] -> IO Package) -- ^ load upstream package
               -> SourceMap
               -> InstalledMap
               -> m Plan
@@ -205,7 +205,7 @@ mkUnregisterLocal tasks dirtyReason locallyRegistered sourceMap =
         case M.lookup name tasks of
             Nothing ->
                 case M.lookup name sourceMap of
-                    Just (PSUpstream _ Snap _ _) -> Map.singleton gid
+                    Just (PSUpstream _ Snap _ _ _) -> Map.singleton gid
                         ( ident
                         , Just "Switching to snapshot installed package"
                         )
@@ -234,7 +234,6 @@ addFinal lp package isAllInOne = do
                             (getEnvConfig ctx)
                             (baseConfigOpts ctx)
                             allDeps
-                            True -- wanted
                             True -- local
                             Local
                             package
@@ -279,14 +278,16 @@ tellExecutables :: PackageName -> PackageSource -> M ()
 tellExecutables _ (PSLocal lp)
     | lpWanted lp = tellExecutablesPackage Local $ lpPackage lp
     | otherwise = return ()
-tellExecutables name (PSUpstream version loc flags _) =
+-- Ignores ghcOptions because they don't matter for enumerating
+-- executables.
+tellExecutables name (PSUpstream version loc flags _ghcOptions _gitSha) =
     tellExecutablesUpstream name version loc flags
 
 tellExecutablesUpstream :: PackageName -> Version -> InstallLocation -> Map FlagName Bool -> M ()
 tellExecutablesUpstream name version loc flags = do
     ctx <- ask
     when (name `Set.member` extraToBuild ctx) $ do
-        p <- liftIO $ loadPackage ctx name version flags
+        p <- liftIO $ loadPackage ctx name version flags []
         tellExecutablesPackage loc p
 
 tellExecutablesPackage :: InstallLocation -> Package -> M ()
@@ -319,8 +320,8 @@ installPackage :: Bool -- ^ is this being used by a dependency?
 installPackage treatAsDep name ps minstalled = do
     ctx <- ask
     case ps of
-        PSUpstream version _ flags _ -> do
-            package <- liftIO $ loadPackage ctx name version flags
+        PSUpstream version _ flags ghcOptions _ -> do
+            package <- liftIO $ loadPackage ctx name version flags ghcOptions
             resolveDepsAndInstall False treatAsDep ps package minstalled
         PSLocal lp ->
             case lpTestBench lp of
@@ -403,7 +404,6 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL
                         (getEnvConfig ctx)
                         (baseConfigOpts ctx)
                         allDeps
-                        (psWanted ps)
                         (psLocal ps)
                         -- An assertion to check for a recurrence of
                         -- https://github.com/commercialhaskell/stack/issues/345
@@ -413,7 +413,7 @@ installPackageGivenDeps isAllInOne ps package minstalled (missing, present, minL
             , taskType =
                 case ps of
                     PSLocal lp -> TTLocal lp
-                    PSUpstream _ loc _ sha -> TTUpstream package (loc <> minLoc) sha
+                    PSUpstream _ loc _ _ sha -> TTUpstream package (loc <> minLoc) sha
             , taskAllInOne = isAllInOne
             }
 
@@ -503,7 +503,6 @@ checkDirtiness ps installed package present wanted = do
             (getEnvConfig ctx)
             (baseConfigOpts ctx)
             present
-            (psWanted ps)
             (psLocal ps)
             (piiLocation ps) -- should be Local always
             package
@@ -599,10 +598,6 @@ psDirty :: PackageSource -> Maybe (Set FilePath)
 psDirty (PSLocal lp) = lpDirtyFiles lp
 psDirty (PSUpstream {}) = Nothing -- files never change in an upstream package
 
-psWanted :: PackageSource -> Bool
-psWanted (PSLocal lp) = lpWanted lp
-psWanted (PSUpstream {}) = False
-
 psLocal :: PackageSource -> Bool
 psLocal (PSLocal _) = True
 psLocal (PSUpstream {}) = False

src/Stack/Build/Source.hs

@@ -11,19 +11,20 @@ module Stack.Build.Source
     ( loadSourceMap
     , SourceMap
     , PackageSource (..)
-    , localFlags
+    , getLocalFlags
+    , getGhcOptions
     , getLocalPackageViews
-    , loadLocalPackage
     , parseTargetsFromBuildOpts
     , addUnlistedToBuildCache
+    , getDefaultPackageConfig
     , getPackageConfig
     ) where
 
 import           Control.Applicative
 import           Control.Arrow ((&&&))
 import           Control.Exception (assert, catch)
 import           Control.Monad
-import           Control.Monad.Catch (MonadMask)
+import           Control.Monad.Catch (MonadMask, MonadCatch)
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
 import           Control.Monad.Reader (MonadReader, asks)
@@ -91,6 +92,7 @@ loadSourceMap needTargets boptsCli = do
     locals <- mapM (loadLocalPackage boptsCli targets) $ Map.toList rawLocals
     checkFlagsUsed boptsCli locals extraDeps0 (mbpPackages mbp0)
     checkComponentsBuildable locals
+    warnAllowNewer mbp0
 
     let
         -- loadLocals returns PackageName (foo) and PackageIdentifier (bar-1.2.3) targets separately;
@@ -111,31 +113,34 @@ loadSourceMap needTargets boptsCli = do
         -- Add the extra deps from the stack.yaml file to the deps grabbed from
         -- the snapshot
         extraDeps2 = Map.union
-            (Map.map (\v -> (v, Map.empty)) extraDeps0)
-            (Map.map (mpiVersion &&& mpiFlags) extraDeps1)
+            (Map.map (\v -> (v, Map.empty, [])) extraDeps0)
+            (Map.map (\mpi -> (mpiVersion mpi, mpiFlags mpi, mpiGhcOptions mpi)) extraDeps1)
 
-        -- Overwrite any flag settings with those from the config file
+        -- Add flag and ghc-option settings from the config file / cli
         extraDeps3 = Map.mapWithKey
-            (\n (v, f) -> PSUpstream v Local
-               (case ( Map.lookup (Just n) $ boptsCLIFlags boptsCli
-                     , Map.lookup Nothing $ boptsCLIFlags boptsCli
-                     , Map.lookup n $ bcFlags bconfig
-                     ) of
-                    -- Didn't have any flag overrides, fall back to the flags
-                    -- defined in the snapshot.
-                    (Nothing, Nothing, Nothing) -> f
-                    -- Either command line flag for this package, general
-                    -- command line flag, or flag in stack.yaml is defined.
-                    -- Take all of those and ignore the snapshot flags.
-                    (x, y, z) -> Map.unions
-                        [ fromMaybe Map.empty x
-                        , fromMaybe Map.empty y
-                        , fromMaybe Map.empty z
-                        ])
-
+            (\n (v, flags0, ghcOptions0) ->
+                let flags =
+                        case ( Map.lookup (Just n) $ boptsCLIFlags boptsCli
+                             , Map.lookup Nothing $ boptsCLIFlags boptsCli
+                             , Map.lookup n $ unPackageFlags $ bcFlags bconfig
+                             ) of
+                            -- Didn't have any flag overrides, fall back to the flags
+                            -- defined in the snapshot.
+                            (Nothing, Nothing, Nothing) -> flags0
+                            -- Either command line flag for this package, general
+                            -- command line flag, or flag in stack.yaml is defined.
+                            -- Take all of those and ignore the snapshot flags.
+                            (x, y, z) -> Map.unions
+                                [ fromMaybe Map.empty x
+                                , fromMaybe Map.empty y
+                                , fromMaybe Map.empty z
+                                ]
+                    ghcOptions =
+                        ghcOptions0 ++
+                        getGhcOptions bconfig boptsCli n False False
                  -- currently have no ability for extra-deps to specify their
                  -- cabal file hashes
-                 Nothing)
+                in PSUpstream v Local flags ghcOptions Nothing)
             extraDeps2
 
     let sourceMap = Map.unions
@@ -144,11 +149,45 @@ loadSourceMap needTargets boptsCli = do
                  in (packageName p, PSLocal lp)
             , extraDeps3
             , flip fmap (mbpPackages mbp) $ \mpi ->
-                PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) (mpiGitSHA1 mpi)
+                PSUpstream (mpiVersion mpi) Snap (mpiFlags mpi) (mpiGhcOptions mpi) (mpiGitSHA1 mpi)
             ] `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages))
 
     return (targets, mbp, locals, nonLocalTargets, sourceMap)
 
+-- | All flags for a local package
+getLocalFlags
+    :: BuildConfig
+    -> BuildOptsCLI
+    -> PackageName
+    -> Map FlagName Bool
+getLocalFlags bconfig boptsCli name = Map.unions
+    [ Map.findWithDefault Map.empty (Just name) cliFlags
+    , Map.findWithDefault Map.empty Nothing cliFlags
+    , Map.findWithDefault Map.empty name (unPackageFlags (bcFlags bconfig))
+    ]
+  where
+    cliFlags = boptsCLIFlags boptsCli
+
+getGhcOptions :: BuildConfig -> BuildOptsCLI -> PackageName -> Bool -> Bool -> [Text]
+getGhcOptions bconfig boptsCli name isTarget isLocal = concat
+    [ ghcOptionsFor name (configGhcOptions config)
+    , concat [["-fhpc"] | isLocal && toCoverage (boptsTestOpts bopts)]
+    , if (boptsLibProfile bopts || boptsExeProfile bopts)
+         then ["-auto-all","-caf-all"]
+         else []
+    , if includeExtraOptions
+         then boptsCLIGhcOptions boptsCli
+         else []
+    ]
+  where
+    bopts = configBuild config
+    config = bcConfig bconfig
+    includeExtraOptions =
+        case configApplyGhcOptions config of
+            AGOTargets -> isTarget
+            AGOLocals -> isLocal
+            AGOEverything -> True
+
 -- | Use the build options and environment to parse targets.
 parseTargetsFromBuildOpts
     :: (MonadIO m, MonadMask m, MonadReader env m, HasBuildConfig env, MonadBaseControl IO m, HasHttpManager env, MonadLogger m, HasEnvConfig env)
@@ -170,6 +209,7 @@ parseTargetsFromBuildOpts needTargets boptscli = do
                 return MiniBuildPlan
                     { mbpCompilerVersion = version
                     , mbpPackages = Map.empty
+                    , mbpAllowNewer = False
                     }
             ResolverCustom _ url -> do
                 stackYamlFP <- asks $ bcStackYaml . getBuildConfig
@@ -285,11 +325,11 @@ loadLocalPackage
     -> (PackageName, (LocalPackageView, GenericPackageDescription))
     -> m LocalPackage
 loadLocalPackage boptsCli targets (name, (lpv, gpkg)) = do
-    config  <- getPackageConfig boptsCli name
+    let mtarget = Map.lookup name targets
+    config  <- getPackageConfig boptsCli name (isJust mtarget) True
     bopts <- asks (configBuild . getConfig)
     let pkg = resolvePackage config gpkg
 
-        mtarget = Map.lookup name targets
         (exes, tests, benches) =
             case mtarget of
                 Just (STLocalComps comps) -> splitComponents $ Set.toList comps
@@ -384,7 +424,7 @@ checkFlagsUsed boptsCli lps extraDeps snapshot = do
         -- Check if flags specified in stack.yaml and the command line are
         -- used, see https://github.com/commercialhaskell/stack/issues/617
     let flags = map (, FSCommandLine) [(k, v) | (Just k, v) <- Map.toList $ boptsCLIFlags boptsCli]
-             ++ map (, FSStackYaml) (Map.toList $ bcFlags bconfig)
+             ++ map (, FSStackYaml) (Map.toList $ unPackageFlags $ bcFlags bconfig)
 
         localNameMap = Map.fromList $ map (packageName . lpPackage &&& lpPackage) lps
         checkFlagUsed ((name, userFlags), source) =
@@ -415,17 +455,6 @@ checkFlagsUsed boptsCli lps extraDeps snapshot = do
         $ InvalidFlagSpecification
         $ Set.fromList unusedFlags
 
--- | All flags for a local package
-localFlags :: Map (Maybe PackageName) (Map FlagName Bool)
-           -> BuildConfig
-           -> PackageName
-           -> Map FlagName Bool
-localFlags boptsflags bconfig name = Map.unions
-    [ Map.findWithDefault Map.empty (Just name) boptsflags
-    , Map.findWithDefault Map.empty Nothing boptsflags
-    , Map.findWithDefault Map.empty name (bcFlags bconfig)
-    ]
-
 -- | Add in necessary packages to extra dependencies
 --
 -- Originally part of https://github.com/commercialhaskell/stack/issues/272,
@@ -568,18 +597,50 @@ checkComponentsBuildable lps =
         , c <- Set.toList (lpUnbuildable lp)
         ]
 
+warnAllowNewer :: (MonadThrow m, MonadLogger m, MonadReader env m, HasConfig env)
+               => MiniBuildPlan -> m ()
+warnAllowNewer mpb = do
+    -- TODO: Perhaps we should just have the snapshot setting imply
+    -- allow-newer? I just didn't want to make 'configAllowNewer'
+    -- non-authoritative about whether allow-newer is enabled.
+    allowNewer <- asks (configAllowNewer . getConfig)
+    when (mbpAllowNewer mpb && not allowNewer) $ do
+        $logWarn $ T.unlines
+            [ ""
+            , "WARNING: The snapshot specifies that allow-newer needs to be used."
+            , "You should probably add 'allow-newer: true' to suppress this warning."
+            , ""
+            ]
+
+getDefaultPackageConfig :: (MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m, MonadReader env m, HasEnvConfig env)
+  => m PackageConfig
+getDefaultPackageConfig = do
+  econfig <- asks getEnvConfig
+  bconfig <- asks getBuildConfig
+  return PackageConfig
+    { packageConfigEnableTests = False
+    , packageConfigEnableBenchmarks = False
+    , packageConfigFlags = M.empty
+    , packageConfigGhcOptions = []
+    , packageConfigCompilerVersion = envConfigCompilerVersion econfig
+    , packageConfigPlatform = configPlatform $ getConfig bconfig
+    }
+
 -- | Get 'PackageConfig' for package given its name.
 getPackageConfig :: (MonadIO m, MonadThrow m, MonadMask m, MonadLogger m, MonadReader env m, HasEnvConfig env)
   => BuildOptsCLI
   -> PackageName
+  -> Bool
+  -> Bool
   -> m PackageConfig
-getPackageConfig boptsCli name = do
+getPackageConfig boptsCli name isTarget isLocal = do
   econfig <- asks getEnvConfig
   bconfig <- asks getBuildConfig
   return PackageConfig
     { packageConfigEnableTests = False
     , packageConfigEnableBenchmarks = False
-    , packageConfigFlags = localFlags (boptsCLIFlags boptsCli) bconfig name
+    , packageConfigFlags = getLocalFlags bconfig boptsCli name
+    , packageConfigGhcOptions = getGhcOptions bconfig boptsCli name isTarget isLocal
     , packageConfigCompilerVersion = envConfigCompilerVersion econfig
     , packageConfigPlatform = configPlatform $ getConfig bconfig
     }