diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/large-records.cabal b/large-records.cabal --- a/large-records.cabal +++ b/large-records.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: large-records -version: 0.4.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: diff --git a/src/Data/Record/Internal/GHC/Fresh.hs b/src/Data/Record/Internal/GHC/Fresh.hs --- a/src/Data/Record/Internal/GHC/Fresh.hs +++ b/src/Data/Record/Internal/GHC/Fresh.hs @@ -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) - diff --git a/src/Data/Record/Internal/GHC/Shim.hs b/src/Data/Record/Internal/GHC/Shim.hs --- a/src/Data/Record/Internal/GHC/Shim.hs +++ b/src/Data/Record/Internal/GHC/Shim.hs @@ -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 diff --git a/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs b/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs --- a/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs +++ b/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs @@ -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) diff --git a/src/Data/Record/Internal/Plugin/CodeGen.hs b/src/Data/Record/Internal/Plugin/CodeGen.hs --- a/src/Data/Record/Internal/Plugin/CodeGen.hs +++ b/src/Data/Record/Internal/Plugin/CodeGen.hs @@ -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" diff --git a/src/Data/Record/Internal/Plugin/Names.hs b/src/Data/Record/Internal/Plugin/Names.hs --- a/src/Data/Record/Internal/Plugin/Names.hs +++ b/src/Data/Record/Internal/Plugin/Names.hs @@ -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 diff --git a/src/Data/Record/Internal/Plugin/Options.hs b/src/Data/Record/Internal/Plugin/Options.hs --- a/src/Data/Record/Internal/Plugin/Options.hs +++ b/src/Data/Record/Internal/Plugin/Options.hs @@ -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 } diff --git a/src/Data/Record/Internal/Plugin/Record.hs b/src/Data/Record/Internal/Plugin/Record.hs --- a/src/Data/Record/Internal/Plugin/Record.hs +++ b/src/Data/Record/Internal/Plugin/Record.hs @@ -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) diff --git a/src/Data/Record/Plugin.hs b/src/Data/Record/Plugin.hs --- a/src/Data/Record/Plugin.hs +++ b/src/Data/Record/Plugin.hs @@ -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 diff --git a/src/Data/Record/Plugin/Options.hs b/src/Data/Record/Plugin/Options.hs --- a/src/Data/Record/Plugin/Options.hs +++ b/src/Data/Record/Plugin/Options.hs diff --git a/test/Test/Record/Sanity/EqualFieldTypes.hs b/test/Test/Record/Sanity/EqualFieldTypes.hs --- a/test/Test/Record/Sanity/EqualFieldTypes.hs +++ b/test/Test/Record/Sanity/EqualFieldTypes.hs @@ -43,5 +43,3 @@ expected = MkR 2 1 actual = swap $ MkR 1 2 - - diff --git a/test/Test/Record/Sanity/GhcGenerics.hs b/test/Test/Record/Sanity/GhcGenerics.hs --- a/test/Test/Record/Sanity/GhcGenerics.hs +++ b/test/Test/Record/Sanity/GhcGenerics.hs diff --git a/test/Test/Record/Sanity/NamedWildCards.hs b/test/Test/Record/Sanity/NamedWildCards.hs --- a/test/Test/Record/Sanity/NamedWildCards.hs +++ b/test/Test/Record/Sanity/NamedWildCards.hs diff --git a/test/Test/Record/Sanity/Optics/SingleModule.hs b/test/Test/Record/Sanity/Optics/SingleModule.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/Optics/SingleModule.hs @@ -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 + ] diff --git a/test/Test/Record/Sanity/Optics/SplitModule.hs b/test/Test/Record/Sanity/Optics/SplitModule.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/Optics/SplitModule.hs @@ -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 + ] diff --git a/test/Test/Record/Sanity/Optics/SplitModule/RecordDef.hs b/test/Test/Record/Sanity/Optics/SplitModule/RecordDef.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/Optics/SplitModule/RecordDef.hs @@ -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) diff --git a/test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs b/test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs --- a/test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs +++ b/test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs @@ -43,4 +43,3 @@ data R5_WithLR = MkR5_WithLR { r5_withLR_x :: Char, r5_withLR_y :: Double } deriving (Show, Eq) - diff --git a/test/TestLargeRecords.hs b/test/TestLargeRecords.hs --- a/test/TestLargeRecords.hs +++ b/test/TestLargeRecords.hs @@ -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