generic-data 0.7.0.0 → 0.8.0.0

raw patch · 18 files changed

+526/−97 lines, 18 filesdep +Globdep +QuickCheckdep +doctestdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: Glob, QuickCheck, doctest

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−1
• generic-data.cabal +19/−2
• src/Generic/Data.hs +11/−0
• src/Generic/Data/Internal/Compat.hs +10/−0
• src/Generic/Data/Internal/Data.hs +10/−2
• src/Generic/Data/Internal/Enum.hs +115/−4
• src/Generic/Data/Internal/Error.hs +53/−0
• src/Generic/Data/Internal/Functions.hs +10/−2
• src/Generic/Data/Internal/Generically.hs +56/−4
• src/Generic/Data/Internal/Meta.hs +84/−35
• src/Generic/Data/Internal/Microsurgery.hs +8/−0
• src/Generic/Data/Internal/Newtype.hs +8/−0
• src/Generic/Data/Internal/Prelude.hs +10/−2
• src/Generic/Data/Internal/Resolvers.hs +10/−0
• src/Generic/Data/Internal/Show.hs +10/−0
• src/Generic/Data/Internal/Utils.hs +10/−0
• test/doctest.hs +7/−0
• test/unit.hs +82/−45

@@ -1,6 +1,18 @@+# 0.8.0.0++- Add `GenericProduct`, for deriving `via GenericProduct B` when `B` is not the+  type `A` you want the derived instance for.+  Note this used to be `Generically`'s behavior for `Monoid` before 0.7.0.0.+- Add generic implementations for `Ix`. Thanks to Topsii.++- Add `conIdNamed`, to get a `ConId` by its type-level name+- Add instance `Show (ConId a)`+- Improve type errors for deriving `Semigroup` and `Monoid` via `Generically`.+  Thanks to yairchu.+ # 0.7.0.0 -- Changed `Monoid` instance for `Generically`, to be compatible with users'+- Change `Monoid` instance for `Generically`, to be compatible with users'   non-generic instances of `Semigroup`. Thanks to yairchu. - Add `gcoerce`, `gcoerceBinop`. 

@@ -1,5 +1,5 @@ name:                generic-data-version:             0.7.0.0+version:             0.8.0.0 synopsis:            Deriving instances with GHC.Generics and related utilities description:   Generic implementations of standard type classes.@@ -15,7 +15,8 @@ build-type:          Simple extra-source-files:  README.md, CHANGELOG.md cabal-version:       >=1.10-tested-with:         GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1, GHC == 8.6.3+tested-with:         GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.3, GHC == 8.6.1,+                     GHC == 8.6.3, GHC == 8.6.5, GHC == 8.8.2  library   hs-source-dirs:      src@@ -26,6 +27,7 @@     Generic.Data.Internal.Compat     Generic.Data.Internal.Data     Generic.Data.Internal.Enum+    Generic.Data.Internal.Error     Generic.Data.Internal.Functions     Generic.Data.Internal.Generically     Generic.Data.Internal.Meta@@ -113,9 +115,24 @@     generic-lens >= 1.1.0.0,     one-liner >= 1.0,     base+  ghc-options: -Wall -threaded+  default-language: Haskell2010+  type: exitcode-stdio-1.0++test-suite generic-data-doctest+  hs-source-dirs: test+  main-is: doctest.hs+  build-depends:+    doctest,+    Glob,+    QuickCheck,+    generic-data,+    base   ghc-options: -Wall   default-language: Haskell2010   type: exitcode-stdio-1.0+  if !impl(ghc >= 8.6)+    buildable: False  benchmark bench   hs-source-dirs: test

@@ -61,6 +61,14 @@   , gmaxBound   , GBounded() +    -- ** 'Ix'+    -- | Can also be derived by GHC as part of the standard.+  , grange+  , gindex+  , ginRange+  , GIx()+  , gunsafeIndex+     -- * Higher-kinded classes      -- ** 'Functor'@@ -104,6 +112,7 @@      -- * Carriers of generic instances   , Generically(..)+  , GenericProduct(..)   , FiniteEnumeration(..)   , Generically1(..) @@ -143,6 +152,8 @@   , conIdToInt   , conIdToString   , conIdEnum+  , conIdNamed+  , ConIdNamed    -- ** Using type families   , MetaOf

@@ -5,6 +5,16 @@     TypeOperators,     UndecidableInstances #-} +-- | Shim for backwards compatibility.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.+ module Generic.Data.Internal.Compat   ( readPrec1   , Div

@@ -1,5 +1,3 @@--- | Generic representations as data types.- {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-}@@ -8,6 +6,16 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}++-- | Generic representations as data types.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.  module Generic.Data.Internal.Data where 

@@ -8,11 +8,20 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} --- | Generic deriving for 'Enum'.+-- | Generic deriving for 'Enum', 'Bounded' and 'Ix'.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.  module Generic.Data.Internal.Enum where  import GHC.Generics+import Data.Ix  -- | Generic 'toEnum' generated with the 'StandardEnum' option. --@@ -25,7 +34,7 @@ --   'enumFromTo' = 'genumFromTo' --   'enumFromThenTo' = 'genumFromThenTo' -- @-gtoEnum :: forall a. (Generic a, GEnum StandardEnum (Rep a)) => Int -> a+gtoEnum :: (Generic a, GEnum StandardEnum (Rep a)) => Int -> a gtoEnum = gtoEnum' @StandardEnum "gtoEnum"  -- | Generic 'fromEnum' generated with the 'StandardEnum' option.@@ -70,7 +79,7 @@ --   'enumFromTo' = 'gfiniteEnumFromTo' --   'enumFromThenTo' = 'gfiniteEnumFromThenTo' -- @-gtoFiniteEnum :: forall a. (Generic a, GEnum FiniteEnum (Rep a)) => Int -> a+gtoFiniteEnum :: (Generic a, GEnum FiniteEnum (Rep a)) => Int -> a gtoFiniteEnum = gtoEnum' @FiniteEnum "gtoFiniteEnum"  -- | Generic 'fromEnum' generated with the 'FiniteEnum' option.@@ -179,6 +188,55 @@ gmaxBound :: (Generic a, GBounded (Rep a)) => a gmaxBound = to gMaxBound +-- | Generic 'range'.+--+-- @+-- import "Data.Ix"+-- instance 'Ix' MyType where+--   'range' = 'grange'+--   'index' = 'gindex'+--   'inRange' = 'ginRange'+-- @+grange :: (Generic a, GIx (Rep a)) => (a, a) -> [a]+grange (m, n) = map to $ gRange (from m, from n)++-- | Generic 'index'.+--+-- See also 'grange'.+gindex :: (Generic a, GIx (Rep a)) => (a, a) -> a -> Int+gindex b i+  | ginRange b i = gunsafeIndex b i+  | otherwise = errorWithoutStackTrace "gindex: out of bounds"++-- | Generic @unsafeIndex@.+--+-- === __Details__+--+-- The functions @unsafeIndex@ and @unsafeRangeSize@ belong to 'Ix' but are+-- internal to GHC and hence not exported from the module "Data.Ix". However they+-- are exported from the module @GHC.Arr@.+-- See 'grange' for how to define an instance of 'Ix' such that it does not+-- depend on the stability of GHCs internal API. Unfortunately this results in+-- additional (unnecessary) bound checks.+-- With the danger of having no stability guarantees for GHC's internal API one+-- can alternatively define an instance of 'Ix' as+--+-- @+-- import GHC.Arr+-- instance 'Ix' MyType where+--   'range' = 'grange'+--   unsafeIndex = 'gunsafeIndex'+--   'inRange' = 'ginRange'+-- @+gunsafeIndex :: (Generic a, GIx (Rep a)) => (a, a) -> a -> Int+gunsafeIndex (m, n) i = gUnsafeIndex (from m, from n) (from i)++-- | Generic 'inRange'.+--+-- See also 'grange'.+ginRange :: (Generic a, GIx (Rep a)) => (a, a) -> a -> Bool+ginRange (m, n) i = gInRange (from m, from n) (from i)+ -- | Generic representation of 'Enum' types. -- -- The @opts@ parameter is a type-level option to select different@@ -195,8 +253,12 @@  -- | Extends the 'StandardEnum' option for 'GEnum' to allow all constructors to  -- have arbitrary many fields. Each field type must be an instance of --- both 'Enum' and 'Bounded'. Two restrictions require the user's caution:+-- both 'Enum' and 'Bounded'. --+-- === __Details__+--+-- Two restrictions require the user's caution:+-- -- * The 'Enum' instances of the field types need to start enumerating from 0.  -- Particularly 'Int' is an unfit field type, because the enumeration of the  -- negative values starts before 0. @@ -292,3 +354,52 @@ instance (GBounded f, GBounded g) => GBounded (f :*: g) where   gMinBound = gMinBound :*: gMinBound   gMaxBound = gMaxBound :*: gMaxBound++-- | Generic representation of 'Ix' types.+--+class GIx f where+  gRange :: (f p, f p) -> [f p]+  gUnsafeIndex :: (f p, f p) -> f p -> Int+  gInRange :: (f p, f p) -> f p -> Bool++instance GIx f => GIx (M1 i c f) where+  gRange (M1 m, M1 n) = map M1 $ gRange (m, n)+  gUnsafeIndex (M1 m, M1 n) (M1 i) = gUnsafeIndex (m, n) i+  gInRange (M1 m, M1 n) (M1 i) = gInRange (m, n) i++instance (GEnum StandardEnum f, GEnum StandardEnum g) => GIx (f :+: g) where+  gRange (x, y) = map toE [ i_x .. i_y ]+    where+      toE = gToEnum @StandardEnum+      i_x = gFromEnum @StandardEnum x+      i_y = gFromEnum @StandardEnum y+  gUnsafeIndex (m, _) i = fromIntegral (i_i - i_m)+    where+      i_m = gFromEnum @StandardEnum m+      i_i = gFromEnum @StandardEnum i+  gInRange (m, n) i = i_m <= i_i && i_i <= i_n+    where+      i_m = gFromEnum @StandardEnum m+      i_n = gFromEnum @StandardEnum n+      i_i = gFromEnum @StandardEnum i++instance (GIx f, GIx g) => GIx (f :*: g) where+  gRange (m1 :*: m2, n1 :*: n2) =+    [ i1 :*: i2 | i1 <- gRange (m1, n1), i2 <- gRange (m2, n2) ]+  gUnsafeIndex (m1 :*: m2, n1 :*: n2) (i1 :*: i2) = int1 * rangeSize2 + int2+    where+      int1 = gUnsafeIndex (m1, n1) i1+      int2 = gUnsafeIndex (m2, n2) i2+      rangeSize2 = gUnsafeIndex (m2, n2) n2 + 1+  gInRange (m1 :*: m2, n1 :*: n2) (i1 :*: i2) =+    gInRange (m1, n1) i1 && gInRange (m2, n2) i2+  +instance GIx U1 where+  gRange (U1, U1) = [U1]+  gUnsafeIndex (U1, U1) U1 = 0+  gInRange (U1, U1) U1 = True++instance (Ix c) => GIx (K1 i c) where+  gRange (K1 m, K1 n) = map K1 $ range (m, n)+  gUnsafeIndex (K1 m, K1 n) (K1 i) = index (m, n) i +  gInRange (K1 m, K1 n) (K1 i) = inRange (m, n) i

@@ -0,0 +1,53 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++-- | Error messages.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.++module Generic.Data.Internal.Error where++import Data.Kind+import Data.Type.Bool+import GHC.Generics+import GHC.TypeLits++type family HasSum f where+  HasSum V1 = 'False+  HasSum U1 = 'False+  HasSum (K1 i c) = 'False+  HasSum (M1 i c f) = HasSum f+  HasSum (f :*: g) = HasSum f || HasSum g+  HasSum (f :+: g) = 'True++class Assert (pred :: Bool) (msg :: ErrorMessage)+instance Assert 'True msg+instance (TypeError msg ~ '()) => Assert 'False msg++-- |+-- >>> :set -XDeriveGeneric -XDerivingVia+-- >>> import Generic.Data (Generically(..))+-- >>> :{+--   data AB = A | B+--     deriving stock Generic+--     deriving Semigroup via Generically AB+-- :}+-- ...+--     • Cannot derive Semigroup instance for AB due to sum type+--     • When deriving the instance for (Semigroup AB)+type AssertNoSum (constraint :: * -> Constraint) a =+    Assert (Not (HasSum (Rep a)))+    ('Text "Cannot derive " ':<>: 'ShowType constraint ':<>:+        'Text " instance for " ':<>: 'ShowType a ':<>: 'Text " due to sum type")

@@ -1,5 +1,3 @@--- | Type level functions on generic representations.- {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}@@ -9,6 +7,16 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}++-- | Type-level functions on generic representations.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.  module Generic.Data.Internal.Functions where 

@@ -1,19 +1,29 @@--- | Newtypes with instances implemented using generic combinators.- {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +-- | Newtypes with instances implemented using generic combinators.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.+ module Generic.Data.Internal.Generically where  import Control.Applicative import Data.Functor.Classes import Data.Semigroup+import Data.Ix import GHC.Generics  import Generic.Data.Internal.Prelude import Generic.Data.Internal.Enum+import Generic.Data.Internal.Error import Generic.Data.Internal.Show  -- | Type with instances derived via 'Generic'.@@ -33,13 +43,13 @@ instance (Generic a, GShow0 (Rep a)) => Show (Generically a) where   showsPrec = gshowsPrec -instance (Generic a, Semigroup (Rep a ())) => Semigroup (Generically a) where+instance (AssertNoSum Semigroup a, Generic a, Semigroup (Rep a ())) => Semigroup (Generically a) where   (<>) = gmappend  -- | This uses the 'Semigroup' instance of the wrapped type 'a' to define 'mappend'. -- The purpose of this instance is to derive 'mempty', while remaining consistent -- with possibly custom 'Semigroup' instances.-instance (Semigroup a, Generic a, Monoid (Rep a ())) => Monoid (Generically a) where+instance (AssertNoSum Semigroup a, Semigroup a, Generic a, Monoid (Rep a ())) => Monoid (Generically a) where   mempty = gmempty   mappend (Generically x) (Generically y) = Generically (x <> y) @@ -51,6 +61,11 @@   enumFromTo = genumFromTo   enumFromThenTo = genumFromThenTo +instance (Generic a, Ord (Rep a ()), GIx (Rep a)) => Ix (Generically a) where+  range = grange+  index = gindex+  inRange = ginRange+ instance (Generic a, GBounded (Rep a)) => Bounded (Generically a) where   minBound = gminBound   maxBound = gmaxBound@@ -124,3 +139,40 @@ instance (Generic1 f, Traversable (Rep1 f)) => Traversable (Generically1 f) where   traverse = gtraverse   sequenceA = gsequenceA++-- | Product type with generic instances of 'Semigroup' and 'Monoid'.+--+-- This is similar to 'Generic.Data.Generically' in most cases, but+-- 'GenericProduct' also works for types @T@ with deriving+-- @via 'GenericProduct' U@, where @U@ is a generic product type coercible to,+-- but distinct from @T@. In particular, @U@ may not have an instance of+-- 'Semigroup', which 'Generic.Data.Generically' requires.+--+-- === __Example__+--+-- >>> :set -XDeriveGeneric -XDerivingVia+-- >>> data Point a = Point a a deriving Generic+-- >>> :{+--   newtype Vector a = Vector (Point a)+--     deriving (Semigroup, Monoid)+--       via GenericProduct (Point (Sum a))+-- :}+--+-- If it were @via 'Generic.Data.Generically' (Point (Sum a))@ instead, then+-- @Vector@'s 'mappend' (the 'Monoid' method) would be defined as @Point@'s+-- @('<>')@ (the 'Semigroup' method), which might not exist, or might not be+-- equivalent to @Vector@'s generic 'Semigroup' instance, which would be+-- unlawful.+newtype GenericProduct a = GenericProduct { unGenericProduct :: a }++instance Generic a => Generic (GenericProduct a) where+  type Rep (GenericProduct a) = Rep a+  to = GenericProduct . to+  from = from . unGenericProduct++instance (AssertNoSum Semigroup a, Generic a, Semigroup (Rep a ())) => Semigroup (GenericProduct a) where+  (<>) = gmappend++instance (AssertNoSum Semigroup a, Generic a, Monoid (Rep a ())) => Monoid (GenericProduct a) where+  mempty = gmempty+  mappend = gmappend'

@@ -1,13 +1,10 @@--- | Type metadata accessors------ Type names, constructor names...- {-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}  {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-}@@ -15,37 +12,58 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +-- | Type metadata accessors+--+-- Type names, constructor names...+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.+ module Generic.Data.Internal.Meta where  import Data.Proxy import GHC.Generics-import GHC.TypeLits (Symbol)+import GHC.TypeLits (Symbol, Nat, KnownNat, type (+), natVal, TypeError, ErrorMessage(..)) +import Generic.Data.Internal.Functions++-- $setup+-- >>> :set -XDataKinds -XTypeApplications+-- >>> import Control.Applicative (ZipList)+-- >>> import Data.Monoid (Sum(..))+ -- | Name of the first data constructor in a type as a string. ----- @--- 'gdatatypeName' @('Maybe' AnyType) = \"Maybe\"--- @+-- >>> gdatatypeName @(Maybe Int)+-- "Maybe" gdatatypeName :: forall a. (Generic a, GDatatype (Rep a)) => String gdatatypeName = gDatatypeName @(Rep a)  -- | Name of the module where the first type constructor is defined. ----- @--- 'gmoduleName' @('Maybe' AnyType) = \"GHC.Base\"--- @+-- >>> gmoduleName @(ZipList Int)+-- "Control.Applicative" gmoduleName :: forall a. (Generic a, GDatatype (Rep a)) => String gmoduleName = gModuleName @(Rep a)  -- | Name of the package where the first type constructor is defined. ----- @--- 'gpackageName' @('Maybe' AnyType) = \"base\"--- @+-- >>> gpackageName @(Maybe Int)+-- "base" gpackageName :: forall a. (Generic a, GDatatype (Rep a)) => String gpackageName = gPackageName @(Rep a)  -- | 'True' if the first type constructor is a newtype.+--+-- >>> gisNewtype @[Int]+-- False+-- >>> gisNewtype @(ZipList Int)+-- True gisNewtype :: forall a. (Generic a, GDatatype (Rep a)) => Bool gisNewtype = gIsNewtype @(Rep a) @@ -67,51 +85,48 @@  -- | Name of the first constructor in a value. ----- @--- 'gconName' ('Just' 0) = \"Just\"--- @+-- >>> gconName (Just 0)+-- "Just" gconName :: forall a. Constructors a => a -> String gconName = conIdToString . conId  -- | The fixity of the first constructor. ----- @--- 'gconFixity' ('Just' 0) = 'Prefix'--- 'gconFixity' ([] :*: id) = 'Infix' 'RightAssociative' 6--- @+-- >>> gconFixity (Just 0)+-- Prefix+-- >>> gconFixity ([] :*: id)+-- Infix RightAssociative 6 gconFixity :: forall a. Constructors a => a -> Fixity gconFixity = gConFixity . from  -- | 'True' if the constructor is a record. ----- @--- 'gconIsRecord' ('Just' 0) = 'False'--- 'gconIsRecord' ('Data.Monoid.Sum' 0) = 'True'--- -- newtype 'Data.Monoid.Sum' a = Sum { getSum :: a }--- @+-- >>> gconIsRecord (Just 0)+-- False+-- >>> gconIsRecord (Sum 0)   -- Note:  newtype Sum a = Sum { getSum :: a }+-- True gconIsRecord :: forall a. Constructors a => a -> Bool gconIsRecord = gConIsRecord . from  -- | Number of constructors. ----- @--- 'gconNum' @('Maybe' AnyType) = 2--- @+-- >>> gconNum @(Maybe Int)+-- 2 gconNum :: forall a. Constructors a => Int gconNum = gConNum @(Rep a)  -- | Index of a constructor. ----- @--- 'gconIndex' Nothing = 0--- 'gconIndex' (Just "test") = 1--- @+-- >>> gconIndex Nothing+-- 0+-- >>> gconIndex (Just "test")+-- 1 gconIndex :: forall a. Constructors a => a -> Int gconIndex = conIdToInt . conId  -- | An opaque identifier for a constructor. newtype ConId a = ConId Int-  deriving (Eq, Ord)+  deriving (Eq, Ord, Show)  -- | Identifier of a constructor. conId :: forall a. Constructors a => a -> ConId a@@ -126,7 +141,7 @@ conIdToString :: forall a. Constructors a => ConId a -> String conIdToString = gConIdToString . fromConId --- | All constructor identifiers.+-- | All constructor identifiers. This must not be called on an empty type. -- -- @ -- 'gconNum' \@a = length ('conIdEnum' \@a)@@ -144,10 +159,25 @@ conIdMax :: forall a. Constructors a => ConId a conIdMax = toConId gConIdMax +-- | Get a 'ConId' by name.+--+-- >>> conIdNamed @"Nothing" :: ConId (Maybe Int)+-- ConId 0+-- >>> conIdNamed @"Just"    :: ConId (Maybe Int)+-- ConId 1+conIdNamed :: forall s a. ConIdNamed s a => ConId a+conIdNamed = ConId (fromInteger (natVal (Proxy @(ConIdNamed' s a))))+ -- | Constraint synonym for 'Generic' and 'GConstructors'. class (Generic a, GConstructors (Rep a)) => Constructors a instance (Generic a, GConstructors (Rep a)) => Constructors a +-- | Constraint synonym for generic types @a@ with a constructor named @n@.+class (Generic a, KnownNat (ConIdNamed' n a)) => ConIdNamed n a+instance (Generic a, KnownNat (ConIdNamed' n a)) => ConIdNamed n a++-- *** Constructor information on generic representations+ newtype GConId r = GConId Int   deriving (Eq, Ord) @@ -208,6 +238,25 @@   gConNum = 1   gConFixity = conFixity   gConIsRecord = conIsRecord++-- *** Find a constructor tag by name++type ConIdNamed' n t = GConIdNamedIf n t (GConIdNamed n (Rep t))++type GConIdNamed n f = GConIdNamed' n f 0 'Nothing++type family GConIdNamed' (n :: Symbol) (f :: k -> *) (i :: Nat) (o :: Maybe Nat) :: Maybe Nat where+  GConIdNamed' n (M1 D _c f) i r = GConIdNamed' n f i r+  GConIdNamed' n (f :+: g) i r = GConIdNamed' n f i (GConIdNamed' n g (i + NConstructors f) r)+  GConIdNamed' n (M1 C ('MetaCons n _f _s) _g) i _r = 'Just i+  GConIdNamed' n (M1 C ('MetaCons _n _f _s) _g) _i r = r+  GConIdNamed' _n V1 _i r = r++type family GConIdNamedIf (n :: Symbol) (t :: *) (o :: Maybe Nat) :: Nat where+  GConIdNamedIf _n _t ('Just i) = i+  GConIdNamedIf  n  t 'Nothing = TypeError+    ('Text "No constructor named " ':<>: 'ShowType n+    ':<>: 'Text " in generic type " ':<>: 'ShowType t)  -- * Type families 

@@ -11,6 +11,14 @@     UndecidableInstances #-}  -- | Surgeries that are just 'coerce'.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.  module Generic.Data.Internal.Microsurgery where 

@@ -8,6 +8,14 @@ {-# LANGUAGE UndecidableSuperClasses #-}  -- | Pack/unpack newtypes.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.  module Generic.Data.Internal.Newtype where 

@@ -1,6 +1,14 @@--- | Generic deriving for standard classes in base- {-# LANGUAGE FlexibleContexts #-}++-- | Generic deriving for standard classes in base+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.  module Generic.Data.Internal.Prelude where 

@@ -1,5 +1,15 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} +-- | Newtypes with special instances for deriving.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.+ module Generic.Data.Internal.Resolvers where  import Data.Bifunctor (first)

@@ -7,6 +7,16 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE Safe #-} +-- | Generic implementation of Show+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.+ module Generic.Data.Internal.Show where  import Data.Foldable (foldl')

@@ -3,6 +3,16 @@     FlexibleContexts,     PolyKinds #-} +-- | Utilities.+--+-- === Warning+--+-- This is an internal module: it is not subject to any versioning policy,+-- breaking changes can happen at any time.+--+-- If something here seems useful, please report it or create a pull request to+-- export it from an external module.+ module Generic.Data.Internal.Utils where  import Data.Coerce

@@ -0,0 +1,7 @@+module Main (main) where++import System.FilePath.Glob (glob)+import Test.DocTest (doctest)++main :: IO ()+main = glob "src/**/*.hs" >>= doctest

@@ -1,8 +1,11 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE+    CPP,+    DataKinds,+    DeriveGeneric,+    TypeApplications #-}  import Control.Applicative+import Data.Ix import Data.Semigroup import Data.Monoid (Sum(..)) import Data.Functor.Classes@@ -45,11 +48,17 @@ pl1 = p1  data E = E0 | E1 | E2 | E3-  deriving (Eq, Show, Generic)+  deriving (Eq, Ord, Show, Generic, Ix)  data FiniteE = SE0 Bool Bool | SE1 Bool   deriving (Eq, Ord, Show, Generic) +data TupleE = T E E+  deriving (Eq, Ord, Show, Generic)++data Unit = Unit+  deriving (Eq, Ord, Show, Generic)+ e0, e1, eLast :: FiniteE e0 = allEs !! 0 e1 = allEs !! 1@@ -88,64 +97,84 @@ test :: TestTree test = testGroup "unit"   [ testGroup "Eq"-      [ testCase "(==)" $ p' 1 2 @?= p' 1 2-      , testCase "(/=)" $ False @?= (p' 1 2 == p' 1 1)+      [ testCase "(==)" $ p' 1 2 @=? p' 1 2+      , testCase "(/=)" $ False @=? (p' 1 2 == p' 1 1)       ]   , testGroup "Ord"-      [ testCase "compare" $ LT @?= compare (p' 1 2) (p' 2 1)-      , testCase "(<=)" $ True @?= (p' 1 1 <= p' 1 1)+      [ testCase "compare" $ LT @=? compare (p' 1 2) (p' 2 1)+      , testCase "(<=)" $ True @=? (p' 1 1 <= p' 1 1)       ]   , testGroup "Semigroup"-      [ testCase "(<>)" $ pl [1, 5] [2, 3] @?= (pl [1] [2] <> pl [5] [3])+      [ testCase "(<>)" $ pl [1, 5] [2, 3] @=? (pl [1] [2] <> pl [5] [3])       ]   , testGroup "Monoid"-      [ testCase "mempty" $ pl [] [] @?= mempty+      [ testCase "mempty" $ pl [] [] @=? mempty       ]   , testGroup "Functor"-      [ testCase "fmap" $ p1' [1] [2] @?= fmap (+ 1) (p1 [0] [1])+      [ testCase "fmap" $ p1' [1] [2] @=? fmap (+ 1) (p1 [0] [1])       ]   , testGroup "Applicative"-      [ testCase "pure" $ p1' [3] [3] @?= pure 3-      , testCase "ap" $ p1' [1, 3] [2] @?= (p1 [id, (+2)] [(+2)] <*> p1 [1] [0])+      [ testCase "pure" $ p1' [3] [3] @=? pure 3+      , testCase "ap" $ p1' [1, 3] [2] @=? (p1 [id, (+2)] [(+2)] <*> p1 [1] [0])       ]   , testGroup "Alternative"-      [ testCase "empty" $ p1' [] [] @?= empty-      , testCase "(<|>)" $ p1' [1, 5] [2, 3] @?= (p1 [1] [2] <|> p1 [5] [3])+      [ testCase "empty" $ p1' [] [] @=? empty+      , testCase "(<|>)" $ p1' [1, 5] [2, 3] @=? (p1 [1] [2] <|> p1 [5] [3])       ]   , testGroup "Foldable"-      [ testCase "foldMap" $ Sum 3 @?= foldMap Sum (p1' [1] [2])-      , testCase "foldr" $ 3 @?= foldr (+) 0 (p1' [1] [2])+      [ testCase "foldMap" $ Sum 3 @=? foldMap Sum (p1' [1] [2])+      , testCase "foldr" $ 3 @=? foldr (+) 0 (p1' [1] [2])       ]   , testGroup "Traversable"       [ testCase "traverse" $-          [p1 [1] [2], p1 [1] [3], p1 [2] [2], p1 [2] [3]] @?=+          [p1 [1] [2], p1 [1] [3], p1 [2] [2], p1 [2] [3]] @=?             traverse (\y -> [y, y+1]) (p1' [1] [2])       , testCase "sequenceA" $-          [p1 [1] [2], p1 [2] [2]] @?= sequenceA (pl1 [[1, 2]] [[2]])+          [p1 [1] [2], p1 [2] [2]] @=? sequenceA (pl1 [[1, 2]] [[2]])       ]   , testGroup "Bounded"-      [ testCase "minBound @E" $ E0 @?= gminBound-      , testCase "maxBound @E" $ E3 @?= gmaxBound-      , testCase "minBound @(P Int)" $ p' minBound minBound @?= gminBound-      , testCase "maxBound @(P Int)" $ p' maxBound maxBound @?= gmaxBound+      [ testCase "minBound @E" $ E0 @=? gminBound+      , testCase "maxBound @E" $ E3 @=? gmaxBound+      , testCase "minBound @(P Int)" $ p' minBound minBound @=? gminBound+      , testCase "maxBound @(P Int)" $ p' maxBound maxBound @=? gmaxBound       ]   , testGroup "Enum"-      [ testCase "toEnum" $ [E0, E1, E2, E3] @?= fmap gtoEnum [0, 1, 2, 3]-      , testCase "fromEnum" $ [0, 1, 2, 3] @?= fmap gfromEnum [E0, E1, E2, E3]-      , testCase "enumFrom" $ [E0, E1, E2, E3] @?= genumFrom E0-      , testCase "enumFromThen" $ [E0, E1, E2, E3] @?= genumFromThen E0 E1-      , testCase "enumFromTo" $ [E0, E1, E2, E3] @?= genumFromTo E0 E3-      , testCase "enumFromThenTo" $ [E0, E1, E2, E3] @?= genumFromThenTo E0 E1 E3-      , testCase "toEnum (FiniteEnum)" $ allEs @?= fmap gtoFiniteEnum [0 .. 5]-      , testCase "fromEnum (FiniteEnum)" $ [0 .. 5] @?= fmap gfromFiniteEnum allEs-      , testCase "enumFrom (FiniteEnum)" $ allEs @?= gfiniteEnumFrom e0-      , testCase "enumFromThen (FiniteEnum)" $ allEs @?= gfiniteEnumFromThen e0 e1-      , testCase "enumFromTo (FiniteEnum)" $ allEs @?= gfiniteEnumFromTo e0 eLast-      , testCase "enumFromThenTo (FiniteEnum)" $ allEs @?= gfiniteEnumFromThenTo e0 e1 eLast+      [ testGroup "StandardEnum"+        [ testCase "toEnum" $ [E0, E1, E2, E3] @=? fmap gtoEnum [0, 1, 2, 3]+        , testCase "fromEnum" $ [0, 1, 2, 3] @=? fmap gfromEnum [E0, E1, E2, E3]+        , testCase "enumFrom" $ [E0, E1, E2, E3] @=? genumFrom E0+        , testCase "enumFromThen" $ [E0, E1, E2, E3] @=? genumFromThen E0 E1+        , testCase "enumFromTo" $ [E0, E1, E2, E3] @=? genumFromTo E0 E3+        , testCase "enumFromThenTo" $ [E0, E1, E2, E3] @=? genumFromThenTo E0 E1 E3+        ]+      , testGroup "FiniteEnum"+        [ testCase "toEnum" $ allEs @=? fmap gtoFiniteEnum [0 .. 5]+        , testCase "fromEnum" $ [0 .. 5] @=? fmap gfromFiniteEnum allEs+        , testCase "enumFrom" $ allEs @=? gfiniteEnumFrom e0+        , testCase "enumFromThen" $ allEs @=? gfiniteEnumFromThen e0 e1+        , testCase "enumFromTo" $ allEs @=? gfiniteEnumFromTo e0 eLast+        , testCase "enumFromThenTo" $ allEs @=? gfiniteEnumFromThenTo e0 e1 eLast+        ]       ]+  , testGroup "Ix"+      [ testGroup "only nullary constructors" +        [ testCase "range" $ [E0, E1, E2] @=? grange (E0, E2)+        , testCase "index" $ 1 @=? gindex (E1, E3) E2+        , testCase "inRange (within)" $ True @=? ginRange (E1, E3) E2+        , testCase "inRange (outside)" $ False @=? ginRange (E1, E3) E0+        ]+      , testGroup "single constructor"+        [ testCase "range" $ [T E1 E2, T E1 E3, T E2 E2, T E2 E3]  @=?+          grange (T E1 E2, T E2 E3)+        , testCase "index" $ 2 @=? gindex (T E1 E2, T E2 E3) (T E2 E2)+        , testCase "inRange (within)" $ True @=? ginRange (T E1 E2, T E2 E3) (T E1 E3)+        , testCase "inRange (outside)" $ False @=? ginRange (T E1 E2, T E2 E3) (T E2 E1)+        ]+      , testCase "single nullary constructor" $ 0 @=? gindex (Unit, Unit) Unit+      ]   , testGroup "Show"-      [ testCase "show" $ "P 1 2" @?= show (p' 1 2)-      , testCase "showsPrec" $ "(P 1 2)" @?= showsPrec 11 (p' 1 2) ""+      [ testCase "show" $ "P 1 2" @=? show (p' 1 2)+      , testCase "showsPrec" $ "(P 1 2)" @=? showsPrec 11 (p' 1 2) ""       ]    , testGroup "Show1"@@ -153,13 +182,21 @@       ]    , testGroup "Meta"-      [ testCase "datatypeName" $ "Maybe" @?= gdatatypeName @(Maybe Int)-      , testCase "moduleName" $ maybeModuleName @?= gmoduleName @(Maybe Int)-      , testCase "packageName" $ "base" @?= gpackageName @(Maybe Int)-      , testCase "isNewtype" $ False @?= gisNewtype @(Maybe Int)-      , testCase "conName" $ "Just" @?= gconName (Just ())-      , testCase "conFixity" $ Prefix @?= gconFixity (Just ())-      , testCase "conIsRecord" $ False @?= gconIsRecord (Just ())-      , testCase "conNum" $ 2 @?= gconNum @(Maybe Int)+      [ testCase "datatypeName" $ "Maybe" @=? gdatatypeName @(Maybe Int)+      , testCase "moduleName" $ maybeModuleName @=? gmoduleName @(Maybe Int)+      , testCase "packageName" $ "base" @=? gpackageName @(Maybe Int)+      , testCase "isNewtype" $ False @=? gisNewtype @(Maybe Int)+      , testCase "conName" $ "Just" @=? gconName (Just ())+      , testCase "conFixity" $ Prefix @=? gconFixity (Just ())+      , testCase "conIsRecord" $ False @=? gconIsRecord (Just ())+      , testCase "conNum" $ 2 @=? gconNum @(Maybe Int)+      ]+  , let i = conId (Just ()) in+    testGroup "ConId"+      [ testCase "conId" $ "ConId 1" @?= show i+      , testCase "conIdToInt" $ 1 @?= conIdToInt i+      , testCase "conIdToString" $ "Just" @?= conIdToString i+      , testCase "conIdEnum" $ [conId Nothing, conId (Just ())] @?= conIdEnum @(Maybe ())+      , testCase "conIdNamed" $ i @?= conIdNamed @"Just"       ]   ]