{-# 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.Traverse.Constructor
import Generic.Data.MetaParse.Cstr
import GHC.Exts ( proxy# )

import Control.Applicative qualified as Applicative
import Control.Applicative ( Alternative((<|>)) )

import Generic.Data.Function.Common.TypeLits ( symbolVal'' )
import GHC.TypeLits ( Symbol, KnownSymbol )

class GTraverseSum tag sumtag gf where
    gTraverseSum
        :: 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 sumtag V1 where
    gTraverseSum :: forall pt (p :: k).
ParseCstrTo sumtag pt
-> (String -> GenericTraverseF tag pt)
-> (forall a. String -> GenericTraverseF tag a)
-> (pt -> pt -> Bool)
-> GenericTraverseF tag (V1 p)
gTraverseSum ParseCstrTo sumtag pt
_parseCstr String -> GenericTraverseF tag pt
_ptGet forall a. String -> GenericTraverseF tag a
_fNoMatch pt -> pt -> Bool
_ptEq =
        forall (tag :: k) {k1} (p :: k1).
GenericTraverse tag =>
GenericTraverseF tag (V1 p)
forall {k} (tag :: k) {k1} (p :: k1).
GenericTraverse tag =>
GenericTraverseF tag (V1 p)
genericTraverseV1 @tag

instance
  ( 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 :: forall pt (p :: k).
ParseCstrTo sumtag pt
-> (String -> GenericTraverseF tag pt)
-> (forall a. String -> GenericTraverseF tag a)
-> (pt -> pt -> Bool)
-> GenericTraverseF tag (D1 ('MetaData dtName _md2 _md3 _md4) gf p)
gTraverseSum ParseCstrTo sumtag pt
parseCstr String -> GenericTraverseF tag pt
ptGet forall a. String -> GenericTraverseF tag a
fNoMatch pt -> pt -> Bool
ptEq = do
        pt
pt <- String -> GenericTraverseF tag pt
ptGet String
dtName
        gf p -> D1 ('MetaData dtName _md2 _md3 _md4) gf p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (gf p -> D1 ('MetaData dtName _md2 _md3 _md4) gf p)
-> f (gf p) -> f (D1 ('MetaData dtName _md2 _md3 _md4) gf p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
            (     forall (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) pt (p :: k).
GTraverseCSum tag sumtag dtName gf =>
ParseCstrTo sumtag pt
-> (pt -> pt -> Bool) -> pt -> GenericTraverseF tag (gf p)
forall {k} {k} {k} (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) pt (p :: k).
GTraverseCSum tag sumtag dtName gf =>
ParseCstrTo sumtag pt
-> (pt -> pt -> Bool) -> pt -> GenericTraverseF tag (gf p)
gTraverseCSum @tag @sumtag @dtName Proxy# x -> pt
ParseCstrTo sumtag pt
parseCstr pt -> pt -> Bool
ptEq pt
pt
              f (gf p) -> f (gf p) -> f (gf p)
forall a. f a -> f a -> f a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> String -> GenericTraverseF tag (gf p)
forall a. String -> GenericTraverseF tag a
fNoMatch String
dtName)
      where
        dtName :: String
dtName = forall (sym :: Symbol). KnownSymbol sym => String
symbolVal'' @dtName

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 sumtag dtName l
  , GTraverseCSum tag sumtag dtName r
  ) => GTraverseCSum tag sumtag dtName (l :+: r) where
    gTraverseCSum :: forall pt (p :: k).
ParseCstrTo sumtag pt
-> (pt -> pt -> Bool) -> pt -> GenericTraverseF tag ((:+:) l r p)
gTraverseCSum ParseCstrTo sumtag pt
parseCstr pt -> pt -> Bool
ptEq 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 (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) pt (p :: k).
GTraverseCSum tag sumtag dtName gf =>
ParseCstrTo sumtag pt
-> (pt -> pt -> Bool) -> pt -> GenericTraverseF tag (gf p)
forall {k} {k} {k} (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) pt (p :: k).
GTraverseCSum tag sumtag dtName gf =>
ParseCstrTo sumtag pt
-> (pt -> pt -> Bool) -> pt -> GenericTraverseF tag (gf p)
gTraverseCSum @tag @sumtag @dtName Proxy# x -> pt
ParseCstrTo sumtag pt
parseCstr pt -> pt -> Bool
ptEq 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 (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) pt (p :: k).
GTraverseCSum tag sumtag dtName gf =>
ParseCstrTo sumtag pt
-> (pt -> pt -> Bool) -> pt -> GenericTraverseF tag (gf p)
forall {k} {k} {k} (tag :: k) (sumtag :: k) (dtName :: Symbol)
       (gf :: k -> Type) pt (p :: k).
GTraverseCSum tag sumtag dtName gf =>
ParseCstrTo sumtag pt
-> (pt -> pt -> Bool) -> pt -> GenericTraverseF tag (gf p)
gTraverseCSum @tag @sumtag @dtName Proxy# x -> pt
ParseCstrTo sumtag pt
parseCstr pt -> pt -> Bool
ptEq pt
pt

instance
  ( Alternative (GenericTraverseF tag)
  , 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 :: forall pt (p :: k).
ParseCstrTo sumtag pt
-> (pt -> pt -> Bool)
-> pt
-> GenericTraverseF tag (C1 ('MetaCons cstrName _mc2 _mc3) gf p)
gTraverseCSum ParseCstrTo sumtag pt
parseCstr pt -> pt -> Bool
ptEq pt
pt = do
        if   pt -> pt -> Bool
ptEq pt
pt pt
ptCstr
        then gf p -> C1 ('MetaCons cstrName _mc2 _mc3) gf p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (gf p -> C1 ('MetaCons cstrName _mc2 _mc3) gf p)
-> GenericTraverseF tag (gf p)
-> GenericTraverseF tag (C1 ('MetaCons cstrName _mc2 _mc3) gf p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tag :: k) (cd :: Symbol) (cc :: Symbol) (si :: Natural)
       (gf :: k -> Type) (p :: k).
GTraverseC tag cd cc si gf =>
GenericTraverseF tag (gf p)
forall {k} {k1} (tag :: k) (cd :: Symbol) (cc :: Symbol)
       (si :: Natural) (gf :: k1 -> Type) (p :: k1).
GTraverseC tag cd cc si gf =>
GenericTraverseF tag (gf p)
gTraverseC @tag @dtName @cstrName @0
        else GenericTraverseF tag (C1 ('MetaCons cstrName _mc2 _mc3) gf p)
forall a. GenericTraverseF tag a
forall (f :: Type -> Type) a. Alternative f => f a
Applicative.empty
      where
        ptCstr :: pt
ptCstr = Proxy# cstrParsed -> pt
ParseCstrTo sumtag pt
parseCstr (forall {k} (a :: k). Proxy# a
forall (a :: CstrParseResult sumtag). Proxy# a
proxy# @cstrParsed)