{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE UndecidableInstances #-}

module Web.Hyperbole.Data.Encoded where

import Data.Aeson (FromJSON (..), ToJSON (..), Value (..))
import Data.Aeson qualified as A
import Data.Attoparsec.ByteString qualified as AB
import Data.Attoparsec.ByteString.Char8 (sepBy)
import Data.Attoparsec.ByteString.Char8 qualified as AC
import Data.Bifunctor (first)
import Data.String (IsString)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Generics
import Web.Hyperbole.Data.Argument


newtype ConName = ConName {ConName -> Text
text :: Text}
  deriving newtype (ConName -> ConName -> Bool
(ConName -> ConName -> Bool)
-> (ConName -> ConName -> Bool) -> Eq ConName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConName -> ConName -> Bool
== :: ConName -> ConName -> Bool
$c/= :: ConName -> ConName -> Bool
/= :: ConName -> ConName -> Bool
Eq, Int -> ConName -> ShowS
[ConName] -> ShowS
ConName -> String
(Int -> ConName -> ShowS)
-> (ConName -> String) -> ([ConName] -> ShowS) -> Show ConName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ConName -> ShowS
showsPrec :: Int -> ConName -> ShowS
$cshow :: ConName -> String
show :: ConName -> String
$cshowList :: [ConName] -> ShowS
showList :: [ConName] -> ShowS
Show, String -> ConName
(String -> ConName) -> IsString ConName
forall a. (String -> a) -> IsString a
$cfromString :: String -> ConName
fromString :: String -> ConName
IsString, Eq ConName
Eq ConName =>
(ConName -> ConName -> Ordering)
-> (ConName -> ConName -> Bool)
-> (ConName -> ConName -> Bool)
-> (ConName -> ConName -> Bool)
-> (ConName -> ConName -> Bool)
-> (ConName -> ConName -> ConName)
-> (ConName -> ConName -> ConName)
-> Ord ConName
ConName -> ConName -> Bool
ConName -> ConName -> Ordering
ConName -> ConName -> ConName
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ConName -> ConName -> Ordering
compare :: ConName -> ConName -> Ordering
$c< :: ConName -> ConName -> Bool
< :: ConName -> ConName -> Bool
$c<= :: ConName -> ConName -> Bool
<= :: ConName -> ConName -> Bool
$c> :: ConName -> ConName -> Bool
> :: ConName -> ConName -> Bool
$c>= :: ConName -> ConName -> Bool
>= :: ConName -> ConName -> Bool
$cmax :: ConName -> ConName -> ConName
max :: ConName -> ConName -> ConName
$cmin :: ConName -> ConName -> ConName
min :: ConName -> ConName -> ConName
Ord)
instance Semigroup ConName where
  -- Ignore the second constructor name
  ConName
c1 <> :: ConName -> ConName -> ConName
<> ConName
_ = ConName
c1
instance Monoid ConName where
  mempty :: ConName
mempty = Text -> ConName
ConName Text
""


{- | Human Readable top-level encoding for ViewAction and ViewId
For simple Sum and Product types it is equivalent to the Show/Read instance

@
MyConstructor 1 2 3
OtherConstructor "hello" 2
@
-}
data Encoded = Encoded ConName [Argument]
  deriving (Int -> Encoded -> ShowS
[Encoded] -> ShowS
Encoded -> String
(Int -> Encoded -> ShowS)
-> (Encoded -> String) -> ([Encoded] -> ShowS) -> Show Encoded
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Encoded -> ShowS
showsPrec :: Int -> Encoded -> ShowS
$cshow :: Encoded -> String
show :: Encoded -> String
$cshowList :: [Encoded] -> ShowS
showList :: [Encoded] -> ShowS
Show, Encoded -> Encoded -> Bool
(Encoded -> Encoded -> Bool)
-> (Encoded -> Encoded -> Bool) -> Eq Encoded
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Encoded -> Encoded -> Bool
== :: Encoded -> Encoded -> Bool
$c/= :: Encoded -> Encoded -> Bool
/= :: Encoded -> Encoded -> Bool
Eq, Eq Encoded
Eq Encoded =>
(Encoded -> Encoded -> Ordering)
-> (Encoded -> Encoded -> Bool)
-> (Encoded -> Encoded -> Bool)
-> (Encoded -> Encoded -> Bool)
-> (Encoded -> Encoded -> Bool)
-> (Encoded -> Encoded -> Encoded)
-> (Encoded -> Encoded -> Encoded)
-> Ord Encoded
Encoded -> Encoded -> Bool
Encoded -> Encoded -> Ordering
Encoded -> Encoded -> Encoded
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Encoded -> Encoded -> Ordering
compare :: Encoded -> Encoded -> Ordering
$c< :: Encoded -> Encoded -> Bool
< :: Encoded -> Encoded -> Bool
$c<= :: Encoded -> Encoded -> Bool
<= :: Encoded -> Encoded -> Bool
$c> :: Encoded -> Encoded -> Bool
> :: Encoded -> Encoded -> Bool
$c>= :: Encoded -> Encoded -> Bool
>= :: Encoded -> Encoded -> Bool
$cmax :: Encoded -> Encoded -> Encoded
max :: Encoded -> Encoded -> Encoded
$cmin :: Encoded -> Encoded -> Encoded
min :: Encoded -> Encoded -> Encoded
Ord)


instance Semigroup Encoded where
  Encoded ConName
c1 [Argument]
es1 <> :: Encoded -> Encoded -> Encoded
<> Encoded ConName
c2 [Argument]
es2 =
    ConName -> [Argument] -> Encoded
Encoded (ConName
c1 ConName -> ConName -> ConName
forall a. Semigroup a => a -> a -> a
<> ConName
c2) ([Argument]
es1 [Argument] -> [Argument] -> [Argument]
forall a. Semigroup a => a -> a -> a
<> [Argument]
es2)
instance Monoid Encoded where
  mempty :: Encoded
mempty = ConName -> [Argument] -> Encoded
Encoded ConName
forall a. Monoid a => a
mempty [Argument]
forall a. Monoid a => a
mempty
instance ToJSON Encoded where
  toJSON :: Encoded -> Value
toJSON Encoded
e = Text -> Value
forall a. ToJSON a => a -> Value
toJSON (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Encoded -> Text
forall a. ToEncoded a => a -> Text
encode Encoded
e
instance FromJSON Encoded where
  parseJSON :: Value -> Parser Encoded
parseJSON (String Text
t) =
    case Text -> Either String Encoded
forall a. FromEncoded a => Text -> Either String a
decodeEither Text
t of
      Left String
e -> String -> Parser Encoded
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Encoded) -> String -> Parser Encoded
forall a b. (a -> b) -> a -> b
$ String
"Encoded " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a b. ConvertibleStrings a b => a -> b
cs String
e
      Right Encoded
a -> Encoded -> Parser Encoded
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Encoded
a
  parseJSON Value
val = String -> Parser Encoded
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Encoded) -> String -> Parser Encoded
forall a b. (a -> b) -> a -> b
$ String
"Expected Encoded but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
val


encode :: (ToEncoded a) => a -> Text
encode :: forall a. ToEncoded a => a -> Text
encode a
a = Encoded -> Text
encodedToText (Encoded -> Text) -> Encoded -> Text
forall a b. (a -> b) -> a -> b
$ a -> Encoded
forall a. ToEncoded a => a -> Encoded
toEncoded a
a


decode :: (FromEncoded a) => Text -> Maybe a
decode :: forall a. FromEncoded a => Text -> Maybe a
decode Text
t = (String -> Maybe a) -> (a -> Maybe a) -> Either String a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> String -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either String a -> Maybe a) -> Either String a -> Maybe a
forall a b. (a -> b) -> a -> b
$ Text -> Either String a
forall a. FromEncoded a => Text -> Either String a
decodeEither Text
t


decodeEither :: (FromEncoded a) => Text -> Either String a
decodeEither :: forall a. FromEncoded a => Text -> Either String a
decodeEither Text
t = do
  enc <- Text -> Either String Encoded
encodedParseText Text
t
  parseEncoded enc


-- | Basic Encoding
encodedToText :: Encoded -> Text
encodedToText :: Encoded -> Text
encodedToText (Encoded ConName
con [Argument]
values) =
  Text -> [Text] -> Text
T.intercalate Text
" " (ConName
con.text Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Argument -> Text) -> [Argument] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Argument -> Text
encodeFromArgument [Argument]
values)


encodedParseText :: Text -> Either String Encoded
encodedParseText :: Text -> Either String Encoded
encodedParseText Text
inp =
  ShowS -> Either String Encoded -> Either String Encoded
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ShowS
forall a b. ConvertibleStrings a b => a -> b
cs (Either String Encoded -> Either String Encoded)
-> Either String Encoded -> Either String Encoded
forall a b. (a -> b) -> a -> b
$ Parser Encoded -> ByteString -> Either String Encoded
forall a. Parser a -> ByteString -> Either String a
AB.parseOnly Parser Encoded
encodedParser (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
inp)
 where
  encodedParser :: AB.Parser Encoded
  encodedParser :: Parser Encoded
encodedParser = do
    con <- (Char -> Bool) -> Parser ByteString
AC.takeTill Char -> Bool
AC.isSpace
    AC.skipSpace
    ps <- argumentParser `sepBy` AC.char ' '
    pure $ Encoded (ConName (cs con)) ps


genericToEncoded :: (Generic a, GToEncoded (Rep a)) => a -> Encoded
genericToEncoded :: forall a. (Generic a, GToEncoded (Rep a)) => a -> Encoded
genericToEncoded a
a = Rep a (ZonkAny 1) -> Encoded
forall p. Rep a p -> Encoded
forall {k} (f :: k -> *) (p :: k). GToEncoded f => f p -> Encoded
gToEncoded (a -> Rep a (ZonkAny 1)
forall x. a -> Rep a x
forall a x. Generic a => a -> Rep a x
from a
a)


genericParseEncoded :: (Generic a, GFromEncoded (Rep a)) => Encoded -> Either String a
genericParseEncoded :: forall a.
(Generic a, GFromEncoded (Rep a)) =>
Encoded -> Either String a
genericParseEncoded Encoded
enc = do
  (gen, _) <- Encoded -> Either String (Rep a (ZonkAny 0), [Argument])
forall p. Encoded -> Either String (Rep a p, [Argument])
forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [Argument])
gParseEncoded Encoded
enc
  pure $ to gen


genericDecode :: (Generic a, GFromEncoded (Rep a)) => Text -> Maybe a
genericDecode :: forall a. (Generic a, GFromEncoded (Rep a)) => Text -> Maybe a
genericDecode Text
t = (String -> Maybe a) -> (a -> Maybe a) -> Either String a -> Maybe a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe a -> String -> Maybe a
forall a b. a -> b -> a
const Maybe a
forall a. Maybe a
Nothing) a -> Maybe a
forall a. a -> Maybe a
Just (Either String a -> Maybe a) -> Either String a -> Maybe a
forall a b. (a -> b) -> a -> b
$ do
  enc <- Text -> Either String Encoded
encodedParseText Text
t
  genericParseEncoded enc


-- | Custom Encoding for embedding into web documents. Noteably used for 'ViewId' and 'ViewAction'
class ToEncoded a where
  toEncoded :: a -> Encoded
  default toEncoded :: (Generic a, GToEncoded (Rep a)) => a -> Encoded
  toEncoded = a -> Encoded
forall a. (Generic a, GToEncoded (Rep a)) => a -> Encoded
genericToEncoded


instance ToEncoded Encoded where
  toEncoded :: Encoded -> Encoded
toEncoded = Encoded -> Encoded
forall a. a -> a
id
instance ToEncoded () where
  toEncoded :: () -> Encoded
toEncoded ()
_ = Encoded
forall a. Monoid a => a
mempty
instance ToEncoded Argument where
  toEncoded :: Argument -> Encoded
toEncoded Argument
a = ConName -> [Argument] -> Encoded
Encoded ConName
forall a. Monoid a => a
mempty [Item [Argument]
Argument
a]
instance ToEncoded Int where
  toEncoded :: Int -> Encoded
toEncoded Int
n = Argument -> Encoded
forall a. ToEncoded a => a -> Encoded
toEncoded (Argument -> Encoded) -> Argument -> Encoded
forall a b. (a -> b) -> a -> b
$ Value -> Argument
JSON (Scientific -> Value
Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Int -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n)
instance ToEncoded Text where
  toEncoded :: Text -> Encoded
toEncoded Text
t = Argument -> Encoded
forall a. ToEncoded a => a -> Encoded
toEncoded (Argument -> Encoded) -> Argument -> Encoded
forall a b. (a -> b) -> a -> b
$ Value -> Argument
JSON (Text -> Value
String Text
t)


-- | Custom Encoding for embedding into web documents. Noteably used for 'ViewId' and 'ViewAction'
class FromEncoded a where
  parseEncoded :: Encoded -> Either String a
  default parseEncoded :: (Generic a, GFromEncoded (Rep a)) => Encoded -> Either String a
  parseEncoded = Encoded -> Either String a
forall a.
(Generic a, GFromEncoded (Rep a)) =>
Encoded -> Either String a
genericParseEncoded


instance FromEncoded Encoded where
  parseEncoded :: Encoded -> Either String Encoded
parseEncoded = Encoded -> Either String Encoded
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
instance FromEncoded () where
  parseEncoded :: Encoded -> Either String ()
parseEncoded Encoded
_ = () -> Either String ()
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
instance FromEncoded Argument where
  parseEncoded :: Encoded -> Either String Argument
parseEncoded (Encoded ConName
_ [Argument]
as) = do
    case [Argument]
as of
      [Item [Argument]
a] -> Argument -> Either String Argument
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Item [Argument]
Argument
a
      [Argument]
_ -> String -> Either String Argument
forall a b. a -> Either a b
Left (String -> Either String Argument)
-> String -> Either String Argument
forall a b. (a -> b) -> a -> b
$ String
"Expected single argument value [arg] but got: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [Argument] -> String
forall a. Show a => a -> String
show [Argument]
as
instance FromEncoded Int where
  parseEncoded :: Encoded -> Either String Int
parseEncoded Encoded
enc = do
    arg <- forall a. FromEncoded a => Encoded -> Either String a
parseEncoded @Argument Encoded
enc
    case arg of
      JSON (Number Scientific
a) -> Int -> Either String Int
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> Either String Int) -> Int -> Either String Int
forall a b. (a -> b) -> a -> b
$ Scientific -> Int
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
a
      Argument
other -> String -> Either String Int
forall a b. a -> Either a b
Left (String -> Either String Int) -> String -> Either String Int
forall a b. (a -> b) -> a -> b
$ String
"Expected Int but got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Argument -> String
forall a. Show a => a -> String
show Argument
other
instance FromEncoded Text where
  parseEncoded :: Encoded -> Either String Text
parseEncoded Encoded
enc = do
    arg <- forall a. FromEncoded a => Encoded -> Either String a
parseEncoded @Argument Encoded
enc
    case arg of
      JSON (String Text
t) -> Text -> Either String Text
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
t
      Argument
other -> String -> Either String Text
forall a b. a -> Either a b
Left (String -> Either String Text) -> String -> Either String Text
forall a b. (a -> b) -> a -> b
$ String
"Expected Text but got " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Argument -> String
forall a. Show a => a -> String
show Argument
other


fromResult :: A.Result a -> Either String a
fromResult :: forall a. Result a -> Either String a
fromResult (A.Success a
a) = a -> Either String a
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
fromResult (A.Error String
e) = String -> Either String a
forall a b. a -> Either a b
Left (ShowS
forall a b. ConvertibleStrings a b => a -> b
cs String
e)


-------------------------------------------------------------------------------
-- GENERICS
-------------------------------------------------------------------------------

-- GToEncoded: Generic ViewAction Encoding

class GToEncoded f where
  gToEncoded :: f p -> Encoded


instance (GToEncoded f, GToEncoded g) => GToEncoded (f :+: g) where
  gToEncoded :: forall (p :: k). (:+:) f g p -> Encoded
gToEncoded (L1 f p
f) = f p -> Encoded
forall (p :: k). f p -> Encoded
forall {k} (f :: k -> *) (p :: k). GToEncoded f => f p -> Encoded
gToEncoded f p
f
  gToEncoded (R1 g p
f) = g p -> Encoded
forall (p :: k). g p -> Encoded
forall {k} (f :: k -> *) (p :: k). GToEncoded f => f p -> Encoded
gToEncoded g p
f


instance (GToEncoded f, GToEncoded g) => GToEncoded (f :*: g) where
  gToEncoded :: forall (p :: k). (:*:) f g p -> Encoded
gToEncoded (f p
f :*: g p
g) =
    f p -> Encoded
forall (p :: k). f p -> Encoded
forall {k} (f :: k -> *) (p :: k). GToEncoded f => f p -> Encoded
gToEncoded f p
f Encoded -> Encoded -> Encoded
forall a. Semigroup a => a -> a -> a
<> g p -> Encoded
forall (p :: k). g p -> Encoded
forall {k} (f :: k -> *) (p :: k). GToEncoded f => f p -> Encoded
gToEncoded g p
g


instance GToEncoded U1 where
  gToEncoded :: forall (p :: k). U1 p -> Encoded
gToEncoded U1 p
U1 = Encoded
forall a. Monoid a => a
mempty


instance (GToEncoded f) => GToEncoded (M1 D d f) where
  gToEncoded :: forall (p :: k). M1 D d f p -> Encoded
gToEncoded (M1 f p
f) = f p -> Encoded
forall (p :: k). f p -> Encoded
forall {k} (f :: k -> *) (p :: k). GToEncoded f => f p -> Encoded
gToEncoded f p
f


instance (Constructor c, GToEncoded f) => GToEncoded (M1 C c f) where
  gToEncoded :: forall (p :: k). M1 C c f p -> Encoded
gToEncoded (M1 f p
f) =
    let con :: Text
con = String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (M1 C c f (ZonkAny 3) -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName (M1 C c f p
forall {p :: k}. M1 C c f p
forall a. HasCallStack => a
undefined :: M1 C c f p))
     in ConName -> [Argument] -> Encoded
Encoded (Text -> ConName
ConName Text
con) [Argument]
forall a. Monoid a => a
mempty Encoded -> Encoded -> Encoded
forall a. Semigroup a => a -> a -> a
<> f p -> Encoded
forall (p :: k). f p -> Encoded
forall {k} (f :: k -> *) (p :: k). GToEncoded f => f p -> Encoded
gToEncoded f p
f


instance (GToEncoded f) => GToEncoded (M1 S s f) where
  gToEncoded :: forall (p :: k). M1 S s f p -> Encoded
gToEncoded (M1 f p
f) = f p -> Encoded
forall (p :: k). f p -> Encoded
forall {k} (f :: k -> *) (p :: k). GToEncoded f => f p -> Encoded
gToEncoded f p
f


instance (ToJSON a) => GToEncoded (K1 R a) where
  gToEncoded :: forall (p :: k). K1 R a p -> Encoded
gToEncoded (K1 a
a) = do
    let JSON Value
val = a -> Argument
forall a. ToJSON a => a -> Argument
toArgument a
a
    ConName -> [Argument] -> Encoded
Encoded ConName
forall a. Monoid a => a
mempty [Value -> Argument
JSON Value
val]


-- GFromEncoded: Generic ViewAction Decoding

class GFromEncoded f where
  gParseEncoded :: Encoded -> Either String (f p, [Argument])


instance (GFromEncoded f, GFromEncoded g) => GFromEncoded (f :+: g) where
  gParseEncoded :: forall (p :: k). Encoded -> Either String ((:+:) f g p, [Argument])
gParseEncoded enc :: Encoded
enc@(Encoded ConName
con [Argument]
vals) = do
    let el :: Either String (f p, [Argument])
el = forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [Argument])
forall (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [Argument])
gParseEncoded @f Encoded
enc
    let er :: Either String (g p, [Argument])
er = forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [Argument])
forall (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [Argument])
gParseEncoded @g Encoded
enc
    case (Either String (f p, [Argument])
el, Either String (g p, [Argument])
er) of
      (Right (f p
l, [Argument]
lvals), Either String (g p, [Argument])
_) -> ((:+:) f g p, [Argument])
-> Either String ((:+:) f g p, [Argument])
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). f p -> (:+:) f g p
L1 f p
l, [Argument]
lvals)
      (Either String (f p, [Argument])
_, Right (g p
r, [Argument]
rvals)) -> ((:+:) f g p, [Argument])
-> Either String ((:+:) f g p, [Argument])
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (g p -> (:+:) f g p
forall k (f :: k -> *) (g :: k -> *) (p :: k). g p -> (:+:) f g p
R1 g p
r, [Argument]
rvals)
      (Left String
_e1, Left String
_e2) ->
        String -> Either String ((:+:) f g p, [Argument])
forall a b. a -> Either a b
Left (String -> Either String ((:+:) f g p, [Argument]))
-> String -> Either String ((:+:) f g p, [Argument])
forall a b. (a -> b) -> a -> b
$ String
"No matching sum constructor: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs ConName
con.text String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShowS
forall a b. ConvertibleStrings a b => a -> b
cs ([Argument] -> String
forall a. Show a => a -> String
show [Argument]
vals)


instance (GFromEncoded f, GFromEncoded g) => GFromEncoded (f :*: g) where
  gParseEncoded :: forall (p :: k). Encoded -> Either String ((:*:) f g p, [Argument])
gParseEncoded (Encoded ConName
con [Argument]
vals) = do
    (a, rest) <- forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [Argument])
forall (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [Argument])
gParseEncoded @f (ConName -> [Argument] -> Encoded
Encoded ConName
con [Argument]
vals)
    (b, gone) <- gParseEncoded @g (Encoded con rest)
    pure (a :*: b, gone)


instance GFromEncoded U1 where
  gParseEncoded :: forall (p :: k). Encoded -> Either String (U1 p, [Argument])
gParseEncoded (Encoded ConName
_ [Argument]
vals) = (U1 p, [Argument]) -> Either String (U1 p, [Argument])
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (U1 p
forall k (p :: k). U1 p
U1, [Argument]
vals)


instance (GFromEncoded f) => GFromEncoded (M1 D d f) where
  gParseEncoded :: forall (p :: k). Encoded -> Either String (M1 D d f p, [Argument])
gParseEncoded Encoded
enc = do
    (f p -> M1 D d f p)
-> (f p, [Argument]) -> (M1 D d f p, [Argument])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first f p -> M1 D d f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 ((f p, [Argument]) -> (M1 D d f p, [Argument]))
-> Either String (f p, [Argument])
-> Either String (M1 D d f p, [Argument])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Encoded -> Either String (f p, [Argument])
forall (p :: k). Encoded -> Either String (f p, [Argument])
forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [Argument])
gParseEncoded Encoded
enc


instance (Constructor c, GFromEncoded f) => GFromEncoded (M1 C c f) where
  gParseEncoded :: forall (p :: k). Encoded -> Either String (M1 C c f p, [Argument])
gParseEncoded enc :: Encoded
enc@(Encoded ConName
cname [Argument]
_) = do
    if Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs ConName
cname.text String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
con
      then (f p -> M1 C c f p)
-> (f p, [Argument]) -> (M1 C c f p, [Argument])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first f p -> M1 C c f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 ((f p, [Argument]) -> (M1 C c f p, [Argument]))
-> Either String (f p, [Argument])
-> Either String (M1 C c f p, [Argument])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [Argument])
forall (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [Argument])
gParseEncoded @f Encoded
enc
      else String -> Either String (M1 C c f p, [Argument])
forall a b. a -> Either a b
Left (String -> Either String (M1 C c f p, [Argument]))
-> String -> Either String (M1 C c f p, [Argument])
forall a b. (a -> b) -> a -> b
$ String
"Mismatched Constructor " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs ConName
cname.text String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" /= " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
con
   where
    con :: String
con = ShowS
forall a b. ConvertibleStrings a b => a -> b
cs ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ M1 C c f (ZonkAny 2) -> String
forall {k} (c :: k) k1 (t :: k -> (k1 -> *) -> k1 -> *)
       (f :: k1 -> *) (a :: k1).
Constructor c =>
t c f a -> String
forall k1 (t :: Meta -> (k1 -> *) -> k1 -> *) (f :: k1 -> *)
       (a :: k1).
t c f a -> String
conName (M1 C c f p
forall {p :: k}. M1 C c f p
forall a. HasCallStack => a
undefined :: M1 C c f p)


instance (GFromEncoded f) => GFromEncoded (M1 S s f) where
  gParseEncoded :: forall (p :: k). Encoded -> Either String (M1 S s f p, [Argument])
gParseEncoded Encoded
enc = do
    (a, rest) <- Encoded -> Either String (f p, [Argument])
forall (p :: k). Encoded -> Either String (f p, [Argument])
forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [Argument])
gParseEncoded Encoded
enc
    pure (M1 a, rest)


-- how can we *sometimes* parse it as user input?
-- we can branch here based on something the client sends?
-- wrap it in user input instead?
-- newtype Input a = Input a
-- then I can overload it here.
instance (FromJSON a) => GFromEncoded (K1 R a) where
  gParseEncoded :: forall (p :: k). Encoded -> Either String (K1 R a p, [Argument])
gParseEncoded (Encoded ConName
con [Argument]
vals) = do
    case [Argument]
vals of
      (Argument
param : [Argument]
rest) -> do
        case Argument -> Either String a
forall a. FromJSON a => Argument -> Either String a
parseArgument Argument
param of
          -- consume one param
          Right a
a -> (K1 R a p, [Argument]) -> Either String (K1 R a p, [Argument])
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> K1 R a p
forall k i c (p :: k). c -> K1 i c p
K1 a
a, [Argument]
rest)
          Left String
e -> String -> Either String (K1 R a p, [Argument])
forall a b. a -> Either a b
Left (ShowS
forall a b. ConvertibleStrings a b => a -> b
cs String
e)
      [] -> String -> Either String (K1 R a p, [Argument])
forall a b. a -> Either a b
Left (String -> Either String (K1 R a p, [Argument]))
-> String -> Either String (K1 R a p, [Argument])
forall a b. (a -> b) -> a -> b
$ String
"Missing parameters for Encoded Constructor:" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs ConName
con.text