large-records 0.1.0.0 → 0.2.0.0

raw patch · 114 files changed

+3448/−8255 lines, 114 filesdep +ghcdep +large-genericsdep −QuickCheckdep −aesondep −generics-sopdep ~basedep ~record-dot-preprocessordep ~transformersPVP ok

version bump matches the API change (PVP)

Dependencies added: ghc, large-generics

Dependencies removed: QuickCheck, aeson, generics-sop, ghc-dump-core, haskell-src-exts, haskell-src-meta, json-sop, microlens, sop-core, tasty-quickcheck, text

Dependency ranges changed: base, record-dot-preprocessor, transformers, vector

API changes (from Hackage documentation)

Files

• CHANGELOG.md +15/−1
• large-records.cabal +101/−171
• src/Data/Record/Generic.hs +0/−100
• src/Data/Record/Generic/Eq.hs +0/−37
• src/Data/Record/Generic/GHC.hs +0/−111
• src/Data/Record/Generic/JSON.hs +0/−45
• src/Data/Record/Generic/Lens/Micro.hs +0/−212
• src/Data/Record/Generic/LowerBound.hs +0/−31
• src/Data/Record/Generic/Rep.hs +0/−210
• src/Data/Record/Generic/Rep/Internal.hs +0/−91
• src/Data/Record/Generic/SOP.hs +0/−126
• src/Data/Record/Generic/Show.hs +0/−38
• src/Data/Record/Generic/Transform.hs +0/−174
• src/Data/Record/Internal/CodeGen.hs +0/−110
• src/Data/Record/Internal/GHC/Fresh.hs +55/−0
• src/Data/Record/Internal/GHC/Shim.hs +319/−0
• src/Data/Record/Internal/GHC/TemplateHaskellStyle.hs +778/−0
• src/Data/Record/Internal/Naming.hs +0/−65
• src/Data/Record/Internal/Plugin/CodeGen.hs +677/−0
• src/Data/Record/Internal/Plugin/Exception.hs +37/−0
• src/Data/Record/Internal/Plugin/Names/GhcGenerics.hs +42/−0
• src/Data/Record/Internal/Plugin/Names/Runtime.hs +223/−0
• src/Data/Record/Internal/Plugin/Options.hs +119/−0
• src/Data/Record/Internal/Plugin/Record.hs +129/−0
• src/Data/Record/Internal/Record.hs +0/−115
• src/Data/Record/Internal/Record/Parser.hs +0/−140
• src/Data/Record/Internal/Record/Resolution.hs +0/−79
• src/Data/Record/Internal/Record/Resolution/GHC.hs +0/−110
• src/Data/Record/Internal/Record/Resolution/Internal.hs +0/−72
• src/Data/Record/Internal/TH/Name.hs +0/−321
• src/Data/Record/Internal/TH/Util.hs +0/−134
• src/Data/Record/Internal/Util.hs +0/−17
• src/Data/Record/Plugin.hs +196/−0
• src/Data/Record/Plugin/Options.hs +10/−0
• src/Data/Record/Plugin/Runtime.hs +75/−0
• src/Data/Record/QQ/CodeGen.hs +0/−212
• src/Data/Record/QQ/CodeGen/HSE.hs +0/−84
• src/Data/Record/QQ/CodeGen/Parser.hs +0/−85
• src/Data/Record/QQ/Runtime/MatchHasField.hs +0/−83
• src/Data/Record/TH.hs +0/−7
• src/Data/Record/TH/CodeGen.hs +0/−758
• src/Data/Record/TH/CodeGen/Tree.hs +0/−139
• src/Data/Record/TH/Config/Options.hs +0/−133
• src/Data/Record/TH/Runtime.hs +0/−58
• test/Test/Record/Prop/Show.hs +0/−15
• test/Test/Record/Prop/Show/Large.hs +0/−40
• test/Test/Record/Prop/Show/Regular.hs +0/−22
• test/Test/Record/Prop/ToFromJSON.hs +0/−61
• test/Test/Record/Sanity/CodeGen.hs +72/−0
• test/Test/Record/Sanity/Derive.hs +45/−46
• test/Test/Record/Sanity/EqualFieldTypes.hs +35/−19
• test/Test/Record/Sanity/ErrorsAndWarnings.hs +0/−82
• test/Test/Record/Sanity/ErrorsAndWarnings/Stage1.hs +0/−68
• test/Test/Record/Sanity/Generics.hs +0/−267
• test/Test/Record/Sanity/GhcGenerics.hs +21/−130
• test/Test/Record/Sanity/HKD.hs +26/−32
• test/Test/Record/Sanity/HigherKinded.hs +28/−31
• test/Test/Record/Sanity/Laziness.hs +0/−156
• test/Test/Record/Sanity/Lens/Micro.hs +0/−297
• test/Test/Record/Sanity/OverloadingNoDRF.hs +27/−20
• test/Test/Record/Sanity/PatternMatch.hs +50/−39
• test/Test/Record/Sanity/QualifiedImports.hs +14/−15
• test/Test/Record/Sanity/QualifiedImports/A.hs +12/−14
• test/Test/Record/Sanity/QualifiedImports/B.hs +13/−14
• test/Test/Record/Sanity/RDP/SingleModule.hs +118/−0
• test/Test/Record/Sanity/RDP/SplitModule.hs +99/−0
• test/Test/Record/Sanity/RDP/SplitModule/RecordDef.hs +45/−0
• test/Test/Record/Sanity/RecordConstruction.hs +34/−35
• test/Test/Record/Sanity/Strictness.hs +20/−21
• test/Test/Record/Sanity/Transform.hs +0/−339
• test/Test/Record/Size/After/HK010.hs +0/−39
• test/Test/Record/Size/After/HK020.hs +0/−24
• test/Test/Record/Size/After/HK030.hs +0/−24
• test/Test/Record/Size/After/HK040.hs +0/−24
• test/Test/Record/Size/After/HK050.hs +0/−24
• test/Test/Record/Size/After/HK060.hs +0/−24
• test/Test/Record/Size/After/HK070.hs +0/−24
• test/Test/Record/Size/After/HK080.hs +0/−24
• test/Test/Record/Size/After/HK090.hs +0/−24
• test/Test/Record/Size/After/HK100.hs +0/−24
• test/Test/Record/Size/After/R0010.hs +0/−43
• test/Test/Record/Size/After/R0020.hs +0/−43
• test/Test/Record/Size/After/R0030.hs +0/−43
• test/Test/Record/Size/After/R0040.hs +0/−43
• test/Test/Record/Size/After/R0050.hs +0/−43
• test/Test/Record/Size/After/R0060.hs +0/−43
• test/Test/Record/Size/After/R0070.hs +0/−43
• test/Test/Record/Size/After/R0080.hs +0/−43
• test/Test/Record/Size/After/R0090.hs +0/−43
• test/Test/Record/Size/After/R0100.hs +0/−43
• test/Test/Record/Size/After/R0200.hs +0/−43
• test/Test/Record/Size/After/R0300.hs +0/−43
• test/Test/Record/Size/After/R0400.hs +0/−43
• test/Test/Record/Size/After/R0500.hs +0/−43
• test/Test/Record/Size/After/R0600.hs +0/−43
• test/Test/Record/Size/After/R0700.hs +0/−43
• test/Test/Record/Size/After/R0800.hs +0/−43
• test/Test/Record/Size/After/R0900.hs +0/−43
• test/Test/Record/Size/After/R1000.hs +0/−43
• test/Test/Record/Size/Before/Baseline.hs +0/−2
• test/Test/Record/Size/Before/R010.hs +0/−49
• test/Test/Record/Size/Before/R020.hs +0/−60
• test/Test/Record/Size/Before/R030.hs +0/−71
• test/Test/Record/Size/Before/R040.hs +0/−82
• test/Test/Record/Size/Before/R050.hs +0/−93
• test/Test/Record/Size/Before/R060.hs +0/−104
• test/Test/Record/Size/Before/R070.hs +0/−115
• test/Test/Record/Size/Before/R080.hs +0/−126
• test/Test/Record/Size/Before/R090.hs +0/−137
• test/Test/Record/Size/Before/R100.hs +0/−148
• test/Test/Record/Size/Infra.hs +0/−133
• test/Test/Record/Size/Sanity.hs +0/−208
• test/Test/Record/Util.hs +4/−0
• test/TestLargeRecords.hs +9/−23

@@ -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.

@@ -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+      -- <https://github.com/ndmitchell/record-dot-preprocessor/pull/48>+    , 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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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 -- ===============================================================

@@ -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 []

@@ -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)

@@ -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 "}"-        )

@@ -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

@@ -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) |]

@@ -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)++

@@ -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

@@ -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)++

@@ -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"        ++)

@@ -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 <https://gitlab.haskell.org/ghc/ghc/-/issues/17991>+-------------------------------------------------------------------------------}++-- | 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

@@ -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"+      ]

@@ -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

@@ -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

@@ -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

@@ -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+-- <https://github.com/well-typed/large-records/pull/42>.+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)

@@ -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) }

@@ -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.------ <https://gitlab.haskell.org/ghc/ghc/-/wikis/records/overloaded-record-fields/duplicate-record-fields>--- <https://gitlab.haskell.org/ghc/ghc/-/issues/14848>-undoDRF :: String -> String-undoDRF nm =-   case nm of-     '$' : drf  -> takeWhile (/= ':') . tail . dropWhile (/= ':') $ drf-     _otherwise -> nm

@@ -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

@@ -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-        , ")"-        ]

@@ -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-

@@ -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

@@ -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)

@@ -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-

@@ -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

@@ -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

@@ -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++

@@ -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:------ * <https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0160-no-toplevel-field-selectors.rst>--- * <https://gitlab.haskell.org/ghc/ghc/-/merge_requests/4743>-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-        ]-    }

@@ -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"

@@ -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-

@@ -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)

@@ -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

@@ -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 <https://gitlab.haskell.org/ghc/ghc/-/issues/17991>--------------------------------------------------------------------------------}---- | 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

@@ -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

@@ -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-    }

@@ -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 <https://gitlab.haskell.org/ghc/ghc/-/issues/16893>.--- 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-

@@ -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)

@@ -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-      } |]

@@ -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-        ]-      ]

@@ -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)

@@ -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+    ]