large-generics (empty) → 0.1.0.0

raw patch · 25 files changed

+2984/−0 lines, 25 filesdep +QuickCheckdep +aesondep +base

Dependencies added: QuickCheck, aeson, base, generic-deriving, generics-sop, large-generics, microlens, mtl, sop-core, tasty, tasty-hunit, tasty-quickcheck, vector

Files

• CHANGELOG.md +5/−0
• large-generics.cabal +87/−0
• src/Data/Record/Generic.hs +121/−0
• src/Data/Record/Generic/Eq.hs +37/−0
• src/Data/Record/Generic/GHC.hs +111/−0
• src/Data/Record/Generic/JSON.hs +44/−0
• src/Data/Record/Generic/Lens/VL.hs +222/−0
• src/Data/Record/Generic/LowerBound.hs +31/−0
• src/Data/Record/Generic/Rep.hs +200/−0
• src/Data/Record/Generic/Rep/Internal.hs +110/−0
• src/Data/Record/Generic/SOP.hs +126/−0
• src/Data/Record/Generic/Show.hs +38/−0
• src/Data/Record/Generic/Transform.hs +173/−0
• test/Test/Record/Generic/Infra/Beam/Interpretation.hs +72/−0
• test/Test/Record/Generic/Infra/Beam/Mini.hs +63/−0
• test/Test/Record/Generic/Infra/Examples.hs +538/−0
• test/Test/Record/Generic/Infra/Util.hs +28/−0
• test/Test/Record/Generic/Prop/Show.hs +16/−0
• test/Test/Record/Generic/Prop/ToFromJSON.hs +21/−0
• test/Test/Record/Generic/Sanity/GhcGenerics.hs +126/−0
• test/Test/Record/Generic/Sanity/Laziness.hs +151/−0
• test/Test/Record/Generic/Sanity/Lens/VL.hs +246/−0
• test/Test/Record/Generic/Sanity/Rep.hs +169/−0
• test/Test/Record/Generic/Sanity/Transform.hs +227/−0
• test/TestLargeGenerics.hs +22/−0

@@ -0,0 +1,5 @@+# Revision history for large-generics++## 0.1.0.0 -- 2022-03-23++* First public release

@@ -0,0 +1,87 @@+cabal-version:      2.4+name:               large-generics+version:            0.1.0.0+synopsis:           Generic programming API for large-records and large-anon+description:        The large-generics package offers a style of generic+                    programming inspired by generics-sop, but optimized for+                    compilation time. For more information, see the blog posts+                    "Avoiding quadratic core code size with large records"+                    <https://well-typed.com/blog/2021/08/large-records/>.+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+tested-with:        GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.2++library+  exposed-modules:+      -- General infrastructure+      Data.Record.Generic+      Data.Record.Generic.Rep+      Data.Record.Generic.Rep.Internal+      Data.Record.Generic.Transform++      -- Interop with other generics approaches+      Data.Record.Generic.GHC+      Data.Record.Generic.SOP++      -- Specific generic functions+      Data.Record.Generic.Eq+      Data.Record.Generic.JSON+      Data.Record.Generic.Lens.VL+      Data.Record.Generic.LowerBound+      Data.Record.Generic.Show+  default-language:+      Haskell2010+  ghc-options:+      -Wall+      -Wredundant-constraints+  hs-source-dirs:+      src+  build-depends:+      base         >= 4.13  && < 4.17+    , aeson        >= 1.4.4 && < 2.1+    , generics-sop >= 0.5   && < 0.6+    , sop-core     >= 0.5   && < 0.6+    , vector       >= 0.12  && < 0.13++test-suite test-large-generics+  type:+      exitcode-stdio-1.0+  main-is:+      TestLargeGenerics.hs+  other-modules:+      Test.Record.Generic.Infra.Examples+      Test.Record.Generic.Infra.Beam.Interpretation+      Test.Record.Generic.Infra.Beam.Mini+      Test.Record.Generic.Infra.Util+      Test.Record.Generic.Prop.Show+      Test.Record.Generic.Prop.ToFromJSON+      Test.Record.Generic.Sanity.GhcGenerics+      Test.Record.Generic.Sanity.Laziness+      Test.Record.Generic.Sanity.Lens.VL+      Test.Record.Generic.Sanity.Rep+      Test.Record.Generic.Sanity.Transform+  default-language:+      Haskell2010+  ghc-options:+      -Wall+      -Wredundant-constraints+  hs-source-dirs:+      test+  build-depends:+      base+    , large-generics++    , aeson+    , generic-deriving+    , generics-sop+    , microlens+    , mtl+    , QuickCheck+    , sop-core+    , tasty+    , tasty-hunit+    , tasty-quickcheck

@@ -0,0 +1,121 @@+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE ExplicitNamespaces   #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE KindSignatures       #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}++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+  --+  -- NOTE: using type-level lists without resulting in quadratic core code is+  -- extremely difficult. Any use of this type-level metadata therefore needs+  -- delibrate consideration. Some examples:+  --+  -- o Within the @large-generics@ library, 'MetadataOf' is used in the+  --   definition of 'HasNormalForm'. This constraint is carefully defined to+  --   avoid quadratic code, as described in the presentation+  --   "Avoiding Quadratic Blow-up During Compilation"+  --   <https://skillsmatter.com/skillscasts/17262-avoiding-quadratic-blow-up-during-compilation>+  -- o The @large-records@ library uses it to provide a compatibility layer+  --   between it and @sop-core@; this is however only for testing purposes, and+  --   the quadratic code here is simply accepted.+  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++  This is primarily designed for interop with SOP.+-------------------------------------------------------------------------------}++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)+         , KnownSymbol (FieldName field)+         ) => IsField field+instance ( field ~ '(FieldName field, FieldType field)+         , KnownSymbol (FieldName field)+         ) => IsField field

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

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

@@ -0,0 +1,44 @@+{-# 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 Data.String++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 -> (fromString 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 .: fromString fld

@@ -0,0 +1,222 @@+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE KindSignatures        #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE QuantifiedConstraints #-}++-- | van Laarhoven lenses for large records.+-- The type synonym+--+-- @+--   type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s+-- @+-- Appears below, however it is not exported to avoid conflicts with other+-- libraries defining equivalent synonyms.+module Data.Record.Generic.Lens.VL (+    -- * 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 Data.Record.Generic+import Data.Record.Generic.Transform++import qualified Data.Record.Generic.Rep as Rep++-- | The standard van Laarhoven representation for a monomorphic lens+type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s++{-------------------------------------------------------------------------------+  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)

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

@@ -0,0 +1,200 @@+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++-- | 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.+--++{-------------------------------------------------------------------------------+  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)++{-------------------------------------------------------------------------------+  "Applicative"+-------------------------------------------------------------------------------}++pure :: forall f a. Generic a => (forall x. f x) -> Rep f a+pure f = Rep (V.replicate (recordSize (metadata (Proxy @a))) f)++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++{-------------------------------------------------------------------------------+  "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)++{-------------------------------------------------------------------------------+  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

@@ -0,0 +1,110 @@+{-# LANGUAGE FlexibleInstances   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE RoleAnnotations     #-}+{-# 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+  , unsafeFromListAny+  , collapse+  , toListAny+    -- * Auxiliary+  , noInlineUnsafeCo+  ) 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 Unsafe.Coerce (unsafeCoerce)++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 'Rep' to list+toListAny :: Rep f a -> [f Any]+toListAny (Rep v) = V.toList v++-- | Convert list to 'Rep'+--+-- Does not check that the list has the right number of elements.+unsafeFromList :: [b] -> Rep (K b) a+unsafeFromList = Rep . V.fromList . Prelude.map K++-- | Convert list to 'Rep'+--+-- Does not check that the list has the right number of elements, nor the+-- types of those elements.+unsafeFromListAny :: [f Any] -> Rep f a+unsafeFromListAny = Rep . V.fromList++{-------------------------------------------------------------------------------+  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')++{-------------------------------------------------------------------------------+  Auxiliary+-------------------------------------------------------------------------------}++-- | 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+

@@ -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.Generic.Rep.Internal (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)

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

@@ -0,0 +1,173 @@+{-# LANGUAGE ConstraintKinds         #-}+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE DefaultSignatures       #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE KindSignatures          #-}+{-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE PolyKinds               #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE TypeApplications        #-}+{-# LANGUAGE TypeFamilies            #-}+{-# LANGUAGE TypeOperators           #-}+{-# LANGUAGE UndecidableInstances    #-}++-- 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 tests in "Test.Record.Generic.Sanity.Transform" show 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

@@ -0,0 +1,72 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++-- | Integration of large-generics with mini-beam+--+-- See the @beam-large-package@ for full beam integration.+module Test.Record.Generic.Infra.Beam.Interpretation (+    BeamInterpretation+  , ZipInterpreted(..)+  , gzipBeam+  ) where++import Data.Functor.Identity+import Data.Kind+import Data.Proxy++import Data.Record.Generic+import Data.Record.Generic.Transform+import Data.Record.Generic.Lens.VL++import qualified Data.Record.Generic.Rep as Rep++import Test.Record.Generic.Infra.Beam.Mini++data BeamInterpretation (f :: Type -> Type)++type instance Interpreted (BeamInterpretation f) (table Uninterpreted) = table f+type instance Interpreted (BeamInterpretation f) (Uninterpreted x)     = Columnar f x++instance StandardInterpretation BeamInterpretation (RegularRecordLens tbl f)+instance StandardInterpretation BeamInterpretation Identity++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++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))+

@@ -0,0 +1,63 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE KindSignatures       #-}+{-# LANGUAGE RankNTypes           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}++-- TODO: cleanup++module Test.Record.Generic.Infra.Beam.Mini (+    Columnar+  , Columnar'(..)+  , applyColumnar'+  , PrimaryKey+  , Table+  , Lenses+  , Beamable(..)+  , WrapLens(..)+  ) where++import Data.Functor.Identity+import Data.Kind+import Data.Proxy+import Lens.Micro (Lens')++data Nullable (c :: Type -> Type) x++data Lenses (tbl :: (Type -> Type) -> Type) (f :: Type -> Type) (x :: Type)++data WrapLens a b = WrapLens (Lens' a b)++type family Columnar (f :: Type -> Type) x where+  Columnar Identity       x = x+  Columnar (Nullable c)   x = Columnar c (Maybe x)+  Columnar (Lenses tbl f) x = WrapLens (tbl f) (Columnar f x)+  Columnar f              x = f x++newtype Columnar' f a = Columnar' { getColumnar' :: Columnar f a }++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)++class Beamable (table :: (Type -> Type) -> Type) where+  zipBeamFieldsM ::+       Applicative m+    => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a))+    -> table f -> table g -> m (table h)++-- | Primary key of a table+--+-- In beam this is an associated type of the 'Table' class; we split this off+-- so that we can define the basic table definitions without needing to define+-- the transform ('zipBeamFieldsM') at the same time.+data family PrimaryKey (table :: (Type -> Type) -> Type) :: (Type -> Type) -> Type++class (Beamable table, Beamable (PrimaryKey table)) => Table table where+

@@ -0,0 +1,538 @@+{-# LANGUAGE ConstraintKinds         #-}+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE DeriveGeneric           #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE InstanceSigs            #-}+{-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE RecordWildCards         #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE StandaloneDeriving      #-}+{-# LANGUAGE TypeApplications        #-}+{-# LANGUAGE TypeFamilies            #-}+{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE UndecidableSuperClasses #-}+{-# LANGUAGE ViewPatterns            #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++-- | Standard Haskell records with a hand-written Generic instance+--+-- @large-records@ and @large-anon@ provide different record representations,+-- but here we want to test the generics infrastructure independent from these+-- libraries. The definitions here are simple, not intended to check for core+-- size; we do that in large-records and large-anon.+--+-- These definitions serve as a simple example of how the 'Generic' class might+-- be instantiated, and are used as a basis for testing.+module Test.Record.Generic.Infra.Examples (+    -- * Simple+    SimpleRecord(..)+  , exampleSimpleRecord+    -- * With type parameters+  , ParamRecord(..)+  , exampleParamRecord+    -- * Higher-kinded+  , Regular(..)+  , Irregular(..)+  , MultiFun(..)+  , exampleRegular+  , exampleIrregular+    -- * Beam-like+  , MixinTable(..)+  , FullTable(..)+  , PrimaryKey(..)+  , exampleMixinTable+  ) where++import Data.Kind++import qualified GHC.Generics as GHC+import qualified Generics.SOP as SOP++import Test.QuickCheck++import Data.Record.Generic+import Data.Record.Generic.Rep.Internal (noInlineUnsafeCo)++import qualified Data.Record.Generic.Rep.Internal as Rep++import Test.Record.Generic.Infra.Beam.Mini+import Data.Functor.Identity++{-------------------------------------------------------------------------------+  Simple record+-------------------------------------------------------------------------------}++data SimpleRecord = MkSimpleRecord {+      simpleRecordField1 :: Word+    , simpleRecordField2 :: Bool+    }+  deriving (Show, Eq, GHC.Generic) -- GHC generics for the GhcGenerics tests++exampleSimpleRecord :: SimpleRecord+exampleSimpleRecord = MkSimpleRecord 5 True++class    (c Word, c Bool) => ConstraintsSimpleRecord c where+instance (c Word, c Bool) => ConstraintsSimpleRecord c where++instance Generic SimpleRecord where+  type Constraints SimpleRecord = ConstraintsSimpleRecord+  type MetadataOf  SimpleRecord = '[ '("simpleRecordField1", Word)+                                   , '("simpleRecordField2", Bool)+                                   ]++  from MkSimpleRecord{..} = Rep.unsafeFromListAny [+        I $ noInlineUnsafeCo simpleRecordField1+      , I $ noInlineUnsafeCo simpleRecordField2+      ]++  to rep =+    let { [ I (noInlineUnsafeCo -> simpleRecordField1)+          , I (noInlineUnsafeCo -> simpleRecordField2)+          ] = Rep.toListAny rep }+    in MkSimpleRecord{..}++  dict :: forall c.+       ConstraintsSimpleRecord c+    => Proxy c -> Rep (Dict c) SimpleRecord+  dict _ = Rep.unsafeFromListAny [+        noInlineUnsafeCo (Dict :: Dict c Word)+      , noInlineUnsafeCo (Dict :: Dict c Bool)+      ]++  metadata _ = Metadata {+        recordName          = "SimpleRecord"+      , recordConstructor   = "MkSimpleRecord"+      , recordSize          = 2+      , recordFieldMetadata = Rep.unsafeFromListAny [+            noInlineUnsafeCo $+              FieldMetadata (Proxy @"simpleRecordField1") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"simpleRecordField2") FieldLazy+          ]+      }++instance Arbitrary SimpleRecord where+  arbitrary = MkSimpleRecord <$> arbitrary <*> arbitrary+  shrink (MkSimpleRecord f1 f2) = concat [+        [ MkSimpleRecord f1' f2+        | f1' <- shrink f1+        ]+      , [ MkSimpleRecord f1 f2'+        | f2' <- shrink f2+        ]+      ]++{-------------------------------------------------------------------------------+  Record with some type arguments (but not higher-kinded)+-------------------------------------------------------------------------------}++data ParamRecord a b = MkParamRecord {+      paramRecordField1 :: Word+    , paramRecordField2 :: Bool+    , paramRecordField3 :: Char+    , paramRecordField4 :: a+    , paramRecordField5 :: [b]+    }+  deriving (Eq, Ord, Show, GHC.Generic)++instance SOP.Generic (ParamRecord a b)+  -- For comparison purposes only++class    (c Word, c Bool, c Char, c a, c [b]) => ConstraintsParamRecord a b c+instance (c Word, c Bool, c Char, c a, c [b]) => ConstraintsParamRecord a b c++instance Generic (ParamRecord a b) where+  type Constraints (ParamRecord a b) = ConstraintsParamRecord a b+  type MetadataOf  (ParamRecord a b) = '[ '("paramRecordField1", Word)+                                        , '("paramRecordField2", Bool)+                                        , '("paramRecordField3", Char)+                                        , '("paramRecordField4", a)+                                        , '("paramRecordField5", [b])+                                        ]++  from MkParamRecord{..} = Rep.unsafeFromListAny [+        I $ noInlineUnsafeCo paramRecordField1+      , I $ noInlineUnsafeCo paramRecordField2+      , I $ noInlineUnsafeCo paramRecordField3+      , I $ noInlineUnsafeCo paramRecordField4+      , I $ noInlineUnsafeCo paramRecordField5+      ]++  to rep =+    let { [ I (noInlineUnsafeCo -> paramRecordField1)+          , I (noInlineUnsafeCo -> paramRecordField2)+          , I (noInlineUnsafeCo -> paramRecordField3)+          , I (noInlineUnsafeCo -> paramRecordField4)+          , I (noInlineUnsafeCo -> paramRecordField5)+          ] = Rep.toListAny rep }+    in MkParamRecord{..}++  dict :: forall c.+       ConstraintsParamRecord a b c+    => Proxy c -> Rep (Dict c) (ParamRecord a b)+  dict _ = Rep.unsafeFromListAny [+        noInlineUnsafeCo (Dict :: Dict c Word)+      , noInlineUnsafeCo (Dict :: Dict c Bool)+      , noInlineUnsafeCo (Dict :: Dict c Char)+      , noInlineUnsafeCo (Dict :: Dict c a)+      , noInlineUnsafeCo (Dict :: Dict c [b])+      ]++  metadata _ = Metadata {+        recordName          = "ParamRecord"+      , recordConstructor   = "MkParamRecord"+      , recordSize          = 5+      , recordFieldMetadata = Rep.unsafeFromListAny [+            noInlineUnsafeCo $+              FieldMetadata (Proxy @"paramRecordField1") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"paramRecordField2") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"paramRecordField3") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"paramRecordField4") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"paramRecordField5") FieldLazy+          ]+      }++exampleParamRecord :: ParamRecord () Float+exampleParamRecord = MkParamRecord 5 True 'c' () [3.14]++{-------------------------------------------------------------------------------+  Higher kinded record: regular+-------------------------------------------------------------------------------}++-- | Regular example: all fields have an @f@ parameter+data Regular f = MkRegular {+        regularField1 :: f Int+      , regularField2 :: f Bool+      , regularField3 :: f String+      }++exampleRegular :: Regular I+exampleRegular = MkRegular {+      regularField1 = I 5+    , regularField2 = I True+    , regularField3 = I "a"+    }++deriving instance (Show (f Int), Show (f Bool), Show (f String)) => Show (Regular f)+deriving instance (Eq   (f Int), Eq   (f Bool), Eq   (f String)) => Eq   (Regular f)++class    (c (f Int), c (f Bool), c (f String)) => ConstraintsRegular f c+instance (c (f Int), c (f Bool), c (f String)) => ConstraintsRegular f c++instance Generic (Regular f) where+  type Constraints (Regular f) = ConstraintsRegular f+  type MetadataOf  (Regular f) = '[ '("regularField1", f Int)+                                  , '("regularField1", f Bool)+                                  , '("regularField3", f String)+                                  ]+++  from MkRegular{..} = Rep.unsafeFromListAny [+        I $ noInlineUnsafeCo regularField1+      , I $ noInlineUnsafeCo regularField2+      , I $ noInlineUnsafeCo regularField3+      ]++  to rep =+    let { [ I (noInlineUnsafeCo -> regularField1)+          , I (noInlineUnsafeCo -> regularField2)+          , I (noInlineUnsafeCo -> regularField3)+          ] = Rep.toListAny rep }+    in MkRegular{..}++  dict :: forall c.+       ConstraintsRegular f c+    => Proxy c -> Rep (Dict c) (Regular f)+  dict _ = Rep.unsafeFromListAny [+        noInlineUnsafeCo (Dict :: Dict c (f Int))+      , noInlineUnsafeCo (Dict :: Dict c (f Bool))+      , noInlineUnsafeCo (Dict :: Dict c (f String))+      ]++  metadata _ = Metadata {+        recordName          = "Regular"+      , recordConstructor   = "MkRegular"+      , recordSize          = 3+      , recordFieldMetadata = Rep.unsafeFromListAny [+            noInlineUnsafeCo $+              FieldMetadata (Proxy @"regularField1") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"regularField2") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"regularField3") FieldLazy+          ]+      }++{-------------------------------------------------------------------------------+  Higher kinded record: irregular+-------------------------------------------------------------------------------}++-- | Irregular example: not all fields have an @f@ parameter+data Irregular f = MkIrregular {+        irregularField1 :: f Int+      , irregularField2 :: f Bool+      , irregularField3 :: String+      }++exampleIrregular :: Irregular I+exampleIrregular = MkIrregular {+      irregularField1 = I 1234+    , irregularField2 = I True+    , irregularField3 = "hi"+    }++deriving instance (Show (f Int), Show (f Bool)) => Show (Irregular f)+deriving instance (Eq   (f Int), Eq   (f Bool)) => Eq   (Irregular f)++class    (c (f Int), c (f Bool), c String) => ConstraintsIrregular f c+instance (c (f Int), c (f Bool), c String) => ConstraintsIrregular f c++instance Generic (Irregular f) where+  type Constraints (Irregular f) = ConstraintsIrregular f+  type MetadataOf  (Irregular f) = '[ '("irregularField1", f Int)+                                    , '("irregularField1", f Bool)+                                    , '("irregularField3", String)+                                    ]++  from MkIrregular{..} = Rep.unsafeFromListAny [+        I $ noInlineUnsafeCo irregularField1+      , I $ noInlineUnsafeCo irregularField2+      , I $ noInlineUnsafeCo irregularField3+      ]++  to rep =+    let { [ I (noInlineUnsafeCo -> irregularField1)+          , I (noInlineUnsafeCo -> irregularField2)+          , I (noInlineUnsafeCo -> irregularField3)+          ] = Rep.toListAny rep }+    in MkIrregular{..}++  dict :: forall c.+       ConstraintsIrregular f c+    => Proxy c -> Rep (Dict c) (Irregular f)+  dict _ = Rep.unsafeFromListAny [+        noInlineUnsafeCo (Dict :: Dict c (f Int))+      , noInlineUnsafeCo (Dict :: Dict c (f Bool))+      , noInlineUnsafeCo (Dict :: Dict c String)+      ]++  metadata _ = Metadata {+        recordName          = "Irregular"+      , recordConstructor   = "MkIrregular"+      , recordSize          = 3+      , recordFieldMetadata = Rep.unsafeFromListAny [+            noInlineUnsafeCo $+              FieldMetadata (Proxy @"irregularField1") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"irregularField2") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"irregularField3") FieldLazy+          ]+      }++{-------------------------------------------------------------------------------+  Higher kinded record: multiple functors+-------------------------------------------------------------------------------}++data MultiFun f g = MkMultiFun {+        multiFunField1 :: f Int+      , multiFunField2 :: g Bool+      , multiFunField3 :: String+      }++deriving instance (Show (f Int), Show (g Bool)) => Show (MultiFun f g)+deriving instance (Eq   (f Int), Eq   (g Bool)) => Eq   (MultiFun f g)++class    (c (f Int), c (g Bool), c String) => ConstraintsMultiFun f g c+instance (c (f Int), c (g Bool), c String) => ConstraintsMultiFun f g c++instance Generic (MultiFun f g) where+  type Constraints (MultiFun f g) = ConstraintsMultiFun f g+  type MetadataOf  (MultiFun f g) = '[ '("multiFunField1", f Int)+                                     , '("multiFunField1", g Bool)+                                     , '("multiFunField3", String)+                                     ]++  from MkMultiFun{..} = Rep.unsafeFromListAny [+        I $ noInlineUnsafeCo multiFunField1+      , I $ noInlineUnsafeCo multiFunField2+      , I $ noInlineUnsafeCo multiFunField3+      ]++  to rep =+    let { [ I (noInlineUnsafeCo -> multiFunField1)+          , I (noInlineUnsafeCo -> multiFunField2)+          , I (noInlineUnsafeCo -> multiFunField3)+          ] = Rep.toListAny rep }+    in MkMultiFun{..}++  dict :: forall c.+       ConstraintsMultiFun f g c+    => Proxy c -> Rep (Dict c) (MultiFun f g)+  dict _ = Rep.unsafeFromListAny [+        noInlineUnsafeCo (Dict :: Dict c (f Int))+      , noInlineUnsafeCo (Dict :: Dict c (g Bool))+      , noInlineUnsafeCo (Dict :: Dict c String)+      ]++  metadata _ = Metadata {+        recordName          = "MultiFun"+      , recordConstructor   = "MkMultiFun"+      , recordSize          = 3+      , recordFieldMetadata = Rep.unsafeFromListAny [+            noInlineUnsafeCo $+              FieldMetadata (Proxy @"multiFunField1") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"multiFunField2") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"multiFunField3") FieldLazy+          ]+      }++{-------------------------------------------------------------------------------+  Beam-like mixin table++  This is the simpler case, because it contains only Columnar fields.+-------------------------------------------------------------------------------}++data MixinTable (f :: Type -> Type) = MkMixinTable {+      mixinTableField1 :: Columnar f Char+    , mixinTableField2 :: Columnar f Double+    }++exampleMixinTable :: MixinTable Identity+exampleMixinTable = MkMixinTable {+      mixinTableField1 = 'a'+    , mixinTableField2 = 3.14+    }++deriving instance ( Show (Columnar f Char)+                  , Show (Columnar f Double)+                  ) => Show (MixinTable f)+deriving instance ( Eq (Columnar f Char)+                  , Eq (Columnar f Double)+                  ) => Eq (MixinTable f)++class    (c (Columnar f Char), c (Columnar f Double)) => ConstraintsMixinTable f c+instance (c (Columnar f Char), c (Columnar f Double)) => ConstraintsMixinTable f c++instance Generic (MixinTable f) where+  type Constraints (MixinTable f) = ConstraintsMixinTable f+  type MetadataOf  (MixinTable f) = '[ '("mixinTableField1", Columnar f Char)+                                     , '("mixinTableField2", Columnar f Double)+                                     ]++  from MkMixinTable{..} = Rep.unsafeFromListAny [+        I $ noInlineUnsafeCo mixinTableField1+      , I $ noInlineUnsafeCo mixinTableField2+      ]++  to rep =+    let { [ I (noInlineUnsafeCo -> mixinTableField1)+          , I (noInlineUnsafeCo -> mixinTableField2)+          ] = Rep.toListAny rep }+    in MkMixinTable{..}++  dict :: forall c.+       ConstraintsMixinTable f c+    => Proxy c -> Rep (Dict c) (MixinTable f)+  dict _ = Rep.unsafeFromListAny [+        noInlineUnsafeCo (Dict :: Dict c (Columnar f Char))+      , noInlineUnsafeCo (Dict :: Dict c (Columnar f Double))+      ]++  metadata _ = Metadata {+        recordName          = "MixinTable"+      , recordConstructor   = "MkMixinTable"+      , recordSize          = 2+      , recordFieldMetadata = Rep.unsafeFromListAny [+            noInlineUnsafeCo $+              FieldMetadata (Proxy @"mixinTableField1") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"mixinTableField2") FieldLazy+          ]+      }++{-------------------------------------------------------------------------------+  Beam-like full table example+-------------------------------------------------------------------------------}++data FullTable (f :: Type -> Type) = MkFullTable {+      fullTableField1 :: PrimaryKey FullTable f+    , fullTableField2 :: Columnar f Bool+    , fullTableField3 :: MixinTable f+    }++data instance PrimaryKey FullTable f = PrimA (Columnar f Int)++deriving instance Show (Columnar f Int) => Show (PrimaryKey FullTable f)+deriving instance Eq   (Columnar f Int) => Eq   (PrimaryKey FullTable f)++deriving instance ( Show (Columnar f Int)+                  , Show (Columnar f Bool)+                  , Show (Columnar f Char)+                  , Show (Columnar f Double)+                  ) => Show (FullTable f)+deriving instance ( Eq (Columnar f Int)+                  , Eq (Columnar f Bool)+                  , Eq (Columnar f Char)+                  , Eq (Columnar f Double)+                  ) => Eq (FullTable f)++class    ( c (PrimaryKey FullTable f)+         , c (Columnar f Bool)+         , c (MixinTable f)+         ) => ConstraintsFullTable f c+instance ( c (PrimaryKey FullTable f)+         , c (Columnar f Bool)+         , c (MixinTable f)+         ) => ConstraintsFullTable f c++instance Generic (FullTable f) where+  type Constraints (FullTable f) = ConstraintsFullTable f+  type MetadataOf  (FullTable f) = '[ '("fullTableField1", PrimaryKey FullTable f)+                                    , '("fullTableField2", Columnar f Bool)+                                    , '("fullTableField3", MixinTable f)+                                    ]++  from MkFullTable{..} = Rep.unsafeFromListAny [+        I $ noInlineUnsafeCo fullTableField1+      , I $ noInlineUnsafeCo fullTableField2+      , I $ noInlineUnsafeCo fullTableField3+      ]++  to rep =+    let { [ I (noInlineUnsafeCo -> fullTableField1)+          , I (noInlineUnsafeCo -> fullTableField2)+          , I (noInlineUnsafeCo -> fullTableField3)+          ] = Rep.toListAny rep }+    in MkFullTable{..}++  dict :: forall c.+       ConstraintsFullTable f c+    => Proxy c -> Rep (Dict c) (FullTable f)+  dict _ = Rep.unsafeFromListAny [+        noInlineUnsafeCo (Dict :: Dict c (PrimaryKey FullTable f))+      , noInlineUnsafeCo (Dict :: Dict c (Columnar f Bool))+      , noInlineUnsafeCo (Dict :: Dict c (MixinTable f))+      ]++  metadata _ = Metadata {+        recordName          = "FullTable"+      , recordConstructor   = "MkFullTable"+      , recordSize          = 3+      , recordFieldMetadata = Rep.unsafeFromListAny [+            noInlineUnsafeCo $+              FieldMetadata (Proxy @"fullTableField1") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"fullTableField2") FieldLazy+          , noInlineUnsafeCo $+              FieldMetadata (Proxy @"fullTableField3") FieldLazy+          ]+      }

@@ -0,0 +1,28 @@+module Test.Record.Generic.Infra.Util (+    expectException+  ) where++import Control.Exception+import Test.Tasty.HUnit++-- | 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+

@@ -0,0 +1,16 @@+module Test.Record.Generic.Prop.Show (tests) where++import Data.Record.Generic.Show (gshowsPrec)++import Test.Tasty+import Test.Tasty.QuickCheck++import Test.Record.Generic.Infra.Examples++tests :: TestTree+tests = testGroup "Test.Record.Generic.Prop.Show" [+      testProperty "show" prop_show+    ]++prop_show :: SimpleRecord -> Property+prop_show ex = show ex === gshowsPrec 0 ex ""

@@ -0,0 +1,21 @@+module Test.Record.Generic.Prop.ToFromJSON (tests) where++import Data.Aeson.Types (parseEither)++import Data.Record.Generic.JSON++import Test.Tasty+import Test.Tasty.QuickCheck++import Test.Record.Generic.Infra.Examples++tests :: TestTree+tests = testGroup "Test.Record.Prop.ToFromJSON" [+      testProperty "tofromJSON" prop_tofromJSON+    ]++-- | Test that gtoJSON and gfromJSON are inverse+prop_tofromJSON :: SimpleRecord -> Property+prop_tofromJSON ex =+      counterexample (show (gtoJSON ex))+    $ Right ex === parseEither gparseJSON (gtoJSON ex)

@@ -0,0 +1,126 @@+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Record.Generic.Sanity.GhcGenerics (tests) where++import Data.Function (on)+import Data.Proxy+import Data.SOP.BasicFunctors+import Generics.Deriving.Eq (GEq'(..), geqdefault)++import qualified GHC.Generics as GHC++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Generic.GHC++import qualified Data.Record.Generic     as L+import qualified Data.Record.Generic.Eq  as L (geq)+import qualified Data.Record.Generic.Rep as Rep++import Test.Record.Generic.Infra.Examples++{-------------------------------------------------------------------------------+  Show that we can use geqdefault on a large record+-------------------------------------------------------------------------------}++instance ( L.Generic a+         , L.Constraints a Eq+         ) => GEq' (ThroughLRGenerics a) where+  geq' = L.geq `on` unwrapThroughLRGenerics++allEqualTo :: (GHC.Generic a, GEq' (GHC.Rep a)) => a -> [a] -> Bool+allEqualTo x = all (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)++ghcRecordToTable :: (GHC.Generic a, GRecordToTable (GHC.Rep a)) => a -> Table+ghcRecordToTable = Table . gRecordToTable . GHC.from++-- The goal is to reuse the instance for fields+-- TODO: We could potentially extend this to the other metadata as well+largeRecordToTable :: forall a.+     (L.Generic a, L.Constraints a Show)+  => a -> Table+largeRecordToTable = \x ->+    Table {+        tableFields = concat . Rep.collapse $+            Rep.czipWith+              (Proxy @Show)+              aux+              (L.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.Generic.Sanity.GhcGenerics" [+      testCase "allEqualTo"          test_allEqualTo+    , testCase "simpleRecordToTable" test_simpleRecordToTable+    , testCase "largeRecordToTable"  test_largeRecordToTable+    ]++test_allEqualTo :: Assertion+test_allEqualTo =+    assertEqual "" True $+      allEqualTo exampleSimpleRecord [exampleSimpleRecord]++-- Just a sanity check that the standard GHC generic functions works as intended+test_simpleRecordToTable :: Assertion+test_simpleRecordToTable =+    assertEqual "" expectedTable $+      ghcRecordToTable exampleSimpleRecord++test_largeRecordToTable :: Assertion+test_largeRecordToTable =+    assertEqual "" expectedTable $+      largeRecordToTable exampleSimpleRecord++expectedTable :: Table+expectedTable = Table [+      ("simpleRecordField1", "5")+    , ("simpleRecordField2", "True")+    ]+

@@ -0,0 +1,151 @@+-- {-# LANGUAGE ConstraintKinds           #-}+-- {-# LANGUAGE DataKinds                 #-}+-- {-# LANGUAGE ExistentialQuantification #-}+-- {-# LANGUAGE FlexibleContexts          #-}+-- {-# LANGUAGE FlexibleInstances         #-}+-- {-# LANGUAGE MultiParamTypeClasses     #-}+{-# 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.Generic.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 qualified Data.Record.Generic.Rep          as Rep+import qualified Data.Record.Generic.Rep.Internal as Rep++import Test.Record.Generic.Infra.Examples+import Test.Record.Generic.Infra.Util (expectException)++{-------------------------------------------------------------------------------+  Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Generic.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) SimpleRecord+    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) SimpleRecord+    fns = Rep.map' (\x -> Fn $ \_ -> x) (from exampleSimpleRecord)++    expected, actual :: SimpleRecord+    expected = exampleSimpleRecord+    actual   = to $ Rep.ap fns undefined++test_map :: Assertion+test_map =+    assertEqual "" expected actual+  where+    expected, actual :: Rep (K Int) SimpleRecord+    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) SimpleRecord+    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) SimpleRecord <- Rep.mapM next undefined+    assertEqual "" expected actual+  where+    expected :: Rep (K Int) SimpleRecord+    expected = Rep.unsafeFromList [1, 2]++test_cmap :: Assertion+test_cmap =+    assertEqual "" expected actual+  where+    expected, actual :: SimpleRecord+    expected = MkSimpleRecord {+                   simpleRecordField1 = 0+                 , simpleRecordField2 = 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 :: SimpleRecord <- to <$> Rep.cmapM (Proxy @Bounded) next undefined+    assertEqual "" expected actual+  where+    expected :: SimpleRecord+    expected = MkSimpleRecord {+                   simpleRecordField1 = 0+                 , simpleRecordField2 = True+                 }++test_zipWithM :: Assertion+test_zipWithM =+    assertEqual "" expected actual+  where+    expected, actual :: Maybe (Rep (K Int) SimpleRecord)+    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 SimpleRecord+    expected = Just $ MkSimpleRecord {+                   simpleRecordField1 = 0+                 , simpleRecordField2 = False+                 }+    actual   = to <$> Rep.czipWithM+                        (Proxy @Bounded)+                        (\_ _ -> Just $ I minBound)+                        undefined+                        undefined

@@ -0,0 +1,246 @@+{-# LANGUAGE FlexibleContexts          #-}+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE ScopedTypeVariables       #-}+{-# LANGUAGE TypeApplications          #-}+{-# LANGUAGE TypeFamilies              #-}++{-# OPTIONS_GHC -Wno-missing-signatures #-}++module Test.Record.Generic.Sanity.Lens.VL (tests) where++import Data.Char (toUpper)+import Data.Functor.Identity+import Data.Maybe (fromJust)+import Data.Proxy+import Data.SOP+import Lens.Micro (Lens', (^.), (&), (%~))++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Generic+import Data.Record.Generic.Lens.VL+import Data.Record.Generic.SOP+import Data.Record.Generic.Transform++import qualified Data.Record.Generic.Rep as Rep++import Test.Record.Generic.Infra.Examples+import Test.Record.Generic.Infra.Beam.Interpretation+import Test.Record.Generic.Infra.Beam.Mini++{-------------------------------------------------------------------------------+  Simple example (no type families)+-------------------------------------------------------------------------------}++regularLenses :: Regular (RegularRecordLens Regular f)+regularLenses = lensesForRegularRecord (Proxy @DefaultInterpretation)++MkRegular {+      regularField1 = RegularRecordLens regularLens1+    , regularField2 = RegularRecordLens regularLens2+    , regularField3 = RegularRecordLens regularLens3+    } = regularLenses++{-------------------------------------------------------------------------------+  Example with type families, but still regular+-------------------------------------------------------------------------------}++mixinTableLenses :: MixinTable (RegularRecordLens MixinTable Identity)+mixinTableLenses = lensesForRegularRecord (Proxy @BeamInterpretation)++MkMixinTable {+      mixinTableField1 = RegularRecordLens mixinTableLens1+    , mixinTableField2 = RegularRecordLens mixinTableLens2+    } = mixinTableLenses++{-------------------------------------------------------------------------------+  Irregular example+-------------------------------------------------------------------------------}++-- We cannot define this now:+--+-- > irregularLenses :: Irregular (RegularRecordLens Irregular I)+-- > irregularLenses = lensesForRegularRecord (Proxy @DefaultInterpretation)+--+-- It will complain that @String@ is not equal to+--+-- > Interpreted (DefaultInterpretation (RegularRecordLens Irregular I)) String+--+-- 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++-- Unlike the beam tutorial, we match to get these lenses in two steps: first,+-- we get 'SimpleRecordLens' out, which does not rely on impredicativity;+-- then we get the Van Laarhoven lenses out in three separate bindings. This+-- avoids problems with ghc type inference which gets very confused by that+-- pattern match.++irregularLens1' :: SimpleRecordLens (Irregular f) (f Int)+irregularLens2' :: SimpleRecordLens (Irregular f) (f Bool)+irregularLens3' :: SimpleRecordLens (Irregular f) String++(    Field irregularLens1'+  :* Field irregularLens2'+  :* Field irregularLens3'+  :* Nil ) = irregularLenses++irregularLens1 :: Lens' (Irregular f) (f Int)+irregularLens2 :: Lens' (Irregular f) (f Bool)+irregularLens3 :: Lens' (Irregular f) String++SimpleRecordLens irregularLens1 = irregularLens1'+SimpleRecordLens irregularLens2 = irregularLens2'+SimpleRecordLens irregularLens3 = irregularLens3'++{-------------------------------------------------------------------------------+  Beam-like example (using the 'Lenses' indirection).++  This still does not support all beam features; in particular, this only works+  for the regular 'MixinTable', not for the complete 'FullTable'. To do that, we+  would need to introduce a separate type class (instead of 'IsRegularField')+  that then needs to be available for every field, so that we can distinguish+  between mixins and normal ('Columnar') fields. For a completely worked out+  exmaple, see the @beam-large-records@ package+  <https://github.com/well-typed/beam-large-records>.+-------------------------------------------------------------------------------}++beamLikeLenses :: forall tbl.+     ( Generic (tbl (Lenses tbl Identity))+     , Generic (tbl Uninterpreted)+     , Generic (tbl Identity)+     , HasNormalForm (BeamInterpretation (Lenses tbl Identity)) (tbl (Lenses tbl Identity)) (tbl Uninterpreted)+     , HasNormalForm (BeamInterpretation Identity) (tbl Identity) (tbl Uninterpreted)+     , Constraints (tbl Uninterpreted) (IsRegularField Uninterpreted)+     )+  => tbl (Lenses tbl Identity)+beamLikeLenses =+    to . denormalize1 (Proxy @BeamInterpretation) $+      Rep.cmap+        (Proxy @(IsRegularField Uninterpreted))+        aux+        (lensesForHKRecord (Proxy @BeamInterpretation))+  where+    aux :: forall x.+         IsRegularField Uninterpreted x+      => HKRecordLens BeamInterpretation Identity tbl x+      -> Interpret (BeamInterpretation (Lenses tbl Identity)) x+    aux (HKRecordLens l) =+        case isRegularField (Proxy @(Uninterpreted x)) of+          RegularField -> Interpret $ WrapLens $+              l+            . standardInterpretationLens (Proxy @BeamInterpretation)+            . unI'++    unI' :: Lens' (Identity x) x+    unI' f (Identity x) = Identity <$> f x++mixinBeamLikeLenses :: MixinTable (Lenses MixinTable Identity)+mixinBeamLikeLenses = beamLikeLenses++MkMixinTable {+      mixinTableField1 = WrapLens mixinBeamLikeLens1+    , mixinTableField2 = WrapLens mixinBeamLikeLens2+    } = mixinBeamLikeLenses++{-------------------------------------------------------------------------------+  Tests proper+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Generic.Sanity.Lens.VL" [+      testCase "regular_get"   test_regular_get+    , testCase "regular_set"   test_regular_set+    , testCase "mixin_get"     test_mixin_get+    , testCase "mixin_set"     test_mixin_set+    , testCase "irregular_get" test_irregular_get+    , testCase "irregular_set" test_irregular_set+    , testCase "beamlike_get"  test_beamlike_get+    , testCase "beamlike_set"  test_beamlike_set+    ]++test_regular_get :: Assertion+test_regular_get =+    assertEqual "" (I True)+      (exampleRegular ^. regularLens2)++test_regular_set :: Assertion+test_regular_set =+    assertEqual "" expected $+        exampleRegular+      & regularLens1 %~ mapII negate+      & regularLens3 %~ mapII (map toUpper)+  where+    expected :: Regular I+    expected = MkRegular {+          regularField1 = I (-5)+        , regularField2 = I True+        , regularField3 = I "A"+        }++test_mixin_get :: Assertion+test_mixin_get =+    assertEqual "" 3.14+      (exampleMixinTable ^. mixinTableLens2)++test_mixin_set :: Assertion+test_mixin_set =+    assertEqual "" expected $+        exampleMixinTable+      & mixinTableLens1 %~ succ+      & mixinTableLens2 %~ negate+  where+    expected :: MixinTable Identity+    expected = MkMixinTable {+          mixinTableField1 = 'b'+        , mixinTableField2 = -3.14+        }++test_irregular_get :: Assertion+test_irregular_get =+    assertEqual "" (I True)+      (exampleIrregular ^. irregularLens2)++test_irregular_set :: Assertion+test_irregular_set =+    assertEqual "" expected $+        exampleIrregular+      & irregularLens1 %~ mapII negate+      & irregularLens3 %~ map toUpper+  where+    expected :: Irregular I+    expected = MkIrregular {+          irregularField1 = I (-1234)+        , irregularField2 = I True+        , irregularField3 = "HI"+        }++test_beamlike_get :: Assertion+test_beamlike_get =+    assertEqual "" 3.14+      (exampleMixinTable ^. mixinBeamLikeLens2)++test_beamlike_set :: Assertion+test_beamlike_set =+    assertEqual "" expected $+        exampleMixinTable+      & mixinBeamLikeLens1 %~ succ+      & mixinBeamLikeLens2 %~ negate+  where+    expected :: MixinTable Identity+    expected = MkMixinTable {+          mixinTableField1 = 'b'+        , mixinTableField2 = -3.14+        }

@@ -0,0 +1,169 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeOperators       #-}++module Test.Record.Generic.Sanity.Rep (tests) where++import Control.Monad.State (State, evalState, state)+import Data.SOP (NP(..), All, Compose)++import qualified Data.SOP as SOP++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 qualified Data.Record.Generic.SOP as SOP+import qualified Data.Record.Generic.Rep as Rep++import Test.Record.Generic.Infra.Examples++{-------------------------------------------------------------------------------+  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"++{-------------------------------------------------------------------------------+  Tests+-------------------------------------------------------------------------------}++test_pure :: Assertion+test_pure =+    compareTyped expected actual+  where+    expected :: NP (Field (K Char)) (MetadataOf (ParamRecord () Float))+    expected =+           Field (K 'a')+        :* Field (K 'a')+        :* Field (K 'a')+        :* Field (K 'a')+        :* Field (K 'a')+        :* Nil++    actual :: Rep (K Char) (ParamRecord () Float)+    actual = Rep.pure (K 'a')++test_cpure :: Assertion+test_cpure =+    assertEqual "matches hand-constructed" expected actual+  where+    expected, actual :: ParamRecord () Float+    expected = MkParamRecord 0 False '\x0000' () []+    actual   = glowerBound++test_sequenceA :: Assertion+test_sequenceA =+    compareTyped expected actual+  where+    expected :: NP (Field (K Int)) (MetadataOf (ParamRecord () 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) (ParamRecord () Float)+    actual = flip evalState 0 $ Rep.sequenceA $ SOP.fromSOP example++    example :: NP (Field (State Int SOP.:.: K Int)) (MetadataOf (ParamRecord () 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 (ParamRecord () 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) (ParamRecord () 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 (ParamRecord () 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 :: ParamRecord () Float+    t1 = MkParamRecord w  b  'c' () [3.14]+    t2 = MkParamRecord w' b' 'c' () [3.14]++{-------------------------------------------------------------------------------+  All tests+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Generic.Sanity.Rep" [+      testCase     "pure"       test_pure+    , testCase     "cpure"      test_cpure+    , testCase     "sequenceA"  test_sequenceA+    , testCase     "zipWithM"   test_zipWithM+    , testProperty "ord"        test_ord+    ]

@@ -0,0 +1,227 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE UndecidableInstances  #-}++{-# OPTIONS_GHC -Wno-orphans #-}++module Test.Record.Generic.Sanity.Transform (tests) where++import Data.Functor.Identity+import Data.Kind+import Data.Proxy+import Data.SOP.BasicFunctors+import GHC.TypeLits (Nat)++import Test.Tasty+import Test.Tasty.HUnit++import Data.Record.Generic+import Data.Record.Generic.Transform++import qualified Data.Record.Generic.Rep as Rep+import qualified Generics.SOP            as SOP++import Test.Record.Generic.Infra.Beam.Interpretation+import Test.Record.Generic.Infra.Beam.Mini+import Test.Record.Generic.Infra.Examples++{-------------------------------------------------------------------------------+  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.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++-- | 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))++justIrregular :: Irregular I -> Irregular Maybe+justIrregular = gjust++{-------------------------------------------------------------------------------+  Example with two variables+-------------------------------------------------------------------------------}++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++swapMultiFun :: MultiFun I Identity -> MultiFun Identity I+swapMultiFun = gswap++{-------------------------------------------------------------------------------+  Beam test+-------------------------------------------------------------------------------}++instance Beamable (PrimaryKey FullTable) 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 FullTable  where zipBeamFieldsM = gzipBeam+instance Beamable MixinTable where zipBeamFieldsM = gzipBeam++instance Table FullTable++{-------------------------------------------------------------------------------+  Tests+-------------------------------------------------------------------------------}++tests :: TestTree+tests = testGroup "Test.Record.Generic.Sanity.Transform" [+      testCase "gjust"    test_gjust+    , testCase "gswap"    test_gswap+    , testCase "gzipBeam" test_gzipBeam+    ]++test_gjust :: Assertion+test_gjust =+    assertEqual ""+      (justIrregular $ MkIrregular (I    5) (I    True) "hi")+      (                MkIrregular (Just 5) (Just True) "hi")++test_gswap :: Assertion+test_gswap =+    assertEqual ""+      (swapMultiFun $ MkMultiFun (I        5) (Identity True) "hi")+      (               MkMultiFun (Identity 5) (I        True) "hi")++data Pair x = Pair x x+  deriving (Show, Eq)++test_gzipBeam :: Assertion+test_gzipBeam =+    assertEqual ""+      (unI (zipBeamFieldsM pairup parentTable parentTable))+      parentTable'+  where+    pairup :: Columnar' I x -> Columnar' I x -> I (Columnar' Pair x)+    pairup (Columnar' (I x)) (Columnar' (I y)) = I (Columnar' $ Pair x y)++    parentTable :: FullTable I+    parentTable = MkFullTable {+          fullTableField1 = PrimA (I 5)+        , fullTableField2 = I True+        , fullTableField3 = mixinTable+        }++    mixinTable :: MixinTable I+    mixinTable = MkMixinTable {+          mixinTableField1 = I 'x'+        , mixinTableField2 = I 3.14+        }++    parentTable' :: FullTable Pair+    parentTable' = MkFullTable {+          fullTableField1 = PrimA (Pair 5 5)+        , fullTableField2 = Pair True True+        , fullTableField3 = mixinTable'+        }++    mixinTable' :: MixinTable Pair+    mixinTable' = MkMixinTable {+          mixinTableField1 = Pair 'x' 'x'+        , mixinTableField2 = Pair 3.14 3.14+        }

@@ -0,0 +1,22 @@+module Main where++import Test.Tasty++import qualified Test.Record.Generic.Prop.Show+import qualified Test.Record.Generic.Prop.ToFromJSON+import qualified Test.Record.Generic.Sanity.GhcGenerics+import qualified Test.Record.Generic.Sanity.Laziness+import qualified Test.Record.Generic.Sanity.Lens.VL+import qualified Test.Record.Generic.Sanity.Rep+import qualified Test.Record.Generic.Sanity.Transform++main :: IO ()+main = defaultMain $ testGroup "TestLargeGenerics" [+      Test.Record.Generic.Sanity.Rep.tests+    , Test.Record.Generic.Sanity.Transform.tests+    , Test.Record.Generic.Sanity.GhcGenerics.tests+    , Test.Record.Generic.Sanity.Laziness.tests+    , Test.Record.Generic.Sanity.Lens.VL.tests+    , Test.Record.Generic.Prop.Show.tests+    , Test.Record.Generic.Prop.ToFromJSON.tests+    ]