{-# options_haddock prune #-}

-- |Errors for messagepack decoding.
module Ribosome.Host.Class.Msgpack.Error where

import Data.MessagePack (Object (..))
import qualified Data.Text as Text
import qualified Data.Text.Encoding.Error as UnicodeException
import Exon (exon)
import Log (Severity (Error))
import Numeric (showHex)
import Type.Reflection (typeRep)

import Ribosome.Host.Data.Report (Report (Report), Reportable (toReport))

-- |A decoding error in a field of a larger type.
--
-- May be nested arbitrarily deep.
data FieldError =
  FieldError Text
  |
  NestedFieldError DecodeError
  deriving stock (FieldError -> FieldError -> Bool
(FieldError -> FieldError -> Bool)
-> (FieldError -> FieldError -> Bool) -> Eq FieldError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldError -> FieldError -> Bool
$c/= :: FieldError -> FieldError -> Bool
== :: FieldError -> FieldError -> Bool
$c== :: FieldError -> FieldError -> Bool
Eq, Int -> FieldError -> ShowS
[FieldError] -> ShowS
FieldError -> String
(Int -> FieldError -> ShowS)
-> (FieldError -> String)
-> ([FieldError] -> ShowS)
-> Show FieldError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldError] -> ShowS
$cshowList :: [FieldError] -> ShowS
show :: FieldError -> String
$cshow :: FieldError -> String
showsPrec :: Int -> FieldError -> ShowS
$cshowsPrec :: Int -> FieldError -> ShowS
Show, (forall x. FieldError -> Rep FieldError x)
-> (forall x. Rep FieldError x -> FieldError) -> Generic FieldError
forall x. Rep FieldError x -> FieldError
forall x. FieldError -> Rep FieldError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FieldError x -> FieldError
$cfrom :: forall x. FieldError -> Rep FieldError x
Generic)

instance IsString FieldError where
  fromString :: String -> FieldError
fromString =
    Text -> FieldError
FieldError (Text -> FieldError) -> (String -> Text) -> String -> FieldError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

-- |A messagepack decoding error.
data DecodeError =
  DecodeError {
    -- |The name of the type being decoded.
    DecodeError -> Text
mainType :: Text,
    -- |An error, potentially nested in other types.
    DecodeError -> FieldError
fieldError :: FieldError
  }
  deriving stock (DecodeError -> DecodeError -> Bool
(DecodeError -> DecodeError -> Bool)
-> (DecodeError -> DecodeError -> Bool) -> Eq DecodeError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DecodeError -> DecodeError -> Bool
$c/= :: DecodeError -> DecodeError -> Bool
== :: DecodeError -> DecodeError -> Bool
$c== :: DecodeError -> DecodeError -> Bool
Eq, Int -> DecodeError -> ShowS
[DecodeError] -> ShowS
DecodeError -> String
(Int -> DecodeError -> ShowS)
-> (DecodeError -> String)
-> ([DecodeError] -> ShowS)
-> Show DecodeError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DecodeError] -> ShowS
$cshowList :: [DecodeError] -> ShowS
show :: DecodeError -> String
$cshow :: DecodeError -> String
showsPrec :: Int -> DecodeError -> ShowS
$cshowsPrec :: Int -> DecodeError -> ShowS
Show, (forall x. DecodeError -> Rep DecodeError x)
-> (forall x. Rep DecodeError x -> DecodeError)
-> Generic DecodeError
forall x. Rep DecodeError x -> DecodeError
forall x. DecodeError -> Rep DecodeError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep DecodeError x -> DecodeError
$cfrom :: forall x. DecodeError -> Rep DecodeError x
Generic)

compileError :: DecodeError -> (Text, Text)
compileError :: DecodeError -> (Text, Text)
compileError DecodeError
err =
  ([Text] -> Text) -> ([Text], Text) -> (Text, Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> [Text] -> Text
Text.intercalate Text
" within " ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse) (DecodeError -> ([Text], Text)
nest DecodeError
err)
  where
    nest :: DecodeError -> ([Text], Text)
nest DecodeError {Text
FieldError
fieldError :: FieldError
mainType :: Text
$sel:fieldError:DecodeError :: DecodeError -> FieldError
$sel:mainType:DecodeError :: DecodeError -> Text
..} =
      ([Text] -> [Text]) -> ([Text], Text) -> ([Text], Text)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text
mainType Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:) (FieldError -> ([Text], Text)
field FieldError
fieldError)
    field :: FieldError -> ([Text], Text)
field = \case
      FieldError Text
msg ->
        ([], Text
msg)
      NestedFieldError DecodeError
nerr ->
        DecodeError -> ([Text], Text)
nest DecodeError
nerr

-- |Create a user-friendly message for a 'DecodeError'.
renderError :: DecodeError -> Text
renderError :: DecodeError -> Text
renderError DecodeError
err =
  [exon|Decoding #{mainTypes}: #{fieldMsg}|]
  where
    (Text
mainTypes, Text
fieldMsg) =
      DecodeError -> (Text, Text)
compileError DecodeError
err

instance Reportable DecodeError where
  toReport :: DecodeError -> Report
toReport DecodeError
err =
    HasCallStack => Text -> [Text] -> Severity -> Report
Text -> [Text] -> Severity -> Report
Report Text
msg [Text
Item [Text]
msg] Severity
Error
    where
      msg :: Text
msg =
        DecodeError -> Text
renderError DecodeError
err

-- |Convert a 'FieldError' in a 'Left' to a 'DecodeError' by adding the type name via 'Typeable'.
toDecodeError ::
  ∀ a .
  Typeable a =>
  Either FieldError a ->
  Either DecodeError a
toDecodeError :: forall a. Typeable a => Either FieldError a -> Either DecodeError a
toDecodeError =
  (FieldError -> DecodeError)
-> Either FieldError a -> Either DecodeError a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Text -> FieldError -> DecodeError
DecodeError (TypeRep a -> Text
forall b a. (Show a, IsString b) => a -> b
show (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a)))

-- |Create a @'Left' 'DecodeError'@ from a 'Text' by adding the type name via 'Typeable'.
decodeError ::
  ∀ a .
  Typeable a =>
  Text ->
  Either DecodeError a
decodeError :: forall a. Typeable a => Text -> Either DecodeError a
decodeError Text
msg =
  Either FieldError a -> Either DecodeError a
forall a. Typeable a => Either FieldError a -> Either DecodeError a
toDecodeError (FieldError -> Either FieldError a
forall a b. a -> Either a b
Left (Text -> FieldError
FieldError Text
msg))

symbolText ::
  ∀ a .
  KnownSymbol a =>
  Text
symbolText :: forall (a :: Symbol). KnownSymbol a => Text
symbolText =
  String -> Text
forall a. ToText a => a -> Text
toText (Proxy a -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (forall {k} (t :: k). Proxy t
forall {t :: Symbol}. Proxy t
Proxy @a))

describe :: Object -> Text
describe :: Object -> Text
describe = \case
  Object
ObjectNil -> Text
"Nil"
  ObjectUInt Word64
_ -> Text
"UInt"
  ObjectInt Int64
_ -> Text
"Int"
  ObjectBool Bool
_ -> Text
"Bool"
  ObjectFloat Float
_ -> Text
"Float"
  ObjectDouble Double
_ -> Text
"Double"
  ObjectString ByteString
_ -> Text
"String"
  ObjectBinary ByteString
_ -> Text
"Binary"
  ObjectArray [Object]
_ -> Text
"Array"
  ObjectMap Map Object Object
_ -> Text
"Map"
  ObjectExt Int8
_ ByteString
_ -> Text
"Ext"

incompatibleShapeError ::
  Text ->
  Text ->
  FieldError
incompatibleShapeError :: Text -> Text -> FieldError
incompatibleShapeError Text
target Text
got =
  Text -> FieldError
FieldError [exon|Got #{got} for #{target}|]

incompatibleShape ::
  Text ->
  Text ->
  Either FieldError a
incompatibleShape :: forall a. Text -> Text -> Either FieldError a
incompatibleShape Text
target Text
got =
  FieldError -> Either FieldError a
forall a b. a -> Either a b
Left (Text -> Text -> FieldError
incompatibleShapeError Text
target Text
got)

incompatibleCon ::
  Text ->
  Object ->
  Either FieldError a
incompatibleCon :: forall a. Text -> Object -> Either FieldError a
incompatibleCon Text
target Object
o =
  Text -> Text -> Either FieldError a
forall a. Text -> Text -> Either FieldError a
incompatibleShape Text
target (Object -> Text
describe Object
o)

-- |Create a 'FieldError' for a field when the 'Object' constructor is wrong, using 'Typeable' to obtain the type name.
incompatible ::
  ∀ a .
  Typeable a =>
  Object ->
  Either FieldError a
incompatible :: forall a. Typeable a => Object -> Either FieldError a
incompatible =
  Text -> Object -> Either FieldError a
forall a. Text -> Object -> Either FieldError a
incompatibleCon (TypeRep a -> Text
forall b a. (Show a, IsString b) => a -> b
show (forall a. Typeable a => TypeRep a
forall {k} (a :: k). Typeable a => TypeRep a
typeRep @a))

-- |Create a 'DecodeError' for a type when the 'Object' constructor is wrong, using 'Typeable' to obtain the type name.
decodeIncompatible ::
  ∀ a .
  Typeable a =>
  Object ->
  Either DecodeError a
decodeIncompatible :: forall a. Typeable a => Object -> Either DecodeError a
decodeIncompatible Object
o =
  Text -> Either DecodeError a
forall a. Typeable a => Text -> Either DecodeError a
decodeError [exon|Got #{describe o}|]

utf8Error :: UnicodeException -> FieldError
utf8Error :: UnicodeException -> FieldError
utf8Error = \case
  UnicodeException.DecodeError String
_ (Just Word8
w) ->
    Text -> FieldError
FieldError [exon|Invalid byte \x#{toText (showHex w "")}|]
  UnicodeException.DecodeError String
_ Maybe Word8
Nothing ->
    Text -> FieldError
FieldError Text
"Incomplete input"
  UnicodeException
_ ->
    Text -> FieldError
FieldError Text
"Impossible encode error"