diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,15 +1,29 @@ # Revision history for large-records +## 0.4 -- 2023-03-06 + +* Fix issue with operator type families used in fields (#120). +* Fix issue with `NamedWildCards` (#121, #124, #125). +* Do not generate imports in the plugin (#129). + NOTE: This means that use code must now import `Data.Record.Plugin` to bring + `largeRecord` into scope (necessary for `ANN` annotations). +* Support ghc 9.4 (#131). + An annoying quirk of ghc 9.4 is that the order of plugins is reversed; this + matters when using `large-records` and `record-dot-preprocessor` together. + To avoid CPP, you can now use `Data.Record.Plugin.WithRDP`, which combines + both plugins. +* Support `OverloadedRecordDot` and `OverloadedRecordUpdate` (#135). + ## 0.3 -- 2022-07-22 -* Support ghc 9.2 (#117) -* Support for field strictness annotations (#107) +* Support ghc 9.2 (#113 / #117). +* Support for field strictness annotations (#106 / #107). ## 0.2.1.0 -- 2022-04-06 * Update for `large-generics` 0.2 -## 0.2.0.0 -- 2022-03-23 +## 0.2.0.0 -- 2022-03-23 * Avoid all quotes: no more Template Haskell (#63) or quasi-quotes (#43). TH replaced by a source-plugin; quasi-quotes avoided by using a different 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.3 +version: 0.4 synopsis: Efficient compilation for large records, linear in the size of the record description: For many reasons, the internal code generated for modules that contain records is quadratic in the number of record @@ -16,7 +16,7 @@ maintainer: edsko@well-typed.com category: Generics extra-source-files: CHANGELOG.md -tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2 +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.4 source-repository head type: git @@ -26,8 +26,10 @@ exposed-modules: Data.Record.Plugin - Data.Record.Plugin.Runtime Data.Record.Plugin.Options + Data.Record.Plugin.Runtime + Data.Record.Plugin.WithRDP + Data.Record.Overloading other-modules: @@ -37,26 +39,28 @@ Data.Record.Internal.Plugin.CodeGen Data.Record.Internal.Plugin.Exception - Data.Record.Internal.Plugin.Names.GhcGenerics - Data.Record.Internal.Plugin.Names.Runtime + Data.Record.Internal.Plugin.Names Data.Record.Internal.Plugin.Options Data.Record.Internal.Plugin.Record build-depends: - base >= 4.13 && < 4.17 - , containers >= 0.6.2 && < 0.7 - , mtl >= 2.2.1 && < 2.3 - , primitive >= 0.7 && < 0.8 - , record-hasfield >= 1.0 && < 1.1 - , syb >= 0.7 && < 0.8 + base >= 4.13 && < 4.18 + , containers >= 0.6.2 && < 0.7 + , mtl >= 2.2.1 && < 2.3 + , primitive >= 0.7 && < 0.8 + , syb >= 0.7 && < 0.8 + , record-hasfield >= 1.0 && < 1.1 -- large-generics 0.2 starts using 'SmallArray' instead of 'Vector' - , large-generics >= 0.2 && < 0.3 + , large-generics >= 0.2 && < 0.3 -- transformers 0.5.6 introduces Writer.CPS - , transformers >= 0.5.6 && < 0.7 + , transformers >= 0.5.6 && < 0.7 - -- whatever version is bundled with ghc + -- 0.2.16 introduces support for ghc 9.4 + , record-dot-preprocessor >= 0.2.16 && < 0.3 + + -- whatever versions are bundled with ghc , ghc , template-haskell hs-source-dirs: @@ -87,8 +91,12 @@ Test.Record.Sanity.CodeGen Test.Record.Sanity.Derive Test.Record.Sanity.EqualFieldTypes + Test.Record.Sanity.GhcGenerics Test.Record.Sanity.HigherKinded Test.Record.Sanity.HKD + Test.Record.Sanity.NamedWildCards + Test.Record.Sanity.Operators + Test.Record.Sanity.OverloadedRecordUpdate Test.Record.Sanity.OverloadingNoDRF Test.Record.Sanity.PatternMatch Test.Record.Sanity.QualifiedImports @@ -100,7 +108,6 @@ Test.Record.Sanity.RecordConstruction Test.Record.Sanity.Strictness Test.Record.Sanity.StrictnessStrictData - Test.Record.Sanity.GhcGenerics Test.Record.Util build-depends: @@ -111,14 +118,12 @@ , large-generics , mtl , newtype + , record-dot-preprocessor , record-hasfield , tasty , tasty-hunit , template-haskell , transformers - - -- - , record-dot-preprocessor >= 0.2.14 hs-source-dirs: test default-language: @@ -130,10 +135,3 @@ -Wincomplete-record-updates -Wpartial-fields -Widentities - - if impl(ghc >= 9.0.1) - -- ghc 9 provides warnings about unused imports for the imports added by - -- the plugin. I'm not yet sure how to deal with this properly. The imports - -- are necessary (I think...?), both for the generated code and to typecheck - -- the user's own ANN pragma. For now we just disable the warning. - ghc-options: -Wno-unused-imports 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 @@ -6,7 +6,6 @@ , runFreshHsc ) where -import Data.IORef import Control.Monad.Reader import Data.Record.Internal.GHC.Shim @@ -16,40 +15,41 @@ -- -- NOTES: -- - -- o These names should be used for module exports. - -- o These names should be used for exactly /one/ binder. - -- o The resulting name has the same 'NameSpace' as the argument. + -- * These names should be used for module exports. + -- * These names should be used for exactly /one/ binder. + -- * The resulting name has the same 'NameSpace' as the argument. freshName :: LRdrName -> m LRdrName + freshName = freshName' True -newtype Fresh a = WrapFresh { unwrapFresh :: ReaderT (IORef NameCache) IO a } + -- variant which doesn't rename the variable. + -- The 'False' variant can be used in types. + freshName' :: Bool -> LRdrName -> m LRdrName + +newtype Fresh a = WrapFresh { unwrapFresh :: ReaderT NameCacheIO IO a } deriving newtype (Functor, Applicative, Monad) instance MonadFresh Fresh where - freshName (L l name) = WrapFresh $ ReaderT $ \nc_var -> - atomicModifyIORef nc_var aux + freshName' pfx (L l name) = WrapFresh $ ReaderT $ \nc -> do + newUniq <- takeUniqFromNameCacheIO nc + return $ L l $ Exact $ + mkInternalName newUniq (newOccName (rdrNameOcc name)) l where - aux :: NameCache -> (NameCache, LRdrName) - aux nc = ( - nc { nsUniqs = us } - , L l $ Exact $ - mkInternalName newUniq (newOccName (rdrNameOcc name)) l - ) - where - (newUniq, us) = takeUniqFromSupply (nsUniqs nc) - -- Even when we generate fresh names, ghc can still complain about name -- shadowing, because this check only considers the 'OccName', not the -- unique. We therefore prefix the name with an underscore to avoid the -- warning. newOccName :: OccName -> OccName - newOccName n = mkOccName (occNameSpace n) . ("_" ++) $ occNameString n + newOccName n = mkOccName (occNameSpace n) $ addPrefix $ occNameString n -runFresh :: Fresh a -> IORef NameCache -> IO a + addPrefix :: String -> String + addPrefix = if pfx then ("_" ++) else id + +runFresh :: Fresh a -> NameCacheIO -> IO a runFresh = runReaderT . unwrapFresh runFreshHsc :: Fresh a -> Hsc a runFreshHsc fa = do env <- getHscEnv - liftIO $ runFresh fa (hsc_NC env) + liftIO $ runFresh fa (hscNameCacheIO env) 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 @@ -2,9 +2,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -14,8 +16,12 @@ -- This should be the only module with GHC-specific CPP directives, and the -- rest of the plugin should not import from any GHC modules directly. module Data.Record.Internal.GHC.Shim ( + -- * Names + lookupVarName + , lookupTcName + -- * Miscellaneous - importDecl + , importDecl , conPat , mkFunBind , HsModule @@ -45,12 +51,22 @@ , hsTyVarLName , setDefaultSpecificity + -- * Locations + , ToSrcSpan(..) + , InheritLoc(..) + , withoutLoc + -- * New functionality , compareHs - , inheritLoc - , inheritLoc' - , inheritLocPat + -- * NameCache + , NameCacheIO + , hscNameCacheIO + , takeUniqFromNameCacheIO + + -- * Records + , simpleRecordUpdates + -- * Re-exports -- The whole-sale module exports are not ideal for preserving compatibility @@ -70,7 +86,6 @@ , module GHC.Hs , module GHC.Plugins , module GHC.Tc.Types.Evidence - , module GHC.Types.Name.Cache , module GHC.Utils.Error #if __GLASGOW_HASKELL__ >= 902 , module GHC.Types.SourceText @@ -79,6 +94,7 @@ #endif ) where +import Control.Monad import Data.List.NonEmpty (NonEmpty(..)) import Data.Generics (Data, GenericQ, cast, toConstr, gzipWithQ) @@ -86,13 +102,17 @@ #if __GLASGOW_HASKELL__ < 900 +import Data.IORef + +import Bag (Bag, listToBag, emptyBag) import BasicTypes (SourceText (NoSourceText)) -import Bag (listToBag, emptyBag) import ConLike (ConLike) import ErrUtils (mkErrMsg, mkWarnMsg) +import Finder (findImportedModule) import GHC hiding (AnnKeywordId(..), HsModule, exprType, typeKind, mkFunBind) import GhcPlugins hiding ((<>), getHscEnv,) import HscMain (getHscEnv) +import IfaceEnv (lookupOrigIO) import NameCache (NameCache(nsUniqs)) import PatSyn (PatSyn) import TcEvidence (HsWrapper(WpHole)) @@ -103,36 +123,103 @@ #else import GHC.Hs hiding (LHsTyVarBndr, HsTyVarBndr, HsModule, mkFunBind) +import qualified GHC.Hs as GHC import GHC.Core.Class (Class) import GHC.Core.ConLike (ConLike) import GHC.Core.PatSyn (PatSyn) -import GHC.Data.Bag (listToBag, emptyBag) +import GHC.Data.Bag (Bag, listToBag, emptyBag) import GHC.Driver.Main (getHscEnv) import GHC.Tc.Types.Evidence (HsWrapper(WpHole)) -import GHC.Types.Name.Cache (NameCache(nsUniqs)) import GHC.Utils.Error (Severity(SevError, SevWarning)) import GHC.Plugins hiding ((<>), getHscEnv -#if __GLASGOW_HASKELL__ >=902 +#if __GLASGOW_HASKELL__ >= 902 , AnnType, AnnLet, AnnRec, AnnLam, AnnCase , Exception #endif +#if __GLASGOW_HASKELL__ < 904 + , trace +#endif ) #if __GLASGOW_HASKELL__ < 902 -import GHC.Utils.Error (mkErrMsg, mkWarnMsg) +import GHC.Driver.Finder (findImportedModule) import GHC.Parser.Annotation (IsUnicodeSyntax(NormalSyntax)) +import GHC.Utils.Error (mkErrMsg, mkWarnMsg) #else -import GHC.Types.SourceText (SourceText(NoSourceText), mkIntegralLit) import GHC.Types.Fixity +import GHC.Types.SourceText (SourceText(NoSourceText), mkIntegralLit) +import GHC.Unit.Finder (findImportedModule, FindResult(Found)) #endif -import qualified GHC.Hs as GHC +#if __GLASGOW_HASKELL__ < 904 +import Data.IORef +import GHC.Iface.Env (lookupOrigIO) +import GHC.Types.Name.Cache (NameCache(nsUniqs)) +#else +import GHC.Iface.Env (lookupNameCache) +import GHC.Rename.Names (renamePkgQual) +import GHC.Types.Name.Cache (NameCache, takeUniqFromNameCache) +#endif #endif {------------------------------------------------------------------------------- + Name resolution +-------------------------------------------------------------------------------} + +lookupVarName :: + HasCallStack + => ModuleName + -> Maybe FastString -- ^ Optional package name + -> String -> Hsc Name +lookupVarName modl pkg = lookupOccName modl pkg . mkVarOcc + +lookupTcName :: + HasCallStack + => ModuleName + -> Maybe FastString -- ^ Optional package name + -> String -> Hsc Name +lookupTcName modl pkg = lookupOccName modl pkg . mkTcOcc + +lookupOccName :: + HasCallStack + => ModuleName + -> Maybe FastString -- ^ Optional package name + -> OccName -> Hsc Name +lookupOccName modlName mPkgName name = do + env <- getHscEnv + +#if __GLASGOW_HASKELL__ >= 904 + let pkgq :: PkgQual + pkgq = renamePkgQual (hsc_unit_env env) modlName mPkgName +#else + let pkgq :: Maybe FastString + pkgq = mPkgName +#endif + + mModl <- liftIO $ findImportedModule env modlName pkgq + case mModl of + Found _ modl -> liftIO $ lookupOrigIO env modl name + _otherwise -> error $ concat [ + "lookupName: could not find " + , occNameString name + , " in module " + , moduleNameString modlName + , ". This might be due to an undeclared package dependency" + , case mPkgName of + Nothing -> "" + Just pkg -> " on " ++ unpackFS pkg + , "." + ] + +#if __GLASGOW_HASKELL__ >= 904 +lookupOrigIO :: HscEnv -> Module -> OccName -> IO Name +lookupOrigIO env modl occ = lookupNameCache (hsc_NC env) modl occ +#endif + +{------------------------------------------------------------------------------- Miscellaneous -------------------------------------------------------------------------------} @@ -142,7 +229,11 @@ ideclExt = defExt , ideclSourceSrc = NoSourceText , ideclName = noLocA name +#if __GLASGOW_HASKELL__ >= 904 + , ideclPkgQual = NoRawPkgQual +#else , ideclPkgQual = Nothing +#endif , ideclSafe = False , ideclImplicit = False , ideclAs = Nothing @@ -183,6 +274,29 @@ type LRdrName = Located RdrName {------------------------------------------------------------------------------- + NameCache +-------------------------------------------------------------------------------} + +#if __GLASGOW_HASKELL__ < 904 +type NameCacheIO = IORef NameCache + +takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique +takeUniqFromNameCacheIO = flip atomicModifyIORef aux + where + aux :: NameCache -> (NameCache, Unique) + aux nc = let (newUniq, us) = takeUniqFromSupply (nsUniqs nc) + in (nc { nsUniqs = us }, newUniq) +#else +type NameCacheIO = NameCache + +takeUniqFromNameCacheIO :: NameCacheIO -> IO Unique +takeUniqFromNameCacheIO = takeUniqFromNameCache +#endif + +hscNameCacheIO :: HscEnv -> NameCacheIO +hscNameCacheIO = hsc_NC + +{------------------------------------------------------------------------------- Exact-print annotations -------------------------------------------------------------------------------} @@ -242,7 +356,7 @@ -- In GHC-9.2 some things have extension fields. #if __GLASGOW_HASKELL__ >= 902 withDefExt :: HasDefaultExt a => (a -> b) -> b -withDefExt f = f defExt +withDefExt f = f defExt #else withDefExt :: a -> a withDefExt a = a @@ -257,11 +371,13 @@ type LHsTyVarBndr pass = GHC.LHsTyVarBndr () pass #endif -hsFunTy :: XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass +hsFunTy :: XFunTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs #if __GLASGOW_HASKELL__ < 900 hsFunTy = HsFunTy -#else +#elif __GLASGOW_HASKELL__ < 904 hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow NormalSyntax) +#else +hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow (L NoTokenLoc HsNormalTok)) #endif userTyVar :: @@ -359,57 +475,143 @@ Working with locations -------------------------------------------------------------------------------} -class FromSrcSpan l where - fromSrcSpan :: SrcSpan -> l +class ToSrcSpan a where + toSrcSpan :: a -> SrcSpan -instance FromSrcSpan SrcSpan where - fromSrcSpan = id +instance ToSrcSpan SrcSpan where + toSrcSpan = id #if __GLASGOW_HASKELL__ >= 902 -instance HasDefaultExt ann => FromSrcSpan (SrcSpanAnn' ann) where - fromSrcSpan = SrcSpanAnn defExt +instance ToSrcSpan (SrcSpanAnn' a) where + toSrcSpan = locA #endif -class InheritLoc a where - inheritLoc :: FromSrcSpan l => a -> b -> GenLocated l b +instance ToSrcSpan l => ToSrcSpan (GenLocated l a) where + toSrcSpan (L l _) = toSrcSpan l +instance ToSrcSpan a => ToSrcSpan (NonEmpty a) where + toSrcSpan = toSrcSpan . NE.head + +-- | The instance for @[]@ is not ideal: we use 'noLoc' if the list is empty +-- +-- For the use cases in this library, this is acceptable: typically these are +-- lists with elements for the record fields, and having slightly poorer error +-- messages for highly unusual "empty large" records is fine. +instance ToSrcSpan a => ToSrcSpan [a] where + toSrcSpan (a:_) = toSrcSpan a + toSrcSpan [] = noSrcSpan + +class InheritLoc x a b | b -> a where + inheritLoc :: x -> a -> b + +instance ToSrcSpan x => InheritLoc x a (GenLocated SrcSpan a) where + inheritLoc = L . toSrcSpan + #if __GLASGOW_HASKELL__ >= 902 --- GHC-9.2 may not require annotation -inheritLoc' :: a -> b -> b -inheritLoc' _ = id -#else -inheritLoc' :: InheritLoc a => a -> b -> Located b -inheritLoc' = inheritLoc +instance ToSrcSpan x => InheritLoc x a (GenLocated (SrcAnn ann) a) where + inheritLoc = L . SrcSpanAnn defExt . toSrcSpan #endif -instance InheritLoc a => InheritLoc (NonEmpty a) where - inheritLoc = inheritLoc . NE.head +instance InheritLoc x [a] [a] where inheritLoc _ = id +instance InheritLoc x Bool Bool where inheritLoc _ = id +instance InheritLoc x (HsTupArg p) (HsTupArg p) where inheritLoc _ = id +instance InheritLoc x (Pat p ) (Pat p) where inheritLoc _ = id +instance InheritLoc x (HsLocalBindsLR p q) (HsLocalBindsLR p q) where inheritLoc _ = id -instance InheritLoc l => InheritLoc (GenLocated l a) where - inheritLoc (L l _) = inheritLoc l +withoutLoc :: InheritLoc SrcSpan a b => a -> b +withoutLoc = inheritLoc noSrcSpan -instance InheritLoc SrcSpan where - inheritLoc l x = L (fromSrcSpan l) x +{------------------------------------------------------------------------------- + Records +-------------------------------------------------------------------------------} #if __GLASGOW_HASKELL__ >= 902 -instance InheritLoc (SrcSpanAnn' ann) where - inheritLoc (SrcSpanAnn _ l) = inheritLoc l +type RupdFlds = Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs] +#else +type RupdFlds = [LHsRecUpdField GhcPs] #endif --- --- -- | The instance for @[]@ is not ideal: we use 'noLoc' if the list is empty --- -- --- -- For the use cases in this library, this is acceptable: typically these are --- -- lists with elements for the record fields, and having slightly poorer error --- -- messages for highly unusual "empty large" records is fine. -instance InheritLoc a => InheritLoc [a] where - inheritLoc (a:_) = inheritLoc a - inheritLoc [] = inheritLoc noSrcSpan +-- | Pattern match against the @rupd_flds@ of @RecordUpd@ +simpleRecordUpdates :: RupdFlds -> Maybe [(LRdrName, LHsExpr GhcPs)] -#if __GLASGOW_HASKELL__ < 810 -inheritLocPat :: a -> Pat p -> LPat p -inheritLocPat _ = id -- In 8.8, 'LPat' is a synonym for 'Pat' +#if __GLASGOW_HASKELL__ >= 904 + +simpleRecordUpdates = + \case + Left flds -> mapM (aux (isUnambigous . unLoc)) flds + Right flds -> mapM (aux (isSingleLabel . unLoc)) flds + where + aux :: forall lhs rhs. + (lhs -> Maybe LRdrName) + -> LHsFieldBind GhcPs lhs rhs + -> Maybe (LRdrName, rhs) + aux f (L _ (HsFieldBind { hfbLHS = lbl + , hfbRHS = val + , hfbPun = pun + })) = do + guard $ not pun + (, val) <$> f lbl + + isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName + isUnambigous (Unambiguous _ name) = Just $ reLoc name + isUnambigous _ = Nothing + + isSingleLabel :: FieldLabelStrings GhcPs -> Maybe LRdrName + isSingleLabel (FieldLabelStrings labels) = + case labels of + [L _ (DotFieldOcc _ (L l label))] -> + Just $ reLoc $ L l (Unqual $ mkVarOccFS label) + _otherwise -> + Nothing + +#elif __GLASGOW_HASKELL__ == 902 + +simpleRecordUpdates = + \case + Left flds -> mapM (aux isUnambigous) flds + Right flds -> mapM (aux isSingleLabel) flds + where + aux :: forall lhs rhs. + (lhs -> Maybe LRdrName) + -> LHsRecField' GhcPs lhs rhs + -> Maybe (LRdrName, rhs) + aux f (L _ (HsRecField { hsRecFieldLbl = L _ lbl + , hsRecFieldArg = val + , hsRecPun = pun + })) = do + guard $ not pun + (, val) <$> f lbl + + isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName + isUnambigous (Unambiguous _ name) = Just $ reLoc name + isUnambigous _ = Nothing + + isSingleLabel :: FieldLabelStrings GhcPs -> Maybe LRdrName + isSingleLabel (FieldLabelStrings labels) = + case labels of + [L _ (HsFieldLabel _ (L l label))] -> + Just $ L l (Unqual $ mkVarOccFS label) + _otherwise -> + Nothing + #else -inheritLocPat :: InheritLoc a => a -> Pat (GhcPass p) -> LPat (GhcPass p) -inheritLocPat = inheritLoc + +simpleRecordUpdates = + mapM (aux isUnambigous) + where + aux :: forall lhs rhs. + (lhs -> Maybe LRdrName) + -> LHsRecField' lhs rhs + -> Maybe (LRdrName, rhs) + aux f (L _ (HsRecField { hsRecFieldLbl = L _ lbl + , hsRecFieldArg = val + , hsRecPun = pun + })) = do + guard $ not pun + (, val) <$> f lbl + + isUnambigous :: AmbiguousFieldOcc GhcPs -> Maybe LRdrName + isUnambigous (Unambiguous _ name) = Just $ reLoc name + isUnambigous _ = Nothing + #endif 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 @@ -33,11 +33,13 @@ , lamE1 , caseE , appsE + , appTypeE , tupE , sigE -- ** Without direct equivalent , intE -- * Types + , parensT , litT , pattern VarT , pattern ConT @@ -184,7 +186,7 @@ -- | Inverse to 'varE' viewVarE :: LHsExpr GhcPs -> Maybe LRdrName -viewVarE (reLoc -> L _ (HsVar _ (reLoc -> name))) | isTermVar name = Just name +viewVarE (L _ (HsVar _ (reLoc -> name))) | isTermVar name = Just name viewVarE _ = Nothing pattern VarE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs @@ -200,7 +202,7 @@ -- | Inverse to 'conE' viewConE :: LHsExpr GhcPs -> Maybe LRdrName -viewConE (reLoc -> L _ (HsVar _ (reLoc -> name))) | isTermCon name = Just name +viewConE (L _ (HsVar _ (reLoc -> name))) | isTermCon name = Just name viewConE _ = Nothing pattern ConE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs @@ -226,11 +228,14 @@ mkFld :: LRdrName -> LHsExpr GhcPs -> LHsRecField GhcPs (LHsExpr GhcPs) mkFld name val = inheritLoc name $ +#if __GLASGOW_HASKELL__ >= 904 + HsFieldBind defExt +#elif __GLASGOW_HASKELL__ >= 902 + HsRecField defExt +#else HsRecField -#if __GLASGOW_HASKELL__ >= 902 - defExt #endif - (reLoc (inheritLoc name (mkFieldOcc (reLocA name)))) val False + (inheritLoc name (mkFieldOcc (reLocA name))) val False -- | Equivalent of 'Language.Haskell.TH.Lib.recUpdE' recUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs @@ -246,27 +251,21 @@ updFld :: LRdrName -> LHsExpr GhcPs -> LHsRecUpdField GhcPs updFld name val = inheritLoc name $ +#if __GLASGOW_HASKELL__ >= 904 + HsFieldBind +#else HsRecField +#endif #if __GLASGOW_HASKELL__ >= 902 defExt #endif - (reLoc (inheritLoc name (mkAmbiguousFieldOcc (reLocA name)))) val False + (inheritLoc name (mkAmbiguousFieldOcc (reLocA name))) val False viewRecUpdE :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(LRdrName, LHsExpr GhcPs)]) -#if __GLASGOW_HASKELL__ >= 902 -viewRecUpdE (L _ (RecordUpd _ recExpr (Left fields))) = -#else viewRecUpdE (L _ (RecordUpd _ recExpr fields)) = -#endif - (recExpr,) <$> mapM viewFieldUpd fields - where - viewFieldUpd :: LHsRecUpdField GhcPs -> Maybe (LRdrName, LHsExpr GhcPs) - viewFieldUpd (L _ (HsRecField { hsRecFieldLbl = L _ (Unambiguous _ name), hsRecFieldArg = val, hsRecPun = False })) = - Just (reLoc name, val) - viewFieldUpd _otherwise = - Nothing + (recExpr,) <$> simpleRecordUpdates fields viewRecUpdE _otherwise = Nothing pattern RecUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs @@ -312,12 +311,24 @@ appsE :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs appsE = foldl' appE +-- | Equivalent of 'Language.Haskell.TH.Lib.appT' +appTypeE :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs +appTypeE expr typ = inheritLoc expr $ + HsAppType +#if __GLASGOW_HASKELL__ >= 902 + (toSrcSpan expr) +#else + defExt +#endif + expr + (HsWC defExt typ) + -- | Equivalent of 'Language.Haskell.TH.Lib.tupE' tupE :: NonEmpty (LHsExpr GhcPs) -> LHsExpr GhcPs tupE xs = inheritLoc xs $ ExplicitTuple defExt - [inheritLoc' xs (Present defExt x) | x <- NE.toList xs] + [inheritLoc xs (Present defExt x) | x <- NE.toList xs] Boxed -- | Equivalent of 'Language.Haskell.TH.Lib.sigE' @@ -337,6 +348,10 @@ Types -------------------------------------------------------------------------------} +-- | Equivalent of 'Language.Haskell.TH.Lib.parensT' +parensT :: LHsType GhcPs -> LHsType GhcPs +parensT = noLocA . HsParTy defExt + -- | Equivalent of 'Language.Haskell.TH.Lib.litT' litT :: HsTyLit -> LHsType GhcPs litT = noLocA . HsTyLit defExt @@ -349,7 +364,7 @@ -- | Inverse to 'varT' viewVarT :: LHsType GhcPs -> Maybe LRdrName -viewVarT (reLoc -> L _ (HsTyVar _ _ (reLoc -> name))) | isTypeVar name = Just name +viewVarT (L _ (HsTyVar _ _ (reLoc -> name))) | isTypeVar name = Just name viewVarT _otherwise = Nothing pattern VarT :: HasCallStack => () => LRdrName -> LHsType GhcPs @@ -365,7 +380,7 @@ -- | Inverse to 'conT' viewConT :: LHsType GhcPs -> Maybe LRdrName -viewConT (reLoc -> L _ (HsTyVar _ _ (reLoc -> name))) | isTypeCon name = Just name +viewConT (L _ (HsTyVar _ _ (reLoc -> name))) | isTypeCon name = Just name viewConT _otherwise = Nothing pattern ConT :: HasCallStack => () => LRdrName -> LHsType GhcPs @@ -414,27 +429,27 @@ -- | Equivalent of 'Language.Haskell.TH.Lib.varP' varP :: LRdrName -> LPat GhcPs -varP name = inheritLocPat name (VarPat defExt (reLocA name)) +varP name = inheritLoc name (VarPat defExt (reLocA name)) -- | Equivalent of 'Language.Haskell.TH.Lib.conP' conP :: LRdrName -> [LPat GhcPs] -> LPat GhcPs #if __GLASGOW_HASKELL__ >= 902 -conP con args = inheritLocPat con (conPat con (PrefixCon [] args)) +conP con args = inheritLoc con (conPat con (PrefixCon [] args)) #else -conP con args = inheritLocPat con (conPat con (PrefixCon args)) +conP con args = inheritLoc con (conPat con (PrefixCon args)) #endif -- | Equivalent of 'Language.Haskell.TH.Lib.bangP' bangP :: LPat GhcPs -> LPat GhcPs -bangP p = inheritLocPat p $ BangPat defExt p +bangP p = inheritLoc p $ BangPat defExt p -- | Equivalent of 'Language.Haskell.TH.Lib.listP' listP :: [LPat GhcPs] -> LPat GhcPs -listP xs = inheritLocPat xs $ ListPat defExt xs +listP xs = inheritLoc xs $ ListPat defExt xs -- | Equivalent of 'Language.Haskell.TH.Lib.wildP' wildP :: LPat GhcPs -wildP = inheritLocPat noSrcSpan (WildPat defExt) +wildP = inheritLoc noSrcSpan (WildPat defExt) {------------------------------------------------------------------------------- Strictness @@ -453,7 +468,14 @@ -- | Equivalent of 'Language.Haskell.TH.Lib.equalP' equalP :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs -equalP x y = inheritLoc x $ mkHsOpTy x (inheritLoc x eqTyCon_RDR) y +equalP x y = inheritLoc x $ + mkHsOpTy +#if __GLASGOW_HASKELL__ >= 904 + NotPromoted +#endif + x + (inheritLoc x eqTyCon_RDR) + y {------------------------------------------------------------------------------- Constructors @@ -516,7 +538,7 @@ forallRecC vars ctxt conName args = inheritLoc conName $ ConDeclH98 { con_ext = defExt , con_name = reLocA conName - , con_forall = inheritLoc' conName True + , con_forall = inheritLoc conName True , con_ex_tvs = map (setDefaultSpecificity . mkBndr) vars , con_mb_cxt = Just (inheritLoc conName ctxt) , con_args = RecCon (inheritLoc conName $ map (uncurry mkRecField) args) @@ -591,7 +613,7 @@ , dd_cType = Nothing , dd_kindSig = Nothing , dd_cons = cons - , dd_derivs = inheritLoc' typeName derivs + , dd_derivs = inheritLoc typeName derivs } } @@ -704,13 +726,15 @@ where qualT :: [LHsType GhcPs] -> LHsType GhcPs -> LHsType GhcPs qualT [] a = a - qualT ctx@(c:_) a = inheritLoc c $ HsQualTy defExt -#if __GLASGOW_HASKELL__ >= 902 - (Just (inheritLoc c ctx)) + qualT ctx@(c:_) a = inheritLoc c $ + HsQualTy + defExt +#if __GLASGOW_HASKELL__ >= 902 && __GLASGOW_HASKELL__ < 904 + (Just (inheritLoc c ctx)) #else - (inheritLoc c ctx) + (inheritLoc c ctx) #endif - a + a -- | Equivalent of 'Language.Haskell.TH.Lib.classD' classD :: @@ -856,6 +880,6 @@ simpleGHRSs body = GRHSs defExt [inheritLoc body $ GRHS defExt [] body] - (inheritLoc' body $ EmptyLocalBinds defExt) + (inheritLoc body $ EmptyLocalBinds defExt) 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 @@ -15,29 +15,29 @@ import Data.Record.Internal.GHC.Fresh import Data.Record.Internal.GHC.Shim hiding (mkTyVar) import Data.Record.Internal.GHC.TemplateHaskellStyle +import Data.Record.Internal.Plugin.Names import Data.Record.Internal.Plugin.Record -import qualified Data.Record.Internal.Plugin.Names.GhcGenerics as GHC -import qualified Data.Record.Internal.Plugin.Names.Runtime as RT - {------------------------------------------------------------------------------- Top-level -------------------------------------------------------------------------------} -- | Generate all large-records definitions for a record. -genLargeRecord :: MonadFresh m => Record -> DynFlags -> m [LHsDecl GhcPs] -genLargeRecord r@Record{..} dynFlags = concatM [ - (:[]) <$> genDatatype r - , genVectorConversions r - , genIndexedAccessor r - , genUnsafeSetIndex r - , genStockInstances r - , mapM (genHasFieldInstance r) recordFields +genLargeRecord :: MonadFresh m + => QualifiedNames + -> Record -> DynFlags -> m [LHsDecl GhcPs] +genLargeRecord names r@Record{..} dynFlags = concatM [ + (:[]) <$> genDatatype r + , genVectorConversions names r + , genIndexedAccessor names r + , genUnsafeSetIndex names r + , genStockInstances names r + , mapM (genHasFieldInstance names r) recordFields , sequence [ - genConstraintsClass r - , genConstraintsInstance r - , genGenericInstance r dynFlags - , genGHCGeneric r + genConstraintsClass names r + , genConstraintsInstance names r + , genGenericInstance names r dynFlags + , genGHCGeneric names r ] ] @@ -102,7 +102,7 @@ (zipWith fieldExistentialType vars recordFields) ] - [ DerivClause (Just (noLoc (withDefExt AnyclassStrategy))) (c :| []) + [ DerivClause (Just (withoutLoc (withDefExt AnyclassStrategy))) (c :| []) | DeriveAnyClass c <- recordDerivings ] where @@ -151,12 +151,16 @@ -- -- TODO: From ghc 9.2, these could be identity functions. See 'genDatatype' -- for details. -genVectorConversions :: forall m. MonadFresh m => Record -> m [LHsDecl GhcPs] -genVectorConversions r@Record{..} = concatM [ +genVectorConversions :: forall m. + MonadFresh m + => QualifiedNames -> Record -> m [LHsDecl GhcPs] +genVectorConversions QualifiedNames{..} r@Record{..} = concatM [ fromVector , toVector ] where + UnqualifiedNames{..} = getUnqualifiedNames + fromVector :: m [LHsDecl GhcPs] fromVector = do args <- mapM (freshName . fieldName) recordFields @@ -164,12 +168,12 @@ sigD name $ funT (recordTypeT r) - (ConT RT.type_SmallArray `appT` ConT RT.type_Any) + (ConT type_AnyArray) , valD name $ lamE1 (conP recordConName (map varP args)) $ appE - (VarE RT.smallArrayFromList) - (listE [ VarE RT.unsafeCoerce `appE` VarE arg + (VarE anyArrayFromList) + (listE [ VarE noInlineUnsafeCo `appE` VarE arg | arg <- args ] ) @@ -185,21 +189,21 @@ return $ [ sigD name $ funT - (ConT RT.type_SmallArray `appT` ConT RT.type_Any) + (ConT type_AnyArray) (recordTypeT r) , valD name $ lamE1 (varP x) $ caseE - (VarE RT.smallArrayToList `appE` VarE x) + (VarE anyArrayToList `appE` VarE x) [ ( listP (map varP args) , appsE (ConE recordConName) - [ VarE RT.unsafeCoerce `appE` VarE arg + [ VarE noInlineUnsafeCo `appE` VarE arg | arg <- args ] ) , ( wildP - , VarE RT.error `appE` stringE matchErr + , VarE unq_error `appE` stringE matchErr ) ] ] @@ -230,28 +234,33 @@ -- -- > unsafeGetIndexT :: forall x a b. Int -> T a b -> x -- > unsafeGetIndexT = \ n t -> noInlineUnsafeCo (V.unsafeIndex (vectorFromT t) n) -genIndexedAccessor :: MonadFresh m => Record -> m [LHsDecl GhcPs] -genIndexedAccessor r@Record{..} = do - x <- freshName $ mkTyVar recordAnnLoc "x" +genIndexedAccessor :: + MonadFresh m + => QualifiedNames + -> Record -> m [LHsDecl GhcPs] +genIndexedAccessor QualifiedNames{..} r@Record{..} = do + x <- freshName' False $ mkTyVar recordAnnLoc "x" n <- freshName $ mkExpVar recordAnnLoc "n" t <- freshName $ mkExpVar recordAnnLoc "t" return [ sigD name $ funT - (ConT RT.type_Int) + (ConT unq_type_Int) (recordTypeT r `funT` VarT x) , valD name $ lamE (varP n :| [varP t]) $ appE - (VarE RT.noInlineUnsafeCo) + (VarE noInlineUnsafeCo) (appsE - (VarE RT.indexSmallArray) + (VarE anyArrayIndex) [ VarE (nameVectorFrom r) `appE` VarE t , VarE n ] ) ] where + UnqualifiedNames{..} = getUnqualifiedNames + name :: LRdrName name = nameUnsafeGetIndex r @@ -267,32 +276,37 @@ -- would need to take the strictness of the fields into account. If we change -- our internal representation, we might need to be more careful with that -- again. See 'genTo' for further discussion. -genUnsafeSetIndex :: MonadFresh m => Record -> m [LHsDecl GhcPs] -genUnsafeSetIndex r@Record{..} = do - x <- freshName $ mkTyVar recordAnnLoc "x" +genUnsafeSetIndex :: + MonadFresh m + => QualifiedNames + -> Record -> m [LHsDecl GhcPs] +genUnsafeSetIndex QualifiedNames{..} r@Record{..} = do + x <- freshName' False $ mkTyVar recordAnnLoc "x" n <- freshName $ mkExpVar recordAnnLoc "n" t <- freshName $ mkExpVar recordAnnLoc "t" val <- freshName $ mkExpVar recordAnnLoc "val" return [ sigD name $ - ConT RT.type_Int + ConT unq_type_Int `funT` (recordTypeT r `funT` (VarT x `funT` recordTypeT r)) , valD name $ lamE (varP n :| [varP t, (varP val)]) $ appE (VarE (nameVectorTo r)) (appsE - (VarE RT.updateSmallArray) + (VarE anyArrayUpdate) [ VarE (nameVectorFrom r) `appE` VarE t , listE [ tupE $ VarE n - :| [VarE RT.noInlineUnsafeCo `appE` VarE val] + :| [VarE noInlineUnsafeCo `appE` VarE val] ] ] ) ] where + UnqualifiedNames{..} = getUnqualifiedNames + name :: LRdrName name = nameUnsafeSetIndex r @@ -302,21 +316,23 @@ -- -- > instance x ~ Word => HasField "tInt" (T a b) x where -- > hasField = \t -> (unsafeSetIndexT 0 t, unsafeGetIndexT 0 t) -genHasFieldInstance :: MonadFresh m => Record -> Field -> m (LHsDecl GhcPs) -genHasFieldInstance r@Record{..} Field{..} = do - x <- freshName $ mkTyVar recordAnnLoc "x" +genHasFieldInstance :: MonadFresh m + => QualifiedNames + -> Record -> Field -> m (LHsDecl GhcPs) +genHasFieldInstance QualifiedNames{..} r@Record{..} Field{..} = do + x <- freshName' False $ mkTyVar recordAnnLoc "x" t <- freshName $ mkExpVar recordAnnLoc "t" return $ instanceD [equalP (VarT x) fieldType] (appsT - (ConT RT.type_HasField) + (ConT type_HasField) [ stringT (nameBase fieldName) , recordTypeT r , VarT x ] ) - [ ( RT.unq_hasField + [ ( hasField , lamE1 (varP t) $ tupE $ appsE (VarE (nameUnsafeSetIndex r)) [intE fieldIndex, VarE t] @@ -346,19 +362,21 @@ -- and use lots of "tuple constraint extractor" functions, each of which have -- the same size as the number of constraints (another example of a -- @case f of { T x1 x2 x3 .. -> xn@ function, but now at the dictionary level). -genConstraintsClass :: MonadFresh m => Record -> m (LHsDecl GhcPs) -genConstraintsClass r@Record{..} = do - c <- freshName $ mkTyVar recordAnnLoc "c" +genConstraintsClass :: + MonadFresh m + => QualifiedNames -> Record -> m (LHsDecl GhcPs) +genConstraintsClass QualifiedNames{..} r@Record{..} = do + c <- freshName' False $ mkTyVar recordAnnLoc "c" return $ classD [] (nameConstraints r) (recordTyVars ++ [kindedTV c cKind]) [ ( nameDictConstraints r , funT - (ConT RT.type_Proxy `appT` VarT c) + (ConT type_Proxy `appT` VarT c) (appsT - (ConT RT.type_Rep) - [ ConT RT.type_Dict `appT` VarT c + (ConT type_Rep) + [ ConT type_Dict `appT` VarT c , recordTypeT r ] ) @@ -366,7 +384,7 @@ ] where cKind :: LHsType GhcPs - cKind = ConT RT.type_Type `funT` ConT RT.type_Constraint + cKind = ConT type_Type `funT` ConT type_Constraint -- | Superclass constraints required by the constraints class instance -- @@ -413,23 +431,23 @@ -- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy a)) -- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy [b])) -- > ]) -genDict :: MonadFresh m => Record -> m (LHsExpr GhcPs) -genDict Record{..} = do +genDict :: + MonadFresh m + => QualifiedNames + -> Record -> m (LHsExpr GhcPs) +genDict names@QualifiedNames{..} Record{..} = do p <- freshName $ mkExpVar recordAnnLoc "p" return $ lamE1 (varP p) $ appE - (ConE RT.con_Rep) - (appE - (VarE RT.smallArrayFromList) - (listE (map (dictForField p) recordFields)) - ) + (VarE mkDicts) + (listE (map (dictForField p) recordFields)) where dictForField :: LRdrName -> Field -> LHsExpr GhcPs dictForField p Field{..} = appE - (VarE RT.noInlineUnsafeCo) - (VarE RT.dictFor `appsE` [VarE p, proxyE fieldType]) + (VarE noInlineUnsafeCo) + (VarE mkDict `appsE` [VarE p, proxyE names fieldType]) -- | Generate (one and only) instance of the constraints class -- @@ -439,10 +457,12 @@ -- > dictConstraints_T = .. -- -- where the body of @dictConstraints_T@ is generated by 'genDict'. -genConstraintsInstance :: MonadFresh m => Record -> m (LHsDecl GhcPs) -genConstraintsInstance r@Record{..} = do - body <- genDict r - c <- freshName $ mkTyVar recordAnnLoc "c" +genConstraintsInstance :: + MonadFresh m + => QualifiedNames -> Record -> m (LHsDecl GhcPs) +genConstraintsInstance names r@Record{..} = do + body <- genDict names r + c <- freshName' False $ mkTyVar recordAnnLoc "c" return $ instanceD (genRequiredConstraints r (VarT c)) @@ -468,68 +488,51 @@ -- > , FieldMetadata (Proxy :: Proxy "tListB")) FieldLazy -- > ] -- > } -genMetadata :: MonadFresh m => Record -> DynFlags -> m (LHsExpr GhcPs) -genMetadata r@Record{..} dynFlags = do +genMetadata :: + MonadFresh m + => QualifiedNames + -> Record -> DynFlags -> m (LHsExpr GhcPs) +genMetadata names@QualifiedNames{..} r@Record{..} dynFlags = do p <- freshName $ mkExpVar recordAnnLoc "p" return $ lamE1 (varP p) $ - recConE - RT.con_Metadata [ - ( RT.recordName - , stringE (nameRecord r) - ) - , ( RT.recordConstructor - , stringE (nameBase recordConName) - ) - , ( RT.recordSize - , intE (length recordFields) - ) - , ( RT.recordFieldMetadata - , appE - (ConE RT.con_Rep) - (appE - (VarE RT.smallArrayFromList) - (listE (map auxField recordFields)) - ) - ) - ] + appsE (VarE mkMetadata) [ + stringE (nameRecord r) + , stringE (nameBase recordConName) + , listE (map auxField recordFields) + ] where auxField :: Field -> LHsExpr GhcPs auxField Field{..} = - appsE - (ConE RT.con_FieldMetadata) - [ proxyE (stringT (nameBase fieldName)) - , ConE $ case decideStrictness dynFlags fieldStrictness of - HsStrict -> RT.con_FieldStrict - HsLazy -> RT.con_FieldLazy - HsUnpack _ -> RT.con_FieldStrict - ] + (appE . VarE $ if isStrict dynFlags fieldStrictness + then mkStrictField + else mkLazyField) + $ proxyE names + $ stringT (nameBase fieldName) --- | Implementation of https://hackage.haskell.org/package/base-4.16.1.0/docs/GHC-Generics.html#t:DecidedStrictness -decideStrictness :: DynFlags -> HsSrcBang -> HsImplBang -decideStrictness dynFlags (HsSrcBang _ unpackedness strictness) = - case (unpackedness, srcToImpl strictness) of - (SrcUnpack, HsStrict) | optimizations -> HsUnpack Nothing - (_, strictness') -> strictness' +isStrict :: DynFlags -> HsSrcBang -> Bool +isStrict dynFlags (HsSrcBang _ _ strictness) = + case strictness of + SrcStrict -> True + SrcLazy -> False + NoSrcStrict -> if strictData then True else False where strictData = xopt StrictData dynFlags - optimizations = optLevel dynFlags >= 1 - srcToImpl = \case - SrcStrict -> HsStrict - SrcLazy -> HsLazy - NoSrcStrict -> if strictData then HsStrict else HsLazy -- | Generate definition for `from` in the `Generic` instance -- -- Generates something like -- -- > repFromVectorStrict . vectorFromT -genFrom :: MonadFresh m => Record -> m (LHsExpr GhcPs) -genFrom r@Record{..} = do +genFrom :: + MonadFresh m + => QualifiedNames + -> Record -> m (LHsExpr GhcPs) +genFrom QualifiedNames{..} r@Record{..} = do x <- freshName $ mkExpVar recordAnnLoc "x" return $ lamE1 (varP x) $ - VarE RT.repFromVector `appE` (VarE (nameVectorFrom r) `appE` VarE x) + VarE anyArrayToRep `appE` (VarE (nameVectorFrom r) `appE` VarE x) -- | Generate definition for `to` in the `Generic` instance -- @@ -541,12 +544,15 @@ -- " normal " record as our internal representation (albeit with strange types), -- and the fields of that record have their own strictness annotation, we don't -- have to worry about strictness here. -genTo :: MonadFresh m => Record -> m (LHsExpr GhcPs) -genTo r@Record{..} = do +genTo :: + MonadFresh m + => QualifiedNames + -> Record -> m (LHsExpr GhcPs) +genTo QualifiedNames{..} r@Record{..} = do x <- freshName $ mkExpVar recordAnnLoc "x" return $ lamE1 (varP x) $ - VarE (nameVectorTo r) `appE` (VarE RT.repToVector `appE` VarE x) + VarE (nameVectorTo r) `appE` (VarE anyArrayFromRep `appE` VarE x) -- | Generate an instance of large-records 'Data.Record.Generic'. -- @@ -561,40 +567,45 @@ -- > to = .. -- > dict = dictConstraints_T -- > metadata = .. -genGenericInstance :: MonadFresh m => Record -> DynFlags -> m (LHsDecl GhcPs) -genGenericInstance r@Record{..} dynFlags = do - metadata <- genMetadata r dynFlags - from <- genFrom r - to <- genTo r +genGenericInstance :: + MonadFresh m + => QualifiedNames + -> Record -> DynFlags -> m (LHsDecl GhcPs) +genGenericInstance names@QualifiedNames{..} r@Record{..} dynFlags = do + metadata <- genMetadata names r dynFlags + from <- genFrom names r + to <- genTo names r return $ instanceD [] - (ConT RT.type_Generic `appT` recordTypeT r) - [ ( RT.unq_from , from ) - , ( RT.unq_to , to ) - , ( RT.unq_dict , VarE (nameDictConstraints r) ) - , ( RT.unq_metadata , metadata ) + (ConT type_LR_Generic `appT` recordTypeT r) + [ ( lr_from , from ) + , ( lr_to , to ) + , ( lr_dict , VarE (nameDictConstraints r) ) + , ( lr_metadata , metadata ) ] - [ tySynEqn RT.unq_type_Constraints [recordTypeT r] $ + [ tySynEqn type_LR_Constraints [recordTypeT r] $ appsT (ConT (nameConstraints r)) [VarT (tyVarBndrName v) | v <- recordTyVars] - , tySynEqn RT.unq_type_MetadataOf [recordTypeT r] $ + , tySynEqn type_LR_MetadataOf [recordTypeT r] $ listT [ tupT $ stringT (nameBase fieldName) :| [fieldType] | Field{..} <- recordFields ] ] - where {------------------------------------------------------------------------------- "Stock" instances -------------------------------------------------------------------------------} -- | Generate stock instances -genStockInstances :: MonadFresh m => Record -> m [LHsDecl GhcPs] -genStockInstances r@Record{..} = concatM [ - genStockInstance r d +genStockInstances :: + MonadFresh m + => QualifiedNames + -> Record -> m [LHsDecl GhcPs] +genStockInstances names r@Record{..} = concatM [ + genStockInstance names r d | DeriveStock d <- recordDerivings ] @@ -609,13 +620,17 @@ -- TODO: For 'Generic' we currently don't do anything. We could change this so -- that we generate the 'GHC.Generics' instance only when the user asks for a -- 'Generics' instance? -genStockInstance :: MonadFresh m => Record -> StockDeriving -> m [LHsDecl GhcPs] -genStockInstance r = pure . \case - Show -> [mkInstance RT.type_Show RT.unq_showsPrec RT.gshowsPrec] - Eq -> [mkInstance RT.type_Eq RT.unq_eq RT.geq ] - Ord -> [mkInstance RT.type_Ord RT.unq_compare RT.gcompare ] +genStockInstance :: MonadFresh m + => QualifiedNames + -> Record -> StockDeriving -> m [LHsDecl GhcPs] +genStockInstance QualifiedNames{..} r = pure . \case + Show -> [mkInstance unq_type_Show unq_showsPrec gshowsPrec] + Eq -> [mkInstance unq_type_Eq unq_eq geq ] + Ord -> [mkInstance unq_type_Ord unq_compare gcompare ] Generic -> [] where + UnqualifiedNames{..} = getUnqualifiedNames + mkInstance :: LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs mkInstance cls mthd gen = instanceD @@ -639,16 +654,18 @@ -- > to = unwrapThroughLRGenerics -- -- See 'ThroughLRGenerics' for documentation. -genGHCGeneric :: MonadFresh m => Record -> m (LHsDecl GhcPs) -genGHCGeneric r = pure $ +genGHCGeneric :: + MonadFresh m + => QualifiedNames -> Record -> m (LHsDecl GhcPs) +genGHCGeneric QualifiedNames{..} r = pure $ instanceD [] - (ConT GHC.type_Generic `appT` recordTypeT r) - [ ( GHC.unq_from , ConE RT.con_WrapThroughLRGenerics ) - , ( GHC.unq_to , VarE RT.unwrapThroughLRGenerics ) + (ConT type_GHC_Generic `appT` recordTypeT r) + [ ( ghc_from , VarE wrapThroughLRGenerics ) + , ( ghc_to , VarE unwrapThroughLRGenerics ) ] - [ tySynEqn GHC.unq_type_Rep [recordTypeT r] $ - ConT RT.type_ThroughLRGenerics `appT` recordTypeT r + [ tySynEqn type_GHC_Rep [recordTypeT r] $ + ConT type_ThroughLRGenerics `appT` recordTypeT r ] {------------------------------------------------------------------------------- @@ -692,8 +709,9 @@ -- | Generate a Proxy expression for the given type. -- -- @proxyE [t|ty|]@ will result in a @Proxy :: Proxy ty@. -proxyE :: LHsType GhcPs -> LHsExpr GhcPs -proxyE ty = sigE (ConE RT.con_Proxy) (ConT RT.type_Proxy `appT` ty) +proxyE :: QualifiedNames -> LHsType GhcPs -> LHsExpr GhcPs +proxyE QualifiedNames{..} ty = + sigE (VarE proxy) (ConT type_Proxy `appT` ty) concatM :: Applicative m => [m [a]] -> m [a] concatM = fmap concat . sequenceA diff --git a/src/Data/Record/Internal/Plugin/Exception.hs b/src/Data/Record/Internal/Plugin/Exception.hs --- a/src/Data/Record/Internal/Plugin/Exception.hs +++ b/src/Data/Record/Internal/Plugin/Exception.hs @@ -18,9 +18,9 @@ exceptionLoc :: Exception -> SrcSpan exceptionLoc = \case - UnsupportedStockDeriving (reLoc -> L l _) -> l - UnsupportedStrategy (id -> L l _) -> l - InvalidDeclaration (reLoc -> L l _) -> l + UnsupportedStockDeriving x -> toSrcSpan x + UnsupportedStrategy x -> toSrcSpan x + InvalidDeclaration x -> toSrcSpan x exceptionToSDoc :: Exception -> SDoc exceptionToSDoc = hsep . \case diff --git a/src/Data/Record/Internal/Plugin/Names.hs b/src/Data/Record/Internal/Plugin/Names.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Plugin/Names.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Data.Record.Internal.Plugin.Names ( + -- * Qualified names + QualifiedNames(..) + , getQualifiedNames + -- * Unqualified names + , UnqualifiedNames(..) + , getUnqualifiedNames + ) where + +import Data.Record.Internal.GHC.Shim + +{------------------------------------------------------------------------------- + Qualified names +-------------------------------------------------------------------------------} + +data QualifiedNames = QualifiedNames { + + -- + -- Base + -- + + type_Constraint :: LRdrName + , type_GHC_Generic :: LRdrName + , type_GHC_Rep :: LRdrName + , type_Proxy :: LRdrName + , type_Type :: LRdrName + , proxy :: LRdrName + , ghc_from :: LRdrName + , ghc_to :: LRdrName + + -- + -- AnyArray + -- + + , type_AnyArray :: LRdrName + , anyArrayFromList :: LRdrName + , anyArrayToList :: LRdrName + , anyArrayIndex :: LRdrName + , anyArrayUpdate :: LRdrName + + -- + -- large-generics + -- + + , type_LR_Generic :: LRdrName + , type_LR_MetadataOf :: LRdrName + , type_LR_Constraints :: LRdrName + , lr_from :: LRdrName + , lr_to :: LRdrName + , lr_dict :: LRdrName + , lr_metadata :: LRdrName + + -- .. wrappers + + , type_Rep :: LRdrName + , type_Dict :: LRdrName + , gcompare :: LRdrName + , geq :: LRdrName + , gshowsPrec :: LRdrName + , noInlineUnsafeCo :: LRdrName + + -- .. utilities + + , anyArrayToRep :: LRdrName + , anyArrayFromRep :: LRdrName + , mkDicts :: LRdrName + , mkDict :: LRdrName + , mkStrictField :: LRdrName + , mkLazyField :: LRdrName + , mkMetadata :: LRdrName + + -- .. ThroughLRGenerics + + , type_ThroughLRGenerics :: LRdrName + , wrapThroughLRGenerics :: LRdrName + , unwrapThroughLRGenerics :: LRdrName + + -- + -- record-hasfield + -- + + , type_HasField :: LRdrName + , hasField :: LRdrName + } + +-- | Resolve qualified names +-- +-- We try to import whenever possible from "Data.Record.Plugin.Runtime"; only +-- when this is /really/ not possible do we import from other modules. We do +-- this to avoid two problems: +-- +-- * When we resolve a name, we must specify the module where something is +-- /defined/, not merely a module that /exports/ the thing we need; this means +-- that this is quite brittle. +-- +-- * When we resolve a name from a different package, users must explicitly +-- define a dependency on that other package. +getQualifiedNames :: Hsc QualifiedNames +getQualifiedNames = do + -- + -- base + -- + + type_Constraint <- exact <$> lookupTcName runtime Nothing "Constraint" + type_GHC_Generic <- exact <$> lookupTcName ghcGenerics Nothing "Generic" + type_GHC_Rep <- exact <$> lookupTcName ghcGenerics Nothing "Rep" + type_Proxy <- exact <$> lookupTcName runtime Nothing "Proxy" + type_Type <- exact <$> lookupTcName runtime Nothing "Type" + proxy <- exact <$> lookupVarName runtime Nothing "proxy" + ghc_from <- exact <$> lookupVarName ghcGenerics Nothing "from" + ghc_to <- exact <$> lookupVarName ghcGenerics Nothing "to" + + -- + -- AnyArray + -- + + type_AnyArray <- exact <$> lookupTcName runtime Nothing "AnyArray" + anyArrayFromList <- exact <$> lookupVarName runtime Nothing "anyArrayFromList" + anyArrayToList <- exact <$> lookupVarName runtime Nothing "anyArrayToList" + anyArrayIndex <- exact <$> lookupVarName runtime Nothing "anyArrayIndex" + anyArrayUpdate <- exact <$> lookupVarName runtime Nothing "anyArrayUpdate" + + -- + -- large-generics + -- + + type_LR_Generic <- exact <$> lookupTcName largeGenerics (Just "large-generics") "Generic" + type_LR_Constraints <- exact <$> lookupTcName largeGenerics (Just "large-generics") "Constraints" + type_LR_MetadataOf <- exact <$> lookupTcName largeGenerics (Just "large-generics") "MetadataOf" + lr_from <- exact <$> lookupVarName largeGenerics (Just "large-generics") "from" + lr_to <- exact <$> lookupVarName largeGenerics (Just "large-generics") "to" + lr_dict <- exact <$> lookupVarName largeGenerics (Just "large-generics") "dict" + lr_metadata <- exact <$> lookupVarName largeGenerics (Just "large-generics") "metadata" + + -- .. utilities + + anyArrayToRep <- exact <$> lookupVarName runtime Nothing "anyArrayToRep" + anyArrayFromRep <- exact <$> lookupVarName runtime Nothing "anyArrayFromRep" + mkDicts <- exact <$> lookupVarName runtime Nothing "mkDicts" + mkDict <- exact <$> lookupVarName runtime Nothing "mkDict" + mkStrictField <- exact <$> lookupVarName runtime Nothing "mkStrictField" + mkLazyField <- exact <$> lookupVarName runtime Nothing "mkLazyField" + mkMetadata <- exact <$> lookupVarName runtime Nothing "mkMetadata" + + -- .. wrappers + + type_Rep <- exact <$> lookupTcName runtime Nothing "Rep" + type_Dict <- exact <$> lookupTcName runtime Nothing "Dict" + gcompare <- exact <$> lookupVarName runtime Nothing "gcompare" + geq <- exact <$> lookupVarName runtime Nothing "geq" + gshowsPrec <- exact <$> lookupVarName runtime Nothing "gshowsPrec" + noInlineUnsafeCo <- exact <$> lookupVarName runtime Nothing "noInlineUnsafeCo" + + -- .. ThroughLRGenerics + + type_ThroughLRGenerics <- exact <$> lookupTcName runtime Nothing "ThroughLRGenerics" + wrapThroughLRGenerics <- exact <$> lookupVarName runtime Nothing "wrapThroughLRGenerics" + unwrapThroughLRGenerics <- exact <$> lookupVarName runtime Nothing "unwrapThroughLRGenerics" + + -- + -- record-hasfield + -- + + type_HasField <- exact <$> lookupTcName recordHasField (Just "record-hasfield") "HasField" + hasField <- exact <$> lookupVarName recordHasField (Just "record-hasfield") "hasField" + + return QualifiedNames{..} + + where + exact :: Name -> LRdrName + exact = noLoc . Exact + + runtime, recordHasField, ghcGenerics, largeGenerics :: ModuleName + runtime = mkModuleName "Data.Record.Plugin.Runtime" + recordHasField = mkModuleName "GHC.Records.Compat" + ghcGenerics = mkModuleName "GHC.Generics" + largeGenerics = mkModuleName "Data.Record.Generic" + +{------------------------------------------------------------------------------- + We use Prelude names unqualified. +-------------------------------------------------------------------------------} + +data UnqualifiedNames = UnqualifiedNames { + unq_type_Eq :: LRdrName + , unq_type_Int :: LRdrName + , unq_type_Ord :: LRdrName + , unq_type_Show :: LRdrName + , unq_compare :: LRdrName + , unq_eq :: LRdrName + , unq_error :: LRdrName + , unq_showsPrec :: LRdrName + } + +getUnqualifiedNames :: UnqualifiedNames +getUnqualifiedNames = UnqualifiedNames { + unq_type_Eq = tc "Eq" + , unq_type_Int = tc "Int" + , unq_type_Ord = tc "Ord" + , unq_type_Show = tc "Show" + , unq_compare = var "compare" + , unq_eq = var "==" + , unq_error = var "error" + , unq_showsPrec = var "showsPrec" + } + where + var, tc :: String -> LRdrName + var x = noLoc $ mkRdrUnqual $ mkVarOcc x + tc x = noLoc $ mkRdrUnqual $ mkTcOcc x diff --git a/src/Data/Record/Internal/Plugin/Names/GhcGenerics.hs b/src/Data/Record/Internal/Plugin/Names/GhcGenerics.hs deleted file mode 100644 --- a/src/Data/Record/Internal/Plugin/Names/GhcGenerics.hs +++ /dev/null @@ -1,42 +0,0 @@ --- | Names for GHC generics --- --- We cannot make this part of the main ghcGenerics, because the names clash --- with @large-records@ generics. -module Data.Record.Internal.Plugin.Names.GhcGenerics ( - type_Generic - , unq_type_Rep - , unq_from - , unq_to - ) where - -import Data.Record.Internal.GHC.Shim - -{------------------------------------------------------------------------------- - Names of GHC.Generics --------------------------------------------------------------------------------} - -type_Generic :: LRdrName -type_Generic = nameQT "Generic" - -unq_type_Rep :: LRdrName -unq_type_Rep = nameUT "Rep" - -unq_from, unq_to :: LRdrName -unq_from = nameUV "from" -unq_to = nameUV "to" - -{------------------------------------------------------------------------------- - Internal auxiliary - - NOTE: Unqualified names are used when generating class instances. --------------------------------------------------------------------------------} - -ghcGenerics :: ModuleName -ghcGenerics = mkModuleName "GHC.Generics" - -nameQT :: String -> LRdrName -nameQT var = noLoc $ mkRdrQual ghcGenerics $ mkTcOcc var - -nameUV, nameUT :: String -> LRdrName -nameUV var = noLoc $ mkRdrUnqual $ mkVarOcc var -nameUT var = noLoc $ mkRdrUnqual $ mkTcOcc var diff --git a/src/Data/Record/Internal/Plugin/Names/Runtime.hs b/src/Data/Record/Internal/Plugin/Names/Runtime.hs deleted file mode 100644 --- a/src/Data/Record/Internal/Plugin/Names/Runtime.hs +++ /dev/null @@ -1,223 +0,0 @@ --- | Names of all everything used by the generated code --- --- This follows the structure of "Data.Record.Plugin.Runtime". -module Data.Record.Internal.Plugin.Names.Runtime ( - -- * base - type_Any - , type_Constraint - , type_Eq - , type_Int - , type_Ord - , type_Proxy - , type_Show - , type_Type - , con_Proxy - , unq_compare - , unq_eq - , unq_showsPrec - , error - , unsafeCoerce - -- * primitive - , type_SmallArray - , smallArrayFromList - , smallArrayToList - , indexSmallArray - , updateSmallArray - -- * record-hasfield - , type_HasField - , unq_hasField - -- * large-generics - , type_Dict - , type_Generic - , type_Rep - , type_ThroughLRGenerics - , unq_type_Constraints - , unq_type_MetadataOf - , con_FieldLazy - , con_FieldMetadata - , con_FieldStrict - , con_Metadata - , con_Rep - , con_WrapThroughLRGenerics - , unq_from - , unq_to - , unq_dict - , unq_metadata - , gcompare - , geq - , gshowsPrec - , noInlineUnsafeCo - , recordConstructor - , recordFieldMetadata - , recordName - , recordSize - , unwrapThroughLRGenerics - -- * Auxiliary - , dictFor - , repFromVector - , repToVector - ) where - -import Prelude hiding (error, showsPrec, compare) - -import Data.Record.Internal.GHC.Shim - -{------------------------------------------------------------------------------- - base --------------------------------------------------------------------------------} - -type_Any :: LRdrName -type_Constraint :: LRdrName -type_Eq :: LRdrName -type_Int :: LRdrName -type_Ord :: LRdrName -type_Proxy :: LRdrName -type_Show :: LRdrName -type_Type :: LRdrName - -type_Any = nameQT "Any" -type_Constraint = nameQT "Constraint" -type_Eq = nameQT "Eq" -type_Int = nameQT "Int" -type_Ord = nameQT "Ord" -type_Proxy = nameQT "Proxy" -type_Show = nameQT "Show" -type_Type = nameQT "Type" - -con_Proxy :: LRdrName -con_Proxy = nameQC "Proxy" - -error :: LRdrName -unsafeCoerce :: LRdrName - -error = nameQV "error" -unsafeCoerce = nameQV "unsafeCoerce" - -unq_compare :: LRdrName -unq_eq :: LRdrName -unq_showsPrec :: LRdrName - -unq_compare = nameUV "compare" -unq_eq = nameUV "==" -unq_showsPrec = nameUV "showsPrec" - -{------------------------------------------------------------------------------- - vector --------------------------------------------------------------------------------} - -type_SmallArray :: LRdrName -type_SmallArray = nameQT "SmallArray" - -smallArrayFromList :: LRdrName -smallArrayToList :: LRdrName -indexSmallArray :: LRdrName -updateSmallArray :: LRdrName - -smallArrayFromList = nameQV "smallArrayFromList" -smallArrayToList = nameQV "smallArrayToList" -indexSmallArray = nameQV "indexSmallArray" -updateSmallArray = nameQV "updateSmallArray" - -{------------------------------------------------------------------------------- - record-hasfield --------------------------------------------------------------------------------} - -type_HasField :: LRdrName -type_HasField = nameQT "HasField" - -unq_hasField :: LRdrName -unq_hasField = nameUV "hasField" - -{------------------------------------------------------------------------------- - large-generics --------------------------------------------------------------------------------} - -type_Dict :: LRdrName -type_Generic :: LRdrName -type_Rep :: LRdrName -type_ThroughLRGenerics :: LRdrName - -type_Dict = nameQT "Dict" -type_Generic = nameQT "Generic" -type_Rep = nameQT "Rep" -type_ThroughLRGenerics = nameQT "ThroughLRGenerics" - -unq_type_MetadataOf :: LRdrName -unq_type_Constraints :: LRdrName - -unq_type_Constraints = nameUT "Constraints" -unq_type_MetadataOf = nameUT "MetadataOf" - -con_FieldLazy :: LRdrName -con_FieldMetadata :: LRdrName -con_FieldStrict :: LRdrName -con_Metadata :: LRdrName -con_Rep :: LRdrName -con_WrapThroughLRGenerics :: LRdrName - -con_FieldLazy = nameQC "FieldLazy" -con_FieldMetadata = nameQC "FieldMetadata" -con_FieldStrict = nameQC "FieldStrict" -con_Metadata = nameQC "Metadata" -con_Rep = nameQC "Rep" -con_WrapThroughLRGenerics = nameQC "WrapThroughLRGenerics" - -unq_from :: LRdrName -unq_to :: LRdrName -unq_dict :: LRdrName -unq_metadata :: LRdrName - -unq_from = nameUV "from" -unq_to = nameUV "to" -unq_dict = nameUV "dict" -unq_metadata = nameUV "metadata" - -gcompare :: LRdrName -geq :: LRdrName -gshowsPrec :: LRdrName -noInlineUnsafeCo :: LRdrName -recordConstructor :: LRdrName -recordFieldMetadata :: LRdrName -recordName :: LRdrName -recordSize :: LRdrName -unwrapThroughLRGenerics :: LRdrName - -gcompare = nameQV "gcompare" -geq = nameQV "geq" -gshowsPrec = nameQV "gshowsPrec" -noInlineUnsafeCo = nameQV "noInlineUnsafeCo" -recordConstructor = nameQV "recordConstructor" -recordFieldMetadata = nameQV "recordFieldMetadata" -recordName = nameQV "recordName" -recordSize = nameQV "recordSize" -unwrapThroughLRGenerics = nameQV "unwrapThroughLRGenerics" - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - -dictFor :: LRdrName -repFromVector :: LRdrName -repToVector :: LRdrName - -dictFor = nameQV "dictFor" -repFromVector = nameQV "repFromVector" -repToVector = nameQV "repToVector" - -{------------------------------------------------------------------------------- - Internal auxiliary - - NOTE: Unqualified names are used when generating class instances. --------------------------------------------------------------------------------} - -runtime :: ModuleName -runtime = mkModuleName "Data.Record.Plugin.Runtime" - -nameQV, nameQT, nameQC :: String -> LRdrName -nameQV var = noLoc $ mkRdrQual runtime $ mkVarOcc var -nameQT var = noLoc $ mkRdrQual runtime $ mkTcOcc var -nameQC var = noLoc $ mkRdrQual runtime $ mkDataOcc var - -nameUV, nameUT :: String -> LRdrName -nameUV var = noLoc $ mkRdrUnqual $ mkVarOcc var -nameUT var = noLoc $ mkRdrUnqual $ mkTcOcc var 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 @@ -1,7 +1,9 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ViewPatterns #-} -- | Generation options for large-records. module Data.Record.Internal.Plugin.Options ( @@ -16,6 +18,7 @@ import Data.Data (Data) import Data.Map (Map) import Data.Maybe (mapMaybe) +import GHC.Records.Compat import qualified Data.Generics as SYB import qualified Data.Map.Strict as Map @@ -49,6 +52,15 @@ } {------------------------------------------------------------------------------- + HasField instances + + These instances are required in modules that enable 'OverloadedRecordUpdate' +-------------------------------------------------------------------------------} + +instance HasField "debugLargeRecords" LargeRecordOptions Bool where + hasField r = (\x -> r{debugLargeRecords = x}, debugLargeRecords r) + +{------------------------------------------------------------------------------- Extract options from module -------------------------------------------------------------------------------} @@ -86,7 +98,7 @@ opts <- intOptions expr updates <- mapM intUpdate fields return $ foldr (.) id updates opts -intOptions _otherwise = +intOptions _ = Nothing intUpdate :: 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 @@ -100,7 +100,7 @@ MonadError Exception m => (LRdrName, LHsType GhcPs) -> m (Int -> Field) viewField (name, typ) = - return $ Field name (getBangType typ) (getBangStrictness typ) + return $ Field name (parensT (getBangType typ)) (getBangStrictness typ) viewRecordDerivings :: MonadError Exception m diff --git a/src/Data/Record/Overloading.hs b/src/Data/Record/Overloading.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Overloading.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} + +-- Necessary for correct type for @setField@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +-- | Provide @Prelude@-like environment when using @RebindableSyntax@ +-- +-- If you want to use @large-records@ with 'OverloadedRecordDot' and +-- 'OverloadedRecordUpdate', you need to enable the @RebindableSyntax@ language +-- extension. You can then import this module to get a standard environment +-- back, with one exception; see 'getField' for details. +module Data.Record.Overloading ( + module Prelude + , Control.Arrow.app + , Control.Arrow.arr + , Control.Arrow.first + , Control.Arrow.loop + , (Control.Arrow.>>>) + , (Control.Arrow.|||) + , Data.String.fromString + , GHC.OverloadedLabels.fromLabel + -- * New definitions + , ifThenElse + , getField + , setField + ) where + +import qualified Control.Arrow +import qualified Data.String +import qualified GHC.OverloadedLabels +import qualified GHC.Records.Compat + +{------------------------------------------------------------------------------- + Other exports +-------------------------------------------------------------------------------} + +ifThenElse :: Bool -> a -> a -> a +ifThenElse b x y = if b then x else y + +-- | Get record field +-- +-- This is /NOT/ the standard @getField@ from "GHC.Records", but is instead +-- defined in terms of "GHC.Records.Compat.HasField". As a consequence we do not +-- currently support @OverloadedRecordDot@ without @RebindableSyntax@. +-- (For ghc 9.2 and 9.4 @RebindableSyntax@ is required /anyway/ when using +-- @OverloadedRecordUpdate@, so this is less of a limitation than it might +-- seem.) +-- +-- Unfortunately, we /cannot/ currently support 'GHC.Records.HasField'; in the +-- remainder of this comment we explain why. Consider a record such as +-- +-- > {-# ANN type Person largeRecord #-} +-- > data Person = Person { name :: String } +-- +-- The internal representation of this record generated by @large-records@ +-- looks something like this: +-- +-- > data Person = forall a. a ~ String => Person { name :: a } +-- +-- This representation prevents ghc from generating record accessors, whilst +-- at the same time still making it possible to define and pattern match on +-- records in the normal way. Unfortunately, although GHC does not generate +-- a 'HasField' instance for such a record, it /also/ prevents us from +-- defining our own: +-- +-- If a field has a higher-rank or existential type, the corresponding +-- HasField constraint will not be solved automatically (as described above), +-- but in the interests of simplicity we do not permit users to define their +-- own instances either. +-- +-- +-- +-- There is a proposal to change this +-- (), +-- but for now we instead rely on 'GHC.Records.Compat.HasField', for which no +-- such restrictions exist. +getField :: forall x r a. GHC.Records.Compat.HasField x r a => r -> a +getField = snd . GHC.Records.Compat.hasField @x + +setField :: forall x r a. GHC.Records.Compat.HasField x r a => r -> a -> r +setField = fst . GHC.Records.Compat.hasField @x 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 @@ -8,6 +8,8 @@ -- -- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} -- > +-- > import Data.Record.Plugin +-- > -- > {-# ANN type B largeRecord #-} -- > data B a = B {a :: a, b :: String} -- > deriving stock (Show, Eq, Ord) @@ -16,14 +18,26 @@ -- -- = Usage with @record-dot-preprocessor@ -- --- There are two important points. First, the order of plugins matters — --- @record-dot-preprocessor@ has to be listed before this plugin (and --- correspondingly will be applied /after/ this plugin): +-- The easiest way to use both plugins together is to do -- +-- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-} +-- +-- You /can/ also load them separately, but if you do, you need to be careful +-- with the order. Unfortunately, the correct order is different in different +-- ghc versions. Prior to ghc 9.4, the plugins must be loaded like this: +-- -- > {-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -fplugin=Data.Record.Plugin #-} -- --- Second, you will want at least version 0.2.14. -module Data.Record.Plugin (plugin) where +-- From ghc 9.4 and up, they need to be loaded in the opposite order: +-- +-- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin -fplugin=RecordDotPreprocessor #-} +module Data.Record.Plugin ( + -- * Annotations + LargeRecordOptions(..) + , largeRecord + -- * For use by ghc + , plugin + ) where import Control.Monad.Except import Control.Monad.Trans.Writer.CPS @@ -43,28 +57,44 @@ import Data.Record.Internal.Plugin.Exception import Data.Record.Internal.Plugin.Options import Data.Record.Internal.Plugin.Record +import Data.Record.Internal.Plugin.Names #if __GLASGOW_HASKELL__ >= 902 -import GHC.Driver.Errors -import GHC.Types.Error (mkWarnMsg, mkErr, mkDecorated) import GHC.Utils.Logger (getLogger) #endif +#if __GLASGOW_HASKELL__ == 902 +import GHC.Types.Error (mkWarnMsg, mkErr, mkDecorated) +import GHC.Driver.Errors (printOrThrowWarnings) +#endif + +#if __GLASGOW_HASKELL__ >= 904 +import GHC.Driver.Config.Diagnostic (initDiagOpts) +import GHC.Driver.Errors (printOrThrowDiagnostics) +import GHC.Driver.Errors.Types (GhcMessage(GhcUnknownMessage)) +import GHC.Types.Error (mkPlainError, mkMessages, mkPlainDiagnostic) +import GHC.Utils.Error (mkMsgEnvelope, mkErrorMsgEnvelope) +#endif + {------------------------------------------------------------------------------- Top-level: the plugin proper -------------------------------------------------------------------------------} plugin :: Plugin plugin = defaultPlugin { - parsedResultAction = aux + parsedResultAction = \_ _ -> ignoreMessages aux , pluginRecompile = purePlugin } where - aux :: - [CommandLineOption] - -> ModSummary - -> HsParsedModule -> Hsc HsParsedModule - aux _opts _summary parsed@HsParsedModule{hpm_module = modl} = do +#if __GLASGOW_HASKELL__ >= 904 + ignoreMessages f (ParsedResult modl msgs) = + (\modl' -> ParsedResult modl' msgs) <$> f modl +#else + ignoreMessages = id +#endif + + aux :: HsParsedModule -> Hsc HsParsedModule + aux parsed@HsParsedModule{hpm_module = modl} = do modl' <- transformDecls modl pure $ parsed { hpm_module = modl' } @@ -73,7 +103,7 @@ -------------------------------------------------------------------------------} transformDecls :: LHsModule -> Hsc LHsModule -transformDecls (L l modl@HsModule {hsmodDecls = decls, hsmodImports}) = do +transformDecls (L l modl@HsModule{hsmodDecls = decls}) = do (decls', transformed) <- runWriterT $ for decls $ transformDecl largeRecords checkEnabledExtensions l @@ -87,25 +117,11 @@ -- We add imports whether or not there were some errors, to avoid spurious -- additional errors from ghc about things not in scope. - pure $ L l $ modl { - hsmodDecls = concat decls' - , hsmodImports = hsmodImports ++ map (uncurry importDecl) requiredImports - } + pure $ L l $ modl{hsmodDecls = concat decls'} where largeRecords :: Map String [(SrcSpan, LargeRecordOptions)] largeRecords = getLargeRecordOptions modl - -- Required imports along with whether or not they should be qualified - -- - -- ANN pragmas are written by the user, and should thefore not require - -- qualification; references to the runtime are generated by the plugin. - requiredImports :: [(ModuleName, Bool)] - requiredImports = [ - (mkModuleName "Data.Record.Plugin.Options", False) - , (mkModuleName "Data.Record.Plugin.Runtime", True) - , (mkModuleName "GHC.Generics", True) - ] - transformDecl :: Map String [(SrcSpan, LargeRecordOptions)] -> LHsDecl GhcPs @@ -127,11 +143,12 @@ lift $ issueError (exceptionLoc e) (exceptionToSDoc e) -- Return the declaration unchanged if we cannot parse it return [decl] - Right r -> do - dynFlags <- lift getDynFlags - newDecls <- lift $ runFreshHsc $ genLargeRecord r dynFlags + Right r -> lift $ do + dynFlags <- getDynFlags + names <- getQualifiedNames + newDecls <- runFreshHsc $ genLargeRecord names r dynFlags when (debugLargeRecords opts) $ - lift $ issueWarning l (debugMsg newDecls) + issueWarning l (debugMsg newDecls) pure newDecls _otherwise -> pure [decl] @@ -193,9 +210,15 @@ issueError :: SrcSpan -> SDoc -> Hsc () issueError l errMsg = do -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ == 902 throwOneError $ mkErr l neverQualify (mkDecorated [errMsg]) +#elif __GLASGOW_HASKELL__ >= 904 + throwOneError $ + mkErrorMsgEnvelope + l + neverQualify + (GhcUnknownMessage $ mkPlainError [] errMsg) #else dynFlags <- getDynFlags throwOneError $ @@ -205,11 +228,22 @@ issueWarning :: SrcSpan -> SDoc -> Hsc () issueWarning l errMsg = do dynFlags <- getDynFlags -#if __GLASGOW_HASKELL__ >= 902 +#if __GLASGOW_HASKELL__ == 902 logger <- getLogger - liftIO $ printOrThrowWarnings logger dynFlags . listToBag . (:[]) $ + liftIO $ printOrThrowWarnings logger dynFlags . bag $ mkWarnMsg l neverQualify errMsg +#elif __GLASGOW_HASKELL__ >= 904 + logger <- getLogger + liftIO $ printOrThrowDiagnostics logger (initDiagOpts dynFlags) . mkMessages . bag $ + mkMsgEnvelope + (initDiagOpts dynFlags) + l + neverQualify + (GhcUnknownMessage $ mkPlainDiagnostic WarningWithoutFlag [] errMsg) #else - liftIO $ printOrThrowWarnings dynFlags . listToBag . (:[]) $ + liftIO $ printOrThrowWarnings dynFlags . bag $ mkWarnMsg dynFlags l neverQualify errMsg #endif + where + bag :: a -> Bag a + bag = listToBag . (:[]) diff --git a/src/Data/Record/Plugin/Runtime.hs b/src/Data/Record/Plugin/Runtime.hs --- a/src/Data/Record/Plugin/Runtime.hs +++ b/src/Data/Record/Plugin/Runtime.hs @@ -1,84 +1,161 @@ -{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DisambiguateRecordFields #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} -- | Re-exports of types and functions used by generated code -- -- This exports all functionality required by the generated code, with the -- exception of GHC generics (name clash with @large-records@ generics). --- --- This follows the structure of "Data.Record.Internal.Plugin.RuntimeNames". module Data.Record.Plugin.Runtime ( - -- * base - Any - , Constraint - , Eq((==)) - , Int - , Ord(compare) - , Proxy(Proxy) - , Show(showsPrec) + -- * Base + Constraint + , Proxy , Type - , unsafeCoerce - , error - -- * vector - , SmallArray - , smallArrayFromList - , smallArrayToList - , indexSmallArray - , updateSmallArray - -- * record-hasfield - , GRC.HasField(hasField) + , proxy + -- * AnyArray + , AnyArray + , anyArrayFromList + , anyArrayToList + , anyArrayIndex + , anyArrayUpdate -- * large-generics - , LR.Dict - , LR.FieldMetadata(FieldMetadata) - , LR.FieldStrictness(FieldLazy, FieldStrict) - , LR.Generic(Constraints, MetadataOf, dict, from, metadata, to) - , LR.Metadata(Metadata, recordConstructor, recordFieldMetadata, recordName, recordSize) - , LR.Rep(Rep) - , LR.ThroughLRGenerics(WrapThroughLRGenerics, unwrapThroughLRGenerics) - , LR.gcompare - , LR.geq - , LR.gshowsPrec - , LR.noInlineUnsafeCo - -- * Auxiliary - , dictFor - , repFromVector - , repToVector + , Rep + , Dict + , anyArrayToRep + , anyArrayFromRep + , mkDicts + , mkDict + , mkStrictField + , mkLazyField + , mkMetadata + -- ** wrappers + , gcompare + , geq + , gshowsPrec + , noInlineUnsafeCo + -- ** ThroughLRGenerics + , ThroughLRGenerics + , wrapThroughLRGenerics + , unwrapThroughLRGenerics ) where import Control.Monad (forM_) import Data.Coerce (coerce) -import Data.Kind (Constraint, Type) import Data.Primitive.SmallArray -import Data.Proxy (Proxy(Proxy)) import GHC.Exts (Any) -import Unsafe.Coerce (unsafeCoerce) +import GHC.TypeLits import qualified Data.Foldable as Foldable +import qualified Data.Kind as Base +import qualified Data.Proxy as Base import qualified Data.Record.Generic as LR import qualified Data.Record.Generic.Eq as LR import qualified Data.Record.Generic.GHC as LR import qualified Data.Record.Generic.Rep.Internal as LR import qualified Data.Record.Generic.Show as LR -import qualified GHC.Records.Compat as GRC {------------------------------------------------------------------------------- - Auxiliary + base -------------------------------------------------------------------------------} -dictFor :: c x => Proxy c -> Proxy x -> LR.Dict c x -dictFor _ _ = LR.Dict +type Constraint = Base.Constraint +type Proxy = Base.Proxy +type Type = Base.Type -repFromVector :: SmallArray Any -> LR.Rep LR.I a -repFromVector = coerce +proxy :: forall k (a :: k). Proxy a +proxy = Base.Proxy -repToVector :: LR.Rep LR.I a -> SmallArray Any -repToVector = coerce +{------------------------------------------------------------------------------- + AnyArray +-------------------------------------------------------------------------------} -smallArrayToList :: SmallArray a -> [a] -smallArrayToList = Foldable.toList +type AnyArray = SmallArray Any -updateSmallArray :: SmallArray a -> [(Int, a)] -> SmallArray a -updateSmallArray v updates = runSmallArray $ do +anyArrayFromList :: [Any] -> AnyArray +anyArrayFromList = smallArrayFromList + +anyArrayToList :: AnyArray -> [Any] +anyArrayToList = Foldable.toList + +anyArrayIndex :: AnyArray -> Int -> Any +anyArrayIndex = indexSmallArray + +anyArrayUpdate :: AnyArray -> [(Int, Any)] -> AnyArray +anyArrayUpdate v updates = runSmallArray $ do v' <- thawSmallArray v 0 (sizeofSmallArray v) forM_ updates $ \(i, a) -> do writeSmallArray v' i a return v' + +{------------------------------------------------------------------------------- + large-generics: utilities +-------------------------------------------------------------------------------} + +anyArrayToRep :: AnyArray -> Rep LR.I a +anyArrayToRep = coerce + +anyArrayFromRep :: Rep LR.I a -> AnyArray +anyArrayFromRep = coerce + +mkDicts :: [Dict c Any] -> Rep (Dict c) a +mkDicts = LR.Rep . smallArrayFromList + +mkDict :: c x => Proxy c -> Proxy x -> Dict c x +mkDict _ _ = LR.Dict + +mkStrictField :: forall name a. + KnownSymbol name + => Proxy name -> LR.FieldMetadata a +mkStrictField _ = LR.FieldMetadata (Base.Proxy @name) LR.FieldStrict + +mkLazyField :: forall name a. + KnownSymbol name + => Proxy name -> LR.FieldMetadata a +mkLazyField _ = LR.FieldMetadata (Base.Proxy @name) LR.FieldLazy + +mkMetadata :: + String -- ^ Record name + -> String -- ^ Constructor name + -> [LR.FieldMetadata Any] + -> LR.Metadata a +mkMetadata name constr fields = LR.Metadata { + recordName = name + , recordConstructor = constr + , recordSize = length fields + , recordFieldMetadata = LR.Rep $ smallArrayFromList fields + } + +{------------------------------------------------------------------------------- + large-generics: wrappers +-------------------------------------------------------------------------------} + +type Rep = LR.Rep +type Dict = LR.Dict + +gcompare :: (LR.Generic a, LR.Constraints a Ord) => a -> a -> Ordering +gcompare = LR.gcompare + +geq :: (LR.Generic a, LR.Constraints a Eq) => a -> a -> Bool +geq = LR.geq + +gshowsPrec :: (LR.Generic a, LR.Constraints a Show) => Int -> a -> ShowS +gshowsPrec = LR.gshowsPrec + +noInlineUnsafeCo :: a -> b +noInlineUnsafeCo = LR.noInlineUnsafeCo + +{------------------------------------------------------------------------------- + large-generics: ThroughLRGenerics +-------------------------------------------------------------------------------} + +type ThroughLRGenerics = LR.ThroughLRGenerics + +wrapThroughLRGenerics :: a -> ThroughLRGenerics a p +wrapThroughLRGenerics = LR.WrapThroughLRGenerics + +unwrapThroughLRGenerics :: ThroughLRGenerics a p -> a +unwrapThroughLRGenerics = LR.unwrapThroughLRGenerics diff --git a/src/Data/Record/Plugin/WithRDP.hs b/src/Data/Record/Plugin/WithRDP.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Plugin/WithRDP.hs @@ -0,0 +1,33 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Data.Record.Plugin.WithRDP ( + -- * Annotations + WithoutRDP.LargeRecordOptions(..) + , WithoutRDP.largeRecord + -- * For use by ghc + , plugin + ) where + +import Control.Monad + +import qualified RecordDotPreprocessor as RDP + +import Data.Record.Internal.GHC.Shim + +import qualified Data.Record.Plugin as WithoutRDP + +plugin :: Plugin +plugin = WithoutRDP.plugin <> RDP.plugin + +-- | Limited 'Semigroup' instance that defines just enough to combine +-- @large-records@ and @record-dot-preprocessor@ +instance Semigroup Plugin where + p <> q = defaultPlugin { + parsedResultAction = \args summary -> + parsedResultAction p args summary + >=> parsedResultAction q args summary + , pluginRecompile = \args -> + (<>) + <$> pluginRecompile p args + <*> pluginRecompile q args + } diff --git a/test/Test/Record/Sanity/CodeGen.hs b/test/Test/Record/Sanity/CodeGen.hs --- a/test/Test/Record/Sanity/CodeGen.hs +++ b/test/Test/Record/Sanity/CodeGen.hs @@ -7,6 +7,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} @@ -15,6 +16,7 @@ module Test.Record.Sanity.CodeGen (tests) where import Data.Record.Generic +import Data.Record.Plugin import Test.Tasty import Test.Tasty.HUnit diff --git a/test/Test/Record/Sanity/Derive.hs b/test/Test/Record/Sanity/Derive.hs --- a/test/Test/Record/Sanity/Derive.hs +++ b/test/Test/Record/Sanity/Derive.hs @@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} @@ -22,6 +23,8 @@ import GHC.Records.Compat import Test.Tasty import Test.Tasty.HUnit + +import Data.Record.Plugin {------------------------------------------------------------------------------- Class of kind @Type -> Constraint@. 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 @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- The point of this module is to verify that largeRecord does not generate @@ -19,6 +20,8 @@ import Test.Tasty import Test.Tasty.HUnit + +import Data.Record.Plugin {-# ANN type R largeRecord #-} data R a = MkR { 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 @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} @@ -15,11 +16,12 @@ import Data.Record.Generic.GHC import Generics.Deriving.Show (gshowsPrecdefault, GShow'(..)) +import Test.Tasty +import Test.Tasty.HUnit import qualified GHC.Generics as GHC -import Test.Tasty -import Test.Tasty.HUnit +import Data.Record.Plugin {-# ANN type R largeRecord #-} data R = MkR { a :: Int } diff --git a/test/Test/Record/Sanity/HKD.hs b/test/Test/Record/Sanity/HKD.hs --- a/test/Test/Record/Sanity/HKD.hs +++ b/test/Test/Record/Sanity/HKD.hs @@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} @@ -21,9 +22,10 @@ import Data.Functor.Const import Data.Kind import GHC.Records.Compat - import Test.Tasty import Test.Tasty.HUnit + +import Data.Record.Plugin type family HKD f a where HKD Identity a = a diff --git a/test/Test/Record/Sanity/HigherKinded.hs b/test/Test/Record/Sanity/HigherKinded.hs --- a/test/Test/Record/Sanity/HigherKinded.hs +++ b/test/Test/Record/Sanity/HigherKinded.hs @@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} @@ -19,13 +20,13 @@ ) where import Data.Kind -import GHC.TypeLits - import Data.Record.Generic import Data.Record.Generic.LowerBound - +import GHC.TypeLits import Test.Tasty import Test.Tasty.HUnit + +import Data.Record.Plugin newtype T (n :: Nat) (f :: Type -> Type) = MkT (f Word) diff --git a/test/Test/Record/Sanity/NamedWildCards.hs b/test/Test/Record/Sanity/NamedWildCards.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/NamedWildCards.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NamedWildCards #-} +{-# LANGUAGE PolyKinds #-} + +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} + +module Test.Record.Sanity.NamedWildCards where + +import Data.Record.Plugin + +{-# ANN type X largeRecord #-} +data X = MkX { _x :: Int } + +{-# ANN type Y largeRecord #-} +data Y a = MkY { _y :: a } + +{-# ANN type Z largeRecord #-} +data Z a (b :: a) = MkZ { _z :: a } + +{-# ANN type Empty largeRecord #-} +data Empty = MkEmpty {} diff --git a/test/Test/Record/Sanity/Operators.hs b/test/Test/Record/Sanity/Operators.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/Operators.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} + +module Test.Record.Sanity.Operators () where + +import Data.Kind (Type) + +import Data.Record.Plugin + +-- Some type family (e.g. servant record-style API def). +type family tag :- route :: Type + +{-# ANN type X largeRecord #-} +data X mode = MkX { _fx1 :: (mode :- Int) } + +{-# ANN type Y largeRecord #-} +data Y mode = MkY { _fy1 :: mode :- Int } diff --git a/test/Test/Record/Sanity/OverloadedRecordUpdate.hs b/test/Test/Record/Sanity/OverloadedRecordUpdate.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/OverloadedRecordUpdate.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE CPP #-} + +#if __GLASGOW_HASKELL__ < 902 + +module Test.Record.Sanity.OverloadedRecordUpdate (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = + testCaseInfo "Test.Record.Sanity.OverloadedRecordUpdate" $ + return "Skipped for ghc < 9.2" + +#else + +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedRecordUpdate #-} +{-# LANGUAGE RebindableSyntax #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} + +module Test.Record.Sanity.OverloadedRecordUpdate (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Record.Generic (Rep) +import Data.Record.Generic.Lens.VL +import Data.Record.Overloading +import Data.Record.Plugin + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.OverloadedRecordUpdate" [ + testGroup "get" [ + testCase "simple" test_get_simple + , testCase "nested" test_get_nested + ] + , testGroup "set" [ + testCase "simple" test_set_simple + , testCase "nested" test_set_nested + ] + ] + +{------------------------------------------------------------------------------- + Example records +-------------------------------------------------------------------------------} + +{-# ANN type Person largeRecord #-} +data Person = Person { + name :: String + , age :: Int + } + deriving (Show, Eq) + +{-# ANN type Company largeRecord #-} +data Company = Company { + name :: String + , ceo :: Person + } + deriving (Show, Eq) + +person :: Person +person = Person { + name = "John Doe" + , age = 30 + } + +company :: Company +company = Company { + name = "Sprockets Inc" + , ceo = person + } + +{------------------------------------------------------------------------------- + Sanity check we really are dealing with a large-record here +-------------------------------------------------------------------------------} + +_lensesPerson :: Rep (SimpleRecordLens Person) Person +_lensesPerson = lensesForSimpleRecord + +_lensesCompany :: Rep (SimpleRecordLens Company) Company +_lensesCompany = lensesForSimpleRecord + +{------------------------------------------------------------------------------- + Get fields +-------------------------------------------------------------------------------} + +test_get_simple :: Assertion +test_get_simple = assertEqual "" 30 $ person.age + +test_get_nested :: Assertion +test_get_nested = assertEqual "" 30 $ company.ceo.age + +{------------------------------------------------------------------------------- + Set fields +-------------------------------------------------------------------------------} + +test_set_simple :: Assertion +test_set_simple = + assertEqual "" expected $ + person{age = 31} + where + expected :: Person + expected = Person { + name = "John Doe" + , age = 31 + } + +test_set_nested :: Assertion +test_set_nested = + assertEqual "" expected $ + company{ceo.age = 31} + where + expected :: Company + expected = Company { + name = "Sprockets Inc" + , ceo = Person { + name = "John Doe" + , age = 31 + } + } + +#endif diff --git a/test/Test/Record/Sanity/OverloadingNoDRF.hs b/test/Test/Record/Sanity/OverloadingNoDRF.hs --- a/test/Test/Record/Sanity/OverloadingNoDRF.hs +++ b/test/Test/Record/Sanity/OverloadingNoDRF.hs @@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} @@ -17,9 +18,10 @@ ) where import GHC.Records.Compat - import Test.Tasty import Test.Tasty.HUnit + +import Data.Record.Plugin {------------------------------------------------------------------------------- Simple test case diff --git a/test/Test/Record/Sanity/PatternMatch.hs b/test/Test/Record/Sanity/PatternMatch.hs --- a/test/Test/Record/Sanity/PatternMatch.hs +++ b/test/Test/Record/Sanity/PatternMatch.hs @@ -8,6 +8,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} @@ -21,6 +22,8 @@ import Data.List (isInfixOf) import Test.Tasty import Test.Tasty.HUnit + +import Data.Record.Plugin import Test.Record.Util diff --git a/test/Test/Record/Sanity/QualifiedImports/A.hs b/test/Test/Record/Sanity/QualifiedImports/A.hs --- a/test/Test/Record/Sanity/QualifiedImports/A.hs +++ b/test/Test/Record/Sanity/QualifiedImports/A.hs @@ -5,11 +5,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Sanity.QualifiedImports.A (T(..)) where + +import Data.Record.Plugin {-# ANN type T largeRecord #-} data T a = MkT { x :: Int, y :: [a] } diff --git a/test/Test/Record/Sanity/QualifiedImports/B.hs b/test/Test/Record/Sanity/QualifiedImports/B.hs --- a/test/Test/Record/Sanity/QualifiedImports/B.hs +++ b/test/Test/Record/Sanity/QualifiedImports/B.hs @@ -6,11 +6,14 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Sanity.QualifiedImports.B (T(..)) where + +import Data.Record.Plugin import qualified Test.Record.Sanity.QualifiedImports.A as A diff --git a/test/Test/Record/Sanity/RDP/SingleModule.hs b/test/Test/Record/Sanity/RDP/SingleModule.hs --- a/test/Test/Record/Sanity/RDP/SingleModule.hs +++ b/test/Test/Record/Sanity/RDP/SingleModule.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,15 +9,18 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -fplugin=Data.Record.Plugin #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin.WithRDP #-} -- | Test what happens if both plugins are used in the same module module Test.Record.Sanity.RDP.SingleModule (tests) where import Test.Tasty import Test.Tasty.HUnit + +import Data.Record.Plugin {------------------------------------------------------------------------------- Simple field selection and override diff --git a/test/Test/Record/Sanity/RDP/SplitModule.hs b/test/Test/Record/Sanity/RDP/SplitModule.hs --- a/test/Test/Record/Sanity/RDP/SplitModule.hs +++ b/test/Test/Record/Sanity/RDP/SplitModule.hs @@ -3,6 +3,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DuplicateRecordFields #-} 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 @@ -7,6 +7,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} @@ -21,6 +22,8 @@ , R4_WithLR(..) , R5_WithLR(..) ) where + +import Data.Record.Plugin {-# ANN type R1 largeRecord #-} data R1 = MkR1 { r1_x :: Int, r1_y :: Bool } diff --git a/test/Test/Record/Sanity/RecordConstruction.hs b/test/Test/Record/Sanity/RecordConstruction.hs --- a/test/Test/Record/Sanity/RecordConstruction.hs +++ b/test/Test/Record/Sanity/RecordConstruction.hs @@ -9,6 +9,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} @@ -16,9 +17,10 @@ module Test.Record.Sanity.RecordConstruction (tests) where import GHC.Records.Compat - import Test.Tasty import Test.Tasty.HUnit + +import Data.Record.Plugin -- Test that this works if we don't generate field accessors -- See diff --git a/test/Test/Record/Sanity/Strictness.hs b/test/Test/Record/Sanity/Strictness.hs --- a/test/Test/Record/Sanity/Strictness.hs +++ b/test/Test/Record/Sanity/Strictness.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} @@ -17,15 +18,15 @@ module Test.Record.Sanity.Strictness (tests) where import Control.Exception -import GHC.Records.Compat - import Data.Record.Generic import Data.Record.Generic.LowerBound +import GHC.Records.Compat +import Test.Tasty +import Test.Tasty.HUnit import qualified Data.Record.Generic.Rep as Rep -import Test.Tasty -import Test.Tasty.HUnit +import Data.Record.Plugin {-# ANN type Lazy largeRecord #-} data Lazy = MkLazy { lazyField :: Word } diff --git a/test/Test/Record/Sanity/StrictnessStrictData.hs b/test/Test/Record/Sanity/StrictnessStrictData.hs --- a/test/Test/Record/Sanity/StrictnessStrictData.hs +++ b/test/Test/Record/Sanity/StrictnessStrictData.hs @@ -10,6 +10,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE StrictData #-} @@ -18,15 +19,15 @@ module Test.Record.Sanity.StrictnessStrictData (tests) where import Control.Exception -import GHC.Records.Compat - import Data.Record.Generic import Data.Record.Generic.LowerBound +import GHC.Records.Compat +import Test.Tasty +import Test.Tasty.HUnit import qualified Data.Record.Generic.Rep as Rep -import Test.Tasty -import Test.Tasty.HUnit +import Data.Record.Plugin {-# ANN type Lazy largeRecord #-} data Lazy = MkLazy { lazyField :: ~Word } diff --git a/test/Test/Record/Util.hs b/test/Test/Record/Util.hs --- a/test/Test/Record/Util.hs +++ b/test/Test/Record/Util.hs @@ -168,6 +168,9 @@ qPutDoc = \x y -> liftQ $ qPutDoc x y qGetDoc = \x -> liftQ $ qGetDoc x #endif +#if MIN_VERSION_template_haskell(2,19,0) + qGetPackageRoot = liftQ $ qGetPackageRoot +#endif {------------------------------------------------------------------------------- Internal auxiliary: figure out how TH does error handling diff --git a/test/TestLargeRecords.hs b/test/TestLargeRecords.hs --- a/test/TestLargeRecords.hs +++ b/test/TestLargeRecords.hs @@ -5,17 +5,18 @@ import qualified Test.Record.Sanity.CodeGen import qualified Test.Record.Sanity.Derive import qualified Test.Record.Sanity.EqualFieldTypes +import qualified Test.Record.Sanity.GhcGenerics import qualified Test.Record.Sanity.HigherKinded import qualified Test.Record.Sanity.HKD +import qualified Test.Record.Sanity.OverloadedRecordUpdate import qualified Test.Record.Sanity.OverloadingNoDRF import qualified Test.Record.Sanity.PatternMatch import qualified Test.Record.Sanity.QualifiedImports -import qualified Test.Record.Sanity.RDP.SplitModule import qualified Test.Record.Sanity.RDP.SingleModule +import qualified Test.Record.Sanity.RDP.SplitModule import qualified Test.Record.Sanity.RecordConstruction import qualified Test.Record.Sanity.Strictness import qualified Test.Record.Sanity.StrictnessStrictData -import qualified Test.Record.Sanity.GhcGenerics main :: IO () main = defaultMain tests @@ -37,5 +38,6 @@ , Test.Record.Sanity.Strictness.tests , Test.Record.Sanity.StrictnessStrictData.tests , Test.Record.Sanity.GhcGenerics.tests + , Test.Record.Sanity.OverloadedRecordUpdate.tests ] ]