module Data.Yaml.Marked.Parse
  ( withObject
  , withArray
  , withText
  , withScientific
  , withBool
  , (.:)
  , (.:?)
  , array
  , json
  , value
  , text
  , double
  , int
  , bool

    -- * Lower-level
  , withPrependedPath
  ) where

import Prelude

import Data.Aeson.Compat (FromJSON, Key)
import qualified Data.Aeson.Compat as Aeson
import qualified Data.Aeson.Compat.Key as Key
import qualified Data.Aeson.Compat.KeyMap as KeyMap
import Data.Aeson.Types (formatRelativePath)
import Data.Bifunctor (first)
import Data.Foldable (toList)
import Data.Scientific (Scientific)
import Data.Text (Text)
import Data.Yaml.Marked
import Data.Yaml.Marked.Value

withObject
  :: String
  -> (MarkedObject -> Either String a)
  -> Marked Value
  -> Either String (Marked a)
withObject :: forall a.
String
-> (MarkedObject -> Either String a)
-> Marked Value
-> Either String (Marked a)
withObject String
label MarkedObject -> Either String a
f = (Value -> Either String a)
-> Marked Value -> Either String (Marked a)
forall val a.
(val -> Either String a) -> Marked val -> Either String (Marked a)
withPrependedPath ((Value -> Either String a)
 -> Marked Value -> Either String (Marked a))
-> (Value -> Either String a)
-> Marked Value
-> Either String (Marked a)
forall a b. (a -> b) -> a -> b
$ \case
  Object MarkedObject
hm -> MarkedObject -> Either String a
f MarkedObject
hm
  Value
v -> String -> Either String a -> Either String a
forall a. String -> Either String a -> Either String a
prependContext String
label (Either String a -> Either String a)
-> Either String a -> Either String a
forall a b. (a -> b) -> a -> b
$ String -> Value -> Either String a
forall a. String -> Value -> Either String a
typeMismatch String
"Object" Value
v

withArray
  :: String
  -> (MarkedArray -> Either String a)
  -> Marked Value
  -> Either String (Marked a)
withArray :: forall a.
String
-> (MarkedArray -> Either String a)
-> Marked Value
-> Either String (Marked a)
withArray String
label MarkedArray -> Either String a
f = (Value -> Either String a)
-> Marked Value -> Either String (Marked a)
forall val a.
(val -> Either String a) -> Marked val -> Either String (Marked a)
withPrependedPath ((Value -> Either String a)
 -> Marked Value -> Either String (Marked a))
-> (Value -> Either String a)
-> Marked Value
-> Either String (Marked a)
forall a b. (a -> b) -> a -> b
$ \case
  Array MarkedArray
v -> MarkedArray -> Either String a
f MarkedArray
v
  Value
v -> String -> Either String a -> Either String a
forall a. String -> Either String a -> Either String a
prependContext String
label (Either String a -> Either String a)
-> Either String a -> Either String a
forall a b. (a -> b) -> a -> b
$ String -> Value -> Either String a
forall a. String -> Value -> Either String a
typeMismatch String
"Array" Value
v

withText
  :: String
  -> (Text -> Either String a)
  -> Marked Value
  -> Either String (Marked a)
withText :: forall a.
String
-> (Text -> Either String a)
-> Marked Value
-> Either String (Marked a)
withText String
label Text -> Either String a
f = (Value -> Either String a)
-> Marked Value -> Either String (Marked a)
forall val a.
(val -> Either String a) -> Marked val -> Either String (Marked a)
withPrependedPath ((Value -> Either String a)
 -> Marked Value -> Either String (Marked a))
-> (Value -> Either String a)
-> Marked Value
-> Either String (Marked a)
forall a b. (a -> b) -> a -> b
$ \case
  String Text
t -> Text -> Either String a
f Text
t
  Value
v -> String -> Either String a -> Either String a
forall a. String -> Either String a -> Either String a
prependContext String
label (Either String a -> Either String a)
-> Either String a -> Either String a
forall a b. (a -> b) -> a -> b
$ String -> Value -> Either String a
forall a. String -> Value -> Either String a
typeMismatch String
"String" Value
v

withScientific
  :: String
  -> (Scientific -> Either String a)
  -> Marked Value
  -> Either String (Marked a)
withScientific :: forall a.
String
-> (Scientific -> Either String a)
-> Marked Value
-> Either String (Marked a)
withScientific String
label Scientific -> Either String a
f = (Value -> Either String a)
-> Marked Value -> Either String (Marked a)
forall val a.
(val -> Either String a) -> Marked val -> Either String (Marked a)
withPrependedPath ((Value -> Either String a)
 -> Marked Value -> Either String (Marked a))
-> (Value -> Either String a)
-> Marked Value
-> Either String (Marked a)
forall a b. (a -> b) -> a -> b
$ \case
  Number Scientific
s -> Scientific -> Either String a
f Scientific
s
  Value
v -> String -> Either String a -> Either String a
forall a. String -> Either String a -> Either String a
prependContext String
label (Either String a -> Either String a)
-> Either String a -> Either String a
forall a b. (a -> b) -> a -> b
$ String -> Value -> Either String a
forall a. String -> Value -> Either String a
typeMismatch String
"Number" Value
v

withBool
  :: String
  -> (Bool -> Either String a)
  -> Marked Value
  -> Either String (Marked a)
withBool :: forall a.
String
-> (Bool -> Either String a)
-> Marked Value
-> Either String (Marked a)
withBool String
label Bool -> Either String a
f = (Value -> Either String a)
-> Marked Value -> Either String (Marked a)
forall val a.
(val -> Either String a) -> Marked val -> Either String (Marked a)
withPrependedPath ((Value -> Either String a)
 -> Marked Value -> Either String (Marked a))
-> (Value -> Either String a)
-> Marked Value
-> Either String (Marked a)
forall a b. (a -> b) -> a -> b
$ \case
  Bool Bool
b -> Bool -> Either String a
f Bool
b
  Value
v -> String -> Either String a -> Either String a
forall a. String -> Either String a -> Either String a
prependContext String
label (Either String a -> Either String a)
-> Either String a -> Either String a
forall a b. (a -> b) -> a -> b
$ String -> Value -> Either String a
forall a. String -> Value -> Either String a
typeMismatch String
"Bool" Value
v

prependContext :: String -> Either String a -> Either String a
prependContext :: forall a. String -> Either String a -> Either String a
prependContext String
label = (String -> String) -> Either String a -> Either String a
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
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<>)
 where
  prefix :: String
prefix = String
"parsing " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
label String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" failed, "

typeMismatch :: String -> Value -> Either String a
typeMismatch :: forall a. String -> Value -> Either String a
typeMismatch String
expected =
  String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a)
-> (Value -> String) -> Value -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<>) (String -> String) -> (Value -> String) -> Value -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
    Object {} -> String
"Object"
    Array {} -> String
"Array"
    String {} -> String
"String"
    Number {} -> String
"Number"
    Bool {} -> String
"Bool"
    Value
Null -> String
"Null"
 where
  prefix :: String
prefix = String
"expected " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
expected String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", but encountered "

(.:) :: MarkedObject -> Key -> Either String (Marked Value)
.: :: MarkedObject -> Key -> Either String (Marked Value)
(.:) MarkedObject
km Key
k = Either String (Marked Value)
-> (Marked Value -> Either String (Marked Value))
-> Maybe (Marked Value)
-> Either String (Marked Value)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String (Marked Value)
forall a b. a -> Either a b
Left (String -> Either String (Marked Value))
-> String -> Either String (Marked Value)
forall a b. (a -> b) -> a -> b
$ String
"Key not found: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Key -> String
Key.toString Key
k) Marked Value -> Either String (Marked Value)
forall a b. b -> Either a b
Right (Maybe (Marked Value) -> Either String (Marked Value))
-> Maybe (Marked Value) -> Either String (Marked Value)
forall a b. (a -> b) -> a -> b
$ Key -> MarkedObject -> Maybe (Marked Value)
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
k MarkedObject
km

(.:?) :: MarkedObject -> Key -> Either String (Maybe (Marked Value))
.:? :: MarkedObject -> Key -> Either String (Maybe (Marked Value))
(.:?) MarkedObject
km Key
k = Maybe (Marked Value) -> Either String (Maybe (Marked Value))
forall a b. b -> Either a b
Right (Maybe (Marked Value) -> Either String (Maybe (Marked Value)))
-> Maybe (Marked Value) -> Either String (Maybe (Marked Value))
forall a b. (a -> b) -> a -> b
$ Key -> MarkedObject -> Maybe (Marked Value)
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
k MarkedObject
km

array
  :: (Marked Value -> Either String (Marked a))
  -> Marked Value
  -> Either String (Marked [Marked a])
array :: forall a.
(Marked Value -> Either String (Marked a))
-> Marked Value -> Either String (Marked [Marked a])
array Marked Value -> Either String (Marked a)
f = String
-> (MarkedArray -> Either String [Marked a])
-> Marked Value
-> Either String (Marked [Marked a])
forall a.
String
-> (MarkedArray -> Either String a)
-> Marked Value
-> Either String (Marked a)
withArray String
"an array" ((MarkedArray -> Either String [Marked a])
 -> Marked Value -> Either String (Marked [Marked a]))
-> (MarkedArray -> Either String [Marked a])
-> Marked Value
-> Either String (Marked [Marked a])
forall a b. (a -> b) -> a -> b
$ (Marked Value -> Either String (Marked a))
-> [Marked Value] -> Either String [Marked a]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Marked Value -> Either String (Marked a)
f ([Marked Value] -> Either String [Marked a])
-> (MarkedArray -> [Marked Value])
-> MarkedArray
-> Either String [Marked a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MarkedArray -> [Marked Value]
forall a. Vector a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | Parse the value using its 'FromJSON' instance, passing along the marks
json :: FromJSON a => Marked Value -> Either String (Marked a)
json :: forall a. FromJSON a => Marked Value -> Either String (Marked a)
json = (Value -> Either String a)
-> Marked Value -> Either String (Marked a)
forall val a.
(val -> Either String a) -> Marked val -> Either String (Marked a)
withPrependedPath Value -> Either String a
forall a. FromJSON a => Value -> Either String a
valueAsJSON

value :: Marked Value -> Either String (Marked Aeson.Value)
value :: Marked Value -> Either String (Marked Value)
value = Marked Value -> Either String (Marked Value)
forall a. FromJSON a => Marked Value -> Either String (Marked a)
json

text :: Marked Value -> Either String (Marked Text)
text :: Marked Value -> Either String (Marked Text)
text = Marked Value -> Either String (Marked Text)
forall a. FromJSON a => Marked Value -> Either String (Marked a)
json

double :: Marked Value -> Either String (Marked Double)
double :: Marked Value -> Either String (Marked Double)
double = Marked Value -> Either String (Marked Double)
forall a. FromJSON a => Marked Value -> Either String (Marked a)
json

int :: Marked Value -> Either String (Marked Int)
int :: Marked Value -> Either String (Marked Int)
int = Marked Value -> Either String (Marked Int)
forall a. FromJSON a => Marked Value -> Either String (Marked a)
json

bool :: Marked Value -> Either String (Marked Bool)
bool :: Marked Value -> Either String (Marked Bool)
bool = Marked Value -> Either String (Marked Bool)
forall a. FromJSON a => Marked Value -> Either String (Marked a)
json

-- | Prepend an error with an item's 'markedJSONPath', when present
--
-- All of the functions above do this already. You would only need this if
-- you're writing something that doesn't us them.
withPrependedPath
  :: (val -> Either String a)
  -> Marked val
  -> Either String (Marked a)
withPrependedPath :: forall val a.
(val -> Either String a) -> Marked val -> Either String (Marked a)
withPrependedPath val -> Either String a
f Marked val
mv = (String -> String)
-> Either String (Marked a) -> Either String (Marked a)
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 -> String
format (Either String (Marked a) -> Either String (Marked a))
-> Either String (Marked a) -> Either String (Marked a)
forall a b. (a -> b) -> a -> b
$ (val -> Either String a) -> Marked val -> Either String (Marked a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Marked a -> f (Marked b)
traverse val -> Either String a
f Marked val
mv
 where
  format :: String -> String
  format :: String -> String
format = case Marked val -> Maybe JSONPath
forall a. Marked a -> Maybe JSONPath
markedJSONPath Marked val
mv of
    Maybe JSONPath
Nothing -> String -> String
forall a. a -> a
id
    Just [] -> String -> String -> String
prependPathElem String
"Error in $"
    Just JSONPath
xs -> String -> String -> String
prependPathElem (String -> String -> String) -> String -> String -> String
forall a b. (a -> b) -> a -> b
$ JSONPath -> String
formatRelativePath [JSONPath -> JSONPathElement
forall a. HasCallStack => [a] -> a
last JSONPath
xs]

prependPathElem :: String -> String -> String
prependPathElem :: String -> String -> String
prependPathElem String
prefix = \case
  ys :: String
ys@(Char
'[' : String
_) -> String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ys -- ys is "[k]", make it (e.g.) "$[k]"
  String
ys -> String
prefix String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
ys -- ys is "{...}", make it (e.g.) "$: {...}"