diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history for large-records +## 0.4.5 -- 2026-05-20 + +* Support ghc 9.14 + ## 0.4.4 -- 2025-09-19 * Generate `optics-core` `LabelOptic` instances. diff --git a/large-records.cabal b/large-records.cabal --- a/large-records.cabal +++ b/large-records.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: large-records -version: 0.4.4 +version: 0.4.5 synopsis: Efficient compilation for large records, linear in the size of the record description: For many reasons, the internal code generated for modules that contain records is quadratic in the number of record @@ -24,6 +24,7 @@ GHC ==9.8.4 GHC ==9.10.2 GHC ==9.12.2 + GHC ==9.14.1 source-repository head type: git @@ -55,14 +56,14 @@ 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 diff --git a/src/Data/Record/Internal/GHC/Shim.hs b/src/Data/Record/Internal/GHC/Shim.hs --- a/src/Data/Record/Internal/GHC/Shim.hs +++ b/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 @@ , mkFunBind , HsModule , LHsModule - , pattern GHC.HsModule + , data GHC.HsModule -- * Annotations #if __GLASGOW_HASKELL__ < 902 @@ -77,9 +83,16 @@ -- * Compat #if __GLASGOW_HASKELL__ >= 910 - , pattern LambdaExpr + , data LambdaExpr #endif + , wrapBangTy + , Singleton (..) +#if __GLASGOW_HASKELL__ >= 914 + , getBangType + , getBangStrictness +#endif + -- * Re-exports -- The whole-sale module exports are not ideal for preserving compatibility @@ -107,12 +120,15 @@ #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 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 GhcPlugins as GHC hiding (unLoc, singleton) #else @@ -144,7 +160,7 @@ 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 @@ -299,6 +315,9 @@ #if __GLASGOW_HASKELL__ >= 906 , ideclImportList = Nothing #endif +#if __GLASGOW_HASKELL__ >= 914 + , ideclLevelSpec = NotLevelled +#endif } conPat :: LIdP GhcPs -> HsConPatDetails GhcPs -> Pat GhcPs @@ -483,8 +502,10 @@ 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 @@ 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,9 +877,53 @@ 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 diff --git a/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs b/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs --- a/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs +++ b/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs @@ -3,6 +3,13 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} +-- Workaround for -Wpattern-namespace-specifie +#if __GLASGOW_HASKELL__ <914 +#define data pattern +#else +{-# LANGUAGE ExplicitNamespaces #-} +#endif + -- | Interface to the GHC API that closely mimicks Template Haskell -- -- See "Language.Haskell.TH.Lib". @@ -17,16 +24,16 @@ , mkNameExp , mkNameTy , mkNameTyCon - , pattern ExpVar - , pattern TyVar - , pattern TyCon + , data ExpVar + , data TyVar + , data TyCon -- * Expressions , litE , stringE - , pattern VarE - , pattern ConE + , data VarE + , data ConE , recConE - , pattern RecUpdE + , data RecUpdE , appE , listE , lamE @@ -41,8 +48,8 @@ -- * Types , parensT , litT - , pattern VarT - , pattern ConT + , data VarT + , data ConT , appT , listT -- ** Without direct equivalent @@ -56,12 +63,10 @@ , bangP , listP , wildP - -- * Strictness - , bangType -- * Class contexts , equalP -- * Constructors - , pattern RecC + , data RecC , forallRecC -- * Type variable binders , kindedTV @@ -70,14 +75,14 @@ -- * Top-level declarations , sigD , valD - , pattern DataD - , pattern DerivClause + , data DataD + , data DerivClause , instanceD , classD , tySynEqn -- * Pragmas - , pattern TypeAnnotation - , pattern PragAnnD + , data TypeAnnotation + , data PragAnnD -- * Re-exported types (intentionally without constructors) -- @@ -103,6 +108,8 @@ , LTyFamInstDecl ) where +#undef data + import Data.List (foldl') import Data.Maybe (fromMaybe) import Data.List.NonEmpty (NonEmpty(..)) @@ -321,7 +328,7 @@ -- | Convenience wrapper around 'lamE' for a single argument lamE1 :: LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -lamE1 p = lamE (p :| []) +lamE1 p = lamE (singleton p) -- | Equivalent of 'Language.Haskell.TH.Lib.caseE' caseE :: LHsExpr GhcPs -> [(LPat GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs @@ -474,7 +481,9 @@ -- | Equivalent of 'Language.Haskell.TH.Lib.conP' conP :: LIdP GhcPs -> [LPat GhcPs] -> LPat GhcPs -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ >= 914 +conP con args = inheritLoc con (conPat con (PrefixCon args)) +#elif __GLASGOW_HASKELL__ >= 902 conP con args = inheritLoc con (conPat con (PrefixCon [] args)) #else conP con args = inheritLoc con (conPat con (PrefixCon args)) @@ -493,20 +502,6 @@ wildP = inheritLoc noSrcSpan (WildPat defExt) {------------------------------------------------------------------------------- - Strictness --------------------------------------------------------------------------------} - --- | Approximate equivalent of 'Language.Haskell.TH.Lib.bangType' --- --- The GHC API has no equivalent of 'Language.Haskell.TH.Syntax.BangType'. -bangType :: LHsType GhcPs -> LHsType GhcPs -bangType t = inheritLoc t $ -#if __GLASGOW_HASKELL__ >= 912 - HsBangTy defExt (HsBang NoSrcUnpack SrcStrict) t -#else - HsBangTy defExt (HsSrcBang NoSourceText NoSrcUnpack SrcStrict) t -#endif -{------------------------------------------------------------------------------- Class contexts -------------------------------------------------------------------------------} @@ -529,11 +524,11 @@ -- -- NOTE: The GHC AST (but not TH) supports declaring multiple record fields -- with the same type. We do not support this here (since we follow TH). -recC :: LIdP GhcPs -> [(LIdP GhcPs, LHsType GhcPs)] -> LConDecl GhcPs +recC :: LIdP GhcPs -> [(LIdP GhcPs, LHsType GhcPs, HsSrcBang)] -> LConDecl GhcPs recC = forallRecC [] [] -- | Inverse to 'recC' -viewRecC :: LConDecl GhcPs -> Maybe (LIdP GhcPs, [(LIdP GhcPs, LHsType GhcPs)]) +viewRecC :: LConDecl GhcPs -> Maybe (LIdP GhcPs, [(LIdP GhcPs, LHsType GhcPs, HsSrcBang)]) viewRecC (L _ ConDeclH98 { @@ -549,14 +544,22 @@ } ) = (conName ,) <$> mapM viewRecField fields where - viewRecField :: LConDeclField GhcPs -> Maybe (LIdP GhcPs, LHsType GhcPs) +#if __GLASGOW_HASKELL__ >= 914 + viewRecField :: LHsConDeclRecField GhcPs -> Maybe (LIdP GhcPs, LHsType GhcPs, HsSrcBang) viewRecField (L _ + (HsConDeclRecField _ [L _ name] CDF { cdf_type = ty, cdf_bang = bang, cdf_unpack = unpack }) + ) = Just (viewFieldOcc name, ty, HsSrcBang NoSourceText unpack bang) +#else + viewRecField :: LConDeclField GhcPs -> Maybe (LIdP GhcPs, LHsType GhcPs, HsSrcBang) + viewRecField + (L _ ConDeclField { cd_fld_names = [L _ name] , cd_fld_type = ty } - ) = Just $ (viewFieldOcc name, ty) + ) = Just (viewFieldOcc name, getBangType ty, getBangStrictness ty) +#endif viewRecField _otherwise = Nothing viewFieldOcc :: FieldOcc GhcPs -> LIdP GhcPs @@ -566,7 +569,7 @@ #endif viewRecC _otherwise = Nothing -pattern RecC :: LIdP GhcPs -> [(LIdP GhcPs, LHsType GhcPs)] -> LConDecl GhcPs +pattern RecC :: LIdP GhcPs -> [(LIdP GhcPs, LHsType GhcPs, HsSrcBang)] -> LConDecl GhcPs pattern RecC conName args <- (viewRecC -> Just (conName, args)) where RecC = recC @@ -577,7 +580,7 @@ [LIdP GhcPs] -- ^ @forallC@ argument: bound type variables -> [LHsType GhcPs] -- ^ @forallC@ argument: context -> LIdP GhcPs -- ^ @recC@ argument: record constructor name - -> [(LIdP GhcPs, LHsType GhcPs)] -- ^ @recC@ argument: record fields + -> [(LIdP GhcPs, LHsType GhcPs, HsSrcBang)] -- ^ @recC@ argument: record fields -> LConDecl GhcPs forallRecC vars ctxt conName args = inheritLoc conName $ ConDeclH98 { con_ext = defExt @@ -585,21 +588,46 @@ , con_forall = inheritLoc conName True , con_ex_tvs = map (setDefaultSpecificity . mkBndr) vars , con_mb_cxt = Just (inheritLoc conName ctxt) - , con_args = RecCon (inheritLoc conName $ map (uncurry mkRecField) args) + , con_args = RecCon (inheritLoc conName $ map mkRecField args) , con_doc = Nothing } where mkBndr :: LIdP GhcPs -> LHsTyVarBndr GhcPs mkBndr name = inheritLoc name $ userTyVar name - mkRecField :: LIdP GhcPs -> LHsType GhcPs -> LConDeclField GhcPs - mkRecField name ty = inheritLoc name $ ConDeclField { +#if __GLASGOW_HASKELL__ >= 914 + mkRecField :: (LIdP GhcPs, LHsType GhcPs, HsSrcBang) -> LHsConDeclRecField GhcPs + mkRecField (name, ty, HsSrcBang _ unpack bang) = inheritLoc name $ HsConDeclRecField + { cdrf_ext = defExt + , cdrf_names = [inheritLoc name $ mkFieldOcc name] + , cdrf_spec = CDF + { cdf_ext = defExt + , cdf_unpack = unpack + , cdf_bang = bang + , cdf_multiplicity = HsUnannotated (EpArrow defExt) + , cdf_type = ty + , cdf_doc = Nothing + } + } + +#else + mkRecField :: (LIdP GhcPs, LHsType GhcPs, HsSrcBang) -> LConDeclField GhcPs + mkRecField (name, ty, bang) = inheritLoc name $ ConDeclField { cd_fld_ext = defExt , cd_fld_names = [inheritLoc name $ mkFieldOcc name] - , cd_fld_type = ty + , cd_fld_type = optionalBang bang ty , cd_fld_doc = Nothing } + optionalBang :: HsSrcBang -> LHsType GhcPs -> LHsType GhcPs + optionalBang bang = noLocA . HsBangTy defExt +#if __GLASGOW_HASKELL__ >= 912 + (case bang of HsSrcBang _ b -> b) +#else + bang +#endif +#endif + {------------------------------------------------------------------------------- Type variable binders -------------------------------------------------------------------------------} @@ -965,5 +993,5 @@ simpleGHRSs :: LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs) simpleGHRSs body = GRHSs defExt - [inheritLoc body $ GRHS defExt [] body] + (singleton (inheritLoc body (GRHS defExt [] body))) (inheritLoc body $ EmptyLocalBinds defExt) diff --git a/src/Data/Record/Internal/Plugin/CodeGen.hs b/src/Data/Record/Internal/Plugin/CodeGen.hs --- a/src/Data/Record/Internal/Plugin/CodeGen.hs +++ b/src/Data/Record/Internal/Plugin/CodeGen.hs @@ -124,19 +124,11 @@ | (i, _) <- zip [1 :: Int ..] recordFields ] - optionalBang :: HsSrcBang -> LHsType GhcPs -> LHsType GhcPs - optionalBang bang = noLocA . HsBangTy defExt -#if __GLASGOW_HASKELL__ >= 912 - (case bang of HsSrcBang _ b -> b) -#else - bang -#endif - fieldContext :: LIdP GhcPs -> Field -> LHsType GhcPs fieldContext var fld = equalP (VarT var) (fieldType fld) - fieldExistentialType :: LIdP GhcPs -> Field -> (LIdP GhcPs, LHsType GhcPs) - fieldExistentialType var fld = (fieldName fld, optionalBang (fieldStrictness fld) $ VarT var) + fieldExistentialType :: LIdP GhcPs -> Field -> (LIdP GhcPs, LHsType GhcPs, HsSrcBang) + fieldExistentialType var fld = (fieldName fld, VarT var, fieldStrictness fld) -- | Generate conversion to and from an array -- @@ -554,7 +546,9 @@ $ stringT (nameBase fieldName) isStrict :: DynFlags -> HsSrcBang -> Bool -#if __GLASGOW_HASKELL__ >= 912 +#if __GLASGOW_HASKELL__ >= 914 +isStrict dynFlags (HsSrcBang _ _ strictness) = +#elif __GLASGOW_HASKELL__ >= 912 isStrict dynFlags (HsSrcBang _ (HsBang _ strictness)) = #else isStrict dynFlags (HsSrcBang _ _ strictness) = diff --git a/src/Data/Record/Internal/Plugin/Record.hs b/src/Data/Record/Internal/Plugin/Record.hs --- a/src/Data/Record/Internal/Plugin/Record.hs +++ b/src/Data/Record/Internal/Plugin/Record.hs @@ -82,7 +82,7 @@ => SrcSpan -> LargeRecordOptions -> LHsDecl GhcPs -> m Record viewRecord annLoc options decl = case decl of - DataD tyName tyVars [RecC conName fields] derivs-> do + DataD tyName tyVars [RecC conName fields] derivs -> do fields' <- mapM viewField fields derivings <- viewRecordDerivings derivs pure Record { @@ -98,9 +98,9 @@ viewField :: MonadError Exception m - => (LIdP GhcPs, LHsType GhcPs) -> m (Int -> Field) -viewField (name, typ) = - return $ Field name (parensT (getBangType typ)) (getBangStrictness typ) + => (LIdP GhcPs, LHsType GhcPs, HsSrcBang) -> m (Int -> Field) +viewField (name, typ, bang) = + return $ Field name (parensT typ) bang viewRecordDerivings :: MonadError Exception m diff --git a/src/Data/Record/Overloading.hs b/src/Data/Record/Overloading.hs --- a/src/Data/Record/Overloading.hs +++ b/src/Data/Record/Overloading.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -79,5 +80,10 @@ getField :: forall x r a. GHC.Records.Compat.HasField x r a => r -> a getField = snd . GHC.Records.Compat.hasField @x +#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 diff --git a/test/Test/Record/Sanity/StrictnessStrictData.hs b/test/Test/Record/Sanity/StrictnessStrictData.hs --- a/test/Test/Record/Sanity/StrictnessStrictData.hs +++ b/test/Test/Record/Sanity/StrictnessStrictData.hs @@ -40,7 +40,7 @@ ) tests :: TestTree -tests = testGroup "Test.Record.Sanity.Strictness" [ +tests = testGroup "Test.Record.Sanity.StrictnessStrictData" [ testCase "initValueLazy" test_initValueLazy , testCase "initValueStrict" test_initValueStrict , testCase "setValueLazy" test_setValueLazy