module Ribosome.Host.Data.ApiType where

import Data.Char (isSpace)
import Exon (exon)
import qualified FlatParse.Basic as FlatParse
import FlatParse.Basic (
  Result (Err, Fail, OK),
  branch,
  char,
  inSpan,
  isLatinLetter,
  many_,
  optional,
  readInt,
  runParser,
  satisfy,
  satisfyASCII,
  string,
  switch,
  takeRest,
  withSpan,
  (<|>),
  )
import Prelude hiding (optional, some, span, try, (<|>))
import Text.Show (showsPrec)

import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (fromMsgpack))
import Ribosome.Host.Class.Msgpack.Error (DecodeError, decodeError)

-- TODO see if using GADT can move some TH stuff to type level
data ApiPrim =
  Boolean
  |
  Integer
  |
  Float
  |
  String
  |
  Dictionary
  |
  Object
  |
  Void
  |
  LuaRef
  deriving stock (ApiPrim -> ApiPrim -> Bool
(ApiPrim -> ApiPrim -> Bool)
-> (ApiPrim -> ApiPrim -> Bool) -> Eq ApiPrim
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApiPrim -> ApiPrim -> Bool
$c/= :: ApiPrim -> ApiPrim -> Bool
== :: ApiPrim -> ApiPrim -> Bool
$c== :: ApiPrim -> ApiPrim -> Bool
Eq, Int -> ApiPrim -> ShowS
[ApiPrim] -> ShowS
ApiPrim -> String
(Int -> ApiPrim -> ShowS)
-> (ApiPrim -> String) -> ([ApiPrim] -> ShowS) -> Show ApiPrim
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiPrim] -> ShowS
$cshowList :: [ApiPrim] -> ShowS
show :: ApiPrim -> String
$cshow :: ApiPrim -> String
showsPrec :: Int -> ApiPrim -> ShowS
$cshowsPrec :: Int -> ApiPrim -> ShowS
Show)

data ApiType =
  Prim ApiPrim
  |
  Array ApiType (Maybe Int)
  |
  Ext String
  deriving stock (Int -> ApiType -> ShowS
[ApiType] -> ShowS
ApiType -> String
(Int -> ApiType -> ShowS)
-> (ApiType -> String) -> ([ApiType] -> ShowS) -> Show ApiType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ApiType] -> ShowS
$cshowList :: [ApiType] -> ShowS
show :: ApiType -> String
$cshow :: ApiType -> String
showsPrec :: Int -> ApiType -> ShowS
$cshowsPrec :: Int -> ApiType -> ShowS
Show, ApiType -> ApiType -> Bool
(ApiType -> ApiType -> Bool)
-> (ApiType -> ApiType -> Bool) -> Eq ApiType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ApiType -> ApiType -> Bool
$c/= :: ApiType -> ApiType -> Bool
== :: ApiType -> ApiType -> Bool
$c== :: ApiType -> ApiType -> Bool
Eq)

polyType :: ApiType -> Bool
polyType :: ApiType -> Bool
polyType = \case
  Prim ApiPrim
Object -> Bool
True
  Prim ApiPrim
Dictionary -> Bool
True
  ApiType
_ -> Bool
False

pattern PolyType :: ApiType
pattern $mPolyType :: forall {r}. ApiType -> (Void# -> r) -> (Void# -> r) -> r
PolyType <- (polyType -> True)

type Parser =
  FlatParse.Parser Text

ws :: Parser ()
ws :: Parser ()
ws =
  Parser Text Char -> Parser ()
forall e a. Parser e a -> Parser e ()
many_ ((Char -> Bool) -> Parser Text Char
forall e. (Char -> Bool) -> Parser e Char
satisfy Char -> Bool
isSpace)

span :: Parser () -> Parser String
span :: Parser () -> Parser String
span Parser ()
seek =
  Parser () -> (() -> Span -> Parser String) -> Parser String
forall e a b. Parser e a -> (a -> Span -> Parser e b) -> Parser e b
withSpan Parser ()
seek \ ()
_ Span
sp -> Span -> Parser String -> Parser String
forall e a. Span -> Parser e a -> Parser e a
inSpan Span
sp Parser String
forall e. Parser e String
takeRest

prim :: Parser ApiPrim
prim :: Parser ApiPrim
prim =
  $(switch [|
  case _ of
    "Boolean" -> pure Boolean
    "Integer" -> pure Integer
    "Float" -> pure Float
    "String" -> pure String
    "Dictionary" -> pure Dictionary
    "Object" -> pure Object
    "void" -> pure Void
    "LuaRef" -> pure LuaRef
  |])

typedArray :: Parser ApiType
typedArray :: Parser ApiType
typedArray = do
  ApiType
t <- Parser ApiType
apiType
  Maybe Int
arity <- Parser Text Int -> Parser Text (Maybe Int)
forall e a. Parser e a -> Parser e (Maybe a)
optional do
    $(char ',')
    Parser ()
ws
    Parser Text Int
forall e. Parser e Int
readInt
  pure (ApiType -> Maybe Int -> ApiType
Array ApiType
t Maybe Int
arity)

array :: Parser ApiType
array :: Parser ApiType
array = do
  $(string "Array")
  Parser () -> Parser ApiType -> Parser ApiType -> Parser ApiType
forall e a b. Parser e a -> Parser e b -> Parser e b -> Parser e b
branch $(string "Of(") (Parser ApiType
typedArray Parser ApiType -> Parser () -> Parser ApiType
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* $(char ')')) (ApiType -> Parser ApiType
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ApiType -> Maybe Int -> ApiType
Array (ApiPrim -> ApiType
Prim ApiPrim
Object) Maybe Int
forall a. Maybe a
Nothing))

ext :: Parser ApiType
ext :: Parser ApiType
ext =
  String -> ApiType
Ext (String -> ApiType) -> Parser String -> Parser ApiType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser () -> Parser String
span (Parser Text Char -> Parser ()
forall e a. Parser e a -> Parser e ()
many_ ((Char -> Bool) -> Parser Text Char
forall e. (Char -> Bool) -> Parser e Char
satisfyASCII Char -> Bool
isLatinLetter))

apiType :: Parser ApiType
apiType :: Parser ApiType
apiType =
  Parser ApiType
array Parser ApiType -> Parser ApiType -> Parser ApiType
forall e a. Parser e a -> Parser e a -> Parser e a
<|> (ApiPrim -> ApiType
Prim (ApiPrim -> ApiType) -> Parser ApiPrim -> Parser ApiType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ApiPrim
prim) Parser ApiType -> Parser ApiType -> Parser ApiType
forall e a. Parser e a -> Parser e a -> Parser e a
<|> Parser ApiType
ext

parseApiType :: ByteString -> Either DecodeError ApiType
parseApiType :: ByteString -> Either DecodeError ApiType
parseApiType =
  Parser ApiType -> ByteString -> Result Text ApiType
forall e a. Parser e a -> ByteString -> Result e a
runParser Parser ApiType
apiType (ByteString -> Result Text ApiType)
-> (Result Text ApiType -> Either DecodeError ApiType)
-> ByteString
-> Either DecodeError ApiType
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
    OK ApiType
a ByteString
"" -> ApiType -> Either DecodeError ApiType
forall a b. b -> Either a b
Right ApiType
a
    OK ApiType
a ByteString
u -> Text -> Either DecodeError ApiType
forall a. Typeable a => Text -> Either DecodeError a
decodeError [exon|Parsed #{toText (showsPrec 11 a "")} but got leftovers: #{decodeUtf8 u}|]
    Result Text ApiType
Fail -> Text -> Either DecodeError ApiType
forall a. Typeable a => Text -> Either DecodeError a
decodeError Text
"fail"
    Err Text
e -> Text -> Either DecodeError ApiType
forall a. Typeable a => Text -> Either DecodeError a
decodeError Text
e

instance MsgpackDecode ApiType where
  fromMsgpack :: Object -> Either DecodeError ApiType
fromMsgpack =
    ByteString -> Either DecodeError ApiType
parseApiType (ByteString -> Either DecodeError ApiType)
-> (Object -> Either DecodeError ByteString)
-> Object
-> Either DecodeError ApiType
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Object -> Either DecodeError ByteString
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack