{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
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(type GenericTraverseF, type GenericTraverseC)
)
import Generic.Data.Rep.Error
import Generic.Data.Function.Common
import Data.Text ( Text )
import Control.Applicative qualified as Applicative
import Control.Applicative ( Alternative((<|>)) )
class GenericTraverse tag => GenericTraverseSum tag where
genericTraverseSumPfxTagAction
:: GenericTraverseC tag pt
=> String
-> GenericTraverseF tag pt
genericTraverseSumNoMatchingCstrAction
:: String
-> [String]
-> Text
-> GenericTraverseF tag a
data PfxTagCfg a = PfxTagCfg
{ forall a. PfxTagCfg a -> String -> a
pfxTagCfgFromCstr :: String -> a
, forall a. PfxTagCfg a -> a -> a -> Bool
pfxTagCfgEq :: a -> a -> Bool
, forall a. PfxTagCfg a -> a -> Text
pfxTagCfgShow :: a -> Text
}
class GTraverseSum (opts :: SumOpts) cd tag gf where
gTraverseSum
:: GenericTraverseC tag pt
=> PfxTagCfg pt -> GenericTraverseF tag (gf p)
instance
( GenericTraverseSum tag, GTraverseCSum cd tag (l :+: r), Datatype cd
, Alternative (GenericTraverseF tag)
, Monad (GenericTraverseF tag)
) => GTraverseSum opts cd tag (l :+: r) where
gTraverseSum :: forall pt (p :: k).
GenericTraverseC tag pt =>
PfxTagCfg pt -> GenericTraverseF tag ((:+:) l r p)
gTraverseSum = forall (cd :: k) (tag :: k) (gf :: k -> Type) pt.
(GenericTraverseC tag pt, Alternative (GenericTraverseF tag),
Monad (GenericTraverseF tag), GenericTraverseSum tag,
GTraverseCSum cd tag gf, Datatype cd) =>
PfxTagCfg pt -> GenericTraverseF tag (gf p)
forall {k} {k} {k} {p :: k} (cd :: k) (tag :: k) (gf :: k -> Type)
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' @cd @tag
gTraverseSum'
:: 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' :: forall {k} {k} {k} {p :: k} (cd :: k) (tag :: k) (gf :: k -> Type)
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' PfxTagCfg pt
ptc = do
pt
pt <- forall (tag :: k) pt.
(GenericTraverseSum tag, GenericTraverseC tag pt) =>
String -> GenericTraverseF tag pt
forall {k} (tag :: k) pt.
(GenericTraverseSum tag, GenericTraverseC tag pt) =>
String -> GenericTraverseF tag pt
genericTraverseSumPfxTagAction @tag String
cd
forall (cd :: k) (tag :: k) (gf :: k -> Type) pt (p :: k).
GTraverseCSum cd tag gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
forall {k} {k} {k} (cd :: k) (tag :: k) (gf :: k -> Type) pt
(p :: k).
GTraverseCSum cd tag gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
gTraverseCSum @cd @tag PfxTagCfg pt
ptc pt
pt GenericTraverseF tag (gf p)
-> GenericTraverseF tag (gf p) -> GenericTraverseF tag (gf p)
forall a.
GenericTraverseF tag a
-> GenericTraverseF tag a -> GenericTraverseF tag a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> pt -> GenericTraverseF tag (gf p)
parseErrorNoMatch pt
pt
where
cd :: String
cd = forall (d :: k). Datatype d => String
forall {k} (d :: k). Datatype d => String
datatypeName' @cd
parseErrorNoMatch :: pt -> GenericTraverseF tag (gf p)
parseErrorNoMatch pt
pt =
forall (tag :: k) a.
GenericTraverseSum tag =>
String -> [String] -> Text -> GenericTraverseF tag a
forall {k} (tag :: k) a.
GenericTraverseSum tag =>
String -> [String] -> Text -> GenericTraverseF tag a
genericTraverseSumNoMatchingCstrAction @tag String
cd [String]
forall {a}. [a]
testedCstrs ((PfxTagCfg pt -> pt -> Text
forall a. PfxTagCfg a -> a -> Text
pfxTagCfgShow PfxTagCfg pt
ptc) pt
pt)
testedCstrs :: [a]
testedCstrs = []
instance GTraverseSum 'SumOnly cd tag (C1 cc gf) where
gTraverseSum :: forall pt (p :: k).
GenericTraverseC tag pt =>
PfxTagCfg pt -> GenericTraverseF tag (C1 cc gf p)
gTraverseSum = String -> PfxTagCfg pt -> GenericTraverseF tag (C1 cc gf p)
forall a. HasCallStack => String -> a
error String
eNeedSum
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 :: forall pt (p :: k).
GenericTraverseC tag pt =>
PfxTagCfg pt -> GenericTraverseF tag (C1 cc gf p)
gTraverseSum = forall (cd :: k) (tag :: k) (gf :: k -> Type) pt.
(GenericTraverseC tag pt, Alternative (GenericTraverseF tag),
Monad (GenericTraverseF tag), GenericTraverseSum tag,
GTraverseCSum cd tag gf, Datatype cd) =>
PfxTagCfg pt -> GenericTraverseF tag (gf p)
forall {k} {k} {k} {p :: k} (cd :: k) (tag :: k) (gf :: k -> Type)
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' @cd @tag
instance GTraverseSum opts cd tag V1 where
gTraverseSum :: forall pt (p :: k).
GenericTraverseC tag pt =>
PfxTagCfg pt -> GenericTraverseF tag (V1 p)
gTraverseSum = String -> PfxTagCfg pt -> GenericTraverseF tag (V1 p)
forall a. HasCallStack => String -> a
error String
eNoEmpty
class GTraverseCSum cd tag gf where
gTraverseCSum :: PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
instance
( Alternative (GenericTraverseF tag)
, GTraverseCSum cd tag l
, GTraverseCSum cd tag r
) => GTraverseCSum cd tag (l :+: r) where
gTraverseCSum :: forall pt (p :: k).
PfxTagCfg pt -> pt -> GenericTraverseF tag ((:+:) l r p)
gTraverseCSum PfxTagCfg pt
ptc pt
pt = GenericTraverseF tag ((:+:) l r p)
l GenericTraverseF tag ((:+:) l r p)
-> GenericTraverseF tag ((:+:) l r p)
-> GenericTraverseF tag ((:+:) l r p)
forall a.
GenericTraverseF tag a
-> GenericTraverseF tag a -> GenericTraverseF tag a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> GenericTraverseF tag ((:+:) l r p)
r
where
l :: GenericTraverseF tag ((:+:) l r p)
l = l p -> (:+:) l r p
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
f p -> (:+:) f g p
L1 (l p -> (:+:) l r p)
-> GenericTraverseF tag (l p) -> GenericTraverseF tag ((:+:) l r p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (cd :: k) (tag :: k) (gf :: k -> Type) pt (p :: k).
GTraverseCSum cd tag gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
forall {k} {k} {k} (cd :: k) (tag :: k) (gf :: k -> Type) pt
(p :: k).
GTraverseCSum cd tag gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
gTraverseCSum @cd @tag PfxTagCfg pt
ptc pt
pt
r :: GenericTraverseF tag ((:+:) l r p)
r = r p -> (:+:) l r p
forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
g p -> (:+:) f g p
R1 (r p -> (:+:) l r p)
-> GenericTraverseF tag (r p) -> GenericTraverseF tag ((:+:) l r p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (cd :: k) (tag :: k) (gf :: k -> Type) pt (p :: k).
GTraverseCSum cd tag gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
forall {k} {k} {k} (cd :: k) (tag :: k) (gf :: k -> Type) pt
(p :: k).
GTraverseCSum cd tag gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
gTraverseCSum @cd @tag PfxTagCfg pt
ptc pt
pt
instance
( Alternative (GenericTraverseF tag)
, GTraverseC cd cc 0 tag gf, Constructor cc
) => GTraverseCSum cd tag (C1 cc gf) where
gTraverseCSum :: forall pt (p :: k).
PfxTagCfg pt -> pt -> GenericTraverseF tag (C1 cc gf p)
gTraverseCSum PfxTagCfg pt
ptc pt
pt = do
if (PfxTagCfg pt -> pt -> pt -> Bool
forall a. PfxTagCfg a -> a -> a -> Bool
pfxTagCfgEq PfxTagCfg pt
ptc) pt
pt pt
ptCstr
then gf p -> C1 cc gf p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (gf p -> C1 cc gf p)
-> GenericTraverseF tag (gf p) -> GenericTraverseF tag (C1 cc gf p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (cd :: k) (cc :: Meta) (si :: Natural) (tag :: k)
(gf :: k -> Type) (p :: k).
GTraverseC cd cc si tag gf =>
GenericTraverseF tag (gf p)
forall {k} {k1} {k2} {k3} (cd :: k) (cc :: k1) (si :: Natural)
(tag :: k2) (gf :: k3 -> Type) (p :: k3).
GTraverseC cd cc si tag gf =>
GenericTraverseF tag (gf p)
gTraverseC @cd @cc @0 @tag
else GenericTraverseF tag (C1 cc gf p)
forall a. GenericTraverseF tag a
forall (f :: Type -> Type) a. Alternative f => f a
Applicative.empty
where
ptCstr :: pt
ptCstr = (PfxTagCfg pt -> String -> pt
forall a. PfxTagCfg a -> String -> a
pfxTagCfgFromCstr PfxTagCfg pt
ptc) (forall {k} (c :: k). Constructor c => String
forall (c :: Meta). Constructor c => String
conName' @cc)