GHC-9.14 support

Author: phadej

beam-large-records/beam-large-records.cabal

@@ -40,7 +40,7 @@ library
   build-depends:
       -- lower bound on beam-core is necessary
       -- see https://github.com/haskell-beam/beam/issues/585
-      base           >= 4.14     && < 4.23
+      base           >= 4.14     && < 4.24
     , beam-core      >= 0.10.3.0 && < 0.11
     , large-generics >= 0.2      && < 0.3
     , microlens      >= 0.4      && < 0.5

cabal.project

@@ -2,7 +2,7 @@ packages: typelet
 packages: large-anon
 packages: large-generics
 packages: large-records
-packages: beam-large-records
+-- packages: beam-large-records
 
 if impl(ghc <9)
   packages: large-records-benchmarks
@@ -25,3 +25,26 @@ package beam-large-records
 
 package typelet
   tests: True
+
+allow-newer: primitive-0.9.1.0:base
+allow-newer: primitive-0.9.1.0:template-haskell
+allow-newer: indexed-traversable-0.1.4:base
+allow-newer: finite-typelits-0.2.1.0:base
+allow-newer: finite-typelits-0.2.1.0:template-haskell
+allow-newer: bifunctors-5.6.2:template-haskell
+allow-newer: th-abstraction-0.7.1.0:template-haskell
+allow-newer: assoc-1.1.1:base
+allow-newer: vector-0.13.2.0:base
+allow-newer: vector-stream-0.1.0.1:base
+allow-newer: splitmix-0.1.3.1:base
+allow-newer: tagged-0.8.9:template-haskell
+allow-newer: scientific-0.3.8.0:base
+allow-newer: scientific-0.3.8.0:template-haskell
+allow-newer: integer-logarithms-1.0.4:base
+allow-newer: integer-logarithms-1.0.4:ghc-bignum
+allow-newer: *:base
+allow-newer: *:template-haskell
+allow-newer: *:ghc-bignum
+allow-newer: *:containers
+allow-newer: *:time
+allow-newer: ghc-tcplugin-api-0.17.0.0:ghc

large-anon/large-anon.cabal

@@ -77,10 +77,10 @@ library
 
   build-depends:
     , aeson            >= 1.4.4  && < 2.3
-    , base             >= 4.14   && < 4.22
+    , base             >= 4.14   && < 4.23
     , containers       >= 0.6.2  && < 0.9
     , deepseq          >= 1.4.4  && < 1.6
-    , ghc              >= 8.10   && < 9.13
+    , ghc              >= 8.10   && < 9.15
     , ghc-tcplugin-api >= 0.17.1.0 && < 0.18
     , hashable         >= 1.3    && < 1.6
     , mtl              >= 2.2.1  && < 2.4

large-anon/src/Data/Record/Anon/Internal/Plugin/Source/GhcShim.hs

@@ -256,6 +256,9 @@ importDecl qualified name = reLocA $ noLoc $ ImportDecl {
 #endif
 #if __GLASGOW_HASKELL__ >= 906
     , ideclImportList = Nothing
+#endif
+#if __GLASGOW_HASKELL__ >= 914
+    , ideclLevelSpec = NotLevelled
 #endif
     }
 
@@ -294,7 +297,11 @@ issueWarning l errMsg = do
                          (initPrintConfig dynFlags)
                          (initDiagOpts dynFlags)
 
+#if __GLASGOW_HASKELL__ >= 914
+    let msg :: Err.UnknownDiagnostic opts Err.GhcHint
+#else
     let msg :: Err.UnknownDiagnostic opts
+#endif
         msg = Err.mkSimpleUnknownDiagnostic $
                 mkPlainError [] errMsg
 #endif

large-anon/src/Data/Record/Anon/Overloading.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP                 #-}
 {-# LANGUAGE PolyKinds           #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
@@ -41,5 +42,11 @@ import qualified GHC.Records.Compat
 ifThenElse :: Bool -> a -> a -> a
 ifThenElse b x y = if b then x else y
 
+-- | NOTE: the order of arguments is GHC version dependent.
+#if __GLASGOW_HASKELL__ >=914
+setField :: forall x r a. GHC.Records.Compat.HasField x r a => a -> r -> r
+setField = flip (fst . GHC.Records.Compat.hasField @x)
+#else
 setField :: forall x r a. GHC.Records.Compat.HasField x r a => r -> a -> r
 setField = fst . GHC.Records.Compat.hasField @x
+#endif

large-records/large-records.cabal

@@ -55,14 +55,14 @@ library
       Data.Record.Internal.Plugin.Record
 
   build-depends:
-    , base             >= 4.14   && < 4.22
+    , base             >= 4.14   && < 4.23
     , containers       >= 0.6.2  && < 0.9
-    , ghc              >= 8.10   && < 9.13
+    , ghc              >= 8.10   && < 9.15
     , mtl              >= 2.2.1  && < 2.4
     , primitive        >= 0.7.3  && < 0.10
     , record-hasfield  >= 1.0    && < 1.1
     , syb              >= 0.7    && < 0.8
-    , template-haskell >= 2.16   && < 2.24
+    , template-haskell >= 2.16   && < 2.25
 
       -- large-generics 0.2 starts using 'SmallArray' instead of 'Vector'
     , large-generics >= 0.2 && < 0.3

large-records/src/Data/Record/Internal/GHC/Shim.hs

@@ -12,6 +12,12 @@
 {-# LANGUAGE ViewPatterns           #-}
 {-# LANGUAGE TypeOperators #-}
 
+#if __GLASGOW_HASKELL__ <914
+#define data pattern
+#else
+{-# LANGUAGE ExplicitNamespaces #-}
+#endif
+
 -- | Thin compatibility layer around GHC
 --
 -- This should be the only module with GHC-specific CPP directives, and the
@@ -26,7 +32,7 @@ module Data.Record.Internal.GHC.Shim (
   , mkFunBind
   , HsModule
   , LHsModule
-  , pattern GHC.HsModule
+  , data GHC.HsModule
 
     -- * Annotations
 #if __GLASGOW_HASKELL__ < 902
@@ -77,7 +83,14 @@ module Data.Record.Internal.GHC.Shim (
 
     -- * Compat
 #if __GLASGOW_HASKELL__ >= 910
-  , pattern LambdaExpr
+  , data LambdaExpr
+#endif
+  , wrapBangTy
+  , Singleton (..)
+
+#if __GLASGOW_HASKELL__ >= 914
+  , getBangType
+  , getBangStrictness
 #endif
 
     -- * Re-exports
@@ -107,12 +120,15 @@ module Data.Record.Internal.GHC.Shim (
 #endif
   ) where
 
+#undef data
+
 import Control.Monad
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Generics (Data, GenericQ, cast, toConstr, gzipWithQ)
 
 import qualified Data.List.NonEmpty as NE
 
+-- ATM only 8.10.7 is <900
 #if __GLASGOW_HASKELL__ < 900
 
 import Data.IORef
@@ -122,14 +138,14 @@ import BasicTypes (SourceText (NoSourceText))
 import ConLike (ConLike)
 import ErrUtils (mkErrMsg, mkWarnMsg)
 import GHC hiding (AnnKeywordId(..), HsModule, exprType, typeKind, mkFunBind, unLoc)
-import GhcPlugins hiding ((<>), getHscEnv, unLoc)
+import GhcPlugins hiding ((<>), getHscEnv, unLoc, singleton)
 import HscMain (getHscEnv)
 import NameCache (NameCache(nsUniqs))
 import PatSyn (PatSyn)
 import TcEvidence (HsWrapper(WpHole))
 
-import qualified GHC hiding (unLoc)
-import qualified GhcPlugins as GHC hiding (unLoc)
+import qualified GHC hiding (unLoc, singleton)
+import qualified GhcPlugins as GHC hiding (unLoc, singleton)
 
 #else
 
@@ -144,7 +160,7 @@ import GHC.Driver.Main (getHscEnv)
 import GHC.Tc.Types.Evidence (HsWrapper(WpHole))
 import GHC.Utils.Error (Severity(SevError, SevWarning))
 
-import GHC.Plugins hiding ((<>), getHscEnv, unLoc
+import GHC.Plugins hiding ((<>), getHscEnv, unLoc, singleton
 #if __GLASGOW_HASKELL__ >= 902
     , AnnType, AnnLet, AnnRec, AnnLam, AnnCase
     , Exception
@@ -298,6 +314,9 @@ importDecl qualified name = noLocA $ ImportDecl {
 #endif
 #if __GLASGOW_HASKELL__ >= 906
     , ideclImportList = Nothing
+#endif
+#if __GLASGOW_HASKELL__ >= 914
+    , ideclLevelSpec  = NotLevelled
 #endif
     }
 
@@ -483,8 +502,10 @@ hsFunTy = HsFunTy
 hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow NormalSyntax)
 #elif __GLASGOW_HASKELL__ < 910
 hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow (L NoTokenLoc HsNormalTok))
-#else
+#elif __GLASGOW_HASKELL__ < 914
 hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow NoEpUniTok)
+#else
+hsFunTy ext = HsFunTy ext (HsUnannotated (EpArrow defExt))
 #endif
 
 userTyVar :: LIdP GhcPs -> HsTyVarBndr GhcPs
@@ -726,7 +747,7 @@ simpleRecordUpdates =
     isSingleLabel (FieldLabelStrings labels) =
         case labels of
 #if __GLASGOW_HASKELL__ >= 906
-          [L _ (DotFieldOcc _ (L l (FieldLabelString label)))] ->
+          (matchSingleton -> Just (L _ (DotFieldOcc _ (L l (FieldLabelString label))))) ->
 #else
           [L _ (DotFieldOcc _ (L l label))] ->
 #endif
@@ -856,10 +877,54 @@ issueWarning l errMsg = do
     bag :: a -> Bag a
     bag = listToBag . (:[])
 
+
+{-------------------------------------------------------------------------------
+  Strictness
+-------------------------------------------------------------------------------}
+
+#if __GLASGOW_HASKELL__ >= 914
+getBangType :: LHsType GhcPs -> LHsType GhcPs
+getBangType                 (L _ (XHsType (HsBangTy _ _ lty))) = lty
+--getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =
+--  addCLocA lty lds (HsDocTy x lty lds)
+getBangType lty                                            = lty
+
+getBangStrictness :: LHsType GhcPs -> HsSrcBang
+getBangStrictness                 (L _ (XHsType (HsBangTy _ s _ty))) = s
+-- getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy (_, s) b _)) _)) = HsSrcBang s b
+getBangStrictness _ = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
+#endif
+
+{-------------------------------------------------------------------------------
+  Singleton
+-------------------------------------------------------------------------------}
+
+class Singleton f where
+    singleton :: a -> f a
+    matchSingleton :: f a -> Maybe a
+
+instance Singleton [] where
+    singleton x = [x]
+    matchSingleton [x] = Just x
+    matchSingleton _   = Nothing
+
+instance Singleton NonEmpty where
+    singleton x = x :| []
+    matchSingleton (x :| []) = Just x
+    matchSingleton _         = Nothing
+
 {-------------------------------------------------------------------------------
   Compat
 -------------------------------------------------------------------------------}
 
+#if __GLASGOW_HASKELL__ >= 914
+wrapBangTy :: HsTypeGhcPsExt -> HsType GhcPs
+wrapBangTy = XHsType
+#else
+wrapBangTy :: HsType GhcPs -> HsType GhcPs
+wrapBangTy = id
+#endif
+
 #if __GLASGOW_HASKELL__ >= 910
 pattern LambdaExpr :: HsMatchContext fn
 pattern LambdaExpr = LamAlt LamSingle