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

import Prelude

import Data.Aeson.Compat (FromJSON, Key)
import qualified Data.Aeson.Compat as Aeson
import qualified Data.Aeson.Compat.KeyMap as KeyMap
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 (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 ((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 (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 ((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 (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 ((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 (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 ((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 (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 ((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
"Key not found") 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 (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 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