Skip to content

Commit 04712a7

Browse files
phadejphadej
committed
GHC-9.14 support
1 parent 5aa7f6f commit 04712a7

File tree

12 files changed

+184
-55
lines changed

12 files changed

+184
-55
lines changed

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -40,7 +40,7 @@ library
4040
build-depends:
4141
-- lower bound on beam-core is necessary
4242
-- see https://github.com/haskell-beam/beam/issues/585
43-
base >= 4.14 && < 4.23
43+
base >= 4.14 && < 4.24
4444
, beam-core >= 0.10.3.0 && < 0.11
4545
, large-generics >= 0.2 && < 0.3
4646
, microlens >= 0.4 && < 0.5

‎cabal.project‎

Lines changed: 24 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -2,7 +2,7 @@ packages: typelet
22
packages: large-anon
33
packages: large-generics
44
packages: large-records
5-
packages: beam-large-records
5+
-- packages: beam-large-records
66

77
if impl(ghc <9)
88
packages: large-records-benchmarks
@@ -25,3 +25,26 @@ package beam-large-records
2525

2626
package typelet
2727
tests: True
28+
29+
allow-newer: primitive-0.9.1.0:base
30+
allow-newer: primitive-0.9.1.0:template-haskell
31+
allow-newer: indexed-traversable-0.1.4:base
32+
allow-newer: finite-typelits-0.2.1.0:base
33+
allow-newer: finite-typelits-0.2.1.0:template-haskell
34+
allow-newer: bifunctors-5.6.2:template-haskell
35+
allow-newer: th-abstraction-0.7.1.0:template-haskell
36+
allow-newer: assoc-1.1.1:base
37+
allow-newer: vector-0.13.2.0:base
38+
allow-newer: vector-stream-0.1.0.1:base
39+
allow-newer: splitmix-0.1.3.1:base
40+
allow-newer: tagged-0.8.9:template-haskell
41+
allow-newer: scientific-0.3.8.0:base
42+
allow-newer: scientific-0.3.8.0:template-haskell
43+
allow-newer: integer-logarithms-1.0.4:base
44+
allow-newer: integer-logarithms-1.0.4:ghc-bignum
45+
allow-newer: *:base
46+
allow-newer: *:template-haskell
47+
allow-newer: *:ghc-bignum
48+
allow-newer: *:containers
49+
allow-newer: *:time
50+
allow-newer: ghc-tcplugin-api-0.17.0.0:ghc

‎large-anon/large-anon.cabal‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -77,10 +77,10 @@ library
7777

7878
build-depends:
7979
, aeson >= 1.4.4 && < 2.3
80-
, base >= 4.14 && < 4.22
80+
, base >= 4.14 && < 4.23
8181
, containers >= 0.6.2 && < 0.9
8282
, deepseq >= 1.4.4 && < 1.6
83-
, ghc >= 8.10 && < 9.13
83+
, ghc >= 8.10 && < 9.15
8484
, ghc-tcplugin-api >= 0.17.1.0 && < 0.18
8585
, hashable >= 1.3 && < 1.6
8686
, mtl >= 2.2.1 && < 2.4

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

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -256,6 +256,9 @@ importDecl qualified name = reLocA $ noLoc $ ImportDecl {
256256
#endif
257257
#if __GLASGOW_HASKELL__ >= 906
258258
, ideclImportList = Nothing
259+
#endif
260+
#if __GLASGOW_HASKELL__ >= 914
261+
, ideclLevelSpec = NotLevelled
259262
#endif
260263
}
261264

@@ -294,7 +297,11 @@ issueWarning l errMsg = do
294297
(initPrintConfig dynFlags)
295298
(initDiagOpts dynFlags)
296299

300+
#if __GLASGOW_HASKELL__ >= 914
301+
let msg :: Err.UnknownDiagnostic opts Err.GhcHint
302+
#else
297303
let msg :: Err.UnknownDiagnostic opts
304+
#endif
298305
msg = Err.mkSimpleUnknownDiagnostic $
299306
mkPlainError [] errMsg
300307
#endif

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

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# LANGUAGE CPP #-}
12
{-# LANGUAGE PolyKinds #-}
23
{-# LANGUAGE ScopedTypeVariables #-}
34
{-# LANGUAGE TypeApplications #-}
@@ -41,5 +42,11 @@ import qualified GHC.Records.Compat
4142
ifThenElse :: Bool -> a -> a -> a
4243
ifThenElse b x y = if b then x else y
4344

45+
-- | NOTE: the order of arguments is GHC version dependent.
46+
#if __GLASGOW_HASKELL__ >=914
47+
setField :: forall x r a. GHC.Records.Compat.HasField x r a => a -> r -> r
48+
setField = flip (fst . GHC.Records.Compat.hasField @x)
49+
#else
4450
setField :: forall x r a. GHC.Records.Compat.HasField x r a => r -> a -> r
4551
setField = fst . GHC.Records.Compat.hasField @x
52+
#endif

‎large-records/large-records.cabal‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -55,14 +55,14 @@ library
5555
Data.Record.Internal.Plugin.Record
5656

5757
build-depends:
58-
, base >= 4.14 && < 4.22
58+
, base >= 4.14 && < 4.23
5959
, containers >= 0.6.2 && < 0.9
60-
, ghc >= 8.10 && < 9.13
60+
, ghc >= 8.10 && < 9.15
6161
, mtl >= 2.2.1 && < 2.4
6262
, primitive >= 0.7.3 && < 0.10
6363
, record-hasfield >= 1.0 && < 1.1
6464
, syb >= 0.7 && < 0.8
65-
, template-haskell >= 2.16 && < 2.24
65+
, template-haskell >= 2.16 && < 2.25
6666

6767
-- large-generics 0.2 starts using 'SmallArray' instead of 'Vector'
6868
, large-generics >= 0.2 && < 0.3

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

Lines changed: 69 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -12,6 +12,12 @@
1212
{-# LANGUAGE ViewPatterns #-}
1313
{-# LANGUAGE TypeOperators #-}
1414

15+
#if __GLASGOW_HASKELL__ <914
16+
#define data pattern
17+
#else
18+
{-# LANGUAGE ExplicitNamespaces #-}
19+
#endif
20+
1521
-- | Thin compatibility layer around GHC
1622
--
1723
-- This should be the only module with GHC-specific CPP directives, and the
@@ -26,7 +32,7 @@ module Data.Record.Internal.GHC.Shim (
2632
, mkFunBind
2733
, HsModule
2834
, LHsModule
29-
, pattern GHC.HsModule
35+
, data GHC.HsModule
3036

3137
-- * Annotations
3238
#if __GLASGOW_HASKELL__ < 902
@@ -77,7 +83,14 @@ module Data.Record.Internal.GHC.Shim (
7783

7884
-- * Compat
7985
#if __GLASGOW_HASKELL__ >= 910
80-
, pattern LambdaExpr
86+
, data LambdaExpr
87+
#endif
88+
, wrapBangTy
89+
, Singleton (..)
90+
91+
#if __GLASGOW_HASKELL__ >= 914
92+
, getBangType
93+
, getBangStrictness
8194
#endif
8295

8396
-- * Re-exports
@@ -107,6 +120,8 @@ module Data.Record.Internal.GHC.Shim (
107120
#endif
108121
) where
109122

123+
#undef data
124+
110125
import Control.Monad
111126
import Data.List.NonEmpty (NonEmpty(..))
112127
import Data.Generics (Data, GenericQ, cast, toConstr, gzipWithQ)
@@ -144,7 +159,7 @@ import GHC.Driver.Main (getHscEnv)
144159
import GHC.Tc.Types.Evidence (HsWrapper(WpHole))
145160
import GHC.Utils.Error (Severity(SevError, SevWarning))
146161

147-
import GHC.Plugins hiding ((<>), getHscEnv, unLoc
162+
import GHC.Plugins hiding ((<>), getHscEnv, unLoc, singleton
148163
#if __GLASGOW_HASKELL__ >= 902
149164
, AnnType, AnnLet, AnnRec, AnnLam, AnnCase
150165
, Exception
@@ -298,6 +313,9 @@ importDecl qualified name = noLocA $ ImportDecl {
298313
#endif
299314
#if __GLASGOW_HASKELL__ >= 906
300315
, ideclImportList = Nothing
316+
#endif
317+
#if __GLASGOW_HASKELL__ >= 914
318+
, ideclLevelSpec = NotLevelled
301319
#endif
302320
}
303321

@@ -483,8 +501,10 @@ hsFunTy = HsFunTy
483501
hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow NormalSyntax)
484502
#elif __GLASGOW_HASKELL__ < 910
485503
hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow (L NoTokenLoc HsNormalTok))
486-
#else
504+
#elif __GLASGOW_HASKELL__ < 914
487505
hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow NoEpUniTok)
506+
#else
507+
hsFunTy ext = HsFunTy ext (HsUnannotated (EpArrow defExt))
488508
#endif
489509

490510
userTyVar :: LIdP GhcPs -> HsTyVarBndr GhcPs
@@ -726,7 +746,7 @@ simpleRecordUpdates =
726746
isSingleLabel (FieldLabelStrings labels) =
727747
case labels of
728748
#if __GLASGOW_HASKELL__ >= 906
729-
[L _ (DotFieldOcc _ (L l (FieldLabelString label)))] ->
749+
(matchSingleton -> Just (L _ (DotFieldOcc _ (L l (FieldLabelString label))))) ->
730750
#else
731751
[L _ (DotFieldOcc _ (L l label))] ->
732752
#endif
@@ -856,10 +876,54 @@ issueWarning l errMsg = do
856876
bag :: a -> Bag a
857877
bag = listToBag . (:[])
858878

879+
880+
{-------------------------------------------------------------------------------
881+
Strictness
882+
-------------------------------------------------------------------------------}
883+
884+
#if __GLASGOW_HASKELL__ >= 914
885+
getBangType :: LHsType GhcPs -> LHsType GhcPs
886+
getBangType (L _ (XHsType (HsBangTy _ _ lty))) = lty
887+
--getBangType (L _ (HsDocTy x (L _ (HsBangTy _ _ lty)) lds)) =
888+
-- addCLocA lty lds (HsDocTy x lty lds)
889+
getBangType lty = lty
890+
891+
getBangStrictness :: LHsType GhcPs -> HsSrcBang
892+
getBangStrictness (L _ (XHsType (HsBangTy _ s _ty))) = s
893+
-- getBangStrictness (L _ (HsDocTy _ (L _ (HsBangTy (_, s) b _)) _)) = HsSrcBang s b
894+
getBangStrictness _ = HsSrcBang NoSourceText NoSrcUnpack NoSrcStrict
895+
#endif
896+
897+
{-------------------------------------------------------------------------------
898+
Singleton
899+
-------------------------------------------------------------------------------}
900+
901+
class Singleton f where
902+
singleton :: a -> f a
903+
matchSingleton :: f a -> Maybe a
904+
905+
instance Singleton [] where
906+
singleton x = [x]
907+
matchSingleton [x] = Just x
908+
matchSingleton _ = Nothing
909+
910+
instance Singleton NonEmpty where
911+
singleton x = x :| []
912+
matchSingleton (x :| []) = Just x
913+
matchSingleton _ = Nothing
914+
859915
{-------------------------------------------------------------------------------
860916
Compat
861917
-------------------------------------------------------------------------------}
862918

919+
#if __GLASGOW_HASKELL__ >= 914
920+
wrapBangTy :: HsTypeGhcPsExt -> HsType GhcPs
921+
wrapBangTy = XHsType
922+
#else
923+
wrapBangTy :: HsType GhcPs -> HsType GhcPs
924+
wrapBangTy = id
925+
#endif
926+
863927
#if __GLASGOW_HASKELL__ >= 910
864928
pattern LambdaExpr :: HsMatchContext fn
865929
pattern LambdaExpr = LamAlt LamSingle

0 commit comments

Comments
 (0)