generic-data-functions 0.2.0 → 0.3.0

raw patch · 20 files changed

+456/−236 lines, 20 filesdep +contravariantPVP ok

version bump matches the API change (PVP)

Dependencies added: contravariant

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• README.md +22/−31
• generic-data-functions.cabal +7/−2
• src/Generic/Data/Function/Contra.hs +43/−0
• src/Generic/Data/Function/Contra/Constructor.hs +51/−0
• src/Generic/Data/Function/Contra/NonSum.hs +22/−0
• src/Generic/Data/Function/Contra/Sum.hs +49/−0
• src/Generic/Data/Function/Example.hs +5/−4
• src/Generic/Data/Function/FoldMap.hs +11/−9
• src/Generic/Data/Function/FoldMap/Constructor.hs +33/−22
• src/Generic/Data/Function/FoldMap/NonSum.hs +9/−9
• src/Generic/Data/Function/FoldMap/Sum.hs +21/−16
• src/Generic/Data/Function/FoldMap/SumConsByte.hs +29/−25
• src/Generic/Data/Function/Traverse.hs +12/−12
• src/Generic/Data/Function/Traverse/Constructor.hs +48/−34
• src/Generic/Data/Function/Traverse/NonSum.hs +12/−10
• src/Generic/Data/Function/Traverse/Sum.hs +55/−33
• src/Generic/Data/Function/Via.hs +0/−28
• src/Generic/Data/Rep/Assert.hs +1/−1
• src/Generic/Data/Wrappers.hs +18/−0

@@ -1,3 +1,11 @@+## 0.3.0 (2024-04-03)+* Use type tags, push actual target types into a type family. It means more+  required type annotations, but this is fine by me as I think this library+  should be implemented using GHC 9.10 `TypeApplications`.+* Swap `NoRec0`, `EmptyRec0` for uninstantiated data types. Less unwrapping,+  more consistent to the rest of the type-heavy interface. (They were labelled+  "via" but never used with `DerivingVia`.)+ ## 0.2.0 (2023-08-04) * Redesign interface, pushing certain checks out of type classes into top-level   generic function type signature. It means busier top-level types and more code

@@ -2,40 +2,28 @@ [hackage-megaparsec]: https://hackage.haskell.org/package/megaparsec  # generic-data-functions-A small Haskell library providing some funky generics that work over arbitrary-Haskell data types. We handle the sums of products representation; you only need-to pass a handful of definitions. Obtain simple, type-safe generic-serializers/reducers and parsers for almost zero effort.--Well, OK, so really this is a generic binary serialization library. It just so-happens that the generics look like `foldMap` and `traverse`.--## Really?-Kind of. We only handle *sequential concatenation*, being cleanly represented by-builtin type classes. Weirder cases like JSON parsing/serialization have more-going on, and aren't sensibly discussed generically. So you are probably only-going to use this with bytestrings and simple binary formats.--## Why?-It is 2023. There are a number of competing parsing and serialization Haskell-libraries, recently some notable high-performance ones. These are often fairly-experimental. Maybe you want some generics to benchmark some real-world use case-against popular libraries like binary and cereal. But maybe generics aren't-provided. Shucks.--That's a shame, because a binary/cereal-esque generic binary parser or-serializer doesn't have much work to do:+Generic functions that approximate familiar term-level functions. The generics+handle the sum of products representation and have "holes" for the base case,+which must be filled by the user via a type class. Perhaps you may also think of+these as "reusable" or "generic" generics. -  * traverse the generic sum-of-products tree of the given type left to right-  * defer to the appropriate type class for base cases+Most relevant for simple parsing and printing/serializing/reducing tasks where+the only "work" to do for the given data type is mechanical field sequencing.+If you require more logic than that (and can't place it in types/newtypes), you+will not be able to use this library. -Sum types necessitate a little more work. Otherwise, most such parsers and-serializers look fairly comparable to each other. Why are we rewriting this-stuff over and over again?+## Rationale+There are a number of competing parsing and serialization Haskell libraries.+Most have a type class for enumerating permitted types, and some simple generics+which use that type class for the base case. Other than that base case, everyone+is writing largely the same generic code. -generic-data-functions provides *reusable generics* which have holes in for your-favorite parsers and serializers. Fill out a few definitions to receive a fresh-new generic instance for your own library, without all the boilerplate.+While writing my own libraries, I realized that if another developer wanted use+my serializer, they would probably need to write their own type class for base+cases (due to some specific library design). Alas, this would mean they have to+copy-paste my generics and swap the type classes. Very silly. But it turned out+my generics were otherwise highly general, so I spun them out into this library.+Now you can swap the type class just by filling in some holes.  ## Functions ### `foldMap` (L->R)@@ -66,6 +54,9 @@ Useful for:    * simple binary parsers which can parse generic `foldMap` output++### `contra`+I don't know what this is exactly. It's like contramap?  ## Notes ### Orphan instances

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           generic-data-functions-version:        0.2.0+version:        0.3.0 synopsis:       Familiar functions lifted to generic data types description:    Please see README.md. category:       Data, Serialization@@ -28,6 +28,10 @@   exposed-modules:       Generic.Data.Function       Generic.Data.Function.Common+      Generic.Data.Function.Contra+      Generic.Data.Function.Contra.Constructor+      Generic.Data.Function.Contra.NonSum+      Generic.Data.Function.Contra.Sum       Generic.Data.Function.Example       Generic.Data.Function.FoldMap       Generic.Data.Function.FoldMap.Constructor@@ -40,9 +44,9 @@       Generic.Data.Function.Traverse.Sum       Generic.Data.Function.Util.Generic       Generic.Data.Function.Util.TypeNats-      Generic.Data.Function.Via       Generic.Data.Rep.Assert       Generic.Data.Rep.Error+      Generic.Data.Wrappers   other-modules:       Paths_generic_data_functions   hs-source-dirs:@@ -61,5 +65,6 @@   ghc-options: -Wall   build-depends:       base >=4.14 && <5+    , contravariant >=1.5.5 && <1.6     , text >=1.2.5.0 && <2.1   default-language: GHC2021

@@ -0,0 +1,43 @@+{-# LANGUAGE AllowAmbiguousTypes #-} -- due to type class design++module Generic.Data.Function.Contra+  ( GenericContra(..)+  , genericContraNonSum, GContraNonSum+  , genericContraSum,    GContraSum+  ) where++import GHC.Generics++import Generic.Data.Rep.Assert+import Generic.Data.Function.Contra.NonSum+import Generic.Data.Function.Contra.Sum+import Generic.Data.Function.Contra.Constructor+import Data.Functor.Contravariant++-- | Generic contra over a term of non-sum data type @a@.+--+-- @a@ must have exactly one constructor.+genericContraNonSum+    :: forall {cd} {gf} asserts tag a+    .  ( Generic a, Rep a ~ D1 cd gf+       , GContraNonSum tag gf+       , ApplyGCAsserts asserts gf+       , Contravariant (GenericContraF tag))+    => GenericContraF tag a+genericContraNonSum = contramap (unM1 . from) (gContraNonSum @tag)++-- | Generic contra over a term of sum data type @a@.+--+-- You must provide a contra function for constructor names.+--+-- This is the most generic option, but depending on your string manipulation+-- may be slower.+genericContraSum+    :: forall {cd} {gf} opts asserts tag a+    .  ( Generic a, Rep a ~ D1 cd gf+       , GContraSum opts tag gf+       , ApplyGCAsserts asserts gf+       , Contravariant (GenericContraF tag))+    => GenericContraF tag String+    -> GenericContraF tag a+genericContraSum f = contramap (unM1 . from) (gContraSum @opts @tag f)

@@ -0,0 +1,51 @@+{-# LANGUAGE UndecidableInstances #-} -- due to type class design+{-# LANGUAGE AllowAmbiguousTypes  #-} -- due to type class design++module Generic.Data.Function.Contra.Constructor where++import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible++import GHC.Generics+import Data.Kind ( type Type, type Constraint )++import Generic.Data.Wrappers ( NoRec0, type ENoRec0, EmptyRec0 )+import GHC.TypeLits ( TypeError )++class GenericContra tag where+    type GenericContraF tag :: Type -> Type+    type GenericContraC tag a :: Constraint+    -- TODO added Divisible+    genericContraF+        :: (GenericContraC tag a, Divisible (GenericContraF tag))+        => GenericContraF tag a++-- | over types with no fields in any constructor+instance GenericContra (NoRec0 (f :: Type -> Type)) where+    type GenericContraF (NoRec0 f) = f+    type GenericContraC (NoRec0 f) _ = TypeError ENoRec0+    genericContraF = undefined++-- | over types where all fields map to 'mempty'+instance GenericContra (EmptyRec0 (f :: Type -> Type)) where+    type GenericContraF (EmptyRec0 f) = f+    type GenericContraC (EmptyRec0 f) a = ()+    genericContraF = conquer+    -- TODO by adding Divisible f we don't need (Monoid a)/mempty any more++class GContraC tag gf where gContraC :: GenericContraF tag (gf p)++instance+  ( Divisible (GenericContraF tag)+  , GContraC tag l, GContraC tag r+  ) => GContraC tag (l :*: r) where+    gContraC = divide (\(l :*: r) -> (l, r)) (gContraC @tag) (gContraC @tag)++instance+  ( Divisible (GenericContraF tag)+  , GenericContra tag, GenericContraC tag a+  ) => GContraC tag (S1 c (Rec0 a)) where+    gContraC = contramap (unK1 . unM1) (genericContraF @tag)++instance Divisible (GenericContraF tag) => GContraC tag U1 where+    gContraC = conquer

@@ -0,0 +1,22 @@+{-# LANGUAGE UndecidableInstances #-} -- due to type class design+{-# LANGUAGE AllowAmbiguousTypes  #-} -- due to type class design++module Generic.Data.Function.Contra.NonSum where++import Data.Functor.Contravariant++import GHC.Generics+import Generic.Data.Function.Contra.Constructor+  ( GContraC(gContraC)+  , GenericContra(type GenericContraF)+  )+import Generic.Data.Rep.Error++class GContraNonSum tag gf where gContraNonSum :: GenericContraF tag (gf p)++instance (Contravariant (GenericContraF tag), GContraC tag g)+  => GContraNonSum tag (C1 c g) where+    gContraNonSum = contramap unM1 (gContraC @tag)++instance GContraNonSum tag (l :+: r) where gContraNonSum = error eNoSum+instance GContraNonSum tag V1        where gContraNonSum = error eNoEmpty

@@ -0,0 +1,49 @@+{-# LANGUAGE UndecidableInstances #-} -- due to typeclass design+{-# LANGUAGE AllowAmbiguousTypes #-}  -- due to typeclass design++module Generic.Data.Function.Contra.Sum where++import GHC.Generics+import Generic.Data.Function.Util.Generic ( conName' )+import Generic.Data.Function.Contra.Constructor+  ( GContraC(gContraC)+  , GenericContra(type GenericContraF)+  )+import Generic.Data.Rep.Error+import Generic.Data.Function.Common++import Data.Functor.Contravariant.Divisible++class GContraSum (opts :: SumOpts) tag gf where+    gContraSum :: GenericContraF tag String -> GenericContraF tag (gf p)++instance GContraCSum tag (l :+: r) => GContraSum opts tag (l :+: r) where+    gContraSum = gContraCSum @tag++instance GContraSum 'SumOnly tag (C1 c g) where+    gContraSum = error eNeedSum++instance GContraCSum tag (C1 c g)+  => GContraSum 'AllowSingletonSum tag (C1 c g) where+    gContraSum = gContraCSum @tag++instance GContraSum opts tag V1 where+    gContraSum = error eNoEmpty++-- TODO rename (? had this on foldmap sum)+class GContraCSum tag gf where+    gContraCSum :: GenericContraF tag String -> GenericContraF tag (gf p)++instance+  ( Decidable (GenericContraF tag)+  , GContraCSum tag l+  , GContraCSum tag r+  ) => GContraCSum tag (l :+: r) where+    gContraCSum f = choose genericSumToEither (gContraCSum @tag f) (gContraCSum @tag f)+      where genericSumToEither = \case L1 l -> Left l; R1 r -> Right r++instance+  ( Divisible (GenericContraF tag)+  , GContraC tag gf, Constructor c+  ) => GContraCSum tag (C1 c gf) where+    gContraCSum f = divide (\(M1 g) -> (conName' @c, g)) f (gContraC @tag)

@@ -18,19 +18,20 @@  instance GenericFoldMap Showly where     type GenericFoldMapC Showly a = Show a-    genericFoldMapF = Showly . (\a -> [a]) . show+    type GenericFoldMapM Showly = [String]+    genericFoldMapF = (\a -> [a]) . show  showGeneric     :: forall {cd} {f} opts asserts a     .  (Generic a, Rep a ~ D1 cd f, GFoldMapSum opts Showly f, ApplyGCAsserts asserts f)     => a -> String showGeneric =-      mconcat . List.intersperse " " . unShowly-    . genericFoldMapSum @opts @asserts (\cstr -> Showly [cstr])+      mconcat . List.intersperse " "+    . genericFoldMapSum @opts @asserts @Showly (\cstr -> [cstr])  showGeneric'     :: forall {cd} {f} asserts a     .  (Generic a, Rep a ~ D1 cd f, GFoldMapNonSum Showly f, ApplyGCAsserts asserts f)     => a -> String showGeneric' =-    mconcat . List.intersperse " " . unShowly . genericFoldMapNonSum @asserts+    mconcat . List.intersperse " " . genericFoldMapNonSum @asserts @Showly

@@ -47,12 +47,13 @@ -- -- @a@ must have exactly one constructor. genericFoldMapNonSum-    :: forall {cd} {f} asserts m a+    :: forall {cd} {f} asserts tag {m} a     .  ( Generic a, Rep a ~ D1 cd f-       , GFoldMapNonSum m f+       , m ~ GenericFoldMapM tag+       , GFoldMapNonSum tag f        , ApplyGCAsserts asserts f)     => a -> m-genericFoldMapNonSum = gFoldMapNonSum . unM1 . from+genericFoldMapNonSum = gFoldMapNonSum @tag . unM1 . from  -- | Generic 'foldMap' over a term of sum data type @a@. --@@ -61,13 +62,14 @@ -- This is the most generic option, but depending on your string manipulation -- may be slower. genericFoldMapSum-    :: forall {cd} {f} opts asserts m a+    :: forall {cd} {f} opts asserts tag {m} a     .  ( Generic a, Rep a ~ D1 cd f-       , GFoldMapSum opts m f+       , m ~ GenericFoldMapM tag+       , GFoldMapSum opts tag f        , ApplyGCAsserts asserts f)     => (String -> m)     -> a -> m-genericFoldMapSum f = gFoldMapSum @opts f . unM1 . from+genericFoldMapSum f = gFoldMapSum @opts @tag f . unM1 . from  -- | Generic 'foldMap' over a term of sum data type @a@ where constructors are -- mapped to their index (distance from first/leftmost constructor)@@ -79,8 +81,8 @@ -- This should be fairly fast, but sadly I think it's slower than the generics -- in store and binary/cereal libraries. genericFoldMapSumConsByte-    :: forall m a-    .  (Generic a, GFoldMapSumConsByte m (Rep a))+    :: forall tag {m} a+    .  (m ~ GenericFoldMapM tag, Generic a, GFoldMapSumConsByte tag (Rep a))     => (Word8 -> m)     -> a -> m-genericFoldMapSumConsByte f = gFoldMapSumConsByte f . from+genericFoldMapSumConsByte f = gFoldMapSumConsByte @tag f . from

@@ -1,45 +1,56 @@-{-# LANGUAGE UndecidableInstances #-} -- due to type class design+{-# LANGUAGE AllowAmbiguousTypes  #-} -- due to tag type class design+{-# LANGUAGE UndecidableInstances #-} -- due to generic type class design  module Generic.Data.Function.FoldMap.Constructor where  import GHC.Generics-import Data.Kind ( type Constraint )+import Data.Kind ( type Constraint, type Type ) -import Generic.Data.Function.Via+import Generic.Data.Wrappers ( NoRec0, type ENoRec0, EmptyRec0 ) import GHC.TypeLits ( TypeError ) --- | 'Monoid's that can be generically 'foldMap'ped to.-class GenericFoldMap m where-    -- | The type class that enables mapping permitted types to the monoid.-    ---    -- The type class should provide a function that looks like-    -- 'genericFoldMapF'.-    type GenericFoldMapC m a :: Constraint+-- | Implementation enumeration type class for generic 'foldMap'.+--+-- The type variable is uninstantiated, used purely as a tag.+--+-- Avoid orphan instances by defining custom empty types to use here.+-- See the binrep library on Hackage for an example.+class GenericFoldMap tag where+    -- | The target 'Monoid' to 'foldMap' to.+    type GenericFoldMapM tag :: Type -    -- | The "map" function in 'foldMap' (first argument).-    genericFoldMapF :: GenericFoldMapC m a => a -> m+    -- | The type class providing the map function in 'foldMap' for permitted+    --   types.+    type GenericFoldMapC tag a :: Constraint +    -- | The map function in 'foldMap' (first argument).+    genericFoldMapF :: GenericFoldMapC tag a => a -> GenericFoldMapM tag+ -- | 'foldMap' over types with no fields in any constructor.-instance GenericFoldMap (NoRec0 m) where+instance GenericFoldMap (NoRec0 (m :: Type)) where+    type GenericFoldMapM (NoRec0 m)   = m     type GenericFoldMapC (NoRec0 m) _ = TypeError ENoRec0     genericFoldMapF = undefined+    -- ^ TODO why safe  -- | 'foldMap' over types where all fields map to 'mempty'. instance Monoid m => GenericFoldMap (EmptyRec0 m) where+    type GenericFoldMapM (EmptyRec0 m)   = m     type GenericFoldMapC (EmptyRec0 m) _ = ()-    genericFoldMapF _ = EmptyRec0 mempty+    genericFoldMapF _ = mempty  -- | 'foldMap' on individual constructors (products).-class GFoldMapC m f where gFoldMapC :: f p -> m+class GFoldMapC tag f where gFoldMapC :: f p -> GenericFoldMapM tag  -- | 'foldMap' on individual constructors (products).-instance (Semigroup m, GFoldMapC m l, GFoldMapC m r)-  => GFoldMapC m (l :*: r) where-    gFoldMapC (l :*: r) = gFoldMapC l <> gFoldMapC r+instance (Semigroup (GenericFoldMapM tag), GFoldMapC tag l, GFoldMapC tag r)+  => GFoldMapC tag (l :*: r) where+    gFoldMapC (l :*: r) = gFoldMapC @tag l <> gFoldMapC @tag r -instance (GenericFoldMap m, GenericFoldMapC m a)-  => GFoldMapC m (S1 c (Rec0 a)) where-    gFoldMapC (M1 (K1 a)) = genericFoldMapF a+instance (GenericFoldMap tag, GenericFoldMapC tag a)+  => GFoldMapC tag (S1 c (Rec0 a)) where+    gFoldMapC (M1 (K1 a)) = genericFoldMapF @tag a  -- | Wow, look! Nothing!-instance Monoid m => GFoldMapC m U1 where gFoldMapC U1 = mempty+instance Monoid (GenericFoldMapM tag) => GFoldMapC tag U1 where+    gFoldMapC U1 = mempty

@@ -1,9 +1,12 @@+{-# LANGUAGE AllowAmbiguousTypes  #-} -- due to tag type class design {-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6  module Generic.Data.Function.FoldMap.NonSum where  import GHC.Generics-import Generic.Data.Function.FoldMap.Constructor ( GFoldMapC(gFoldMapC) )+import Generic.Data.Function.FoldMap.Constructor+  ( GFoldMapC(gFoldMapC)+  , GenericFoldMap(type GenericFoldMapM) ) import Generic.Data.Rep.Error  {- | 'foldMap' over generic product data types.@@ -11,13 +14,10 @@ Take a generic representation, map each field in the data type to a 'Monoid', and combine the results with ('<>'). -}-class GFoldMapNonSum m f where gFoldMapNonSum :: f p -> m--instance GFoldMapC m f => GFoldMapNonSum m (C1 c f) where-    gFoldMapNonSum (M1 a) = gFoldMapC a+class GFoldMapNonSum tag f where gFoldMapNonSum :: f p -> GenericFoldMapM tag -instance GFoldMapNonSum m (l :+: r) where-    gFoldMapNonSum = error eNoSum+instance GFoldMapC tag f => GFoldMapNonSum tag (C1 c f) where+    gFoldMapNonSum (M1 a) = gFoldMapC @tag a -instance GFoldMapNonSum m V1 where-    gFoldMapNonSum = error eNoEmpty+instance GFoldMapNonSum tag (l :+: r) where gFoldMapNonSum = error eNoSum+instance GFoldMapNonSum tag V1        where gFoldMapNonSum = error eNoEmpty

@@ -13,35 +13,40 @@  import GHC.Generics import Generic.Data.Function.Util.Generic ( conName' )-import Generic.Data.Function.FoldMap.Constructor ( GFoldMapC(gFoldMapC) )+import Generic.Data.Function.FoldMap.Constructor+  ( GFoldMapC(gFoldMapC)+  , GenericFoldMap(type GenericFoldMapM) ) import Generic.Data.Rep.Error import Generic.Data.Function.Common -class GFoldMapSum (opts :: SumOpts) m f where gFoldMapSum :: (String -> m) -> f p -> m+class GFoldMapSum (opts :: SumOpts) tag f where+    gFoldMapSum :: (String -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag -instance GFoldMapCSum m (l :+: r) => GFoldMapSum opts m (l :+: r) where-    gFoldMapSum = gFoldMapCSum+instance GFoldMapCSum tag (l :+: r) => GFoldMapSum opts tag (l :+: r) where+    gFoldMapSum = gFoldMapCSum @tag -instance GFoldMapSum 'SumOnly m (C1 c f) where+instance GFoldMapSum 'SumOnly tag (C1 c f) where     gFoldMapSum = error eNeedSum -instance GFoldMapCSum m (C1 c f)-  => GFoldMapSum 'AllowSingletonSum m (C1 c f) where-    gFoldMapSum = gFoldMapCSum+instance GFoldMapCSum tag (C1 c f)+  => GFoldMapSum 'AllowSingletonSum tag (C1 c f) where+    gFoldMapSum = gFoldMapCSum @tag -instance GFoldMapSum opts m V1 where+instance GFoldMapSum opts tag V1 where     gFoldMapSum = error eNoEmpty  -- | Sum type handler prefixing constructor contents with their mapped --   constructor name via a provided @String -> m@. -- -- TODO rename-class GFoldMapCSum m f where gFoldMapCSum :: (String -> m) -> f p -> m+class GFoldMapCSum tag f where+    gFoldMapCSum :: (String -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag -instance (GFoldMapCSum m l, GFoldMapCSum m r) => GFoldMapCSum m (l :+: r) where-    gFoldMapCSum f = \case L1 l -> gFoldMapCSum f l-                           R1 r -> gFoldMapCSum f r+instance (GFoldMapCSum tag l, GFoldMapCSum tag r)+  => GFoldMapCSum tag (l :+: r) where+    gFoldMapCSum f = \case L1 l -> gFoldMapCSum @tag f l+                           R1 r -> gFoldMapCSum @tag f r -instance (Semigroup m, Constructor c, GFoldMapC m f)-  => GFoldMapCSum m (C1 c f) where-    gFoldMapCSum mapCstr (M1 a) = mapCstr (conName' @c) <> gFoldMapC a+instance (Semigroup (GenericFoldMapM tag), Constructor c, GFoldMapC tag f)+  => GFoldMapCSum tag (C1 c f) where+    gFoldMapCSum mapCstr (M1 a) = mapCstr (conName' @c) <> gFoldMapC @tag a

@@ -15,24 +15,27 @@ import GHC.TypeLits import Data.Kind ( Type, Constraint ) import Generic.Data.Function.Util.TypeNats ( natVal'' )-import Generic.Data.Function.FoldMap.Constructor ( GFoldMapC(gFoldMapC) )+import Generic.Data.Function.FoldMap.Constructor+  ( GFoldMapC(gFoldMapC)+  , GenericFoldMap(type GenericFoldMapM) )  import Data.Word ( Word8 ) -class GFoldMapSumConsByte m f where-    gFoldMapSumConsByte :: (Word8 -> m) -> f p -> m+class GFoldMapSumConsByte tag f where+    gFoldMapSumConsByte+        :: (Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag -instance GFoldMapSumConsByte m f => GFoldMapSumConsByte m (D1 c f) where-    gFoldMapSumConsByte f (M1 a) = gFoldMapSumConsByte f a+instance GFoldMapSumConsByte tag f => GFoldMapSumConsByte tag (D1 c f) where+    gFoldMapSumConsByte f (M1 a) = gFoldMapSumConsByte @tag f a  instance   ( FitsInByte (SumArity (l :+: r))-  , GFoldMapCSumCtrArityByte m 0 (l :+: r)-  , GFoldMapCSumCtr m (l :+: r)-  , Semigroup m-  ) => GFoldMapSumConsByte m (l :+: r) where+  , GFoldMapCSumCtrArityByte tag 0 (l :+: r)+  , GFoldMapCSumCtr tag (l :+: r)+  , Semigroup (GenericFoldMapM tag)+  ) => GFoldMapSumConsByte tag (l :+: r) where     gFoldMapSumConsByte f lr =-        gFoldMapCSumCtrArityByte @m @0 f lr <> gFoldMapCSumCtr lr+        gFoldMapCSumCtrArityByte @tag @0 f lr <> gFoldMapCSumCtr @tag lr  instance GFoldMapSumConsByte m (C1 c f) where     gFoldMapSumConsByte _ = undefined@@ -44,30 +47,31 @@  -- | Sum type handler handling constructors only. Useful if you handle --   constructor prefixes elsewhere.-class GFoldMapCSumCtr m f where gFoldMapCSumCtr :: f p -> m+class GFoldMapCSumCtr tag f where gFoldMapCSumCtr :: f p -> GenericFoldMapM tag -instance (GFoldMapCSumCtr m l, GFoldMapCSumCtr m r)-  => GFoldMapCSumCtr m (l :+: r) where-    gFoldMapCSumCtr = \case L1 l -> gFoldMapCSumCtr l-                            R1 r -> gFoldMapCSumCtr r+instance (GFoldMapCSumCtr tag l, GFoldMapCSumCtr tag r)+  => GFoldMapCSumCtr tag (l :+: r) where+    gFoldMapCSumCtr = \case L1 l -> gFoldMapCSumCtr @tag l+                            R1 r -> gFoldMapCSumCtr @tag r -instance GFoldMapC m f => GFoldMapCSumCtr m (C1 c f) where-    gFoldMapCSumCtr (M1 a) = gFoldMapC a+instance GFoldMapC tag f => GFoldMapCSumCtr tag (C1 c f) where+    gFoldMapCSumCtr (M1 a) = gFoldMapC @tag a  --- -class GFoldMapCSumCtrArityByte m (arity :: Natural) f where-    gFoldMapCSumCtrArityByte :: (Word8 -> m) -> f p -> m+class GFoldMapCSumCtrArityByte tag (arity :: Natural) f where+    gFoldMapCSumCtrArityByte+        :: (Word8 -> GenericFoldMapM tag) -> f p -> GenericFoldMapM tag  instance-  ( GFoldMapCSumCtrArityByte m arity l-  , GFoldMapCSumCtrArityByte m (arity + SumArity l) r-  ) => GFoldMapCSumCtrArityByte m arity (l :+: r) where+  ( GFoldMapCSumCtrArityByte tag arity l+  , GFoldMapCSumCtrArityByte tag (arity + SumArity l) r+  ) => GFoldMapCSumCtrArityByte tag arity (l :+: r) where     gFoldMapCSumCtrArityByte f = \case-      L1 l -> gFoldMapCSumCtrArityByte @m @arity                f l-      R1 r -> gFoldMapCSumCtrArityByte @m @(arity + SumArity l) f r+      L1 l -> gFoldMapCSumCtrArityByte @tag @arity                f l+      R1 r -> gFoldMapCSumCtrArityByte @tag @(arity + SumArity l) f r -instance KnownNat arity => GFoldMapCSumCtrArityByte m arity (C1 c f) where+instance KnownNat arity => GFoldMapCSumCtrArityByte tag arity (C1 c f) where     gFoldMapCSumCtrArityByte f _ = f (fromIntegral (natVal'' @arity))  ---

@@ -27,26 +27,26 @@  -- | Generic 'traverse' over a term of non-sum data type @f a@. genericTraverseNonSum-    :: forall {cd} {gf} asserts f a+    :: forall {cd} {gf} asserts tag a     .  ( Generic a, Rep a ~ D1 cd gf-       , GTraverseNonSum cd f gf-       , ApplyGCAsserts asserts f-       , Functor f)-    => f a-genericTraverseNonSum = (to . M1) <$> gTraverseNonSum @cd+       , GTraverseNonSum cd tag gf+       , ApplyGCAsserts asserts tag+       , Functor (GenericTraverseF tag))+    => GenericTraverseF tag a+genericTraverseNonSum = (to . M1) <$> gTraverseNonSum @cd @tag  -- | Generic 'traverse' over a term of sum data type @f a@. -- -- You must provide a configuration for how to handle constructors. genericTraverseSum-    :: forall {cd} {gf} opts asserts f a pt+    :: forall {cd} {gf} opts asserts tag a pt     .  ( Generic a, Rep a ~ D1 cd gf-       , GTraverseSum opts cd f gf-       , ApplyGCAsserts asserts f-       , GenericTraverseC f pt, Functor f)+       , GTraverseSum opts cd tag gf+       , ApplyGCAsserts asserts tag+       , GenericTraverseC tag pt, Functor (GenericTraverseF tag))     => PfxTagCfg pt-    -> f a-genericTraverseSum ptc = (to . M1) <$> gTraverseSum @opts @cd ptc+    -> GenericTraverseF tag a+genericTraverseSum ptc = (to . M1) <$> gTraverseSum @opts @cd @tag ptc  -- | Construct a prefix tag config using existing 'Eq' and 'Show' instances. --

@@ -1,6 +1,5 @@ {-# LANGUAGE UndecidableInstances #-} -- due to type class design-{-# LANGUAGE AllowAmbiguousTypes #-}  -- due to type class design-{-# LANGUAGE ApplicativeDo #-} -- TODO because I'm lazy+{-# LANGUAGE AllowAmbiguousTypes  #-}  -- due to type class design  module Generic.Data.Function.Traverse.Constructor where @@ -9,69 +8,84 @@ import Generic.Data.Function.Util.Generic ( datatypeName', conName', selName'' ) import Generic.Data.Function.Util.TypeNats ( natVal'' ) -import Control.Applicative ( liftA2 )+import Control.Applicative qualified as Applicative+import Control.Applicative ( Alternative(empty) )  import Data.Kind ( type Type, type Constraint ) -import Generic.Data.Function.Via+import Generic.Data.Wrappers ( NoRec0, type ENoRec0, EmptyRec0 ) import GHC.TypeLits ( TypeError ) -import Data.Monoid-data A a = A a (Sum Int) ()-    deriving stock (Generic, Show)+-- import Data.Monoid --- | 'Applicative' functors that can be generically 'traverse'd.-class GenericTraverse f where-    -- | The type class providing (applicative) actions for permitted types.-    type GenericTraverseC f a :: Constraint+-- | Implementation enumeration type class for generic 'traverse'.+--+-- The type variable is uninstantiated, used purely as a tag.+--+-- Avoid orphan instances by defining custom empty types to use here.+-- See the binrep library on Hackage for an example.+class GenericTraverse tag where+    -- | The target 'Applicative' to 'traverse' to.+    type GenericTraverseF tag :: Type -> Type +    -- | The type class providing the action in 'traverse' for permitted types.+    type GenericTraverseC tag a :: Constraint+     -- | The action in 'traverse' (first argument).     --     -- We include data type metadata because this function is useful for monadic     -- parsers, which can record it in error messages. (We don't do it for     -- foldMap because it's pure.)     genericTraverseAction-        :: GenericTraverseC f a+        :: GenericTraverseC tag a         => String       {- ^ data type name -}         -> String       {- ^ constructor name -}         -> Maybe String {- ^ record name (if present) -}         -> Natural      {- ^ field index -}-        -> f a+        -> GenericTraverseF tag a  -- | 'traverse' over types with no fields in any constructor.-instance GenericTraverse NoRec0 where-    type GenericTraverseC NoRec0 a = TypeError ENoRec0+instance GenericTraverse (NoRec0 (f :: Type -> Type)) where+    type GenericTraverseF (NoRec0 f) = f+    type GenericTraverseC (NoRec0 _) _ = TypeError ENoRec0     genericTraverseAction = undefined --- | 'traverse' over types where all fields map to their respective 'mempty'.------ Can result in type errors lacking context: a field missing a 'Monoid'--- instance will type error with a regular "no instance for" message, without--- telling you the surrounding type.+-- | 'traverse' over types where all fields are replaced with the functor's+--   'empty'. ----- Maybe silly.-instance GenericTraverse EmptyRec0 where-    type GenericTraverseC EmptyRec0 a = Monoid a-    genericTraverseAction _ _ _ _ = EmptyRec0 mempty+-- Note that one may write a valid instance using a 'Monoid' on @a@s instead.+-- I don't think you should. But I can't explain why.+instance GenericTraverse (EmptyRec0 (f :: Type -> Type)) where+    type GenericTraverseF (EmptyRec0 f) = f+    type GenericTraverseC (EmptyRec0 f) _ = Alternative f+    genericTraverseAction _ _ _ _ = empty -class GTraverseC cd cc (si :: Natural) f f' where gTraverseC :: f (f' p)+class GTraverseC cd cc (si :: Natural) tag gf where+    gTraverseC :: GenericTraverseF tag (gf p) -instance (Applicative f, GTraverseC cd cc si f l, GTraverseC cd cc (si + ProdArity r) f r)-  => GTraverseC cd cc si f (l :*: r) where-    gTraverseC = liftA2 (:*:)-                   (gTraverseC @cd @cc @si)-                   (gTraverseC @cd @cc @(si + ProdArity r))+instance+  ( Applicative (GenericTraverseF tag)+  , GTraverseC cd cc si                 tag l+  , GTraverseC cd cc (si + ProdArity r) tag r+  ) => GTraverseC cd cc si tag (l :*: r) where+    gTraverseC = Applicative.liftA2 (:*:)+                   (gTraverseC @cd @cc @si                 @tag)+                   (gTraverseC @cd @cc @(si + ProdArity r) @tag) -instance (GenericTraverse f, GenericTraverseC f a, Functor f, KnownNat si, Selector cs, Constructor cc, Datatype cd)-  => GTraverseC cd cc si f (S1 cs (Rec0 a)) where-    gTraverseC = (M1 . K1) <$> genericTraverseAction cd cc cs si+instance+  ( GenericTraverse tag, GenericTraverseC tag a+  , Functor (GenericTraverseF tag)+  , KnownNat si, Selector cs, Constructor cc, Datatype cd+  ) => GTraverseC cd cc si tag (S1 cs (Rec0 a)) where+    gTraverseC = (M1 . K1) <$> genericTraverseAction @tag cd cc cs si       where         cs = selName'' @cs         cd = datatypeName' @cd         cc = conName' @cc         si = natVal'' @si -instance Applicative f => GTraverseC cd cc 0 f U1 where gTraverseC = pure U1+instance Applicative (GenericTraverseF tag) => GTraverseC cd cc 0 tag U1 where+    gTraverseC = pure U1  type family ProdArity (f :: Type -> Type) :: Natural where     ProdArity (S1 c f)  = 1

@@ -4,16 +4,18 @@ module Generic.Data.Function.Traverse.NonSum where  import GHC.Generics-import Generic.Data.Function.Traverse.Constructor ( GTraverseC(gTraverseC) )--class GTraverseNonSum (cd :: Meta) f f' where gTraverseNonSum :: f (f' p)+import Generic.Data.Function.Traverse.Constructor+  ( GTraverseC(gTraverseC)+  , GenericTraverse(type GenericTraverseF)+  )+import Generic.Data.Rep.Error -instance GTraverseNonSum cd f (l :+: r) where-    gTraverseNonSum = undefined+class GTraverseNonSum (cd :: Meta) tag gf where+    gTraverseNonSum :: GenericTraverseF tag (gf p) -instance (Functor f, GTraverseC cd cc 0 f f')-  => GTraverseNonSum cd f (C1 cc f') where-    gTraverseNonSum = M1 <$> gTraverseC @cd @cc @0+instance (Functor (GenericTraverseF tag), GTraverseC cd cc 0 tag gf)+  => GTraverseNonSum cd tag (C1 cc gf) where+    gTraverseNonSum = M1 <$> gTraverseC @cd @cc @0 @tag -instance GTraverseNonSum cd f V1 where-    gTraverseNonSum = undefined+instance GTraverseNonSum cd tag (l :+: r) where gTraverseNonSum = error eNoSum+instance GTraverseNonSum cd tag V1        where gTraverseNonSum = error eNoEmpty

@@ -1,11 +1,14 @@ {-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6-{-# LANGUAGE AllowAmbiguousTypes #-} -- required due to generic typeclass design+{-# LANGUAGE AllowAmbiguousTypes  #-} -- due to generic typeclass design  module Generic.Data.Function.Traverse.Sum where  import GHC.Generics import Generic.Data.Function.Util.Generic ( datatypeName', conName' )-import Generic.Data.Function.Traverse.Constructor ( GTraverseC(gTraverseC), GenericTraverse(..) )+import Generic.Data.Function.Traverse.Constructor+  ( GTraverseC(gTraverseC)+  , GenericTraverse(type GenericTraverseF, type GenericTraverseC)+  ) import Generic.Data.Rep.Error import Generic.Data.Function.Common @@ -15,16 +18,16 @@  {- | Sum type monads that can be generically 'traverse'd. -For sum types, we require a monad with choice to differentiate constructors.+We use 'Alternative' to handle "which constructor" checking on the term level. -}-class (GenericTraverse f, Alternative f, Monad f) => GenericTraverseSum f where+class GenericTraverse tag => GenericTraverseSum tag where     -- | Try to parse a prefix tag of type 'pt'.     --     -- Relevant metadata is provided as arguments.     genericTraverseSumPfxTagAction-        :: GenericTraverseC f pt+        :: GenericTraverseC tag pt         => String   -- ^ data type name-        -> f pt+        -> GenericTraverseF tag pt      -- | Parse error due to no constructor matching the parsed prefix tag.     --@@ -33,7 +36,7 @@         :: String   -- ^ data type name         -> [String] -- ^ non-matching constructor names         -> Text     -- ^ prefix tag, prettified-        -> f a+        -> GenericTraverseF tag a  -- | How to use a type as a prefix tag in a generic sum type parser. data PfxTagCfg a = PfxTagCfg@@ -50,52 +53,71 @@   -- ^ Make a prefix tag human-readable. 'show' is often appropriate.   } -class GTraverseSum (opts :: SumOpts) cd f f' where-    gTraverseSum :: GenericTraverseC f pt => PfxTagCfg pt -> f (f' p)+class GTraverseSum (opts :: SumOpts) cd tag gf where+    gTraverseSum+        :: GenericTraverseC tag pt+        => PfxTagCfg pt -> GenericTraverseF tag (gf p) -instance (GenericTraverseSum f, GTraverseCSum cd f (l :+: r), Datatype cd)-  => GTraverseSum opts cd f (l :+: r) where-    gTraverseSum = gTraverseSum' @cd+instance+  ( GenericTraverseSum tag, GTraverseCSum cd tag (l :+: r), Datatype cd+  , Alternative (GenericTraverseF tag)+  , Monad (GenericTraverseF tag)+  ) => GTraverseSum opts cd tag (l :+: r) where+    gTraverseSum = gTraverseSum' @cd @tag  gTraverseSum'-    :: forall {p} cd f f' pt-    .  (GenericTraverseC f pt, GenericTraverseSum f, GTraverseCSum cd f f', Datatype cd)-    => PfxTagCfg pt -> f (f' p)+    :: forall {p} cd tag gf pt+    .  ( GenericTraverseC tag pt+       , Alternative (GenericTraverseF tag)+       , Monad (GenericTraverseF tag)+       , GenericTraverseSum tag, GTraverseCSum cd tag gf+       , Datatype cd+    ) => PfxTagCfg pt -> GenericTraverseF tag (gf p) gTraverseSum' ptc = do-    pt <- genericTraverseSumPfxTagAction cd-    gTraverseCSum @cd ptc pt <|> parseErrorNoMatch pt+    pt <- genericTraverseSumPfxTagAction @tag cd+    gTraverseCSum @cd @tag ptc pt <|> parseErrorNoMatch pt   where     cd = datatypeName' @cd     parseErrorNoMatch pt =-        genericTraverseSumNoMatchingCstrAction cd testedCstrs ((pfxTagCfgShow ptc) pt)+        genericTraverseSumNoMatchingCstrAction @tag cd testedCstrs ((pfxTagCfgShow ptc) pt)     testedCstrs = [] -- TODO -instance GTraverseSum 'SumOnly cd f (C1 cc f') where+instance GTraverseSum 'SumOnly cd tag (C1 cc gf) where     gTraverseSum = error eNeedSum -instance (GenericTraverseSum f, GTraverseCSum cd f (C1 cc f'), Datatype cd)-  => GTraverseSum 'AllowSingletonSum cd f (C1 cc f') where-    gTraverseSum = gTraverseSum' @cd+instance+  ( GenericTraverseSum tag, GTraverseCSum cd tag (C1 cc gf), Datatype cd+  , Alternative (GenericTraverseF tag)+  , Monad (GenericTraverseF tag)+  ) => GTraverseSum 'AllowSingletonSum cd tag (C1 cc gf) where+    gTraverseSum = gTraverseSum' @cd @tag -instance GTraverseSum opts cd f V1 where+instance GTraverseSum opts cd tag V1 where     gTraverseSum = error eNoEmpty --- | Generic getter (constructor sum level).-class GTraverseCSum cd f f' where-    gTraverseCSum :: PfxTagCfg pt -> pt -> f (f' p)+class GTraverseCSum cd tag gf where+    gTraverseCSum :: PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p) -instance (Functor f, Alternative f, GTraverseCSum cd f l, GTraverseCSum cd f r)-  => GTraverseCSum cd f (l :+: r) where+-- | Combine constructor options with '(<|>)' ("or").+instance+  ( Alternative (GenericTraverseF tag)+  , GTraverseCSum cd tag l+  , GTraverseCSum cd tag r+  ) => GTraverseCSum cd tag (l :+: r) where     gTraverseCSum ptc pt = l <|> r       where-        l = L1 <$> gTraverseCSum @cd ptc pt-        r = R1 <$> gTraverseCSum @cd ptc pt+        l = L1 <$> gTraverseCSum @cd @tag ptc pt+        r = R1 <$> gTraverseCSum @cd @tag ptc pt -instance (Alternative f, GTraverseC cd cc 0 f f', Constructor cc)-  => GTraverseCSum cd f (C1 cc f') where+-- | If the constructor matches the expected prefix tag, then return the action+--   handling that constructor's contents, else return the empty action.+instance+  ( Alternative (GenericTraverseF tag)+  , GTraverseC cd cc 0 tag gf, Constructor cc+  ) => GTraverseCSum cd tag (C1 cc gf) where     gTraverseCSum ptc pt = do         if   (pfxTagCfgEq ptc) pt ptCstr-        then M1 <$> gTraverseC @cd @cc @0+        then M1 <$> gTraverseC @cd @cc @0 @tag         else Applicative.empty       where         ptCstr = (pfxTagCfgFromCstr ptc) (conName' @cc)

@@ -1,28 +0,0 @@--- | Wrapper types for using with @DerivingVia@.--module Generic.Data.Function.Via where--import GHC.Generics ( Generic )-import GHC.TypeLits ( ErrorMessage(Text) )-import Data.Functor.Identity ( Identity(..) )---- | Wrapper for using to derive instances via generics. Emit type error on---   'Rec0' base case i.e. any non-empty constructor.-newtype NoRec0 a = NoRec0 { unNoRec0 :: a }-    deriving stock (Generic, Show)-    deriving (Functor, Applicative, Monad) via Identity--type ENoRec0 =-    'Text "Cannot use generic function on NoRec0-wrapped type containing fields"---- | Wrapper for using to derive instances via generics. Do nothing for 'Rec0'---   base case i.e. every constructor field.------ "nothing" probably means 'mempty', but *may* be another unit-like.------ TODO This might not be useful. It's not "special" like 'NoRec0', it's--- basically tied to 'Monoid'. So it's useful for 'foldMap', but kind of--- arbitrary when applied to 'traverse'.-newtype EmptyRec0 a = EmptyRec0 { unEmptyRec0 :: a }-    deriving stock (Generic, Show)-    deriving (Functor, Applicative, Monad) via Identity

@@ -1,4 +1,4 @@-{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6 TODO maybe untrue for this+{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6  {- | Assertions on precise generic data representation. 

@@ -0,0 +1,18 @@+-- | Wrappers for "free" generics, where the base case is handled for you.++module Generic.Data.Wrappers where++import GHC.TypeLits ( ErrorMessage(Text) )++-- | Free generic wrapper where any field emits a type error.+--+-- Useful for generic functions on void or enum types.+data NoRec0 (a :: k)++type ENoRec0 =+    'Text "Cannot use generic function on NoRec0-wrapped type containing fields"++-- | Free generic wrapper where every field does "nothing" (e.g. 'mempty'.)+--+-- Maybe useful for testing?+data EmptyRec0 (a :: k)