large-records 0.4.3 → 0.4.4
raw patch · 19 files changed
+894/−385 lines, 19 filesdep +ghc-internaldep +optics-coredep +optics-thdep −ghc-primdep ~basedep ~ghcdep ~template-haskellPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: ghc-internal, optics-core, optics-th
Dependencies removed: ghc-prim
Dependency ranges changed: base, ghc, template-haskell
API changes (from Hackage documentation)
- Data.Record.Plugin.WithRDP: LargeRecordOptions :: Bool -> LargeRecordOptions
- Data.Record.Plugin.WithRDP: [debugLargeRecords] :: LargeRecordOptions -> Bool
- Data.Record.Plugin.WithRDP: data LargeRecordOptions
- Data.Record.Plugin.WithRDP: instance GHC.Base.Semigroup GHC.Driver.Plugins.Plugin
- Data.Record.Plugin.WithRDP: largeRecord :: LargeRecordOptions
- Data.Record.Plugin.WithRDP: plugin :: Plugin
Files
- CHANGELOG.md +7/−0
- large-records.cabal +37/−12
- src/Data/Record/Internal/GHC/Fresh.hs +3/−4
- src/Data/Record/Internal/GHC/Shim.hs +224/−129
- src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs +141/−105
- src/Data/Record/Internal/Plugin/CodeGen.hs +68/−18
- src/Data/Record/Internal/Plugin/Names.hs +117/−104
- src/Data/Record/Internal/Plugin/Options.hs +2/−2
- src/Data/Record/Internal/Plugin/Record.hs +4/−4
- src/Data/Record/Plugin.hs +2/−2
- src/Data/Record/Plugin/Options.hs +0/−0
- test/Test/Record/Sanity/EqualFieldTypes.hs +0/−2
- test/Test/Record/Sanity/GhcGenerics.hs +0/−0
- test/Test/Record/Sanity/NamedWildCards.hs +0/−0
- test/Test/Record/Sanity/Optics/SingleModule.hs +127/−0
- test/Test/Record/Sanity/Optics/SplitModule.hs +106/−0
- test/Test/Record/Sanity/Optics/SplitModule/RecordDef.hs +44/−0
- test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs +0/−1
- test/TestLargeRecords.hs +12/−2
CHANGELOG.md view
@@ -1,5 +1,12 @@ # Revision history for large-records +## 0.4.4 -- 2025-09-19++* Generate `optics-core` `LabelOptic` instances.+* Support for ghc 9.10 and 9.12+* The `rdp` flag now defaults to off; you might wish you enable this if you+ use the `record-dot-preprocessor`.+ ## 0.4.3 -- 2025-07-19 * Support ghc 9.8 (Gabriele Sales)
large-records.cabal view
@@ -1,6 +1,6 @@ cabal-version: 2.4 name: large-records-version: 0.4.3+version: 0.4.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@@ -17,22 +17,29 @@ category: Generics extra-doc-files: CHANGELOG.md tested-with: GHC ==8.10.7+ GHC ==9.0.2 GHC ==9.2.8 GHC ==9.4.8 GHC ==9.6.7 GHC ==9.8.4+ GHC ==9.10.2+ GHC ==9.12.2 source-repository head type: git location: https://github.com/well-typed/large-records +flag rdp+ description: Include @record-dot-preprocessor@ functionality+ manual: True+ default: False+ library exposed-modules: Data.Record.Plugin Data.Record.Plugin.Options Data.Record.Plugin.Runtime- Data.Record.Plugin.WithRDP Data.Record.Overloading other-modules:@@ -48,14 +55,14 @@ Data.Record.Internal.Plugin.Record build-depends:- , base >= 4.14 && < 4.20+ , base >= 4.14 && < 4.22 , containers >= 0.6.2 && < 0.9- , ghc >= 8.10 && < 9.9+ , ghc >= 8.10 && < 9.13 , mtl >= 2.2.1 && < 2.4 , primitive >= 0.7.3 && < 0.10 , record-hasfield >= 1.0 && < 1.1 , syb >= 0.7 && < 0.8- , template-haskell >= 2.16 && < 2.22+ , template-haskell >= 2.16 && < 2.24 -- large-generics 0.2 starts using 'SmallArray' instead of 'Vector' , large-generics >= 0.2 && < 0.3@@ -63,8 +70,13 @@ -- transformers 0.5.6 introduces Writer.CPS , transformers >= 0.5.6 && < 0.7 - -- 0.2.16 introduces support for ghc 9.4- , record-dot-preprocessor >= 0.2.16 && < 0.3++ , optics-core >=0.4.1.1 && <0.5++ if flag(rdp)+ build-depends: record-dot-preprocessor >= 0.2.16 && < 0.3+ exposed-modules: Data.Record.Plugin.WithRDP+ hs-source-dirs: src default-language:@@ -102,29 +114,42 @@ Test.Record.Sanity.QualifiedImports Test.Record.Sanity.QualifiedImports.A Test.Record.Sanity.QualifiedImports.B- Test.Record.Sanity.RDP.SingleModule- Test.Record.Sanity.RDP.SplitModule- Test.Record.Sanity.RDP.SplitModule.RecordDef+ Test.Record.Sanity.Optics.SingleModule+ Test.Record.Sanity.Optics.SplitModule+ Test.Record.Sanity.Optics.SplitModule.RecordDef Test.Record.Sanity.RecordConstruction Test.Record.Sanity.Strictness Test.Record.Sanity.StrictnessStrictData Test.Record.Util + if flag(rdp)+ cpp-options: -DHAS_RDP+ other-modules:+ Test.Record.Sanity.RDP.SingleModule+ Test.Record.Sanity.RDP.SplitModule+ Test.Record.Sanity.RDP.SplitModule.RecordDef+ build-depends: base , large-records , generic-deriving- , ghc-prim , large-generics , mtl , newtype- , record-dot-preprocessor , record-hasfield , tasty , tasty-hunit , template-haskell , transformers+ , optics-core+ , optics-th >=0.4.1 && <0.5++ if impl(ghc >= 9.10)+ build-depends: ghc-internal++ if flag(rdp)+ build-depends: record-dot-preprocessor hs-source-dirs: test default-language:
src/Data/Record/Internal/GHC/Fresh.hs view
@@ -18,12 +18,12 @@ -- * 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 :: ToSrcSpan l => GenLocated l RdrName -> m (GenLocated l RdrName) freshName = freshName' True -- variant which doesn't rename the variable. -- The 'False' variant can be used in types.- freshName' :: Bool -> LRdrName -> m LRdrName+ freshName' :: ToSrcSpan l => Bool -> GenLocated l RdrName -> m (GenLocated l RdrName) newtype Fresh a = WrapFresh { unwrapFresh :: ReaderT NameCacheIO IO a } deriving newtype (Functor, Applicative, Monad)@@ -32,7 +32,7 @@ freshName' pfx (L l name) = WrapFresh $ ReaderT $ \nc -> do newUniq <- takeUniqFromNameCacheIO nc return $ L l $ Exact $- mkInternalName newUniq (newOccName (rdrNameOcc name)) l+ mkInternalName newUniq (newOccName (rdrNameOcc name)) (toSrcSpan l) where -- Even when we generate fresh names, ghc can still complain about name -- shadowing, because this check only considers the 'OccName', not the@@ -51,5 +51,4 @@ runFreshHsc fa = do env <- getHscEnv liftIO $ runFresh fa (hscNameCacheIO env)-
src/Data/Record/Internal/GHC/Shim.hs view
@@ -10,6 +10,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE TypeOperators #-} -- | Thin compatibility layer around GHC --@@ -17,8 +18,7 @@ -- rest of the plugin should not import from any GHC modules directly. module Data.Record.Internal.GHC.Shim ( -- * Names- lookupVarName- , lookupTcName+ thNameToGhcNameHsc -- * Miscellaneous , importDecl@@ -26,19 +26,17 @@ , mkFunBind , HsModule , LHsModule- , LRdrName , pattern GHC.HsModule -- * Annotations #if __GLASGOW_HASKELL__ < 902 , reLoc- , reLocA , noLocA #endif+ , unLoc -- * Extensions , HasDefaultExt(..)- , withDefExt -- * Generalized @forall@ #if __GLASGOW_HASKELL__ >= 900@@ -48,11 +46,14 @@ , hsFunTy , userTyVar , kindedTyVar+#if __GLASGOW_HASKELL__ < 912 , hsTyVarLName+#endif , setDefaultSpecificity -- * Locations , ToSrcSpan(..)+ , FromSrcSpan(..) , InheritLoc(..) , withoutLoc @@ -66,11 +67,19 @@ -- * Records , simpleRecordUpdates+#if __GLASGOW_HASKELL__ >= 912+ , mkAmbiguousFieldOcc+#endif -- * Diagnostics , issueError , issueWarning + -- * Compat+#if __GLASGOW_HASKELL__ >= 910+ , pattern LambdaExpr+#endif+ -- * Re-exports -- The whole-sale module exports are not ideal for preserving compatibility@@ -112,17 +121,15 @@ import BasicTypes (SourceText (NoSourceText)) import ConLike (ConLike) import ErrUtils (mkErrMsg, mkWarnMsg)-import Finder (findImportedModule)-import GHC hiding (AnnKeywordId(..), HsModule, exprType, typeKind, mkFunBind)-import GhcPlugins hiding ((<>), getHscEnv,)+import GHC hiding (AnnKeywordId(..), HsModule, exprType, typeKind, mkFunBind, unLoc)+import GhcPlugins hiding ((<>), getHscEnv, unLoc) import HscMain (getHscEnv)-import IfaceEnv (lookupOrigIO) import NameCache (NameCache(nsUniqs)) import PatSyn (PatSyn) import TcEvidence (HsWrapper(WpHole)) -import qualified GHC-import qualified GhcPlugins as GHC+import qualified GHC hiding (unLoc)+import qualified GhcPlugins as GHC hiding (unLoc) #else @@ -137,7 +144,7 @@ import GHC.Tc.Types.Evidence (HsWrapper(WpHole)) import GHC.Utils.Error (Severity(SevError, SevWarning)) -import GHC.Plugins hiding ((<>), getHscEnv+import GHC.Plugins hiding ((<>), getHscEnv, unLoc #if __GLASGOW_HASKELL__ >= 902 , AnnType, AnnLet, AnnRec, AnnLam, AnnCase , Exception@@ -151,22 +158,17 @@ ) #if __GLASGOW_HASKELL__ < 902-import GHC.Driver.Finder (findImportedModule) import GHC.Parser.Annotation (IsUnicodeSyntax(NormalSyntax)) import GHC.Utils.Error (mkErrMsg, mkWarnMsg) #else import GHC.Types.Fixity import GHC.Types.SourceText (SourceText(NoSourceText), mkIntegralLit)-import GHC.Unit.Finder (findImportedModule, FindResult(Found)) #endif #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 @@ -204,59 +206,56 @@ import GHC.Driver.Config.Diagnostic (initPrintConfig) #endif +import qualified Language.Haskell.TH as TH++-- thNameToGhcNameIO imports+#if !MIN_VERSION_ghc(9,0,0)+import Data.Maybe (listToMaybe)+import IfaceEnv (lookupOrigIO)+import GHC.ThToHs (thRdrNameGuesses)+import MonadUtils (mapMaybeM)+#elif !MIN_VERSION_ghc(9,4,0)+import Data.Maybe (listToMaybe)+import GHC.Iface.Env (lookupOrigIO)+import GHC.ThToHs (thRdrNameGuesses)+import GHC.Utils.Monad (mapMaybeM)+#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-+thNameToGhcNameHsc :: TH.Name -> Hsc Name+thNameToGhcNameHsc th_name = do+ hsc_env <- getHscEnv #if __GLASGOW_HASKELL__ >= 904- let pkgq :: PkgQual- pkgq = renamePkgQual (hsc_unit_env env) modlName mPkgName+ let nameCache = hsc_NC hsc_env #else- let pkgq :: Maybe FastString- pkgq = mPkgName+ let nameCache = hsc_env #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- , "."- ]+ mname <- liftIO $ thNameToGhcNameIO nameCache th_name+ case mname of+ Just name -> return name+ Nothing -> issueError noSrcSpan $ text "Cannot lookup" <+> text (show th_name) -#if __GLASGOW_HASKELL__ >= 904-lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name-lookupOrigIO env modl occ = lookupNameCache (hsc_NC env) modl occ+#if !MIN_VERSION_ghc(9,4,0)+thNameToGhcNameIO :: HscEnv -> TH.Name -> IO (Maybe Name)+thNameToGhcNameIO hscEnv th_name+ = do { names <- mapMaybeM do_lookup (thRdrNameGuesses th_name)+ ; return (listToMaybe names) }+ where+ do_lookup rdr_name+ | Just n <- isExact_maybe rdr_name+ = return $ if isExternalName n then Just n else Nothing+ | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name+#if MIN_VERSION_ghc(9,3,0)+ = Just <$> lookupNameCache (hsc_NC hscEnv) rdr_mod rdr_occ+#else+ = Just <$> lookupOrigIO hscEnv rdr_mod rdr_occ #endif+ | otherwise+ = return Nothing+#endif {------------------------------------------------------------------------------- Miscellaneous@@ -264,7 +263,7 @@ -- | Optionally @qualified@ import declaration importDecl :: Bool -> ModuleName -> LImportDecl GhcPs-importDecl qualified name = reLocA $ noLoc $ ImportDecl {+importDecl qualified name = noLocA $ ImportDecl { #if __GLASGOW_HASKELL__ < 906 ideclExt = defExt #else@@ -277,7 +276,7 @@ #if __GLASGOW_HASKELL__ < 906 , ideclSourceSrc = NoSourceText #endif- , ideclName = reLocA $ noLoc name+ , ideclName = noLocA name #if __GLASGOW_HASKELL__ >= 904 , ideclPkgQual = NoRawPkgQual #else@@ -302,18 +301,18 @@ #endif } -conPat :: Located RdrName -> HsConPatDetails GhcPs -> Pat GhcPs+conPat :: LIdP GhcPs -> HsConPatDetails GhcPs -> Pat GhcPs #if __GLASGOW_HASKELL__ < 900 conPat x y = ConPatIn x y #else-conPat x y = ConPat defExt (reLocA x) y+conPat x y = ConPat defExt x y #endif -mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs+mkFunBind :: LIdP GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs #if __GLASGOW_HASKELL__ >= 908-mkFunBind (reLocA -> n) = GHC.mkFunBind (Generated DoPmc) n+mkFunBind n = GHC.mkFunBind defExt n #else-mkFunBind (reLocA -> n) = GHC.mkFunBind Generated n+mkFunBind n = GHC.mkFunBind Generated n #endif #if __GLASGOW_HASKELL__ < 900@@ -327,7 +326,6 @@ #else type LHsModule = Located HsModule #endif-type LRdrName = Located RdrName {------------------------------------------------------------------------------- NameCache@@ -360,9 +358,6 @@ reLoc :: Located a -> Located a reLoc = id -reLocA :: Located a -> Located a-reLocA = id- noLocA :: e -> Located e noLocA = noLoc @@ -376,15 +371,24 @@ Extensions -------------------------------------------------------------------------------} +-- | This class has evolved to be essentially @class Default a where def :: a@, class HasDefaultExt a where defExt :: a +instance HasDefaultExt (Maybe a) where defExt = Nothing+instance HasDefaultExt [a] where defExt = []+ instance HasDefaultExt NoExtField where defExt = noExtField +instance HasDefaultExt (Bag a) where+ defExt = emptyBag+ #if __GLASGOW_HASKELL__ >= 906+#if __GLASGOW_HASKELL__ < 910 instance HasDefaultExt (LayoutInfo GhcPs) where defExt = NoLayoutInfo+#endif instance HasDefaultExt SourceText where defExt = NoSourceText #elif __GLASGOW_HASKELL__ >= 900@@ -392,8 +396,11 @@ defExt = NoLayoutInfo #endif -#if __GLASGOW_HASKELL__ >= 908+#if __GLASGOW_HASKELL__ >= 910 instance HasDefaultExt GHC.Types.Basic.Origin where+ defExt = Generated OtherExpansion DoPmc+#elif __GLASGOW_HASKELL__ >= 908+instance HasDefaultExt GHC.Types.Basic.Origin where defExt = Generated DoPmc #elif __GLASGOW_HASKELL__ >= 906 instance HasDefaultExt GHC.Types.Basic.Origin where@@ -406,26 +413,57 @@ instance (HasDefaultExt a, HasDefaultExt b, HasDefaultExt c) => HasDefaultExt (a, b, c) where defExt = (defExt, defExt, defExt) -#if __GLASGOW_HASKELL__ >= 902-instance HasDefaultExt (EpAnn ann) where+#if __GLASGOW_HASKELL__ >= 910+instance NoAnn ann => HasDefaultExt (EpAnn ann) where defExt = noAnn +instance HasDefaultExt EpAnnComments where+ defExt = epAnnComments (noAnn @(EpAnn [()]))++#elif __GLASGOW_HASKELL__ >= 902+instance HasDefaultExt (EpAnn ann) where+ defExt = noAnn instance HasDefaultExt AnnSortKey where defExt = NoAnnSortKey- instance HasDefaultExt EpAnnComments where defExt = epAnnComments noAnn #endif --- In GHC-9.2 some things have extension fields.-#if __GLASGOW_HASKELL__ >= 902-withDefExt :: HasDefaultExt a => (a -> b) -> b-withDefExt f = f defExt+#if __GLASGOW_HASKELL__ >= 910+instance HasDefaultExt NoEpAnns where defExt = NoEpAnns+instance HasDefaultExt AnnListItem where defExt = noAnn+instance HasDefaultExt AnnPragma where defExt = noAnn+instance HasDefaultExt AnnContext where defExt = noAnn+instance HasDefaultExt AnnSig where defExt = noAnn+instance HasDefaultExt AnnParen where defExt = noAnn+instance HasDefaultExt EpAnnHsCase where defExt = noAnn+instance HasDefaultExt NameAnn where defExt = noAnn+instance HasDefaultExt (AnnSortKey tag) where defExt = NoAnnSortKey+instance HasDefaultExt EpLayout where defExt = EpNoLayout+instance HasDefaultExt (EpToken t) where defExt = noAnn++#if __GLASGOW_HASKELL__ >= 912+instance NoAnn a => HasDefaultExt (AnnList a) where defExt = noAnn #else-withDefExt :: a -> a-withDefExt a = a+instance HasDefaultExt AnnList where defExt = noAnn #endif +#endif++#if __GLASGOW_HASKELL__ >= 912+instance HasDefaultExt EpAnnLam where defExt = noAnn+instance HasDefaultExt AnnConDeclH98 where defExt = noAnn+instance HasDefaultExt AnnClassDecl where defExt = noAnn+instance HasDefaultExt AnnFunRhs where defExt = noAnn+instance HasDefaultExt AnnClsInstDecl where defExt = noAnn+instance HasDefaultExt AnnDataDefn where defExt = noAnn+instance HasDefaultExt AnnTyVarBndr where defExt = noAnn++instance HasDefaultExt (EpUniToken tok utok) where defExt = NoEpUniTok++instance a ~ [LEpaComment] => HasDefaultExt (EpaLocation' a) where defExt = noAnn+#endif+ {------------------------------------------------------------------------------- Generalized @forall@ in 9.0 -------------------------------------------------------------------------------}@@ -443,58 +481,67 @@ hsFunTy = HsFunTy #elif __GLASGOW_HASKELL__ < 904 hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow NormalSyntax)-#else+#elif __GLASGOW_HASKELL__ < 910 hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow (L NoTokenLoc HsNormalTok))+#else+hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow NoEpUniTok) #endif -userTyVar ::- XUserTyVar GhcPs- -> Located (IdP GhcPs)- -> HsTyVarBndr GhcPs+userTyVar :: LIdP GhcPs -> HsTyVarBndr GhcPs #if __GLASGOW_HASKELL__ < 900-userTyVar = UserTyVar+userTyVar = UserTyVar defExt #elif __GLASGOW_HASKELL__ < 908-userTyVar ext x = UserTyVar ext () (reLocA x)+userTyVar = UserTyVar defExt ()+#elif __GLASGOW_HASKELL__ < 910+userTyVar = UserTyVar defExt HsBndrRequired+#elif __GLASGOW_HASKELL__ < 912+userTyVar = UserTyVar defExt (HsBndrRequired defExt) #else-userTyVar ext x = UserTyVar ext HsBndrRequired (reLocA x)+userTyVar n = HsTvb defExt (HsBndrRequired defExt) (HsBndrVar defExt n) (HsBndrNoKind defExt) #endif -kindedTyVar ::- XKindedTyVar GhcPs- -> Located (IdP GhcPs)- -> LHsKind GhcPs- -> HsTyVarBndr GhcPs+kindedTyVar :: LIdP GhcPs -> LHsKind GhcPs -> HsTyVarBndr GhcPs #if __GLASGOW_HASKELL__ < 900-kindedTyVar = KindedTyVar+kindedTyVar = KindedTyVar defExt #elif __GLASGOW_HASKELL__ < 908-kindedTyVar ext k = KindedTyVar ext () (reLocA k)+kindedTyVar = KindedTyVar defExt ()+#elif __GLASGOW_HASKELL__ < 910+kindedTyVar = KindedTyVar defExt HsBndrRequired+#elif __GLASGOW_HASKELL__ < 912+kindedTyVar = KindedTyVar defExt (HsBndrRequired defExt) #else-kindedTyVar ext k = KindedTyVar ext HsBndrRequired (reLocA k)+kindedTyVar n k = HsTvb defExt (HsBndrRequired defExt) (HsBndrVar defExt n) (HsBndrKind defExt k) #endif +#if __GLASGOW_HASKELL__ < 912 -- | Like 'hsTyVarName', but don't throw away the location information-hsTyVarLName :: HsTyVarBndr GhcPs -> LRdrName+hsTyVarLName :: HsTyVarBndr GhcPs -> Maybe (LIdP GhcPs) #if __GLASGOW_HASKELL__ < 900-hsTyVarLName (UserTyVar _ n ) = n-hsTyVarLName (KindedTyVar _ n _) = n-hsTyVarLName _ = panic "hsTyVarLName"+hsTyVarLName (UserTyVar _ n ) = Just n+hsTyVarLName (KindedTyVar _ n _) = Just n+hsTyVarLName _ = Nothing #else-hsTyVarLName (UserTyVar _ _ n ) = reLoc n-hsTyVarLName (KindedTyVar _ _ n _) = reLoc n+hsTyVarLName (UserTyVar _ _ n ) = Just n+hsTyVarLName (KindedTyVar _ _ n _) = Just n #endif+#endif #if __GLASGOW_HASKELL__ < 900 setDefaultSpecificity :: LHsTyVarBndr pass -> GHC.LHsTyVarBndr pass setDefaultSpecificity = id #else setDefaultSpecificity :: LHsTyVarBndr GhcPs -> GHC.LHsTyVarBndr Specificity GhcPs+#if __GLASGOW_HASKELL__ < 912 setDefaultSpecificity = mapXRec @GhcPs $ \case UserTyVar ext _ name -> UserTyVar ext SpecifiedSpec name KindedTyVar ext _ name kind -> KindedTyVar ext SpecifiedSpec name kind #if __GLASGOW_HASKELL__ < 900 XTyVarBndr ext -> XTyVarBndr ext #endif+#else+setDefaultSpecificity = mapXRec @GhcPs $ \(HsTvb ext _ name kind) -> HsTvb ext SpecifiedSpec name kind #endif+#endif {------------------------------------------------------------------------------- New functionality@@ -552,7 +599,7 @@ instance ToSrcSpan SrcSpan where toSrcSpan = id -#if __GLASGOW_HASKELL__ >= 902+#if 902 <= __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 910 instance ToSrcSpan (SrcSpanAnn' a) where toSrcSpan = locA #endif@@ -563,6 +610,14 @@ instance ToSrcSpan a => ToSrcSpan (NonEmpty a) where toSrcSpan = toSrcSpan . NE.head +#if __GLASGOW_HASKELL__ >= 910+instance ToSrcSpan (EpAnn ann) where+ toSrcSpan x = toSrcSpan (entry x)++instance ToSrcSpan EpaLocation where+ toSrcSpan = getHasLoc+#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@@ -572,17 +627,34 @@ 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+class FromSrcSpan a where+ fromSrcSpan :: SrcSpan -> a -#if __GLASGOW_HASKELL__ >= 902-instance ToSrcSpan x => InheritLoc x a (GenLocated (SrcAnn ann) a) where- inheritLoc = L . SrcSpanAnn defExt . toSrcSpan+instance FromSrcSpan SrcSpan where+ fromSrcSpan = id++#if 902 <= __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 910+instance FromSrcSpan (SrcAnn ann) where+ fromSrcSpan = SrcSpanAnn defExt #endif +#if __GLASGOW_HASKELL__ >= 910+instance HasDefaultExt ann => FromSrcSpan (EpAnn ann) where+ fromSrcSpan s = EpAnn (spanAsAnchor s) defExt emptyComments+#endif++#if __GLASGOW_HASKELL__ >= 912+instance FromSrcSpan (EpaLocation' ann) where+ fromSrcSpan = EpaSpan+#endif++class InheritLoc x a b | b -> a where+ inheritLoc :: x -> a -> b++instance (ToSrcSpan x, FromSrcSpan y) => InheritLoc x a (GenLocated y a) where+ inheritLoc = L . fromSrcSpan . toSrcSpan+ 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@@ -592,6 +664,10 @@ withoutLoc :: InheritLoc SrcSpan a b => a -> b withoutLoc = inheritLoc noSrcSpan +-- GHC-8.10 has weird unLoc definition.+unLoc :: GenLocated l a -> a+unLoc (L _ a) = a+ {------------------------------------------------------------------------------- Records -------------------------------------------------------------------------------}@@ -604,8 +680,13 @@ type RupdFlds = [LHsRecUpdField GhcPs] #endif +#if __GLASGOW_HASKELL__ >= 912+mkAmbiguousFieldOcc :: LIdP GhcPs -> FieldOcc GhcPs+mkAmbiguousFieldOcc = mkFieldOcc+#endif+ -- | Pattern match against the @rupd_flds@ of @RecordUpd@-simpleRecordUpdates :: RupdFlds -> Maybe [(LRdrName, LHsExpr GhcPs)]+simpleRecordUpdates :: RupdFlds -> Maybe [(LIdP GhcPs, LHsExpr GhcPs)] #if __GLASGOW_HASKELL__ >= 904 @@ -622,9 +703,9 @@ #endif where aux :: forall lhs rhs.- (lhs -> Maybe LRdrName)+ (lhs -> Maybe (LIdP GhcPs)) -> LHsFieldBind GhcPs lhs rhs- -> Maybe (LRdrName, rhs)+ -> Maybe (LIdP GhcPs, rhs) aux f (L _ (HsFieldBind { hfbLHS = lbl , hfbRHS = val , hfbPun = pun@@ -632,11 +713,16 @@ guard $ not pun (, val) <$> f lbl - isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName- isUnambigous (Unambiguous _ name) = Just $ reLoc name+#if __GLASGOW_HASKELL__ >= 912+ isUnambigous :: FieldOcc GhcPs -> Maybe (LIdP GhcPs)+ isUnambigous (FieldOcc _ name) = Just name+#else+ isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe (LIdP GhcPs)+ isUnambigous (Unambiguous _ name) = Just name isUnambigous _ = Nothing+#endif - isSingleLabel :: FieldLabelStrings GhcPs -> Maybe LRdrName+ isSingleLabel :: FieldLabelStrings GhcPs -> Maybe (LIdP GhcPs) isSingleLabel (FieldLabelStrings labels) = case labels of #if __GLASGOW_HASKELL__ >= 906@@ -644,7 +730,7 @@ #else [L _ (DotFieldOcc _ (L l label))] -> #endif- Just $ reLoc $ L l (Unqual $ mkVarOccFS label)+ Just $ L l (Unqual $ mkVarOccFS label) _otherwise -> Nothing @@ -656,9 +742,9 @@ Right flds -> mapM (aux isSingleLabel) flds where aux :: forall lhs rhs.- (lhs -> Maybe LRdrName)+ (lhs -> Maybe (LIdP GhcPs)) -> LHsRecField' GhcPs lhs rhs- -> Maybe (LRdrName, rhs)+ -> Maybe (LIdP GhcPs, rhs) aux f (L _ (HsRecField { hsRecFieldLbl = L _ lbl , hsRecFieldArg = val , hsRecPun = pun@@ -666,15 +752,15 @@ guard $ not pun (, val) <$> f lbl - isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName- isUnambigous (Unambiguous _ name) = Just $ reLoc name+ isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe (LIdP GhcPs)+ isUnambigous (Unambiguous _ name) = Just name isUnambigous _ = Nothing - isSingleLabel :: FieldLabelStrings GhcPs -> Maybe LRdrName+ isSingleLabel :: FieldLabelStrings GhcPs -> Maybe (LIdP GhcPs) isSingleLabel (FieldLabelStrings labels) = case labels of [L _ (HsFieldLabel _ (L l label))] ->- Just $ L l (Unqual $ mkVarOccFS label)+ Just $ inheritLoc l (Unqual $ mkVarOccFS label) _otherwise -> Nothing @@ -684,9 +770,9 @@ mapM (aux isUnambigous) where aux :: forall lhs rhs.- (lhs -> Maybe LRdrName)+ (lhs -> Maybe (LIdP GhcPs)) -> LHsRecField' lhs rhs- -> Maybe (LRdrName, rhs)+ -> Maybe (LIdP GhcPs, rhs) aux f (L _ (HsRecField { hsRecFieldLbl = L _ lbl , hsRecFieldArg = val , hsRecPun = pun@@ -694,7 +780,7 @@ guard $ not pun (, val) <$> f lbl - isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName+ isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe (LIdP GhcPs) isUnambigous (Unambiguous _ name) = Just $ reLoc name isUnambigous _ = Nothing @@ -704,7 +790,7 @@ Diagnostics -------------------------------------------------------------------------------} -issueError :: SrcSpan -> SDoc -> Hsc ()+issueError :: SrcSpan -> SDoc -> Hsc a issueError l errMsg = do #if __GLASGOW_HASKELL__ == 902 throwOneError $@@ -769,3 +855,12 @@ where bag :: a -> Bag a bag = listToBag . (:[])++{-------------------------------------------------------------------------------+ Compat+-------------------------------------------------------------------------------}++#if __GLASGOW_HASKELL__ >= 910+pattern LambdaExpr :: HsMatchContext fn+pattern LambdaExpr = LamAlt LamSingle+#endif
src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs view
@@ -101,10 +101,10 @@ , LHsTyVarBndr , LPat , LTyFamInstDecl- , LRdrName ) where import Data.List (foldl')+import Data.Maybe (fromMaybe) import Data.List.NonEmpty (NonEmpty(..)) import qualified Data.List.NonEmpty as NE@@ -115,13 +115,14 @@ Internal auxiliary: types of names -------------------------------------------------------------------------------} -isTermVar, isTermCon, isTypeVar, isTypeCon :: LRdrName -> Bool+isTermVar, isTermCon, isTypeVar, isTypeCon :: GenLocated l RdrName -> Bool isTermVar = checkNameType isVarOcc isTermCon = checkNameType isDataOcc isTypeVar = checkNameType isTvOcc isTypeCon = checkNameType isTcOcc -checkNameType :: (OccName -> Bool) -> LRdrName -> Bool++checkNameType :: (OccName -> Bool) -> GenLocated l RdrName -> Bool checkNameType f (L _ n) = f (rdrNameOcc n) {-------------------------------------------------------------------------------@@ -129,50 +130,50 @@ -------------------------------------------------------------------------------} -- | Equivalent of 'Language.Haskell.TH.Syntax.nameBase'-nameBase :: LRdrName -> String+nameBase :: GenLocated l RdrName -> String nameBase = occNameString . rdrNameOcc . unLoc -- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for expression vars-mkNameExp :: SrcSpan -> String -> LRdrName-mkNameExp l = L l . mkRdrUnqual . mkVarOcc+mkNameExp :: SrcSpan -> String -> LIdP GhcPs+mkNameExp l = inheritLoc l . mkRdrUnqual . mkVarOcc -- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for type vars-mkNameTy :: SrcSpan -> String -> LRdrName-mkNameTy l = L l . mkRdrUnqual . mkTyVarOcc+mkNameTy :: SrcSpan -> String -> LIdP GhcPs+mkNameTy l = inheritLoc l . mkRdrUnqual . mkTyVarOcc -- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for type constructors-mkNameTyCon :: SrcSpan -> String -> LRdrName-mkNameTyCon l = L l . mkRdrUnqual . mkTcOcc+mkNameTyCon :: SrcSpan -> String -> LIdP GhcPs+mkNameTyCon l = inheritLoc l . mkRdrUnqual . mkTcOcc -- | Inverse to 'mkNameExp' -- -- NOTE: Defined in terms of 'nameBase', so discards qualifiers.-viewExpVar :: LRdrName -> Maybe String+viewExpVar :: LIdP GhcPs -> Maybe String viewExpVar n | isTermVar n = Just (nameBase n) viewExpVar _otherwise = Nothing -- | Inverse to 'mkNameTy' -- -- NOTE: Defined in terms of 'nameBase', so discards qualifiers.-viewTyVar :: LRdrName -> Maybe String+viewTyVar :: LIdP GhcPs -> Maybe String viewTyVar n | isTypeVar n = Just (nameBase n) viewTyVar _otherwise = Nothing -- | Inverse to 'mkNameTyCon'-viewTyCon :: LRdrName -> Maybe String+viewTyCon :: LIdP GhcPs -> Maybe String viewTyCon n | isTypeCon n = Just (nameBase n) viewTyCon _otherwise = Nothing --- This patterns are not bidirectional: to construct a LRdrName, we need a+-- This patterns are not bidirectional: to construct a LIdP GhcPs, we need a -- location. We may want to change this somehow. Use a Located String? -pattern ExpVar :: String -> LRdrName+pattern ExpVar :: String -> LIdP GhcPs pattern ExpVar n <- (viewExpVar -> Just n) -pattern TyVar :: String -> LRdrName+pattern TyVar :: String -> LIdP GhcPs pattern TyVar n <- (viewTyVar -> Just n) -pattern TyCon :: String -> LRdrName+pattern TyCon :: String -> LIdP GhcPs pattern TyCon n <- (viewTyCon -> Just n) {-------------------------------------------------------------------------------@@ -180,33 +181,33 @@ -------------------------------------------------------------------------------} -- | Equivalent of 'Language.Haskell.TH.Lib.varE'-varE :: HasCallStack => LRdrName -> LHsExpr GhcPs+varE :: HasCallStack => LIdP GhcPs -> LHsExpr GhcPs varE name- | isTermVar name = inheritLoc name $ HsVar defExt (reLocA name)+ | isTermVar name = inheritLoc name $ HsVar defExt name | otherwise = error "varE: incorrect name type" -- | Inverse to 'varE'-viewVarE :: LHsExpr GhcPs -> Maybe LRdrName-viewVarE (L _ (HsVar _ (reLoc -> name))) | isTermVar name = Just name+viewVarE :: LHsExpr GhcPs -> Maybe (LIdP GhcPs)+viewVarE (L _ (HsVar _ name)) | isTermVar name = Just name viewVarE _ = Nothing -pattern VarE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs+pattern VarE :: HasCallStack => () => LIdP GhcPs -> LHsExpr GhcPs pattern VarE name <- (viewVarE -> Just name) where VarE = varE -- | Equivalent of 'Language.Haskell.TH.Lib.conE'-conE :: HasCallStack => LRdrName -> LHsExpr GhcPs+conE :: HasCallStack => LIdP GhcPs -> LHsExpr GhcPs conE name- | isTermCon name = inheritLoc name $ HsVar defExt (reLocA name)+ | isTermCon name = inheritLoc name $ HsVar defExt name | otherwise = error "conE: incorrect name type" -- | Inverse to 'conE'-viewConE :: LHsExpr GhcPs -> Maybe LRdrName-viewConE (L _ (HsVar _ (reLoc -> name))) | isTermCon name = Just name+viewConE :: LHsExpr GhcPs -> Maybe (LIdP GhcPs)+viewConE (L _ (HsVar _ name)) | isTermCon name = Just name viewConE _ = Nothing -pattern ConE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs+pattern ConE :: HasCallStack => () => LIdP GhcPs -> LHsExpr GhcPs pattern ConE name <- (viewConE -> Just name) where ConE = conE@@ -220,14 +221,19 @@ stringE = litE . HsString NoSourceText . fsLit -- | Equivalent of 'Language.Haskell.TH.Lib.recConE'-recConE :: LRdrName -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs+recConE :: LIdP GhcPs -> [(LIdP GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs recConE = \recName -> mkRec recName . map (uncurry mkFld) where- mkRec :: LRdrName -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs+ mkRec :: LIdP GhcPs -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs mkRec name fields = inheritLoc name $- RecordCon defExt (reLocA name) (HsRecFields fields Nothing)+ RecordCon defExt name (HsRecFields+#if __GLASGOW_HASKELL__ >= 912+ defExt+#endif - mkFld :: LRdrName -> LHsExpr GhcPs -> LHsRecField GhcPs (LHsExpr GhcPs)+ fields Nothing)++ mkFld :: LIdP GhcPs -> LHsExpr GhcPs -> LHsRecField GhcPs (LHsExpr GhcPs) mkFld name val = inheritLoc name $ #if __GLASGOW_HASKELL__ >= 904 HsFieldBind defExt@@ -236,10 +242,10 @@ #else HsRecField #endif- (inheritLoc name (mkFieldOcc (reLocA name))) val False+ (inheritLoc name (mkFieldOcc name)) val False -- | Equivalent of 'Language.Haskell.TH.Lib.recUpdE'-recUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs+recUpdE :: LHsExpr GhcPs -> [(LIdP GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs recUpdE = \recExpr -> updRec recExpr . map (uncurry updFld) where #if __GLASGOW_HASKELL__ >= 908@@ -257,9 +263,9 @@ fields #if __GLASGOW_HASKELL__ >= 908- updFld :: LRdrName -> LHsExpr GhcPs -> LHsRecUpdField GhcPs GhcPs+ updFld :: LIdP GhcPs -> LHsExpr GhcPs -> LHsRecUpdField GhcPs GhcPs #else- updFld :: LRdrName -> LHsExpr GhcPs -> LHsRecUpdField GhcPs+ updFld :: LIdP GhcPs -> LHsExpr GhcPs -> LHsRecUpdField GhcPs #endif updFld name val = inheritLoc name $ #if __GLASGOW_HASKELL__ >= 904@@ -270,16 +276,16 @@ #if __GLASGOW_HASKELL__ >= 902 defExt #endif- (inheritLoc name (mkAmbiguousFieldOcc (reLocA name))) val False+ (inheritLoc name (mkAmbiguousFieldOcc name)) val False viewRecUpdE :: LHsExpr GhcPs- -> Maybe (LHsExpr GhcPs, [(LRdrName, LHsExpr GhcPs)])+ -> Maybe (LHsExpr GhcPs, [(LIdP GhcPs, LHsExpr GhcPs)]) viewRecUpdE (L _ (RecordUpd _ recExpr fields)) = (recExpr,) <$> simpleRecordUpdates fields viewRecUpdE _otherwise = Nothing -pattern RecUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs+pattern RecUpdE :: LHsExpr GhcPs -> [(LIdP GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs pattern RecUpdE recExpr fields <- (viewRecUpdE -> Just (recExpr, fields)) where RecUpdE = recUpdE@@ -299,7 +305,11 @@ -- | Equivalent of 'Language.Haskell.TH.Lib.lamE' lamE :: NonEmpty (LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs lamE pats body = inheritLoc body $- HsLam defExt $+ HsLam defExt+#if __GLASGOW_HASKELL__ >= 910+ LamSingle+#endif+ $ #if __GLASGOW_HASKELL__ >= 906 MG defExt (inheritLoc body [inheritLoc body match]) #else@@ -307,7 +317,7 @@ #endif where match :: Match GhcPs (LHsExpr GhcPs)- match = Match defExt LambdaExpr (NE.toList pats) (simpleGHRSs body)+ match = Match defExt LambdaExpr (inheritLoc pats (NE.toList pats)) (simpleGHRSs body) -- | Convenience wrapper around 'lamE' for a single argument lamE1 :: LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs@@ -324,16 +334,18 @@ where mkAlt :: (LPat GhcPs, LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) mkAlt (pat, body) = inheritLoc x $- Match defExt CaseAlt [pat] (simpleGHRSs body)+ Match defExt CaseAlt (inheritLoc pat [pat]) (simpleGHRSs body) -- | Equivalent of 'Language.Haskell.TH.Lib.appsE' appsE :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs-appsE = foldl' appE+appsE = Data.List.foldl' appE -- prefix to avoid unused import warning. -- | Equivalent of 'Language.Haskell.TH.Lib.appT' appTypeE :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs appTypeE expr typ = inheritLoc expr $-#if __GLASGOW_HASKELL__ >= 906+#if __GLASGOW_HASKELL__ >= 910+ HsAppType defExt expr (HsWC defExt typ)+#elif __GLASGOW_HASKELL__ >= 906 HsAppType noExtField expr noHsTok (HsWC defExt typ) #else HsAppType@@ -383,33 +395,33 @@ litT = noLocA . HsTyLit defExt -- | Equivalent of 'Language.Haskell.TH.Lib.varT'-varT :: HasCallStack => LRdrName -> LHsType GhcPs+varT :: HasCallStack => LIdP GhcPs -> LHsType GhcPs varT name- | isTypeVar name = inheritLoc name (HsTyVar defExt NotPromoted (reLocA name))+ | isTypeVar name = inheritLoc name (HsTyVar defExt NotPromoted name) | otherwise = error "varT: incorrect name type" -- | Inverse to 'varT'-viewVarT :: LHsType GhcPs -> Maybe LRdrName-viewVarT (L _ (HsTyVar _ _ (reLoc -> name))) | isTypeVar name = Just name+viewVarT :: LHsType GhcPs -> Maybe (LIdP GhcPs)+viewVarT (L _ (HsTyVar _ _ name)) | isTypeVar name = Just name viewVarT _otherwise = Nothing -pattern VarT :: HasCallStack => () => LRdrName -> LHsType GhcPs+pattern VarT :: HasCallStack => () => LIdP GhcPs -> LHsType GhcPs pattern VarT name <- (viewVarT -> Just name) where VarT = varT -- | Equivalent of 'Language.Haskell.TH.Lib.conT'-conT :: HasCallStack => LRdrName -> LHsType GhcPs+conT :: HasCallStack => LIdP GhcPs -> LHsType GhcPs conT name- | isTypeCon name = inheritLoc name (HsTyVar defExt NotPromoted (reLocA name))+ | isTypeCon name = inheritLoc name (HsTyVar defExt NotPromoted name) | otherwise = error "varT: incorrect name type" -- | Inverse to 'conT'-viewConT :: LHsType GhcPs -> Maybe LRdrName-viewConT (L _ (HsTyVar _ _ (reLoc -> name))) | isTypeCon name = Just name+viewConT :: LHsType GhcPs -> Maybe (LIdP GhcPs)+viewConT (L _ (HsTyVar _ _ name)) | isTypeCon name = Just name viewConT _otherwise = Nothing -pattern ConT :: HasCallStack => () => LRdrName -> LHsType GhcPs+pattern ConT :: HasCallStack => () => LIdP GhcPs -> LHsType GhcPs pattern ConT name <- (viewConT -> Just name) where ConT = conT@@ -447,18 +459,21 @@ -- TH only provides 'Language.Haskell.TH.Lib.tupleT'. -- Signature by analogy with 'tupE'. tupT :: NonEmpty (LHsType GhcPs) -> LHsType GhcPs+#if __GLASGOW_HASKELL__ >= 912+tupT ts = withoutLoc $ HsExplicitTupleTy defExt NotPromoted (NE.toList ts)+#else tupT ts = inheritLoc ts $ HsExplicitTupleTy defExt (NE.toList ts)-+#endif {------------------------------------------------------------------------------- Patterns -------------------------------------------------------------------------------} -- | Equivalent of 'Language.Haskell.TH.Lib.varP'-varP :: LRdrName -> LPat GhcPs-varP name = inheritLoc name (VarPat defExt (reLocA name))+varP :: LIdP GhcPs -> LPat GhcPs+varP name = inheritLoc name (VarPat defExt name) -- | Equivalent of 'Language.Haskell.TH.Lib.conP'-conP :: LRdrName -> [LPat GhcPs] -> LPat GhcPs+conP :: LIdP GhcPs -> [LPat GhcPs] -> LPat GhcPs #if __GLASGOW_HASKELL__ >= 902 conP con args = inheritLoc con (conPat con (PrefixCon [] args)) #else@@ -486,8 +501,11 @@ -- The GHC API has no equivalent of 'Language.Haskell.TH.Syntax.BangType'. bangType :: LHsType GhcPs -> LHsType GhcPs bangType t = inheritLoc t $+#if __GLASGOW_HASKELL__ >= 912+ HsBangTy defExt (HsBang NoSrcUnpack SrcStrict) t+#else HsBangTy defExt (HsSrcBang NoSourceText NoSrcUnpack SrcStrict) t-+#endif {------------------------------------------------------------------------------- Class contexts -------------------------------------------------------------------------------}@@ -511,11 +529,11 @@ -- -- NOTE: The GHC AST (but not TH) supports declaring multiple record fields -- with the same type. We do not support this here (since we follow TH).-recC :: LRdrName -> [(LRdrName, LHsType GhcPs)] -> LConDecl GhcPs+recC :: LIdP GhcPs -> [(LIdP GhcPs, LHsType GhcPs)] -> LConDecl GhcPs recC = forallRecC [] [] -- | Inverse to 'recC'-viewRecC :: LConDecl GhcPs -> Maybe (LRdrName, [(LRdrName, LHsType GhcPs)])+viewRecC :: LConDecl GhcPs -> Maybe (LIdP GhcPs, [(LIdP GhcPs, LHsType GhcPs)]) viewRecC (L _ ConDeclH98 {@@ -529,9 +547,9 @@ , con_mb_cxt = Nothing , con_args = RecCon (L _ fields) }- ) = (reLoc conName ,) <$> mapM viewRecField fields+ ) = (conName ,) <$> mapM viewRecField fields where- viewRecField :: LConDeclField GhcPs -> Maybe (LRdrName, LHsType GhcPs)+ viewRecField :: LConDeclField GhcPs -> Maybe (LIdP GhcPs, LHsType GhcPs) viewRecField (L _ ConDeclField {@@ -541,14 +559,14 @@ ) = Just $ (viewFieldOcc name, ty) viewRecField _otherwise = Nothing - viewFieldOcc :: FieldOcc GhcPs -> LRdrName- viewFieldOcc (FieldOcc _ (reLoc -> name)) = name+ viewFieldOcc :: FieldOcc GhcPs -> LIdP GhcPs+ viewFieldOcc (FieldOcc _ name) = name #if __GLASGOW_HASKELL__ < 900 viewFieldOcc _ = panic "viewFieldOcc" #endif viewRecC _otherwise = Nothing -pattern RecC :: LRdrName -> [(LRdrName, LHsType GhcPs)] -> LConDecl GhcPs+pattern RecC :: LIdP GhcPs -> [(LIdP GhcPs, LHsType GhcPs)] -> LConDecl GhcPs pattern RecC conName args <- (viewRecC -> Just (conName, args)) where RecC = recC@@ -556,14 +574,14 @@ -- | Equivalent of the combination of 'Language.Haskell.TH.Lib.forallC' and -- 'Language.Haskell.TH.Lib.recC'. forallRecC ::- [LRdrName] -- ^ @forallC@ argument: bound type variables- -> [LHsType GhcPs] -- ^ @forallC@ argument: context- -> LRdrName -- ^ @recC@ argument: record constructor name- -> [(LRdrName, LHsType GhcPs)] -- ^ @recC@ argument: record fields+ [LIdP GhcPs] -- ^ @forallC@ argument: bound type variables+ -> [LHsType GhcPs] -- ^ @forallC@ argument: context+ -> LIdP GhcPs -- ^ @recC@ argument: record constructor name+ -> [(LIdP GhcPs, LHsType GhcPs)] -- ^ @recC@ argument: record fields -> LConDecl GhcPs forallRecC vars ctxt conName args = inheritLoc conName $ ConDeclH98 { con_ext = defExt- , con_name = reLocA conName+ , con_name = conName , con_forall = inheritLoc conName True , con_ex_tvs = map (setDefaultSpecificity . mkBndr) vars , con_mb_cxt = Just (inheritLoc conName ctxt)@@ -571,13 +589,13 @@ , con_doc = Nothing } where- mkBndr :: LRdrName -> LHsTyVarBndr GhcPs- mkBndr name = inheritLoc name $ userTyVar defExt name+ mkBndr :: LIdP GhcPs -> LHsTyVarBndr GhcPs+ mkBndr name = inheritLoc name $ userTyVar name - mkRecField :: LRdrName -> LHsType GhcPs -> LConDeclField GhcPs+ mkRecField :: LIdP GhcPs -> LHsType GhcPs -> LConDeclField GhcPs mkRecField name ty = inheritLoc name $ ConDeclField { cd_fld_ext = defExt- , cd_fld_names = [inheritLoc name $ mkFieldOcc $ reLocA name]+ , cd_fld_names = [inheritLoc name $ mkFieldOcc name] , cd_fld_type = ty , cd_fld_doc = Nothing }@@ -587,37 +605,37 @@ -------------------------------------------------------------------------------} -- | Equivalent of 'Language.Haskell.TH.Lib.kindedTV'-kindedTV :: LRdrName -> LHsType GhcPs -> LHsTyVarBndr GhcPs-kindedTV name ty = inheritLoc name (kindedTyVar defExt name ty)+kindedTV :: LIdP GhcPs -> LHsType GhcPs -> LHsTyVarBndr GhcPs+kindedTV name ty = inheritLoc name (kindedTyVar name ty) {------------------------------------------------------------------------------- .. without direct equivalent -------------------------------------------------------------------------------} -tyVarBndrName :: LHsTyVarBndr GhcPs -> LRdrName-tyVarBndrName = hsTyVarLName . unLoc+tyVarBndrName :: LHsTyVarBndr GhcPs -> LIdP GhcPs+tyVarBndrName = fromMaybe (error "tyVarBndrName: Nothing") . hsTyVarLName . unLoc {------------------------------------------------------------------------------- Top-level declarations -------------------------------------------------------------------------------} -- | Equivalent of 'Language.Haskell.TH.Lib.sigD'-sigD :: LRdrName -> LHsType GhcPs -> LHsDecl GhcPs+sigD :: LIdP GhcPs -> LHsType GhcPs -> LHsDecl GhcPs sigD name ty = inheritLoc name $ SigD defExt sig where sig :: Sig GhcPs- sig = TypeSig defExt [reLocA name] $ HsWC defExt (implicitBndrs ty)+ sig = TypeSig defExt [name] $ HsWC defExt (implicitBndrs ty) -- | Equivalent of 'Language.Haskell.TH.Lib.valD' -- -- Currently this offers a simplified API only.-valD :: LRdrName -> LHsExpr GhcPs -> LHsDecl GhcPs+valD :: LIdP GhcPs -> LHsExpr GhcPs -> LHsDecl GhcPs valD fnName body = inheritLoc fnName $ ValD defExt (unLoc (simpleBinding fnName body)) -- | Equivalent of 'Language.Haskell.TH.Lib.dataD' dataD ::- LRdrName -- ^ Datatype name+ LIdP GhcPs -- ^ Datatype name -> [LHsTyVarBndr GhcPs] -- ^ Type arguments -> [LConDecl GhcPs] -- ^ Constructors -> [LHsDerivingClause GhcPs] -- ^ Deriving clauses@@ -625,7 +643,7 @@ dataD typeName tyVars cons derivs = inheritLoc typeName $ TyClD defExt $ DataDecl { tcdDExt = defExt- , tcdLName = reLocA typeName+ , tcdLName = typeName , tcdTyVars = mkHsQTvs tyVars , tcdFixity = Prefix , tcdDataDefn = HsDataDefn {@@ -654,7 +672,7 @@ viewDataD :: LHsDecl GhcPs -> Maybe (- LRdrName+ LIdP GhcPs , [LHsTyVarBndr GhcPs] , [LConDecl GhcPs] , [LHsDerivingClause GhcPs]@@ -691,11 +709,11 @@ } } )- ) = Just (reLoc typeName, tyVars, cons, derivs)+ ) = Just (typeName, tyVars, cons, derivs) viewDataD _otherwise = Nothing pattern DataD ::- LRdrName+ LIdP GhcPs -> [LHsTyVarBndr GhcPs] -> [LConDecl GhcPs] -> [LHsDerivingClause GhcPs]@@ -749,14 +767,18 @@ instanceD :: [LHsType GhcPs] -- ^ Context -> LHsType GhcPs -- ^ Head- -> [(LRdrName, LHsExpr GhcPs)] -- ^ Bindings+ -> [(LIdP GhcPs, LHsExpr GhcPs)] -- ^ Bindings -> [LTyFamInstDecl GhcPs] -- ^ Associated types -> LHsDecl GhcPs instanceD ctxt hd binds assocTypes = inheritLoc hd $ InstD defExt $ ClsInstD defExt $ ClsInstDecl { cid_ext = defExt , cid_poly_ty = implicitBndrs (qualT ctxt hd)+#if __GLASGOW_HASKELL__ >= 912+ , cid_binds = map (uncurry simpleBinding) binds+#else , cid_binds = listToBag $ map (uncurry simpleBinding) binds+#endif , cid_sigs = [] , cid_tyfam_insts = assocTypes , cid_datafam_insts = []@@ -777,40 +799,42 @@ -- | Equivalent of 'Language.Haskell.TH.Lib.classD' classD ::- [LHsType GhcPs] -- ^ Class context- -> LRdrName -- ^ Class name- -> [LHsTyVarBndr GhcPs] -- ^ Type variables- -> [(LRdrName, LHsType GhcPs)] -- ^ Method signatures+ [LHsType GhcPs] -- ^ Class context+ -> LIdP GhcPs -- ^ Class name+ -> [LHsTyVarBndr GhcPs] -- ^ Type variables+ -> [(LIdP GhcPs, LHsType GhcPs)] -- ^ Method signatures -> LHsDecl GhcPs classD = \ctx name clsVars sigs -> inheritLoc name $ TyClD defExt $ ClassDecl { tcdCExt = defExt #if __GLASGOW_HASKELL__ >= 906+#if __GLASGOW_HASKELL__ < 910 , tcdLayout = NoLayoutInfo #endif+#endif #if __GLASGOW_HASKELL__ >= 902 , tcdCtxt = Just (inheritLoc name ctx) #else , tcdCtxt = inheritLoc name ctx #endif- , tcdLName = reLocA name+ , tcdLName = name , tcdTyVars = mkHsQTvs clsVars , tcdFixity = Prefix , tcdFDs = [] , tcdSigs = map (uncurry classOpSig) sigs- , tcdMeths = emptyBag+ , tcdMeths = defExt , tcdATs = [] , tcdATDefs = [] , tcdDocs = [] } where- classOpSig :: LRdrName -> LHsType GhcPs -> LSig GhcPs+ classOpSig :: LIdP GhcPs -> LHsType GhcPs -> LSig GhcPs classOpSig name ty = inheritLoc name $- ClassOpSig defExt False [reLocA name] (implicitBndrs ty)+ ClassOpSig defExt False [name] (implicitBndrs ty) -- | Approximate equivalent of 'Language.Haskell.TH.Lib.tySynEqn' tySynEqn ::- LRdrName -- ^ Type family name+ LIdP GhcPs -- ^ Type family name -> [LHsType GhcPs] -- ^ Equation LHS -> LHsType GhcPs -- ^ Equation RHS -> LTyFamInstDecl GhcPs@@ -822,20 +846,24 @@ $ implicitBndrs $ #endif FamEqn defExt- (reLocA name)+ name #if __GLASGOW_HASKELL__ >= 902 (HsOuterImplicit defExt) #else Nothing #endif+#if __GLASGOW_HASKELL__ >= 910+ (map (HsValArg defExt) pats)+#else (map HsValArg pats)+#endif Prefix val {------------------------------------------------------------------------------- Pragmas - NOTE: We work with 'LRdrName' everywhere, but 'AnnProvenance' /already/ wraps+ NOTE: We work with 'LIdP GhcPs' everywhere, but 'AnnProvenance' /already/ wraps the @name@ type in @Located@. -------------------------------------------------------------------------------} @@ -847,15 +875,15 @@ #endif -- | Equivalent of 'Language.Haskell.TH.Lib.typeAnnotation'-typeAnnotation :: LRdrName -> AnnProvenancePs-typeAnnotation name = TypeAnnProvenance (reLocA name)+typeAnnotation :: LIdP GhcPs -> AnnProvenancePs+typeAnnotation name = TypeAnnProvenance name -- | Inverse to 'typeAnnotation'-viewTypeAnnotation :: AnnProvenancePs -> Maybe LRdrName-viewTypeAnnotation (TypeAnnProvenance name) = Just (reLoc name)+viewTypeAnnotation :: AnnProvenancePs -> Maybe (LIdP GhcPs)+viewTypeAnnotation (TypeAnnProvenance name) = Just name viewTypeAnnotation _otherwise = Nothing -pattern TypeAnnotation :: LRdrName -> AnnProvenancePs+pattern TypeAnnotation :: LIdP GhcPs -> AnnProvenancePs pattern TypeAnnotation name <- (viewTypeAnnotation -> Just name) where TypeAnnotation = typeAnnotation@@ -911,7 +939,7 @@ #endif -- | Simple binding (without patterns)-simpleBinding :: LRdrName -> LHsExpr GhcPs -> LHsBind GhcPs+simpleBinding :: LIdP GhcPs -> LHsExpr GhcPs -> LHsBind GhcPs simpleBinding fnName body = inheritLoc fnName $ mkFunBind fnName [match] where@@ -921,8 +949,16 @@ match :: LMatch GhcPs (LHsExpr GhcPs) match = inheritLoc fnName $ Match defExt- (FunRhs (reLocA fnName) Prefix NoSrcStrict)+#if __GLASGOW_HASKELL__ >= 912+ (FunRhs fnName Prefix NoSrcStrict defExt)+#else+ (FunRhs fnName Prefix NoSrcStrict)+#endif+#if __GLASGOW_HASKELL__ >= 912+ (withoutLoc [])+#else []+#endif grhs -- | Simple guarded RHS (no guards)
src/Data/Record/Internal/Plugin/CodeGen.hs view
@@ -36,6 +36,7 @@ , genUnsafeSetIndex names r , genStockInstances names r , mapM (genHasFieldInstance names r) recordFields+ , mapM (genLabelOpticInstance names r) recordFields , sequence [ genConstraintsClass names r , genConstraintsInstance names r@@ -105,25 +106,36 @@ (zipWith fieldExistentialType vars recordFields) ]- [ DerivClause (Just (withoutLoc (withDefExt AnyclassStrategy))) (c :| [])+ [ DerivClause (Just (withoutLoc strategy)) (c :| []) | DeriveAnyClass c <- recordDerivings ] where+#if __GLASGOW_HASKELL__ >= 902+ strategy = AnyclassStrategy defExt+#else+ strategy = AnyclassStrategy+#endif+ -- There is no need to generate fresh va riables here, as these type vars -- cannot clash with anything else (no other type vars can be in scope).- vars :: [LRdrName]+ vars :: [LIdP GhcPs] vars = [ mkNameTy recordAnnLoc ("lr_f" <> show i) | (i, _) <- zip [1 :: Int ..] recordFields ] optionalBang :: HsSrcBang -> LHsType GhcPs -> LHsType GhcPs- optionalBang bang = noLocA . HsBangTy defExt bang+ optionalBang bang = noLocA . HsBangTy defExt+#if __GLASGOW_HASKELL__ >= 912+ (case bang of HsSrcBang _ b -> b)+#else+ bang+#endif - fieldContext :: LRdrName -> Field -> LHsType GhcPs+ fieldContext :: LIdP GhcPs -> Field -> LHsType GhcPs fieldContext var fld = equalP (VarT var) (fieldType fld) - fieldExistentialType :: LRdrName -> Field -> (LRdrName, LHsType GhcPs)+ fieldExistentialType :: LIdP GhcPs -> Field -> (LIdP GhcPs, LHsType GhcPs) fieldExistentialType var fld = (fieldName fld, optionalBang (fieldStrictness fld) $ VarT var) -- | Generate conversion to and from an array@@ -180,7 +192,7 @@ ) ] where- name :: LRdrName+ name :: LIdP GhcPs name = nameVectorFrom r toVector :: m [LHsDecl GhcPs]@@ -209,7 +221,7 @@ ] ] where- name :: LRdrName+ name :: LIdP GhcPs name = nameVectorTo r matchErr :: String@@ -260,7 +272,7 @@ ) ] where- name :: LRdrName+ name :: LIdP GhcPs name = nameUnsafeGetIndex r -- | Generate index field overwrite@@ -304,7 +316,7 @@ ) ] where- name :: LRdrName+ name :: LIdP GhcPs name = nameUnsafeSetIndex r -- | Generate 'HasField' instance for single field@@ -338,6 +350,40 @@ ] [] +-- | Generate 'LabelOptic' instance for a single field+--+-- Generates something like+--+-- > instance (x ~ Word, y ~ Word) => LabelOptic "tInt" A_Lens (T a b) (T a b) x y where+-- > labelOptic = lens (unsafeGetIndexT 0) (unsafeSetIndexT 0)+genLabelOpticInstance :: MonadFresh m+ => QualifiedNames+ -> Record -> Field -> m (LHsDecl GhcPs)+genLabelOpticInstance QualifiedNames{..} r@Record{..} Field{..} = do+ x <- freshName' False $ mkNameTy recordAnnLoc "x"+ y <- freshName' False $ mkNameTy recordAnnLoc "y"+ return $+ instanceD+ [equalP (VarT x) fieldType, equalP (VarT y) fieldType]+ (appsT+ (ConT type_LabelOptic)+ [ stringT (nameBase fieldName)+ , ConT type_A_Lens+ , recordTypeT r+ , recordTypeT r+ , VarT x+ , VarT y+ ]+ )+ [ ( labelOptic+ , appsE (VarE lens)+ [ appsE (VarE (nameUnsafeGetIndex r)) [intE fieldIndex]+ , appsE (VarE (nameUnsafeSetIndex r)) [intE fieldIndex]+ ]+ )+ ]+ []+ {------------------------------------------------------------------------------- Generics -------------------------------------------------------------------------------}@@ -440,7 +486,7 @@ (VarE mkDicts) (listE (map (dictForField p) recordFields)) where- dictForField :: LRdrName -> Field -> LHsExpr GhcPs+ dictForField :: LIdP GhcPs -> Field -> LHsExpr GhcPs dictForField p Field{..} = appE (VarE noInlineUnsafeCo)@@ -508,7 +554,11 @@ $ stringT (nameBase fieldName) isStrict :: DynFlags -> HsSrcBang -> Bool+#if __GLASGOW_HASKELL__ >= 912+isStrict dynFlags (HsSrcBang _ (HsBang _ strictness)) =+#else isStrict dynFlags (HsSrcBang _ _ strictness) =+#endif case strictness of SrcStrict -> True SrcLazy -> False@@ -626,7 +676,7 @@ Ord -> [mkInstance prelude_type_Ord prelude_compare gcompare ] Generic -> [] where- mkInstance :: LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs+ mkInstance :: LIdP GhcPs -> LIdP GhcPs -> LIdP GhcPs -> LHsDecl GhcPs mkInstance cls mthd gen = instanceD (genRequiredConstraints r (ConT cls))@@ -680,15 +730,15 @@ nameRecord Record{..} = nameBase recordTyName -- | Make name derived from the name of the record-mkDerived :: (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName+mkDerived :: (SrcSpan -> String -> LIdP GhcPs) -> String -> Record -> LIdP GhcPs mkDerived f prefix r = f (recordAnnLoc r) (prefix <> nameRecord r) -nameVectorFrom :: Record -> LRdrName-nameVectorTo :: Record -> LRdrName-nameUnsafeGetIndex :: Record -> LRdrName-nameUnsafeSetIndex :: Record -> LRdrName-nameConstraints :: Record -> LRdrName-nameDictConstraints :: Record -> LRdrName+nameVectorFrom :: Record -> LIdP GhcPs+nameVectorTo :: Record -> LIdP GhcPs+nameUnsafeGetIndex :: Record -> LIdP GhcPs+nameUnsafeSetIndex :: Record -> LIdP GhcPs+nameConstraints :: Record -> LIdP GhcPs+nameDictConstraints :: Record -> LIdP GhcPs nameVectorFrom = mkDerived mkNameExp "vectorFrom" nameVectorTo = mkDerived mkNameExp "vectorTo"
src/Data/Record/Internal/Plugin/Names.hs view
@@ -1,5 +1,7 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskellQuotes #-} module Data.Record.Internal.Plugin.Names ( QualifiedNames(..)@@ -9,6 +11,13 @@ import Prelude hiding (error) import Data.Record.Internal.GHC.Shim +import qualified Data.Record.Plugin.Runtime as Runtime+import qualified GHC.Generics+import qualified Data.Record.Generic+import qualified GHC.Records.Compat+import qualified Optics.Core+import qualified Optics.Label+ {------------------------------------------------------------------------------- Qualified names -------------------------------------------------------------------------------}@@ -19,81 +28,88 @@ -- Prelude type classes -- - prelude_type_Eq :: LRdrName- , prelude_type_Ord :: LRdrName- , prelude_type_Show :: LRdrName- , prelude_compare :: LRdrName- , prelude_eq :: LRdrName- , prelude_showsPrec :: LRdrName+ prelude_type_Eq :: LIdP GhcPs+ , prelude_type_Ord :: LIdP GhcPs+ , prelude_type_Show :: LIdP GhcPs+ , prelude_compare :: LIdP GhcPs+ , prelude_eq :: LIdP GhcPs+ , prelude_showsPrec :: LIdP GhcPs -- -- Other base -- - , type_Constraint :: LRdrName- , type_GHC_Generic :: LRdrName- , type_GHC_Rep :: LRdrName- , type_Int :: LRdrName- , type_Proxy :: LRdrName- , type_Type :: LRdrName- , error :: LRdrName- , ghc_from :: LRdrName- , ghc_to :: LRdrName- , proxy :: LRdrName+ , type_Constraint :: LIdP GhcPs+ , type_GHC_Generic :: LIdP GhcPs+ , type_GHC_Rep :: LIdP GhcPs+ , type_Int :: LIdP GhcPs+ , type_Proxy :: LIdP GhcPs+ , type_Type :: LIdP GhcPs+ , error :: LIdP GhcPs+ , ghc_from :: LIdP GhcPs+ , ghc_to :: LIdP GhcPs+ , proxy :: LIdP GhcPs -- -- AnyArray -- - , type_AnyArray :: LRdrName- , anyArrayFromList :: LRdrName- , anyArrayToList :: LRdrName- , anyArrayIndex :: LRdrName- , anyArrayUpdate :: LRdrName+ , type_AnyArray :: LIdP GhcPs+ , anyArrayFromList :: LIdP GhcPs+ , anyArrayToList :: LIdP GhcPs+ , anyArrayIndex :: LIdP GhcPs+ , anyArrayUpdate :: LIdP GhcPs -- -- 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+ , type_LR_Generic :: LIdP GhcPs+ , type_LR_MetadataOf :: LIdP GhcPs+ , type_LR_Constraints :: LIdP GhcPs+ , lr_from :: LIdP GhcPs+ , lr_to :: LIdP GhcPs+ , lr_dict :: LIdP GhcPs+ , lr_metadata :: LIdP GhcPs -- .. wrappers - , type_Rep :: LRdrName- , type_Dict :: LRdrName- , gcompare :: LRdrName- , geq :: LRdrName- , gshowsPrec :: LRdrName- , noInlineUnsafeCo :: LRdrName+ , type_Rep :: LIdP GhcPs+ , type_Dict :: LIdP GhcPs+ , gcompare :: LIdP GhcPs+ , geq :: LIdP GhcPs+ , gshowsPrec :: LIdP GhcPs+ , noInlineUnsafeCo :: LIdP GhcPs -- .. utilities - , anyArrayToRep :: LRdrName- , anyArrayFromRep :: LRdrName- , mkDicts :: LRdrName- , mkDict :: LRdrName- , mkStrictField :: LRdrName- , mkLazyField :: LRdrName- , mkMetadata :: LRdrName+ , anyArrayToRep :: LIdP GhcPs+ , anyArrayFromRep :: LIdP GhcPs+ , mkDicts :: LIdP GhcPs+ , mkDict :: LIdP GhcPs+ , mkStrictField :: LIdP GhcPs+ , mkLazyField :: LIdP GhcPs+ , mkMetadata :: LIdP GhcPs -- .. ThroughLRGenerics - , type_ThroughLRGenerics :: LRdrName- , wrapThroughLRGenerics :: LRdrName- , unwrapThroughLRGenerics :: LRdrName+ , type_ThroughLRGenerics :: LIdP GhcPs+ , wrapThroughLRGenerics :: LIdP GhcPs+ , unwrapThroughLRGenerics :: LIdP GhcPs -- -- record-hasfield -- - , type_HasField :: LRdrName- , hasField :: LRdrName+ , type_HasField :: LIdP GhcPs+ , hasField :: LIdP GhcPs++ -- optics++ , type_LabelOptic :: LIdP GhcPs+ , type_A_Lens :: LIdP GhcPs+ , labelOptic :: LIdP GhcPs+ , lens :: LIdP GhcPs } -- | Resolve qualified names@@ -118,94 +134,91 @@ -- we cannot declare instances of type aliased classes. -- - prelude_type_Eq <- exact <$> lookupTcName ghcClasses (Just "ghc-prim") "Eq"- prelude_type_Ord <- exact <$> lookupTcName ghcClasses (Just "ghc-prim") "Ord"- prelude_type_Show <- exact <$> lookupTcName ghcShow Nothing "Show"- prelude_compare <- exact <$> lookupVarName ghcClasses (Just "ghc-prim") "compare"- prelude_eq <- exact <$> lookupVarName ghcClasses (Just "ghc-prim") "=="- prelude_showsPrec <- exact <$> lookupVarName ghcShow Nothing "showsPrec"+ prelude_type_Eq <- exact <$> thNameToGhcNameHsc ''Eq+ prelude_type_Ord <- exact <$> thNameToGhcNameHsc ''Ord+ prelude_type_Show <- exact <$> thNameToGhcNameHsc ''Show+ prelude_compare <- exact <$> thNameToGhcNameHsc 'compare+ prelude_eq <- exact <$> thNameToGhcNameHsc '(==)+ prelude_showsPrec <- exact <$> thNameToGhcNameHsc 'showsPrec -- -- Other 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"- type_Int <- exact <$> lookupTcName runtime Nothing "Int"- error <- exact <$> lookupVarName runtime Nothing "error"- ghc_from <- exact <$> lookupVarName ghcGenerics Nothing "from"- ghc_to <- exact <$> lookupVarName ghcGenerics Nothing "to"- proxy <- exact <$> lookupVarName runtime Nothing "proxy"+ type_Constraint <- exact <$> thNameToGhcNameHsc ''Runtime.Constraint+ type_GHC_Generic <- exact <$> thNameToGhcNameHsc ''GHC.Generics.Generic+ type_GHC_Rep <- exact <$> thNameToGhcNameHsc ''GHC.Generics.Rep+ type_Proxy <- exact <$> thNameToGhcNameHsc ''Runtime.Proxy+ type_Type <- exact <$> thNameToGhcNameHsc ''Runtime.Type+ type_Int <- exact <$> thNameToGhcNameHsc ''Runtime.Int+ error <- exact <$> thNameToGhcNameHsc 'Runtime.error+ ghc_from <- exact <$> thNameToGhcNameHsc 'GHC.Generics.from+ ghc_to <- exact <$> thNameToGhcNameHsc 'GHC.Generics.to+ proxy <- exact <$> thNameToGhcNameHsc 'Runtime.proxy -- -- 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"+ type_AnyArray <- exact <$> thNameToGhcNameHsc ''Runtime.AnyArray+ anyArrayFromList <- exact <$> thNameToGhcNameHsc 'Runtime.anyArrayFromList+ anyArrayToList <- exact <$> thNameToGhcNameHsc 'Runtime.anyArrayToList+ anyArrayIndex <- exact <$> thNameToGhcNameHsc 'Runtime.anyArrayIndex+ anyArrayUpdate <- exact <$> thNameToGhcNameHsc 'Runtime.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"+ type_LR_Generic <- exact <$> thNameToGhcNameHsc ''Data.Record.Generic.Generic+ type_LR_Constraints <- exact <$> thNameToGhcNameHsc ''Data.Record.Generic.Constraints+ type_LR_MetadataOf <- exact <$> thNameToGhcNameHsc ''Data.Record.Generic.MetadataOf+ lr_from <- exact <$> thNameToGhcNameHsc 'Data.Record.Generic.from+ lr_to <- exact <$> thNameToGhcNameHsc 'Data.Record.Generic.to+ lr_dict <- exact <$> thNameToGhcNameHsc 'Data.Record.Generic.dict+ lr_metadata <- exact <$> thNameToGhcNameHsc 'Data.Record.Generic.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"+ anyArrayToRep <- exact <$> thNameToGhcNameHsc 'Runtime.anyArrayToRep+ anyArrayFromRep <- exact <$> thNameToGhcNameHsc 'Runtime.anyArrayFromRep+ mkDicts <- exact <$> thNameToGhcNameHsc 'Runtime.mkDicts+ mkDict <- exact <$> thNameToGhcNameHsc 'Runtime.mkDict+ mkStrictField <- exact <$> thNameToGhcNameHsc 'Runtime.mkStrictField+ mkLazyField <- exact <$> thNameToGhcNameHsc 'Runtime.mkLazyField+ mkMetadata <- exact <$> thNameToGhcNameHsc 'Runtime.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"+ type_Rep <- exact <$> thNameToGhcNameHsc ''Runtime.Rep+ type_Dict <- exact <$> thNameToGhcNameHsc ''Runtime.Dict+ gcompare <- exact <$> thNameToGhcNameHsc 'Runtime.gcompare+ geq <- exact <$> thNameToGhcNameHsc 'Runtime.geq+ gshowsPrec <- exact <$> thNameToGhcNameHsc 'Runtime.gshowsPrec+ noInlineUnsafeCo <- exact <$> thNameToGhcNameHsc 'Runtime.noInlineUnsafeCo -- .. ThroughLRGenerics - type_ThroughLRGenerics <- exact <$> lookupTcName runtime Nothing "ThroughLRGenerics"- wrapThroughLRGenerics <- exact <$> lookupVarName runtime Nothing "wrapThroughLRGenerics"- unwrapThroughLRGenerics <- exact <$> lookupVarName runtime Nothing "unwrapThroughLRGenerics"+ type_ThroughLRGenerics <- exact <$> thNameToGhcNameHsc ''Runtime.ThroughLRGenerics+ wrapThroughLRGenerics <- exact <$> thNameToGhcNameHsc 'Runtime.wrapThroughLRGenerics+ unwrapThroughLRGenerics <- exact <$> thNameToGhcNameHsc 'Runtime.unwrapThroughLRGenerics -- -- record-hasfield -- - type_HasField <- exact <$> lookupTcName recordHasField (Just "record-hasfield") "HasField"- hasField <- exact <$> lookupVarName recordHasField (Just "record-hasfield") "hasField"+ type_HasField <- exact <$> thNameToGhcNameHsc ''GHC.Records.Compat.HasField+ hasField <- exact <$> thNameToGhcNameHsc 'GHC.Records.Compat.hasField - return QualifiedNames{..}+ -- optics - where- exact :: Name -> LRdrName- exact = noLoc . Exact+ type_LabelOptic <- exact <$> thNameToGhcNameHsc ''Optics.Label.LabelOptic+ labelOptic <- exact <$> thNameToGhcNameHsc 'Optics.Label.labelOptic+ type_A_Lens <- exact <$> thNameToGhcNameHsc ''Optics.Core.A_Lens+ lens <- exact <$> thNameToGhcNameHsc 'Optics.Core.lens - ghcClasses, ghcShow :: ModuleName- ghcClasses = mkModuleName "GHC.Classes"- ghcShow = mkModuleName "GHC.Show"+ return QualifiedNames{..} - 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"+ where+ exact :: Name -> LIdP GhcPs+ exact = noLocA . Exact
src/Data/Record/Internal/Plugin/Options.hs view
@@ -82,7 +82,7 @@ viewAnnotation :: AnnDecl GhcPs -> Maybe (String, (SrcSpan, LargeRecordOptions)) viewAnnotation = \case PragAnnD (TypeAnnotation tyName) (intOptions -> Just options) ->- Just (nameBase tyName, (getLoc tyName, options))+ Just (nameBase tyName, (toSrcSpan tyName, options)) _otherwise -> Nothing @@ -107,7 +107,7 @@ Nothing intUpdate ::- (LRdrName, LHsExpr GhcPs)+ (LIdP GhcPs, LHsExpr GhcPs) -> Maybe (LargeRecordOptions -> LargeRecordOptions) intUpdate (nameBase -> "debugLargeRecords", intBool -> Just b) = Just $ \opts -> opts { debugLargeRecords = b }
src/Data/Record/Internal/Plugin/Record.hs view
@@ -29,9 +29,9 @@ -- | A representation for records that can be processed by large-records. data Record = Record {- recordTyName :: LRdrName+ recordTyName :: LIdP GhcPs , recordTyVars :: [LHsTyVarBndr GhcPs]- , recordConName :: LRdrName+ , recordConName :: LIdP GhcPs , recordFields :: [Field] , recordDerivings :: [RecordDeriving] , recordOptions :: LargeRecordOptions@@ -43,7 +43,7 @@ } data Field = Field {- fieldName :: LRdrName+ fieldName :: LIdP GhcPs , fieldType :: LHsType GhcPs , fieldStrictness :: HsSrcBang , fieldIndex :: Int@@ -98,7 +98,7 @@ viewField :: MonadError Exception m- => (LRdrName, LHsType GhcPs) -> m (Int -> Field) + => (LIdP GhcPs, LHsType GhcPs) -> m (Int -> Field) viewField (name, typ) = return $ Field name (parensT (getBangType typ)) (getBangStrictness typ)
src/Data/Record/Plugin.hs view
@@ -158,13 +158,13 @@ -- Not a large record. Leave alone. return [decl] (_:_:_) -> do- lift $ issueError l $ text ("Conflicting annotations for " ++ name)+ _ <- lift $ issueError l $ text ("Conflicting annotations for " ++ name) return [decl] [(annLoc, opts)] -> do tell (Set.singleton name) case runExcept (viewRecord annLoc opts decl) of Left e -> do- lift $ issueError (exceptionLoc e) (exceptionToSDoc e)+ _ <- lift $ issueError (exceptionLoc e) (exceptionToSDoc e) -- Return the declaration unchanged if we cannot parse it return [decl] Right r -> lift $ do
src/Data/Record/Plugin/Options.hs view
test/Test/Record/Sanity/EqualFieldTypes.hs view
@@ -43,5 +43,3 @@ expected = MkR 2 1 actual = swap $ MkR 1 2 --
test/Test/Record/Sanity/GhcGenerics.hs view
test/Test/Record/Sanity/NamedWildCards.hs view
+ test/Test/Record/Sanity/Optics/SingleModule.hs view
@@ -0,0 +1,127 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Test what happens if both plugins are used in the same module+module Test.Record.Sanity.Optics.SingleModule (tests) where++import Test.Tasty+import Test.Tasty.HUnit+import Optics.Core+import Optics.TH (makeFieldLabelsNoPrefix)++{-------------------------------------------------------------------------------+ Simple field selection and override+-------------------------------------------------------------------------------}++{-# ANN type R1 largeRecord #-}+data R1 = MkR1 { r1_x :: Int, r1_y :: Bool }+ deriving (Show, Eq)++test_simple :: Assertion+test_simple = do+ assertEqual "x" (r1 ^. #r1_x) $ 1+ assertEqual "y" (r1 ^. #r1_y) $ True+ assertEqual "r1_x" r1_x' $ r1 & #r1_x .~ 2+ assertEqual "r1_y" r1_y' $ r1 & #r1_y .~ False+ assertEqual "r1_xy" r1_xy' $ r1 & #r1_x .~ 2 & #r1_y .~ False+ where+ r1, r1_x', r1_y', r1_xy' :: R1+ r1 = MkR1 { r1_x = 1, r1_y = True }+ r1_x' = MkR1 { r1_x = 2, r1_y = True }+ r1_y' = MkR1 { r1_x = 1, r1_y = False }+ r1_xy' = MkR1 { r1_x = 2, r1_y = False }++{-------------------------------------------------------------------------------+ Field selection and override when there are overloaded fields+-------------------------------------------------------------------------------}++{-# ANN type R2 largeRecord #-}+data R2 = MkR2 { a :: Int, b :: Bool }+ deriving (Show, Eq)++{-# ANN type R3 largeRecord #-}+data R3 = MkR3 { a :: Int, b :: Char }+ deriving (Show, Eq)++test_overloaded :: Assertion+test_overloaded = do+ assertEqual "r2.a" (r2 ^. #a) $ 1+ assertEqual "r2.b" (r2 ^. #b) $ True+ assertEqual "r3.a" (r3 ^. #a) $ 2+ assertEqual "r3.b" (r3 ^. #b) $ 'a'+ assertEqual "r2'" r2' $ r2 & #a .~ 2+ assertEqual "r3'" r3' $ r3 & #b .~ 'b'+ where+ r2, r2' :: R2+ r2 = MkR2 { a = 1, b = True }+ r2' = MkR2 { a = 2, b = True }++ r3 :: R3+ r3 = MkR3 { a = 2, b = 'a' }+ r3' = MkR3 { a = 2, b = 'b' }++{-------------------------------------------------------------------------------+ Nested records++ Both with and without LR.+-------------------------------------------------------------------------------}++data R4_WOutLR = MkR4_WOutLR { r4_woutLR_x :: Int, r4_woutLR_y :: R5_WOutLR }+ deriving (Show, Eq)++data R5_WOutLR = MkR5_WOutLR { r5_woutLR_x :: Char, r5_woutLR_y :: Double }+ deriving (Show, Eq)++makeFieldLabelsNoPrefix ''R4_WOutLR+makeFieldLabelsNoPrefix ''R5_WOutLR++{-# ANN type R4_WithLR largeRecord #-}+data R4_WithLR = MkR4_WithLR { r4_withLR_x :: Int, r4_withLR_y :: R5_WithLR }+ deriving (Show, Eq)++{-# ANN type R5_WithLR largeRecord #-}+data R5_WithLR = MkR5_WithLR { r5_withLR_x :: Char, r5_withLR_y :: Double }+ deriving (Show, Eq)++test_nested :: Assertion+test_nested = do+ assertEqual "r4_woutLR_x" (r4_woutLR ^. #r4_woutLR_y % #r5_woutLR_x) $ 'a'+ assertEqual "r4_withLR_x" (r4_WithLR ^. #r4_withLR_y % #r5_withLR_x) $ 'a'+ where+ r4_woutLR :: R4_WOutLR+ r4_woutLR = MkR4_WOutLR { r4_woutLR_x = 1, r4_woutLR_y = r5_woutLR }++ r5_woutLR :: R5_WOutLR+ r5_woutLR = MkR5_WOutLR { r5_woutLR_x = 'a', r5_woutLR_y = 1.2 }++ r4_WithLR :: R4_WithLR+ r4_WithLR = MkR4_WithLR { r4_withLR_x = 1, r4_withLR_y = r5_WithLR }++ r5_WithLR :: R5_WithLR+ r5_WithLR = MkR5_WithLR { r5_withLR_x = 'a', r5_withLR_y = 1.2 }++{-------------------------------------------------------------------------------+ Collect all tests+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Sanity.Optics" [+ testCase "simple" test_simple+ , testCase "overloaded" test_overloaded+ , testCase "nested" test_nested+ ]
+ test/Test/Record/Sanity/Optics/SplitModule.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-}++-- | Test that the RDP plugin can use records created by large-records+--+-- For this test, we split the modules: one using the large-records plugin,+-- one using the RDP plugin. See also "Test.Record.Sanity.RDP.SingleModule".+module Test.Record.Sanity.Optics.SplitModule (tests) where++import Test.Tasty+import Test.Tasty.HUnit+import Optics.Core++import Test.Record.Sanity.Optics.SplitModule.RecordDef++import Optics.TH (makeFieldLabelsNoPrefix)++{-------------------------------------------------------------------------------+ Simple field selection and override+-------------------------------------------------------------------------------}++test_simple :: Assertion+test_simple = do+ assertEqual "x" (r1 ^. #r1_x) $ 1+ assertEqual "y" (r1 ^. #r1_y) $ True+ assertEqual "r1_x" r1_x' $ r1 & #r1_x .~ 2+ assertEqual "r1_y" r1_y' $ r1 & #r1_y .~ False+ assertEqual "r1_xy" r1_xy' $ r1 & #r1_x .~ 2 & #r1_y .~ False+ where+ r1, r1_x', r1_y', r1_xy' :: R1+ r1 = MkR1 { r1_x = 1, r1_y = True }+ r1_x' = MkR1 { r1_x = 2, r1_y = True }+ r1_y' = MkR1 { r1_x = 1, r1_y = False }+ r1_xy' = MkR1 { r1_x = 2, r1_y = False }++{-------------------------------------------------------------------------------+ Field selection and override when there are overloaded fields+-------------------------------------------------------------------------------}++test_overloaded :: Assertion+test_overloaded = do+ assertEqual "r2.a" (r2 ^. #a) $ 1+ assertEqual "r2.b" (r2 ^. #b) $ True+ assertEqual "r3.a" (r3 ^. #a) $ 2+ assertEqual "r3.b" (r3 ^. #b) $ 'a'+ assertEqual "r2'" r2' $ r2 & #a .~ 2+ assertEqual "r3'" r3' $ r3 & #b .~ 'b'+ where+ r2, r2' :: R2+ r2 = MkR2 { a = 1, b = True }+ r2' = MkR2 { a = 2, b = True }++ r3 :: R3+ r3 = MkR3 { a = 2, b = 'a' }+ r3' = MkR3 { a = 2, b = 'b' }++{-------------------------------------------------------------------------------+ Nested records++ Both with and without LR.+-------------------------------------------------------------------------------}++data R4_WOutLR = MkR4_WOutLR { r4_woutLR_x :: Int, r4_woutLR_y :: R5_WOutLR }+ deriving (Show, Eq)++data R5_WOutLR = MkR5_WOutLR { r5_woutLR_x :: Char, r5_woutLR_y :: Double }+ deriving (Show, Eq)++makeFieldLabelsNoPrefix ''R4_WOutLR+makeFieldLabelsNoPrefix ''R5_WOutLR++test_nested :: Assertion+test_nested = do+ assertEqual "r4_woutLR_x" (r4_woutLR ^. #r4_woutLR_y % #r5_woutLR_x) $ 'a'+ assertEqual "r4_withLR_x" (r4_WithLR ^. #r4_withLR_y % #r5_withLR_x) $ 'a'+ where+ r4_woutLR :: R4_WOutLR+ r4_woutLR = MkR4_WOutLR { r4_woutLR_x = 1, r4_woutLR_y = r5_woutLR }++ r5_woutLR :: R5_WOutLR+ r5_woutLR = MkR5_WOutLR { r5_woutLR_x = 'a', r5_woutLR_y = 1.2 }++ r4_WithLR :: R4_WithLR+ r4_WithLR = MkR4_WithLR { r4_withLR_x = 1, r4_withLR_y = r5_WithLR }++ r5_WithLR :: R5_WithLR+ r5_WithLR = MkR5_WithLR { r5_withLR_x = 'a', r5_withLR_y = 1.2 }++{-------------------------------------------------------------------------------+ Collect all tests+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Sanity.Optics.SplitModule" [+ testCase "simple" test_simple+ , testCase "overloaded" test_overloaded+ , testCase "nested" test_nested+ ]
+ test/Test/Record/Sanity/Optics/SplitModule/RecordDef.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-}++-- | Record definitions for "Test.Record.Sanity.RDP.SplitModule"+--+-- See "Test.Record.Sanity.RDP.SplitModule" for details.+module Test.Record.Sanity.Optics.SplitModule.RecordDef (+ R1(..)+ , R2(..)+ , R3(..)+ , R4_WithLR(..)+ , R5_WithLR(..)+ ) where++{-# ANN type R1 largeRecord #-}+data R1 = MkR1 { r1_x :: Int, r1_y :: Bool }+ deriving (Show, Eq)++{-# ANN type R2 largeRecord #-}+data R2 = MkR2 { a :: Int, b :: Bool }+ deriving (Show, Eq)++{-# ANN type R3 largeRecord #-}+data R3 = MkR3 { a :: Int, b :: Char }+ deriving (Show, Eq)++{-# ANN type R4_WithLR largeRecord #-}+data R4_WithLR = MkR4_WithLR { r4_withLR_x :: Int, r4_withLR_y :: R5_WithLR }+ deriving (Show, Eq)++{-# ANN type R5_WithLR largeRecord #-}+data R5_WithLR = MkR5_WithLR { r5_withLR_x :: Char, r5_withLR_y :: Double }+ deriving (Show, Eq)
test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs view
@@ -43,4 +43,3 @@ data R5_WithLR = MkR5_WithLR { r5_withLR_x :: Char, r5_withLR_y :: Double } deriving (Show, Eq) -
test/TestLargeRecords.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Main (main) where import Test.Tasty@@ -12,12 +13,17 @@ import qualified Test.Record.Sanity.OverloadingNoDRF import qualified Test.Record.Sanity.PatternMatch import qualified Test.Record.Sanity.QualifiedImports-import qualified Test.Record.Sanity.RDP.SingleModule-import qualified Test.Record.Sanity.RDP.SplitModule+import qualified Test.Record.Sanity.Optics.SingleModule+import qualified Test.Record.Sanity.Optics.SplitModule import qualified Test.Record.Sanity.RecordConstruction import qualified Test.Record.Sanity.Strictness import qualified Test.Record.Sanity.StrictnessStrictData +#if HAS_RDP+import qualified Test.Record.Sanity.RDP.SingleModule+import qualified Test.Record.Sanity.RDP.SplitModule+#endif+ main :: IO () main = defaultMain tests @@ -32,8 +38,12 @@ , Test.Record.Sanity.OverloadingNoDRF.tests , Test.Record.Sanity.PatternMatch.tests , Test.Record.Sanity.QualifiedImports.tests+ , Test.Record.Sanity.Optics.SplitModule.tests+ , Test.Record.Sanity.Optics.SingleModule.tests+#if HAS_RDP , Test.Record.Sanity.RDP.SplitModule.tests , Test.Record.Sanity.RDP.SingleModule.tests+#endif , Test.Record.Sanity.RecordConstruction.tests , Test.Record.Sanity.Strictness.tests , Test.Record.Sanity.StrictnessStrictData.tests