large-records 0.3 → 0.4

raw patch · 37 files changed

+1329/−653 lines, 37 filesdep ~basedep ~primitivedep ~record-dot-preprocessorPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, primitive, record-dot-preprocessor

API changes (from Hackage documentation)

Files

• CHANGELOG.md +17/−3
• large-records.cabal +23/−25
• src/Data/Record/Internal/GHC/Fresh.hs +19/−19
• src/Data/Record/Internal/GHC/Shim.hs +253/−51
• src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs +59/−35
• src/Data/Record/Internal/Plugin/CodeGen.hs +157/−139
• src/Data/Record/Internal/Plugin/Exception.hs +3/−3
• src/Data/Record/Internal/Plugin/Names.hs +211/−0
• src/Data/Record/Internal/Plugin/Names/GhcGenerics.hs +0/−42
• src/Data/Record/Internal/Plugin/Names/Runtime.hs +0/−223
• src/Data/Record/Internal/Plugin/Options.hs +17/−5
• src/Data/Record/Internal/Plugin/Record.hs +1/−1
• src/Data/Record/Overloading.hs +83/−0
• src/Data/Record/Plugin.hs +71/−37
• src/Data/Record/Plugin/Runtime.hs +128/−51
• src/Data/Record/Plugin/WithRDP.hs +33/−0
• test/Test/Record/Sanity/CodeGen.hs +2/−0
• test/Test/Record/Sanity/Derive.hs +3/−0
• test/Test/Record/Sanity/EqualFieldTypes.hs +3/−0
• test/Test/Record/Sanity/GhcGenerics.hs +4/−2
• test/Test/Record/Sanity/HKD.hs +3/−1
• test/Test/Record/Sanity/HigherKinded.hs +4/−3
• test/Test/Record/Sanity/NamedWildCards.hs +31/−0
• test/Test/Record/Sanity/Operators.hs +28/−0
• test/Test/Record/Sanity/OverloadedRecordUpdate.hs +135/−0
• test/Test/Record/Sanity/OverloadingNoDRF.hs +3/−1
• test/Test/Record/Sanity/PatternMatch.hs +3/−0
• test/Test/Record/Sanity/QualifiedImports/A.hs +3/−0
• test/Test/Record/Sanity/QualifiedImports/B.hs +3/−0
• test/Test/Record/Sanity/RDP/SingleModule.hs +5/−1
• test/Test/Record/Sanity/RDP/SplitModule.hs +1/−0
• test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs +3/−0
• test/Test/Record/Sanity/RecordConstruction.hs +3/−1
• test/Test/Record/Sanity/Strictness.hs +5/−4
• test/Test/Record/Sanity/StrictnessStrictData.hs +5/−4
• test/Test/Record/Util.hs +3/−0
• test/TestLargeRecords.hs +4/−2

@@ -1,15 +1,29 @@ # Revision history for large-records +## 0.4 -- 2023-03-06++* Fix issue with operator type families used in fields (#120).+* Fix issue with `NamedWildCards` (#121, #124, #125).+* Do not generate imports in the plugin (#129).+  NOTE: This means that use code must now import `Data.Record.Plugin` to bring+  `largeRecord` into scope (necessary for `ANN` annotations).+* Support ghc 9.4 (#131).+  An annoying quirk of ghc 9.4 is that the order of plugins is reversed; this+  matters when using `large-records` and `record-dot-preprocessor` together.+  To avoid CPP, you can now use `Data.Record.Plugin.WithRDP`, which combines+  both plugins.+* Support `OverloadedRecordDot` and `OverloadedRecordUpdate` (#135).+ ## 0.3 -- 2022-07-22 -* Support ghc 9.2 (#117)-* Support for field strictness annotations (#107)+* Support ghc 9.2 (#113 / #117).+* Support for field strictness annotations (#106 / #107).  ## 0.2.1.0 -- 2022-04-06  * Update for `large-generics` 0.2 -## 0.2.0.0 -- 2022-03-23 +## 0.2.0.0 -- 2022-03-23  * Avoid all quotes: no more Template Haskell (#63) or quasi-quotes (#43).   TH replaced by a source-plugin; quasi-quotes avoided by using a different

@@ -1,6 +1,6 @@ cabal-version:      2.4 name:               large-records-version:            0.3+version:            0.4 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 || ==9.2.2+tested-with:        GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4  source-repository head   type:     git@@ -26,8 +26,10 @@   exposed-modules:        Data.Record.Plugin-      Data.Record.Plugin.Runtime       Data.Record.Plugin.Options+      Data.Record.Plugin.Runtime+      Data.Record.Plugin.WithRDP+      Data.Record.Overloading    other-modules: @@ -37,26 +39,28 @@        Data.Record.Internal.Plugin.CodeGen       Data.Record.Internal.Plugin.Exception-      Data.Record.Internal.Plugin.Names.GhcGenerics-      Data.Record.Internal.Plugin.Names.Runtime+      Data.Record.Internal.Plugin.Names       Data.Record.Internal.Plugin.Options       Data.Record.Internal.Plugin.Record    build-depends:-      base             >= 4.13   && < 4.17-    , containers       >= 0.6.2  && < 0.7-    , mtl              >= 2.2.1  && < 2.3-    , primitive        >= 0.7    && < 0.8-    , record-hasfield  >= 1.0    && < 1.1-    , syb              >= 0.7    && < 0.8+      base            >= 4.13   && < 4.18+    , containers      >= 0.6.2  && < 0.7+    , mtl             >= 2.2.1  && < 2.3+    , primitive       >= 0.7    && < 0.8+    , syb             >= 0.7    && < 0.8+    , record-hasfield >= 1.0    && < 1.1        -- large-generics 0.2 starts using 'SmallArray' instead of 'Vector'-    , large-generics   >= 0.2    && < 0.3+    , large-generics >= 0.2 && < 0.3        -- transformers 0.5.6 introduces Writer.CPS-    , transformers     >= 0.5.6  && < 0.7+    , transformers >= 0.5.6 && < 0.7 -      -- whatever version is bundled with ghc+      -- 0.2.16 introduces support for ghc 9.4+    , record-dot-preprocessor >= 0.2.16 && < 0.3++      -- whatever versions are bundled with ghc     , ghc     , template-haskell   hs-source-dirs:@@ -87,8 +91,12 @@       Test.Record.Sanity.CodeGen       Test.Record.Sanity.Derive       Test.Record.Sanity.EqualFieldTypes+      Test.Record.Sanity.GhcGenerics       Test.Record.Sanity.HigherKinded       Test.Record.Sanity.HKD+      Test.Record.Sanity.NamedWildCards+      Test.Record.Sanity.Operators+      Test.Record.Sanity.OverloadedRecordUpdate       Test.Record.Sanity.OverloadingNoDRF       Test.Record.Sanity.PatternMatch       Test.Record.Sanity.QualifiedImports@@ -100,7 +108,6 @@       Test.Record.Sanity.RecordConstruction       Test.Record.Sanity.Strictness       Test.Record.Sanity.StrictnessStrictData-      Test.Record.Sanity.GhcGenerics       Test.Record.Util    build-depends:@@ -111,14 +118,12 @@     , large-generics     , mtl     , newtype+    , record-dot-preprocessor     , record-hasfield     , tasty     , tasty-hunit     , template-haskell     , transformers--      -- <https://github.com/ndmitchell/record-dot-preprocessor/pull/48>-    , record-dot-preprocessor >= 0.2.14   hs-source-dirs:       test   default-language:@@ -130,10 +135,3 @@       -Wincomplete-record-updates       -Wpartial-fields       -Widentities--  if impl(ghc >= 9.0.1)-    -- ghc 9 provides warnings about unused imports for the imports added by-    -- the plugin. I'm not yet sure how to deal with this properly. The imports-    -- are necessary (I think...?), both for the generated code and to typecheck-    -- the user's own ANN pragma. For now we just disable the warning.-    ghc-options: -Wno-unused-imports

@@ -6,7 +6,6 @@   , runFreshHsc   ) where -import Data.IORef import Control.Monad.Reader  import Data.Record.Internal.GHC.Shim@@ -16,40 +15,41 @@   --   -- NOTES:   ---  -- o These names should be used for module exports.-  -- o These names should be used for exactly /one/ binder.-  -- o The resulting name has the same 'NameSpace' as the argument.+  -- * These names should be used for module exports.+  -- * These names should be used for exactly /one/ binder.+  -- * The resulting name has the same 'NameSpace' as the argument.   freshName :: LRdrName -> m LRdrName+  freshName = freshName' True -newtype Fresh a = WrapFresh { unwrapFresh :: ReaderT (IORef NameCache) IO a }+  -- variant which doesn't rename the variable.+  -- The 'False' variant can be used in types.+  freshName' :: Bool -> LRdrName -> m LRdrName++newtype Fresh a = WrapFresh { unwrapFresh :: ReaderT NameCacheIO IO a }   deriving newtype (Functor, Applicative, Monad)  instance MonadFresh Fresh where-  freshName (L l name) = WrapFresh $ ReaderT $ \nc_var ->-      atomicModifyIORef nc_var aux+  freshName' pfx (L l name) = WrapFresh $ ReaderT $ \nc -> do+      newUniq <- takeUniqFromNameCacheIO nc+      return $ L l $ Exact $+        mkInternalName newUniq (newOccName (rdrNameOcc name)) l     where-      aux :: NameCache -> (NameCache, LRdrName)-      aux nc = (-            nc { nsUniqs = us }-          , L l $ Exact $-              mkInternalName newUniq (newOccName (rdrNameOcc name)) l-          )-        where-          (newUniq, us) = takeUniqFromSupply (nsUniqs nc)-       -- Even when we generate fresh names, ghc can still complain about name       -- shadowing, because this check only considers the 'OccName', not the       -- unique. We therefore prefix the name with an underscore to avoid the       -- warning.       newOccName :: OccName -> OccName-      newOccName n = mkOccName (occNameSpace n) . ("_" ++) $ occNameString n+      newOccName n = mkOccName (occNameSpace n) $ addPrefix $ occNameString n -runFresh :: Fresh a -> IORef NameCache -> IO a+      addPrefix :: String -> String+      addPrefix = if pfx then ("_" ++) else id++runFresh :: Fresh a -> NameCacheIO -> IO a runFresh = runReaderT . unwrapFresh  runFreshHsc :: Fresh a -> Hsc a runFreshHsc fa = do     env <- getHscEnv-    liftIO $ runFresh fa (hsc_NC env)+    liftIO $ runFresh fa (hscNameCacheIO env)  

@@ -2,9 +2,11 @@ {-# LANGUAGE FlexibleContexts       #-} {-# LANGUAGE FlexibleInstances      #-} {-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE LambdaCase             #-} {-# LANGUAGE MultiParamTypeClasses  #-} {-# LANGUAGE PatternSynonyms        #-} {-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE TupleSections          #-} {-# LANGUAGE TypeApplications       #-} {-# LANGUAGE UndecidableInstances   #-} {-# LANGUAGE ViewPatterns           #-}@@ -14,8 +16,12 @@ -- This should be the only module with GHC-specific CPP directives, and the -- rest of the plugin should not import from any GHC modules directly. module Data.Record.Internal.GHC.Shim (+    -- * Names+    lookupVarName+  , lookupTcName+     -- * Miscellaneous-    importDecl+  , importDecl   , conPat   , mkFunBind   , HsModule@@ -45,12 +51,22 @@   , hsTyVarLName   , setDefaultSpecificity +    -- * Locations+  , ToSrcSpan(..)+  , InheritLoc(..)+  , withoutLoc+     -- * New functionality   , compareHs-  , inheritLoc-  , inheritLoc'-  , inheritLocPat +    -- * NameCache+  , NameCacheIO+  , hscNameCacheIO+  , takeUniqFromNameCacheIO++    -- * Records+  , simpleRecordUpdates+     -- * Re-exports      -- The whole-sale module exports are not ideal for preserving compatibility@@ -70,7 +86,6 @@   , module GHC.Hs   , module GHC.Plugins   , module GHC.Tc.Types.Evidence-  , module GHC.Types.Name.Cache   , module GHC.Utils.Error #if __GLASGOW_HASKELL__ >= 902   , module GHC.Types.SourceText@@ -79,6 +94,7 @@ #endif   ) where +import Control.Monad import Data.List.NonEmpty (NonEmpty(..)) import Data.Generics (Data, GenericQ, cast, toConstr, gzipWithQ) @@ -86,13 +102,17 @@  #if __GLASGOW_HASKELL__ < 900 +import Data.IORef++import Bag (Bag, listToBag, emptyBag) import BasicTypes (SourceText (NoSourceText))-import Bag (listToBag, emptyBag) import ConLike (ConLike) import ErrUtils (mkErrMsg, mkWarnMsg)+import Finder (findImportedModule) import GHC hiding (AnnKeywordId(..), HsModule, exprType, typeKind, mkFunBind) import GhcPlugins hiding ((<>), getHscEnv,) import HscMain (getHscEnv)+import IfaceEnv (lookupOrigIO) import NameCache (NameCache(nsUniqs)) import PatSyn (PatSyn) import TcEvidence (HsWrapper(WpHole))@@ -103,36 +123,103 @@ #else  import GHC.Hs hiding (LHsTyVarBndr, HsTyVarBndr, HsModule, mkFunBind)+import qualified GHC.Hs as GHC  import GHC.Core.Class (Class) import GHC.Core.ConLike (ConLike) import GHC.Core.PatSyn (PatSyn)-import GHC.Data.Bag (listToBag, emptyBag)+import GHC.Data.Bag (Bag, listToBag, emptyBag) import GHC.Driver.Main (getHscEnv) import GHC.Tc.Types.Evidence (HsWrapper(WpHole))-import GHC.Types.Name.Cache (NameCache(nsUniqs)) import GHC.Utils.Error (Severity(SevError, SevWarning))  import GHC.Plugins hiding ((<>), getHscEnv-#if __GLASGOW_HASKELL__ >=902+#if __GLASGOW_HASKELL__ >= 902     , AnnType, AnnLet, AnnRec, AnnLam, AnnCase     , Exception #endif+#if __GLASGOW_HASKELL__ < 904+    , trace+#endif     )  #if __GLASGOW_HASKELL__ < 902-import GHC.Utils.Error (mkErrMsg, mkWarnMsg)+import GHC.Driver.Finder (findImportedModule) import GHC.Parser.Annotation (IsUnicodeSyntax(NormalSyntax))+import GHC.Utils.Error (mkErrMsg, mkWarnMsg) #else-import GHC.Types.SourceText (SourceText(NoSourceText), mkIntegralLit) import GHC.Types.Fixity+import GHC.Types.SourceText (SourceText(NoSourceText), mkIntegralLit)+import GHC.Unit.Finder (findImportedModule, FindResult(Found)) #endif -import qualified GHC.Hs      as GHC+#if __GLASGOW_HASKELL__ < 904+import Data.IORef+import GHC.Iface.Env (lookupOrigIO)+import GHC.Types.Name.Cache (NameCache(nsUniqs))+#else+import GHC.Iface.Env (lookupNameCache)+import GHC.Rename.Names (renamePkgQual)+import GHC.Types.Name.Cache (NameCache, takeUniqFromNameCache)+#endif  #endif  {-------------------------------------------------------------------------------+  Name resolution+-------------------------------------------------------------------------------}++lookupVarName ::+     HasCallStack+  => ModuleName+  -> Maybe FastString -- ^ Optional package name+  -> String -> Hsc Name+lookupVarName modl pkg = lookupOccName modl pkg . mkVarOcc++lookupTcName ::+     HasCallStack+  => ModuleName+  -> Maybe FastString -- ^ Optional package name+  -> String -> Hsc Name+lookupTcName modl pkg = lookupOccName modl pkg . mkTcOcc++lookupOccName ::+     HasCallStack+  => ModuleName+  -> Maybe FastString -- ^ Optional package name+  -> OccName -> Hsc Name+lookupOccName modlName mPkgName name = do+    env <- getHscEnv++#if __GLASGOW_HASKELL__ >= 904+    let pkgq :: PkgQual+        pkgq = renamePkgQual (hsc_unit_env env) modlName mPkgName+#else+    let pkgq :: Maybe FastString+        pkgq = mPkgName+#endif++    mModl <- liftIO $ findImportedModule env modlName pkgq+    case mModl of+      Found _ modl -> liftIO $ lookupOrigIO env modl name+      _otherwise   -> error $ concat [+          "lookupName: could not find "+        , occNameString name+        , " in module "+        , moduleNameString modlName+        , ". This might be due to an undeclared package dependency"+        , case mPkgName of+            Nothing  -> ""+            Just pkg -> " on " ++ unpackFS pkg+        , "."+        ]++#if __GLASGOW_HASKELL__ >= 904+lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name+lookupOrigIO env modl occ = lookupNameCache (hsc_NC env) modl occ+#endif++{-------------------------------------------------------------------------------   Miscellaneous -------------------------------------------------------------------------------} @@ -142,7 +229,11 @@       ideclExt       = defExt     , ideclSourceSrc = NoSourceText     , ideclName      = noLocA name+#if __GLASGOW_HASKELL__ >= 904+    , ideclPkgQual   = NoRawPkgQual+#else     , ideclPkgQual   = Nothing+#endif     , ideclSafe      = False     , ideclImplicit  = False     , ideclAs        = Nothing@@ -183,6 +274,29 @@ type LRdrName  = Located RdrName  {-------------------------------------------------------------------------------+  NameCache+-------------------------------------------------------------------------------}++#if __GLASGOW_HASKELL__ < 904+type NameCacheIO = IORef NameCache++takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique+takeUniqFromNameCacheIO = flip atomicModifyIORef aux+  where+    aux :: NameCache -> (NameCache, Unique)+    aux nc = let (newUniq, us) = takeUniqFromSupply (nsUniqs nc)+             in (nc { nsUniqs = us }, newUniq)+#else+type NameCacheIO = NameCache++takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique+takeUniqFromNameCacheIO = takeUniqFromNameCache+#endif++hscNameCacheIO :: HscEnv -> NameCacheIO+hscNameCacheIO = hsc_NC++{-------------------------------------------------------------------------------   Exact-print annotations -------------------------------------------------------------------------------} @@ -242,7 +356,7 @@ -- In GHC-9.2 some things have extension fields. #if __GLASGOW_HASKELL__ >= 902 withDefExt :: HasDefaultExt a => (a -> b) -> b-withDefExt f = f defExt +withDefExt f = f defExt #else withDefExt :: a -> a withDefExt a = a@@ -257,11 +371,13 @@ type LHsTyVarBndr pass = GHC.LHsTyVarBndr () pass #endif -hsFunTy :: XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass+hsFunTy :: XFunTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs #if __GLASGOW_HASKELL__ < 900 hsFunTy = HsFunTy-#else+#elif __GLASGOW_HASKELL__ < 904 hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow NormalSyntax)+#else+hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow (L NoTokenLoc HsNormalTok)) #endif  userTyVar ::@@ -359,57 +475,143 @@   Working with locations -------------------------------------------------------------------------------} -class FromSrcSpan l where-  fromSrcSpan :: SrcSpan -> l+class ToSrcSpan a where+  toSrcSpan :: a -> SrcSpan -instance FromSrcSpan SrcSpan where-  fromSrcSpan = id+instance ToSrcSpan SrcSpan where+  toSrcSpan = id  #if __GLASGOW_HASKELL__ >= 902-instance HasDefaultExt ann => FromSrcSpan (SrcSpanAnn' ann) where-  fromSrcSpan = SrcSpanAnn defExt+instance ToSrcSpan (SrcSpanAnn' a) where+  toSrcSpan = locA #endif -class InheritLoc a where-  inheritLoc :: FromSrcSpan l => a -> b -> GenLocated l b+instance ToSrcSpan l => ToSrcSpan (GenLocated l a) where+  toSrcSpan (L l _) = toSrcSpan l +instance ToSrcSpan a => ToSrcSpan (NonEmpty a) where+  toSrcSpan = toSrcSpan . NE.head++-- | 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 ToSrcSpan a => ToSrcSpan [a] where+   toSrcSpan (a:_) = toSrcSpan a+   toSrcSpan []    = noSrcSpan++class InheritLoc x a b | b -> a where+  inheritLoc :: x -> a -> b++instance ToSrcSpan x => InheritLoc x a (GenLocated SrcSpan a) where+  inheritLoc = L . toSrcSpan+ #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+instance ToSrcSpan x => InheritLoc x a (GenLocated (SrcAnn ann) a) where+  inheritLoc = L . SrcSpanAnn defExt . toSrcSpan #endif -instance InheritLoc a => InheritLoc (NonEmpty a) where-  inheritLoc = inheritLoc . NE.head+instance InheritLoc x [a]                  [a]                  where inheritLoc _ = id+instance InheritLoc x Bool                 Bool                 where inheritLoc _ = id+instance InheritLoc x (HsTupArg p)         (HsTupArg p)         where inheritLoc _ = id+instance InheritLoc x (Pat p    )          (Pat p)              where inheritLoc _ = id+instance InheritLoc x (HsLocalBindsLR p q) (HsLocalBindsLR p q) where inheritLoc _ = id -instance InheritLoc l => InheritLoc (GenLocated l a) where-  inheritLoc (L l _) = inheritLoc l+withoutLoc :: InheritLoc SrcSpan a b => a -> b+withoutLoc = inheritLoc noSrcSpan -instance InheritLoc SrcSpan where-  inheritLoc l x = L (fromSrcSpan l) x+{-------------------------------------------------------------------------------+  Records+-------------------------------------------------------------------------------}  #if __GLASGOW_HASKELL__ >= 902-instance InheritLoc (SrcSpanAnn' ann) where-  inheritLoc (SrcSpanAnn _ l) = inheritLoc l+type RupdFlds = Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]+#else+type RupdFlds = [LHsRecUpdField GhcPs] #endif ------ -- | 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+-- | Pattern match against the @rupd_flds@ of @RecordUpd@+simpleRecordUpdates :: RupdFlds -> Maybe [(LRdrName, LHsExpr GhcPs)] -#if __GLASGOW_HASKELL__ < 810-inheritLocPat :: a -> Pat p -> LPat p-inheritLocPat _ = id -- In 8.8, 'LPat' is a synonym for 'Pat'+#if __GLASGOW_HASKELL__ >= 904++simpleRecordUpdates =+    \case+      Left  flds -> mapM (aux (isUnambigous  . unLoc)) flds+      Right flds -> mapM (aux (isSingleLabel . unLoc)) flds+  where+    aux :: forall lhs rhs.+         (lhs -> Maybe LRdrName)+      -> LHsFieldBind GhcPs lhs rhs+      -> Maybe (LRdrName, rhs)+    aux f (L _ (HsFieldBind { hfbLHS = lbl+                            , hfbRHS = val+                            , hfbPun = pun+                            })) = do+        guard $ not pun+        (, val) <$> f lbl++    isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName+    isUnambigous (Unambiguous _ name) = Just $ reLoc name+    isUnambigous _                    = Nothing++    isSingleLabel :: FieldLabelStrings GhcPs -> Maybe LRdrName+    isSingleLabel (FieldLabelStrings labels) =+        case labels of+          [L _ (DotFieldOcc _ (L l label))] ->+            Just $ reLoc $ L l (Unqual $ mkVarOccFS label)+          _otherwise ->+            Nothing++#elif __GLASGOW_HASKELL__ == 902++simpleRecordUpdates =+    \case+      Left  flds -> mapM (aux isUnambigous)  flds+      Right flds -> mapM (aux isSingleLabel) flds+  where+    aux :: forall lhs rhs.+         (lhs -> Maybe LRdrName)+      -> LHsRecField' GhcPs lhs rhs+      -> Maybe (LRdrName, rhs)+    aux f (L _ (HsRecField { hsRecFieldLbl = L _ lbl+                           , hsRecFieldArg = val+                           , hsRecPun      = pun+                           })) = do+        guard $ not pun+        (, val) <$> f lbl++    isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName+    isUnambigous (Unambiguous _ name) = Just $ reLoc name+    isUnambigous _                    = Nothing++    isSingleLabel :: FieldLabelStrings GhcPs -> Maybe LRdrName+    isSingleLabel (FieldLabelStrings labels) =+        case labels of+          [L _ (HsFieldLabel _ (L l label))] ->+            Just $ L l (Unqual $ mkVarOccFS label)+          _otherwise ->+            Nothing+ #else-inheritLocPat :: InheritLoc a => a -> Pat (GhcPass p) -> LPat (GhcPass p)-inheritLocPat = inheritLoc++simpleRecordUpdates =+     mapM (aux isUnambigous)+  where+    aux :: forall lhs rhs.+         (lhs -> Maybe LRdrName)+      -> LHsRecField' lhs rhs+      -> Maybe (LRdrName, rhs)+    aux f (L _ (HsRecField { hsRecFieldLbl = L _ lbl+                           , hsRecFieldArg = val+                           , hsRecPun      = pun+                           })) = do+        guard $ not pun+        (, val) <$> f lbl++    isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName+    isUnambigous (Unambiguous _ name) = Just $ reLoc name+    isUnambigous _                    = Nothing+ #endif

@@ -33,11 +33,13 @@   , lamE1   , caseE   , appsE+  , appTypeE   , tupE   , sigE     -- ** Without direct equivalent   , intE     -- * Types+  , parensT   , litT   , pattern VarT   , pattern ConT@@ -184,7 +186,7 @@  -- | Inverse to 'varE' viewVarE :: LHsExpr GhcPs -> Maybe LRdrName-viewVarE (reLoc -> L _ (HsVar _ (reLoc -> name))) | isTermVar name = Just name+viewVarE (L _ (HsVar _ (reLoc -> name))) | isTermVar name = Just name viewVarE _ = Nothing  pattern VarE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs@@ -200,7 +202,7 @@  -- | Inverse to 'conE' viewConE :: LHsExpr GhcPs -> Maybe LRdrName-viewConE (reLoc -> L _ (HsVar _ (reLoc -> name))) | isTermCon name = Just name+viewConE (L _ (HsVar _ (reLoc -> name))) | isTermCon name = Just name viewConE _ = Nothing  pattern ConE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs@@ -226,11 +228,14 @@      mkFld :: LRdrName -> LHsExpr GhcPs -> LHsRecField GhcPs (LHsExpr GhcPs)     mkFld name val = inheritLoc name $+#if __GLASGOW_HASKELL__ >= 904+        HsFieldBind defExt+#elif __GLASGOW_HASKELL__ >= 902+        HsRecField defExt+#else         HsRecField-#if __GLASGOW_HASKELL__ >= 902-          defExt #endif-          (reLoc (inheritLoc name (mkFieldOcc (reLocA name)))) val False+          (inheritLoc name (mkFieldOcc (reLocA name))) val False  -- | Equivalent of 'Language.Haskell.TH.Lib.recUpdE' recUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs@@ -246,27 +251,21 @@      updFld :: LRdrName -> LHsExpr GhcPs -> LHsRecUpdField GhcPs     updFld name val = inheritLoc name $+#if __GLASGOW_HASKELL__ >= 904+        HsFieldBind+#else         HsRecField+#endif #if __GLASGOW_HASKELL__ >= 902           defExt #endif-         (reLoc (inheritLoc name (mkAmbiguousFieldOcc (reLocA name)))) val False+          (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 { hsRecFieldLbl = L _ (Unambiguous _ name), hsRecFieldArg = val, hsRecPun = False })) =-        Just (reLoc name, val)-    viewFieldUpd _otherwise =-        Nothing+    (recExpr,) <$> simpleRecordUpdates fields viewRecUpdE _otherwise = Nothing  pattern RecUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs@@ -312,12 +311,24 @@ appsE :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs appsE = foldl' appE +-- | Equivalent of 'Language.Haskell.TH.Lib.appT'+appTypeE :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs+appTypeE expr typ = inheritLoc expr $+    HsAppType+#if __GLASGOW_HASKELL__ >= 902+      (toSrcSpan expr)+#else+      defExt+#endif+      expr+      (HsWC defExt typ)+ -- | Equivalent of 'Language.Haskell.TH.Lib.tupE' tupE :: NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs 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'@@ -337,6 +348,10 @@   Types -------------------------------------------------------------------------------} +-- | Equivalent of 'Language.Haskell.TH.Lib.parensT'+parensT :: LHsType GhcPs -> LHsType GhcPs+parensT = noLocA . HsParTy defExt+ -- | Equivalent of 'Language.Haskell.TH.Lib.litT' litT :: HsTyLit -> LHsType GhcPs litT = noLocA . HsTyLit defExt@@ -349,7 +364,7 @@  -- | Inverse to 'varT' viewVarT :: LHsType GhcPs -> Maybe LRdrName-viewVarT (reLoc -> L _ (HsTyVar _ _ (reLoc -> name))) | isTypeVar name = Just name+viewVarT (L _ (HsTyVar _ _ (reLoc -> name))) | isTypeVar name = Just name viewVarT _otherwise = Nothing  pattern VarT :: HasCallStack => () => LRdrName -> LHsType GhcPs@@ -365,7 +380,7 @@  -- | Inverse to 'conT' viewConT :: LHsType GhcPs -> Maybe LRdrName-viewConT (reLoc -> L _ (HsTyVar _ _ (reLoc -> name))) | isTypeCon name = Just name+viewConT (L _ (HsTyVar _ _ (reLoc -> name))) | isTypeCon name = Just name viewConT _otherwise = Nothing  pattern ConT :: HasCallStack => () => LRdrName -> LHsType GhcPs@@ -414,27 +429,27 @@  -- | Equivalent of 'Language.Haskell.TH.Lib.varP' varP :: LRdrName -> LPat GhcPs-varP name = inheritLocPat name (VarPat defExt (reLocA name))+varP name = inheritLoc name (VarPat defExt (reLocA name))  -- | Equivalent of 'Language.Haskell.TH.Lib.conP' conP :: LRdrName -> [LPat GhcPs] -> LPat GhcPs #if __GLASGOW_HASKELL__ >= 902-conP con args = inheritLocPat con (conPat con (PrefixCon [] args))+conP con args = inheritLoc con (conPat con (PrefixCon [] args)) #else-conP con args = inheritLocPat con (conPat con (PrefixCon args))+conP con args = inheritLoc con (conPat con (PrefixCon args)) #endif  -- | Equivalent of 'Language.Haskell.TH.Lib.bangP' bangP :: LPat GhcPs -> LPat GhcPs-bangP p = inheritLocPat p $ BangPat defExt p+bangP p = inheritLoc p $ BangPat defExt p  -- | Equivalent of 'Language.Haskell.TH.Lib.listP' listP :: [LPat GhcPs] -> LPat GhcPs-listP xs = inheritLocPat xs $ ListPat defExt xs+listP xs = inheritLoc xs $ ListPat defExt xs  -- | Equivalent of 'Language.Haskell.TH.Lib.wildP' wildP :: LPat GhcPs-wildP = inheritLocPat noSrcSpan (WildPat defExt)+wildP = inheritLoc noSrcSpan (WildPat defExt)  {-------------------------------------------------------------------------------   Strictness@@ -453,7 +468,14 @@  -- | Equivalent of 'Language.Haskell.TH.Lib.equalP' equalP :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs-equalP x y = inheritLoc x $ mkHsOpTy x (inheritLoc x eqTyCon_RDR) y+equalP x y = inheritLoc x $+    mkHsOpTy+#if __GLASGOW_HASKELL__ >= 904+      NotPromoted+#endif+      x+      (inheritLoc x eqTyCon_RDR)+      y  {-------------------------------------------------------------------------------   Constructors@@ -516,7 +538,7 @@ forallRecC vars ctxt conName args = inheritLoc conName $ ConDeclH98 {       con_ext    = defExt     , con_name   = reLocA conName-    , con_forall = inheritLoc' conName True+    , 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)@@ -591,7 +613,7 @@           , dd_cType   = Nothing           , dd_kindSig = Nothing           , dd_cons    = cons-          , dd_derivs  = inheritLoc' typeName derivs+          , dd_derivs  = inheritLoc typeName derivs           }       } @@ -704,13 +726,15 @@   where     qualT :: [LHsType GhcPs] -> LHsType GhcPs -> LHsType GhcPs     qualT []        a = a-    qualT ctx@(c:_) a = inheritLoc c $ HsQualTy defExt-#if __GLASGOW_HASKELL__ >= 902-        (Just (inheritLoc c ctx))+    qualT ctx@(c:_) a = inheritLoc c $+        HsQualTy+          defExt+#if __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 904+          (Just (inheritLoc c ctx)) #else-        (inheritLoc c ctx)+          (inheritLoc c ctx) #endif-        a+          a  -- | Equivalent of 'Language.Haskell.TH.Lib.classD' classD ::@@ -856,6 +880,6 @@ simpleGHRSs body =     GRHSs defExt           [inheritLoc body $ GRHS defExt [] body]-          (inheritLoc' body $ EmptyLocalBinds defExt)+          (inheritLoc body $ EmptyLocalBinds defExt)  

@@ -15,29 +15,29 @@ 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.Names import Data.Record.Internal.Plugin.Record -import qualified Data.Record.Internal.Plugin.Names.GhcGenerics as GHC-import qualified Data.Record.Internal.Plugin.Names.Runtime     as RT- {-------------------------------------------------------------------------------   Top-level -------------------------------------------------------------------------------}  -- | Generate all large-records definitions for a record.-genLargeRecord :: MonadFresh m => Record -> DynFlags -> m [LHsDecl GhcPs]-genLargeRecord r@Record{..} dynFlags = concatM [-      (:[]) <$> genDatatype r-    , genVectorConversions  r-    , genIndexedAccessor    r-    , genUnsafeSetIndex     r-    , genStockInstances     r-    , mapM (genHasFieldInstance r) recordFields+genLargeRecord :: MonadFresh m+  => QualifiedNames+  -> Record -> DynFlags -> m [LHsDecl GhcPs]+genLargeRecord names r@Record{..} dynFlags = concatM [+      (:[]) <$> genDatatype           r+    , genVectorConversions      names r+    , genIndexedAccessor        names r+    , genUnsafeSetIndex         names r+    , genStockInstances         names r+    , mapM (genHasFieldInstance names r) recordFields     , sequence [-          genConstraintsClass    r-        , genConstraintsInstance r-        , genGenericInstance     r dynFlags-        , genGHCGeneric          r+          genConstraintsClass    names r+        , genConstraintsInstance names r+        , genGenericInstance     names r dynFlags+        , genGHCGeneric          names r       ]     ] @@ -102,7 +102,7 @@           (zipWith fieldExistentialType vars recordFields)        ]-      [ DerivClause (Just (noLoc (withDefExt AnyclassStrategy))) (c :| [])+      [ DerivClause (Just (withoutLoc (withDefExt AnyclassStrategy))) (c :| [])       | DeriveAnyClass c <- recordDerivings       ]   where@@ -151,12 +151,16 @@ -- -- TODO: From ghc 9.2, these could be identity functions. See 'genDatatype' -- for details.-genVectorConversions :: forall m. MonadFresh m => Record -> m [LHsDecl GhcPs]-genVectorConversions r@Record{..} = concatM [+genVectorConversions :: forall m.+     MonadFresh m+  => QualifiedNames -> Record -> m [LHsDecl GhcPs]+genVectorConversions QualifiedNames{..} r@Record{..} = concatM [       fromVector     , toVector     ]   where+    UnqualifiedNames{..} = getUnqualifiedNames+     fromVector :: m [LHsDecl GhcPs]     fromVector = do         args <- mapM (freshName . fieldName) recordFields@@ -164,12 +168,12 @@             sigD name $               funT                 (recordTypeT r)-                (ConT RT.type_SmallArray `appT` ConT RT.type_Any)+                (ConT type_AnyArray)           , valD name $               lamE1 (conP recordConName (map varP args)) $                 appE-                  (VarE RT.smallArrayFromList)-                  (listE [ VarE RT.unsafeCoerce `appE` VarE arg+                  (VarE anyArrayFromList)+                  (listE [ VarE noInlineUnsafeCo `appE` VarE arg                          | arg <- args                          ]                   )@@ -185,21 +189,21 @@         return $ [             sigD name $               funT-                (ConT RT.type_SmallArray `appT` ConT RT.type_Any)+                (ConT type_AnyArray)                 (recordTypeT r)           , valD name $               lamE1 (varP x) $                 caseE-                  (VarE RT.smallArrayToList `appE` VarE x)+                  (VarE anyArrayToList `appE` VarE x)                   [ ( listP (map varP args)                     , appsE                         (ConE recordConName)-                        [ VarE RT.unsafeCoerce `appE` VarE arg+                        [ VarE noInlineUnsafeCo `appE` VarE arg                         | arg <- args                         ]                     )                   , ( wildP-                    , VarE RT.error `appE` stringE matchErr+                    , VarE unq_error `appE` stringE matchErr                     )                   ]           ]@@ -230,28 +234,33 @@ -- -- > unsafeGetIndexT :: forall x a b. Int -> T a b -> x -- > unsafeGetIndexT = \ n t -> noInlineUnsafeCo (V.unsafeIndex (vectorFromT t) n)-genIndexedAccessor :: MonadFresh m => Record -> m [LHsDecl GhcPs]-genIndexedAccessor r@Record{..} = do-    x <- freshName $ mkTyVar  recordAnnLoc "x"+genIndexedAccessor ::+     MonadFresh m+  => QualifiedNames+  -> Record -> m [LHsDecl GhcPs]+genIndexedAccessor QualifiedNames{..} r@Record{..} = do+    x <- freshName' False $ mkTyVar  recordAnnLoc "x"     n <- freshName $ mkExpVar recordAnnLoc "n"     t <- freshName $ mkExpVar recordAnnLoc "t"     return [         sigD name $           funT-            (ConT RT.type_Int)+            (ConT unq_type_Int)             (recordTypeT r `funT` VarT x)       , valD name $           lamE (varP n :| [varP t]) $             appE-              (VarE RT.noInlineUnsafeCo)+              (VarE noInlineUnsafeCo)               (appsE-                 (VarE RT.indexSmallArray)+                 (VarE anyArrayIndex)                  [ VarE (nameVectorFrom r) `appE` VarE t                  , VarE n                  ]               )       ]   where+    UnqualifiedNames{..} = getUnqualifiedNames+     name :: LRdrName     name = nameUnsafeGetIndex r @@ -267,32 +276,37 @@ -- would need to take the strictness of the fields into account. If we change -- our internal representation, we might need to be more careful with that -- again. See 'genTo' for further discussion.-genUnsafeSetIndex :: MonadFresh m => Record -> m [LHsDecl GhcPs]-genUnsafeSetIndex r@Record{..} = do-    x   <- freshName $ mkTyVar  recordAnnLoc "x"+genUnsafeSetIndex ::+     MonadFresh m+  => QualifiedNames+  -> Record -> m [LHsDecl GhcPs]+genUnsafeSetIndex QualifiedNames{..} r@Record{..} = do+    x   <- freshName' False $ mkTyVar  recordAnnLoc "x"     n   <- freshName $ mkExpVar recordAnnLoc "n"     t   <- freshName $ mkExpVar recordAnnLoc "t"     val <- freshName $ mkExpVar recordAnnLoc "val"     return [       sigD name $-               ConT RT.type_Int+               ConT unq_type_Int         `funT` (recordTypeT r `funT` (VarT x `funT` recordTypeT r))       , valD name $           lamE (varP n :| [varP t, (varP val)]) $             appE               (VarE (nameVectorTo r))               (appsE-                 (VarE RT.updateSmallArray)+                 (VarE anyArrayUpdate)                  [ VarE (nameVectorFrom r) `appE` VarE t                  , listE [                        tupE $                              VarE n-                         :| [VarE RT.noInlineUnsafeCo `appE` VarE val]+                         :| [VarE noInlineUnsafeCo `appE` VarE val]                      ]                  ]               )       ]   where+    UnqualifiedNames{..} = getUnqualifiedNames+     name :: LRdrName     name = nameUnsafeSetIndex r @@ -302,21 +316,23 @@ -- -- > instance x ~ Word => HasField "tInt" (T a b) x where -- >   hasField = \t -> (unsafeSetIndexT 0 t, unsafeGetIndexT 0 t)-genHasFieldInstance :: MonadFresh m => Record -> Field -> m (LHsDecl GhcPs)-genHasFieldInstance r@Record{..} Field{..} = do-    x <- freshName $ mkTyVar  recordAnnLoc "x"+genHasFieldInstance :: MonadFresh m+  => QualifiedNames+  -> Record -> Field -> m (LHsDecl GhcPs)+genHasFieldInstance QualifiedNames{..} r@Record{..} Field{..} = do+    x <- freshName' False $ mkTyVar  recordAnnLoc "x"     t <- freshName $ mkExpVar recordAnnLoc "t"     return $       instanceD         [equalP (VarT x) fieldType]         (appsT-           (ConT RT.type_HasField)+           (ConT type_HasField)            [ stringT (nameBase fieldName)            , recordTypeT r            , VarT x            ]         )-        [ ( RT.unq_hasField+        [ ( hasField           , lamE1 (varP t) $               tupE $                     appsE (VarE (nameUnsafeSetIndex r)) [intE fieldIndex, VarE t]@@ -346,19 +362,21 @@ -- and use lots of "tuple constraint extractor" functions, each of which have -- the same size as the number of constraints (another example of a -- @case f of { T x1 x2 x3 .. -> xn@ function, but now at the dictionary level).-genConstraintsClass :: MonadFresh m => Record -> m (LHsDecl GhcPs)-genConstraintsClass r@Record{..} = do-    c <- freshName $ mkTyVar recordAnnLoc "c"+genConstraintsClass ::+     MonadFresh m+  => QualifiedNames -> Record -> m (LHsDecl GhcPs)+genConstraintsClass QualifiedNames{..} r@Record{..} = do+    c <- freshName' False $ mkTyVar recordAnnLoc "c"     return $ classD       []       (nameConstraints r)       (recordTyVars ++ [kindedTV c cKind])       [ ( nameDictConstraints r         , funT-            (ConT RT.type_Proxy `appT` VarT c)+            (ConT type_Proxy `appT` VarT c)             (appsT-               (ConT RT.type_Rep)-               [ ConT RT.type_Dict `appT` VarT c+               (ConT type_Rep)+               [ ConT type_Dict `appT` VarT c                , recordTypeT r                ]             )@@ -366,7 +384,7 @@       ]   where     cKind :: LHsType GhcPs-    cKind = ConT RT.type_Type `funT` ConT RT.type_Constraint+    cKind = ConT type_Type `funT` ConT type_Constraint  -- | Superclass constraints required by the constraints class instance --@@ -413,23 +431,23 @@ -- >   , noInlineUnsafeCo (dictFor p (Proxy :: Proxy a)) -- >   , noInlineUnsafeCo (dictFor p (Proxy :: Proxy [b])) -- >   ])-genDict :: MonadFresh m => Record -> m (LHsExpr GhcPs)-genDict Record{..} = do+genDict ::+     MonadFresh m+  => QualifiedNames+  -> Record -> m (LHsExpr GhcPs)+genDict names@QualifiedNames{..} Record{..} = do     p <- freshName $ mkExpVar recordAnnLoc "p"     return $       lamE1 (varP p) $         appE-          (ConE RT.con_Rep)-          (appE-             (VarE RT.smallArrayFromList)-             (listE (map (dictForField p) recordFields))-          )+          (VarE mkDicts)+          (listE (map (dictForField p) recordFields))   where     dictForField :: LRdrName -> Field -> LHsExpr GhcPs     dictForField p Field{..} =         appE-          (VarE RT.noInlineUnsafeCo)-          (VarE RT.dictFor `appsE` [VarE p, proxyE fieldType])+          (VarE noInlineUnsafeCo)+          (VarE mkDict `appsE` [VarE p, proxyE names fieldType])  -- | Generate (one and only) instance of the constraints class --@@ -439,10 +457,12 @@ -- >   dictConstraints_T = .. -- -- where the body of @dictConstraints_T@ is generated by 'genDict'.-genConstraintsInstance :: MonadFresh m => Record -> m (LHsDecl GhcPs)-genConstraintsInstance r@Record{..} = do-    body <- genDict r-    c    <- freshName $ mkTyVar recordAnnLoc "c"+genConstraintsInstance ::+     MonadFresh m+  => QualifiedNames -> Record -> m (LHsDecl GhcPs)+genConstraintsInstance names r@Record{..} = do+    body <- genDict names r+    c    <- freshName' False $ mkTyVar recordAnnLoc "c"     return $       instanceD         (genRequiredConstraints r (VarT c))@@ -468,68 +488,51 @@ -- >       , FieldMetadata (Proxy :: Proxy "tListB")) FieldLazy -- >       ] -- >   }-genMetadata :: MonadFresh m => Record -> DynFlags -> m (LHsExpr GhcPs)-genMetadata r@Record{..} dynFlags = do+genMetadata ::+     MonadFresh m+  => QualifiedNames+  -> Record -> DynFlags -> m (LHsExpr GhcPs)+genMetadata names@QualifiedNames{..} r@Record{..} dynFlags = do     p <- freshName $ mkExpVar recordAnnLoc "p"     return $       lamE1 (varP p) $-        recConE-          RT.con_Metadata [-              ( RT.recordName-              , stringE (nameRecord r)-              )-            , ( RT.recordConstructor-              , stringE (nameBase recordConName)-              )-            , ( RT.recordSize-              , intE (length recordFields)-              )-            , ( RT.recordFieldMetadata-              , appE-                  (ConE RT.con_Rep)-                  (appE-                     (VarE RT.smallArrayFromList)-                     (listE (map auxField recordFields))-                  )-              )-            ]+        appsE (VarE mkMetadata) [+            stringE (nameRecord r)+          , stringE (nameBase recordConName)+          , listE (map auxField recordFields)+          ]   where     auxField :: Field -> LHsExpr GhcPs     auxField Field{..} =-        appsE-          (ConE RT.con_FieldMetadata)-          [ proxyE (stringT (nameBase fieldName))-          , ConE $ case decideStrictness dynFlags fieldStrictness of-              HsStrict                  -> RT.con_FieldStrict-              HsLazy                    -> RT.con_FieldLazy-              HsUnpack _                -> RT.con_FieldStrict-          ]+          (appE . VarE $ if isStrict dynFlags fieldStrictness+            then mkStrictField+            else mkLazyField)+        $ proxyE names+        $ stringT (nameBase fieldName) --- | 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'+isStrict :: DynFlags -> HsSrcBang -> Bool+isStrict dynFlags (HsSrcBang _ _ strictness) =+    case strictness of+      SrcStrict   -> True+      SrcLazy     -> False+      NoSrcStrict -> if strictData then True else False   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 -- -- > repFromVectorStrict . vectorFromT-genFrom :: MonadFresh m => Record -> m (LHsExpr GhcPs)-genFrom r@Record{..} = do+genFrom ::+     MonadFresh m+  => QualifiedNames+  -> Record -> m (LHsExpr GhcPs)+genFrom QualifiedNames{..} r@Record{..} = do     x <- freshName $ mkExpVar recordAnnLoc "x"     return $       lamE1 (varP x) $-        VarE RT.repFromVector `appE` (VarE (nameVectorFrom r) `appE` VarE x)+        VarE anyArrayToRep `appE` (VarE (nameVectorFrom r) `appE` VarE x)  -- | Generate definition for `to` in the `Generic` instance --@@ -541,12 +544,15 @@ -- " normal " record as our internal representation (albeit with strange types), -- and the fields of that record have their own strictness annotation, we don't -- have to worry about strictness here.-genTo :: MonadFresh m => Record -> m (LHsExpr GhcPs)-genTo r@Record{..} = do+genTo ::+     MonadFresh m+  => QualifiedNames+  -> Record -> m (LHsExpr GhcPs)+genTo QualifiedNames{..} r@Record{..} = do     x <- freshName $ mkExpVar recordAnnLoc "x"     return $       lamE1 (varP x) $-        VarE (nameVectorTo r) `appE` (VarE RT.repToVector `appE` VarE x)+        VarE (nameVectorTo r) `appE` (VarE anyArrayFromRep `appE` VarE x)  -- | Generate an instance of large-records 'Data.Record.Generic'. --@@ -561,40 +567,45 @@ -- >   to       = .. -- >   dict     = dictConstraints_T -- >   metadata = ..-genGenericInstance :: MonadFresh m => Record -> DynFlags -> m (LHsDecl GhcPs)-genGenericInstance r@Record{..} dynFlags  = do-    metadata <- genMetadata r dynFlags-    from     <- genFrom     r-    to       <- genTo       r+genGenericInstance ::+     MonadFresh m+  => QualifiedNames+  -> Record -> DynFlags -> m (LHsDecl GhcPs)+genGenericInstance names@QualifiedNames{..} r@Record{..} dynFlags  = do+    metadata <- genMetadata names r dynFlags+    from     <- genFrom     names r+    to       <- genTo       names r     return $       instanceD         []-        (ConT RT.type_Generic `appT` recordTypeT r)-        [ ( RT.unq_from     , from                         )-        , ( RT.unq_to       , to                           )-        , ( RT.unq_dict     , VarE (nameDictConstraints r) )-        , ( RT.unq_metadata , metadata                     )+        (ConT type_LR_Generic `appT` recordTypeT r)+        [ ( lr_from     , from                         )+        , ( lr_to       , to                           )+        , ( lr_dict     , VarE (nameDictConstraints r) )+        , ( lr_metadata , metadata                     )         ]-        [ tySynEqn RT.unq_type_Constraints [recordTypeT r] $+        [ tySynEqn type_LR_Constraints [recordTypeT r] $             appsT               (ConT (nameConstraints r))               [VarT (tyVarBndrName v) | v <- recordTyVars]-        , tySynEqn RT.unq_type_MetadataOf [recordTypeT r] $+        , tySynEqn type_LR_MetadataOf [recordTypeT r] $             listT [                 tupT $ stringT (nameBase fieldName) :| [fieldType]               | Field{..} <- recordFields               ]         ]-  where  {-------------------------------------------------------------------------------   "Stock" instances -------------------------------------------------------------------------------}  -- | Generate stock instances-genStockInstances :: MonadFresh m => Record -> m [LHsDecl GhcPs]-genStockInstances r@Record{..} = concatM [-      genStockInstance r d+genStockInstances ::+     MonadFresh m+  => QualifiedNames+  -> Record -> m [LHsDecl GhcPs]+genStockInstances names r@Record{..} = concatM [+      genStockInstance names r d     | DeriveStock d <- recordDerivings     ] @@ -609,13 +620,17 @@ -- TODO: For 'Generic' we currently don't do anything. We could change this so -- that we generate the 'GHC.Generics' instance only when the user asks for a -- 'Generics' instance?-genStockInstance :: MonadFresh m => Record -> StockDeriving -> m [LHsDecl GhcPs]-genStockInstance r = pure . \case-    Show    -> [mkInstance RT.type_Show RT.unq_showsPrec RT.gshowsPrec]-    Eq      -> [mkInstance RT.type_Eq   RT.unq_eq        RT.geq       ]-    Ord     -> [mkInstance RT.type_Ord  RT.unq_compare   RT.gcompare  ]+genStockInstance :: MonadFresh m+  => QualifiedNames+  -> Record -> StockDeriving -> m [LHsDecl GhcPs]+genStockInstance QualifiedNames{..} r = pure . \case+    Show    -> [mkInstance unq_type_Show unq_showsPrec gshowsPrec]+    Eq      -> [mkInstance unq_type_Eq   unq_eq        geq       ]+    Ord     -> [mkInstance unq_type_Ord  unq_compare   gcompare  ]     Generic -> []   where+    UnqualifiedNames{..} = getUnqualifiedNames+     mkInstance :: LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs     mkInstance cls mthd gen =         instanceD@@ -639,16 +654,18 @@ -- >   to   = unwrapThroughLRGenerics -- -- See 'ThroughLRGenerics' for documentation.-genGHCGeneric :: MonadFresh m => Record -> m (LHsDecl GhcPs)-genGHCGeneric r = pure $+genGHCGeneric ::+     MonadFresh m+  => QualifiedNames -> Record -> m (LHsDecl GhcPs)+genGHCGeneric QualifiedNames{..} r = pure $     instanceD       []-      (ConT GHC.type_Generic `appT` recordTypeT r)-      [ ( GHC.unq_from , ConE RT.con_WrapThroughLRGenerics )-      , ( GHC.unq_to   , VarE RT.unwrapThroughLRGenerics   )+      (ConT type_GHC_Generic `appT` recordTypeT r)+      [ ( ghc_from , VarE wrapThroughLRGenerics   )+      , ( ghc_to   , VarE unwrapThroughLRGenerics )       ]-      [ tySynEqn GHC.unq_type_Rep [recordTypeT r] $-          ConT RT.type_ThroughLRGenerics `appT` recordTypeT r+      [ tySynEqn type_GHC_Rep [recordTypeT r] $+          ConT type_ThroughLRGenerics `appT` recordTypeT r       ]  {-------------------------------------------------------------------------------@@ -692,8 +709,9 @@ -- | Generate a Proxy expression for the given type. -- -- @proxyE [t|ty|]@ will result in a @Proxy :: Proxy ty@.-proxyE :: LHsType GhcPs -> LHsExpr GhcPs-proxyE ty = sigE (ConE RT.con_Proxy) (ConT RT.type_Proxy `appT` ty)+proxyE :: QualifiedNames -> LHsType GhcPs -> LHsExpr GhcPs+proxyE QualifiedNames{..} ty =+    sigE (VarE proxy) (ConT type_Proxy `appT` ty)  concatM :: Applicative m => [m [a]] -> m [a] concatM = fmap concat . sequenceA

@@ -18,9 +18,9 @@  exceptionLoc :: Exception -> SrcSpan exceptionLoc = \case-    UnsupportedStockDeriving (reLoc -> L l _) -> l-    UnsupportedStrategy      (id    -> L l _) -> l-    InvalidDeclaration       (reLoc -> L l _) -> l+    UnsupportedStockDeriving x -> toSrcSpan x+    UnsupportedStrategy      x -> toSrcSpan x+    InvalidDeclaration       x -> toSrcSpan x  exceptionToSDoc :: Exception -> SDoc exceptionToSDoc = hsep . \case

@@ -0,0 +1,211 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++module Data.Record.Internal.Plugin.Names (+    -- * Qualified names+    QualifiedNames(..)+  , getQualifiedNames+    -- * Unqualified names+  , UnqualifiedNames(..)+  , getUnqualifiedNames+  ) where++import Data.Record.Internal.GHC.Shim++{-------------------------------------------------------------------------------+  Qualified names+-------------------------------------------------------------------------------}++data QualifiedNames = QualifiedNames {++      --+      -- Base+      --++      type_Constraint  :: LRdrName+    , type_GHC_Generic :: LRdrName+    , type_GHC_Rep     :: LRdrName+    , type_Proxy       :: LRdrName+    , type_Type        :: LRdrName+    , proxy            :: LRdrName+    , ghc_from         :: LRdrName+    , ghc_to           :: LRdrName++      --+      -- AnyArray+      --++    , type_AnyArray    :: LRdrName+    , anyArrayFromList :: LRdrName+    , anyArrayToList   :: LRdrName+    , anyArrayIndex    :: LRdrName+    , anyArrayUpdate   :: LRdrName++      --+      -- large-generics+      --++    , type_LR_Generic     :: LRdrName+    , type_LR_MetadataOf  :: LRdrName+    , type_LR_Constraints :: LRdrName+    , lr_from             :: LRdrName+    , lr_to               :: LRdrName+    , lr_dict             :: LRdrName+    , lr_metadata         :: LRdrName++      -- .. wrappers++    , type_Rep         :: LRdrName+    , type_Dict        :: LRdrName+    , gcompare         :: LRdrName+    , geq              :: LRdrName+    , gshowsPrec       :: LRdrName+    , noInlineUnsafeCo :: LRdrName++      -- .. utilities++    , anyArrayToRep   :: LRdrName+    , anyArrayFromRep :: LRdrName+    , mkDicts         :: LRdrName+    , mkDict          :: LRdrName+    , mkStrictField   :: LRdrName+    , mkLazyField     :: LRdrName+    , mkMetadata      :: LRdrName++      -- .. ThroughLRGenerics++    , type_ThroughLRGenerics  :: LRdrName+    , wrapThroughLRGenerics   :: LRdrName+    , unwrapThroughLRGenerics :: LRdrName++      --+      -- record-hasfield+      --++    , type_HasField :: LRdrName+    , hasField      :: LRdrName+    }++-- | Resolve qualified names+--+-- We try to import whenever possible from "Data.Record.Plugin.Runtime"; only+-- when this is /really/ not possible do we import from other modules. We do+-- this to avoid two problems:+--+-- * When we resolve a name, we must specify the module where something is+--   /defined/, not merely a module that /exports/ the thing we need; this means+--   that this is quite brittle.+--+-- * When we resolve a name from a different package, users must explicitly+--   define a dependency on that other package.+getQualifiedNames :: Hsc QualifiedNames+getQualifiedNames = do+    --+    -- base+    --++    type_Constraint  <- exact <$> lookupTcName  runtime     Nothing "Constraint"+    type_GHC_Generic <- exact <$> lookupTcName  ghcGenerics Nothing "Generic"+    type_GHC_Rep     <- exact <$> lookupTcName  ghcGenerics Nothing "Rep"+    type_Proxy       <- exact <$> lookupTcName  runtime     Nothing "Proxy"+    type_Type        <- exact <$> lookupTcName  runtime     Nothing "Type"+    proxy            <- exact <$> lookupVarName runtime     Nothing "proxy"+    ghc_from         <- exact <$> lookupVarName ghcGenerics Nothing "from"+    ghc_to           <- exact <$> lookupVarName ghcGenerics Nothing "to"++    --+    -- AnyArray+    --++    type_AnyArray    <- exact <$> lookupTcName  runtime Nothing "AnyArray"+    anyArrayFromList <- exact <$> lookupVarName runtime Nothing "anyArrayFromList"+    anyArrayToList   <- exact <$> lookupVarName runtime Nothing "anyArrayToList"+    anyArrayIndex    <- exact <$> lookupVarName runtime Nothing "anyArrayIndex"+    anyArrayUpdate   <- exact <$> lookupVarName runtime Nothing "anyArrayUpdate"++    --+    -- large-generics+    --++    type_LR_Generic     <- exact <$> lookupTcName  largeGenerics (Just "large-generics") "Generic"+    type_LR_Constraints <- exact <$> lookupTcName  largeGenerics (Just "large-generics") "Constraints"+    type_LR_MetadataOf  <- exact <$> lookupTcName  largeGenerics (Just "large-generics") "MetadataOf"+    lr_from             <- exact <$> lookupVarName largeGenerics (Just "large-generics") "from"+    lr_to               <- exact <$> lookupVarName largeGenerics (Just "large-generics") "to"+    lr_dict             <- exact <$> lookupVarName largeGenerics (Just "large-generics") "dict"+    lr_metadata         <- exact <$> lookupVarName largeGenerics (Just "large-generics") "metadata"++    -- .. utilities++    anyArrayToRep   <- exact <$> lookupVarName runtime Nothing "anyArrayToRep"+    anyArrayFromRep <- exact <$> lookupVarName runtime Nothing "anyArrayFromRep"+    mkDicts         <- exact <$> lookupVarName runtime Nothing "mkDicts"+    mkDict          <- exact <$> lookupVarName runtime Nothing "mkDict"+    mkStrictField   <- exact <$> lookupVarName runtime Nothing "mkStrictField"+    mkLazyField     <- exact <$> lookupVarName runtime Nothing "mkLazyField"+    mkMetadata      <- exact <$> lookupVarName runtime Nothing "mkMetadata"++    -- .. wrappers++    type_Rep         <- exact <$> lookupTcName  runtime Nothing "Rep"+    type_Dict        <- exact <$> lookupTcName  runtime Nothing "Dict"+    gcompare         <- exact <$> lookupVarName runtime Nothing "gcompare"+    geq              <- exact <$> lookupVarName runtime Nothing "geq"+    gshowsPrec       <- exact <$> lookupVarName runtime Nothing "gshowsPrec"+    noInlineUnsafeCo <- exact <$> lookupVarName runtime Nothing "noInlineUnsafeCo"++    -- .. ThroughLRGenerics++    type_ThroughLRGenerics  <- exact <$> lookupTcName  runtime Nothing "ThroughLRGenerics"+    wrapThroughLRGenerics   <- exact <$> lookupVarName runtime Nothing "wrapThroughLRGenerics"+    unwrapThroughLRGenerics <- exact <$> lookupVarName runtime Nothing "unwrapThroughLRGenerics"++    --+    -- record-hasfield+    --++    type_HasField <- exact <$> lookupTcName  recordHasField (Just "record-hasfield") "HasField"+    hasField      <- exact <$> lookupVarName recordHasField (Just "record-hasfield") "hasField"++    return QualifiedNames{..}++  where+   exact :: Name -> LRdrName+   exact = noLoc . Exact++   runtime, recordHasField, ghcGenerics, largeGenerics :: ModuleName+   runtime        = mkModuleName "Data.Record.Plugin.Runtime"+   recordHasField = mkModuleName "GHC.Records.Compat"+   ghcGenerics    = mkModuleName "GHC.Generics"+   largeGenerics  = mkModuleName "Data.Record.Generic"++{-------------------------------------------------------------------------------+  We use Prelude names unqualified.+-------------------------------------------------------------------------------}++data UnqualifiedNames = UnqualifiedNames {+      unq_type_Eq   :: LRdrName+    , unq_type_Int  :: LRdrName+    , unq_type_Ord  :: LRdrName+    , unq_type_Show :: LRdrName+    , unq_compare   :: LRdrName+    , unq_eq        :: LRdrName+    , unq_error     :: LRdrName+    , unq_showsPrec :: LRdrName+    }++getUnqualifiedNames :: UnqualifiedNames+getUnqualifiedNames = UnqualifiedNames {+      unq_type_Eq   = tc "Eq"+    , unq_type_Int  = tc "Int"+    , unq_type_Ord  = tc "Ord"+    , unq_type_Show = tc "Show"+    , unq_compare   = var "compare"+    , unq_eq        = var "=="+    , unq_error     = var "error"+    , unq_showsPrec = var "showsPrec"+    }+  where+    var, tc :: String -> LRdrName+    var x = noLoc $ mkRdrUnqual $ mkVarOcc x+    tc  x = noLoc $ mkRdrUnqual $ mkTcOcc  x

@@ -1,42 +0,0 @@--- | Names for GHC generics------ We cannot make this part of the main ghcGenerics, because the names clash--- with @large-records@ generics.-module Data.Record.Internal.Plugin.Names.GhcGenerics (-    type_Generic-  , unq_type_Rep-  , unq_from-  , unq_to-  ) where--import Data.Record.Internal.GHC.Shim--{--------------------------------------------------------------------------------  Names of GHC.Generics--------------------------------------------------------------------------------}--type_Generic :: LRdrName-type_Generic = nameQT "Generic"--unq_type_Rep :: LRdrName-unq_type_Rep = nameUT "Rep"--unq_from, unq_to :: LRdrName-unq_from = nameUV "from"-unq_to   = nameUV "to"--{--------------------------------------------------------------------------------  Internal auxiliary--  NOTE: Unqualified names are used when generating class instances.--------------------------------------------------------------------------------}--ghcGenerics :: ModuleName-ghcGenerics = mkModuleName "GHC.Generics"--nameQT :: String -> LRdrName-nameQT var = noLoc $ mkRdrQual ghcGenerics $ mkTcOcc   var--nameUV, nameUT :: String -> LRdrName-nameUV var = noLoc $ mkRdrUnqual $ mkVarOcc var-nameUT var = noLoc $ mkRdrUnqual $ mkTcOcc  var

@@ -1,223 +0,0 @@--- | Names of all everything used by the generated code------ This follows the structure of "Data.Record.Plugin.Runtime".-module Data.Record.Internal.Plugin.Names.Runtime (-    -- * base-    type_Any-  , type_Constraint-  , type_Eq-  , type_Int-  , type_Ord-  , type_Proxy-  , type_Show-  , type_Type-  , con_Proxy-  , unq_compare-  , unq_eq-  , unq_showsPrec-  , error-  , unsafeCoerce-    -- * primitive-  , type_SmallArray-  , smallArrayFromList-  , smallArrayToList-  , indexSmallArray-  , updateSmallArray-    -- * record-hasfield-  , type_HasField-  , unq_hasField-    -- * large-generics-  , type_Dict-  , type_Generic-  , type_Rep-  , type_ThroughLRGenerics-  , unq_type_Constraints-  , unq_type_MetadataOf-  , con_FieldLazy-  , con_FieldMetadata-  , con_FieldStrict-  , con_Metadata-  , con_Rep-  , con_WrapThroughLRGenerics-  , unq_from-  , unq_to-  , unq_dict-  , unq_metadata-  , gcompare-  , geq-  , gshowsPrec-  , noInlineUnsafeCo-  , recordConstructor-  , recordFieldMetadata-  , recordName-  , recordSize-  , unwrapThroughLRGenerics-    -- * Auxiliary-  , dictFor-  , repFromVector-  , repToVector-  ) where--import Prelude hiding (error, showsPrec, compare)--import Data.Record.Internal.GHC.Shim--{--------------------------------------------------------------------------------  base--------------------------------------------------------------------------------}--type_Any        :: LRdrName-type_Constraint :: LRdrName-type_Eq         :: LRdrName-type_Int        :: LRdrName-type_Ord        :: LRdrName-type_Proxy      :: LRdrName-type_Show       :: LRdrName-type_Type       :: LRdrName--type_Any        = nameQT "Any"-type_Constraint = nameQT "Constraint"-type_Eq         = nameQT "Eq"-type_Int        = nameQT "Int"-type_Ord        = nameQT "Ord"-type_Proxy      = nameQT "Proxy"-type_Show       = nameQT "Show"-type_Type       = nameQT "Type"--con_Proxy :: LRdrName-con_Proxy = nameQC "Proxy"--error        :: LRdrName-unsafeCoerce :: LRdrName--error        = nameQV "error"-unsafeCoerce = nameQV "unsafeCoerce"--unq_compare   :: LRdrName-unq_eq        :: LRdrName-unq_showsPrec :: LRdrName--unq_compare   = nameUV "compare"-unq_eq        = nameUV "=="-unq_showsPrec = nameUV "showsPrec"--{--------------------------------------------------------------------------------  vector--------------------------------------------------------------------------------}--type_SmallArray :: LRdrName-type_SmallArray = nameQT "SmallArray"--smallArrayFromList :: LRdrName-smallArrayToList   :: LRdrName-indexSmallArray    :: LRdrName-updateSmallArray   :: LRdrName--smallArrayFromList = nameQV "smallArrayFromList"-smallArrayToList   = nameQV "smallArrayToList"-indexSmallArray    = nameQV "indexSmallArray"-updateSmallArray   = nameQV "updateSmallArray"--{--------------------------------------------------------------------------------  record-hasfield--------------------------------------------------------------------------------}--type_HasField :: LRdrName-type_HasField = nameQT "HasField"--unq_hasField :: LRdrName-unq_hasField = nameUV "hasField"--{--------------------------------------------------------------------------------  large-generics--------------------------------------------------------------------------------}--type_Dict              :: LRdrName-type_Generic           :: LRdrName-type_Rep               :: LRdrName-type_ThroughLRGenerics :: LRdrName--type_Dict              = nameQT "Dict"-type_Generic           = nameQT "Generic"-type_Rep               = nameQT "Rep"-type_ThroughLRGenerics = nameQT "ThroughLRGenerics"--unq_type_MetadataOf :: LRdrName-unq_type_Constraints :: LRdrName--unq_type_Constraints = nameUT "Constraints"-unq_type_MetadataOf  = nameUT "MetadataOf"--con_FieldLazy             :: LRdrName-con_FieldMetadata         :: LRdrName-con_FieldStrict           :: LRdrName-con_Metadata              :: LRdrName-con_Rep                   :: LRdrName-con_WrapThroughLRGenerics :: LRdrName--con_FieldLazy             = nameQC "FieldLazy"-con_FieldMetadata         = nameQC "FieldMetadata"-con_FieldStrict           = nameQC "FieldStrict"-con_Metadata              = nameQC "Metadata"-con_Rep                   = nameQC "Rep"-con_WrapThroughLRGenerics = nameQC "WrapThroughLRGenerics"--unq_from     :: LRdrName-unq_to       :: LRdrName-unq_dict     :: LRdrName-unq_metadata :: LRdrName--unq_from     = nameUV "from"-unq_to       = nameUV "to"-unq_dict     = nameUV "dict"-unq_metadata = nameUV "metadata"--gcompare                :: LRdrName-geq                     :: LRdrName-gshowsPrec              :: LRdrName-noInlineUnsafeCo        :: LRdrName-recordConstructor       :: LRdrName-recordFieldMetadata     :: LRdrName-recordName              :: LRdrName-recordSize              :: LRdrName-unwrapThroughLRGenerics :: LRdrName--gcompare                = nameQV "gcompare"-geq                     = nameQV "geq"-gshowsPrec              = nameQV "gshowsPrec"-noInlineUnsafeCo        = nameQV "noInlineUnsafeCo"-recordConstructor       = nameQV "recordConstructor"-recordFieldMetadata     = nameQV "recordFieldMetadata"-recordName              = nameQV "recordName"-recordSize              = nameQV "recordSize"-unwrapThroughLRGenerics = nameQV "unwrapThroughLRGenerics"--{--------------------------------------------------------------------------------  Auxiliary--------------------------------------------------------------------------------}--dictFor       :: LRdrName-repFromVector :: LRdrName-repToVector   :: LRdrName--dictFor       = nameQV "dictFor"-repFromVector = nameQV "repFromVector"-repToVector   = nameQV "repToVector"--{--------------------------------------------------------------------------------  Internal auxiliary--  NOTE: Unqualified names are used when generating class instances.--------------------------------------------------------------------------------}--runtime :: ModuleName-runtime = mkModuleName "Data.Record.Plugin.Runtime"--nameQV, nameQT, nameQC :: String -> LRdrName-nameQV var = noLoc $ mkRdrQual runtime $ mkVarOcc  var-nameQT var = noLoc $ mkRdrQual runtime $ mkTcOcc   var-nameQC var = noLoc $ mkRdrQual runtime $ mkDataOcc var--nameUV, nameUT :: String -> LRdrName-nameUV var = noLoc $ mkRdrUnqual $ mkVarOcc var-nameUT var = noLoc $ mkRdrUnqual $ mkTcOcc  var

@@ -1,7 +1,9 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE LambdaCase         #-}-{-# LANGUAGE ViewPatterns       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE DerivingStrategies    #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ViewPatterns          #-}  -- | Generation options for large-records. module Data.Record.Internal.Plugin.Options (@@ -16,6 +18,7 @@ import Data.Data (Data) import Data.Map (Map) import Data.Maybe (mapMaybe)+import GHC.Records.Compat  import qualified Data.Generics   as SYB import qualified Data.Map.Strict as Map@@ -49,6 +52,15 @@     }  {-------------------------------------------------------------------------------+  HasField instances++  These instances are required in modules that enable 'OverloadedRecordUpdate'+-------------------------------------------------------------------------------}++instance HasField "debugLargeRecords" LargeRecordOptions Bool where+   hasField r = (\x -> r{debugLargeRecords = x}, debugLargeRecords r)++{-------------------------------------------------------------------------------   Extract options from module -------------------------------------------------------------------------------} @@ -86,7 +98,7 @@     opts    <- intOptions expr     updates <- mapM intUpdate fields     return $ foldr (.) id updates opts-intOptions _otherwise =+intOptions _ =     Nothing  intUpdate ::

@@ -100,7 +100,7 @@      MonadError Exception m   => (LRdrName, LHsType GhcPs) -> m (Int -> Field)   viewField (name, typ) =-  return $ Field name (getBangType typ) (getBangStrictness typ)+  return $ Field name (parensT (getBangType typ)) (getBangStrictness typ)  viewRecordDerivings ::      MonadError Exception m

@@ -0,0 +1,83 @@+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++-- Necessary for correct type for @setField@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Provide @Prelude@-like environment when using @RebindableSyntax@+--+-- If you want to use @large-records@ with 'OverloadedRecordDot' and+-- 'OverloadedRecordUpdate', you need to enable the @RebindableSyntax@ language+-- extension. You can then import this module to get a standard environment+-- back, with one exception; see 'getField' for details.+module Data.Record.Overloading (+    module Prelude+  , Control.Arrow.app+  , Control.Arrow.arr+  , Control.Arrow.first+  , Control.Arrow.loop+  , (Control.Arrow.>>>)+  , (Control.Arrow.|||)+  , Data.String.fromString+  , GHC.OverloadedLabels.fromLabel+    -- * New definitions+  , ifThenElse+  , getField+  , setField+  ) where++import qualified Control.Arrow+import qualified Data.String+import qualified GHC.OverloadedLabels+import qualified GHC.Records.Compat++{-------------------------------------------------------------------------------+  Other exports+-------------------------------------------------------------------------------}++ifThenElse :: Bool -> a -> a -> a+ifThenElse b x y = if b then x else y++-- | Get record field+--+-- This is /NOT/ the standard @getField@ from "GHC.Records", but is instead+-- defined in terms of "GHC.Records.Compat.HasField". As a consequence we do not+-- currently support @OverloadedRecordDot@ without @RebindableSyntax@.+-- (For ghc 9.2 and 9.4 @RebindableSyntax@ is required /anyway/ when using+-- @OverloadedRecordUpdate@, so this is less of a limitation than it might+-- seem.)+--+-- Unfortunately, we /cannot/ currently support 'GHC.Records.HasField'; in the+-- remainder of this comment we explain why. Consider a record such as+--+-- > {-# ANN type Person largeRecord #-}+-- > data Person = Person { name :: String }+--+-- The internal representation of this record generated by @large-records@+-- looks something like this:+--+-- > data Person = forall a. a ~ String => Person { name :: a }+--+-- This representation prevents ghc from generating record accessors, whilst+-- at the same time still making it possible to define and pattern match on+-- records in the normal way. Unfortunately, although GHC does not generate+-- a 'HasField' instance for such a record, it /also/ prevents us from+-- defining our own:+--+--   If a field has a higher-rank or existential type, the corresponding+--   HasField constraint will not be solved automatically (as described above),+--   but in the interests of simplicity we do not permit users to define their+--   own instances either.+--+--   <https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/hasfield.html#solving-hasfield-constraints>+--+-- There is a proposal to change this+-- (<https://github.com/ghc-proposals/ghc-proposals/pull/515>),+-- but for now we instead rely on 'GHC.Records.Compat.HasField', for which no+-- such restrictions exist.+getField :: forall x r a. GHC.Records.Compat.HasField x r a => r -> a+getField = snd . GHC.Records.Compat.hasField @x++setField :: forall x r a. GHC.Records.Compat.HasField x r a => r -> a -> r+setField = fst . GHC.Records.Compat.hasField @x

@@ -8,6 +8,8 @@ -- -- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} -- >+-- > import Data.Record.Plugin+-- > -- > {-# ANN type B largeRecord #-} -- > data B a = B {a :: a, b :: String} -- >   deriving stock (Show, Eq, Ord)@@ -16,14 +18,26 @@ -- -- = Usage with @record-dot-preprocessor@ ----- There are two important points. First, the order of plugins matters —--- @record-dot-preprocessor@ has to be listed before this plugin (and--- correspondingly will be applied /after/ this plugin):+-- The easiest way to use both plugins together is to do --+-- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}+--+-- You /can/ also load them separately, but if you do, you need to be careful+-- with the order. Unfortunately, the correct order is different in different+-- ghc versions. Prior to ghc 9.4, the plugins must be loaded like this:+-- -- > {-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -fplugin=Data.Record.Plugin #-} ----- Second, you will want at least version 0.2.14.-module Data.Record.Plugin (plugin) where+-- From ghc 9.4 and up, they need to be loaded in the opposite order:+--+-- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin -fplugin=RecordDotPreprocessor #-}+module Data.Record.Plugin (+    -- * Annotations+    LargeRecordOptions(..)+  , largeRecord+    -- * For use by ghc+  , plugin+  ) where  import Control.Monad.Except import Control.Monad.Trans.Writer.CPS@@ -43,28 +57,44 @@ import Data.Record.Internal.Plugin.Exception import Data.Record.Internal.Plugin.Options import Data.Record.Internal.Plugin.Record+import Data.Record.Internal.Plugin.Names  #if __GLASGOW_HASKELL__ >= 902-import GHC.Driver.Errors-import GHC.Types.Error (mkWarnMsg, mkErr, mkDecorated) import GHC.Utils.Logger (getLogger) #endif +#if __GLASGOW_HASKELL__ == 902+import GHC.Types.Error (mkWarnMsg, mkErr, mkDecorated)+import GHC.Driver.Errors (printOrThrowWarnings)+#endif++#if __GLASGOW_HASKELL__ >= 904+import GHC.Driver.Config.Diagnostic (initDiagOpts)+import GHC.Driver.Errors (printOrThrowDiagnostics)+import GHC.Driver.Errors.Types (GhcMessage(GhcUnknownMessage))+import GHC.Types.Error (mkPlainError, mkMessages, mkPlainDiagnostic)+import GHC.Utils.Error (mkMsgEnvelope, mkErrorMsgEnvelope)+#endif+ {-------------------------------------------------------------------------------   Top-level: the plugin proper -------------------------------------------------------------------------------}  plugin :: Plugin plugin = defaultPlugin {-      parsedResultAction = aux+      parsedResultAction = \_ _ -> ignoreMessages aux     , pluginRecompile    = purePlugin     }   where-    aux ::-         [CommandLineOption]-      -> ModSummary-      -> HsParsedModule -> Hsc HsParsedModule-    aux _opts _summary parsed@HsParsedModule{hpm_module = modl} = do+#if __GLASGOW_HASKELL__ >= 904+    ignoreMessages f (ParsedResult modl msgs) =+            (\modl' -> ParsedResult modl' msgs) <$> f modl+#else+    ignoreMessages = id+#endif++    aux :: HsParsedModule -> Hsc HsParsedModule+    aux parsed@HsParsedModule{hpm_module = modl} = do         modl' <- transformDecls modl         pure $ parsed { hpm_module = modl' } @@ -73,7 +103,7 @@ -------------------------------------------------------------------------------}  transformDecls :: LHsModule -> Hsc LHsModule-transformDecls (L l modl@HsModule {hsmodDecls = decls, hsmodImports}) = do+transformDecls (L l modl@HsModule{hsmodDecls = decls}) = do     (decls', transformed) <- runWriterT $ for decls $ transformDecl largeRecords      checkEnabledExtensions l@@ -87,25 +117,11 @@      -- We add imports whether or not there were some errors, to avoid spurious     -- additional errors from ghc about things not in scope.-    pure $ L l $ modl {-        hsmodDecls   = concat decls'-      , hsmodImports = hsmodImports ++ map (uncurry importDecl) requiredImports-      }+    pure $ L l $ modl{hsmodDecls = concat decls'}   where     largeRecords :: Map String [(SrcSpan, LargeRecordOptions)]     largeRecords = getLargeRecordOptions modl -    -- Required imports along with whether or not they should be qualified-    ---    -- ANN pragmas are written by the user, and should thefore not require-    -- qualification; references to the runtime are generated by the plugin.-    requiredImports :: [(ModuleName, Bool)]-    requiredImports = [-          (mkModuleName "Data.Record.Plugin.Options", False)-        , (mkModuleName "Data.Record.Plugin.Runtime", True)-        , (mkModuleName "GHC.Generics", True)-        ]- transformDecl ::      Map String [(SrcSpan, LargeRecordOptions)]   -> LHsDecl GhcPs@@ -127,11 +143,12 @@                 lift $ issueError (exceptionLoc e) (exceptionToSDoc e)                 -- Return the declaration unchanged if we cannot parse it                 return [decl]-              Right r -> do-                dynFlags <- lift getDynFlags-                newDecls <- lift $ runFreshHsc $ genLargeRecord r dynFlags+              Right r -> lift $ do+                dynFlags <- getDynFlags+                names    <- getQualifiedNames+                newDecls <- runFreshHsc $ genLargeRecord names r dynFlags                 when (debugLargeRecords opts) $-                  lift $ issueWarning l (debugMsg newDecls)+                  issueWarning l (debugMsg newDecls)                 pure newDecls       _otherwise ->         pure [decl]@@ -193,9 +210,15 @@  issueError :: SrcSpan -> SDoc -> Hsc () issueError l errMsg = do-#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ == 902     throwOneError $       mkErr l neverQualify (mkDecorated [errMsg])+#elif __GLASGOW_HASKELL__ >= 904+    throwOneError $+      mkErrorMsgEnvelope+        l+        neverQualify+        (GhcUnknownMessage $ mkPlainError [] errMsg) #else     dynFlags <- getDynFlags     throwOneError $@@ -205,11 +228,22 @@ issueWarning :: SrcSpan -> SDoc -> Hsc () issueWarning l errMsg = do     dynFlags <- getDynFlags-#if __GLASGOW_HASKELL__ >= 902+#if __GLASGOW_HASKELL__ == 902     logger <- getLogger-    liftIO $ printOrThrowWarnings logger dynFlags . listToBag . (:[]) $+    liftIO $ printOrThrowWarnings logger dynFlags . bag $       mkWarnMsg l neverQualify errMsg+#elif __GLASGOW_HASKELL__ >= 904+    logger <- getLogger+    liftIO $ printOrThrowDiagnostics logger (initDiagOpts dynFlags) . mkMessages . bag $+      mkMsgEnvelope+        (initDiagOpts dynFlags)+        l+        neverQualify+        (GhcUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag [] errMsg) #else-    liftIO $ printOrThrowWarnings dynFlags . listToBag . (:[]) $+    liftIO $ printOrThrowWarnings dynFlags . bag $       mkWarnMsg dynFlags l neverQualify errMsg #endif+  where+    bag :: a -> Bag a+    bag = listToBag . (:[])

@@ -1,84 +1,161 @@-{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE ConstraintKinds          #-}+{-# LANGUAGE DataKinds                #-}+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE KindSignatures           #-}+{-# LANGUAGE PolyKinds                #-}+{-# LANGUAGE ScopedTypeVariables      #-}+{-# LANGUAGE TypeApplications         #-}  -- | Re-exports of types and functions used by generated code -- -- This exports all functionality required by the generated code, with the -- exception of GHC generics (name clash with @large-records@ generics).------ This follows the structure of "Data.Record.Internal.Plugin.RuntimeNames". module Data.Record.Plugin.Runtime (-    -- * base-    Any-  , Constraint-  , Eq((==))-  , Int-  , Ord(compare)-  , Proxy(Proxy)-  , Show(showsPrec)+    -- * Base+    Constraint+  , Proxy   , Type-  , unsafeCoerce-  , error-    -- * vector-  , SmallArray-  , smallArrayFromList-  , smallArrayToList-  , indexSmallArray-  , updateSmallArray-    -- * record-hasfield-  , GRC.HasField(hasField)+  , proxy+    -- * AnyArray+  , AnyArray+  , anyArrayFromList+  , anyArrayToList+  , anyArrayIndex+  , anyArrayUpdate     -- * large-generics-  , LR.Dict-  , LR.FieldMetadata(FieldMetadata)-  , LR.FieldStrictness(FieldLazy, FieldStrict)-  , LR.Generic(Constraints, MetadataOf, dict, from, metadata, to)-  , LR.Metadata(Metadata, recordConstructor, recordFieldMetadata, recordName, recordSize)-  , LR.Rep(Rep)-  , LR.ThroughLRGenerics(WrapThroughLRGenerics, unwrapThroughLRGenerics)-  , LR.gcompare-  , LR.geq-  , LR.gshowsPrec-  , LR.noInlineUnsafeCo-    -- * Auxiliary-  , dictFor-  , repFromVector-  , repToVector+  , Rep+  , Dict+  , anyArrayToRep+  , anyArrayFromRep+  , mkDicts+  , mkDict+  , mkStrictField+  , mkLazyField+  , mkMetadata+    -- ** wrappers+  , gcompare+  , geq+  , gshowsPrec+  , noInlineUnsafeCo+    -- ** ThroughLRGenerics+  , ThroughLRGenerics+  , wrapThroughLRGenerics+  , unwrapThroughLRGenerics   ) where  import Control.Monad (forM_) import Data.Coerce (coerce)-import Data.Kind (Constraint, Type) import Data.Primitive.SmallArray-import Data.Proxy (Proxy(Proxy)) import GHC.Exts (Any)-import Unsafe.Coerce (unsafeCoerce)+import GHC.TypeLits  import qualified Data.Foldable                    as Foldable+import qualified Data.Kind                        as Base+import qualified Data.Proxy                       as Base import qualified Data.Record.Generic              as LR import qualified Data.Record.Generic.Eq           as LR import qualified Data.Record.Generic.GHC          as LR import qualified Data.Record.Generic.Rep.Internal as LR import qualified Data.Record.Generic.Show         as LR-import qualified GHC.Records.Compat               as GRC  {--------------------------------------------------------------------------------  Auxiliary+  base -------------------------------------------------------------------------------} -dictFor :: c x => Proxy c -> Proxy x -> LR.Dict c x-dictFor _ _ = LR.Dict+type Constraint = Base.Constraint+type Proxy      = Base.Proxy+type Type       = Base.Type -repFromVector :: SmallArray Any -> LR.Rep LR.I a-repFromVector = coerce+proxy :: forall k (a :: k). Proxy a+proxy = Base.Proxy -repToVector :: LR.Rep LR.I a -> SmallArray Any-repToVector = coerce+{-------------------------------------------------------------------------------+  AnyArray+-------------------------------------------------------------------------------} -smallArrayToList :: SmallArray a -> [a]-smallArrayToList = Foldable.toList+type AnyArray = SmallArray Any -updateSmallArray :: SmallArray a -> [(Int, a)] -> SmallArray a-updateSmallArray v updates = runSmallArray $ do+anyArrayFromList :: [Any] -> AnyArray+anyArrayFromList = smallArrayFromList++anyArrayToList :: AnyArray -> [Any]+anyArrayToList = Foldable.toList++anyArrayIndex :: AnyArray -> Int -> Any+anyArrayIndex = indexSmallArray++anyArrayUpdate :: AnyArray -> [(Int, Any)] -> AnyArray+anyArrayUpdate v updates = runSmallArray $ do     v' <- thawSmallArray v 0 (sizeofSmallArray v)     forM_ updates $ \(i, a) -> do       writeSmallArray v' i a     return v'++{-------------------------------------------------------------------------------+  large-generics: utilities+-------------------------------------------------------------------------------}++anyArrayToRep :: AnyArray -> Rep LR.I a+anyArrayToRep = coerce++anyArrayFromRep :: Rep LR.I a -> AnyArray+anyArrayFromRep = coerce++mkDicts :: [Dict c Any] -> Rep (Dict c) a+mkDicts = LR.Rep . smallArrayFromList++mkDict :: c x => Proxy c -> Proxy x -> Dict c x+mkDict _ _ = LR.Dict++mkStrictField :: forall name a.+     KnownSymbol name+  => Proxy name -> LR.FieldMetadata a+mkStrictField _ = LR.FieldMetadata (Base.Proxy @name) LR.FieldStrict++mkLazyField :: forall name a.+     KnownSymbol name+  => Proxy name -> LR.FieldMetadata a+mkLazyField _ = LR.FieldMetadata (Base.Proxy @name) LR.FieldLazy++mkMetadata ::+     String  -- ^ Record name+  -> String  -- ^ Constructor name+  -> [LR.FieldMetadata Any]+  -> LR.Metadata a+mkMetadata name constr fields = LR.Metadata {+      recordName          = name+    , recordConstructor   = constr+    , recordSize          = length fields+    , recordFieldMetadata = LR.Rep $ smallArrayFromList fields+    }++{-------------------------------------------------------------------------------+  large-generics: wrappers+-------------------------------------------------------------------------------}++type Rep  = LR.Rep+type Dict = LR.Dict++gcompare :: (LR.Generic a, LR.Constraints a Ord) => a -> a -> Ordering+gcompare = LR.gcompare++geq :: (LR.Generic a, LR.Constraints a Eq) => a -> a -> Bool+geq = LR.geq++gshowsPrec :: (LR.Generic a, LR.Constraints a Show) => Int -> a -> ShowS+gshowsPrec = LR.gshowsPrec++noInlineUnsafeCo :: a -> b+noInlineUnsafeCo = LR.noInlineUnsafeCo++{-------------------------------------------------------------------------------+  large-generics: ThroughLRGenerics+-------------------------------------------------------------------------------}++type ThroughLRGenerics = LR.ThroughLRGenerics++wrapThroughLRGenerics :: a -> ThroughLRGenerics a p+wrapThroughLRGenerics = LR.WrapThroughLRGenerics++unwrapThroughLRGenerics :: ThroughLRGenerics a p -> a+unwrapThroughLRGenerics = LR.unwrapThroughLRGenerics

@@ -0,0 +1,33 @@+{-# OPTIONS_GHC -Wno-orphans #-}++module Data.Record.Plugin.WithRDP (+    -- * Annotations+    WithoutRDP.LargeRecordOptions(..)+  , WithoutRDP.largeRecord+    -- * For use by ghc+  , plugin+  ) where++import Control.Monad++import qualified RecordDotPreprocessor as RDP++import Data.Record.Internal.GHC.Shim++import qualified Data.Record.Plugin as WithoutRDP++plugin :: Plugin+plugin = WithoutRDP.plugin <> RDP.plugin++-- | Limited 'Semigroup' instance that defines just enough to combine+-- @large-records@ and @record-dot-preprocessor@+instance Semigroup Plugin where+  p <> q = defaultPlugin {+      parsedResultAction = \args summary ->+            parsedResultAction p args summary+        >=> parsedResultAction q args summary+    , pluginRecompile = \args ->+            (<>)+        <$> pluginRecompile p args+        <*> pluginRecompile q args+    }

@@ -7,6 +7,7 @@ {-# LANGUAGE RecordWildCards           #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-}  {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}@@ -15,6 +16,7 @@ module Test.Record.Sanity.CodeGen (tests) where  import Data.Record.Generic+import Data.Record.Plugin  import Test.Tasty import Test.Tasty.HUnit

@@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TypeApplications          #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-}  {-# OPTIONS_GHC -Wno-unused-top-binds #-}@@ -22,6 +23,8 @@ import GHC.Records.Compat import Test.Tasty import Test.Tasty.HUnit++import Data.Record.Plugin  {-------------------------------------------------------------------------------   Class of kind @Type -> Constraint@.

@@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TemplateHaskell           #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-}  -- The point of this module is to verify that largeRecord does not generate@@ -19,6 +20,8 @@  import Test.Tasty import Test.Tasty.HUnit++import Data.Record.Plugin  {-# ANN type R largeRecord #-} data R a = MkR {

@@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-}  {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}@@ -15,11 +16,12 @@  import Data.Record.Generic.GHC import Generics.Deriving.Show (gshowsPrecdefault, GShow'(..))+import Test.Tasty+import Test.Tasty.HUnit  import qualified GHC.Generics as GHC -import Test.Tasty-import Test.Tasty.HUnit+import Data.Record.Plugin  {-# ANN type R largeRecord #-} data R = MkR { a :: Int }

@@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TypeApplications          #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-}  {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}@@ -21,9 +22,10 @@ import Data.Functor.Const import Data.Kind import GHC.Records.Compat- import Test.Tasty import Test.Tasty.HUnit++import Data.Record.Plugin  type family HKD f a where   HKD Identity  a = a

@@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE StandaloneDeriving        #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-}  {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}@@ -19,13 +20,13 @@   ) where  import Data.Kind-import GHC.TypeLits- import Data.Record.Generic import Data.Record.Generic.LowerBound-+import GHC.TypeLits import Test.Tasty import Test.Tasty.HUnit++import Data.Record.Plugin  newtype T (n :: Nat) (f :: Type -> Type) = MkT (f Word) 

@@ -0,0 +1,31 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE NamedWildCards        #-}+{-# LANGUAGE PolyKinds             #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}++module Test.Record.Sanity.NamedWildCards where++import Data.Record.Plugin++{-# ANN type X largeRecord #-}+data X = MkX { _x :: Int }++{-# ANN type Y largeRecord #-}+data Y a = MkY { _y :: a }++{-# ANN type Z largeRecord #-}+data Z a (b :: a) = MkZ { _z :: a }++{-# ANN type Empty largeRecord #-}+data Empty = MkEmpty {}

@@ -0,0 +1,28 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}++module Test.Record.Sanity.Operators () where++import Data.Kind (Type)++import Data.Record.Plugin++-- Some type family (e.g. servant record-style API def).+type family tag :- route :: Type++{-# ANN type X largeRecord #-}+data X mode = MkX { _fx1 :: (mode :- Int) }++{-# ANN type Y largeRecord #-}+data Y mode = MkY { _fy1 :: mode :- Int }

@@ -0,0 +1,135 @@+{-# LANGUAGE CPP #-}++#if __GLASGOW_HASKELL__ < 902++module Test.Record.Sanity.OverloadedRecordUpdate (tests) where++import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+    testCaseInfo "Test.Record.Sanity.OverloadedRecordUpdate" $+      return "Skipped for ghc < 9.2"++#else++{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE OverloadedRecordDot    #-}+{-# LANGUAGE OverloadedRecordUpdate #-}+{-# LANGUAGE RebindableSyntax       #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}++module Test.Record.Sanity.OverloadedRecordUpdate (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Generic (Rep)+import Data.Record.Generic.Lens.VL+import Data.Record.Overloading+import Data.Record.Plugin++tests :: TestTree+tests = testGroup "Test.Record.Sanity.OverloadedRecordUpdate" [+      testGroup "get" [+          testCase "simple" test_get_simple+        , testCase "nested" test_get_nested+        ]+    , testGroup "set" [+          testCase "simple" test_set_simple+        , testCase "nested" test_set_nested+        ]+    ]++{-------------------------------------------------------------------------------+  Example records+-------------------------------------------------------------------------------}++{-# ANN type Person largeRecord #-}+data Person = Person {+      name :: String+    , age  :: Int+    }+  deriving (Show, Eq)++{-# ANN type Company largeRecord #-}+data Company = Company {+      name :: String+    , ceo  :: Person+    }+  deriving (Show, Eq)++person :: Person+person = Person {+      name = "John Doe"+    , age  = 30+    }++company :: Company+company = Company {+      name = "Sprockets Inc"+    , ceo  = person+    }++{-------------------------------------------------------------------------------+  Sanity check we really are dealing with a large-record here+-------------------------------------------------------------------------------}++_lensesPerson :: Rep (SimpleRecordLens Person) Person+_lensesPerson = lensesForSimpleRecord++_lensesCompany :: Rep (SimpleRecordLens Company) Company+_lensesCompany = lensesForSimpleRecord++{-------------------------------------------------------------------------------+  Get fields+-------------------------------------------------------------------------------}++test_get_simple :: Assertion+test_get_simple = assertEqual "" 30 $ person.age++test_get_nested :: Assertion+test_get_nested = assertEqual "" 30 $ company.ceo.age++{-------------------------------------------------------------------------------+  Set fields+-------------------------------------------------------------------------------}++test_set_simple :: Assertion+test_set_simple =+    assertEqual "" expected $+      person{age = 31}+  where+    expected :: Person+    expected = Person {+          name = "John Doe"+        , age  = 31+        }++test_set_nested :: Assertion+test_set_nested =+    assertEqual "" expected $+      company{ceo.age = 31}+  where+    expected :: Company+    expected = Company {+          name = "Sprockets Inc"+        , ceo  = Person {+              name = "John Doe"+            , age  = 31+            }+        }++#endif

@@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TypeApplications          #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-}  {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}@@ -17,9 +18,10 @@   ) where  import GHC.Records.Compat- import Test.Tasty import Test.Tasty.HUnit++import Data.Record.Plugin  {-------------------------------------------------------------------------------   Simple test case

@@ -8,6 +8,7 @@ {-# LANGUAGE NamedFieldPuns            #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-} {-# LANGUAGE ViewPatterns              #-} @@ -21,6 +22,8 @@ import Data.List (isInfixOf) import Test.Tasty import Test.Tasty.HUnit++import Data.Record.Plugin  import Test.Record.Util 

@@ -5,11 +5,14 @@ {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-}  {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}  module Test.Record.Sanity.QualifiedImports.A (T(..)) where++import Data.Record.Plugin  {-# ANN type T largeRecord #-} data T a = MkT { x :: Int, y :: [a] }

@@ -6,11 +6,14 @@ {-# LANGUAGE MultiParamTypeClasses     #-} {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-}  {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}  module Test.Record.Sanity.QualifiedImports.B (T(..)) where++import Data.Record.Plugin  import qualified Test.Record.Sanity.QualifiedImports.A as A 

@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances     #-}@@ -8,15 +9,18 @@ {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -fplugin=Data.Record.Plugin #-}+{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-}  -- | Test what happens if both plugins are used in the same module module Test.Record.Sanity.RDP.SingleModule (tests) where  import Test.Tasty import Test.Tasty.HUnit++import Data.Record.Plugin  {-------------------------------------------------------------------------------   Simple field selection and override

@@ -3,6 +3,7 @@ {-# LANGUAGE GADTs                 #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-} {-# LANGUAGE DuplicateRecordFields #-} 

@@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables   #-} {-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-}  {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}@@ -21,6 +22,8 @@   , R4_WithLR(..)   , R5_WithLR(..)   ) where++import Data.Record.Plugin  {-# ANN type R1 largeRecord #-} data R1 = MkR1 { r1_x :: Int, r1_y :: Bool }

@@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables       #-} {-# LANGUAGE TypeApplications          #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-}  {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}@@ -16,9 +17,10 @@ module Test.Record.Sanity.RecordConstruction (tests) where  import GHC.Records.Compat- import Test.Tasty import Test.Tasty.HUnit++import Data.Record.Plugin  -- Test that this works if we don't generate field accessors -- See <https://gitlab.haskell.org/ghc/ghc/-/issues/19312>

@@ -10,6 +10,7 @@ {-# LANGUAGE TemplateHaskell           #-} {-# LANGUAGE TypeApplications          #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-}  {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}@@ -17,15 +18,15 @@ module Test.Record.Sanity.Strictness (tests) where  import Control.Exception-import GHC.Records.Compat- import Data.Record.Generic import Data.Record.Generic.LowerBound+import GHC.Records.Compat+import Test.Tasty+import Test.Tasty.HUnit  import qualified Data.Record.Generic.Rep as Rep -import Test.Tasty-import Test.Tasty.HUnit+import Data.Record.Plugin  {-# ANN type Lazy largeRecord #-} data Lazy = MkLazy { lazyField :: Word }

@@ -10,6 +10,7 @@ {-# LANGUAGE TemplateHaskell           #-} {-# LANGUAGE TypeApplications          #-} {-# LANGUAGE TypeFamilies              #-}+{-# LANGUAGE TypeOperators             #-} {-# LANGUAGE UndecidableInstances      #-} {-# LANGUAGE StrictData                #-} @@ -18,15 +19,15 @@ module Test.Record.Sanity.StrictnessStrictData (tests) where  import Control.Exception-import GHC.Records.Compat- import Data.Record.Generic import Data.Record.Generic.LowerBound+import GHC.Records.Compat+import Test.Tasty+import Test.Tasty.HUnit  import qualified Data.Record.Generic.Rep as Rep -import Test.Tasty-import Test.Tasty.HUnit+import Data.Record.Plugin  {-# ANN type Lazy largeRecord #-} data Lazy = MkLazy { lazyField :: ~Word }

@@ -168,6 +168,9 @@   qPutDoc             = \x y -> liftQ $ qPutDoc             x y   qGetDoc             = \x   -> liftQ $ qGetDoc             x #endif+#if MIN_VERSION_template_haskell(2,19,0)+  qGetPackageRoot     =         liftQ $ qGetPackageRoot+#endif  {-------------------------------------------------------------------------------   Internal auxiliary: figure out how TH does error handling

@@ -5,17 +5,18 @@ import qualified Test.Record.Sanity.CodeGen import qualified Test.Record.Sanity.Derive import qualified Test.Record.Sanity.EqualFieldTypes+import qualified Test.Record.Sanity.GhcGenerics import qualified Test.Record.Sanity.HigherKinded import qualified Test.Record.Sanity.HKD+import qualified Test.Record.Sanity.OverloadedRecordUpdate import qualified Test.Record.Sanity.OverloadingNoDRF import qualified Test.Record.Sanity.PatternMatch import qualified Test.Record.Sanity.QualifiedImports-import qualified Test.Record.Sanity.RDP.SplitModule import qualified Test.Record.Sanity.RDP.SingleModule+import qualified Test.Record.Sanity.RDP.SplitModule 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 () main = defaultMain tests@@ -37,5 +38,6 @@         , Test.Record.Sanity.Strictness.tests         , Test.Record.Sanity.StrictnessStrictData.tests         , Test.Record.Sanity.GhcGenerics.tests+        , Test.Record.Sanity.OverloadedRecordUpdate.tests         ]     ]