Skip to content

Commit

Permalink
Use Exact names for Prelude imports
Browse files Browse the repository at this point in the history 
Closes #162
  • Loading branch information
@edsko
edsko committed Oct 15, 2024
1 parent 2a257b5 commit effdb13
Show file tree
Hide file tree
Showing 8 changed files with 91 additions and 69 deletions.
1 change: 1 addition & 0 deletions beam-large-records/beam-large-records.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -74,6 +74,7 @@ test-suite test-beam-large-records
, beam-core
, beam-large-records
, beam-sqlite
, ghc-prim
, large-generics
, large-records
, microlens
Expand Down
7 changes: 5 additions & 2 deletions large-records-benchmarks/large-records-benchmarks.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -131,6 +131,7 @@ executable bench-before
build-depends:
, aeson
, generics-sop
, ghc-prim
, json-sop
, record-dot-preprocessor
, record-hasfield
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
11 changes: 8 additions & 3 deletions large-records/CHANGELOG.md
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
1 change: 1 addition & 0 deletions large-records/large-records.cabal
View file
Original file line number Diff line number Diff line change
Expand Up @@ -113,6 +113,7 @@ test-suite test-large-records
, large-records

, generic-deriving
, ghc-prim
, large-generics
, mtl
, newtype
Expand Down
22 changes: 8 additions & 14 deletions large-records/src/Data/Record/Internal/Plugin/CodeGen.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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(..))

Expand Down Expand Up @@ -159,8 +161,6 @@ genVectorConversions QualifiedNames{..} r@Record{..} = concatM [
, toVector
]
where
UnqualifiedNames{..} = getUnqualifiedNames

fromVector :: m [LHsDecl GhcPs]
fromVector = do
args <- mapM (freshName . fieldName) recordFields
Expand Down Expand Up @@ -203,7 +203,7 @@ genVectorConversions QualifiedNames{..} r@Record{..} = concatM [
]
)
, ( wildP
, VarE unq_error `appE` stringE matchErr
, VarE error `appE` stringE matchErr
)
]
]
Expand Down Expand Up @@ -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]) $
Expand All @@ -259,8 +259,6 @@ genIndexedAccessor QualifiedNames{..} r@Record{..} = do
)
]
where
UnqualifiedNames{..} = getUnqualifiedNames

name :: LRdrName
name = nameUnsafeGetIndex r

Expand All @@ -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)]) $
Expand All @@ -305,8 +303,6 @@ genUnsafeSetIndex QualifiedNames{..} r@Record{..} = do
)
]
where
UnqualifiedNames{..} = getUnqualifiedNames

name :: LRdrName
name = nameUnsafeSetIndex r

Expand Down Expand Up @@ -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
Expand Down
80 changes: 40 additions & 40 deletions large-records/src/Data/Record/Internal/Plugin/Names.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

{-------------------------------------------------------------------------------
Expand All @@ -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
Expand Down Expand Up @@ -100,18 +110,35 @@ 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"
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"
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
Expand Down Expand Up @@ -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
8 changes: 5 additions & 3 deletions large-records/src/Data/Record/Plugin.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
--
Expand Down
30 changes: 23 additions & 7 deletions large-records/src/Data/Record/Plugin/Runtime.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
-------------------------------------------------------------------------------}
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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)
}

{-------------------------------------------------------------------------------
Expand Down

0 comments on commit effdb13

Please sign in to comment.