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

Uses C pre-processor (CPP) directives to not disturb the existing code that builds with versions of GHC before 9.0.2.

Tested by building stack on Windows 11. The built stack executable was, in turn, then tested by using it to build stack on Windows 11.

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.