Merge pull request #3327 from commercialhaskell/849-unify-flags-ghc-options

Promote packages to local database by ghc-options #849

Author: snoyberg

ChangeLog.md

@@ -26,6 +26,10 @@ Behavior changes:
   paths.  TH relative paths will still work when loading a single
   package into intero. See
   [#3309](https://github.com/commercialhaskell/stack/issues/3309)
+* Setting GHC options for a package via `ghc-options:` in your
+  `stack.yaml` will promote it to a local package, providing for more
+  consistency with flags and better reproducibility. See:
+  [#849](https://github.com/commercialhaskell/stack/issues/849)
 
 Other enhancements:
 

doc/yaml_configuration.md

@@ -503,10 +503,17 @@ ghc-options:
     some-package: -DSOME_CPP_FLAG
 ```
 
-Caveat emptor: setting options like this will affect your snapshot packages,
-which can lead to unpredictable behavior versus official Stackage snapshots.
-This is in contrast to the `ghc-options` command line flag, which will only
-affect the packages specified by the [`apply-ghc-options` option](yaml_configuration.md#apply-ghc-options).
+Since 0.1.6, setting a GHC options for a specific package will
+automatically promote it to a local package (much like setting a
+custom package flag). However, setting options via `"*"` on all flags
+will not do so (see
+[Github discussion](https://github.com/commercialhaskell/stack/issues/849#issuecomment-320892095)
+for reasoning). This can lead to unpredicable behavior by affecting
+your snapshot packages.
+
+By contrast, the `ghc-options` command line flag will only affect the
+packages specified by the
+[`apply-ghc-options` option](yaml_configuration.md#apply-ghc-options).
 
 ### apply-ghc-options
 

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"]

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
 

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

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) $

src/Stack/Types/Config.hs

@@ -104,9 +104,6 @@ module Stack.Types.Config
   ,readColorWhen
   -- ** SCM
   ,SCM(..)
-  -- ** GhcOptions
-  ,GhcOptions(..)
-  ,ghcOptionsFor
   -- * Paths
   ,bindirSuffix
   ,configInstalledCache
@@ -172,11 +169,11 @@ module Stack.Types.Config
 
 import           Stack.Prelude
 import           Data.Aeson.Extended
-                 (ToJSON, toJSON, FromJSON, parseJSON, withText, object,
+                 (ToJSON, toJSON, FromJSON, FromJSONKey (..), parseJSON, withText, object,
                   (.=), (..:), (..:?), (..!=), Value(Bool, String),
                   withObjectWarnings, WarningParser, Object, jsonSubWarnings,
-                  jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings)
-import           Data.Attoparsec.Args
+                  jsonSubWarningsT, jsonSubWarningsTT, WithJSONWarnings(..), noJSONWarnings,
+                  FromJSONKeyFunction (FromJSONKeyTextParser))
 import qualified Data.ByteString.Char8 as S8
 import           Data.List (stripPrefix)
 import           Data.List.NonEmpty (NonEmpty)
@@ -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]
@@ -795,6 +795,14 @@ parseConfigMonoidObject rootDir obj = do
     configMonoidCompilerCheck <- First <$> obj ..:? configMonoidCompilerCheckName
 
     configMonoidGhcOptions <- obj ..:? configMonoidGhcOptionsName ..!= mempty
+    let configMonoidGhcOptionsByName = Map.unions (map
+          (\(mname, opts) ->
+              case mname of
+                GOKAll -> Map.empty
+                GOKPackage name -> Map.singleton name opts)
+          (Map.toList configMonoidGhcOptions))
+        configMonoidGhcOptionsAll = Map.findWithDefault [] GOKAll configMonoidGhcOptions
+
     configMonoidExtraPath <- obj ..:? configMonoidExtraPathName ..!= []
     configMonoidSetupInfoLocations <-
         maybeToList <$> jsonSubWarningsT (obj ..:?  configMonoidSetupInfoLocationsName)
@@ -1713,43 +1721,16 @@ data DockerUser = DockerUser
     , duUmask :: FileMode -- ^ File creation mask }
     } deriving (Read,Show)
 
-newtype GhcOptions = GhcOptions
-    { unGhcOptions :: Map (Maybe PackageName) [Text] }
-    deriving Show
-
-instance FromJSON GhcOptions where
-    parseJSON val = do
-        ghcOptions <- parseJSON val
-        fmap (GhcOptions . Map.fromList) $ mapM handleGhcOptions $ Map.toList ghcOptions
-      where
-        handleGhcOptions :: Monad m => (Text, Text) -> m (Maybe PackageName, [Text])
-        handleGhcOptions (name', vals') = do
-            name <-
-                if name' == "*"
-                    then return Nothing
-                    else case parsePackageNameFromString $ T.unpack name' of
-                            Left e -> fail $ show e
-                            Right x -> return $ Just x
-
-            case parseArgs Escaping vals' of
-                Left e -> fail e
-                Right vals -> return (name, map T.pack vals)
-
-instance Monoid GhcOptions where
-    mempty = GhcOptions mempty
-    -- FIXME: Should GhcOptions really monoid like this? Keeping it this
-    -- way preserves the behavior of the ConfigMonoid. However, this
-    -- means there isn't the ability to fully override snapshot
-    -- ghc-options in the same way there is for flags. Do we want to
-    -- change the semantics here? (particularly for extensible
-    -- snapshots)
-    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
+data GhcOptionKey = GOKAll | GOKPackage !PackageName
+  deriving (Eq, Ord)
+instance FromJSONKey GhcOptionKey where
+  fromJSONKey = FromJSONKeyTextParser $ \t ->
+    if t == "*"
+      then return GOKAll
+      else case parsePackageName t of
+             Left e -> fail $ show e
+             Right x -> return $ GOKPackage x
+  fromJSONKeyList = FromJSONKeyTextParser $ \_ -> fail "GhcOptionKey.fromJSONKeyList"
 
 -----------------------------------
 -- Lens classes