{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLists #-}

module Web.Hyperbole.Data.Argument where

import Control.Applicative ((<|>))
import Data.Aeson (FromJSON (..), ToJSON (..), Value (..))
import Data.Aeson qualified as A
import Data.Aeson.KeyMap (KeyMap, (!?))
import Data.Aeson.Parser (json)
import Data.Attoparsec.ByteString qualified as AB
import Data.Attoparsec.ByteString qualified as Atto
import Data.Attoparsec.ByteString.Char8 (sepBy)
import Data.Attoparsec.ByteString.Char8 qualified as AC
import Data.Bifunctor (first)
import Data.Char (isAlphaNum, isUpper)
import Data.Maybe (fromMaybe)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Text qualified as T
import GHC.Exts (IsList (..))
import GHC.Generics


data Argument
  = JSON Value
  deriving (Int -> Argument -> ShowS
[Argument] -> ShowS
Argument -> String
(Int -> Argument -> ShowS)
-> (Argument -> String) -> ([Argument] -> ShowS) -> Show Argument
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Argument -> ShowS
showsPrec :: Int -> Argument -> ShowS
$cshow :: Argument -> String
show :: Argument -> String
$cshowList :: [Argument] -> ShowS
showList :: [Argument] -> ShowS
Show, Argument -> Argument -> Bool
(Argument -> Argument -> Bool)
-> (Argument -> Argument -> Bool) -> Eq Argument
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Argument -> Argument -> Bool
== :: Argument -> Argument -> Bool
$c/= :: Argument -> Argument -> Bool
/= :: Argument -> Argument -> Bool
Eq, Eq Argument
Eq Argument =>
(Argument -> Argument -> Ordering)
-> (Argument -> Argument -> Bool)
-> (Argument -> Argument -> Bool)
-> (Argument -> Argument -> Bool)
-> (Argument -> Argument -> Bool)
-> (Argument -> Argument -> Argument)
-> (Argument -> Argument -> Argument)
-> Ord Argument
Argument -> Argument -> Bool
Argument -> Argument -> Ordering
Argument -> Argument -> Argument
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 :: Argument -> Argument -> Ordering
compare :: Argument -> Argument -> Ordering
$c< :: Argument -> Argument -> Bool
< :: Argument -> Argument -> Bool
$c<= :: Argument -> Argument -> Bool
<= :: Argument -> Argument -> Bool
$c> :: Argument -> Argument -> Bool
> :: Argument -> Argument -> Bool
$c>= :: Argument -> Argument -> Bool
>= :: Argument -> Argument -> Bool
$cmax :: Argument -> Argument -> Argument
max :: Argument -> Argument -> Argument
$cmin :: Argument -> Argument -> Argument
min :: Argument -> Argument -> Argument
Ord, (forall x. Argument -> Rep Argument x)
-> (forall x. Rep Argument x -> Argument) -> Generic Argument
forall x. Rep Argument x -> Argument
forall x. Argument -> Rep Argument x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Argument -> Rep Argument x
from :: forall x. Argument -> Rep Argument x
$cto :: forall x. Rep Argument x -> Argument
to :: forall x. Rep Argument x -> Argument
Generic)


-------------------------------------------------------------------------------
-- ARGUMENT ENCODING
-------------------------------------------------------------------------------

toArgument :: (ToJSON a) => a -> Argument
toArgument :: forall a. ToJSON a => a -> Argument
toArgument = Value -> Argument
JSON (Value -> Argument) -> (a -> Value) -> a -> Argument
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Value
forall a. ToJSON a => a -> Value
toJSON


parseArgument :: forall a. (FromJSON a) => Argument -> Either String a
parseArgument :: forall a. FromJSON a => Argument -> Either String a
parseArgument (JSON Value
v) = do
  case Value -> Result a
forall a. FromJSON a => Value -> Result a
A.fromJSON Value
v of
    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
    A.Error String
e -> String -> Either String a
forall a b. a -> Either a b
Left String
e


-- | Parses both json and our custom constructor format
argumentParser :: Atto.Parser Argument
argumentParser :: Parser Argument
argumentParser =
  Value -> Argument
JSON (Value -> Argument) -> Parser ByteString Value -> Parser Argument
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser ByteString Value
json Parser ByteString Value
-> Parser ByteString Value -> Parser ByteString Value
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Value
constructor Parser ByteString Value
-> Parser ByteString Value -> Parser ByteString Value
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Value
innerProduct)
 where
  innerProduct :: Parser ByteString Value
innerProduct = do
    _ <- Char -> Parser Char
AC.char Char
'('
    tag <- AC.takeWhile1 isAlphaNum
    contents :: KeyMap Value <- innerContents <|> pure []
    _ <- AC.char ')'
    pure $ Object $ [("tag", String $ cs tag)] <> contents

  innerContents :: Parser ByteString (KeyMap Value)
innerContents = do
    _ <- Char -> Parser Char
AC.char Char
' '
    args <- json `sepBy` AC.space
    pure $ case args of
      [] -> []
      [Item [Value]
a] -> [(Key
"contents", Item [Value]
Value
a)]
      [Value]
as -> [(Key
"contents", Array -> Value
Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ [Item Array] -> Array
forall l. IsList l => [Item l] -> l
fromList [Item Array]
[Value]
as)]

  constructor :: Parser ByteString Value
constructor = do
    s <- (Char -> Bool) -> Parser ByteString
AC.takeWhile1 Char -> Bool
isAlphaNum
    pure $ String (cs s)


-- decode a single argument
decodeToArgument :: Text -> Either String Argument
decodeToArgument :: Text -> Either String Argument
decodeToArgument Text
inp =
  ShowS -> Either String Argument -> Either String Argument
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 (\String
e -> String
"decodeArgument: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs Text
inp String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" failed with error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
e) (Either String Argument -> Either String Argument)
-> Either String Argument -> Either String Argument
forall a b. (a -> b) -> a -> b
$ Parser Argument -> ByteString -> Either String Argument
forall a. Parser a -> ByteString -> Either String a
AB.parseOnly Parser Argument
argumentParser (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
inp)


decodeArgument :: (FromJSON a) => Text -> Either String a
decodeArgument :: forall a. FromJSON a => Text -> Either String a
decodeArgument Text
inp = do
  Text -> Either String Argument
decodeToArgument Text
inp Either String Argument
-> (Argument -> Either String a) -> Either String a
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Argument -> Either String a
forall a. FromJSON a => Argument -> Either String a
parseArgument


encodeArgument :: (ToJSON a) => a -> Text
encodeArgument :: forall a. ToJSON a => a -> Text
encodeArgument a
a = Argument -> Text
encodeFromArgument (Argument -> Text) -> Argument -> Text
forall a b. (a -> b) -> a -> b
$ a -> Argument
forall a. ToJSON a => a -> Argument
toArgument a
a


-- | JSON Encode argument, but alter it slightly to use raw strings for constructors without parameters, and switch to two-element sum encoding
encodeFromArgument :: Argument -> Text
encodeFromArgument :: Argument -> Text
encodeFromArgument (JSON Value
v) = Value -> Text
encodeJSON Value
v


-- | Encodes as JSON for simple values, but forces constructors into our custom show-like format
encodeJSON :: Value -> Text
encodeJSON :: Value -> Text
encodeJSON = \case
  (String Text
s) ->
    if Text -> Bool
isConstructorName Text
s
      then Text
s
      else Value -> Text
encodeValue (Value -> Text) -> Value -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Value
String Text
s
  (Object KeyMap Value
km) ->
    Value -> Text
simplifySumEncoding (Value -> Text) -> Value -> Text
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> Value
Object KeyMap Value
km
  Value
v -> Value -> Text
encodeValue Value
v
 where
  encodeValue :: Value -> Text
  encodeValue :: Value -> Text
encodeValue = ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> Text) -> (Value -> ByteString) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode

  isConstructorName :: Text -> Bool
  isConstructorName :: Text -> Bool
isConstructorName Text
"" = Bool
False
  isConstructorName Text
t =
    Char -> Bool
isUpper (HasCallStack => Text -> Char
Text -> Char
T.head Text
t) Bool -> Bool -> Bool
&& (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isAlphaNum Text
t

  simplifySumEncoding :: Value -> Text
  simplifySumEncoding :: Value -> Text
simplifySumEncoding (Object KeyMap Value
o) = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (Value -> Text
encodeValue (Value -> Text) -> Value -> Text
forall a b. (a -> b) -> a -> b
$ KeyMap Value -> Value
Object KeyMap Value
o) (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ do
    KeyMap Value -> Maybe Text
innerProduct KeyMap Value
o Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> KeyMap Value -> Maybe Text
simpleTag KeyMap Value
o
  simplifySumEncoding Value
v = Value -> Text
encodeValue Value
v

  innerProduct :: KeyMap Value -> Maybe Text
  innerProduct :: KeyMap Value -> Maybe Text
innerProduct KeyMap Value
o = do
    String t <- KeyMap Value
o KeyMap Value -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
!? Key
"tag"
    c <- o !? "contents"
    let contents = case Value
c of
          Array Array
a -> Text -> [Text] -> Text
T.intercalate Text
" " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Vector Text -> [Item (Vector Text)]
forall l. IsList l => l -> [Item l]
toList (Vector Text -> [Item (Vector Text)])
-> Vector Text -> [Item (Vector Text)]
forall a b. (a -> b) -> a -> b
$ (Value -> Text) -> Array -> Vector Text
forall a b. (a -> b) -> Vector a -> Vector b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Text
encodeValue Array
a
          Value
other -> Value -> Text
encodeValue Value
other
    pure $ "(" <> t <> " " <> contents <> ")"

  simpleTag :: KeyMap Value -> Maybe Text
  simpleTag :: KeyMap Value -> Maybe Text
simpleTag KeyMap Value
o = do
    t <- KeyMap Value
o KeyMap Value -> Key -> Maybe Value
forall v. KeyMap v -> Key -> Maybe v
!? Key
"tag"
    case t of
      String Text
s -> Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
s Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      Value
v -> Text -> Maybe Text
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Value -> Text
encodeValue Value
v