packages feed

large-records (empty) → 0.1.0.0

raw patch · 98 files changed

+9097/−0 lines, 98 filesdep +QuickCheckdep +aesondep +base

Dependencies added: QuickCheck, aeson, base, containers, generic-deriving, generics-sop, ghc-dump-core, haskell-src-exts, haskell-src-meta, json-sop, large-records, microlens, mtl, newtype, record-dot-preprocessor, record-hasfield, sop-core, syb, tasty, tasty-hunit, tasty-quickcheck, template-haskell, text, transformers, vector

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for large-records++## 0.1.0.0 -- 2021-08-19++* First public release
+ large-records.cabal view
@@ -0,0 +1,206 @@+cabal-version:      2.4+name:               large-records+version:            0.1.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+                    fields. For large records (more than 30 fields, say), this+                    can become problematic, leading to large compilation times+                    and high memory requirements for ghc. The large-records+                    library provides a way to define records that is guaranteed+                    to result in ghc core that is /linear/ in the number of+                    record fields.+bug-reports:        https://github.com/well-typed/large-records/issues+license:            BSD-3-Clause+author:             Edsko de Vries+maintainer:         edsko@well-typed.com+category:           Generics+extra-source-files: CHANGELOG.md++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++                        Data.Record.QQ.CodeGen+                        Data.Record.QQ.CodeGen.HSE+                        Data.Record.QQ.CodeGen.Parser+                        Data.Record.QQ.Runtime.MatchHasField++                        Data.Record.TH+                        Data.Record.TH.CodeGen+                        Data.Record.TH.CodeGen.Tree+                        Data.Record.TH.Config.Options+                        Data.Record.TH.Runtime++                        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++    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++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+                      , 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++    if flag(profile-allzip)+      cpp-options: -DPROFILE_ALLZIP++    if flag(use-ghc-dump)+      cpp-options: -DUSE_GHC_DUMP+      build-depends: ghc-dump-core++    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++Flag build-all-modules+  Description: Build all test modules in Size+  Default: False++Flag use-ghc-dump+  Description: use ghc-dump to output AST sizes+  Default: False++Flag profile-allzip+  Description: Include experiment to verify size of AllZip is linear+  Default: False
+ src/Data/Record/Generic.hs view
@@ -0,0 +1,100 @@+{-# 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
+ src/Data/Record/Generic/Eq.hs view
@@ -0,0 +1,37 @@+{-# 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)
+ src/Data/Record/Generic/GHC.hs view
@@ -0,0 +1,111 @@+{-# 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
+ src/Data/Record/Generic/JSON.hs view
@@ -0,0 +1,45 @@+{-# 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
+ src/Data/Record/Generic/Lens/Micro.hs view
@@ -0,0 +1,212 @@+{-# 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)
+ src/Data/Record/Generic/LowerBound.hs view
@@ -0,0 +1,31 @@+{-# 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)
+ src/Data/Record/Generic/Rep.hs view
@@ -0,0 +1,210 @@+{-# 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 -- ===============================================================
+ src/Data/Record/Generic/Rep/Internal.hs view
@@ -0,0 +1,91 @@+{-# 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 []
+ src/Data/Record/Generic/SOP.hs view
@@ -0,0 +1,126 @@+{-# 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)
+ src/Data/Record/Generic/Show.hs view
@@ -0,0 +1,38 @@+{-# 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 "}"+        )
+ src/Data/Record/Generic/Transform.hs view
@@ -0,0 +1,174 @@+{-# 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
+ src/Data/Record/Internal/CodeGen.hs view
@@ -0,0 +1,110 @@+{-# 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) |]
+ src/Data/Record/Internal/Naming.hs view
@@ -0,0 +1,65 @@+{-# 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"        ++)
+ src/Data/Record/Internal/Record.hs view
@@ -0,0 +1,115 @@+{-# 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) }
+ src/Data/Record/Internal/Record/Parser.hs view
@@ -0,0 +1,140 @@+{-# 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
+ src/Data/Record/Internal/Record/Resolution.hs view
@@ -0,0 +1,79 @@+{-# 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
+ src/Data/Record/Internal/Record/Resolution/GHC.hs view
@@ -0,0 +1,110 @@+{-# 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+        , ")"+        ]
+ src/Data/Record/Internal/Record/Resolution/Internal.hs view
@@ -0,0 +1,72 @@+{-# 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+
+ src/Data/Record/Internal/TH/Name.hs view
@@ -0,0 +1,321 @@+{-# 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
+ src/Data/Record/Internal/TH/Util.hs view
@@ -0,0 +1,134 @@+{-# 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)
+ src/Data/Record/Internal/Util.hs view
@@ -0,0 +1,17 @@+-- | 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+
+ src/Data/Record/QQ/CodeGen.hs view
@@ -0,0 +1,212 @@+{-# 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+        ]+    }
+ src/Data/Record/QQ/CodeGen/HSE.hs view
@@ -0,0 +1,84 @@+{-# 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"
+ src/Data/Record/QQ/CodeGen/Parser.hs view
@@ -0,0 +1,85 @@+{-# 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+
+ src/Data/Record/QQ/Runtime/MatchHasField.hs view
@@ -0,0 +1,83 @@+{-# 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)
+ src/Data/Record/TH.hs view
@@ -0,0 +1,7 @@+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
+ src/Data/Record/TH/CodeGen.hs view
@@ -0,0 +1,758 @@+{-# 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
+ src/Data/Record/TH/CodeGen/Tree.hs view
@@ -0,0 +1,139 @@+{-# 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
+ src/Data/Record/TH/Config/Options.hs view
@@ -0,0 +1,133 @@+-- | 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+    }
+ src/Data/Record/TH/Runtime.hs view
@@ -0,0 +1,58 @@+{-# 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+
+ test/Test/Record/Prop/Show.hs view
@@ -0,0 +1,15 @@+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)
+ test/Test/Record/Prop/Show/Large.hs view
@@ -0,0 +1,40 @@+{-# 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+      } |]
+ test/Test/Record/Prop/Show/Regular.hs view
@@ -0,0 +1,22 @@+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+        ]+      ]
+ test/Test/Record/Prop/ToFromJSON.hs view
@@ -0,0 +1,61 @@+{-# 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)
+ test/Test/Record/Sanity/Derive.hs view
@@ -0,0 +1,175 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE DeriveAnyClass      #-}+{-# LANGUAGE DerivingStrategies  #-}+{-# LANGUAGE QuasiQuotes         #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving  #-}+{-# LANGUAGE TemplateHaskell     #-}++{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}+-- {-# OPTIONS_GHC -ddump-splices #-}++module Test.Record.Sanity.Derive (tests) where++import Control.Newtype+import Data.Functor.Identity+import Data.Kind+import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.TH++{-------------------------------------------------------------------------------+  Class of kind @Type -> Constraint@.+-------------------------------------------------------------------------------}++class C1 (a :: Type) where+  c1 :: a -> String+  c1 _ = "x"++-- Type of kind @Type@++largeRecord defaultPureScript [d|+      data LA1 = MkLA1 { la1_f1 :: Int }+        deriving anyclass C1+    |]++-- Type of kind @Type -> Type@ (regular and large example)++data RA2 a = MkRA1 { ra2_f1 :: a }+  deriving anyclass C1++largeRecord defaultPureScript [d|+    data LA2 a = MkLA2 { la2_f1 :: a }+      deriving anyclass C1+  |]++{-------------------------------------------------------------------------------+  Class of kind @Type -> Type -> Constraint@, partially instantiated.+  (From a purely kind point of view, this is no different to the previous+  sectiono, of course.)++  To make transpilation easier, the PureScript to Haskell transpiler makes+  all records as being a "newtype of themselves" (in PureScript, something like++  > newtype T = MkT { a :: Int, b :: Bool }++  really is a newtype around a record).+-------------------------------------------------------------------------------}++largeRecord defaultPureScript [d|+    data LB = MkLB { lb1 :: Int, lb2 :: Int }+        deriving anyclass (Newtype LB)+    |]++f :: LB -> LB+f r = pack ((unpack r){ lb1 = r.lb2, lb2 = r.lb1 })++{-------------------------------------------------------------------------------+  Class of kind @(Type -> Type) -> Constraint@+-------------------------------------------------------------------------------}++class C3 (f :: Type -> Type) where+  c3 :: f Bool -> String+  c3 _ = "x"++-- Regular (non-large) example+data RC a = MkRC { rc1 :: a, rc2 :: Int }+  deriving anyclass C3++largeRecord defaultPureScript [d|+      data LC (a :: Type) = MkLC { lc1 :: a, lc2 :: Int }+        deriving anyclass C3+    |]++{-------------------------------------------------------------------------------+  Class of kind @((Type -> Type) -> Type) -> Constraint@+-------------------------------------------------------------------------------}++class C4 (f :: (Type -> Type) -> Type) where+  c4 :: f Identity -> String+  c4 _ = "x"++-- Regular (non-large) example+data RD f = MkRD { rd1 :: f Int, rd2 :: Int }+  deriving anyclass C4++largeRecord defaultPureScript [d|+      data LD (f :: Type -> Type) = MkLD { ld1 :: f Int, ld2 :: Int }+        deriving anyclass C4+    |]++{-------------------------------------------------------------------------------+  Class with a constraint+-------------------------------------------------------------------------------}++class Show a => C5 (a :: Type) where+  c5 :: a -> String+  c5 = show++-- Regular (non-large) example+data RE = MkRE { re1 :: Int, re2 :: Bool }+  deriving stock Show+  deriving anyclass C5++largeRecord defaultPureScript [d|+      data LE = MkLE { le1 :: Int, le2 :: Bool }+        deriving stock Show+        deriving anyclass C5+    |]++{-------------------------------------------------------------------------------+  Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Sanity.Derive" [+      testCase "kind 'Type -> Constraint'"                            test_c1+    , testCase "kind 'Type -> Type -> Constraint', partially applied" test_newtype+    , testCase "kind '(Type -> Type) -> Constraint'"                  test_c3+    , testCase "kind '((Type -> Type) -> Type) -> Constraint'"        test_c4+    , testCase "kind 'Type -> Constraint', superclass constraint"     test_c5+    ]++test_c1 :: Assertion+test_c1 = do+    assertEqual "type of kind 'Type'"         (c1 la1) "x"+    assertEqual "type of kind 'Type -> Type'" (c1 la2) "x"+  where+    la1 :: LA1+    la1 = [lr| MkLA1 { la1_f1 = 1 } |]++    la2 :: LA2 Int+    la2 = [lr| MkLA2 { la2_f1 = 1 } |]++test_newtype :: Assertion+test_newtype =+    assertEqual "" r'.lb1 2+  where+    r :: LB+    r =  [lr| MkLB { lb1 = 1, lb2 = 2 }|]++    r' :: LB+    r' = f r++test_c3 :: Assertion+test_c3 =+    assertEqual "" (c3 r) "x"+  where+    r :: LC Bool+    r = [lr| MkLC { lc1 = True, lc2 = 2 } |]++test_c4 :: Assertion+test_c4 =+    assertEqual "" (c4 r) "x"+  where+    r :: LD Identity+    r = [lr| MkLD { ld1 = Identity 1, ld2 = 2 } |]++test_c5 :: Assertion+test_c5 =+    assertEqual "" (c5 r) "MkLE {le1 = 1, le2 = True}"+  where+    r :: LE+    r = [lr| MkLE { le1 = 1, le2 = True } |]
+ test/Test/Record/Sanity/EqualFieldTypes.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++-- The point of this module is to verify that largeRecord does not generate+-- redundant constraints+{-# OPTIONS_GHC -Werror -Wredundant-constraints #-}++module Test.Record.Sanity.EqualFieldTypes (tests) where++import Data.Record.TH+import Test.Tasty++largeRecord defaultPureScript [d|+      data R a = MkR {+            field1 :: a+          , field2 :: a+          }+        deriving (Show, Eq)+    |]++-- The test is compilation itself+tests :: TestTree+tests = testGroup "Test.Record.Sanity.EqualFieldTypes" []
+ test/Test/Record/Sanity/ErrorsAndWarnings.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE DataKinds        #-}+{-# LANGUAGE TemplateHaskell  #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns     #-}++module Test.Record.Sanity.ErrorsAndWarnings (tests) where++import Test.Tasty+import Test.Tasty.HUnit++import Test.Record.Util+import Test.Record.Sanity.ErrorsAndWarnings.Stage1++problemsForSyntaxErrorInExp :: (Maybe String, [Problem])+problemsForSyntaxErrorInExp = $qProblemsForSyntaxErrorInExp++problemsForSyntaxErrorInPat :: (Maybe String, [Problem])+problemsForSyntaxErrorInPat = $qProblemsForSyntaxErrorInPat++problemsForUnknownFieldsInExp :: (Maybe String, [Problem])+problemsForUnknownFieldsInExp = $qProblemsForUnknownFieldsInExp++problemsForUnknownFieldsInPat :: (Maybe String, [Problem])+problemsForUnknownFieldsInPat = $qProblemsForUnknownFieldsInPat++problemsForMissingFieldsInExp :: (Maybe String, [Problem])+problemsForMissingFieldsInExp = $qProblemsForMissingFieldsInExp++problemsForMissingFieldsInPat :: (Maybe String, [Problem])+problemsForMissingFieldsInPat = $qProblemsForMissingFieldsInPat++tests :: TestTree+tests = testGroup "Test.Record.Sanity.ErrorsAndWarnings" [+      testCase "problemsForSyntaxErrorInExp" test_problemsForSyntaxErrorInExp+    , testCase "problemsForSyntaxErrorInPat" test_problemsForSyntaxErrorInPat+    , testCase "problemsForUnknownFieldsInExp" test_problemsForUnknownFieldsInExp+    , testCase "problemsForUnknownFieldsInPat" test_problemsForUnknownFieldsInPat+    , testCase "problemsForMissingFieldsInExp" test_problemsForMissingFieldsInExp+    , testCase "problemsForMissingFieldsInPat" test_problemsForMissingFieldsInPat+    ]++test_problemsForSyntaxErrorInExp :: Assertion+test_problemsForSyntaxErrorInExp = do+    assertJust "no failure reported" (fst problemsForSyntaxErrorInExp) $+      assertPrefix "Could not parse expression:"+    assertEqual "other problems" [] (snd problemsForSyntaxErrorInExp)++test_problemsForSyntaxErrorInPat :: Assertion+test_problemsForSyntaxErrorInPat = do+    assertJust "no failure reported" (fst problemsForSyntaxErrorInPat) $+      assertPrefix "Could not parse pattern:"+    assertEqual "other problems" [] (snd problemsForSyntaxErrorInPat)++test_problemsForUnknownFieldsInExp :: Assertion+test_problemsForUnknownFieldsInExp =+    assertEqual "" expected problemsForUnknownFieldsInExp+  where+    expected :: (Maybe String, [Problem])+    expected = (Nothing, [Error "Unknown fields: c"])++test_problemsForUnknownFieldsInPat :: Assertion+test_problemsForUnknownFieldsInPat =+    assertEqual "" expected problemsForUnknownFieldsInPat+  where+    expected :: (Maybe String, [Problem])+    expected = (Nothing, [Error "Unknown fields: c"])++test_problemsForMissingFieldsInExp :: Assertion+test_problemsForMissingFieldsInExp =+    assertEqual "" expected problemsForMissingFieldsInExp+  where+    expected :: (Maybe String, [Problem])+    expected = (Nothing, [Warning "No value for field b"])++test_problemsForMissingFieldsInPat :: Assertion+test_problemsForMissingFieldsInPat =+    assertEqual "" expected problemsForMissingFieldsInPat+  where+    -- It is of course perfectly fine for a pattern to be missing fields+    expected :: (Maybe String, [Problem])+    expected = (Nothing, [])+
+ test/Test/Record/Sanity/ErrorsAndWarnings/Stage1.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++-- {-# OPTIONS_GHC -ddump-splices #-}++module Test.Record.Sanity.ErrorsAndWarnings.Stage1 (+    -- * The record we're testing against+    --+    -- It is important that we export 'R', because the various TH expressions+    -- we not executed here, but rather where we use them+    -- ("Test.Record.Sanity.ErrorsAndWarnings.Stage1"); this means that if we+    -- don't export this, the " problem " that is reported is the constructor+    -- not being in scope, rather than the missing/extra fields.+    R(..)++    -- The specific tests+  , qProblemsForSyntaxErrorInExp+  , qProblemsForSyntaxErrorInPat+  , qProblemsForUnknownFieldsInExp+  , qProblemsForUnknownFieldsInPat+  , qProblemsForMissingFieldsInExp+  , qProblemsForMissingFieldsInPat+  ) where++import Language.Haskell.TH+import Language.Haskell.TH.Syntax++import Data.Record.TH+import Data.Record.QQ.CodeGen++import Test.Record.Util++largeRecord defaultPureScript [d|+      data R = MkR { a :: Int, b :: Bool }+    |]++qProblemsForSyntaxErrorInExp :: Q Exp+qProblemsForSyntaxErrorInExp = (lift =<<) $ collectOnlyProblems $+    lrExp "MkR { a = 1, b = True, c = ()"++qProblemsForSyntaxErrorInPat :: Q Exp+qProblemsForSyntaxErrorInPat = (lift =<<) $ collectOnlyProblems $+    lrPat "MkR { a = x, b = y, c = z"++qProblemsForUnknownFieldsInExp :: Q Exp+qProblemsForUnknownFieldsInExp = (lift =<<) $ collectOnlyProblems $+    lrExp "MkR { a = 1, b = True, c = () }"++qProblemsForUnknownFieldsInPat :: Q Exp+qProblemsForUnknownFieldsInPat = (lift =<<) $ collectOnlyProblems $+    lrPat "MkR { a = x, b = y, c = z }"++qProblemsForMissingFieldsInExp :: Q Exp+qProblemsForMissingFieldsInExp = (lift =<<) $ collectOnlyProblems $+    lrExp "MkR { a = 1 }"++qProblemsForMissingFieldsInPat :: Q Exp+qProblemsForMissingFieldsInPat = (lift =<<) $ collectOnlyProblems $+    lrPat "MkR { a = x }"+
+ test/Test/Record/Sanity/Generics.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE DataKinds              #-}+{-# LANGUAGE EmptyCase              #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE KindSignatures         #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE PatternSynonyms        #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TemplateHaskell        #-}+{-# LANGUAGE TypeApplications       #-}+{-# LANGUAGE TypeFamilies           #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE UndecidableInstances   #-}+{-# LANGUAGE ViewPatterns           #-}++-- {-# OPTIONS_GHC -ddump-splices #-}++-- | Sanity check that the generic functions are not totally broken+--+-- These are not proper tests, merely intended to catch egregious refactoring+-- mistakes.+module Test.Record.Sanity.Generics (tests) where++import Control.Monad.State (State, evalState, state)+import Data.Proxy+import Data.SOP (NP(..), All, Compose)++import qualified Data.SOP                   as SOP+import qualified Generics.SOP               as SOP+import qualified Generics.SOP.Metadata      as SOP+import qualified Generics.SOP.Type.Metadata as SOP.T++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck++import Data.Record.Generic+import Data.Record.Generic.LowerBound+import Data.Record.Generic.SOP hiding (glowerBound)+import Data.Record.TH++import qualified Data.Record.Generic.SOP as SOP+import qualified Data.Record.Generic.Rep as Rep++{-------------------------------------------------------------------------------+  Small test record+-------------------------------------------------------------------------------}++largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d|+  data T a b = MkT {+        tInt   :: Word+      , tBool  :: Bool+      , tChar  :: Char+      , tA     :: a+      , tListB :: [b]+      }+    deriving (Eq, Ord, Show)+  |]++exampleT :: T () Float+exampleT = MkT 5 True 'c' () [3.14]++_silenceWarnings :: ()+_silenceWarnings = const () $ (+      tInt+    , tBool+    , tChar+    , tA+    , tListB+    )++{-------------------------------------------------------------------------------+  Handwritten SOP instance++  This allows us to compare the untyped representation used by @large-records@+  to the strongly typed version from @generics-sop@.+-------------------------------------------------------------------------------}++instance SOP.Generic (T a b) where+  type Code (T a b) = '[[Word, Bool, Char, a, [b]]]+  from (MkT i b c a bs) = SOP.SOP (SOP.Z (I i :* I b :* I c :* I a :* I bs :* Nil))+  to (SOP.SOP (SOP.Z (I i :* I b :* I c :* I a :* I bs :* Nil))) = MkT i b c a bs+  to (SOP.SOP (SOP.S x)) = case x of {}++type DefaultBang =+       'SOP.T.StrictnessInfo+          'SOP.NoSourceUnpackedness+          'SOP.NoSourceStrictness+          'SOP.DecidedLazy++instance SOP.HasDatatypeInfo (T a b) where+  type DatatypeInfoOf (T a b) =+    'SOP.T.ADT+      "Data.Record.Generic.Sanity"+      "T"+      '[ 'SOP.T.Record "MkT" '[+          'SOP.T.FieldInfo "tInt"+        , 'SOP.T.FieldInfo "tBool"+        , 'SOP.T.FieldInfo "tChar"+        , 'SOP.T.FieldInfo "tA"+        , 'SOP.T.FieldInfo "tListB"+        ]]+      '[ '[+          DefaultBang+        , DefaultBang+        , DefaultBang+        , DefaultBang+        , DefaultBang+        ]]++  datatypeInfo _ =+      SOP.T.demoteDatatypeInfo $ Proxy @(SOP.DatatypeInfoOf (T a b))++{-------------------------------------------------------------------------------+  Tests+-------------------------------------------------------------------------------}++test_from_to_id :: Assertion+test_from_to_id =+    assertEqual "from . to = id" expected actual+  where+    expected, actual :: T () Float+    expected = exampleT+    actual   = (to . from) exampleT++test_pure :: Assertion+test_pure =+    compareTyped expected actual+  where+    expected :: NP (Field (K Char)) (MetadataOf (T () Float))+    expected =+           Field (K 'a')+        :* Field (K 'a')+        :* Field (K 'a')+        :* Field (K 'a')+        :* Field (K 'a')+        :* Nil++    actual :: Rep (K Char) (T () Float)+    actual = Rep.pure (K 'a')++test_cpure :: Assertion+test_cpure =+    assertEqual "matches hand-constructed" expected actual+  where+    expected, actual :: T () Float+    expected = MkT 0 False '\x0000' () []+    actual   = glowerBound++test_sequenceA :: Assertion+test_sequenceA =+    compareTyped expected actual+  where+    expected :: NP (Field (K Int)) (MetadataOf (T () Float))+    expected =+          flip evalState 0+        $ SOP.hsequence'+        $ SOP.hmap distrib+        $ example+      where+        distrib :: Field (State Int :.: K Int) x+                -> (State Int :.: (Field (K Int))) x+        distrib (Field (Comp x)) = Comp (Field <$> x)++    actual :: Rep (K Int) (T () Float)+    actual = flip evalState 0 $ Rep.sequenceA $ SOP.fromSOP example++    example :: NP (Field (State Int SOP.:.: K Int)) (MetadataOf (T () Float))+    example =+           Field (Comp (K <$> tick))+        :* Field (Comp (K <$> tick))+        :* Field (Comp (K <$> tick))+        :* Field (Comp (K <$> tick))+        :* Field (Comp (K <$> tick))+        :* Nil++    tick :: State Int Int+    tick = state $ \i -> (i, i + 1)++test_zipWithM :: Assertion+test_zipWithM =+    compareTyped expected actual+  where+    expected :: NP (Field (K Int)) (MetadataOf (T () Float))+    expected =+          flip evalState 0+        $ SOP.hsequence'+        $ SOP.hliftA2 tick' x y+      where+        tick' :: Field (K Int) field+              -> Field (K Int) field+              -> (State Int :.: Field (K Int)) field+        tick' (Field a) (Field b) = Comp $ Field <$> tick a b++    actual :: Rep (K Int) (T () Float)+    actual = flip evalState 0 $+        Rep.zipWithM tick (fromSOP x) (fromSOP y)++    tick :: K Int x -> K Int x -> State Int (K Int x)+    tick (K a) (K b) = state $ \i -> (K (a + b + i), i + 1)++    x, y :: NP (Field (K Int)) (MetadataOf (T () Float))+    x = Field (K 10)+     :* Field (K 11)+     :* Field (K 12)+     :* Field (K 13)+     :* Field (K 14)+     :* Nil+    y = Field (K 20)+     :* Field (K 21)+     :* Field (K 22)+     :* Field (K 23)+     :* Field (K 24)+     :* Nil++test_ord :: Word -> Word -> Bool -> Bool -> Property+test_ord w w' b b'+  | w == w' && b == b' = t1 === t2+  | w == w'            = compare t1 t2 === compare b b'+  | otherwise          = compare t1 t2 === compare w w'+  where+    t1, t2 :: T () Float+    t1 = MkT w  b  'c' () [3.14]+    t2 = MkT w' b' 'c' () [3.14]++{-------------------------------------------------------------------------------+  For testing purposes, we compare against proper heterogeneous lists+-------------------------------------------------------------------------------}++compareTyped ::+     forall f a. (+       Generic a+     , Constraints a (Compose Eq f)+     , Constraints a (Compose Show f)+     , All IsField (MetadataOf a)+     )+  => NP (Field f) (MetadataOf a) -> Rep f a -> Assertion+compareTyped expected actual =+    case toSOP actual of+      Nothing ->+        assertFailure "compareTyped: incorrect number of fields"+      Just actual' ->+        case toDictAll (Proxy @f) (Proxy @a) (Proxy @Show) of+          Dict ->+            case toDictAll (Proxy @f) (Proxy @a) (Proxy @Eq) of+              Dict -> go expected actual'+  where+    go :: ( All (Compose Eq   (Field f)) fields+          , All (Compose Show (Field f)) fields+          )+       => NP (Field f) fields -> NP (Field f) fields -> Assertion+    go = assertEqual "compareTyped"++{-------------------------------------------------------------------------------+  All tests+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Sanity" [+      testCase     "from_to_id" test_from_to_id+    , testCase     "pure"       test_pure+    , testCase     "sequenceA"  test_sequenceA+    , testCase     "zipWithM"   test_zipWithM+    , testCase     "cpure"      test_cpure+    , testProperty "ord"        test_ord+    ]
+ test/Test/Record/Sanity/GhcGenerics.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -Wno-orphans #-}+-- {-# OPTIONS_GHC -ddump-splices #-}++module Test.Record.Sanity.GhcGenerics (tests) where++import Data.Function (on)+import Data.Proxy+import Data.Record.Generic.GHC+import Data.Record.TH+import Data.SOP.BasicFunctors+import Test.Tasty+import Test.Tasty.HUnit++import qualified Data.Record.Generic     as LR+import qualified Data.Record.Generic.Eq  as LR+import qualified Data.Record.Generic.Rep as Rep+import qualified Generics.Deriving.Eq    as GHC+import qualified GHC.Generics            as GHC++{-------------------------------------------------------------------------------+  Example large record+-------------------------------------------------------------------------------}++largeRecord defaultPureScript [d|+      data LargeRecord = MkLargeRecord {+            largeField1 :: Int+          , largeField2 :: Bool+          }+    |]++example :: LargeRecord+example = [lr| MkLargeRecord |] 1 True++{-------------------------------------------------------------------------------+  Show that we can use geqdefault on a large record+-------------------------------------------------------------------------------}++instance ( LR.Generic a+         , LR.Constraints a Eq+         ) => GHC.GEq' (ThroughLRGenerics a) where+  geq' = LR.geq `on` unwrapThroughLRGenerics++allEqualTo :: (GHC.Generic a, GHC.GEq' (GHC.Rep a)) => a -> [a] -> Bool+allEqualTo x = all (GHC.geqdefault x)++{-------------------------------------------------------------------------------+  Example with GHC field metadata+-------------------------------------------------------------------------------}++class GRecordToTable f where+  gRecordToTable :: f p -> [(String, String)]++instance GRecordToTable f+      => GRecordToTable (GHC.M1 GHC.D c f) where+  gRecordToTable (GHC.M1 x) = gRecordToTable x++instance GRecordToTable f+      => GRecordToTable (GHC.M1 GHC.C c f) where+  gRecordToTable (GHC.M1 x) = gRecordToTable x++instance (GRecordToTable f, GRecordToTable g)+      => GRecordToTable (f GHC.:*: g) where+  gRecordToTable (l GHC.:*: r) = gRecordToTable l ++ gRecordToTable r++instance (GHC.Selector f, Show a)+      => GRecordToTable (GHC.M1 GHC.S f (GHC.K1 GHC.R a)) where+  gRecordToTable f@(GHC.M1 (GHC.K1 x)) = [(GHC.selName f, show x)]++data Table = Table {+      tableFields :: [(String, String)]+    }+  deriving (Show, Eq)++simpleRecordToTable :: (GHC.Generic a, GRecordToTable (GHC.Rep a)) => a -> Table+simpleRecordToTable = Table . gRecordToTable . GHC.from++data SimpleRecord = MkSimpleRecord {+      simpleField1 :: Int+    , simpleField2 :: Bool+    }+  deriving (GHC.Generic)++-- The goal is to reuse the instance for fields+-- TODO: We could potentially extend this to the other metadata as well+largeRecordToTable :: forall a.+     (LR.Generic a, LR.Constraints a Show)+  => a -> Table+largeRecordToTable = \x ->+    Table {+        tableFields = concat . Rep.collapse $+            Rep.czipWith+              (Proxy @Show)+              aux+              (LR.from x)+              (ghcMetadataFields (ghcMetadata (Proxy @a)))+      }+  where+    aux :: Show x => I x -> GhcFieldMetadata x -> K [(String, String)] x+    aux (I x) (GhcFieldMetadata p) = K $ gRecordToTable $ aux' x p++    aux' :: x -> Proxy f -> GHC.M1 GHC.S f (GHC.K1 GHC.R x) p+    aux' x _ = GHC.M1 (GHC.K1 x)++{-------------------------------------------------------------------------------+  Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Sanity.GhcGenerics" [+      testCase "allEqualTo"          test_allEqualTo+    , testCase "simpleRecordToTable" test_simpleRecordToTable+    , testCase "largeRecordToTable"  test_largeRecordToTable+    ]++test_allEqualTo :: Assertion+test_allEqualTo = assertEqual "" (allEqualTo example [example]) True++-- Just a sanity check that the standard GHC generic functions works as intended+test_simpleRecordToTable :: Assertion+test_simpleRecordToTable =+    assertEqual "" (simpleRecordToTable r) tbl+  where+    r :: SimpleRecord+    r = MkSimpleRecord 1 True++    tbl :: Table+    tbl = Table [+          ("simpleField1", "1")+        , ("simpleField2", "True")+        ]++test_largeRecordToTable :: Assertion+test_largeRecordToTable =+    assertEqual "" (largeRecordToTable example) tbl+  where+    tbl :: Table+    tbl = Table [+          ("largeField1", "1")+        , ("largeField2", "True")+        ]
+ test/Test/Record/Sanity/HKD.hs view
@@ -0,0 +1,73 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE ViewPatterns          #-}++{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}+-- {-# OPTIONS_GHC -ddump-splices #-}++module Test.Record.Sanity.HKD (+    tests+  ) where++import Data.Functor.Identity+import Data.Functor.Const+import Data.Kind++import Data.Record.TH++import Test.Tasty+import Test.Tasty.HUnit++type family HKD f a where+  HKD Identity  a = a+  HKD (Const b) a = b++-- | Test record with fields whose types are given by type families+largeRecord defaultPureScript [d|+    data T (f :: Type -> Type) = MkT {+          field1 :: HKD f Int+        , field2 :: HKD f Bool+        }+      deriving (Show, Eq)+  |]++{-------------------------------------------------------------------------------+  Tests+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Sanity.HKD" [+      testCase "get"   testGet+    , testCase "set"   testSet+    , testCase "match" testMatch+    ]++example1, example2 :: T Identity+example1 = [lr| MkT { field1 = 1, field2 = True  } |]+example2 = [lr| MkT { field1 = 1, field2 = False } |]++example3 :: T (Const Char)+example3 = [lr| MkT { field1 = 'a', field2 = 'b' } |]++exampleFun :: T f -> HKD f Int+exampleFun [lr| MkT { field1 } |] = field1++testGet :: Assertion+testGet = assertEqual "" example1.field1 1++testSet :: Assertion+testSet = assertEqual "" (example1{ field2 = False }) example2++testMatch :: Assertion+testMatch = do+    assertEqual "example1" (exampleFun example1) 1+    assertEqual "example3" (exampleFun example3) 'a'
+ test/Test/Record/Sanity/HigherKinded.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++-- {-# OPTIONS_GHC -ddump-splices #-}++-- | Simple example of a type with a higher kind+module Test.Record.Sanity.HigherKinded (+    tests+  ) where++import Data.Kind+import GHC.TypeLits++import Data.Record.Generic+import Data.Record.Generic.LowerBound+import Data.Record.TH++import Test.Tasty+import Test.Tasty.HUnit++newtype T (n :: Nat) (f :: Type -> Type) = MkT (f Word)++instance LowerBound (T n I) where+  lowerBound = MkT (I lowerBound)++deriving instance Show (T n I)++-- We need an explicit kind annotation on @f@ for @large-records@ to generate+-- correct code (either that, or use @PolyKinds@).+largeRecord defaultLazyOptions [d|+  data MyRecord (f :: Type -> Type) = MyRecord {+        field0 :: T 0 f+      , field1 :: T 1 f+      , field2 :: T 2 f+      , field3 :: T 3 f+      , field4 :: T 4 f+      , field5 :: T 5 f+      , field6 :: T 6 f+      , field7 :: T 7 f+      , field8 :: T 8 f+      , field9 :: T 9 f+      }+      deriving (Show)+  |]++_suppressWarnings :: ()+_suppressWarnings = const () (+      field0+    , field1+    , field2+    , field3+    , field4+    , field5+    , field6+    , field7+    , field8+    , field9+    )++example :: MyRecord I+example = glowerBound++{-------------------------------------------------------------------------------+  Just to make sure we don't regard everything as dead code+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Sanity.HigherKinded" [+      testCase "show" test_show+    ]++test_show :: Assertion+test_show = assertBool "" $ (not . null) (show example)
+ test/Test/Record/Sanity/Laziness.hs view
@@ -0,0 +1,156 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}++-- | Check that the functions on 'Rep' can be called on 'undefined'+module Test.Record.Sanity.Laziness (tests) where++import Control.Exception+import Data.List (isInfixOf)+import Data.IORef+import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Generic+import Data.Record.TH++import qualified Data.Record.Generic.Rep          as Rep+import qualified Data.Record.Generic.Rep.Internal as Rep++import Test.Record.Util++{-------------------------------------------------------------------------------+  Example record+-------------------------------------------------------------------------------}++largeRecord defaultPureScript [d|+      data R = MkR {+            ri :: Word+          , rb :: Bool+          }+        deriving (Show, Eq)+    |]++example :: R+example = [lr| MkR { ri = 5, rb = True } |]++{-------------------------------------------------------------------------------+  Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Sanity.Laziness" [+      testCase "mapWithIndex" test_mapWithIndex+    , testCase "ap"           test_ap+    , testCase "map"          test_map+    , testCase "map'"         test_map'+    , testCase "mapM"         test_mapM+    , testCase "cmap"         test_cmap+    , testCase "cmapM"        test_cmapM+    , testCase "zipWithM"     test_zipWithM+    , testCase "czipWithM"    test_czipWithM+    ]++test_mapWithIndex :: Assertion+test_mapWithIndex =+    assertEqual "" expected actual+  where+    expected, actual :: Rep (K Int) R+    expected = Rep.unsafeFromList [0, 1]+    actual   = Rep.mapWithIndex (\ix _ -> K $ Rep.indexToInt ix) undefined++test_ap :: Assertion+test_ap =+    assertEqual "" expected actual+  where+    fns :: Rep (f -.-> I) R+    fns = Rep.map' (\x -> Fn $ \_ -> x) (from example)++    expected, actual :: R+    expected = example+    actual   = to $ Rep.ap fns undefined++test_map :: Assertion+test_map =+    assertEqual "" expected actual+  where+    expected, actual :: Rep (K Int) R+    expected = Rep.unsafeFromList [0, 0]+    actual   = Rep.map (\_ -> K 0) undefined++-- Just to be sure: if we use map' instead of map, we get bottom+test_map' :: Assertion+test_map' = expectException isExpectedException $ do+    assertEqual "" expected actual+  where+    isExpectedException :: SomeException -> Bool+    isExpectedException e = "undefined" `isInfixOf` show e++    expected, actual :: Rep (K Int) R+    expected = Rep.unsafeFromList [0, 0]+    actual   = Rep.map' (\_ -> K 0) undefined++test_mapM :: Assertion+test_mapM = do+    r <- newIORef 1++    let next :: f x -> IO (K Int x)+        next _ = atomicModifyIORef r $ \i -> (i + 1, K i)++    actual :: Rep (K Int) R <- Rep.mapM next undefined+    assertEqual "" expected actual+  where+    expected :: Rep (K Int) R+    expected = Rep.unsafeFromList [1, 2]++test_cmap :: Assertion+test_cmap =+    assertEqual "" expected actual+  where+    expected, actual :: R+    expected = [lr| MkR { ri = 0, rb = False } |]+    actual   = to $ Rep.cmap (Proxy @Bounded) (\_ -> I minBound) undefined++test_cmapM :: Assertion+test_cmapM = do+    r <- newIORef False++    let next :: Bounded x => f x -> IO (I x)+        next _ = do+            b <- atomicModifyIORef r $ \b -> (not b, b)+            return . I $ if b then maxBound else minBound++    actual :: R <- to <$> Rep.cmapM (Proxy @Bounded) next undefined+    assertEqual "" expected actual+  where+    expected :: R+    expected = [lr| MkR { ri = 0, rb = True } |]++test_zipWithM :: Assertion+test_zipWithM =+    assertEqual "" expected actual+  where+    expected, actual :: Maybe (Rep (K Int) R)+    expected = Just $ Rep.unsafeFromList [0, 0]+    actual   = Rep.zipWithM (\_ _ -> Just $ K 0) undefined undefined++test_czipWithM :: Assertion+test_czipWithM =+    assertEqual "" expected actual+  where+    expected, actual :: Maybe R+    expected = Just $ [lr| MkR { ri = 0, rb = False } |]+    actual   = to <$> Rep.czipWithM+                        (Proxy @Bounded)+                        (\_ _ -> Just $ I minBound)+                        undefined+                        undefined
+ test/Test/Record/Sanity/Lens/Micro.hs view
@@ -0,0 +1,297 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE ImpredicativeTypes    #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ViewPatterns #-}++module Test.Record.Sanity.Lens.Micro (tests) where++import Data.Kind+import Data.Maybe (fromJust)+import Data.SOP+import Lens.Micro (Lens', (^.), (&), (%~))+import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Generic+import Data.Record.Generic.Lens.Micro+import Data.Record.Generic.SOP+import Data.Record.Generic.Transform+import Data.Record.QQ.CodeGen+import Data.Record.TH++import qualified Data.Record.Generic.Rep as Rep++{-------------------------------------------------------------------------------+  Simple example (no type families)+-------------------------------------------------------------------------------}++largeRecord defaultPureScript [d|+      data Simple (f :: Type -> Type) = MkSimple {+            s1 :: f Int+          , s2 :: f Bool+          , s3 :: f Char+          }+        deriving (Show, Eq)+    |]++simpleExample :: Simple I+simpleExample = [lr| MkSimple {+      s1 = I 5+    , s2 = I True+    , s3 = I 'a'+    } |]++simpleExampleLenses :: Simple (RegularRecordLens Simple f)+simpleExampleLenses = lensesForRegularRecord (Proxy @DefaultInterpretation)++[lr| MkSimple {+      s1 = RegularRecordLens xs1+    , s2 = RegularRecordLens xs2+    , s3 = RegularRecordLens xs3+    } |] = simpleExampleLenses++{-------------------------------------------------------------------------------+  Simplified version of beam's 'Columnar' type'+-------------------------------------------------------------------------------}++data Lenses (tbl :: (Type -> Type) -> Type) (f :: Type -> Type) (x :: Type)++data WrapLens a b = WrapLens (Lens' a b)++type family Columnar f x :: Type where+  Columnar I              x = x+  Columnar (Lenses tbl f) x = WrapLens (tbl f) (Columnar f x)+  Columnar f              x = f x++{-------------------------------------------------------------------------------+  Example with type families, but still regular++  See /next/ example for usage of, and motivation for, 'Lenses'.+-------------------------------------------------------------------------------}++data BeamInterpretation (f :: Type -> Type)++type instance Interpreted (BeamInterpretation f) (Uninterpreted x) = Columnar f x++instance StandardInterpretation BeamInterpretation (RegularRecordLens tbl f)+instance StandardInterpretation BeamInterpretation I++largeRecord defaultPureScript [d|+      data Regular (f :: Type -> Type) = MkRegular {+            r1 :: Columnar f Int+          , r2 :: Columnar f Bool+          , r3 :: Columnar f Char+          }+        deriving (Show, Eq)+    |]++regularExample :: Regular I+regularExample = [lr| MkRegular {+      r1 = 5+    , r2 = True+    , r3 = 'a'+    } |]++regularLenses :: Regular (RegularRecordLens Regular I)+regularLenses = lensesForRegularRecord (Proxy @BeamInterpretation)++[lr| MkRegular {+      r1 = RegularRecordLens xr1+    , r2 = RegularRecordLens xr2+    , r3 = RegularRecordLens xr3+    } |] = regularLenses++{-------------------------------------------------------------------------------+  Beam-like example++  The lenses we generate above have @I x@ as their argument, rather than @x@. In+  beam, the lenses have @Columnar f x@ as their target, which is just @x@ in the+  case that @f == I@. If we want to replicate this, we cannot use+  'lensesForRegularRecord', which gives us 'RegularRecordLens', and must instead+  use the lower-level function 'lensesForHKRecord'. This example is still+  simplified from the beam example because we don't support any form of mixins;+  we insist every field is regular, which allows us to avoid introducing a+  separate type class. See the @beam-large-package@ for full beam integration.+-------------------------------------------------------------------------------}++beamLikeLenses :: forall tbl.+     ( Generic (tbl (Lenses tbl I))+     , Generic (tbl Uninterpreted)+     , Generic (tbl I)+     , HasNormalForm (BeamInterpretation (Lenses tbl I)) (tbl (Lenses tbl I)) (tbl Uninterpreted)+     , HasNormalForm (BeamInterpretation I) (tbl I) (tbl Uninterpreted)+     , Constraints (tbl Uninterpreted) (IsRegularField Uninterpreted)+     )+  => tbl (Lenses tbl I)+beamLikeLenses =+    to . denormalize1 (Proxy @BeamInterpretation) $+      Rep.cmap+        (Proxy @(IsRegularField Uninterpreted))+        aux+        (lensesForHKRecord (Proxy @BeamInterpretation))+  where+    aux :: forall x.+         IsRegularField Uninterpreted x+      => HKRecordLens BeamInterpretation I tbl x+      -> Interpret (BeamInterpretation (Lenses tbl I)) x+    aux (HKRecordLens l) =+        case isRegularField (Proxy @(Uninterpreted x)) of+          RegularField -> Interpret $ WrapLens $+              l+            . standardInterpretationLens (Proxy @BeamInterpretation)+            . unI'++    unI' :: Lens' (I x) x+    unI' f (I x) = I <$> f x++regularBeamLikeLenses :: Regular (Lenses Regular I)+regularBeamLikeLenses = beamLikeLenses++[lr| MkRegular {+      r1 = WrapLens br1+    , r2 = WrapLens br2+    , r3 = WrapLens br3+    } |] = regularBeamLikeLenses++{-------------------------------------------------------------------------------+  Irregular example+-------------------------------------------------------------------------------}++largeRecord defaultPureScript [d|+      data Irregular (f :: Type -> Type) = MkIrregular {+            i1 :: f Int+          , i2 :: f Bool+          , i3 :: Char -- No @f@!+          }+        deriving (Show, Eq)+    |]++irregularExample :: Irregular I+irregularExample = [lr| MkIrregular {+      i1 = I 5+    , i2 = I True+    , i3 = 'a'+    } |]++-- We cannot define this now:+--+-- > irregularLenses :: Irregular (RegularRecordLens Irregular I)+-- > irregularLenses = lensesForRegularRecord (Proxy @DefaultInterpretation)+--+-- It will complain that @Char@ is not equal to+--+-- > Interpreted (DefaultInterpretation (RegularRecordLens Irregular I)) Char+--+-- We can use 'repLenses' to nonetheless get lenses for all fields in+-- 'Irregular', and then translate to an NP so that we can pattern match on it+-- in a type-safe way. Of course, the translation to SOP incurs O(N^2)+-- compile-time cost so this is not a proper solution.+--+-- NOTE: There is not much point using 'repLenses'' here; that is primarily+-- useful only if there is some post-processing step (like done by+-- 'lensesForRegularRecord').+irregularLenses :: NP (Field (SimpleRecordLens (Irregular f))) (MetadataOf (Irregular f))+irregularLenses = fromJust $ toSOP rep+  where+    rep :: Rep (SimpleRecordLens (Irregular f)) (Irregular f)+    rep = lensesForSimpleRecord++(    Field (SimpleRecordLens xi1)+  :* Field (SimpleRecordLens xi2)+  :* Field (SimpleRecordLens xi3)+  :* Nil ) = irregularLenses++{-------------------------------------------------------------------------------+  Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Sanity.Lens.Micro" [+      testCase "simple_get"    test_simple_get+    , testCase "simple_set"    test_simple_set+    , testCase "regular_get"   test_regular_get+    , testCase "regular_set"   test_regular_set+    , testCase "beamlike_get"  test_beamlike_get+    , testCase "beamlike_set"  test_beamlike_set+    , testCase "irregular_get" test_irregular_get+    , testCase "irregular_set" test_irregular_set+    ]++test_simple_get :: Assertion+test_simple_get =+    assertEqual "" (I True)+      (simpleExample ^. xs2)++test_simple_set :: Assertion+test_simple_set =+    assertEqual "" expected $+      simpleExample & xs1 %~ mapII negate & xs3 %~ mapII succ+  where+    expected :: Simple I+    expected = [lr| MkSimple {+          s1 = I (-5)+        , s2 = I True+        , s3 = I 'b'+        } |]++test_regular_get :: Assertion+test_regular_get =+    assertEqual "" (I True)+      (regularExample ^. xr2)++test_regular_set :: Assertion+test_regular_set =+    assertEqual "" expected $+      regularExample & xr1 %~ mapII negate & xr3 %~ mapII succ+  where+    expected :: Regular I+    expected = [lr| MkRegular {+          r1 = (-5)+        , r2 = True+        , r3 = 'b'+        } |]++test_beamlike_get :: Assertion+test_beamlike_get =+    assertEqual "" True+      (regularExample ^. br2)++test_beamlike_set :: Assertion+test_beamlike_set =+    assertEqual "" expected $+      regularExample & br1 %~ negate & br3 %~ succ+  where+    expected :: Regular I+    expected = [lr| MkRegular {+          r1 = (-5)+        , r2 = True+        , r3 = 'b'+        } |]++test_irregular_get :: Assertion+test_irregular_get =+    assertEqual "" (I True)+      (irregularExample ^. xi2)++test_irregular_set :: Assertion+test_irregular_set =+    assertEqual "" expected $+      irregularExample & xi1 %~ mapII negate & xi3 %~ succ+  where+    expected :: Irregular I+    expected = [lr| MkIrregular {+          i1 = I (-5)+        , i2 = I True+        , i3 = 'b'+        } |]
+ test/Test/Record/Sanity/OverloadingNoDRF.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}+-- {-# OPTIONS_GHC -ddump-splices #-}++module Test.Record.Sanity.OverloadingNoDRF (+    tests+  ) where++import Data.Record.TH++import Test.Tasty+import Test.Tasty.HUnit++{-------------------------------------------------------------------------------+  Simple test case+-------------------------------------------------------------------------------}++largeRecord defaultPureScript [d|+  data X = MkX { a :: Int    }+  data Y = MkY { a :: String }+  |]++testOverloading :: Assertion+testOverloading = do+    assertEqual "X" x.a 0+    assertEqual "Y" y.a "hi"+  where+    x :: X+    x = _construct_MkX 0++    y :: Y+    y = _construct_MkY "hi"++tests :: TestTree+tests = testGroup "Test.Record.Sanity.OverloadingNoDRF" [+      testCase "overloading" testOverloading+    ]
+ test/Test/Record/Sanity/PatternMatch.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns        #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE ViewPatterns          #-}++{-# OPTIONS_GHC -Wno-missing-signatures #-}+{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors  #-}+-- {-# OPTIONS_GHC -ddump-splices #-}++module Test.Record.Sanity.PatternMatch (tests) where++import Control.Exception+import Data.List (isInfixOf)+import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.TH++import Test.Record.Util++{-------------------------------------------------------------------------------+  Basic pattern matching tests+-------------------------------------------------------------------------------}++largeRecord defaultPureScript [d|+    data T a = MkT { x :: Int,  y :: [a], z :: Double }+    data S a = MkS { x :: Char, y :: T a }+  |]++projectOne :: T Bool -> Int+projectOne [lr| MkT { x = a } |] = a++projectTwo :: T a -> (Int, [a])+projectTwo [lr| MkT { x = a, y = b } |] = (a, b)++-- | Test projecting more than 2 elements+--+-- This is an important special case, because this checks that the pattern we+-- generate is correctedly nested to match the 'MatchHasField' instances.+projectThree :: T a -> (Int, [a], Double)+projectThree [lr| MkT { x = a, y = b, z = c } |] = (a, b, c)++projectPuns :: T a -> (Int, [a])+projectPuns [lr| MkT { x, y } |] = (x, y)++projectNested :: S a -> (Char, Int, [a])+projectNested [lr| MkS { x = a, y = MkT { x = b, y = c } } |] = (a, b, c)++projectView :: T Bool -> Int+projectView [lr| MkT { x = ((+1) -> a) } |] = a++matchEmpty :: T Bool -> Int+matchEmpty [lr| MkT {} |] = 42++{-------------------------------------------------------------------------------+  Verify inferred types++  We want to infer that the types are not more polymorphic than they should be:+  functions that match on a record should not be polymorphic in 'HasField', but+  should only accept values of that specific record type.++  Functions 'useNoSigEmpty' and 'useNoSigNonEmpty' below will have (deferred)+  type errors iff 'noSigEmpty' and 'noSigNonEmpty' are suffciently monomorphic.+-------------------------------------------------------------------------------}++largeRecord defaultPureScript [d|+    data T2 = MkT2 { x :: Int }+  |]++noSigEmpty [lr| MkT {} |] = ()++noSigNonEmpty [lr| MkT { x = a } |] = const () a++useNoSigEmpty :: ()+useNoSigEmpty = noSigEmpty [lr| MkT2 { x = 5 } |]++useNoSigNonEmpty :: ()+useNoSigNonEmpty = noSigNonEmpty [lr| MkT2 { x = 5 } |]++{-------------------------------------------------------------------------------+  Tests proper+-------------------------------------------------------------------------------}++testProjections :: Assertion+testProjections = do+    assertEqual "one"    (projectOne    t)  5+    assertEqual "two"    (projectTwo    t) (5, [True])+    assertEqual "three"  (projectThree  t) (5, [True], 1.0)+    assertEqual "puns"   (projectPuns   t) (5, [True])+    assertEqual "nested" (projectNested s) ('a', 2, [True, False])+    assertEqual "view"   (projectView   t)  6+    assertEqual "empty"  (matchEmpty    t)  42++    expectException isExpectedTypeError $+      assertEqual "sig-empty"    useNoSigEmpty    ()+    expectException isExpectedTypeError $+      assertEqual "sig-nonempty" useNoSigNonEmpty ()+  where+    isExpectedTypeError :: SomeException -> Bool+    isExpectedTypeError e = "Couldn't match expected type" `isInfixOf` show e++    t :: T Bool+    t = [lr| MkT { x = 5, y = [True], z = 1.0 } |]++    s :: S Bool+    s = [lr| MkS { x = 'a', y = MkT { x = 2, y = [True, False], z = 1.0 } } |]++tests :: TestTree+tests = testGroup "Test.Record.Sanity.Projection" [+      testCase "projections" testProjections+    ]
+ test/Test/Record/Sanity/QualifiedImports.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE ViewPatterns          #-}+{-# LANGUAGE ScopedTypeVariables   #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}+-- {-# OPTIONS_GHC -ddump-splices #-}++module Test.Record.Sanity.QualifiedImports (tests) where++import Data.Record.TH++import Test.Tasty+import Test.Tasty.HUnit++import qualified Test.Record.Sanity.QualifiedImports.A as A+import qualified Test.Record.Sanity.QualifiedImports.B as B++constructA :: A.T Bool+constructA = [lr| A.MkT { x = 5, y = [True] } |]++constructB :: B.T Bool+constructB = [lr| B.MkT { x = 'a', y = A.MkT { x = 2, y = [True, False] } } |]++projectA :: A.T a -> (Int, [a])+projectA [lr| A.MkT { x = a, y = b } |] = (a, b)++projectB :: B.T a -> (Char, Int, [a])+projectB [lr| B.MkT { x = a, y = A.MkT { x = b, y = c } } |] = (a, b, c)++tests :: TestTree+tests = testGroup "Test.Record.Sanity.QualifiedImports" [+      testCase "qualifiedImports" testQualifiedImports+    ]++testQualifiedImports :: Assertion+testQualifiedImports = do+    assertEqual "constructA" a.x          5+    assertEqual "projectA"   (projectA a) (5, [True])+    assertEqual "constructB" b.x          'a'+    assertEqual "projectB"   (projectB b) ('a', 2, [True, False])+  where+    a :: A.T Bool+    a = constructA++    b :: B.T Bool+    b = constructB
+ test/Test/Record/Sanity/QualifiedImports/A.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++module Test.Record.Sanity.QualifiedImports.A where++import Data.Record.TH++largeRecord defaultPureScript [d|+    data T a = MkT { x :: Int, y :: [a] }+  |]
+ test/Test/Record/Sanity/QualifiedImports/B.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++module Test.Record.Sanity.QualifiedImports.B where++import Data.Record.TH++import qualified Test.Record.Sanity.QualifiedImports.A as A++largeRecord defaultPureScript [d|+    data T a = MkT { x :: Char, y :: A.T a }+  |]
+ test/Test/Record/Sanity/RecordConstruction.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}+-- {-# OPTIONS_GHC -ddump-splices #-}+{-# OPTIONS_GHC -Wwarn #-}++module Test.Record.Sanity.RecordConstruction (tests) where++import Data.Record.TH++import Test.Tasty+import Test.Tasty.HUnit++-- Test that this works if we don't generate field accessors+-- See <https://gitlab.haskell.org/ghc/ghc/-/issues/19312>+--+-- Use lazy fields so that we can test values with missing fields.+--+-- Test both the case where the name of the type and the name of the constructor+-- are the same and where they are different.+largeRecord (defaultPureScript {allFieldsStrict = False}) [d|+    data R a = MkR { x :: Int, y :: [a] } deriving (Eq, Show)+    data S a = S   { x :: Int, y :: [a] } deriving (Eq, Show)+  |]++inOrder :: R Bool+inOrder = [lr| MkR { x = 1234, y = [True] } |]++outOfOrder :: R Bool+outOfOrder = [lr| MkR { y = [True], x = 1234 } |]++-- | Constructor application+--+-- Occassionally we cannot use the quasi-quoter (for instance, in an+-- applicative context).+constructorApp :: R Bool+constructorApp = [lr| MkR |] 1234 [True]++valueOfS :: S Bool+valueOfS = [lr| S { x = 1234, y = [True] } |]++{-------------------------------------------------------------------------------+  Nested records+-------------------------------------------------------------------------------}++data RegularRecord = RR { a :: Int }+  deriving (Show, Eq)++largeRecord defaultPureScript [d|+    data T = T { x :: Int, y :: S Bool, z :: RegularRecord }+  |]++valueOfT :: T+valueOfT = [lr| T { x = 5+                  , y = S { x = 1234, y = [True] }+                  , z = RR { a = 5 }+                  }+              |]++{-------------------------------------------------------------------------------+  Sanity check+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Sanity.RecordConstruction" [+      testCase "allEqual" testAllEqual+    ]++testAllEqual :: Assertion+testAllEqual = do+    assertEqual "inOrder/outOfOrder" inOrder.x  outOfOrder.x+    assertEqual "inOrder/withoutQQ"  inOrder.x  constructorApp.x+    assertEqual "R/S"                inOrder.x  valueOfS.x+    assertEqual "T/S"                valueOfT.y valueOfS+    assertEqual "T/R"                valueOfT.z (RR 5)
+ test/Test/Record/Sanity/Strictness.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++-- {-# OPTIONS_GHC -ddump-splices -ddump-simpl #-}++module Test.Record.Sanity.Strictness (tests) where++import Control.Exception+import GHC.Records.Compat++import Data.Record.Generic+import Data.Record.Generic.LowerBound+import Data.Record.TH++import qualified Data.Record.Generic.Rep as Rep++import Test.Tasty+import Test.Tasty.HUnit++largeRecord defaultLazyOptions [d|+    data Lazy = MkLazy { lazyField :: Word }+  |]++largeRecord defaultStrictOptions [d|+    data Strict = MkStrict { strictField :: Word }+  |]++_silenceWarnings :: ()+_silenceWarnings = const () $ (+      lazyField+    , strictField+    )++tests :: TestTree+tests = testGroup "Test.Record.Sanity.Strictness" [+      testCase "initValueLazy"   test_initValueLazy+    , testCase "initValueStrict" test_initValueStrict+    , testCase "setValueLazy"    test_setValueLazy+    , testCase "setValueStrict"  test_setValueStrict+    ]++test_initValueLazy :: Assertion+test_initValueLazy =+    initValue `seq` return ()+  where+    initValue :: Lazy+    initValue = to $ Rep.pure undefined++test_initValueStrict :: Assertion+test_initValueStrict =+    expectBoom (initValue `seq` return ())+  where+    initValue :: Strict+    initValue = to $ Rep.pure boom++test_setValueLazy :: Assertion+test_setValueLazy =+    setField @"lazyField" initValue boom `seq` return ()+  where+    initValue :: Lazy+    initValue = glowerBound++test_setValueStrict :: Assertion+test_setValueStrict =+    expectBoom (setField @"strictField" initValue boom `seq` return ())+  where+    initValue :: Strict+    initValue = glowerBound++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++data Boom = Boom+  deriving (Show)++boom :: a+boom = throw Boom++instance Exception Boom++expectBoom :: IO () -> Assertion+expectBoom act = do+    mErr <- try act+    case mErr of+      Left Boom -> return ()+      Right ()  -> assertFailure "Expected boom"
+ test/Test/Record/Sanity/Transform.hs view
@@ -0,0 +1,339 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PatternSynonyms       #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE ViewPatterns          #-}++module Test.Record.Sanity.Transform (tests) where++import Data.Functor.Identity+import Data.Kind+import Data.Proxy+import Data.SOP.BasicFunctors+import GHC.TypeLits++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.TH+import Data.Record.Generic+import Data.Record.Generic.Transform++import qualified Data.Record.Generic.Rep as Rep+import qualified Generics.SOP            as SOP++{-------------------------------------------------------------------------------+  Motivating example using SOP+-------------------------------------------------------------------------------}++class CanInject x y where+  inject :: x -> y++instance CanInject (I x) (Maybe x) where+  inject (I x) = Just x++instance CanInject String String where+  inject = id++_gjust_SOP :: forall x fields fields'.+     ( SOP.Generic (x I)+     , SOP.Generic (x Maybe)+     , SOP.IsProductType (x I)     fields+     , SOP.IsProductType (x Maybe) fields'+     , SOP.AllZip CanInject fields fields'+     )+  => x I -> x Maybe+_gjust_SOP =+    SOP.productTypeTo . aux . SOP.productTypeFrom+  where+    aux :: SOP.NP I fields -> SOP.NP I fields'+    aux = SOP.htrans (Proxy @CanInject) (fmap inject)++{-------------------------------------------------------------------------------+  Simple example+-------------------------------------------------------------------------------}++type instance Interpreted (DefaultInterpretation f) String = String++class InjectInterpreted f g a where+  injectInterpreted ::+       Interpret (DefaultInterpretation f) a+    -> Interpret (DefaultInterpretation g) a++instance InjectInterpreted I Maybe (Uninterpreted a) where+  injectInterpreted = liftInterpreted $ \(I x) -> Just x++instance InjectInterpreted I Maybe String where+  injectInterpreted = liftInterpreted $ id++largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d|+    data A (f :: Type -> Type) = A {+          aI :: f Int+        , aB :: f Bool+        , aS :: String+        }+      deriving (Show, Eq)+  |]++-- | Generic injection, using LR generics+--+-- The type annotations are just to explain the flow, they are not required+-- for type inference.+gjust :: forall x (f :: Type -> Type) (g :: Type -> Type).+     ( Generic (x f)+     , Generic (x g)+     , Generic (x Uninterpreted)+     , Constraints (x Uninterpreted) (InjectInterpreted f g)+     , HasNormalForm (DefaultInterpretation f) (x f) (x Uninterpreted)+     , HasNormalForm (DefaultInterpretation g) (x g) (x Uninterpreted)+     )+  => x f -> x g+gjust =+      (to+         :: Rep I (x g)+         -> x g)+    . (denormalize1 (Proxy @DefaultInterpretation)+         :: Rep (Interpret (DefaultInterpretation g)) (x Uninterpreted)+         -> Rep I (x g))+    . (Rep.cmap (Proxy @(InjectInterpreted f g)) injectInterpreted+         :: Rep (Interpret (DefaultInterpretation f)) (x Uninterpreted)+         -> Rep (Interpret (DefaultInterpretation g)) (x Uninterpreted))+    . (normalize1 (Proxy @DefaultInterpretation)+         :: Rep I (x f)+         -> Rep (Interpret (DefaultInterpretation f)) (x Uninterpreted))+    . (from+         :: x f+         -> Rep I (x f))++justA :: A I -> A Maybe+justA = gjust++{-------------------------------------------------------------------------------+  Example with two variables+-------------------------------------------------------------------------------}++largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d|+    data B (f :: Type -> Type) (g :: Type -> Type) = B {+          bI :: f Int+        , bB :: g Bool+        , bS :: String+        }+      deriving (Show, Eq)+  |]++data Skolem (n :: Nat) x++data DefInt2 (f :: Type -> Type) (g :: Type -> Type)++type instance Interpreted (DefInt2 f g) (Skolem 0 x) = f x+type instance Interpreted (DefInt2 f g) (Skolem 1 x) = g x+type instance Interpreted (DefInt2 f g) String       = String++class SwapInterpreted f g a where+  swapInterpreted ::+       Interpret (DefInt2 f g) a+    -> Interpret (DefInt2 g f) a++instance SwapInterpreted I Identity (Skolem 0 x) where+  swapInterpreted = liftInterpreted $ \(I x) -> Identity x++instance SwapInterpreted I Identity (Skolem 1 y) where+  swapInterpreted = liftInterpreted $ \(Identity x) -> I x++instance SwapInterpreted f g String where+  swapInterpreted = liftInterpreted $ id++gswap :: forall x (f :: Type -> Type) (g :: Type -> Type).+     ( Generic (x f g)+     , Generic (x g f)+     , Generic (x (Skolem 0) (Skolem 1))+     , Constraints (x (Skolem 0) (Skolem 1)) (SwapInterpreted f g)+     , HasNormalForm (DefInt2 f g) (x f g) (x (Skolem 0) (Skolem 1))+     , HasNormalForm (DefInt2 g f) (x g f) (x (Skolem 0) (Skolem 1))+     )+  => x f g -> x g f+gswap =+      to+    . denormalize (Proxy @(DefInt2 g f)) (Proxy @(x (Skolem 0) (Skolem 1)))+    . Rep.cmap (Proxy @(SwapInterpreted f g)) swapInterpreted+    . normalize (Proxy @(DefInt2 f g)) (Proxy @(x (Skolem 0) (Skolem 1)))+    . from++swapB :: B I Identity -> B Identity I+swapB = gswap++{-------------------------------------------------------------------------------+  Mini-beam+-------------------------------------------------------------------------------}++data Nullable (c :: Type -> Type) x++type family Columnar (f :: Type -> Type) x where+  Columnar Identity     x = x+  Columnar (Nullable c) x = Columnar c (Maybe x)+  Columnar f            x = f x++newtype Columnar' f a = Columnar' { getColumnar' :: Columnar f a }++class Beamable table where+  zipBeamFieldsM ::+       Applicative m+    => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))+    -> table f -> table g -> m (table h)++class (Beamable table, Beamable (PrimaryKey table)) => Table table where+  data PrimaryKey table (f :: Type -> Type) :: Type++{-------------------------------------------------------------------------------+  Interpretation function for Beam+-------------------------------------------------------------------------------}++data BeamInterpretation (f :: Type -> Type)++type instance Interpreted (BeamInterpretation f) (table Uninterpreted) = table f+type instance Interpreted (BeamInterpretation f) (Uninterpreted x)     = Columnar f x++class ZipInterpreted a where+  zipInterpreted ::+       Applicative m+    => (forall x. Columnar' f x -> Columnar' g x -> m (Columnar' h x))+    -> Interpret (BeamInterpretation f) a+    -> Interpret (BeamInterpretation g) a+    -> m (Interpret (BeamInterpretation h) a)++instance Beamable table => ZipInterpreted (table Uninterpreted) where+  zipInterpreted f = liftInterpretedA2 $ zipBeamFieldsM f++instance ZipInterpreted (Uninterpreted x) where+  zipInterpreted f = liftInterpretedA2 $ applyColumnar' (Proxy @x) f++applyColumnar' :: forall m f g h x.+     Functor m+  => Proxy x+  -> (Columnar' f x -> Columnar' g x -> m (Columnar' h x))+  -> (Columnar  f x -> Columnar  g x -> m (Columnar  h x))+applyColumnar' _ f fx gx = getColumnar' <$> f (Columnar' fx) (Columnar' gx)++{-------------------------------------------------------------------------------+  Beam test+-------------------------------------------------------------------------------}++largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d|+    data TableA (f :: Type -> Type) = TableA {+          taFieldI :: PrimaryKey TableA f+        , taFieldB :: Columnar f Bool+        , taFieldM :: TableB f+        }+      deriving (Show, Eq)++    data TableB (f :: Type -> Type) = TableB {+          tbFieldC :: Columnar f Char+        }+      deriving (Show, Eq)+  |]++instance Table TableA where+  data PrimaryKey TableA f = PrimA (Columnar f Int)++deriving instance Show (Columnar f Int) => Show (PrimaryKey TableA f)+deriving instance Eq   (Columnar f Int) => Eq   (PrimaryKey TableA f)++instance Beamable (PrimaryKey TableA) where+  -- The GHC.Generics instance would normally be fine for primary keys+  zipBeamFieldsM f (PrimA x) (PrimA y) = PrimA <$>+      applyColumnar' (Proxy @Int) f x y++instance Beamable TableA where+  zipBeamFieldsM = gzipBeam++instance Beamable TableB where+  zipBeamFieldsM = gzipBeam++gzipBeam :: forall m table f g h.+     ( Applicative m+     , Generic (table f)+     , Generic (table g)+     , Generic (table h)+     , Generic (table Uninterpreted)+     , Constraints (table Uninterpreted) ZipInterpreted+     , HasNormalForm (BeamInterpretation f) (table f) (table Uninterpreted)+     , HasNormalForm (BeamInterpretation g) (table g) (table Uninterpreted)+     , HasNormalForm (BeamInterpretation h) (table h) (table Uninterpreted)+     )+  => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))+  -> table f -> table g -> m (table h)+gzipBeam f a b =+    fmap (to . denormalize1 (Proxy @BeamInterpretation)) $+      Rep.czipWithM+        (Proxy @ZipInterpreted)+        (zipInterpreted f)+        (normalize1 (Proxy @BeamInterpretation) (from a))+        (normalize1 (Proxy @BeamInterpretation) (from b))++{-------------------------------------------------------------------------------+  Tests+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Sanity.Transform" [+      testCase "gjust"    test_gjust+    , testCase "gswap"    test_gswap+    , testCase "gzipBeam" test_gzipBeam+    ]++test_gjust :: Assertion+test_gjust =+    assertEqual ""+      (justA $ A { aI = I    5, aB = I    True, aS = "hi" })+      (        A { aI = Just 5, aB = Just True, aS = "hi" })++test_gswap :: Assertion+test_gswap =+    assertEqual ""+      (swapB $ B { bI = I        5, bB = Identity True, bS = "hi" })+      (        B { bI = Identity 5, bB = I        True, bS = "hi" })++data Pair x = Pair x x+  deriving (Show, Eq)++test_gzipBeam :: Assertion+test_gzipBeam =+    assertEqual ""+      (unI (zipBeamFieldsM pairup tableA tableA))+      tableA'+  where+    pairup :: Columnar' I x -> Columnar' I x -> I (Columnar' Pair x)+    pairup (Columnar' (I x)) (Columnar' (I y)) = I (Columnar' $ Pair x y)++    tableA :: TableA I+    tableA = TableA {+          taFieldI = PrimA (I 5)+        , taFieldB = I True+        , taFieldM = tableB+        }++    tableB :: TableB I+    tableB = TableB {+          tbFieldC = I 'x'+        }++    tableA' :: TableA Pair+    tableA' = TableA {+          taFieldI = PrimA (Pair 5 5)+        , taFieldB = Pair True True+        , taFieldM = tableB'+        }++    tableB' :: TableB Pair+    tableB' = TableB {+          tbFieldC = Pair 'x' 'x'+        }
+ test/Test/Record/Size/After/HK010.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++-- {-# OPTIONS_GHC -ddump-splices #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.HK010 where++import Data.Record.TH++import Test.Record.Size.Infra++largeRecord defaultLazyOptions (higherKindedRecordOfSize 10)++-- Complains about+--+-- > No instance for (Data.Functor.Classes.Show1 r)+-- >   arising from a use of ‘show’+--+-- which is what we want: @ghc@ has simplified all 10 constraints on each+-- individual field (generated by 'largeRecord') to a single constraint on @r@.+--+-- TODO: Perhaps we could check this automatically using -fdefer-type-errors.+--+-- checkInferredType :: HKR r -> String+-- checkInferredType (r :: HKR f) = show r
+ test/Test/Record/Size/After/HK020.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.HK020 where++import Data.Record.TH++import Test.Record.Size.Infra++largeRecord defaultLazyOptions (higherKindedRecordOfSize 20)
+ test/Test/Record/Size/After/HK030.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.HK030 where++import Data.Record.TH++import Test.Record.Size.Infra++largeRecord defaultLazyOptions (higherKindedRecordOfSize 30)
+ test/Test/Record/Size/After/HK040.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.HK040 where++import Data.Record.TH++import Test.Record.Size.Infra++largeRecord defaultLazyOptions (higherKindedRecordOfSize 40)
+ test/Test/Record/Size/After/HK050.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.HK050 where++import Data.Record.TH++import Test.Record.Size.Infra++largeRecord defaultLazyOptions (higherKindedRecordOfSize 50)
+ test/Test/Record/Size/After/HK060.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.HK060 where++import Data.Record.TH++import Test.Record.Size.Infra++largeRecord defaultLazyOptions (higherKindedRecordOfSize 60)
+ test/Test/Record/Size/After/HK070.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.HK070 where++import Data.Record.TH++import Test.Record.Size.Infra++largeRecord defaultLazyOptions (higherKindedRecordOfSize 70)
+ test/Test/Record/Size/After/HK080.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.HK080 where++import Data.Record.TH++import Test.Record.Size.Infra++largeRecord defaultLazyOptions (higherKindedRecordOfSize 80)
+ test/Test/Record/Size/After/HK090.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.HK090 where++import Data.Record.TH++import Test.Record.Size.Infra++largeRecord defaultLazyOptions (higherKindedRecordOfSize 90)
+ test/Test/Record/Size/After/HK100.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.HK100 where++import Data.Record.TH++import Test.Record.Size.Infra++largeRecord defaultLazyOptions (higherKindedRecordOfSize 100)
+ test/Test/Record/Size/After/R0010.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0010 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 10)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0020.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0020 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 20)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0030.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0030 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 30)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0040.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0040 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 40)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0050.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0050 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 50)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0060.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0060 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 60)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0070.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0070 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 70)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0080.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0080 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 80)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0090.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0090 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 90)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0100.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0100 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 100)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0200.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0200 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 200)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0300.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0300 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 300)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0400.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0400 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 400)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0500.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0500 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 500)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0600.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0600 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 600)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0700.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0700 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 700)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0800.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0800 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 800)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R0900.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R0900 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 900)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/After/R1000.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.After.R1000 where++import Data.Aeson (ToJSON(..))++import Data.Record.Generic.JSON+import Data.Record.TH++import Test.Record.Size.Infra++#ifdef PROFILE_ALLZIP+import Data.Record.Generic+import Data.Record.Generic.Transform+#endif++largeRecord defaultLazyOptions (recordOfSize 1000)++instance ToJSON R where+  toJSON = gtoJSON++#ifdef PROFILE_ALLZIP+testInterpretTo :: ()+testInterpretTo = aux+  where+    aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => ()+    aux = ()+#endif
+ test/Test/Record/Size/Before/Baseline.hs view
@@ -0,0 +1,2 @@+-- | Empty module, to establish a baseline for memory usage+module Test.Record.Size.Before.Baseline () where
+ test/Test/Record/Size/Before/R010.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.Before.R010 where++import Data.Aeson+import Generics.SOP.JSON+import Generics.SOP.TH++import Test.Record.Size.Infra++-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'.+data R = MkR {+      -- 1 .. 10+      field1  :: T 1+    , field2  :: T 2+    , field3  :: T 3+    , field4  :: T 4+    , field5  :: T 5+    , field6  :: T 6+    , field7  :: T 7+    , field8  :: T 8+    , field9  :: T 9+    , field10 :: T 10+    }++deriving instance Eq   R+deriving instance Show R++deriveGeneric ''R++instance ToJSON R where+  toJSON = gtoJSON defaultJsonOptions
+ test/Test/Record/Size/Before/R020.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.Before.R020 where++import Data.Aeson+import Generics.SOP.JSON+import Generics.SOP.TH++import Test.Record.Size.Infra++-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'.+data R = MkR {+      -- 1 .. 10+      field1  :: T 1+    , field2  :: T 2+    , field3  :: T 3+    , field4  :: T 4+    , field5  :: T 5+    , field6  :: T 6+    , field7  :: T 7+    , field8  :: T 8+    , field9  :: T 9+    , field10 :: T 10+      -- 11 .. 20+    , field11 :: T 11+    , field12 :: T 12+    , field13 :: T 13+    , field14 :: T 14+    , field15 :: T 15+    , field16 :: T 16+    , field17 :: T 17+    , field18 :: T 18+    , field19 :: T 19+    , field20 :: T 20+    }++deriving instance Eq   R+deriving instance Show R++deriveGeneric ''R++instance ToJSON R where+  toJSON = gtoJSON defaultJsonOptions
+ test/Test/Record/Size/Before/R030.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.Before.R030 where++import Data.Aeson+import Generics.SOP.JSON+import Generics.SOP.TH++import Test.Record.Size.Infra++-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'.+data R = MkR {+      -- 1 .. 10+      field1  :: T 1+    , field2  :: T 2+    , field3  :: T 3+    , field4  :: T 4+    , field5  :: T 5+    , field6  :: T 6+    , field7  :: T 7+    , field8  :: T 8+    , field9  :: T 9+    , field10 :: T 10+      -- 11 .. 20+    , field11 :: T 11+    , field12 :: T 12+    , field13 :: T 13+    , field14 :: T 14+    , field15 :: T 15+    , field16 :: T 16+    , field17 :: T 17+    , field18 :: T 18+    , field19 :: T 19+    , field20 :: T 20+      -- 21 .. 30+    , field21 :: T 21+    , field22 :: T 22+    , field23 :: T 23+    , field24 :: T 24+    , field25 :: T 25+    , field26 :: T 26+    , field27 :: T 27+    , field28 :: T 28+    , field29 :: T 29+    , field30 :: T 30+    }++deriving instance Eq   R+deriving instance Show R++deriveGeneric ''R++instance ToJSON R where+  toJSON = gtoJSON defaultJsonOptions
+ test/Test/Record/Size/Before/R040.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.Before.R040 where++import Data.Aeson+import Generics.SOP.JSON+import Generics.SOP.TH++import Test.Record.Size.Infra++-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'.+data R = MkR {+      -- 1 .. 10+      field1  :: T 1+    , field2  :: T 2+    , field3  :: T 3+    , field4  :: T 4+    , field5  :: T 5+    , field6  :: T 6+    , field7  :: T 7+    , field8  :: T 8+    , field9  :: T 9+    , field10 :: T 10+      -- 11 .. 20+    , field11 :: T 11+    , field12 :: T 12+    , field13 :: T 13+    , field14 :: T 14+    , field15 :: T 15+    , field16 :: T 16+    , field17 :: T 17+    , field18 :: T 18+    , field19 :: T 19+    , field20 :: T 20+      -- 21 .. 30+    , field21 :: T 21+    , field22 :: T 22+    , field23 :: T 23+    , field24 :: T 24+    , field25 :: T 25+    , field26 :: T 26+    , field27 :: T 27+    , field28 :: T 28+    , field29 :: T 29+    , field30 :: T 30+      -- 31 .. 40+    , field31 :: T 31+    , field32 :: T 32+    , field33 :: T 33+    , field34 :: T 34+    , field35 :: T 35+    , field36 :: T 36+    , field37 :: T 37+    , field38 :: T 38+    , field39 :: T 39+    , field40 :: T 40+    }++deriving instance Eq   R+deriving instance Show R++deriveGeneric ''R++instance ToJSON R where+  toJSON = gtoJSON defaultJsonOptions
+ test/Test/Record/Size/Before/R050.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.Before.R050 where++import Data.Aeson+import Generics.SOP.JSON+import Generics.SOP.TH++import Test.Record.Size.Infra++-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'.+data R = MkR {+      -- 1 .. 10+      field1  :: T 1+    , field2  :: T 2+    , field3  :: T 3+    , field4  :: T 4+    , field5  :: T 5+    , field6  :: T 6+    , field7  :: T 7+    , field8  :: T 8+    , field9  :: T 9+    , field10 :: T 10+      -- 11 .. 20+    , field11 :: T 11+    , field12 :: T 12+    , field13 :: T 13+    , field14 :: T 14+    , field15 :: T 15+    , field16 :: T 16+    , field17 :: T 17+    , field18 :: T 18+    , field19 :: T 19+    , field20 :: T 20+      -- 21 .. 30+    , field21 :: T 21+    , field22 :: T 22+    , field23 :: T 23+    , field24 :: T 24+    , field25 :: T 25+    , field26 :: T 26+    , field27 :: T 27+    , field28 :: T 28+    , field29 :: T 29+    , field30 :: T 30+      -- 31 .. 40+    , field31 :: T 31+    , field32 :: T 32+    , field33 :: T 33+    , field34 :: T 34+    , field35 :: T 35+    , field36 :: T 36+    , field37 :: T 37+    , field38 :: T 38+    , field39 :: T 39+    , field40 :: T 40+      -- 41 .. 50+    , field41 :: T 41+    , field42 :: T 42+    , field43 :: T 43+    , field44 :: T 44+    , field45 :: T 45+    , field46 :: T 46+    , field47 :: T 47+    , field48 :: T 48+    , field49 :: T 49+    , field50 :: T 50+    }++deriving instance Eq   R+deriving instance Show R++deriveGeneric ''R++instance ToJSON R where+  toJSON = gtoJSON defaultJsonOptions
+ test/Test/Record/Size/Before/R060.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.Before.R060 where++import Data.Aeson+import Generics.SOP.JSON+import Generics.SOP.TH++import Test.Record.Size.Infra++-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'.+data R = MkR {+      -- 1 .. 10+      field1  :: T 1+    , field2  :: T 2+    , field3  :: T 3+    , field4  :: T 4+    , field5  :: T 5+    , field6  :: T 6+    , field7  :: T 7+    , field8  :: T 8+    , field9  :: T 9+    , field10 :: T 10+      -- 11 .. 20+    , field11 :: T 11+    , field12 :: T 12+    , field13 :: T 13+    , field14 :: T 14+    , field15 :: T 15+    , field16 :: T 16+    , field17 :: T 17+    , field18 :: T 18+    , field19 :: T 19+    , field20 :: T 20+      -- 21 .. 30+    , field21 :: T 21+    , field22 :: T 22+    , field23 :: T 23+    , field24 :: T 24+    , field25 :: T 25+    , field26 :: T 26+    , field27 :: T 27+    , field28 :: T 28+    , field29 :: T 29+    , field30 :: T 30+      -- 31 .. 40+    , field31 :: T 31+    , field32 :: T 32+    , field33 :: T 33+    , field34 :: T 34+    , field35 :: T 35+    , field36 :: T 36+    , field37 :: T 37+    , field38 :: T 38+    , field39 :: T 39+    , field40 :: T 40+      -- 41 .. 50+    , field41 :: T 41+    , field42 :: T 42+    , field43 :: T 43+    , field44 :: T 44+    , field45 :: T 45+    , field46 :: T 46+    , field47 :: T 47+    , field48 :: T 48+    , field49 :: T 49+    , field50 :: T 50+      -- 51 .. 60+    , field51 :: T 51+    , field52 :: T 52+    , field53 :: T 53+    , field54 :: T 54+    , field55 :: T 55+    , field56 :: T 56+    , field57 :: T 57+    , field58 :: T 58+    , field59 :: T 59+    , field60 :: T 60+    }++deriving instance Eq   R+deriving instance Show R++deriveGeneric ''R++instance ToJSON R where+  toJSON = gtoJSON defaultJsonOptions
+ test/Test/Record/Size/Before/R070.hs view
@@ -0,0 +1,115 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.Before.R070 where++import Data.Aeson+import Generics.SOP.JSON+import Generics.SOP.TH++import Test.Record.Size.Infra++-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'.+data R = MkR {+      -- 1 .. 10+      field1  :: T 1+    , field2  :: T 2+    , field3  :: T 3+    , field4  :: T 4+    , field5  :: T 5+    , field6  :: T 6+    , field7  :: T 7+    , field8  :: T 8+    , field9  :: T 9+    , field10 :: T 10+      -- 11 .. 20+    , field11 :: T 11+    , field12 :: T 12+    , field13 :: T 13+    , field14 :: T 14+    , field15 :: T 15+    , field16 :: T 16+    , field17 :: T 17+    , field18 :: T 18+    , field19 :: T 19+    , field20 :: T 20+      -- 21 .. 30+    , field21 :: T 21+    , field22 :: T 22+    , field23 :: T 23+    , field24 :: T 24+    , field25 :: T 25+    , field26 :: T 26+    , field27 :: T 27+    , field28 :: T 28+    , field29 :: T 29+    , field30 :: T 30+      -- 31 .. 40+    , field31 :: T 31+    , field32 :: T 32+    , field33 :: T 33+    , field34 :: T 34+    , field35 :: T 35+    , field36 :: T 36+    , field37 :: T 37+    , field38 :: T 38+    , field39 :: T 39+    , field40 :: T 40+      -- 41 .. 50+    , field41 :: T 41+    , field42 :: T 42+    , field43 :: T 43+    , field44 :: T 44+    , field45 :: T 45+    , field46 :: T 46+    , field47 :: T 47+    , field48 :: T 48+    , field49 :: T 49+    , field50 :: T 50+      -- 51 .. 60+    , field51 :: T 51+    , field52 :: T 52+    , field53 :: T 53+    , field54 :: T 54+    , field55 :: T 55+    , field56 :: T 56+    , field57 :: T 57+    , field58 :: T 58+    , field59 :: T 59+    , field60 :: T 60+      -- 61 .. 70+    , field61 :: T 61+    , field62 :: T 62+    , field63 :: T 63+    , field64 :: T 64+    , field65 :: T 65+    , field66 :: T 66+    , field67 :: T 67+    , field68 :: T 68+    , field69 :: T 69+    , field70 :: T 70+    }++deriving instance Eq   R+deriving instance Show R++deriveGeneric ''R++instance ToJSON R where+  toJSON = gtoJSON defaultJsonOptions
+ test/Test/Record/Size/Before/R080.hs view
@@ -0,0 +1,126 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.Before.R080 where++import Data.Aeson+import Generics.SOP.JSON+import Generics.SOP.TH++import Test.Record.Size.Infra++-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'.+data R = MkR {+      -- 1 .. 10+      field1  :: T 1+    , field2  :: T 2+    , field3  :: T 3+    , field4  :: T 4+    , field5  :: T 5+    , field6  :: T 6+    , field7  :: T 7+    , field8  :: T 8+    , field9  :: T 9+    , field10 :: T 10+      -- 11 .. 20+    , field11 :: T 11+    , field12 :: T 12+    , field13 :: T 13+    , field14 :: T 14+    , field15 :: T 15+    , field16 :: T 16+    , field17 :: T 17+    , field18 :: T 18+    , field19 :: T 19+    , field20 :: T 20+      -- 21 .. 30+    , field21 :: T 21+    , field22 :: T 22+    , field23 :: T 23+    , field24 :: T 24+    , field25 :: T 25+    , field26 :: T 26+    , field27 :: T 27+    , field28 :: T 28+    , field29 :: T 29+    , field30 :: T 30+      -- 31 .. 40+    , field31 :: T 31+    , field32 :: T 32+    , field33 :: T 33+    , field34 :: T 34+    , field35 :: T 35+    , field36 :: T 36+    , field37 :: T 37+    , field38 :: T 38+    , field39 :: T 39+    , field40 :: T 40+      -- 41 .. 50+    , field41 :: T 41+    , field42 :: T 42+    , field43 :: T 43+    , field44 :: T 44+    , field45 :: T 45+    , field46 :: T 46+    , field47 :: T 47+    , field48 :: T 48+    , field49 :: T 49+    , field50 :: T 50+      -- 51 .. 60+    , field51 :: T 51+    , field52 :: T 52+    , field53 :: T 53+    , field54 :: T 54+    , field55 :: T 55+    , field56 :: T 56+    , field57 :: T 57+    , field58 :: T 58+    , field59 :: T 59+    , field60 :: T 60+      -- 61 .. 70+    , field61 :: T 61+    , field62 :: T 62+    , field63 :: T 63+    , field64 :: T 64+    , field65 :: T 65+    , field66 :: T 66+    , field67 :: T 67+    , field68 :: T 68+    , field69 :: T 69+    , field70 :: T 70+      -- 71 .. 80+    , field71 :: T 71+    , field72 :: T 72+    , field73 :: T 73+    , field74 :: T 74+    , field75 :: T 75+    , field76 :: T 76+    , field77 :: T 77+    , field78 :: T 78+    , field79 :: T 79+    , field80 :: T 80+    }++deriving instance Eq   R+deriving instance Show R++deriveGeneric ''R++instance ToJSON R where+  toJSON = gtoJSON defaultJsonOptions
+ test/Test/Record/Size/Before/R090.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.Before.R090 where++import Data.Aeson+import Generics.SOP.JSON+import Generics.SOP.TH++import Test.Record.Size.Infra++-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'.+data R = MkR {+      -- 1 .. 10+      field1  :: T 1+    , field2  :: T 2+    , field3  :: T 3+    , field4  :: T 4+    , field5  :: T 5+    , field6  :: T 6+    , field7  :: T 7+    , field8  :: T 8+    , field9  :: T 9+    , field10 :: T 10+      -- 11 .. 20+    , field11 :: T 11+    , field12 :: T 12+    , field13 :: T 13+    , field14 :: T 14+    , field15 :: T 15+    , field16 :: T 16+    , field17 :: T 17+    , field18 :: T 18+    , field19 :: T 19+    , field20 :: T 20+      -- 21 .. 30+    , field21 :: T 21+    , field22 :: T 22+    , field23 :: T 23+    , field24 :: T 24+    , field25 :: T 25+    , field26 :: T 26+    , field27 :: T 27+    , field28 :: T 28+    , field29 :: T 29+    , field30 :: T 30+      -- 31 .. 40+    , field31 :: T 31+    , field32 :: T 32+    , field33 :: T 33+    , field34 :: T 34+    , field35 :: T 35+    , field36 :: T 36+    , field37 :: T 37+    , field38 :: T 38+    , field39 :: T 39+    , field40 :: T 40+      -- 41 .. 50+    , field41 :: T 41+    , field42 :: T 42+    , field43 :: T 43+    , field44 :: T 44+    , field45 :: T 45+    , field46 :: T 46+    , field47 :: T 47+    , field48 :: T 48+    , field49 :: T 49+    , field50 :: T 50+      -- 51 .. 60+    , field51 :: T 51+    , field52 :: T 52+    , field53 :: T 53+    , field54 :: T 54+    , field55 :: T 55+    , field56 :: T 56+    , field57 :: T 57+    , field58 :: T 58+    , field59 :: T 59+    , field60 :: T 60+      -- 61 .. 70+    , field61 :: T 61+    , field62 :: T 62+    , field63 :: T 63+    , field64 :: T 64+    , field65 :: T 65+    , field66 :: T 66+    , field67 :: T 67+    , field68 :: T 68+    , field69 :: T 69+    , field70 :: T 70+      -- 71 .. 80+    , field71 :: T 71+    , field72 :: T 72+    , field73 :: T 73+    , field74 :: T 74+    , field75 :: T 75+    , field76 :: T 76+    , field77 :: T 77+    , field78 :: T 78+    , field79 :: T 79+    , field80 :: T 80+      -- 81 .. 90+    , field81 :: T 81+    , field82 :: T 82+    , field83 :: T 83+    , field84 :: T 84+    , field85 :: T 85+    , field86 :: T 86+    , field87 :: T 87+    , field88 :: T 88+    , field89 :: T 89+    , field90 :: T 90+    }++deriving instance Eq   R+deriving instance Show R++deriveGeneric ''R++instance ToJSON R where+  toJSON = gtoJSON defaultJsonOptions
+ test/Test/Record/Size/Before/R100.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE StandaloneDeriving    #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-}++#if USE_GHC_DUMP+{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-}+#endif++module Test.Record.Size.Before.R100 where++import Data.Aeson+import Generics.SOP.JSON+import Generics.SOP.TH++import Test.Record.Size.Infra++-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'.+data R = MkR {+      -- 1 .. 10+      field1  :: T 1+    , field2  :: T 2+    , field3  :: T 3+    , field4  :: T 4+    , field5  :: T 5+    , field6  :: T 6+    , field7  :: T 7+    , field8  :: T 8+    , field9  :: T 9+    , field10 :: T 10+      -- 11 .. 20+    , field11 :: T 11+    , field12 :: T 12+    , field13 :: T 13+    , field14 :: T 14+    , field15 :: T 15+    , field16 :: T 16+    , field17 :: T 17+    , field18 :: T 18+    , field19 :: T 19+    , field20 :: T 20+      -- 21 .. 30+    , field21 :: T 21+    , field22 :: T 22+    , field23 :: T 23+    , field24 :: T 24+    , field25 :: T 25+    , field26 :: T 26+    , field27 :: T 27+    , field28 :: T 28+    , field29 :: T 29+    , field30 :: T 30+      -- 31 .. 40+    , field31 :: T 31+    , field32 :: T 32+    , field33 :: T 33+    , field34 :: T 34+    , field35 :: T 35+    , field36 :: T 36+    , field37 :: T 37+    , field38 :: T 38+    , field39 :: T 39+    , field40 :: T 40+      -- 41 .. 50+    , field41 :: T 41+    , field42 :: T 42+    , field43 :: T 43+    , field44 :: T 44+    , field45 :: T 45+    , field46 :: T 46+    , field47 :: T 47+    , field48 :: T 48+    , field49 :: T 49+    , field50 :: T 50+      -- 51 .. 60+    , field51 :: T 51+    , field52 :: T 52+    , field53 :: T 53+    , field54 :: T 54+    , field55 :: T 55+    , field56 :: T 56+    , field57 :: T 57+    , field58 :: T 58+    , field59 :: T 59+    , field60 :: T 60+      -- 61 .. 70+    , field61 :: T 61+    , field62 :: T 62+    , field63 :: T 63+    , field64 :: T 64+    , field65 :: T 65+    , field66 :: T 66+    , field67 :: T 67+    , field68 :: T 68+    , field69 :: T 69+    , field70 :: T 70+      -- 71 .. 80+    , field71 :: T 71+    , field72 :: T 72+    , field73 :: T 73+    , field74 :: T 74+    , field75 :: T 75+    , field76 :: T 76+    , field77 :: T 77+    , field78 :: T 78+    , field79 :: T 79+    , field80 :: T 80+      -- 81 .. 90+    , field81 :: T 81+    , field82 :: T 82+    , field83 :: T 83+    , field84 :: T 84+    , field85 :: T 85+    , field86 :: T 86+    , field87 :: T 87+    , field88 :: T 88+    , field89 :: T 89+    , field90 :: T 90+      -- 91 .. 100+    , field91  :: T 91+    , field92  :: T 92+    , field93  :: T 93+    , field94  :: T 94+    , field95  :: T 95+    , field96  :: T 96+    , field97  :: T 97+    , field98  :: T 98+    , field99  :: T 99+    , field100 :: T 100+    }++deriving instance Eq   R+deriving instance Show R++deriveGeneric ''R++instance ToJSON R where+  toJSON = gtoJSON defaultJsonOptions
+ test/Test/Record/Size/Infra.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE UndecidableInstances       #-}++module Test.Record.Size.Infra (+    recordOfSize+  , higherKindedRecordOfSize+    -- * Supporting infrastructure used by generated code+  , T(..)+    -- * Re-exports+  , I+  ) where++import Data.Aeson+import Data.Functor.Classes+import Data.Functor.Identity+import Data.Kind+import Data.Proxy+import Data.SOP.BasicFunctors+import GHC.TypeLits++import Language.Haskell.TH hiding (Type)+import Language.Haskell.TH.Syntax hiding (Type)++import Data.Record.Generic.LowerBound+import Data.Record.Generic.Transform++{-------------------------------------------------------------------------------+  Construct records of specified size+-------------------------------------------------------------------------------}++-- | Generate something like+--+-- > data R = MkR {+-- >       field1  :: T 1+-- >     , field2  :: T 2+-- >     , field3  :: T 3+-- >     , field4  :: T 4+-- >     , field5  :: T 5+-- >     }+--+-- In order to be compatible with the records originating from @[d| ... |]@,+-- we use 'newName' here rather than 'mkName'.+recordOfSize :: Integer -> Q [Dec]+recordOfSize n = fmap (:[]) $ do+    r   <- newName "R"+    mkR <- newName "MkR"+    dataD+      (cxt [])+      r+      []+      Nothing+      [recC mkR fields]+      []+  where+    fields :: [Q VarBangType]+    fields = [+          do fieldI <- newName $ "field" ++ show i+             varBangType+               fieldI+               (bangType defaultBang (conT ''T `appT` litT (numTyLit i)))+        | i <- [1 .. n]+        ]++-- | Like 'recordOfSize', but generate a record with a higher-kinded type var.+--+-- Generates something like:+--+-- > data HKR (f :: Type -> Type) = MkHKR {+-- >       field1  :: HK 1 f+-- >     , field2  :: HK 2 f+-- >     , field3  :: HK 3 f+-- >     , field4  :: HK 4 f+-- >     , field5  :: HK 5 f+-- >     }+-- >   deriving Show+--+-- See comments in 'recordOfSize' for the use of 'newName'.+higherKindedRecordOfSize :: Integer -> Q [Dec]+higherKindedRecordOfSize n = fmap (:[]) $ do+    f     <- newName "f"+    k     <- [t| Type -> Type |]+    hkr   <- newName "HKR"+    mkHKR <- newName "MkHKR"+    dataD+      (cxt [])+      hkr+      [KindedTV f k]+      Nothing+      [recC mkHKR (fields f)]+      [derivClause Nothing [conT ''Show]]+  where+    fields :: Name -> [Q VarBangType]+    fields f = [+          do fieldI <- newName $ "field" ++ show i+             varBangType+               fieldI+               (bangType defaultBang (conT ''HK `appT` litT (numTyLit i) `appT` varT f))+        | i <- [1 .. n]+        ]++defaultBang :: BangQ+defaultBang = bang noSourceUnpackedness noSourceStrictness++{-------------------------------------------------------------------------------+  Definitions referred to by the generated TH code+-------------------------------------------------------------------------------}++-- | 'T' gives us as many different types as we need+newtype T (i :: Nat) = MkT Word+  deriving (Show, Eq, ToJSON)++type instance Interpreted I (T i) = T i++-- | Like 'T', but with a higher-kinded type variable+newtype HK (i :: Nat) (f :: Type -> Type) = MkHK (f Word)++instance KnownNat i => LowerBound (T i) where+  lowerBound = MkT $ fromInteger $ natVal (Proxy @i)++instance KnownNat i => LowerBound (HK i Identity) where+  lowerBound = MkHK $ fromInteger $ natVal (Proxy @i)++instance Show1 f => Show (HK i f) where+  showsPrec d (MkHK x) = showsPrec1 d x
+ test/Test/Record/Size/Sanity.hs view
@@ -0,0 +1,208 @@+{-# LANGUAGE CPP #-}++{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-}++-- | Sanity checks that we generate correct code for in the @Sized.*@ modules+--+-- The real test of the @Size.*@ moduels of course is not this module, but+-- rather their compiled size.+module Test.Record.Size.Sanity (tests) where++import Data.Aeson+import Data.Functor.Identity++import qualified Data.Record.Generic.SOP        as SOP+import qualified Data.Record.Generic.LowerBound as LR++import qualified Test.Record.Size.Before.R010 as Before010+import qualified Test.Record.Size.After.R0010 as After0010+import qualified Test.Record.Size.After.HK010 as AfterHK10++#if USE_GHC_DUMP+import Test.Record.Size.Infra (T(..))++import qualified Test.Record.Size.Before.R020 as Before020+import qualified Test.Record.Size.Before.R030 as Before030+import qualified Test.Record.Size.Before.R040 as Before040+import qualified Test.Record.Size.Before.R050 as Before050+import qualified Test.Record.Size.Before.R060 as Before060+import qualified Test.Record.Size.Before.R070 as Before070+import qualified Test.Record.Size.Before.R080 as Before080+import qualified Test.Record.Size.Before.R090 as Before090+import qualified Test.Record.Size.Before.R100 as Before100+import qualified Test.Record.Size.After.R0020 as After0020+import qualified Test.Record.Size.After.R0030 as After0030+import qualified Test.Record.Size.After.R0040 as After0040+import qualified Test.Record.Size.After.R0050 as After0050+import qualified Test.Record.Size.After.R0060 as After0060+import qualified Test.Record.Size.After.R0070 as After0070+import qualified Test.Record.Size.After.R0080 as After0080+import qualified Test.Record.Size.After.R0090 as After0090+import qualified Test.Record.Size.After.R0100 as After0100+import qualified Test.Record.Size.After.R0200 as After0200+import qualified Test.Record.Size.After.R0300 as After0300+import qualified Test.Record.Size.After.R0400 as After0400+import qualified Test.Record.Size.After.R0500 as After0500+import qualified Test.Record.Size.After.R0600 as After0600+import qualified Test.Record.Size.After.R0700 as After0700+import qualified Test.Record.Size.After.R0800 as After0800+import qualified Test.Record.Size.After.R0900 as After0900+import qualified Test.Record.Size.After.R1000 as After1000+import qualified Test.Record.Size.After.HK020 as AfterHK20+import qualified Test.Record.Size.After.HK030 as AfterHK30+import qualified Test.Record.Size.After.HK040 as AfterHK40+import qualified Test.Record.Size.After.HK050 as AfterHK50+import qualified Test.Record.Size.After.HK060 as AfterHK60+import qualified Test.Record.Size.After.HK070 as AfterHK70+import qualified Test.Record.Size.After.HK080 as AfterHK80+import qualified Test.Record.Size.After.HK090 as AfterHK90+import qualified Test.Record.Size.After.HK100 as AfterH100+#endif++import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests = testGroup "Test.Record.Size.Sanity" [+      testCase "sameValue" test_sameValue+    , testCase "sameField" test_sameField+    , testCase "showHK"    test_showHK+#if USE_GHC_DUMP+    , testCase "reallyBig" test_reallyBig+#endif+    ]++-- | Test that @generics-sop@ and @large-records@ generates the same structure+test_sameValue :: Assertion+test_sameValue = do+    assertEqual "10"+      (toJSON (SOP.glowerBound :: Before010.R))+      (toJSON ( LR.glowerBound :: After0010.R))+#if USE_GHC_DUMP+    assertEqual "20"+      (toJSON (SOP.glowerBound :: Before020.R))+      (toJSON ( LR.glowerBound :: After0020.R))+    assertEqual "30"+      (toJSON (SOP.glowerBound :: Before030.R))+      (toJSON ( LR.glowerBound :: After0030.R))+    assertEqual "40"+      (toJSON (SOP.glowerBound :: Before040.R))+      (toJSON ( LR.glowerBound :: After0040.R))+    assertEqual "50"+      (toJSON (SOP.glowerBound :: Before050.R))+      (toJSON ( LR.glowerBound :: After0050.R))+    assertEqual "60"+      (toJSON (SOP.glowerBound :: Before060.R))+      (toJSON ( LR.glowerBound :: After0060.R))+    assertEqual "70"+      (toJSON (SOP.glowerBound :: Before070.R))+      (toJSON ( LR.glowerBound :: After0070.R))+    assertEqual "80"+      (toJSON (SOP.glowerBound :: Before080.R))+      (toJSON ( LR.glowerBound :: After0080.R))+    assertEqual "90"+      (toJSON (SOP.glowerBound :: Before090.R))+      (toJSON ( LR.glowerBound :: After0090.R))+    assertEqual "100"+      (toJSON (SOP.glowerBound :: Before100.R))+      (toJSON ( LR.glowerBound :: After0100.R))+#endif++-- | Test that we have the necessary @HasField@ instances+test_sameField :: Assertion+test_sameField = do+    assertEqual "HasField" sop010.field1  lr010.field1+#if USE_GHC_DUMP+    assertEqual "HasField" sop020.field11 lr020.field11+    assertEqual "HasField" sop030.field21 lr030.field21+    assertEqual "HasField" sop040.field31 lr040.field31+    assertEqual "HasField" sop050.field41 lr050.field41+    assertEqual "HasField" sop060.field51 lr060.field51+    assertEqual "HasField" sop070.field61 lr070.field61+    assertEqual "HasField" sop080.field71 lr080.field71+    assertEqual "HasField" sop090.field81 lr090.field81+    assertEqual "HasField" sop100.field91 lr100.field91+#endif+  where+    sop010 = SOP.glowerBound :: Before010.R+    lr010  =  LR.glowerBound :: After0010.R++#if USE_GHC_DUMP+    sop020 = SOP.glowerBound :: Before020.R+    sop030 = SOP.glowerBound :: Before030.R+    sop040 = SOP.glowerBound :: Before040.R+    sop050 = SOP.glowerBound :: Before050.R+    sop060 = SOP.glowerBound :: Before060.R+    sop070 = SOP.glowerBound :: Before070.R+    sop080 = SOP.glowerBound :: Before080.R+    sop090 = SOP.glowerBound :: Before090.R+    sop100 = SOP.glowerBound :: Before100.R++    lr020 = LR.glowerBound :: After0020.R+    lr030 = LR.glowerBound :: After0030.R+    lr040 = LR.glowerBound :: After0040.R+    lr050 = LR.glowerBound :: After0050.R+    lr060 = LR.glowerBound :: After0060.R+    lr070 = LR.glowerBound :: After0070.R+    lr080 = LR.glowerBound :: After0080.R+    lr090 = LR.glowerBound :: After0090.R+    lr100 = LR.glowerBound :: After0100.R+#endif++-- | Check that we can 'Show' the higher-kinded records+test_showHK :: Assertion+test_showHK = do+    assertBool "some output" (not . null $ show lr010)++#if USE_GHC_DUMP+    assertBool "some output" (not . null $ show lr020)+    assertBool "some output" (not . null $ show lr030)+    assertBool "some output" (not . null $ show lr040)+    assertBool "some output" (not . null $ show lr050)+    assertBool "some output" (not . null $ show lr060)+    assertBool "some output" (not . null $ show lr070)+    assertBool "some output" (not . null $ show lr080)+    assertBool "some output" (not . null $ show lr090)+    assertBool "some output" (not . null $ show lr100)+#endif+  where+    lr010 = LR.glowerBound :: AfterHK10.HKR Identity++#if USE_GHC_DUMP+    lr020 = LR.glowerBound :: AfterHK20.HKR Identity+    lr030 = LR.glowerBound :: AfterHK30.HKR Identity+    lr040 = LR.glowerBound :: AfterHK40.HKR Identity+    lr050 = LR.glowerBound :: AfterHK50.HKR Identity+    lr060 = LR.glowerBound :: AfterHK60.HKR Identity+    lr070 = LR.glowerBound :: AfterHK70.HKR Identity+    lr080 = LR.glowerBound :: AfterHK80.HKR Identity+    lr090 = LR.glowerBound :: AfterHK90.HKR Identity+    lr100 = LR.glowerBound :: AfterH100.HKR Identity+#endif++#if USE_GHC_DUMP+-- | Check the value of the last field in the truly big records+test_reallyBig :: Assertion+test_reallyBig = do+    assertEqual "HasField" lr0100.field100  (MkT  100)+    assertEqual "HasField" lr0200.field200  (MkT  200)+    assertEqual "HasField" lr0300.field300  (MkT  300)+    assertEqual "HasField" lr0400.field400  (MkT  400)+    assertEqual "HasField" lr0500.field500  (MkT  500)+    assertEqual "HasField" lr0600.field600  (MkT  600)+    assertEqual "HasField" lr0700.field700  (MkT  700)+    assertEqual "HasField" lr0800.field800  (MkT  800)+    assertEqual "HasField" lr0900.field900  (MkT  900)+    assertEqual "HasField" lr1000.field1000 (MkT 1000)+  where+    lr0100 = LR.glowerBound :: After0100.R+    lr0200 = LR.glowerBound :: After0200.R+    lr0300 = LR.glowerBound :: After0300.R+    lr0400 = LR.glowerBound :: After0400.R+    lr0500 = LR.glowerBound :: After0500.R+    lr0600 = LR.glowerBound :: After0600.R+    lr0700 = LR.glowerBound :: After0700.R+    lr0800 = LR.glowerBound :: After0800.R+    lr0900 = LR.glowerBound :: After0900.R+    lr1000 = LR.glowerBound :: After1000.R+#endif
+ test/Test/Record/Util.hs view
@@ -0,0 +1,244 @@+{-# LANGUAGE DeriveLift                 #-}+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs               #-}+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE CPP                        #-}++module Test.Record.Util (+    -- * Tasty/HUnit auxiliary+    assertPrefix+  , assertJust+  , expectException+    -- * TH error collection+  , Problem(..)+  , CollectProblems -- opaque+  , collectProblems+  , collectOnlyProblems+  ) where++import Control.Exception+import Control.Monad.Except hiding (lift)+import Control.Monad.State hiding (lift)+import Data.Bifunctor+import Data.List (isPrefixOf)+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Test.Tasty.HUnit++import qualified Control.Monad.Trans.Class as Trans++{-------------------------------------------------------------------------------+  Tasty/HUnit auxiliary+-------------------------------------------------------------------------------}++assertPrefix :: (Show a, Eq a) => [a] -> [a] -> Assertion+assertPrefix xs ys =+   assertBool (show xs ++ " is not a prefix of " ++ show ys) $+      xs `isPrefixOf` ys++assertJust :: String -> Maybe a -> (a -> Assertion) -> Assertion+assertJust msg Nothing  _ = assertFailure msg+assertJust _   (Just a) k = k a++-- | Only used internally in 'expectException'+data Result =+    NoException+  | ExpectedException+  | UnexpectedException SomeException++expectException :: (SomeException -> Bool) -> Assertion -> Assertion+expectException p k = do+    result <- handle (return . aux) (k >> return NoException)+    case result of+      ExpectedException ->+        return ()+      NoException ->+        assertFailure $ "Expected exception, but none was raised"+      UnexpectedException e ->+        assertFailure $ "Raised exception does not match predicate: " ++ show e+  where+    aux :: SomeException -> Result+    aux e | p e       = ExpectedException+          | otherwise = UnexpectedException e++{-------------------------------------------------------------------------------+  TH error collection++  We use explicit error collection so that we can /test/ that we are+  generating the appropriate errors and warnings.+-------------------------------------------------------------------------------}++data Problem = Error String | Warning String+  deriving (Show, Eq, Lift)++problemIsError :: Problem -> Bool+problemIsError (Error   _) = True+problemIsError (Warning _) = False++-- | 'Quasi' monad which allows us to inspect errors and warnings+--+-- We use this to /test/ that our TH code is reporting the expected errors+-- and warnings.+newtype CollectProblems a = CollectProblems {+      -- Implementation notes:+      --+      -- o 'ExceptT' for 'MonadFail', 'StateT' for 'qReport'+      -- o 'ExceptT' on the outside, so that /if/ there is a failure (as in+      --   'fail'), we still get the errors/warnings that were reported+      --   before the failure.+      -- o Problems are stored in reverse order+      -- o Errors and warnings are stored together, rather than as two lists,+      --   so that we preserve their relative ordering.+      unwrapCollectProblems :: ExceptT String (StateT [Problem] Q) a+    }+  deriving newtype (Functor, Applicative, Monad, MonadIO)++liftQ :: Q a -> CollectProblems a+liftQ = CollectProblems . Trans.lift . Trans.lift++instance MonadFail CollectProblems where+  fail str = CollectProblems $ throwError str++-- | Run 'CollectProblems'+collectProblems :: CollectProblems a -> Q (Either String a, [Problem])+collectProblems = fmap (second reverse) . runCollectProblems++-- | Like 'collectProblems', but return /only/ the problems+collectOnlyProblems :: CollectProblems a -> Q (Maybe String, [Problem])+collectOnlyProblems = fmap (first aux) . collectProblems+  where+    aux :: Either String a -> Maybe String+    aux = either Just (const Nothing)++-- | Lower-level version of 'runCollectProblems' that reports errors in reverse+-- order+runCollectProblems :: CollectProblems a -> Q (Either String a, [Problem])+runCollectProblems = (`runStateT` []) . runExceptT  . unwrapCollectProblems++instance Quasi CollectProblems where+  -- Only error-reporting is different++  qReport :: Bool -> String -> CollectProblems ()+  qReport False w = CollectProblems $ modify (Warning w:)+  qReport True  e = CollectProblems $ modify (Error   e:)++  qRecover :: CollectProblems a -> CollectProblems a -> CollectProblems a+  qRecover handler action =+      CollectProblems $ ExceptT $ StateT $ \problemsBeforeRecovery -> do+        -- We run the action with an empty list of problems; this is okay,+        -- because there is no way to /inspect/ the current list of problems,+        -- we only catch problems thrown inside the action+        (mResult, problemsDuringAction) <- runCollectProblems action+        case mResult of+          Right a | not (any problemIsError problemsDuringAction) ->+            return (Right a, problemsDuringAction ++ problemsBeforeRecovery)+          _otherwise -> do+            -- If there was a failure, _or_ an error (but not a warning), the+            -- handler runs. In this case, any errors /or/ warnings that were+            -- reported during the action are ignored.+            second (++ problemsBeforeRecovery) <$> runCollectProblems handler++  -- Everything else just lifts++  qNewName            = \x   -> liftQ $ qNewName            x+  qLookupName         = \x y -> liftQ $ qLookupName         x y+  qReify              = \x   -> liftQ $ qReify              x+  qReifyFixity        = \x   -> liftQ $ qReifyFixity        x+#if MIN_VERSION_template_haskell(2,16,0)+  qReifyType          = \x   -> liftQ $ qReifyType          x+#endif+  qReifyInstances     = \x y -> liftQ $ qReifyInstances     x y+  qReifyRoles         = \x   -> liftQ $ qReifyRoles         x+  qReifyAnnotations   = \x   -> liftQ $ qReifyAnnotations   x+  qReifyModule        = \x   -> liftQ $ qReifyModule        x+  qReifyConStrictness = \x   -> liftQ $ qReifyConStrictness x+  qLocation           =         liftQ $ qLocation+  qAddDependentFile   = \x   -> liftQ $ qAddDependentFile   x+  qAddTempFile        = \x   -> liftQ $ qAddTempFile        x+  qAddTopDecls        = \x   -> liftQ $ qAddTopDecls        x+  qAddForeignFilePath = \x y -> liftQ $ qAddForeignFilePath x y+  qAddModFinalizer    = \x   -> liftQ $ qAddModFinalizer    x+  qAddCorePlugin      = \x   -> liftQ $ qAddCorePlugin      x+  qGetQ               =         liftQ $ qGetQ+  qPutQ               = \x   -> liftQ $ qPutQ               x+  qIsExtEnabled       = \x   -> liftQ $ qIsExtEnabled       x+  qExtsEnabled        =         liftQ $ qExtsEnabled++{-------------------------------------------------------------------------------+  Internal auxiliary: figure out how TH does error handling+-------------------------------------------------------------------------------}++-- | TH error behaviour+--+-- TH error behaviour is a bit of a mess. When the code below is executed, it+-- yields:+--+-- > n == 1+-- > a+-- > n == 2+-- > handler_2+-- > n == 3+-- > handler_3+-- > n == 4+-- > handler_4+-- > n == 4+--+-- Some observations:+--+-- 1. The documentation of `recover` says that it allows recovery from errors+--    raised by `reportError` or `fail`. The above supports this, /but/ notice+--    that if code raises errors that are caught, any warnings thrown by that+--    code /also/ disappear.+-- 2. The documentation of `qRecover` only talks about recovery from `fail`,+--    not `reportError`, but `recover` is just a wrapper around `qRecover`.+-- 3. Unlike `fail`, `reportError` does not halt execution. This means that+--    even though we can attempt to recover from errors raised by `reportError`,+--    we actually have no idea what the state looks like when recovery begins.+-- 4. Despite `IO` having a `Quasi` instance, `recover` actually does not work+--    /at all/ in `IO` (in fact, /most/ functions of the 'Quasi' class are not+--    supported in IO).+-- 5. Who knew that TH had dynamically typed global variables?+_thErrorBehaviour :: Q [Dec]+_thErrorBehaviour = do+    qPutQ (1 :: Int)+    showN++    -- What happens if we /only/ throw a warning?+    recover (reportWarning "handler_1" >> return ()) $ do+      reportWarning "a"+      qPutQ (2 :: Int)++    showN++    -- What happens if we throw warnings /around/ an error?+    recover (reportWarning "handler_2" >> return ()) $ do+      reportWarning "b"+      reportError   "c"+      reportWarning "d"+      qPutQ (3 :: Int)++    showN++    -- What happens if we throw /multiple/ errors?+    recover (reportWarning "handler_3" >> return ()) $ do+      reportError "e"+      reportError "f"+      qPutQ (4 :: Int)++    showN++    -- What happens if we /fail/ after a warning?+    recover (reportWarning "handler_4" >> return ()) $ do+      reportWarning "g"+      () <- fail "h"+      qPutQ (5 :: Int)++    showN+    return []+  where+    showN :: Q ()+    showN = do+        Just n <- qGetQ+        reportWarning $ "n == " ++ show (n :: Int)+
+ test/TestLargeRecords.hs view
@@ -0,0 +1,53 @@+module Main (main) where++import Test.Tasty++import qualified Test.Record.Prop.Show+import qualified Test.Record.Prop.ToFromJSON+import qualified Test.Record.Sanity.Derive+import qualified Test.Record.Sanity.EqualFieldTypes+import qualified Test.Record.Sanity.ErrorsAndWarnings+import qualified Test.Record.Sanity.Generics+import qualified Test.Record.Sanity.GhcGenerics+import qualified Test.Record.Sanity.HigherKinded+import qualified Test.Record.Sanity.HKD+import qualified Test.Record.Sanity.Laziness+import qualified Test.Record.Sanity.Lens.Micro+import qualified Test.Record.Sanity.OverloadingNoDRF+import qualified Test.Record.Sanity.PatternMatch+import qualified Test.Record.Sanity.QualifiedImports+import qualified Test.Record.Sanity.RecordConstruction+import qualified Test.Record.Sanity.Strictness+import qualified Test.Record.Sanity.Transform+import qualified Test.Record.Size.Sanity++main :: IO ()+main = defaultMain tests++tests :: TestTree+tests = testGroup "Tests" [+      testGroup "Sanity" [+          Test.Record.Sanity.Derive.tests+        , Test.Record.Sanity.EqualFieldTypes.tests+        , Test.Record.Sanity.ErrorsAndWarnings.tests+        , Test.Record.Sanity.Generics.tests+        , Test.Record.Sanity.GhcGenerics.tests+        , Test.Record.Sanity.HigherKinded.tests+        , Test.Record.Sanity.HKD.tests+        , Test.Record.Sanity.Laziness.tests+        , Test.Record.Sanity.Lens.Micro.tests+        , Test.Record.Sanity.OverloadingNoDRF.tests+        , Test.Record.Sanity.PatternMatch.tests+        , Test.Record.Sanity.QualifiedImports.tests+        , Test.Record.Sanity.RecordConstruction.tests+        , Test.Record.Sanity.Strictness.tests+        , Test.Record.Sanity.Transform.tests+        ]+    , testGroup "Size" [+          Test.Record.Size.Sanity.tests+        ]+    , testGroup "Prop" [+          Test.Record.Prop.Show.tests+        , Test.Record.Prop.ToFromJSON.tests+        ]+    ]