{-# LANGUAGE UndecidableInstances #-} -- due to type hell
{-# LANGUAGE AllowAmbiguousTypes  #-} -- due to generic typeclass design

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 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
  { forall a. PfxTagCfg a -> String -> a
pfxTagCfgFromCstr :: String -> a
  -- ^ How to turn a constructor name into a prefix tag.

  , forall a. PfxTagCfg a -> a -> a -> Bool
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 '(==)'.

  , forall a. PfxTagCfg a -> a -> Text
pfxTagCfgShow :: a -> Text
  -- ^ Make a prefix tag human-readable. 'show' is often appropriate.
  }

class GTraverseSum tag gf where
    -- have to stuff pt constraint in here because we can't access pt externally
    gTraverseSum
        :: GenericTraverseC tag pt
        => PfxTagCfg pt -> GenericTraverseF tag (gf p)

instance GenericTraverse tag => GTraverseSum tag V1 where
    gTraverseSum :: forall pt (p :: k).
GenericTraverseC tag pt =>
PfxTagCfg pt -> GenericTraverseF tag (V1 p)
gTraverseSum PfxTagCfg pt
_ = 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

-- | 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 :: forall pt (p :: k).
GenericTraverseC tag pt =>
PfxTagCfg pt -> GenericTraverseF tag (D1 cd 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
        gf p -> D1 cd gf p
forall k i (c :: Meta) (f :: k -> Type) (p :: k). f p -> M1 i c f p
M1 (gf p -> D1 cd gf p)
-> GenericTraverseF tag (gf p) -> GenericTraverseF tag (D1 cd gf p)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (tag :: k) (cd :: Meta) (gf :: k -> Type) pt (p :: k).
GTraverseCSum tag cd gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
forall {k} {k} {k} (tag :: k) (cd :: k) (gf :: k -> Type) pt
       (p :: k).
GTraverseCSum tag cd gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
gTraverseCSum @tag @cd 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 {k} (d :: k). Datatype d => String
forall (d :: Meta). 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]
testedCstrs
                ((PfxTagCfg pt -> pt -> Text
forall a. PfxTagCfg a -> a -> Text
pfxTagCfgShow PfxTagCfg pt
ptc) pt
pt)
        testedCstrs :: [String]
testedCstrs = forall (as :: [Symbol]). KnownSymbols as => [String]
forall {k} (as :: k). KnownSymbols as => [String]
symbolVals @(CstrNames gf)

class GTraverseCSum tag cd gf where
    gTraverseCSum :: PfxTagCfg pt -> 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 :: 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 (tag :: k) (cd :: k) (gf :: k -> Type) pt (p :: k).
GTraverseCSum tag cd gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
forall {k} {k} {k} (tag :: k) (cd :: k) (gf :: k -> Type) pt
       (p :: k).
GTraverseCSum tag cd gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
gTraverseCSum @tag @cd 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 (tag :: k) (cd :: k) (gf :: k -> Type) pt (p :: k).
GTraverseCSum tag cd gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
forall {k} {k} {k} (tag :: k) (cd :: k) (gf :: k -> Type) pt
       (p :: k).
GTraverseCSum tag cd gf =>
PfxTagCfg pt -> pt -> GenericTraverseF tag (gf p)
gTraverseCSum @tag @cd PfxTagCfg pt
ptc pt
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 :: 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 (tag :: k) (cd :: k) (cc :: Meta) (si :: Natural)
       (gf :: k -> Type) (p :: k).
GTraverseC tag cd cc si gf =>
GenericTraverseF tag (gf p)
forall {k} {k1} {k2} {k3} (tag :: k) (cd :: k1) (cc :: k2)
       (si :: Natural) (gf :: k3 -> Type) (p :: k3).
GTraverseC tag cd cc si gf =>
GenericTraverseF tag (gf p)
gTraverseC @tag @cd @cc @0
        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)