{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}

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 qualified as Atto
import Data.Attoparsec.ByteString.Char8 (isSpace, sepBy, takeWhile1)
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.Param


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)
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
""


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

MyConstructor 1 2 3
-}
data Encoded = Encoded ConName [ParamValue]
  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)


instance Semigroup Encoded where
  Encoded ConName
c1 [ParamValue]
es1 <> :: Encoded -> Encoded -> Encoded
<> Encoded ConName
c2 [ParamValue]
es2 =
    ConName -> [ParamValue] -> Encoded
Encoded (ConName
c1 ConName -> ConName -> ConName
forall a. Semigroup a => a -> a -> a
<> ConName
c2) ([ParamValue]
es1 [ParamValue] -> [ParamValue] -> [ParamValue]
forall a. Semigroup a => a -> a -> a
<> [ParamValue]
es2)
instance Monoid Encoded where
  mempty :: Encoded
mempty = ConName -> [ParamValue] -> Encoded
Encoded ConName
forall a. Monoid a => a
mempty [ParamValue]
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
  Encoded
enc <- Text -> Either String Encoded
encodedParseText Text
t
  Encoded -> Either String a
forall a. FromEncoded a => Encoded -> Either String a
parseEncoded Encoded
enc


-- | Basic Encoding
encodedToText :: Encoded -> Text
encodedToText :: Encoded -> Text
encodedToText (Encoded ConName
con [ParamValue]
values) =
  let params :: Text
params = Text -> [Text] -> Text
T.intercalate Text
" " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (ParamValue -> Text) -> [ParamValue] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ParamValue -> Text
encodeParam [ParamValue]
values
   in case Text
params of
        Text
"" -> ConName
con.text
        Text
_ -> ConName
con.text Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
params


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
    ByteString
con <- (Char -> Bool) -> Parser ByteString
AC.takeTill Char -> Bool
AC.isSpace
    Parser ()
AC.skipSpace
    [ParamValue]
params <- Parser ParamValue
paramParser Parser ParamValue
-> Parser ByteString Char -> Parser ByteString [ParamValue]
forall (f :: * -> *) a s. Alternative f => f a -> f s -> f [a]
`sepBy` Char -> Parser ByteString Char
AC.char Char
' '
    Encoded -> Parser Encoded
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Encoded -> Parser Encoded) -> Encoded -> Parser Encoded
forall a b. (a -> b) -> a -> b
$ ConName -> [ParamValue] -> Encoded
Encoded (Text -> ConName
ConName (ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
con)) [ParamValue]
params


genericToEncoded :: (Generic a, GToEncoded (Rep a)) => a -> Encoded
genericToEncoded :: forall a. (Generic a, GToEncoded (Rep a)) => a -> Encoded
genericToEncoded a
a = Rep a Any -> Encoded
forall p. Rep a p -> Encoded
forall {k} (f :: k -> *) (p :: k). GToEncoded f => f p -> Encoded
gToEncoded (a -> Rep a Any
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
  (Rep a Any
gen, [ParamValue]
_) <- Encoded -> Either String (Rep a Any, [ParamValue])
forall p. Encoded -> Either String (Rep a p, [ParamValue])
forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [ParamValue])
gParseEncoded Encoded
enc
  a -> Either String a
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Either String a) -> a -> Either String a
forall a b. (a -> b) -> a -> b
$ Rep a Any -> a
forall a x. Generic a => Rep a x -> a
forall x. Rep a x -> a
to Rep a Any
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
  Encoded
enc <- Text -> Either String Encoded
encodedParseText Text
t
  Encoded -> Either String a
forall a.
(Generic a, GFromEncoded (Rep a)) =>
Encoded -> Either String a
genericParseEncoded Encoded
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


-- | 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


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)


-------------------------------------------------------------------------------
-- PARAM ENCODING
-------------------------------------------------------------------------------
-- Params need to be sanitized and escaped, because we want to use spaces to separate our params
-- Data.Param by default does not sanitize spaces

paramParser :: Atto.Parser ParamValue
paramParser :: Parser ParamValue
paramParser = do
  ByteString
t <- (Char -> Bool) -> Parser ByteString
takeWhile1 (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isSpace)
  ParamValue -> Parser ParamValue
forall a. a -> Parser ByteString a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ParamValue -> Parser ParamValue)
-> ParamValue -> Parser ParamValue
forall a b. (a -> b) -> a -> b
$ Text -> ParamValue
decodeParam (Text -> ParamValue) -> Text -> ParamValue
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ByteString
t


decodeParam :: Text -> ParamValue
decodeParam :: Text -> ParamValue
decodeParam = \case
  Text
"|" -> Text -> ParamValue
ParamValue Text
""
  Text
t -> Text -> ParamValue
ParamValue (Text -> ParamValue) -> Text -> ParamValue
forall a b. (a -> b) -> a -> b
$ Text -> Text
desanitizeParamText Text
t


-- replace all underscores that are NOT "\\_" with spaces

desanitizeParamText :: Text -> Text
desanitizeParamText :: Text -> Text
desanitizeParamText =
  HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"\\ " Text
"_" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"_" Text
" "


--   | T.isSuffixOf "\\" seg = T.dropEnd 1 seg <> "_" <> txt
--   | otherwise = seg <> " " <> txt

-- foldr join "" $
-- where
--
-- join "" "" = " "
-- join "" " " = " "
-- join seg "" = seg
-- join seg txt
--   | T.isSuffixOf "\\" seg = T.dropEnd 1 seg <> "_" <> txt
--   | otherwise = seg <> " " <> txt

encodeParam :: ParamValue -> Text
encodeParam :: ParamValue -> Text
encodeParam (ParamValue Text
t) =
  case Text
t of
    Text
"" -> Text
"|"
    Text
_ -> Text -> Text
sanitizeParamText Text
t
 where
  sanitizeParamText :: Text -> Text
  sanitizeParamText :: Text -> Text
sanitizeParamText = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
" " Text
"_" (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"_" Text
"\\_"


-- decodeParamValue :: (FromParam a) => Text -> Either String a
-- decodeParamValue = parseParam . decodeParam

-- decodeParam :: Text -> ParamValue
-- decodeParam inp = do
--   case A.eitherDecode (cs inp) of
--     Left _ -> paramFromText inp
--     Right v -> ParamValue inp v

-------------------------------------------------------------------------------
-- 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
  -- WARNING: not sure if this will work
  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 Any -> 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 -> [ParamValue] -> Encoded
Encoded (Text -> ConName
ConName Text
con) [ParamValue]
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 (ToParam a) => GToEncoded (K1 R a) where
  gToEncoded :: forall (p :: k). K1 R a p -> Encoded
gToEncoded (K1 a
a) = ConName -> [ParamValue] -> Encoded
Encoded ConName
forall a. Monoid a => a
mempty [a -> ParamValue
forall a. ToParam a => a -> ParamValue
toParam a
a]


-- GFromEncoded: Generic ViewAction Decoding

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


instance (GFromEncoded f, GFromEncoded g) => GFromEncoded (f :+: g) where
  gParseEncoded :: forall (p :: k).
Encoded -> Either String ((:+:) f g p, [ParamValue])
gParseEncoded enc :: Encoded
enc@(Encoded ConName
con [ParamValue]
vals) = do
    let el :: Either String (f p, [ParamValue])
el = forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [ParamValue])
forall (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [ParamValue])
gParseEncoded @f Encoded
enc
    let er :: Either String (g p, [ParamValue])
er = forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [ParamValue])
forall (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [ParamValue])
gParseEncoded @g Encoded
enc
    case (Either String (f p, [ParamValue])
el, Either String (g p, [ParamValue])
er) of
      (Right (f p
l, [ParamValue]
lvals), Either String (g p, [ParamValue])
_) -> ((:+:) f g p, [ParamValue])
-> Either String ((:+:) f g p, [ParamValue])
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, [ParamValue]
lvals)
      (Either String (f p, [ParamValue])
_, Right (g p
r, [ParamValue]
rvals)) -> ((:+:) f g p, [ParamValue])
-> Either String ((:+:) f g p, [ParamValue])
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, [ParamValue]
rvals)
      (Left String
_, Left String
_) ->
        String -> Either String ((:+:) f g p, [ParamValue])
forall a b. a -> Either a b
Left (String -> Either String ((:+:) f g p, [ParamValue]))
-> String -> Either String ((:+:) f g p, [ParamValue])
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 ([ParamValue] -> String
forall a. Show a => a -> String
show [ParamValue]
vals)


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


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


instance (GFromEncoded f) => GFromEncoded (M1 D d f) where
  gParseEncoded :: forall (p :: k).
Encoded -> Either String (M1 D d f p, [ParamValue])
gParseEncoded Encoded
enc = do
    (f p -> M1 D d f p)
-> (f p, [ParamValue]) -> (M1 D d f p, [ParamValue])
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, [ParamValue]) -> (M1 D d f p, [ParamValue]))
-> Either String (f p, [ParamValue])
-> Either String (M1 D d f p, [ParamValue])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Encoded -> Either String (f p, [ParamValue])
forall (p :: k). Encoded -> Either String (f p, [ParamValue])
forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [ParamValue])
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, [ParamValue])
gParseEncoded enc :: Encoded
enc@(Encoded ConName
cname [ParamValue]
_) = 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, [ParamValue]) -> (M1 C c f p, [ParamValue])
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, [ParamValue]) -> (M1 C c f p, [ParamValue]))
-> Either String (f p, [ParamValue])
-> Either String (M1 C c f p, [ParamValue])
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, [ParamValue])
forall (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [ParamValue])
gParseEncoded @f Encoded
enc
      else String -> Either String (M1 C c f p, [ParamValue])
forall a b. a -> Either a b
Left (String -> Either String (M1 C c f p, [ParamValue]))
-> String -> Either String (M1 C c f p, [ParamValue])
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 Any -> 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, [ParamValue])
gParseEncoded Encoded
enc = do
    (f p
a, [ParamValue]
rest) <- Encoded -> Either String (f p, [ParamValue])
forall (p :: k). Encoded -> Either String (f p, [ParamValue])
forall {k} (f :: k -> *) (p :: k).
GFromEncoded f =>
Encoded -> Either String (f p, [ParamValue])
gParseEncoded Encoded
enc
    (M1 S s f p, [ParamValue])
-> Either String (M1 S s f p, [ParamValue])
forall a. a -> Either String a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (f p -> M1 S s f p
forall k i (c :: Meta) (f :: k -> *) (p :: k). f p -> M1 i c f p
M1 f p
a, [ParamValue]
rest)


instance (FromParam a) => GFromEncoded (K1 R a) where
  gParseEncoded :: forall (p :: k). Encoded -> Either String (K1 R a p, [ParamValue])
gParseEncoded (Encoded ConName
con [ParamValue]
vals) = do
    case [ParamValue]
vals of
      (ParamValue
param : [ParamValue]
rest) -> do
        case ParamValue -> Either String a
forall a. FromParam a => ParamValue -> Either String a
parseParam ParamValue
param of
          -- consume one param
          Right a
a -> (K1 R a p, [ParamValue]) -> Either String (K1 R a p, [ParamValue])
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, [ParamValue]
rest)
          Left String
e -> String -> Either String (K1 R a p, [ParamValue])
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, [ParamValue])
forall a b. a -> Either a b
Left (String -> Either String (K1 R a p, [ParamValue]))
-> String -> Either String (K1 R a p, [ParamValue])
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