{-# LANGUAGE PolyKinds, DataKinds, KindSignatures,
ExplicitForAll, TemplateHaskell, ViewPatterns,
ScopedTypeVariables, TypeOperators, TypeFamilies,
GeneralizedNewtypeDeriving, GADTs, LambdaCase #-}
module Data.Yaml.Combinators
( Parser
, parse
, runParser
, string
, theString
, number
, integer
, bool
, null_
, array
, theArray
, ElementParser
, element
, object
, FieldParser
, field
, optField
, defaultField
, theField
, extraFields
, anyValue
, ParseError(..)
, ppParseError
, Reason(..)
, validate
) where
import Data.Scientific
import Data.Yaml (decodeEither', encode)
import Data.Aeson (Array, Object, Value (..))
import qualified Data.Aeson.Key as Key
import qualified Data.Aeson.KeyMap as KeyMap
import Data.Text (Text)
import Data.List
import Data.Maybe
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import Data.Bifunctor (first)
import Control.Monad
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State as State
import Data.Vector (Vector)
import qualified Data.Vector as V
import Data.HashSet (HashSet)
import qualified Data.HashSet as HS
import Data.Ord
import Data.Monoid
import Generics.SOP
import Generics.SOP.TH
import Data.Yaml.Combinators.Free as Free
deriveGeneric ''Value
parse :: Parser a -> ByteString -> Either String a
parse :: forall a. Parser a -> ByteString -> Either [Char] a
parse Parser a
p ByteString
bs = do
Value
aesonValue <- forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Either ParseException a
decodeEither' ByteString
bs
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseError -> [Char]
ppParseError forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Value -> Either ParseError a
runParser Parser a
p Value
aesonValue
data ParseError = ParseError
!Int
Reason
deriving (ParseError -> ParseError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ParseError -> ParseError -> Bool
$c/= :: ParseError -> ParseError -> Bool
== :: ParseError -> ParseError -> Bool
$c== :: ParseError -> ParseError -> Bool
Eq, Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ParseError] -> ShowS
$cshowList :: [ParseError] -> ShowS
show :: ParseError -> [Char]
$cshow :: ParseError -> [Char]
showsPrec :: Int -> ParseError -> ShowS
$cshowsPrec :: Int -> ParseError -> ShowS
Show)
data Reason
= UnexpectedAsPartOf Value Value
| ExpectedAsPartOf (HashSet String) Value
| ExpectedInsteadOf (HashSet String) Value
deriving (Reason -> Reason -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Reason -> Reason -> Bool
$c/= :: Reason -> Reason -> Bool
== :: Reason -> Reason -> Bool
$c== :: Reason -> Reason -> Bool
Eq, Int -> Reason -> ShowS
[Reason] -> ShowS
Reason -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Reason] -> ShowS
$cshowList :: [Reason] -> ShowS
show :: Reason -> [Char]
$cshow :: Reason -> [Char]
showsPrec :: Int -> Reason -> ShowS
$cshowsPrec :: Int -> Reason -> ShowS
Show)
compareSeverity :: ParseError -> ParseError -> Ordering
compareSeverity :: ParseError -> ParseError -> Ordering
compareSeverity (ParseError Int
l1 Reason
r1) (ParseError Int
l2 Reason
r2) =
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reason -> Bool
isUnexpected) Reason
r1 Reason
r2 forall a. Semigroup a => a -> a -> a
<>
forall a. Ord a => a -> a -> Ordering
compare Int
l1 Int
l2 forall a. Semigroup a => a -> a -> a
<>
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing Reason -> Bool
isMismatch Reason
r1 Reason
r2
where
isUnexpected :: Reason -> Bool
isUnexpected Reason
e = case Reason
e of
UnexpectedAsPartOf {} -> Bool
True
Reason
_ -> Bool
False
isMismatch :: Reason -> Bool
isMismatch Reason
e = case Reason
e of
ExpectedInsteadOf {} -> Bool
True
Reason
_ -> Bool
False
moreSevere :: ParseError -> ParseError -> ParseError
moreSevere :: ParseError -> ParseError -> ParseError
moreSevere ParseError
e1 ParseError
e2 =
case ParseError -> ParseError -> Ordering
compareSeverity ParseError
e1 ParseError
e2 of
Ordering
LT -> ParseError
e2
Ordering
_ -> ParseError
e1
lessSevere :: ParseError -> ParseError -> ParseError
lessSevere :: ParseError -> ParseError -> ParseError
lessSevere ParseError
e1 ParseError
e2 =
case ParseError -> ParseError -> Ordering
compareSeverity ParseError
e1 ParseError
e2 of
Ordering
GT -> ParseError
e2
Ordering
_ -> ParseError
e1
newtype Validation a = Validation { forall a. Validation a -> Either ParseError a
getValidation :: Either ParseError a }
deriving forall a b. a -> Validation b -> Validation a
forall a b. (a -> b) -> Validation a -> Validation b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Validation b -> Validation a
$c<$ :: forall a b. a -> Validation b -> Validation a
fmap :: forall a b. (a -> b) -> Validation a -> Validation b
$cfmap :: forall a b. (a -> b) -> Validation a -> Validation b
Functor
instance Applicative Validation where
pure :: forall a. a -> Validation a
pure = forall a. Either ParseError a -> Validation a
Validation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
Validation Either ParseError (a -> b)
a <*> :: forall a b. Validation (a -> b) -> Validation a -> Validation b
<*> Validation Either ParseError a
b = forall a. Either ParseError a -> Validation a
Validation forall a b. (a -> b) -> a -> b
$
case Either ParseError (a -> b)
a of
Right a -> b
va -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
va Either ParseError a
b
Left ParseError
ea -> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> ParseError -> ParseError
moreSevere ParseError
ea) (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ParseError
ea) Either ParseError a
b
bindV :: Validation a -> (a -> Validation b) -> Validation b
bindV :: forall a b. Validation a -> (a -> Validation b) -> Validation b
bindV Validation a
a a -> Validation b
b = forall a. Either ParseError a -> Validation a
Validation forall a b. (a -> b) -> a -> b
$ forall a. Validation a -> Either ParseError a
getValidation Validation a
a forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Validation a -> Either ParseError a
getValidation forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Validation b
b
mergeParseError :: ParseError -> ParseError -> ParseError
mergeParseError :: ParseError -> ParseError -> ParseError
mergeParseError e1 :: ParseError
e1@(ParseError Int
l1 Reason
r1) e2 :: ParseError
e2@(ParseError Int
l2 Reason
r2)
| Int
l1 forall a. Eq a => a -> a -> Bool
== Int
l2
, ExpectedAsPartOf HashSet [Char]
exp1 Value
w1 <- Reason
r1
, ExpectedAsPartOf HashSet [Char]
exp2 Value
w2 <- Reason
r2
, Value
w1 forall a. Eq a => a -> a -> Bool
== Value
w2
= Int -> Reason -> ParseError
ParseError Int
l1 (HashSet [Char] -> Value -> Reason
ExpectedAsPartOf (HashSet [Char]
exp1 forall a. Semigroup a => a -> a -> a
<> HashSet [Char]
exp2) Value
w1)
| Int
l1 forall a. Eq a => a -> a -> Bool
== Int
l2
, ExpectedInsteadOf HashSet [Char]
exp1 Value
w1 <- Reason
r1
, ExpectedInsteadOf HashSet [Char]
exp2 Value
w2 <- Reason
r2
, Value
w1 forall a. Eq a => a -> a -> Bool
== Value
w2
= Int -> Reason -> ParseError
ParseError Int
l1 (HashSet [Char] -> Value -> Reason
ExpectedInsteadOf (HashSet [Char]
exp1 forall a. Semigroup a => a -> a -> a
<> HashSet [Char]
exp2) Value
w1)
| Bool
otherwise = ParseError -> ParseError -> ParseError
lessSevere ParseError
e1 ParseError
e2
ppParseError :: ParseError -> String
ppParseError :: ParseError -> [Char]
ppParseError (ParseError Int
_lvl Reason
reason) =
case Reason
reason of
UnexpectedAsPartOf Value
part Value
whole ->
[Char]
"Unexpected \n\n" forall a. [a] -> [a] -> [a]
++ Value -> [Char]
showYaml Value
part forall a. [a] -> [a] -> [a]
++ [Char]
"\nas part of\n\n" forall a. [a] -> [a] -> [a]
++ Value -> [Char]
showYaml Value
whole
ExpectedInsteadOf HashSet [Char]
exp1 Value
got ->
[Char]
"Expected " forall a. [a] -> [a] -> [a]
++ HashSet [Char] -> [Char]
fmt_list HashSet [Char]
exp1 forall a. [a] -> [a] -> [a]
++ [Char]
" instead of:\n\n" forall a. [a] -> [a] -> [a]
++ Value -> [Char]
showYaml Value
got
ExpectedAsPartOf HashSet [Char]
exp1 Value
got ->
[Char]
"Expected " forall a. [a] -> [a] -> [a]
++ HashSet [Char] -> [Char]
fmt_list HashSet [Char]
exp1 forall a. [a] -> [a] -> [a]
++ [Char]
" as part of:\n\n" forall a. [a] -> [a] -> [a]
++ Value -> [Char]
showYaml Value
got
where
showYaml :: Value -> String
showYaml :: Value -> [Char]
showYaml = ByteString -> [Char]
BS8.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode
fmt_list :: HashSet String -> String
fmt_list :: HashSet [Char] -> [Char]
fmt_list = forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashSet a -> [a]
HS.toList
newtype ParserComponent a fs = ParserComponent (Maybe (Value -> NP I fs -> Validation a))
newtype Parser a = Parser (NP (ParserComponent a) (Code Value))
pcFmap :: (a -> b) -> ParserComponent a fs -> ParserComponent b fs
pcFmap :: forall a b (fs :: [*]).
(a -> b) -> ParserComponent a fs -> ParserComponent b fs
pcFmap a -> b
f (ParserComponent Maybe (Value -> NP I fs -> Validation a)
mbP) = forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a -> b) -> a -> b
$ a -> b
f) Maybe (Value -> NP I fs -> Validation a)
mbP
instance Functor Parser where
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
fmap a -> b
f (Parser NP (ParserComponent a) (Code Value)
comps) = forall a. NP (ParserComponent a) (Code Value) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
(f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hliftA (forall a b (fs :: [*]).
(a -> b) -> ParserComponent a fs -> ParserComponent b fs
pcFmap a -> b
f) NP (ParserComponent a) (Code Value)
comps
instance Semigroup (ParserComponent a fs) where
ParserComponent Maybe (Value -> NP I fs -> Validation a)
mbP1 <> :: ParserComponent a fs
-> ParserComponent a fs -> ParserComponent a fs
<> ParserComponent Maybe (Value -> NP I fs -> Validation a)
mbP2 =
forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$ case (Maybe (Value -> NP I fs -> Validation a)
mbP1, Maybe (Value -> NP I fs -> Validation a)
mbP2) of
(Maybe (Value -> NP I fs -> Validation a)
Nothing, Maybe (Value -> NP I fs -> Validation a)
Nothing) -> forall a. Maybe a
Nothing
(Just Value -> NP I fs -> Validation a
p1, Maybe (Value -> NP I fs -> Validation a)
Nothing) -> forall a. a -> Maybe a
Just Value -> NP I fs -> Validation a
p1
(Maybe (Value -> NP I fs -> Validation a)
Nothing, Just Value -> NP I fs -> Validation a
p2) -> forall a. a -> Maybe a
Just Value -> NP I fs -> Validation a
p2
(Just Value -> NP I fs -> Validation a
p1, Just Value -> NP I fs -> Validation a
p2) -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \Value
o NP I fs
v -> forall a. Either ParseError a -> Validation a
Validation forall a b. (a -> b) -> a -> b
$
case (forall a. Validation a -> Either ParseError a
getValidation forall a b. (a -> b) -> a -> b
$ Value -> NP I fs -> Validation a
p1 Value
o NP I fs
v, forall a. Validation a -> Either ParseError a
getValidation forall a b. (a -> b) -> a -> b
$ Value -> NP I fs -> Validation a
p2 Value
o NP I fs
v) of
(Right a
r1, Either ParseError a
_) -> forall a b. b -> Either a b
Right a
r1
(Either ParseError a
_, Right a
r2) -> forall a b. b -> Either a b
Right a
r2
(Left ParseError
l1, Left ParseError
l2) -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ParseError -> ParseError -> ParseError
mergeParseError ParseError
l1 ParseError
l2
instance Monoid (ParserComponent a fs) where
mempty :: ParserComponent a fs
mempty = forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a. Maybe a
Nothing
mappend :: ParserComponent a fs
-> ParserComponent a fs -> ParserComponent a fs
mappend = forall a. Semigroup a => a -> a -> a
(<>)
instance Semigroup (Parser a) where
Parser NP (ParserComponent a) (Code Value)
rec1 <> :: Parser a -> Parser a -> Parser a
<> Parser NP (ParserComponent a) (Code Value)
rec2 = forall a. NP (ParserComponent a) (Code Value) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
(f' :: k -> *) (f'' :: k -> *).
(SListIN (Prod h) xs, HAp h, HAp (Prod h)) =>
(forall (a :: k). f a -> f' a -> f'' a)
-> Prod h f xs -> h f' xs -> h f'' xs
hliftA2 forall a. Monoid a => a -> a -> a
mappend NP (ParserComponent a) (Code Value)
rec1 NP (ParserComponent a) (Code Value)
rec2
instance Monoid (Parser a) where
mempty :: Parser a
mempty = forall a. NP (ParserComponent a) (Code Value) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *).
(HPure h, SListIN h xs) =>
(forall (a :: k). f a) -> h f xs
hpure forall a. Monoid a => a
mempty
mappend :: Parser a -> Parser a -> Parser a
mappend = forall a. Semigroup a => a -> a -> a
(<>)
runParser :: Parser a -> Value -> Either ParseError a
runParser :: forall a. Parser a -> Value -> Either ParseError a
runParser Parser a
p = forall a. Validation a -> Either ParseError a
getValidation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Value -> Validation a
runParserV Parser a
p
runParserV :: Parser a -> Value -> Validation a
runParserV :: forall a. Parser a -> Value -> Validation a
runParserV (Parser NP (ParserComponent a) (Code Value)
comps) orig :: Value
orig@(forall a. Generic a => a -> Rep a
from -> SOP NS (NP I) (Code Value)
v) =
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
(f' :: k -> *) (f'' :: k -> *).
(SListIN (Prod h) xs, HAp h, HAp (Prod h)) =>
(forall (a :: k). f a -> f' a -> f'' a)
-> Prod h f xs -> h f' xs -> h f'' xs
hliftA2 forall a (fs :: [*]).
ParserComponent a fs -> NP I fs -> K (Validation a) fs
match NP (ParserComponent a) (Code Value)
comps NS (NP I) (Code Value)
v
where
match :: ParserComponent a fs -> NP I fs -> K (Validation a) fs
match :: forall a (fs :: [*]).
ParserComponent a fs -> NP I fs -> K (Validation a) fs
match (ParserComponent Maybe (Value -> NP I fs -> Validation a)
mbP) NP I fs
v1 = forall k a (b :: k). a -> K a b
K forall a b. (a -> b) -> a -> b
$
case Maybe (Value -> NP I fs -> Validation a)
mbP of
Maybe (Value -> NP I fs -> Validation a)
Nothing -> forall a. Either ParseError a -> Validation a
Validation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> Reason -> ParseError
ParseError Int
0 forall a b. (a -> b) -> a -> b
$ HashSet [Char] -> Value -> Reason
ExpectedInsteadOf (forall a. Hashable a => a -> HashSet a
HS.singleton [Char]
expected) Value
orig
Just Value -> NP I fs -> Validation a
p -> Value -> NP I fs -> Validation a
p Value
orig NP I fs
v1
expected :: [Char]
expected =
let
f :: ParserComponent a fs -> K a b -> K (Maybe a) b
f (ParserComponent Maybe (Value -> NP I fs -> Validation a)
pc) (K a
name) = forall k a (b :: k). a -> K a b
K (a
name forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Maybe (Value -> NP I fs -> Validation a)
pc)
in forall a. [a] -> [[a]] -> [a]
intercalate [Char]
", " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [Maybe a] -> [a]
catMaybes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
hcollapse forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
(f' :: k -> *) (f'' :: k -> *).
(SListIN (Prod h) xs, HAp h, HAp (Prod h)) =>
(forall (a :: k). f a -> f' a -> f'' a)
-> Prod h f xs -> h f' xs -> h f'' xs
hliftA2 forall {k} {k} {a} {fs :: [*]} {a} {b :: k} {b :: k}.
ParserComponent a fs -> K a b -> K (Maybe a) b
f NP (ParserComponent a) (Code Value)
comps NP (K [Char]) (Code Value)
valueConNames
valueConNames :: NP (K String) (Code Value)
valueConNames :: NP (K [Char]) (Code Value)
valueConNames =
let
ADT [Char]
_ [Char]
_ NP ConstructorInfo (Code Value)
cons POP StrictnessInfo (Code Value)
_ = forall a (proxy :: * -> *).
HasDatatypeInfo a =>
proxy a -> DatatypeInfo (Code a)
datatypeInfo (forall {k} (t :: k). Proxy t
Proxy :: Proxy Value)
in forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
(f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hliftA (\(Constructor [Char]
name) -> forall k a (b :: k). a -> K a b
K [Char]
name) NP
ConstructorInfo
'[ '[Object], '[Array], '[Text], '[Scientific], '[Bool], '[]]
cons
fromComponent :: forall a . NS (ParserComponent a) (Code Value) -> Parser a
fromComponent :: forall a. NS (ParserComponent a) (Code Value) -> Parser a
fromComponent NS (ParserComponent a) (Code Value)
parser = forall a. NP (ParserComponent a) (Code Value) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *).
(HExpand h, SListIN (Prod h) xs) =>
(forall (x :: k). f x) -> h f xs -> Prod h f xs
hexpand forall a. Monoid a => a
mempty NS (ParserComponent a) (Code Value)
parser
decorate :: forall a b. Parser a -> (a -> Value -> Either ParseError b) -> Parser b
decorate :: forall a b.
Parser a -> (a -> Value -> Either ParseError b) -> Parser b
decorate (Parser NP (ParserComponent a) (Code Value)
components) a -> Value -> Either ParseError b
decorator = forall a. NP (ParserComponent a) (Code Value) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ forall {k} {l} (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *)
(f' :: k -> *).
(SListIN (Prod h) xs, HAp h) =>
(forall (a :: k). f a -> f' a) -> h f xs -> h f' xs
hmap forall (fs :: [*]). ParserComponent a fs -> ParserComponent b fs
wrap NP (ParserComponent a) (Code Value)
components
where
wrap :: ParserComponent a fs -> ParserComponent b fs
wrap :: forall (fs :: [*]). ParserComponent a fs -> ParserComponent b fs
wrap (ParserComponent Maybe (Value -> NP I fs -> Validation a)
maybeP) = forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$
case Maybe (Value -> NP I fs -> Validation a)
maybeP of
Maybe (Value -> NP I fs -> Validation a)
Nothing -> forall a. Maybe a
Nothing
Just Value -> NP I fs -> Validation a
p -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \Value
orig NP I fs
val -> Value -> NP I fs -> Validation a
p Value
orig NP I fs
val forall a b. Validation a -> (a -> Validation b) -> Validation b
`bindV`
\a
parsed -> forall a. Either ParseError a -> Validation a
Validation forall a b. (a -> b) -> a -> b
$ a -> Value -> Either ParseError b
decorator a
parsed Value
orig
incErrLevel :: Validation a -> Validation a
incErrLevel :: forall a. Validation a -> Validation a
incErrLevel = forall a. Either ParseError a -> Validation a
Validation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (\(ParseError Int
l Reason
r) -> Int -> Reason -> ParseError
ParseError (Int
lforall a. Num a => a -> a -> a
+Int
1) Reason
r) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Validation a -> Either ParseError a
getValidation
string :: Parser Text
string :: Parser Text
string = forall a. NS (ParserComponent a) (Code Value) -> Parser a
fromComponent forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \(I x
s :* NP I xs
Nil) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure x
s
theString :: Text -> Parser ()
theString :: Text -> Parser ()
theString Text
t = forall a. NS (ParserComponent a) (Code Value) -> Parser a
fromComponent forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \(I x
s :* NP I xs
Nil) ->
forall a. Either ParseError a -> Validation a
Validation forall a b. (a -> b) -> a -> b
$ if x
s forall a. Eq a => a -> a -> Bool
== Text
t
then forall a b. b -> Either a b
Right ()
else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> Reason -> ParseError
ParseError Int
0 (HashSet [Char] -> Value -> Reason
ExpectedInsteadOf (forall a. Hashable a => a -> HashSet a
HS.singleton forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Text
t) (Text -> Value
String x
s))
array :: Parser a -> Parser (Vector a)
array :: forall a. Parser a -> Parser (Vector a)
array Parser a
p = forall a. NS (ParserComponent a) (Code Value) -> Parser a
fromComponent forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \(I x
a :* NP I xs
Nil) -> forall a. Validation a -> Validation a
incErrLevel forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a. Parser a -> Value -> Validation a
runParserV Parser a
p) x
a
newtype ElementParser a = ElementParser
(((State [Value]) :.: (ReaderT Array Validation)) a)
deriving (forall a b. a -> ElementParser b -> ElementParser a
forall a b. (a -> b) -> ElementParser a -> ElementParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ElementParser b -> ElementParser a
$c<$ :: forall a b. a -> ElementParser b -> ElementParser a
fmap :: forall a b. (a -> b) -> ElementParser a -> ElementParser b
$cfmap :: forall a b. (a -> b) -> ElementParser a -> ElementParser b
Functor, Functor ElementParser
forall a. a -> ElementParser a
forall a b. ElementParser a -> ElementParser b -> ElementParser a
forall a b. ElementParser a -> ElementParser b -> ElementParser b
forall a b.
ElementParser (a -> b) -> ElementParser a -> ElementParser b
forall a b c.
(a -> b -> c)
-> ElementParser a -> ElementParser b -> ElementParser c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. ElementParser a -> ElementParser b -> ElementParser a
$c<* :: forall a b. ElementParser a -> ElementParser b -> ElementParser a
*> :: forall a b. ElementParser a -> ElementParser b -> ElementParser b
$c*> :: forall a b. ElementParser a -> ElementParser b -> ElementParser b
liftA2 :: forall a b c.
(a -> b -> c)
-> ElementParser a -> ElementParser b -> ElementParser c
$cliftA2 :: forall a b c.
(a -> b -> c)
-> ElementParser a -> ElementParser b -> ElementParser c
<*> :: forall a b.
ElementParser (a -> b) -> ElementParser a -> ElementParser b
$c<*> :: forall a b.
ElementParser (a -> b) -> ElementParser a -> ElementParser b
pure :: forall a. a -> ElementParser a
$cpure :: forall a. a -> ElementParser a
Applicative)
element :: Parser a -> ElementParser a
element :: forall a. Parser a -> ElementParser a
element Parser a
p = forall a.
(:.:) (State [Value]) (ReaderT Array Validation) a
-> ElementParser a
ElementParser forall a b. (a -> b) -> a -> b
$ forall l k (f :: l -> *) (g :: k -> l) (p :: k).
f (g p) -> (:.:) f g p
Comp forall a b. (a -> b) -> a -> b
$ do
[Value]
vs <- forall (m :: * -> *) s. Monad m => StateT s m s
State.get
case [Value]
vs of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \Array
arr -> forall a. Either ParseError a -> Validation a
Validation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
let n :: Int
n = forall a. Vector a -> Int
V.length Array
arr forall a. Num a => a -> a -> a
+ Int
1
in Int -> Reason -> ParseError
ParseError Int
0 forall a b. (a -> b) -> a -> b
$ HashSet [Char] -> Value -> Reason
ExpectedAsPartOf (forall a. Hashable a => a -> HashSet a
HS.singleton forall a b. (a -> b) -> a -> b
$ [Char]
"at least " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
n forall a. [a] -> [a] -> [a]
++ [Char]
" elements") forall a b. (a -> b) -> a -> b
$ Array -> Value
Array Array
arr
(Value
v:[Value]
vs') -> do
forall (m :: * -> *) s. Monad m => s -> StateT s m ()
State.put [Value]
vs'
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a r. f a -> ReaderT r f a
liftR forall a b. (a -> b) -> a -> b
$ forall a. Parser a -> Value -> Validation a
runParserV Parser a
p Value
v
theArray :: ElementParser a -> Parser a
theArray :: forall a. ElementParser a -> Parser a
theArray (ElementParser (Comp State [Value] (ReaderT Array Validation a)
ep)) = forall a. NS (ParserComponent a) (Code Value) -> Parser a
fromComponent forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \(I x
a :* NP I xs
Nil) -> forall a. Validation a -> Validation a
incErrLevel forall a b. (a -> b) -> a -> b
$
case forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT x
a) forall a b. (a -> b) -> a -> b
$ forall s a. State s a -> s -> (a, s)
runState State [Value] (ReaderT Array Validation a)
ep (forall a. Vector a -> [a]
V.toList x
a) of
(Validation a
result, [Value]
leftover) ->
Validation a
result forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
(case [Value]
leftover of
[] -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Value
v : [Value]
_ -> forall a. Either ParseError a -> Validation a
Validation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> Reason -> ParseError
ParseError Int
0 forall a b. (a -> b) -> a -> b
$ Value -> Value -> Reason
UnexpectedAsPartOf Value
v forall a b. (a -> b) -> a -> b
$ Array -> Value
Array x
a
)
number :: Parser Scientific
number :: Parser Scientific
number = forall a. NS (ParserComponent a) (Code Value) -> Parser a
fromComponent forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \(I x
n :* NP I xs
Nil) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure x
n
integer :: (Integral i, Bounded i) => Parser i
integer :: forall i. (Integral i, Bounded i) => Parser i
integer = forall a. NS (ParserComponent a) (Code Value) -> Parser a
fromComponent forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \(I x
n :* NP I xs
Nil) ->
case forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger x
n of
Just i
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure i
i
Maybe i
Nothing -> forall a. Either ParseError a -> Validation a
Validation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> Reason -> ParseError
ParseError Int
0 forall a b. (a -> b) -> a -> b
$ HashSet [Char] -> Value -> Reason
ExpectedInsteadOf (forall a. Hashable a => a -> HashSet a
HS.singleton [Char]
"integer") (Scientific -> Value
Number x
n)
bool :: Parser Bool
bool :: Parser Bool
bool = forall a. NS (ParserComponent a) (Code Value) -> Parser a
fromComponent forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \(I x
b :* NP I xs
Nil) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure x
b
null_ :: Parser ()
null_ :: Parser ()
null_ = forall a. NS (ParserComponent a) (Code Value) -> Parser a
fromComponent forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (xs :: [k]) (x :: k).
NS a xs -> NS a (x : xs)
S forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \NP I '[]
Nil -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
validate ::
Parser a
-> (a -> Either String b)
-> Parser b
validate :: forall a b. Parser a -> (a -> Either [Char] b) -> Parser b
validate Parser a
parser a -> Either [Char] b
validator =
forall a b.
Parser a -> (a -> Value -> Either ParseError b) -> Parser b
decorate Parser a
parser (forall {b}. Either [Char] b -> Value -> Either ParseError b
validity forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either [Char] b
validator)
where
validity :: Either [Char] b -> Value -> Either ParseError b
validity (Right b
result) Value
_ = forall a b. b -> Either a b
Right b
result
validity (Left [Char]
problem) Value
orig = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> Reason -> ParseError
ParseError Int
1 forall a b. (a -> b) -> a -> b
$ HashSet [Char] -> Value -> Reason
ExpectedInsteadOf (forall a. Hashable a => a -> HashSet a
HS.singleton [Char]
problem) Value
orig
newtype FieldParser a = FieldParser
(Free FieldParserBase a)
deriving (forall a b. a -> FieldParser b -> FieldParser a
forall a b. (a -> b) -> FieldParser a -> FieldParser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FieldParser b -> FieldParser a
$c<$ :: forall a b. a -> FieldParser b -> FieldParser a
fmap :: forall a b. (a -> b) -> FieldParser a -> FieldParser b
$cfmap :: forall a b. (a -> b) -> FieldParser a -> FieldParser b
Functor, Functor FieldParser
forall a. a -> FieldParser a
forall a b. FieldParser a -> FieldParser b -> FieldParser a
forall a b. FieldParser a -> FieldParser b -> FieldParser b
forall a b. FieldParser (a -> b) -> FieldParser a -> FieldParser b
forall a b c.
(a -> b -> c) -> FieldParser a -> FieldParser b -> FieldParser c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. FieldParser a -> FieldParser b -> FieldParser a
$c<* :: forall a b. FieldParser a -> FieldParser b -> FieldParser a
*> :: forall a b. FieldParser a -> FieldParser b -> FieldParser b
$c*> :: forall a b. FieldParser a -> FieldParser b -> FieldParser b
liftA2 :: forall a b c.
(a -> b -> c) -> FieldParser a -> FieldParser b -> FieldParser c
$cliftA2 :: forall a b c.
(a -> b -> c) -> FieldParser a -> FieldParser b -> FieldParser c
<*> :: forall a b. FieldParser (a -> b) -> FieldParser a -> FieldParser b
$c<*> :: forall a b. FieldParser (a -> b) -> FieldParser a -> FieldParser b
pure :: forall a. a -> FieldParser a
$cpure :: forall a. a -> FieldParser a
Applicative)
data FieldParserBase a where
OneField
:: Text
-> ReaderT Object Validation a
-> FieldParserBase a
:: FieldParserBase Object
field
:: Text
-> Parser a
-> FieldParser a
field :: forall a. Text -> Parser a -> FieldParser a
field Text
name Parser a
p = forall a. Free FieldParserBase a -> FieldParser a
FieldParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Free f a
Free.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> ReaderT Object Validation a -> FieldParserBase a
OneField Text
name forall a b. (a -> b) -> a -> b
$
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \Object
o ->
case forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
name) Object
o of
Maybe Value
Nothing -> forall a. Either ParseError a -> Validation a
Validation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> Reason -> ParseError
ParseError Int
0 forall a b. (a -> b) -> a -> b
$ HashSet [Char] -> Value -> Reason
ExpectedAsPartOf (forall a. Hashable a => a -> HashSet a
HS.singleton forall a b. (a -> b) -> a -> b
$ [Char]
"field " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
name) forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
o
Just Value
v -> forall a. Parser a -> Value -> Validation a
runParserV Parser a
p Value
v
optField
:: Text
-> Parser a
-> FieldParser (Maybe a)
optField :: forall a. Text -> Parser a -> FieldParser (Maybe a)
optField Text
name Parser a
p = forall a. Free FieldParserBase a -> FieldParser a
FieldParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Free f a
Free.lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> ReaderT Object Validation a -> FieldParserBase a
OneField Text
name forall a b. (a -> b) -> a -> b
$
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall a b. (a -> b) -> a -> b
$ \Object
o -> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a. Parser a -> Value -> Validation a
runParserV Parser a
p) forall a b. (a -> b) -> a -> b
$ forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup (Text -> Key
Key.fromText Text
name) Object
o
defaultField
:: Text
-> a
-> Parser a
-> FieldParser a
defaultField :: forall a. Text -> a -> Parser a -> FieldParser a
defaultField Text
name a
defaultVal Parser a
p = forall a. a -> Maybe a -> a
fromMaybe a
defaultVal forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Text -> Parser a -> FieldParser (Maybe a)
optField Text
name Parser a
p
theField
:: Text
-> Text
-> FieldParser ()
theField :: Text -> Text -> FieldParser ()
theField Text
key Text
value = forall a. Text -> Parser a -> FieldParser a
field Text
key (Text -> Parser ()
theString Text
value)
extraFields :: FieldParser Object
= forall a. Free FieldParserBase a -> FieldParser a
FieldParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. f a -> Free f a
Free.lift forall a b. (a -> b) -> a -> b
$ FieldParserBase Object
ExtraFields
data StrictPair a b = StrictPair !a !b
instance (Semigroup a, Semigroup b) => Semigroup (StrictPair a b) where
StrictPair a
a1 b
b1 <> :: StrictPair a b -> StrictPair a b -> StrictPair a b
<> StrictPair a
a2 b
b2 = forall a b. a -> b -> StrictPair a b
StrictPair (a
a1 forall a. Semigroup a => a -> a -> a
<> a
a2) (b
b1 forall a. Semigroup a => a -> a -> a
<> b
b2)
instance (Monoid a, Monoid b) => Monoid (StrictPair a b) where
mempty :: StrictPair a b
mempty = forall a b. a -> b -> StrictPair a b
StrictPair forall a. Monoid a => a
mempty forall a. Monoid a => a
mempty
object :: FieldParser a -> Parser a
object :: forall a. FieldParser a -> Parser a
object (FieldParser Free FieldParserBase a
fp) = forall a. NS (ParserComponent a) (Code Value) -> Parser a
fromComponent forall a b. (a -> b) -> a -> b
$ forall {k} (a :: k -> *) (x :: k) (xs :: [k]). a x -> NS a (x : xs)
Z forall a b. (a -> b) -> a -> b
$ forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ \(I x
o :* NP I xs
Nil) ->
forall a. Validation a -> Validation a
incErrLevel forall a b. (a -> b) -> a -> b
$
let
StrictPair KeyMap ()
requested_names (Any Bool
requested_extra_fields) = forall a b (f :: * -> *).
Monoid b =>
(forall c. f c -> b) -> Free f a -> b
Free.foldMap (\case
OneField Text
name ReaderT Object Validation c
_ -> forall a b. a -> b -> StrictPair a b
StrictPair (forall v. Key -> v -> KeyMap v
KeyMap.singleton (Text -> Key
Key.fromText Text
name) ()) (Bool -> Any
Any Bool
False)
FieldParserBase c
ExtraFields -> forall a b. a -> b -> StrictPair a b
StrictPair forall a. Monoid a => a
mempty (Bool -> Any
Any Bool
True)
) Free FieldParserBase a
fp
extra_fields :: Object
extra_fields = forall v v'. KeyMap v -> KeyMap v' -> KeyMap v
KeyMap.difference x
o KeyMap ()
requested_names
extra_fields_error :: Validation ()
extra_fields_error =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
requested_extra_fields Bool -> Bool -> Bool
&& Bool -> Bool
not (forall v. KeyMap v -> Bool
KeyMap.null Object
extra_fields)) forall a b. (a -> b) -> a -> b
$
forall a. Either ParseError a -> Validation a
Validation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> Reason -> ParseError
ParseError Int
0 forall a b. (a -> b) -> a -> b
$
Value -> Value -> Reason
UnexpectedAsPartOf (Object -> Value
Object Object
extra_fields) (Object -> Value
Object x
o)
in
forall a (f :: * -> *) (g :: * -> *).
Applicative g =>
(forall c. f c -> g c) -> Free f a -> g a
Free.run (\case
OneField Text
_ ReaderT Object Validation c
p -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Object Validation c
p x
o
FieldParserBase c
ExtraFields -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
extra_fields
) Free FieldParserBase a
fp
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Validation ()
extra_fields_error
anyValue :: Parser Value
anyValue :: Parser Value
anyValue = forall a. NP (ParserComponent a) (Code Value) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ forall k l (h :: (k -> *) -> l -> *) (xs :: l) (f :: k -> *).
(HPure h, SListIN h xs) =>
(forall (a :: k). f a) -> h f xs
hpure forall a b. (a -> b) -> a -> b
$ forall a (fs :: [*]).
Maybe (Value -> NP I fs -> Validation a) -> ParserComponent a fs
ParserComponent forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \Value
val NP I a
_np -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
val
liftR :: f a -> ReaderT r f a
liftR :: forall (f :: * -> *) a r. f a -> ReaderT r f a
liftR = forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const