-- | Combinators for parsing YAML into Haskell types.
--
-- Based on the article <https://ro-che.info/articles/2015-07-26-better-yaml-parsing Better Yaml Parsing>.
{-# LANGUAGE PolyKinds, DataKinds, KindSignatures,
             ExplicitForAll, TemplateHaskell, ViewPatterns,
             ScopedTypeVariables, TypeOperators, TypeFamilies,
             GeneralizedNewtypeDeriving, GADTs, LambdaCase #-}
module Data.Yaml.Combinators
  ( Parser
  , parse
  , runParser
  -- * Scalars
  , string
  , theString
  , number
  , integer
  , bool
  , null_
  -- * Arrays
  , array
  , theArray
  , ElementParser
  , element
  -- * Objects
  , object
  , FieldParser
  , field
  , optField
  , defaultField
  , theField
  , extraFields
  -- * Arbitrary values
  , anyValue
  -- * Errors
  , 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

-- orphan Value instances
deriveGeneric ''Value

----------------------------------------------------------------------
--                           Parsing function
----------------------------------------------------------------------

-- | Run a 'Parser' on a 'ByteString' containing the YAML content.
--
-- This is a high-level function implemented on top of 'runParser'.
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

----------------------------------------------------------------------
--                      Errors and Pretty-printing
----------------------------------------------------------------------

-- | A parse error. 'Reason' describes the error.
-- The 'Int' field denotes at which level the error occurred and
-- is used to select the deepest (most relevant) error
-- when merging multiple parsers.
data ParseError = ParseError
  !Int  -- level
  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)

-- | Describes what exactly went wrong during parsing.
data Reason
  -- NB: the order of constructors is important for the Ord instance
  = 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)

-- | Find out which error is more severe
compareSeverity :: ParseError -> ParseError -> Ordering
compareSeverity :: ParseError -> ParseError -> Ordering
compareSeverity (ParseError Int
l1 Reason
r1) (ParseError Int
l2 Reason
r2) =
  -- extra stuff is always less severe than mismatching/missing stuff
  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
<>
  -- otherwise, compare the depths
  forall a. Ord a => a -> a -> Ordering
compare Int
l1 Int
l2 forall a. Semigroup a => a -> a -> a
<>
  -- if the depths are equal, mismatches are more severe that misses,
  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

-- | Choose the more severe of two errors.
--
-- If they are equally severe, pick the earlier one.
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

-- | Choose the less severe of two errors.
--
-- If they are equally severe, pick the earlier one.
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)
  -- first, see if we can merge the two errors
  | 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)
  -- otherwise, just choose the least severe one,
  -- since its branch is more likely to be the right one
  | Bool
otherwise = ParseError -> ParseError -> ParseError
lessSevere ParseError
e1 ParseError
e2

-- | Pretty-print a 'ParseError'
--
-- @since 1.1
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

----------------------------------------------------------------------
--                           Core definitions
----------------------------------------------------------------------

newtype ParserComponent a fs = ParserComponent (Maybe (Value -> NP I fs -> Validation a))
-- | A top-level YAML parser.
--
-- * Construct a 'Parser' with 'string', 'number', 'integer', 'bool', 'array', or 'object'.
--
-- * Combine two or more 'Parser's with 'Monoid' or 'Semigroup' operators
-- such as 'mappend', '<>', or `mconcat` —
-- e.g. if you expect either an object or a string.
--
-- * Run with 'parse' or 'runParser'.
newtype Parser a = Parser (NP (ParserComponent a) (Code Value))

-- fmap for ParserComponent (in its first type argument)
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
(<>)

-- | A low-level function to run a 'Parser'.
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

-- Wrap a parser with a decorator. The decorator has access to the parsed value as well
-- as the original and can inject its own processing logic.
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

----------------------------------------------------------------------
--                           Combinators
----------------------------------------------------------------------

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

-- | Match a single YAML string.
--
-- >>> parse string "howdy"
-- Right "howdy"
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

-- | Match a specific YAML string, usually a «tag» identifying a particular
-- form of an array or object.
--
-- >>> parse (theString "hello") "hello"
-- Right ()
-- >>> either putStr print $ parse (theString "hello") "bye"
-- Expected "hello" instead of:
-- <BLANKLINE>
-- bye
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))

-- | Match an array of elements, where each of elements are matched by
-- the same parser. This is the function you'll use most of the time when
-- parsing arrays, as they are usually homogeneous.
--
-- >>> parse (array string) "[a,b,c]"
-- Right ["a","b","c"]
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

-- | An 'ElementParser' describes how to parse a fixed-size array
-- where each positional element has its own parser.
--
-- This can be used to parse heterogeneous tuples represented as YAML
-- arrays.
--
-- * Construct an 'ElementParser' with 'element' and the 'Applicative' combinators.
--
-- * Turn a 'FieldParser' into a 'Parser' with 'theArray'.
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)

-- | Construct an 'ElementParser' that parses the current array element
-- with the given 'Parser'.
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

-- | Match an array consisting of a fixed number of elements. The way each
-- element is parsed depends on its position within the array and
-- is determined by the 'ElementParser'.
--
-- >>> parse (theArray $ (,) <$> element string <*> element bool) "[f, true]"
-- Right ("f",True)
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
      )

-- | Match a real number.
--
-- >>> parse number "3.14159"
-- Right 3.14159
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

-- | Match an integer.
--
-- >>> parse (integer @Int) "2017"
-- Right 2017
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)

-- | Match a boolean.
--
-- >>> parse bool "yes"
-- Right True
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

-- | Match the @null@ value.
--
-- >>> parse null_ "null"
-- Right ()
--
-- @since 1.1
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 ()

-- | Make a parser match only valid values.
--
-- If the validator does not accept the value, it should return a
-- 'Left' 'String' with a noun phrase that characterizes the expected
-- value, as in the example:
--
-- >>> let acceptEven n = if even n then Right n else Left "an even number"
-- >>> either putStr print $ parse (integer @Int `validate` acceptEven) "2017"
-- Expected an even number instead of:
-- <BLANKLINE>
-- 2017
--
-- @since 1.0.1
validate ::
  Parser a -- ^ parser to wrap
  -> (a -> Either String b) -- ^ validator
  -> 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

-- | A 'FieldParser' describes how to parse an object.
--
-- * Construct a 'FieldParser' with 'field', 'optField', or 'theField', and the 'Applicative' combinators.
--
-- * Turn a 'FieldParser' into a 'Parser' with 'object'.
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 -- field name
    -> ReaderT Object Validation a
    -> FieldParserBase a
  ExtraFields :: FieldParserBase Object

-- | Require an object field with the given name and with a value matched by
-- the given 'Parser'.
field
  :: Text -- ^ field name
  -> Parser a -- ^ value parser
  -> 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


-- | Declare an optional object field with the given name and with a value
-- matched by the given 'Parser'.
optField
  :: Text -- ^ field name
  -> Parser a -- ^ value parser
  -> 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

-- | Declare an optional object field with the given name and with a default
-- to use if the field is absent.
defaultField
  :: Text -- ^ field name
  -> a -- ^ default value
  -> Parser a -- ^ value parser
  -> 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

-- | Require an object field with the given name and the given string value.
--
-- This is a convenient wrapper around 'theString' intended for «tagging»
-- objects.
--
-- >>> :{
--     let p = object (Right <$ theField "type" "number" <*> field "value" number)
--          <> object (Left  <$ theField "type" "string" <*> field "value" string)
-- >>> :}
--
-- >>> parse p "{type: string, value: abc}"
-- Right (Left "abc")
-- >>> parse p "{type: number, value: 123}"
-- Right (Right 123.0)
theField
  :: Text -- ^ key name
  -> Text -- ^ expected value
  -> 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)

-- | This combinator does two things:
--
-- 1. Allow extra fields (not specified by 'field', 'theField' etc.) in the
-- parsed object.
-- 2. Return such extra fields as an 'Object'.
--
-- The return value can be of course ignored.
--
-- >>> let fp = field "name" string
-- >>> either putStr print $ parse (object fp) "name: Anton"
-- "Anton"
-- >>> either putStr print $ parse (object fp) "{name: Anton, age: 2}"
-- Unexpected
-- <BLANKLINE>
-- age: 2
-- <BLANKLINE>
-- as part of
-- <BLANKLINE>
-- age: 2
-- name: Anton
-- >>> either putStr print $ parse (object $ (,) <$> fp <*> extraFields) "{name: Anton, age: 2}"
-- ("Anton",fromList [("age",Number 2.0)])
-- >>> either putStr print $ parse (object $ fp <* extraFields) "{name: Anton, age: 2}"
-- "Anton"
--
-- @since 1.1.2
extraFields :: FieldParser Object
extraFields :: FieldParser Object
extraFields = 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

-- | Match an object. Which set of keys to expect and how their values
-- should be parsed is determined by the 'FieldParser'.
--
-- >>> let p = object $ (,) <$> field "name" string <*> optField "age" (integer @Int)
-- >>> parse p "{ name: Anton, age: 2 }"
-- Right ("Anton",Just 2)
-- >>> parse p "name: Roma"
-- Right ("Roma",Nothing)
--
-- By default, this function will fail when there are unrecognized fields
-- in the object. See 'extraFields' for a way to capture or ignore them.
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
      -- Do a first run over the free FieldParser applicative to collect
      -- some metainformation: which fields are requested by the parser,
      -- and whether extra fields are requested too (and therefore allowed)
      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
        -- See Note [Extra fields error]
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Validation ()
extra_fields_error

{- Note [Extra fields error]
   ~~~~~~~~~~~~~~~~~~~~~~~~~
   We could have written

     if not requested_extra_fields && not (HM.null extra_fields)
        then Validation . Left $  ...
        else ...

   However, we intentionally try to run the applicative parser even when
   there are extra fields, because some of the resulting validation errors
   may be more severe/interesting than the "extra fields" error.
-}

-- | Match any JSON value and return it as Aeson's 'Value'.
--
-- >>> parse anyValue "[one, two, {three: four}]"
-- Right (Array [String "one",String "two",Object (fromList [("three",String "four")])])
--
-- @since 1.1.1
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

-- | Like 'lift' for 'ReaderT', but doesn't require a 'Monad' instance
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