{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
module Generic.Data.Function.Traverse.Sum where
import GHC.Generics
import GHC.TypeLits ( TypeError )
import Generic.Data.Function.Util.Generic ( datatypeName', conName' )
import Generic.Data.Function.Error ( type ENoEmpty, type EUnexpectedNonSum )
import Generic.Data.Function.Traverse.Constructor ( GTraverseC(gTraverseC), GenericTraverse(..) )
import Data.Text ( Text )
import Control.Applicative qualified as Applicative
import Control.Applicative ( Alternative((<|>)) )
class (GenericTraverse f, Alternative f, Monad f) => GenericTraverseSum f where
genericTraverseSumPfxTagAction
:: GenericTraverseC f pt
=> String
-> f pt
genericTraverseSumNoMatchingCstrAction
:: String
-> [String]
-> Text
-> f 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 f f' where
gTraverseSum :: GenericTraverseC f pt => PfxTagCfg pt -> f (f' p)
instance (Functor f, GTraverseSum' cd f f') => GTraverseSum f (D1 cd f') where
gTraverseSum :: forall pt (p :: k).
GenericTraverseC f pt =>
PfxTagCfg pt -> f (D1 cd f' p)
gTraverseSum PfxTagCfg pt
pt = forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} {k} (cd :: k) (f :: Type -> Type) (f' :: k -> Type) pt
(p :: k).
(GTraverseSum' cd f f', GenericTraverseC f pt) =>
PfxTagCfg pt -> f (f' p)
gTraverseSum' @cd PfxTagCfg pt
pt
class GTraverseSum' cd f f' where
gTraverseSum' :: GenericTraverseC f pt => PfxTagCfg pt -> f (f' p)
instance (GenericTraverseSum f, GTraverseCSum cd f (l :+: r), Datatype cd)
=> GTraverseSum' cd f (l :+: r) where
gTraverseSum' :: forall pt (p :: k).
GenericTraverseC f pt =>
PfxTagCfg pt -> f ((:+:) l r p)
gTraverseSum' PfxTagCfg pt
ptc = do
pt
pt <- forall (f :: Type -> Type) pt.
(GenericTraverseSum f, GenericTraverseC f pt) =>
String -> f pt
genericTraverseSumPfxTagAction String
cd
forall {k} {k} {k} (cd :: k) (f :: k -> Type) (f' :: k -> k) pt
(p :: k).
GTraverseCSum cd f f' =>
PfxTagCfg pt -> pt -> f (f' p)
gTraverseCSum @cd PfxTagCfg pt
ptc pt
pt forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> pt -> f ((:+:) l r p)
parseErrorNoMatch pt
pt
where
cd :: String
cd = forall {k} (d :: k). Datatype d => String
datatypeName' @cd
parseErrorNoMatch :: pt -> f ((:+:) l r p)
parseErrorNoMatch pt
pt =
forall (f :: Type -> Type) a.
GenericTraverseSum f =>
String -> [String] -> Text -> f a
genericTraverseSumNoMatchingCstrAction String
cd forall {a}. [a]
testedCstrs ((forall a. PfxTagCfg a -> a -> Text
pfxTagCfgShow PfxTagCfg pt
ptc) pt
pt)
testedCstrs :: [a]
testedCstrs = []
instance TypeError EUnexpectedNonSum => GTraverseSum' cd f (C1 cc f') where
gTraverseSum' :: forall pt (p :: k).
GenericTraverseC f pt =>
PfxTagCfg pt -> f (C1 cc f' p)
gTraverseSum' = forall a. HasCallStack => a
undefined
instance TypeError ENoEmpty => GTraverseSum' cd f V1 where
gTraverseSum' :: forall pt (p :: k).
GenericTraverseC f pt =>
PfxTagCfg pt -> f (V1 p)
gTraverseSum' = forall a. HasCallStack => a
undefined
class GTraverseCSum cd f f' where
gTraverseCSum :: PfxTagCfg pt -> pt -> f (f' p)
instance (Functor f, Alternative f, GTraverseCSum cd f l, GTraverseCSum cd f r)
=> GTraverseCSum cd f (l :+: r) where
gTraverseCSum :: forall pt (p :: k). PfxTagCfg pt -> pt -> f ((:+:) l r p)
gTraverseCSum PfxTagCfg pt
ptc pt
pt = f ((:+:) l r p)
l forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> f ((:+:) l r p)
r
where
l :: f ((:+:) l r p)
l = forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
f p -> (:+:) f g p
L1 forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} {k} {k} (cd :: k) (f :: k -> Type) (f' :: k -> k) pt
(p :: k).
GTraverseCSum cd f f' =>
PfxTagCfg pt -> pt -> f (f' p)
gTraverseCSum @cd PfxTagCfg pt
ptc pt
pt
r :: f ((:+:) l r p)
r = forall k (f :: k -> Type) (g :: k -> Type) (p :: k).
g p -> (:+:) f g p
R1 forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} {k} {k} (cd :: k) (f :: k -> Type) (f' :: k -> k) pt
(p :: k).
GTraverseCSum cd f f' =>
PfxTagCfg pt -> pt -> f (f' p)
gTraverseCSum @cd PfxTagCfg pt
ptc pt
pt
instance (Alternative f, GTraverseC cd cc 0 f f', Constructor cc)
=> GTraverseCSum cd f (C1 cc f') where
gTraverseCSum :: forall pt (p :: k). PfxTagCfg pt -> pt -> f (C1 cc f' p)
gTraverseCSum PfxTagCfg pt
ptc pt
pt = do
if (forall a. PfxTagCfg a -> a -> a -> Bool
pfxTagCfgEq PfxTagCfg pt
ptc) pt
pt pt
ptCstr
then forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} {k} {k} {k} (cd :: k) (cc :: k) (si :: Natural)
(f :: k -> Type) (f' :: k -> k) (p :: k).
GTraverseC cd cc si f f' =>
f (f' p)
gTraverseC @cd @cc @0
else forall (f :: Type -> Type) a. Alternative f => f a
Applicative.empty
where
ptCstr :: pt
ptCstr = (forall a. PfxTagCfg a -> String -> a
pfxTagCfgFromCstr PfxTagCfg pt
ptc) (forall {k} (c :: k). Constructor c => String
conName' @cc)