packages feed

large-records 0.2.1.0 → 0.3

raw patch · 26 files changed

+503/−195 lines, 26 filesdep ~ghcPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc

API changes (from Hackage documentation)

- Data.Record.Plugin.Options: [allFieldsStrict] :: LargeRecordOptions -> Bool
- Data.Record.Plugin.Options: largeRecordLazy :: LargeRecordOptions
- Data.Record.Plugin.Options: largeRecordStrict :: LargeRecordOptions
+ Data.Record.Plugin.Options: largeRecord :: LargeRecordOptions
- Data.Record.Plugin.Options: LargeRecordOptions :: Bool -> Bool -> LargeRecordOptions
+ Data.Record.Plugin.Options: LargeRecordOptions :: Bool -> LargeRecordOptions

Files

CHANGELOG.md view
@@ -1,5 +1,10 @@ # Revision history for large-records +## 0.3 -- 2022-07-22++* Support ghc 9.2 (#117)+* Support for field strictness annotations (#107)+ ## 0.2.1.0 -- 2022-04-06  * Update for `large-generics` 0.2
large-records.cabal view
@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               large-records-version:            0.2.1.0+version:            0.3 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@@ -16,7 +16,7 @@ maintainer:         edsko@well-typed.com category:           Generics extra-source-files: CHANGELOG.md-tested-with:        GHC ==8.8.4 || ==8.10.7 || ==9.0.2+tested-with:        GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2  source-repository head   type:     git@@ -99,6 +99,7 @@       Test.Record.Sanity.RDP.SplitModule.RecordDef       Test.Record.Sanity.RecordConstruction       Test.Record.Sanity.Strictness+      Test.Record.Sanity.StrictnessStrictData       Test.Record.Sanity.GhcGenerics       Test.Record.Util
src/Data/Record/Internal/GHC/Shim.hs view
@@ -7,6 +7,7 @@ {-# LANGUAGE RankNTypes             #-} {-# LANGUAGE TypeApplications       #-} {-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE ViewPatterns           #-}  -- | Thin compatibility layer around GHC --@@ -21,10 +22,17 @@   , LHsModule   , LRdrName   , pattern GHC.HsModule-  , putLogMsg +    -- * Annotations+#if __GLASGOW_HASKELL__ < 902+  , reLoc+  , reLocA+  , noLocA+#endif+     -- * Extensions   , HasDefaultExt(..)+  , withDefExt      -- * Generalized @forall@ #if __GLASGOW_HASKELL__ >= 900@@ -39,7 +47,9 @@      -- * New functionality   , compareHs-  , InheritLoc(..)+  , inheritLoc+  , inheritLoc'+  , inheritLocPat      -- * Re-exports @@ -60,10 +70,13 @@   , module GHC.Hs   , module GHC.Plugins   , module GHC.Tc.Types.Evidence-  , module GHC.Types.Basic   , module GHC.Types.Name.Cache   , module GHC.Utils.Error+#if __GLASGOW_HASKELL__ >= 902+  , module GHC.Types.SourceText+  , module GHC.Types.Fixity #endif+#endif   ) where  import Data.List.NonEmpty (NonEmpty(..))@@ -73,12 +86,12 @@  #if __GLASGOW_HASKELL__ < 900 +import BasicTypes (SourceText (NoSourceText)) import Bag (listToBag, emptyBag)-import BasicTypes (SourceText(NoSourceText)) import ConLike (ConLike) import ErrUtils (mkErrMsg, mkWarnMsg) import GHC hiding (AnnKeywordId(..), HsModule, exprType, typeKind, mkFunBind)-import GhcPlugins hiding ((<>), getHscEnv, putLogMsg)+import GhcPlugins hiding ((<>), getHscEnv,) import HscMain (getHscEnv) import NameCache (NameCache(nsUniqs)) import PatSyn (PatSyn)@@ -89,21 +102,33 @@  #else +import GHC.Hs hiding (LHsTyVarBndr, HsTyVarBndr, HsModule, mkFunBind)+ import GHC.Core.Class (Class) import GHC.Core.ConLike (ConLike) import GHC.Core.PatSyn (PatSyn) import GHC.Data.Bag (listToBag, emptyBag) import GHC.Driver.Main (getHscEnv)-import GHC.Hs hiding (LHsTyVarBndr, HsTyVarBndr, HsModule, mkFunBind)-import GHC.Parser.Annotation (IsUnicodeSyntax(NormalSyntax))-import GHC.Plugins hiding ((<>), getHscEnv, putLogMsg) import GHC.Tc.Types.Evidence (HsWrapper(WpHole))-import GHC.Types.Basic (SourceText(NoSourceText)) import GHC.Types.Name.Cache (NameCache(nsUniqs))-import GHC.Utils.Error (Severity(SevError, SevWarning), mkErrMsg, mkWarnMsg)+import GHC.Utils.Error (Severity(SevError, SevWarning)) +import GHC.Plugins hiding ((<>), getHscEnv+#if __GLASGOW_HASKELL__ >=902+    , AnnType, AnnLet, AnnRec, AnnLam, AnnCase+    , Exception+#endif+    )++#if __GLASGOW_HASKELL__ < 902+import GHC.Utils.Error (mkErrMsg, mkWarnMsg)+import GHC.Parser.Annotation (IsUnicodeSyntax(NormalSyntax))+#else+import GHC.Types.SourceText (SourceText(NoSourceText), mkIntegralLit)+import GHC.Types.Fixity+#endif+ import qualified GHC.Hs      as GHC-import qualified GHC.Plugins as GHC  #endif @@ -113,10 +138,10 @@  -- | Optionally @qualified@ import declaration importDecl :: ModuleName -> Bool -> LImportDecl GhcPs-importDecl name qualified = noLoc $ ImportDecl {+importDecl name qualified = noLocA $ ImportDecl {       ideclExt       = defExt     , ideclSourceSrc = NoSourceText-    , ideclName      = noLoc name+    , ideclName      = noLocA name     , ideclPkgQual   = Nothing     , ideclSafe      = False     , ideclImplicit  = False@@ -138,14 +163,14 @@ #if __GLASGOW_HASKELL__ < 900 conPat x y = ConPatIn x y #else-conPat x y = ConPat noExtField x y+conPat x y = ConPat defExt (reLocA x) y #endif  mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs #if __GLASGOW_HASKELL__ < 810 mkFunBind = GHC.mkFunBind #else-mkFunBind = GHC.mkFunBind Generated+mkFunBind (reLocA -> n) = GHC.mkFunBind Generated n #endif  #if __GLASGOW_HASKELL__ < 900@@ -157,13 +182,25 @@ type LHsModule = Located HsModule type LRdrName  = Located RdrName -putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO ()-#if __GLASGOW_HASKELL__ < 900-putLogMsg flags reason sev srcspan =-    GHC.putLogMsg flags reason sev srcspan (defaultErrStyle flags)-#else-putLogMsg = GHC.putLogMsg+{-------------------------------------------------------------------------------+  Exact-print annotations+-------------------------------------------------------------------------------}++#if __GLASGOW_HASKELL__ < 902+reLoc :: Located a -> Located a+reLoc = id++reLocA :: Located a -> Located a+reLocA = id++noLocA :: e -> Located e+noLocA = noLoc++#if __GLASGOW_HASKELL__ >= 900+mapXRec :: forall pass f g l. (f pass -> g pass) -> GenLocated l (f pass) -> GenLocated l (g pass)+mapXRec = fmap #endif+#endif  {-------------------------------------------------------------------------------   Extensions@@ -185,6 +222,32 @@   defExt = NoLayoutInfo #endif +instance (HasDefaultExt a, HasDefaultExt b) => HasDefaultExt (a, b) where+  defExt = (defExt, defExt)++instance (HasDefaultExt a, HasDefaultExt b, HasDefaultExt c) => HasDefaultExt (a, b, c) where+  defExt = (defExt, defExt, defExt)++#if __GLASGOW_HASKELL__ >= 902+instance HasDefaultExt (EpAnn ann) where+  defExt = noAnn++instance HasDefaultExt AnnSortKey where+  defExt = NoAnnSortKey++instance HasDefaultExt EpAnnComments where+  defExt = epAnnComments noAnn+#endif++-- In GHC-9.2 some things have extension fields.+#if __GLASGOW_HASKELL__ >= 902+withDefExt :: HasDefaultExt a => (a -> b) -> b+withDefExt f = f defExt +#else+withDefExt :: a -> a+withDefExt a = a+#endif+ {-------------------------------------------------------------------------------   Generalized @forall@ in 9.0 -------------------------------------------------------------------------------}@@ -202,24 +265,24 @@ #endif  userTyVar ::-     XUserTyVar pass-  -> Located (IdP pass)-  -> HsTyVarBndr pass+     XUserTyVar GhcPs+  -> Located (IdP GhcPs)+  -> HsTyVarBndr GhcPs #if __GLASGOW_HASKELL__ < 900 userTyVar = UserTyVar #else-userTyVar ext = UserTyVar ext ()+userTyVar ext x = UserTyVar ext () (reLocA x) #endif  kindedTyVar ::-     XKindedTyVar pass-  -> Located (IdP pass)-  -> LHsKind pass-  -> HsTyVarBndr pass+     XKindedTyVar GhcPs+  -> Located (IdP GhcPs)+  -> LHsKind GhcPs+  -> HsTyVarBndr GhcPs #if __GLASGOW_HASKELL__ < 900 kindedTyVar = KindedTyVar #else-kindedTyVar ext = KindedTyVar ext ()+kindedTyVar ext k = KindedTyVar ext () (reLocA k) #endif  -- | Like 'hsTyVarName', but don't throw away the location information@@ -229,20 +292,22 @@ hsTyVarLName (KindedTyVar _ n _) = n hsTyVarLName _ = panic "hsTyVarLName" #else-hsTyVarLName (UserTyVar   _ _ n  ) = n-hsTyVarLName (KindedTyVar _ _ n _) = n+hsTyVarLName (UserTyVar   _ _ n  ) = reLoc n+hsTyVarLName (KindedTyVar _ _ n _) = reLoc n #endif  #if __GLASGOW_HASKELL__ < 900 setDefaultSpecificity :: LHsTyVarBndr pass -> GHC.LHsTyVarBndr pass setDefaultSpecificity = id #else-setDefaultSpecificity :: LHsTyVarBndr pass -> GHC.LHsTyVarBndr Specificity pass-setDefaultSpecificity (L l v) = L l $ case v of+setDefaultSpecificity :: LHsTyVarBndr GhcPs -> GHC.LHsTyVarBndr Specificity GhcPs+setDefaultSpecificity = mapXRec @GhcPs $ \v -> case v of     UserTyVar   ext () name      -> UserTyVar   ext SpecifiedSpec name     KindedTyVar ext () name kind -> KindedTyVar ext SpecifiedSpec name kind+#if __GLASGOW_HASKELL__ < 900     XTyVarBndr  ext              -> XTyVarBndr  ext #endif+#endif  {-------------------------------------------------------------------------------   New functionality@@ -294,26 +359,57 @@   Working with locations -------------------------------------------------------------------------------} -class InheritLoc a b lb | lb -> b where-  inheritLoc :: a -> b -> lb+class FromSrcSpan l where+  fromSrcSpan :: SrcSpan -> l -instance InheritLoc (Located a) b (Located b) where-  inheritLoc (L l _) = L l+instance FromSrcSpan SrcSpan where+  fromSrcSpan = id -instance InheritLoc a b lb => InheritLoc (NonEmpty a) b lb where+#if __GLASGOW_HASKELL__ >= 902+instance HasDefaultExt ann => FromSrcSpan (SrcSpanAnn' ann) where+  fromSrcSpan = SrcSpanAnn defExt+#endif++class InheritLoc a where+  inheritLoc :: FromSrcSpan l => a -> b -> GenLocated l b++#if __GLASGOW_HASKELL__ >= 902+-- GHC-9.2 may not require annotation+inheritLoc' :: a -> b -> b+inheritLoc' _ = id+#else+inheritLoc' :: InheritLoc a => a -> b -> Located b+inheritLoc' = inheritLoc+#endif++instance InheritLoc a => InheritLoc (NonEmpty a) where   inheritLoc = inheritLoc . NE.head --- | The instance for @[]@ is not ideal: we use 'noLoc' if the list is empty+instance InheritLoc l => InheritLoc (GenLocated l a) where+  inheritLoc (L l _) = inheritLoc l++instance InheritLoc SrcSpan where+  inheritLoc l x = L (fromSrcSpan l) x++#if __GLASGOW_HASKELL__ >= 902+instance InheritLoc (SrcSpanAnn' ann) where+  inheritLoc (SrcSpanAnn _ l) = inheritLoc l+#endif+ ----- For the use cases in this library, this is acceptable: typically these are--- lists with elements for the record fields, and having slightly poorer error--- messages for highly unusual "empty large" records is fine.-instance InheritLoc a b (Located b) => InheritLoc [a] b (Located b) where-  inheritLoc (a:_) = inheritLoc a-  inheritLoc []    = noLoc+-- -- | The instance for @[]@ is not ideal: we use 'noLoc' if the list is empty+-- --+-- -- For the use cases in this library, this is acceptable: typically these are+-- -- lists with elements for the record fields, and having slightly poorer error+-- -- messages for highly unusual "empty large" records is fine.+instance InheritLoc a => InheritLoc [a] where+   inheritLoc (a:_) = inheritLoc a+   inheritLoc []    = inheritLoc noSrcSpan  #if __GLASGOW_HASKELL__ < 810--- In 8.8, 'LPat' is a synonym for 'Pat'-instance InheritLoc a (Pat p) (LPat p) where-  inheritLoc _ = id+inheritLocPat :: a -> Pat p -> LPat p+inheritLocPat _ = id -- In 8.8, 'LPat' is a synonym for 'Pat'+#else+inheritLocPat :: InheritLoc a => a -> Pat (GhcPass p) -> LPat (GhcPass p)+inheritLocPat = inheritLoc #endif
src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs view
@@ -179,13 +179,13 @@ -- | Equivalent of 'Language.Haskell.TH.Lib.varE' varE :: HasCallStack => LRdrName -> LHsExpr GhcPs varE name-  | isTermVar name = inheritLoc name $ HsVar defExt name+  | isTermVar name = inheritLoc name $ HsVar defExt (reLocA name)   | otherwise      = error "varE: incorrect name type"  -- | Inverse to 'varE' viewVarE :: LHsExpr GhcPs -> Maybe LRdrName-viewVarE (L _ (HsVar _ name)) | isTermVar name = Just name-viewVarE _                                     = Nothing+viewVarE (reLoc -> L _ (HsVar _ (reLoc -> name))) | isTermVar name = Just name+viewVarE _ = Nothing  pattern VarE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs pattern VarE name <- (viewVarE -> Just name)@@ -195,12 +195,12 @@ -- | Equivalent of 'Language.Haskell.TH.Lib.conE' conE :: HasCallStack => LRdrName -> LHsExpr GhcPs conE name-  | isTermCon name = inheritLoc name $ HsVar defExt name+  | isTermCon name = inheritLoc name $ HsVar defExt (reLocA name)   | otherwise      = error "conE: incorrect name type"  -- | Inverse to 'conE' viewConE :: LHsExpr GhcPs -> Maybe LRdrName-viewConE (L _ (HsVar _ name)) | isTermCon name = Just name+viewConE (reLoc -> L _ (HsVar _ (reLoc -> name))) | isTermCon name = Just name viewConE _ = Nothing  pattern ConE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs@@ -210,7 +210,7 @@  -- | Equivalent of 'Language.Haskell.TH.Lib.litE' litE :: HsLit GhcPs -> LHsExpr GhcPs-litE = noLoc . HsLit defExt+litE = noLocA . HsLit defExt  -- | Equivalent of 'Language.Haskell.TH.Lib.stringE' stringE :: String -> LHsExpr GhcPs@@ -222,11 +222,15 @@   where     mkRec :: LRdrName -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs     mkRec name fields = inheritLoc name $-        RecordCon defExt name (HsRecFields fields Nothing)+        RecordCon defExt (reLocA name) (HsRecFields fields Nothing)      mkFld :: LRdrName -> LHsExpr GhcPs -> LHsRecField GhcPs (LHsExpr GhcPs)     mkFld name val = inheritLoc name $-        HsRecField (inheritLoc name (mkFieldOcc name)) val False+        HsRecField+#if __GLASGOW_HASKELL__ >= 902+          defExt+#endif+          (reLoc (inheritLoc name (mkFieldOcc (reLocA name)))) val False  -- | Equivalent of 'Language.Haskell.TH.Lib.recUpdE' recUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs@@ -234,21 +238,33 @@   where     updRec :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> LHsExpr GhcPs     updRec expr fields = inheritLoc expr $-        RecordUpd defExt expr fields+        RecordUpd defExt expr+#if __GLASGOW_HASKELL__ >= 902+          $ Left+#endif+            fields      updFld :: LRdrName -> LHsExpr GhcPs -> LHsRecUpdField GhcPs     updFld name val = inheritLoc name $-        HsRecField (inheritLoc name (mkAmbiguousFieldOcc name)) val False+        HsRecField+#if __GLASGOW_HASKELL__ >= 902+          defExt+#endif+         (reLoc (inheritLoc name (mkAmbiguousFieldOcc (reLocA name)))) val False  viewRecUpdE ::      LHsExpr GhcPs   -> Maybe (LHsExpr GhcPs, [(LRdrName, LHsExpr GhcPs)])+#if __GLASGOW_HASKELL__ >= 902+viewRecUpdE (L _ (RecordUpd _ recExpr (Left fields))) =+#else viewRecUpdE (L _ (RecordUpd _ recExpr fields)) =+#endif     (recExpr,) <$> mapM viewFieldUpd fields   where     viewFieldUpd :: LHsRecUpdField GhcPs -> Maybe (LRdrName, LHsExpr GhcPs)-    viewFieldUpd (L _ (HsRecField (L _ (Unambiguous _ name)) val False)) =-        Just (name, val)+    viewFieldUpd (L _ (HsRecField { hsRecFieldLbl = L _ (Unambiguous _ name), hsRecFieldArg = val, hsRecPun = False })) =+        Just (reLoc name, val)     viewFieldUpd _otherwise =         Nothing viewRecUpdE _otherwise = Nothing@@ -264,7 +280,11 @@  -- | Equivalent of 'Language.Haskell.TH.Lib.listE' listE :: [LHsExpr GhcPs] -> LHsExpr GhcPs-listE es = inheritLoc es $ ExplicitList defExt Nothing es+listE es = inheritLoc es $ ExplicitList defExt+#if __GLASGOW_HASKELL__ < 902+    Nothing+#endif+    es  -- | Equivalent of 'Language.Haskell.TH.Lib.lamE' lamE :: NonEmpty (LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs@@ -297,7 +317,7 @@ tupE xs = inheritLoc xs $     ExplicitTuple       defExt-      [inheritLoc xs (Present defExt x) | x <- NE.toList xs]+      [inheritLoc' xs (Present defExt x) | x <- NE.toList xs]       Boxed  -- | Equivalent of 'Language.Haskell.TH.Lib.sigE'@@ -319,18 +339,18 @@  -- | Equivalent of 'Language.Haskell.TH.Lib.litT' litT :: HsTyLit -> LHsType GhcPs-litT = noLoc . HsTyLit defExt+litT = noLocA . HsTyLit defExt  -- | Equivalent of 'Language.Haskell.TH.Lib.varT' varT :: HasCallStack => LRdrName -> LHsType GhcPs varT name-  | isTypeVar name = inheritLoc name (HsTyVar defExt NotPromoted name)+  | isTypeVar name = inheritLoc name (HsTyVar defExt NotPromoted (reLocA name))   | otherwise      = error "varT: incorrect name type"  -- | Inverse to 'varT' viewVarT :: LHsType GhcPs -> Maybe LRdrName-viewVarT (L _ (HsTyVar _ _ name)) | isTypeVar name = Just name-viewVarT _otherwise                                = Nothing+viewVarT (reLoc -> L _ (HsTyVar _ _ (reLoc -> name))) | isTypeVar name = Just name+viewVarT _otherwise = Nothing  pattern VarT :: HasCallStack => () => LRdrName -> LHsType GhcPs pattern VarT name <- (viewVarT -> Just name)@@ -340,13 +360,13 @@ -- | Equivalent of 'Language.Haskell.TH.Lib.conT' conT :: HasCallStack => LRdrName -> LHsType GhcPs conT name-  | isTypeCon name = inheritLoc name (HsTyVar defExt NotPromoted name)+  | isTypeCon name = inheritLoc name (HsTyVar defExt NotPromoted (reLocA name))   | otherwise      = error "varT: incorrect name type"  -- | Inverse to 'conT' viewConT :: LHsType GhcPs -> Maybe LRdrName-viewConT (L _ (HsTyVar _ _ name)) | isTypeCon name = Just name-viewConT _otherwise                                = Nothing+viewConT (reLoc -> L _ (HsTyVar _ _ (reLoc -> name))) | isTypeCon name = Just name+viewConT _otherwise = Nothing  pattern ConT :: HasCallStack => () => LRdrName -> LHsType GhcPs pattern ConT name <- (viewConT -> Just name)@@ -394,23 +414,27 @@  -- | Equivalent of 'Language.Haskell.TH.Lib.varP' varP :: LRdrName -> LPat GhcPs-varP name = inheritLoc name (VarPat defExt name)+varP name = inheritLocPat name (VarPat defExt (reLocA name))  -- | Equivalent of 'Language.Haskell.TH.Lib.conP' conP :: LRdrName -> [LPat GhcPs] -> LPat GhcPs-conP con args = inheritLoc con (conPat con (PrefixCon args))+#if __GLASGOW_HASKELL__ >= 902+conP con args = inheritLocPat con (conPat con (PrefixCon [] args))+#else+conP con args = inheritLocPat con (conPat con (PrefixCon args))+#endif  -- | Equivalent of 'Language.Haskell.TH.Lib.bangP' bangP :: LPat GhcPs -> LPat GhcPs-bangP p = inheritLoc p $ BangPat defExt p+bangP p = inheritLocPat p $ BangPat defExt p  -- | Equivalent of 'Language.Haskell.TH.Lib.listP' listP :: [LPat GhcPs] -> LPat GhcPs-listP xs = inheritLoc xs $ ListPat defExt xs+listP xs = inheritLocPat xs $ ListPat defExt xs  -- | Equivalent of 'Language.Haskell.TH.Lib.wildP' wildP :: LPat GhcPs-wildP = noLoc (WildPat defExt)+wildP = inheritLocPat noSrcSpan (WildPat defExt)  {-------------------------------------------------------------------------------   Strictness@@ -448,12 +472,16 @@     (L _        ConDeclH98 {            con_name   = conName+#if __GLASGOW_HASKELL__ >= 902+         , con_forall = False+#else          , con_forall = L _ False+#endif          , con_ex_tvs = []          , con_mb_cxt = Nothing          , con_args   = RecCon (L _ fields)          }-    ) = (conName,) <$> mapM viewRecField fields+    ) = (reLoc conName ,) <$> mapM viewRecField fields   where     viewRecField :: LConDeclField GhcPs -> Maybe (LRdrName, LHsType GhcPs)     viewRecField@@ -466,7 +494,7 @@     viewRecField _otherwise = Nothing      viewFieldOcc :: FieldOcc GhcPs -> LRdrName-    viewFieldOcc (FieldOcc _ name) = name+    viewFieldOcc (FieldOcc _ (reLoc -> name)) = name #if __GLASGOW_HASKELL__ < 900     viewFieldOcc _ = panic "viewFieldOcc" #endif@@ -487,8 +515,8 @@   -> LConDecl GhcPs forallRecC vars ctxt conName args = inheritLoc conName $ ConDeclH98 {       con_ext    = defExt-    , con_name   = conName-    , con_forall = inheritLoc conName True+    , con_name   = reLocA conName+    , 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)@@ -501,7 +529,7 @@     mkRecField :: LRdrName -> LHsType GhcPs -> LConDeclField GhcPs     mkRecField name ty = inheritLoc name $ ConDeclField {           cd_fld_ext   = defExt-        , cd_fld_names = [inheritLoc name $ mkFieldOcc name]+        , cd_fld_names = [inheritLoc name $ mkFieldOcc $ reLocA name]         , cd_fld_type  = ty         , cd_fld_doc   = Nothing         }@@ -530,7 +558,7 @@ sigD name ty = inheritLoc name $ SigD defExt sig   where     sig :: Sig GhcPs-    sig = TypeSig defExt [name] $ HsWC defExt (implicitBndrs ty)+    sig = TypeSig defExt [reLocA name] $ HsWC defExt (implicitBndrs ty)  -- | Equivalent of 'Language.Haskell.TH.Lib.valD' --@@ -549,17 +577,21 @@ dataD typeName tyVars cons derivs = inheritLoc typeName $     TyClD defExt $ DataDecl {         tcdDExt     = defExt-      , tcdLName    = typeName+      , tcdLName    = reLocA typeName       , tcdTyVars   = mkHsQTvs tyVars       , tcdFixity   = Prefix       , tcdDataDefn = HsDataDefn {             dd_ext     = defExt           , dd_ND      = DataType+#if __GLASGOW_HASKELL__ >= 902+          , dd_ctxt    = Nothing+#else           , dd_ctxt    = inheritLoc typeName []+#endif           , dd_cType   = Nothing           , dd_kindSig = Nothing           , dd_cons    = cons-          , dd_derivs  = inheritLoc typeName derivs+          , dd_derivs  = inheritLoc' typeName derivs           }       } @@ -582,15 +614,23 @@            , tcdFixity   = Prefix            , tcdDataDefn = HsDataDefn {                    dd_ND      = DataType+#if __GLASGOW_HASKELL__ >= 902+                 , dd_ctxt    = Nothing+#else                  , dd_ctxt    = L _ []+#endif                  , dd_cType   = Nothing                  , dd_kindSig = Nothing                  , dd_cons    = cons+#if __GLASGOW_HASKELL__ >= 902+                 , dd_derivs  = derivs+#else                  , dd_derivs  = L _ derivs+#endif                  }            }        )-    ) = Just (typeName, tyVars, cons, derivs)+    ) = Just (reLoc typeName, tyVars, cons, derivs) viewDataD _otherwise = Nothing  pattern DataD ::@@ -610,15 +650,25 @@   -> NonEmpty (LHsType GhcPs)   -> LHsDerivingClause GhcPs derivClause strat tys = inheritLoc tys $-    HsDerivingClause defExt strat $-      inheritLoc tys $ map implicitBndrs (NE.toList tys)+    HsDerivingClause defExt strat $ inheritLoc tys $+#if __GLASGOW_HASKELL__ >= 902+      DctMulti defExt $+#endif+      map implicitBndrs (NE.toList tys)  -- | Inverse of 'derivClause' viewDerivClause ::      LHsDerivingClause GhcPs   -> (Maybe (LDerivStrategy GhcPs), [LHsType GhcPs])+#if __GLASGOW_HASKELL__ >= 902+viewDerivClause (L _ (HsDerivingClause _ mStrat (L _ (DctMulti _ tys)))) =+    (mStrat, map viewImplicitBndrs tys)+viewDerivClause (L _ (HsDerivingClause _ mStrat (L _ (DctSingle _ ty)))) =+    (mStrat, map viewImplicitBndrs [ty])+#else viewDerivClause (L _ (HsDerivingClause _ mStrat (L _ tys))) =     (mStrat, map viewImplicitBndrs tys)+#endif #if __GLASGOW_HASKELL__ < 900 viewDerivClause _ = panic "viewDerivClause" #endif@@ -654,8 +704,13 @@   where     qualT :: [LHsType GhcPs] -> LHsType GhcPs -> LHsType GhcPs     qualT []        a = a-    qualT ctx@(c:_) a = inheritLoc c $-                          HsQualTy defExt (inheritLoc c ctx) a+    qualT ctx@(c:_) a = inheritLoc c $ HsQualTy defExt+#if __GLASGOW_HASKELL__ >= 902+        (Just (inheritLoc c ctx))+#else+        (inheritLoc c ctx)+#endif+        a  -- | Equivalent of 'Language.Haskell.TH.Lib.classD' classD ::@@ -667,8 +722,12 @@ classD = \ctx name clsVars sigs -> inheritLoc name $     TyClD defExt $ ClassDecl {         tcdCExt   = defExt+#if __GLASGOW_HASKELL__ >= 902+      , tcdCtxt   = Just (inheritLoc name ctx)+#else       , tcdCtxt   = inheritLoc name ctx-      , tcdLName  = name+#endif+      , tcdLName  = reLocA name       , tcdTyVars = mkHsQTvs clsVars       , tcdFixity = Prefix       , tcdFDs    = []@@ -681,7 +740,7 @@   where     classOpSig :: LRdrName -> LHsType GhcPs -> LSig GhcPs     classOpSig name ty = inheritLoc name $-        ClassOpSig defExt False [name] (implicitBndrs ty)+        ClassOpSig defExt False [reLocA name] (implicitBndrs ty)  -- | Approximate equivalent of 'Language.Haskell.TH.Lib.tySynEqn' tySynEqn ::@@ -690,11 +749,19 @@   -> LHsType GhcPs   -- ^ Equation RHS   -> LTyFamInstDecl GhcPs tySynEqn name pats val = inheritLoc val $-    TyFamInstDecl $-      implicitBndrs $+    TyFamInstDecl+#if __GLASGOW_HASKELL__ >= 902+      defExt $+#else+      $ implicitBndrs $+#endif         FamEqn defExt-               name+               (reLocA name)+#if __GLASGOW_HASKELL__ >= 902+               (HsOuterImplicit defExt)+#else                Nothing+#endif                (map HsValArg pats)                Prefix                val@@ -706,22 +773,29 @@   the @name@ type in @Located@. -------------------------------------------------------------------------------} +type AnnProvenancePs = AnnProvenance+#if __GLASGOW_HASKELL__ >= 902+    GhcPs+#else+    RdrName+#endif+ -- | Equivalent of 'Language.Haskell.TH.Lib.typeAnnotation'-typeAnnotation :: LRdrName -> AnnProvenance RdrName-typeAnnotation name = TypeAnnProvenance name+typeAnnotation :: LRdrName -> AnnProvenancePs+typeAnnotation name = TypeAnnProvenance (reLocA name)  -- | Inverse to 'typeAnnotation'-viewTypeAnnotation :: AnnProvenance RdrName -> Maybe LRdrName-viewTypeAnnotation (TypeAnnProvenance name) = Just name+viewTypeAnnotation :: AnnProvenancePs -> Maybe LRdrName+viewTypeAnnotation (TypeAnnProvenance name) = Just (reLoc name) viewTypeAnnotation _otherwise               = Nothing -pattern TypeAnnotation :: LRdrName -> AnnProvenance RdrName+pattern TypeAnnotation :: LRdrName -> AnnProvenancePs pattern TypeAnnotation name <- (viewTypeAnnotation -> Just name)   where     TypeAnnotation = typeAnnotation  -- | Equivalent of 'Language.Haskell.TH.Lib.pragAnnD'-pragAnnD :: AnnProvenance RdrName -> LHsExpr GhcPs -> AnnDecl GhcPs+pragAnnD :: AnnProvenancePs -> LHsExpr GhcPs -> AnnDecl GhcPs pragAnnD prov value =     HsAnnotation       defExt@@ -729,13 +803,13 @@       prov       value -viewPragAnnD :: AnnDecl GhcPs -> (AnnProvenance RdrName, LHsExpr GhcPs)+viewPragAnnD :: AnnDecl GhcPs -> (AnnProvenancePs, LHsExpr GhcPs) viewPragAnnD (HsAnnotation _ _ prov value) = (prov, value) #if __GLASGOW_HASKELL__ < 900 viewPragAnnD _ = panic "viewPragAnnD" #endif -pattern PragAnnD :: AnnProvenance RdrName -> LHsExpr GhcPs -> AnnDecl GhcPs+pattern PragAnnD :: AnnProvenancePs -> LHsExpr GhcPs -> AnnDecl GhcPs pattern PragAnnD prov value <- (viewPragAnnD -> (prov, value))   where     PragAnnD = pragAnnD@@ -744,6 +818,14 @@   Internal auxiliary -------------------------------------------------------------------------------} +#if __GLASGOW_HASKELL__ >= 902+implicitBndrs :: LHsType GhcPs -> LHsSigType GhcPs+implicitBndrs t = inheritLoc t (HsSig defExt (HsOuterImplicit defExt) t)++viewImplicitBndrs :: LHsSigType GhcPs -> LHsType GhcPs+viewImplicitBndrs (L _ (HsSig _ _ ty)) = ty++#else implicitBndrs :: a -> HsImplicitBndrs GhcPs a implicitBndrs a = HsIB defExt a @@ -752,6 +834,7 @@ #if __GLASGOW_HASKELL__ < 900 viewImplicitBndrs _ = panic "viewImplicitBndrs" #endif+#endif  -- | Simple binding (without patterns) simpleBinding :: LRdrName -> LHsExpr GhcPs -> LHsBind GhcPs@@ -764,7 +847,7 @@     match :: LMatch GhcPs (LHsExpr GhcPs)     match = inheritLoc fnName $         Match defExt-              (FunRhs fnName Prefix NoSrcStrict)+              (FunRhs (reLocA fnName) Prefix NoSrcStrict)               []               grhs @@ -773,6 +856,6 @@ simpleGHRSs body =     GRHSs defExt           [inheritLoc body $ GRHS defExt [] body]-          (inheritLoc body $ EmptyLocalBinds defExt)+          (inheritLoc' body $ EmptyLocalBinds defExt)
src/Data/Record/Internal/Plugin/CodeGen.hs view
@@ -8,12 +8,13 @@ import Data.List (nubBy) import Data.List.NonEmpty (NonEmpty(..)) +import Language.Haskell.TH (Extension(StrictData))+ import qualified Data.Generics as SYB  import Data.Record.Internal.GHC.Fresh import Data.Record.Internal.GHC.Shim hiding (mkTyVar) import Data.Record.Internal.GHC.TemplateHaskellStyle-import Data.Record.Internal.Plugin.Options import Data.Record.Internal.Plugin.Record  import qualified Data.Record.Internal.Plugin.Names.GhcGenerics as GHC@@ -24,8 +25,8 @@ -------------------------------------------------------------------------------}  -- | Generate all large-records definitions for a record.-genLargeRecord :: MonadFresh m => Record -> m [LHsDecl GhcPs]-genLargeRecord r@Record{..} = concatM [+genLargeRecord :: MonadFresh m => Record -> DynFlags -> m [LHsDecl GhcPs]+genLargeRecord r@Record{..} dynFlags = concatM [       (:[]) <$> genDatatype r     , genVectorConversions  r     , genIndexedAccessor    r@@ -35,7 +36,7 @@     , sequence [           genConstraintsClass    r         , genConstraintsInstance r-        , genGenericInstance     r+        , genGenericInstance     r dynFlags         , genGHCGeneric          r       ]     ]@@ -101,7 +102,7 @@           (zipWith fieldExistentialType vars recordFields)        ]-      [ DerivClause (Just (noLoc AnyclassStrategy)) (c :| [])+      [ DerivClause (Just (noLoc (withDefExt AnyclassStrategy))) (c :| [])       | DeriveAnyClass c <- recordDerivings       ]   where@@ -113,14 +114,14 @@         | (i, _) <- zip [1 :: Int ..] recordFields         ] -    optionalBang :: LHsType GhcPs -> LHsType GhcPs-    optionalBang = if allFieldsStrict recordOptions then bangType else id+    optionalBang :: HsSrcBang -> LHsType GhcPs -> LHsType GhcPs+    optionalBang bang = noLocA . HsBangTy defExt bang      fieldContext :: LRdrName -> Field -> LHsType GhcPs     fieldContext var fld = equalP (VarT var) (fieldType fld)      fieldExistentialType :: LRdrName -> Field -> (LRdrName, LHsType GhcPs)-    fieldExistentialType var fld = (fieldName fld, optionalBang $ VarT var)+    fieldExistentialType var fld = (fieldName fld, optionalBang (fieldStrictness fld) $ VarT var)  -- | Generate conversion to and from an array --@@ -467,8 +468,8 @@ -- >       , FieldMetadata (Proxy :: Proxy "tListB")) FieldLazy -- >       ] -- >   }-genMetadata :: MonadFresh m => Record -> m (LHsExpr GhcPs)-genMetadata r@Record{..} = do+genMetadata :: MonadFresh m => Record -> DynFlags -> m (LHsExpr GhcPs)+genMetadata r@Record{..} dynFlags = do     p <- freshName $ mkExpVar recordAnnLoc "p"     return $       lamE1 (varP p) $@@ -498,11 +499,26 @@         appsE           (ConE RT.con_FieldMetadata)           [ proxyE (stringT (nameBase fieldName))-          , ConE $ if allFieldsStrict recordOptions-                     then RT.con_FieldStrict-                     else RT.con_FieldLazy+          , ConE $ case decideStrictness dynFlags fieldStrictness of+              HsStrict                  -> RT.con_FieldStrict+              HsLazy                    -> RT.con_FieldLazy+              HsUnpack _                -> RT.con_FieldStrict           ] +-- | Implementation of https://hackage.haskell.org/package/base-4.16.1.0/docs/GHC-Generics.html#t:DecidedStrictness+decideStrictness :: DynFlags -> HsSrcBang -> HsImplBang+decideStrictness dynFlags (HsSrcBang _ unpackedness strictness) =+  case (unpackedness, srcToImpl strictness) of+    (SrcUnpack, HsStrict) | optimizations -> HsUnpack Nothing+    (_, strictness') -> strictness'+  where+    strictData = xopt StrictData dynFlags+    optimizations = optLevel dynFlags >= 1+    srcToImpl = \case+      SrcStrict -> HsStrict+      SrcLazy -> HsLazy+      NoSrcStrict -> if strictData then HsStrict else HsLazy+ -- | Generate definition for `from` in the `Generic` instance -- -- Generates something like@@ -545,9 +561,9 @@ -- >   to       = .. -- >   dict     = dictConstraints_T -- >   metadata = ..-genGenericInstance :: MonadFresh m => Record -> m (LHsDecl GhcPs)-genGenericInstance r@Record{..} = do-    metadata <- genMetadata r+genGenericInstance :: MonadFresh m => Record -> DynFlags -> m (LHsDecl GhcPs)+genGenericInstance r@Record{..} dynFlags  = do+    metadata <- genMetadata r dynFlags     from     <- genFrom     r     to       <- genTo       r     return $
src/Data/Record/Internal/Plugin/Exception.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE LambdaCase        #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns      #-}  -- | Exceptions that may be thrown by the large-records plugin. module Data.Record.Internal.Plugin.Exception (@@ -17,9 +18,9 @@  exceptionLoc :: Exception -> SrcSpan exceptionLoc = \case-    UnsupportedStockDeriving (L l _) -> l-    UnsupportedStrategy      (L l _) -> l-    InvalidDeclaration       (L l _) -> l+    UnsupportedStockDeriving (reLoc -> L l _) -> l+    UnsupportedStrategy      (id    -> L l _) -> l+    InvalidDeclaration       (reLoc -> L l _) -> l  exceptionToSDoc :: Exception -> SDoc exceptionToSDoc = hsep . \case
src/Data/Record/Internal/Plugin/Options.hs view
@@ -7,8 +7,7 @@ module Data.Record.Internal.Plugin.Options (     -- * Definition     LargeRecordOptions(..)-  , largeRecordStrict-  , largeRecordLazy+  , largeRecord     -- * Extract options from source module   , getLargeRecordOptions   ) where@@ -32,34 +31,21 @@ -- -- The default for Haskell code should probably be: ----- > {-# ANN type T largeRecordLazy #-}--- > data T = ..------ For records with strict fields, you can use:------ > {-# ANN type T largeRecordStrict #-}+-- > {-# ANN type T largeRecord #-} -- > data T = .. -- -- To see the definitions generated by @large-records@: ----- > {-# ANN type T largeRecordLazy {debugLargeRecords = True} #-}+-- > {-# ANN type T largeRecord {debugLargeRecords = True} #-} -- > data T = .. data LargeRecordOptions = LargeRecordOptions {-      allFieldsStrict   :: Bool-    , debugLargeRecords :: Bool+      debugLargeRecords :: Bool     }   deriving stock (Data) -largeRecordStrict :: LargeRecordOptions-largeRecordStrict = LargeRecordOptions {-      allFieldsStrict   = True-    , debugLargeRecords = False-    }--largeRecordLazy :: LargeRecordOptions-largeRecordLazy = LargeRecordOptions {-      allFieldsStrict   = False-    , debugLargeRecords = False+largeRecord :: LargeRecordOptions+largeRecord = LargeRecordOptions {+      debugLargeRecords = False     }  {-------------------------------------------------------------------------------@@ -94,10 +80,8 @@ -------------------------------------------------------------------------------}  intOptions :: LHsExpr GhcPs -> Maybe LargeRecordOptions-intOptions (VarE (nameBase -> "largeRecordStrict")) =-    Just largeRecordStrict-intOptions (VarE (nameBase -> "largeRecordLazy")) =-    Just largeRecordLazy+intOptions (VarE (nameBase -> "largeRecord")) =+    Just largeRecord intOptions (RecUpdE expr fields) = do     opts    <- intOptions expr     updates <- mapM intUpdate fields
src/Data/Record/Internal/Plugin/Record.hs view
@@ -43,9 +43,10 @@     }  data Field = Field {-      fieldName  :: LRdrName-    , fieldType  :: LHsType GhcPs-    , fieldIndex :: Int+      fieldName       :: LRdrName+    , fieldType       :: LHsType GhcPs+    , fieldStrictness :: HsSrcBang+    , fieldIndex      :: Int     }  -- | Derived classes that we can support.@@ -97,8 +98,9 @@  viewField ::      MonadError Exception m-  => (LRdrName, LHsType GhcPs) -> m (Int -> Field)-viewField (name, typ) = return $ Field name typ+  => (LRdrName, LHsType GhcPs) -> m (Int -> Field)  +viewField (name, typ) =+  return $ Field name (getBangType typ) (getBangStrictness typ)  viewRecordDerivings ::      MonadError Exception m@@ -111,9 +113,9 @@ viewRecordDeriving = \case     DerivClause Nothing tys ->       goStock tys-    DerivClause (Just (L _ StockStrategy)) tys ->+    DerivClause (Just (L _ StockStrategy {})) tys ->       goStock tys-    DerivClause (Just (L _ AnyclassStrategy)) tys ->+    DerivClause (Just (L _ AnyclassStrategy {})) tys ->       pure $ fmap DeriveAnyClass (NE.toList tys)     DerivClause (Just strategy) _ ->       throwError (UnsupportedStrategy strategy)
src/Data/Record/Plugin.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP            #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ViewPatterns   #-} @@ -7,7 +8,7 @@ -- -- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} -- >--- > {-# ANN type B LargeRecordStrict #-}+-- > {-# ANN type B largeRecord #-} -- > data B a = B {a :: a, b :: String} -- >   deriving stock (Show, Eq, Ord) --@@ -43,6 +44,12 @@ import Data.Record.Internal.Plugin.Options import Data.Record.Internal.Plugin.Record +#if __GLASGOW_HASKELL__ >= 902+import GHC.Driver.Errors+import GHC.Types.Error (mkWarnMsg, mkErr, mkDecorated)+import GHC.Utils.Logger (getLogger)+#endif+ {-------------------------------------------------------------------------------   Top-level: the plugin proper -------------------------------------------------------------------------------}@@ -103,7 +110,7 @@      Map String [(SrcSpan, LargeRecordOptions)]   -> LHsDecl GhcPs   -> WriterT (Set String) Hsc [LHsDecl GhcPs]-transformDecl largeRecords decl@(L l _) =+transformDecl largeRecords decl@(reLoc -> L l _) =     case decl of       DataD (nameBase -> name) _ _ _  ->         case Map.findWithDefault [] name largeRecords of@@ -121,7 +128,8 @@                 -- Return the declaration unchanged if we cannot parse it                 return [decl]               Right r -> do-                newDecls <- lift $ runFreshHsc $ genLargeRecord r+                dynFlags <- lift getDynFlags+                newDecls <- lift $ runFreshHsc $ genLargeRecord r dynFlags                 when (debugLargeRecords opts) $                   lift $ issueWarning l (debugMsg newDecls)                 pure newDecls@@ -185,12 +193,23 @@  issueError :: SrcSpan -> SDoc -> Hsc () issueError l errMsg = do+#if __GLASGOW_HASKELL__ >= 902+    throwOneError $+      mkErr l neverQualify (mkDecorated [errMsg])+#else     dynFlags <- getDynFlags     throwOneError $       mkErrMsg dynFlags l neverQualify errMsg+#endif  issueWarning :: SrcSpan -> SDoc -> Hsc () issueWarning l errMsg = do     dynFlags <- getDynFlags+#if __GLASGOW_HASKELL__ >= 902+    logger <- getLogger+    liftIO $ printOrThrowWarnings logger dynFlags . listToBag . (:[]) $+      mkWarnMsg l neverQualify errMsg+#else     liftIO $ printOrThrowWarnings dynFlags . listToBag . (:[]) $       mkWarnMsg dynFlags l neverQualify errMsg+#endif
src/Data/Record/Plugin/Options.hs view
@@ -3,8 +3,7 @@ -- This module is added as an export to user code by the plugin. module Data.Record.Plugin.Options (     LargeRecordOptions(..)-  , largeRecordStrict-  , largeRecordLazy+  , largeRecord   ) where  import Data.Record.Internal.Plugin.Options
test/Test/Record/Sanity/CodeGen.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds           #-} {-# LANGUAGE DataKinds                 #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE RecordWildCards           #-}@@ -24,7 +25,7 @@   This is the example record we use throughout the comments in TH codegen. -------------------------------------------------------------------------------} -{-# ANN type T largeRecordStrict #-}+{-# ANN type T largeRecord #-} data T a b = MkT {       tInt   :: Word     , tBool  :: Bool
test/Test/Record/Sanity/Derive.hs view
@@ -33,7 +33,7 @@  -- Type of kind @Type@ -{-# ANN type LA1 largeRecordStrict #-}+{-# ANN type LA1 largeRecord #-} data LA1 = MkLA1 { la1_f1 :: Int }   deriving anyclass C1 @@ -42,7 +42,7 @@ data RA2 a = MkRA1 { ra2_f1 :: a }   deriving anyclass C1 -{-# ANN type LA2 largeRecordStrict #-}+{-# ANN type LA2 largeRecord #-} data LA2 a = MkLA2 { la2_f1 :: a }   deriving anyclass C1 @@ -59,7 +59,7 @@   really is a newtype around a record). -------------------------------------------------------------------------------} -{-# ANN type LB largeRecordStrict #-}+{-# ANN type LB largeRecord #-} data LB = MkLB { lb1 :: Int, lb2 :: Int }     deriving anyclass (Newtype LB) @@ -80,7 +80,7 @@ data RC a = MkRC { rc1 :: a, rc2 :: Int }   deriving anyclass C3 -{-# ANN type LC largeRecordStrict #-}+{-# ANN type LC largeRecord #-} data LC (a :: Type) = MkLC { lc1 :: a, lc2 :: Int }   deriving anyclass C3 @@ -96,7 +96,7 @@ data RD f = MkRD { rd1 :: f Int, rd2 :: Int }   deriving anyclass C4 -{-# ANN type LD largeRecordStrict #-}+{-# ANN type LD largeRecord #-} data LD (f :: Type -> Type) = MkLD { ld1 :: f Int, ld2 :: Int }   deriving anyclass C4 @@ -113,7 +113,7 @@   deriving stock Show   deriving anyclass C5 -{-# ANN type LE largeRecordStrict #-}+{-# ANN type LE largeRecord #-} data LE = MkLE { le1 :: Int, le2 :: Bool }   deriving stock Show   deriving anyclass C5
test/Test/Record/Sanity/EqualFieldTypes.hs view
@@ -20,7 +20,7 @@ import Test.Tasty import Test.Tasty.HUnit -{-# ANN type R largeRecordStrict #-}+{-# ANN type R largeRecord #-} data R a = MkR {       field1 :: a     , field2 :: a
test/Test/Record/Sanity/GhcGenerics.hs view
@@ -21,7 +21,7 @@ import Test.Tasty import Test.Tasty.HUnit -{-# ANN type R largeRecordStrict #-}+{-# ANN type R largeRecord #-} data R = MkR { a :: Int }   deriving (Show)
test/Test/Record/Sanity/HKD.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds           #-} {-# LANGUAGE DataKinds                 #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE KindSignatures            #-} {-# LANGUAGE MultiParamTypeClasses     #-}@@ -29,7 +30,7 @@   HKD (Const b) a = b  -- | Test record with fields whose types are given by type families-{-# ANN type T largeRecordStrict #-}+{-# ANN type T largeRecord #-} data T (f :: Type -> Type) = MkT {       field1 :: HKD f Int     , field2 :: HKD f Bool
test/Test/Record/Sanity/HigherKinded.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE ConstraintKinds           #-} {-# LANGUAGE DataKinds                 #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE KindSignatures            #-} {-# LANGUAGE MultiParamTypeClasses     #-}@@ -35,7 +36,7 @@  -- We need an explicit kind annotation on @f@ for @large-records@ to generate -- correct code (either that, or use @PolyKinds@).-{-# ANN type MyRecord largeRecordStrict #-}+{-# ANN type MyRecord largeRecord #-} data MyRecord (f :: Type -> Type) = MyRecord {       field0 :: T 0 f     , field1 :: T 1 f
test/Test/Record/Sanity/OverloadingNoDRF.hs view
@@ -29,10 +29,10 @@   through DRF. --------------------------------------s-----------------------------------------} -{-# ANN type X largeRecordStrict #-}+{-# ANN type X largeRecord #-} data X = MkX { a :: Int } -{-# ANN type Y largeRecordStrict #-}+{-# ANN type Y largeRecord #-} data Y = MkY { a :: String }  testOverloading :: Assertion
test/Test/Record/Sanity/PatternMatch.hs view
@@ -28,10 +28,10 @@   Basic pattern matching tests -------------------------------------------------------------------------------} -{-# ANN type T largeRecordStrict #-}+{-# ANN type T largeRecord #-} data T a = MkT { x :: Int,  y :: [a], z :: Double } -{-# ANN type S largeRecordStrict #-}+{-# ANN type S largeRecord #-} data S a = MkS { x :: Char, y :: T a }  projectOne :: T Bool -> Int@@ -75,7 +75,7 @@   type errors iff 'noSigEmpty' and 'noSigNonEmpty' are suffciently monomorphic. -------------------------------------------------------------------------------} -{-# ANN type T2 largeRecordStrict #-}+{-# ANN type T2 largeRecord #-} data T2 = MkT2 { x :: Int }  noSigEmpty MkT {} = ()
test/Test/Record/Sanity/QualifiedImports/A.hs view
@@ -11,5 +11,5 @@  module Test.Record.Sanity.QualifiedImports.A (T(..)) where -{-# ANN type T largeRecordStrict #-}+{-# ANN type T largeRecord #-} data T a = MkT { x :: Int, y :: [a] }
test/Test/Record/Sanity/QualifiedImports/B.hs view
@@ -14,5 +14,5 @@  import qualified Test.Record.Sanity.QualifiedImports.A as A -{-# ANN type T largeRecordStrict #-}+{-# ANN type T largeRecord #-} data T a = MkT { x :: Char, y :: A.T a }
test/Test/Record/Sanity/RDP/SingleModule.hs view
@@ -22,7 +22,7 @@   Simple field selection and override -------------------------------------------------------------------------------} -{-# ANN type R1 largeRecordStrict #-}+{-# ANN type R1 largeRecord #-} data R1 = MkR1 { r1_x :: Int, r1_y :: Bool }   deriving (Show, Eq) @@ -44,11 +44,11 @@   Field selection and override when there are overloaded fields -------------------------------------------------------------------------------} -{-# ANN type R2 largeRecordStrict #-}+{-# ANN type R2 largeRecord #-} data R2 = MkR2 { a :: Int, b :: Bool }   deriving (Show, Eq) -{-# ANN type R3 largeRecordStrict #-}+{-# ANN type R3 largeRecord #-} data R3 = MkR3 { a :: Int, b :: Char }   deriving (Show, Eq) @@ -81,11 +81,11 @@ data R5_WOutLR = MkR5_WOutLR { r5_woutLR_x :: Char, r5_woutLR_y :: Double }   deriving (Show, Eq) -{-# ANN type R4_WithLR largeRecordStrict #-}+{-# ANN type R4_WithLR largeRecord #-} data R4_WithLR = MkR4_WithLR { r4_withLR_x :: Int, r4_withLR_y :: R5_WithLR }   deriving (Show, Eq) -{-# ANN type R5_WithLR largeRecordStrict #-}+{-# ANN type R5_WithLR largeRecord #-} data R5_WithLR = MkR5_WithLR { r5_withLR_x :: Char, r5_withLR_y :: Double }   deriving (Show, Eq)
test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs view
@@ -22,23 +22,23 @@   , R5_WithLR(..)   ) where -{-# ANN type R1 largeRecordStrict #-}+{-# ANN type R1 largeRecord #-} data R1 = MkR1 { r1_x :: Int, r1_y :: Bool }   deriving (Show, Eq) -{-# ANN type R2 largeRecordStrict #-}+{-# ANN type R2 largeRecord #-} data R2 = MkR2 { a :: Int, b :: Bool }   deriving (Show, Eq) -{-# ANN type R3 largeRecordStrict #-}+{-# ANN type R3 largeRecord #-} data R3 = MkR3 { a :: Int, b :: Char }   deriving (Show, Eq) -{-# ANN type R4_WithLR largeRecordStrict #-}+{-# ANN type R4_WithLR largeRecord #-} data R4_WithLR = MkR4_WithLR { r4_withLR_x :: Int, r4_withLR_y :: R5_WithLR }   deriving (Show, Eq) -{-# ANN type R5_WithLR largeRecordStrict #-}+{-# ANN type R5_WithLR largeRecord #-} data R5_WithLR = MkR5_WithLR { r5_withLR_x :: Char, r5_withLR_y :: Double }   deriving (Show, Eq)
test/Test/Record/Sanity/RecordConstruction.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE DataKinds                 #-} {-# LANGUAGE DuplicateRecordFields     #-} {-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-} {-# LANGUAGE FlexibleInstances         #-} {-# LANGUAGE KindSignatures            #-} {-# LANGUAGE MultiParamTypeClasses     #-}@@ -27,10 +28,10 @@ -- Test both the case where the name of the type and the name of the constructor -- are the same and where they are different. -{-# ANN type R largeRecordLazy #-}+{-# ANN type R largeRecord #-} data R a = MkR { x :: Int, y :: [a] } deriving (Eq, Show) -{-# ANN type S largeRecordLazy #-}+{-# ANN type S largeRecord #-} data S a = S { x :: Int, y :: [a] } deriving (Eq, Show)  inOrder :: R Bool@@ -56,7 +57,7 @@ data RegularRecord = RR { a :: Int }   deriving (Show, Eq) -{-# ANN type T largeRecordStrict #-}+{-# ANN type T largeRecord #-} data T = T { x :: Int, y :: S Bool, z :: RegularRecord }  valueOfT :: T
test/Test/Record/Sanity/Strictness.hs view
@@ -27,11 +27,11 @@ import Test.Tasty import Test.Tasty.HUnit -{-# ANN type Lazy largeRecordLazy #-}+{-# ANN type Lazy largeRecord #-} data Lazy = MkLazy { lazyField :: Word } -{-# ANN type Strict largeRecordStrict #-}-data Strict = MkStrict { strictField :: Word }+{-# ANN type Strict largeRecord #-}+data Strict = MkStrict { strictField :: !Word }  _silenceWarnings :: Lazy -> Strict -> () _silenceWarnings MkLazy{..} MkStrict{..} = const () $ (
+ test/Test/Record/Sanity/StrictnessStrictData.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE ConstraintKinds           #-}+{-# LANGUAGE DataKinds                 #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE FlexibleInstances         #-}+{-# LANGUAGE MultiParamTypeClasses     #-}+{-# LANGUAGE RecordWildCards           #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE TemplateHaskell           #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE UndecidableInstances      #-}+{-# LANGUAGE StrictData                #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}++module Test.Record.Sanity.StrictnessStrictData (tests) where++import Control.Exception+import GHC.Records.Compat++import Data.Record.Generic+import Data.Record.Generic.LowerBound++import qualified Data.Record.Generic.Rep as Rep++import Test.Tasty+import Test.Tasty.HUnit++{-# ANN type Lazy largeRecord #-}+data Lazy = MkLazy { lazyField :: ~Word }++{-# ANN type Strict largeRecord #-}+data Strict = MkStrict { strictField :: Word }++_silenceWarnings :: Lazy -> Strict -> ()+_silenceWarnings MkLazy{..} MkStrict{..} = const () $ (+      lazyField+    , strictField+    )++tests :: TestTree+tests = testGroup "Test.Record.Sanity.Strictness" [+      testCase "initValueLazy"   test_initValueLazy+    , testCase "initValueStrict" test_initValueStrict+    , testCase "setValueLazy"    test_setValueLazy+    , testCase "setValueStrict"  test_setValueStrict+    ]++test_initValueLazy :: Assertion+test_initValueLazy =+    initValue `seq` return ()+  where+    initValue :: Lazy+    initValue = to $ Rep.pure undefined++test_initValueStrict :: Assertion+test_initValueStrict =+    expectBoom (initValue `seq` return ())+  where+    initValue :: Strict+    initValue = to $ Rep.pure boom++test_setValueLazy :: Assertion+test_setValueLazy =+    setField @"lazyField" initValue boom `seq` return ()+  where+    initValue :: Lazy+    initValue = glowerBound++test_setValueStrict :: Assertion+test_setValueStrict =+    expectBoom (setField @"strictField" initValue boom `seq` return ())+  where+    initValue :: Strict+    initValue = glowerBound++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++data Boom = Boom+  deriving (Show)++boom :: a+boom = throw Boom++instance Exception Boom++expectBoom :: IO () -> Assertion+expectBoom act = do+    mErr <- try act+    case mErr of+      Left Boom -> return ()+      Right ()  -> assertFailure "Expected boom"
test/TestLargeRecords.hs view
@@ -14,6 +14,7 @@ import qualified Test.Record.Sanity.RDP.SingleModule import qualified Test.Record.Sanity.RecordConstruction import qualified Test.Record.Sanity.Strictness+import qualified Test.Record.Sanity.StrictnessStrictData import qualified Test.Record.Sanity.GhcGenerics  main :: IO ()@@ -34,6 +35,7 @@         , Test.Record.Sanity.RDP.SingleModule.tests         , Test.Record.Sanity.RecordConstruction.tests         , Test.Record.Sanity.Strictness.tests+        , Test.Record.Sanity.StrictnessStrictData.tests         , Test.Record.Sanity.GhcGenerics.tests         ]     ]