From effdb13df0aed4fea5b5637ae3600c9410c6fc6f Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Tue, 15 Oct 2024 14:55:46 +0200 Subject: [PATCH] Use `Exact` names for `Prelude` imports Closes #162 --- beam-large-records/beam-large-records.cabal | 1 + .../large-records-benchmarks.cabal | 7 +- large-records/CHANGELOG.md | 11 ++- large-records/large-records.cabal | 1 + .../Data/Record/Internal/Plugin/CodeGen.hs | 22 ++--- .../src/Data/Record/Internal/Plugin/Names.hs | 80 +++++++++---------- large-records/src/Data/Record/Plugin.hs | 8 +- .../src/Data/Record/Plugin/Runtime.hs | 30 +++++-- 8 files changed, 91 insertions(+), 69 deletions(-) diff --git a/beam-large-records/beam-large-records.cabal b/beam-large-records/beam-large-records.cabal index 246bea53..5ffdf381 100644 --- a/beam-large-records/beam-large-records.cabal +++ b/beam-large-records/beam-large-records.cabal @@ -74,6 +74,7 @@ test-suite test-beam-large-records , beam-core , beam-large-records , beam-sqlite + , ghc-prim , large-generics , large-records , microlens diff --git a/large-records-benchmarks/large-records-benchmarks.cabal b/large-records-benchmarks/large-records-benchmarks.cabal index 3d39008b..5ef4ad1f 100644 --- a/large-records-benchmarks/large-records-benchmarks.cabal +++ b/large-records-benchmarks/large-records-benchmarks.cabal @@ -131,6 +131,7 @@ executable bench-before build-depends: , aeson , generics-sop + , ghc-prim , json-sop , record-dot-preprocessor , record-hasfield @@ -159,7 +160,8 @@ executable bench-after -- Needed for the HasNormalForm benchmark -freduction-depth=2000 build-depends: - aeson + , aeson + , ghc-prim , large-generics , large-records , record-hasfield @@ -656,8 +658,9 @@ test-suite test-large-records-benchmarks bench/before bench/experiments build-depends: - aeson + , aeson , generics-sop + , ghc-prim , json-sop , large-generics , large-records diff --git a/large-records/CHANGELOG.md b/large-records/CHANGELOG.md index fdb617d4..dc56c701 100644 --- a/large-records/CHANGELOG.md +++ b/large-records/CHANGELOG.md @@ -5,10 +5,15 @@ * Support `primitive-0.7.3` (#159, Isaac Elliott). * Plugin idempotence (#159, Isaac Elliott). * Document required additional dependencies and language extensions (#161). +* Use `Exact` names for `Prelude` imports, to avoid unexpected clashes (#162). -Note: if your code imports `Data.Plugin.Record` only for the `largeRecord` -identifier used in the `ANN` annotations, this import is no longer required -as of this version and can be omitted. +Notes: + +* If your code imports `Data.Plugin.Record` only for the `largeRecord` + identifier used in the `ANN` annotations, this import is no longer required as + of this version and can be omitted. +* In addition to `large-generics` and `record-hasfield` you will now also need + to declare a dependency on `ghc-prim`. ## 0.4.1 -- 2024-05-30 diff --git a/large-records/large-records.cabal b/large-records/large-records.cabal index 0783fa10..ab5b6ace 100644 --- a/large-records/large-records.cabal +++ b/large-records/large-records.cabal @@ -113,6 +113,7 @@ test-suite test-large-records , large-records , generic-deriving + , ghc-prim , large-generics , mtl , newtype diff --git a/large-records/src/Data/Record/Internal/Plugin/CodeGen.hs b/large-records/src/Data/Record/Internal/Plugin/CodeGen.hs index 41920449..dd4ccfab 100644 --- a/large-records/src/Data/Record/Internal/Plugin/CodeGen.hs +++ b/large-records/src/Data/Record/Internal/Plugin/CodeGen.hs @@ -5,6 +5,8 @@ -- | The core of the plugin implementation. module Data.Record.Internal.Plugin.CodeGen (genLargeRecord) where +import Prelude hiding (error) + import Data.List (nubBy) import Data.List.NonEmpty (NonEmpty(..)) @@ -159,8 +161,6 @@ genVectorConversions QualifiedNames{..} r@Record{..} = concatM [ , toVector ] where - UnqualifiedNames{..} = getUnqualifiedNames - fromVector :: m [LHsDecl GhcPs] fromVector = do args <- mapM (freshName . fieldName) recordFields @@ -203,7 +203,7 @@ genVectorConversions QualifiedNames{..} r@Record{..} = concatM [ ] ) , ( wildP - , VarE unq_error `appE` stringE matchErr + , VarE error `appE` stringE matchErr ) ] ] @@ -245,7 +245,7 @@ genIndexedAccessor QualifiedNames{..} r@Record{..} = do return [ sigD name $ funT - (ConT unq_type_Int) + (ConT type_Int) (recordTypeT r `funT` VarT x) , valD name $ lamE (varP n :| [varP t]) $ @@ -259,8 +259,6 @@ genIndexedAccessor QualifiedNames{..} r@Record{..} = do ) ] where - UnqualifiedNames{..} = getUnqualifiedNames - name :: LRdrName name = nameUnsafeGetIndex r @@ -287,7 +285,7 @@ genUnsafeSetIndex QualifiedNames{..} r@Record{..} = do val <- freshName $ mkExpVar recordAnnLoc "val" return [ sigD name $ - ConT unq_type_Int + ConT type_Int `funT` (recordTypeT r `funT` (VarT x `funT` recordTypeT r)) , valD name $ lamE (varP n :| [varP t, (varP val)]) $ @@ -305,8 +303,6 @@ genUnsafeSetIndex QualifiedNames{..} r@Record{..} = do ) ] where - UnqualifiedNames{..} = getUnqualifiedNames - name :: LRdrName name = nameUnsafeSetIndex r @@ -624,13 +620,11 @@ 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 ] + Show -> [mkInstance prelude_type_Show prelude_showsPrec gshowsPrec] + Eq -> [mkInstance prelude_type_Eq prelude_eq geq ] + Ord -> [mkInstance prelude_type_Ord prelude_compare gcompare ] Generic -> [] where - UnqualifiedNames{..} = getUnqualifiedNames - mkInstance :: LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs mkInstance cls mthd gen = instanceD diff --git a/large-records/src/Data/Record/Internal/Plugin/Names.hs b/large-records/src/Data/Record/Internal/Plugin/Names.hs index ecfd86ec..15946712 100644 --- a/large-records/src/Data/Record/Internal/Plugin/Names.hs +++ b/large-records/src/Data/Record/Internal/Plugin/Names.hs @@ -2,14 +2,11 @@ {-# LANGUAGE RecordWildCards #-} module Data.Record.Internal.Plugin.Names ( - -- * Qualified names QualifiedNames(..) , getQualifiedNames - -- * Unqualified names - , UnqualifiedNames(..) - , getUnqualifiedNames ) where +import Prelude hiding (error) import Data.Record.Internal.GHC.Shim {------------------------------------------------------------------------------- @@ -19,17 +16,30 @@ import Data.Record.Internal.GHC.Shim data QualifiedNames = QualifiedNames { -- - -- Base + -- Prelude type classes -- - type_Constraint :: LRdrName + prelude_type_Eq :: LRdrName + , prelude_type_Ord :: LRdrName + , prelude_type_Show :: LRdrName + , prelude_compare :: LRdrName + , prelude_eq :: LRdrName + , prelude_showsPrec :: LRdrName + + -- + -- Other base + -- + + , type_Constraint :: LRdrName , type_GHC_Generic :: LRdrName , type_GHC_Rep :: LRdrName + , type_Int :: LRdrName , type_Proxy :: LRdrName , type_Type :: LRdrName - , proxy :: LRdrName + , error :: LRdrName , ghc_from :: LRdrName , ghc_to :: LRdrName + , proxy :: LRdrName -- -- AnyArray @@ -100,8 +110,23 @@ data QualifiedNames = QualifiedNames { -- define a dependency on that other package. getQualifiedNames :: Hsc QualifiedNames getQualifiedNames = do + + -- + -- Prelude classes + -- + -- Annoyingly, we cannot re-rexport these through our runtime module, since + -- we cannot declare instances of type aliased classes. + -- + + prelude_type_Eq <- exact <$> lookupTcName ghcClasses (Just "ghc-prim") "Eq" + prelude_type_Ord <- exact <$> lookupTcName ghcClasses (Just "ghc-prim") "Ord" + prelude_type_Show <- exact <$> lookupTcName ghcShow Nothing "Show" + prelude_compare <- exact <$> lookupVarName ghcClasses (Just "ghc-prim") "compare" + prelude_eq <- exact <$> lookupVarName ghcClasses (Just "ghc-prim") "==" + prelude_showsPrec <- exact <$> lookupVarName ghcShow Nothing "showsPrec" + -- - -- base + -- Other base -- type_Constraint <- exact <$> lookupTcName runtime Nothing "Constraint" @@ -109,9 +134,11 @@ getQualifiedNames = do 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" + type_Int <- exact <$> lookupTcName runtime Nothing "Int" + error <- exact <$> lookupVarName runtime Nothing "error" ghc_from <- exact <$> lookupVarName ghcGenerics Nothing "from" ghc_to <- exact <$> lookupVarName ghcGenerics Nothing "to" + proxy <- exact <$> lookupVarName runtime Nothing "proxy" -- -- AnyArray @@ -173,39 +200,12 @@ getQualifiedNames = do exact :: Name -> LRdrName exact = noLoc . Exact + ghcClasses, ghcShow :: ModuleName + ghcClasses = mkModuleName "GHC.Classes" + ghcShow = mkModuleName "GHC.Show" + 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/large-records/src/Data/Record/Plugin.hs b/large-records/src/Data/Record/Plugin.hs index e731be19..2b6ed251 100644 --- a/large-records/src/Data/Record/Plugin.hs +++ b/large-records/src/Data/Record/Plugin.hs @@ -17,9 +17,11 @@ -- = Dependencies -- -- In addition to the dependency on @large-records@, you will also need to add --- dependencies --- on [large-generics](http://hackage.haskell.org/package/large-generics) --- and [record-hasfield](http://hackage.haskell.org/package/record-hasfield). +-- dependencies on +-- +-- * [ghc-prim](http://hackage.haskell.org/package/ghc-prim). +-- * [large-generics](http://hackage.haskell.org/package/large-generics) +-- * [record-hasfield](http://hackage.haskell.org/package/record-hasfield). -- -- = Language extensions -- diff --git a/large-records/src/Data/Record/Plugin/Runtime.hs b/large-records/src/Data/Record/Plugin/Runtime.hs index 099c833c..2318e177 100644 --- a/large-records/src/Data/Record/Plugin/Runtime.hs +++ b/large-records/src/Data/Record/Plugin/Runtime.hs @@ -11,8 +11,11 @@ -- This exports all functionality required by the generated code, with the -- exception of GHC generics (name clash with @large-records@ generics). module Data.Record.Plugin.Runtime ( - -- * Base - Constraint + -- * Prelude + Int + , error + -- * Other base + , Constraint , Proxy , Type , proxy @@ -43,10 +46,14 @@ module Data.Record.Plugin.Runtime ( , unwrapThroughLRGenerics ) where +import Prelude hiding (Int, error) +import qualified Prelude as Prelude + import Control.Monad (forM_) import Data.Coerce (coerce) import Data.Primitive.SmallArray import GHC.Exts (Any) +import GHC.Stack (HasCallStack) import GHC.TypeLits import qualified Data.Foldable as Foldable @@ -58,6 +65,15 @@ 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 +{------------------------------------------------------------------------------- + Prelude +-------------------------------------------------------------------------------} + +type Int = Prelude.Int + +error :: HasCallStack => String -> a +error = Prelude.error + {------------------------------------------------------------------------------- base -------------------------------------------------------------------------------} @@ -85,11 +101,11 @@ anyArrayIndex :: AnyArray -> Int -> Any anyArrayIndex = indexSmallArray anyArrayUpdate :: AnyArray -> [(Int, Any)] -> AnyArray -anyArrayUpdate v updates = runSmallArray $ do +anyArrayUpdate v updates = runSmallArray (do v' <- thawSmallArray v 0 (sizeofSmallArray v) - forM_ updates $ \(i, a) -> do - writeSmallArray v' i a + forM_ updates (\(i, a) -> writeSmallArray v' i a) return v' + ) {------------------------------------------------------------------------------- large-generics: utilities @@ -102,7 +118,7 @@ anyArrayFromRep :: Rep LR.I a -> AnyArray anyArrayFromRep = coerce mkDicts :: [Dict c Any] -> Rep (Dict c) a -mkDicts = LR.Rep . smallArrayFromList +mkDicts ds = LR.Rep (smallArrayFromList ds) mkDict :: c x => Proxy c -> Proxy x -> Dict c x mkDict _ _ = LR.Dict @@ -126,7 +142,7 @@ mkMetadata name constr fields = LR.Metadata { recordName = name , recordConstructor = constr , recordSize = length fields - , recordFieldMetadata = LR.Rep $ smallArrayFromList fields + , recordFieldMetadata = LR.Rep (smallArrayFromList fields) } {-------------------------------------------------------------------------------