Promote packages to local database by ghc-options #849

commercialhaskell · Aug 8, 2017 · 8ca47e2 · 8ca47e2
1 parent 9ae8070
commit 8ca47e2
Show file tree

Hide file tree

Showing 5 changed files with 32 additions and 31 deletions.
diff --git a/src/Stack/Build/Source.hs b/src/Stack/Build/Source.hs
@@ -92,10 +92,12 @@ loadSourceMapFull needTargets boptsCli = do
             [ Map.fromList $ map (\lp' -> (packageName $ lpPackage lp', PSLocal lp')) locals
             , flip Map.mapWithKey localDeps $ \n lpi ->
                 let configOpts = getGhcOptions bconfig boptsCli n False False
-                 in PSUpstream (lpiVersion lpi) Local (lpiFlags lpi) (lpiGhcOptions lpi ++ configOpts) (lpiLocation lpi)
+                 -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon
+                 in PSUpstream (lpiVersion lpi) Local (lpiFlags lpi) configOpts (lpiLocation lpi)
             , flip Map.mapWithKey (lsPackages ls) $ \n lpi ->
                 let configOpts = getGhcOptions bconfig boptsCli n False False
-                 in PSUpstream (lpiVersion lpi) Snap (lpiFlags lpi) (lpiGhcOptions lpi ++ configOpts) (lpiLocation lpi)
+                 -- NOTE: configOpts includes lpiGhcOptions for now, this may get refactored soon
+                 in PSUpstream (lpiVersion lpi) Snap (lpiFlags lpi) configOpts (lpiLocation lpi)
             ]
             `Map.difference` Map.fromList (map (, ()) (HashSet.toList wiredInPackages))
 
@@ -125,7 +127,8 @@ getLocalFlags bconfig boptsCli name = Map.unions
 -- configuration and commandline.
 getGhcOptions :: BuildConfig -> BuildOptsCLI -> PackageName -> Bool -> Bool -> [Text]
 getGhcOptions bconfig boptsCli name isTarget isLocal = concat
-    [ ghcOptionsFor name (configGhcOptions config)
+    [ Map.findWithDefault [] name (configGhcOptionsByName config)
+    , configGhcOptionsAll config
     , concat [["-fhpc"] | isLocal && toCoverage (boptsTestOpts bopts)]
     , if boptsLibProfile bopts || boptsExeProfile bopts
          then ["-auto-all","-caf-all"]

diff --git a/src/Stack/Build/Target.hs b/src/Stack/Build/Target.hs
@@ -522,16 +522,12 @@ parseTargets needTargets boptscli = do
         (bcFlags bconfig)
       hides = Map.empty -- not supported to add hidden packages
 
-      -- We set this to empty here, which will prevent the call to
-      -- calculatePackagePromotion from promoting packages based on
-      -- changed GHC options. This is probably not ideal behavior,
-      -- but is consistent with pre-extensible-snapshots behavior of
-      -- Stack. We can consider modifying this instead.
+      -- We promote packages to the local database if the GHC options
+      -- are added to them by name. See:
+      -- https://github.com/commercialhaskell/stack/issues/849#issuecomment-320892095.
       --
-      -- Nonetheless, GHC options will be calculated later based on
-      -- config file and command line parameters, so we're not
-      -- actually losing them.
-      options = Map.empty
+      -- GHC options applied to all packages are handled by getGhcOptions.
+      options = configGhcOptionsByName (bcConfig bconfig)
 
       drops = Set.empty -- not supported to add drops
 

diff --git a/src/Stack/Config.hs b/src/Stack/Config.hs
@@ -358,7 +358,8 @@ configFromConfigMonoid
 
      let configTemplateParams = configMonoidTemplateParameters
          configScmInit = getFirst configMonoidScmInit
-         configGhcOptions = configMonoidGhcOptions
+         configGhcOptionsByName = configMonoidGhcOptionsByName
+         configGhcOptionsAll = configMonoidGhcOptionsAll
          configSetupInfoLocations = configMonoidSetupInfoLocations
          configPvpBounds = fromFirst (PvpBounds PvpBoundsNone False) configMonoidPvpBounds
          configModifyCodePage = fromFirst True configMonoidModifyCodePage

diff --git a/src/Stack/Ghci.hs b/src/Stack/Ghci.hs
@@ -301,10 +301,8 @@ runGhci GhciOpts{..} targets mainIsTargets pkgs extraFiles = do
         genOpts = nubOrd (concatMap (concatMap (oneWordOpts . snd) . ghciPkgOpts) pkgs)
         (omittedOpts, ghcOpts) = partition badForGhci $
             concatMap (concatMap (bioOpts . snd) . ghciPkgOpts) pkgs ++
-            getUserOptions Nothing ++
-            concatMap (getUserOptions . Just . ghciPkgName) pkgs
-        getUserOptions mpkg =
-            map T.unpack (M.findWithDefault [] mpkg (unGhcOptions (configGhcOptions config)))
+            map T.unpack (configGhcOptionsAll config ++ concatMap (getUserOptions . ghciPkgName) pkgs)
+        getUserOptions pkg = M.findWithDefault [] pkg (configGhcOptionsByName config)
         badForGhci x =
             isPrefixOf "-O" x || elem x (words "-debug -threaded -ticky -static -Werror")
     unless (null omittedOpts) $

diff --git a/src/Stack/Types/Config.hs b/src/Stack/Types/Config.hs
@@ -104,9 +104,6 @@ module Stack.Types.Config
   ,readColorWhen
   -- ** SCM
   ,SCM(..)
-  -- ** GhcOptions
-  ,GhcOptions(..)
-  ,ghcOptionsFor
   -- * Paths
   ,bindirSuffix
   ,configInstalledCache
@@ -314,9 +311,10 @@ data Config =
          -- ^ Parameters for templates.
          ,configScmInit             :: !(Maybe SCM)
          -- ^ Initialize SCM (e.g. git) when creating new projects.
-         ,configGhcOptions          :: !GhcOptions
-         -- ^ Additional GHC options to apply to either all packages (Nothing)
-         -- or a specific package (Just).
+         ,configGhcOptionsByName    :: !(Map PackageName [Text])
+         -- ^ Additional GHC options to apply to specific packages.
+         ,configGhcOptionsAll       :: ![Text]
+         -- ^ Additional GHC options to apply to all packages
          ,configSetupInfoLocations  :: ![SetupInfoLocation]
          -- ^ Additional SetupInfo (inline or remote) to use to find tools.
          ,configPvpBounds           :: !PvpBounds
@@ -709,8 +707,10 @@ data ConfigMonoid =
     -- ^ Template parameters.
     ,configMonoidScmInit             :: !(First SCM)
     -- ^ Initialize SCM (e.g. git init) when making new projects?
-    ,configMonoidGhcOptions          :: !GhcOptions
-    -- ^ See 'configGhcOptions'
+    ,configMonoidGhcOptionsByName    :: !(Map PackageName [Text])
+    -- ^ See 'configGhcOptionsByName'
+    ,configMonoidGhcOptionsAll       :: ![Text]
+    -- ^ See 'configGhcOptionsAll'
     ,configMonoidExtraPath           :: ![Path Abs Dir]
     -- ^ Additional paths to search for executables in
     ,configMonoidSetupInfoLocations  :: ![SetupInfoLocation]
@@ -794,7 +794,15 @@ parseConfigMonoidObject rootDir obj = do
           return (First scmInit,fromMaybe M.empty params)
     configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName
 
-    configMonoidGhcOptions <- obj ..:? configMonoidGhcOptionsName ..!= mempty
+    GhcOptions configMonoidGhcOptions <- obj ..:? configMonoidGhcOptionsName ..!= mempty
+    let configMonoidGhcOptionsByName = Map.unions (map
+          (\(mname, opts) ->
+              case mname of
+                Nothing -> Map.empty
+                Just name -> Map.singleton name opts)
+          (Map.toList configMonoidGhcOptions))
+        configMonoidGhcOptionsAll = fromMaybe [] (Map.lookup Nothing configMonoidGhcOptions)
+
     configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= []
     configMonoidSetupInfoLocations <-
         maybeToList <$> jsonSubWarningsT (obj ..:?  configMonoidSetupInfoLocationsName)
@@ -1746,11 +1754,6 @@ instance Monoid GhcOptions where
     mappend (GhcOptions l) (GhcOptions r) =
         GhcOptions (Map.unionWith (++) l r)
 
-ghcOptionsFor :: PackageName -> GhcOptions -> [Text]
-ghcOptionsFor name (GhcOptions mp) =
-    M.findWithDefault [] Nothing mp ++
-    M.findWithDefault [] (Just name) mp
-
 -----------------------------------
 -- Lens classes
 -----------------------------------