generic-data-functions 0.5.1 → 0.6.0

raw patch · 20 files changed

+456/−192 lines, 20 filesdep −textdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies removed: text

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• LICENSE +1/−1
• README.md +14/−2
• generic-data-functions.cabal +8/−5
• src/Generic/Data/FOnCstr.hs +96/−0
• src/Generic/Data/Function/Common/Generic/Meta.hs +1/−1
• src/Generic/Data/Function/Common/TypeLits.hs +21/−0
• src/Generic/Data/Function/Common/TypeNats.hs +0/−17
• src/Generic/Data/Function/Example.hs +3/−2
• src/Generic/Data/Function/FoldMap.hs +21/−9
• src/Generic/Data/Function/FoldMap/Sum.hs +40/−34
• src/Generic/Data/Function/FoldMap/SumConsByte.hs +1/−1
• src/Generic/Data/Function/Traverse.hs +24/−22
• src/Generic/Data/Function/Traverse/Constructor.hs +14/−12
• src/Generic/Data/Function/Traverse/NonSum.hs +8/−7
• src/Generic/Data/Function/Traverse/Sum.hs +56/−74
• src/Generic/Data/MetaParse/Cstr.hs +84/−0
• src/Generic/Data/MetaParse/Internal.hs +4/−0
• src/Generic/Data/Wrappers.hs +13/−5
• src/Generic/Type/CstrPath.hs +38/−0

@@ -1,3 +1,12 @@+## 0.6.0 (2024-06-15)+* support parsing constructor names on type-level for `foldMap`, `traverse`+  * effectively requires Symparsec-- but we need not incur a dependency+  * previous behaviour is still present using `*Raw` functions+* add `FOnCstr`, for targeting a single constructor of a sum type+* bump minimum compiler to GHC 9.2 (base-4.16) because I can't easily test GHC+  9.0+* big cleanup+ ## 0.5.1 (2024-04-10) * remove spurious constraint in Traverse.Sum (should be same semantics) * bump text upper bound for GHC 9.8 compatibility

@@ -1,4 +1,4 @@-Copyright (c) 2023 Ben Orchard (@raehik) <thefirstmuffinman@gmail.com>+Copyright (c) 2023-2024 Ben Orchard (@raehik) <thefirstmuffinman@gmail.com>  Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the

@@ -8,10 +8,16 @@ these as "reusable" or "generic" generics.  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+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. +Emphasis is put on type safety and performance. Notably, for sum type generics,+we permit parsing constructor names on the type level (via+[symparsec](https://hackage.haskell.org/package/symparsec)). For cases where you+want to implement your own high-performance sum type handling, we provide+`Generic.Data.FOnCstr`.+ ## 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@@ -24,6 +30,12 @@ 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.++## Design notes+### Sum types are handled by prepending a sum tag+Unless otherwise specified, this is how we disambiguate constructors. How the+sum tag is parsed from a constructor is up to the user (and may be done on the+type-level if one wishes).  ## Functions ### `foldMap` (L->R)

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           generic-data-functions-version:        0.5.1+version:        0.6.0 synopsis:       Familiar functions lifted to generic data types description:    Please see README.md. category:       Data, Generics@@ -26,11 +26,12 @@  library   exposed-modules:+      Generic.Data.FOnCstr       Generic.Data.Function       Generic.Data.Function.Common.Error       Generic.Data.Function.Common.Generic       Generic.Data.Function.Common.Generic.Meta-      Generic.Data.Function.Common.TypeNats+      Generic.Data.Function.Common.TypeLits       Generic.Data.Function.Contra       Generic.Data.Function.Contra.Constructor       Generic.Data.Function.Contra.NonSum@@ -45,7 +46,10 @@       Generic.Data.Function.Traverse.Constructor       Generic.Data.Function.Traverse.NonSum       Generic.Data.Function.Traverse.Sum+      Generic.Data.MetaParse.Cstr+      Generic.Data.MetaParse.Internal       Generic.Data.Wrappers+      Generic.Type.CstrPath   other-modules:       Paths_generic_data_functions   hs-source-dirs:@@ -61,9 +65,8 @@       TypeFamilies       DataKinds       MagicHash-  ghc-options: -Wall+  ghc-options: -Wall -Wno-unticked-promoted-constructors   build-depends:-      base >=4.14 && <5+      base >=4.16 && <5     , contravariant >=1.5.5 && <1.6-    , text >=1.2.5.0 && <2.2   default-language: GHC2021

@@ -0,0 +1,96 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE AllowAmbiguousTypes #-} -- for da test++module Generic.Data.FOnCstr where++import GHC.Generics+import GHC.TypeLits+import Data.Kind ( type Type, type Constraint )+import Generic.Type.CstrPath+import GHC.Exts ( Proxy#, proxy# )++-- | What generic functor to run on the requested constructor.+class GenericFOnCstr tag where+    -- | Functor.+    type GenericFOnCstrF tag :: Type -> Type++    -- | Constraint. Includes relevant generic meta (data type & constructor+    --   name).+    type GenericFOnCstrC tag (dtName :: Symbol) (cstrName :: Symbol) (gf :: k -> Type) :: Constraint++    -- | Generic functor.+    --+    -- We have to pass a proxy thanks to type applications not working properly+    -- with instances. (This will be easier in GHC 9.10 via+    -- RequiredTypeArguments).+    genericFOnCstrF+        :: GenericFOnCstrC tag dtName cstrName gf+        => Proxy# '(dtName, cstrName)+        -> GenericFOnCstrF tag (gf p)++-- | Run a generic functor (provided via @tag@) on the constructor name @name@.+--+-- We hope and pray that GHC removes the generic wrappers, at least the+-- constructor ones, since we do a whole bunch of nothing with them on the term+-- level. Checking this (the produced Core) is a big TODO.+class GFOnCstr tag (name :: Symbol) gf where+    gFOnCstr :: GenericFOnCstrF tag (gf p)++type family AssertValidCstrPath dtName cstr eae where+    AssertValidCstrPath dtName cstr (Right a) = a+    AssertValidCstrPath dtName cstr (Left  e) = TypeError+        (      Text "error searching for constructor " :<>: Text cstr+          :<>: Text " in data type " :<>: Text dtName :<>: Text ":"+          :$$: e )++instance+  ( turns ~ AssertValidCstrPath dtName cstrName (GCstrPath cstrName gf)+  , Functor (GenericFOnCstrF tag)+  , GFOnCstr' tag dtName cstrName turns gf+  ) => GFOnCstr tag cstrName (D1 (MetaData dtName _md2 _md3 _md4) gf) where+    {-# INLINE gFOnCstr #-}+    gFOnCstr = M1 <$> gFOnCstr' @tag @dtName @cstrName @turns++class GFOnCstr' tag (dtName :: Symbol) (cstrName :: Symbol) (turns :: [GCstrChoice]) gf where+    gFOnCstr' :: GenericFOnCstrF tag (gf p)++{-+The following instances rely on @turns@ being valid for the current generic+representation. I don't attempt to handle this at all, because I assume my+constructor path algorithm is correct. Please let me know if you get an error+that says it came from this class.+-}+instance (Functor (GenericFOnCstrF tag), GFOnCstr' tag dtName cstrName turns l)+  => GFOnCstr' tag dtName cstrName (GoL1 : turns) (l :+: r) where+    {-# INLINE gFOnCstr' #-}+    gFOnCstr' = L1 <$> gFOnCstr' @tag @dtName @cstrName @turns+instance (Functor (GenericFOnCstrF tag), GFOnCstr' tag dtName cstrName turns r)+  => GFOnCstr' tag dtName cstrName (GoR1 : turns) (l :+: r) where+    {-# INLINE gFOnCstr' #-}+    gFOnCstr' = R1 <$> gFOnCstr' @tag @dtName @cstrName @turns+instance+  ( Functor (GenericFOnCstrF tag), GenericFOnCstr tag+  , GenericFOnCstrC tag dtName cstrName gf+  ) => GFOnCstr' tag dtName cstrName '[] (C1 mc gf) where+    {-# INLINE gFOnCstr' #-}+    gFOnCstr' =+        M1 <$> genericFOnCstrF @tag (proxy# :: Proxy# '(dtName, cstrName))++-- | Run a generic functor on the requested constructor of the given type.+genericFOnCstr+    :: forall tag (name :: Symbol) a+    .  ( Generic a, Functor (GenericFOnCstrF tag), GFOnCstr tag name (Rep a) )+    => GenericFOnCstrF tag a+genericFOnCstr = to <$> gFOnCstr @tag @name++{-+This type errors due to a "could not deduce 'GFOnCstr GX name (Rep a)'", "The+type variable 'k0' is ambiguous". Unsure why. GHC seems to indicate that it's+making a whole bunch of unused k1-3 type vars... I feel like GHC is trying to+match instances too early, and somehow backs itself into a corner.+genericFOnCstr'+    :: forall (name :: Symbol) a+    .  ( Generic a, GFOnCstr GX name (Rep a) )+    => Maybe a+genericFOnCstr' = to <$> gFOnCstr @GX @name+-}

@@ -10,7 +10,7 @@ -- | List every constructor name in a generic type rep. type family CstrNames gf :: [Symbol] where     CstrNames (l :+: r) = CstrNames l ++ CstrNames r-    CstrNames (C1 ('MetaCons n _ _) _) = '[n]+    CstrNames (C1 (MetaCons n _ _) _) = '[n]  -- | Append for type-level lists. type family (as :: [k]) ++ (bs :: [k]) :: [k] where

@@ -0,0 +1,21 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Handy typelit utils.++module Generic.Data.Function.Common.TypeLits where++import GHC.TypeNats ( Natural, KnownNat, natVal' )+import GHC.TypeLits ( KnownSymbol, symbolVal' )+import GHC.Exts ( proxy#, Proxy# )++natVal'' :: forall n. KnownNat n => Natural+natVal'' = natVal' (proxy# :: Proxy# n)+{-# INLINE natVal'' #-}++natValInt :: forall n. KnownNat n => Int+natValInt = fromIntegral $ natVal'' @n+{-# INLINE natValInt #-}++symbolVal'' :: forall sym. KnownSymbol sym => String+symbolVal'' = symbolVal' (proxy# :: Proxy# sym)+{-# INLINE symbolVal'' #-}

@@ -1,17 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}---- | Handy typenat utils.--module Generic.Data.Function.Common.TypeNats where---- natVal''-import GHC.TypeNats ( Natural, KnownNat, natVal' )-import GHC.Exts ( proxy#, Proxy# )--natVal'' :: forall n. KnownNat n => Natural-natVal'' = natVal' (proxy# :: Proxy# n)-{-# INLINE natVal'' #-}--natValInt :: forall n. KnownNat n => Int-natValInt = fromIntegral $ natVal'' @n-{-# INLINE natValInt #-}

@@ -4,6 +4,7 @@  import GHC.Generics import Generic.Data.Function.FoldMap+import Generic.Data.MetaParse.Cstr  import Data.List qualified as List @@ -22,11 +23,11 @@  showGeneric     :: forall a-    .  (Generic a, GFoldMapSum Showly (Rep a))+    .  (Generic a, GFoldMapSum Showly Raw (Rep a))     => a -> String showGeneric =       mconcat . List.intersperse " "-    . genericFoldMapSum @Showly (\cstr -> [cstr])+    . genericFoldMapSumRaw @Showly (\cstr -> [cstr])  showGeneric'     :: forall a

@@ -31,6 +31,7 @@   ( GenericFoldMap(..)   , genericFoldMapNonSum, GFoldMapNonSum   , genericFoldMapSum,    GFoldMapSum+  , genericFoldMapSumRaw   , genericFoldMapSumConsByte,    GFoldMapSumConsByte   ) where @@ -42,27 +43,38 @@ import Generic.Data.Function.FoldMap.SumConsByte import Data.Word ( Word8 ) +import Generic.Data.MetaParse.Cstr+import GHC.TypeLits ( symbolVal' )+ -- | Generic 'foldMap' over a term of non-sum data type @a@. -- -- @a@ must have exactly one constructor. genericFoldMapNonSum-    :: forall {k} (tag :: k) a+    :: forall tag a     .  ( Generic a, GFoldMapNonSum tag (Rep a)     ) => a -> GenericFoldMapM tag genericFoldMapNonSum = gFoldMapNonSum @tag . from  -- | Generic 'foldMap' over a term of sum data type @a@. ----- You must provide a function for mapping constructor names to monoidal values.------ This is the most generic option, but depending on your string manipulation--- may be slower.+-- You must provide a type tag for parsing constructor names on the type-level,+-- and a function for reifying such results to monoidal values. genericFoldMapSum-    :: forall {k} (tag :: k) a-    .  ( Generic a, GFoldMapSum tag (Rep a)-    ) => (String -> GenericFoldMapM tag)+    :: forall tag sumtag a+    .  (Generic a, GFoldMapSum tag sumtag (Rep a))+    => ParseCstrTo sumtag (GenericFoldMapM tag)     -> a -> GenericFoldMapM tag-genericFoldMapSum f = gFoldMapSum @tag f . from+genericFoldMapSum f = gFoldMapSum @tag @sumtag f . from++-- | Generic 'foldMap' over a term of sum data type @a@.+--+-- You must provide a function for mapping constructor names to monoidal values.+genericFoldMapSumRaw+    :: forall tag a+    .  (Generic a, GFoldMapSum tag Raw (Rep a))+    => (String -> GenericFoldMapM tag)+    -> a -> GenericFoldMapM tag+genericFoldMapSumRaw f = gFoldMapSum @tag @Raw (\p -> f (symbolVal' p)) . from  -- | Generic 'foldMap' over a term of sum data type @a@ where constructors are -- mapped to their index (distance from first/leftmost constructor)

@@ -1,51 +1,57 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6--{- | 'foldMap' for sum types where constructors are encoded by mapping the-      constructor name.--Note that constructor names are unique per type. So as long as your mapping-function similarly outputs unique values of your monoid for each constructor,-you should be able to "reverse" the process (e.g. for generic 'traverse').--}+{-# LANGUAGE UndecidableInstances #-} -- due to type families in constraints+{-# LANGUAGE AllowAmbiguousTypes  #-} -- due to class design  module Generic.Data.Function.FoldMap.Sum where  import GHC.Generics-import Generic.Data.Function.Common.Generic ( conName', absurdV1 )+import Generic.Data.Function.Common.Generic ( absurdV1 ) import Generic.Data.Function.FoldMap.Constructor   ( GFoldMapC(gFoldMapC)   , GenericFoldMap(type GenericFoldMapM) )+import Generic.Data.MetaParse.Cstr+import GHC.Exts ( proxy# )+import GHC.TypeLits ( Symbol ) -class GFoldMapSum tag gf where+class GFoldMapSum tag sumtag gf where     gFoldMapSum-        :: (String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag+        :: ParseCstrTo sumtag (GenericFoldMapM tag)+        -> gf p -> GenericFoldMapM tag -instance GFoldMapSum tag gf => GFoldMapSum tag (D1 c gf) where-    gFoldMapSum f = gFoldMapSum @tag f . unM1+instance GFoldMapSumD tag sumtag dtName gf+  => GFoldMapSum tag sumtag (D1 (MetaData dtName _md2 _md3 _md4) gf) where+    gFoldMapSum f = gFoldMapSumD @tag @sumtag @dtName f . unM1 -instance GFoldMapCSum tag (l :+: r) => GFoldMapSum tag (l :+: r) where-    gFoldMapSum = gFoldMapCSum @tag+class GFoldMapSumD tag sumtag dtName gf where+    gFoldMapSumD+        :: ParseCstrTo sumtag (GenericFoldMapM tag)+        -> gf p -> GenericFoldMapM tag -instance GFoldMapCSum tag (C1 c gf) => GFoldMapSum tag (C1 c gf) where-    gFoldMapSum = gFoldMapCSum @tag+instance GFoldMapSumD tag sumtag dtName V1 where+    gFoldMapSumD _ = absurdV1 -instance GFoldMapSum tag V1 where-    gFoldMapSum _ = absurdV1+instance GFoldMapCSum tag sumtag dtName (C1 c gf)+  => GFoldMapSumD tag sumtag dtName (C1 c gf) where+    gFoldMapSumD = gFoldMapCSum @tag @sumtag @dtName --- | Sum type handler prefixing constructor contents with their mapped---   constructor name via a provided @String -> m@.------ TODO rename-class GFoldMapCSum tag gf where+instance GFoldMapCSum tag sumtag dtName (l :+: r)+  => GFoldMapSumD tag sumtag dtName (l :+: r) where+    gFoldMapSumD = gFoldMapCSum @tag @sumtag @dtName++class GFoldMapCSum tag sumtag (dtName :: Symbol) gf where     gFoldMapCSum-        :: (String -> GenericFoldMapM tag) -> gf p -> GenericFoldMapM tag+        :: ParseCstrTo sumtag (GenericFoldMapM tag)+        -> gf p -> GenericFoldMapM tag -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 (GFoldMapCSum tag sumtag dtName l, GFoldMapCSum tag sumtag dtName r)+  => GFoldMapCSum tag sumtag dtName (l :+: r) where+    gFoldMapCSum f = \case L1 l -> gFoldMapCSum @tag @sumtag @dtName f l+                           R1 r -> gFoldMapCSum @tag @sumtag @dtName f r -instance (Semigroup (GenericFoldMapM tag), Constructor c, GFoldMapC tag gf)-  => GFoldMapCSum tag (C1 c gf) where-    gFoldMapCSum mapCstr (M1 a) = mapCstr (conName' @c) <> gFoldMapC @tag a+-- TODO could play with this. Perhaps Unsatisfiable (GHC 9.8) is better?+instance+  ( Semigroup (GenericFoldMapM tag), GFoldMapC tag gf+  , ReifyCstrParseResult sumtag cstrParsed+  , ForceGCParse dtName cstr (ParseCstr sumtag cstr) ~ cstrParsed+  ) => GFoldMapCSum tag sumtag dtName (C1 (MetaCons cstr _mc2 _mc3) gf) where+    gFoldMapCSum mapReifyCstr (M1 a) =+        mapReifyCstr (proxy# @cstrParsed) <> gFoldMapC @tag a

@@ -14,7 +14,7 @@ import GHC.Generics import GHC.TypeLits import Data.Kind ( Type, Constraint )-import Generic.Data.Function.Common.TypeNats ( natVal'' )+import Generic.Data.Function.Common.TypeLits ( natVal'' ) import Generic.Data.Function.FoldMap.Constructor   ( GFoldMapC(gFoldMapC)   , GenericFoldMap(type GenericFoldMapM) )

@@ -11,9 +11,8 @@ module Generic.Data.Function.Traverse   ( GenericTraverse(..)   , genericTraverseNonSum , GTraverseNonSum-  , GenericTraverseSum(..), PfxTagCfg(..)   , genericTraverseSum,     GTraverseSum-  , eqShowPfxTagCfg+  , genericTraverseSumRaw   ) where  import GHC.Generics@@ -21,8 +20,8 @@ import Generic.Data.Function.Traverse.NonSum import Generic.Data.Function.Traverse.Sum import Generic.Data.Function.Traverse.Constructor--import Data.Text qualified as Text+import Generic.Data.MetaParse.Cstr+import GHC.TypeLits ( symbolVal' )  -- | Generic 'traverse' over a term of non-sum data type @f a@, --   where @f@ is set by the @tag@ you pass.@@ -34,25 +33,28 @@     ) => GenericTraverseF tag a genericTraverseNonSum = to <$> gTraverseNonSum @tag --- | Generic 'traverse' over a term of sum data type @f a@,---   where @f@ is set by the @tag@ you pass.------ You must provide a configuration for how to handle constructors. genericTraverseSum-    :: forall {k} (tag :: k) a pt+    :: forall tag sumtag a pt     .  ( Generic a        , Functor (GenericTraverseF tag)-       , GTraverseSum tag (Rep a)-       , GenericTraverseC tag pt-    ) => PfxTagCfg pt -> GenericTraverseF tag a-genericTraverseSum ptc = to <$> gTraverseSum @tag ptc+       , GTraverseSum tag sumtag (Rep a)+    ) => ParseCstrTo sumtag pt+      -> (String -> GenericTraverseF tag pt)+      -> (forall x. String -> GenericTraverseF tag x)+      -> (pt -> pt -> Bool)+      -> GenericTraverseF tag a+genericTraverseSum parseCstr ptGet fNoMatch ptEq =+    to <$> gTraverseSum @tag @sumtag parseCstr ptGet fNoMatch ptEq --- | Construct a prefix tag config using existing 'Eq' and 'Show' instances.------ The user only needs to provide the constructor name parser.-eqShowPfxTagCfg :: (Eq a, Show a) => (String -> a) -> PfxTagCfg a-eqShowPfxTagCfg f = PfxTagCfg-    { pfxTagCfgFromCstr = f-    , pfxTagCfgEq = (==)-    , pfxTagCfgShow = Text.pack . show-    }+genericTraverseSumRaw+    :: forall tag a pt+    .  ( Generic a+       , Functor (GenericTraverseF tag)+       , GTraverseSum tag Raw (Rep a)+    ) => (String -> pt)+      -> (String -> GenericTraverseF tag pt)+      -> (forall x. String -> GenericTraverseF tag x)+      -> (pt -> pt -> Bool)+      -> GenericTraverseF tag a+genericTraverseSumRaw parseCstr ptGet fNoMatch ptEq = to <$>+    gTraverseSum @tag @Raw (\p -> parseCstr (symbolVal' p)) ptGet fNoMatch ptEq

@@ -4,9 +4,8 @@ module Generic.Data.Function.Traverse.Constructor where  import GHC.Generics-import GHC.TypeNats ( Natural, KnownNat, type (+) )-import Generic.Data.Function.Common.Generic ( datatypeName', conName', selName'' )-import Generic.Data.Function.Common.TypeNats ( natVal'' )+import GHC.TypeLits+import Generic.Data.Function.Common.TypeLits ( natVal'', symbolVal'' ) import Generic.Data.Function.Common.Error ( eNoEmpty )  import Control.Applicative qualified as Applicative@@ -15,10 +14,7 @@ import Data.Kind ( type Type, type Constraint )  import Generic.Data.Wrappers ( NoRec0, type ENoRec0, EmptyRec0 )-import GHC.TypeError ( TypeError, ErrorMessage(..) ) --- import Data.Monoid- -- | Implementation enumeration type class for generic 'traverse'. -- -- The type variable is uninstantiated, used purely as a tag.@@ -81,7 +77,7 @@     type GenericTraverseC (EmptyRec0 f) _ = Alternative f     genericTraverseAction _ _ _ _ = empty -class GTraverseC tag cd cc (si :: Natural) gf where+class GTraverseC tag (cd :: Symbol) (cc :: Symbol) (si :: Natural) gf where     gTraverseC :: GenericTraverseF tag (gf p)  instance@@ -96,13 +92,13 @@ instance   ( GenericTraverse tag, GenericTraverseC tag a   , Functor (GenericTraverseF tag)-  , KnownNat si, Selector cs, Constructor cc, Datatype cd-  ) => GTraverseC tag cd cc si (S1 cs (Rec0 a)) where+  , KnownNat si, ReifyMaybeSymbol mSelName, KnownSymbol cc, KnownSymbol cd+  ) => GTraverseC tag cd cc si (S1 (MetaSel mSelName _ms2 _ms3 _ms4) (Rec0 a)) where     gTraverseC = (M1 . K1) <$> genericTraverseAction @tag cd cc cs si       where-        cs = selName'' @cs-        cd = datatypeName' @cd-        cc = conName' @cc+        cs = reifyMaybeSymbol @mSelName+        cd = symbolVal'' @cd+        cc = symbolVal'' @cc         si = natVal'' @si  instance Applicative (GenericTraverseF tag) => GTraverseC tag cd cc 0 U1 where@@ -111,3 +107,9 @@ type family ProdArity (f :: Type -> Type) :: Natural where     ProdArity (S1 c f)  = 1     ProdArity (l :*: r) = ProdArity l + ProdArity r++class ReifyMaybeSymbol (mstr :: Maybe Symbol) where+    reifyMaybeSymbol :: Maybe String+instance ReifyMaybeSymbol Nothing where reifyMaybeSymbol = Nothing+instance KnownSymbol str => ReifyMaybeSymbol (Just str) where+    reifyMaybeSymbol = Just (symbolVal'' @str)

@@ -4,22 +4,23 @@ module Generic.Data.Function.Traverse.NonSum where  import GHC.Generics+import GHC.TypeLits ( Symbol ) import Generic.Data.Function.Traverse.Constructor import Generic.Data.Function.Common.Error  class GTraverseNonSum tag gf where     gTraverseNonSum :: GenericTraverseF tag (gf p) -instance (Functor (GenericTraverseF tag), GTraverseNonSumD tag cd gf)-  => GTraverseNonSum tag (D1 cd gf) where-    gTraverseNonSum = M1 <$> gTraverseNonSumD @tag @cd+instance (Functor (GenericTraverseF tag), GTraverseNonSumD tag dtName gf)+  => GTraverseNonSum tag (D1 (MetaData dtName _md2 _md3 _md4) gf) where+    gTraverseNonSum = M1 <$> gTraverseNonSumD @tag @dtName -class GTraverseNonSumD tag (cd :: Meta) gf where+class GTraverseNonSumD tag (cd :: Symbol) gf where     gTraverseNonSumD :: GenericTraverseF tag (gf p) -instance (Functor (GenericTraverseF tag), GTraverseC tag cd cc 0 gf)-  => GTraverseNonSumD tag cd (C1 cc gf) where-    gTraverseNonSumD = M1 <$> gTraverseC @tag @cd @cc @0+instance (Functor (GenericTraverseF tag), GTraverseC tag cd cstrName 0 gf)+  => GTraverseNonSumD tag cd (C1 (MetaCons cstrName _mc2 _mc3) gf) where+    gTraverseNonSumD = M1 <$> gTraverseC @tag @cd @cstrName @0  instance GTraverseNonSumD tag cd (l :+: r) where gTraverseNonSumD = error eNoSum instance GenericTraverse tag => GTraverseNonSumD tag cd V1 where

@@ -1,102 +1,84 @@ {-# LANGUAGE UndecidableInstances #-} -- due to type hell {-# LANGUAGE AllowAmbiguousTypes  #-} -- due to generic typeclass design +{- | 'traverse' over generic sum types.++Disambiguates constructors by prepending sum tags.++Note that the sum tag approach has efficiency limitations.+You may design a constructor disambiguation schema which permits "incrementally"+parsing, rather than parsing some whole thing then comparing to each option,+which will be faster. If you wish to perform such sum tag handling yourself, but+still want the free generics, "Generic.Data.FOnCstr" can do this for you.+-}+ module Generic.Data.Function.Traverse.Sum where  import GHC.Generics-import Generic.Data.Function.Common.Generic-import Generic.Data.Function.Common.Generic.Meta import Generic.Data.Function.Traverse.Constructor+import Generic.Data.MetaParse.Cstr+import GHC.Exts ( proxy# ) -import Data.Text ( Text ) import Control.Applicative qualified as Applicative import Control.Applicative ( Alternative((<|>)) ) --- | Sum type monads that can be generically 'traverse'd.-class GenericTraverse tag => GenericTraverseSum tag where-    -- | Try to parse a prefix tag of type 'pt'.-    ---    -- Relevant metadata is provided as arguments.-    genericTraverseSumPfxTagAction-        :: GenericTraverseC tag pt-        => String   -- ^ data type name-        -> GenericTraverseF tag pt--    -- | Parse error due to no constructor matching the parsed prefix tag.-    ---    -- Relevant metadata is provided as arguments.-    genericTraverseSumNoMatchingCstrAction-        :: String   -- ^ data type name-        -> [String] -- ^ non-matching constructor names-        -> Text     -- ^ prefix tag, prettified-        -> GenericTraverseF tag a---- | How to use a type as a prefix tag in a generic sum type parser.-data PfxTagCfg a = PfxTagCfg-  { pfxTagCfgFromCstr :: String -> a-  -- ^ How to turn a constructor name into a prefix tag.--  , pfxTagCfgEq :: a -> a -> Bool-  -- ^ How to compare prefix tags for equality.-  ---  -- By shoving this into our generic derivation config, we can avoid adding an-  -- insidious 'Eq' constraint. In general, you will want to set this to '(==)'.--  , pfxTagCfgShow :: a -> Text-  -- ^ Make a prefix tag human-readable. 'show' is often appropriate.-  }+import Generic.Data.Function.Common.TypeLits ( symbolVal'' )+import GHC.TypeLits ( Symbol, KnownSymbol ) -class GTraverseSum tag gf where-    -- have to stuff pt constraint in here because we can't access pt externally+class GTraverseSum tag sumtag gf where     gTraverseSum-        :: GenericTraverseC tag pt-        => PfxTagCfg pt -> GenericTraverseF tag (gf p)+        :: ParseCstrTo sumtag pt+        -> (String -> GenericTraverseF tag pt)+        -> (forall a. String -> GenericTraverseF tag a)+        -> (pt -> pt -> Bool)+        -> GenericTraverseF tag (gf p) -instance GenericTraverse tag => GTraverseSum tag V1 where-    gTraverseSum _ = genericTraverseV1 @tag+instance GenericTraverse tag => GTraverseSum tag sumtag V1 where+    gTraverseSum _parseCstr _ptGet _fNoMatch _ptEq =+        genericTraverseV1 @tag --- | Test all constructors of the given non-void data type; if they all fail,---   run a failure action and pass it all the constructors names in the type. instance-  ( Alternative (GenericTraverseF tag)-  , Monad (GenericTraverseF tag)-  , GenericTraverseSum tag, GTraverseCSum tag cd gf-  , Datatype cd-  , KnownSymbols (CstrNames gf)-  ) => GTraverseSum tag (D1 cd gf) where-    gTraverseSum ptc = do-        pt <- genericTraverseSumPfxTagAction @tag cd-        M1 <$> (gTraverseCSum @tag @cd ptc pt <|> parseErrorNoMatch pt)+  ( f ~ GenericTraverseF tag+  , Alternative f+  , Monad f+  , KnownSymbol dtName+  , GTraverseCSum tag sumtag dtName gf+  ) => GTraverseSum tag sumtag (D1 (MetaData dtName _md2 _md3 _md4) gf) where+    gTraverseSum parseCstr ptGet fNoMatch ptEq = do+        pt <- ptGet dtName+        M1 <$>+            (     gTraverseCSum @tag @sumtag @dtName parseCstr ptEq pt+              <|> fNoMatch dtName)       where-        cd = datatypeName' @cd-        parseErrorNoMatch pt =-            genericTraverseSumNoMatchingCstrAction @tag cd testedCstrs-                ((pfxTagCfgShow ptc) pt)-        testedCstrs = symbolVals @(CstrNames gf)+        dtName = symbolVal'' @dtName -class GTraverseCSum tag cd gf where-    gTraverseCSum :: PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)+class GTraverseCSum tag sumtag (dtName :: Symbol) gf where+    gTraverseCSum+        :: ParseCstrTo sumtag pt+        -> (pt -> pt -> Bool)+        -> pt+        -> GenericTraverseF tag (gf p)  -- | Combine constructor options with '(<|>)' ("or"). instance   ( Alternative (GenericTraverseF tag)-  , GTraverseCSum tag cd l-  , GTraverseCSum tag cd r-  ) => GTraverseCSum tag cd (l :+: r) where-    gTraverseCSum ptc pt = l <|> r+  , GTraverseCSum tag sumtag dtName l+  , GTraverseCSum tag sumtag dtName r+  ) => GTraverseCSum tag sumtag dtName (l :+: r) where+    gTraverseCSum parseCstr ptEq pt = l <|> r       where-        l = L1 <$> gTraverseCSum @tag @cd ptc pt-        r = R1 <$> gTraverseCSum @tag @cd ptc pt+        l = L1 <$> gTraverseCSum @tag @sumtag @dtName parseCstr ptEq pt+        r = R1 <$> gTraverseCSum @tag @sumtag @dtName parseCstr ptEq pt --- | 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 tag cd cc 0 gf, Constructor cc-  ) => GTraverseCSum tag cd (C1 cc gf) where-    gTraverseCSum ptc pt = do-        if   (pfxTagCfgEq ptc) pt ptCstr-        then M1 <$> gTraverseC @tag @cd @cc @0+  , GTraverseC tag dtName cstrName 0 gf+  , ReifyCstrParseResult sumtag cstrParsed+  , ForceGCParse dtName cstr (ParseCstr sumtag cstrName) ~ cstrParsed+  ) => GTraverseCSum tag sumtag dtName (C1 (MetaCons cstrName _mc2 _mc3) gf) where+    gTraverseCSum parseCstr ptEq pt = do+        if   ptEq pt ptCstr+        then M1 <$> gTraverseC @tag @dtName @cstrName @0         else Applicative.empty       where-        ptCstr = (pfxTagCfgFromCstr ptc) (conName' @cc)+        ptCstr = parseCstr (proxy# @cstrParsed)

@@ -0,0 +1,84 @@+{-# LANGUAGE TemplateHaskell #-} -- due to GHC bug+{-# LANGUAGE UndecidableInstances #-} -- required below GHC 9.6++{- | Definitions for parsing data type constructor names on the type level.++Classically, when doing 'GHC.Generic.Generic' programming in Haskell that+inspects data type metadata such as constructor and record names, we reify these+early and do any parsing etc. on the term level. Constant folding should compute+much of this at compile time, so performance isn't really a worry. But if you're+doing failable operations such as parsing, you can't catch failures at compile+time.++This module provides definitions for parsing constructor names on the type+level, and is used internally in sum type generics. But wait, how do you write a+type-level string parser? That's now feasible-- see the Symparsec library :)+-}++module Generic.Data.MetaParse.Cstr+  ( CstrParser(..)+  , CstrParser'(..)+  , ForceGCParse+  , Raw+  , ParseCstrTo+  ) where++import Generic.Data.MetaParse.Internal+import Data.Kind ( type Constraint )+import GHC.TypeLits ( type Symbol, KnownSymbol )+import GHC.TypeLits ( ErrorMessage(..), type TypeError )+import GHC.Exts ( Proxy# )++-- | Constructor name parse result demotion function using 'Proxy#'.+type ParseCstrTo tag r =+       forall (x :: CstrParseResult tag)+    .  ReifyCstrParseResult tag x+    => Proxy# x -> r++-- | Types defining constructor name parsers.+--+-- When defining instances of these two classes, ensure that you place an empty+-- TH splice e.g. @$(pure [])@ between the instances. This is due to a GHC bug.+class CstrParser' tag => CstrParser tag where+    -- | Constructor name parser.+    --+    -- The Symparsec library generates type families that look like this. See+    -- "Generic.Data.Cstr.Parser.Symparsec" for handy definitions.+    type ParseCstr tag (str :: Symbol)+        :: Either ErrorMessage (CstrParseResult tag)++    -- | Constraint enabling reification of the parsed type-level constructor+    --   name.+    --+    -- For example, you might reify @'(a, b) :: (Symbol, Symbol)@ with+    -- @(KnownSymbol a, KnownSymbol b)@.+    type ReifyCstrParseResult tag (x :: CstrParseResult tag) :: Constraint++-- | Types defining constructor name parsers (inner class).+--+-- We're forced to separate this associated type family from the other class due+-- to GHC complaining "type constructor cannot be used here (it is defined and+-- used in the same recursive group)".+--+-- When defining instances of these two classes, ensure that you place an empty+-- TH splice e.g. @$(pure [])@ between the instances. This is due to a GHC bug.+class CstrParser' tag where+    -- | Result kind of the constructor name parser.+    type CstrParseResult tag :: k++-- | Unwrap a generic constructor parse result. Emits a 'TypeError' on parse+--   failure.+type ForceGCParse :: Symbol -> Symbol -> Either ErrorMessage k -> k+type family ForceGCParse dtName cstr a where+    ForceGCParse _      _    (Right a) = a+    ForceGCParse dtName cstr (Left  e) = TypeError+      ( Text "error while parsing "+        :<>: Text dtName :<>: Text "." :<>: Text cstr :<>: Text ":"+        :$$: e+      )++instance CstrParser' Raw where type CstrParseResult Raw = Symbol+$(pure [])+instance CstrParser  Raw where+    type ParseCstr Raw str = Right str+    type ReifyCstrParseResult Raw str = KnownSymbol str

@@ -0,0 +1,4 @@+module Generic.Data.MetaParse.Internal where++-- | Type-level parser tag. Return the string unparsed.+data Raw

@@ -4,15 +4,23 @@  import GHC.TypeLits ( ErrorMessage(Text) ) +-- | Free generic wrapper where every field does "nothing" (e.g. 'mempty'.)+--+-- Maybe useful for testing?+data EmptyRec0 (a :: k)+ -- | Free generic wrapper where any field emits a type error. -- -- Useful for generic functions on void or enum types.+--+-- Note that the type you use here must still fulfill any requirements e.g. for+-- generic @foldMap@, it must be a 'Monoid', even though the instance won't be+-- used. We could perhaps falsify these requirements with some dictionary+-- cleverness, which would make using this a little easier. But I think it would+-- be in bad taste.+--+-- Consider it a further-limited 'EmptyRec0'. 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)

@@ -0,0 +1,38 @@+{-# LANGUAGE UndecidableInstances #-}++module Generic.Type.CstrPath+  ( type GCstrPath+  , GCstrChoice(..)+  ) where++import GHC.Generics+import GHC.TypeLits+import Data.Type.Bool ( type If )+import Data.Type.Equality ( type (==) )+import Data.Kind ( type Type )++-- | Which direction to take at a ':+:' constructor choice.+data GCstrChoice = GoL1 -- ^ left  (the 'L1' constructor)+                 | GoR1 -- ^ right (the 'R1' constructor)++-- | Get the path to a named constructor in a generic type representation.+--+-- The D1 meta must already be stripped.+type GCstrPath :: Symbol -> (k -> Type) -> Either ErrorMessage [GCstrChoice]+type family GCstrPath name gf where+    -- handle the V1 case early so we don't have to keep checking later+    GCstrPath name V1 = Left (Text "type is empty (no constructors)")+    GCstrPath name gf = GCstrPath' name '[ '( '[], gf)]++type family GCstrPath' name zippers where+    GCstrPath' name ('(bcs, (l :+: r)) : zippers) =+        GCstrPath' name ('((GoL1 : bcs), l) : '((GoR1 : bcs), r) : zippers)+    GCstrPath' name ('(bcs, (C1 (MetaCons name' _ _) _)) : zippers) =+        If (name == name') (Right (Reverse bcs)) (GCstrPath' name zippers)+    GCstrPath' name '[] = Left (Text "no matching constructor")++-- | Reverse a type level list.+type Reverse as = Reverse' as '[]+type family Reverse' (as :: [k]) (acc :: [k]) :: [k] where+  Reverse' '[]      acc = acc+  Reverse' (a : as) acc = Reverse' as (a : acc)