diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for large-generics + +## 0.1.0.0 -- 2022-03-23 + +* First public release diff --git a/large-generics.cabal b/large-generics.cabal new file mode 100644 --- /dev/null +++ b/large-generics.cabal @@ -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" + . +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 diff --git a/src/Data/Record/Generic.hs b/src/Data/Record/Generic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic.hs @@ -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" + -- + -- 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 diff --git a/src/Data/Record/Generic/Eq.hs b/src/Data/Record/Generic/Eq.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic/Eq.hs @@ -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) diff --git a/src/Data/Record/Generic/GHC.hs b/src/Data/Record/Generic/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic/GHC.hs @@ -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 diff --git a/src/Data/Record/Generic/JSON.hs b/src/Data/Record/Generic/JSON.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic/JSON.hs @@ -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 diff --git a/src/Data/Record/Generic/Lens/VL.hs b/src/Data/Record/Generic/Lens/VL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic/Lens/VL.hs @@ -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) diff --git a/src/Data/Record/Generic/LowerBound.hs b/src/Data/Record/Generic/LowerBound.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic/LowerBound.hs @@ -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) diff --git a/src/Data/Record/Generic/Rep.hs b/src/Data/Record/Generic/Rep.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic/Rep.hs @@ -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 diff --git a/src/Data/Record/Generic/Rep/Internal.hs b/src/Data/Record/Generic/Rep/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic/Rep/Internal.hs @@ -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 . +-- I haven't actually seen this fail in large-records, but we saw it fail in +-- the compact representation branch of sop-core, and what we do here is not +-- so different, so better to play it safe. +noInlineUnsafeCo :: forall a b. a -> b +{-# NOINLINE noInlineUnsafeCo #-} +noInlineUnsafeCo = unsafeCoerce + diff --git a/src/Data/Record/Generic/SOP.hs b/src/Data/Record/Generic/SOP.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic/SOP.hs @@ -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) diff --git a/src/Data/Record/Generic/Show.hs b/src/Data/Record/Generic/Show.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic/Show.hs @@ -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 "}" + ) diff --git a/src/Data/Record/Generic/Transform.hs b/src/Data/Record/Generic/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic/Transform.hs @@ -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 diff --git a/test/Test/Record/Generic/Infra/Beam/Interpretation.hs b/test/Test/Record/Generic/Infra/Beam/Interpretation.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Generic/Infra/Beam/Interpretation.hs @@ -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)) + diff --git a/test/Test/Record/Generic/Infra/Beam/Mini.hs b/test/Test/Record/Generic/Infra/Beam/Mini.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Generic/Infra/Beam/Mini.hs @@ -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 + diff --git a/test/Test/Record/Generic/Infra/Examples.hs b/test/Test/Record/Generic/Infra/Examples.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Generic/Infra/Examples.hs @@ -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 + ] + } diff --git a/test/Test/Record/Generic/Infra/Util.hs b/test/Test/Record/Generic/Infra/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Generic/Infra/Util.hs @@ -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 + diff --git a/test/Test/Record/Generic/Prop/Show.hs b/test/Test/Record/Generic/Prop/Show.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Generic/Prop/Show.hs @@ -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 "" diff --git a/test/Test/Record/Generic/Prop/ToFromJSON.hs b/test/Test/Record/Generic/Prop/ToFromJSON.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Generic/Prop/ToFromJSON.hs @@ -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) diff --git a/test/Test/Record/Generic/Sanity/GhcGenerics.hs b/test/Test/Record/Generic/Sanity/GhcGenerics.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Generic/Sanity/GhcGenerics.hs @@ -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") + ] + diff --git a/test/Test/Record/Generic/Sanity/Laziness.hs b/test/Test/Record/Generic/Sanity/Laziness.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Generic/Sanity/Laziness.hs @@ -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 diff --git a/test/Test/Record/Generic/Sanity/Lens/VL.hs b/test/Test/Record/Generic/Sanity/Lens/VL.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Generic/Sanity/Lens/VL.hs @@ -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 + . +-------------------------------------------------------------------------------} + +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 + } diff --git a/test/Test/Record/Generic/Sanity/Rep.hs b/test/Test/Record/Generic/Sanity/Rep.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Generic/Sanity/Rep.hs @@ -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 + ] diff --git a/test/Test/Record/Generic/Sanity/Transform.hs b/test/Test/Record/Generic/Sanity/Transform.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Generic/Sanity/Transform.hs @@ -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 + } diff --git a/test/TestLargeGenerics.hs b/test/TestLargeGenerics.hs new file mode 100644 --- /dev/null +++ b/test/TestLargeGenerics.hs @@ -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 + ]