Merge pull request commercialhaskell#5696 from mpilgrem/ghc902

Allow stack to build with lts-19.1 (GHC 9.0.2)

Author: mpilgrem

src/Stack/Build.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -19,7 +20,12 @@ module Stack.Build
 
 import           Stack.Prelude hiding (loadPackage)
 import           Data.Aeson (Value (Object, Array), (.=), object)
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.Key as Key
+import qualified Data.Aeson.KeyMap as KeyMap
+#else
 import qualified Data.HashMap.Strict as HM
+#endif
 import           Data.List ((\\), isPrefixOf)
 import           Data.List.Extra (groupSort)
 import qualified Data.List.NonEmpty as NE
@@ -293,7 +299,11 @@ queryBuildInfo selectors0 =
     select front (sel:sels) value =
         case value of
             Object o ->
+#if MIN_VERSION_aeson(2,0,0)
+                case KeyMap.lookup (Key.fromText sel) o of
+#else
                 case HM.lookup sel o of
+#endif
                     Nothing -> err "Selector not found"
                     Just value' -> cont value'
             Array v ->
@@ -328,15 +338,23 @@ rawBuildInfo = do
     wantedCompiler <- view $ wantedCompilerVersionL.to (utf8BuilderToText . display)
     actualCompiler <- view $ actualCompilerVersionL.to compilerVersionText
     return $ object
+#if MIN_VERSION_aeson(2,0,0)
+        [ "locals" .= Object (KeyMap.fromList $ map localToPair locals)
+#else
         [ "locals" .= Object (HM.fromList $ map localToPair locals)
+#endif
         , "compiler" .= object
             [ "wanted" .= wantedCompiler
             , "actual" .= actualCompiler
             ]
         ]
   where
     localToPair lp =
+#if MIN_VERSION_aeson(2,0,0)
+        (Key.fromText $ T.pack $ packageNameString $ packageName p, value)
+#else
         (T.pack $ packageNameString $ packageName p, value)
+#endif
       where
         p = lpPackage lp
         value = object
@@ -358,7 +376,11 @@ checkComponentsBuildable lps =
 checkSubLibraryDependencies :: HasLogFunc env => [ProjectPackage] -> RIO env ()
 checkSubLibraryDependencies proj = do
   forM_ proj $ \p -> do
+#if MIN_VERSION_Cabal(3,4,0)
+    C.GenericPackageDescription _ _ _ lib subLibs foreignLibs exes tests benches <- liftIO $ cpGPD . ppCommon $ p
+#else
     C.GenericPackageDescription _ _ lib subLibs foreignLibs exes tests benches <- liftIO $ cpGPD . ppCommon $ p
+#endif
 
     let dependencies = concatMap getDeps subLibs <>
                        concatMap getDeps foreignLibs <>
@@ -372,7 +394,7 @@ checkSubLibraryDependencies proj = do
       (logWarn "SubLibrary dependency is not supported, this will almost certainly fail")
   where
     getDeps (_, C.CondNode _ dep _) = dep
-    subLibDepExist lib = 
+    subLibDepExist lib =
       any (\x ->
         case x of
           C.LSubLibName _ -> True

src/Stack/Build/Execute.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
@@ -1218,7 +1219,11 @@ withSingleContext ActionContext {..} ee@ExecuteEnv {..} task@Task {..} allDeps m
                             let macroDeps = mapMaybe snd matchedDeps
                                 cppMacrosFile = setupDir </> relFileSetupMacrosH
                                 cppArgs = ["-optP-include", "-optP" ++ toFilePath cppMacrosFile]
+#if MIN_VERSION_Cabal(3,4,0)
+                            writeBinaryFileAtomic cppMacrosFile (encodeUtf8Builder (T.pack (C.generatePackageVersionMacros (packageVersion package) macroDeps)))
+#else
                             writeBinaryFileAtomic cppMacrosFile (encodeUtf8Builder (T.pack (C.generatePackageVersionMacros macroDeps)))
+#endif
                             return (packageDBArgs ++ depsArgs ++ cppArgs)
 
                         -- This branch is usually taken for builds, and

src/Stack/BuildPlan.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE ConstraintKinds    #-}
+{-# LANGUAGE CPP                #-}
 {-# LANGUAGE DataKinds          #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts   #-}
@@ -224,7 +225,11 @@ selectPackageBuildPlan platform compiler pool gpd =
     flagCombinations :: NonEmpty [(FlagName, Bool)]
     flagCombinations = mapM getOptions (genPackageFlags gpd)
       where
+#if MIN_VERSION_Cabal(3,4,0)
+        getOptions :: C.PackageFlag -> NonEmpty (FlagName, Bool)
+#else
         getOptions :: C.Flag -> NonEmpty (FlagName, Bool)
+#endif
         getOptions f
             | flagManual f = (fname, flagDefault f) :| []
             | flagDefault f = (fname, True) :| [(fname, False)]

src/Stack/ConfigCmd.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -17,9 +18,15 @@ module Stack.ConfigCmd
        ,cfgCmdName) where
 
 import           Stack.Prelude
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.Key as Key
+import qualified Data.Aeson.KeyMap as KeyMap
+#endif
 import           Data.ByteString.Builder (byteString)
 import qualified Data.Map.Merge.Strict as Map
+#if !MIN_VERSION_aeson(2,0,0)
 import qualified Data.HashMap.Strict as HMap
+#endif
 import qualified Data.Text as T
 import qualified Data.Yaml as Yaml
 import qualified Options.Applicative as OA
@@ -74,7 +81,11 @@ cfgCmdSet cmd = do
         liftIO (Yaml.decodeFileEither (toFilePath configFilePath)) >>= either throwM return
     newValue <- cfgCmdSetValue (parent configFilePath) cmd
     let cmdKey = cfgCmdSetOptionName cmd
+#if MIN_VERSION_aeson(2,0,0)
+        config' = KeyMap.insert (Key.fromText cmdKey) newValue config
+#else
         config' = HMap.insert cmdKey newValue config
+#endif
     if config' == config
         then logInfo
                  (fromString (toFilePath configFilePath) <>

src/Stack/Init.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings     #-}
@@ -11,10 +12,15 @@ module Stack.Init
     ) where
 
 import           Stack.Prelude
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap               as KeyMap
+#endif
 import qualified Data.ByteString.Builder         as B
 import qualified Data.ByteString.Char8           as BC
 import qualified Data.Foldable                   as F
+#if !MIN_VERSION_aeson(2,0,0)
 import qualified Data.HashMap.Strict             as HM
+#endif
 import qualified Data.IntMap                     as IntMap
 import           Data.List.Extra                 (groupSortOn)
 import qualified Data.List.NonEmpty              as NonEmpty
@@ -83,29 +89,29 @@ initProject currDir initOpts mresolver = do
     let ignored = Map.difference bundle rbundle
         dupPkgMsg
             | dupPkgs /= [] =
-                "Warning (added by new or init): Some packages were found to \
-                \have names conflicting with others and have been commented \
-                \out in the packages section.\n"
+                "Warning (added by new or init): Some packages were found to " <>
+                "have names conflicting with others and have been commented " <>
+                "out in the packages section.\n"
             | otherwise = ""
 
         missingPkgMsg
             | Map.size ignored > 0 =
-                "Warning (added by new or init): Some packages were found to \
-                \be incompatible with the resolver and have been left commented \
-                \out in the packages section.\n"
+                "Warning (added by new or init): Some packages were found to " <>
+                "be incompatible with the resolver and have been left commented " <>
+                "out in the packages section.\n"
             | otherwise = ""
 
         extraDepMsg
             | Map.size extraDeps > 0 =
-                "Warning (added by new or init): Specified resolver could not \
-                \satisfy all dependencies. Some external packages have been \
-                \added as dependencies.\n"
+                "Warning (added by new or init): Specified resolver could not " <>
+                "satisfy all dependencies. Some external packages have been " <>
+                "added as dependencies.\n"
             | otherwise = ""
         makeUserMsg msgs =
             let msg = concat msgs
             in if msg /= "" then
-                  msg <> "You can omit this message by removing it from \
-                         \stack.yaml\n"
+                  msg <> "You can omit this message by removing it from " <>
+                         "stack.yaml\n"
                  else ""
 
         userMsg = makeUserMsg [dupPkgMsg, missingPkgMsg, extraDepMsg]
@@ -177,12 +183,20 @@ renderStackYaml p ignoredPackages dupPackages =
            B.byteString headerHelp
         <> B.byteString "\n\n"
         <> F.foldMap (goComment o) comments
+#if MIN_VERSION_aeson(2,0,0)
+        <> goOthers (o `KeyMap.difference` KeyMap.fromList comments)
+#else
         <> goOthers (o `HM.difference` HM.fromList comments)
+#endif
         <> B.byteString footerHelp
         <> "\n"
 
     goComment o (name, comment) =
+#if MIN_VERSION_aeson(2,0,0)
+        case (convert <$> KeyMap.lookup name o) <|> nonPresentValue name of
+#else
         case (convert <$> HM.lookup name o) <|> nonPresentValue name of
+#endif
             Nothing -> assert (name == "user-message") mempty
             Just v ->
                 B.byteString comment <>
@@ -226,7 +240,11 @@ renderStackYaml p ignoredPackages dupPackages =
         | otherwise = ""
 
     goOthers o
+#if MIN_VERSION_aeson(2,0,0)
+        | KeyMap.null o = mempty
+#else
         | HM.null o = mempty
+#endif
         | otherwise = assert False $ B.byteString $ Yaml.encode o
 
     -- Per Section Help
@@ -394,9 +412,9 @@ getWorkingResolverPlan initOpts pkgDirs0 snapCandidate snapLoc = do
                 Right (f, edeps)-> return (snapLoc, f, edeps, pkgDirs)
                 Left ignored
                     | Map.null available -> do
-                        logWarn "*** Could not find a working plan for any of \
-                                 \the user packages.\nProceeding to create a \
-                                 \config anyway."
+                        logWarn $ "*** Could not find a working plan for any of " <>
+                                "the user packages.\nProceeding to create a " <>
+                                "config anyway."
                         return (snapLoc, Map.empty, Map.empty, Map.empty)
                     | otherwise -> do
                         when (Map.size available == Map.size pkgDirs) $
@@ -537,9 +555,9 @@ cabalPackagesCheck cabaldirs dupErrMsg = do
 
     when (nameMismatchPkgs /= []) $ do
         rels <- mapM prettyPath nameMismatchPkgs
-        error $ "Package name as defined in the .cabal file must match the \
-                \.cabal file name.\n\
-                \Please fix the following packages and try again:\n"
+        error $ "Package name as defined in the .cabal file must match the " <>
+                ".cabal file name.\n" <>
+                "Please fix the following packages and try again:\n"
                 <> T.unpack (utf8BuilderToText (formatGroup rels))
 
     let dupGroups = filter ((> 1) . length)

src/Stack/New.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -18,6 +19,9 @@ module Stack.New
 import           Stack.Prelude
 import           Control.Monad.Trans.Writer.Strict
 import           Data.Aeson as A
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap as KeyMap
+#endif
 import qualified Data.ByteString.Base64 as B64
 import           Data.ByteString.Builder (lazyByteString)
 import qualified Data.ByteString.Lazy as LB
@@ -40,7 +44,9 @@ import           Stack.Constants
 import           Stack.Constants.Config
 import           Stack.Types.Config
 import           Stack.Types.TemplateName
+#if !MIN_VERSION_aeson(2,0,0)
 import qualified RIO.HashMap as HM
+#endif
 import           RIO.Process
 import qualified Text.Mustache as Mustache
 import qualified Text.Mustache.Render as Mustache
@@ -139,7 +145,7 @@ loadTemplate name logIt = do
         RepoPath rtp -> do
             let settings = settingsFromRepoTemplatePath rtp
             downloadFromUrl settings templateDir
-                            
+
   where
     loadLocalFile :: Path b File -> (ByteString -> Either String Text) -> RIO env Text
     loadLocalFile path extract = do
@@ -209,7 +215,11 @@ settingsFromRepoTemplatePath (RepoTemplatePath Github user name) =
     , tplExtract = \bs -> do
         decodedJson <- eitherDecode (LB.fromStrict bs)
         case decodedJson of
+#if MIN_VERSION_aeson(2,0,0)
+          Object o | Just (String content) <- KeyMap.lookup "content" o -> do
+#else
           Object o | Just (String content) <- HM.lookup "content" o -> do
+#endif
                        let noNewlines = T.filter (/= '\n')
                        bsContent <- B64.decode $ T.encodeUtf8 (noNewlines content)
                        mapLeft show $ decodeUtf8' bsContent
@@ -258,8 +268,8 @@ applyTemplate project template nonceParams dir templateText = do
 
     let isPkgSpec f = ".cabal" `isSuffixOf` f || f == "package.yaml"
     unless (any isPkgSpec . M.keys $ files) $
-         throwM (InvalidTemplate template "Template does not contain a .cabal \
-                                          \or package.yaml file")
+         throwM (InvalidTemplate template
+           "Template does not contain a .cabal or package.yaml file")
 
     -- Apply Mustache templating to a single file within the project
     -- template.