{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

-- | Helper functions for parsing values from @JSString@s

module Cardano.Prelude.Json.Parse
  ( parseJSString
  )
where

import Cardano.Prelude.Base

import Data.String (String)
import Formatting (Format, build, formatToString, string)
import Formatting.Buildable (Buildable)
import Text.JSON.Canonical
  ( JSValue(JSString)
  , ReportSchemaErrors(expected)
  , expectedButGotValue
  , fromJSString
  )


-- | Attempt to parse a value of type @a@ from the body of a @JSString@ using
--   @parser@
parseJSString
  :: forall a m e
   . (Typeable a, ReportSchemaErrors m, Buildable e)
  => (Text -> Either e a)
  -> JSValue
  -> m a
parseJSString :: (Text -> Either e a) -> JSValue -> m a
parseJSString Text -> Either e a
parser = \case
  JSString JSString
str ->
    (e -> m a) -> (a -> m a) -> Either e a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> e -> m a
report (String -> e -> m a) -> String -> e -> m a
forall a b. (a -> b) -> a -> b
$ JSString -> String
fromJSString JSString
str) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> m a) -> (String -> Either e a) -> String -> m a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Either e a
parser (Text -> Either e a) -> (String -> Text) -> String -> Either e a
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ JSString -> String
fromJSString JSString
str
  JSValue
val -> String -> JSValue -> m a
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> JSValue -> m a
expectedButGotValue String
typeName JSValue
val
 where
  typeName :: String
  typeName :: String
typeName = TypeRep -> String
forall a b. (Show a, ConvertText String b) => a -> b
show (TypeRep -> String) -> TypeRep -> String
forall a b. (a -> b) -> a -> b
$ Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy @a)

  report :: String -> e -> m a
  report :: String -> e -> m a
report String
str e
err =
    String -> Maybe String -> m a
forall (m :: * -> *) a.
ReportSchemaErrors m =>
String -> Maybe String -> m a
expected String
typeName (String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ Format String (String -> e -> String) -> String -> e -> String
forall a. Format String a -> a
formatToString Format String (String -> e -> String)
forall r. Format r (String -> e -> r)
errFormat String
str e
err)

  errFormat :: Format r (String -> e -> r)
  errFormat :: Format r (String -> e -> r)
errFormat =
    Format (String -> e -> r) (String -> e -> r)
"Failed to parse value from JSString "
      Format (String -> e -> r) (String -> e -> r)
-> Format r (String -> e -> r) -> Format r (String -> e -> r)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (e -> r) (String -> e -> r)
forall r. Format r (String -> r)
string
      Format (e -> r) (String -> e -> r)
-> Format r (e -> r) -> Format r (String -> e -> r)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (e -> r) (e -> r)
"\n"
      Format (e -> r) (e -> r) -> Format r (e -> r) -> Format r (e -> r)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format (e -> r) (e -> r)
"Parser failed with error: "
      Format (e -> r) (e -> r) -> Format r (e -> r) -> Format r (e -> r)
forall k (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Format r (e -> r)
forall a r. Buildable a => Format r (a -> r)
build