large-records 0.4.4 → 0.4.5
raw patch · 8 files changed
+167/−69 lines, 8 filesdep ~basedep ~ghcdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: base, ghc, template-haskell
API changes (from Hackage documentation)
Files
- CHANGELOG.md +4/−0
- large-records.cabal +5/−4
- src/Data/Record/Internal/GHC/Shim.hs +72/−7
- src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs +70/−42
- src/Data/Record/Internal/Plugin/CodeGen.hs +5/−11
- src/Data/Record/Internal/Plugin/Record.hs +4/−4
- src/Data/Record/Overloading.hs +6/−0
- test/Test/Record/Sanity/StrictnessStrictData.hs +1/−1
CHANGELOG.md view
@@ -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.
large-records.cabal view
@@ -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
src/Data/Record/Internal/GHC/Shim.hs view
@@ -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
src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs view
@@ -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)
src/Data/Record/Internal/Plugin/CodeGen.hs view
@@ -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) =
src/Data/Record/Internal/Plugin/Record.hs view
@@ -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
src/Data/Record/Overloading.hs view
@@ -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
test/Test/Record/Sanity/StrictnessStrictData.hs view
@@ -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