diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,20 @@ # Revision history for large-records +## 0.4.2 -- 2024-10-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). + +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 * Support ghc 9.6 (and drop ghc <= 8.8) diff --git a/large-records.cabal b/large-records.cabal --- a/large-records.cabal +++ b/large-records.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: large-records -version: 0.4.1 +version: 0.4.2 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 @@ -15,8 +15,8 @@ author: Edsko de Vries maintainer: edsko@well-typed.com category: Generics -extra-source-files: CHANGELOG.md -tested-with: GHC ==8.10.7 || ==9.2.8 || ==9.4.8 || ==9.6.4 +extra-doc-files: CHANGELOG.md +tested-with: GHC ==8.10.7 || ==9.2.8 || ==9.4.8 || ==9.6.6 source-repository head type: git @@ -48,7 +48,7 @@ , containers >= 0.6.2 && < 0.8 , ghc >= 8.10 && < 9.7 , mtl >= 2.2.1 && < 2.4 - , primitive >= 0.8 && < 0.10 + , primitive >= 0.7.3 && < 0.10 , record-hasfield >= 1.0 && < 1.1 , syb >= 0.7 && < 0.8 , template-haskell >= 2.16 && < 2.21 @@ -113,6 +113,7 @@ , large-records , generic-deriving + , ghc-prim , large-generics , mtl , newtype 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 @@ -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 @@ , toVector ] where - UnqualifiedNames{..} = getUnqualifiedNames - fromVector :: m [LHsDecl GhcPs] fromVector = do args <- mapM (freshName . fieldName) recordFields @@ -203,7 +203,7 @@ ] ) , ( wildP - , VarE unq_error `appE` stringE matchErr + , VarE error `appE` stringE matchErr ) ] ] @@ -245,7 +245,7 @@ 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 @@ ) ] where - UnqualifiedNames{..} = getUnqualifiedNames - name :: LRdrName name = nameUnsafeGetIndex r @@ -287,7 +285,7 @@ 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 @@ ) ] where - UnqualifiedNames{..} = getUnqualifiedNames - name :: LRdrName name = nameUnsafeSetIndex r @@ -624,13 +620,11 @@ => 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/src/Data/Record/Internal/Plugin/Names.hs b/src/Data/Record/Internal/Plugin/Names.hs --- a/src/Data/Record/Internal/Plugin/Names.hs +++ b/src/Data/Record/Internal/Plugin/Names.hs @@ -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 @@ 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,18 +110,35 @@ -- define a dependency on that other package. getQualifiedNames :: Hsc QualifiedNames getQualifiedNames = do + -- - -- base + -- 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" + + -- + -- 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 @@ -173,39 +200,12 @@ 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/src/Data/Record/Plugin.hs b/src/Data/Record/Plugin.hs --- a/src/Data/Record/Plugin.hs +++ b/src/Data/Record/Plugin.hs @@ -8,14 +8,42 @@ -- -- > {-# 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) -- -- See 'LargeRecordOptions' for the list of all possible annotations. -- +-- = Dependencies +-- +-- In addition to the dependency on @large-records@, you will also need to add +-- 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 +-- +-- The plugin depends on a number of language extensions. If you are using +-- GHC2021, you will need enable: +-- +-- > {-# LANGUAGE DataKinds #-} +-- > {-# LANGUAGE TypeFamilies #-} +-- > {-# LANGUAGE UndecidableInstances #-} +-- +-- If you are using Haskell2010, you need to enable: +-- +-- > {-# LANGUAGE ConstraintKinds #-} +-- > {-# LANGUAGE DataKinds #-} +-- > {-# LANGUAGE FlexibleInstances #-} +-- > {-# LANGUAGE GADTs #-} +-- > {-# LANGUAGE MultiParamTypeClasses #-} +-- > {-# LANGUAGE ScopedTypeVariables #-} +-- > {-# LANGUAGE TypeFamilies #-} +-- > {-# LANGUAGE TypeOperators #-} +-- > {-# LANGUAGE UndecidableInstances #-} +-- -- = Usage with @record-dot-preprocessor@ -- -- The easiest way to use both plugins together is to do @@ -135,7 +163,18 @@ -> WriterT (Set String) Hsc [LHsDecl GhcPs] transformDecl largeRecords decl@(reLoc -> L l _) = case decl of - DataD (nameBase -> name) _ _ _ -> + (unLoc -> AnnD _ (PragAnnD (TypeAnnotation (nameBase -> name)) _)) -> + case Map.findWithDefault [] name largeRecords of + [_] -> + {- A valid `large-records` annotation. + + Remove it so that subsequent passes of the plugin will ignore the generated + `large-records` code. + -} + pure [] + _ -> + pure [decl] + DataD (nameBase -> name) _ _ _ -> do case Map.findWithDefault [] name largeRecords of [] -> -- Not a large record. Leave alone. 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 @@ -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 @@ , 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 @@ -59,6 +66,15 @@ 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 = 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 = 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 @@ recordName = name , recordConstructor = constr , recordSize = length fields - , recordFieldMetadata = LR.Rep $ smallArrayFromList fields + , recordFieldMetadata = LR.Rep (smallArrayFromList fields) } {------------------------------------------------------------------------------- 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 @@ -16,7 +16,6 @@ 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 @@ -24,8 +24,6 @@ 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 @@ -21,8 +21,6 @@ import Test.Tasty import Test.Tasty.HUnit -import Data.Record.Plugin - {-# ANN type R largeRecord #-} data R a = MkR { field1 :: a 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 @@ -21,8 +21,6 @@ import qualified GHC.Generics as GHC -import Data.Record.Plugin - {-# ANN type R largeRecord #-} data R = MkR { a :: Int } deriving (Show) 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 @@ -25,8 +25,6 @@ import Test.Tasty import Test.Tasty.HUnit -import Data.Record.Plugin - type family HKD f a where HKD Identity a = a HKD (Const b) a = b 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 @@ -26,8 +26,6 @@ import Test.Tasty import Test.Tasty.HUnit -import Data.Record.Plugin - newtype T (n :: Nat) (f :: Type -> Type) = MkT (f Word) instance LowerBound (T n I) where diff --git a/test/Test/Record/Sanity/NamedWildCards.hs b/test/Test/Record/Sanity/NamedWildCards.hs --- a/test/Test/Record/Sanity/NamedWildCards.hs +++ b/test/Test/Record/Sanity/NamedWildCards.hs @@ -16,8 +16,6 @@ module Test.Record.Sanity.NamedWildCards where -import Data.Record.Plugin - {-# ANN type X largeRecord #-} data X = MkX { _x :: Int } diff --git a/test/Test/Record/Sanity/Operators.hs b/test/Test/Record/Sanity/Operators.hs --- a/test/Test/Record/Sanity/Operators.hs +++ b/test/Test/Record/Sanity/Operators.hs @@ -16,8 +16,6 @@ import Data.Kind (Type) -import Data.Record.Plugin - -- Some type family (e.g. servant record-style API def). type family tag :- route :: Type diff --git a/test/Test/Record/Sanity/OverloadedRecordUpdate.hs b/test/Test/Record/Sanity/OverloadedRecordUpdate.hs --- a/test/Test/Record/Sanity/OverloadedRecordUpdate.hs +++ b/test/Test/Record/Sanity/OverloadedRecordUpdate.hs @@ -39,7 +39,6 @@ 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" [ 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 @@ -21,8 +21,6 @@ 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 @@ -23,8 +23,6 @@ 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 @@ -12,7 +12,5 @@ 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 @@ -13,8 +13,6 @@ module Test.Record.Sanity.QualifiedImports.B (T(..)) where -import Data.Record.Plugin - import qualified Test.Record.Sanity.QualifiedImports.A as A {-# ANN type T largeRecord #-} 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 @@ -20,8 +20,6 @@ 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/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 @@ -23,8 +23,6 @@ , R5_WithLR(..) ) where -import Data.Record.Plugin - {-# ANN type R1 largeRecord #-} data R1 = MkR1 { r1_x :: Int, r1_y :: Bool } deriving (Show, Eq) 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 @@ -20,8 +20,6 @@ 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 @@ -26,8 +26,6 @@ import qualified Data.Record.Generic.Rep as Rep -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 @@ -27,8 +27,6 @@ import qualified Data.Record.Generic.Rep as Rep -import Data.Record.Plugin - {-# ANN type Lazy largeRecord #-} data Lazy = MkLazy { lazyField :: ~Word }