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-records + +## 0.1.0.0 -- 2021-08-19 + +* First public release diff --git a/large-records.cabal b/large-records.cabal new file mode 100644 --- /dev/null +++ b/large-records.cabal @@ -0,0 +1,206 @@ +cabal-version: 2.4 +name: large-records +version: 0.1.0.0 +synopsis: Efficient compilation for large records, linear in the size of the record +description: For many reasons, the internal code generated for modules + that contain records is quadratic in the number of record + fields. For large records (more than 30 fields, say), this + can become problematic, leading to large compilation times + and high memory requirements for ghc. The large-records + library provides a way to define records that is guaranteed + to result in ghc core that is /linear/ in the number of + record fields. +bug-reports: https://github.com/well-typed/large-records/issues +license: BSD-3-Clause +author: Edsko de Vries +maintainer: edsko@well-typed.com +category: Generics +extra-source-files: CHANGELOG.md + +source-repository head + type: git + location: https://github.com/well-typed/large-records + +library + exposed-modules: Data.Record.Generic + Data.Record.Generic.Eq + Data.Record.Generic.GHC + Data.Record.Generic.JSON + Data.Record.Generic.Lens.Micro + Data.Record.Generic.LowerBound + Data.Record.Generic.Rep + Data.Record.Generic.Rep.Internal + Data.Record.Generic.Show + Data.Record.Generic.SOP + Data.Record.Generic.Transform + + Data.Record.QQ.CodeGen + Data.Record.QQ.CodeGen.HSE + Data.Record.QQ.CodeGen.Parser + Data.Record.QQ.Runtime.MatchHasField + + Data.Record.TH + Data.Record.TH.CodeGen + Data.Record.TH.CodeGen.Tree + Data.Record.TH.Config.Options + Data.Record.TH.Runtime + + Data.Record.Internal.CodeGen + Data.Record.Internal.Naming + Data.Record.Internal.Record + Data.Record.Internal.Record.Parser + Data.Record.Internal.Record.Resolution + Data.Record.Internal.Record.Resolution.GHC + Data.Record.Internal.Record.Resolution.Internal + Data.Record.Internal.TH.Name + Data.Record.Internal.TH.Util + Data.Record.Internal.Util + + build-depends: base >=4.13 && < 4.15 + , aeson + , containers + , generics-sop + , haskell-src-exts + , haskell-src-meta + , microlens + , mtl + , record-hasfield + , sop-core + , syb + , template-haskell + , text + , vector + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: NoStarIsType + ghc-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -Wredundant-constraints + -Wmissing-export-lists + +test-suite test-large-records + type: exitcode-stdio-1.0 + main-is: TestLargeRecords.hs + other-modules: Test.Record.Prop.Show + Test.Record.Prop.Show.Regular + Test.Record.Prop.Show.Large + Test.Record.Prop.ToFromJSON + Test.Record.Sanity.Derive + Test.Record.Sanity.EqualFieldTypes + Test.Record.Sanity.ErrorsAndWarnings + Test.Record.Sanity.ErrorsAndWarnings.Stage1 + Test.Record.Sanity.Generics + Test.Record.Sanity.GhcGenerics + Test.Record.Sanity.HigherKinded + Test.Record.Sanity.HKD + Test.Record.Sanity.Laziness + Test.Record.Sanity.Lens.Micro + Test.Record.Sanity.OverloadingNoDRF + Test.Record.Sanity.PatternMatch + Test.Record.Sanity.QualifiedImports + Test.Record.Sanity.QualifiedImports.A + Test.Record.Sanity.QualifiedImports.B + Test.Record.Sanity.RecordConstruction + Test.Record.Sanity.Strictness + Test.Record.Sanity.Transform + Test.Record.Size.After.HK010 + Test.Record.Size.After.R0010 + Test.Record.Size.Before.Baseline + Test.Record.Size.Before.R010 + Test.Record.Size.Infra + Test.Record.Size.Sanity + Test.Record.Util + + build-depends: base + , aeson + , generics-sop + , json-sop + , generic-deriving + -- TODO: Remove: + , ghc-dump-core + , large-records + , newtype + , microlens + , mtl + , record-dot-preprocessor + , record-hasfield + , sop-core + , tasty + , tasty-hunit + , tasty-quickcheck + , template-haskell + , transformers + , vector + , QuickCheck + build-tool-depends: record-dot-preprocessor:record-dot-preprocessor + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + -Wcompat + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -Wpartial-fields + -Widentities + -- Needed for the AllZip tests + -freduction-depth=2000 + + if flag(profile-allzip) + cpp-options: -DPROFILE_ALLZIP + + if flag(use-ghc-dump) + cpp-options: -DUSE_GHC_DUMP + build-depends: ghc-dump-core + + if flag(build-all-modules) + other-modules: Test.Record.Size.After.HK020 + Test.Record.Size.After.HK030 + Test.Record.Size.After.HK040 + Test.Record.Size.After.HK050 + Test.Record.Size.After.HK060 + Test.Record.Size.After.HK070 + Test.Record.Size.After.HK080 + Test.Record.Size.After.HK090 + Test.Record.Size.After.HK100 + Test.Record.Size.After.R0020 + Test.Record.Size.After.R0030 + Test.Record.Size.After.R0040 + Test.Record.Size.After.R0050 + Test.Record.Size.After.R0060 + Test.Record.Size.After.R0070 + Test.Record.Size.After.R0080 + Test.Record.Size.After.R0090 + Test.Record.Size.After.R0100 + Test.Record.Size.After.R0200 + Test.Record.Size.After.R0300 + Test.Record.Size.After.R0400 + Test.Record.Size.After.R0500 + Test.Record.Size.After.R0600 + Test.Record.Size.After.R0700 + Test.Record.Size.After.R0800 + Test.Record.Size.After.R0900 + Test.Record.Size.After.R1000 + Test.Record.Size.Before.R020 + Test.Record.Size.Before.R030 + Test.Record.Size.Before.R040 + Test.Record.Size.Before.R050 + Test.Record.Size.Before.R060 + Test.Record.Size.Before.R070 + Test.Record.Size.Before.R080 + Test.Record.Size.Before.R090 + Test.Record.Size.Before.R100 + +Flag build-all-modules + Description: Build all test modules in Size + Default: False + +Flag use-ghc-dump + Description: use ghc-dump to output AST sizes + Default: False + +Flag profile-allzip + Description: Include experiment to verify size of AllZip is linear + Default: False 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,100 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Record.Generic ( + -- * Types with a generic view + Generic(..) + , Rep(..) -- TODO: Make opaque? + -- * Metadata + , Metadata(..) + , FieldStrictness(..) + , recordFieldNames + , FieldMetadata(..) + -- * Working with type-level metadata + , FieldName + , FieldType + , IsField + -- * Re-exports + , module SOP + , Proxy(..) + ) where + +import Data.Kind +import Data.Proxy +import GHC.TypeLits + +-- To reduce overlap between the two libraries and improve interoperability, +-- we import as much from sop-core as possible. +import Data.SOP.BasicFunctors as SOP +import Data.SOP.Classes as SOP (type (-.->)(..)) +import Data.SOP.Dict as SOP (Dict(..)) + +import Data.Record.Generic.Rep.Internal (Rep(..)) + +import qualified Data.Record.Generic.Rep.Internal as Rep + +{------------------------------------------------------------------------------- + Generic type class +-------------------------------------------------------------------------------} + +class Generic a where + -- | @Constraints a c@ means "all fields of @a@ satisfy @c@" + type Constraints a :: (Type -> Constraint) -> Constraint + + -- | Type-level metadata + type MetadataOf a :: [(Symbol, Type)] + + -- | Translate to generic representation + from :: a -> Rep I a + + -- | Translate from generic representation + to :: Rep I a -> a + + -- | Construct vector of dictionaries, one for each field of the record + dict :: Constraints a c => Proxy c -> Rep (Dict c) a + + -- | Metadata + metadata :: proxy a -> Metadata a + +{------------------------------------------------------------------------------- + Metadata +-------------------------------------------------------------------------------} + +data Metadata a = Metadata { + recordName :: String + , recordConstructor :: String + , recordSize :: Int + , recordFieldMetadata :: Rep FieldMetadata a + } + +data FieldStrictness = FieldStrict | FieldLazy + +data FieldMetadata x where + FieldMetadata :: + KnownSymbol name + => Proxy name + -> FieldStrictness + -> FieldMetadata x + +recordFieldNames :: Metadata a -> Rep (K String) a +recordFieldNames = Rep.map' aux . recordFieldMetadata + where + aux :: FieldMetadata x -> K String x + aux (FieldMetadata p _) = K $ symbolVal p + +{------------------------------------------------------------------------------- + Working with the type-level metadata +-------------------------------------------------------------------------------} + +type family FieldName (field :: (Symbol, Type)) :: Symbol where + FieldName '(name, _typ) = name + +type family FieldType (field :: (Symbol, Type)) :: Type where + FieldType '(_name, typ) = typ + +class (field ~ '(FieldName field, FieldType field)) => IsField field +instance (field ~ '(FieldName field, FieldType field)) => IsField field 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,45 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | Generic conversion to/from JSON +module Data.Record.Generic.JSON ( + gtoJSON + , gparseJSON + ) where + +import Data.Aeson +import Data.Aeson.Types +import Data.Proxy + +import qualified Data.Text as Text + +import Data.Record.Generic +import qualified Data.Record.Generic.Rep as Rep + +gtoJSON :: forall a. (Generic a, Constraints a ToJSON) => a -> Value +gtoJSON = + object + . Rep.collapse + . Rep.zipWith (mapKKK $ \n x -> (Text.pack n, x)) (recordFieldNames md) + . Rep.cmap (Proxy @ToJSON) (K . toJSON . unI) + . from + where + md = metadata (Proxy @a) + +gparseJSON :: forall a. (Generic a, Constraints a FromJSON) => Value -> Parser a +gparseJSON = + withObject (recordName md) (fmap to . Rep.sequenceA . aux) + where + md = metadata (Proxy @a) + + aux :: Object -> Rep (Parser :.: I) a + aux obj = + Rep.cmap + (Proxy @FromJSON) + (\(K fld) -> Comp (I <$> getField fld)) + (recordFieldNames md) + where + getField :: FromJSON x => String -> Parser x + getField fld = obj .: Text.pack fld diff --git a/src/Data/Record/Generic/Lens/Micro.hs b/src/Data/Record/Generic/Lens/Micro.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Generic/Lens/Micro.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE QuantifiedConstraints #-} + +module Data.Record.Generic.Lens.Micro ( + -- * Lenses for records + SimpleRecordLens(..) + , HKRecordLens(..) + , RegularRecordLens(..) + , lensesForSimpleRecord + , lensesForHKRecord + , lensesForRegularRecord + -- * Regular records + , RegularField(..) + , IsRegularField(..) + -- * Lenses into 'Rep' + , RepLens(..) + , repLenses + -- * General purpose lenses + , genericLens + , normalForm1Lens + , interpretedLens + , standardInterpretationLens + ) where + +import Data.Kind +import Lens.Micro (Lens') + +import Data.Record.Generic +import Data.Record.Generic.Transform + +import qualified Data.Record.Generic.Rep as Rep + +{------------------------------------------------------------------------------- + Simple records (in contrast to higher-kinded records, see below) +-------------------------------------------------------------------------------} + +data SimpleRecordLens a b where + SimpleRecordLens :: Lens' a b -> SimpleRecordLens a b + +-- | Construct lenses for each field in the record +-- +-- NOTE: This is of limited use since we cannot pattern match on the resulting +-- 'Rep' in any meaningful way. It is possible to go through the SOP adapter, +-- but if we do, we incur quadratic cost again. +-- +-- We can do better for higher-kinded records, and better still for regular +-- higher-kinded records. See 'lensesForHKRecord' and 'lensesForRegularRecord'. +lensesForSimpleRecord :: forall a. Generic a => Rep (SimpleRecordLens a) a +lensesForSimpleRecord = + Rep.map (\(RepLens l) -> SimpleRecordLens $ \f -> aux l f) repLenses + where + aux :: Lens' (Rep I a) (I x) -> Lens' a x + aux l f a = to <$> l (\(I x) -> I <$> f x) (from a) + +{------------------------------------------------------------------------------- + Higher-kinded records (records with a functor parameter) +-------------------------------------------------------------------------------} + +-- | Lens for higher-kinded record +-- +-- See 'lensesForHKRecord' for details. +data HKRecordLens d (f :: Type -> Type) tbl x where + HKRecordLens :: Lens' (tbl f) (Interpret (d f) x) -> HKRecordLens d f tbl x + +-- | Lenses for higher-kinded records +-- +-- NOTE: The lenses constructed by this function are primarily intended for +-- further processing, either by 'lensesForRegularRecord' or using application +-- specific logic. Details below. +-- +-- Suppose we have a record @tbl f@ which is indexed by a functor @f@, and we +-- want to construct lenses from @tbl f@ to each field in the record. Using the +-- @Transform@ infrastructure, we can construct a lens +-- +-- > tbl f ~~> Rep I (tbl f) ~~> Rep (Interpret (d f)) (tbl Uninterpreted) +-- +-- Using 'repLenses' we can construct a lens of type +-- +-- > Rep (Interpret (d f)) (tbl Uninterpreted) ~~> Interpret (d f) x +-- +-- for every field of type @x@. Putting these two together gives us a lens +-- +-- > tbl f ~~> Interpret (d f) x +-- +-- for every field in @tbl Uninterpreted@. We cannot simplify this, because we +-- do not know anything about the shape of @x@; specifically, it might not be +-- equal to @Uninterpreted x'@ for some @x'@, and hence we cannot simplify the +-- target type of the lens. We can do better for records with regular fields; +-- see 'lensesForRegularRecord'. +lensesForHKRecord :: forall d tbl f. + ( Generic (tbl f) + , Generic (tbl Uninterpreted) + , HasNormalForm (d f) (tbl f) (tbl Uninterpreted) + ) + => Proxy d -> Rep (HKRecordLens d f tbl) (tbl Uninterpreted) +lensesForHKRecord d = Rep.map aux fromRepLenses + where + fromRepLenses :: Rep (RepLens (Interpret (d f)) (tbl Uninterpreted)) (tbl Uninterpreted) + fromRepLenses = repLenses + + aux :: forall x. RepLens (Interpret (d f)) (tbl Uninterpreted) x -> HKRecordLens d f tbl x + aux (RepLens l) = HKRecordLens $ + genericLens + . normalForm1Lens d + . l + +{------------------------------------------------------------------------------- + Regular records +-------------------------------------------------------------------------------} + +-- | Proof that @x@ is a regular field +-- +-- See 'IsRegularField' +data RegularField f x where + RegularField :: RegularField f (f x) + +-- | Regular record fields +-- +-- For a higher-kinded record @tbl f@, parameterized over some functor @f@, +-- we say that the fields are /regular/ iff every field has the form @f x@ +-- for some @x@. +class IsRegularField f x where + isRegularField :: Proxy (f x) -> RegularField f x + +instance IsRegularField f (f x) where + isRegularField _ = RegularField + +{------------------------------------------------------------------------------- + Lenses into regular records +-------------------------------------------------------------------------------} + +-- | Lens into a regular record +-- +-- See 'lensesForRegularRecord' +data RegularRecordLens tbl f x where + RegularRecordLens :: Lens' (tbl f) (f x) -> RegularRecordLens tbl f x + +-- | Lenses into higher-kinded records with regular fields +-- +-- We can use 'lensesForHKRecord' to construct a 'Rep' of lenses into a higher-kinded +-- record. If in addition the record is regular, we can use the record type +-- /itself/ to store all the lenses. +lensesForRegularRecord :: forall d tbl f. + ( Generic (tbl (RegularRecordLens tbl f)) + , Generic (tbl Uninterpreted) + , Generic (tbl f) + , HasNormalForm (d (RegularRecordLens tbl f)) (tbl (RegularRecordLens tbl f)) (tbl Uninterpreted) + , HasNormalForm (d f) (tbl f) (tbl Uninterpreted) + , Constraints (tbl Uninterpreted) (IsRegularField Uninterpreted) + , StandardInterpretation d (RegularRecordLens tbl f) + , StandardInterpretation d f + ) + => Proxy d -> tbl (RegularRecordLens tbl f) +lensesForRegularRecord d = to . denormalize1 d $ + Rep.cmap + (Proxy @(IsRegularField Uninterpreted)) + aux + (lensesForHKRecord d) + where + aux :: forall x. + IsRegularField Uninterpreted x + => HKRecordLens d f tbl x + -> Interpret (d (RegularRecordLens tbl f)) x + aux (HKRecordLens l) = + case isRegularField (Proxy @(Uninterpreted x)) of + RegularField -> toStandardInterpretation d $ RegularRecordLens $ + l . standardInterpretationLens d + +{------------------------------------------------------------------------------- + Lenses into 'Rep' +-------------------------------------------------------------------------------} + +data RepLens f a x where + RepLens :: Lens' (Rep f a) (f x) -> RepLens f a x + +repLenses :: Generic a => Rep (RepLens f a) a +repLenses = Rep.map aux Rep.allIndices + where + aux :: Rep.Index a x -> RepLens f a x + aux ix = RepLens $ Rep.updateAtIndex ix + +{------------------------------------------------------------------------------- + General purpose lenses +-------------------------------------------------------------------------------} + +genericLens :: Generic a => Lens' a (Rep I a) +genericLens f a = to <$> f (from a) + +normalForm1Lens :: + HasNormalForm (d f) (x f) (x Uninterpreted) + => Proxy d + -> Lens' (Rep I (x f)) (Rep (Interpret (d f)) (x Uninterpreted)) +normalForm1Lens p f a = denormalize1 p <$> f (normalize1 p a) + +interpretedLens :: Lens' (Interpret d x) (Interpreted d x) +interpretedLens f (Interpret x) = Interpret <$> f x + +standardInterpretationLens :: forall d f x. + StandardInterpretation d f + => Proxy d + -> Lens' (Interpret (d f) (Uninterpreted x)) (f x) +standardInterpretationLens p f x = + toStandardInterpretation p <$> + f (fromStandardInterpretation p x) 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,210 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Operations on the generic representation +-- +-- We also re-export some non-derive functions to clarify where they belong +-- in this list. +-- +-- This module is intended for qualified import. +-- +-- > import qualified Data.Record.Generic.Rep as Rep +-- +-- TODO: Could we provide instances for the @generics-sop@ type classes? +-- Might lessen the pain of switching between the two or using both? +module Data.Record.Generic.Rep ( + Rep(..) -- TODO: Make opaque? + -- * "Functor" + , map + , mapM + , cmap + , cmapM + -- * Zipping + , zip + , zipWith + , zipWithM + , czipWith + , czipWithM + -- * "Foldable" + , collapse + -- * "Traversable" + , sequenceA + -- * "Applicable" + , pure + , cpure + , ap + -- * Array-like interface + , Index -- opaque + , indexToInt + , getAtIndex + , putAtIndex + , updateAtIndex + , allIndices + , mapWithIndex + ) where + +import Prelude hiding ( + map + , mapM + , pure + , sequenceA + , zip + , zipWith + ) + +import Data.Proxy +import Data.Functor.Identity +import Data.Functor.Product +import Data.SOP.Classes (fn_2) +import Unsafe.Coerce (unsafeCoerce) + +import qualified Data.Vector as V + +import Data.Record.Generic +import Data.Record.Generic.Rep.Internal + +-- +-- NOTE: In order to avoid circular definitions, this module is strictly defined +-- in order: every function only depends on the functions defined before it. To +-- enforce this, we make use of 'compileToHere' to force ghc to compile the +-- module to that point. +-- + +{------------------------------------------------------------------------------- + Array-like interface +-------------------------------------------------------------------------------} + +newtype Index a x = UnsafeIndex Int + +indexToInt :: Index a x -> Int +indexToInt (UnsafeIndex ix) = ix + +getAtIndex :: Index a x -> Rep f a -> f x +getAtIndex (UnsafeIndex ix) (Rep v) = + unsafeCoerce $ V.unsafeIndex v ix + +putAtIndex :: Index a x -> f x -> Rep f a -> Rep f a +putAtIndex (UnsafeIndex ix) x (Rep v) = Rep $ + V.unsafeUpd v [(ix, unsafeCoerce x)] + +updateAtIndex :: + Functor m + => Index a x + -> (f x -> m (f x)) + -> Rep f a -> m (Rep f a) +updateAtIndex ix f a = (\x -> putAtIndex ix x a) <$> f (getAtIndex ix a) + +allIndices :: forall a. Generic a => Rep (Index a) a +allIndices = Rep $ V.generate (recordSize (metadata (Proxy @a))) UnsafeIndex + +-- | Map with index +-- +-- This is an important building block in this module. +-- Crucially, @mapWithIndex f a@ is lazy in @a@, reading elements from @a@ +-- only if and when @f@ demands them. +mapWithIndex :: + forall f g a. Generic a + => (forall x. Index a x -> f x -> g x) + -> Rep f a -> Rep g a +mapWithIndex f as = map' f' allIndices + where + f' :: Index a x -> g x + f' ix = f ix (getAtIndex ix as) +compileToHere -- =============================================================== + +{------------------------------------------------------------------------------- + "Applicative" +-------------------------------------------------------------------------------} + +pure :: forall f a. Generic a => (forall x. f x) -> Rep f a +pure = Rep . V.replicate (recordSize (metadata (Proxy @a))) + +cpure :: + (Generic a, Constraints a c) + => Proxy c + -> (forall x. c x => f x) + -> Rep f a +cpure p f = map' (\Dict -> f) (dict p) + +-- | Higher-order version of @<*>@ +-- +-- Lazy in the second argument. +ap :: forall f g a. Generic a => Rep (f -.-> g) a -> Rep f a -> Rep g a +ap fs as = mapWithIndex f' fs + where + f' :: Index a x -> (-.->) f g x -> g x + f' ix f = f `apFn` getAtIndex ix as + +compileToHere -- =============================================================== + +{------------------------------------------------------------------------------- + "Functor" +-------------------------------------------------------------------------------} + +map :: Generic a => (forall x. f x -> g x) -> Rep f a -> Rep g a +map f = mapWithIndex (const f) + +mapM :: + (Applicative m, Generic a) + => (forall x. f x -> m (g x)) + -> Rep f a -> m (Rep g a) +mapM f = sequenceA . mapWithIndex (const (Comp . f)) + +cmap :: + (Generic a, Constraints a c) + => Proxy c + -> (forall x. c x => f x -> g x) + -> Rep f a -> Rep g a +cmap p f = ap $ cpure p (Fn f) + +cmapM :: + forall m f g c a. (Generic a, Applicative m, Constraints a c) + => Proxy c + -> (forall x. c x => f x -> m (g x)) + -> Rep f a -> m (Rep g a) +cmapM p f = sequenceA . cmap p (Comp . f) + +compileToHere -- =============================================================== + +{------------------------------------------------------------------------------- + Zipping +-------------------------------------------------------------------------------} + +zipWithM :: + forall m f g h a. (Generic a, Applicative m) + => (forall x. f x -> g x -> m (h x)) + -> Rep f a -> Rep g a -> m (Rep h a) +zipWithM f a b = sequenceA $ + pure (fn_2 $ \x y -> Comp $ f x y) `ap` a `ap` b + +zipWith :: + Generic a + => (forall x. f x -> g x -> h x) + -> Rep f a -> Rep g a -> Rep h a +zipWith f a b = runIdentity $ + zipWithM (\x y -> Identity $ f x y) a b + +zip :: Generic a => Rep f a -> Rep g a -> Rep (Product f g) a +zip = zipWith Pair + +czipWithM :: + forall m f g h c a. (Generic a, Applicative m, Constraints a c) + => Proxy c + -> (forall x. c x => f x -> g x -> m (h x)) + -> Rep f a -> Rep g a -> m (Rep h a) +czipWithM p f a b = sequenceA $ + cpure p (fn_2 $ \x y -> Comp $ f x y) `ap` a `ap` b + +czipWith :: + (Generic a, Constraints a c) + => Proxy c + -> (forall x. c x => f x -> g x -> h x) + -> Rep f a -> Rep g a -> Rep h a +czipWith p f a b = runIdentity $ + czipWithM p (\x y -> Identity (f x y)) a b + +compileToHere -- =============================================================== 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,91 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} + +-- | Definition of 'Rep' and functions that do not depend on ".Generic" +-- +-- Defined as a separate module to avoid circular module dependencies. +module Data.Record.Generic.Rep.Internal ( + Rep(..) + -- * Basic functions + , map' + , sequenceA + -- * Conversion + , unsafeFromList + , collapse + -- * Utility (for use in @.Rep@) + , compileToHere + ) where + +import Prelude hiding (sequenceA) +import qualified Prelude + +import Data.Coerce (coerce) +import Data.SOP.BasicFunctors +import Data.Vector (Vector) +import GHC.Exts (Any) +import Language.Haskell.TH + +import qualified Data.Vector as V + +{------------------------------------------------------------------------------- + Representation +-------------------------------------------------------------------------------} + +-- | Representation of some record @a@ +-- +-- The @f@ parameter describes which functor has been applied to all fields of +-- the record; in other words @Rep I@ is isomorphic to the record itself. +newtype Rep f a = Rep (Vector (f Any)) + +type role Rep representational nominal + +{------------------------------------------------------------------------------- + Basic functions +-------------------------------------------------------------------------------} + +-- | Strict map +-- +-- @map' f x@ is strict in @x@: if @x@ is undefined, @map f x@ will also be +-- undefined, even if @f@ never needs any values from @x@. +map' :: (forall x. f x -> g x) -> Rep f a -> Rep g a +map' f (Rep v) = Rep $ f <$> v + +sequenceA :: Applicative m => Rep (m :.: f) a -> m (Rep f a) +sequenceA (Rep v) = Rep <$> Prelude.sequenceA (fmap unComp v) + +{------------------------------------------------------------------------------- + Conversion +-------------------------------------------------------------------------------} + +collapse :: Rep (K a) b -> [a] +collapse (Rep v) = coerce (V.toList v) + +-- | Convert list to 'Rep' +-- +-- Does not check that the length has the right number of elements. +unsafeFromList :: [b] -> Rep (K b) a +unsafeFromList = Rep . V.fromList . Prelude.map K + +{------------------------------------------------------------------------------- + Some specialised instances for 'Rep +-------------------------------------------------------------------------------} + +instance Show x => Show (Rep (K x) a) where + show (Rep v) = + show $ Prelude.map unK (V.toList v) + +instance Eq x => Eq (Rep (K x) a) where + Rep v == Rep v' = + Prelude.map unK (V.toList v) + == Prelude.map unK (V.toList v') + +{------------------------------------------------------------------------------- + Internal utility +-------------------------------------------------------------------------------} + +compileToHere :: Q [Dec] +compileToHere = return [] 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.TH.Runtime (noInlineUnsafeCo) + +{------------------------------------------------------------------------------- + Conversion back and forth to generics-sop records + + NOTE: We do /not/ require @SListI (MetadataOf a)@ by default, as this would + result in quadratic blow-up again. This is only required in this module for + SOP interop. + + NOTE: We don't currently use @records-sop@, despite it being a /near/ perfect + fit. The problem is that @records-sop@ is not generalized over a functor, + which would make these functions less general than we need them to be. +-------------------------------------------------------------------------------} + +newtype Field (f :: Type -> Type) (field :: (Symbol, Type)) where + Field :: f (FieldType field) -> Field f field + +deriving instance Show (f x) => Show (Field f '(nm, x)) +deriving instance Eq (f x) => Eq (Field f '(nm, x)) + +fromSOP :: SListI (MetadataOf a) => NP (Field f) (MetadataOf a) -> Rep f a +fromSOP = + Rep . V.fromList . SOP.hcollapse . SOP.hmap conv + where + conv :: Field f field -> K (f Any) field + conv (Field fx) = K $ noInlineUnsafeCo fx + +toSOP :: SListI (MetadataOf a) => Rep f a -> Maybe (NP (Field f) (MetadataOf a)) +toSOP (Rep v) = + SOP.hmap conv <$> SOP.fromList (V.toList v) + where + conv :: K (f Any) field -> Field f field + conv (K fx) = Field (noInlineUnsafeCo fx) + +{------------------------------------------------------------------------------- + Translate constraints +-------------------------------------------------------------------------------} + +-- | Translate constraints +-- +-- When using 'toSOP', if you start with something of type +-- +-- > Rep f a +-- +-- you end up with something of type +-- +-- > NP (Field f) (MetadataOf a) +-- +-- When doing so, 'toDictAll' can translate +-- +-- > Constraints a (Compose c f) +-- +-- (which is useful over the original representation) to +-- +-- > All (Compose c (Field f)) (MetadataOf a) +-- +-- which is useful for the translated representation. +toDictAll :: + forall f a c. + ( Generic a + , Constraints a (Compose c f) + , All IsField (MetadataOf a) + , forall nm x. c (f x) => c (Field f '(nm, x)) + ) + => Proxy f + -> Proxy a + -> Proxy c + -> Dict (All (Compose c (Field f))) (MetadataOf a) +toDictAll _ _ _ = + case toSOP dictT of + Nothing -> error "toDictAll: invalid dictionary" + Just d -> all_NP (SOP.hcmap (Proxy @IsField) conv d) + where + dictT :: Rep (Dict (Compose c f)) a + dictT = dict (Proxy @(Compose c f)) + + conv :: IsField field + => Field (Dict (Compose c f)) field + -> Dict (Compose c (Field f)) field + conv (Field Dict) = Dict + +{------------------------------------------------------------------------------- + Additional SOP generic functions +-------------------------------------------------------------------------------} + +glowerBound :: (SOP.Generic a, All LowerBound xs, Code a ~ '[xs]) => a +glowerBound = SOP.to . SOP . Z $ SOP.hcpure (Proxy @LowerBound) (I lowerBound) diff --git a/src/Data/Record/Generic/Show.hs b/src/Data/Record/Generic/Show.hs 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,174 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UndecidableSuperClasses #-} + +-- The 'HasNormalForm' constraint on 'normalize' and 'denormalize' is +-- redundant as far as ghc is concerned (it's just 'unsafeCoerce' after all), +-- but essential for type safety of these two functions. +{-# OPTIONS_GHC -Wno-redundant-constraints #-} + +module Data.Record.Generic.Transform ( + -- * Interpretation function + Interpreted + , Interpret(..) + -- ** Working with the 'Interpreted' newtype wrapper + , liftInterpreted + , liftInterpretedA2 + -- * Normal form + -- ** Existence + , HasNormalForm + , InterpretTo + , IfEqual + -- ** Construction + , normalize + , denormalize + -- ** Specialized forms for the common case of a single type argument + , Uninterpreted + , DefaultInterpretation + , normalize1 + , denormalize1 + -- ** Generalization of the default interpretation + , StandardInterpretation(..) + , toStandardInterpretation + , fromStandardInterpretation + ) where + +import Data.Coerce +import Data.Kind +import Data.Proxy +import Data.SOP.BasicFunctors +import GHC.TypeLits +import Unsafe.Coerce (unsafeCoerce) + +import Data.Record.Generic + +{------------------------------------------------------------------------------- + Interpretation function +-------------------------------------------------------------------------------} + +type family Interpreted (d :: dom) (x :: Type) :: Type + +newtype Interpret d x = Interpret (Interpreted d x) + +{------------------------------------------------------------------------------- + Working with the 'Interpreted' newtype wrapper +-------------------------------------------------------------------------------} + +liftInterpreted :: + (Interpreted dx x -> Interpreted dy y) + -> (Interpret dx x -> Interpret dy y) +liftInterpreted f (Interpret x) = Interpret (f x) + +liftInterpretedA2 :: + Applicative m + => (Interpreted dx x -> Interpreted dy y -> m (Interpreted dz z)) + -> (Interpret dx x -> Interpret dy y -> m (Interpret dz z)) +liftInterpretedA2 f (Interpret x) (Interpret y) = Interpret <$> f x y + +{------------------------------------------------------------------------------- + Normal forms +-------------------------------------------------------------------------------} + +type HasNormalForm d x y = InterpretTo d (MetadataOf x) (MetadataOf y) + +type family InterpretTo d xs ys :: Constraint where + InterpretTo _ '[] '[] = () + InterpretTo d ('(f, x) ': xs) ('(f, y) ': ys) = IfEqual x (Interpreted d y) + (InterpretTo d xs ys) + +type family IfEqual x y (r :: k) :: k where + IfEqual actual actual k = k + IfEqual expected actual k = TypeError ( + 'Text "Expected " + ':<>: 'ShowType expected + ':<>: 'Text " but got " + ':<>: 'ShowType actual + ) + +-- | Construct normal form +-- +-- TODO: Documentation. +normalize :: + HasNormalForm d x y + => Proxy d + -> Proxy y + -> Rep I x -> Rep (Interpret d) y +normalize _ _ = unsafeCoerce + +denormalize :: + HasNormalForm d x y + => Proxy d + -> Proxy y + -> Rep (Interpret d) y -> Rep I x +denormalize _ _ = unsafeCoerce + +{------------------------------------------------------------------------------- + Specialized forms for the common case of a single type argument + + The test ("Test.Record.Sanity.Transform") shows an example with two arguments. +-------------------------------------------------------------------------------} + +data Uninterpreted x + +data DefaultInterpretation (f :: Type -> Type) + +type instance Interpreted (DefaultInterpretation f) (Uninterpreted x) = f x + +normalize1 :: forall d f x. + HasNormalForm (d f) (x f) (x Uninterpreted) + => Proxy d + -> Rep I (x f) -> Rep (Interpret (d f)) (x Uninterpreted) +normalize1 _ = normalize (Proxy @(d f)) (Proxy @(x Uninterpreted)) + +denormalize1 :: forall d f x. + HasNormalForm (d f) (x f) (x Uninterpreted) + => Proxy d + -> Rep (Interpret (d f)) (x Uninterpreted) -> Rep I (x f) +denormalize1 _ = denormalize (Proxy @(d f)) (Proxy @(x Uninterpreted)) + +{------------------------------------------------------------------------------- + Generalization of the default interpretation +-------------------------------------------------------------------------------} + +class StandardInterpretation d f where + standardInterpretation :: + Proxy d + -> ( Interpreted (d f) (Uninterpreted x) -> f x + , f x -> Interpreted (d f) (Uninterpreted x) + ) + + default standardInterpretation :: + Coercible (Interpreted (d f) (Uninterpreted x)) (f x) + => Proxy d + -> ( Interpreted (d f) (Uninterpreted x) -> f x + , f x -> Interpreted (d f) (Uninterpreted x) + ) + standardInterpretation _ = (coerce, coerce) + +instance StandardInterpretation DefaultInterpretation f + +toStandardInterpretation :: forall d f x. + StandardInterpretation d f + => Proxy d + -> f x -> Interpret (d f) (Uninterpreted x) +toStandardInterpretation d fx = Interpret $ + snd (standardInterpretation d) fx + +fromStandardInterpretation :: forall d f x. + StandardInterpretation d f + => Proxy d + -> Interpret (d f) (Uninterpreted x) -> f x +fromStandardInterpretation d (Interpret fx) = + fst (standardInterpretation d) fx diff --git a/src/Data/Record/Internal/CodeGen.hs b/src/Data/Record/Internal/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/CodeGen.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | Code generation shared by TH and QQ +-- +-- Since these can also be used by QQ, these functions cannot take 'Options'. +module Data.Record.Internal.CodeGen ( + -- * Records + recordTypeE + , recordConstrE + , recordTypeT + , recordToVectorE + , recordFromVectorDontForceE + , recordIndexedAccessorE + , recordIndexedOverwriteE + , recordUndefinedValueE + -- * Fields + , fieldNameE + , fieldNameT + , fieldTypeT + , fieldIndexE + , fieldUntypedAccessorE + , fieldUntypedOverwriteE + ) where + +import Language.Haskell.TH + +import Data.Record.Internal.Naming +import Data.Record.Internal.Record +import Data.Record.Internal.TH.Util + +import qualified Data.Record.Internal.TH.Name as N hiding (unqualified) + +{------------------------------------------------------------------------------- + Records +-------------------------------------------------------------------------------} + +-- | Name of the record as a term-level literal +recordTypeE :: Record a -> Q Exp +recordTypeE = stringE . recordType + +-- | Name of the constructor as a term-level literal +recordConstrE :: Record a -> Q Exp +recordConstrE = stringE . recordConstr + +-- | The saturated type of the record (that is, with all type vars applied) +recordTypeT :: N.Qualifier -> Record a -> Q Type +recordTypeT qual Record{..} = + appsT (N.conT (N.qualify qual recordType)) $ map tyVarType recordTVars + +-- | Coerce the record to the underlying @Vector Any@ +recordToVectorE :: N.Qualifier -> Record a -> Q Exp +recordToVectorE qual = + N.varE . N.qualify qual . nameRecordInternalField . recordType + +-- | Construct record from the underlying @Vector Any@ +-- +-- This doesn't force any elements in the vector, so this can be used if +-- +-- * the record has lazy fields, or +-- * we know through other means that all values are already forced. +-- +-- See also 'recordFromVectorForceE'. +recordFromVectorDontForceE :: N.Qualifier -> Record a -> Q Exp +recordFromVectorDontForceE qual = + N.conE . N.qualify qual . nameRecordInternalConstr . recordConstr + +-- | The (unsafe) indexed field accessor +recordIndexedAccessorE :: N.Qualifier -> Record a -> Q Exp +recordIndexedAccessorE qual = + N.varE . N.qualify qual . nameRecordIndexedAccessor . recordType + +-- | The (unsafe) indexed field overwrite +recordIndexedOverwriteE :: N.Qualifier -> Record a -> Q Exp +recordIndexedOverwriteE qual = + N.varE . N.qualify qual . nameRecordIndexedOverwrite . recordType + +recordUndefinedValueE :: N.Qualifier -> Record a -> Q Exp +recordUndefinedValueE qual r = + [| $(recordFromVectorDontForceE qual r) undefined |] + +{------------------------------------------------------------------------------- + Record fields +-------------------------------------------------------------------------------} + +-- | Name of the field as a term-level literal +fieldNameE :: Field a -> Q Exp +fieldNameE = stringE . fieldName + +-- | Name of the field as a type-level literal +fieldNameT :: Field a -> Q Type +fieldNameT = litT . strTyLit . fieldName + +-- | Type of the field +fieldTypeT :: Field a -> Q Type +fieldTypeT Field{..} = return fieldType + +-- | Index of the field +fieldIndexE :: Field a -> Q Exp +fieldIndexE Field{..} = litE . integerL $ fromIntegral fieldIndex + +-- | The indexed field accessor, applied to this field +fieldUntypedAccessorE :: N.Qualifier -> Record a -> Field a -> Q Exp +fieldUntypedAccessorE qual r f = + [| $(recordIndexedAccessorE qual r) $(fieldIndexE f) |] + +-- | The indexed field overwrite, applied to this field +fieldUntypedOverwriteE :: N.Qualifier -> Record a -> Field a -> Q Exp +fieldUntypedOverwriteE qual r f = + [| $(recordIndexedOverwriteE qual r) $(fieldIndexE f) |] diff --git a/src/Data/Record/Internal/Naming.hs b/src/Data/Record/Internal/Naming.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Naming.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Names of the various things we generate +-- +-- This is used by both TH code generation and the quasi-quoter. +module Data.Record.Internal.Naming ( + -- * Names based on the constructor + nameRecordInternalConstr + , nameRecordTypedConstructorFn + -- * Names based on the type + , nameRecordConstraintsClass + , nameRecordConstraintsMethod + , nameRecordIndexedAccessor + , nameRecordIndexedOverwrite + , nameRecordInternalField + , nameRecordView + ) where + +{------------------------------------------------------------------------------- + Names based on the constructor +-------------------------------------------------------------------------------} + +-- | The name of the constructor used internally +-- +-- We must pick this so that +-- +-- 1. It is different from the user-written constructor (so that we can use that +-- name for the pattern synonym, /if/ we generate it) +-- +-- 2. It is derivable /from/ the user-written constructor, so that in, say, +-- +-- > [lr| MkR { x = 5, y = True } |] +-- +-- the quasi-quoter can figure out the name of the internal constructor +-- (provided that the constructor is in scope, but that's a reasonable +-- requirement). +nameRecordInternalConstr :: String -> String +nameRecordInternalConstr = ("LR__" ++) + +-- | Name of the record constructor function +-- +-- Unlike the internal constructor (which takes a @Vector Any@ as argument), +-- this function takes @n@ arguments, one for each record field, of the +-- appropriate types. +nameRecordTypedConstructorFn :: String -> String +nameRecordTypedConstructorFn = ("_construct_" ++) + +{------------------------------------------------------------------------------- + Names based on the type +-------------------------------------------------------------------------------} + +nameRecordConstraintsClass :: String -> String +nameRecordConstraintsMethod :: String -> String +nameRecordIndexedAccessor :: String -> String +nameRecordIndexedOverwrite :: String -> String +nameRecordInternalField :: String -> String +nameRecordView :: String -> String + +nameRecordConstraintsClass = ("Constraints_" ++) +nameRecordConstraintsMethod = ("dictConstraints_" ++) +nameRecordIndexedAccessor = ("unsafeGetIndex" ++) +nameRecordIndexedOverwrite = ("unsafeSetIndex" ++) +nameRecordInternalField = ("vectorFrom" ++) +nameRecordView = ("tupleFrom" ++) diff --git a/src/Data/Record/Internal/Record.hs b/src/Data/Record/Internal/Record.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Record.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Record.Internal.Record ( + -- * Record description + Record(..) + , Field(..) + -- * Combinators + , matchRecordFields + , dropMissingRecordFields + ) where + +import Control.Monad.State +import Data.List (sortBy) +import Data.Map (Map) +import Data.Maybe (mapMaybe) +import Data.Ord (comparing) +import Language.Haskell.TH + +import qualified Data.Map as Map +import qualified Data.Map.Merge.Lazy as Map + +{------------------------------------------------------------------------------- + Description +-------------------------------------------------------------------------------} + +-- | Record description +data Record a = Record { + -- | Record type name + recordType :: String + + -- | Record constructor name + , recordConstr :: String + + -- | Type variables in the records type + , recordTVars :: [TyVarBndr] + + -- | Fields in the record + , recordFields :: [Field a] + } + deriving stock (Show, Functor, Foldable, Traversable) + +-- | Record field description +data Field a = Field { + -- | Field name + fieldName :: String + + -- | Type of the field + , fieldType :: Type + + -- | Index of the field (field 0, field 1, ..) + -- + -- This is strictly speaking redundant information, as this is already + -- implied by the position of the field in 'recordFields'. However, since + -- we do a lot of positional processing (every field corresponds to a + -- vector element), it is convenient to have the index readily available. + , fieldIndex :: Int + + -- | Value associated with this field ('Nothing' if not present) + , fieldVal :: a + } + deriving stock (Show, Functor, Foldable, Traversable) + +{------------------------------------------------------------------------------- + Combinators +-------------------------------------------------------------------------------} + +-- | Match field values against field definitions +-- +-- We explicit mark missing fields; one use case for this is record +-- construction, where we want to issue a warning for missing fields. +matchRecordFields :: forall a b. + [(String, b)] + -> Record a + -> (Record (a, Maybe b), [String]) +matchRecordFields values r = ( + r { recordFields = sortBy (comparing fieldIndex) $ + Map.elems matched + } + , unknown + ) + where + given :: Map String b + given = Map.fromList values + + defined :: Map String (Field a) + defined = Map.fromList $ + map (\f -> (fieldName f, f)) (recordFields r) + + matched :: Map String (Field (a, Maybe b)) + unknown :: [String] + (matched, unknown) = flip runState [] $ + Map.mergeA + (Map.traverseMissing fieldMissing) + (Map.traverseMaybeMissing fieldUnknown) + (Map.zipWithAMatched fieldPresent) + defined + given + + fieldPresent :: String -> Field a -> b -> State [String] (Field (a, Maybe b)) + fieldMissing :: String -> Field a -> State [String] (Field (a, Maybe b)) + fieldUnknown :: String -> b -> State [String] (Maybe (Field (a, Maybe b))) + + fieldPresent _nm f a = return $ f { fieldVal = (fieldVal f, Just a) } + fieldMissing _nm f = return $ f { fieldVal = (fieldVal f, Nothing) } + fieldUnknown nm _a = modify (nm:) >> return Nothing + +dropMissingRecordFields :: Record (Maybe a) -> Record a +dropMissingRecordFields r = + r { recordFields = mapMaybe sequenceA (recordFields r) } diff --git a/src/Data/Record/Internal/Record/Parser.hs b/src/Data/Record/Internal/Record/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Record/Parser.hs @@ -0,0 +1,140 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Record.Internal.Record.Parser ( + RecordInstances(..) + , Deriving(..) + , parseRecordDef + ) where + +import Data.Either (partitionEithers) +import Data.Maybe (catMaybes) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Data.Record.Internal.Record +import Data.Record.Internal.TH.Util +import Data.Record.Internal.Util + +{------------------------------------------------------------------------------- + Record instances +-------------------------------------------------------------------------------} + +data RecordInstances = RecordInstances { + -- | Explicitly supported type class instances + recordInstancesDerived :: [Deriving] + + -- | Anyclass deriving + -- + -- We list these separately, because we need to add these as anyclass + -- deriving classes when defining the newtype, rather than as standalone + -- deriving instances. (If we don't, we need to duplicate ghc's logic for + -- figuring out how many parameters to provide to the datatype.) + , recordInstancesAnyclass :: [Type] + } + +data Deriving = + DeriveEq + | DeriveOrd + | DeriveShow + deriving (Show) + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +-- | Try to match a record declaration +-- +-- We use 'Maybe' in these matching functions, along with 'reportError', so that +-- we can report multiple errors rather than stopping at the first. +parseRecordDef :: Dec -> Q (Maybe (Record (), RecordInstances)) +parseRecordDef (DataD + _cxt@[] + typeName + tyVarBndrs + _kind@Nothing + [RecC constrName fieldTypes] + derivClauses + ) = do + + fields <- catMaybes <$> + mapM parseFieldDef (zip [0..] fieldTypes) + (deriv, anyclass) <- partitionEithers <$> + concatMapM parseDeriv derivClauses + + return $ Just ( + Record { + recordType = nameBase typeName + , recordConstr = nameBase constrName + , recordTVars = tyVarBndrs + , recordFields = fields + } + , RecordInstances { + recordInstancesDerived = deriv + , recordInstancesAnyclass = anyclass + } + ) +parseRecordDef d = do + reportError $ "Unsupported declaration: " ++ show d + return Nothing + +-- | Support deriving clauses +-- +-- We return the anyclass deriving clauses separately. +-- See 'recordAnyclass' for more details. +parseDeriv :: DerivClause -> Q [Either Deriving Type] +parseDeriv = \case + DerivClause Nothing cs -> + map Left <$> derivStock cs + DerivClause (Just StockStrategy) cs -> + map Left <$> derivStock cs + DerivClause (Just AnyclassStrategy) cs -> + return $ map Right cs + DerivClause strategy _ -> do + reportError $ "Unsupported deriving strategy " ++ show strategy + return [] + where + derivStock cs = catMaybes <$> mapM go cs + go :: Pred -> Q (Maybe Deriving) + go p | p == ConT ''Eq = return $ Just DeriveEq + | p == ConT ''Ord = return $ Just DeriveOrd + | p == ConT ''Show = return $ Just DeriveShow + | otherwise = do + reportError $ "Cannot derive instance for " ++ show p + return Nothing + +parseFieldDef :: (Int, VarBangType) -> Q (Maybe (Field ())) +parseFieldDef (i, (nm, bng, typ)) = + case bng of + DefaultBang -> + return . Just $ Field { + fieldName = unqualify nm + , fieldType = typ + , fieldIndex = i + , fieldVal = () + } + _otherwise -> do + reportError $ "Unsupported bang type: " ++ show bng + return Nothing + where + unqualify :: Name -> String + unqualify = undoDRF . nameBase + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +-- When @DuplicateRecordFields@ is enabled, it produces field names such as +-- @$sel:a:MkY@. We don't really care much about 'DuplicateRecordFields', +-- insofar as that we will not try to be compatible with DRF-style +-- overloading (all overloading must happen through 'HasField' instead). +-- We do however need to recover the original field name. +-- +-- +-- +undoDRF :: String -> String +undoDRF nm = + case nm of + '$' : drf -> takeWhile (/= ':') . tail . dropWhile (/= ':') $ drf + _otherwise -> nm diff --git a/src/Data/Record/Internal/Record/Resolution.hs b/src/Data/Record/Internal/Record/Resolution.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Record/Resolution.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} + +module Data.Record.Internal.Record.Resolution ( + resolveRecord + ) where + +import Language.Haskell.TH.Syntax (Quasi, NameSpace(..)) + +import Data.Record.Internal.Record + +import qualified Data.Record.Internal.Record.Resolution.GHC as GHC +import qualified Data.Record.Internal.Record.Resolution.Internal as Internal +import qualified Data.Record.Internal.TH.Name as N + +-- | Resolve record info +-- +-- When the quasi-quoter needs to turn +-- +-- > [lr| MkRecord { field2 = 5, field1 = True } |] +-- +-- into +-- +-- > _construct_MkRecord True 5 +-- +-- it needs to know the record definition: the types of all fields, and the +-- order of all fields. +-- +-- The primary means through which we achieve this is by looking up the +-- 'MetadataOf' type family instance for the record, and then parsing that +-- ('GHC.parseRecordInfo'). +-- +-- Unfortunately, however, this does not always work. In an example such as +-- +-- > largeRecord defaultPureScript [d| +-- > data SomeRecord = MkRecord { field1 :: Int, field2 :: Bool } +-- > |] +-- > +-- > foo :: SomeRecord +-- > foo = [lr| MkRecord { field1 = 5, field2 = True } |] +-- +-- the call to 'largeRecord' and the definition of @foo@ is considered to be a +-- single binding group (not entirely sure why). Both the 'largeRecord' splice +-- and the 'lr' quasi-quote are now run /before typechecking/, which is why when +-- we get to the 'lr' quasi-quote, the 'MetadataOf' instance is not yet +-- available, even though it /has/ been generated. +-- +-- One work-around is to insert an empty splice +-- +-- > largeRecord defaultPureScript [d| +-- > data SomeRecord = MkRecord { field1 :: Int, .. } +-- > |] +-- > +-- > $(return []) +-- > +-- > foo :: SomeRecord +-- > foo = [lr| MkRecord { field1 = 5, .. } |] +-- +-- That works (and we previously did that, giving that empty splice a name +-- @endOfBindingGroup@), but requiring this is bad for useability of the lib. +-- Most users probably don't know what binding groups even are, much less want +-- to think about the scope of each binding group: that's a task for @ghc@. +-- +-- Therefore, in addition to being able to parse the 'MetadataOf' instance, we +-- also maintain our own environment, mapping constructor names to record info +-- (see 'Internal.getRecordInfo'). The 'largeRecord' splice adds entries into +-- this environment, and the 'lr' quasi-quoter consults this environment. +-- The contents of this environment are ephemeral, of course, and certainly not +-- stored as part of interface files, so this is merely a backup for when the +-- 'MetadataOf' information is not available. +resolveRecord :: Quasi m + => String -- ^ User-defined constructor + -> N.Name 'DataName 'N.Global -- ^ Internal constructor + -> m (Either String (Record ())) +resolveRecord userConstr internalConstr = do + mInfo <- Internal.getRecordInfo internalConstr + case mInfo of + Just info -> return $ Right info + Nothing -> GHC.parseRecordInfo userConstr internalConstr diff --git a/src/Data/Record/Internal/Record/Resolution/GHC.hs b/src/Data/Record/Internal/Record/Resolution/GHC.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Record/Resolution/GHC.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +module Data.Record.Internal.Record.Resolution.GHC ( + parseRecordInfo + ) where + +import Control.Monad.Except +import Data.Maybe (fromMaybe) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import qualified Control.Monad.Except as Except + +import Data.Record.Generic +import Data.Record.Internal.Record +import Data.Record.Internal.TH.Util + +import qualified Data.Record.Internal.TH.Name as N + +{------------------------------------------------------------------------------- + Parsing +-------------------------------------------------------------------------------} + +-- | Parse previously constructed type level data +-- +-- We do this when we construct record /values/, at which point we have no +-- 'Options', so this must work without options. +-- +-- 'Nothing' if this wasn't a type created using @large-records@. +parseRecordInfo :: forall m. + Quasi m + => String -- ^ User-defined constructor + -> N.Name 'DataName 'N.Global -- ^ Internal constructor + -> m (Either String (Record ())) +parseRecordInfo userConstr internalConstr = runExceptT $ do + parent <- Except.lift (N.reify internalConstr) >>= getDataConParent + saturated <- Except.lift (N.reify parent) >>= getSaturatedType + parsed <- Except.lift (getMetadataInstance saturated) >>= parseTySynInst + return $ mkRecordInfo (N.nameBase parent) parsed + where + mkRecordInfo :: + String + -> ([TyVarBndr], [(String, Type)]) + -> Record () + mkRecordInfo rType (tyVars, fieldTypes) = Record { + recordType = rType + , recordConstr = userConstr + , recordTVars = tyVars + , recordFields = zipWith (uncurry mkFieldInfo) fieldTypes [0..] + } + + mkFieldInfo :: String -> Type -> Int -> Field () + mkFieldInfo fName fType ix = Field { + fieldName = fName + , fieldType = fType + , fieldIndex = ix + , fieldVal = () + } + + saturate :: Name -> [TyVarBndr] -> Type + saturate n = foldl (\t v -> t `AppT` VarT (tyVarName v)) (ConT n) + + getMetadataInstance :: Type -> m [InstanceDec] + getMetadataInstance = runQ . reifyInstances ''MetadataOf . (:[]) + + getSaturatedType :: Info -> ExceptT String m Type + getSaturatedType (TyConI (NewtypeD [] nm tyVars _kind _con _deriv)) = + return $ saturate nm tyVars + getSaturatedType i = + unexpected i "newtype" + + getDataConParent :: Info -> ExceptT String m (N.Name 'TcClsName 'N.Global) + getDataConParent (DataConI _ _ parent) = + return $ N.fromTH' parent + getDataConParent i = + unexpected i "data constructor" + + parseTySynInst :: + [InstanceDec] + -> ExceptT String m ([TyVarBndr], [(String, Type)]) + parseTySynInst [TySynInstD (TySynEqn vars _lhs rhs)] = + (fromMaybe [] vars, ) <$> parseList rhs + parseTySynInst is = + unexpected is "type instance" + + parseList :: Type -> ExceptT String m [(String, Type)] + parseList (AppT (AppT PromotedConsT t) ts) = + (:) <$> parseTuple t <*> parseList ts + parseList PromotedNilT = + return [] + parseList (SigT t _kind) = + parseList t + parseList t = unexpected t "list" + + parseTuple :: Type -> ExceptT String m (String, Type) + parseTuple (AppT (AppT (PromotedTupleT 2) (LitT (StrTyLit f))) t) = + return (f, t) + parseTuple t = unexpected t "tuple" + + unexpected :: Show a => a -> String -> ExceptT String m b + unexpected actual expected = throwError $ concat [ + "Unexpected " + , show actual + , " (expected " + , expected + , ")" + ] diff --git a/src/Data/Record/Internal/Record/Resolution/Internal.hs b/src/Data/Record/Internal/Record/Resolution/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Record/Resolution/Internal.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE DataKinds #-} + +module Data.Record.Internal.Record.Resolution.Internal ( + getRecordInfo + , putRecordInfo + ) where + +import Data.Map (Map) +import Data.Maybe (fromMaybe) +import Language.Haskell.TH.Syntax + +import qualified Data.Map as Map + +import Data.Record.Internal.Naming +import Data.Record.Internal.Record + +import qualified Data.Record.Internal.TH.Name as N + +{------------------------------------------------------------------------------- + Internal state + + As keys we use the names of the internal constructor, because when we do name + resolution, that is what we would normally use to query ghc. We use /global/ + names, which uniquely identify a name (qualified by package and module). +-------------------------------------------------------------------------------} + +newtype TypeEnv = WrapTypeEnv { + unwrapTypeEnv :: Map (N.Name 'DataName 'N.Global) (Record ()) + } + +getTypeEnv :: Quasi m => m TypeEnv +getTypeEnv = fromMaybe (WrapTypeEnv Map.empty) <$> qGetQ + +putTypeEnv :: Quasi m => TypeEnv -> m () +putTypeEnv = qPutQ + +{------------------------------------------------------------------------------- + Accessing the internal state +-------------------------------------------------------------------------------} + +getRecordInfo :: + Quasi m + => N.Name 'DataName 'N.Global -- ^ Name of the internal constructor + -> m (Maybe (Record ())) +getRecordInfo internalConstr = + Map.lookup internalConstr . unwrapTypeEnv <$> getTypeEnv + +-- | Add 'RecordInfo' to the environment +-- +-- NOTE: Must be called whilst processing the module in which the record is +-- defined. +putRecordInfo :: Quasi m => Record () -> m () +putRecordInfo info = do + env <- unwrapTypeEnv <$> getTypeEnv + + -- In order to be able to resolve the record info later, we need to properly + -- quantify the record name. We do this by requesting the /current/ TH + -- location. This is justified by the precondition to the function. + + loc <- runQ location + let internalConstr :: N.Name 'DataName 'N.Global + internalConstr = + N.Name + (OccName (nameRecordInternalConstr (recordConstr info))) + (N.NameGlobal + DataName + (mkPkgName (loc_package loc)) + (mkModName (loc_module loc)) + ) + + putTypeEnv $ WrapTypeEnv $ Map.insert internalConstr info env + diff --git a/src/Data/Record/Internal/TH/Name.hs b/src/Data/Record/Internal/TH/Name.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/TH/Name.hs @@ -0,0 +1,321 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} + +{-# OPTIONS_GHC -Wno-partial-type-signatures #-} + +-- | Names with statically known flavour +-- +-- Intended for qualified import. +module Data.Record.Internal.TH.Name ( + -- * Names + Name(..) + , Flavour(..) + , NameFlavour(..) + -- * Simple functions + , nameBase + , mapNameBase + -- * Working with qualified names + , Qualifier(..) + , qualify + , unqualified + , nameQualifier + -- * Fresh names + , newName + -- * Conversion + , fromTH + , fromTH' + , toTH + -- * Resolution + , LookupName(..) + , reify + -- * Construct TH + , classD + , conE + , conT + , newtypeD + , patSynD + , patSynSigD + , pragCompleteD + , recC + , recordPatSyn + , sigD + , varBangType + , varE + , varLocalP + , varGlobalP + ) where + +import Data.Kind +import Data.Maybe (fromMaybe) +import Language.Haskell.TH (Q) +import Language.Haskell.TH.Syntax (Quasi, runQ, NameSpace(..)) + +import qualified Language.Haskell.TH.Syntax as TH +import qualified Language.Haskell.TH.Lib as TH + +{------------------------------------------------------------------------------- + Names +-------------------------------------------------------------------------------} + +-- | Name flavours (used as a kind, not as a type) +-- +-- Technically speaking there is one flavour missing: names that are locally +-- bound, but outside of the TH quote, something like +-- +-- > foo x = [| .. x .. |] +-- +-- However, we won't actually deal with such names. +data Flavour = + -- | Dynamically bound + -- + -- Dynamically bound names will be bound to a global name by @ghc@ after + -- splicing the TH generated Haskelll code. + -- + -- These are generated with 'mkName' (also used by @haskell-src-meta@). + Dynamic + + -- | A new name + -- + -- These are names either generated by 'newName' or are new names in a TH + -- declaration quote @[d| ... |]@. + | Unique + + -- | Reference to a specific name defined outside of the TH quote + | Global + +data NameFlavour :: Flavour -> Type where + -- | Dynamically bound name, with an optional module prefix (@T.foo@) + NameDynamic :: Maybe TH.ModName -> NameFlavour 'Dynamic + + -- | Unique local name + NameUnique :: TH.Uniq -> NameFlavour 'Unique + + -- | Global name bound outside of the TH quot + NameGlobal :: TH.NameSpace -> TH.PkgName -> TH.ModName -> NameFlavour 'Global + +-- | Like TH's 'Name', but with statically known flavour. +data Name :: NameSpace -> Flavour -> Type where + Name :: TH.OccName -> NameFlavour flavour -> Name ns flavour + +deriving instance Show (NameFlavour flavour) +deriving instance Eq (NameFlavour flavour) +deriving instance Ord (NameFlavour flavour) + +deriving instance Show (Name ns flavour) +deriving instance Eq (Name ns flavour) +deriving instance Ord (Name ns flavour) + +{------------------------------------------------------------------------------- + Simple functions +-------------------------------------------------------------------------------} + +nameBase :: Name ns flavour -> String +nameBase (Name (TH.OccName occ) _) = occ + +-- | Modify the unqualified part of the name +-- +-- Since we often to do this derive one kind of name from another, the +-- namespace of the result is not related to the namespace of the argument. +mapNameBase :: (String -> String) -> Name ns flavour -> Name ns' flavour +mapNameBase f (Name (TH.OccName occ) flav) = Name (TH.OccName (f occ)) flav + +{------------------------------------------------------------------------------- + Working with qualified names +-------------------------------------------------------------------------------} + +data Qualifier = Unqual | Qual TH.ModName + +qualify :: Qualifier -> String -> Name ns 'Dynamic +qualify Unqual occ = Name (TH.OccName occ) (NameDynamic Nothing) +qualify (Qual m) occ = Name (TH.OccName occ) (NameDynamic (Just m)) + +unqualified :: String -> Name ns 'Dynamic +unqualified = qualify Unqual + +nameQualifier :: Name ns 'Dynamic -> Qualifier +nameQualifier (Name _ (NameDynamic (Just m))) = Qual m +nameQualifier (Name _ (NameDynamic Nothing)) = Unqual + +{------------------------------------------------------------------------------- + Singleton +-------------------------------------------------------------------------------} + +-- | Singleton type associated with 'Flavour' +data SFlavour :: Flavour -> Type where + SDynamic :: SFlavour 'Dynamic + SUnique :: SFlavour 'Unique + SGlobal :: SFlavour 'Global + +deriving instance Show (SFlavour flavour) + +class IsFlavour flavour where + isFlavour :: SFlavour flavour + +instance IsFlavour 'Dynamic where isFlavour = SDynamic +instance IsFlavour 'Unique where isFlavour = SUnique +instance IsFlavour 'Global where isFlavour = SGlobal + +{------------------------------------------------------------------------------- + Conversion +-------------------------------------------------------------------------------} + +toFlavourF :: SFlavour flavour -> TH.NameFlavour -> Maybe (NameFlavour flavour) +toFlavourF SDynamic (TH.NameS) = Just $ NameDynamic Nothing +toFlavourF SDynamic (TH.NameQ m) = Just $ NameDynamic (Just m) +toFlavourF SUnique (TH.NameU u) = Just $ NameUnique u +toFlavourF SGlobal (TH.NameG n p m) = Just $ NameGlobal n p m +toFlavourF _ _ = Nothing + +fromFlavourF :: NameFlavour flavour -> TH.NameFlavour +fromFlavourF (NameDynamic Nothing) = TH.NameS +fromFlavourF (NameDynamic (Just m)) = TH.NameQ m +fromFlavourF (NameUnique u) = TH.NameU u +fromFlavourF (NameGlobal n p m) = TH.NameG n p m + +-- | Translate from a dynamically typed TH name +-- +-- Returns 'Nothing' if the TH name does not have the specified flavour. +fromTH :: IsFlavour flavour => TH.Name -> Maybe (Name ns flavour) +fromTH (TH.Name occ flavour') = Name occ <$> toFlavourF isFlavour flavour' + +-- | Variation on 'fromTH' that throws an exception on a flavour mismatch +fromTH' :: forall ns flavour. IsFlavour flavour => TH.Name -> Name ns flavour +fromTH' name@(TH.Name occ flavour') = + fromMaybe (error err) $ fromTH name + where + err :: String + err = concat [ + "fromTH': name " + , show occ + , " has the wrong flavour: " + , show (isFlavour :: SFlavour flavour) + , " /= " + , show flavour' + ] + +-- | Forget type level information +toTH :: Name ns flavour -> TH.Name +toTH (Name occ flavour) = TH.Name occ (fromFlavourF flavour) + +{------------------------------------------------------------------------------- + Resolution +-------------------------------------------------------------------------------} + +class LookupName ns where + -- | Resolve existing name + lookupName :: Quasi m => Name ns 'Dynamic -> m (Maybe (Name ns 'Global)) + +instance LookupName 'TcClsName where + lookupName (Name occ (NameDynamic mMod)) = + fmap fromTH' <$> + runQ (TH.lookupTypeName $ qualifyDotted mMod occ) + +instance LookupName 'DataName where + lookupName (Name occ (NameDynamic mMod)) = + fmap fromTH' <$> + runQ (TH.lookupValueName $ qualifyDotted mMod occ) + +instance LookupName 'VarName where + lookupName (Name occ (NameDynamic mMod)) = + fmap fromTH' <$> + runQ (TH.lookupValueName $ qualifyDotted mMod occ) + +-- | Get info about the given name +-- +-- Only global names can be reified. See 'lookupName'. +reify :: Quasi m => Name ns 'Global -> m TH.Info +reify = runQ . TH.reify . toTH + +{------------------------------------------------------------------------------- + Fresh names +-------------------------------------------------------------------------------} + +newName :: String -> Q (Name ns 'Unique) +newName = fmap fromTH' . TH.newName + +{------------------------------------------------------------------------------- + /Defining/ global names + + Since these are all meant to define capturable names, these functions all take + an 'Dynamic' name as argument. +-------------------------------------------------------------------------------} + +-- | Define pattern synonym +patSynD :: Name 'DataName 'Dynamic -> _ +patSynD = TH.patSynD . toTH + +-- | Define pattern synonym signature +patSynSigD :: Name 'DataName 'Dynamic -> _ +patSynSigD = TH.patSynSigD . toTH + +-- | Define function signature +sigD :: Name 'VarName 'Dynamic -> _ +sigD = TH.sigD . toTH + +-- | Define record field signature +varBangType :: Name 'VarName 'Dynamic -> _ +varBangType = TH.varBangType . toTH + +-- | Define record constructor +recC :: Name 'DataName 'Dynamic -> _ +recC = TH.recC . toTH + +-- | Define class +classD :: _ -> Name 'TcClsName 'Dynamic -> _ +classD cxt = TH.classD cxt . toTH + +-- | Define newtype +newtypeD :: _ -> Name 'TcClsName 'Dynamic -> _ +newtypeD cxt = TH.newtypeD cxt . toTH + +-- | Define record pattern synonym +recordPatSyn :: [String] -> _ +recordPatSyn = TH.recordPatSyn . map (toTH . unqualified) + +-- | Define COMPLETE pragma +pragCompleteD :: [Name 'DataName 'Dynamic] -> Maybe (Name 'TcClsName 'Dynamic) -> _ +pragCompleteD constrs typ = + TH.pragCompleteD (toTH <$> constrs) (toTH <$> typ) + +-- | Define pattern variable for use in a record pattern synonym +varGlobalP :: Name 'VarName 'Dynamic -> _ +varGlobalP = TH.varP . toTH + +-- | Define pattern variable for use in a local pattern match +varLocalP :: Name 'VarName 'Unique -> _ +varLocalP = TH.varP . toTH + +{------------------------------------------------------------------------------- + Referencing existing names + + We can reference any flavour of name. +-------------------------------------------------------------------------------} + +-- | Reference constructor +conE :: Name 'DataName flavour -> _ +conE = TH.conE . toTH + +-- | Reference type +conT :: Name 'TcClsName flavour -> _ +conT = TH.conT . toTH + +-- | Reference variable +varE :: Name 'VarName flavour -> _ +varE = TH.varE . toTH + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +-- | Qualify a name (for use in 'lookupTypeName' and co) +qualifyDotted :: Maybe TH.ModName -> TH.OccName -> String +qualifyDotted Nothing (TH.OccName occ) = occ +qualifyDotted (Just (TH.ModName m)) (TH.OccName occ) = m ++ "." ++ occ diff --git a/src/Data/Record/Internal/TH/Util.hs b/src/Data/Record/Internal/TH/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/TH/Util.hs @@ -0,0 +1,134 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Utility functions for working with TH +module Data.Record.Internal.TH.Util ( + -- * Folding + appsT + , arrT + -- * Constructing lists (variations on 'listE') + , vectorE + , plistT + , ptupleT + -- * Simplified construction + , simpleFn + , simplePatSynType + -- * Dealing with type variables + , tyVarName + , tyVarType + -- * Bang + , pattern DefaultBang + -- * Extensions + , requiresExtensions + ) where + +import Control.Monad +import Data.List (intercalate) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import qualified Data.Vector as V + +import qualified Data.Record.Internal.TH.Name as N + +{------------------------------------------------------------------------------- + Folding +-------------------------------------------------------------------------------} + +-- | Repeated application +-- +-- @appsT f [x1, .., xN]@ constructs something like +-- +-- > f x1 .. xN +appsT :: Q Type -> [Q Type] -> Q Type +appsT t ts = foldl appT t ts + +-- | Repeated application of @(->)@ +-- +-- @arrT [x1, .., xN] y@ constructs something like +-- +-- > x1 -> .. -> xN -> y +arrT :: [Q Type] -> Q Type -> Q Type +arrT ts t = foldr (\a b -> arrowT `appT` a `appT` b) t ts + +{------------------------------------------------------------------------------- + Constructing lists (variations on 'listE') +-------------------------------------------------------------------------------} + +vectorE :: (a -> Q Exp) -> [a] -> Q Exp +vectorE f elems = [| V.fromList $(listE (map f elems)) |] + +plistT :: [Q Type] -> Q Type +plistT = foldr cons nil + where + nil = promotedNilT + cons t ts = promotedConsT `appT` t `appT` ts + +ptupleT :: [Q Type] -> Q Type +ptupleT ts = appsT (promotedTupleT (length ts)) ts + +{------------------------------------------------------------------------------- + Simplified construction +-------------------------------------------------------------------------------} + +-- | Construct simple function +-- +-- @simpleFn n typ body@ constructs something like +-- +-- > f :: typ +-- > f = body +simpleFn :: N.Name 'VarName flavour -> Q Type -> Q Exp -> Q [Dec] +simpleFn fnName qTyp qBody = do + typ <- qTyp + body <- qBody + return [ + SigD fnName' typ + , ValD (VarP fnName') (NormalB body) [] + ] + where + fnName' :: Name + fnName' = N.toTH fnName + +-- | Construct simple pattern synonym type +-- +-- @simplePatSynType xs [t1, .., tn] s@ constructs something like +-- +-- > pattern foo :: forall xs. t1 -> .. -> tn -> s +simplePatSynType :: [TyVarBndr] -> [Q Type] -> Q Type -> Q PatSynType +simplePatSynType tvars fieldTypes resultType = + forallT tvars (cxt []) + $ forallT [] (cxt []) + $ arrT fieldTypes resultType + +{------------------------------------------------------------------------------- + Dealing with type variables +-------------------------------------------------------------------------------} + +tyVarName :: TyVarBndr -> Name +tyVarName (PlainTV n) = n +tyVarName (KindedTV n _) = n + +tyVarType :: TyVarBndr -> Q Type +tyVarType = varT . tyVarName + +{------------------------------------------------------------------------------- + Bang +-------------------------------------------------------------------------------} + +pattern DefaultBang :: Bang +pattern DefaultBang = Bang NoSourceUnpackedness NoSourceStrictness + +{------------------------------------------------------------------------------- + Extensions +-------------------------------------------------------------------------------} + +-- | Check that the specified extensions are enabled +-- +-- To improve user experience, we report all missing extensions at once (rather +-- than giving an error for the first missing one). +requiresExtensions :: Quasi m => [Extension] -> m () +requiresExtensions exts = runQ $ do + disabled <- filterM (fmap not . isExtEnabled) exts + unless (null disabled) $ do + fail $ "Please enable " ++ intercalate ", " (map show disabled) diff --git a/src/Data/Record/Internal/Util.hs b/src/Data/Record/Internal/Util.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Internal/Util.hs @@ -0,0 +1,17 @@ +-- | Miscellaneous utility functions +module Data.Record.Internal.Util ( + -- * Monadic combinators + concatM + , concatMapM + ) where + +{------------------------------------------------------------------------------- + Monadic combinators +-------------------------------------------------------------------------------} + +concatM :: Applicative m => [m [a]] -> m [a] +concatM = fmap concat . sequenceA + +concatMapM :: Applicative m => (a -> m [b]) -> [a] -> m [b] +concatMapM f = concatM . map f + diff --git a/src/Data/Record/QQ/CodeGen.hs b/src/Data/Record/QQ/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/QQ/CodeGen.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | Quasi-quoter support for large records +-- +-- NOTE: The only reason for the existence of this module is that record pattern +-- syonyms in @ghc@ are currently not useable: when we declare a record pattern +-- synonym, @ghc@ automatically derives field accessors for every field in the +-- record. We don't want those accessors: they result in name clashes +-- (DuplicateRecordFields does not apply to record pattern synonyms) and, more +-- importantly, they result in quadratic code size again. Once the +-- @NoFieldSelectors@ language extension is merged (probably @ghc@ 9.2), we +-- can reconsider whether this module is still required. +-- +-- See also: +-- +-- * +-- * +module Data.Record.QQ.CodeGen ( + lr + + -- * Exported for the benefit of tests + , lrExp + , lrPat + ) where + +import Data.List (intercalate) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Language.Haskell.TH.Syntax + +import qualified Data.Generics as SYB +import qualified Language.Haskell.Exts as HSE +import qualified Language.Haskell.Meta as HSE.Meta + +import Data.Record.Internal.CodeGen +import Data.Record.Internal.Naming +import Data.Record.Internal.Record +import Data.Record.Internal.TH.Util +import Data.Record.QQ.CodeGen.HSE +import Data.Record.QQ.CodeGen.Parser +import Data.Record.QQ.Runtime.MatchHasField +import Data.Record.TH.CodeGen.Tree + +import qualified Data.Record.Internal.TH.Name as N + +{------------------------------------------------------------------------------- + Top-level quasi-quoter +-------------------------------------------------------------------------------} + +-- | Construct or match on @large-records@-style records +-- +-- Example construction usage: +-- +-- > inOrder :: R Bool +-- > inOrder = [lr| MkR { x = 1234, y = [True] } |] +-- +-- or: +-- +-- > constructorApp :: R Bool +-- > constructorApp = [lr| MkR |] 1234 [True] +-- +-- Example matching usage: +-- +-- > projectOne :: T Bool -> Int +-- > projectOne [lr| MkT { x = a } |] = a +lr :: QuasiQuoter +lr = QuasiQuoter { + quoteExp = lrExp + , quotePat = lrPat + , quoteType = unsupported + , quoteDec = unsupported + } + where + unsupported :: String -> Q a + unsupported _ = fail "lr can only be used for expressions or patterns" + +{------------------------------------------------------------------------------- + Individual quasi-quoters +-------------------------------------------------------------------------------} + +lrExp :: forall m. Quasi m => String -> m Exp +lrExp = \str -> do + exts <- runQ extsEnabled + case parseExp exts str of + Left err -> fail $ parseErr err + Right expr -> construct expr + where + parseExp :: [Extension] -> String -> Either String Exp + parseExp exts str = + case HSE.parseExpWithMode (parseMode exts) str of + HSE.ParseFailed _loc err -> Left err + HSE.ParseOk e -> Right (HSE.Meta.toExp e) + + parseErr :: String -> String + parseErr err = concat [ + "Could not parse expression: " + , map (\c -> if c == '\n' then ' ' else c) err + ] + +lrPat :: forall m. Quasi m => String -> m Pat +lrPat = \str -> do + exts <- runQ extsEnabled + case parsePat exts str of + Left err -> fail $ parseErr err + Right expr -> deconstruct expr + where + parsePat :: [Extension] -> String -> Either String Pat + parsePat exts str = + case HSE.parsePatWithMode (parseMode exts) str of + HSE.ParseFailed _loc err -> Left err + HSE.ParseOk p -> Right (HSE.Meta.toPat (processRecordPuns p)) + + parseErr :: String -> String + parseErr err = concat [ + "Could not parse pattern: " + , map (\c -> if c == '\n' then ' ' else c) err + ] + +{------------------------------------------------------------------------------- + Construction +-------------------------------------------------------------------------------} + +construct :: forall m. Quasi m => Exp -> m Exp +construct = \case + ConE constr -> do + constrFn <- resolveKnownHseName nameRecordTypedConstructorFn (fromHseName constr) + runQ $ N.varE constrFn + expr -> + -- Assume this is a record construction expression + SYB.everywhereM (SYB.mkM go) expr + where + go :: Exp -> m Exp + go e = do + mTerm <- parseRecordExp e + case mTerm of + Nothing -> + -- Leave non-record expressions alone + return e + Just NotKnownLargeRecord -> + return e + Just (UnknownFields unknown) -> runQ $ do + reportError $ "Unknown fields: " ++ intercalate ", " unknown + [| undefined |] + Just (ParsedRecordInfo qual Record{..}) -> runQ $ do + appsE $ N.varE (N.qualify qual (nameRecordTypedConstructorFn recordConstr)) + : map mkArg recordFields + + mkArg :: Field (Maybe Exp) -> Q Exp + mkArg Field{..} + | Just e <- fieldVal = return e + | otherwise = do + reportWarning $ "No value for field " ++ fieldName + [| error $ "No value given for field " ++ $(lift fieldName) |] + +{------------------------------------------------------------------------------- + Deconstruction +-------------------------------------------------------------------------------} + +deconstruct :: forall m. Quasi m => Pat -> m Pat +deconstruct = \pat -> do + requiresExtensions [TypeApplications, ViewPatterns, DataKinds] + SYB.everywhereM (SYB.mkM go) pat + where + go :: Pat -> m Pat + go p = do + mTerm <- parseRecordPat p + case mTerm of + Nothing -> -- Not a record pattern + return p + Just NotKnownLargeRecord -> + return p + Just (UnknownFields unknown) -> runQ $ do + reportError $ "Unknown fields: " ++ intercalate ", " unknown + return p + Just (ParsedRecordInfo qual r) -> runQ $ + viewP (varE 'viewAtType `appE` recordUndefinedValueE qual r) $ + case recordFields (dropMissingRecordFields r) of + [] -> wildP + fs -> outerViewPat fs + + outerViewPat :: [Field Pat] -> Q Pat + outerViewPat fs = + viewP (varE 'matchHasField) $ + mkTupleP innerViewPat $ nest (MaxTupleElems 2) fs + + innerViewPat :: Field Pat -> Q Pat + innerViewPat f@Field{..} = + viewP + (varE 'fieldNamed `appTypeE` fieldNameT f) + (return fieldVal) + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +parseMode :: [Extension] -> HSE.ParseMode +parseMode exts = HSE.defaultParseMode { + HSE.extensions = concat [ + -- Include extensions enabled in the module + map extensionFromTH exts + + -- But also include the default + -- + -- We do this primarily because 'fromTH' doesn't actually parse + -- all extensions + , HSE.extensions HSE.defaultParseMode + ] + } diff --git a/src/Data/Record/QQ/CodeGen/HSE.hs b/src/Data/Record/QQ/CodeGen/HSE.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/QQ/CodeGen/HSE.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} + +-- | Additional utilities for working with @haskell-src-exts@ +module Data.Record.QQ.CodeGen.HSE ( + -- * Language extensions + extensionFromTH + , processRecordPuns + -- * Naming + , fromHseName + , resolveHseName + , resolveKnownHseName + ) where + +import Data.Generics +import Language.Haskell.Exts +import Language.Haskell.TH.Syntax (Quasi) + +import qualified Language.Haskell.TH.Syntax as TH + +import qualified Data.Record.Internal.TH.Name as N + +{------------------------------------------------------------------------------- + Language extensions +-------------------------------------------------------------------------------} + +-- | Translate TH extension into HSE extension +-- +-- Useful in combination with 'extsEnabled'. +extensionFromTH :: TH.Extension -> Extension +extensionFromTH = \case + TH.DataKinds -> EnableExtension $ DataKinds + TH.RecordPuns -> EnableExtension $ NamedFieldPuns + TH.TypeApplications -> EnableExtension $ TypeApplications + TH.ViewPatterns -> EnableExtension $ ViewPatterns + + -- We don't care about all extensions; there are many of them, and they vary + -- from ghc version to ghc version. Treating them all would be a lot of work + -- for little benefit. We assume that calling @show@ gives us a valid + -- extension name; by and large this seems to be true (though for instance + -- it will give us 'RecordPuns' rather than 'NamedFieldPuns', which although + -- valid, is deprecated). + e -> UnknownExtension $ show e + +processRecordPuns :: forall l. Data l => Pat l -> Pat l +processRecordPuns = everywhere (mkT go) + where + go :: PatField l -> PatField l + go (PFieldPun pLoc n@(UnQual nLoc n')) = PFieldPat pLoc n (PVar nLoc n') + go p = p + +{------------------------------------------------------------------------------- + Naming +-------------------------------------------------------------------------------} + +-- | HSE generated names are always dynamically bound +fromHseName :: TH.Name -> N.Name flavour 'N.Dynamic +fromHseName = N.fromTH' + +-- | Resolve HSE generated name +-- +-- As mentioned in 'fromHseName', HSE generated names are always dynamically +-- bound, and we therefore need to do a "renaming pass": we need to resolve the +-- name. However, the exact name we want to lookup might not be the name as it +-- appears in the QQ place; for if the user writes @MkR@, the name we actually +-- want to look up might be, say, @LR__MkR@. +resolveHseName :: (Quasi m, N.LookupName ns') + => (String -> String) + -> N.Name ns 'N.Dynamic + -> m (Maybe (N.Name ns' 'N.Global)) +resolveHseName f = N.lookupName . N.mapNameBase f + +-- | Variation on 'resolveHseName' that fails if the name is not known +resolveKnownHseName :: (Quasi m, N.LookupName ns') + => (String -> String) + -> N.Name ns 'N.Dynamic + -> m (N.Name ns' 'N.Global) +resolveKnownHseName f n = do + mn' <- resolveHseName f n + case mn' of + Just n' -> return n' + Nothing -> fail $ "resolveKnownHseName: " ++ N.nameBase n ++ " not in scope" diff --git a/src/Data/Record/QQ/CodeGen/Parser.hs b/src/Data/Record/QQ/CodeGen/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/QQ/CodeGen/Parser.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Record.QQ.CodeGen.Parser ( + ParsedRecordInfo(..) + , parseRecordExp + , parseRecordPat + ) where + +import Data.Bifunctor +import Language.Haskell.TH (Exp(RecConE), Pat(RecP)) +import Language.Haskell.TH.Syntax (Quasi, NameSpace(..)) + +import qualified Language.Haskell.TH.Syntax as TH + +import Data.Record.Internal.Naming +import Data.Record.Internal.Record +import Data.Record.Internal.Record.Resolution +import Data.Record.QQ.CodeGen.HSE + +import qualified Data.Record.Internal.TH.Name as N + +data ParsedRecordInfo a = + -- | The pattern/value we matched against is not a (known) large record + NotKnownLargeRecord + + -- | The pattern/value has fields not present in the record definition + | UnknownFields [String] + + -- | Successfully matched against a known large records + -- + -- Note that not all fields may have a corresponding value/pattern. + -- + -- In addition to the record info, we also record the qualifier used in + -- the original name. + | ParsedRecordInfo N.Qualifier (Record (Maybe a)) + +parseRecordExp :: Quasi m => Exp -> m (Maybe (ParsedRecordInfo Exp)) +parseRecordExp = traverse (uncurry parseRecordInfo) . termExp + +parseRecordPat :: Quasi m => Pat -> m (Maybe (ParsedRecordInfo Pat)) +parseRecordPat = traverse (uncurry parseRecordInfo) . termPat + +-- | Try to match a pattern or expression against a (large) record +parseRecordInfo :: + forall m a. Quasi m + => N.Name 'DataName 'N.Dynamic + -> [(String, a)] + -> m (ParsedRecordInfo a) +parseRecordInfo userConstr fields = do + mInternalConstr <- resolveHseName nameRecordInternalConstr userConstr + case mInternalConstr of + Nothing -> + return NotKnownLargeRecord + Just internalConstr -> + aux <$> resolveRecord (N.nameBase userConstr) internalConstr + where + aux :: Either String (Record ()) -> ParsedRecordInfo a + aux (Left _err) = NotKnownLargeRecord + aux (Right r) = + case matchRecordFields fields r of + (r', []) -> ParsedRecordInfo (N.nameQualifier userConstr) (snd <$> r') + (_ , un) -> UnknownFields un + +{------------------------------------------------------------------------------- + Match against the syntax tree generated by @haskell-src-exts@ + + We ignore any qualifiers for field names. +-------------------------------------------------------------------------------} + +termExp :: Exp -> Maybe (N.Name 'DataName 'N.Dynamic, [(String, TH.Exp)]) +termExp (RecConE constr fields) = Just ( + fromHseName constr + , map (first TH.nameBase) fields + ) +termExp _otherwise = Nothing + +termPat :: Pat -> Maybe (N.Name 'DataName 'N.Dynamic, [(String, TH.Pat)]) +termPat (RecP constr fields) = Just ( + fromHseName constr + , map (first TH.nameBase) fields + ) +termPat _otherwise = Nothing + diff --git a/src/Data/Record/QQ/Runtime/MatchHasField.hs b/src/Data/Record/QQ/Runtime/MatchHasField.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/QQ/Runtime/MatchHasField.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Infrastructure for supporting matching on records +-- +-- We are be careful not to reintroduce quadratic code size here. +module Data.Record.QQ.Runtime.MatchHasField ( + MatchHasField -- opaque + , matchHasField + , fieldNamed + , viewAtType + ) where + +import Data.Kind +import GHC.Records.Compat +import GHC.TypeLits + +{------------------------------------------------------------------------------- + Infrastructure +-------------------------------------------------------------------------------} + +-- | Pattern match on 'HasField' +-- +-- This is intended to be used together with 'matchHasField'. Example usage: +-- +-- > data Foo a +-- > +-- > instance HasField "fooX" (Foo a) Int where .. +-- > instance HasField "fooY" (Foo a) [a] where .. +-- > +-- > _example :: Foo Char -> (Int, [Char]) +-- > _example (matchHasField -> ( fieldNamed @"fooX" -> x +-- > , fieldNamed @"fooY" -> y +-- > ) ) = (x, y) +class MatchHasField a b | b -> a where + matchHasField :: a -> b + +-- | To be used in conjunction with 'MatchHasField'. +-- +-- See 'MatchHasField' for details. +fieldNamed :: GetField x r a -> a +fieldNamed (GetField a) = a + +data GetField (x :: Symbol) (r :: Type) (a :: Type) = GetField a + +instance HasField x r a => MatchHasField r (GetField x r a) where + matchHasField = GetField . (getField @x) + +instance (MatchHasField a b, MatchHasField a c) => MatchHasField a (b, c) where + matchHasField r = (matchHasField r, matchHasField r) + +-- | Can be used alongside 'matchHasField' to fix the type of the argument +-- +-- This avoids inferring types in terms of @HasField ..@; see example below. +viewAtType :: a -> a -> a +viewAtType = const id + +{------------------------------------------------------------------------------- + Example +-------------------------------------------------------------------------------} + +data Foo a = MkFoo + +instance HasField "fooX" (Foo a) Int where hasField = undefined +instance HasField "fooY" (Foo a) [a] where hasField = undefined + +_example1 :: (HasField "fooX" a b, HasField "fooY" a c) => a -> (b, c) +_example1 (matchHasField -> ( fieldNamed @"fooX" -> x + , fieldNamed @"fooY" -> y + ) ) = (x, y) + +_example2 :: Foo a -> (Int, [a]) -- This is the inferred signature +_example2 (viewAtType MkFoo -> matchHasField -> ( fieldNamed @"fooX" -> x + , fieldNamed @"fooY" -> y + ) ) = (x, y) diff --git a/src/Data/Record/TH.hs b/src/Data/Record/TH.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/TH.hs @@ -0,0 +1,7 @@ +module Data.Record.TH ( + module X + ) where + +import Data.Record.QQ.CodeGen as X (lr) +import Data.Record.TH.CodeGen as X (largeRecord) +import Data.Record.TH.Config.Options as X diff --git a/src/Data/Record/TH/CodeGen.hs b/src/Data/Record/TH/CodeGen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/TH/CodeGen.hs @@ -0,0 +1,758 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} + +-- | Code generation +module Data.Record.TH.CodeGen ( + largeRecord + ) where + +import Data.List (nub) +import Data.Maybe (catMaybes) +import Data.Proxy +import Data.Vector (Vector) +import GHC.Exts (Any) +import GHC.Records.Compat +import Language.Haskell.TH +import Language.Haskell.TH.Syntax (NameSpace(..)) + +import qualified Data.Generics as SYB +import qualified Data.Kind as Kind +import qualified Data.Vector as V +import qualified GHC.Generics as GHC +import qualified Language.Haskell.TH.Syntax as TH + +import Data.Record.Generic +import Data.Record.Generic.Eq +import Data.Record.Generic.GHC +import Data.Record.Generic.Show + +import Data.Record.Internal.CodeGen +import Data.Record.Internal.Naming +import Data.Record.Internal.Record +import Data.Record.Internal.Record.Parser +import Data.Record.Internal.Record.Resolution.Internal (putRecordInfo) +import Data.Record.Internal.TH.Util +import Data.Record.Internal.Util +import Data.Record.TH.CodeGen.Tree +import Data.Record.TH.Config.Options +import Data.Record.TH.Runtime + +import qualified Data.Record.Generic.Rep.Internal as Rep +import qualified Data.Record.Internal.TH.Name as N + +{------------------------------------------------------------------------------- + Public API +-------------------------------------------------------------------------------} + +-- | Declare a large record +-- +-- Example usage: +-- +-- > largeRecord defaultPureScript [d| +-- > data R a = MkR { x :: Int, y :: [a] } deriving (Eq, Show) +-- > data S a = S { x :: Int, y :: [a] } deriving (Eq, Show) +-- > |] +largeRecord :: Options -> Q [Dec] -> Q [Dec] +largeRecord opts decls = do + rs <- mapM parseRecordDef . dropUniques =<< decls + concatMapM (genAll opts) (catMaybes rs) + +{------------------------------------------------------------------------------- + Top-level +-------------------------------------------------------------------------------} + +-- | Generate all definitions +genAll :: Options -> (Record (), RecordInstances) -> Q [Dec] +genAll opts@Options{..} (r, instances) = do + putRecordInfo r + concatM $ [ + (:[]) <$> genNewtype opts r instances + , genIndexedAccessor opts r + , genIndexedOverwrite opts r + , when generateHasFieldInstances $ [ + genHasFieldInstances opts r + ] + -- If we generate the pattern synonym, there is no need to generate + -- field accessors, because GHC will generate them from the synonym + , when (generateFieldAccessors && not generatePatternSynonym) $ [ + genFieldAccessors opts r + ] + , when generateConstructorFn [ + genConstructorFn opts r + ] + , when generatePatternSynonym $ [ + genRecordView opts r + , genPatSynonym opts r + ] + , genGenericInstance opts r instances + , genGhcGenericsInstances opts r + ] + where + when :: Bool -> [Q [Dec]] -> Q [Dec] + when False _ = return [] + when True gen = concatM gen + +{------------------------------------------------------------------------------- + Generation: the type itself + + NOTE: All generation exampleshask assume as example + + > data T a b = MkT { + > tWord :: Word + > , tBool :: Bool + > , tChar :: Char + > , tA :: a + > , tListB :: [b] + > } + > deriving (Eq, Show) +-------------------------------------------------------------------------------} + +-- | Generate the newtype that will represent the record +-- +-- Generates something like +-- +-- > newtype T a b = TFromVector {vectorFromT :: Vector Any} +-- > deriving anyclass C -- where applicable +genNewtype :: Options -> Record () -> RecordInstances -> Q Dec +genNewtype _opts Record{..} RecordInstances{recordInstancesAnyclass} = + N.newtypeD + (cxt []) + (N.unqualified recordType) + recordTVars + Nothing + (N.recC (N.unqualified (nameRecordInternalConstr recordConstr)) [ + N.varBangType (N.unqualified (nameRecordInternalField recordType)) $ + bangType (return DefaultBang) [t| Vector Any |] + ]) + (map anyclassDerivClause recordInstancesAnyclass) + where + anyclassDerivClause :: Type -> DerivClauseQ + anyclassDerivClause clss = derivClause (Just AnyclassStrategy) [pure clss] + +{------------------------------------------------------------------------------- + Generation: field accessors + + TODO: If we had support within GHC itself for accessing fields in records, + we might be able to integrate this a lot more closely with normal GHC, + especially when combined with the @NoFieldSelectors@ extension. + + See +-------------------------------------------------------------------------------} + +-- | Generate the indexed field accessor +-- +-- Generates something like +-- +-- > unsafeGetIndexT :: forall x a b. Int -> T a b -> x +-- > unsafeGetIndexT = \ n t -> noInlineUnsafeCo (V.unsafeIndex (vectorFromT t) n) + +genIndexedAccessor :: Options -> Record () -> Q [Dec] +genIndexedAccessor _opts r@Record{..} = do + x <- newName "x" + simpleFn + (N.unqualified (nameRecordIndexedAccessor recordType)) + (forallT + (PlainTV x : recordTVars) + (cxt []) + (arrT [conT ''Int, recordTypeT N.Unqual r] (varT x))) + [| \n t -> noInlineUnsafeCo $ + V.unsafeIndex ($(recordToVectorE N.Unqual r) t) n + |] + +-- | Generate index field overwrite +-- +-- Generates something like +-- +-- > unsafeSetIndexT :: forall x a b. Int -> T a b -> x -> T a b +-- > unsafeSetIndexT = \n t val -> +-- > TFromVector (V.unsafeUpd (vectorFromT t) [(n, noInlineUnsafeCo val)]) +-- +-- If using 'allFieldsStrict', the function will be strict in @val@. +-- +-- TODO: We should support per-field strictness. +genIndexedOverwrite :: Options -> Record () -> Q [Dec] +genIndexedOverwrite Options{..} r@Record{..} = do + x <- newName "x" + simpleFn + (N.unqualified (nameRecordIndexedOverwrite recordType)) + (forallT + (PlainTV x : recordTVars) + (cxt []) + (arrT + [conT ''Int, recordTypeT N.Unqual r, varT x] + (recordTypeT N.Unqual r)) + ) + body + where + body :: Q Exp + body + | allFieldsStrict = + [| \n t !val -> $(recordFromVectorDontForceE N.Unqual r) ( + V.unsafeUpd ($(recordToVectorE N.Unqual r) t) + [(n, noInlineUnsafeCo val)] + ) + |] + | otherwise = + [| \n t val -> $(recordFromVectorDontForceE N.Unqual r) ( + V.unsafeUpd ($(recordToVectorE N.Unqual r) t) + [(n, noInlineUnsafeCo val)] + ) + |] + +-- | Generate field accessors for all fields +genFieldAccessors :: Options -> Record () -> Q [Dec] +genFieldAccessors opts r@Record{..} = + concatMapM (genFieldAccessor opts r) recordFields + +-- | Generate accessor for single field +-- +-- Generates function such as +-- +-- > tWord :: forall a b. T a b -> Word +-- > tWord = unsafeGetIndexT 0 +genFieldAccessor :: Options -> Record () -> Field () -> Q [Dec] +genFieldAccessor _opts r@Record{..} f@Field{..} = do + simpleFn + (N.unqualified fieldName) + (forallT recordTVars (cxt []) $ + arrT [recordTypeT N.Unqual r] (fieldTypeT f)) + (fieldUntypedAccessorE N.Unqual r f) + +-- | Generate 'HasField' instances for all fields +genHasFieldInstances :: Options -> Record () -> Q [Dec] +genHasFieldInstances opts r@Record{..} = + mapM (genHasFieldInstance opts r) recordFields + +-- | Generate 'HasField' instance for single field +-- +-- Generates something like +-- +-- > instance x ~ Word => HasField "tInt" (T a b) x where +-- > hasField = \t -> (unsafeSetIndexT 0 t, unsafeGetIndexT 0 t) +genHasFieldInstance :: Options -> Record () -> Field () -> Q Dec +genHasFieldInstance _opts r f@Field{..} = do + requiresExtensions [ + DataKinds + , FlexibleInstances + , MultiParamTypeClasses + , TypeFamilies + , UndecidableInstances + ] + x <- newName "x" + instanceD + (cxt [equalityT `appT` varT x `appT` fieldTypeT f]) + (appsT (conT ''HasField) [ + fieldNameT f + , recordTypeT N.Unqual r + , varT x + ]) + [valD (varP 'hasField) (normalB [| + \t -> ( $(fieldUntypedOverwriteE N.Unqual r f) t + , $(fieldUntypedAccessorE N.Unqual r f) t + ) + |]) []] + +{------------------------------------------------------------------------------- + Generation: constructor function +-------------------------------------------------------------------------------} + +-- | Construct a value of the record +-- +-- Generates something like +-- +-- > \tWord' tBool' tChar' tA' tListB' -> (..) (V.fromList [ +-- > , noInlineUnsafeCo tWord' +-- > , noInlineUnsafeCo tBool' +-- > , noInlineUnsafeCo tChar' +-- > , noInlineUnsafeCo tA' +-- > , noInlineUnsafeCo tListB' +-- > ]) +-- +-- where the " constructor " on the @"(..)"@ is generated by +-- 'recordFromUnforcedVectorQ', so that we correctly deal with strict/non-strict +-- fields. +-- +-- However, this function is slightly more general than this, generalizing over +-- the "kind of lambda" we want to construct. We use this both in +-- 'genPatSynonym' and in 'genConstructorFn'. +genRecordVal :: Options -> Record () -> ([Q Pat] -> Q Exp -> Q a) -> Q a +genRecordVal opts r@Record{..} mkFn = do + -- The constructor arguments are locally bound, and should not have the + -- same name as the fields themselves + vars <- mapM (N.newName . fieldName) recordFields + mkFn (map N.varLocalP vars) [| + $(recordFromVectorForceStrictFieldsE opts r) + $(vectorE qNoInlineUnsafeCo vars) + |] + where + qNoInlineUnsafeCo :: N.Name 'VarName 'N.Unique -> Q Exp + qNoInlineUnsafeCo x = [| noInlineUnsafeCo $(N.varE x) |] + +-- | Generate constructor function +-- +-- Generates something like +-- +-- > mkT :: forall a b. Word -> Bool -> Char -> a -> [b] -> T a b +-- > mkT = .. +-- +-- where the body of @mkT@ is generated by 'genRecordVal'. +genConstructorFn :: Options -> Record () -> Q [Dec] +genConstructorFn opts r@Record{..} = do + simpleFn + (N.unqualified (nameRecordTypedConstructorFn recordConstr)) + (forallT recordTVars (cxt []) $ + arrT + (map fieldTypeT recordFields) + (recordTypeT N.Unqual r) + ) + (genRecordVal opts r lamE) + +{------------------------------------------------------------------------------- + Generation: type-level metadata +-------------------------------------------------------------------------------} + +-- | Generate type-level metadata +-- +-- Generates something like +-- +-- > type MetadataOf (T a b) = '[ +-- > '("tInt", Word), +-- > , '("tBool", Bool), +-- > , '("tChar", Char), +-- > , '("tA", a), +-- > , '("tListB", [b]) +-- > ] +-- +-- NOTE: We do not use type-level lists in most places, since it's difficult +-- to avoid quadratic core code size when working with type-level list. We use +-- this meta-data currently for two purposes only: +-- +-- * The 'lr' quasi-quoter uses it as a way to lookup the record definition. +-- See "Data.Record.Internal.RecordInfo.Resolution.GHC". +-- * We use it to put a constraint on 'normalize'; this constraint is carefully +-- defined to avoid quadratic core code size. +-- See "Data.Record.Generic.Transform". +genInstanceMetadataOf :: Options -> Record () -> Q Dec +genInstanceMetadataOf _opts r@Record{..} = tySynInstD $ + tySynEqn + Nothing + [t| MetadataOf $(recordTypeT N.Unqual r) |] + (plistT $ map fieldMetadata recordFields) + where + fieldMetadata :: Field () -> Q Type + fieldMetadata f = ptupleT [fieldNameT f, fieldTypeT f] + +{------------------------------------------------------------------------------- + Generation: pattern synonym +-------------------------------------------------------------------------------} + +-- | Generate view on the record +-- +-- Generates function such as +-- +-- > tupleFromT :: forall a b. T a b -> (Word, Bool, Char, a, [b]) +-- > tupleFromT = \x -> ( +-- > unsafeGetIndexT 0 x +-- > , unsafeGetIndexT 1 x +-- > , unsafeGetIndexT 2 x +-- > , unsafeGetIndexT 3 x +-- > , unsafeGetIndexT 4 x +-- > ) +-- +-- Modulo tuple nesting (see 'nest'). +genRecordView :: Options -> Record () -> Q [Dec] +genRecordView _opts r@Record{..} = do + simpleFn + (N.unqualified (nameRecordView recordType)) + (forallT recordTVars (cxt []) $ + arrT [recordTypeT N.Unqual r] viewType + ) + viewBody + where + viewType :: Q Type + viewType = mkTupleT fieldTypeT $ + nest DefaultGhcTupleLimit recordFields + + viewBody :: Q Exp + viewBody = do + x <- newName "x" + lamE [varP x] $ mkTupleE (viewField x) $ + nest DefaultGhcTupleLimit recordFields + + -- We generate the view only if we are generating the pattern synonym, + -- but when we do we don't generate the typed accessors, because they + -- are instead derived from the pattern synonym by GHC. Since the synonym + -- requires the view, we therefore use the untyped accessor here. + viewField :: Name -> Field () -> Q Exp + viewField x f = [| $(fieldUntypedAccessorE N.Unqual r f) $(varE x) |] + +-- | Generate pattern synonym +-- +-- Constructs something like this: +-- +-- > pattern MkT :: forall a b. Word -> Bool -> Char -> a -> [b] -> T a b +-- > pattern MkT{tWord, tBool, tChar, tA, tListB} <- +-- > (tupleFromT -> (tWord, tBool, tChar, tA, tListB) ) +-- > where +-- > MkT tWord' tBool' tChar' tA' tListB' = .. +-- > +-- > {-# COMPLETE MkT #-} +-- +-- modulo nesting ('nest'), where the body of 'MkT' (and its arguments) are +-- constructed by 'genRecordVal'. +genPatSynonym :: Options -> Record () -> Q [Dec] +genPatSynonym opts r@Record{..} = do + requiresExtensions [PatternSynonyms, ViewPatterns] + sequence [ + N.patSynSigD (N.unqualified recordConstr) $ + simplePatSynType + recordTVars + (map fieldTypeT recordFields) + (recordTypeT N.Unqual r) + , N.patSynD (N.unqualified recordConstr) + (N.recordPatSyn $ map fieldName recordFields) + qDir + matchVector + , N.pragCompleteD [N.unqualified recordConstr] Nothing + ] + where + matchVector :: Q Pat + matchVector = viewP (N.varE (N.unqualified (nameRecordView recordType))) $ + mkTupleP (N.varGlobalP . N.unqualified . fieldName) $ + nest DefaultGhcTupleLimit recordFields + + constrVector :: [Q Pat] -> Q Exp -> Q Clause + constrVector xs body = clause xs (normalB body) [] + + qDir :: Q PatSynDir + qDir = explBidir . (:[]) $ genRecordVal opts r constrVector + +{------------------------------------------------------------------------------- + Generation: Generic instance +-------------------------------------------------------------------------------} + +-- | Generate the class we will use to instantiate 'Constraints' +-- +-- Generates something like this: +-- +-- > class Constraints_T a b (c :: Type -> Constraint) where +-- > dictConstraints_T :: Proxy c -> Rep (Dict c) (T a b) +-- +-- NOTE: It is critical that we don't give the class any superclass constraints +-- like +-- +-- > class (c Word, c Bool, c Char, c a, c [b]) +-- > => Constraints_T a b (c :: Type -> Constraint) +-- +-- because then @ghc@ would use resolve @Constraints_T@ to that tuple instead, +-- and use lots of "tuple constraint extractor" functions, each of which have +-- the same size as the number of constraints (another example of a +-- @case f of { T x1 x2 x3 .. -> xn@ function, but now at the dictionary level). +genConstraintsClass :: Options -> Record () -> Q Dec +genConstraintsClass _opts r@Record{..} = do + requiresExtensions [KindSignatures, ConstraintKinds] + c <- newName "c" + k <- [t| Kind.Type -> Kind.Constraint |] + N.classD + (cxt []) + (N.unqualified (nameRecordConstraintsClass recordType)) + (recordTVars ++ [KindedTV c k]) + [] + [ N.sigD (N.unqualified (nameRecordConstraintsMethod recordType)) [t| + Proxy $(varT c) -> Rep (Dict $(varT c)) $(recordTypeT N.Unqual r) + |] + ] + +-- | Superclass constraints required by the constraints class instance +-- +-- Generates something like +-- +-- > (c Word, c Bool, c Char, c a, c [b]) +-- +-- However, we filter out constraints that are type variable free, so if we +-- pass, say, @Show@ for @c@, then we generate +-- +-- > (Show a, Show [b]) +-- +-- instead. This avoids @ghc@ complaining about +-- +-- > Redundant constraints: (Show Word, Show Bool, Show Char) +genRequiredConstraints :: Options -> Record () -> Q Type -> Q Cxt +genRequiredConstraints _opts Record{..} c = do + requiresExtensions [FlexibleContexts] + constraints <- mapM constrainField recordFields + return $ nub $ filter hasTypeVar constraints + where + constrainField :: Field () -> Q Pred + constrainField f = c `appT` fieldTypeT f + + hasTypeVar :: Pred -> Bool + hasTypeVar = SYB.everything (||) (SYB.mkQ False isTypeVar) + + isTypeVar :: Type -> Bool + isTypeVar (VarT _) = True + isTypeVar _otherwise = False + +-- | Generate the dictionary creation function ('dict') +-- +-- Generates something like +-- +-- > \p -> Rep (V.fromList [ +-- > noInlineUnsafeCo (dictFor p (Proxy :: Proxy Word)) +-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Bool)) +-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy Char)) +-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy a)) +-- > , noInlineUnsafeCo (dictFor p (Proxy :: Proxy [b])) +-- > ]) +genDict :: Options -> Record () -> Q Exp +genDict _opts Record{..} = do + p <- newName "p" + lamE [varP p] [| Rep $(vectorE (dictForField p) recordFields) |] + where + dictForField :: Name -> Field () -> Q Exp + dictForField p f = [| + noInlineUnsafeCo (dictFor $(varE p) (Proxy :: Proxy $(fieldTypeT f))) + |] + +-- | Generate (one and only) instance of the constraints class +-- +-- Generates something like +-- +-- > instance (..) => Constraints_T a b c where +-- > dictConstraints_T = .. +-- +-- where the body of @dictConstraints_T@ is generated by 'genDict'. +genConstraintsClassInstance :: Options -> Record () -> Q Dec +genConstraintsClassInstance opts r@Record{..} = do + requiresExtensions [ScopedTypeVariables] + c <- newName "c" + instanceD + (genRequiredConstraints opts r (varT c)) + (appsT (N.conT (N.unqualified (nameRecordConstraintsClass recordType))) $ + map tyVarType recordTVars ++ [varT c]) + [ valD (N.varGlobalP (N.unqualified (nameRecordConstraintsMethod recordType))) + (normalB (genDict opts r)) + [] + ] + +-- | Generate the Constraints type family instance +-- +-- Generates something like +-- +-- > type Constraints (T a b) = Constraints_T a b +genInstanceConstraints :: Options -> Record () -> Q Dec +genInstanceConstraints _opts r@Record{..} = tySynInstD $ + tySynEqn + Nothing + [t| Constraints $(recordTypeT N.Unqual r) |] + (appsT (N.conT (N.unqualified (nameRecordConstraintsClass recordType))) $ + map tyVarType recordTVars) + +-- | Generate metadata +-- +-- Generates something like +-- +-- > \_p -> Metadata { +-- > recordName = "T" +-- > , recordConstructor = "MkT" +-- > , recordSize = 5 +-- > , recordFieldMetadata = Rep $ Data.Vector.fromList [ +-- > FieldMetadata (Proxy :: Proxy "tInt")) FieldLazy +-- > , FieldMetadata (Proxy :: Proxy "tBool")) FieldLazy +-- > , FieldMetadata (Proxy :: Proxy "tChar")) FieldLazy +-- > , FieldMetadata (Proxy :: Proxy "tA")) FieldLazy +-- > , FieldMetadata (Proxy :: Proxy "tListB")) FieldLazy +-- > ] +-- > } +genMetadata :: Options -> Record () -> Q Exp +genMetadata Options{..} r@Record{..} = do + p <- newName "_p" + lamE [varP p] $ recConE 'Metadata [ + fieldExp 'recordName $ recordTypeE r + , fieldExp 'recordConstructor $ recordConstrE r + , fieldExp 'recordSize $ litE (integerL numFields) + , fieldExp 'recordFieldMetadata $ [| Rep.Rep $ V.fromList $fieldMetadata |] + ] + where + numFields :: Integer + numFields = fromIntegral $ length recordFields + + fieldMetadata :: Q Exp + fieldMetadata = listE $ map mkFieldMetadata recordFields + + mkFieldMetadata :: Field () -> ExpQ + mkFieldMetadata f = [| + FieldMetadata + (Proxy :: Proxy $(fieldNameT f) ) + $(if allFieldsStrict + then [| FieldStrict |] + else [| FieldLazy |]) + |] + +-- | Generate instance for specific class +-- +-- Generates one of the following: +-- +-- * 'Show': +-- +-- > instance (..) => Eq (T a b) where +-- > (==) = geq +-- +-- * 'Eq': +-- +-- > instance (..) => Show (T a b) where +-- > showsPrec = gshowsPrec +-- +-- where the @(..)@ constraints are generated by 'genRequiredConstraints' +-- (i.e., a constraint for each field). +-- +-- TODO: Think about DeriveFunctor? +genDeriving :: Options -> Record () -> Deriving -> Q Dec +genDeriving opts r = \case + DeriveEq -> inst ''Eq '(==) 'geq + DeriveOrd -> inst ''Ord 'compare 'gcompare + DeriveShow -> inst ''Show 'showsPrec 'gshowsPrec + where + inst :: Name -> Name -> Name -> Q Dec + inst clss fn gfn = + instanceD + (genRequiredConstraints opts r (conT clss)) + [t| $(conT clss) $(recordTypeT N.Unqual r) |] + [valD (varP fn) (normalB (varE gfn)) []] + +-- | Generate definition for `from` in the `Generic` instance +-- +-- Generates something like +-- +-- > repFromVectorStrict . vectorFromT +genFrom :: Options -> Record () -> Q Exp +genFrom _opts Record{..} = [| + repFromVector + . $(N.varE (N.unqualified (nameRecordInternalField recordType))) + |] + +-- | Generate definition for `to` in the `Generic` instance +-- +-- > (..) . repToVector +-- +-- where the @(..)@ is generated by 'recordFromVectorForceStrictFieldsE' +-- (which will any strict fields in the vector). +genTo :: Options -> Record () -> Q Exp +genTo opts r = [| + $(recordFromVectorForceStrictFieldsE opts r) + . repToVector + |] + +-- | Generate the definitions required to provide the instance for 'Generic' +-- +-- > instance Generic T where +-- > type Constraints T = Constraints_T +-- > from = coerce +-- > to = coerce +-- > dict = dictConstraints_T +-- > metadata = .. +genGenericInstance :: Options -> Record () -> RecordInstances -> Q [Dec] +genGenericInstance opts r@Record{..} RecordInstances{recordInstancesDerived} = + concatM [ + sequence [ + genConstraintsClass opts r + , genConstraintsClassInstance opts r + , instanceD + (cxt []) + [t| Generic $(recordTypeT N.Unqual r) |] + [ genInstanceConstraints opts r + , genInstanceMetadataOf opts r + , valD (varP 'from) (normalB $ genFrom opts r) [] + , valD (varP 'to) (normalB $ genTo opts r) [] + , valD (varP 'dict) (normalB $ N.varE . N.unqualified . nameRecordConstraintsMethod $ recordType) [] + , valD (varP 'metadata) (normalB $ genMetadata opts r) [] + ] + ] + , mapM (genDeriving opts r) recordInstancesDerived + ] + +{------------------------------------------------------------------------------- + GHC generics +-------------------------------------------------------------------------------} + +-- | Generate GHC generics instance +-- +-- Generates something like +-- +-- > instance GHC.Generic ExampleRecord where +-- > type Rep ExampleRecord = ThroughLRGenerics ExampleRecord +-- > +-- > from = WrapThroughLRGenerics +-- > to = unwrapThroughLRGenerics +-- +-- See 'ThroughLRGenerics' for documentation. + +genGhcGenericsInstances :: Options -> Record () -> Q [Dec] +genGhcGenericsInstances _opts r = sequenceA [ + instanceD + (cxt []) + [t| GHC.Generic $(recordTypeT N.Unqual r) |] + [ tySynInstD $ + tySynEqn + Nothing + [t| GHC.Rep $(recordTypeT N.Unqual r) |] + [t| ThroughLRGenerics $(recordTypeT N.Unqual r) |] + , valD (varP 'GHC.from) (normalB (conE 'WrapThroughLRGenerics)) [] + , valD (varP 'GHC.to) (normalB (varE 'unwrapThroughLRGenerics)) [] + ] + ] + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +-- | Construct record from the underlying @Vector Any@, forcing strict fields +-- +-- Currently either /all/ fields are strict or /none/, so we either just force +-- all fields, or none of them. +-- +-- See also 'recordFromVectorDontForceE'. +recordFromVectorForceStrictFieldsE :: Options -> Record () -> Q Exp +recordFromVectorForceStrictFieldsE Options{..} r + | allFieldsStrict = [| + \v -> rnfVectorAny v `seq` $(recordFromVectorDontForceE N.Unqual r) v + |] + | otherwise = + recordFromVectorDontForceE N.Unqual r + +{------------------------------------------------------------------------------- + Fix TH naming + + TH distinguishes between global names (names from an explicit package/module), + dynamically bound names that are resolved and bound after splicing in, and + unique names, that are meant to be different from all other names. + + Specifically, 'mkName' is intended to create names that are meant to be + capturable after splicing; 'mkName' generates dynamic names. + + For some strange reason however binder names of declarations in a @[d| ... |]@ + splice are given a unique name rather than a dynamic name. This is + inconsistent, and complicates the already complicated story for correctly + dealing with names. We therefore " fix " this here and makes those names + dynamic. + + Since we are only interested in declaration splices containing /type/ + declarations, nothing else, it suffices to drop the uniques from type + constructors. Type /variables/ can (and should) remain to have a unique + flavour, as they are locally bound by the type declarations. +-------------------------------------------------------------------------------} + +dropUniques :: [Dec] -> [Dec] +dropUniques = SYB.everywhere (SYB.mkT dropUnique) + where + dropUnique :: Type -> Type + dropUnique (ConT n@(TH.Name occ flavour)) = ConT $ + case flavour of + TH.NameU _ -> TH.Name occ TH.NameS + _otherwise -> n + dropUnique typ = typ diff --git a/src/Data/Record/TH/CodeGen/Tree.hs b/src/Data/Record/TH/CodeGen/Tree.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/TH/CodeGen/Tree.hs @@ -0,0 +1,139 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Data.Record.TH.CodeGen.Tree ( + -- * Trees and forests + Tree(..) + , Forest(..) + -- * Catamorphisms + , Cata(..) + , tree + , forest + -- * Dealing with @ghc@'s tuple size limit + , TupleLimit(..) + , nest + , mkTupleE + , mkTupleT + , mkTupleP + ) where + +import Language.Haskell.TH + +import Data.Record.Internal.TH.Util + +{------------------------------------------------------------------------------- + Trees and forests +-------------------------------------------------------------------------------} + +-- | Trees with values at the leaves +data Tree a = Leaf a | Branch (Forest a) deriving (Show) +data Forest a = Forest [Tree a] deriving (Show) + +{------------------------------------------------------------------------------- + Catamorphisms + + Unlike regular folds, these catamorphisms are structure preserving. + See "Dealing with Large Bananas", by Ralf Lämmel et al +-------------------------------------------------------------------------------} + +data Cata a b = Cata { + leaf :: a -> b + , branch :: [b] -> b + } + +tree :: Cata a b -> Tree a -> b +tree cata (Leaf a) = leaf cata a +tree cata (Branch as) = forest cata as + +forest :: Cata a b -> Forest a -> b +forest cata (Forest ts) = branch cata (map (tree cata) ts) + +{------------------------------------------------------------------------------- + Nesting +-------------------------------------------------------------------------------} + +-- | Observe @ghc@'s tuple length +-- +-- Haskell has a limit of 62 fields per tuple. Here we take an arbitrary +-- list and turn it into a nested tuple that preserves this limit. +-- +-- Example: if we reduce the limit to @2@, we get the following nestings, +-- for lengths @[1..10]@: +-- +-- > A +-- > (A, A) +-- > ((A, A), A) +-- > ((A, A), (A, A)) +-- > (((A, A), (A, A)), A) +-- > (((A, A), (A, A)), (A, A)) +-- > (((A, A), (A, A)), ((A, A), A)) +-- > (((A, A), (A, A)), ((A, A), (A, A))) +-- > ((((A, A), (A, A)), ((A, A), (A, A))), A) +-- > ((((A, A), (A, A)), ((A, A), (A, A))), (A, A)) +nest :: TupleLimit -> [a] -> Forest a +nest mLimit = go . map Leaf + where + go :: [Tree a] -> Forest a + go ts | length ts < limit = Forest ts + | otherwise = go (map (Branch . Forest) (chunk limit ts)) + + limit :: Int + limit = case mLimit of + DefaultGhcTupleLimit -> 62 + MaxTupleElems n -> n + +-- | Maximum number of elements in a tuple +data TupleLimit = + -- | Default maximum number of elements in a tuple in ghc (62) + DefaultGhcTupleLimit + + -- | Explicit specified liit + | MaxTupleElems Int + +{------------------------------------------------------------------------------- + Constructing nested types/values/patterns +-------------------------------------------------------------------------------} + +-- | Construct tuple type +mkTupleT :: forall a. (a -> Q Type) -> Forest a -> Q Type +mkTupleT f = forest cata + where + cata :: Cata a (Q Type) + cata = Cata { + leaf = f + , branch = \case [t] -> t + ts -> appsT (tupleT (length ts)) ts + } + +-- | Construct tuple expression +mkTupleE :: forall a. (a -> Q Exp) -> Forest a -> Q Exp +mkTupleE f = forest cata + where + cata :: Cata a (Q Exp) + cata = Cata { + leaf = f + , branch = \case [e] -> e + es -> tupE es + } + +-- | Construct tuple pattern +mkTupleP :: forall a. (a -> Q Pat) -> Forest a -> Q Pat +mkTupleP f = forest cata + where + cata :: Cata a (Q Pat) + cata = Cata { + leaf = f + , branch = \case [p] -> p + ps -> tupP ps + } + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +chunk :: Int -> [a] -> [[a]] +chunk n = go + where + go :: [a] -> [[a]] + go [] = [] + go xs = let (firstChunk, rest) = splitAt n xs in firstChunk : go rest diff --git a/src/Data/Record/TH/Config/Options.hs b/src/Data/Record/TH/Config/Options.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/TH/Config/Options.hs @@ -0,0 +1,133 @@ +-- | Options that influence TH code generation +module Data.Record.TH.Config.Options ( + Options(..) + , defaultStrictOptions + , defaultLazyOptions + , defaultPureScript + ) where + +{------------------------------------------------------------------------------- + Options +-------------------------------------------------------------------------------} + +-- | Tweak the output of the generator +-- +-- In the explanations of the various options below, we will use the following +-- record as our running example: +-- +-- > data T a b = MkT { +-- > tWord :: Word +-- > , tBool :: Bool +-- > , tChar :: Char +-- > , tA :: a +-- > , tListB :: [b] +-- > } +-- > deriving (Eq, Show) +data Options = Options { + -- | Generate a pattern synonym for the record + -- + -- > pattern MkT :: Word -> Bool -> Char -> a -> [b] -> T a b + -- > pattern MkT{tInt, tBool, tChar, tA, tListB} <- .. + -- > where + -- > MkT tInt' tBool' tChar' tA' tListB' = .. + -- + -- The pattern synonym makes it possible to construct or pattern match on + -- @T@ values as if it had been defined like a normal record. + -- + -- We do /not/ do this by default, however, because unfortunately when + -- we define a record pattern synonym in @ghc@, @ghc@ also (unnecessarily + -- but currently unavoidably) introduces field accessors for all fields + -- in the record, and we're back to code that is quadratic in size. + -- + -- Avoid if possible. + generatePatternSynonym :: Bool + + -- | Generate a "constructor function" for the record + -- + -- > _construct_MkT :: Word -> Bool -> Char -> a -> [b] -> T a b + -- > _construct_MkT = .. + -- + -- This function can be used directly, but it is also used by the 'lr' + -- quasi-quoter, so if this function is not generated, 'lr' will not work. + , generateConstructorFn :: Bool + + -- | Generate 'HasField' instances + -- + -- > instance HasField "tInt" (T a b) Word where + -- > hasField = .. + -- + -- These are required by the @record-dot-preprocessor@. + , generateHasFieldInstances :: Bool + + -- | Generate field accessors + -- + -- > tInt :: T a b -> Word + -- > tInt = .. + -- + -- If field accessors are not generated, the only way to access fields + -- is through the 'HasField' instances. + -- + -- Disabling this option is primarily useful if you need overloading: + -- if you have multiple records with a field of the same name, then + -- generating field accessors would result in name clashes. Without the + -- accessors, overloading is resolved through 'HasField'. + , generateFieldAccessors :: Bool + + -- | Make all fields strict + -- + -- This should be used when using the @StrictData@ or @Strict@ language + -- extension. + , allFieldsStrict :: Bool + } + +{------------------------------------------------------------------------------- + Defaults +-------------------------------------------------------------------------------} + +defaultLazyOptions :: Options +defaultLazyOptions = Options { + generatePatternSynonym = False + , generateConstructorFn = True + , generateHasFieldInstances = True + , generateFieldAccessors = True + , allFieldsStrict = False + } + +defaultStrictOptions :: Options +defaultStrictOptions = Options { + generatePatternSynonym = False + , generateConstructorFn = True + , generateHasFieldInstances = True + , generateFieldAccessors = True + , allFieldsStrict = True + } + +-- | Default options for "Purescript style" records +-- +-- That is: +-- +-- * All fields are strict +-- * We do /not/ generate field accessors: fields must be accessed and updated +-- through the 'HasField' instances (e.g., @record-dot-preprocessor@ syntax). +-- +-- We do not introduce a pattern synonym by default: +-- +-- * Introducing a pattern synonym reintroduces code that is quadratic in size. +-- * Perhaps more importantly, it would make it impossible to define two records +-- with the same field names in a single module, as the field accessors +-- (unnecessarily but currently unavoidably) introduced by the pattern synonym +-- would clash. +-- +-- NOTE: The @record-dot-preprocessor@ enables @DuplicateRecordFields@ by +-- default. Since the records that we produce are not visible to @ghc@, +-- @large-records@ is not compatible with DRF-style overloading. However, as +-- long as all overloading is resolved through @HasField@ instead (which is +-- what @record-dot-preprocessor@ encourages anyway), all is fine. +defaultPureScript :: Options +defaultPureScript = Options { + generatePatternSynonym = False + , generateConstructorFn = True + , generateHasFieldInstances = True + , generateFieldAccessors = False + , allFieldsStrict = True + } diff --git a/src/Data/Record/TH/Runtime.hs b/src/Data/Record/TH/Runtime.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/TH/Runtime.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Functions to support the TH code (i.e., functions called by generated code) +-- +-- NOTE: We leave the generic representation type as lazy, and only force +-- values once we translate back to the type itself. This means that we can +-- chain generic functions and get some kind of fusion without having to +-- traverse records multiple times. +module Data.Record.TH.Runtime ( + -- * Miscellaneous + dictFor + , repFromVector + , repToVector + , rnfVectorAny + , noInlineUnsafeCo + ) where + +import Data.Coerce (coerce) +import Data.Proxy +import Data.Vector (Vector) +import GHC.Exts (Any) +import Unsafe.Coerce (unsafeCoerce) + +import qualified Data.Vector as V + +import Data.Record.Generic + +{------------------------------------------------------------------------------- + Miscellaneous +-------------------------------------------------------------------------------} + +dictFor :: c x => Proxy c -> Proxy x -> Dict c x +dictFor _ _ = Dict + +repFromVector :: Vector Any -> Rep I a +repFromVector = coerce + +repToVector :: Rep I a -> Vector Any +repToVector = coerce + +rnfVectorAny :: Vector Any -> () +rnfVectorAny = rnfElems . V.toList + where + rnfElems :: [Any] -> () + rnfElems [] = () + rnfElems (x:xs) = x `seq` rnfElems xs + +-- | Avoid potential segfault with ghc < 9.0 +-- +-- See . +-- I haven't actually seen this fail in large-records, but we saw it fail in +-- the compact representation branch of sop-core, and what we do here is not +-- so different, so better to play it safe. +noInlineUnsafeCo :: forall a b. a -> b +{-# NOINLINE noInlineUnsafeCo #-} +noInlineUnsafeCo = unsafeCoerce + diff --git a/test/Test/Record/Prop/Show.hs b/test/Test/Record/Prop/Show.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Prop/Show.hs @@ -0,0 +1,15 @@ +module Test.Record.Prop.Show (tests) where + +import Test.Tasty +import Test.Tasty.QuickCheck + +import qualified Test.Record.Prop.Show.Regular as Regular +import qualified Test.Record.Prop.Show.Large as Large + +tests :: TestTree +tests = testGroup "Test.Record.Prop.Show" [ + testProperty "show" prop_show + ] + +prop_show :: Regular.Example1 -> Property +prop_show ex = show ex === show (Large.fromRegular ex) diff --git a/test/Test/Record/Prop/Show/Large.hs b/test/Test/Record/Prop/Show/Large.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Prop/Show/Large.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Test.Record.Prop.Show.Large ( + FromRegular(..) + , Example1(..) + ) where + +import Data.Record.TH + +import qualified Test.Record.Prop.Show.Regular as Regular + +class FromRegular a b | a -> b, b -> a where + fromRegular :: a -> b + +largeRecord defaultPureScript [d| + data Example1 = MkExample1 { + example1Field1 :: Int + , example1Field2 :: Bool + } + deriving (Show) + |] + +instance FromRegular Regular.Example1 Example1 where + fromRegular Regular.MkExample1{..} = [lr| MkExample1 { + example1Field1 = example1Field1 + , example1Field2 = example1Field2 + } |] diff --git a/test/Test/Record/Prop/Show/Regular.hs b/test/Test/Record/Prop/Show/Regular.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Prop/Show/Regular.hs @@ -0,0 +1,22 @@ +module Test.Record.Prop.Show.Regular ( + Example1(..) + ) where + +import Test.QuickCheck + +data Example1 = MkExample1 { + example1Field1 :: Int + , example1Field2 :: Bool + } + deriving (Show) + +instance Arbitrary Example1 where + arbitrary = MkExample1 <$> arbitrary <*> arbitrary + shrink (MkExample1 f1 f2) = concat [ + [ MkExample1 f1' f2 + | f1' <- shrink f1 + ] + , [ MkExample1 f1 f2' + | f2' <- shrink f2 + ] + ] diff --git a/test/Test/Record/Prop/ToFromJSON.hs b/test/Test/Record/Prop/ToFromJSON.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Prop/ToFromJSON.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Test.Record.Prop.ToFromJSON (tests) where + +import Data.Aeson +import Data.Aeson.Types + +import Data.Record.TH +import Data.Record.Generic.JSON + +import Test.Tasty +import Test.Tasty.QuickCheck + +{------------------------------------------------------------------------------- + Test that gtoJSON and gfromJSON are inverse +-------------------------------------------------------------------------------} + +largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d| + data A = MkA { + ax :: Int + , ay :: Bool + } + deriving (Show, Eq) + |] + +instance Arbitrary A where + arbitrary = MkA <$> arbitrary <*> arbitrary + shrink MkA{ax = x, ay = y} = concat [ + (\x' -> MkA x' y ) <$> shrink x + , (\y' -> MkA x y') <$> shrink y + ] + +instance ToJSON A where toJSON = gtoJSON +instance FromJSON A where parseJSON = gparseJSON + +{------------------------------------------------------------------------------- + Top-level tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Prop.ToFromJSON" [ + testProperty "tofromJSON" prop_tofromJSON + ] + +prop_tofromJSON :: A -> Property +prop_tofromJSON a = + counterexample (show (toJSON a)) + $ Right a === parseEither parseJSON (toJSON a) diff --git a/test/Test/Record/Sanity/Derive.hs b/test/Test/Record/Sanity/Derive.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/Derive.hs @@ -0,0 +1,175 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-} +{-# OPTIONS_GHC -Wno-unused-top-binds #-} +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Test.Record.Sanity.Derive (tests) where + +import Control.Newtype +import Data.Functor.Identity +import Data.Kind +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Record.TH + +{------------------------------------------------------------------------------- + Class of kind @Type -> Constraint@. +-------------------------------------------------------------------------------} + +class C1 (a :: Type) where + c1 :: a -> String + c1 _ = "x" + +-- Type of kind @Type@ + +largeRecord defaultPureScript [d| + data LA1 = MkLA1 { la1_f1 :: Int } + deriving anyclass C1 + |] + +-- Type of kind @Type -> Type@ (regular and large example) + +data RA2 a = MkRA1 { ra2_f1 :: a } + deriving anyclass C1 + +largeRecord defaultPureScript [d| + data LA2 a = MkLA2 { la2_f1 :: a } + deriving anyclass C1 + |] + +{------------------------------------------------------------------------------- + Class of kind @Type -> Type -> Constraint@, partially instantiated. + (From a purely kind point of view, this is no different to the previous + sectiono, of course.) + + To make transpilation easier, the PureScript to Haskell transpiler makes + all records as being a "newtype of themselves" (in PureScript, something like + + > newtype T = MkT { a :: Int, b :: Bool } + + really is a newtype around a record). +-------------------------------------------------------------------------------} + +largeRecord defaultPureScript [d| + data LB = MkLB { lb1 :: Int, lb2 :: Int } + deriving anyclass (Newtype LB) + |] + +f :: LB -> LB +f r = pack ((unpack r){ lb1 = r.lb2, lb2 = r.lb1 }) + +{------------------------------------------------------------------------------- + Class of kind @(Type -> Type) -> Constraint@ +-------------------------------------------------------------------------------} + +class C3 (f :: Type -> Type) where + c3 :: f Bool -> String + c3 _ = "x" + +-- Regular (non-large) example +data RC a = MkRC { rc1 :: a, rc2 :: Int } + deriving anyclass C3 + +largeRecord defaultPureScript [d| + data LC (a :: Type) = MkLC { lc1 :: a, lc2 :: Int } + deriving anyclass C3 + |] + +{------------------------------------------------------------------------------- + Class of kind @((Type -> Type) -> Type) -> Constraint@ +-------------------------------------------------------------------------------} + +class C4 (f :: (Type -> Type) -> Type) where + c4 :: f Identity -> String + c4 _ = "x" + +-- Regular (non-large) example +data RD f = MkRD { rd1 :: f Int, rd2 :: Int } + deriving anyclass C4 + +largeRecord defaultPureScript [d| + data LD (f :: Type -> Type) = MkLD { ld1 :: f Int, ld2 :: Int } + deriving anyclass C4 + |] + +{------------------------------------------------------------------------------- + Class with a constraint +-------------------------------------------------------------------------------} + +class Show a => C5 (a :: Type) where + c5 :: a -> String + c5 = show + +-- Regular (non-large) example +data RE = MkRE { re1 :: Int, re2 :: Bool } + deriving stock Show + deriving anyclass C5 + +largeRecord defaultPureScript [d| + data LE = MkLE { le1 :: Int, le2 :: Bool } + deriving stock Show + deriving anyclass C5 + |] + +{------------------------------------------------------------------------------- + Tests proper +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.Derive" [ + testCase "kind 'Type -> Constraint'" test_c1 + , testCase "kind 'Type -> Type -> Constraint', partially applied" test_newtype + , testCase "kind '(Type -> Type) -> Constraint'" test_c3 + , testCase "kind '((Type -> Type) -> Type) -> Constraint'" test_c4 + , testCase "kind 'Type -> Constraint', superclass constraint" test_c5 + ] + +test_c1 :: Assertion +test_c1 = do + assertEqual "type of kind 'Type'" (c1 la1) "x" + assertEqual "type of kind 'Type -> Type'" (c1 la2) "x" + where + la1 :: LA1 + la1 = [lr| MkLA1 { la1_f1 = 1 } |] + + la2 :: LA2 Int + la2 = [lr| MkLA2 { la2_f1 = 1 } |] + +test_newtype :: Assertion +test_newtype = + assertEqual "" r'.lb1 2 + where + r :: LB + r = [lr| MkLB { lb1 = 1, lb2 = 2 }|] + + r' :: LB + r' = f r + +test_c3 :: Assertion +test_c3 = + assertEqual "" (c3 r) "x" + where + r :: LC Bool + r = [lr| MkLC { lc1 = True, lc2 = 2 } |] + +test_c4 :: Assertion +test_c4 = + assertEqual "" (c4 r) "x" + where + r :: LD Identity + r = [lr| MkLD { ld1 = Identity 1, ld2 = 2 } |] + +test_c5 :: Assertion +test_c5 = + assertEqual "" (c5 r) "MkLE {le1 = 1, le2 = True}" + where + r :: LE + r = [lr| MkLE { le1 = 1, le2 = True } |] diff --git a/test/Test/Record/Sanity/EqualFieldTypes.hs b/test/Test/Record/Sanity/EqualFieldTypes.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/EqualFieldTypes.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- The point of this module is to verify that largeRecord does not generate +-- redundant constraints +{-# OPTIONS_GHC -Werror -Wredundant-constraints #-} + +module Test.Record.Sanity.EqualFieldTypes (tests) where + +import Data.Record.TH +import Test.Tasty + +largeRecord defaultPureScript [d| + data R a = MkR { + field1 :: a + , field2 :: a + } + deriving (Show, Eq) + |] + +-- The test is compilation itself +tests :: TestTree +tests = testGroup "Test.Record.Sanity.EqualFieldTypes" [] diff --git a/test/Test/Record/Sanity/ErrorsAndWarnings.hs b/test/Test/Record/Sanity/ErrorsAndWarnings.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/ErrorsAndWarnings.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Test.Record.Sanity.ErrorsAndWarnings (tests) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Test.Record.Util +import Test.Record.Sanity.ErrorsAndWarnings.Stage1 + +problemsForSyntaxErrorInExp :: (Maybe String, [Problem]) +problemsForSyntaxErrorInExp = $qProblemsForSyntaxErrorInExp + +problemsForSyntaxErrorInPat :: (Maybe String, [Problem]) +problemsForSyntaxErrorInPat = $qProblemsForSyntaxErrorInPat + +problemsForUnknownFieldsInExp :: (Maybe String, [Problem]) +problemsForUnknownFieldsInExp = $qProblemsForUnknownFieldsInExp + +problemsForUnknownFieldsInPat :: (Maybe String, [Problem]) +problemsForUnknownFieldsInPat = $qProblemsForUnknownFieldsInPat + +problemsForMissingFieldsInExp :: (Maybe String, [Problem]) +problemsForMissingFieldsInExp = $qProblemsForMissingFieldsInExp + +problemsForMissingFieldsInPat :: (Maybe String, [Problem]) +problemsForMissingFieldsInPat = $qProblemsForMissingFieldsInPat + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.ErrorsAndWarnings" [ + testCase "problemsForSyntaxErrorInExp" test_problemsForSyntaxErrorInExp + , testCase "problemsForSyntaxErrorInPat" test_problemsForSyntaxErrorInPat + , testCase "problemsForUnknownFieldsInExp" test_problemsForUnknownFieldsInExp + , testCase "problemsForUnknownFieldsInPat" test_problemsForUnknownFieldsInPat + , testCase "problemsForMissingFieldsInExp" test_problemsForMissingFieldsInExp + , testCase "problemsForMissingFieldsInPat" test_problemsForMissingFieldsInPat + ] + +test_problemsForSyntaxErrorInExp :: Assertion +test_problemsForSyntaxErrorInExp = do + assertJust "no failure reported" (fst problemsForSyntaxErrorInExp) $ + assertPrefix "Could not parse expression:" + assertEqual "other problems" [] (snd problemsForSyntaxErrorInExp) + +test_problemsForSyntaxErrorInPat :: Assertion +test_problemsForSyntaxErrorInPat = do + assertJust "no failure reported" (fst problemsForSyntaxErrorInPat) $ + assertPrefix "Could not parse pattern:" + assertEqual "other problems" [] (snd problemsForSyntaxErrorInPat) + +test_problemsForUnknownFieldsInExp :: Assertion +test_problemsForUnknownFieldsInExp = + assertEqual "" expected problemsForUnknownFieldsInExp + where + expected :: (Maybe String, [Problem]) + expected = (Nothing, [Error "Unknown fields: c"]) + +test_problemsForUnknownFieldsInPat :: Assertion +test_problemsForUnknownFieldsInPat = + assertEqual "" expected problemsForUnknownFieldsInPat + where + expected :: (Maybe String, [Problem]) + expected = (Nothing, [Error "Unknown fields: c"]) + +test_problemsForMissingFieldsInExp :: Assertion +test_problemsForMissingFieldsInExp = + assertEqual "" expected problemsForMissingFieldsInExp + where + expected :: (Maybe String, [Problem]) + expected = (Nothing, [Warning "No value for field b"]) + +test_problemsForMissingFieldsInPat :: Assertion +test_problemsForMissingFieldsInPat = + assertEqual "" expected problemsForMissingFieldsInPat + where + -- It is of course perfectly fine for a pattern to be missing fields + expected :: (Maybe String, [Problem]) + expected = (Nothing, []) + diff --git a/test/Test/Record/Sanity/ErrorsAndWarnings/Stage1.hs b/test/Test/Record/Sanity/ErrorsAndWarnings/Stage1.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/ErrorsAndWarnings/Stage1.hs @@ -0,0 +1,68 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Test.Record.Sanity.ErrorsAndWarnings.Stage1 ( + -- * The record we're testing against + -- + -- It is important that we export 'R', because the various TH expressions + -- we not executed here, but rather where we use them + -- ("Test.Record.Sanity.ErrorsAndWarnings.Stage1"); this means that if we + -- don't export this, the " problem " that is reported is the constructor + -- not being in scope, rather than the missing/extra fields. + R(..) + + -- The specific tests + , qProblemsForSyntaxErrorInExp + , qProblemsForSyntaxErrorInPat + , qProblemsForUnknownFieldsInExp + , qProblemsForUnknownFieldsInPat + , qProblemsForMissingFieldsInExp + , qProblemsForMissingFieldsInPat + ) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +import Data.Record.TH +import Data.Record.QQ.CodeGen + +import Test.Record.Util + +largeRecord defaultPureScript [d| + data R = MkR { a :: Int, b :: Bool } + |] + +qProblemsForSyntaxErrorInExp :: Q Exp +qProblemsForSyntaxErrorInExp = (lift =<<) $ collectOnlyProblems $ + lrExp "MkR { a = 1, b = True, c = ()" + +qProblemsForSyntaxErrorInPat :: Q Exp +qProblemsForSyntaxErrorInPat = (lift =<<) $ collectOnlyProblems $ + lrPat "MkR { a = x, b = y, c = z" + +qProblemsForUnknownFieldsInExp :: Q Exp +qProblemsForUnknownFieldsInExp = (lift =<<) $ collectOnlyProblems $ + lrExp "MkR { a = 1, b = True, c = () }" + +qProblemsForUnknownFieldsInPat :: Q Exp +qProblemsForUnknownFieldsInPat = (lift =<<) $ collectOnlyProblems $ + lrPat "MkR { a = x, b = y, c = z }" + +qProblemsForMissingFieldsInExp :: Q Exp +qProblemsForMissingFieldsInExp = (lift =<<) $ collectOnlyProblems $ + lrExp "MkR { a = 1 }" + +qProblemsForMissingFieldsInPat :: Q Exp +qProblemsForMissingFieldsInPat = (lift =<<) $ collectOnlyProblems $ + lrPat "MkR { a = x }" + diff --git a/test/Test/Record/Sanity/Generics.hs b/test/Test/Record/Sanity/Generics.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/Generics.hs @@ -0,0 +1,267 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +-- {-# OPTIONS_GHC -ddump-splices #-} + +-- | Sanity check that the generic functions are not totally broken +-- +-- These are not proper tests, merely intended to catch egregious refactoring +-- mistakes. +module Test.Record.Sanity.Generics (tests) where + +import Control.Monad.State (State, evalState, state) +import Data.Proxy +import Data.SOP (NP(..), All, Compose) + +import qualified Data.SOP as SOP +import qualified Generics.SOP as SOP +import qualified Generics.SOP.Metadata as SOP +import qualified Generics.SOP.Type.Metadata as SOP.T + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +import Data.Record.Generic +import Data.Record.Generic.LowerBound +import Data.Record.Generic.SOP hiding (glowerBound) +import Data.Record.TH + +import qualified Data.Record.Generic.SOP as SOP +import qualified Data.Record.Generic.Rep as Rep + +{------------------------------------------------------------------------------- + Small test record +-------------------------------------------------------------------------------} + +largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d| + data T a b = MkT { + tInt :: Word + , tBool :: Bool + , tChar :: Char + , tA :: a + , tListB :: [b] + } + deriving (Eq, Ord, Show) + |] + +exampleT :: T () Float +exampleT = MkT 5 True 'c' () [3.14] + +_silenceWarnings :: () +_silenceWarnings = const () $ ( + tInt + , tBool + , tChar + , tA + , tListB + ) + +{------------------------------------------------------------------------------- + Handwritten SOP instance + + This allows us to compare the untyped representation used by @large-records@ + to the strongly typed version from @generics-sop@. +-------------------------------------------------------------------------------} + +instance SOP.Generic (T a b) where + type Code (T a b) = '[[Word, Bool, Char, a, [b]]] + from (MkT i b c a bs) = SOP.SOP (SOP.Z (I i :* I b :* I c :* I a :* I bs :* Nil)) + to (SOP.SOP (SOP.Z (I i :* I b :* I c :* I a :* I bs :* Nil))) = MkT i b c a bs + to (SOP.SOP (SOP.S x)) = case x of {} + +type DefaultBang = + 'SOP.T.StrictnessInfo + 'SOP.NoSourceUnpackedness + 'SOP.NoSourceStrictness + 'SOP.DecidedLazy + +instance SOP.HasDatatypeInfo (T a b) where + type DatatypeInfoOf (T a b) = + 'SOP.T.ADT + "Data.Record.Generic.Sanity" + "T" + '[ 'SOP.T.Record "MkT" '[ + 'SOP.T.FieldInfo "tInt" + , 'SOP.T.FieldInfo "tBool" + , 'SOP.T.FieldInfo "tChar" + , 'SOP.T.FieldInfo "tA" + , 'SOP.T.FieldInfo "tListB" + ]] + '[ '[ + DefaultBang + , DefaultBang + , DefaultBang + , DefaultBang + , DefaultBang + ]] + + datatypeInfo _ = + SOP.T.demoteDatatypeInfo $ Proxy @(SOP.DatatypeInfoOf (T a b)) + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +test_from_to_id :: Assertion +test_from_to_id = + assertEqual "from . to = id" expected actual + where + expected, actual :: T () Float + expected = exampleT + actual = (to . from) exampleT + +test_pure :: Assertion +test_pure = + compareTyped expected actual + where + expected :: NP (Field (K Char)) (MetadataOf (T () Float)) + expected = + Field (K 'a') + :* Field (K 'a') + :* Field (K 'a') + :* Field (K 'a') + :* Field (K 'a') + :* Nil + + actual :: Rep (K Char) (T () Float) + actual = Rep.pure (K 'a') + +test_cpure :: Assertion +test_cpure = + assertEqual "matches hand-constructed" expected actual + where + expected, actual :: T () Float + expected = MkT 0 False '\x0000' () [] + actual = glowerBound + +test_sequenceA :: Assertion +test_sequenceA = + compareTyped expected actual + where + expected :: NP (Field (K Int)) (MetadataOf (T () Float)) + expected = + flip evalState 0 + $ SOP.hsequence' + $ SOP.hmap distrib + $ example + where + distrib :: Field (State Int :.: K Int) x + -> (State Int :.: (Field (K Int))) x + distrib (Field (Comp x)) = Comp (Field <$> x) + + actual :: Rep (K Int) (T () Float) + actual = flip evalState 0 $ Rep.sequenceA $ SOP.fromSOP example + + example :: NP (Field (State Int SOP.:.: K Int)) (MetadataOf (T () Float)) + example = + Field (Comp (K <$> tick)) + :* Field (Comp (K <$> tick)) + :* Field (Comp (K <$> tick)) + :* Field (Comp (K <$> tick)) + :* Field (Comp (K <$> tick)) + :* Nil + + tick :: State Int Int + tick = state $ \i -> (i, i + 1) + +test_zipWithM :: Assertion +test_zipWithM = + compareTyped expected actual + where + expected :: NP (Field (K Int)) (MetadataOf (T () Float)) + expected = + flip evalState 0 + $ SOP.hsequence' + $ SOP.hliftA2 tick' x y + where + tick' :: Field (K Int) field + -> Field (K Int) field + -> (State Int :.: Field (K Int)) field + tick' (Field a) (Field b) = Comp $ Field <$> tick a b + + actual :: Rep (K Int) (T () Float) + actual = flip evalState 0 $ + Rep.zipWithM tick (fromSOP x) (fromSOP y) + + tick :: K Int x -> K Int x -> State Int (K Int x) + tick (K a) (K b) = state $ \i -> (K (a + b + i), i + 1) + + x, y :: NP (Field (K Int)) (MetadataOf (T () Float)) + x = Field (K 10) + :* Field (K 11) + :* Field (K 12) + :* Field (K 13) + :* Field (K 14) + :* Nil + y = Field (K 20) + :* Field (K 21) + :* Field (K 22) + :* Field (K 23) + :* Field (K 24) + :* Nil + +test_ord :: Word -> Word -> Bool -> Bool -> Property +test_ord w w' b b' + | w == w' && b == b' = t1 === t2 + | w == w' = compare t1 t2 === compare b b' + | otherwise = compare t1 t2 === compare w w' + where + t1, t2 :: T () Float + t1 = MkT w b 'c' () [3.14] + t2 = MkT w' b' 'c' () [3.14] + +{------------------------------------------------------------------------------- + For testing purposes, we compare against proper heterogeneous lists +-------------------------------------------------------------------------------} + +compareTyped :: + forall f a. ( + Generic a + , Constraints a (Compose Eq f) + , Constraints a (Compose Show f) + , All IsField (MetadataOf a) + ) + => NP (Field f) (MetadataOf a) -> Rep f a -> Assertion +compareTyped expected actual = + case toSOP actual of + Nothing -> + assertFailure "compareTyped: incorrect number of fields" + Just actual' -> + case toDictAll (Proxy @f) (Proxy @a) (Proxy @Show) of + Dict -> + case toDictAll (Proxy @f) (Proxy @a) (Proxy @Eq) of + Dict -> go expected actual' + where + go :: ( All (Compose Eq (Field f)) fields + , All (Compose Show (Field f)) fields + ) + => NP (Field f) fields -> NP (Field f) fields -> Assertion + go = assertEqual "compareTyped" + +{------------------------------------------------------------------------------- + All tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity" [ + testCase "from_to_id" test_from_to_id + , testCase "pure" test_pure + , testCase "sequenceA" test_sequenceA + , testCase "zipWithM" test_zipWithM + , testCase "cpure" test_cpure + , testProperty "ord" test_ord + ] diff --git a/test/Test/Record/Sanity/GhcGenerics.hs b/test/Test/Record/Sanity/GhcGenerics.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/GhcGenerics.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-orphans #-} +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Test.Record.Sanity.GhcGenerics (tests) where + +import Data.Function (on) +import Data.Proxy +import Data.Record.Generic.GHC +import Data.Record.TH +import Data.SOP.BasicFunctors +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Data.Record.Generic as LR +import qualified Data.Record.Generic.Eq as LR +import qualified Data.Record.Generic.Rep as Rep +import qualified Generics.Deriving.Eq as GHC +import qualified GHC.Generics as GHC + +{------------------------------------------------------------------------------- + Example large record +-------------------------------------------------------------------------------} + +largeRecord defaultPureScript [d| + data LargeRecord = MkLargeRecord { + largeField1 :: Int + , largeField2 :: Bool + } + |] + +example :: LargeRecord +example = [lr| MkLargeRecord |] 1 True + +{------------------------------------------------------------------------------- + Show that we can use geqdefault on a large record +-------------------------------------------------------------------------------} + +instance ( LR.Generic a + , LR.Constraints a Eq + ) => GHC.GEq' (ThroughLRGenerics a) where + geq' = LR.geq `on` unwrapThroughLRGenerics + +allEqualTo :: (GHC.Generic a, GHC.GEq' (GHC.Rep a)) => a -> [a] -> Bool +allEqualTo x = all (GHC.geqdefault x) + +{------------------------------------------------------------------------------- + Example with GHC field metadata +-------------------------------------------------------------------------------} + +class GRecordToTable f where + gRecordToTable :: f p -> [(String, String)] + +instance GRecordToTable f + => GRecordToTable (GHC.M1 GHC.D c f) where + gRecordToTable (GHC.M1 x) = gRecordToTable x + +instance GRecordToTable f + => GRecordToTable (GHC.M1 GHC.C c f) where + gRecordToTable (GHC.M1 x) = gRecordToTable x + +instance (GRecordToTable f, GRecordToTable g) + => GRecordToTable (f GHC.:*: g) where + gRecordToTable (l GHC.:*: r) = gRecordToTable l ++ gRecordToTable r + +instance (GHC.Selector f, Show a) + => GRecordToTable (GHC.M1 GHC.S f (GHC.K1 GHC.R a)) where + gRecordToTable f@(GHC.M1 (GHC.K1 x)) = [(GHC.selName f, show x)] + +data Table = Table { + tableFields :: [(String, String)] + } + deriving (Show, Eq) + +simpleRecordToTable :: (GHC.Generic a, GRecordToTable (GHC.Rep a)) => a -> Table +simpleRecordToTable = Table . gRecordToTable . GHC.from + +data SimpleRecord = MkSimpleRecord { + simpleField1 :: Int + , simpleField2 :: Bool + } + deriving (GHC.Generic) + +-- The goal is to reuse the instance for fields +-- TODO: We could potentially extend this to the other metadata as well +largeRecordToTable :: forall a. + (LR.Generic a, LR.Constraints a Show) + => a -> Table +largeRecordToTable = \x -> + Table { + tableFields = concat . Rep.collapse $ + Rep.czipWith + (Proxy @Show) + aux + (LR.from x) + (ghcMetadataFields (ghcMetadata (Proxy @a))) + } + where + aux :: Show x => I x -> GhcFieldMetadata x -> K [(String, String)] x + aux (I x) (GhcFieldMetadata p) = K $ gRecordToTable $ aux' x p + + aux' :: x -> Proxy f -> GHC.M1 GHC.S f (GHC.K1 GHC.R x) p + aux' x _ = GHC.M1 (GHC.K1 x) + +{------------------------------------------------------------------------------- + Tests proper +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.GhcGenerics" [ + testCase "allEqualTo" test_allEqualTo + , testCase "simpleRecordToTable" test_simpleRecordToTable + , testCase "largeRecordToTable" test_largeRecordToTable + ] + +test_allEqualTo :: Assertion +test_allEqualTo = assertEqual "" (allEqualTo example [example]) True + +-- Just a sanity check that the standard GHC generic functions works as intended +test_simpleRecordToTable :: Assertion +test_simpleRecordToTable = + assertEqual "" (simpleRecordToTable r) tbl + where + r :: SimpleRecord + r = MkSimpleRecord 1 True + + tbl :: Table + tbl = Table [ + ("simpleField1", "1") + , ("simpleField2", "True") + ] + +test_largeRecordToTable :: Assertion +test_largeRecordToTable = + assertEqual "" (largeRecordToTable example) tbl + where + tbl :: Table + tbl = Table [ + ("largeField1", "1") + , ("largeField2", "True") + ] diff --git a/test/Test/Record/Sanity/HKD.hs b/test/Test/Record/Sanity/HKD.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/HKD.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-} +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Test.Record.Sanity.HKD ( + tests + ) where + +import Data.Functor.Identity +import Data.Functor.Const +import Data.Kind + +import Data.Record.TH + +import Test.Tasty +import Test.Tasty.HUnit + +type family HKD f a where + HKD Identity a = a + HKD (Const b) a = b + +-- | Test record with fields whose types are given by type families +largeRecord defaultPureScript [d| + data T (f :: Type -> Type) = MkT { + field1 :: HKD f Int + , field2 :: HKD f Bool + } + deriving (Show, Eq) + |] + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.HKD" [ + testCase "get" testGet + , testCase "set" testSet + , testCase "match" testMatch + ] + +example1, example2 :: T Identity +example1 = [lr| MkT { field1 = 1, field2 = True } |] +example2 = [lr| MkT { field1 = 1, field2 = False } |] + +example3 :: T (Const Char) +example3 = [lr| MkT { field1 = 'a', field2 = 'b' } |] + +exampleFun :: T f -> HKD f Int +exampleFun [lr| MkT { field1 } |] = field1 + +testGet :: Assertion +testGet = assertEqual "" example1.field1 1 + +testSet :: Assertion +testSet = assertEqual "" (example1{ field2 = False }) example2 + +testMatch :: Assertion +testMatch = do + assertEqual "example1" (exampleFun example1) 1 + assertEqual "example3" (exampleFun example3) 'a' diff --git a/test/Test/Record/Sanity/HigherKinded.hs b/test/Test/Record/Sanity/HigherKinded.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/HigherKinded.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- {-# OPTIONS_GHC -ddump-splices #-} + +-- | Simple example of a type with a higher kind +module Test.Record.Sanity.HigherKinded ( + tests + ) where + +import Data.Kind +import GHC.TypeLits + +import Data.Record.Generic +import Data.Record.Generic.LowerBound +import Data.Record.TH + +import Test.Tasty +import Test.Tasty.HUnit + +newtype T (n :: Nat) (f :: Type -> Type) = MkT (f Word) + +instance LowerBound (T n I) where + lowerBound = MkT (I lowerBound) + +deriving instance Show (T n I) + +-- We need an explicit kind annotation on @f@ for @large-records@ to generate +-- correct code (either that, or use @PolyKinds@). +largeRecord defaultLazyOptions [d| + data MyRecord (f :: Type -> Type) = MyRecord { + field0 :: T 0 f + , field1 :: T 1 f + , field2 :: T 2 f + , field3 :: T 3 f + , field4 :: T 4 f + , field5 :: T 5 f + , field6 :: T 6 f + , field7 :: T 7 f + , field8 :: T 8 f + , field9 :: T 9 f + } + deriving (Show) + |] + +_suppressWarnings :: () +_suppressWarnings = const () ( + field0 + , field1 + , field2 + , field3 + , field4 + , field5 + , field6 + , field7 + , field8 + , field9 + ) + +example :: MyRecord I +example = glowerBound + +{------------------------------------------------------------------------------- + Just to make sure we don't regard everything as dead code +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.HigherKinded" [ + testCase "show" test_show + ] + +test_show :: Assertion +test_show = assertBool "" $ (not . null) (show example) diff --git a/test/Test/Record/Sanity/Laziness.hs b/test/Test/Record/Sanity/Laziness.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/Laziness.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | Check that the functions on 'Rep' can be called on 'undefined' +module Test.Record.Sanity.Laziness (tests) where + +import Control.Exception +import Data.List (isInfixOf) +import Data.IORef +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Record.Generic +import Data.Record.TH + +import qualified Data.Record.Generic.Rep as Rep +import qualified Data.Record.Generic.Rep.Internal as Rep + +import Test.Record.Util + +{------------------------------------------------------------------------------- + Example record +-------------------------------------------------------------------------------} + +largeRecord defaultPureScript [d| + data R = MkR { + ri :: Word + , rb :: Bool + } + deriving (Show, Eq) + |] + +example :: R +example = [lr| MkR { ri = 5, rb = True } |] + +{------------------------------------------------------------------------------- + Tests proper +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.Laziness" [ + testCase "mapWithIndex" test_mapWithIndex + , testCase "ap" test_ap + , testCase "map" test_map + , testCase "map'" test_map' + , testCase "mapM" test_mapM + , testCase "cmap" test_cmap + , testCase "cmapM" test_cmapM + , testCase "zipWithM" test_zipWithM + , testCase "czipWithM" test_czipWithM + ] + +test_mapWithIndex :: Assertion +test_mapWithIndex = + assertEqual "" expected actual + where + expected, actual :: Rep (K Int) R + expected = Rep.unsafeFromList [0, 1] + actual = Rep.mapWithIndex (\ix _ -> K $ Rep.indexToInt ix) undefined + +test_ap :: Assertion +test_ap = + assertEqual "" expected actual + where + fns :: Rep (f -.-> I) R + fns = Rep.map' (\x -> Fn $ \_ -> x) (from example) + + expected, actual :: R + expected = example + actual = to $ Rep.ap fns undefined + +test_map :: Assertion +test_map = + assertEqual "" expected actual + where + expected, actual :: Rep (K Int) R + expected = Rep.unsafeFromList [0, 0] + actual = Rep.map (\_ -> K 0) undefined + +-- Just to be sure: if we use map' instead of map, we get bottom +test_map' :: Assertion +test_map' = expectException isExpectedException $ do + assertEqual "" expected actual + where + isExpectedException :: SomeException -> Bool + isExpectedException e = "undefined" `isInfixOf` show e + + expected, actual :: Rep (K Int) R + expected = Rep.unsafeFromList [0, 0] + actual = Rep.map' (\_ -> K 0) undefined + +test_mapM :: Assertion +test_mapM = do + r <- newIORef 1 + + let next :: f x -> IO (K Int x) + next _ = atomicModifyIORef r $ \i -> (i + 1, K i) + + actual :: Rep (K Int) R <- Rep.mapM next undefined + assertEqual "" expected actual + where + expected :: Rep (K Int) R + expected = Rep.unsafeFromList [1, 2] + +test_cmap :: Assertion +test_cmap = + assertEqual "" expected actual + where + expected, actual :: R + expected = [lr| MkR { ri = 0, rb = False } |] + actual = to $ Rep.cmap (Proxy @Bounded) (\_ -> I minBound) undefined + +test_cmapM :: Assertion +test_cmapM = do + r <- newIORef False + + let next :: Bounded x => f x -> IO (I x) + next _ = do + b <- atomicModifyIORef r $ \b -> (not b, b) + return . I $ if b then maxBound else minBound + + actual :: R <- to <$> Rep.cmapM (Proxy @Bounded) next undefined + assertEqual "" expected actual + where + expected :: R + expected = [lr| MkR { ri = 0, rb = True } |] + +test_zipWithM :: Assertion +test_zipWithM = + assertEqual "" expected actual + where + expected, actual :: Maybe (Rep (K Int) R) + expected = Just $ Rep.unsafeFromList [0, 0] + actual = Rep.zipWithM (\_ _ -> Just $ K 0) undefined undefined + +test_czipWithM :: Assertion +test_czipWithM = + assertEqual "" expected actual + where + expected, actual :: Maybe R + expected = Just $ [lr| MkR { ri = 0, rb = False } |] + actual = to <$> Rep.czipWithM + (Proxy @Bounded) + (\_ _ -> Just $ I minBound) + undefined + undefined diff --git a/test/Test/Record/Sanity/Lens/Micro.hs b/test/Test/Record/Sanity/Lens/Micro.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/Lens/Micro.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ImpredicativeTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +module Test.Record.Sanity.Lens.Micro (tests) where + +import Data.Kind +import Data.Maybe (fromJust) +import Data.SOP +import Lens.Micro (Lens', (^.), (&), (%~)) +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Record.Generic +import Data.Record.Generic.Lens.Micro +import Data.Record.Generic.SOP +import Data.Record.Generic.Transform +import Data.Record.QQ.CodeGen +import Data.Record.TH + +import qualified Data.Record.Generic.Rep as Rep + +{------------------------------------------------------------------------------- + Simple example (no type families) +-------------------------------------------------------------------------------} + +largeRecord defaultPureScript [d| + data Simple (f :: Type -> Type) = MkSimple { + s1 :: f Int + , s2 :: f Bool + , s3 :: f Char + } + deriving (Show, Eq) + |] + +simpleExample :: Simple I +simpleExample = [lr| MkSimple { + s1 = I 5 + , s2 = I True + , s3 = I 'a' + } |] + +simpleExampleLenses :: Simple (RegularRecordLens Simple f) +simpleExampleLenses = lensesForRegularRecord (Proxy @DefaultInterpretation) + +[lr| MkSimple { + s1 = RegularRecordLens xs1 + , s2 = RegularRecordLens xs2 + , s3 = RegularRecordLens xs3 + } |] = simpleExampleLenses + +{------------------------------------------------------------------------------- + Simplified version of beam's 'Columnar' type' +-------------------------------------------------------------------------------} + +data Lenses (tbl :: (Type -> Type) -> Type) (f :: Type -> Type) (x :: Type) + +data WrapLens a b = WrapLens (Lens' a b) + +type family Columnar f x :: Type where + Columnar I x = x + Columnar (Lenses tbl f) x = WrapLens (tbl f) (Columnar f x) + Columnar f x = f x + +{------------------------------------------------------------------------------- + Example with type families, but still regular + + See /next/ example for usage of, and motivation for, 'Lenses'. +-------------------------------------------------------------------------------} + +data BeamInterpretation (f :: Type -> Type) + +type instance Interpreted (BeamInterpretation f) (Uninterpreted x) = Columnar f x + +instance StandardInterpretation BeamInterpretation (RegularRecordLens tbl f) +instance StandardInterpretation BeamInterpretation I + +largeRecord defaultPureScript [d| + data Regular (f :: Type -> Type) = MkRegular { + r1 :: Columnar f Int + , r2 :: Columnar f Bool + , r3 :: Columnar f Char + } + deriving (Show, Eq) + |] + +regularExample :: Regular I +regularExample = [lr| MkRegular { + r1 = 5 + , r2 = True + , r3 = 'a' + } |] + +regularLenses :: Regular (RegularRecordLens Regular I) +regularLenses = lensesForRegularRecord (Proxy @BeamInterpretation) + +[lr| MkRegular { + r1 = RegularRecordLens xr1 + , r2 = RegularRecordLens xr2 + , r3 = RegularRecordLens xr3 + } |] = regularLenses + +{------------------------------------------------------------------------------- + Beam-like example + + The lenses we generate above have @I x@ as their argument, rather than @x@. In + beam, the lenses have @Columnar f x@ as their target, which is just @x@ in the + case that @f == I@. If we want to replicate this, we cannot use + 'lensesForRegularRecord', which gives us 'RegularRecordLens', and must instead + use the lower-level function 'lensesForHKRecord'. This example is still + simplified from the beam example because we don't support any form of mixins; + we insist every field is regular, which allows us to avoid introducing a + separate type class. See the @beam-large-package@ for full beam integration. +-------------------------------------------------------------------------------} + +beamLikeLenses :: forall tbl. + ( Generic (tbl (Lenses tbl I)) + , Generic (tbl Uninterpreted) + , Generic (tbl I) + , HasNormalForm (BeamInterpretation (Lenses tbl I)) (tbl (Lenses tbl I)) (tbl Uninterpreted) + , HasNormalForm (BeamInterpretation I) (tbl I) (tbl Uninterpreted) + , Constraints (tbl Uninterpreted) (IsRegularField Uninterpreted) + ) + => tbl (Lenses tbl I) +beamLikeLenses = + to . denormalize1 (Proxy @BeamInterpretation) $ + Rep.cmap + (Proxy @(IsRegularField Uninterpreted)) + aux + (lensesForHKRecord (Proxy @BeamInterpretation)) + where + aux :: forall x. + IsRegularField Uninterpreted x + => HKRecordLens BeamInterpretation I tbl x + -> Interpret (BeamInterpretation (Lenses tbl I)) x + aux (HKRecordLens l) = + case isRegularField (Proxy @(Uninterpreted x)) of + RegularField -> Interpret $ WrapLens $ + l + . standardInterpretationLens (Proxy @BeamInterpretation) + . unI' + + unI' :: Lens' (I x) x + unI' f (I x) = I <$> f x + +regularBeamLikeLenses :: Regular (Lenses Regular I) +regularBeamLikeLenses = beamLikeLenses + +[lr| MkRegular { + r1 = WrapLens br1 + , r2 = WrapLens br2 + , r3 = WrapLens br3 + } |] = regularBeamLikeLenses + +{------------------------------------------------------------------------------- + Irregular example +-------------------------------------------------------------------------------} + +largeRecord defaultPureScript [d| + data Irregular (f :: Type -> Type) = MkIrregular { + i1 :: f Int + , i2 :: f Bool + , i3 :: Char -- No @f@! + } + deriving (Show, Eq) + |] + +irregularExample :: Irregular I +irregularExample = [lr| MkIrregular { + i1 = I 5 + , i2 = I True + , i3 = 'a' + } |] + +-- We cannot define this now: +-- +-- > irregularLenses :: Irregular (RegularRecordLens Irregular I) +-- > irregularLenses = lensesForRegularRecord (Proxy @DefaultInterpretation) +-- +-- It will complain that @Char@ is not equal to +-- +-- > Interpreted (DefaultInterpretation (RegularRecordLens Irregular I)) Char +-- +-- We can use 'repLenses' to nonetheless get lenses for all fields in +-- 'Irregular', and then translate to an NP so that we can pattern match on it +-- in a type-safe way. Of course, the translation to SOP incurs O(N^2) +-- compile-time cost so this is not a proper solution. +-- +-- NOTE: There is not much point using 'repLenses'' here; that is primarily +-- useful only if there is some post-processing step (like done by +-- 'lensesForRegularRecord'). +irregularLenses :: NP (Field (SimpleRecordLens (Irregular f))) (MetadataOf (Irregular f)) +irregularLenses = fromJust $ toSOP rep + where + rep :: Rep (SimpleRecordLens (Irregular f)) (Irregular f) + rep = lensesForSimpleRecord + +( Field (SimpleRecordLens xi1) + :* Field (SimpleRecordLens xi2) + :* Field (SimpleRecordLens xi3) + :* Nil ) = irregularLenses + +{------------------------------------------------------------------------------- + Tests proper +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.Lens.Micro" [ + testCase "simple_get" test_simple_get + , testCase "simple_set" test_simple_set + , testCase "regular_get" test_regular_get + , testCase "regular_set" test_regular_set + , testCase "beamlike_get" test_beamlike_get + , testCase "beamlike_set" test_beamlike_set + , testCase "irregular_get" test_irregular_get + , testCase "irregular_set" test_irregular_set + ] + +test_simple_get :: Assertion +test_simple_get = + assertEqual "" (I True) + (simpleExample ^. xs2) + +test_simple_set :: Assertion +test_simple_set = + assertEqual "" expected $ + simpleExample & xs1 %~ mapII negate & xs3 %~ mapII succ + where + expected :: Simple I + expected = [lr| MkSimple { + s1 = I (-5) + , s2 = I True + , s3 = I 'b' + } |] + +test_regular_get :: Assertion +test_regular_get = + assertEqual "" (I True) + (regularExample ^. xr2) + +test_regular_set :: Assertion +test_regular_set = + assertEqual "" expected $ + regularExample & xr1 %~ mapII negate & xr3 %~ mapII succ + where + expected :: Regular I + expected = [lr| MkRegular { + r1 = (-5) + , r2 = True + , r3 = 'b' + } |] + +test_beamlike_get :: Assertion +test_beamlike_get = + assertEqual "" True + (regularExample ^. br2) + +test_beamlike_set :: Assertion +test_beamlike_set = + assertEqual "" expected $ + regularExample & br1 %~ negate & br3 %~ succ + where + expected :: Regular I + expected = [lr| MkRegular { + r1 = (-5) + , r2 = True + , r3 = 'b' + } |] + +test_irregular_get :: Assertion +test_irregular_get = + assertEqual "" (I True) + (irregularExample ^. xi2) + +test_irregular_set :: Assertion +test_irregular_set = + assertEqual "" expected $ + irregularExample & xi1 %~ mapII negate & xi3 %~ succ + where + expected :: Irregular I + expected = [lr| MkIrregular { + i1 = I (-5) + , i2 = I True + , i3 = 'b' + } |] diff --git a/test/Test/Record/Sanity/OverloadingNoDRF.hs b/test/Test/Record/Sanity/OverloadingNoDRF.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/OverloadingNoDRF.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-} +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Test.Record.Sanity.OverloadingNoDRF ( + tests + ) where + +import Data.Record.TH + +import Test.Tasty +import Test.Tasty.HUnit + +{------------------------------------------------------------------------------- + Simple test case +-------------------------------------------------------------------------------} + +largeRecord defaultPureScript [d| + data X = MkX { a :: Int } + data Y = MkY { a :: String } + |] + +testOverloading :: Assertion +testOverloading = do + assertEqual "X" x.a 0 + assertEqual "Y" y.a "hi" + where + x :: X + x = _construct_MkX 0 + + y :: Y + y = _construct_MkY "hi" + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.OverloadingNoDRF" [ + testCase "overloading" testOverloading + ] diff --git a/test/Test/Record/Sanity/PatternMatch.hs b/test/Test/Record/Sanity/PatternMatch.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/PatternMatch.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# OPTIONS_GHC -fdefer-type-errors -Wno-deferred-type-errors #-} +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Test.Record.Sanity.PatternMatch (tests) where + +import Control.Exception +import Data.List (isInfixOf) +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Record.TH + +import Test.Record.Util + +{------------------------------------------------------------------------------- + Basic pattern matching tests +-------------------------------------------------------------------------------} + +largeRecord defaultPureScript [d| + data T a = MkT { x :: Int, y :: [a], z :: Double } + data S a = MkS { x :: Char, y :: T a } + |] + +projectOne :: T Bool -> Int +projectOne [lr| MkT { x = a } |] = a + +projectTwo :: T a -> (Int, [a]) +projectTwo [lr| MkT { x = a, y = b } |] = (a, b) + +-- | Test projecting more than 2 elements +-- +-- This is an important special case, because this checks that the pattern we +-- generate is correctedly nested to match the 'MatchHasField' instances. +projectThree :: T a -> (Int, [a], Double) +projectThree [lr| MkT { x = a, y = b, z = c } |] = (a, b, c) + +projectPuns :: T a -> (Int, [a]) +projectPuns [lr| MkT { x, y } |] = (x, y) + +projectNested :: S a -> (Char, Int, [a]) +projectNested [lr| MkS { x = a, y = MkT { x = b, y = c } } |] = (a, b, c) + +projectView :: T Bool -> Int +projectView [lr| MkT { x = ((+1) -> a) } |] = a + +matchEmpty :: T Bool -> Int +matchEmpty [lr| MkT {} |] = 42 + +{------------------------------------------------------------------------------- + Verify inferred types + + We want to infer that the types are not more polymorphic than they should be: + functions that match on a record should not be polymorphic in 'HasField', but + should only accept values of that specific record type. + + Functions 'useNoSigEmpty' and 'useNoSigNonEmpty' below will have (deferred) + type errors iff 'noSigEmpty' and 'noSigNonEmpty' are suffciently monomorphic. +-------------------------------------------------------------------------------} + +largeRecord defaultPureScript [d| + data T2 = MkT2 { x :: Int } + |] + +noSigEmpty [lr| MkT {} |] = () + +noSigNonEmpty [lr| MkT { x = a } |] = const () a + +useNoSigEmpty :: () +useNoSigEmpty = noSigEmpty [lr| MkT2 { x = 5 } |] + +useNoSigNonEmpty :: () +useNoSigNonEmpty = noSigNonEmpty [lr| MkT2 { x = 5 } |] + +{------------------------------------------------------------------------------- + Tests proper +-------------------------------------------------------------------------------} + +testProjections :: Assertion +testProjections = do + assertEqual "one" (projectOne t) 5 + assertEqual "two" (projectTwo t) (5, [True]) + assertEqual "three" (projectThree t) (5, [True], 1.0) + assertEqual "puns" (projectPuns t) (5, [True]) + assertEqual "nested" (projectNested s) ('a', 2, [True, False]) + assertEqual "view" (projectView t) 6 + assertEqual "empty" (matchEmpty t) 42 + + expectException isExpectedTypeError $ + assertEqual "sig-empty" useNoSigEmpty () + expectException isExpectedTypeError $ + assertEqual "sig-nonempty" useNoSigNonEmpty () + where + isExpectedTypeError :: SomeException -> Bool + isExpectedTypeError e = "Couldn't match expected type" `isInfixOf` show e + + t :: T Bool + t = [lr| MkT { x = 5, y = [True], z = 1.0 } |] + + s :: S Bool + s = [lr| MkS { x = 'a', y = MkT { x = 2, y = [True, False], z = 1.0 } } |] + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.Projection" [ + testCase "projections" testProjections + ] diff --git a/test/Test/Record/Sanity/QualifiedImports.hs b/test/Test/Record/Sanity/QualifiedImports.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/QualifiedImports.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} +-- {-# OPTIONS_GHC -ddump-splices #-} + +module Test.Record.Sanity.QualifiedImports (tests) where + +import Data.Record.TH + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified Test.Record.Sanity.QualifiedImports.A as A +import qualified Test.Record.Sanity.QualifiedImports.B as B + +constructA :: A.T Bool +constructA = [lr| A.MkT { x = 5, y = [True] } |] + +constructB :: B.T Bool +constructB = [lr| B.MkT { x = 'a', y = A.MkT { x = 2, y = [True, False] } } |] + +projectA :: A.T a -> (Int, [a]) +projectA [lr| A.MkT { x = a, y = b } |] = (a, b) + +projectB :: B.T a -> (Char, Int, [a]) +projectB [lr| B.MkT { x = a, y = A.MkT { x = b, y = c } } |] = (a, b, c) + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.QualifiedImports" [ + testCase "qualifiedImports" testQualifiedImports + ] + +testQualifiedImports :: Assertion +testQualifiedImports = do + assertEqual "constructA" a.x 5 + assertEqual "projectA" (projectA a) (5, [True]) + assertEqual "constructB" b.x 'a' + assertEqual "projectB" (projectB b) ('a', 2, [True, False]) + where + a :: A.T Bool + a = constructA + + b :: B.T Bool + b = constructB diff --git a/test/Test/Record/Sanity/QualifiedImports/A.hs b/test/Test/Record/Sanity/QualifiedImports/A.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/QualifiedImports/A.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Record.Sanity.QualifiedImports.A where + +import Data.Record.TH + +largeRecord defaultPureScript [d| + data T a = MkT { x :: Int, y :: [a] } + |] diff --git a/test/Test/Record/Sanity/QualifiedImports/B.hs b/test/Test/Record/Sanity/QualifiedImports/B.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/QualifiedImports/B.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Record.Sanity.QualifiedImports.B where + +import Data.Record.TH + +import qualified Test.Record.Sanity.QualifiedImports.A as A + +largeRecord defaultPureScript [d| + data T a = MkT { x :: Char, y :: A.T a } + |] diff --git a/test/Test/Record/Sanity/RecordConstruction.hs b/test/Test/Record/Sanity/RecordConstruction.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/RecordConstruction.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-} +-- {-# OPTIONS_GHC -ddump-splices #-} +{-# OPTIONS_GHC -Wwarn #-} + +module Test.Record.Sanity.RecordConstruction (tests) where + +import Data.Record.TH + +import Test.Tasty +import Test.Tasty.HUnit + +-- Test that this works if we don't generate field accessors +-- See +-- +-- Use lazy fields so that we can test values with missing fields. +-- +-- Test both the case where the name of the type and the name of the constructor +-- are the same and where they are different. +largeRecord (defaultPureScript {allFieldsStrict = False}) [d| + data R a = MkR { x :: Int, y :: [a] } deriving (Eq, Show) + data S a = S { x :: Int, y :: [a] } deriving (Eq, Show) + |] + +inOrder :: R Bool +inOrder = [lr| MkR { x = 1234, y = [True] } |] + +outOfOrder :: R Bool +outOfOrder = [lr| MkR { y = [True], x = 1234 } |] + +-- | Constructor application +-- +-- Occassionally we cannot use the quasi-quoter (for instance, in an +-- applicative context). +constructorApp :: R Bool +constructorApp = [lr| MkR |] 1234 [True] + +valueOfS :: S Bool +valueOfS = [lr| S { x = 1234, y = [True] } |] + +{------------------------------------------------------------------------------- + Nested records +-------------------------------------------------------------------------------} + +data RegularRecord = RR { a :: Int } + deriving (Show, Eq) + +largeRecord defaultPureScript [d| + data T = T { x :: Int, y :: S Bool, z :: RegularRecord } + |] + +valueOfT :: T +valueOfT = [lr| T { x = 5 + , y = S { x = 1234, y = [True] } + , z = RR { a = 5 } + } + |] + +{------------------------------------------------------------------------------- + Sanity check +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.RecordConstruction" [ + testCase "allEqual" testAllEqual + ] + +testAllEqual :: Assertion +testAllEqual = do + assertEqual "inOrder/outOfOrder" inOrder.x outOfOrder.x + assertEqual "inOrder/withoutQQ" inOrder.x constructorApp.x + assertEqual "R/S" inOrder.x valueOfS.x + assertEqual "T/S" valueOfT.y valueOfS + assertEqual "T/R" valueOfT.z (RR 5) diff --git a/test/Test/Record/Sanity/Strictness.hs b/test/Test/Record/Sanity/Strictness.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/Strictness.hs @@ -0,0 +1,96 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- {-# OPTIONS_GHC -ddump-splices -ddump-simpl #-} + +module Test.Record.Sanity.Strictness (tests) where + +import Control.Exception +import GHC.Records.Compat + +import Data.Record.Generic +import Data.Record.Generic.LowerBound +import Data.Record.TH + +import qualified Data.Record.Generic.Rep as Rep + +import Test.Tasty +import Test.Tasty.HUnit + +largeRecord defaultLazyOptions [d| + data Lazy = MkLazy { lazyField :: Word } + |] + +largeRecord defaultStrictOptions [d| + data Strict = MkStrict { strictField :: Word } + |] + +_silenceWarnings :: () +_silenceWarnings = const () $ ( + lazyField + , strictField + ) + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.Strictness" [ + testCase "initValueLazy" test_initValueLazy + , testCase "initValueStrict" test_initValueStrict + , testCase "setValueLazy" test_setValueLazy + , testCase "setValueStrict" test_setValueStrict + ] + +test_initValueLazy :: Assertion +test_initValueLazy = + initValue `seq` return () + where + initValue :: Lazy + initValue = to $ Rep.pure undefined + +test_initValueStrict :: Assertion +test_initValueStrict = + expectBoom (initValue `seq` return ()) + where + initValue :: Strict + initValue = to $ Rep.pure boom + +test_setValueLazy :: Assertion +test_setValueLazy = + setField @"lazyField" initValue boom `seq` return () + where + initValue :: Lazy + initValue = glowerBound + +test_setValueStrict :: Assertion +test_setValueStrict = + expectBoom (setField @"strictField" initValue boom `seq` return ()) + where + initValue :: Strict + initValue = glowerBound + +{------------------------------------------------------------------------------- + Auxiliary +-------------------------------------------------------------------------------} + +data Boom = Boom + deriving (Show) + +boom :: a +boom = throw Boom + +instance Exception Boom + +expectBoom :: IO () -> Assertion +expectBoom act = do + mErr <- try act + case mErr of + Left Boom -> return () + Right () -> assertFailure "Expected boom" diff --git a/test/Test/Record/Sanity/Transform.hs b/test/Test/Record/Sanity/Transform.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Sanity/Transform.hs @@ -0,0 +1,339 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Test.Record.Sanity.Transform (tests) where + +import Data.Functor.Identity +import Data.Kind +import Data.Proxy +import Data.SOP.BasicFunctors +import GHC.TypeLits + +import Test.Tasty +import Test.Tasty.HUnit + +import Data.Record.TH +import Data.Record.Generic +import Data.Record.Generic.Transform + +import qualified Data.Record.Generic.Rep as Rep +import qualified Generics.SOP as SOP + +{------------------------------------------------------------------------------- + Motivating example using SOP +-------------------------------------------------------------------------------} + +class CanInject x y where + inject :: x -> y + +instance CanInject (I x) (Maybe x) where + inject (I x) = Just x + +instance CanInject String String where + inject = id + +_gjust_SOP :: forall x fields fields'. + ( SOP.Generic (x I) + , SOP.Generic (x Maybe) + , SOP.IsProductType (x I) fields + , SOP.IsProductType (x Maybe) fields' + , SOP.AllZip CanInject fields fields' + ) + => x I -> x Maybe +_gjust_SOP = + SOP.productTypeTo . aux . SOP.productTypeFrom + where + aux :: SOP.NP I fields -> SOP.NP I fields' + aux = SOP.htrans (Proxy @CanInject) (fmap inject) + +{------------------------------------------------------------------------------- + Simple example +-------------------------------------------------------------------------------} + +type instance Interpreted (DefaultInterpretation f) String = String + +class InjectInterpreted f g a where + injectInterpreted :: + Interpret (DefaultInterpretation f) a + -> Interpret (DefaultInterpretation g) a + +instance InjectInterpreted I Maybe (Uninterpreted a) where + injectInterpreted = liftInterpreted $ \(I x) -> Just x + +instance InjectInterpreted I Maybe String where + injectInterpreted = liftInterpreted $ id + +largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d| + data A (f :: Type -> Type) = A { + aI :: f Int + , aB :: f Bool + , aS :: String + } + deriving (Show, Eq) + |] + +-- | Generic injection, using LR generics +-- +-- The type annotations are just to explain the flow, they are not required +-- for type inference. +gjust :: forall x (f :: Type -> Type) (g :: Type -> Type). + ( Generic (x f) + , Generic (x g) + , Generic (x Uninterpreted) + , Constraints (x Uninterpreted) (InjectInterpreted f g) + , HasNormalForm (DefaultInterpretation f) (x f) (x Uninterpreted) + , HasNormalForm (DefaultInterpretation g) (x g) (x Uninterpreted) + ) + => x f -> x g +gjust = + (to + :: Rep I (x g) + -> x g) + . (denormalize1 (Proxy @DefaultInterpretation) + :: Rep (Interpret (DefaultInterpretation g)) (x Uninterpreted) + -> Rep I (x g)) + . (Rep.cmap (Proxy @(InjectInterpreted f g)) injectInterpreted + :: Rep (Interpret (DefaultInterpretation f)) (x Uninterpreted) + -> Rep (Interpret (DefaultInterpretation g)) (x Uninterpreted)) + . (normalize1 (Proxy @DefaultInterpretation) + :: Rep I (x f) + -> Rep (Interpret (DefaultInterpretation f)) (x Uninterpreted)) + . (from + :: x f + -> Rep I (x f)) + +justA :: A I -> A Maybe +justA = gjust + +{------------------------------------------------------------------------------- + Example with two variables +-------------------------------------------------------------------------------} + +largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d| + data B (f :: Type -> Type) (g :: Type -> Type) = B { + bI :: f Int + , bB :: g Bool + , bS :: String + } + deriving (Show, Eq) + |] + +data Skolem (n :: Nat) x + +data DefInt2 (f :: Type -> Type) (g :: Type -> Type) + +type instance Interpreted (DefInt2 f g) (Skolem 0 x) = f x +type instance Interpreted (DefInt2 f g) (Skolem 1 x) = g x +type instance Interpreted (DefInt2 f g) String = String + +class SwapInterpreted f g a where + swapInterpreted :: + Interpret (DefInt2 f g) a + -> Interpret (DefInt2 g f) a + +instance SwapInterpreted I Identity (Skolem 0 x) where + swapInterpreted = liftInterpreted $ \(I x) -> Identity x + +instance SwapInterpreted I Identity (Skolem 1 y) where + swapInterpreted = liftInterpreted $ \(Identity x) -> I x + +instance SwapInterpreted f g String where + swapInterpreted = liftInterpreted $ id + +gswap :: forall x (f :: Type -> Type) (g :: Type -> Type). + ( Generic (x f g) + , Generic (x g f) + , Generic (x (Skolem 0) (Skolem 1)) + , Constraints (x (Skolem 0) (Skolem 1)) (SwapInterpreted f g) + , HasNormalForm (DefInt2 f g) (x f g) (x (Skolem 0) (Skolem 1)) + , HasNormalForm (DefInt2 g f) (x g f) (x (Skolem 0) (Skolem 1)) + ) + => x f g -> x g f +gswap = + to + . denormalize (Proxy @(DefInt2 g f)) (Proxy @(x (Skolem 0) (Skolem 1))) + . Rep.cmap (Proxy @(SwapInterpreted f g)) swapInterpreted + . normalize (Proxy @(DefInt2 f g)) (Proxy @(x (Skolem 0) (Skolem 1))) + . from + +swapB :: B I Identity -> B Identity I +swapB = gswap + +{------------------------------------------------------------------------------- + Mini-beam +-------------------------------------------------------------------------------} + +data Nullable (c :: Type -> Type) x + +type family Columnar (f :: Type -> Type) x where + Columnar Identity x = x + Columnar (Nullable c) x = Columnar c (Maybe x) + Columnar f x = f x + +newtype Columnar' f a = Columnar' { getColumnar' :: Columnar f a } + +class Beamable table where + zipBeamFieldsM :: + Applicative m + => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) + -> table f -> table g -> m (table h) + +class (Beamable table, Beamable (PrimaryKey table)) => Table table where + data PrimaryKey table (f :: Type -> Type) :: Type + +{------------------------------------------------------------------------------- + Interpretation function for Beam +-------------------------------------------------------------------------------} + +data BeamInterpretation (f :: Type -> Type) + +type instance Interpreted (BeamInterpretation f) (table Uninterpreted) = table f +type instance Interpreted (BeamInterpretation f) (Uninterpreted x) = Columnar f x + +class ZipInterpreted a where + zipInterpreted :: + Applicative m + => (forall x. Columnar' f x -> Columnar' g x -> m (Columnar' h x)) + -> Interpret (BeamInterpretation f) a + -> Interpret (BeamInterpretation g) a + -> m (Interpret (BeamInterpretation h) a) + +instance Beamable table => ZipInterpreted (table Uninterpreted) where + zipInterpreted f = liftInterpretedA2 $ zipBeamFieldsM f + +instance ZipInterpreted (Uninterpreted x) where + zipInterpreted f = liftInterpretedA2 $ applyColumnar' (Proxy @x) f + +applyColumnar' :: forall m f g h x. + Functor m + => Proxy x + -> (Columnar' f x -> Columnar' g x -> m (Columnar' h x)) + -> (Columnar f x -> Columnar g x -> m (Columnar h x)) +applyColumnar' _ f fx gx = getColumnar' <$> f (Columnar' fx) (Columnar' gx) + +{------------------------------------------------------------------------------- + Beam test +-------------------------------------------------------------------------------} + +largeRecord (defaultLazyOptions { generatePatternSynonym = True }) [d| + data TableA (f :: Type -> Type) = TableA { + taFieldI :: PrimaryKey TableA f + , taFieldB :: Columnar f Bool + , taFieldM :: TableB f + } + deriving (Show, Eq) + + data TableB (f :: Type -> Type) = TableB { + tbFieldC :: Columnar f Char + } + deriving (Show, Eq) + |] + +instance Table TableA where + data PrimaryKey TableA f = PrimA (Columnar f Int) + +deriving instance Show (Columnar f Int) => Show (PrimaryKey TableA f) +deriving instance Eq (Columnar f Int) => Eq (PrimaryKey TableA f) + +instance Beamable (PrimaryKey TableA) where + -- The GHC.Generics instance would normally be fine for primary keys + zipBeamFieldsM f (PrimA x) (PrimA y) = PrimA <$> + applyColumnar' (Proxy @Int) f x y + +instance Beamable TableA where + zipBeamFieldsM = gzipBeam + +instance Beamable TableB where + zipBeamFieldsM = gzipBeam + +gzipBeam :: forall m table f g h. + ( Applicative m + , Generic (table f) + , Generic (table g) + , Generic (table h) + , Generic (table Uninterpreted) + , Constraints (table Uninterpreted) ZipInterpreted + , HasNormalForm (BeamInterpretation f) (table f) (table Uninterpreted) + , HasNormalForm (BeamInterpretation g) (table g) (table Uninterpreted) + , HasNormalForm (BeamInterpretation h) (table h) (table Uninterpreted) + ) + => (forall a. Columnar' f a -> Columnar' g a -> m (Columnar' h a)) + -> table f -> table g -> m (table h) +gzipBeam f a b = + fmap (to . denormalize1 (Proxy @BeamInterpretation)) $ + Rep.czipWithM + (Proxy @ZipInterpreted) + (zipInterpreted f) + (normalize1 (Proxy @BeamInterpretation) (from a)) + (normalize1 (Proxy @BeamInterpretation) (from b)) + +{------------------------------------------------------------------------------- + Tests +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Record.Sanity.Transform" [ + testCase "gjust" test_gjust + , testCase "gswap" test_gswap + , testCase "gzipBeam" test_gzipBeam + ] + +test_gjust :: Assertion +test_gjust = + assertEqual "" + (justA $ A { aI = I 5, aB = I True, aS = "hi" }) + ( A { aI = Just 5, aB = Just True, aS = "hi" }) + +test_gswap :: Assertion +test_gswap = + assertEqual "" + (swapB $ B { bI = I 5, bB = Identity True, bS = "hi" }) + ( B { bI = Identity 5, bB = I True, bS = "hi" }) + +data Pair x = Pair x x + deriving (Show, Eq) + +test_gzipBeam :: Assertion +test_gzipBeam = + assertEqual "" + (unI (zipBeamFieldsM pairup tableA tableA)) + tableA' + where + pairup :: Columnar' I x -> Columnar' I x -> I (Columnar' Pair x) + pairup (Columnar' (I x)) (Columnar' (I y)) = I (Columnar' $ Pair x y) + + tableA :: TableA I + tableA = TableA { + taFieldI = PrimA (I 5) + , taFieldB = I True + , taFieldM = tableB + } + + tableB :: TableB I + tableB = TableB { + tbFieldC = I 'x' + } + + tableA' :: TableA Pair + tableA' = TableA { + taFieldI = PrimA (Pair 5 5) + , taFieldB = Pair True True + , taFieldM = tableB' + } + + tableB' :: TableB Pair + tableB' = TableB { + tbFieldC = Pair 'x' 'x' + } diff --git a/test/Test/Record/Size/After/HK010.hs b/test/Test/Record/Size/After/HK010.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/HK010.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +-- {-# OPTIONS_GHC -ddump-splices #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.HK010 where + +import Data.Record.TH + +import Test.Record.Size.Infra + +largeRecord defaultLazyOptions (higherKindedRecordOfSize 10) + +-- Complains about +-- +-- > No instance for (Data.Functor.Classes.Show1 r) +-- > arising from a use of ‘show’ +-- +-- which is what we want: @ghc@ has simplified all 10 constraints on each +-- individual field (generated by 'largeRecord') to a single constraint on @r@. +-- +-- TODO: Perhaps we could check this automatically using -fdefer-type-errors. +-- +-- checkInferredType :: HKR r -> String +-- checkInferredType (r :: HKR f) = show r diff --git a/test/Test/Record/Size/After/HK020.hs b/test/Test/Record/Size/After/HK020.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/HK020.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.HK020 where + +import Data.Record.TH + +import Test.Record.Size.Infra + +largeRecord defaultLazyOptions (higherKindedRecordOfSize 20) diff --git a/test/Test/Record/Size/After/HK030.hs b/test/Test/Record/Size/After/HK030.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/HK030.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.HK030 where + +import Data.Record.TH + +import Test.Record.Size.Infra + +largeRecord defaultLazyOptions (higherKindedRecordOfSize 30) diff --git a/test/Test/Record/Size/After/HK040.hs b/test/Test/Record/Size/After/HK040.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/HK040.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.HK040 where + +import Data.Record.TH + +import Test.Record.Size.Infra + +largeRecord defaultLazyOptions (higherKindedRecordOfSize 40) diff --git a/test/Test/Record/Size/After/HK050.hs b/test/Test/Record/Size/After/HK050.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/HK050.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.HK050 where + +import Data.Record.TH + +import Test.Record.Size.Infra + +largeRecord defaultLazyOptions (higherKindedRecordOfSize 50) diff --git a/test/Test/Record/Size/After/HK060.hs b/test/Test/Record/Size/After/HK060.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/HK060.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.HK060 where + +import Data.Record.TH + +import Test.Record.Size.Infra + +largeRecord defaultLazyOptions (higherKindedRecordOfSize 60) diff --git a/test/Test/Record/Size/After/HK070.hs b/test/Test/Record/Size/After/HK070.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/HK070.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.HK070 where + +import Data.Record.TH + +import Test.Record.Size.Infra + +largeRecord defaultLazyOptions (higherKindedRecordOfSize 70) diff --git a/test/Test/Record/Size/After/HK080.hs b/test/Test/Record/Size/After/HK080.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/HK080.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.HK080 where + +import Data.Record.TH + +import Test.Record.Size.Infra + +largeRecord defaultLazyOptions (higherKindedRecordOfSize 80) diff --git a/test/Test/Record/Size/After/HK090.hs b/test/Test/Record/Size/After/HK090.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/HK090.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.HK090 where + +import Data.Record.TH + +import Test.Record.Size.Infra + +largeRecord defaultLazyOptions (higherKindedRecordOfSize 90) diff --git a/test/Test/Record/Size/After/HK100.hs b/test/Test/Record/Size/After/HK100.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/HK100.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.HK100 where + +import Data.Record.TH + +import Test.Record.Size.Infra + +largeRecord defaultLazyOptions (higherKindedRecordOfSize 100) diff --git a/test/Test/Record/Size/After/R0010.hs b/test/Test/Record/Size/After/R0010.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0010.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0010 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 10) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0020.hs b/test/Test/Record/Size/After/R0020.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0020.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0020 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 20) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0030.hs b/test/Test/Record/Size/After/R0030.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0030.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0030 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 30) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0040.hs b/test/Test/Record/Size/After/R0040.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0040.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0040 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 40) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0050.hs b/test/Test/Record/Size/After/R0050.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0050.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0050 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 50) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0060.hs b/test/Test/Record/Size/After/R0060.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0060.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0060 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 60) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0070.hs b/test/Test/Record/Size/After/R0070.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0070.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0070 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 70) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0080.hs b/test/Test/Record/Size/After/R0080.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0080.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0080 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 80) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0090.hs b/test/Test/Record/Size/After/R0090.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0090.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0090 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 90) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0100.hs b/test/Test/Record/Size/After/R0100.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0100.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0100 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 100) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0200.hs b/test/Test/Record/Size/After/R0200.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0200.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0200 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 200) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0300.hs b/test/Test/Record/Size/After/R0300.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0300.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0300 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 300) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0400.hs b/test/Test/Record/Size/After/R0400.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0400.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0400 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 400) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0500.hs b/test/Test/Record/Size/After/R0500.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0500.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0500 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 500) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0600.hs b/test/Test/Record/Size/After/R0600.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0600.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0600 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 600) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0700.hs b/test/Test/Record/Size/After/R0700.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0700.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0700 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 700) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0800.hs b/test/Test/Record/Size/After/R0800.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0800.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0800 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 800) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R0900.hs b/test/Test/Record/Size/After/R0900.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R0900.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R0900 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 900) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/After/R1000.hs b/test/Test/Record/Size/After/R1000.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/After/R1000.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.After.R1000 where + +import Data.Aeson (ToJSON(..)) + +import Data.Record.Generic.JSON +import Data.Record.TH + +import Test.Record.Size.Infra + +#ifdef PROFILE_ALLZIP +import Data.Record.Generic +import Data.Record.Generic.Transform +#endif + +largeRecord defaultLazyOptions (recordOfSize 1000) + +instance ToJSON R where + toJSON = gtoJSON + +#ifdef PROFILE_ALLZIP +testInterpretTo :: () +testInterpretTo = aux + where + aux :: InterpretTo I (MetadataOf R) (MetadataOf R) => () + aux = () +#endif diff --git a/test/Test/Record/Size/Before/Baseline.hs b/test/Test/Record/Size/Before/Baseline.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Before/Baseline.hs @@ -0,0 +1,2 @@ +-- | Empty module, to establish a baseline for memory usage +module Test.Record.Size.Before.Baseline () where diff --git a/test/Test/Record/Size/Before/R010.hs b/test/Test/Record/Size/Before/R010.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Before/R010.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.Before.R010 where + +import Data.Aeson +import Generics.SOP.JSON +import Generics.SOP.TH + +import Test.Record.Size.Infra + +-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. +data R = MkR { + -- 1 .. 10 + field1 :: T 1 + , field2 :: T 2 + , field3 :: T 3 + , field4 :: T 4 + , field5 :: T 5 + , field6 :: T 6 + , field7 :: T 7 + , field8 :: T 8 + , field9 :: T 9 + , field10 :: T 10 + } + +deriving instance Eq R +deriving instance Show R + +deriveGeneric ''R + +instance ToJSON R where + toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R020.hs b/test/Test/Record/Size/Before/R020.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Before/R020.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.Before.R020 where + +import Data.Aeson +import Generics.SOP.JSON +import Generics.SOP.TH + +import Test.Record.Size.Infra + +-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. +data R = MkR { + -- 1 .. 10 + field1 :: T 1 + , field2 :: T 2 + , field3 :: T 3 + , field4 :: T 4 + , field5 :: T 5 + , field6 :: T 6 + , field7 :: T 7 + , field8 :: T 8 + , field9 :: T 9 + , field10 :: T 10 + -- 11 .. 20 + , field11 :: T 11 + , field12 :: T 12 + , field13 :: T 13 + , field14 :: T 14 + , field15 :: T 15 + , field16 :: T 16 + , field17 :: T 17 + , field18 :: T 18 + , field19 :: T 19 + , field20 :: T 20 + } + +deriving instance Eq R +deriving instance Show R + +deriveGeneric ''R + +instance ToJSON R where + toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R030.hs b/test/Test/Record/Size/Before/R030.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Before/R030.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.Before.R030 where + +import Data.Aeson +import Generics.SOP.JSON +import Generics.SOP.TH + +import Test.Record.Size.Infra + +-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. +data R = MkR { + -- 1 .. 10 + field1 :: T 1 + , field2 :: T 2 + , field3 :: T 3 + , field4 :: T 4 + , field5 :: T 5 + , field6 :: T 6 + , field7 :: T 7 + , field8 :: T 8 + , field9 :: T 9 + , field10 :: T 10 + -- 11 .. 20 + , field11 :: T 11 + , field12 :: T 12 + , field13 :: T 13 + , field14 :: T 14 + , field15 :: T 15 + , field16 :: T 16 + , field17 :: T 17 + , field18 :: T 18 + , field19 :: T 19 + , field20 :: T 20 + -- 21 .. 30 + , field21 :: T 21 + , field22 :: T 22 + , field23 :: T 23 + , field24 :: T 24 + , field25 :: T 25 + , field26 :: T 26 + , field27 :: T 27 + , field28 :: T 28 + , field29 :: T 29 + , field30 :: T 30 + } + +deriving instance Eq R +deriving instance Show R + +deriveGeneric ''R + +instance ToJSON R where + toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R040.hs b/test/Test/Record/Size/Before/R040.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Before/R040.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.Before.R040 where + +import Data.Aeson +import Generics.SOP.JSON +import Generics.SOP.TH + +import Test.Record.Size.Infra + +-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. +data R = MkR { + -- 1 .. 10 + field1 :: T 1 + , field2 :: T 2 + , field3 :: T 3 + , field4 :: T 4 + , field5 :: T 5 + , field6 :: T 6 + , field7 :: T 7 + , field8 :: T 8 + , field9 :: T 9 + , field10 :: T 10 + -- 11 .. 20 + , field11 :: T 11 + , field12 :: T 12 + , field13 :: T 13 + , field14 :: T 14 + , field15 :: T 15 + , field16 :: T 16 + , field17 :: T 17 + , field18 :: T 18 + , field19 :: T 19 + , field20 :: T 20 + -- 21 .. 30 + , field21 :: T 21 + , field22 :: T 22 + , field23 :: T 23 + , field24 :: T 24 + , field25 :: T 25 + , field26 :: T 26 + , field27 :: T 27 + , field28 :: T 28 + , field29 :: T 29 + , field30 :: T 30 + -- 31 .. 40 + , field31 :: T 31 + , field32 :: T 32 + , field33 :: T 33 + , field34 :: T 34 + , field35 :: T 35 + , field36 :: T 36 + , field37 :: T 37 + , field38 :: T 38 + , field39 :: T 39 + , field40 :: T 40 + } + +deriving instance Eq R +deriving instance Show R + +deriveGeneric ''R + +instance ToJSON R where + toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R050.hs b/test/Test/Record/Size/Before/R050.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Before/R050.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.Before.R050 where + +import Data.Aeson +import Generics.SOP.JSON +import Generics.SOP.TH + +import Test.Record.Size.Infra + +-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. +data R = MkR { + -- 1 .. 10 + field1 :: T 1 + , field2 :: T 2 + , field3 :: T 3 + , field4 :: T 4 + , field5 :: T 5 + , field6 :: T 6 + , field7 :: T 7 + , field8 :: T 8 + , field9 :: T 9 + , field10 :: T 10 + -- 11 .. 20 + , field11 :: T 11 + , field12 :: T 12 + , field13 :: T 13 + , field14 :: T 14 + , field15 :: T 15 + , field16 :: T 16 + , field17 :: T 17 + , field18 :: T 18 + , field19 :: T 19 + , field20 :: T 20 + -- 21 .. 30 + , field21 :: T 21 + , field22 :: T 22 + , field23 :: T 23 + , field24 :: T 24 + , field25 :: T 25 + , field26 :: T 26 + , field27 :: T 27 + , field28 :: T 28 + , field29 :: T 29 + , field30 :: T 30 + -- 31 .. 40 + , field31 :: T 31 + , field32 :: T 32 + , field33 :: T 33 + , field34 :: T 34 + , field35 :: T 35 + , field36 :: T 36 + , field37 :: T 37 + , field38 :: T 38 + , field39 :: T 39 + , field40 :: T 40 + -- 41 .. 50 + , field41 :: T 41 + , field42 :: T 42 + , field43 :: T 43 + , field44 :: T 44 + , field45 :: T 45 + , field46 :: T 46 + , field47 :: T 47 + , field48 :: T 48 + , field49 :: T 49 + , field50 :: T 50 + } + +deriving instance Eq R +deriving instance Show R + +deriveGeneric ''R + +instance ToJSON R where + toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R060.hs b/test/Test/Record/Size/Before/R060.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Before/R060.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.Before.R060 where + +import Data.Aeson +import Generics.SOP.JSON +import Generics.SOP.TH + +import Test.Record.Size.Infra + +-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. +data R = MkR { + -- 1 .. 10 + field1 :: T 1 + , field2 :: T 2 + , field3 :: T 3 + , field4 :: T 4 + , field5 :: T 5 + , field6 :: T 6 + , field7 :: T 7 + , field8 :: T 8 + , field9 :: T 9 + , field10 :: T 10 + -- 11 .. 20 + , field11 :: T 11 + , field12 :: T 12 + , field13 :: T 13 + , field14 :: T 14 + , field15 :: T 15 + , field16 :: T 16 + , field17 :: T 17 + , field18 :: T 18 + , field19 :: T 19 + , field20 :: T 20 + -- 21 .. 30 + , field21 :: T 21 + , field22 :: T 22 + , field23 :: T 23 + , field24 :: T 24 + , field25 :: T 25 + , field26 :: T 26 + , field27 :: T 27 + , field28 :: T 28 + , field29 :: T 29 + , field30 :: T 30 + -- 31 .. 40 + , field31 :: T 31 + , field32 :: T 32 + , field33 :: T 33 + , field34 :: T 34 + , field35 :: T 35 + , field36 :: T 36 + , field37 :: T 37 + , field38 :: T 38 + , field39 :: T 39 + , field40 :: T 40 + -- 41 .. 50 + , field41 :: T 41 + , field42 :: T 42 + , field43 :: T 43 + , field44 :: T 44 + , field45 :: T 45 + , field46 :: T 46 + , field47 :: T 47 + , field48 :: T 48 + , field49 :: T 49 + , field50 :: T 50 + -- 51 .. 60 + , field51 :: T 51 + , field52 :: T 52 + , field53 :: T 53 + , field54 :: T 54 + , field55 :: T 55 + , field56 :: T 56 + , field57 :: T 57 + , field58 :: T 58 + , field59 :: T 59 + , field60 :: T 60 + } + +deriving instance Eq R +deriving instance Show R + +deriveGeneric ''R + +instance ToJSON R where + toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R070.hs b/test/Test/Record/Size/Before/R070.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Before/R070.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.Before.R070 where + +import Data.Aeson +import Generics.SOP.JSON +import Generics.SOP.TH + +import Test.Record.Size.Infra + +-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. +data R = MkR { + -- 1 .. 10 + field1 :: T 1 + , field2 :: T 2 + , field3 :: T 3 + , field4 :: T 4 + , field5 :: T 5 + , field6 :: T 6 + , field7 :: T 7 + , field8 :: T 8 + , field9 :: T 9 + , field10 :: T 10 + -- 11 .. 20 + , field11 :: T 11 + , field12 :: T 12 + , field13 :: T 13 + , field14 :: T 14 + , field15 :: T 15 + , field16 :: T 16 + , field17 :: T 17 + , field18 :: T 18 + , field19 :: T 19 + , field20 :: T 20 + -- 21 .. 30 + , field21 :: T 21 + , field22 :: T 22 + , field23 :: T 23 + , field24 :: T 24 + , field25 :: T 25 + , field26 :: T 26 + , field27 :: T 27 + , field28 :: T 28 + , field29 :: T 29 + , field30 :: T 30 + -- 31 .. 40 + , field31 :: T 31 + , field32 :: T 32 + , field33 :: T 33 + , field34 :: T 34 + , field35 :: T 35 + , field36 :: T 36 + , field37 :: T 37 + , field38 :: T 38 + , field39 :: T 39 + , field40 :: T 40 + -- 41 .. 50 + , field41 :: T 41 + , field42 :: T 42 + , field43 :: T 43 + , field44 :: T 44 + , field45 :: T 45 + , field46 :: T 46 + , field47 :: T 47 + , field48 :: T 48 + , field49 :: T 49 + , field50 :: T 50 + -- 51 .. 60 + , field51 :: T 51 + , field52 :: T 52 + , field53 :: T 53 + , field54 :: T 54 + , field55 :: T 55 + , field56 :: T 56 + , field57 :: T 57 + , field58 :: T 58 + , field59 :: T 59 + , field60 :: T 60 + -- 61 .. 70 + , field61 :: T 61 + , field62 :: T 62 + , field63 :: T 63 + , field64 :: T 64 + , field65 :: T 65 + , field66 :: T 66 + , field67 :: T 67 + , field68 :: T 68 + , field69 :: T 69 + , field70 :: T 70 + } + +deriving instance Eq R +deriving instance Show R + +deriveGeneric ''R + +instance ToJSON R where + toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R080.hs b/test/Test/Record/Size/Before/R080.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Before/R080.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.Before.R080 where + +import Data.Aeson +import Generics.SOP.JSON +import Generics.SOP.TH + +import Test.Record.Size.Infra + +-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. +data R = MkR { + -- 1 .. 10 + field1 :: T 1 + , field2 :: T 2 + , field3 :: T 3 + , field4 :: T 4 + , field5 :: T 5 + , field6 :: T 6 + , field7 :: T 7 + , field8 :: T 8 + , field9 :: T 9 + , field10 :: T 10 + -- 11 .. 20 + , field11 :: T 11 + , field12 :: T 12 + , field13 :: T 13 + , field14 :: T 14 + , field15 :: T 15 + , field16 :: T 16 + , field17 :: T 17 + , field18 :: T 18 + , field19 :: T 19 + , field20 :: T 20 + -- 21 .. 30 + , field21 :: T 21 + , field22 :: T 22 + , field23 :: T 23 + , field24 :: T 24 + , field25 :: T 25 + , field26 :: T 26 + , field27 :: T 27 + , field28 :: T 28 + , field29 :: T 29 + , field30 :: T 30 + -- 31 .. 40 + , field31 :: T 31 + , field32 :: T 32 + , field33 :: T 33 + , field34 :: T 34 + , field35 :: T 35 + , field36 :: T 36 + , field37 :: T 37 + , field38 :: T 38 + , field39 :: T 39 + , field40 :: T 40 + -- 41 .. 50 + , field41 :: T 41 + , field42 :: T 42 + , field43 :: T 43 + , field44 :: T 44 + , field45 :: T 45 + , field46 :: T 46 + , field47 :: T 47 + , field48 :: T 48 + , field49 :: T 49 + , field50 :: T 50 + -- 51 .. 60 + , field51 :: T 51 + , field52 :: T 52 + , field53 :: T 53 + , field54 :: T 54 + , field55 :: T 55 + , field56 :: T 56 + , field57 :: T 57 + , field58 :: T 58 + , field59 :: T 59 + , field60 :: T 60 + -- 61 .. 70 + , field61 :: T 61 + , field62 :: T 62 + , field63 :: T 63 + , field64 :: T 64 + , field65 :: T 65 + , field66 :: T 66 + , field67 :: T 67 + , field68 :: T 68 + , field69 :: T 69 + , field70 :: T 70 + -- 71 .. 80 + , field71 :: T 71 + , field72 :: T 72 + , field73 :: T 73 + , field74 :: T 74 + , field75 :: T 75 + , field76 :: T 76 + , field77 :: T 77 + , field78 :: T 78 + , field79 :: T 79 + , field80 :: T 80 + } + +deriving instance Eq R +deriving instance Show R + +deriveGeneric ''R + +instance ToJSON R where + toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R090.hs b/test/Test/Record/Size/Before/R090.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Before/R090.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.Before.R090 where + +import Data.Aeson +import Generics.SOP.JSON +import Generics.SOP.TH + +import Test.Record.Size.Infra + +-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. +data R = MkR { + -- 1 .. 10 + field1 :: T 1 + , field2 :: T 2 + , field3 :: T 3 + , field4 :: T 4 + , field5 :: T 5 + , field6 :: T 6 + , field7 :: T 7 + , field8 :: T 8 + , field9 :: T 9 + , field10 :: T 10 + -- 11 .. 20 + , field11 :: T 11 + , field12 :: T 12 + , field13 :: T 13 + , field14 :: T 14 + , field15 :: T 15 + , field16 :: T 16 + , field17 :: T 17 + , field18 :: T 18 + , field19 :: T 19 + , field20 :: T 20 + -- 21 .. 30 + , field21 :: T 21 + , field22 :: T 22 + , field23 :: T 23 + , field24 :: T 24 + , field25 :: T 25 + , field26 :: T 26 + , field27 :: T 27 + , field28 :: T 28 + , field29 :: T 29 + , field30 :: T 30 + -- 31 .. 40 + , field31 :: T 31 + , field32 :: T 32 + , field33 :: T 33 + , field34 :: T 34 + , field35 :: T 35 + , field36 :: T 36 + , field37 :: T 37 + , field38 :: T 38 + , field39 :: T 39 + , field40 :: T 40 + -- 41 .. 50 + , field41 :: T 41 + , field42 :: T 42 + , field43 :: T 43 + , field44 :: T 44 + , field45 :: T 45 + , field46 :: T 46 + , field47 :: T 47 + , field48 :: T 48 + , field49 :: T 49 + , field50 :: T 50 + -- 51 .. 60 + , field51 :: T 51 + , field52 :: T 52 + , field53 :: T 53 + , field54 :: T 54 + , field55 :: T 55 + , field56 :: T 56 + , field57 :: T 57 + , field58 :: T 58 + , field59 :: T 59 + , field60 :: T 60 + -- 61 .. 70 + , field61 :: T 61 + , field62 :: T 62 + , field63 :: T 63 + , field64 :: T 64 + , field65 :: T 65 + , field66 :: T 66 + , field67 :: T 67 + , field68 :: T 68 + , field69 :: T 69 + , field70 :: T 70 + -- 71 .. 80 + , field71 :: T 71 + , field72 :: T 72 + , field73 :: T 73 + , field74 :: T 74 + , field75 :: T 75 + , field76 :: T 76 + , field77 :: T 77 + , field78 :: T 78 + , field79 :: T 79 + , field80 :: T 80 + -- 81 .. 90 + , field81 :: T 81 + , field82 :: T 82 + , field83 :: T 83 + , field84 :: T 84 + , field85 :: T 85 + , field86 :: T 86 + , field87 :: T 87 + , field88 :: T 88 + , field89 :: T 89 + , field90 :: T 90 + } + +deriving instance Eq R +deriving instance Show R + +deriveGeneric ''R + +instance ToJSON R where + toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Before/R100.hs b/test/Test/Record/Size/Before/R100.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Before/R100.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-# OPTIONS_GHC -fplugin=RecordDotPreprocessor #-} + +#if USE_GHC_DUMP +{-# OPTIONS_GHC -fplugin=GhcDump.Plugin #-} +#endif + +module Test.Record.Size.Before.R100 where + +import Data.Aeson +import Generics.SOP.JSON +import Generics.SOP.TH + +import Test.Record.Size.Infra + +-- @RecordDotPreprocessor@ runs before TH, so cannot use 'recordOfSize'. +data R = MkR { + -- 1 .. 10 + field1 :: T 1 + , field2 :: T 2 + , field3 :: T 3 + , field4 :: T 4 + , field5 :: T 5 + , field6 :: T 6 + , field7 :: T 7 + , field8 :: T 8 + , field9 :: T 9 + , field10 :: T 10 + -- 11 .. 20 + , field11 :: T 11 + , field12 :: T 12 + , field13 :: T 13 + , field14 :: T 14 + , field15 :: T 15 + , field16 :: T 16 + , field17 :: T 17 + , field18 :: T 18 + , field19 :: T 19 + , field20 :: T 20 + -- 21 .. 30 + , field21 :: T 21 + , field22 :: T 22 + , field23 :: T 23 + , field24 :: T 24 + , field25 :: T 25 + , field26 :: T 26 + , field27 :: T 27 + , field28 :: T 28 + , field29 :: T 29 + , field30 :: T 30 + -- 31 .. 40 + , field31 :: T 31 + , field32 :: T 32 + , field33 :: T 33 + , field34 :: T 34 + , field35 :: T 35 + , field36 :: T 36 + , field37 :: T 37 + , field38 :: T 38 + , field39 :: T 39 + , field40 :: T 40 + -- 41 .. 50 + , field41 :: T 41 + , field42 :: T 42 + , field43 :: T 43 + , field44 :: T 44 + , field45 :: T 45 + , field46 :: T 46 + , field47 :: T 47 + , field48 :: T 48 + , field49 :: T 49 + , field50 :: T 50 + -- 51 .. 60 + , field51 :: T 51 + , field52 :: T 52 + , field53 :: T 53 + , field54 :: T 54 + , field55 :: T 55 + , field56 :: T 56 + , field57 :: T 57 + , field58 :: T 58 + , field59 :: T 59 + , field60 :: T 60 + -- 61 .. 70 + , field61 :: T 61 + , field62 :: T 62 + , field63 :: T 63 + , field64 :: T 64 + , field65 :: T 65 + , field66 :: T 66 + , field67 :: T 67 + , field68 :: T 68 + , field69 :: T 69 + , field70 :: T 70 + -- 71 .. 80 + , field71 :: T 71 + , field72 :: T 72 + , field73 :: T 73 + , field74 :: T 74 + , field75 :: T 75 + , field76 :: T 76 + , field77 :: T 77 + , field78 :: T 78 + , field79 :: T 79 + , field80 :: T 80 + -- 81 .. 90 + , field81 :: T 81 + , field82 :: T 82 + , field83 :: T 83 + , field84 :: T 84 + , field85 :: T 85 + , field86 :: T 86 + , field87 :: T 87 + , field88 :: T 88 + , field89 :: T 89 + , field90 :: T 90 + -- 91 .. 100 + , field91 :: T 91 + , field92 :: T 92 + , field93 :: T 93 + , field94 :: T 94 + , field95 :: T 95 + , field96 :: T 96 + , field97 :: T 97 + , field98 :: T 98 + , field99 :: T 99 + , field100 :: T 100 + } + +deriving instance Eq R +deriving instance Show R + +deriveGeneric ''R + +instance ToJSON R where + toJSON = gtoJSON defaultJsonOptions diff --git a/test/Test/Record/Size/Infra.hs b/test/Test/Record/Size/Infra.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Infra.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +module Test.Record.Size.Infra ( + recordOfSize + , higherKindedRecordOfSize + -- * Supporting infrastructure used by generated code + , T(..) + -- * Re-exports + , I + ) where + +import Data.Aeson +import Data.Functor.Classes +import Data.Functor.Identity +import Data.Kind +import Data.Proxy +import Data.SOP.BasicFunctors +import GHC.TypeLits + +import Language.Haskell.TH hiding (Type) +import Language.Haskell.TH.Syntax hiding (Type) + +import Data.Record.Generic.LowerBound +import Data.Record.Generic.Transform + +{------------------------------------------------------------------------------- + Construct records of specified size +-------------------------------------------------------------------------------} + +-- | Generate something like +-- +-- > data R = MkR { +-- > field1 :: T 1 +-- > , field2 :: T 2 +-- > , field3 :: T 3 +-- > , field4 :: T 4 +-- > , field5 :: T 5 +-- > } +-- +-- In order to be compatible with the records originating from @[d| ... |]@, +-- we use 'newName' here rather than 'mkName'. +recordOfSize :: Integer -> Q [Dec] +recordOfSize n = fmap (:[]) $ do + r <- newName "R" + mkR <- newName "MkR" + dataD + (cxt []) + r + [] + Nothing + [recC mkR fields] + [] + where + fields :: [Q VarBangType] + fields = [ + do fieldI <- newName $ "field" ++ show i + varBangType + fieldI + (bangType defaultBang (conT ''T `appT` litT (numTyLit i))) + | i <- [1 .. n] + ] + +-- | Like 'recordOfSize', but generate a record with a higher-kinded type var. +-- +-- Generates something like: +-- +-- > data HKR (f :: Type -> Type) = MkHKR { +-- > field1 :: HK 1 f +-- > , field2 :: HK 2 f +-- > , field3 :: HK 3 f +-- > , field4 :: HK 4 f +-- > , field5 :: HK 5 f +-- > } +-- > deriving Show +-- +-- See comments in 'recordOfSize' for the use of 'newName'. +higherKindedRecordOfSize :: Integer -> Q [Dec] +higherKindedRecordOfSize n = fmap (:[]) $ do + f <- newName "f" + k <- [t| Type -> Type |] + hkr <- newName "HKR" + mkHKR <- newName "MkHKR" + dataD + (cxt []) + hkr + [KindedTV f k] + Nothing + [recC mkHKR (fields f)] + [derivClause Nothing [conT ''Show]] + where + fields :: Name -> [Q VarBangType] + fields f = [ + do fieldI <- newName $ "field" ++ show i + varBangType + fieldI + (bangType defaultBang (conT ''HK `appT` litT (numTyLit i) `appT` varT f)) + | i <- [1 .. n] + ] + +defaultBang :: BangQ +defaultBang = bang noSourceUnpackedness noSourceStrictness + +{------------------------------------------------------------------------------- + Definitions referred to by the generated TH code +-------------------------------------------------------------------------------} + +-- | 'T' gives us as many different types as we need +newtype T (i :: Nat) = MkT Word + deriving (Show, Eq, ToJSON) + +type instance Interpreted I (T i) = T i + +-- | Like 'T', but with a higher-kinded type variable +newtype HK (i :: Nat) (f :: Type -> Type) = MkHK (f Word) + +instance KnownNat i => LowerBound (T i) where + lowerBound = MkT $ fromInteger $ natVal (Proxy @i) + +instance KnownNat i => LowerBound (HK i Identity) where + lowerBound = MkHK $ fromInteger $ natVal (Proxy @i) + +instance Show1 f => Show (HK i f) where + showsPrec d (MkHK x) = showsPrec1 d x diff --git a/test/Test/Record/Size/Sanity.hs b/test/Test/Record/Size/Sanity.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Size/Sanity.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE CPP #-} + +{-# OPTIONS_GHC -F -pgmF=record-dot-preprocessor #-} + +-- | Sanity checks that we generate correct code for in the @Sized.*@ modules +-- +-- The real test of the @Size.*@ moduels of course is not this module, but +-- rather their compiled size. +module Test.Record.Size.Sanity (tests) where + +import Data.Aeson +import Data.Functor.Identity + +import qualified Data.Record.Generic.SOP as SOP +import qualified Data.Record.Generic.LowerBound as LR + +import qualified Test.Record.Size.Before.R010 as Before010 +import qualified Test.Record.Size.After.R0010 as After0010 +import qualified Test.Record.Size.After.HK010 as AfterHK10 + +#if USE_GHC_DUMP +import Test.Record.Size.Infra (T(..)) + +import qualified Test.Record.Size.Before.R020 as Before020 +import qualified Test.Record.Size.Before.R030 as Before030 +import qualified Test.Record.Size.Before.R040 as Before040 +import qualified Test.Record.Size.Before.R050 as Before050 +import qualified Test.Record.Size.Before.R060 as Before060 +import qualified Test.Record.Size.Before.R070 as Before070 +import qualified Test.Record.Size.Before.R080 as Before080 +import qualified Test.Record.Size.Before.R090 as Before090 +import qualified Test.Record.Size.Before.R100 as Before100 +import qualified Test.Record.Size.After.R0020 as After0020 +import qualified Test.Record.Size.After.R0030 as After0030 +import qualified Test.Record.Size.After.R0040 as After0040 +import qualified Test.Record.Size.After.R0050 as After0050 +import qualified Test.Record.Size.After.R0060 as After0060 +import qualified Test.Record.Size.After.R0070 as After0070 +import qualified Test.Record.Size.After.R0080 as After0080 +import qualified Test.Record.Size.After.R0090 as After0090 +import qualified Test.Record.Size.After.R0100 as After0100 +import qualified Test.Record.Size.After.R0200 as After0200 +import qualified Test.Record.Size.After.R0300 as After0300 +import qualified Test.Record.Size.After.R0400 as After0400 +import qualified Test.Record.Size.After.R0500 as After0500 +import qualified Test.Record.Size.After.R0600 as After0600 +import qualified Test.Record.Size.After.R0700 as After0700 +import qualified Test.Record.Size.After.R0800 as After0800 +import qualified Test.Record.Size.After.R0900 as After0900 +import qualified Test.Record.Size.After.R1000 as After1000 +import qualified Test.Record.Size.After.HK020 as AfterHK20 +import qualified Test.Record.Size.After.HK030 as AfterHK30 +import qualified Test.Record.Size.After.HK040 as AfterHK40 +import qualified Test.Record.Size.After.HK050 as AfterHK50 +import qualified Test.Record.Size.After.HK060 as AfterHK60 +import qualified Test.Record.Size.After.HK070 as AfterHK70 +import qualified Test.Record.Size.After.HK080 as AfterHK80 +import qualified Test.Record.Size.After.HK090 as AfterHK90 +import qualified Test.Record.Size.After.HK100 as AfterH100 +#endif + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = testGroup "Test.Record.Size.Sanity" [ + testCase "sameValue" test_sameValue + , testCase "sameField" test_sameField + , testCase "showHK" test_showHK +#if USE_GHC_DUMP + , testCase "reallyBig" test_reallyBig +#endif + ] + +-- | Test that @generics-sop@ and @large-records@ generates the same structure +test_sameValue :: Assertion +test_sameValue = do + assertEqual "10" + (toJSON (SOP.glowerBound :: Before010.R)) + (toJSON ( LR.glowerBound :: After0010.R)) +#if USE_GHC_DUMP + assertEqual "20" + (toJSON (SOP.glowerBound :: Before020.R)) + (toJSON ( LR.glowerBound :: After0020.R)) + assertEqual "30" + (toJSON (SOP.glowerBound :: Before030.R)) + (toJSON ( LR.glowerBound :: After0030.R)) + assertEqual "40" + (toJSON (SOP.glowerBound :: Before040.R)) + (toJSON ( LR.glowerBound :: After0040.R)) + assertEqual "50" + (toJSON (SOP.glowerBound :: Before050.R)) + (toJSON ( LR.glowerBound :: After0050.R)) + assertEqual "60" + (toJSON (SOP.glowerBound :: Before060.R)) + (toJSON ( LR.glowerBound :: After0060.R)) + assertEqual "70" + (toJSON (SOP.glowerBound :: Before070.R)) + (toJSON ( LR.glowerBound :: After0070.R)) + assertEqual "80" + (toJSON (SOP.glowerBound :: Before080.R)) + (toJSON ( LR.glowerBound :: After0080.R)) + assertEqual "90" + (toJSON (SOP.glowerBound :: Before090.R)) + (toJSON ( LR.glowerBound :: After0090.R)) + assertEqual "100" + (toJSON (SOP.glowerBound :: Before100.R)) + (toJSON ( LR.glowerBound :: After0100.R)) +#endif + +-- | Test that we have the necessary @HasField@ instances +test_sameField :: Assertion +test_sameField = do + assertEqual "HasField" sop010.field1 lr010.field1 +#if USE_GHC_DUMP + assertEqual "HasField" sop020.field11 lr020.field11 + assertEqual "HasField" sop030.field21 lr030.field21 + assertEqual "HasField" sop040.field31 lr040.field31 + assertEqual "HasField" sop050.field41 lr050.field41 + assertEqual "HasField" sop060.field51 lr060.field51 + assertEqual "HasField" sop070.field61 lr070.field61 + assertEqual "HasField" sop080.field71 lr080.field71 + assertEqual "HasField" sop090.field81 lr090.field81 + assertEqual "HasField" sop100.field91 lr100.field91 +#endif + where + sop010 = SOP.glowerBound :: Before010.R + lr010 = LR.glowerBound :: After0010.R + +#if USE_GHC_DUMP + sop020 = SOP.glowerBound :: Before020.R + sop030 = SOP.glowerBound :: Before030.R + sop040 = SOP.glowerBound :: Before040.R + sop050 = SOP.glowerBound :: Before050.R + sop060 = SOP.glowerBound :: Before060.R + sop070 = SOP.glowerBound :: Before070.R + sop080 = SOP.glowerBound :: Before080.R + sop090 = SOP.glowerBound :: Before090.R + sop100 = SOP.glowerBound :: Before100.R + + lr020 = LR.glowerBound :: After0020.R + lr030 = LR.glowerBound :: After0030.R + lr040 = LR.glowerBound :: After0040.R + lr050 = LR.glowerBound :: After0050.R + lr060 = LR.glowerBound :: After0060.R + lr070 = LR.glowerBound :: After0070.R + lr080 = LR.glowerBound :: After0080.R + lr090 = LR.glowerBound :: After0090.R + lr100 = LR.glowerBound :: After0100.R +#endif + +-- | Check that we can 'Show' the higher-kinded records +test_showHK :: Assertion +test_showHK = do + assertBool "some output" (not . null $ show lr010) + +#if USE_GHC_DUMP + assertBool "some output" (not . null $ show lr020) + assertBool "some output" (not . null $ show lr030) + assertBool "some output" (not . null $ show lr040) + assertBool "some output" (not . null $ show lr050) + assertBool "some output" (not . null $ show lr060) + assertBool "some output" (not . null $ show lr070) + assertBool "some output" (not . null $ show lr080) + assertBool "some output" (not . null $ show lr090) + assertBool "some output" (not . null $ show lr100) +#endif + where + lr010 = LR.glowerBound :: AfterHK10.HKR Identity + +#if USE_GHC_DUMP + lr020 = LR.glowerBound :: AfterHK20.HKR Identity + lr030 = LR.glowerBound :: AfterHK30.HKR Identity + lr040 = LR.glowerBound :: AfterHK40.HKR Identity + lr050 = LR.glowerBound :: AfterHK50.HKR Identity + lr060 = LR.glowerBound :: AfterHK60.HKR Identity + lr070 = LR.glowerBound :: AfterHK70.HKR Identity + lr080 = LR.glowerBound :: AfterHK80.HKR Identity + lr090 = LR.glowerBound :: AfterHK90.HKR Identity + lr100 = LR.glowerBound :: AfterH100.HKR Identity +#endif + +#if USE_GHC_DUMP +-- | Check the value of the last field in the truly big records +test_reallyBig :: Assertion +test_reallyBig = do + assertEqual "HasField" lr0100.field100 (MkT 100) + assertEqual "HasField" lr0200.field200 (MkT 200) + assertEqual "HasField" lr0300.field300 (MkT 300) + assertEqual "HasField" lr0400.field400 (MkT 400) + assertEqual "HasField" lr0500.field500 (MkT 500) + assertEqual "HasField" lr0600.field600 (MkT 600) + assertEqual "HasField" lr0700.field700 (MkT 700) + assertEqual "HasField" lr0800.field800 (MkT 800) + assertEqual "HasField" lr0900.field900 (MkT 900) + assertEqual "HasField" lr1000.field1000 (MkT 1000) + where + lr0100 = LR.glowerBound :: After0100.R + lr0200 = LR.glowerBound :: After0200.R + lr0300 = LR.glowerBound :: After0300.R + lr0400 = LR.glowerBound :: After0400.R + lr0500 = LR.glowerBound :: After0500.R + lr0600 = LR.glowerBound :: After0600.R + lr0700 = LR.glowerBound :: After0700.R + lr0800 = LR.glowerBound :: After0800.R + lr0900 = LR.glowerBound :: After0900.R + lr1000 = LR.glowerBound :: After1000.R +#endif diff --git a/test/Test/Record/Util.hs b/test/Test/Record/Util.hs new file mode 100644 --- /dev/null +++ b/test/Test/Record/Util.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} + +module Test.Record.Util ( + -- * Tasty/HUnit auxiliary + assertPrefix + , assertJust + , expectException + -- * TH error collection + , Problem(..) + , CollectProblems -- opaque + , collectProblems + , collectOnlyProblems + ) where + +import Control.Exception +import Control.Monad.Except hiding (lift) +import Control.Monad.State hiding (lift) +import Data.Bifunctor +import Data.List (isPrefixOf) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import Test.Tasty.HUnit + +import qualified Control.Monad.Trans.Class as Trans + +{------------------------------------------------------------------------------- + Tasty/HUnit auxiliary +-------------------------------------------------------------------------------} + +assertPrefix :: (Show a, Eq a) => [a] -> [a] -> Assertion +assertPrefix xs ys = + assertBool (show xs ++ " is not a prefix of " ++ show ys) $ + xs `isPrefixOf` ys + +assertJust :: String -> Maybe a -> (a -> Assertion) -> Assertion +assertJust msg Nothing _ = assertFailure msg +assertJust _ (Just a) k = k a + +-- | Only used internally in 'expectException' +data Result = + NoException + | ExpectedException + | UnexpectedException SomeException + +expectException :: (SomeException -> Bool) -> Assertion -> Assertion +expectException p k = do + result <- handle (return . aux) (k >> return NoException) + case result of + ExpectedException -> + return () + NoException -> + assertFailure $ "Expected exception, but none was raised" + UnexpectedException e -> + assertFailure $ "Raised exception does not match predicate: " ++ show e + where + aux :: SomeException -> Result + aux e | p e = ExpectedException + | otherwise = UnexpectedException e + +{------------------------------------------------------------------------------- + TH error collection + + We use explicit error collection so that we can /test/ that we are + generating the appropriate errors and warnings. +-------------------------------------------------------------------------------} + +data Problem = Error String | Warning String + deriving (Show, Eq, Lift) + +problemIsError :: Problem -> Bool +problemIsError (Error _) = True +problemIsError (Warning _) = False + +-- | 'Quasi' monad which allows us to inspect errors and warnings +-- +-- We use this to /test/ that our TH code is reporting the expected errors +-- and warnings. +newtype CollectProblems a = CollectProblems { + -- Implementation notes: + -- + -- o 'ExceptT' for 'MonadFail', 'StateT' for 'qReport' + -- o 'ExceptT' on the outside, so that /if/ there is a failure (as in + -- 'fail'), we still get the errors/warnings that were reported + -- before the failure. + -- o Problems are stored in reverse order + -- o Errors and warnings are stored together, rather than as two lists, + -- so that we preserve their relative ordering. + unwrapCollectProblems :: ExceptT String (StateT [Problem] Q) a + } + deriving newtype (Functor, Applicative, Monad, MonadIO) + +liftQ :: Q a -> CollectProblems a +liftQ = CollectProblems . Trans.lift . Trans.lift + +instance MonadFail CollectProblems where + fail str = CollectProblems $ throwError str + +-- | Run 'CollectProblems' +collectProblems :: CollectProblems a -> Q (Either String a, [Problem]) +collectProblems = fmap (second reverse) . runCollectProblems + +-- | Like 'collectProblems', but return /only/ the problems +collectOnlyProblems :: CollectProblems a -> Q (Maybe String, [Problem]) +collectOnlyProblems = fmap (first aux) . collectProblems + where + aux :: Either String a -> Maybe String + aux = either Just (const Nothing) + +-- | Lower-level version of 'runCollectProblems' that reports errors in reverse +-- order +runCollectProblems :: CollectProblems a -> Q (Either String a, [Problem]) +runCollectProblems = (`runStateT` []) . runExceptT . unwrapCollectProblems + +instance Quasi CollectProblems where + -- Only error-reporting is different + + qReport :: Bool -> String -> CollectProblems () + qReport False w = CollectProblems $ modify (Warning w:) + qReport True e = CollectProblems $ modify (Error e:) + + qRecover :: CollectProblems a -> CollectProblems a -> CollectProblems a + qRecover handler action = + CollectProblems $ ExceptT $ StateT $ \problemsBeforeRecovery -> do + -- We run the action with an empty list of problems; this is okay, + -- because there is no way to /inspect/ the current list of problems, + -- we only catch problems thrown inside the action + (mResult, problemsDuringAction) <- runCollectProblems action + case mResult of + Right a | not (any problemIsError problemsDuringAction) -> + return (Right a, problemsDuringAction ++ problemsBeforeRecovery) + _otherwise -> do + -- If there was a failure, _or_ an error (but not a warning), the + -- handler runs. In this case, any errors /or/ warnings that were + -- reported during the action are ignored. + second (++ problemsBeforeRecovery) <$> runCollectProblems handler + + -- Everything else just lifts + + qNewName = \x -> liftQ $ qNewName x + qLookupName = \x y -> liftQ $ qLookupName x y + qReify = \x -> liftQ $ qReify x + qReifyFixity = \x -> liftQ $ qReifyFixity x +#if MIN_VERSION_template_haskell(2,16,0) + qReifyType = \x -> liftQ $ qReifyType x +#endif + qReifyInstances = \x y -> liftQ $ qReifyInstances x y + qReifyRoles = \x -> liftQ $ qReifyRoles x + qReifyAnnotations = \x -> liftQ $ qReifyAnnotations x + qReifyModule = \x -> liftQ $ qReifyModule x + qReifyConStrictness = \x -> liftQ $ qReifyConStrictness x + qLocation = liftQ $ qLocation + qAddDependentFile = \x -> liftQ $ qAddDependentFile x + qAddTempFile = \x -> liftQ $ qAddTempFile x + qAddTopDecls = \x -> liftQ $ qAddTopDecls x + qAddForeignFilePath = \x y -> liftQ $ qAddForeignFilePath x y + qAddModFinalizer = \x -> liftQ $ qAddModFinalizer x + qAddCorePlugin = \x -> liftQ $ qAddCorePlugin x + qGetQ = liftQ $ qGetQ + qPutQ = \x -> liftQ $ qPutQ x + qIsExtEnabled = \x -> liftQ $ qIsExtEnabled x + qExtsEnabled = liftQ $ qExtsEnabled + +{------------------------------------------------------------------------------- + Internal auxiliary: figure out how TH does error handling +-------------------------------------------------------------------------------} + +-- | TH error behaviour +-- +-- TH error behaviour is a bit of a mess. When the code below is executed, it +-- yields: +-- +-- > n == 1 +-- > a +-- > n == 2 +-- > handler_2 +-- > n == 3 +-- > handler_3 +-- > n == 4 +-- > handler_4 +-- > n == 4 +-- +-- Some observations: +-- +-- 1. The documentation of `recover` says that it allows recovery from errors +-- raised by `reportError` or `fail`. The above supports this, /but/ notice +-- that if code raises errors that are caught, any warnings thrown by that +-- code /also/ disappear. +-- 2. The documentation of `qRecover` only talks about recovery from `fail`, +-- not `reportError`, but `recover` is just a wrapper around `qRecover`. +-- 3. Unlike `fail`, `reportError` does not halt execution. This means that +-- even though we can attempt to recover from errors raised by `reportError`, +-- we actually have no idea what the state looks like when recovery begins. +-- 4. Despite `IO` having a `Quasi` instance, `recover` actually does not work +-- /at all/ in `IO` (in fact, /most/ functions of the 'Quasi' class are not +-- supported in IO). +-- 5. Who knew that TH had dynamically typed global variables? +_thErrorBehaviour :: Q [Dec] +_thErrorBehaviour = do + qPutQ (1 :: Int) + showN + + -- What happens if we /only/ throw a warning? + recover (reportWarning "handler_1" >> return ()) $ do + reportWarning "a" + qPutQ (2 :: Int) + + showN + + -- What happens if we throw warnings /around/ an error? + recover (reportWarning "handler_2" >> return ()) $ do + reportWarning "b" + reportError "c" + reportWarning "d" + qPutQ (3 :: Int) + + showN + + -- What happens if we throw /multiple/ errors? + recover (reportWarning "handler_3" >> return ()) $ do + reportError "e" + reportError "f" + qPutQ (4 :: Int) + + showN + + -- What happens if we /fail/ after a warning? + recover (reportWarning "handler_4" >> return ()) $ do + reportWarning "g" + () <- fail "h" + qPutQ (5 :: Int) + + showN + return [] + where + showN :: Q () + showN = do + Just n <- qGetQ + reportWarning $ "n == " ++ show (n :: Int) + diff --git a/test/TestLargeRecords.hs b/test/TestLargeRecords.hs new file mode 100644 --- /dev/null +++ b/test/TestLargeRecords.hs @@ -0,0 +1,53 @@ +module Main (main) where + +import Test.Tasty + +import qualified Test.Record.Prop.Show +import qualified Test.Record.Prop.ToFromJSON +import qualified Test.Record.Sanity.Derive +import qualified Test.Record.Sanity.EqualFieldTypes +import qualified Test.Record.Sanity.ErrorsAndWarnings +import qualified Test.Record.Sanity.Generics +import qualified Test.Record.Sanity.GhcGenerics +import qualified Test.Record.Sanity.HigherKinded +import qualified Test.Record.Sanity.HKD +import qualified Test.Record.Sanity.Laziness +import qualified Test.Record.Sanity.Lens.Micro +import qualified Test.Record.Sanity.OverloadingNoDRF +import qualified Test.Record.Sanity.PatternMatch +import qualified Test.Record.Sanity.QualifiedImports +import qualified Test.Record.Sanity.RecordConstruction +import qualified Test.Record.Sanity.Strictness +import qualified Test.Record.Sanity.Transform +import qualified Test.Record.Size.Sanity + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" [ + testGroup "Sanity" [ + Test.Record.Sanity.Derive.tests + , Test.Record.Sanity.EqualFieldTypes.tests + , Test.Record.Sanity.ErrorsAndWarnings.tests + , Test.Record.Sanity.Generics.tests + , Test.Record.Sanity.GhcGenerics.tests + , Test.Record.Sanity.HigherKinded.tests + , Test.Record.Sanity.HKD.tests + , Test.Record.Sanity.Laziness.tests + , Test.Record.Sanity.Lens.Micro.tests + , Test.Record.Sanity.OverloadingNoDRF.tests + , Test.Record.Sanity.PatternMatch.tests + , Test.Record.Sanity.QualifiedImports.tests + , Test.Record.Sanity.RecordConstruction.tests + , Test.Record.Sanity.Strictness.tests + , Test.Record.Sanity.Transform.tests + ] + , testGroup "Size" [ + Test.Record.Size.Sanity.tests + ] + , testGroup "Prop" [ + Test.Record.Prop.Show.tests + , Test.Record.Prop.ToFromJSON.tests + ] + ]