diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,19 @@ # Revision history for large-records +## 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 + internal representation, so that records can be constructed "as normal". +* Removed support for the pattern synonym, as it's not needed anymore. +* Compatible with ghc 8.10 and 9.0 (as well as 8.8). +* `large-generics` split off as a separate package (#45). +* Remove dependency on micro-lens (#27); + `Data.Record.Lens.Micro` is now `Data.Record.Generic.Lens.VL` + (and lives in `large-generics). +* Fix some strictness issues (#33). +* Refactored test suite and benchmarks. + ## 0.1.0.0 -- 2021-08-19 -* First public release +* First public release. 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.1.0.0 +version: 0.2.0.0 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,191 +16,121 @@ maintainer: edsko@well-typed.com category: Generics extra-source-files: CHANGELOG.md +tested-with: GHC ==8.8.4 || ==8.10.7 || ==9.0.2 source-repository head type: git location: https://github.com/well-typed/large-records library - exposed-modules: Data.Record.Generic - Data.Record.Generic.Eq - Data.Record.Generic.GHC - Data.Record.Generic.JSON - Data.Record.Generic.Lens.Micro - Data.Record.Generic.LowerBound - Data.Record.Generic.Rep - Data.Record.Generic.Rep.Internal - Data.Record.Generic.Show - Data.Record.Generic.SOP - Data.Record.Generic.Transform + exposed-modules: - Data.Record.QQ.CodeGen - Data.Record.QQ.CodeGen.HSE - Data.Record.QQ.CodeGen.Parser - Data.Record.QQ.Runtime.MatchHasField + Data.Record.Plugin + Data.Record.Plugin.Runtime + Data.Record.Plugin.Options - Data.Record.TH - Data.Record.TH.CodeGen - Data.Record.TH.CodeGen.Tree - Data.Record.TH.Config.Options - Data.Record.TH.Runtime + other-modules: - Data.Record.Internal.CodeGen - Data.Record.Internal.Naming - Data.Record.Internal.Record - Data.Record.Internal.Record.Parser - Data.Record.Internal.Record.Resolution - Data.Record.Internal.Record.Resolution.GHC - Data.Record.Internal.Record.Resolution.Internal - Data.Record.Internal.TH.Name - Data.Record.Internal.TH.Util - Data.Record.Internal.Util + Data.Record.Internal.GHC.Fresh + Data.Record.Internal.GHC.Shim + Data.Record.Internal.GHC.TemplateHaskellStyle - build-depends: base >=4.13 && < 4.15 - , aeson - , containers - , generics-sop - , haskell-src-exts - , haskell-src-meta - , microlens - , mtl - , record-hasfield - , sop-core - , syb - , template-haskell - , text - , vector - hs-source-dirs: src - default-language: Haskell2010 - default-extensions: NoStarIsType - ghc-options: -Wall - -Wcompat - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wpartial-fields - -Widentities - -Wredundant-constraints - -Wmissing-export-lists + 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.Options + Data.Record.Internal.Plugin.Record -test-suite test-large-records - type: exitcode-stdio-1.0 - main-is: TestLargeRecords.hs - other-modules: Test.Record.Prop.Show - Test.Record.Prop.Show.Regular - Test.Record.Prop.Show.Large - Test.Record.Prop.ToFromJSON - Test.Record.Sanity.Derive - Test.Record.Sanity.EqualFieldTypes - Test.Record.Sanity.ErrorsAndWarnings - Test.Record.Sanity.ErrorsAndWarnings.Stage1 - Test.Record.Sanity.Generics - Test.Record.Sanity.GhcGenerics - Test.Record.Sanity.HigherKinded - Test.Record.Sanity.HKD - Test.Record.Sanity.Laziness - Test.Record.Sanity.Lens.Micro - Test.Record.Sanity.OverloadingNoDRF - Test.Record.Sanity.PatternMatch - Test.Record.Sanity.QualifiedImports - Test.Record.Sanity.QualifiedImports.A - Test.Record.Sanity.QualifiedImports.B - Test.Record.Sanity.RecordConstruction - Test.Record.Sanity.Strictness - Test.Record.Sanity.Transform - Test.Record.Size.After.HK010 - Test.Record.Size.After.R0010 - Test.Record.Size.Before.Baseline - Test.Record.Size.Before.R010 - Test.Record.Size.Infra - Test.Record.Size.Sanity - Test.Record.Util + build-depends: + base >= 4.13 && < 4.17 + , containers >= 0.6.2 && < 0.7 + , mtl >= 2.2.1 && < 2.3 + , record-hasfield >= 1.0 && < 1.1 + , syb >= 0.7 && < 0.8 + , vector >= 0.12 && < 0.13 + , large-generics >= 0.1 && < 0.2 - build-depends: base - , aeson - , generics-sop - , json-sop - , generic-deriving - -- TODO: Remove: - , ghc-dump-core - , large-records - , newtype - , microlens - , mtl - , record-dot-preprocessor - , record-hasfield - , sop-core - , tasty - , tasty-hunit - , tasty-quickcheck - , template-haskell - , transformers - , vector - , QuickCheck - build-tool-depends: record-dot-preprocessor:record-dot-preprocessor - hs-source-dirs: test - default-language: Haskell2010 - ghc-options: -Wall - -Wcompat - -Wincomplete-uni-patterns - -Wincomplete-record-updates - -Wpartial-fields - -Widentities - -- Needed for the AllZip tests - -freduction-depth=2000 + -- transformers 0.5.6 introduces Writer.CPS + , transformers >= 0.5.6 && < 0.7 - if flag(profile-allzip) - cpp-options: -DPROFILE_ALLZIP + -- whatever version is bundled with ghc + , ghc + , template-haskell + hs-source-dirs: + src + default-language: + Haskell2010 + default-extensions: + NoStarIsType + ghc-options: + -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists - if flag(use-ghc-dump) - cpp-options: -DUSE_GHC_DUMP - build-depends: ghc-dump-core + if impl(ghc >= 8.10) + ghc-options: -Wunused-packages - if flag(build-all-modules) - other-modules: Test.Record.Size.After.HK020 - Test.Record.Size.After.HK030 - Test.Record.Size.After.HK040 - Test.Record.Size.After.HK050 - Test.Record.Size.After.HK060 - Test.Record.Size.After.HK070 - Test.Record.Size.After.HK080 - Test.Record.Size.After.HK090 - Test.Record.Size.After.HK100 - Test.Record.Size.After.R0020 - Test.Record.Size.After.R0030 - Test.Record.Size.After.R0040 - Test.Record.Size.After.R0050 - Test.Record.Size.After.R0060 - Test.Record.Size.After.R0070 - Test.Record.Size.After.R0080 - Test.Record.Size.After.R0090 - Test.Record.Size.After.R0100 - Test.Record.Size.After.R0200 - Test.Record.Size.After.R0300 - Test.Record.Size.After.R0400 - Test.Record.Size.After.R0500 - Test.Record.Size.After.R0600 - Test.Record.Size.After.R0700 - Test.Record.Size.After.R0800 - Test.Record.Size.After.R0900 - Test.Record.Size.After.R1000 - Test.Record.Size.Before.R020 - Test.Record.Size.Before.R030 - Test.Record.Size.Before.R040 - Test.Record.Size.Before.R050 - Test.Record.Size.Before.R060 - Test.Record.Size.Before.R070 - Test.Record.Size.Before.R080 - Test.Record.Size.Before.R090 - Test.Record.Size.Before.R100 +test-suite test-large-records + type: + exitcode-stdio-1.0 + main-is: + TestLargeRecords.hs + other-modules: + Test.Record.Sanity.CodeGen + Test.Record.Sanity.Derive + Test.Record.Sanity.EqualFieldTypes + Test.Record.Sanity.HigherKinded + Test.Record.Sanity.HKD + Test.Record.Sanity.OverloadingNoDRF + Test.Record.Sanity.PatternMatch + Test.Record.Sanity.QualifiedImports + Test.Record.Sanity.QualifiedImports.A + Test.Record.Sanity.QualifiedImports.B + Test.Record.Sanity.RDP.SingleModule + Test.Record.Sanity.RDP.SplitModule + Test.Record.Sanity.RDP.SplitModule.RecordDef + Test.Record.Sanity.RecordConstruction + Test.Record.Sanity.Strictness + Test.Record.Sanity.GhcGenerics + Test.Record.Util -Flag build-all-modules - Description: Build all test modules in Size - Default: False + build-depends: + base + , large-records -Flag use-ghc-dump - Description: use ghc-dump to output AST sizes - Default: False + , generic-deriving + , large-generics + , mtl + , newtype + , record-hasfield + , tasty + , tasty-hunit + , template-haskell + , transformers -Flag profile-allzip - Description: Include experiment to verify size of AllZip is linear - Default: False + -- + , record-dot-preprocessor >= 0.2.14 + hs-source-dirs: + test + default-language: + Haskell2010 + ghc-options: + -Wall + -Wcompat + -Wincomplete-uni-patterns + -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/Generic.hs b/src/Data/Record/Generic.hs deleted file mode 100644 --- a/src/Data/Record/Generic.hs +++ /dev/null @@ -1,100 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE TypeFamilies #-} - -module Data.Record.Generic ( - -- * Types with a generic view - Generic(..) - , Rep(..) -- TODO: Make opaque? - -- * Metadata - , Metadata(..) - , FieldStrictness(..) - , recordFieldNames - , FieldMetadata(..) - -- * Working with type-level metadata - , FieldName - , FieldType - , IsField - -- * Re-exports - , module SOP - , Proxy(..) - ) where - -import Data.Kind -import Data.Proxy -import GHC.TypeLits - --- To reduce overlap between the two libraries and improve interoperability, --- we import as much from sop-core as possible. -import Data.SOP.BasicFunctors as SOP -import Data.SOP.Classes as SOP (type (-.->)(..)) -import Data.SOP.Dict as SOP (Dict(..)) - -import Data.Record.Generic.Rep.Internal (Rep(..)) - -import qualified Data.Record.Generic.Rep.Internal as Rep - -{------------------------------------------------------------------------------- - Generic type class --------------------------------------------------------------------------------} - -class Generic a where - -- | @Constraints a c@ means "all fields of @a@ satisfy @c@" - type Constraints a :: (Type -> Constraint) -> Constraint - - -- | Type-level metadata - type MetadataOf a :: [(Symbol, Type)] - - -- | Translate to generic representation - from :: a -> Rep I a - - -- | Translate from generic representation - to :: Rep I a -> a - - -- | Construct vector of dictionaries, one for each field of the record - dict :: Constraints a c => Proxy c -> Rep (Dict c) a - - -- | Metadata - metadata :: proxy a -> Metadata a - -{------------------------------------------------------------------------------- - Metadata --------------------------------------------------------------------------------} - -data Metadata a = Metadata { - recordName :: String - , recordConstructor :: String - , recordSize :: Int - , recordFieldMetadata :: Rep FieldMetadata a - } - -data FieldStrictness = FieldStrict | FieldLazy - -data FieldMetadata x where - FieldMetadata :: - KnownSymbol name - => Proxy name - -> FieldStrictness - -> FieldMetadata x - -recordFieldNames :: Metadata a -> Rep (K String) a -recordFieldNames = Rep.map' aux . recordFieldMetadata - where - aux :: FieldMetadata x -> K String x - aux (FieldMetadata p _) = K $ symbolVal p - -{------------------------------------------------------------------------------- - Working with the type-level metadata --------------------------------------------------------------------------------} - -type family FieldName (field :: (Symbol, Type)) :: Symbol where - FieldName '(name, _typ) = name - -type family FieldType (field :: (Symbol, Type)) :: Type where - FieldType '(_name, typ) = typ - -class (field ~ '(FieldName field, FieldType field)) => IsField field -instance (field ~ '(FieldName field, FieldType field)) => IsField field diff --git a/src/Data/Record/Generic/Eq.hs b/src/Data/Record/Generic/Eq.hs deleted file mode 100644 --- a/src/Data/Record/Generic/Eq.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -Wwarn #-} - -module Data.Record.Generic.Eq ( - geq - , gcompare - ) where - -import Data.Record.Generic -import qualified Data.Record.Generic.Rep as Rep - --- | Generic equality function --- --- Typical usage: --- --- > instance Eq T where --- > (==) = geq --- --- TODO: Should we worry about short-circuiting here? -geq :: (Generic a, Constraints a Eq) => a -> a -> Bool -geq = \x y -> - and - . Rep.collapse - $ Rep.czipWith (Proxy @Eq) compareField (from x) (from y) - where - compareField :: Eq x => I x -> I x -> K Bool x - compareField (I x) (I y) = K (x == y) - -gcompare :: (Generic a, Constraints a Ord) => a -> a -> Ordering -gcompare = \x y -> - mconcat - . Rep.collapse - $ Rep.czipWith (Proxy @Ord) compareField (from x) (from y) - where - compareField :: Ord x => I x -> I x -> K Ordering x - compareField (I x) (I y) = K (compare x y) diff --git a/src/Data/Record/Generic/GHC.hs b/src/Data/Record/Generic/GHC.hs deleted file mode 100644 --- a/src/Data/Record/Generic/GHC.hs +++ /dev/null @@ -1,111 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | Interop with standard GHC generics -module Data.Record.Generic.GHC ( - -- * From GHC to LR generics - ThroughLRGenerics(..) - -- * GHC generics metadata - , GhcMetadata(..) - , GhcFieldMetadata(..) - , ghcMetadata - ) where - -import Data.Kind -import Data.Proxy -import GHC.Generics hiding (Generic(..), Rep) -import GHC.TypeLits - -import Data.Record.Generic - -import qualified Data.Record.Generic.Rep as Rep - -{------------------------------------------------------------------------------- - From GHC to LR generics --------------------------------------------------------------------------------} - --- | Route from GHC generics to LR generics --- --- Suppose a function such as --- --- > allEqualTo :: Eq a => a -> [a] -> Bool --- > allEqualTo x = all (== x) --- --- is instead written as --- --- > allEqualTo :: (GHC.Generic a, GHC.GEq' (GHC.Rep a)) => a -> [a] -> Bool --- > allEqualTo x = all (GHC.geqdefault x) --- --- where instead of using an indirection through an auxiliary type class `Eq`, --- it directly assumes @GHC.Generics@ and uses a concrete generic --- implementation. Such design is arguably questionable, but for example --- @beam-core@ contains many such deeply ingrained assumptions of the --- availability of @GHC.Generics@. --- --- In order to be able to call such a function on a large record @Foo@, --- 'largeRecord' will generate an instance --- --- > instance GHC.Generic Foo where --- > type Rep Foo = ThroughLRGenerics Foo --- > --- > from = WrapThroughLRGenerics --- > to = unwrapThroughLRGenerics --- --- For our running example, this instance makes it possible to call 'allEqualTo' --- provided we then provide an instance --- --- > instance ( LR.Generic a --- > , LR.Constraints a Eq --- > ) => GHC.GEq' (ThroughLRGenerics a) where --- > geq' = LR.geq `on` unwrapThroughLRGenerics --- --- Effectively, 'ThroughLRGenerics' can be used to redirect a function that uses --- GHC generics to a function that uses LR generics. -newtype ThroughLRGenerics a p = WrapThroughLRGenerics { - unwrapThroughLRGenerics :: a - } - -{------------------------------------------------------------------------------- - GHC generics metadata --------------------------------------------------------------------------------} - --- | GHC generics metadata --- --- TODO: Currently we provide metadata only for the record fields, not the --- constructor or type name -data GhcMetadata a = GhcMetadata { - ghcMetadataFields :: Rep GhcFieldMetadata a - } - -data GhcFieldMetadata :: Type -> Type where - GhcFieldMetadata :: forall (f :: Meta) (a :: Type). - Selector f - => Proxy f -> GhcFieldMetadata a - -withFieldMetadata :: forall (s :: Symbol) (r :: Type). - KnownSymbol s - => Proxy s - -> FieldStrictness - -> (forall (f :: Meta). Selector f => Proxy f -> r) - -> r -withFieldMetadata _ s k = - case s of - FieldLazy -> k (Proxy @('MetaSel ('Just s) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedLazy)) - FieldStrict -> k (Proxy @('MetaSel ('Just s) 'NoSourceUnpackedness 'NoSourceStrictness 'DecidedStrict)) - -ghcMetadata :: Generic a => proxy a -> GhcMetadata a -ghcMetadata pa = GhcMetadata { - ghcMetadataFields = Rep.map ghcFieldMetadata recordFieldMetadata - } - where - Metadata{..} = metadata pa - - ghcFieldMetadata :: FieldMetadata x -> GhcFieldMetadata x - ghcFieldMetadata (FieldMetadata pName s) = - withFieldMetadata pName s $ GhcFieldMetadata diff --git a/src/Data/Record/Generic/JSON.hs b/src/Data/Record/Generic/JSON.hs deleted file mode 100644 --- a/src/Data/Record/Generic/JSON.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | Generic conversion to/from JSON -module Data.Record.Generic.JSON ( - gtoJSON - , gparseJSON - ) where - -import Data.Aeson -import Data.Aeson.Types -import Data.Proxy - -import qualified Data.Text as Text - -import Data.Record.Generic -import qualified Data.Record.Generic.Rep as Rep - -gtoJSON :: forall a. (Generic a, Constraints a ToJSON) => a -> Value -gtoJSON = - object - . Rep.collapse - . Rep.zipWith (mapKKK $ \n x -> (Text.pack n, x)) (recordFieldNames md) - . Rep.cmap (Proxy @ToJSON) (K . toJSON . unI) - . from - where - md = metadata (Proxy @a) - -gparseJSON :: forall a. (Generic a, Constraints a FromJSON) => Value -> Parser a -gparseJSON = - withObject (recordName md) (fmap to . Rep.sequenceA . aux) - where - md = metadata (Proxy @a) - - aux :: Object -> Rep (Parser :.: I) a - aux obj = - Rep.cmap - (Proxy @FromJSON) - (\(K fld) -> Comp (I <$> getField fld)) - (recordFieldNames md) - where - getField :: FromJSON x => String -> Parser x - getField fld = obj .: Text.pack fld diff --git a/src/Data/Record/Generic/Lens/Micro.hs b/src/Data/Record/Generic/Lens/Micro.hs deleted file mode 100644 --- a/src/Data/Record/Generic/Lens/Micro.hs +++ /dev/null @@ -1,212 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE QuantifiedConstraints #-} - -module Data.Record.Generic.Lens.Micro ( - -- * Lenses for records - SimpleRecordLens(..) - , HKRecordLens(..) - , RegularRecordLens(..) - , lensesForSimpleRecord - , lensesForHKRecord - , lensesForRegularRecord - -- * Regular records - , RegularField(..) - , IsRegularField(..) - -- * Lenses into 'Rep' - , RepLens(..) - , repLenses - -- * General purpose lenses - , genericLens - , normalForm1Lens - , interpretedLens - , standardInterpretationLens - ) where - -import Data.Kind -import Lens.Micro (Lens') - -import Data.Record.Generic -import Data.Record.Generic.Transform - -import qualified Data.Record.Generic.Rep as Rep - -{------------------------------------------------------------------------------- - Simple records (in contrast to higher-kinded records, see below) --------------------------------------------------------------------------------} - -data SimpleRecordLens a b where - SimpleRecordLens :: Lens' a b -> SimpleRecordLens a b - --- | Construct lenses for each field in the record --- --- NOTE: This is of limited use since we cannot pattern match on the resulting --- 'Rep' in any meaningful way. It is possible to go through the SOP adapter, --- but if we do, we incur quadratic cost again. --- --- We can do better for higher-kinded records, and better still for regular --- higher-kinded records. See 'lensesForHKRecord' and 'lensesForRegularRecord'. -lensesForSimpleRecord :: forall a. Generic a => Rep (SimpleRecordLens a) a -lensesForSimpleRecord = - Rep.map (\(RepLens l) -> SimpleRecordLens $ \f -> aux l f) repLenses - where - aux :: Lens' (Rep I a) (I x) -> Lens' a x - aux l f a = to <$> l (\(I x) -> I <$> f x) (from a) - -{------------------------------------------------------------------------------- - Higher-kinded records (records with a functor parameter) --------------------------------------------------------------------------------} - --- | Lens for higher-kinded record --- --- See 'lensesForHKRecord' for details. -data HKRecordLens d (f :: Type -> Type) tbl x where - HKRecordLens :: Lens' (tbl f) (Interpret (d f) x) -> HKRecordLens d f tbl x - --- | Lenses for higher-kinded records --- --- NOTE: The lenses constructed by this function are primarily intended for --- further processing, either by 'lensesForRegularRecord' or using application --- specific logic. Details below. --- --- Suppose we have a record @tbl f@ which is indexed by a functor @f@, and we --- want to construct lenses from @tbl f@ to each field in the record. Using the --- @Transform@ infrastructure, we can construct a lens --- --- > tbl f ~~> Rep I (tbl f) ~~> Rep (Interpret (d f)) (tbl Uninterpreted) --- --- Using 'repLenses' we can construct a lens of type --- --- > Rep (Interpret (d f)) (tbl Uninterpreted) ~~> Interpret (d f) x --- --- for every field of type @x@. Putting these two together gives us a lens --- --- > tbl f ~~> Interpret (d f) x --- --- for every field in @tbl Uninterpreted@. We cannot simplify this, because we --- do not know anything about the shape of @x@; specifically, it might not be --- equal to @Uninterpreted x'@ for some @x'@, and hence we cannot simplify the --- target type of the lens. We can do better for records with regular fields; --- see 'lensesForRegularRecord'. -lensesForHKRecord :: forall d tbl f. - ( Generic (tbl f) - , Generic (tbl Uninterpreted) - , HasNormalForm (d f) (tbl f) (tbl Uninterpreted) - ) - => Proxy d -> Rep (HKRecordLens d f tbl) (tbl Uninterpreted) -lensesForHKRecord d = Rep.map aux fromRepLenses - where - fromRepLenses :: Rep (RepLens (Interpret (d f)) (tbl Uninterpreted)) (tbl Uninterpreted) - fromRepLenses = repLenses - - aux :: forall x. RepLens (Interpret (d f)) (tbl Uninterpreted) x -> HKRecordLens d f tbl x - aux (RepLens l) = HKRecordLens $ - genericLens - . normalForm1Lens d - . l - -{------------------------------------------------------------------------------- - Regular records --------------------------------------------------------------------------------} - --- | Proof that @x@ is a regular field --- --- See 'IsRegularField' -data RegularField f x where - RegularField :: RegularField f (f x) - --- | Regular record fields --- --- For a higher-kinded record @tbl f@, parameterized over some functor @f@, --- we say that the fields are /regular/ iff every field has the form @f x@ --- for some @x@. -class IsRegularField f x where - isRegularField :: Proxy (f x) -> RegularField f x - -instance IsRegularField f (f x) where - isRegularField _ = RegularField - -{------------------------------------------------------------------------------- - Lenses into regular records --------------------------------------------------------------------------------} - --- | Lens into a regular record --- --- See 'lensesForRegularRecord' -data RegularRecordLens tbl f x where - RegularRecordLens :: Lens' (tbl f) (f x) -> RegularRecordLens tbl f x - --- | Lenses into higher-kinded records with regular fields --- --- We can use 'lensesForHKRecord' to construct a 'Rep' of lenses into a higher-kinded --- record. If in addition the record is regular, we can use the record type --- /itself/ to store all the lenses. -lensesForRegularRecord :: forall d tbl f. - ( Generic (tbl (RegularRecordLens tbl f)) - , Generic (tbl Uninterpreted) - , Generic (tbl f) - , HasNormalForm (d (RegularRecordLens tbl f)) (tbl (RegularRecordLens tbl f)) (tbl Uninterpreted) - , HasNormalForm (d f) (tbl f) (tbl Uninterpreted) - , Constraints (tbl Uninterpreted) (IsRegularField Uninterpreted) - , StandardInterpretation d (RegularRecordLens tbl f) - , StandardInterpretation d f - ) - => Proxy d -> tbl (RegularRecordLens tbl f) -lensesForRegularRecord d = to . denormalize1 d $ - Rep.cmap - (Proxy @(IsRegularField Uninterpreted)) - aux - (lensesForHKRecord d) - where - aux :: forall x. - IsRegularField Uninterpreted x - => HKRecordLens d f tbl x - -> Interpret (d (RegularRecordLens tbl f)) x - aux (HKRecordLens l) = - case isRegularField (Proxy @(Uninterpreted x)) of - RegularField -> toStandardInterpretation d $ RegularRecordLens $ - l . standardInterpretationLens d - -{------------------------------------------------------------------------------- - Lenses into 'Rep' --------------------------------------------------------------------------------} - -data RepLens f a x where - RepLens :: Lens' (Rep f a) (f x) -> RepLens f a x - -repLenses :: Generic a => Rep (RepLens f a) a -repLenses = Rep.map aux Rep.allIndices - where - aux :: Rep.Index a x -> RepLens f a x - aux ix = RepLens $ Rep.updateAtIndex ix - -{------------------------------------------------------------------------------- - General purpose lenses --------------------------------------------------------------------------------} - -genericLens :: Generic a => Lens' a (Rep I a) -genericLens f a = to <$> f (from a) - -normalForm1Lens :: - HasNormalForm (d f) (x f) (x Uninterpreted) - => Proxy d - -> Lens' (Rep I (x f)) (Rep (Interpret (d f)) (x Uninterpreted)) -normalForm1Lens p f a = denormalize1 p <$> f (normalize1 p a) - -interpretedLens :: Lens' (Interpret d x) (Interpreted d x) -interpretedLens f (Interpret x) = Interpret <$> f x - -standardInterpretationLens :: forall d f x. - StandardInterpretation d f - => Proxy d - -> Lens' (Interpret (d f) (Uninterpreted x)) (f x) -standardInterpretationLens p f x = - toStandardInterpretation p <$> - f (fromStandardInterpretation p x) diff --git a/src/Data/Record/Generic/LowerBound.hs b/src/Data/Record/Generic/LowerBound.hs deleted file mode 100644 --- a/src/Data/Record/Generic/LowerBound.hs +++ /dev/null @@ -1,31 +0,0 @@ -{-# LANGUAGE TypeApplications #-} - --- | Simple example of a generic function -module Data.Record.Generic.LowerBound ( - LowerBound(..) - , glowerBound - ) where - -import Data.Record.Generic -import qualified Data.Record.Generic.Rep as Rep - -{------------------------------------------------------------------------------- - General definition --------------------------------------------------------------------------------} - --- | Types with a lower bound -class LowerBound a where - lowerBound :: a - -instance LowerBound Word where lowerBound = 0 -instance LowerBound Bool where lowerBound = False -instance LowerBound Char where lowerBound = '\x0000' -instance LowerBound () where lowerBound = () -instance LowerBound [a] where lowerBound = [] - -{------------------------------------------------------------------------------- - Generic definition --------------------------------------------------------------------------------} - -glowerBound :: (Generic a, Constraints a LowerBound) => a -glowerBound = to $ Rep.cpure (Proxy @LowerBound) (I lowerBound) diff --git a/src/Data/Record/Generic/Rep.hs b/src/Data/Record/Generic/Rep.hs deleted file mode 100644 --- a/src/Data/Record/Generic/Rep.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TemplateHaskell #-} - --- | Operations on the generic representation --- --- We also re-export some non-derive functions to clarify where they belong --- in this list. --- --- This module is intended for qualified import. --- --- > import qualified Data.Record.Generic.Rep as Rep --- --- TODO: Could we provide instances for the @generics-sop@ type classes? --- Might lessen the pain of switching between the two or using both? -module Data.Record.Generic.Rep ( - Rep(..) -- TODO: Make opaque? - -- * "Functor" - , map - , mapM - , cmap - , cmapM - -- * Zipping - , zip - , zipWith - , zipWithM - , czipWith - , czipWithM - -- * "Foldable" - , collapse - -- * "Traversable" - , sequenceA - -- * "Applicable" - , pure - , cpure - , ap - -- * Array-like interface - , Index -- opaque - , indexToInt - , getAtIndex - , putAtIndex - , updateAtIndex - , allIndices - , mapWithIndex - ) where - -import Prelude hiding ( - map - , mapM - , pure - , sequenceA - , zip - , zipWith - ) - -import Data.Proxy -import Data.Functor.Identity -import Data.Functor.Product -import Data.SOP.Classes (fn_2) -import Unsafe.Coerce (unsafeCoerce) - -import qualified Data.Vector as V - -import Data.Record.Generic -import Data.Record.Generic.Rep.Internal - --- --- NOTE: In order to avoid circular definitions, this module is strictly defined --- in order: every function only depends on the functions defined before it. To --- enforce this, we make use of 'compileToHere' to force ghc to compile the --- module to that point. --- - -{------------------------------------------------------------------------------- - Array-like interface --------------------------------------------------------------------------------} - -newtype Index a x = UnsafeIndex Int - -indexToInt :: Index a x -> Int -indexToInt (UnsafeIndex ix) = ix - -getAtIndex :: Index a x -> Rep f a -> f x -getAtIndex (UnsafeIndex ix) (Rep v) = - unsafeCoerce $ V.unsafeIndex v ix - -putAtIndex :: Index a x -> f x -> Rep f a -> Rep f a -putAtIndex (UnsafeIndex ix) x (Rep v) = Rep $ - V.unsafeUpd v [(ix, unsafeCoerce x)] - -updateAtIndex :: - Functor m - => Index a x - -> (f x -> m (f x)) - -> Rep f a -> m (Rep f a) -updateAtIndex ix f a = (\x -> putAtIndex ix x a) <$> f (getAtIndex ix a) - -allIndices :: forall a. Generic a => Rep (Index a) a -allIndices = Rep $ V.generate (recordSize (metadata (Proxy @a))) UnsafeIndex - --- | Map with index --- --- This is an important building block in this module. --- Crucially, @mapWithIndex f a@ is lazy in @a@, reading elements from @a@ --- only if and when @f@ demands them. -mapWithIndex :: - forall f g a. Generic a - => (forall x. Index a x -> f x -> g x) - -> Rep f a -> Rep g a -mapWithIndex f as = map' f' allIndices - where - f' :: Index a x -> g x - f' ix = f ix (getAtIndex ix as) -compileToHere -- =============================================================== - -{------------------------------------------------------------------------------- - "Applicative" --------------------------------------------------------------------------------} - -pure :: forall f a. Generic a => (forall x. f x) -> Rep f a -pure = Rep . V.replicate (recordSize (metadata (Proxy @a))) - -cpure :: - (Generic a, Constraints a c) - => Proxy c - -> (forall x. c x => f x) - -> Rep f a -cpure p f = map' (\Dict -> f) (dict p) - --- | Higher-order version of @<*>@ --- --- Lazy in the second argument. -ap :: forall f g a. Generic a => Rep (f -.-> g) a -> Rep f a -> Rep g a -ap fs as = mapWithIndex f' fs - where - f' :: Index a x -> (-.->) f g x -> g x - f' ix f = f `apFn` getAtIndex ix as - -compileToHere -- =============================================================== - -{------------------------------------------------------------------------------- - "Functor" --------------------------------------------------------------------------------} - -map :: Generic a => (forall x. f x -> g x) -> Rep f a -> Rep g a -map f = mapWithIndex (const f) - -mapM :: - (Applicative m, Generic a) - => (forall x. f x -> m (g x)) - -> Rep f a -> m (Rep g a) -mapM f = sequenceA . mapWithIndex (const (Comp . f)) - -cmap :: - (Generic a, Constraints a c) - => Proxy c - -> (forall x. c x => f x -> g x) - -> Rep f a -> Rep g a -cmap p f = ap $ cpure p (Fn f) - -cmapM :: - forall m f g c a. (Generic a, Applicative m, Constraints a c) - => Proxy c - -> (forall x. c x => f x -> m (g x)) - -> Rep f a -> m (Rep g a) -cmapM p f = sequenceA . cmap p (Comp . f) - -compileToHere -- =============================================================== - -{------------------------------------------------------------------------------- - Zipping --------------------------------------------------------------------------------} - -zipWithM :: - forall m f g h a. (Generic a, Applicative m) - => (forall x. f x -> g x -> m (h x)) - -> Rep f a -> Rep g a -> m (Rep h a) -zipWithM f a b = sequenceA $ - pure (fn_2 $ \x y -> Comp $ f x y) `ap` a `ap` b - -zipWith :: - Generic a - => (forall x. f x -> g x -> h x) - -> Rep f a -> Rep g a -> Rep h a -zipWith f a b = runIdentity $ - zipWithM (\x y -> Identity $ f x y) a b - -zip :: Generic a => Rep f a -> Rep g a -> Rep (Product f g) a -zip = zipWith Pair - -czipWithM :: - forall m f g h c a. (Generic a, Applicative m, Constraints a c) - => Proxy c - -> (forall x. c x => f x -> g x -> m (h x)) - -> Rep f a -> Rep g a -> m (Rep h a) -czipWithM p f a b = sequenceA $ - cpure p (fn_2 $ \x y -> Comp $ f x y) `ap` a `ap` b - -czipWith :: - (Generic a, Constraints a c) - => Proxy c - -> (forall x. c x => f x -> g x -> h x) - -> Rep f a -> Rep g a -> Rep h a -czipWith p f a b = runIdentity $ - czipWithM p (\x y -> Identity (f x y)) a b - -compileToHere -- =============================================================== diff --git a/src/Data/Record/Generic/Rep/Internal.hs b/src/Data/Record/Generic/Rep/Internal.hs deleted file mode 100644 --- a/src/Data/Record/Generic/Rep/Internal.hs +++ /dev/null @@ -1,91 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RoleAnnotations #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - --- | Definition of 'Rep' and functions that do not depend on ".Generic" --- --- Defined as a separate module to avoid circular module dependencies. -module Data.Record.Generic.Rep.Internal ( - Rep(..) - -- * Basic functions - , map' - , sequenceA - -- * Conversion - , unsafeFromList - , collapse - -- * Utility (for use in @.Rep@) - , compileToHere - ) where - -import Prelude hiding (sequenceA) -import qualified Prelude - -import Data.Coerce (coerce) -import Data.SOP.BasicFunctors -import Data.Vector (Vector) -import GHC.Exts (Any) -import Language.Haskell.TH - -import qualified Data.Vector as V - -{------------------------------------------------------------------------------- - Representation --------------------------------------------------------------------------------} - --- | Representation of some record @a@ --- --- The @f@ parameter describes which functor has been applied to all fields of --- the record; in other words @Rep I@ is isomorphic to the record itself. -newtype Rep f a = Rep (Vector (f Any)) - -type role Rep representational nominal - -{------------------------------------------------------------------------------- - Basic functions --------------------------------------------------------------------------------} - --- | Strict map --- --- @map' f x@ is strict in @x@: if @x@ is undefined, @map f x@ will also be --- undefined, even if @f@ never needs any values from @x@. -map' :: (forall x. f x -> g x) -> Rep f a -> Rep g a -map' f (Rep v) = Rep $ f <$> v - -sequenceA :: Applicative m => Rep (m :.: f) a -> m (Rep f a) -sequenceA (Rep v) = Rep <$> Prelude.sequenceA (fmap unComp v) - -{------------------------------------------------------------------------------- - Conversion --------------------------------------------------------------------------------} - -collapse :: Rep (K a) b -> [a] -collapse (Rep v) = coerce (V.toList v) - --- | Convert list to 'Rep' --- --- Does not check that the length has the right number of elements. -unsafeFromList :: [b] -> Rep (K b) a -unsafeFromList = Rep . V.fromList . Prelude.map K - -{------------------------------------------------------------------------------- - Some specialised instances for 'Rep --------------------------------------------------------------------------------} - -instance Show x => Show (Rep (K x) a) where - show (Rep v) = - show $ Prelude.map unK (V.toList v) - -instance Eq x => Eq (Rep (K x) a) where - Rep v == Rep v' = - Prelude.map unK (V.toList v) - == Prelude.map unK (V.toList v') - -{------------------------------------------------------------------------------- - Internal utility --------------------------------------------------------------------------------} - -compileToHere :: Q [Dec] -compileToHere = return [] diff --git a/src/Data/Record/Generic/SOP.hs b/src/Data/Record/Generic/SOP.hs deleted file mode 100644 --- a/src/Data/Record/Generic/SOP.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - --- | Interop with @generics-sop@ generics -module Data.Record.Generic.SOP ( - -- | Translate between SOP representation and large-records representation - Field(..) - , fromSOP - , toSOP - -- | Translate constraints - , toDictAll - -- | Additional SOP functions - , glowerBound - ) where - -import Data.Kind -import Data.Proxy -import Data.SOP.Dict (all_NP) -import Generics.SOP (SOP(..), NS(..), NP(..), SListI, All, Code, Compose) -import GHC.Exts (Any) -import GHC.TypeLits (Symbol) - -import qualified Data.Vector as V -import qualified Generics.SOP as SOP - -import Data.Record.Generic -import Data.Record.Generic.LowerBound hiding (glowerBound) -import Data.Record.TH.Runtime (noInlineUnsafeCo) - -{------------------------------------------------------------------------------- - Conversion back and forth to generics-sop records - - NOTE: We do /not/ require @SListI (MetadataOf a)@ by default, as this would - result in quadratic blow-up again. This is only required in this module for - SOP interop. - - NOTE: We don't currently use @records-sop@, despite it being a /near/ perfect - fit. The problem is that @records-sop@ is not generalized over a functor, - which would make these functions less general than we need them to be. --------------------------------------------------------------------------------} - -newtype Field (f :: Type -> Type) (field :: (Symbol, Type)) where - Field :: f (FieldType field) -> Field f field - -deriving instance Show (f x) => Show (Field f '(nm, x)) -deriving instance Eq (f x) => Eq (Field f '(nm, x)) - -fromSOP :: SListI (MetadataOf a) => NP (Field f) (MetadataOf a) -> Rep f a -fromSOP = - Rep . V.fromList . SOP.hcollapse . SOP.hmap conv - where - conv :: Field f field -> K (f Any) field - conv (Field fx) = K $ noInlineUnsafeCo fx - -toSOP :: SListI (MetadataOf a) => Rep f a -> Maybe (NP (Field f) (MetadataOf a)) -toSOP (Rep v) = - SOP.hmap conv <$> SOP.fromList (V.toList v) - where - conv :: K (f Any) field -> Field f field - conv (K fx) = Field (noInlineUnsafeCo fx) - -{------------------------------------------------------------------------------- - Translate constraints --------------------------------------------------------------------------------} - --- | Translate constraints --- --- When using 'toSOP', if you start with something of type --- --- > Rep f a --- --- you end up with something of type --- --- > NP (Field f) (MetadataOf a) --- --- When doing so, 'toDictAll' can translate --- --- > Constraints a (Compose c f) --- --- (which is useful over the original representation) to --- --- > All (Compose c (Field f)) (MetadataOf a) --- --- which is useful for the translated representation. -toDictAll :: - forall f a c. - ( Generic a - , Constraints a (Compose c f) - , All IsField (MetadataOf a) - , forall nm x. c (f x) => c (Field f '(nm, x)) - ) - => Proxy f - -> Proxy a - -> Proxy c - -> Dict (All (Compose c (Field f))) (MetadataOf a) -toDictAll _ _ _ = - case toSOP dictT of - Nothing -> error "toDictAll: invalid dictionary" - Just d -> all_NP (SOP.hcmap (Proxy @IsField) conv d) - where - dictT :: Rep (Dict (Compose c f)) a - dictT = dict (Proxy @(Compose c f)) - - conv :: IsField field - => Field (Dict (Compose c f)) field - -> Dict (Compose c (Field f)) field - conv (Field Dict) = Dict - -{------------------------------------------------------------------------------- - Additional SOP generic functions --------------------------------------------------------------------------------} - -glowerBound :: (SOP.Generic a, All LowerBound xs, Code a ~ '[xs]) => a -glowerBound = SOP.to . SOP . Z $ SOP.hcpure (Proxy @LowerBound) (I lowerBound) diff --git a/src/Data/Record/Generic/Show.hs b/src/Data/Record/Generic/Show.hs deleted file mode 100644 --- a/src/Data/Record/Generic/Show.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - -module Data.Record.Generic.Show ( - gshowsPrec - ) where - -import Data.Record.Generic -import Data.List (intersperse) -import GHC.Show - -import qualified Data.Record.Generic.Rep as Rep - --- | Generic definition of 'showsPrec', compatible with the GHC generated one. --- --- Typical usage: --- --- > instance Show T where --- > showsPrec = gshowsPrec -gshowsPrec :: forall a. (Generic a, Constraints a Show) => Int -> a -> ShowS -gshowsPrec d = - aux - . Rep.collapse - . Rep.czipWith (Proxy @Show) showField (recordFieldNames md) - . from - where - md = metadata (Proxy @a) - - showField :: Show x => K String x -> I x -> K ShowS x - showField (K n) (I x) = K $ showString n . showString " = " . showsPrec 0 x - - aux :: [ShowS] -> ShowS - aux fields = showParen (d >= 11) ( - showString (recordConstructor md) . showString " {" - . foldr (.) id (intersperse showCommaSpace fields) - . showString "}" - ) diff --git a/src/Data/Record/Generic/Transform.hs b/src/Data/Record/Generic/Transform.hs deleted file mode 100644 --- a/src/Data/Record/Generic/Transform.hs +++ /dev/null @@ -1,174 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE UndecidableSuperClasses #-} - --- The 'HasNormalForm' constraint on 'normalize' and 'denormalize' is --- redundant as far as ghc is concerned (it's just 'unsafeCoerce' after all), --- but essential for type safety of these two functions. -{-# OPTIONS_GHC -Wno-redundant-constraints #-} - -module Data.Record.Generic.Transform ( - -- * Interpretation function - Interpreted - , Interpret(..) - -- ** Working with the 'Interpreted' newtype wrapper - , liftInterpreted - , liftInterpretedA2 - -- * Normal form - -- ** Existence - , HasNormalForm - , InterpretTo - , IfEqual - -- ** Construction - , normalize - , denormalize - -- ** Specialized forms for the common case of a single type argument - , Uninterpreted - , DefaultInterpretation - , normalize1 - , denormalize1 - -- ** Generalization of the default interpretation - , StandardInterpretation(..) - , toStandardInterpretation - , fromStandardInterpretation - ) where - -import Data.Coerce -import Data.Kind -import Data.Proxy -import Data.SOP.BasicFunctors -import GHC.TypeLits -import Unsafe.Coerce (unsafeCoerce) - -import Data.Record.Generic - -{------------------------------------------------------------------------------- - Interpretation function --------------------------------------------------------------------------------} - -type family Interpreted (d :: dom) (x :: Type) :: Type - -newtype Interpret d x = Interpret (Interpreted d x) - -{------------------------------------------------------------------------------- - Working with the 'Interpreted' newtype wrapper --------------------------------------------------------------------------------} - -liftInterpreted :: - (Interpreted dx x -> Interpreted dy y) - -> (Interpret dx x -> Interpret dy y) -liftInterpreted f (Interpret x) = Interpret (f x) - -liftInterpretedA2 :: - Applicative m - => (Interpreted dx x -> Interpreted dy y -> m (Interpreted dz z)) - -> (Interpret dx x -> Interpret dy y -> m (Interpret dz z)) -liftInterpretedA2 f (Interpret x) (Interpret y) = Interpret <$> f x y - -{------------------------------------------------------------------------------- - Normal forms --------------------------------------------------------------------------------} - -type HasNormalForm d x y = InterpretTo d (MetadataOf x) (MetadataOf y) - -type family InterpretTo d xs ys :: Constraint where - InterpretTo _ '[] '[] = () - InterpretTo d ('(f, x) ': xs) ('(f, y) ': ys) = IfEqual x (Interpreted d y) - (InterpretTo d xs ys) - -type family IfEqual x y (r :: k) :: k where - IfEqual actual actual k = k - IfEqual expected actual k = TypeError ( - 'Text "Expected " - ':<>: 'ShowType expected - ':<>: 'Text " but got " - ':<>: 'ShowType actual - ) - --- | Construct normal form --- --- TODO: Documentation. -normalize :: - HasNormalForm d x y - => Proxy d - -> Proxy y - -> Rep I x -> Rep (Interpret d) y -normalize _ _ = unsafeCoerce - -denormalize :: - HasNormalForm d x y - => Proxy d - -> Proxy y - -> Rep (Interpret d) y -> Rep I x -denormalize _ _ = unsafeCoerce - -{------------------------------------------------------------------------------- - Specialized forms for the common case of a single type argument - - The test ("Test.Record.Sanity.Transform") shows an example with two arguments. --------------------------------------------------------------------------------} - -data Uninterpreted x - -data DefaultInterpretation (f :: Type -> Type) - -type instance Interpreted (DefaultInterpretation f) (Uninterpreted x) = f x - -normalize1 :: forall d f x. - HasNormalForm (d f) (x f) (x Uninterpreted) - => Proxy d - -> Rep I (x f) -> Rep (Interpret (d f)) (x Uninterpreted) -normalize1 _ = normalize (Proxy @(d f)) (Proxy @(x Uninterpreted)) - -denormalize1 :: forall d f x. - HasNormalForm (d f) (x f) (x Uninterpreted) - => Proxy d - -> Rep (Interpret (d f)) (x Uninterpreted) -> Rep I (x f) -denormalize1 _ = denormalize (Proxy @(d f)) (Proxy @(x Uninterpreted)) - -{------------------------------------------------------------------------------- - Generalization of the default interpretation --------------------------------------------------------------------------------} - -class StandardInterpretation d f where - standardInterpretation :: - Proxy d - -> ( Interpreted (d f) (Uninterpreted x) -> f x - , f x -> Interpreted (d f) (Uninterpreted x) - ) - - default standardInterpretation :: - Coercible (Interpreted (d f) (Uninterpreted x)) (f x) - => Proxy d - -> ( Interpreted (d f) (Uninterpreted x) -> f x - , f x -> Interpreted (d f) (Uninterpreted x) - ) - standardInterpretation _ = (coerce, coerce) - -instance StandardInterpretation DefaultInterpretation f - -toStandardInterpretation :: forall d f x. - StandardInterpretation d f - => Proxy d - -> f x -> Interpret (d f) (Uninterpreted x) -toStandardInterpretation d fx = Interpret $ - snd (standardInterpretation d) fx - -fromStandardInterpretation :: forall d f x. - StandardInterpretation d f - => Proxy d - -> Interpret (d f) (Uninterpreted x) -> f x -fromStandardInterpretation d (Interpret fx) = - fst (standardInterpretation d) fx diff --git a/src/Data/Record/Internal/CodeGen.hs b/src/Data/Record/Internal/CodeGen.hs deleted file mode 100644 --- a/src/Data/Record/Internal/CodeGen.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} - --- | Code generation shared by TH and QQ --- --- Since these can also be used by QQ, these functions cannot take 'Options'. -module Data.Record.Internal.CodeGen ( - -- * Records - recordTypeE - , recordConstrE - , recordTypeT - , recordToVectorE - , recordFromVectorDontForceE - , recordIndexedAccessorE - , recordIndexedOverwriteE - , recordUndefinedValueE - -- * Fields - , fieldNameE - , fieldNameT - , fieldTypeT - , fieldIndexE - , fieldUntypedAccessorE - , fieldUntypedOverwriteE - ) where - -import Language.Haskell.TH - -import Data.Record.Internal.Naming -import Data.Record.Internal.Record -import Data.Record.Internal.TH.Util - -import qualified Data.Record.Internal.TH.Name as N hiding (unqualified) - -{------------------------------------------------------------------------------- - Records --------------------------------------------------------------------------------} - --- | Name of the record as a term-level literal -recordTypeE :: Record a -> Q Exp -recordTypeE = stringE . recordType - --- | Name of the constructor as a term-level literal -recordConstrE :: Record a -> Q Exp -recordConstrE = stringE . recordConstr - --- | The saturated type of the record (that is, with all type vars applied) -recordTypeT :: N.Qualifier -> Record a -> Q Type -recordTypeT qual Record{..} = - appsT (N.conT (N.qualify qual recordType)) $ map tyVarType recordTVars - --- | Coerce the record to the underlying @Vector Any@ -recordToVectorE :: N.Qualifier -> Record a -> Q Exp -recordToVectorE qual = - N.varE . N.qualify qual . nameRecordInternalField . recordType - --- | Construct record from the underlying @Vector Any@ --- --- This doesn't force any elements in the vector, so this can be used if --- --- * the record has lazy fields, or --- * we know through other means that all values are already forced. --- --- See also 'recordFromVectorForceE'. -recordFromVectorDontForceE :: N.Qualifier -> Record a -> Q Exp -recordFromVectorDontForceE qual = - N.conE . N.qualify qual . nameRecordInternalConstr . recordConstr - --- | The (unsafe) indexed field accessor -recordIndexedAccessorE :: N.Qualifier -> Record a -> Q Exp -recordIndexedAccessorE qual = - N.varE . N.qualify qual . nameRecordIndexedAccessor . recordType - --- | The (unsafe) indexed field overwrite -recordIndexedOverwriteE :: N.Qualifier -> Record a -> Q Exp -recordIndexedOverwriteE qual = - N.varE . N.qualify qual . nameRecordIndexedOverwrite . recordType - -recordUndefinedValueE :: N.Qualifier -> Record a -> Q Exp -recordUndefinedValueE qual r = - [| $(recordFromVectorDontForceE qual r) undefined |] - -{------------------------------------------------------------------------------- - Record fields --------------------------------------------------------------------------------} - --- | Name of the field as a term-level literal -fieldNameE :: Field a -> Q Exp -fieldNameE = stringE . fieldName - --- | Name of the field as a type-level literal -fieldNameT :: Field a -> Q Type -fieldNameT = litT . strTyLit . fieldName - --- | Type of the field -fieldTypeT :: Field a -> Q Type -fieldTypeT Field{..} = return fieldType - --- | Index of the field -fieldIndexE :: Field a -> Q Exp -fieldIndexE Field{..} = litE . integerL $ fromIntegral fieldIndex - --- | The indexed field accessor, applied to this field -fieldUntypedAccessorE :: N.Qualifier -> Record a -> Field a -> Q Exp -fieldUntypedAccessorE qual r f = - [| $(recordIndexedAccessorE qual r) $(fieldIndexE f) |] - --- | The indexed field overwrite, applied to this field -fieldUntypedOverwriteE :: N.Qualifier -> Record a -> Field a -> Q Exp -fieldUntypedOverwriteE qual r f = - [| $(recordIndexedOverwriteE qual r) $(fieldIndexE f) |] diff --git a/src/Data/Record/Internal/GHC/Fresh.hs b/src/Data/Record/Internal/GHC/Fresh.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/GHC/Fresh.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Data.Record.Internal.GHC.Fresh ( + MonadFresh(..) + , runFreshHsc + ) where + +import Data.IORef +import Control.Monad.Reader + +import Data.Record.Internal.GHC.Shim + +class Monad m => MonadFresh m where + -- | Construct a fresh name for use in term level expressions + -- + -- 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. + freshName :: LRdrName -> m LRdrName + +newtype Fresh a = WrapFresh { unwrapFresh :: ReaderT (IORef NameCache) IO a } + deriving newtype (Functor, Applicative, Monad) + +instance MonadFresh Fresh where + freshName (L l name) = WrapFresh $ ReaderT $ \nc_var -> + atomicModifyIORef nc_var aux + 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 + +runFresh :: Fresh a -> IORef NameCache -> IO a +runFresh = runReaderT . unwrapFresh + +runFreshHsc :: Fresh a -> Hsc a +runFreshHsc fa = do + env <- getHscEnv + liftIO $ runFresh fa (hsc_NC env) + + diff --git a/src/Data/Record/Internal/GHC/Shim.hs b/src/Data/Record/Internal/GHC/Shim.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/GHC/Shim.hs @@ -0,0 +1,319 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Thin compatibility layer around GHC +-- +-- 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 ( + -- * Miscellaneous + importDecl + , conPat + , mkFunBind + , HsModule + , LHsModule + , LRdrName + , pattern GHC.HsModule + , putLogMsg + + -- * Extensions + , HasDefaultExt(..) + + -- * Generalized @forall@ +#if __GLASGOW_HASKELL__ >= 900 + , HsTyVarBndr + , LHsTyVarBndr +#endif + , hsFunTy + , userTyVar + , kindedTyVar + , hsTyVarLName + , setDefaultSpecificity + + -- * New functionality + , compareHs + , InheritLoc(..) + + -- * Re-exports + + -- The whole-sale module exports are not ideal for preserving compatibility + -- across ghc versions, but we'll deal with this on a case by case basis. +#if __GLASGOW_HASKELL__ < 900 + , module Bag + , module BasicTypes + , module ErrUtils + , module GHC + , module GhcPlugins + , module HscMain + , module NameCache + , module TcEvidence +#else + , module GHC.Data.Bag + , module GHC.Driver.Main + , module GHC.Hs + , module GHC.Plugins + , module GHC.Tc.Types.Evidence + , module GHC.Types.Basic + , module GHC.Types.Name.Cache + , module GHC.Utils.Error +#endif + ) where + +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Generics (Data, GenericQ, cast, toConstr, gzipWithQ) + +import qualified Data.List.NonEmpty as NE + +#if __GLASGOW_HASKELL__ < 900 + +import Bag (listToBag, emptyBag) +import BasicTypes (SourceText(NoSourceText)) +import ConLike (ConLike) +import ErrUtils (mkErrMsg, mkWarnMsg) +import GHC hiding (AnnKeywordId(..), HsModule, exprType, typeKind, mkFunBind) +import GhcPlugins hiding ((<>), getHscEnv, putLogMsg) +import HscMain (getHscEnv) +import NameCache (NameCache(nsUniqs)) +import PatSyn (PatSyn) +import TcEvidence (HsWrapper(WpHole)) + +import qualified GHC +import qualified GhcPlugins as GHC + +#else + +import GHC.Core.Class (Class) +import GHC.Core.ConLike (ConLike) +import GHC.Core.PatSyn (PatSyn) +import GHC.Data.Bag (listToBag, emptyBag) +import GHC.Driver.Main (getHscEnv) +import GHC.Hs hiding (LHsTyVarBndr, HsTyVarBndr, HsModule, mkFunBind) +import GHC.Parser.Annotation (IsUnicodeSyntax(NormalSyntax)) +import GHC.Plugins hiding ((<>), getHscEnv, putLogMsg) +import GHC.Tc.Types.Evidence (HsWrapper(WpHole)) +import GHC.Types.Basic (SourceText(NoSourceText)) +import GHC.Types.Name.Cache (NameCache(nsUniqs)) +import GHC.Utils.Error (Severity(SevError, SevWarning), mkErrMsg, mkWarnMsg) + +import qualified GHC.Hs as GHC +import qualified GHC.Plugins as GHC + +#endif + +{------------------------------------------------------------------------------- + Miscellaneous +-------------------------------------------------------------------------------} + +-- | Optionally @qualified@ import declaration +importDecl :: ModuleName -> Bool -> LImportDecl GhcPs +importDecl name qualified = noLoc $ ImportDecl { + ideclExt = defExt + , ideclSourceSrc = NoSourceText + , ideclName = noLoc name + , ideclPkgQual = Nothing + , ideclSafe = False + , ideclImplicit = False + , ideclAs = Nothing + , ideclHiding = Nothing +#if __GLASGOW_HASKELL__ < 810 + , ideclQualified = qualified +#else + , ideclQualified = if qualified then QualifiedPre else NotQualified +#endif +#if __GLASGOW_HASKELL__ < 900 + , ideclSource = False +#else + , ideclSource = NotBoot +#endif + } + +conPat :: Located RdrName -> HsConPatDetails GhcPs -> Pat GhcPs +#if __GLASGOW_HASKELL__ < 900 +conPat x y = ConPatIn x y +#else +conPat x y = ConPat noExtField x y +#endif + +mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)] -> HsBind GhcPs +#if __GLASGOW_HASKELL__ < 810 +mkFunBind = GHC.mkFunBind +#else +mkFunBind = GHC.mkFunBind Generated +#endif + +#if __GLASGOW_HASKELL__ < 900 +type HsModule = GHC.HsModule GhcPs +#else +type HsModule = GHC.HsModule +#endif + +type LHsModule = Located HsModule +type LRdrName = Located RdrName + +putLogMsg :: DynFlags -> WarnReason -> Severity -> SrcSpan -> SDoc -> IO () +#if __GLASGOW_HASKELL__ < 900 +putLogMsg flags reason sev srcspan = + GHC.putLogMsg flags reason sev srcspan (defaultErrStyle flags) +#else +putLogMsg = GHC.putLogMsg +#endif + +{------------------------------------------------------------------------------- + Extensions +-------------------------------------------------------------------------------} + +class HasDefaultExt a where + defExt :: a + +#if __GLASGOW_HASKELL__ < 810 +instance HasDefaultExt NoExt where + defExt = noExt +#else +instance HasDefaultExt NoExtField where + defExt = noExtField +#endif + +#if __GLASGOW_HASKELL__ >= 900 +instance HasDefaultExt LayoutInfo where + defExt = NoLayoutInfo +#endif + +{------------------------------------------------------------------------------- + Generalized @forall@ in 9.0 +-------------------------------------------------------------------------------} + +#if __GLASGOW_HASKELL__ >= 900 +type HsTyVarBndr pass = GHC.HsTyVarBndr () pass +type LHsTyVarBndr pass = GHC.LHsTyVarBndr () pass +#endif + +hsFunTy :: XFunTy pass -> LHsType pass -> LHsType pass -> HsType pass +#if __GLASGOW_HASKELL__ < 900 +hsFunTy = HsFunTy +#else +hsFunTy ext = HsFunTy ext (HsUnrestrictedArrow NormalSyntax) +#endif + +userTyVar :: + XUserTyVar pass + -> Located (IdP pass) + -> HsTyVarBndr pass +#if __GLASGOW_HASKELL__ < 900 +userTyVar = UserTyVar +#else +userTyVar ext = UserTyVar ext () +#endif + +kindedTyVar :: + XKindedTyVar pass + -> Located (IdP pass) + -> LHsKind pass + -> HsTyVarBndr pass +#if __GLASGOW_HASKELL__ < 900 +kindedTyVar = KindedTyVar +#else +kindedTyVar ext = KindedTyVar ext () +#endif + +-- | Like 'hsTyVarName', but don't throw away the location information +hsTyVarLName :: HsTyVarBndr GhcPs -> LRdrName +#if __GLASGOW_HASKELL__ < 900 +hsTyVarLName (UserTyVar _ n ) = n +hsTyVarLName (KindedTyVar _ n _) = n +hsTyVarLName _ = panic "hsTyVarLName" +#else +hsTyVarLName (UserTyVar _ _ n ) = n +hsTyVarLName (KindedTyVar _ _ n _) = n +#endif + +#if __GLASGOW_HASKELL__ < 900 +setDefaultSpecificity :: LHsTyVarBndr pass -> GHC.LHsTyVarBndr pass +setDefaultSpecificity = id +#else +setDefaultSpecificity :: LHsTyVarBndr pass -> GHC.LHsTyVarBndr Specificity pass +setDefaultSpecificity (L l v) = L l $ case v of + UserTyVar ext () name -> UserTyVar ext SpecifiedSpec name + KindedTyVar ext () name kind -> KindedTyVar ext SpecifiedSpec name kind + XTyVarBndr ext -> XTyVarBndr ext +#endif + +{------------------------------------------------------------------------------- + New functionality +-------------------------------------------------------------------------------} + +-- | Generic comparison for (parts of) the AST +-- +-- NOTE: Not all abstract types are given special treatment here; in particular, +-- types only used in type-checked code ignored. To extend/audit this function, +-- grep the @ghc@ source for @abstractConstr@. Without further extensions, +-- all values of these types are considered equal. +-- +-- NOTE: Although @ghc@ declares the constructor of @Bag@ as abstract as well, +-- we don't actually need a special case here: the constructors will be +-- considered equal, but 'gfoldl' will traverse the /elements/ of the @Bag@ +-- nonetheless, which is precisely what we want. +compareHs' :: GenericQ (GenericQ Bool) +compareHs' x y + | (Just x', Just y') <- (cast x, cast y) = (==) @ConLike x' y' + | (Just x', Just y') <- (cast x, cast y) = (==) @PatSyn x' y' + | (Just x', Just y') <- (cast x, cast y) = (==) @Class x' y' + | (Just x', Just y') <- (cast x, cast y) = (==) @DataCon x' y' + | (Just x', Just y') <- (cast x, cast y) = (==) @FastString x' y' + | (Just x', Just y') <- (cast x, cast y) = (==) @Module x' y' + | (Just x', Just y') <- (cast x, cast y) = (==) @ModuleName x' y' + | (Just x', Just y') <- (cast x, cast y) = (==) @Name x' y' + | (Just x', Just y') <- (cast x, cast y) = (==) @OccName x' y' + | (Just x', Just y') <- (cast x, cast y) = (==) @TyCon x' y' + | (Just x', Just y') <- (cast x, cast y) = (==) @UnitId x' y' + | (Just x', Just y') <- (cast x, cast y) = (==) @Var x' y' +#if __GLASGOW_HASKELL__ >= 900 + | (Just x', Just y') <- (cast x, cast y) = (==) @Unit x' y' +#endif + | (Just x', Just y') <- (cast x, cast y) = ignr @RealSrcSpan x' y' + | (Just x', Just y') <- (cast x, cast y) = ignr @SrcSpan x' y' + | otherwise = (toConstr x == toConstr y) + && and (gzipWithQ compareHs' x y) + where + ignr :: a -> a -> Bool + ignr _ _ = True + +-- | Compare two (parts) of a Haskell source tree for equality +-- +-- The trees are compared for literal equality, but 'SrcSpan's are ignored. +compareHs :: Data a => a -> a -> Bool +compareHs x y = compareHs' x y + +{------------------------------------------------------------------------------- + Working with locations +-------------------------------------------------------------------------------} + +class InheritLoc a b lb | lb -> b where + inheritLoc :: a -> b -> lb + +instance InheritLoc (Located a) b (Located b) where + inheritLoc (L l _) = L l + +instance InheritLoc a b lb => InheritLoc (NonEmpty a) b lb where + inheritLoc = inheritLoc . 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 InheritLoc a b (Located b) => InheritLoc [a] b (Located b) where + inheritLoc (a:_) = inheritLoc a + inheritLoc [] = noLoc + +#if __GLASGOW_HASKELL__ < 810 +-- In 8.8, 'LPat' is a synonym for 'Pat' +instance InheritLoc a (Pat p) (LPat p) where + inheritLoc _ = id +#endif diff --git a/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs b/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs @@ -0,0 +1,778 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Interface to the GHC API that closely mimicks Template Haskell +-- +-- See "Language.Haskell.TH.Lib". +-- +-- This module is intended to be CPP-free, with all CPP confined to +-- "Data.Record.Plugin.GHC.Shim". The only exception to this is the redundant +-- pattern matches that we need for the poor extension design in ghc 9.0; I've +-- not yet found a nice way to shim this. +module Data.Record.Internal.GHC.TemplateHaskellStyle ( + -- * Names + nameBase + , mkExpVar + , mkTyVar + , mkTyCon + , pattern ExpVar + , pattern TyVar + , pattern TyCon + -- * Expressions + , litE + , stringE + , pattern VarE + , pattern ConE + , recConE + , pattern RecUpdE + , appE + , listE + , lamE + , lamE1 + , caseE + , appsE + , tupE + , sigE + -- ** Without direct equivalent + , intE + -- * Types + , litT + , pattern VarT + , pattern ConT + , appT + , listT + -- ** Without direct equivalent + , stringT + , appsT + , funT + , tupT + -- * Patterns + , varP + , conP + , bangP + , listP + , wildP + -- * Strictness + , bangType + -- * Class contexts + , equalP + -- * Constructors + , pattern RecC + , forallRecC + -- * Type variable binders + , kindedTV + -- ** Without direct equivalent + , tyVarBndrName + -- * Top-level declarations + , sigD + , valD + , pattern DataD + , pattern DerivClause + , instanceD + , classD + , tySynEqn + -- * Pragmas + , pattern TypeAnnotation + , pattern PragAnnD + + -- * Re-exported types (intentionally without constructors) + -- + -- We intentionally: + -- + -- o Do not export constructors (unless otherwise indicated): the functions + -- in this module are replacements for those constructors. + -- o Only export the located versions of these types: we should try to + -- minimize location loss when generating code, for better errors. + , AnnDecl + , DerivStrategy(..) -- Exported with constructors, is similar enough to TH + , GhcPs + , HsLit + , HsTyLit + , LConDecl + , LDerivStrategy + , LHsDecl + , LHsDerivingClause + , LHsExpr + , LHsType + , LHsTyVarBndr + , LPat + , LTyFamInstDecl + , LRdrName + ) where + +import Data.List (foldl') + +import Data.Record.Internal.GHC.Shim hiding (mkTyVar) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NE + +{------------------------------------------------------------------------------- + Internal auxiliary: types of names +-------------------------------------------------------------------------------} + +isTermVar, isTermCon, isTypeVar, isTypeCon :: LRdrName -> Bool +isTermVar = checkNameType isVarOcc +isTermCon = checkNameType isDataOcc +isTypeVar = checkNameType isTvOcc +isTypeCon = checkNameType isTcOcc + +checkNameType :: (OccName -> Bool) -> LRdrName -> Bool +checkNameType f (L _ n) = f (rdrNameOcc n) + +{------------------------------------------------------------------------------- + Names +-------------------------------------------------------------------------------} + +-- | Equivalent of 'Language.Haskell.TH.Syntax.nameBase' +nameBase :: LRdrName -> String +nameBase = occNameString . rdrNameOcc . unLoc + +-- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for expression vars +mkExpVar :: SrcSpan -> String -> LRdrName +mkExpVar l = L l . mkRdrUnqual . mkVarOcc + +-- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for type vars +mkTyVar :: SrcSpan -> String -> LRdrName +mkTyVar l = L l . mkRdrUnqual . mkTyVarOcc + +-- | Equivalent of 'Language.Haskell.TH.Syntax.mkName', for type constructors +mkTyCon :: SrcSpan -> String -> LRdrName +mkTyCon l = L l . mkRdrUnqual . mkTcOcc + +-- | Inverse to 'mkExpVar' +-- +-- NOTE: Defined in terms of 'nameBase', so discards qualifiers. +viewExpVar :: LRdrName -> Maybe String +viewExpVar n | isTermVar n = Just (nameBase n) +viewExpVar _otherwise = Nothing + +-- | Inverse to 'mkTyVar' +-- +-- NOTE: Defined in terms of 'nameBase', so discards qualifiers. +viewTyVar :: LRdrName -> Maybe String +viewTyVar n | isTypeVar n = Just (nameBase n) +viewTyVar _otherwise = Nothing + +-- | Inverse to 'mkTyCon' +viewTyCon :: LRdrName -> Maybe String +viewTyCon n | isTypeCon n = Just (nameBase n) +viewTyCon _otherwise = Nothing + +-- This patterns are not bidirectional: to construct a LRdrName, we need a +-- location. We may want to change this somehow. Use a Located String? + +pattern ExpVar :: String -> LRdrName +pattern ExpVar n <- (viewExpVar -> Just n) + +pattern TyVar :: String -> LRdrName +pattern TyVar n <- (viewTyVar -> Just n) + +pattern TyCon :: String -> LRdrName +pattern TyCon n <- (viewTyCon -> Just n) + +{------------------------------------------------------------------------------- + Expressions +-------------------------------------------------------------------------------} + +-- | Equivalent of 'Language.Haskell.TH.Lib.varE' +varE :: HasCallStack => LRdrName -> LHsExpr GhcPs +varE name + | isTermVar name = inheritLoc name $ HsVar defExt name + | otherwise = error "varE: incorrect name type" + +-- | Inverse to 'varE' +viewVarE :: LHsExpr GhcPs -> Maybe LRdrName +viewVarE (L _ (HsVar _ name)) | isTermVar name = Just name +viewVarE _ = Nothing + +pattern VarE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs +pattern VarE name <- (viewVarE -> Just name) + where + VarE = varE + +-- | Equivalent of 'Language.Haskell.TH.Lib.conE' +conE :: HasCallStack => LRdrName -> LHsExpr GhcPs +conE name + | isTermCon name = inheritLoc name $ HsVar defExt name + | otherwise = error "conE: incorrect name type" + +-- | Inverse to 'conE' +viewConE :: LHsExpr GhcPs -> Maybe LRdrName +viewConE (L _ (HsVar _ name)) | isTermCon name = Just name +viewConE _ = Nothing + +pattern ConE :: HasCallStack => () => LRdrName -> LHsExpr GhcPs +pattern ConE name <- (viewConE -> Just name) + where + ConE = conE + +-- | Equivalent of 'Language.Haskell.TH.Lib.litE' +litE :: HsLit GhcPs -> LHsExpr GhcPs +litE = noLoc . HsLit defExt + +-- | Equivalent of 'Language.Haskell.TH.Lib.stringE' +stringE :: String -> LHsExpr GhcPs +stringE = litE . HsString NoSourceText . fsLit + +-- | Equivalent of 'Language.Haskell.TH.Lib.recConE' +recConE :: LRdrName -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs +recConE = \recName -> mkRec recName . map (uncurry mkFld) + where + mkRec :: LRdrName -> [LHsRecField GhcPs (LHsExpr GhcPs)] -> LHsExpr GhcPs + mkRec name fields = inheritLoc name $ + RecordCon defExt name (HsRecFields fields Nothing) + + mkFld :: LRdrName -> LHsExpr GhcPs -> LHsRecField GhcPs (LHsExpr GhcPs) + mkFld name val = inheritLoc name $ + HsRecField (inheritLoc name (mkFieldOcc name)) val False + +-- | Equivalent of 'Language.Haskell.TH.Lib.recUpdE' +recUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs +recUpdE = \recExpr -> updRec recExpr . map (uncurry updFld) + where + updRec :: LHsExpr GhcPs -> [LHsRecUpdField GhcPs] -> LHsExpr GhcPs + updRec expr fields = inheritLoc expr $ + RecordUpd defExt expr fields + + updFld :: LRdrName -> LHsExpr GhcPs -> LHsRecUpdField GhcPs + updFld name val = inheritLoc name $ + HsRecField (inheritLoc name (mkAmbiguousFieldOcc name)) val False + +viewRecUpdE :: + LHsExpr GhcPs + -> Maybe (LHsExpr GhcPs, [(LRdrName, LHsExpr GhcPs)]) +viewRecUpdE (L _ (RecordUpd _ recExpr fields)) = + (recExpr,) <$> mapM viewFieldUpd fields + where + viewFieldUpd :: LHsRecUpdField GhcPs -> Maybe (LRdrName, LHsExpr GhcPs) + viewFieldUpd (L _ (HsRecField (L _ (Unambiguous _ name)) val False)) = + Just (name, val) + viewFieldUpd _otherwise = + Nothing +viewRecUpdE _otherwise = Nothing + +pattern RecUpdE :: LHsExpr GhcPs -> [(LRdrName, LHsExpr GhcPs)] -> LHsExpr GhcPs +pattern RecUpdE recExpr fields <- (viewRecUpdE -> Just (recExpr, fields)) + where + RecUpdE = recUpdE + +-- | Equivalent of 'Language.Haskell.TH.Lib.appE' +appE :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +appE a b = mkHsApp a b + +-- | Equivalent of 'Language.Haskell.TH.Lib.listE' +listE :: [LHsExpr GhcPs] -> LHsExpr GhcPs +listE es = inheritLoc es $ ExplicitList defExt Nothing es + +-- | Equivalent of 'Language.Haskell.TH.Lib.lamE' +lamE :: NonEmpty (LPat GhcPs) -> LHsExpr GhcPs -> LHsExpr GhcPs +lamE pats body = inheritLoc body $ + HsLam defExt $ + MG defExt (inheritLoc body [inheritLoc body match]) Generated + where + match :: Match GhcPs (LHsExpr GhcPs) + match = Match defExt LambdaExpr (NE.toList pats) (simpleGHRSs body) + +-- | Convenience wrapper around 'lamE' for a single argument +lamE1 :: LPat GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs +lamE1 p = lamE (p :| []) + +-- | Equivalent of 'Language.Haskell.TH.Lib.caseE' +caseE :: LHsExpr GhcPs -> [(LPat GhcPs, LHsExpr GhcPs)] -> LHsExpr GhcPs +caseE x alts = inheritLoc x $ + HsCase defExt x (MG defExt (inheritLoc x (map mkAlt alts)) Generated) + where + mkAlt :: (LPat GhcPs, LHsExpr GhcPs) -> LMatch GhcPs (LHsExpr GhcPs) + mkAlt (pat, body) = inheritLoc x $ + Match defExt CaseAlt [pat] (simpleGHRSs body) + +-- | Equivalent of 'Language.Haskell.TH.Lib.appsE' +appsE :: LHsExpr GhcPs -> [LHsExpr GhcPs] -> LHsExpr GhcPs +appsE = foldl' appE + +-- | 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] + Boxed + +-- | Equivalent of 'Language.Haskell.TH.Lib.sigE' +sigE :: LHsExpr GhcPs -> LHsType GhcPs -> LHsExpr GhcPs +sigE expr ty = inheritLoc expr $ + ExprWithTySig defExt expr (HsWC defExt (implicitBndrs ty)) + +{------------------------------------------------------------------------------- + .. without direct equivalent +-------------------------------------------------------------------------------} + +-- | By analogy with 'stringE' +intE :: Integral a => a -> LHsExpr GhcPs +intE = litE . HsInt defExt . mkIntegralLit + +{------------------------------------------------------------------------------- + Types +-------------------------------------------------------------------------------} + +-- | Equivalent of 'Language.Haskell.TH.Lib.litT' +litT :: HsTyLit -> LHsType GhcPs +litT = noLoc . HsTyLit defExt + +-- | Equivalent of 'Language.Haskell.TH.Lib.varT' +varT :: HasCallStack => LRdrName -> LHsType GhcPs +varT name + | isTypeVar name = inheritLoc name (HsTyVar defExt NotPromoted name) + | otherwise = error "varT: incorrect name type" + +-- | Inverse to 'varT' +viewVarT :: LHsType GhcPs -> Maybe LRdrName +viewVarT (L _ (HsTyVar _ _ name)) | isTypeVar name = Just name +viewVarT _otherwise = Nothing + +pattern VarT :: HasCallStack => () => LRdrName -> LHsType GhcPs +pattern VarT name <- (viewVarT -> Just name) + where + VarT = varT + +-- | Equivalent of 'Language.Haskell.TH.Lib.conT' +conT :: HasCallStack => LRdrName -> LHsType GhcPs +conT name + | isTypeCon name = inheritLoc name (HsTyVar defExt NotPromoted name) + | otherwise = error "varT: incorrect name type" + +-- | Inverse to 'conT' +viewConT :: LHsType GhcPs -> Maybe LRdrName +viewConT (L _ (HsTyVar _ _ name)) | isTypeCon name = Just name +viewConT _otherwise = Nothing + +pattern ConT :: HasCallStack => () => LRdrName -> LHsType GhcPs +pattern ConT name <- (viewConT -> Just name) + where + ConT = conT + +-- | Equivalent of 'Language.Haskell.TH.Lib.appT' +appT :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs +appT = mkHsAppTy + +-- | Equivalent of 'Language.Haskell.TH.Lib.listT' +-- +-- Signature by analogy with 'Language.Haskell.TH.Lib.listE'. +listT :: [LHsType GhcPs] -> LHsType GhcPs +listT ts = inheritLoc ts $ HsExplicitListTy defExt IsPromoted ts + +{------------------------------------------------------------------------------- + .. without direct equivalent +-------------------------------------------------------------------------------} + +-- | By analogy with 'stringE' +stringT :: String -> LHsType GhcPs +stringT = litT . HsStrTy NoSourceText . fsLit + +-- | By analogy with 'appsE' +appsT :: LHsType GhcPs -> [LHsType GhcPs] -> LHsType GhcPs +appsT = foldl' appT + +-- | Function type +-- +-- TH only provides 'Language.Haskell.TH.Lib.arrowT'. +funT :: LHsType GhcPs -> LHsType GhcPs -> LHsType GhcPs +funT a b = inheritLoc a (hsFunTy defExt a b) + +-- | Tuple type +-- +-- TH only provides 'Language.Haskell.TH.Lib.tupleT'. +-- Signature by analogy with 'tupE'. +tupT :: NonEmpty (LHsType GhcPs) -> LHsType GhcPs +tupT ts = inheritLoc ts $ HsExplicitTupleTy defExt (NE.toList ts) + +{------------------------------------------------------------------------------- + Patterns +-------------------------------------------------------------------------------} + +-- | Equivalent of 'Language.Haskell.TH.Lib.varP' +varP :: LRdrName -> LPat GhcPs +varP name = inheritLoc name (VarPat defExt name) + +-- | Equivalent of 'Language.Haskell.TH.Lib.conP' +conP :: LRdrName -> [LPat GhcPs] -> LPat GhcPs +conP con args = inheritLoc con (conPat con (PrefixCon args)) + +-- | Equivalent of 'Language.Haskell.TH.Lib.bangP' +bangP :: LPat GhcPs -> LPat GhcPs +bangP p = inheritLoc p $ BangPat defExt p + +-- | Equivalent of 'Language.Haskell.TH.Lib.listP' +listP :: [LPat GhcPs] -> LPat GhcPs +listP xs = inheritLoc xs $ ListPat defExt xs + +-- | Equivalent of 'Language.Haskell.TH.Lib.wildP' +wildP :: LPat GhcPs +wildP = noLoc (WildPat defExt) + +{------------------------------------------------------------------------------- + Strictness +-------------------------------------------------------------------------------} + +-- | Approximate equivalent of 'Language.Haskell.TH.Lib.bangType' +-- +-- The GHC API has no equivalent of 'Language.Haskell.TH.Syntax.BangType'. +bangType :: LHsType GhcPs -> LHsType GhcPs +bangType t = inheritLoc t $ + HsBangTy defExt (HsSrcBang NoSourceText NoSrcUnpack SrcStrict) t + +{------------------------------------------------------------------------------- + Class contexts +-------------------------------------------------------------------------------} + +-- | 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 + +{------------------------------------------------------------------------------- + Constructors +-------------------------------------------------------------------------------} + +-- | Equivalent of 'Language.Haskell.TH.Lib.rec' +-- +-- NOTE: The GHC AST (but not TH) supports declaring multiple record fields +-- with the same type. We do not support this here (since we follow TH). +recC :: LRdrName -> [(LRdrName, LHsType GhcPs)] -> LConDecl GhcPs +recC = forallRecC [] [] + +-- | Inverse to 'recC' +viewRecC :: LConDecl GhcPs -> Maybe (LRdrName, [(LRdrName, LHsType GhcPs)]) +viewRecC + (L _ + ConDeclH98 { + con_name = conName + , con_forall = L _ False + , con_ex_tvs = [] + , con_mb_cxt = Nothing + , con_args = RecCon (L _ fields) + } + ) = (conName,) <$> mapM viewRecField fields + where + viewRecField :: LConDeclField GhcPs -> Maybe (LRdrName, LHsType GhcPs) + viewRecField + (L _ + ConDeclField { + cd_fld_names = [L _ fieldName] + , cd_fld_type = ty + } + ) = Just $ (viewFieldOcc fieldName, ty) + viewRecField _otherwise = Nothing + + viewFieldOcc :: FieldOcc GhcPs -> LRdrName + viewFieldOcc (FieldOcc _ name) = name +#if __GLASGOW_HASKELL__ < 900 + viewFieldOcc _ = panic "viewFieldOcc" +#endif +viewRecC _otherwise = Nothing + +pattern RecC :: LRdrName -> [(LRdrName, LHsType GhcPs)] -> LConDecl GhcPs +pattern RecC conName args <- (viewRecC -> Just (conName, args)) + where + RecC = recC + +-- | Equivalent of the combination of 'Language.Haskell.TH.Lib.forallC' and +-- 'Language.Haskell.TH.Lib.recC'. +forallRecC :: + [LRdrName] -- ^ @forallC@ argument: bound type variables + -> [LHsType GhcPs] -- ^ @forallC@ argument: context + -> LRdrName -- ^ @recC@ argument: record constructor name + -> [(LRdrName, LHsType GhcPs)] -- ^ @recC@ argument: record fields + -> LConDecl GhcPs +forallRecC vars ctxt conName args = inheritLoc conName $ ConDeclH98 { + con_ext = defExt + , con_name = conName + , 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) + , con_doc = Nothing + } + where + mkBndr :: LRdrName -> LHsTyVarBndr GhcPs + mkBndr name = inheritLoc name $ userTyVar defExt name + + mkRecField :: LRdrName -> LHsType GhcPs -> LConDeclField GhcPs + mkRecField name ty = inheritLoc name $ ConDeclField { + cd_fld_ext = defExt + , cd_fld_names = [inheritLoc name $ mkFieldOcc name] + , cd_fld_type = ty + , cd_fld_doc = Nothing + } + +{------------------------------------------------------------------------------- + Type variable binders +-------------------------------------------------------------------------------} + +-- | Equivalent of 'Language.Haskell.TH.Lib.kindedTV' +kindedTV :: LRdrName -> LHsType GhcPs -> LHsTyVarBndr GhcPs +kindedTV name ty = inheritLoc name (kindedTyVar defExt name ty) + +{------------------------------------------------------------------------------- + .. without direct equivalent +-------------------------------------------------------------------------------} + +tyVarBndrName :: LHsTyVarBndr GhcPs -> LRdrName +tyVarBndrName = hsTyVarLName . unLoc + +{------------------------------------------------------------------------------- + Top-level declarations +-------------------------------------------------------------------------------} + +-- | Equivalent of 'Language.Haskell.TH.Lib.sigD' +sigD :: LRdrName -> LHsType GhcPs -> LHsDecl GhcPs +sigD name ty = inheritLoc name $ SigD defExt sig + where + sig :: Sig GhcPs + sig = TypeSig defExt [name] $ HsWC defExt (implicitBndrs ty) + +-- | Equivalent of 'Language.Haskell.TH.Lib.valD' +-- +-- Currently this offers a simplified API only. +valD :: LRdrName -> LHsExpr GhcPs -> LHsDecl GhcPs +valD fnName body = inheritLoc fnName $ + ValD defExt (unLoc (simpleBinding fnName body)) + +-- | Equivalent of 'Language.Haskell.TH.Lib.dataD' +dataD :: + LRdrName -- ^ Datatype name + -> [LHsTyVarBndr GhcPs] -- ^ Type arguments + -> [LConDecl GhcPs] -- ^ Constructors + -> [LHsDerivingClause GhcPs] -- ^ Deriving clauses + -> LHsDecl GhcPs +dataD typeName tyVars cons derivs = inheritLoc typeName $ + TyClD defExt $ DataDecl { + tcdDExt = defExt + , tcdLName = typeName + , tcdTyVars = mkHsQTvs tyVars + , tcdFixity = Prefix + , tcdDataDefn = HsDataDefn { + dd_ext = defExt + , dd_ND = DataType + , dd_ctxt = inheritLoc typeName [] + , dd_cType = Nothing + , dd_kindSig = Nothing + , dd_cons = cons + , dd_derivs = inheritLoc typeName derivs + } + } + +-- | Inverse to 'dataD' +viewDataD :: + LHsDecl GhcPs + -> Maybe ( + LRdrName + , [LHsTyVarBndr GhcPs] + , [LConDecl GhcPs] + , [LHsDerivingClause GhcPs] + ) +viewDataD + (L _ + (TyClD + _ + DataDecl { + tcdLName = typeName + , tcdTyVars = HsQTvs {hsq_explicit = tyVars} + , tcdFixity = Prefix + , tcdDataDefn = HsDataDefn { + dd_ND = DataType + , dd_ctxt = L _ [] + , dd_cType = Nothing + , dd_kindSig = Nothing + , dd_cons = cons + , dd_derivs = L _ derivs + } + } + ) + ) = Just (typeName, tyVars, cons, derivs) +viewDataD _otherwise = Nothing + +pattern DataD :: + LRdrName + -> [LHsTyVarBndr GhcPs] + -> [LConDecl GhcPs] + -> [LHsDerivingClause GhcPs] + -> LHsDecl GhcPs +pattern DataD typeName tyVars cons derivs <- + (viewDataD -> Just (typeName, tyVars, cons, derivs)) + where + DataD = dataD + +-- | Equivalent of 'Language.Haskell.TH.derivClaus' +derivClause :: + Maybe (LDerivStrategy GhcPs) + -> NonEmpty (LHsType GhcPs) + -> LHsDerivingClause GhcPs +derivClause strat tys = inheritLoc tys $ + HsDerivingClause defExt strat $ + inheritLoc tys $ map implicitBndrs (NE.toList tys) + +-- | Inverse of 'derivClause' +viewDerivClause :: + LHsDerivingClause GhcPs + -> (Maybe (LDerivStrategy GhcPs), [LHsType GhcPs]) +viewDerivClause (L _ (HsDerivingClause _ mStrat (L _ tys))) = + (mStrat, map viewImplicitBndrs tys) +#if __GLASGOW_HASKELL__ < 900 +viewDerivClause _ = panic "viewDerivClause" +#endif + +pattern DerivClause :: + Maybe (LDerivStrategy GhcPs) + -> NonEmpty (LHsType GhcPs) + -> LHsDerivingClause GhcPs +pattern DerivClause strat tys <- + (viewDerivClause -> (strat, NE.nonEmpty -> Just tys)) + where + DerivClause = derivClause + +-- | Equivalent of 'Language.Haskell.TH.Lib.instanceD' +-- +-- Unlike in TH, the regular bindings and associated types are separate args. +instanceD :: + [LHsType GhcPs] -- ^ Context + -> LHsType GhcPs -- ^ Head + -> [(LRdrName, LHsExpr GhcPs)] -- ^ Bindings + -> [LTyFamInstDecl GhcPs] -- ^ Associated types + -> LHsDecl GhcPs +instanceD ctxt hd binds assocTypes = inheritLoc hd $ + InstD defExt $ ClsInstD defExt $ ClsInstDecl { + cid_ext = defExt + , cid_poly_ty = implicitBndrs (qualT ctxt hd) + , cid_binds = listToBag $ map (uncurry simpleBinding) binds + , cid_sigs = [] + , cid_tyfam_insts = assocTypes + , cid_datafam_insts = [] + , cid_overlap_mode = Nothing + } + where + qualT :: [LHsType GhcPs] -> LHsType GhcPs -> LHsType GhcPs + qualT [] a = a + qualT ctx@(c:_) a = inheritLoc c $ + HsQualTy defExt (inheritLoc c ctx) a + +-- | Equivalent of 'Language.Haskell.TH.Lib.classD' +classD :: + [LHsType GhcPs] -- ^ Class context + -> LRdrName -- ^ Class name + -> [LHsTyVarBndr GhcPs] -- ^ Type variables + -> [(LRdrName, LHsType GhcPs)] -- ^ Method signatures + -> LHsDecl GhcPs +classD = \ctx name clsVars sigs -> inheritLoc name $ + TyClD defExt $ ClassDecl { + tcdCExt = defExt + , tcdCtxt = inheritLoc name ctx + , tcdLName = name + , tcdTyVars = mkHsQTvs clsVars + , tcdFixity = Prefix + , tcdFDs = [] + , tcdSigs = map (uncurry classOpSig) sigs + , tcdMeths = emptyBag + , tcdATs = [] + , tcdATDefs = [] + , tcdDocs = [] + } + where + classOpSig :: LRdrName -> LHsType GhcPs -> LSig GhcPs + classOpSig name ty = inheritLoc name $ + ClassOpSig defExt False [name] (implicitBndrs ty) + +-- | Approximate equivalent of 'Language.Haskell.TH.Lib.tySynEqn' +tySynEqn :: + LRdrName -- ^ Type family name + -> [LHsType GhcPs] -- ^ Equation LHS + -> LHsType GhcPs -- ^ Equation RHS + -> LTyFamInstDecl GhcPs +tySynEqn name pats val = inheritLoc val $ + TyFamInstDecl $ + implicitBndrs $ + FamEqn defExt + name + Nothing + (map HsValArg pats) + Prefix + val + +{------------------------------------------------------------------------------- + Pragmas + + NOTE: We work with 'LRdrName' everywhere, but 'AnnProvenance' /already/ wraps + the @name@ type in @Located@. +-------------------------------------------------------------------------------} + +-- | Equivalent of 'Language.Haskell.TH.Lib.typeAnnotation' +typeAnnotation :: LRdrName -> AnnProvenance RdrName +typeAnnotation name = TypeAnnProvenance name + +-- | Inverse to 'typeAnnotation' +viewTypeAnnotation :: AnnProvenance RdrName -> Maybe LRdrName +viewTypeAnnotation (TypeAnnProvenance name) = Just name +viewTypeAnnotation _otherwise = Nothing + +pattern TypeAnnotation :: LRdrName -> AnnProvenance RdrName +pattern TypeAnnotation name <- (viewTypeAnnotation -> Just name) + where + TypeAnnotation = typeAnnotation + +-- | Equivalent of 'Language.Haskell.TH.Lib.pragAnnD' +pragAnnD :: AnnProvenance RdrName -> LHsExpr GhcPs -> AnnDecl GhcPs +pragAnnD prov value = + HsAnnotation + defExt + NoSourceText + prov + value + +viewPragAnnD :: AnnDecl GhcPs -> (AnnProvenance RdrName, LHsExpr GhcPs) +viewPragAnnD (HsAnnotation _ _ prov value) = (prov, value) +#if __GLASGOW_HASKELL__ < 900 +viewPragAnnD _ = panic "viewPragAnnD" +#endif + +pattern PragAnnD :: AnnProvenance RdrName -> LHsExpr GhcPs -> AnnDecl GhcPs +pattern PragAnnD prov value <- (viewPragAnnD -> (prov, value)) + where + PragAnnD = pragAnnD + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +implicitBndrs :: a -> HsImplicitBndrs GhcPs a +implicitBndrs a = HsIB defExt a + +viewImplicitBndrs :: HsImplicitBndrs GhcPs a -> a +viewImplicitBndrs (HsIB _ a) = a +#if __GLASGOW_HASKELL__ < 900 +viewImplicitBndrs _ = panic "viewImplicitBndrs" +#endif + +-- | Simple binding (without patterns) +simpleBinding :: LRdrName -> LHsExpr GhcPs -> LHsBind GhcPs +simpleBinding fnName body = inheritLoc fnName $ + mkFunBind fnName [match] + where + grhs :: GRHSs GhcPs (LHsExpr GhcPs) + grhs = simpleGHRSs body + + match :: LMatch GhcPs (LHsExpr GhcPs) + match = inheritLoc fnName $ + Match defExt + (FunRhs fnName Prefix NoSrcStrict) + [] + grhs + +-- | Simple guarded RHS (no guards) +simpleGHRSs :: LHsExpr GhcPs -> GRHSs GhcPs (LHsExpr GhcPs) +simpleGHRSs body = + GRHSs defExt + [inheritLoc body $ GRHS defExt [] body] + (inheritLoc body $ EmptyLocalBinds defExt) + + diff --git a/src/Data/Record/Internal/Naming.hs b/src/Data/Record/Internal/Naming.hs deleted file mode 100644 --- a/src/Data/Record/Internal/Naming.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} - --- | Names of the various things we generate --- --- This is used by both TH code generation and the quasi-quoter. -module Data.Record.Internal.Naming ( - -- * Names based on the constructor - nameRecordInternalConstr - , nameRecordTypedConstructorFn - -- * Names based on the type - , nameRecordConstraintsClass - , nameRecordConstraintsMethod - , nameRecordIndexedAccessor - , nameRecordIndexedOverwrite - , nameRecordInternalField - , nameRecordView - ) where - -{------------------------------------------------------------------------------- - Names based on the constructor --------------------------------------------------------------------------------} - --- | The name of the constructor used internally --- --- We must pick this so that --- --- 1. It is different from the user-written constructor (so that we can use that --- name for the pattern synonym, /if/ we generate it) --- --- 2. It is derivable /from/ the user-written constructor, so that in, say, --- --- > [lr| MkR { x = 5, y = True } |] --- --- the quasi-quoter can figure out the name of the internal constructor --- (provided that the constructor is in scope, but that's a reasonable --- requirement). -nameRecordInternalConstr :: String -> String -nameRecordInternalConstr = ("LR__" ++) - --- | Name of the record constructor function --- --- Unlike the internal constructor (which takes a @Vector Any@ as argument), --- this function takes @n@ arguments, one for each record field, of the --- appropriate types. -nameRecordTypedConstructorFn :: String -> String -nameRecordTypedConstructorFn = ("_construct_" ++) - -{------------------------------------------------------------------------------- - Names based on the type --------------------------------------------------------------------------------} - -nameRecordConstraintsClass :: String -> String -nameRecordConstraintsMethod :: String -> String -nameRecordIndexedAccessor :: String -> String -nameRecordIndexedOverwrite :: String -> String -nameRecordInternalField :: String -> String -nameRecordView :: String -> String - -nameRecordConstraintsClass = ("Constraints_" ++) -nameRecordConstraintsMethod = ("dictConstraints_" ++) -nameRecordIndexedAccessor = ("unsafeGetIndex" ++) -nameRecordIndexedOverwrite = ("unsafeSetIndex" ++) -nameRecordInternalField = ("vectorFrom" ++) -nameRecordView = ("tupleFrom" ++) diff --git a/src/Data/Record/Internal/Plugin/CodeGen.hs b/src/Data/Record/Internal/Plugin/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Plugin/CodeGen.hs @@ -0,0 +1,677 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The core of the plugin implementation. +module Data.Record.Internal.Plugin.CodeGen (genLargeRecord) where + +import Data.List (nubBy) +import Data.List.NonEmpty (NonEmpty(..)) + +import qualified Data.Generics as SYB + +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.Options +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 -> m [LHsDecl GhcPs] +genLargeRecord r@Record{..} = concatM [ + (:[]) <$> genDatatype r + , genVectorConversions r + , genIndexedAccessor r + , genUnsafeSetIndex r + , genStockInstances r + , mapM (genHasFieldInstance r) recordFields + , sequence [ + genConstraintsClass r + , genConstraintsInstance r + , genGenericInstance r + , genGHCGeneric r + ] + ] + +{------------------------------------------------------------------------------- + The type itself and conversion to and from vectors + + NOTE: All generation exampleshask assume as example + + > data T a b = MkT { + > tWord :: Word + > , tBool :: Bool + > , tChar :: Char + > , tA :: a + > , tListB :: [b] + > } + > deriving (Eq, Show) +-------------------------------------------------------------------------------} + +-- | Generate the datatype that will represent the record +-- +-- Currently this generates something like +-- +-- > data T a b = +-- > forall f0 f1 f2 f3 f4. ( +-- > f0 ~ Word +-- > , f1 ~ Bool +-- > , f2 ~ Char +-- > , f3 ~ a +-- > , f4 ~ [b] +-- > ) +-- > => MkT { +-- > tInt :: f0 +-- > , tBool :: f1 +-- > , tChar :: f2 +-- > , tA :: f3 +-- > , tListB :: f4 +-- > } +-- > deriving anyclass C -- where applicable +-- +-- (possibly with strict fields). This representation accomplishes two things: +-- +-- 1. The use of the existentials with type equalities prevents ghc from +-- generating field accessors. +-- 2. It can still be used in the normal way to construct record values and +-- to pattern match on records. +-- +-- TODO: From ghc 9.2 and up, we should generate +-- +-- > newtype T a b = TFromVector {vectorFromT :: Vector Any} +-- > deriving anyclass C -- where applicable +-- +-- instead, along with a pattern synonym. +genDatatype :: MonadFresh m => Record -> m (LHsDecl GhcPs) +genDatatype Record{..} = pure $ + DataD + recordTyName + recordTyVars + [ forallRecC + vars + (zipWith fieldContext vars recordFields) + recordConName + (zipWith fieldExistentialType vars recordFields) + + ] + [ DerivClause (Just (noLoc AnyclassStrategy)) (c :| []) + | DeriveAnyClass c <- recordDerivings + ] + where + -- There is no need to generate fresh va riables here, as these type vars + -- cannot clash with anything else (no other type vars can be in scope). + vars :: [LRdrName] + vars = [ + mkTyVar recordAnnLoc ("lr_f" <> show i) + | (i, _) <- zip [1 :: Int ..] recordFields + ] + + optionalBang :: LHsType GhcPs -> LHsType GhcPs + optionalBang = if allFieldsStrict recordOptions then bangType else id + + fieldContext :: LRdrName -> Field -> LHsType GhcPs + fieldContext var fld = equalP (VarT var) (fieldType fld) + + fieldExistentialType :: LRdrName -> Field -> (LRdrName, LHsType GhcPs) + fieldExistentialType var fld = (fieldName fld, optionalBang $ VarT var) + +-- | Generate conversion to and from vector +-- +-- Generates something like +-- +-- > vectorFromT :: T a b -> Vector Any +-- > vectorFromT = \x -> +-- > case x of +-- > MkT f0 f1 f2 f3 f4 -> V.fromList [ +-- > unsafeCoerce f0 +-- > , unsafeCoerce f1 +-- > , unsafeCoerce f2 +-- > , unsafeCoerce f3 +-- > , unsafeCoerce f4 +-- > ] +-- > +-- > vectorToT :: Vector Any -> T a b +-- > vectorToT = \x -> +-- > case V.toList x of +-- > [f0, f1, f2, f3, f4] -> +-- > MkT (unsafeCoerce f0) +-- > (unsafeCoerce f1) +-- > (unsafeCoerce f2) +-- > (unsafeCoerce f3) +-- > (unsafeCoerce f4) +-- > _ -> error "Pattern match failure in vectorToT: vector with invalid number of elements." +-- +-- 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 [ + fromVector + , toVector + ] + where + fromVector :: m [LHsDecl GhcPs] + fromVector = do + args <- mapM (freshName . fieldName) recordFields + return [ + sigD name $ + funT + (recordTypeT r) + (ConT RT.type_Vector `appT` ConT RT.type_Any) + , valD name $ + lamE1 (conP recordConName (map varP args)) $ + appE + (VarE RT.fromList) + (listE [ VarE RT.unsafeCoerce `appE` VarE arg + | arg <- args + ] + ) + ] + where + name :: LRdrName + name = nameVectorFrom r + + toVector :: m [LHsDecl GhcPs] + toVector = do + x <- freshName $ mkExpVar recordAnnLoc "x" + args <- mapM (freshName . fieldName) recordFields + return $ [ + sigD name $ + funT + (ConT RT.type_Vector `appT` ConT RT.type_Any) + (recordTypeT r) + , valD name $ + lamE1 (varP x) $ + caseE + (VarE RT.toList `appE` VarE x) + [ ( listP (map varP args) + , appsE + (ConE recordConName) + [ VarE RT.unsafeCoerce `appE` VarE arg + | arg <- args + ] + ) + , ( wildP + , VarE RT.error `appE` stringE matchErr + ) + ] + ] + where + name :: LRdrName + name = nameVectorTo r + + matchErr :: String + matchErr = concat [ + "Pattern match failure in " + , nameBase (nameVectorTo r) + , ": vector with invalid number of elements." + ] + +{------------------------------------------------------------------------------- + Field accessors and 'HasField' instance + + TODO: If we had support within GHC itself for accessing fields in records, + we might be able to integrate this a lot more closely with normal GHC, + especially when combined with the @NoFieldSelectors@ extension. + + See +-------------------------------------------------------------------------------} + +-- | Generate the indexed field accessor +-- +-- Generates something like +-- +-- > 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" + n <- freshName $ mkExpVar recordAnnLoc "n" + t <- freshName $ mkExpVar recordAnnLoc "t" + return [ + sigD name $ + funT + (ConT RT.type_Int) + (recordTypeT r `funT` VarT x) + , valD name $ + lamE (varP n :| [varP t]) $ + appE + (VarE RT.noInlineUnsafeCo) + (appsE + (VarE RT.unsafeIndex) + [ VarE (nameVectorFrom r) `appE` VarE t + , VarE n + ] + ) + ] + where + name :: LRdrName + name = nameUnsafeGetIndex r + +-- | Generate index field overwrite +-- +-- Generates something like +-- +-- > unsafeSetIndexT :: forall x a b. Int -> T a b -> x -> T a b +-- > unsafeSetIndexT = \n t val -> +-- > vectorToT (V.unsafeUpd (vectorFromT t) [(n, noInlineUnsafeCo val)]) +-- +-- NOTE: Like 'genTo', this function used to be more complicated, because it +-- 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" + n <- freshName $ mkExpVar recordAnnLoc "n" + t <- freshName $ mkExpVar recordAnnLoc "t" + val <- freshName $ mkExpVar recordAnnLoc "val" + return [ + sigD name $ + ConT RT.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.unsafeUpd) + [ VarE (nameVectorFrom r) `appE` VarE t + , listE [ + tupE $ + VarE n + :| [VarE RT.noInlineUnsafeCo `appE` VarE val] + ] + ] + ) + ] + where + name :: LRdrName + name = nameUnsafeSetIndex r + +-- | Generate 'HasField' instance for single field +-- +-- Generates something like +-- +-- > 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" + t <- freshName $ mkExpVar recordAnnLoc "t" + return $ + instanceD + [equalP (VarT x) fieldType] + (appsT + (ConT RT.type_HasField) + [ stringT (nameBase fieldName) + , recordTypeT r + , VarT x + ] + ) + [ ( RT.unq_hasField + , lamE1 (varP t) $ + tupE $ + appsE (VarE (nameUnsafeSetIndex r)) [intE fieldIndex, VarE t] + :| [appsE (VarE (nameUnsafeGetIndex r)) [intE fieldIndex, VarE t]] + ) + ] + [] + +{------------------------------------------------------------------------------- + Generics +-------------------------------------------------------------------------------} + +-- | Generate the class we will use to instantiate 'Constraints' +-- +-- Generates something like this: +-- +-- > class Constraints_T a b (c :: Type -> Constraint) where +-- > dictConstraints_T :: Proxy c -> Rep (Dict c) (T a b) +-- +-- NOTE: It is critical that we don't give the class any superclass constraints +-- like +-- +-- > class (c Word, c Bool, c Char, c a, c [b]) +-- > => Constraints_T a b (c :: Type -> Constraint) +-- +-- because then @ghc@ would use resolve @Constraints_T@ to that tuple instead, +-- 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" + return $ classD + [] + (nameConstraints r) + (recordTyVars ++ [kindedTV c cKind]) + [ ( nameDictConstraints r + , funT + (ConT RT.type_Proxy `appT` VarT c) + (appsT + (ConT RT.type_Rep) + [ ConT RT.type_Dict `appT` VarT c + , recordTypeT r + ] + ) + ) + ] + where + cKind :: LHsType GhcPs + cKind = ConT RT.type_Type `funT` ConT RT.type_Constraint + +-- | Superclass constraints required by the constraints class instance +-- +-- Generates something like +-- +-- > (c Word, c Bool, c Char, c a, c [b]) +-- +-- However, we filter out constraints that are type variable free, so if we +-- pass, say, @Show@ for @c@, then we generate +-- +-- > (Show a, Show [b]) +-- +-- instead. This avoids @ghc@ complaining about +-- +-- > Redundant constraints: (Show Word, Show Bool, Show Char) +genRequiredConstraints :: Record -> LHsType GhcPs -> [LHsType GhcPs] +genRequiredConstraints Record{..} c = + nubBy sameType $ filter hasTypeVar $ map constrainField recordFields + where + constrainField :: Field -> LHsType GhcPs + constrainField Field{..} = c `appT` fieldType + + sameType :: LHsType GhcPs -> LHsType GhcPs -> Bool + sameType = compareHs + + hasTypeVar :: LHsType GhcPs -> Bool + hasTypeVar = not . null . allTyVars + + allTyVars :: LHsType GhcPs -> [String] + allTyVars = SYB.everything (++) (SYB.mkQ [] isTypeVar) + + isTypeVar :: LHsType GhcPs -> [String] + isTypeVar (VarT (TyVar name)) = [name] + isTypeVar _otherwise = [] + +-- | Generate the dictionary creation function ('dict') +-- +-- Generates something like +-- +-- > \p -> Rep (V.fromList [ +-- > noInlineUnsafeCo (dictFor p (Proxy :: Proxy Word)) +-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Bool)) +-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Char)) +-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy a)) +-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy [b])) +-- > ]) +genDict :: MonadFresh m => Record -> m (LHsExpr GhcPs) +genDict Record{..} = do + p <- freshName $ mkExpVar recordAnnLoc "p" + return $ + lamE1 (varP p) $ + appE + (ConE RT.con_Rep) + (VarE RT.fromList `appE` 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]) + +-- | Generate (one and only) instance of the constraints class +-- +-- Generates something like +-- +-- > instance (..) => Constraints_T a b c where +-- > 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" + return $ + instanceD + (genRequiredConstraints r (VarT c)) + (appsT + (ConT (nameConstraints r)) + ([VarT (tyVarBndrName v) | v <- recordTyVars] ++ [VarT c])) + [(nameDictConstraints r, body)] + [] + +-- | Generate metadata +-- +-- Generates something like +-- +-- > \_p -> Metadata { +-- > recordName = "T" +-- > , recordConstructor = "MkT" +-- > , recordSize = 5 +-- > , recordFieldMetadata = Rep $ V.fromList [ +-- > FieldMetadata (Proxy :: Proxy "tInt")) FieldLazy +-- > , FieldMetadata (Proxy :: Proxy "tBool")) FieldLazy +-- > , FieldMetadata (Proxy :: Proxy "tChar")) FieldLazy +-- > , FieldMetadata (Proxy :: Proxy "tA")) FieldLazy +-- > , FieldMetadata (Proxy :: Proxy "tListB")) FieldLazy +-- > ] +-- > } +genMetadata :: MonadFresh m => Record -> m (LHsExpr GhcPs) +genMetadata r@Record{..} = 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) + (VarE RT.fromList `appE` listE (map auxField recordFields)) + ) + ] + where + auxField :: Field -> LHsExpr GhcPs + auxField Field{..} = + appsE + (ConE RT.con_FieldMetadata) + [ proxyE (stringT (nameBase fieldName)) + , ConE $ if allFieldsStrict recordOptions + then RT.con_FieldStrict + else RT.con_FieldLazy + ] + +-- | Generate definition for `from` in the `Generic` instance +-- +-- Generates something like +-- +-- > repFromVectorStrict . vectorFromT +genFrom :: MonadFresh m => Record -> m (LHsExpr GhcPs) +genFrom r@Record{..} = do + x <- freshName $ mkExpVar recordAnnLoc "x" + return $ + lamE1 (varP x) $ + VarE RT.repFromVector `appE` (VarE (nameVectorFrom r) `appE` VarE x) + +-- | Generate definition for `to` in the `Generic` instance +-- +-- > vectorToT . repToVector +-- +-- NOTE: This function used to be more complicated. When the internal +-- representation of a record /is/ a vector, then we have to be very careful +-- with the strictness of the fields here. However, since we currently use a +-- " 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 + x <- freshName $ mkExpVar recordAnnLoc "x" + return $ + lamE1 (varP x) $ + VarE (nameVectorTo r) `appE` (VarE RT.repToVector `appE` VarE x) + +-- | Generate an instance of large-records 'Data.Record.Generic'. +-- +-- In the sample instance below, @vectorFromT@ and @vectorToT@ are generated +-- per-record by 'genVectorFrom' and 'genVectorTo' respectively. +-- +-- > instance Generic (T ...) where +-- > type Constraints (T ...) = Constraints_T ... +-- > type MetadataOf (T ...) = '[ '("field1", fieldType1), ... ] +-- > +-- > from = .. +-- > to = .. +-- > dict = dictConstraints_T +-- > metadata = .. +genGenericInstance :: MonadFresh m => Record -> m (LHsDecl GhcPs) +genGenericInstance r@Record{..} = do + metadata <- genMetadata r + from <- genFrom r + to <- genTo 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 ) + ] + [ tySynEqn RT.unq_type_Constraints [recordTypeT r] $ + appsT + (ConT (nameConstraints r)) + [VarT (tyVarBndrName v) | v <- recordTyVars] + , tySynEqn RT.unq_type_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 + | DeriveStock d <- recordDerivings + ] + +-- | For a record type @T@ and stock-derivable class @C@, generate +-- +-- > instance $(genRequiredConstraints T C) => C T where +-- > $(method) = $(generic implementation) +-- +-- NOTE: All of these instances depend on the 'Data.Record.Generics.Generics' +-- instance. +-- +-- 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 ] + Generic -> [] + where + mkInstance :: LRdrName -> LRdrName -> LRdrName -> LHsDecl GhcPs + mkInstance cls mthd gen = + instanceD + (genRequiredConstraints r (ConT cls)) + (ConT cls `appT` recordTypeT r) + [(mthd, VarE gen)] + [] + +{------------------------------------------------------------------------------- + GHC generics +-------------------------------------------------------------------------------} + +-- | Generate GHC generics instance +-- +-- Generates something like +-- +-- > instance GHC.Generic ExampleRecord where +-- > type Rep ExampleRecord = ThroughLRGenerics ExampleRecord +-- > +-- > from = WrapThroughLRGenerics +-- > to = unwrapThroughLRGenerics +-- +-- See 'ThroughLRGenerics' for documentation. +genGHCGeneric :: MonadFresh m => Record -> m (LHsDecl GhcPs) +genGHCGeneric r = pure $ + instanceD + [] + (ConT GHC.type_Generic `appT` recordTypeT r) + [ ( GHC.unq_from , ConE RT.con_WrapThroughLRGenerics ) + , ( GHC.unq_to , VarE RT.unwrapThroughLRGenerics ) + ] + [ tySynEqn GHC.unq_type_Rep [recordTypeT r] $ + ConT RT.type_ThroughLRGenerics `appT` recordTypeT r + ] + +{------------------------------------------------------------------------------- + Auxiliary functions for dealing with records +-------------------------------------------------------------------------------} + +-- | The saturated type of the record (that is, with all type vars applied) +recordTypeT :: Record -> LHsType GhcPs +recordTypeT Record{..} = + ConT recordTyName `appsT` [VarT (tyVarBndrName f) | f <- recordTyVars] + +{------------------------------------------------------------------------------- + Pick names for generated code +-------------------------------------------------------------------------------} + +nameRecord :: Record -> String +nameRecord Record{..} = nameBase recordTyName + +-- | Make name derived from the name of the record +mkDerived :: (SrcSpan -> String -> LRdrName) -> String -> Record -> LRdrName +mkDerived f prefix r = f (recordAnnLoc r) (prefix <> nameRecord r) + +nameVectorFrom :: Record -> LRdrName +nameVectorTo :: Record -> LRdrName +nameUnsafeGetIndex :: Record -> LRdrName +nameUnsafeSetIndex :: Record -> LRdrName +nameConstraints :: Record -> LRdrName +nameDictConstraints :: Record -> LRdrName + +nameVectorFrom = mkDerived mkExpVar "vectorFrom" +nameVectorTo = mkDerived mkExpVar "vectorTo" +nameUnsafeGetIndex = mkDerived mkExpVar "unsafeGetIndex" +nameUnsafeSetIndex = mkDerived mkExpVar "unsafeSetIndex" +nameConstraints = mkDerived mkTyCon "Constraints_" +nameDictConstraints = mkDerived mkExpVar "dictConstraints_" + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | 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) + +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 new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Plugin/Exception.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Exceptions that may be thrown by the large-records plugin. +module Data.Record.Internal.Plugin.Exception ( + Exception(..) + , exceptionLoc + , exceptionToSDoc + ) where + +import Data.Record.Internal.GHC.Shim + +data Exception = + UnsupportedStockDeriving (LHsType GhcPs) + | UnsupportedStrategy (LDerivStrategy GhcPs) + | InvalidDeclaration (LHsDecl GhcPs) + +exceptionLoc :: Exception -> SrcSpan +exceptionLoc = \case + UnsupportedStockDeriving (L l _) -> l + UnsupportedStrategy (L l _) -> l + InvalidDeclaration (L l _) -> l + +exceptionToSDoc :: Exception -> SDoc +exceptionToSDoc = hsep . \case + UnsupportedStockDeriving ty -> [ + "Unsupported stock class: " + , ppr ty + ] + UnsupportedStrategy (L _ strategy) -> [ + "Strategy " + , derivStrategyName strategy + , " is not supported" + ] + InvalidDeclaration _decl -> [ + "Unsupported declaration for large-records" + ] diff --git a/src/Data/Record/Internal/Plugin/Names/GhcGenerics.hs b/src/Data/Record/Internal/Plugin/Names/GhcGenerics.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Plugin/Names/GhcGenerics.hs @@ -0,0 +1,42 @@ +-- | 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 new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Plugin/Names/Runtime.hs @@ -0,0 +1,223 @@ +-- | 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 + -- * vector + , type_Vector + , fromList + , toList + , unsafeIndex + , unsafeUpd + -- * 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_Vector :: LRdrName +type_Vector = nameQT "Vector" + +fromList :: LRdrName +toList :: LRdrName +unsafeIndex :: LRdrName +unsafeUpd :: LRdrName + +fromList = nameQV "fromList" +toList = nameQV "toList" +unsafeIndex = nameQV "unsafeIndex" +unsafeUpd = nameQV "unsafeUpd" + +{------------------------------------------------------------------------------- + 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 new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Plugin/Options.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Generation options for large-records. +module Data.Record.Internal.Plugin.Options ( + -- * Definition + LargeRecordOptions(..) + , largeRecordStrict + , largeRecordLazy + -- * Extract options from source module + , getLargeRecordOptions + ) where + +import Data.Bifunctor +import Data.Data (Data) +import Data.Map (Map) +import Data.Maybe (mapMaybe) + +import qualified Data.Generics as SYB +import qualified Data.Map.Strict as Map + +import Data.Record.Internal.GHC.Shim +import Data.Record.Internal.GHC.TemplateHaskellStyle + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | A type specifying how a record should be treated by large-records. +-- +-- The default for Haskell code should probably be: +-- +-- > {-# ANN type T largeRecordLazy #-} +-- > data T = .. +-- +-- For records with strict fields, you can use: +-- +-- > {-# ANN type T largeRecordStrict #-} +-- > data T = .. +-- +-- To see the definitions generated by @large-records@: +-- +-- > {-# ANN type T largeRecordLazy {debugLargeRecords = True} #-} +-- > data T = .. +data LargeRecordOptions = LargeRecordOptions { + allFieldsStrict :: Bool + , debugLargeRecords :: Bool + } + deriving stock (Data) + +largeRecordStrict :: LargeRecordOptions +largeRecordStrict = LargeRecordOptions { + allFieldsStrict = True + , debugLargeRecords = False + } + +largeRecordLazy :: LargeRecordOptions +largeRecordLazy = LargeRecordOptions { + allFieldsStrict = False + , debugLargeRecords = False + } + +{------------------------------------------------------------------------------- + Extract options from module +-------------------------------------------------------------------------------} + +-- | Extract all 'LargeRecordOptions' in a module +-- +-- Additionally returns the location of the ANN pragma. +getLargeRecordOptions :: HsModule -> Map String [(SrcSpan, LargeRecordOptions)] +getLargeRecordOptions = + Map.fromListWith (++) + . map (second (:[])) + . mapMaybe viewAnnotation + . SYB.everything (++) (SYB.mkQ [] (:[])) + +viewAnnotation :: AnnDecl GhcPs -> Maybe (String, (SrcSpan, LargeRecordOptions)) +viewAnnotation = \case + PragAnnD (TypeAnnotation tyName) (intOptions -> Just options) -> + Just (nameBase tyName, (getLoc tyName, options)) + _otherwise -> + Nothing + +{------------------------------------------------------------------------------- + Very limited interpreter for 'LargeRecordOptions' + + TODO: Instead of doing this, we might be able to use runAnnotation. This lives + in the TcM monad, but the Hsc monad gives us a HscEnv which is sufficient to + run things in the TcM monad. For that however we would need to use the + /renamed/ module, rather than the parsed one. I think this might be possible + now that quasi-quotation is no longer necessary, but I am not 100% sure. +-------------------------------------------------------------------------------} + +intOptions :: LHsExpr GhcPs -> Maybe LargeRecordOptions +intOptions (VarE (nameBase -> "largeRecordStrict")) = + Just largeRecordStrict +intOptions (VarE (nameBase -> "largeRecordLazy")) = + Just largeRecordLazy +intOptions (RecUpdE expr fields) = do + opts <- intOptions expr + updates <- mapM intUpdate fields + return $ foldr (.) id updates opts +intOptions _otherwise = + Nothing + +intUpdate :: + (LRdrName, LHsExpr GhcPs) + -> Maybe (LargeRecordOptions -> LargeRecordOptions) +intUpdate (nameBase -> "debugLargeRecords", intBool -> Just b) = + Just $ \opts -> opts { debugLargeRecords = b } +intUpdate _otherwise = + Nothing + +intBool :: LHsExpr GhcPs -> Maybe Bool +intBool (ConE (nameBase -> "True")) = Just True +intBool (ConE (nameBase -> "False")) = Just False +intBool _otherwise = Nothing diff --git a/src/Data/Record/Internal/Plugin/Record.hs b/src/Data/Record/Internal/Plugin/Record.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Plugin/Record.hs @@ -0,0 +1,129 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Convert GHC AST definitions of records into our own representation, 'Record'. +module Data.Record.Internal.Plugin.Record ( + Record(..) + , Field(..) + , StockDeriving(..) + , RecordDeriving(..) + , viewRecord + ) where + +import Control.Monad.Except +import Data.Traversable (for) +import Data.List.NonEmpty (NonEmpty) + +import qualified Data.List.NonEmpty as NE + +import Data.Record.Internal.GHC.Shim +import Data.Record.Internal.GHC.TemplateHaskellStyle +import Data.Record.Internal.Plugin.Exception (Exception (..)) +import Data.Record.Internal.Plugin.Options (LargeRecordOptions) + +{------------------------------------------------------------------------------- + Definition +-------------------------------------------------------------------------------} + +-- | A representation for records that can be processed by large-records. +data Record = Record { + recordTyName :: LRdrName + , recordTyVars :: [LHsTyVarBndr GhcPs] + , recordConName :: LRdrName + , recordFields :: [Field] + , recordDerivings :: [RecordDeriving] + , recordOptions :: LargeRecordOptions + + -- | The location of the @ANN@ pragma + -- + -- We use this as the location of the new identifiers we generate. + , recordAnnLoc :: SrcSpan + } + +data Field = Field { + fieldName :: LRdrName + , fieldType :: LHsType GhcPs + , fieldIndex :: Int + } + +-- | Derived classes that we can support. +data StockDeriving = Eq | Show | Ord | Generic + +-- | A representation for @deriving@ clauses. +-- +-- NOTE: We support @DeriveAnyClass@ style derivation, because this does not +-- depend on the internal representation we choose, but only on the default +-- implementation in the class, which typically depends on generics. For +-- example, it makes it possible to define things like +-- +-- > data UserT (f :: Type -> Type) = User { +-- > userEmail :: Columnar f Text +-- > -- .. other fields .. +-- > } +-- > deriving stock (Show, Eq) +-- > deriving anyclass (Beamable) +-- +-- For now we do /not/ support newtype deriving or deriving-via, since this +-- /does/ depend on the internal record representation. See discussion at +-- . +data RecordDeriving = + DeriveStock StockDeriving + | DeriveAnyClass (LHsType GhcPs) + +{------------------------------------------------------------------------------- + Views +-------------------------------------------------------------------------------} + +viewRecord :: + MonadError Exception m + => SrcSpan -> LargeRecordOptions -> LHsDecl GhcPs -> m Record +viewRecord annLoc options decl = + case decl of + DataD tyName tyVars [RecC conName fields] derivs-> do + fields' <- mapM viewField fields + derivings <- viewRecordDerivings derivs + pure Record { + recordTyName = tyName + , recordTyVars = tyVars + , recordConName = conName + , recordFields = zipWith ($) fields' [0..] + , recordDerivings = derivings + , recordOptions = options + , recordAnnLoc = annLoc + } + _otherwise -> throwError $ InvalidDeclaration decl + +viewField :: + MonadError Exception m + => (LRdrName, LHsType GhcPs) -> m (Int -> Field) +viewField (name, typ) = return $ Field name typ + +viewRecordDerivings :: + MonadError Exception m + => [LHsDerivingClause GhcPs] -> m [RecordDeriving] +viewRecordDerivings = fmap concat . traverse viewRecordDeriving + +viewRecordDeriving :: forall m. + MonadError Exception m + => LHsDerivingClause GhcPs -> m [RecordDeriving] +viewRecordDeriving = \case + DerivClause Nothing tys -> + goStock tys + DerivClause (Just (L _ StockStrategy)) tys -> + goStock tys + DerivClause (Just (L _ AnyclassStrategy)) tys -> + pure $ fmap DeriveAnyClass (NE.toList tys) + DerivClause (Just strategy) _ -> + throwError (UnsupportedStrategy strategy) + _ -> + pure [] + where + goStock :: NonEmpty (LHsType GhcPs) -> m [RecordDeriving] + goStock tys = for (NE.toList tys) $ \case + ConT (nameBase -> "Show") -> pure $ DeriveStock Show + ConT (nameBase -> "Eq") -> pure $ DeriveStock Eq + ConT (nameBase -> "Ord") -> pure $ DeriveStock Ord + ConT (nameBase -> "Generic") -> pure $ DeriveStock Generic + ty -> throwError (UnsupportedStockDeriving ty) diff --git a/src/Data/Record/Internal/Record.hs b/src/Data/Record/Internal/Record.hs deleted file mode 100644 --- a/src/Data/Record/Internal/Record.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Data.Record.Internal.Record ( - -- * Record description - Record(..) - , Field(..) - -- * Combinators - , matchRecordFields - , dropMissingRecordFields - ) where - -import Control.Monad.State -import Data.List (sortBy) -import Data.Map (Map) -import Data.Maybe (mapMaybe) -import Data.Ord (comparing) -import Language.Haskell.TH - -import qualified Data.Map as Map -import qualified Data.Map.Merge.Lazy as Map - -{------------------------------------------------------------------------------- - Description --------------------------------------------------------------------------------} - --- | Record description -data Record a = Record { - -- | Record type name - recordType :: String - - -- | Record constructor name - , recordConstr :: String - - -- | Type variables in the records type - , recordTVars :: [TyVarBndr] - - -- | Fields in the record - , recordFields :: [Field a] - } - deriving stock (Show, Functor, Foldable, Traversable) - --- | Record field description -data Field a = Field { - -- | Field name - fieldName :: String - - -- | Type of the field - , fieldType :: Type - - -- | Index of the field (field 0, field 1, ..) - -- - -- This is strictly speaking redundant information, as this is already - -- implied by the position of the field in 'recordFields'. However, since - -- we do a lot of positional processing (every field corresponds to a - -- vector element), it is convenient to have the index readily available. - , fieldIndex :: Int - - -- | Value associated with this field ('Nothing' if not present) - , fieldVal :: a - } - deriving stock (Show, Functor, Foldable, Traversable) - -{------------------------------------------------------------------------------- - Combinators --------------------------------------------------------------------------------} - --- | Match field values against field definitions --- --- We explicit mark missing fields; one use case for this is record --- construction, where we want to issue a warning for missing fields. -matchRecordFields :: forall a b. - [(String, b)] - -> Record a - -> (Record (a, Maybe b), [String]) -matchRecordFields values r = ( - r { recordFields = sortBy (comparing fieldIndex) $ - Map.elems matched - } - , unknown - ) - where - given :: Map String b - given = Map.fromList values - - defined :: Map String (Field a) - defined = Map.fromList $ - map (\f -> (fieldName f, f)) (recordFields r) - - matched :: Map String (Field (a, Maybe b)) - unknown :: [String] - (matched, unknown) = flip runState [] $ - Map.mergeA - (Map.traverseMissing fieldMissing) - (Map.traverseMaybeMissing fieldUnknown) - (Map.zipWithAMatched fieldPresent) - defined - given - - fieldPresent :: String -> Field a -> b -> State [String] (Field (a, Maybe b)) - fieldMissing :: String -> Field a -> State [String] (Field (a, Maybe b)) - fieldUnknown :: String -> b -> State [String] (Maybe (Field (a, Maybe b))) - - fieldPresent _nm f a = return $ f { fieldVal = (fieldVal f, Just a) } - fieldMissing _nm f = return $ f { fieldVal = (fieldVal f, Nothing) } - fieldUnknown nm _a = modify (nm:) >> return Nothing - -dropMissingRecordFields :: Record (Maybe a) -> Record a -dropMissingRecordFields r = - r { recordFields = mapMaybe sequenceA (recordFields r) } diff --git a/src/Data/Record/Internal/Record/Parser.hs b/src/Data/Record/Internal/Record/Parser.hs deleted file mode 100644 --- a/src/Data/Record/Internal/Record/Parser.hs +++ /dev/null @@ -1,140 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} - -module Data.Record.Internal.Record.Parser ( - RecordInstances(..) - , Deriving(..) - , parseRecordDef - ) where - -import Data.Either (partitionEithers) -import Data.Maybe (catMaybes) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -import Data.Record.Internal.Record -import Data.Record.Internal.TH.Util -import Data.Record.Internal.Util - -{------------------------------------------------------------------------------- - Record instances --------------------------------------------------------------------------------} - -data RecordInstances = RecordInstances { - -- | Explicitly supported type class instances - recordInstancesDerived :: [Deriving] - - -- | Anyclass deriving - -- - -- We list these separately, because we need to add these as anyclass - -- deriving classes when defining the newtype, rather than as standalone - -- deriving instances. (If we don't, we need to duplicate ghc's logic for - -- figuring out how many parameters to provide to the datatype.) - , recordInstancesAnyclass :: [Type] - } - -data Deriving = - DeriveEq - | DeriveOrd - | DeriveShow - deriving (Show) - -{------------------------------------------------------------------------------- - Parsing --------------------------------------------------------------------------------} - --- | Try to match a record declaration --- --- We use 'Maybe' in these matching functions, along with 'reportError', so that --- we can report multiple errors rather than stopping at the first. -parseRecordDef :: Dec -> Q (Maybe (Record (), RecordInstances)) -parseRecordDef (DataD - _cxt@[] - typeName - tyVarBndrs - _kind@Nothing - [RecC constrName fieldTypes] - derivClauses - ) = do - - fields <- catMaybes <$> - mapM parseFieldDef (zip [0..] fieldTypes) - (deriv, anyclass) <- partitionEithers <$> - concatMapM parseDeriv derivClauses - - return $ Just ( - Record { - recordType = nameBase typeName - , recordConstr = nameBase constrName - , recordTVars = tyVarBndrs - , recordFields = fields - } - , RecordInstances { - recordInstancesDerived = deriv - , recordInstancesAnyclass = anyclass - } - ) -parseRecordDef d = do - reportError $ "Unsupported declaration: " ++ show d - return Nothing - --- | Support deriving clauses --- --- We return the anyclass deriving clauses separately. --- See 'recordAnyclass' for more details. -parseDeriv :: DerivClause -> Q [Either Deriving Type] -parseDeriv = \case - DerivClause Nothing cs -> - map Left <$> derivStock cs - DerivClause (Just StockStrategy) cs -> - map Left <$> derivStock cs - DerivClause (Just AnyclassStrategy) cs -> - return $ map Right cs - DerivClause strategy _ -> do - reportError $ "Unsupported deriving strategy " ++ show strategy - return [] - where - derivStock cs = catMaybes <$> mapM go cs - go :: Pred -> Q (Maybe Deriving) - go p | p == ConT ''Eq = return $ Just DeriveEq - | p == ConT ''Ord = return $ Just DeriveOrd - | p == ConT ''Show = return $ Just DeriveShow - | otherwise = do - reportError $ "Cannot derive instance for " ++ show p - return Nothing - -parseFieldDef :: (Int, VarBangType) -> Q (Maybe (Field ())) -parseFieldDef (i, (nm, bng, typ)) = - case bng of - DefaultBang -> - return . Just $ Field { - fieldName = unqualify nm - , fieldType = typ - , fieldIndex = i - , fieldVal = () - } - _otherwise -> do - reportError $ "Unsupported bang type: " ++ show bng - return Nothing - where - unqualify :: Name -> String - unqualify = undoDRF . nameBase - -{------------------------------------------------------------------------------- - Internal auxiliary --------------------------------------------------------------------------------} - --- When @DuplicateRecordFields@ is enabled, it produces field names such as --- @$sel:a:MkY@. We don't really care much about 'DuplicateRecordFields', --- insofar as that we will not try to be compatible with DRF-style --- overloading (all overloading must happen through 'HasField' instead). --- We do however need to recover the original field name. --- --- --- -undoDRF :: String -> String -undoDRF nm = - case nm of - '$' : drf -> takeWhile (/= ':') . tail . dropWhile (/= ':') $ drf - _otherwise -> nm diff --git a/src/Data/Record/Internal/Record/Resolution.hs b/src/Data/Record/Internal/Record/Resolution.hs deleted file mode 100644 --- a/src/Data/Record/Internal/Record/Resolution.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} - -module Data.Record.Internal.Record.Resolution ( - resolveRecord - ) where - -import Language.Haskell.TH.Syntax (Quasi, NameSpace(..)) - -import Data.Record.Internal.Record - -import qualified Data.Record.Internal.Record.Resolution.GHC as GHC -import qualified Data.Record.Internal.Record.Resolution.Internal as Internal -import qualified Data.Record.Internal.TH.Name as N - --- | Resolve record info --- --- When the quasi-quoter needs to turn --- --- > [lr| MkRecord { field2 = 5, field1 = True } |] --- --- into --- --- > _construct_MkRecord True 5 --- --- it needs to know the record definition: the types of all fields, and the --- order of all fields. --- --- The primary means through which we achieve this is by looking up the --- 'MetadataOf' type family instance for the record, and then parsing that --- ('GHC.parseRecordInfo'). --- --- Unfortunately, however, this does not always work. In an example such as --- --- > largeRecord defaultPureScript [d| --- > data SomeRecord = MkRecord { field1 :: Int, field2 :: Bool } --- > |] --- > --- > foo :: SomeRecord --- > foo = [lr| MkRecord { field1 = 5, field2 = True } |] --- --- the call to 'largeRecord' and the definition of @foo@ is considered to be a --- single binding group (not entirely sure why). Both the 'largeRecord' splice --- and the 'lr' quasi-quote are now run /before typechecking/, which is why when --- we get to the 'lr' quasi-quote, the 'MetadataOf' instance is not yet --- available, even though it /has/ been generated. --- --- One work-around is to insert an empty splice --- --- > largeRecord defaultPureScript [d| --- > data SomeRecord = MkRecord { field1 :: Int, .. } --- > |] --- > --- > $(return []) --- > --- > foo :: SomeRecord --- > foo = [lr| MkRecord { field1 = 5, .. } |] --- --- That works (and we previously did that, giving that empty splice a name --- @endOfBindingGroup@), but requiring this is bad for useability of the lib. --- Most users probably don't know what binding groups even are, much less want --- to think about the scope of each binding group: that's a task for @ghc@. --- --- Therefore, in addition to being able to parse the 'MetadataOf' instance, we --- also maintain our own environment, mapping constructor names to record info --- (see 'Internal.getRecordInfo'). The 'largeRecord' splice adds entries into --- this environment, and the 'lr' quasi-quoter consults this environment. --- The contents of this environment are ephemeral, of course, and certainly not --- stored as part of interface files, so this is merely a backup for when the --- 'MetadataOf' information is not available. -resolveRecord :: Quasi m - => String -- ^ User-defined constructor - -> N.Name 'DataName 'N.Global -- ^ Internal constructor - -> m (Either String (Record ())) -resolveRecord userConstr internalConstr = do - mInfo <- Internal.getRecordInfo internalConstr - case mInfo of - Just info -> return $ Right info - Nothing -> GHC.parseRecordInfo userConstr internalConstr diff --git a/src/Data/Record/Internal/Record/Resolution/GHC.hs b/src/Data/Record/Internal/Record/Resolution/GHC.hs deleted file mode 100644 --- a/src/Data/Record/Internal/Record/Resolution/GHC.hs +++ /dev/null @@ -1,110 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - -module Data.Record.Internal.Record.Resolution.GHC ( - parseRecordInfo - ) where - -import Control.Monad.Except -import Data.Maybe (fromMaybe) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -import qualified Control.Monad.Except as Except - -import Data.Record.Generic -import Data.Record.Internal.Record -import Data.Record.Internal.TH.Util - -import qualified Data.Record.Internal.TH.Name as N - -{------------------------------------------------------------------------------- - Parsing --------------------------------------------------------------------------------} - --- | Parse previously constructed type level data --- --- We do this when we construct record /values/, at which point we have no --- 'Options', so this must work without options. --- --- 'Nothing' if this wasn't a type created using @large-records@. -parseRecordInfo :: forall m. - Quasi m - => String -- ^ User-defined constructor - -> N.Name 'DataName 'N.Global -- ^ Internal constructor - -> m (Either String (Record ())) -parseRecordInfo userConstr internalConstr = runExceptT $ do - parent <- Except.lift (N.reify internalConstr) >>= getDataConParent - saturated <- Except.lift (N.reify parent) >>= getSaturatedType - parsed <- Except.lift (getMetadataInstance saturated) >>= parseTySynInst - return $ mkRecordInfo (N.nameBase parent) parsed - where - mkRecordInfo :: - String - -> ([TyVarBndr], [(String, Type)]) - -> Record () - mkRecordInfo rType (tyVars, fieldTypes) = Record { - recordType = rType - , recordConstr = userConstr - , recordTVars = tyVars - , recordFields = zipWith (uncurry mkFieldInfo) fieldTypes [0..] - } - - mkFieldInfo :: String -> Type -> Int -> Field () - mkFieldInfo fName fType ix = Field { - fieldName = fName - , fieldType = fType - , fieldIndex = ix - , fieldVal = () - } - - saturate :: Name -> [TyVarBndr] -> Type - saturate n = foldl (\t v -> t `AppT` VarT (tyVarName v)) (ConT n) - - getMetadataInstance :: Type -> m [InstanceDec] - getMetadataInstance = runQ . reifyInstances ''MetadataOf . (:[]) - - getSaturatedType :: Info -> ExceptT String m Type - getSaturatedType (TyConI (NewtypeD [] nm tyVars _kind _con _deriv)) = - return $ saturate nm tyVars - getSaturatedType i = - unexpected i "newtype" - - getDataConParent :: Info -> ExceptT String m (N.Name 'TcClsName 'N.Global) - getDataConParent (DataConI _ _ parent) = - return $ N.fromTH' parent - getDataConParent i = - unexpected i "data constructor" - - parseTySynInst :: - [InstanceDec] - -> ExceptT String m ([TyVarBndr], [(String, Type)]) - parseTySynInst [TySynInstD (TySynEqn vars _lhs rhs)] = - (fromMaybe [] vars, ) <$> parseList rhs - parseTySynInst is = - unexpected is "type instance" - - parseList :: Type -> ExceptT String m [(String, Type)] - parseList (AppT (AppT PromotedConsT t) ts) = - (:) <$> parseTuple t <*> parseList ts - parseList PromotedNilT = - return [] - parseList (SigT t _kind) = - parseList t - parseList t = unexpected t "list" - - parseTuple :: Type -> ExceptT String m (String, Type) - parseTuple (AppT (AppT (PromotedTupleT 2) (LitT (StrTyLit f))) t) = - return (f, t) - parseTuple t = unexpected t "tuple" - - unexpected :: Show a => a -> String -> ExceptT String m b - unexpected actual expected = throwError $ concat [ - "Unexpected " - , show actual - , " (expected " - , expected - , ")" - ] diff --git a/src/Data/Record/Internal/Record/Resolution/Internal.hs b/src/Data/Record/Internal/Record/Resolution/Internal.hs deleted file mode 100644 --- a/src/Data/Record/Internal/Record/Resolution/Internal.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE DataKinds #-} - -module Data.Record.Internal.Record.Resolution.Internal ( - getRecordInfo - , putRecordInfo - ) where - -import Data.Map (Map) -import Data.Maybe (fromMaybe) -import Language.Haskell.TH.Syntax - -import qualified Data.Map as Map - -import Data.Record.Internal.Naming -import Data.Record.Internal.Record - -import qualified Data.Record.Internal.TH.Name as N - -{------------------------------------------------------------------------------- - Internal state - - As keys we use the names of the internal constructor, because when we do name - resolution, that is what we would normally use to query ghc. We use /global/ - names, which uniquely identify a name (qualified by package and module). --------------------------------------------------------------------------------} - -newtype TypeEnv = WrapTypeEnv { - unwrapTypeEnv :: Map (N.Name 'DataName 'N.Global) (Record ()) - } - -getTypeEnv :: Quasi m => m TypeEnv -getTypeEnv = fromMaybe (WrapTypeEnv Map.empty) <$> qGetQ - -putTypeEnv :: Quasi m => TypeEnv -> m () -putTypeEnv = qPutQ - -{------------------------------------------------------------------------------- - Accessing the internal state --------------------------------------------------------------------------------} - -getRecordInfo :: - Quasi m - => N.Name 'DataName 'N.Global -- ^ Name of the internal constructor - -> m (Maybe (Record ())) -getRecordInfo internalConstr = - Map.lookup internalConstr . unwrapTypeEnv <$> getTypeEnv - --- | Add 'RecordInfo' to the environment --- --- NOTE: Must be called whilst processing the module in which the record is --- defined. -putRecordInfo :: Quasi m => Record () -> m () -putRecordInfo info = do - env <- unwrapTypeEnv <$> getTypeEnv - - -- In order to be able to resolve the record info later, we need to properly - -- quantify the record name. We do this by requesting the /current/ TH - -- location. This is justified by the precondition to the function. - - loc <- runQ location - let internalConstr :: N.Name 'DataName 'N.Global - internalConstr = - N.Name - (OccName (nameRecordInternalConstr (recordConstr info))) - (N.NameGlobal - DataName - (mkPkgName (loc_package loc)) - (mkModName (loc_module loc)) - ) - - putTypeEnv $ WrapTypeEnv $ Map.insert internalConstr info env - diff --git a/src/Data/Record/Internal/TH/Name.hs b/src/Data/Record/Internal/TH/Name.hs deleted file mode 100644 --- a/src/Data/Record/Internal/TH/Name.hs +++ /dev/null @@ -1,321 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} - -{-# OPTIONS_GHC -Wno-partial-type-signatures #-} - --- | Names with statically known flavour --- --- Intended for qualified import. -module Data.Record.Internal.TH.Name ( - -- * Names - Name(..) - , Flavour(..) - , NameFlavour(..) - -- * Simple functions - , nameBase - , mapNameBase - -- * Working with qualified names - , Qualifier(..) - , qualify - , unqualified - , nameQualifier - -- * Fresh names - , newName - -- * Conversion - , fromTH - , fromTH' - , toTH - -- * Resolution - , LookupName(..) - , reify - -- * Construct TH - , classD - , conE - , conT - , newtypeD - , patSynD - , patSynSigD - , pragCompleteD - , recC - , recordPatSyn - , sigD - , varBangType - , varE - , varLocalP - , varGlobalP - ) where - -import Data.Kind -import Data.Maybe (fromMaybe) -import Language.Haskell.TH (Q) -import Language.Haskell.TH.Syntax (Quasi, runQ, NameSpace(..)) - -import qualified Language.Haskell.TH.Syntax as TH -import qualified Language.Haskell.TH.Lib as TH - -{------------------------------------------------------------------------------- - Names --------------------------------------------------------------------------------} - --- | Name flavours (used as a kind, not as a type) --- --- Technically speaking there is one flavour missing: names that are locally --- bound, but outside of the TH quote, something like --- --- > foo x = [| .. x .. |] --- --- However, we won't actually deal with such names. -data Flavour = - -- | Dynamically bound - -- - -- Dynamically bound names will be bound to a global name by @ghc@ after - -- splicing the TH generated Haskelll code. - -- - -- These are generated with 'mkName' (also used by @haskell-src-meta@). - Dynamic - - -- | A new name - -- - -- These are names either generated by 'newName' or are new names in a TH - -- declaration quote @[d| ... |]@. - | Unique - - -- | Reference to a specific name defined outside of the TH quote - | Global - -data NameFlavour :: Flavour -> Type where - -- | Dynamically bound name, with an optional module prefix (@T.foo@) - NameDynamic :: Maybe TH.ModName -> NameFlavour 'Dynamic - - -- | Unique local name - NameUnique :: TH.Uniq -> NameFlavour 'Unique - - -- | Global name bound outside of the TH quot - NameGlobal :: TH.NameSpace -> TH.PkgName -> TH.ModName -> NameFlavour 'Global - --- | Like TH's 'Name', but with statically known flavour. -data Name :: NameSpace -> Flavour -> Type where - Name :: TH.OccName -> NameFlavour flavour -> Name ns flavour - -deriving instance Show (NameFlavour flavour) -deriving instance Eq (NameFlavour flavour) -deriving instance Ord (NameFlavour flavour) - -deriving instance Show (Name ns flavour) -deriving instance Eq (Name ns flavour) -deriving instance Ord (Name ns flavour) - -{------------------------------------------------------------------------------- - Simple functions --------------------------------------------------------------------------------} - -nameBase :: Name ns flavour -> String -nameBase (Name (TH.OccName occ) _) = occ - --- | Modify the unqualified part of the name --- --- Since we often to do this derive one kind of name from another, the --- namespace of the result is not related to the namespace of the argument. -mapNameBase :: (String -> String) -> Name ns flavour -> Name ns' flavour -mapNameBase f (Name (TH.OccName occ) flav) = Name (TH.OccName (f occ)) flav - -{------------------------------------------------------------------------------- - Working with qualified names --------------------------------------------------------------------------------} - -data Qualifier = Unqual | Qual TH.ModName - -qualify :: Qualifier -> String -> Name ns 'Dynamic -qualify Unqual occ = Name (TH.OccName occ) (NameDynamic Nothing) -qualify (Qual m) occ = Name (TH.OccName occ) (NameDynamic (Just m)) - -unqualified :: String -> Name ns 'Dynamic -unqualified = qualify Unqual - -nameQualifier :: Name ns 'Dynamic -> Qualifier -nameQualifier (Name _ (NameDynamic (Just m))) = Qual m -nameQualifier (Name _ (NameDynamic Nothing)) = Unqual - -{------------------------------------------------------------------------------- - Singleton --------------------------------------------------------------------------------} - --- | Singleton type associated with 'Flavour' -data SFlavour :: Flavour -> Type where - SDynamic :: SFlavour 'Dynamic - SUnique :: SFlavour 'Unique - SGlobal :: SFlavour 'Global - -deriving instance Show (SFlavour flavour) - -class IsFlavour flavour where - isFlavour :: SFlavour flavour - -instance IsFlavour 'Dynamic where isFlavour = SDynamic -instance IsFlavour 'Unique where isFlavour = SUnique -instance IsFlavour 'Global where isFlavour = SGlobal - -{------------------------------------------------------------------------------- - Conversion --------------------------------------------------------------------------------} - -toFlavourF :: SFlavour flavour -> TH.NameFlavour -> Maybe (NameFlavour flavour) -toFlavourF SDynamic (TH.NameS) = Just $ NameDynamic Nothing -toFlavourF SDynamic (TH.NameQ m) = Just $ NameDynamic (Just m) -toFlavourF SUnique (TH.NameU u) = Just $ NameUnique u -toFlavourF SGlobal (TH.NameG n p m) = Just $ NameGlobal n p m -toFlavourF _ _ = Nothing - -fromFlavourF :: NameFlavour flavour -> TH.NameFlavour -fromFlavourF (NameDynamic Nothing) = TH.NameS -fromFlavourF (NameDynamic (Just m)) = TH.NameQ m -fromFlavourF (NameUnique u) = TH.NameU u -fromFlavourF (NameGlobal n p m) = TH.NameG n p m - --- | Translate from a dynamically typed TH name --- --- Returns 'Nothing' if the TH name does not have the specified flavour. -fromTH :: IsFlavour flavour => TH.Name -> Maybe (Name ns flavour) -fromTH (TH.Name occ flavour') = Name occ <$> toFlavourF isFlavour flavour' - --- | Variation on 'fromTH' that throws an exception on a flavour mismatch -fromTH' :: forall ns flavour. IsFlavour flavour => TH.Name -> Name ns flavour -fromTH' name@(TH.Name occ flavour') = - fromMaybe (error err) $ fromTH name - where - err :: String - err = concat [ - "fromTH': name " - , show occ - , " has the wrong flavour: " - , show (isFlavour :: SFlavour flavour) - , " /= " - , show flavour' - ] - --- | Forget type level information -toTH :: Name ns flavour -> TH.Name -toTH (Name occ flavour) = TH.Name occ (fromFlavourF flavour) - -{------------------------------------------------------------------------------- - Resolution --------------------------------------------------------------------------------} - -class LookupName ns where - -- | Resolve existing name - lookupName :: Quasi m => Name ns 'Dynamic -> m (Maybe (Name ns 'Global)) - -instance LookupName 'TcClsName where - lookupName (Name occ (NameDynamic mMod)) = - fmap fromTH' <$> - runQ (TH.lookupTypeName $ qualifyDotted mMod occ) - -instance LookupName 'DataName where - lookupName (Name occ (NameDynamic mMod)) = - fmap fromTH' <$> - runQ (TH.lookupValueName $ qualifyDotted mMod occ) - -instance LookupName 'VarName where - lookupName (Name occ (NameDynamic mMod)) = - fmap fromTH' <$> - runQ (TH.lookupValueName $ qualifyDotted mMod occ) - --- | Get info about the given name --- --- Only global names can be reified. See 'lookupName'. -reify :: Quasi m => Name ns 'Global -> m TH.Info -reify = runQ . TH.reify . toTH - -{------------------------------------------------------------------------------- - Fresh names --------------------------------------------------------------------------------} - -newName :: String -> Q (Name ns 'Unique) -newName = fmap fromTH' . TH.newName - -{------------------------------------------------------------------------------- - /Defining/ global names - - Since these are all meant to define capturable names, these functions all take - an 'Dynamic' name as argument. --------------------------------------------------------------------------------} - --- | Define pattern synonym -patSynD :: Name 'DataName 'Dynamic -> _ -patSynD = TH.patSynD . toTH - --- | Define pattern synonym signature -patSynSigD :: Name 'DataName 'Dynamic -> _ -patSynSigD = TH.patSynSigD . toTH - --- | Define function signature -sigD :: Name 'VarName 'Dynamic -> _ -sigD = TH.sigD . toTH - --- | Define record field signature -varBangType :: Name 'VarName 'Dynamic -> _ -varBangType = TH.varBangType . toTH - --- | Define record constructor -recC :: Name 'DataName 'Dynamic -> _ -recC = TH.recC . toTH - --- | Define class -classD :: _ -> Name 'TcClsName 'Dynamic -> _ -classD cxt = TH.classD cxt . toTH - --- | Define newtype -newtypeD :: _ -> Name 'TcClsName 'Dynamic -> _ -newtypeD cxt = TH.newtypeD cxt . toTH - --- | Define record pattern synonym -recordPatSyn :: [String] -> _ -recordPatSyn = TH.recordPatSyn . map (toTH . unqualified) - --- | Define COMPLETE pragma -pragCompleteD :: [Name 'DataName 'Dynamic] -> Maybe (Name 'TcClsName 'Dynamic) -> _ -pragCompleteD constrs typ = - TH.pragCompleteD (toTH <$> constrs) (toTH <$> typ) - --- | Define pattern variable for use in a record pattern synonym -varGlobalP :: Name 'VarName 'Dynamic -> _ -varGlobalP = TH.varP . toTH - --- | Define pattern variable for use in a local pattern match -varLocalP :: Name 'VarName 'Unique -> _ -varLocalP = TH.varP . toTH - -{------------------------------------------------------------------------------- - Referencing existing names - - We can reference any flavour of name. --------------------------------------------------------------------------------} - --- | Reference constructor -conE :: Name 'DataName flavour -> _ -conE = TH.conE . toTH - --- | Reference type -conT :: Name 'TcClsName flavour -> _ -conT = TH.conT . toTH - --- | Reference variable -varE :: Name 'VarName flavour -> _ -varE = TH.varE . toTH - -{------------------------------------------------------------------------------- - Internal auxiliary --------------------------------------------------------------------------------} - --- | Qualify a name (for use in 'lookupTypeName' and co) -qualifyDotted :: Maybe TH.ModName -> TH.OccName -> String -qualifyDotted Nothing (TH.OccName occ) = occ -qualifyDotted (Just (TH.ModName m)) (TH.OccName occ) = m ++ "." ++ occ diff --git a/src/Data/Record/Internal/TH/Util.hs b/src/Data/Record/Internal/TH/Util.hs deleted file mode 100644 --- a/src/Data/Record/Internal/TH/Util.hs +++ /dev/null @@ -1,134 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE PatternSynonyms #-} - --- | Utility functions for working with TH -module Data.Record.Internal.TH.Util ( - -- * Folding - appsT - , arrT - -- * Constructing lists (variations on 'listE') - , vectorE - , plistT - , ptupleT - -- * Simplified construction - , simpleFn - , simplePatSynType - -- * Dealing with type variables - , tyVarName - , tyVarType - -- * Bang - , pattern DefaultBang - -- * Extensions - , requiresExtensions - ) where - -import Control.Monad -import Data.List (intercalate) -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -import qualified Data.Vector as V - -import qualified Data.Record.Internal.TH.Name as N - -{------------------------------------------------------------------------------- - Folding --------------------------------------------------------------------------------} - --- | Repeated application --- --- @appsT f [x1, .., xN]@ constructs something like --- --- > f x1 .. xN -appsT :: Q Type -> [Q Type] -> Q Type -appsT t ts = foldl appT t ts - --- | Repeated application of @(->)@ --- --- @arrT [x1, .., xN] y@ constructs something like --- --- > x1 -> .. -> xN -> y -arrT :: [Q Type] -> Q Type -> Q Type -arrT ts t = foldr (\a b -> arrowT `appT` a `appT` b) t ts - -{------------------------------------------------------------------------------- - Constructing lists (variations on 'listE') --------------------------------------------------------------------------------} - -vectorE :: (a -> Q Exp) -> [a] -> Q Exp -vectorE f elems = [| V.fromList $(listE (map f elems)) |] - -plistT :: [Q Type] -> Q Type -plistT = foldr cons nil - where - nil = promotedNilT - cons t ts = promotedConsT `appT` t `appT` ts - -ptupleT :: [Q Type] -> Q Type -ptupleT ts = appsT (promotedTupleT (length ts)) ts - -{------------------------------------------------------------------------------- - Simplified construction --------------------------------------------------------------------------------} - --- | Construct simple function --- --- @simpleFn n typ body@ constructs something like --- --- > f :: typ --- > f = body -simpleFn :: N.Name 'VarName flavour -> Q Type -> Q Exp -> Q [Dec] -simpleFn fnName qTyp qBody = do - typ <- qTyp - body <- qBody - return [ - SigD fnName' typ - , ValD (VarP fnName') (NormalB body) [] - ] - where - fnName' :: Name - fnName' = N.toTH fnName - --- | Construct simple pattern synonym type --- --- @simplePatSynType xs [t1, .., tn] s@ constructs something like --- --- > pattern foo :: forall xs. t1 -> .. -> tn -> s -simplePatSynType :: [TyVarBndr] -> [Q Type] -> Q Type -> Q PatSynType -simplePatSynType tvars fieldTypes resultType = - forallT tvars (cxt []) - $ forallT [] (cxt []) - $ arrT fieldTypes resultType - -{------------------------------------------------------------------------------- - Dealing with type variables --------------------------------------------------------------------------------} - -tyVarName :: TyVarBndr -> Name -tyVarName (PlainTV n) = n -tyVarName (KindedTV n _) = n - -tyVarType :: TyVarBndr -> Q Type -tyVarType = varT . tyVarName - -{------------------------------------------------------------------------------- - Bang --------------------------------------------------------------------------------} - -pattern DefaultBang :: Bang -pattern DefaultBang = Bang NoSourceUnpackedness NoSourceStrictness - -{------------------------------------------------------------------------------- - Extensions --------------------------------------------------------------------------------} - --- | Check that the specified extensions are enabled --- --- To improve user experience, we report all missing extensions at once (rather --- than giving an error for the first missing one). -requiresExtensions :: Quasi m => [Extension] -> m () -requiresExtensions exts = runQ $ do - disabled <- filterM (fmap not . isExtEnabled) exts - unless (null disabled) $ do - fail $ "Please enable " ++ intercalate ", " (map show disabled) diff --git a/src/Data/Record/Internal/Util.hs b/src/Data/Record/Internal/Util.hs deleted file mode 100644 --- a/src/Data/Record/Internal/Util.hs +++ /dev/null @@ -1,17 +0,0 @@ --- | Miscellaneous utility functions -module Data.Record.Internal.Util ( - -- * Monadic combinators - concatM - , concatMapM - ) where - -{------------------------------------------------------------------------------- - Monadic combinators --------------------------------------------------------------------------------} - -concatM :: Applicative m => [m [a]] -> m [a] -concatM = fmap concat . sequenceA - -concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b] -concatMapM f = concatM . map f - diff --git a/src/Data/Record/Plugin.hs b/src/Data/Record/Plugin.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Plugin.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Support for scalable large records +-- +-- = Usage +-- +-- > {-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} +-- > +-- > {-# ANN type B LargeRecordStrict #-} +-- > data B a = B {a :: a, b :: String} +-- > deriving stock (Show, Eq, Ord) +-- +-- See 'LargeRecordOptions' for the list of all possible annotations. +-- +-- = 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): +-- +-- > {-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -fplugin=Data.Record.Plugin #-} +-- +-- Second, you will want at least version 0.2.14. +module Data.Record.Plugin (plugin) where + +import Control.Monad.Except +import Control.Monad.Trans.Writer.CPS +import Data.List (intersperse) +import Data.Map.Strict (Map) +import Data.Set (Set) +import Data.Traversable (for) +import Language.Haskell.TH (Extension(..)) + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +import Data.Record.Internal.Plugin.CodeGen (genLargeRecord) +import Data.Record.Internal.GHC.Fresh +import Data.Record.Internal.GHC.Shim +import Data.Record.Internal.GHC.TemplateHaskellStyle +import Data.Record.Internal.Plugin.Exception +import Data.Record.Internal.Plugin.Options +import Data.Record.Internal.Plugin.Record + +{------------------------------------------------------------------------------- + Top-level: the plugin proper +-------------------------------------------------------------------------------} + +plugin :: Plugin +plugin = defaultPlugin { + parsedResultAction = aux + , pluginRecompile = purePlugin + } + where + aux :: + [CommandLineOption] + -> ModSummary + -> HsParsedModule -> Hsc HsParsedModule + aux _opts _summary parsed@HsParsedModule{hpm_module = modl} = do + modl' <- transformDecls modl + pure $ parsed { hpm_module = modl' } + +{------------------------------------------------------------------------------- + Transform datatype declarations +-------------------------------------------------------------------------------} + +transformDecls :: LHsModule -> Hsc LHsModule +transformDecls (L l modl@HsModule {hsmodDecls = decls, hsmodImports}) = do + (decls', transformed) <- runWriterT $ for decls $ transformDecl largeRecords + + checkEnabledExtensions l + + -- Check for annotations without corresponding types + let untransformed = Map.keysSet largeRecords `Set.difference` transformed + unless (Set.null untransformed) $ do + issueError l $ vcat $ + text "These large-record annotations were not applied:" + : [text (" - " ++ n) | n <- Set.toList untransformed] + + -- 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 + } + 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 + -> WriterT (Set String) Hsc [LHsDecl GhcPs] +transformDecl largeRecords decl@(L l _) = + case decl of + DataD (nameBase -> name) _ _ _ -> + case Map.findWithDefault [] name largeRecords of + [] -> + -- Not a large record. Leave alone. + return [decl] + (_:_:_) -> do + lift $ issueError l $ text ("Conflicting annotations for " ++ name) + return [decl] + [(annLoc, opts)] -> do + tell (Set.singleton name) + case runExcept (viewRecord annLoc opts decl) of + Left e -> do + lift $ issueError (exceptionLoc e) (exceptionToSDoc e) + -- Return the declaration unchanged if we cannot parse it + return [decl] + Right r -> do + newDecls <- lift $ runFreshHsc $ genLargeRecord r + when (debugLargeRecords opts) $ + lift $ issueWarning l (debugMsg newDecls) + pure newDecls + _otherwise -> + pure [decl] + where + debugMsg :: [LHsDecl GhcPs] -> SDoc + debugMsg newDecls = pprSetDepth AllTheWay $ vcat $ + text "large-records: splicing in the following definitions:" + : map ppr newDecls + +{------------------------------------------------------------------------------- + Check for enabled extensions + + In ghc 8.10 and up there are DynFlags plugins, which we could use to enable + these extensions for the user. Since this is not available in 8.8 however we + will not make use of this for now. (There is also reason to believe that these + may be removed again in later ghc releases.) +-------------------------------------------------------------------------------} + +checkEnabledExtensions :: SrcSpan -> Hsc () +checkEnabledExtensions l = do + dynFlags <- getDynFlags + let missing :: [RequiredExtension] + missing = filter (not . isEnabled dynFlags) requiredExtensions + unless (null missing) $ + -- We issue a warning here instead of an error, for better integration + -- with HLS. Frankly, I'm not entirely sure what's going on there. + issueWarning l $ vcat . concat $ [ + [text "Please enable these extensions for use with large-records:"] + , map ppr missing + ] + where + requiredExtensions :: [RequiredExtension] + requiredExtensions = [ + RequiredExtension [ConstraintKinds] + , RequiredExtension [DataKinds] + , RequiredExtension [ExistentialQuantification, GADTs] + , RequiredExtension [FlexibleInstances] + , RequiredExtension [MultiParamTypeClasses] + , RequiredExtension [ScopedTypeVariables] + , RequiredExtension [TypeFamilies] + , RequiredExtension [UndecidableInstances] + ] + +-- | Required extension +-- +-- The list is used to represent alternative extensions that could all work +-- (e.g., @GADTs@ and @ExistentialQuantification@). +data RequiredExtension = RequiredExtension [Extension] + +instance Outputable RequiredExtension where + ppr (RequiredExtension exts) = hsep . intersperse (text "or") $ map ppr exts + +isEnabled :: DynFlags -> RequiredExtension -> Bool +isEnabled dynflags (RequiredExtension exts) = any (`xopt` dynflags) exts + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +issueError :: SrcSpan -> SDoc -> Hsc () +issueError l errMsg = do + dynFlags <- getDynFlags + throwOneError $ + mkErrMsg dynFlags l neverQualify errMsg + +issueWarning :: SrcSpan -> SDoc -> Hsc () +issueWarning l errMsg = do + dynFlags <- getDynFlags + liftIO $ printOrThrowWarnings dynFlags . listToBag . (:[]) $ + mkWarnMsg dynFlags l neverQualify errMsg diff --git a/src/Data/Record/Plugin/Options.hs b/src/Data/Record/Plugin/Options.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Plugin/Options.hs @@ -0,0 +1,10 @@ +-- | Export 'LargeRecordOptions' for the sake of ANN pragmas +-- +-- This module is added as an export to user code by the plugin. +module Data.Record.Plugin.Options ( + LargeRecordOptions(..) + , largeRecordStrict + , largeRecordLazy + ) where + +import Data.Record.Internal.Plugin.Options diff --git a/src/Data/Record/Plugin/Runtime.hs b/src/Data/Record/Plugin/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Plugin/Runtime.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE ConstraintKinds #-} + +-- | 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) + , Type + , unsafeCoerce + , error + -- * vector + , Vector + , Vector.fromList + , Vector.toList + , Vector.unsafeIndex + , Vector.unsafeUpd + -- * record-hasfield + , GRC.HasField(hasField) + -- * 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 + ) where + +import Data.Coerce (coerce) +import Data.Kind (Constraint, Type) +import Data.Proxy (Proxy(Proxy)) +import Data.Vector (Vector) +import GHC.Exts (Any) +import Unsafe.Coerce (unsafeCoerce) + +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 Data.Vector as Vector +import qualified GHC.Records.Compat as GRC + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +dictFor :: c x => Proxy c -> Proxy x -> LR.Dict c x +dictFor _ _ = LR.Dict + +repFromVector :: Vector Any -> LR.Rep LR.I a +repFromVector = coerce + +repToVector :: LR.Rep LR.I a -> Vector Any +repToVector = coerce + + diff --git a/src/Data/Record/QQ/CodeGen.hs b/src/Data/Record/QQ/CodeGen.hs deleted file mode 100644 --- a/src/Data/Record/QQ/CodeGen.hs +++ /dev/null @@ -1,212 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - --- | Quasi-quoter support for large records --- --- NOTE: The only reason for the existence of this module is that record pattern --- syonyms in @ghc@ are currently not useable: when we declare a record pattern --- synonym, @ghc@ automatically derives field accessors for every field in the --- record. We don't want those accessors: they result in name clashes --- (DuplicateRecordFields does not apply to record pattern synonyms) and, more --- importantly, they result in quadratic code size again. Once the --- @NoFieldSelectors@ language extension is merged (probably @ghc@ 9.2), we --- can reconsider whether this module is still required. --- --- See also: --- --- * --- * -module Data.Record.QQ.CodeGen ( - lr - - -- * Exported for the benefit of tests - , lrExp - , lrPat - ) where - -import Data.List (intercalate) -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import Language.Haskell.TH.Syntax - -import qualified Data.Generics as SYB -import qualified Language.Haskell.Exts as HSE -import qualified Language.Haskell.Meta as HSE.Meta - -import Data.Record.Internal.CodeGen -import Data.Record.Internal.Naming -import Data.Record.Internal.Record -import Data.Record.Internal.TH.Util -import Data.Record.QQ.CodeGen.HSE -import Data.Record.QQ.CodeGen.Parser -import Data.Record.QQ.Runtime.MatchHasField -import Data.Record.TH.CodeGen.Tree - -import qualified Data.Record.Internal.TH.Name as N - -{------------------------------------------------------------------------------- - Top-level quasi-quoter --------------------------------------------------------------------------------} - --- | Construct or match on @large-records@-style records --- --- Example construction usage: --- --- > inOrder :: R Bool --- > inOrder = [lr| MkR { x = 1234, y = [True] } |] --- --- or: --- --- > constructorApp :: R Bool --- > constructorApp = [lr| MkR |] 1234 [True] --- --- Example matching usage: --- --- > projectOne :: T Bool -> Int --- > projectOne [lr| MkT { x = a } |] = a -lr :: QuasiQuoter -lr = QuasiQuoter { - quoteExp = lrExp - , quotePat = lrPat - , quoteType = unsupported - , quoteDec = unsupported - } - where - unsupported :: String -> Q a - unsupported _ = fail "lr can only be used for expressions or patterns" - -{------------------------------------------------------------------------------- - Individual quasi-quoters --------------------------------------------------------------------------------} - -lrExp :: forall m. Quasi m => String -> m Exp -lrExp = \str -> do - exts <- runQ extsEnabled - case parseExp exts str of - Left err -> fail $ parseErr err - Right expr -> construct expr - where - parseExp :: [Extension] -> String -> Either String Exp - parseExp exts str = - case HSE.parseExpWithMode (parseMode exts) str of - HSE.ParseFailed _loc err -> Left err - HSE.ParseOk e -> Right (HSE.Meta.toExp e) - - parseErr :: String -> String - parseErr err = concat [ - "Could not parse expression: " - , map (\c -> if c == '\n' then ' ' else c) err - ] - -lrPat :: forall m. Quasi m => String -> m Pat -lrPat = \str -> do - exts <- runQ extsEnabled - case parsePat exts str of - Left err -> fail $ parseErr err - Right expr -> deconstruct expr - where - parsePat :: [Extension] -> String -> Either String Pat - parsePat exts str = - case HSE.parsePatWithMode (parseMode exts) str of - HSE.ParseFailed _loc err -> Left err - HSE.ParseOk p -> Right (HSE.Meta.toPat (processRecordPuns p)) - - parseErr :: String -> String - parseErr err = concat [ - "Could not parse pattern: " - , map (\c -> if c == '\n' then ' ' else c) err - ] - -{------------------------------------------------------------------------------- - Construction --------------------------------------------------------------------------------} - -construct :: forall m. Quasi m => Exp -> m Exp -construct = \case - ConE constr -> do - constrFn <- resolveKnownHseName nameRecordTypedConstructorFn (fromHseName constr) - runQ $ N.varE constrFn - expr -> - -- Assume this is a record construction expression - SYB.everywhereM (SYB.mkM go) expr - where - go :: Exp -> m Exp - go e = do - mTerm <- parseRecordExp e - case mTerm of - Nothing -> - -- Leave non-record expressions alone - return e - Just NotKnownLargeRecord -> - return e - Just (UnknownFields unknown) -> runQ $ do - reportError $ "Unknown fields: " ++ intercalate ", " unknown - [| undefined |] - Just (ParsedRecordInfo qual Record{..}) -> runQ $ do - appsE $ N.varE (N.qualify qual (nameRecordTypedConstructorFn recordConstr)) - : map mkArg recordFields - - mkArg :: Field (Maybe Exp) -> Q Exp - mkArg Field{..} - | Just e <- fieldVal = return e - | otherwise = do - reportWarning $ "No value for field " ++ fieldName - [| error $ "No value given for field " ++ $(lift fieldName) |] - -{------------------------------------------------------------------------------- - Deconstruction --------------------------------------------------------------------------------} - -deconstruct :: forall m. Quasi m => Pat -> m Pat -deconstruct = \pat -> do - requiresExtensions [TypeApplications, ViewPatterns, DataKinds] - SYB.everywhereM (SYB.mkM go) pat - where - go :: Pat -> m Pat - go p = do - mTerm <- parseRecordPat p - case mTerm of - Nothing -> -- Not a record pattern - return p - Just NotKnownLargeRecord -> - return p - Just (UnknownFields unknown) -> runQ $ do - reportError $ "Unknown fields: " ++ intercalate ", " unknown - return p - Just (ParsedRecordInfo qual r) -> runQ $ - viewP (varE 'viewAtType `appE` recordUndefinedValueE qual r) $ - case recordFields (dropMissingRecordFields r) of - [] -> wildP - fs -> outerViewPat fs - - outerViewPat :: [Field Pat] -> Q Pat - outerViewPat fs = - viewP (varE 'matchHasField) $ - mkTupleP innerViewPat $ nest (MaxTupleElems 2) fs - - innerViewPat :: Field Pat -> Q Pat - innerViewPat f@Field{..} = - viewP - (varE 'fieldNamed `appTypeE` fieldNameT f) - (return fieldVal) - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - -parseMode :: [Extension] -> HSE.ParseMode -parseMode exts = HSE.defaultParseMode { - HSE.extensions = concat [ - -- Include extensions enabled in the module - map extensionFromTH exts - - -- But also include the default - -- - -- We do this primarily because 'fromTH' doesn't actually parse - -- all extensions - , HSE.extensions HSE.defaultParseMode - ] - } diff --git a/src/Data/Record/QQ/CodeGen/HSE.hs b/src/Data/Record/QQ/CodeGen/HSE.hs deleted file mode 100644 --- a/src/Data/Record/QQ/CodeGen/HSE.hs +++ /dev/null @@ -1,84 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} - --- | Additional utilities for working with @haskell-src-exts@ -module Data.Record.QQ.CodeGen.HSE ( - -- * Language extensions - extensionFromTH - , processRecordPuns - -- * Naming - , fromHseName - , resolveHseName - , resolveKnownHseName - ) where - -import Data.Generics -import Language.Haskell.Exts -import Language.Haskell.TH.Syntax (Quasi) - -import qualified Language.Haskell.TH.Syntax as TH - -import qualified Data.Record.Internal.TH.Name as N - -{------------------------------------------------------------------------------- - Language extensions --------------------------------------------------------------------------------} - --- | Translate TH extension into HSE extension --- --- Useful in combination with 'extsEnabled'. -extensionFromTH :: TH.Extension -> Extension -extensionFromTH = \case - TH.DataKinds -> EnableExtension $ DataKinds - TH.RecordPuns -> EnableExtension $ NamedFieldPuns - TH.TypeApplications -> EnableExtension $ TypeApplications - TH.ViewPatterns -> EnableExtension $ ViewPatterns - - -- We don't care about all extensions; there are many of them, and they vary - -- from ghc version to ghc version. Treating them all would be a lot of work - -- for little benefit. We assume that calling @show@ gives us a valid - -- extension name; by and large this seems to be true (though for instance - -- it will give us 'RecordPuns' rather than 'NamedFieldPuns', which although - -- valid, is deprecated). - e -> UnknownExtension $ show e - -processRecordPuns :: forall l. Data l => Pat l -> Pat l -processRecordPuns = everywhere (mkT go) - where - go :: PatField l -> PatField l - go (PFieldPun pLoc n@(UnQual nLoc n')) = PFieldPat pLoc n (PVar nLoc n') - go p = p - -{------------------------------------------------------------------------------- - Naming --------------------------------------------------------------------------------} - --- | HSE generated names are always dynamically bound -fromHseName :: TH.Name -> N.Name flavour 'N.Dynamic -fromHseName = N.fromTH' - --- | Resolve HSE generated name --- --- As mentioned in 'fromHseName', HSE generated names are always dynamically --- bound, and we therefore need to do a "renaming pass": we need to resolve the --- name. However, the exact name we want to lookup might not be the name as it --- appears in the QQ place; for if the user writes @MkR@, the name we actually --- want to look up might be, say, @LR__MkR@. -resolveHseName :: (Quasi m, N.LookupName ns') - => (String -> String) - -> N.Name ns 'N.Dynamic - -> m (Maybe (N.Name ns' 'N.Global)) -resolveHseName f = N.lookupName . N.mapNameBase f - --- | Variation on 'resolveHseName' that fails if the name is not known -resolveKnownHseName :: (Quasi m, N.LookupName ns') - => (String -> String) - -> N.Name ns 'N.Dynamic - -> m (N.Name ns' 'N.Global) -resolveKnownHseName f n = do - mn' <- resolveHseName f n - case mn' of - Just n' -> return n' - Nothing -> fail $ "resolveKnownHseName: " ++ N.nameBase n ++ " not in scope" diff --git a/src/Data/Record/QQ/CodeGen/Parser.hs b/src/Data/Record/QQ/CodeGen/Parser.hs deleted file mode 100644 --- a/src/Data/Record/QQ/CodeGen/Parser.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Data.Record.QQ.CodeGen.Parser ( - ParsedRecordInfo(..) - , parseRecordExp - , parseRecordPat - ) where - -import Data.Bifunctor -import Language.Haskell.TH (Exp(RecConE), Pat(RecP)) -import Language.Haskell.TH.Syntax (Quasi, NameSpace(..)) - -import qualified Language.Haskell.TH.Syntax as TH - -import Data.Record.Internal.Naming -import Data.Record.Internal.Record -import Data.Record.Internal.Record.Resolution -import Data.Record.QQ.CodeGen.HSE - -import qualified Data.Record.Internal.TH.Name as N - -data ParsedRecordInfo a = - -- | The pattern/value we matched against is not a (known) large record - NotKnownLargeRecord - - -- | The pattern/value has fields not present in the record definition - | UnknownFields [String] - - -- | Successfully matched against a known large records - -- - -- Note that not all fields may have a corresponding value/pattern. - -- - -- In addition to the record info, we also record the qualifier used in - -- the original name. - | ParsedRecordInfo N.Qualifier (Record (Maybe a)) - -parseRecordExp :: Quasi m => Exp -> m (Maybe (ParsedRecordInfo Exp)) -parseRecordExp = traverse (uncurry parseRecordInfo) . termExp - -parseRecordPat :: Quasi m => Pat -> m (Maybe (ParsedRecordInfo Pat)) -parseRecordPat = traverse (uncurry parseRecordInfo) . termPat - --- | Try to match a pattern or expression against a (large) record -parseRecordInfo :: - forall m a. Quasi m - => N.Name 'DataName 'N.Dynamic - -> [(String, a)] - -> m (ParsedRecordInfo a) -parseRecordInfo userConstr fields = do - mInternalConstr <- resolveHseName nameRecordInternalConstr userConstr - case mInternalConstr of - Nothing -> - return NotKnownLargeRecord - Just internalConstr -> - aux <$> resolveRecord (N.nameBase userConstr) internalConstr - where - aux :: Either String (Record ()) -> ParsedRecordInfo a - aux (Left _err) = NotKnownLargeRecord - aux (Right r) = - case matchRecordFields fields r of - (r', []) -> ParsedRecordInfo (N.nameQualifier userConstr) (snd <$> r') - (_ , un) -> UnknownFields un - -{------------------------------------------------------------------------------- - Match against the syntax tree generated by @haskell-src-exts@ - - We ignore any qualifiers for field names. --------------------------------------------------------------------------------} - -termExp :: Exp -> Maybe (N.Name 'DataName 'N.Dynamic, [(String, TH.Exp)]) -termExp (RecConE constr fields) = Just ( - fromHseName constr - , map (first TH.nameBase) fields - ) -termExp _otherwise = Nothing - -termPat :: Pat -> Maybe (N.Name 'DataName 'N.Dynamic, [(String, TH.Pat)]) -termPat (RecP constr fields) = Just ( - fromHseName constr - , map (first TH.nameBase) fields - ) -termPat _otherwise = Nothing - diff --git a/src/Data/Record/QQ/Runtime/MatchHasField.hs b/src/Data/Record/QQ/Runtime/MatchHasField.hs deleted file mode 100644 --- a/src/Data/Record/QQ/Runtime/MatchHasField.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- | Infrastructure for supporting matching on records --- --- We are be careful not to reintroduce quadratic code size here. -module Data.Record.QQ.Runtime.MatchHasField ( - MatchHasField -- opaque - , matchHasField - , fieldNamed - , viewAtType - ) where - -import Data.Kind -import GHC.Records.Compat -import GHC.TypeLits - -{------------------------------------------------------------------------------- - Infrastructure --------------------------------------------------------------------------------} - --- | Pattern match on 'HasField' --- --- This is intended to be used together with 'matchHasField'. Example usage: --- --- > data Foo a --- > --- > instance HasField "fooX" (Foo a) Int where .. --- > instance HasField "fooY" (Foo a) [a] where .. --- > --- > _example :: Foo Char -> (Int, [Char]) --- > _example (matchHasField -> ( fieldNamed @"fooX" -> x --- > , fieldNamed @"fooY" -> y --- > ) ) = (x, y) -class MatchHasField a b | b -> a where - matchHasField :: a -> b - --- | To be used in conjunction with 'MatchHasField'. --- --- See 'MatchHasField' for details. -fieldNamed :: GetField x r a -> a -fieldNamed (GetField a) = a - -data GetField (x :: Symbol) (r :: Type) (a :: Type) = GetField a - -instance HasField x r a => MatchHasField r (GetField x r a) where - matchHasField = GetField . (getField @x) - -instance (MatchHasField a b, MatchHasField a c) => MatchHasField a (b, c) where - matchHasField r = (matchHasField r, matchHasField r) - --- | Can be used alongside 'matchHasField' to fix the type of the argument --- --- This avoids inferring types in terms of @HasField ..@; see example below. -viewAtType :: a -> a -> a -viewAtType = const id - -{------------------------------------------------------------------------------- - Example --------------------------------------------------------------------------------} - -data Foo a = MkFoo - -instance HasField "fooX" (Foo a) Int where hasField = undefined -instance HasField "fooY" (Foo a) [a] where hasField = undefined - -_example1 :: (HasField "fooX" a b, HasField "fooY" a c) => a -> (b, c) -_example1 (matchHasField -> ( fieldNamed @"fooX" -> x - , fieldNamed @"fooY" -> y - ) ) = (x, y) - -_example2 :: Foo a -> (Int, [a]) -- This is the inferred signature -_example2 (viewAtType MkFoo -> matchHasField -> ( fieldNamed @"fooX" -> x - , fieldNamed @"fooY" -> y - ) ) = (x, y) diff --git a/src/Data/Record/TH.hs b/src/Data/Record/TH.hs deleted file mode 100644 --- a/src/Data/Record/TH.hs +++ /dev/null @@ -1,7 +0,0 @@ -module Data.Record.TH ( - module X - ) where - -import Data.Record.QQ.CodeGen as X (lr) -import Data.Record.TH.CodeGen as X (largeRecord) -import Data.Record.TH.Config.Options as X diff --git a/src/Data/Record/TH/CodeGen.hs b/src/Data/Record/TH/CodeGen.hs deleted file mode 100644 --- a/src/Data/Record/TH/CodeGen.hs +++ /dev/null @@ -1,758 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} - --- | Code generation -module Data.Record.TH.CodeGen ( - largeRecord - ) where - -import Data.List (nub) -import Data.Maybe (catMaybes) -import Data.Proxy -import Data.Vector (Vector) -import GHC.Exts (Any) -import GHC.Records.Compat -import Language.Haskell.TH -import Language.Haskell.TH.Syntax (NameSpace(..)) - -import qualified Data.Generics as SYB -import qualified Data.Kind as Kind -import qualified Data.Vector as V -import qualified GHC.Generics as GHC -import qualified Language.Haskell.TH.Syntax as TH - -import Data.Record.Generic -import Data.Record.Generic.Eq -import Data.Record.Generic.GHC -import Data.Record.Generic.Show - -import Data.Record.Internal.CodeGen -import Data.Record.Internal.Naming -import Data.Record.Internal.Record -import Data.Record.Internal.Record.Parser -import Data.Record.Internal.Record.Resolution.Internal (putRecordInfo) -import Data.Record.Internal.TH.Util -import Data.Record.Internal.Util -import Data.Record.TH.CodeGen.Tree -import Data.Record.TH.Config.Options -import Data.Record.TH.Runtime - -import qualified Data.Record.Generic.Rep.Internal as Rep -import qualified Data.Record.Internal.TH.Name as N - -{------------------------------------------------------------------------------- - Public API --------------------------------------------------------------------------------} - --- | Declare a large record --- --- Example usage: --- --- > largeRecord defaultPureScript [d| --- > data R a = MkR { x :: Int, y :: [a] } deriving (Eq, Show) --- > data S a = S { x :: Int, y :: [a] } deriving (Eq, Show) --- > |] -largeRecord :: Options -> Q [Dec] -> Q [Dec] -largeRecord opts decls = do - rs <- mapM parseRecordDef . dropUniques =<< decls - concatMapM (genAll opts) (catMaybes rs) - -{------------------------------------------------------------------------------- - Top-level --------------------------------------------------------------------------------} - --- | Generate all definitions -genAll :: Options -> (Record (), RecordInstances) -> Q [Dec] -genAll opts@Options{..} (r, instances) = do - putRecordInfo r - concatM $ [ - (:[]) <$> genNewtype opts r instances - , genIndexedAccessor opts r - , genIndexedOverwrite opts r - , when generateHasFieldInstances $ [ - genHasFieldInstances opts r - ] - -- If we generate the pattern synonym, there is no need to generate - -- field accessors, because GHC will generate them from the synonym - , when (generateFieldAccessors && not generatePatternSynonym) $ [ - genFieldAccessors opts r - ] - , when generateConstructorFn [ - genConstructorFn opts r - ] - , when generatePatternSynonym $ [ - genRecordView opts r - , genPatSynonym opts r - ] - , genGenericInstance opts r instances - , genGhcGenericsInstances opts r - ] - where - when :: Bool -> [Q [Dec]] -> Q [Dec] - when False _ = return [] - when True gen = concatM gen - -{------------------------------------------------------------------------------- - Generation: the type itself - - NOTE: All generation exampleshask assume as example - - > data T a b = MkT { - > tWord :: Word - > , tBool :: Bool - > , tChar :: Char - > , tA :: a - > , tListB :: [b] - > } - > deriving (Eq, Show) --------------------------------------------------------------------------------} - --- | Generate the newtype that will represent the record --- --- Generates something like --- --- > newtype T a b = TFromVector {vectorFromT :: Vector Any} --- > deriving anyclass C -- where applicable -genNewtype :: Options -> Record () -> RecordInstances -> Q Dec -genNewtype _opts Record{..} RecordInstances{recordInstancesAnyclass} = - N.newtypeD - (cxt []) - (N.unqualified recordType) - recordTVars - Nothing - (N.recC (N.unqualified (nameRecordInternalConstr recordConstr)) [ - N.varBangType (N.unqualified (nameRecordInternalField recordType)) $ - bangType (return DefaultBang) [t| Vector Any |] - ]) - (map anyclassDerivClause recordInstancesAnyclass) - where - anyclassDerivClause :: Type -> DerivClauseQ - anyclassDerivClause clss = derivClause (Just AnyclassStrategy) [pure clss] - -{------------------------------------------------------------------------------- - Generation: field accessors - - TODO: If we had support within GHC itself for accessing fields in records, - we might be able to integrate this a lot more closely with normal GHC, - especially when combined with the @NoFieldSelectors@ extension. - - See --------------------------------------------------------------------------------} - --- | Generate the indexed field accessor --- --- Generates something like --- --- > unsafeGetIndexT :: forall x a b. Int -> T a b -> x --- > unsafeGetIndexT = \ n t -> noInlineUnsafeCo (V.unsafeIndex (vectorFromT t) n) - -genIndexedAccessor :: Options -> Record () -> Q [Dec] -genIndexedAccessor _opts r@Record{..} = do - x <- newName "x" - simpleFn - (N.unqualified (nameRecordIndexedAccessor recordType)) - (forallT - (PlainTV x : recordTVars) - (cxt []) - (arrT [conT ''Int, recordTypeT N.Unqual r] (varT x))) - [| \n t -> noInlineUnsafeCo $ - V.unsafeIndex ($(recordToVectorE N.Unqual r) t) n - |] - --- | Generate index field overwrite --- --- Generates something like --- --- > unsafeSetIndexT :: forall x a b. Int -> T a b -> x -> T a b --- > unsafeSetIndexT = \n t val -> --- > TFromVector (V.unsafeUpd (vectorFromT t) [(n, noInlineUnsafeCo val)]) --- --- If using 'allFieldsStrict', the function will be strict in @val@. --- --- TODO: We should support per-field strictness. -genIndexedOverwrite :: Options -> Record () -> Q [Dec] -genIndexedOverwrite Options{..} r@Record{..} = do - x <- newName "x" - simpleFn - (N.unqualified (nameRecordIndexedOverwrite recordType)) - (forallT - (PlainTV x : recordTVars) - (cxt []) - (arrT - [conT ''Int, recordTypeT N.Unqual r, varT x] - (recordTypeT N.Unqual r)) - ) - body - where - body :: Q Exp - body - | allFieldsStrict = - [| \n t !val -> $(recordFromVectorDontForceE N.Unqual r) ( - V.unsafeUpd ($(recordToVectorE N.Unqual r) t) - [(n, noInlineUnsafeCo val)] - ) - |] - | otherwise = - [| \n t val -> $(recordFromVectorDontForceE N.Unqual r) ( - V.unsafeUpd ($(recordToVectorE N.Unqual r) t) - [(n, noInlineUnsafeCo val)] - ) - |] - --- | Generate field accessors for all fields -genFieldAccessors :: Options -> Record () -> Q [Dec] -genFieldAccessors opts r@Record{..} = - concatMapM (genFieldAccessor opts r) recordFields - --- | Generate accessor for single field --- --- Generates function such as --- --- > tWord :: forall a b. T a b -> Word --- > tWord = unsafeGetIndexT 0 -genFieldAccessor :: Options -> Record () -> Field () -> Q [Dec] -genFieldAccessor _opts r@Record{..} f@Field{..} = do - simpleFn - (N.unqualified fieldName) - (forallT recordTVars (cxt []) $ - arrT [recordTypeT N.Unqual r] (fieldTypeT f)) - (fieldUntypedAccessorE N.Unqual r f) - --- | Generate 'HasField' instances for all fields -genHasFieldInstances :: Options -> Record () -> Q [Dec] -genHasFieldInstances opts r@Record{..} = - mapM (genHasFieldInstance opts r) recordFields - --- | Generate 'HasField' instance for single field --- --- Generates something like --- --- > instance x ~ Word => HasField "tInt" (T a b) x where --- > hasField = \t -> (unsafeSetIndexT 0 t, unsafeGetIndexT 0 t) -genHasFieldInstance :: Options -> Record () -> Field () -> Q Dec -genHasFieldInstance _opts r f@Field{..} = do - requiresExtensions [ - DataKinds - , FlexibleInstances - , MultiParamTypeClasses - , TypeFamilies - , UndecidableInstances - ] - x <- newName "x" - instanceD - (cxt [equalityT `appT` varT x `appT` fieldTypeT f]) - (appsT (conT ''HasField) [ - fieldNameT f - , recordTypeT N.Unqual r - , varT x - ]) - [valD (varP 'hasField) (normalB [| - \t -> ( $(fieldUntypedOverwriteE N.Unqual r f) t - , $(fieldUntypedAccessorE N.Unqual r f) t - ) - |]) []] - -{------------------------------------------------------------------------------- - Generation: constructor function --------------------------------------------------------------------------------} - --- | Construct a value of the record --- --- Generates something like --- --- > \tWord' tBool' tChar' tA' tListB' -> (..) (V.fromList [ --- > , noInlineUnsafeCo tWord' --- > , noInlineUnsafeCo tBool' --- > , noInlineUnsafeCo tChar' --- > , noInlineUnsafeCo tA' --- > , noInlineUnsafeCo tListB' --- > ]) --- --- where the " constructor " on the @"(..)"@ is generated by --- 'recordFromUnforcedVectorQ', so that we correctly deal with strict/non-strict --- fields. --- --- However, this function is slightly more general than this, generalizing over --- the "kind of lambda" we want to construct. We use this both in --- 'genPatSynonym' and in 'genConstructorFn'. -genRecordVal :: Options -> Record () -> ([Q Pat] -> Q Exp -> Q a) -> Q a -genRecordVal opts r@Record{..} mkFn = do - -- The constructor arguments are locally bound, and should not have the - -- same name as the fields themselves - vars <- mapM (N.newName . fieldName) recordFields - mkFn (map N.varLocalP vars) [| - $(recordFromVectorForceStrictFieldsE opts r) - $(vectorE qNoInlineUnsafeCo vars) - |] - where - qNoInlineUnsafeCo :: N.Name 'VarName 'N.Unique -> Q Exp - qNoInlineUnsafeCo x = [| noInlineUnsafeCo $(N.varE x) |] - --- | Generate constructor function --- --- Generates something like --- --- > mkT :: forall a b. Word -> Bool -> Char -> a -> [b] -> T a b --- > mkT = .. --- --- where the body of @mkT@ is generated by 'genRecordVal'. -genConstructorFn :: Options -> Record () -> Q [Dec] -genConstructorFn opts r@Record{..} = do - simpleFn - (N.unqualified (nameRecordTypedConstructorFn recordConstr)) - (forallT recordTVars (cxt []) $ - arrT - (map fieldTypeT recordFields) - (recordTypeT N.Unqual r) - ) - (genRecordVal opts r lamE) - -{------------------------------------------------------------------------------- - Generation: type-level metadata --------------------------------------------------------------------------------} - --- | Generate type-level metadata --- --- Generates something like --- --- > type MetadataOf (T a b) = '[ --- > '("tInt", Word), --- > , '("tBool", Bool), --- > , '("tChar", Char), --- > , '("tA", a), --- > , '("tListB", [b]) --- > ] --- --- NOTE: We do not use type-level lists in most places, since it's difficult --- to avoid quadratic core code size when working with type-level list. We use --- this meta-data currently for two purposes only: --- --- * The 'lr' quasi-quoter uses it as a way to lookup the record definition. --- See "Data.Record.Internal.RecordInfo.Resolution.GHC". --- * We use it to put a constraint on 'normalize'; this constraint is carefully --- defined to avoid quadratic core code size. --- See "Data.Record.Generic.Transform". -genInstanceMetadataOf :: Options -> Record () -> Q Dec -genInstanceMetadataOf _opts r@Record{..} = tySynInstD $ - tySynEqn - Nothing - [t| MetadataOf $(recordTypeT N.Unqual r) |] - (plistT $ map fieldMetadata recordFields) - where - fieldMetadata :: Field () -> Q Type - fieldMetadata f = ptupleT [fieldNameT f, fieldTypeT f] - -{------------------------------------------------------------------------------- - Generation: pattern synonym --------------------------------------------------------------------------------} - --- | Generate view on the record --- --- Generates function such as --- --- > tupleFromT :: forall a b. T a b -> (Word, Bool, Char, a, [b]) --- > tupleFromT = \x -> ( --- > unsafeGetIndexT 0 x --- > , unsafeGetIndexT 1 x --- > , unsafeGetIndexT 2 x --- > , unsafeGetIndexT 3 x --- > , unsafeGetIndexT 4 x --- > ) --- --- Modulo tuple nesting (see 'nest'). -genRecordView :: Options -> Record () -> Q [Dec] -genRecordView _opts r@Record{..} = do - simpleFn - (N.unqualified (nameRecordView recordType)) - (forallT recordTVars (cxt []) $ - arrT [recordTypeT N.Unqual r] viewType - ) - viewBody - where - viewType :: Q Type - viewType = mkTupleT fieldTypeT $ - nest DefaultGhcTupleLimit recordFields - - viewBody :: Q Exp - viewBody = do - x <- newName "x" - lamE [varP x] $ mkTupleE (viewField x) $ - nest DefaultGhcTupleLimit recordFields - - -- We generate the view only if we are generating the pattern synonym, - -- but when we do we don't generate the typed accessors, because they - -- are instead derived from the pattern synonym by GHC. Since the synonym - -- requires the view, we therefore use the untyped accessor here. - viewField :: Name -> Field () -> Q Exp - viewField x f = [| $(fieldUntypedAccessorE N.Unqual r f) $(varE x) |] - --- | Generate pattern synonym --- --- Constructs something like this: --- --- > pattern MkT :: forall a b. Word -> Bool -> Char -> a -> [b] -> T a b --- > pattern MkT{tWord, tBool, tChar, tA, tListB} <- --- > (tupleFromT -> (tWord, tBool, tChar, tA, tListB) ) --- > where --- > MkT tWord' tBool' tChar' tA' tListB' = .. --- > --- > {-# COMPLETE MkT #-} --- --- modulo nesting ('nest'), where the body of 'MkT' (and its arguments) are --- constructed by 'genRecordVal'. -genPatSynonym :: Options -> Record () -> Q [Dec] -genPatSynonym opts r@Record{..} = do - requiresExtensions [PatternSynonyms, ViewPatterns] - sequence [ - N.patSynSigD (N.unqualified recordConstr) $ - simplePatSynType - recordTVars - (map fieldTypeT recordFields) - (recordTypeT N.Unqual r) - , N.patSynD (N.unqualified recordConstr) - (N.recordPatSyn $ map fieldName recordFields) - qDir - matchVector - , N.pragCompleteD [N.unqualified recordConstr] Nothing - ] - where - matchVector :: Q Pat - matchVector = viewP (N.varE (N.unqualified (nameRecordView recordType))) $ - mkTupleP (N.varGlobalP . N.unqualified . fieldName) $ - nest DefaultGhcTupleLimit recordFields - - constrVector :: [Q Pat] -> Q Exp -> Q Clause - constrVector xs body = clause xs (normalB body) [] - - qDir :: Q PatSynDir - qDir = explBidir . (:[]) $ genRecordVal opts r constrVector - -{------------------------------------------------------------------------------- - Generation: Generic instance --------------------------------------------------------------------------------} - --- | Generate the class we will use to instantiate 'Constraints' --- --- Generates something like this: --- --- > class Constraints_T a b (c :: Type -> Constraint) where --- > dictConstraints_T :: Proxy c -> Rep (Dict c) (T a b) --- --- NOTE: It is critical that we don't give the class any superclass constraints --- like --- --- > class (c Word, c Bool, c Char, c a, c [b]) --- > => Constraints_T a b (c :: Type -> Constraint) --- --- because then @ghc@ would use resolve @Constraints_T@ to that tuple instead, --- 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 :: Options -> Record () -> Q Dec -genConstraintsClass _opts r@Record{..} = do - requiresExtensions [KindSignatures, ConstraintKinds] - c <- newName "c" - k <- [t| Kind.Type -> Kind.Constraint |] - N.classD - (cxt []) - (N.unqualified (nameRecordConstraintsClass recordType)) - (recordTVars ++ [KindedTV c k]) - [] - [ N.sigD (N.unqualified (nameRecordConstraintsMethod recordType)) [t| - Proxy $(varT c) -> Rep (Dict $(varT c)) $(recordTypeT N.Unqual r) - |] - ] - --- | Superclass constraints required by the constraints class instance --- --- Generates something like --- --- > (c Word, c Bool, c Char, c a, c [b]) --- --- However, we filter out constraints that are type variable free, so if we --- pass, say, @Show@ for @c@, then we generate --- --- > (Show a, Show [b]) --- --- instead. This avoids @ghc@ complaining about --- --- > Redundant constraints: (Show Word, Show Bool, Show Char) -genRequiredConstraints :: Options -> Record () -> Q Type -> Q Cxt -genRequiredConstraints _opts Record{..} c = do - requiresExtensions [FlexibleContexts] - constraints <- mapM constrainField recordFields - return $ nub $ filter hasTypeVar constraints - where - constrainField :: Field () -> Q Pred - constrainField f = c `appT` fieldTypeT f - - hasTypeVar :: Pred -> Bool - hasTypeVar = SYB.everything (||) (SYB.mkQ False isTypeVar) - - isTypeVar :: Type -> Bool - isTypeVar (VarT _) = True - isTypeVar _otherwise = False - --- | Generate the dictionary creation function ('dict') --- --- Generates something like --- --- > \p -> Rep (V.fromList [ --- > noInlineUnsafeCo (dictFor p (Proxy :: Proxy Word)) --- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Bool)) --- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Char)) --- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy a)) --- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy [b])) --- > ]) -genDict :: Options -> Record () -> Q Exp -genDict _opts Record{..} = do - p <- newName "p" - lamE [varP p] [| Rep $(vectorE (dictForField p) recordFields) |] - where - dictForField :: Name -> Field () -> Q Exp - dictForField p f = [| - noInlineUnsafeCo (dictFor $(varE p) (Proxy :: Proxy $(fieldTypeT f))) - |] - --- | Generate (one and only) instance of the constraints class --- --- Generates something like --- --- > instance (..) => Constraints_T a b c where --- > dictConstraints_T = .. --- --- where the body of @dictConstraints_T@ is generated by 'genDict'. -genConstraintsClassInstance :: Options -> Record () -> Q Dec -genConstraintsClassInstance opts r@Record{..} = do - requiresExtensions [ScopedTypeVariables] - c <- newName "c" - instanceD - (genRequiredConstraints opts r (varT c)) - (appsT (N.conT (N.unqualified (nameRecordConstraintsClass recordType))) $ - map tyVarType recordTVars ++ [varT c]) - [ valD (N.varGlobalP (N.unqualified (nameRecordConstraintsMethod recordType))) - (normalB (genDict opts r)) - [] - ] - --- | Generate the Constraints type family instance --- --- Generates something like --- --- > type Constraints (T a b) = Constraints_T a b -genInstanceConstraints :: Options -> Record () -> Q Dec -genInstanceConstraints _opts r@Record{..} = tySynInstD $ - tySynEqn - Nothing - [t| Constraints $(recordTypeT N.Unqual r) |] - (appsT (N.conT (N.unqualified (nameRecordConstraintsClass recordType))) $ - map tyVarType recordTVars) - --- | Generate metadata --- --- Generates something like --- --- > \_p -> Metadata { --- > recordName = "T" --- > , recordConstructor = "MkT" --- > , recordSize = 5 --- > , recordFieldMetadata = Rep $ Data.Vector.fromList [ --- > FieldMetadata (Proxy :: Proxy "tInt")) FieldLazy --- > , FieldMetadata (Proxy :: Proxy "tBool")) FieldLazy --- > , FieldMetadata (Proxy :: Proxy "tChar")) FieldLazy --- > , FieldMetadata (Proxy :: Proxy "tA")) FieldLazy --- > , FieldMetadata (Proxy :: Proxy "tListB")) FieldLazy --- > ] --- > } -genMetadata :: Options -> Record () -> Q Exp -genMetadata Options{..} r@Record{..} = do - p <- newName "_p" - lamE [varP p] $ recConE 'Metadata [ - fieldExp 'recordName $ recordTypeE r - , fieldExp 'recordConstructor $ recordConstrE r - , fieldExp 'recordSize $ litE (integerL numFields) - , fieldExp 'recordFieldMetadata $ [| Rep.Rep $ V.fromList $fieldMetadata |] - ] - where - numFields :: Integer - numFields = fromIntegral $ length recordFields - - fieldMetadata :: Q Exp - fieldMetadata = listE $ map mkFieldMetadata recordFields - - mkFieldMetadata :: Field () -> ExpQ - mkFieldMetadata f = [| - FieldMetadata - (Proxy :: Proxy $(fieldNameT f) ) - $(if allFieldsStrict - then [| FieldStrict |] - else [| FieldLazy |]) - |] - --- | Generate instance for specific class --- --- Generates one of the following: --- --- * 'Show': --- --- > instance (..) => Eq (T a b) where --- > (==) = geq --- --- * 'Eq': --- --- > instance (..) => Show (T a b) where --- > showsPrec = gshowsPrec --- --- where the @(..)@ constraints are generated by 'genRequiredConstraints' --- (i.e., a constraint for each field). --- --- TODO: Think about DeriveFunctor? -genDeriving :: Options -> Record () -> Deriving -> Q Dec -genDeriving opts r = \case - DeriveEq -> inst ''Eq '(==) 'geq - DeriveOrd -> inst ''Ord 'compare 'gcompare - DeriveShow -> inst ''Show 'showsPrec 'gshowsPrec - where - inst :: Name -> Name -> Name -> Q Dec - inst clss fn gfn = - instanceD - (genRequiredConstraints opts r (conT clss)) - [t| $(conT clss) $(recordTypeT N.Unqual r) |] - [valD (varP fn) (normalB (varE gfn)) []] - --- | Generate definition for `from` in the `Generic` instance --- --- Generates something like --- --- > repFromVectorStrict . vectorFromT -genFrom :: Options -> Record () -> Q Exp -genFrom _opts Record{..} = [| - repFromVector - . $(N.varE (N.unqualified (nameRecordInternalField recordType))) - |] - --- | Generate definition for `to` in the `Generic` instance --- --- > (..) . repToVector --- --- where the @(..)@ is generated by 'recordFromVectorForceStrictFieldsE' --- (which will any strict fields in the vector). -genTo :: Options -> Record () -> Q Exp -genTo opts r = [| - $(recordFromVectorForceStrictFieldsE opts r) - . repToVector - |] - --- | Generate the definitions required to provide the instance for 'Generic' --- --- > instance Generic T where --- > type Constraints T = Constraints_T --- > from = coerce --- > to = coerce --- > dict = dictConstraints_T --- > metadata = .. -genGenericInstance :: Options -> Record () -> RecordInstances -> Q [Dec] -genGenericInstance opts r@Record{..} RecordInstances{recordInstancesDerived} = - concatM [ - sequence [ - genConstraintsClass opts r - , genConstraintsClassInstance opts r - , instanceD - (cxt []) - [t| Generic $(recordTypeT N.Unqual r) |] - [ genInstanceConstraints opts r - , genInstanceMetadataOf opts r - , valD (varP 'from) (normalB $ genFrom opts r) [] - , valD (varP 'to) (normalB $ genTo opts r) [] - , valD (varP 'dict) (normalB $ N.varE . N.unqualified . nameRecordConstraintsMethod $ recordType) [] - , valD (varP 'metadata) (normalB $ genMetadata opts r) [] - ] - ] - , mapM (genDeriving opts r) recordInstancesDerived - ] - -{------------------------------------------------------------------------------- - GHC generics --------------------------------------------------------------------------------} - --- | Generate GHC generics instance --- --- Generates something like --- --- > instance GHC.Generic ExampleRecord where --- > type Rep ExampleRecord = ThroughLRGenerics ExampleRecord --- > --- > from = WrapThroughLRGenerics --- > to = unwrapThroughLRGenerics --- --- See 'ThroughLRGenerics' for documentation. - -genGhcGenericsInstances :: Options -> Record () -> Q [Dec] -genGhcGenericsInstances _opts r = sequenceA [ - instanceD - (cxt []) - [t| GHC.Generic $(recordTypeT N.Unqual r) |] - [ tySynInstD $ - tySynEqn - Nothing - [t| GHC.Rep $(recordTypeT N.Unqual r) |] - [t| ThroughLRGenerics $(recordTypeT N.Unqual r) |] - , valD (varP 'GHC.from) (normalB (conE 'WrapThroughLRGenerics)) [] - , valD (varP 'GHC.to) (normalB (varE 'unwrapThroughLRGenerics)) [] - ] - ] - -{------------------------------------------------------------------------------- - Auxiliary --------------------------------------------------------------------------------} - --- | Construct record from the underlying @Vector Any@, forcing strict fields --- --- Currently either /all/ fields are strict or /none/, so we either just force --- all fields, or none of them. --- --- See also 'recordFromVectorDontForceE'. -recordFromVectorForceStrictFieldsE :: Options -> Record () -> Q Exp -recordFromVectorForceStrictFieldsE Options{..} r - | allFieldsStrict = [| - \v -> rnfVectorAny v `seq` $(recordFromVectorDontForceE N.Unqual r) v - |] - | otherwise = - recordFromVectorDontForceE N.Unqual r - -{------------------------------------------------------------------------------- - Fix TH naming - - TH distinguishes between global names (names from an explicit package/module), - dynamically bound names that are resolved and bound after splicing in, and - unique names, that are meant to be different from all other names. - - Specifically, 'mkName' is intended to create names that are meant to be - capturable after splicing; 'mkName' generates dynamic names. - - For some strange reason however binder names of declarations in a @[d| ... |]@ - splice are given a unique name rather than a dynamic name. This is - inconsistent, and complicates the already complicated story for correctly - dealing with names. We therefore " fix " this here and makes those names - dynamic. - - Since we are only interested in declaration splices containing /type/ - declarations, nothing else, it suffices to drop the uniques from type - constructors. Type /variables/ can (and should) remain to have a unique - flavour, as they are locally bound by the type declarations. --------------------------------------------------------------------------------} - -dropUniques :: [Dec] -> [Dec] -dropUniques = SYB.everywhere (SYB.mkT dropUnique) - where - dropUnique :: Type -> Type - dropUnique (ConT n@(TH.Name occ flavour)) = ConT $ - case flavour of - TH.NameU _ -> TH.Name occ TH.NameS - _otherwise -> n - dropUnique typ = typ diff --git a/src/Data/Record/TH/CodeGen/Tree.hs b/src/Data/Record/TH/CodeGen/Tree.hs deleted file mode 100644 --- a/src/Data/Record/TH/CodeGen/Tree.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} - -module Data.Record.TH.CodeGen.Tree ( - -- * Trees and forests - Tree(..) - , Forest(..) - -- * Catamorphisms - , Cata(..) - , tree - , forest - -- * Dealing with @ghc@'s tuple size limit - , TupleLimit(..) - , nest - , mkTupleE - , mkTupleT - , mkTupleP - ) where - -import Language.Haskell.TH - -import Data.Record.Internal.TH.Util - -{------------------------------------------------------------------------------- - Trees and forests --------------------------------------------------------------------------------} - --- | Trees with values at the leaves -data Tree a = Leaf a | Branch (Forest a) deriving (Show) -data Forest a = Forest [Tree a] deriving (Show) - -{------------------------------------------------------------------------------- - Catamorphisms - - Unlike regular folds, these catamorphisms are structure preserving. - See "Dealing with Large Bananas", by Ralf Lämmel et al --------------------------------------------------------------------------------} - -data Cata a b = Cata { - leaf :: a -> b - , branch :: [b] -> b - } - -tree :: Cata a b -> Tree a -> b -tree cata (Leaf a) = leaf cata a -tree cata (Branch as) = forest cata as - -forest :: Cata a b -> Forest a -> b -forest cata (Forest ts) = branch cata (map (tree cata) ts) - -{------------------------------------------------------------------------------- - Nesting --------------------------------------------------------------------------------} - --- | Observe @ghc@'s tuple length --- --- Haskell has a limit of 62 fields per tuple. Here we take an arbitrary --- list and turn it into a nested tuple that preserves this limit. --- --- Example: if we reduce the limit to @2@, we get the following nestings, --- for lengths @[1..10]@: --- --- > A --- > (A, A) --- > ((A, A), A) --- > ((A, A), (A, A)) --- > (((A, A), (A, A)), A) --- > (((A, A), (A, A)), (A, A)) --- > (((A, A), (A, A)), ((A, A), A)) --- > (((A, A), (A, A)), ((A, A), (A, A))) --- > ((((A, A), (A, A)), ((A, A), (A, A))), A) --- > ((((A, A), (A, A)), ((A, A), (A, A))), (A, A)) -nest :: TupleLimit -> [a] -> Forest a -nest mLimit = go . map Leaf - where - go :: [Tree a] -> Forest a - go ts | length ts < limit = Forest ts - | otherwise = go (map (Branch . Forest) (chunk limit ts)) - - limit :: Int - limit = case mLimit of - DefaultGhcTupleLimit -> 62 - MaxTupleElems n -> n - --- | Maximum number of elements in a tuple -data TupleLimit = - -- | Default maximum number of elements in a tuple in ghc (62) - DefaultGhcTupleLimit - - -- | Explicit specified liit - | MaxTupleElems Int - -{------------------------------------------------------------------------------- - Constructing nested types/values/patterns --------------------------------------------------------------------------------} - --- | Construct tuple type -mkTupleT :: forall a. (a -> Q Type) -> Forest a -> Q Type -mkTupleT f = forest cata - where - cata :: Cata a (Q Type) - cata = Cata { - leaf = f - , branch = \case [t] -> t - ts -> appsT (tupleT (length ts)) ts - } - --- | Construct tuple expression -mkTupleE :: forall a. (a -> Q Exp) -> Forest a -> Q Exp -mkTupleE f = forest cata - where - cata :: Cata a (Q Exp) - cata = Cata { - leaf = f - , branch = \case [e] -> e - es -> tupE es - } - --- | Construct tuple pattern -mkTupleP :: forall a. (a -> Q Pat) -> Forest a -> Q Pat -mkTupleP f = forest cata - where - cata :: Cata a (Q Pat) - cata = Cata { - leaf = f - , branch = \case [p] -> p - ps -> tupP ps - } - -{------------------------------------------------------------------------------- - Internal auxiliary --------------------------------------------------------------------------------} - -chunk :: Int -> [a] -> [[a]] -chunk n = go - where - go :: [a] -> [[a]] - go [] = [] - go xs = let (firstChunk, rest) = splitAt n xs in firstChunk : go rest diff --git a/src/Data/Record/TH/Config/Options.hs b/src/Data/Record/TH/Config/Options.hs deleted file mode 100644 --- a/src/Data/Record/TH/Config/Options.hs +++ /dev/null @@ -1,133 +0,0 @@ --- | Options that influence TH code generation -module Data.Record.TH.Config.Options ( - Options(..) - , defaultStrictOptions - , defaultLazyOptions - , defaultPureScript - ) where - -{------------------------------------------------------------------------------- - Options --------------------------------------------------------------------------------} - --- | Tweak the output of the generator --- --- In the explanations of the various options below, we will use the following --- record as our running example: --- --- > data T a b = MkT { --- > tWord :: Word --- > , tBool :: Bool --- > , tChar :: Char --- > , tA :: a --- > , tListB :: [b] --- > } --- > deriving (Eq, Show) -data Options = Options { - -- | Generate a pattern synonym for the record - -- - -- > pattern MkT :: Word -> Bool -> Char -> a -> [b] -> T a b - -- > pattern MkT{tInt, tBool, tChar, tA, tListB} <- .. - -- > where - -- > MkT tInt' tBool' tChar' tA' tListB' = .. - -- - -- The pattern synonym makes it possible to construct or pattern match on - -- @T@ values as if it had been defined like a normal record. - -- - -- We do /not/ do this by default, however, because unfortunately when - -- we define a record pattern synonym in @ghc@, @ghc@ also (unnecessarily - -- but currently unavoidably) introduces field accessors for all fields - -- in the record, and we're back to code that is quadratic in size. - -- - -- Avoid if possible. - generatePatternSynonym :: Bool - - -- | Generate a "constructor function" for the record - -- - -- > _construct_MkT :: Word -> Bool -> Char -> a -> [b] -> T a b - -- > _construct_MkT = .. - -- - -- This function can be used directly, but it is also used by the 'lr' - -- quasi-quoter, so if this function is not generated, 'lr' will not work. - , generateConstructorFn :: Bool - - -- | Generate 'HasField' instances - -- - -- > instance HasField "tInt" (T a b) Word where - -- > hasField = .. - -- - -- These are required by the @record-dot-preprocessor@. - , generateHasFieldInstances :: Bool - - -- | Generate field accessors - -- - -- > tInt :: T a b -> Word - -- > tInt = .. - -- - -- If field accessors are not generated, the only way to access fields - -- is through the 'HasField' instances. - -- - -- Disabling this option is primarily useful if you need overloading: - -- if you have multiple records with a field of the same name, then - -- generating field accessors would result in name clashes. Without the - -- accessors, overloading is resolved through 'HasField'. - , generateFieldAccessors :: Bool - - -- | Make all fields strict - -- - -- This should be used when using the @StrictData@ or @Strict@ language - -- extension. - , allFieldsStrict :: Bool - } - -{------------------------------------------------------------------------------- - Defaults --------------------------------------------------------------------------------} - -defaultLazyOptions :: Options -defaultLazyOptions = Options { - generatePatternSynonym = False - , generateConstructorFn = True - , generateHasFieldInstances = True - , generateFieldAccessors = True - , allFieldsStrict = False - } - -defaultStrictOptions :: Options -defaultStrictOptions = Options { - generatePatternSynonym = False - , generateConstructorFn = True - , generateHasFieldInstances = True - , generateFieldAccessors = True - , allFieldsStrict = True - } - --- | Default options for "Purescript style" records --- --- That is: --- --- * All fields are strict --- * We do /not/ generate field accessors: fields must be accessed and updated --- through the 'HasField' instances (e.g., @record-dot-preprocessor@ syntax). --- --- We do not introduce a pattern synonym by default: --- --- * Introducing a pattern synonym reintroduces code that is quadratic in size. --- * Perhaps more importantly, it would make it impossible to define two records --- with the same field names in a single module, as the field accessors --- (unnecessarily but currently unavoidably) introduced by the pattern synonym --- would clash. --- --- NOTE: The @record-dot-preprocessor@ enables @DuplicateRecordFields@ by --- default. Since the records that we produce are not visible to @ghc@, --- @large-records@ is not compatible with DRF-style overloading. However, as --- long as all overloading is resolved through @HasField@ instead (which is --- what @record-dot-preprocessor@ encourages anyway), all is fine. -defaultPureScript :: Options -defaultPureScript = Options { - generatePatternSynonym = False - , generateConstructorFn = True - , generateHasFieldInstances = True - , generateFieldAccessors = False - , allFieldsStrict = True - } diff --git a/src/Data/Record/TH/Runtime.hs b/src/Data/Record/TH/Runtime.hs deleted file mode 100644 --- a/src/Data/Record/TH/Runtime.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} - --- | Functions to support the TH code (i.e., functions called by generated code) --- --- NOTE: We leave the generic representation type as lazy, and only force --- values once we translate back to the type itself. This means that we can --- chain generic functions and get some kind of fusion without having to --- traverse records multiple times. -module Data.Record.TH.Runtime ( - -- * Miscellaneous - dictFor - , repFromVector - , repToVector - , rnfVectorAny - , noInlineUnsafeCo - ) where - -import Data.Coerce (coerce) -import Data.Proxy -import Data.Vector (Vector) -import GHC.Exts (Any) -import Unsafe.Coerce (unsafeCoerce) - -import qualified Data.Vector as V - -import Data.Record.Generic - -{------------------------------------------------------------------------------- - Miscellaneous --------------------------------------------------------------------------------} - -dictFor :: c x => Proxy c -> Proxy x -> Dict c x -dictFor _ _ = Dict - -repFromVector :: Vector Any -> Rep I a -repFromVector = coerce - -repToVector :: Rep I a -> Vector Any -repToVector = coerce - -rnfVectorAny :: Vector Any -> () -rnfVectorAny = rnfElems . V.toList - where - rnfElems :: [Any] -> () - rnfElems [] = () - rnfElems (x:xs) = x `seq` rnfElems xs - --- | Avoid potential segfault with ghc < 9.0 --- --- See . --- I haven't actually seen this fail in large-records, but we saw it fail in --- the compact representation branch of sop-core, and what we do here is not --- so different, so better to play it safe. -noInlineUnsafeCo :: forall a b. a -> b -{-# NOINLINE noInlineUnsafeCo #-} -noInlineUnsafeCo = unsafeCoerce - diff --git a/test/Test/Record/Prop/Show.hs b/test/Test/Record/Prop/Show.hs deleted file mode 100644 --- a/test/Test/Record/Prop/Show.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Test.Record.Prop.Show (tests) where - -import Test.Tasty -import Test.Tasty.QuickCheck - -import qualified Test.Record.Prop.Show.Regular as Regular -import qualified Test.Record.Prop.Show.Large as Large - -tests :: TestTree -tests = testGroup "Test.Record.Prop.Show" [ - testProperty "show" prop_show - ] - -prop_show :: Regular.Example1 -> Property -prop_show ex = show ex === show (Large.fromRegular ex) diff --git a/test/Test/Record/Prop/Show/Large.hs b/test/Test/Record/Prop/Show/Large.hs deleted file mode 100644 --- a/test/Test/Record/Prop/Show/Large.hs +++ /dev/null @@ -1,40 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- {-# OPTIONS_GHC -ddump-splices #-} - -module Test.Record.Prop.Show.Large ( - FromRegular(..) - , Example1(..) - ) where - -import Data.Record.TH - -import qualified Test.Record.Prop.Show.Regular as Regular - -class FromRegular a b | a -> b, b -> a where - fromRegular :: a -> b - -largeRecord defaultPureScript [d| - data Example1 = MkExample1 { - example1Field1 :: Int - , example1Field2 :: Bool - } - deriving (Show) - |] - -instance FromRegular Regular.Example1 Example1 where - fromRegular Regular.MkExample1{..} = [lr| MkExample1 { - example1Field1 = example1Field1 - , example1Field2 = example1Field2 - } |] diff --git a/test/Test/Record/Prop/Show/Regular.hs b/test/Test/Record/Prop/Show/Regular.hs deleted file mode 100644 --- a/test/Test/Record/Prop/Show/Regular.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Test.Record.Prop.Show.Regular ( - Example1(..) - ) where - -import Test.QuickCheck - -data Example1 = MkExample1 { - example1Field1 :: Int - , example1Field2 :: Bool - } - deriving (Show) - -instance Arbitrary Example1 where - arbitrary = MkExample1 <$> arbitrary <*> arbitrary - shrink (MkExample1 f1 f2) = concat [ - [ MkExample1 f1' f2 - | f1' <- shrink f1 - ] - , [ MkExample1 f1 f2' - | f2' <- shrink f2 - ] - ] diff --git a/test/Test/Record/Prop/ToFromJSON.hs b/test/Test/Record/Prop/ToFromJSON.hs deleted file mode 100644 --- a/test/Test/Record/Prop/ToFromJSON.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- {-# OPTIONS_GHC -ddump-splices #-} - -module Test.Record.Prop.ToFromJSON (tests) where - -import Data.Aeson -import Data.Aeson.Types - -import Data.Record.TH -import Data.Record.Generic.JSON - -import Test.Tasty -import Test.Tasty.QuickCheck - -{------------------------------------------------------------------------------- - Test that gtoJSON and gfromJSON are inverse --------------------------------------------------------------------------------} - -largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d| - data A = MkA { - ax :: Int - , ay :: Bool - } - deriving (Show, Eq) - |] - -instance Arbitrary A where - arbitrary = MkA <$> arbitrary <*> arbitrary - shrink MkA{ax = x, ay = y} = concat [ - (\x' -> MkA x' y ) <$> shrink x - , (\y' -> MkA x y') <$> shrink y - ] - -instance ToJSON A where toJSON = gtoJSON -instance FromJSON A where parseJSON = gparseJSON - -{------------------------------------------------------------------------------- - Top-level tests --------------------------------------------------------------------------------} - -tests :: TestTree -tests = testGroup "Test.Record.Prop.ToFromJSON" [ - testProperty "tofromJSON" prop_tofromJSON - ] - -prop_tofromJSON :: A -> Property -prop_tofromJSON a = - counterexample (show (toJSON a)) - $ Right a === parseEither parseJSON (toJSON a) diff --git a/test/Test/Record/Sanity/CodeGen.hs b/test/Test/Record/Sanity/CodeGen.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/CodeGen.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} + +-- | Sanity checks of the TH code generation +module Test.Record.Sanity.CodeGen (tests) where + +import Data.Record.Generic + +import Test.Tasty +import Test.Tasty.HUnit + +{------------------------------------------------------------------------------- + Test record + + This is the example record we use throughout the comments in TH codegen. +-------------------------------------------------------------------------------} + +{-# ANN type T largeRecordStrict #-} +data T a b = MkT { + tInt :: Word + , tBool :: Bool + , tChar :: Char + , tA :: a + , tListB :: [b] + } + deriving (Eq, Ord, Show) + +exampleT :: T () Float +exampleT = MkT 5 True 'c' () [3.14] + +_silenceWarnings :: T a b -> () +_silenceWarnings MkT{..} = const () $ ( + tInt + , tBool + , tChar + , tA + , tListB + ) + +{------------------------------------------------------------------------------- + Tests + + TODO: Should we have some other sanity checks here of the codegen? + (They might exist in other parts of the test suite, perhaps we should + reorganize things a bit.) +-------------------------------------------------------------------------------} + +test_from_to_id :: Assertion +test_from_to_id = + assertEqual "from . to = id" expected actual + where + expected, actual :: T () Float + expected = exampleT + actual = (to . from) exampleT + +{------------------------------------------------------------------------------- + All tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.CodeGen" [ + testCase "from_to_id" test_from_to_id + ] 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 @@ -1,25 +1,28 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} --- {-# OPTIONS_GHC -ddump-splices #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Sanity.Derive (tests) where import Control.Newtype import Data.Functor.Identity import Data.Kind +import GHC.Records.Compat import Test.Tasty import Test.Tasty.HUnit -import Data.Record.TH - {------------------------------------------------------------------------------- Class of kind @Type -> Constraint@. -------------------------------------------------------------------------------} @@ -30,25 +33,23 @@ -- Type of kind @Type@ -largeRecord defaultPureScript [d| - data LA1 = MkLA1 { la1_f1 :: Int } - deriving anyclass C1 - |] +{-# ANN type LA1 largeRecordStrict #-} +data LA1 = MkLA1 { la1_f1 :: Int } + deriving anyclass C1 -- Type of kind @Type -> Type@ (regular and large example) data RA2 a = MkRA1 { ra2_f1 :: a } deriving anyclass C1 -largeRecord defaultPureScript [d| - data LA2 a = MkLA2 { la2_f1 :: a } - deriving anyclass C1 - |] +{-# ANN type LA2 largeRecordStrict #-} +data LA2 a = MkLA2 { la2_f1 :: a } + deriving anyclass C1 {------------------------------------------------------------------------------- Class of kind @Type -> Type -> Constraint@, partially instantiated. - (From a purely kind point of view, this is no different to the previous - sectiono, of course.) + (Purely from a kind point of view, this is no different to the previous + section, of course.) To make transpilation easier, the PureScript to Haskell transpiler makes all records as being a "newtype of themselves" (in PureScript, something like @@ -58,13 +59,14 @@ really is a newtype around a record). -------------------------------------------------------------------------------} -largeRecord defaultPureScript [d| - data LB = MkLB { lb1 :: Int, lb2 :: Int } - deriving anyclass (Newtype LB) - |] +{-# ANN type LB largeRecordStrict #-} +data LB = MkLB { lb1 :: Int, lb2 :: Int } + deriving anyclass (Newtype LB) f :: LB -> LB -f r = pack ((unpack r){ lb1 = r.lb2, lb2 = r.lb1 }) +f r = flip (setField @"lb1") (getField @"lb2" r) + . flip (setField @"lb2") (getField @"lb1" r) + $ r {------------------------------------------------------------------------------- Class of kind @(Type -> Type) -> Constraint@ @@ -78,10 +80,9 @@ data RC a = MkRC { rc1 :: a, rc2 :: Int } deriving anyclass C3 -largeRecord defaultPureScript [d| - data LC (a :: Type) = MkLC { lc1 :: a, lc2 :: Int } - deriving anyclass C3 - |] +{-# ANN type LC largeRecordStrict #-} +data LC (a :: Type) = MkLC { lc1 :: a, lc2 :: Int } + deriving anyclass C3 {------------------------------------------------------------------------------- Class of kind @((Type -> Type) -> Type) -> Constraint@ @@ -95,10 +96,9 @@ data RD f = MkRD { rd1 :: f Int, rd2 :: Int } deriving anyclass C4 -largeRecord defaultPureScript [d| - data LD (f :: Type -> Type) = MkLD { ld1 :: f Int, ld2 :: Int } - deriving anyclass C4 - |] +{-# ANN type LD largeRecordStrict #-} +data LD (f :: Type -> Type) = MkLD { ld1 :: f Int, ld2 :: Int } + deriving anyclass C4 {------------------------------------------------------------------------------- Class with a constraint @@ -113,11 +113,10 @@ deriving stock Show deriving anyclass C5 -largeRecord defaultPureScript [d| - data LE = MkLE { le1 :: Int, le2 :: Bool } - deriving stock Show - deriving anyclass C5 - |] +{-# ANN type LE largeRecordStrict #-} +data LE = MkLE { le1 :: Int, le2 :: Bool } + deriving stock Show + deriving anyclass C5 {------------------------------------------------------------------------------- Tests proper @@ -138,17 +137,17 @@ assertEqual "type of kind 'Type -> Type'" (c1 la2) "x" where la1 :: LA1 - la1 = [lr| MkLA1 { la1_f1 = 1 } |] + la1 = MkLA1 { la1_f1 = 1 } la2 :: LA2 Int - la2 = [lr| MkLA2 { la2_f1 = 1 } |] + la2 = MkLA2 { la2_f1 = 1 } test_newtype :: Assertion test_newtype = - assertEqual "" r'.lb1 2 + assertEqual "" (getField @"lb1" r') 2 where r :: LB - r = [lr| MkLB { lb1 = 1, lb2 = 2 }|] + r = MkLB { lb1 = 1, lb2 = 2 } r' :: LB r' = f r @@ -158,18 +157,18 @@ assertEqual "" (c3 r) "x" where r :: LC Bool - r = [lr| MkLC { lc1 = True, lc2 = 2 } |] + r = MkLC { lc1 = True, lc2 = 2 } test_c4 :: Assertion test_c4 = assertEqual "" (c4 r) "x" where r :: LD Identity - r = [lr| MkLD { ld1 = Identity 1, ld2 = 2 } |] + r = MkLD { ld1 = Identity 1, ld2 = 2 } test_c5 :: Assertion test_c5 = assertEqual "" (c5 r) "MkLE {le1 = 1, le2 = True}" where r :: LE - r = [lr| MkLE { le1 = 1, le2 = True } |] + r = MkLE { le1 = 1, le2 = True } 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 @@ -1,30 +1,46 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- The point of this module is to verify that largeRecord does not generate -- redundant constraints {-# OPTIONS_GHC -Werror -Wredundant-constraints #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Sanity.EqualFieldTypes (tests) where -import Data.Record.TH import Test.Tasty +import Test.Tasty.HUnit -largeRecord defaultPureScript [d| - data R a = MkR { - field1 :: a - , field2 :: a - } - deriving (Show, Eq) - |] +{-# ANN type R largeRecordStrict #-} +data R a = MkR { + field1 :: a + , field2 :: a + } + deriving (Show, Eq) --- The test is compilation itself +swap :: R a -> R a +swap MkR{ field1, field2 } = MkR{ field1 = field2, field2 = field1 } + tests :: TestTree -tests = testGroup "Test.Record.Sanity.EqualFieldTypes" [] +tests = testGroup "Test.Record.Sanity.EqualFieldTypes" [ + testCase "sanity" test_sanity + ] + +test_sanity :: Assertion +test_sanity = assertEqual "" expected actual + where + expected, actual :: R Int + expected = MkR 2 1 + actual = swap $ MkR 1 2 + + + diff --git a/test/Test/Record/Sanity/ErrorsAndWarnings.hs b/test/Test/Record/Sanity/ErrorsAndWarnings.hs deleted file mode 100644 --- a/test/Test/Record/Sanity/ErrorsAndWarnings.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Test.Record.Sanity.ErrorsAndWarnings (tests) where - -import Test.Tasty -import Test.Tasty.HUnit - -import Test.Record.Util -import Test.Record.Sanity.ErrorsAndWarnings.Stage1 - -problemsForSyntaxErrorInExp :: (Maybe String, [Problem]) -problemsForSyntaxErrorInExp = $qProblemsForSyntaxErrorInExp - -problemsForSyntaxErrorInPat :: (Maybe String, [Problem]) -problemsForSyntaxErrorInPat = $qProblemsForSyntaxErrorInPat - -problemsForUnknownFieldsInExp :: (Maybe String, [Problem]) -problemsForUnknownFieldsInExp = $qProblemsForUnknownFieldsInExp - -problemsForUnknownFieldsInPat :: (Maybe String, [Problem]) -problemsForUnknownFieldsInPat = $qProblemsForUnknownFieldsInPat - -problemsForMissingFieldsInExp :: (Maybe String, [Problem]) -problemsForMissingFieldsInExp = $qProblemsForMissingFieldsInExp - -problemsForMissingFieldsInPat :: (Maybe String, [Problem]) -problemsForMissingFieldsInPat = $qProblemsForMissingFieldsInPat - -tests :: TestTree -tests = testGroup "Test.Record.Sanity.ErrorsAndWarnings" [ - testCase "problemsForSyntaxErrorInExp" test_problemsForSyntaxErrorInExp - , testCase "problemsForSyntaxErrorInPat" test_problemsForSyntaxErrorInPat - , testCase "problemsForUnknownFieldsInExp" test_problemsForUnknownFieldsInExp - , testCase "problemsForUnknownFieldsInPat" test_problemsForUnknownFieldsInPat - , testCase "problemsForMissingFieldsInExp" test_problemsForMissingFieldsInExp - , testCase "problemsForMissingFieldsInPat" test_problemsForMissingFieldsInPat - ] - -test_problemsForSyntaxErrorInExp :: Assertion -test_problemsForSyntaxErrorInExp = do - assertJust "no failure reported" (fst problemsForSyntaxErrorInExp) $ - assertPrefix "Could not parse expression:" - assertEqual "other problems" [] (snd problemsForSyntaxErrorInExp) - -test_problemsForSyntaxErrorInPat :: Assertion -test_problemsForSyntaxErrorInPat = do - assertJust "no failure reported" (fst problemsForSyntaxErrorInPat) $ - assertPrefix "Could not parse pattern:" - assertEqual "other problems" [] (snd problemsForSyntaxErrorInPat) - -test_problemsForUnknownFieldsInExp :: Assertion -test_problemsForUnknownFieldsInExp = - assertEqual "" expected problemsForUnknownFieldsInExp - where - expected :: (Maybe String, [Problem]) - expected = (Nothing, [Error "Unknown fields: c"]) - -test_problemsForUnknownFieldsInPat :: Assertion -test_problemsForUnknownFieldsInPat = - assertEqual "" expected problemsForUnknownFieldsInPat - where - expected :: (Maybe String, [Problem]) - expected = (Nothing, [Error "Unknown fields: c"]) - -test_problemsForMissingFieldsInExp :: Assertion -test_problemsForMissingFieldsInExp = - assertEqual "" expected problemsForMissingFieldsInExp - where - expected :: (Maybe String, [Problem]) - expected = (Nothing, [Warning "No value for field b"]) - -test_problemsForMissingFieldsInPat :: Assertion -test_problemsForMissingFieldsInPat = - assertEqual "" expected problemsForMissingFieldsInPat - where - -- It is of course perfectly fine for a pattern to be missing fields - expected :: (Maybe String, [Problem]) - expected = (Nothing, []) - diff --git a/test/Test/Record/Sanity/ErrorsAndWarnings/Stage1.hs b/test/Test/Record/Sanity/ErrorsAndWarnings/Stage1.hs deleted file mode 100644 --- a/test/Test/Record/Sanity/ErrorsAndWarnings/Stage1.hs +++ /dev/null @@ -1,68 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- {-# OPTIONS_GHC -ddump-splices #-} - -module Test.Record.Sanity.ErrorsAndWarnings.Stage1 ( - -- * The record we're testing against - -- - -- It is important that we export 'R', because the various TH expressions - -- we not executed here, but rather where we use them - -- ("Test.Record.Sanity.ErrorsAndWarnings.Stage1"); this means that if we - -- don't export this, the " problem " that is reported is the constructor - -- not being in scope, rather than the missing/extra fields. - R(..) - - -- The specific tests - , qProblemsForSyntaxErrorInExp - , qProblemsForSyntaxErrorInPat - , qProblemsForUnknownFieldsInExp - , qProblemsForUnknownFieldsInPat - , qProblemsForMissingFieldsInExp - , qProblemsForMissingFieldsInPat - ) where - -import Language.Haskell.TH -import Language.Haskell.TH.Syntax - -import Data.Record.TH -import Data.Record.QQ.CodeGen - -import Test.Record.Util - -largeRecord defaultPureScript [d| - data R = MkR { a :: Int, b :: Bool } - |] - -qProblemsForSyntaxErrorInExp :: Q Exp -qProblemsForSyntaxErrorInExp = (lift =<<) $ collectOnlyProblems $ - lrExp "MkR { a = 1, b = True, c = ()" - -qProblemsForSyntaxErrorInPat :: Q Exp -qProblemsForSyntaxErrorInPat = (lift =<<) $ collectOnlyProblems $ - lrPat "MkR { a = x, b = y, c = z" - -qProblemsForUnknownFieldsInExp :: Q Exp -qProblemsForUnknownFieldsInExp = (lift =<<) $ collectOnlyProblems $ - lrExp "MkR { a = 1, b = True, c = () }" - -qProblemsForUnknownFieldsInPat :: Q Exp -qProblemsForUnknownFieldsInPat = (lift =<<) $ collectOnlyProblems $ - lrPat "MkR { a = x, b = y, c = z }" - -qProblemsForMissingFieldsInExp :: Q Exp -qProblemsForMissingFieldsInExp = (lift =<<) $ collectOnlyProblems $ - lrExp "MkR { a = 1 }" - -qProblemsForMissingFieldsInPat :: Q Exp -qProblemsForMissingFieldsInPat = (lift =<<) $ collectOnlyProblems $ - lrPat "MkR { a = x }" - diff --git a/test/Test/Record/Sanity/Generics.hs b/test/Test/Record/Sanity/Generics.hs deleted file mode 100644 --- a/test/Test/Record/Sanity/Generics.hs +++ /dev/null @@ -1,267 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - --- {-# OPTIONS_GHC -ddump-splices #-} - --- | Sanity check that the generic functions are not totally broken --- --- These are not proper tests, merely intended to catch egregious refactoring --- mistakes. -module Test.Record.Sanity.Generics (tests) where - -import Control.Monad.State (State, evalState, state) -import Data.Proxy -import Data.SOP (NP(..), All, Compose) - -import qualified Data.SOP as SOP -import qualified Generics.SOP as SOP -import qualified Generics.SOP.Metadata as SOP -import qualified Generics.SOP.Type.Metadata as SOP.T - -import Test.Tasty -import Test.Tasty.HUnit -import Test.Tasty.QuickCheck - -import Data.Record.Generic -import Data.Record.Generic.LowerBound -import Data.Record.Generic.SOP hiding (glowerBound) -import Data.Record.TH - -import qualified Data.Record.Generic.SOP as SOP -import qualified Data.Record.Generic.Rep as Rep - -{------------------------------------------------------------------------------- - Small test record --------------------------------------------------------------------------------} - -largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d| - data T a b = MkT { - tInt :: Word - , tBool :: Bool - , tChar :: Char - , tA :: a - , tListB :: [b] - } - deriving (Eq, Ord, Show) - |] - -exampleT :: T () Float -exampleT = MkT 5 True 'c' () [3.14] - -_silenceWarnings :: () -_silenceWarnings = const () $ ( - tInt - , tBool - , tChar - , tA - , tListB - ) - -{------------------------------------------------------------------------------- - Handwritten SOP instance - - This allows us to compare the untyped representation used by @large-records@ - to the strongly typed version from @generics-sop@. --------------------------------------------------------------------------------} - -instance SOP.Generic (T a b) where - type Code (T a b) = '[[Word, Bool, Char, a, [b]]] - from (MkT i b c a bs) = SOP.SOP (SOP.Z (I i :* I b :* I c :* I a :* I bs :* Nil)) - to (SOP.SOP (SOP.Z (I i :* I b :* I c :* I a :* I bs :* Nil))) = MkT i b c a bs - to (SOP.SOP (SOP.S x)) = case x of {} - -type DefaultBang = - 'SOP.T.StrictnessInfo - 'SOP.NoSourceUnpackedness - 'SOP.NoSourceStrictness - 'SOP.DecidedLazy - -instance SOP.HasDatatypeInfo (T a b) where - type DatatypeInfoOf (T a b) = - 'SOP.T.ADT - "Data.Record.Generic.Sanity" - "T" - '[ 'SOP.T.Record "MkT" '[ - 'SOP.T.FieldInfo "tInt" - , 'SOP.T.FieldInfo "tBool" - , 'SOP.T.FieldInfo "tChar" - , 'SOP.T.FieldInfo "tA" - , 'SOP.T.FieldInfo "tListB" - ]] - '[ '[ - DefaultBang - , DefaultBang - , DefaultBang - , DefaultBang - , DefaultBang - ]] - - datatypeInfo _ = - SOP.T.demoteDatatypeInfo $ Proxy @(SOP.DatatypeInfoOf (T a b)) - -{------------------------------------------------------------------------------- - Tests --------------------------------------------------------------------------------} - -test_from_to_id :: Assertion -test_from_to_id = - assertEqual "from . to = id" expected actual - where - expected, actual :: T () Float - expected = exampleT - actual = (to . from) exampleT - -test_pure :: Assertion -test_pure = - compareTyped expected actual - where - expected :: NP (Field (K Char)) (MetadataOf (T () Float)) - expected = - Field (K 'a') - :* Field (K 'a') - :* Field (K 'a') - :* Field (K 'a') - :* Field (K 'a') - :* Nil - - actual :: Rep (K Char) (T () Float) - actual = Rep.pure (K 'a') - -test_cpure :: Assertion -test_cpure = - assertEqual "matches hand-constructed" expected actual - where - expected, actual :: T () Float - expected = MkT 0 False '\x0000' () [] - actual = glowerBound - -test_sequenceA :: Assertion -test_sequenceA = - compareTyped expected actual - where - expected :: NP (Field (K Int)) (MetadataOf (T () Float)) - expected = - flip evalState 0 - $ SOP.hsequence' - $ SOP.hmap distrib - $ example - where - distrib :: Field (State Int :.: K Int) x - -> (State Int :.: (Field (K Int))) x - distrib (Field (Comp x)) = Comp (Field <$> x) - - actual :: Rep (K Int) (T () Float) - actual = flip evalState 0 $ Rep.sequenceA $ SOP.fromSOP example - - example :: NP (Field (State Int SOP.:.: K Int)) (MetadataOf (T () Float)) - example = - Field (Comp (K <$> tick)) - :* Field (Comp (K <$> tick)) - :* Field (Comp (K <$> tick)) - :* Field (Comp (K <$> tick)) - :* Field (Comp (K <$> tick)) - :* Nil - - tick :: State Int Int - tick = state $ \i -> (i, i + 1) - -test_zipWithM :: Assertion -test_zipWithM = - compareTyped expected actual - where - expected :: NP (Field (K Int)) (MetadataOf (T () Float)) - expected = - flip evalState 0 - $ SOP.hsequence' - $ SOP.hliftA2 tick' x y - where - tick' :: Field (K Int) field - -> Field (K Int) field - -> (State Int :.: Field (K Int)) field - tick' (Field a) (Field b) = Comp $ Field <$> tick a b - - actual :: Rep (K Int) (T () Float) - actual = flip evalState 0 $ - Rep.zipWithM tick (fromSOP x) (fromSOP y) - - tick :: K Int x -> K Int x -> State Int (K Int x) - tick (K a) (K b) = state $ \i -> (K (a + b + i), i + 1) - - x, y :: NP (Field (K Int)) (MetadataOf (T () Float)) - x = Field (K 10) - :* Field (K 11) - :* Field (K 12) - :* Field (K 13) - :* Field (K 14) - :* Nil - y = Field (K 20) - :* Field (K 21) - :* Field (K 22) - :* Field (K 23) - :* Field (K 24) - :* Nil - -test_ord :: Word -> Word -> Bool -> Bool -> Property -test_ord w w' b b' - | w == w' && b == b' = t1 === t2 - | w == w' = compare t1 t2 === compare b b' - | otherwise = compare t1 t2 === compare w w' - where - t1, t2 :: T () Float - t1 = MkT w b 'c' () [3.14] - t2 = MkT w' b' 'c' () [3.14] - -{------------------------------------------------------------------------------- - For testing purposes, we compare against proper heterogeneous lists --------------------------------------------------------------------------------} - -compareTyped :: - forall f a. ( - Generic a - , Constraints a (Compose Eq f) - , Constraints a (Compose Show f) - , All IsField (MetadataOf a) - ) - => NP (Field f) (MetadataOf a) -> Rep f a -> Assertion -compareTyped expected actual = - case toSOP actual of - Nothing -> - assertFailure "compareTyped: incorrect number of fields" - Just actual' -> - case toDictAll (Proxy @f) (Proxy @a) (Proxy @Show) of - Dict -> - case toDictAll (Proxy @f) (Proxy @a) (Proxy @Eq) of - Dict -> go expected actual' - where - go :: ( All (Compose Eq (Field f)) fields - , All (Compose Show (Field f)) fields - ) - => NP (Field f) fields -> NP (Field f) fields -> Assertion - go = assertEqual "compareTyped" - -{------------------------------------------------------------------------------- - All tests --------------------------------------------------------------------------------} - -tests :: TestTree -tests = testGroup "Test.Record.Sanity" [ - testCase "from_to_id" test_from_to_id - , testCase "pure" test_pure - , testCase "sequenceA" test_sequenceA - , testCase "zipWithM" test_zipWithM - , testCase "cpure" test_cpure - , testProperty "ord" test_ord - ] 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 @@ -1,154 +1,45 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -Wno-orphans #-} --- {-# OPTIONS_GHC -ddump-splices #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Sanity.GhcGenerics (tests) where -import Data.Function (on) -import Data.Proxy import Data.Record.Generic.GHC -import Data.Record.TH -import Data.SOP.BasicFunctors -import Test.Tasty -import Test.Tasty.HUnit - -import qualified Data.Record.Generic as LR -import qualified Data.Record.Generic.Eq as LR -import qualified Data.Record.Generic.Rep as Rep -import qualified Generics.Deriving.Eq as GHC -import qualified GHC.Generics as GHC - -{------------------------------------------------------------------------------- - Example large record --------------------------------------------------------------------------------} - -largeRecord defaultPureScript [d| - data LargeRecord = MkLargeRecord { - largeField1 :: Int - , largeField2 :: Bool - } - |] - -example :: LargeRecord -example = [lr| MkLargeRecord |] 1 True - -{------------------------------------------------------------------------------- - Show that we can use geqdefault on a large record --------------------------------------------------------------------------------} - -instance ( LR.Generic a - , LR.Constraints a Eq - ) => GHC.GEq' (ThroughLRGenerics a) where - geq' = LR.geq `on` unwrapThroughLRGenerics - -allEqualTo :: (GHC.Generic a, GHC.GEq' (GHC.Rep a)) => a -> [a] -> Bool -allEqualTo x = all (GHC.geqdefault x) - -{------------------------------------------------------------------------------- - Example with GHC field metadata --------------------------------------------------------------------------------} - -class GRecordToTable f where - gRecordToTable :: f p -> [(String, String)] - -instance GRecordToTable f - => GRecordToTable (GHC.M1 GHC.D c f) where - gRecordToTable (GHC.M1 x) = gRecordToTable x - -instance GRecordToTable f - => GRecordToTable (GHC.M1 GHC.C c f) where - gRecordToTable (GHC.M1 x) = gRecordToTable x - -instance (GRecordToTable f, GRecordToTable g) - => GRecordToTable (f GHC.:*: g) where - gRecordToTable (l GHC.:*: r) = gRecordToTable l ++ gRecordToTable r - -instance (GHC.Selector f, Show a) - => GRecordToTable (GHC.M1 GHC.S f (GHC.K1 GHC.R a)) where - gRecordToTable f@(GHC.M1 (GHC.K1 x)) = [(GHC.selName f, show x)] - -data Table = Table { - tableFields :: [(String, String)] - } - deriving (Show, Eq) +import Generics.Deriving.Show (gshowsPrecdefault, GShow'(..)) -simpleRecordToTable :: (GHC.Generic a, GRecordToTable (GHC.Rep a)) => a -> Table -simpleRecordToTable = Table . gRecordToTable . GHC.from +import qualified GHC.Generics as GHC -data SimpleRecord = MkSimpleRecord { - simpleField1 :: Int - , simpleField2 :: Bool - } - deriving (GHC.Generic) +import Test.Tasty +import Test.Tasty.HUnit --- The goal is to reuse the instance for fields --- TODO: We could potentially extend this to the other metadata as well -largeRecordToTable :: forall a. - (LR.Generic a, LR.Constraints a Show) - => a -> Table -largeRecordToTable = \x -> - Table { - tableFields = concat . Rep.collapse $ - Rep.czipWith - (Proxy @Show) - aux - (LR.from x) - (ghcMetadataFields (ghcMetadata (Proxy @a))) - } - where - aux :: Show x => I x -> GhcFieldMetadata x -> K [(String, String)] x - aux (I x) (GhcFieldMetadata p) = K $ gRecordToTable $ aux' x p +{-# ANN type R largeRecordStrict #-} +data R = MkR { a :: Int } + deriving (Show) - aux' :: x -> Proxy f -> GHC.M1 GHC.S f (GHC.K1 GHC.R x) p - aux' x _ = GHC.M1 (GHC.K1 x) +instance GShow' (ThroughLRGenerics R) where + gshowsPrec' _ p (WrapThroughLRGenerics x) = showsPrec p x -{------------------------------------------------------------------------------- - Tests proper --------------------------------------------------------------------------------} +-- | Beam-style "force to go through GHC generics" style function +showGenerically :: (GHC.Generic a, GShow' (GHC.Rep a)) => a -> String +showGenerically x = gshowsPrecdefault 0 x "" tests :: TestTree tests = testGroup "Test.Record.Sanity.GhcGenerics" [ - testCase "allEqualTo" test_allEqualTo - , testCase "simpleRecordToTable" test_simpleRecordToTable - , testCase "largeRecordToTable" test_largeRecordToTable + testCase "show" test_show ] -test_allEqualTo :: Assertion -test_allEqualTo = assertEqual "" (allEqualTo example [example]) True - --- Just a sanity check that the standard GHC generic functions works as intended -test_simpleRecordToTable :: Assertion -test_simpleRecordToTable = - assertEqual "" (simpleRecordToTable r) tbl - where - r :: SimpleRecord - r = MkSimpleRecord 1 True - - tbl :: Table - tbl = Table [ - ("simpleField1", "1") - , ("simpleField2", "True") - ] - -test_largeRecordToTable :: Assertion -test_largeRecordToTable = - assertEqual "" (largeRecordToTable example) tbl +test_show :: Assertion +test_show = + assertEqual "" (show example) $ showGenerically (MkR { a = 5 }) where - tbl :: Table - tbl = Table [ - ("largeField1", "1") - , ("largeField2", "True") - ] + example :: R + example = MkR { a = 5 } 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 @@ -1,18 +1,16 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-} --- {-# OPTIONS_GHC -ddump-splices #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Sanity.HKD ( tests @@ -21,8 +19,7 @@ import Data.Functor.Identity import Data.Functor.Const import Data.Kind - -import Data.Record.TH +import GHC.Records.Compat import Test.Tasty import Test.Tasty.HUnit @@ -32,13 +29,12 @@ HKD (Const b) a = b -- | Test record with fields whose types are given by type families -largeRecord defaultPureScript [d| - data T (f :: Type -> Type) = MkT { - field1 :: HKD f Int - , field2 :: HKD f Bool - } - deriving (Show, Eq) - |] +{-# ANN type T largeRecordStrict #-} +data T (f :: Type -> Type) = MkT { + field1 :: HKD f Int + , field2 :: HKD f Bool + } + deriving (Show, Eq) {------------------------------------------------------------------------------- Tests @@ -52,20 +48,18 @@ ] example1, example2 :: T Identity -example1 = [lr| MkT { field1 = 1, field2 = True } |] -example2 = [lr| MkT { field1 = 1, field2 = False } |] +example1 = MkT { field1 = 1, field2 = True } +example2 = MkT { field1 = 1, field2 = False } example3 :: T (Const Char) -example3 = [lr| MkT { field1 = 'a', field2 = 'b' } |] +example3 = MkT { field1 = 'a', field2 = 'b' } exampleFun :: T f -> HKD f Int -exampleFun [lr| MkT { field1 } |] = field1 - -testGet :: Assertion -testGet = assertEqual "" example1.field1 1 +exampleFun MkT { field1 } = field1 -testSet :: Assertion -testSet = assertEqual "" (example1{ field2 = False }) example2 +testGet, testSet :: Assertion +testGet = assertEqual "" (getField @"field1" example1) 1 +testSet = assertEqual "" (setField @"field2" example2 False) example2 testMatch :: Assertion testMatch = do 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 @@ -1,17 +1,16 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} --- {-# OPTIONS_GHC -ddump-splices #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} -- | Simple example of a type with a higher kind module Test.Record.Sanity.HigherKinded ( @@ -23,7 +22,6 @@ import Data.Record.Generic import Data.Record.Generic.LowerBound -import Data.Record.TH import Test.Tasty import Test.Tasty.HUnit @@ -37,24 +35,23 @@ -- We need an explicit kind annotation on @f@ for @large-records@ to generate -- correct code (either that, or use @PolyKinds@). -largeRecord defaultLazyOptions [d| - data MyRecord (f :: Type -> Type) = MyRecord { - field0 :: T 0 f - , field1 :: T 1 f - , field2 :: T 2 f - , field3 :: T 3 f - , field4 :: T 4 f - , field5 :: T 5 f - , field6 :: T 6 f - , field7 :: T 7 f - , field8 :: T 8 f - , field9 :: T 9 f - } - deriving (Show) - |] +{-# ANN type MyRecord largeRecordStrict #-} +data MyRecord (f :: Type -> Type) = MyRecord { + field0 :: T 0 f + , field1 :: T 1 f + , field2 :: T 2 f + , field3 :: T 3 f + , field4 :: T 4 f + , field5 :: T 5 f + , field6 :: T 6 f + , field7 :: T 7 f + , field8 :: T 8 f + , field9 :: T 9 f + } + deriving (Show) -_suppressWarnings :: () -_suppressWarnings = const () ( +_suppressWarnings :: MyRecord f -> () +_suppressWarnings MyRecord{..} = const () ( field0 , field1 , field2 diff --git a/test/Test/Record/Sanity/Laziness.hs b/test/Test/Record/Sanity/Laziness.hs deleted file mode 100644 --- a/test/Test/Record/Sanity/Laziness.hs +++ /dev/null @@ -1,156 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} - --- | Check that the functions on 'Rep' can be called on 'undefined' -module Test.Record.Sanity.Laziness (tests) where - -import Control.Exception -import Data.List (isInfixOf) -import Data.IORef -import Test.Tasty -import Test.Tasty.HUnit - -import Data.Record.Generic -import Data.Record.TH - -import qualified Data.Record.Generic.Rep as Rep -import qualified Data.Record.Generic.Rep.Internal as Rep - -import Test.Record.Util - -{------------------------------------------------------------------------------- - Example record --------------------------------------------------------------------------------} - -largeRecord defaultPureScript [d| - data R = MkR { - ri :: Word - , rb :: Bool - } - deriving (Show, Eq) - |] - -example :: R -example = [lr| MkR { ri = 5, rb = True } |] - -{------------------------------------------------------------------------------- - Tests proper --------------------------------------------------------------------------------} - -tests :: TestTree -tests = testGroup "Test.Record.Sanity.Laziness" [ - testCase "mapWithIndex" test_mapWithIndex - , testCase "ap" test_ap - , testCase "map" test_map - , testCase "map'" test_map' - , testCase "mapM" test_mapM - , testCase "cmap" test_cmap - , testCase "cmapM" test_cmapM - , testCase "zipWithM" test_zipWithM - , testCase "czipWithM" test_czipWithM - ] - -test_mapWithIndex :: Assertion -test_mapWithIndex = - assertEqual "" expected actual - where - expected, actual :: Rep (K Int) R - expected = Rep.unsafeFromList [0, 1] - actual = Rep.mapWithIndex (\ix _ -> K $ Rep.indexToInt ix) undefined - -test_ap :: Assertion -test_ap = - assertEqual "" expected actual - where - fns :: Rep (f -.-> I) R - fns = Rep.map' (\x -> Fn $ \_ -> x) (from example) - - expected, actual :: R - expected = example - actual = to $ Rep.ap fns undefined - -test_map :: Assertion -test_map = - assertEqual "" expected actual - where - expected, actual :: Rep (K Int) R - expected = Rep.unsafeFromList [0, 0] - actual = Rep.map (\_ -> K 0) undefined - --- Just to be sure: if we use map' instead of map, we get bottom -test_map' :: Assertion -test_map' = expectException isExpectedException $ do - assertEqual "" expected actual - where - isExpectedException :: SomeException -> Bool - isExpectedException e = "undefined" `isInfixOf` show e - - expected, actual :: Rep (K Int) R - expected = Rep.unsafeFromList [0, 0] - actual = Rep.map' (\_ -> K 0) undefined - -test_mapM :: Assertion -test_mapM = do - r <- newIORef 1 - - let next :: f x -> IO (K Int x) - next _ = atomicModifyIORef r $ \i -> (i + 1, K i) - - actual :: Rep (K Int) R <- Rep.mapM next undefined - assertEqual "" expected actual - where - expected :: Rep (K Int) R - expected = Rep.unsafeFromList [1, 2] - -test_cmap :: Assertion -test_cmap = - assertEqual "" expected actual - where - expected, actual :: R - expected = [lr| MkR { ri = 0, rb = False } |] - actual = to $ Rep.cmap (Proxy @Bounded) (\_ -> I minBound) undefined - -test_cmapM :: Assertion -test_cmapM = do - r <- newIORef False - - let next :: Bounded x => f x -> IO (I x) - next _ = do - b <- atomicModifyIORef r $ \b -> (not b, b) - return . I $ if b then maxBound else minBound - - actual :: R <- to <$> Rep.cmapM (Proxy @Bounded) next undefined - assertEqual "" expected actual - where - expected :: R - expected = [lr| MkR { ri = 0, rb = True } |] - -test_zipWithM :: Assertion -test_zipWithM = - assertEqual "" expected actual - where - expected, actual :: Maybe (Rep (K Int) R) - expected = Just $ Rep.unsafeFromList [0, 0] - actual = Rep.zipWithM (\_ _ -> Just $ K 0) undefined undefined - -test_czipWithM :: Assertion -test_czipWithM = - assertEqual "" expected actual - where - expected, actual :: Maybe R - expected = Just $ [lr| MkR { ri = 0, rb = False } |] - actual = to <$> Rep.czipWithM - (Proxy @Bounded) - (\_ _ -> Just $ I minBound) - undefined - undefined diff --git a/test/Test/Record/Sanity/Lens/Micro.hs b/test/Test/Record/Sanity/Lens/Micro.hs deleted file mode 100644 --- a/test/Test/Record/Sanity/Lens/Micro.hs +++ /dev/null @@ -1,297 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE ImpredicativeTypes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -Wno-missing-signatures #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - -module Test.Record.Sanity.Lens.Micro (tests) where - -import Data.Kind -import Data.Maybe (fromJust) -import Data.SOP -import Lens.Micro (Lens', (^.), (&), (%~)) -import Test.Tasty -import Test.Tasty.HUnit - -import Data.Record.Generic -import Data.Record.Generic.Lens.Micro -import Data.Record.Generic.SOP -import Data.Record.Generic.Transform -import Data.Record.QQ.CodeGen -import Data.Record.TH - -import qualified Data.Record.Generic.Rep as Rep - -{------------------------------------------------------------------------------- - Simple example (no type families) --------------------------------------------------------------------------------} - -largeRecord defaultPureScript [d| - data Simple (f :: Type -> Type) = MkSimple { - s1 :: f Int - , s2 :: f Bool - , s3 :: f Char - } - deriving (Show, Eq) - |] - -simpleExample :: Simple I -simpleExample = [lr| MkSimple { - s1 = I 5 - , s2 = I True - , s3 = I 'a' - } |] - -simpleExampleLenses :: Simple (RegularRecordLens Simple f) -simpleExampleLenses = lensesForRegularRecord (Proxy @DefaultInterpretation) - -[lr| MkSimple { - s1 = RegularRecordLens xs1 - , s2 = RegularRecordLens xs2 - , s3 = RegularRecordLens xs3 - } |] = simpleExampleLenses - -{------------------------------------------------------------------------------- - Simplified version of beam's 'Columnar' type' --------------------------------------------------------------------------------} - -data Lenses (tbl :: (Type -> Type) -> Type) (f :: Type -> Type) (x :: Type) - -data WrapLens a b = WrapLens (Lens' a b) - -type family Columnar f x :: Type where - Columnar I x = x - Columnar (Lenses tbl f) x = WrapLens (tbl f) (Columnar f x) - Columnar f x = f x - -{------------------------------------------------------------------------------- - Example with type families, but still regular - - See /next/ example for usage of, and motivation for, 'Lenses'. --------------------------------------------------------------------------------} - -data BeamInterpretation (f :: Type -> Type) - -type instance Interpreted (BeamInterpretation f) (Uninterpreted x) = Columnar f x - -instance StandardInterpretation BeamInterpretation (RegularRecordLens tbl f) -instance StandardInterpretation BeamInterpretation I - -largeRecord defaultPureScript [d| - data Regular (f :: Type -> Type) = MkRegular { - r1 :: Columnar f Int - , r2 :: Columnar f Bool - , r3 :: Columnar f Char - } - deriving (Show, Eq) - |] - -regularExample :: Regular I -regularExample = [lr| MkRegular { - r1 = 5 - , r2 = True - , r3 = 'a' - } |] - -regularLenses :: Regular (RegularRecordLens Regular I) -regularLenses = lensesForRegularRecord (Proxy @BeamInterpretation) - -[lr| MkRegular { - r1 = RegularRecordLens xr1 - , r2 = RegularRecordLens xr2 - , r3 = RegularRecordLens xr3 - } |] = regularLenses - -{------------------------------------------------------------------------------- - Beam-like example - - The lenses we generate above have @I x@ as their argument, rather than @x@. In - beam, the lenses have @Columnar f x@ as their target, which is just @x@ in the - case that @f == I@. If we want to replicate this, we cannot use - 'lensesForRegularRecord', which gives us 'RegularRecordLens', and must instead - use the lower-level function 'lensesForHKRecord'. This example is still - simplified from the beam example because we don't support any form of mixins; - we insist every field is regular, which allows us to avoid introducing a - separate type class. See the @beam-large-package@ for full beam integration. --------------------------------------------------------------------------------} - -beamLikeLenses :: forall tbl. - ( Generic (tbl (Lenses tbl I)) - , Generic (tbl Uninterpreted) - , Generic (tbl I) - , HasNormalForm (BeamInterpretation (Lenses tbl I)) (tbl (Lenses tbl I)) (tbl Uninterpreted) - , HasNormalForm (BeamInterpretation I) (tbl I) (tbl Uninterpreted) - , Constraints (tbl Uninterpreted) (IsRegularField Uninterpreted) - ) - => tbl (Lenses tbl I) -beamLikeLenses = - to . denormalize1 (Proxy @BeamInterpretation) $ - Rep.cmap - (Proxy @(IsRegularField Uninterpreted)) - aux - (lensesForHKRecord (Proxy @BeamInterpretation)) - where - aux :: forall x. - IsRegularField Uninterpreted x - => HKRecordLens BeamInterpretation I tbl x - -> Interpret (BeamInterpretation (Lenses tbl I)) x - aux (HKRecordLens l) = - case isRegularField (Proxy @(Uninterpreted x)) of - RegularField -> Interpret $ WrapLens $ - l - . standardInterpretationLens (Proxy @BeamInterpretation) - . unI' - - unI' :: Lens' (I x) x - unI' f (I x) = I <$> f x - -regularBeamLikeLenses :: Regular (Lenses Regular I) -regularBeamLikeLenses = beamLikeLenses - -[lr| MkRegular { - r1 = WrapLens br1 - , r2 = WrapLens br2 - , r3 = WrapLens br3 - } |] = regularBeamLikeLenses - -{------------------------------------------------------------------------------- - Irregular example --------------------------------------------------------------------------------} - -largeRecord defaultPureScript [d| - data Irregular (f :: Type -> Type) = MkIrregular { - i1 :: f Int - , i2 :: f Bool - , i3 :: Char -- No @f@! - } - deriving (Show, Eq) - |] - -irregularExample :: Irregular I -irregularExample = [lr| MkIrregular { - i1 = I 5 - , i2 = I True - , i3 = 'a' - } |] - --- We cannot define this now: --- --- > irregularLenses :: Irregular (RegularRecordLens Irregular I) --- > irregularLenses = lensesForRegularRecord (Proxy @DefaultInterpretation) --- --- It will complain that @Char@ is not equal to --- --- > Interpreted (DefaultInterpretation (RegularRecordLens Irregular I)) Char --- --- We can use 'repLenses' to nonetheless get lenses for all fields in --- 'Irregular', and then translate to an NP so that we can pattern match on it --- in a type-safe way. Of course, the translation to SOP incurs O(N^2) --- compile-time cost so this is not a proper solution. --- --- NOTE: There is not much point using 'repLenses'' here; that is primarily --- useful only if there is some post-processing step (like done by --- 'lensesForRegularRecord'). -irregularLenses :: NP (Field (SimpleRecordLens (Irregular f))) (MetadataOf (Irregular f)) -irregularLenses = fromJust $ toSOP rep - where - rep :: Rep (SimpleRecordLens (Irregular f)) (Irregular f) - rep = lensesForSimpleRecord - -( Field (SimpleRecordLens xi1) - :* Field (SimpleRecordLens xi2) - :* Field (SimpleRecordLens xi3) - :* Nil ) = irregularLenses - -{------------------------------------------------------------------------------- - Tests proper --------------------------------------------------------------------------------} - -tests :: TestTree -tests = testGroup "Test.Record.Sanity.Lens.Micro" [ - testCase "simple_get" test_simple_get - , testCase "simple_set" test_simple_set - , testCase "regular_get" test_regular_get - , testCase "regular_set" test_regular_set - , testCase "beamlike_get" test_beamlike_get - , testCase "beamlike_set" test_beamlike_set - , testCase "irregular_get" test_irregular_get - , testCase "irregular_set" test_irregular_set - ] - -test_simple_get :: Assertion -test_simple_get = - assertEqual "" (I True) - (simpleExample ^. xs2) - -test_simple_set :: Assertion -test_simple_set = - assertEqual "" expected $ - simpleExample & xs1 %~ mapII negate & xs3 %~ mapII succ - where - expected :: Simple I - expected = [lr| MkSimple { - s1 = I (-5) - , s2 = I True - , s3 = I 'b' - } |] - -test_regular_get :: Assertion -test_regular_get = - assertEqual "" (I True) - (regularExample ^. xr2) - -test_regular_set :: Assertion -test_regular_set = - assertEqual "" expected $ - regularExample & xr1 %~ mapII negate & xr3 %~ mapII succ - where - expected :: Regular I - expected = [lr| MkRegular { - r1 = (-5) - , r2 = True - , r3 = 'b' - } |] - -test_beamlike_get :: Assertion -test_beamlike_get = - assertEqual "" True - (regularExample ^. br2) - -test_beamlike_set :: Assertion -test_beamlike_set = - assertEqual "" expected $ - regularExample & br1 %~ negate & br3 %~ succ - where - expected :: Regular I - expected = [lr| MkRegular { - r1 = (-5) - , r2 = True - , r3 = 'b' - } |] - -test_irregular_get :: Assertion -test_irregular_get = - assertEqual "" (I True) - (irregularExample ^. xi2) - -test_irregular_set :: Assertion -test_irregular_set = - assertEqual "" expected $ - irregularExample & xi1 %~ mapII negate & xi3 %~ succ - where - expected :: Irregular I - expected = [lr| MkIrregular { - i1 = I (-5) - , i2 = I True - , i3 = 'b' - } |] 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 @@ -1,43 +1,50 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-} --- {-# OPTIONS_GHC -ddump-splices #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Sanity.OverloadingNoDRF ( tests ) where -import Data.Record.TH +import GHC.Records.Compat import Test.Tasty import Test.Tasty.HUnit {------------------------------------------------------------------------------- Simple test case --------------------------------------------------------------------------------} -largeRecord defaultPureScript [d| - data X = MkX { a :: Int } - data Y = MkY { a :: String } - |] + We don't support DRF-style overloading, but we _can_ generate records when DRF + is in use, provided all overloading is resolved through `HasField` instead of + through DRF. +--------------------------------------s-----------------------------------------} +{-# ANN type X largeRecordStrict #-} +data X = MkX { a :: Int } + +{-# ANN type Y largeRecordStrict #-} +data Y = MkY { a :: String } + testOverloading :: Assertion testOverloading = do - assertEqual "X" x.a 0 - assertEqual "Y" y.a "hi" + assertEqual "X" (getField @"a" x) 0 + assertEqual "Y" (getField @"a" y) "hi" where x :: X - x = _construct_MkX 0 + x = MkX {a = 0} y :: Y - y = _construct_MkY "hi" + y = MkY {a = "hi"} tests :: TestTree tests = testGroup "Test.Record.Sanity.OverloadingNoDRF" [ 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 @@ -1,21 +1,19 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-missing-signatures #-} {-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-} --- {-# OPTIONS_GHC -ddump-splices #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Sanity.PatternMatch (tests) where @@ -24,44 +22,48 @@ import Test.Tasty import Test.Tasty.HUnit -import Data.Record.TH - import Test.Record.Util {------------------------------------------------------------------------------- Basic pattern matching tests -------------------------------------------------------------------------------} -largeRecord defaultPureScript [d| - data T a = MkT { x :: Int, y :: [a], z :: Double } - data S a = MkS { x :: Char, y :: T a } - |] +{-# ANN type T largeRecordStrict #-} +data T a = MkT { x :: Int, y :: [a], z :: Double } +{-# ANN type S largeRecordStrict #-} +data S a = MkS { x :: Char, y :: T a } + projectOne :: T Bool -> Int -projectOne [lr| MkT { x = a } |] = a +projectOne MkT { x = a } = a projectTwo :: T a -> (Int, [a]) -projectTwo [lr| MkT { x = a, y = b } |] = (a, b) +projectTwo MkT { x = a, y = b } = (a, b) -- | Test projecting more than 2 elements -- -- This is an important special case, because this checks that the pattern we -- generate is correctedly nested to match the 'MatchHasField' instances. projectThree :: T a -> (Int, [a], Double) -projectThree [lr| MkT { x = a, y = b, z = c } |] = (a, b, c) +projectThree MkT { x = a, y = b, z = c } = (a, b, c) projectPuns :: T a -> (Int, [a]) -projectPuns [lr| MkT { x, y } |] = (x, y) +projectPuns MkT { x, y } = (x, y) projectNested :: S a -> (Char, Int, [a]) -projectNested [lr| MkS { x = a, y = MkT { x = b, y = c } } |] = (a, b, c) +projectNested MkS { x = a, y = MkT { x = b, y = c } } = (a, b, c) projectView :: T Bool -> Int -projectView [lr| MkT { x = ((+1) -> a) } |] = a +projectView MkT { x = ((+1) -> a) } = a matchEmpty :: T Bool -> Int -matchEmpty [lr| MkT {} |] = 42 +matchEmpty MkT {} = 42 +-- | A pattern match on a record that does not extract any variables should +-- nonetheless be strict +matchEmptyUndefined :: Int +matchEmptyUndefined = matchEmpty (error "boom") + {------------------------------------------------------------------------------- Verify inferred types @@ -73,19 +75,18 @@ type errors iff 'noSigEmpty' and 'noSigNonEmpty' are suffciently monomorphic. -------------------------------------------------------------------------------} -largeRecord defaultPureScript [d| - data T2 = MkT2 { x :: Int } - |] +{-# ANN type T2 largeRecordStrict #-} +data T2 = MkT2 { x :: Int } -noSigEmpty [lr| MkT {} |] = () +noSigEmpty MkT {} = () -noSigNonEmpty [lr| MkT { x = a } |] = const () a +noSigNonEmpty MkT { x = a } = const () a useNoSigEmpty :: () -useNoSigEmpty = noSigEmpty [lr| MkT2 { x = 5 } |] +useNoSigEmpty = noSigEmpty MkT2 { x = 5 } useNoSigNonEmpty :: () -useNoSigNonEmpty = noSigNonEmpty [lr| MkT2 { x = 5 } |] +useNoSigNonEmpty = noSigNonEmpty MkT2 { x = 5 } {------------------------------------------------------------------------------- Tests proper @@ -101,21 +102,31 @@ assertEqual "view" (projectView t) 6 assertEqual "empty" (matchEmpty t) 42 + expectException isBoom $ + assertEqual "empty-undefined" matchEmptyUndefined 42 + expectException isExpectedTypeError $ assertEqual "sig-empty" useNoSigEmpty () expectException isExpectedTypeError $ assertEqual "sig-nonempty" useNoSigNonEmpty () where + isBoom :: SomeException -> Bool + isBoom e = "boom" `isInfixOf` show e + isExpectedTypeError :: SomeException -> Bool - isExpectedTypeError e = "Couldn't match expected type" `isInfixOf` show e + isExpectedTypeError e = and [ + "Couldn't match" `isInfixOf` show e + , "T" `isInfixOf` show e + , "T2" `isInfixOf` show e + ] t :: T Bool - t = [lr| MkT { x = 5, y = [True], z = 1.0 } |] + t = MkT { x = 5, y = [True], z = 1.0 } s :: S Bool - s = [lr| MkS { x = 'a', y = MkT { x = 2, y = [True, False], z = 1.0 } } |] + s = MkS { x = 'a', y = MkT { x = 2, y = [True, False], z = 1.0 } } tests :: TestTree -tests = testGroup "Test.Record.Sanity.Projection" [ +tests = testGroup "Test.Record.Sanity.PatternMatch" [ testCase "projections" testProjections ] diff --git a/test/Test/Record/Sanity/QualifiedImports.hs b/test/Test/Record/Sanity/QualifiedImports.hs --- a/test/Test/Record/Sanity/QualifiedImports.hs +++ b/test/Test/Record/Sanity/QualifiedImports.hs @@ -1,15 +1,14 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} -- {-# OPTIONS_GHC -ddump-splices #-} module Test.Record.Sanity.QualifiedImports (tests) where -import Data.Record.TH +import GHC.Records.Compat import Test.Tasty import Test.Tasty.HUnit @@ -18,16 +17,16 @@ import qualified Test.Record.Sanity.QualifiedImports.B as B constructA :: A.T Bool -constructA = [lr| A.MkT { x = 5, y = [True] } |] +constructA = A.MkT { A.x = 5, A.y = [True] } constructB :: B.T Bool -constructB = [lr| B.MkT { x = 'a', y = A.MkT { x = 2, y = [True, False] } } |] +constructB = B.MkT { B.x = 'a', B.y = A.MkT { A.x = 2, A.y = [True, False] } } projectA :: A.T a -> (Int, [a]) -projectA [lr| A.MkT { x = a, y = b } |] = (a, b) +projectA A.MkT { A.x = a, A.y = b } = (a, b) projectB :: B.T a -> (Char, Int, [a]) -projectB [lr| B.MkT { x = a, y = A.MkT { x = b, y = c } } |] = (a, b, c) +projectB B.MkT { B.x = a, B.y = A.MkT { A.x = b, A.y = c } } = (a, b, c) tests :: TestTree tests = testGroup "Test.Record.Sanity.QualifiedImports" [ @@ -36,10 +35,10 @@ testQualifiedImports :: Assertion testQualifiedImports = do - assertEqual "constructA" a.x 5 - assertEqual "projectA" (projectA a) (5, [True]) - assertEqual "constructB" b.x 'a' - assertEqual "projectB" (projectB b) ('a', 2, [True, False]) + assertEqual "projectA" (projectA a) $ (5, [True]) + assertEqual "projectB" (projectB b) $ ('a', 2, [True, False]) + assertEqual "constructA" (getField @"x" a) $ 5 + assertEqual "constructB" (getField @"x" b) $ 'a' where a :: A.T Bool a = constructA 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 @@ -1,17 +1,15 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -module Test.Record.Sanity.QualifiedImports.A where +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} -import Data.Record.TH +module Test.Record.Sanity.QualifiedImports.A (T(..)) where -largeRecord defaultPureScript [d| - data T a = MkT { x :: Int, y :: [a] } - |] +{-# ANN type T largeRecordStrict #-} +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 @@ -1,19 +1,18 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -module Test.Record.Sanity.QualifiedImports.B where +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} -import Data.Record.TH +module Test.Record.Sanity.QualifiedImports.B (T(..)) where import qualified Test.Record.Sanity.QualifiedImports.A as A -largeRecord defaultPureScript [d| - data T a = MkT { x :: Char, y :: A.T a } - |] +{-# ANN type T largeRecordStrict #-} +data T a = MkT { x :: Char, y :: A.T a } diff --git a/test/Test/Record/Sanity/RDP/SingleModule.hs b/test/Test/Record/Sanity/RDP/SingleModule.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/RDP/SingleModule.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor -fplugin=Data.Record.Plugin #-} + +-- | 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 + +{------------------------------------------------------------------------------- + Simple field selection and override +-------------------------------------------------------------------------------} + +{-# ANN type R1 largeRecordStrict #-} +data R1 = MkR1 { r1_x :: Int, r1_y :: Bool } + deriving (Show, Eq) + +test_simple :: Assertion +test_simple = do + assertEqual "x" r1.r1_x $ 1 + assertEqual "y" r1.r1_y $ True + assertEqual "r1_x" r1_x' $ r1{r1_x = 2} + assertEqual "r1_y" r1_y' $ r1{r1_y = False} + assertEqual "r1_xy" r1_xy' $ r1{r1_x = 2, r1_y = False} + where + r1, r1_x', r1_y', r1_xy' :: R1 + r1 = MkR1 { r1_x = 1, r1_y = True } + r1_x' = MkR1 { r1_x = 2, r1_y = True } + r1_y' = MkR1 { r1_x = 1, r1_y = False } + r1_xy' = MkR1 { r1_x = 2, r1_y = False } + +{------------------------------------------------------------------------------- + Field selection and override when there are overloaded fields +-------------------------------------------------------------------------------} + +{-# ANN type R2 largeRecordStrict #-} +data R2 = MkR2 { a :: Int, b :: Bool } + deriving (Show, Eq) + +{-# ANN type R3 largeRecordStrict #-} +data R3 = MkR3 { a :: Int, b :: Char } + deriving (Show, Eq) + +test_overloaded :: Assertion +test_overloaded = do + assertEqual "r2.a" r2.a $ 1 + assertEqual "r2.b" r2.b $ True + assertEqual "r3.a" r3.a $ 2 + assertEqual "r3.b" r3.b $ 'a' + assertEqual "r2'" r2' $ r2{a = 2} + assertEqual "r3'" r3' $ r3{b = 'b'} + where + r2, r2' :: R2 + r2 = MkR2 { a = 1, b = True } + r2' = MkR2 { a = 2, b = True } + + r3 :: R3 + r3 = MkR3 { a = 2, b = 'a' } + r3' = MkR3 { a = 2, b = 'b' } + +{------------------------------------------------------------------------------- + Nested records + + Both with and without LR. +-------------------------------------------------------------------------------} + +data R4_WOutLR = MkR4_WOutLR { r4_woutLR_x :: Int, r4_woutLR_y :: R5_WOutLR } + deriving (Show, Eq) + +data R5_WOutLR = MkR5_WOutLR { r5_woutLR_x :: Char, r5_woutLR_y :: Double } + deriving (Show, Eq) + +{-# ANN type R4_WithLR largeRecordStrict #-} +data R4_WithLR = MkR4_WithLR { r4_withLR_x :: Int, r4_withLR_y :: R5_WithLR } + deriving (Show, Eq) + +{-# ANN type R5_WithLR largeRecordStrict #-} +data R5_WithLR = MkR5_WithLR { r5_withLR_x :: Char, r5_withLR_y :: Double } + deriving (Show, Eq) + +test_nested :: Assertion +test_nested = do + assertEqual "r4_woutLR_x" r4_woutLR.r4_woutLR_y.r5_woutLR_x $ 'a' + assertEqual "r4_withLR_x" r4_WithLR.r4_withLR_y.r5_withLR_x $ 'a' + where + r4_woutLR :: R4_WOutLR + r4_woutLR = MkR4_WOutLR { r4_woutLR_x = 1, r4_woutLR_y = r5_woutLR } + + r5_woutLR :: R5_WOutLR + r5_woutLR = MkR5_WOutLR { r5_woutLR_x = 'a', r5_woutLR_y = 1.2 } + + r4_WithLR :: R4_WithLR + r4_WithLR = MkR4_WithLR { r4_withLR_x = 1, r4_withLR_y = r5_WithLR } + + r5_WithLR :: R5_WithLR + r5_WithLR = MkR5_WithLR { r5_withLR_x = 'a', r5_withLR_y = 1.2 } + +{------------------------------------------------------------------------------- + Collect all tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.RDP" [ + testCase "simple" test_simple + , testCase "overloaded" test_overloaded + , testCase "nested" test_nested + ] diff --git a/test/Test/Record/Sanity/RDP/SplitModule.hs b/test/Test/Record/Sanity/RDP/SplitModule.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/RDP/SplitModule.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE DuplicateRecordFields #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +-- | Test that the RDP plugin can use records created by large-records +-- +-- For this test, we split the modules: one using the large-records plugin, +-- one using the RDP plugin. See also "Test.Record.Sanity.RDP.SingleModule". +module Test.Record.Sanity.RDP.SplitModule (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Test.Record.Sanity.RDP.SplitModule.RecordDef + +{------------------------------------------------------------------------------- + Simple field selection and override +-------------------------------------------------------------------------------} + +test_simple :: Assertion +test_simple = do + assertEqual "x" r1.r1_x $ 1 + assertEqual "y" r1.r1_y $ True + assertEqual "r1_x" r1_x' $ r1{r1_x = 2} + assertEqual "r1_y" r1_y' $ r1{r1_y = False} + assertEqual "r1_xy" r1_xy' $ r1{r1_x = 2, r1_y = False} + where + r1, r1_x', r1_y', r1_xy' :: R1 + r1 = MkR1 { r1_x = 1, r1_y = True } + r1_x' = MkR1 { r1_x = 2, r1_y = True } + r1_y' = MkR1 { r1_x = 1, r1_y = False } + r1_xy' = MkR1 { r1_x = 2, r1_y = False } + +{------------------------------------------------------------------------------- + Field selection and override when there are overloaded fields +-------------------------------------------------------------------------------} + +test_overloaded :: Assertion +test_overloaded = do + assertEqual "r2.a" r2.a $ 1 + assertEqual "r2.b" r2.b $ True + assertEqual "r3.a" r3.a $ 2 + assertEqual "r3.b" r3.b $ 'a' + assertEqual "r2'" r2' $ r2{a = 2} + assertEqual "r3'" r3' $ r3{b = 'b'} + where + r2, r2' :: R2 + r2 = MkR2 { a = 1, b = True } + r2' = MkR2 { a = 2, b = True } + + r3 :: R3 + r3 = MkR3 { a = 2, b = 'a' } + r3' = MkR3 { a = 2, b = 'b' } + +{------------------------------------------------------------------------------- + Nested records + + Both with and without LR. +-------------------------------------------------------------------------------} + +data R4_WOutLR = MkR4_WOutLR { r4_woutLR_x :: Int, r4_woutLR_y :: R5_WOutLR } + deriving (Show, Eq) + +data R5_WOutLR = MkR5_WOutLR { r5_woutLR_x :: Char, r5_woutLR_y :: Double } + deriving (Show, Eq) + +test_nested :: Assertion +test_nested = do + assertEqual "r4_woutLR_x" r4_woutLR.r4_woutLR_y.r5_woutLR_x $ 'a' + assertEqual "r4_withLR_x" r4_WithLR.r4_withLR_y.r5_withLR_x $ 'a' + where + r4_woutLR :: R4_WOutLR + r4_woutLR = MkR4_WOutLR { r4_woutLR_x = 1, r4_woutLR_y = r5_woutLR } + + r5_woutLR :: R5_WOutLR + r5_woutLR = MkR5_WOutLR { r5_woutLR_x = 'a', r5_woutLR_y = 1.2 } + + r4_WithLR :: R4_WithLR + r4_WithLR = MkR4_WithLR { r4_withLR_x = 1, r4_withLR_y = r5_WithLR } + + r5_WithLR :: R5_WithLR + r5_WithLR = MkR5_WithLR { r5_withLR_x = 'a', r5_withLR_y = 1.2 } + +{------------------------------------------------------------------------------- + Collect all tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.RDP.SplitModule" [ + testCase "simple" test_simple + , testCase "overloaded" test_overloaded + , testCase "nested" test_nested + ] diff --git a/test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs b/test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} + +-- | Record definitions for "Test.Record.Sanity.RDP.SplitModule" +-- +-- See "Test.Record.Sanity.RDP.SplitModule" for details. +module Test.Record.Sanity.RDP.SplitModule.RecordDef ( + R1(..) + , R2(..) + , R3(..) + , R4_WithLR(..) + , R5_WithLR(..) + ) where + +{-# ANN type R1 largeRecordStrict #-} +data R1 = MkR1 { r1_x :: Int, r1_y :: Bool } + deriving (Show, Eq) + +{-# ANN type R2 largeRecordStrict #-} +data R2 = MkR2 { a :: Int, b :: Bool } + deriving (Show, Eq) + +{-# ANN type R3 largeRecordStrict #-} +data R3 = MkR3 { a :: Int, b :: Char } + deriving (Show, Eq) + +{-# ANN type R4_WithLR largeRecordStrict #-} +data R4_WithLR = MkR4_WithLR { r4_withLR_x :: Int, r4_withLR_y :: R5_WithLR } + deriving (Show, Eq) + +{-# ANN type R5_WithLR largeRecordStrict #-} +data R5_WithLR = MkR5_WithLR { r5_withLR_x :: Char, r5_withLR_y :: Double } + 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 @@ -1,21 +1,20 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-} --- {-# OPTIONS_GHC -ddump-splices #-} -{-# OPTIONS_GHC -Wwarn #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Sanity.RecordConstruction (tests) where -import Data.Record.TH +import GHC.Records.Compat import Test.Tasty import Test.Tasty.HUnit @@ -27,26 +26,28 @@ -- -- Test both the case where the name of the type and the name of the constructor -- are the same and where they are different. -largeRecord (defaultPureScript {allFieldsStrict = False}) [d| - data R a = MkR { x :: Int, y :: [a] } deriving (Eq, Show) - data S a = S { x :: Int, y :: [a] } deriving (Eq, Show) - |] +{-# ANN type R largeRecordLazy #-} +data R a = MkR { x :: Int, y :: [a] } deriving (Eq, Show) + +{-# ANN type S largeRecordLazy #-} +data S a = S { x :: Int, y :: [a] } deriving (Eq, Show) + inOrder :: R Bool -inOrder = [lr| MkR { x = 1234, y = [True] } |] +inOrder = MkR { x = 1234, y = [True] } outOfOrder :: R Bool -outOfOrder = [lr| MkR { y = [True], x = 1234 } |] +outOfOrder = MkR { y = [True], x = 1234 } -- | Constructor application -- -- Occassionally we cannot use the quasi-quoter (for instance, in an -- applicative context). constructorApp :: R Bool -constructorApp = [lr| MkR |] 1234 [True] +constructorApp = MkR 1234 [True] valueOfS :: S Bool -valueOfS = [lr| S { x = 1234, y = [True] } |] +valueOfS = S { x = 1234, y = [True] } {------------------------------------------------------------------------------- Nested records @@ -55,16 +56,14 @@ data RegularRecord = RR { a :: Int } deriving (Show, Eq) -largeRecord defaultPureScript [d| - data T = T { x :: Int, y :: S Bool, z :: RegularRecord } - |] +{-# ANN type T largeRecordStrict #-} +data T = T { x :: Int, y :: S Bool, z :: RegularRecord } valueOfT :: T -valueOfT = [lr| T { x = 5 - , y = S { x = 1234, y = [True] } - , z = RR { a = 5 } - } - |] +valueOfT = T { x = 5 + , y = S { x = 1234, y = [True] } + , z = RR { a = 5 } + } {------------------------------------------------------------------------------- Sanity check @@ -77,8 +76,8 @@ testAllEqual :: Assertion testAllEqual = do - assertEqual "inOrder/outOfOrder" inOrder.x outOfOrder.x - assertEqual "inOrder/withoutQQ" inOrder.x constructorApp.x - assertEqual "R/S" inOrder.x valueOfS.x - assertEqual "T/S" valueOfT.y valueOfS - assertEqual "T/R" valueOfT.z (RR 5) + assertEqual "inOrder/outOfOrder" (getField @"x" inOrder) (getField @"x" outOfOrder) + assertEqual "inOrder/withoutQQ" (getField @"x" inOrder) (getField @"x" constructorApp) + assertEqual "R/S" (getField @"x" inOrder) (getField @"x" valueOfS) + assertEqual "T/S" (getField @"y" valueOfT) valueOfS + assertEqual "T/R" (getField @"z" valueOfT) (RR 5) 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 @@ -1,16 +1,18 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} --- {-# OPTIONS_GHC -ddump-splices -ddump-simpl #-} +{-# OPTIONS_GHC -fplugin=Data.Record.Plugin #-} module Test.Record.Sanity.Strictness (tests) where @@ -19,23 +21,20 @@ import Data.Record.Generic import Data.Record.Generic.LowerBound -import Data.Record.TH import qualified Data.Record.Generic.Rep as Rep import Test.Tasty import Test.Tasty.HUnit -largeRecord defaultLazyOptions [d| - data Lazy = MkLazy { lazyField :: Word } - |] +{-# ANN type Lazy largeRecordLazy #-} +data Lazy = MkLazy { lazyField :: Word } -largeRecord defaultStrictOptions [d| - data Strict = MkStrict { strictField :: Word } - |] +{-# ANN type Strict largeRecordStrict #-} +data Strict = MkStrict { strictField :: Word } -_silenceWarnings :: () -_silenceWarnings = const () $ ( +_silenceWarnings :: Lazy -> Strict -> () +_silenceWarnings MkLazy{..} MkStrict{..} = const () $ ( lazyField , strictField ) diff --git a/test/Test/Record/Sanity/Transform.hs b/test/Test/Record/Sanity/Transform.hs deleted file mode 100644 --- a/test/Test/Record/Sanity/Transform.hs +++ /dev/null @@ -1,339 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -module Test.Record.Sanity.Transform (tests) where - -import Data.Functor.Identity -import Data.Kind -import Data.Proxy -import Data.SOP.BasicFunctors -import GHC.TypeLits - -import Test.Tasty -import Test.Tasty.HUnit - -import Data.Record.TH -import Data.Record.Generic -import Data.Record.Generic.Transform - -import qualified Data.Record.Generic.Rep as Rep -import qualified Generics.SOP as SOP - -{------------------------------------------------------------------------------- - Motivating example using SOP --------------------------------------------------------------------------------} - -class CanInject x y where - inject :: x -> y - -instance CanInject (I x) (Maybe x) where - inject (I x) = Just x - -instance CanInject String String where - inject = id - -_gjust_SOP :: forall x fields fields'. - ( SOP.Generic (x I) - , SOP.Generic (x Maybe) - , SOP.IsProductType (x I) fields - , SOP.IsProductType (x Maybe) fields' - , SOP.AllZip CanInject fields fields' - ) - => x I -> x Maybe -_gjust_SOP = - SOP.productTypeTo . aux . SOP.productTypeFrom - where - aux :: SOP.NP I fields -> SOP.NP I fields' - aux = SOP.htrans (Proxy @CanInject) (fmap inject) - -{------------------------------------------------------------------------------- - Simple example --------------------------------------------------------------------------------} - -type instance Interpreted (DefaultInterpretation f) String = String - -class InjectInterpreted f g a where - injectInterpreted :: - Interpret (DefaultInterpretation f) a - -> Interpret (DefaultInterpretation g) a - -instance InjectInterpreted I Maybe (Uninterpreted a) where - injectInterpreted = liftInterpreted $ \(I x) -> Just x - -instance InjectInterpreted I Maybe String where - injectInterpreted = liftInterpreted $ id - -largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d| - data A (f :: Type -> Type) = A { - aI :: f Int - , aB :: f Bool - , aS :: String - } - deriving (Show, Eq) - |] - --- | Generic injection, using LR generics --- --- The type annotations are just to explain the flow, they are not required --- for type inference. -gjust :: forall x (f :: Type -> Type) (g :: Type -> Type). - ( Generic (x f) - , Generic (x g) - , Generic (x Uninterpreted) - , Constraints (x Uninterpreted) (InjectInterpreted f g) - , HasNormalForm (DefaultInterpretation f) (x f) (x Uninterpreted) - , HasNormalForm (DefaultInterpretation g) (x g) (x Uninterpreted) - ) - => x f -> x g -gjust = - (to - :: Rep I (x g) - -> x g) - . (denormalize1 (Proxy @DefaultInterpretation) - :: Rep (Interpret (DefaultInterpretation g)) (x Uninterpreted) - -> Rep I (x g)) - . (Rep.cmap (Proxy @(InjectInterpreted f g)) injectInterpreted - :: Rep (Interpret (DefaultInterpretation f)) (x Uninterpreted) - -> Rep (Interpret (DefaultInterpretation g)) (x Uninterpreted)) - . (normalize1 (Proxy @DefaultInterpretation) - :: Rep I (x f) - -> Rep (Interpret (DefaultInterpretation f)) (x Uninterpreted)) - . (from - :: x f - -> Rep I (x f)) - -justA :: A I -> A Maybe -justA = gjust - -{------------------------------------------------------------------------------- - Example with two variables --------------------------------------------------------------------------------} - -largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d| - data B (f :: Type -> Type) (g :: Type -> Type) = B { - bI :: f Int - , bB :: g Bool - , bS :: String - } - deriving (Show, Eq) - |] - -data Skolem (n :: Nat) x - -data DefInt2 (f :: Type -> Type) (g :: Type -> Type) - -type instance Interpreted (DefInt2 f g) (Skolem 0 x) = f x -type instance Interpreted (DefInt2 f g) (Skolem 1 x) = g x -type instance Interpreted (DefInt2 f g) String = String - -class SwapInterpreted f g a where - swapInterpreted :: - Interpret (DefInt2 f g) a - -> Interpret (DefInt2 g f) a - -instance SwapInterpreted I Identity (Skolem 0 x) where - swapInterpreted = liftInterpreted $ \(I x) -> Identity x - -instance SwapInterpreted I Identity (Skolem 1 y) where - swapInterpreted = liftInterpreted $ \(Identity x) -> I x - -instance SwapInterpreted f g String where - swapInterpreted = liftInterpreted $ id - -gswap :: forall x (f :: Type -> Type) (g :: Type -> Type). - ( Generic (x f g) - , Generic (x g f) - , Generic (x (Skolem 0) (Skolem 1)) - , Constraints (x (Skolem 0) (Skolem 1)) (SwapInterpreted f g) - , HasNormalForm (DefInt2 f g) (x f g) (x (Skolem 0) (Skolem 1)) - , HasNormalForm (DefInt2 g f) (x g f) (x (Skolem 0) (Skolem 1)) - ) - => x f g -> x g f -gswap = - to - . denormalize (Proxy @(DefInt2 g f)) (Proxy @(x (Skolem 0) (Skolem 1))) - . Rep.cmap (Proxy @(SwapInterpreted f g)) swapInterpreted - . normalize (Proxy @(DefInt2 f g)) (Proxy @(x (Skolem 0) (Skolem 1))) - . from - -swapB :: B I Identity -> B Identity I -swapB = gswap - -{------------------------------------------------------------------------------- - Mini-beam --------------------------------------------------------------------------------} - -data Nullable (c :: Type -> Type) x - -type family Columnar (f :: Type -> Type) x where - Columnar Identity x = x - Columnar (Nullable c) x = Columnar c (Maybe x) - Columnar f x = f x - -newtype Columnar' f a = Columnar' { getColumnar' :: Columnar f a } - -class Beamable table where - zipBeamFieldsM :: - Applicative m - => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) - -> table f -> table g -> m (table h) - -class (Beamable table, Beamable (PrimaryKey table)) => Table table where - data PrimaryKey table (f :: Type -> Type) :: Type - -{------------------------------------------------------------------------------- - Interpretation function for Beam --------------------------------------------------------------------------------} - -data BeamInterpretation (f :: Type -> Type) - -type instance Interpreted (BeamInterpretation f) (table Uninterpreted) = table f -type instance Interpreted (BeamInterpretation f) (Uninterpreted x) = Columnar f x - -class ZipInterpreted a where - zipInterpreted :: - Applicative m - => (forall x. Columnar' f x -> Columnar' g x -> m (Columnar' h x)) - -> Interpret (BeamInterpretation f) a - -> Interpret (BeamInterpretation g) a - -> m (Interpret (BeamInterpretation h) a) - -instance Beamable table => ZipInterpreted (table Uninterpreted) where - zipInterpreted f = liftInterpretedA2 $ zipBeamFieldsM f - -instance ZipInterpreted (Uninterpreted x) where - zipInterpreted f = liftInterpretedA2 $ applyColumnar' (Proxy @x) f - -applyColumnar' :: forall m f g h x. - Functor m - => Proxy x - -> (Columnar' f x -> Columnar' g x -> m (Columnar' h x)) - -> (Columnar f x -> Columnar g x -> m (Columnar h x)) -applyColumnar' _ f fx gx = getColumnar' <$> f (Columnar' fx) (Columnar' gx) - -{------------------------------------------------------------------------------- - Beam test --------------------------------------------------------------------------------} - -largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d| - data TableA (f :: Type -> Type) = TableA { - taFieldI :: PrimaryKey TableA f - , taFieldB :: Columnar f Bool - , taFieldM :: TableB f - } - deriving (Show, Eq) - - data TableB (f :: Type -> Type) = TableB { - tbFieldC :: Columnar f Char - } - deriving (Show, Eq) - |] - -instance Table TableA where - data PrimaryKey TableA f = PrimA (Columnar f Int) - -deriving instance Show (Columnar f Int) => Show (PrimaryKey TableA f) -deriving instance Eq (Columnar f Int) => Eq (PrimaryKey TableA f) - -instance Beamable (PrimaryKey TableA) where - -- The GHC.Generics instance would normally be fine for primary keys - zipBeamFieldsM f (PrimA x) (PrimA y) = PrimA <$> - applyColumnar' (Proxy @Int) f x y - -instance Beamable TableA where - zipBeamFieldsM = gzipBeam - -instance Beamable TableB where - zipBeamFieldsM = gzipBeam - -gzipBeam :: forall m table f g h. - ( Applicative m - , Generic (table f) - , Generic (table g) - , Generic (table h) - , Generic (table Uninterpreted) - , Constraints (table Uninterpreted) ZipInterpreted - , HasNormalForm (BeamInterpretation f) (table f) (table Uninterpreted) - , HasNormalForm (BeamInterpretation g) (table g) (table Uninterpreted) - , HasNormalForm (BeamInterpretation h) (table h) (table Uninterpreted) - ) - => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) - -> table f -> table g -> m (table h) -gzipBeam f a b = - fmap (to . denormalize1 (Proxy @BeamInterpretation)) $ - Rep.czipWithM - (Proxy @ZipInterpreted) - (zipInterpreted f) - (normalize1 (Proxy @BeamInterpretation) (from a)) - (normalize1 (Proxy @BeamInterpretation) (from b)) - -{------------------------------------------------------------------------------- - Tests --------------------------------------------------------------------------------} - -tests :: TestTree -tests = testGroup "Test.Record.Sanity.Transform" [ - testCase "gjust" test_gjust - , testCase "gswap" test_gswap - , testCase "gzipBeam" test_gzipBeam - ] - -test_gjust :: Assertion -test_gjust = - assertEqual "" - (justA $ A { aI = I 5, aB = I True, aS = "hi" }) - ( A { aI = Just 5, aB = Just True, aS = "hi" }) - -test_gswap :: Assertion -test_gswap = - assertEqual "" - (swapB $ B { bI = I 5, bB = Identity True, bS = "hi" }) - ( B { bI = Identity 5, bB = I True, bS = "hi" }) - -data Pair x = Pair x x - deriving (Show, Eq) - -test_gzipBeam :: Assertion -test_gzipBeam = - assertEqual "" - (unI (zipBeamFieldsM pairup tableA tableA)) - tableA' - where - pairup :: Columnar' I x -> Columnar' I x -> I (Columnar' Pair x) - pairup (Columnar' (I x)) (Columnar' (I y)) = I (Columnar' $ Pair x y) - - tableA :: TableA I - tableA = TableA { - taFieldI = PrimA (I 5) - , taFieldB = I True - , taFieldM = tableB - } - - tableB :: TableB I - tableB = TableB { - tbFieldC = I 'x' - } - - tableA' :: TableA Pair - tableA' = TableA { - taFieldI = PrimA (Pair 5 5) - , taFieldB = Pair True True - , taFieldM = tableB' - } - - tableB' :: TableB Pair - tableB' = TableB { - tbFieldC = Pair 'x' 'x' - } diff --git a/test/Test/Record/Size/After/HK010.hs b/test/Test/Record/Size/After/HK010.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/HK010.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - --- {-# OPTIONS_GHC -ddump-splices #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.HK010 where - -import Data.Record.TH - -import Test.Record.Size.Infra - -largeRecord defaultLazyOptions (higherKindedRecordOfSize 10) - --- Complains about --- --- > No instance for (Data.Functor.Classes.Show1 r) --- > arising from a use of ‘show’ --- --- which is what we want: @ghc@ has simplified all 10 constraints on each --- individual field (generated by 'largeRecord') to a single constraint on @r@. --- --- TODO: Perhaps we could check this automatically using -fdefer-type-errors. --- --- checkInferredType :: HKR r -> String --- checkInferredType (r :: HKR f) = show r diff --git a/test/Test/Record/Size/After/HK020.hs b/test/Test/Record/Size/After/HK020.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/HK020.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.HK020 where - -import Data.Record.TH - -import Test.Record.Size.Infra - -largeRecord defaultLazyOptions (higherKindedRecordOfSize 20) diff --git a/test/Test/Record/Size/After/HK030.hs b/test/Test/Record/Size/After/HK030.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/HK030.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.HK030 where - -import Data.Record.TH - -import Test.Record.Size.Infra - -largeRecord defaultLazyOptions (higherKindedRecordOfSize 30) diff --git a/test/Test/Record/Size/After/HK040.hs b/test/Test/Record/Size/After/HK040.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/HK040.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.HK040 where - -import Data.Record.TH - -import Test.Record.Size.Infra - -largeRecord defaultLazyOptions (higherKindedRecordOfSize 40) diff --git a/test/Test/Record/Size/After/HK050.hs b/test/Test/Record/Size/After/HK050.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/HK050.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.HK050 where - -import Data.Record.TH - -import Test.Record.Size.Infra - -largeRecord defaultLazyOptions (higherKindedRecordOfSize 50) diff --git a/test/Test/Record/Size/After/HK060.hs b/test/Test/Record/Size/After/HK060.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/HK060.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.HK060 where - -import Data.Record.TH - -import Test.Record.Size.Infra - -largeRecord defaultLazyOptions (higherKindedRecordOfSize 60) diff --git a/test/Test/Record/Size/After/HK070.hs b/test/Test/Record/Size/After/HK070.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/HK070.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.HK070 where - -import Data.Record.TH - -import Test.Record.Size.Infra - -largeRecord defaultLazyOptions (higherKindedRecordOfSize 70) diff --git a/test/Test/Record/Size/After/HK080.hs b/test/Test/Record/Size/After/HK080.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/HK080.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.HK080 where - -import Data.Record.TH - -import Test.Record.Size.Infra - -largeRecord defaultLazyOptions (higherKindedRecordOfSize 80) diff --git a/test/Test/Record/Size/After/HK090.hs b/test/Test/Record/Size/After/HK090.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/HK090.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.HK090 where - -import Data.Record.TH - -import Test.Record.Size.Infra - -largeRecord defaultLazyOptions (higherKindedRecordOfSize 90) diff --git a/test/Test/Record/Size/After/HK100.hs b/test/Test/Record/Size/After/HK100.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/HK100.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.HK100 where - -import Data.Record.TH - -import Test.Record.Size.Infra - -largeRecord defaultLazyOptions (higherKindedRecordOfSize 100) diff --git a/test/Test/Record/Size/After/R0010.hs b/test/Test/Record/Size/After/R0010.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0010.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0010 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 10) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0020.hs b/test/Test/Record/Size/After/R0020.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0020.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0020 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 20) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0030.hs b/test/Test/Record/Size/After/R0030.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0030.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0030 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 30) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0040.hs b/test/Test/Record/Size/After/R0040.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0040.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0040 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 40) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0050.hs b/test/Test/Record/Size/After/R0050.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0050.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0050 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 50) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0060.hs b/test/Test/Record/Size/After/R0060.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0060.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0060 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 60) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0070.hs b/test/Test/Record/Size/After/R0070.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0070.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0070 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 70) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0080.hs b/test/Test/Record/Size/After/R0080.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0080.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0080 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 80) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0090.hs b/test/Test/Record/Size/After/R0090.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0090.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0090 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 90) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0100.hs b/test/Test/Record/Size/After/R0100.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0100.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0100 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 100) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0200.hs b/test/Test/Record/Size/After/R0200.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0200.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0200 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 200) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0300.hs b/test/Test/Record/Size/After/R0300.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0300.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0300 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 300) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0400.hs b/test/Test/Record/Size/After/R0400.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0400.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0400 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 400) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0500.hs b/test/Test/Record/Size/After/R0500.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0500.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0500 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 500) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0600.hs b/test/Test/Record/Size/After/R0600.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0600.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0600 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 600) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0700.hs b/test/Test/Record/Size/After/R0700.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0700.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0700 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 700) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0800.hs b/test/Test/Record/Size/After/R0800.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0800.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0800 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 800) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R0900.hs b/test/Test/Record/Size/After/R0900.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R0900.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R0900 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 900) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/After/R1000.hs b/test/Test/Record/Size/After/R1000.hs deleted file mode 100644 --- a/test/Test/Record/Size/After/R1000.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.After.R1000 where - -import Data.Aeson (ToJSON(..)) - -import Data.Record.Generic.JSON -import Data.Record.TH - -import Test.Record.Size.Infra - -#ifdef PROFILE_ALLZIP -import Data.Record.Generic -import Data.Record.Generic.Transform -#endif - -largeRecord defaultLazyOptions (recordOfSize 1000) - -instance ToJSON R where - toJSON = gtoJSON - -#ifdef PROFILE_ALLZIP -testInterpretTo :: () -testInterpretTo = aux - where - aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () - aux = () -#endif diff --git a/test/Test/Record/Size/Before/Baseline.hs b/test/Test/Record/Size/Before/Baseline.hs deleted file mode 100644 --- a/test/Test/Record/Size/Before/Baseline.hs +++ /dev/null @@ -1,2 +0,0 @@ --- | Empty module, to establish a baseline for memory usage -module Test.Record.Size.Before.Baseline () where diff --git a/test/Test/Record/Size/Before/R010.hs b/test/Test/Record/Size/Before/R010.hs deleted file mode 100644 --- a/test/Test/Record/Size/Before/R010.hs +++ /dev/null @@ -1,49 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.Before.R010 where - -import Data.Aeson -import Generics.SOP.JSON -import Generics.SOP.TH - -import Test.Record.Size.Infra - --- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. -data R = MkR { - -- 1 .. 10 - field1 :: T 1 - , field2 :: T 2 - , field3 :: T 3 - , field4 :: T 4 - , field5 :: T 5 - , field6 :: T 6 - , field7 :: T 7 - , field8 :: T 8 - , field9 :: T 9 - , field10 :: T 10 - } - -deriving instance Eq R -deriving instance Show R - -deriveGeneric ''R - -instance ToJSON R where - toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R020.hs b/test/Test/Record/Size/Before/R020.hs deleted file mode 100644 --- a/test/Test/Record/Size/Before/R020.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.Before.R020 where - -import Data.Aeson -import Generics.SOP.JSON -import Generics.SOP.TH - -import Test.Record.Size.Infra - --- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. -data R = MkR { - -- 1 .. 10 - field1 :: T 1 - , field2 :: T 2 - , field3 :: T 3 - , field4 :: T 4 - , field5 :: T 5 - , field6 :: T 6 - , field7 :: T 7 - , field8 :: T 8 - , field9 :: T 9 - , field10 :: T 10 - -- 11 .. 20 - , field11 :: T 11 - , field12 :: T 12 - , field13 :: T 13 - , field14 :: T 14 - , field15 :: T 15 - , field16 :: T 16 - , field17 :: T 17 - , field18 :: T 18 - , field19 :: T 19 - , field20 :: T 20 - } - -deriving instance Eq R -deriving instance Show R - -deriveGeneric ''R - -instance ToJSON R where - toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R030.hs b/test/Test/Record/Size/Before/R030.hs deleted file mode 100644 --- a/test/Test/Record/Size/Before/R030.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.Before.R030 where - -import Data.Aeson -import Generics.SOP.JSON -import Generics.SOP.TH - -import Test.Record.Size.Infra - --- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. -data R = MkR { - -- 1 .. 10 - field1 :: T 1 - , field2 :: T 2 - , field3 :: T 3 - , field4 :: T 4 - , field5 :: T 5 - , field6 :: T 6 - , field7 :: T 7 - , field8 :: T 8 - , field9 :: T 9 - , field10 :: T 10 - -- 11 .. 20 - , field11 :: T 11 - , field12 :: T 12 - , field13 :: T 13 - , field14 :: T 14 - , field15 :: T 15 - , field16 :: T 16 - , field17 :: T 17 - , field18 :: T 18 - , field19 :: T 19 - , field20 :: T 20 - -- 21 .. 30 - , field21 :: T 21 - , field22 :: T 22 - , field23 :: T 23 - , field24 :: T 24 - , field25 :: T 25 - , field26 :: T 26 - , field27 :: T 27 - , field28 :: T 28 - , field29 :: T 29 - , field30 :: T 30 - } - -deriving instance Eq R -deriving instance Show R - -deriveGeneric ''R - -instance ToJSON R where - toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R040.hs b/test/Test/Record/Size/Before/R040.hs deleted file mode 100644 --- a/test/Test/Record/Size/Before/R040.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.Before.R040 where - -import Data.Aeson -import Generics.SOP.JSON -import Generics.SOP.TH - -import Test.Record.Size.Infra - --- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. -data R = MkR { - -- 1 .. 10 - field1 :: T 1 - , field2 :: T 2 - , field3 :: T 3 - , field4 :: T 4 - , field5 :: T 5 - , field6 :: T 6 - , field7 :: T 7 - , field8 :: T 8 - , field9 :: T 9 - , field10 :: T 10 - -- 11 .. 20 - , field11 :: T 11 - , field12 :: T 12 - , field13 :: T 13 - , field14 :: T 14 - , field15 :: T 15 - , field16 :: T 16 - , field17 :: T 17 - , field18 :: T 18 - , field19 :: T 19 - , field20 :: T 20 - -- 21 .. 30 - , field21 :: T 21 - , field22 :: T 22 - , field23 :: T 23 - , field24 :: T 24 - , field25 :: T 25 - , field26 :: T 26 - , field27 :: T 27 - , field28 :: T 28 - , field29 :: T 29 - , field30 :: T 30 - -- 31 .. 40 - , field31 :: T 31 - , field32 :: T 32 - , field33 :: T 33 - , field34 :: T 34 - , field35 :: T 35 - , field36 :: T 36 - , field37 :: T 37 - , field38 :: T 38 - , field39 :: T 39 - , field40 :: T 40 - } - -deriving instance Eq R -deriving instance Show R - -deriveGeneric ''R - -instance ToJSON R where - toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R050.hs b/test/Test/Record/Size/Before/R050.hs deleted file mode 100644 --- a/test/Test/Record/Size/Before/R050.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.Before.R050 where - -import Data.Aeson -import Generics.SOP.JSON -import Generics.SOP.TH - -import Test.Record.Size.Infra - --- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. -data R = MkR { - -- 1 .. 10 - field1 :: T 1 - , field2 :: T 2 - , field3 :: T 3 - , field4 :: T 4 - , field5 :: T 5 - , field6 :: T 6 - , field7 :: T 7 - , field8 :: T 8 - , field9 :: T 9 - , field10 :: T 10 - -- 11 .. 20 - , field11 :: T 11 - , field12 :: T 12 - , field13 :: T 13 - , field14 :: T 14 - , field15 :: T 15 - , field16 :: T 16 - , field17 :: T 17 - , field18 :: T 18 - , field19 :: T 19 - , field20 :: T 20 - -- 21 .. 30 - , field21 :: T 21 - , field22 :: T 22 - , field23 :: T 23 - , field24 :: T 24 - , field25 :: T 25 - , field26 :: T 26 - , field27 :: T 27 - , field28 :: T 28 - , field29 :: T 29 - , field30 :: T 30 - -- 31 .. 40 - , field31 :: T 31 - , field32 :: T 32 - , field33 :: T 33 - , field34 :: T 34 - , field35 :: T 35 - , field36 :: T 36 - , field37 :: T 37 - , field38 :: T 38 - , field39 :: T 39 - , field40 :: T 40 - -- 41 .. 50 - , field41 :: T 41 - , field42 :: T 42 - , field43 :: T 43 - , field44 :: T 44 - , field45 :: T 45 - , field46 :: T 46 - , field47 :: T 47 - , field48 :: T 48 - , field49 :: T 49 - , field50 :: T 50 - } - -deriving instance Eq R -deriving instance Show R - -deriveGeneric ''R - -instance ToJSON R where - toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R060.hs b/test/Test/Record/Size/Before/R060.hs deleted file mode 100644 --- a/test/Test/Record/Size/Before/R060.hs +++ /dev/null @@ -1,104 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.Before.R060 where - -import Data.Aeson -import Generics.SOP.JSON -import Generics.SOP.TH - -import Test.Record.Size.Infra - --- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. -data R = MkR { - -- 1 .. 10 - field1 :: T 1 - , field2 :: T 2 - , field3 :: T 3 - , field4 :: T 4 - , field5 :: T 5 - , field6 :: T 6 - , field7 :: T 7 - , field8 :: T 8 - , field9 :: T 9 - , field10 :: T 10 - -- 11 .. 20 - , field11 :: T 11 - , field12 :: T 12 - , field13 :: T 13 - , field14 :: T 14 - , field15 :: T 15 - , field16 :: T 16 - , field17 :: T 17 - , field18 :: T 18 - , field19 :: T 19 - , field20 :: T 20 - -- 21 .. 30 - , field21 :: T 21 - , field22 :: T 22 - , field23 :: T 23 - , field24 :: T 24 - , field25 :: T 25 - , field26 :: T 26 - , field27 :: T 27 - , field28 :: T 28 - , field29 :: T 29 - , field30 :: T 30 - -- 31 .. 40 - , field31 :: T 31 - , field32 :: T 32 - , field33 :: T 33 - , field34 :: T 34 - , field35 :: T 35 - , field36 :: T 36 - , field37 :: T 37 - , field38 :: T 38 - , field39 :: T 39 - , field40 :: T 40 - -- 41 .. 50 - , field41 :: T 41 - , field42 :: T 42 - , field43 :: T 43 - , field44 :: T 44 - , field45 :: T 45 - , field46 :: T 46 - , field47 :: T 47 - , field48 :: T 48 - , field49 :: T 49 - , field50 :: T 50 - -- 51 .. 60 - , field51 :: T 51 - , field52 :: T 52 - , field53 :: T 53 - , field54 :: T 54 - , field55 :: T 55 - , field56 :: T 56 - , field57 :: T 57 - , field58 :: T 58 - , field59 :: T 59 - , field60 :: T 60 - } - -deriving instance Eq R -deriving instance Show R - -deriveGeneric ''R - -instance ToJSON R where - toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R070.hs b/test/Test/Record/Size/Before/R070.hs deleted file mode 100644 --- a/test/Test/Record/Size/Before/R070.hs +++ /dev/null @@ -1,115 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.Before.R070 where - -import Data.Aeson -import Generics.SOP.JSON -import Generics.SOP.TH - -import Test.Record.Size.Infra - --- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. -data R = MkR { - -- 1 .. 10 - field1 :: T 1 - , field2 :: T 2 - , field3 :: T 3 - , field4 :: T 4 - , field5 :: T 5 - , field6 :: T 6 - , field7 :: T 7 - , field8 :: T 8 - , field9 :: T 9 - , field10 :: T 10 - -- 11 .. 20 - , field11 :: T 11 - , field12 :: T 12 - , field13 :: T 13 - , field14 :: T 14 - , field15 :: T 15 - , field16 :: T 16 - , field17 :: T 17 - , field18 :: T 18 - , field19 :: T 19 - , field20 :: T 20 - -- 21 .. 30 - , field21 :: T 21 - , field22 :: T 22 - , field23 :: T 23 - , field24 :: T 24 - , field25 :: T 25 - , field26 :: T 26 - , field27 :: T 27 - , field28 :: T 28 - , field29 :: T 29 - , field30 :: T 30 - -- 31 .. 40 - , field31 :: T 31 - , field32 :: T 32 - , field33 :: T 33 - , field34 :: T 34 - , field35 :: T 35 - , field36 :: T 36 - , field37 :: T 37 - , field38 :: T 38 - , field39 :: T 39 - , field40 :: T 40 - -- 41 .. 50 - , field41 :: T 41 - , field42 :: T 42 - , field43 :: T 43 - , field44 :: T 44 - , field45 :: T 45 - , field46 :: T 46 - , field47 :: T 47 - , field48 :: T 48 - , field49 :: T 49 - , field50 :: T 50 - -- 51 .. 60 - , field51 :: T 51 - , field52 :: T 52 - , field53 :: T 53 - , field54 :: T 54 - , field55 :: T 55 - , field56 :: T 56 - , field57 :: T 57 - , field58 :: T 58 - , field59 :: T 59 - , field60 :: T 60 - -- 61 .. 70 - , field61 :: T 61 - , field62 :: T 62 - , field63 :: T 63 - , field64 :: T 64 - , field65 :: T 65 - , field66 :: T 66 - , field67 :: T 67 - , field68 :: T 68 - , field69 :: T 69 - , field70 :: T 70 - } - -deriving instance Eq R -deriving instance Show R - -deriveGeneric ''R - -instance ToJSON R where - toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R080.hs b/test/Test/Record/Size/Before/R080.hs deleted file mode 100644 --- a/test/Test/Record/Size/Before/R080.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.Before.R080 where - -import Data.Aeson -import Generics.SOP.JSON -import Generics.SOP.TH - -import Test.Record.Size.Infra - --- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. -data R = MkR { - -- 1 .. 10 - field1 :: T 1 - , field2 :: T 2 - , field3 :: T 3 - , field4 :: T 4 - , field5 :: T 5 - , field6 :: T 6 - , field7 :: T 7 - , field8 :: T 8 - , field9 :: T 9 - , field10 :: T 10 - -- 11 .. 20 - , field11 :: T 11 - , field12 :: T 12 - , field13 :: T 13 - , field14 :: T 14 - , field15 :: T 15 - , field16 :: T 16 - , field17 :: T 17 - , field18 :: T 18 - , field19 :: T 19 - , field20 :: T 20 - -- 21 .. 30 - , field21 :: T 21 - , field22 :: T 22 - , field23 :: T 23 - , field24 :: T 24 - , field25 :: T 25 - , field26 :: T 26 - , field27 :: T 27 - , field28 :: T 28 - , field29 :: T 29 - , field30 :: T 30 - -- 31 .. 40 - , field31 :: T 31 - , field32 :: T 32 - , field33 :: T 33 - , field34 :: T 34 - , field35 :: T 35 - , field36 :: T 36 - , field37 :: T 37 - , field38 :: T 38 - , field39 :: T 39 - , field40 :: T 40 - -- 41 .. 50 - , field41 :: T 41 - , field42 :: T 42 - , field43 :: T 43 - , field44 :: T 44 - , field45 :: T 45 - , field46 :: T 46 - , field47 :: T 47 - , field48 :: T 48 - , field49 :: T 49 - , field50 :: T 50 - -- 51 .. 60 - , field51 :: T 51 - , field52 :: T 52 - , field53 :: T 53 - , field54 :: T 54 - , field55 :: T 55 - , field56 :: T 56 - , field57 :: T 57 - , field58 :: T 58 - , field59 :: T 59 - , field60 :: T 60 - -- 61 .. 70 - , field61 :: T 61 - , field62 :: T 62 - , field63 :: T 63 - , field64 :: T 64 - , field65 :: T 65 - , field66 :: T 66 - , field67 :: T 67 - , field68 :: T 68 - , field69 :: T 69 - , field70 :: T 70 - -- 71 .. 80 - , field71 :: T 71 - , field72 :: T 72 - , field73 :: T 73 - , field74 :: T 74 - , field75 :: T 75 - , field76 :: T 76 - , field77 :: T 77 - , field78 :: T 78 - , field79 :: T 79 - , field80 :: T 80 - } - -deriving instance Eq R -deriving instance Show R - -deriveGeneric ''R - -instance ToJSON R where - toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R090.hs b/test/Test/Record/Size/Before/R090.hs deleted file mode 100644 --- a/test/Test/Record/Size/Before/R090.hs +++ /dev/null @@ -1,137 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.Before.R090 where - -import Data.Aeson -import Generics.SOP.JSON -import Generics.SOP.TH - -import Test.Record.Size.Infra - --- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. -data R = MkR { - -- 1 .. 10 - field1 :: T 1 - , field2 :: T 2 - , field3 :: T 3 - , field4 :: T 4 - , field5 :: T 5 - , field6 :: T 6 - , field7 :: T 7 - , field8 :: T 8 - , field9 :: T 9 - , field10 :: T 10 - -- 11 .. 20 - , field11 :: T 11 - , field12 :: T 12 - , field13 :: T 13 - , field14 :: T 14 - , field15 :: T 15 - , field16 :: T 16 - , field17 :: T 17 - , field18 :: T 18 - , field19 :: T 19 - , field20 :: T 20 - -- 21 .. 30 - , field21 :: T 21 - , field22 :: T 22 - , field23 :: T 23 - , field24 :: T 24 - , field25 :: T 25 - , field26 :: T 26 - , field27 :: T 27 - , field28 :: T 28 - , field29 :: T 29 - , field30 :: T 30 - -- 31 .. 40 - , field31 :: T 31 - , field32 :: T 32 - , field33 :: T 33 - , field34 :: T 34 - , field35 :: T 35 - , field36 :: T 36 - , field37 :: T 37 - , field38 :: T 38 - , field39 :: T 39 - , field40 :: T 40 - -- 41 .. 50 - , field41 :: T 41 - , field42 :: T 42 - , field43 :: T 43 - , field44 :: T 44 - , field45 :: T 45 - , field46 :: T 46 - , field47 :: T 47 - , field48 :: T 48 - , field49 :: T 49 - , field50 :: T 50 - -- 51 .. 60 - , field51 :: T 51 - , field52 :: T 52 - , field53 :: T 53 - , field54 :: T 54 - , field55 :: T 55 - , field56 :: T 56 - , field57 :: T 57 - , field58 :: T 58 - , field59 :: T 59 - , field60 :: T 60 - -- 61 .. 70 - , field61 :: T 61 - , field62 :: T 62 - , field63 :: T 63 - , field64 :: T 64 - , field65 :: T 65 - , field66 :: T 66 - , field67 :: T 67 - , field68 :: T 68 - , field69 :: T 69 - , field70 :: T 70 - -- 71 .. 80 - , field71 :: T 71 - , field72 :: T 72 - , field73 :: T 73 - , field74 :: T 74 - , field75 :: T 75 - , field76 :: T 76 - , field77 :: T 77 - , field78 :: T 78 - , field79 :: T 79 - , field80 :: T 80 - -- 81 .. 90 - , field81 :: T 81 - , field82 :: T 82 - , field83 :: T 83 - , field84 :: T 84 - , field85 :: T 85 - , field86 :: T 86 - , field87 :: T 87 - , field88 :: T 88 - , field89 :: T 89 - , field90 :: T 90 - } - -deriving instance Eq R -deriving instance Show R - -deriveGeneric ''R - -instance ToJSON R where - toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R100.hs b/test/Test/Record/Size/Before/R100.hs deleted file mode 100644 --- a/test/Test/Record/Size/Before/R100.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} - -#if USE_GHC_DUMP -{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} -#endif - -module Test.Record.Size.Before.R100 where - -import Data.Aeson -import Generics.SOP.JSON -import Generics.SOP.TH - -import Test.Record.Size.Infra - --- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. -data R = MkR { - -- 1 .. 10 - field1 :: T 1 - , field2 :: T 2 - , field3 :: T 3 - , field4 :: T 4 - , field5 :: T 5 - , field6 :: T 6 - , field7 :: T 7 - , field8 :: T 8 - , field9 :: T 9 - , field10 :: T 10 - -- 11 .. 20 - , field11 :: T 11 - , field12 :: T 12 - , field13 :: T 13 - , field14 :: T 14 - , field15 :: T 15 - , field16 :: T 16 - , field17 :: T 17 - , field18 :: T 18 - , field19 :: T 19 - , field20 :: T 20 - -- 21 .. 30 - , field21 :: T 21 - , field22 :: T 22 - , field23 :: T 23 - , field24 :: T 24 - , field25 :: T 25 - , field26 :: T 26 - , field27 :: T 27 - , field28 :: T 28 - , field29 :: T 29 - , field30 :: T 30 - -- 31 .. 40 - , field31 :: T 31 - , field32 :: T 32 - , field33 :: T 33 - , field34 :: T 34 - , field35 :: T 35 - , field36 :: T 36 - , field37 :: T 37 - , field38 :: T 38 - , field39 :: T 39 - , field40 :: T 40 - -- 41 .. 50 - , field41 :: T 41 - , field42 :: T 42 - , field43 :: T 43 - , field44 :: T 44 - , field45 :: T 45 - , field46 :: T 46 - , field47 :: T 47 - , field48 :: T 48 - , field49 :: T 49 - , field50 :: T 50 - -- 51 .. 60 - , field51 :: T 51 - , field52 :: T 52 - , field53 :: T 53 - , field54 :: T 54 - , field55 :: T 55 - , field56 :: T 56 - , field57 :: T 57 - , field58 :: T 58 - , field59 :: T 59 - , field60 :: T 60 - -- 61 .. 70 - , field61 :: T 61 - , field62 :: T 62 - , field63 :: T 63 - , field64 :: T 64 - , field65 :: T 65 - , field66 :: T 66 - , field67 :: T 67 - , field68 :: T 68 - , field69 :: T 69 - , field70 :: T 70 - -- 71 .. 80 - , field71 :: T 71 - , field72 :: T 72 - , field73 :: T 73 - , field74 :: T 74 - , field75 :: T 75 - , field76 :: T 76 - , field77 :: T 77 - , field78 :: T 78 - , field79 :: T 79 - , field80 :: T 80 - -- 81 .. 90 - , field81 :: T 81 - , field82 :: T 82 - , field83 :: T 83 - , field84 :: T 84 - , field85 :: T 85 - , field86 :: T 86 - , field87 :: T 87 - , field88 :: T 88 - , field89 :: T 89 - , field90 :: T 90 - -- 91 .. 100 - , field91 :: T 91 - , field92 :: T 92 - , field93 :: T 93 - , field94 :: T 94 - , field95 :: T 95 - , field96 :: T 96 - , field97 :: T 97 - , field98 :: T 98 - , field99 :: T 99 - , field100 :: T 100 - } - -deriving instance Eq R -deriving instance Show R - -deriveGeneric ''R - -instance ToJSON R where - toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Infra.hs b/test/Test/Record/Size/Infra.hs deleted file mode 100644 --- a/test/Test/Record/Size/Infra.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} - -module Test.Record.Size.Infra ( - recordOfSize - , higherKindedRecordOfSize - -- * Supporting infrastructure used by generated code - , T(..) - -- * Re-exports - , I - ) where - -import Data.Aeson -import Data.Functor.Classes -import Data.Functor.Identity -import Data.Kind -import Data.Proxy -import Data.SOP.BasicFunctors -import GHC.TypeLits - -import Language.Haskell.TH hiding (Type) -import Language.Haskell.TH.Syntax hiding (Type) - -import Data.Record.Generic.LowerBound -import Data.Record.Generic.Transform - -{------------------------------------------------------------------------------- - Construct records of specified size --------------------------------------------------------------------------------} - --- | Generate something like --- --- > data R = MkR { --- > field1 :: T 1 --- > , field2 :: T 2 --- > , field3 :: T 3 --- > , field4 :: T 4 --- > , field5 :: T 5 --- > } --- --- In order to be compatible with the records originating from @[d| ... |]@, --- we use 'newName' here rather than 'mkName'. -recordOfSize :: Integer -> Q [Dec] -recordOfSize n = fmap (:[]) $ do - r <- newName "R" - mkR <- newName "MkR" - dataD - (cxt []) - r - [] - Nothing - [recC mkR fields] - [] - where - fields :: [Q VarBangType] - fields = [ - do fieldI <- newName $ "field" ++ show i - varBangType - fieldI - (bangType defaultBang (conT ''T `appT` litT (numTyLit i))) - | i <- [1 .. n] - ] - --- | Like 'recordOfSize', but generate a record with a higher-kinded type var. --- --- Generates something like: --- --- > data HKR (f :: Type -> Type) = MkHKR { --- > field1 :: HK 1 f --- > , field2 :: HK 2 f --- > , field3 :: HK 3 f --- > , field4 :: HK 4 f --- > , field5 :: HK 5 f --- > } --- > deriving Show --- --- See comments in 'recordOfSize' for the use of 'newName'. -higherKindedRecordOfSize :: Integer -> Q [Dec] -higherKindedRecordOfSize n = fmap (:[]) $ do - f <- newName "f" - k <- [t| Type -> Type |] - hkr <- newName "HKR" - mkHKR <- newName "MkHKR" - dataD - (cxt []) - hkr - [KindedTV f k] - Nothing - [recC mkHKR (fields f)] - [derivClause Nothing [conT ''Show]] - where - fields :: Name -> [Q VarBangType] - fields f = [ - do fieldI <- newName $ "field" ++ show i - varBangType - fieldI - (bangType defaultBang (conT ''HK `appT` litT (numTyLit i) `appT` varT f)) - | i <- [1 .. n] - ] - -defaultBang :: BangQ -defaultBang = bang noSourceUnpackedness noSourceStrictness - -{------------------------------------------------------------------------------- - Definitions referred to by the generated TH code --------------------------------------------------------------------------------} - --- | 'T' gives us as many different types as we need -newtype T (i :: Nat) = MkT Word - deriving (Show, Eq, ToJSON) - -type instance Interpreted I (T i) = T i - --- | Like 'T', but with a higher-kinded type variable -newtype HK (i :: Nat) (f :: Type -> Type) = MkHK (f Word) - -instance KnownNat i => LowerBound (T i) where - lowerBound = MkT $ fromInteger $ natVal (Proxy @i) - -instance KnownNat i => LowerBound (HK i Identity) where - lowerBound = MkHK $ fromInteger $ natVal (Proxy @i) - -instance Show1 f => Show (HK i f) where - showsPrec d (MkHK x) = showsPrec1 d x diff --git a/test/Test/Record/Size/Sanity.hs b/test/Test/Record/Size/Sanity.hs deleted file mode 100644 --- a/test/Test/Record/Size/Sanity.hs +++ /dev/null @@ -1,208 +0,0 @@ -{-# LANGUAGE CPP #-} - -{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-} - --- | Sanity checks that we generate correct code for in the @Sized.*@ modules --- --- The real test of the @Size.*@ moduels of course is not this module, but --- rather their compiled size. -module Test.Record.Size.Sanity (tests) where - -import Data.Aeson -import Data.Functor.Identity - -import qualified Data.Record.Generic.SOP as SOP -import qualified Data.Record.Generic.LowerBound as LR - -import qualified Test.Record.Size.Before.R010 as Before010 -import qualified Test.Record.Size.After.R0010 as After0010 -import qualified Test.Record.Size.After.HK010 as AfterHK10 - -#if USE_GHC_DUMP -import Test.Record.Size.Infra (T(..)) - -import qualified Test.Record.Size.Before.R020 as Before020 -import qualified Test.Record.Size.Before.R030 as Before030 -import qualified Test.Record.Size.Before.R040 as Before040 -import qualified Test.Record.Size.Before.R050 as Before050 -import qualified Test.Record.Size.Before.R060 as Before060 -import qualified Test.Record.Size.Before.R070 as Before070 -import qualified Test.Record.Size.Before.R080 as Before080 -import qualified Test.Record.Size.Before.R090 as Before090 -import qualified Test.Record.Size.Before.R100 as Before100 -import qualified Test.Record.Size.After.R0020 as After0020 -import qualified Test.Record.Size.After.R0030 as After0030 -import qualified Test.Record.Size.After.R0040 as After0040 -import qualified Test.Record.Size.After.R0050 as After0050 -import qualified Test.Record.Size.After.R0060 as After0060 -import qualified Test.Record.Size.After.R0070 as After0070 -import qualified Test.Record.Size.After.R0080 as After0080 -import qualified Test.Record.Size.After.R0090 as After0090 -import qualified Test.Record.Size.After.R0100 as After0100 -import qualified Test.Record.Size.After.R0200 as After0200 -import qualified Test.Record.Size.After.R0300 as After0300 -import qualified Test.Record.Size.After.R0400 as After0400 -import qualified Test.Record.Size.After.R0500 as After0500 -import qualified Test.Record.Size.After.R0600 as After0600 -import qualified Test.Record.Size.After.R0700 as After0700 -import qualified Test.Record.Size.After.R0800 as After0800 -import qualified Test.Record.Size.After.R0900 as After0900 -import qualified Test.Record.Size.After.R1000 as After1000 -import qualified Test.Record.Size.After.HK020 as AfterHK20 -import qualified Test.Record.Size.After.HK030 as AfterHK30 -import qualified Test.Record.Size.After.HK040 as AfterHK40 -import qualified Test.Record.Size.After.HK050 as AfterHK50 -import qualified Test.Record.Size.After.HK060 as AfterHK60 -import qualified Test.Record.Size.After.HK070 as AfterHK70 -import qualified Test.Record.Size.After.HK080 as AfterHK80 -import qualified Test.Record.Size.After.HK090 as AfterHK90 -import qualified Test.Record.Size.After.HK100 as AfterH100 -#endif - -import Test.Tasty -import Test.Tasty.HUnit - -tests :: TestTree -tests = testGroup "Test.Record.Size.Sanity" [ - testCase "sameValue" test_sameValue - , testCase "sameField" test_sameField - , testCase "showHK" test_showHK -#if USE_GHC_DUMP - , testCase "reallyBig" test_reallyBig -#endif - ] - --- | Test that @generics-sop@ and @large-records@ generates the same structure -test_sameValue :: Assertion -test_sameValue = do - assertEqual "10" - (toJSON (SOP.glowerBound :: Before010.R)) - (toJSON ( LR.glowerBound :: After0010.R)) -#if USE_GHC_DUMP - assertEqual "20" - (toJSON (SOP.glowerBound :: Before020.R)) - (toJSON ( LR.glowerBound :: After0020.R)) - assertEqual "30" - (toJSON (SOP.glowerBound :: Before030.R)) - (toJSON ( LR.glowerBound :: After0030.R)) - assertEqual "40" - (toJSON (SOP.glowerBound :: Before040.R)) - (toJSON ( LR.glowerBound :: After0040.R)) - assertEqual "50" - (toJSON (SOP.glowerBound :: Before050.R)) - (toJSON ( LR.glowerBound :: After0050.R)) - assertEqual "60" - (toJSON (SOP.glowerBound :: Before060.R)) - (toJSON ( LR.glowerBound :: After0060.R)) - assertEqual "70" - (toJSON (SOP.glowerBound :: Before070.R)) - (toJSON ( LR.glowerBound :: After0070.R)) - assertEqual "80" - (toJSON (SOP.glowerBound :: Before080.R)) - (toJSON ( LR.glowerBound :: After0080.R)) - assertEqual "90" - (toJSON (SOP.glowerBound :: Before090.R)) - (toJSON ( LR.glowerBound :: After0090.R)) - assertEqual "100" - (toJSON (SOP.glowerBound :: Before100.R)) - (toJSON ( LR.glowerBound :: After0100.R)) -#endif - --- | Test that we have the necessary @HasField@ instances -test_sameField :: Assertion -test_sameField = do - assertEqual "HasField" sop010.field1 lr010.field1 -#if USE_GHC_DUMP - assertEqual "HasField" sop020.field11 lr020.field11 - assertEqual "HasField" sop030.field21 lr030.field21 - assertEqual "HasField" sop040.field31 lr040.field31 - assertEqual "HasField" sop050.field41 lr050.field41 - assertEqual "HasField" sop060.field51 lr060.field51 - assertEqual "HasField" sop070.field61 lr070.field61 - assertEqual "HasField" sop080.field71 lr080.field71 - assertEqual "HasField" sop090.field81 lr090.field81 - assertEqual "HasField" sop100.field91 lr100.field91 -#endif - where - sop010 = SOP.glowerBound :: Before010.R - lr010 = LR.glowerBound :: After0010.R - -#if USE_GHC_DUMP - sop020 = SOP.glowerBound :: Before020.R - sop030 = SOP.glowerBound :: Before030.R - sop040 = SOP.glowerBound :: Before040.R - sop050 = SOP.glowerBound :: Before050.R - sop060 = SOP.glowerBound :: Before060.R - sop070 = SOP.glowerBound :: Before070.R - sop080 = SOP.glowerBound :: Before080.R - sop090 = SOP.glowerBound :: Before090.R - sop100 = SOP.glowerBound :: Before100.R - - lr020 = LR.glowerBound :: After0020.R - lr030 = LR.glowerBound :: After0030.R - lr040 = LR.glowerBound :: After0040.R - lr050 = LR.glowerBound :: After0050.R - lr060 = LR.glowerBound :: After0060.R - lr070 = LR.glowerBound :: After0070.R - lr080 = LR.glowerBound :: After0080.R - lr090 = LR.glowerBound :: After0090.R - lr100 = LR.glowerBound :: After0100.R -#endif - --- | Check that we can 'Show' the higher-kinded records -test_showHK :: Assertion -test_showHK = do - assertBool "some output" (not . null $ show lr010) - -#if USE_GHC_DUMP - assertBool "some output" (not . null $ show lr020) - assertBool "some output" (not . null $ show lr030) - assertBool "some output" (not . null $ show lr040) - assertBool "some output" (not . null $ show lr050) - assertBool "some output" (not . null $ show lr060) - assertBool "some output" (not . null $ show lr070) - assertBool "some output" (not . null $ show lr080) - assertBool "some output" (not . null $ show lr090) - assertBool "some output" (not . null $ show lr100) -#endif - where - lr010 = LR.glowerBound :: AfterHK10.HKR Identity - -#if USE_GHC_DUMP - lr020 = LR.glowerBound :: AfterHK20.HKR Identity - lr030 = LR.glowerBound :: AfterHK30.HKR Identity - lr040 = LR.glowerBound :: AfterHK40.HKR Identity - lr050 = LR.glowerBound :: AfterHK50.HKR Identity - lr060 = LR.glowerBound :: AfterHK60.HKR Identity - lr070 = LR.glowerBound :: AfterHK70.HKR Identity - lr080 = LR.glowerBound :: AfterHK80.HKR Identity - lr090 = LR.glowerBound :: AfterHK90.HKR Identity - lr100 = LR.glowerBound :: AfterH100.HKR Identity -#endif - -#if USE_GHC_DUMP --- | Check the value of the last field in the truly big records -test_reallyBig :: Assertion -test_reallyBig = do - assertEqual "HasField" lr0100.field100 (MkT 100) - assertEqual "HasField" lr0200.field200 (MkT 200) - assertEqual "HasField" lr0300.field300 (MkT 300) - assertEqual "HasField" lr0400.field400 (MkT 400) - assertEqual "HasField" lr0500.field500 (MkT 500) - assertEqual "HasField" lr0600.field600 (MkT 600) - assertEqual "HasField" lr0700.field700 (MkT 700) - assertEqual "HasField" lr0800.field800 (MkT 800) - assertEqual "HasField" lr0900.field900 (MkT 900) - assertEqual "HasField" lr1000.field1000 (MkT 1000) - where - lr0100 = LR.glowerBound :: After0100.R - lr0200 = LR.glowerBound :: After0200.R - lr0300 = LR.glowerBound :: After0300.R - lr0400 = LR.glowerBound :: After0400.R - lr0500 = LR.glowerBound :: After0500.R - lr0600 = LR.glowerBound :: After0600.R - lr0700 = LR.glowerBound :: After0700.R - lr0800 = LR.glowerBound :: After0800.R - lr0900 = LR.glowerBound :: After0900.R - lr1000 = LR.glowerBound :: After1000.R -#endif 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 @@ -164,6 +164,10 @@ qPutQ = \x -> liftQ $ qPutQ x qIsExtEnabled = \x -> liftQ $ qIsExtEnabled x qExtsEnabled = liftQ $ qExtsEnabled +#if MIN_VERSION_template_haskell(2,18,0) + qPutDoc = \x y -> liftQ $ qPutDoc x y + qGetDoc = \x -> liftQ $ qGetDoc x +#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 @@ -2,24 +2,19 @@ import Test.Tasty -import qualified Test.Record.Prop.Show -import qualified Test.Record.Prop.ToFromJSON +import qualified Test.Record.Sanity.CodeGen import qualified Test.Record.Sanity.Derive import qualified Test.Record.Sanity.EqualFieldTypes -import qualified Test.Record.Sanity.ErrorsAndWarnings -import qualified Test.Record.Sanity.Generics -import qualified Test.Record.Sanity.GhcGenerics import qualified Test.Record.Sanity.HigherKinded import qualified Test.Record.Sanity.HKD -import qualified Test.Record.Sanity.Laziness -import qualified Test.Record.Sanity.Lens.Micro 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.RecordConstruction import qualified Test.Record.Sanity.Strictness -import qualified Test.Record.Sanity.Transform -import qualified Test.Record.Size.Sanity +import qualified Test.Record.Sanity.GhcGenerics main :: IO () main = defaultMain tests @@ -27,27 +22,18 @@ tests :: TestTree tests = testGroup "Tests" [ testGroup "Sanity" [ - Test.Record.Sanity.Derive.tests + Test.Record.Sanity.CodeGen.tests + , Test.Record.Sanity.Derive.tests , Test.Record.Sanity.EqualFieldTypes.tests - , Test.Record.Sanity.ErrorsAndWarnings.tests - , Test.Record.Sanity.Generics.tests - , Test.Record.Sanity.GhcGenerics.tests , Test.Record.Sanity.HigherKinded.tests , Test.Record.Sanity.HKD.tests - , Test.Record.Sanity.Laziness.tests - , Test.Record.Sanity.Lens.Micro.tests , Test.Record.Sanity.OverloadingNoDRF.tests , Test.Record.Sanity.PatternMatch.tests , Test.Record.Sanity.QualifiedImports.tests + , Test.Record.Sanity.RDP.SplitModule.tests + , Test.Record.Sanity.RDP.SingleModule.tests , Test.Record.Sanity.RecordConstruction.tests , Test.Record.Sanity.Strictness.tests - , Test.Record.Sanity.Transform.tests - ] - , testGroup "Size" [ - Test.Record.Size.Sanity.tests - ] - , testGroup "Prop" [ - Test.Record.Prop.Show.tests - , Test.Record.Prop.ToFromJSON.tests + , Test.Record.Sanity.GhcGenerics.tests ] ]