{-# OPTIONS_HADDOCK not-home #-}

-- | The class t'FromYaml', its instances and the parts of the decoder that
-- the generic instances share with it. "Yamlet.Decode" exports the public
-- parts.
--
-- This module is intended for internal use only, and may change without warning
-- in subsequent releases.
module Yamlet.Internal.FromYaml
  ( -- * Class
    FromYaml (..)

    -- * Parser
  , Parser
  , runParser
  , runParserWithin
  , parseNode
  , failAt
  , typeMismatch
  , orElse

    -- * Scalars
  , withNull
  , withBool
  , withInt
  , withFloat
  , withScientific
  , withText
  , withName
  , oneOf

    -- * Collections
  , withSequence
  , withMapping
  , Object (..)
  , objectNode
  , objectEntries
  , objectKeys
  , lookupKey
  , parseField
  , parseFieldMaybe
  , parseFieldIfPresent
  , parseFieldDefault
  , parseFieldWith
  , parseFieldMaybeWith
  , parseFieldIfPresentWith
  , parseFieldDefaultWith
  , rejectUnknownKeys

    -- * Parts of the generic instances
  , parseItems
  , parseEntry
  , findKey
  , missingKey
  , unknownName
  , unquotedName
  , succeeds
  , withNote
  , nullNode
  ) where

import Control.Applicative
import Control.Monad
import Data.Containers.ListUtils
import Data.Fixed
import Data.Functor.Identity
import Data.Int
import Data.IntMap.Strict qualified as IM
import Data.IntSet qualified as IS
import Data.List qualified as L
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as M
import Data.Maybe
import Data.Monoid qualified as Mon
import Data.Ord
import Data.Proxy
import Data.Scientific qualified as Sci
import Data.Semigroup qualified as Sem
import Data.Sequence qualified as Seq
import Data.Set qualified as Set
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Time
import Data.Time.Calendar.Month
import Data.Time.Calendar.Quarter
import Data.Time.FromText
import Data.Tree qualified as Tree
import Data.UUID.Types qualified as UUID
import Data.Void
import Data.Word
import GHC.Real
import Numeric.Natural

import Yamlet.Internal.Compose
import Yamlet.Internal.Schema
import Yamlet.Internal.Syntax qualified as S
import Yamlet.Internal.Utils
import Yamlet.Internal.View
import Yamlet.Value

-- | A parser of nodes. Its errors point to the node that the parser works on,
-- unless 'failAt' names another one.
--
-- The parser has no t'Control.Applicative.Alternative' instance. To try
-- another parser after a failure, use 'orElse'. To reject a value, fail with
-- a message that says why:
--
-- @
-- port <- parseYaml n
-- unless (port > 0 && port < 65536) $ fail "the port must be from 1 to 65535"
-- @
--
-- The applicative operators collect the errors of both parts: '<*>', '*>',
-- '<*', 'liftA2', and the functions that use them, e.g. 'traverse',
-- 'mapM' on a list and 'Data.Foldable.for_'. This parser gives the errors of
-- the unknown keys and of all fields together:
--
-- @
-- rejectUnknownKeys [\"name\", \"paths\"] o
--   *> (Config \<$> parseField o \"name\" \<*> parseField o \"paths\")
-- @
--
-- '>>=' and '>>' stop at the first error. A statement of a @do@ block also
-- stops, e.g. the check of the port above. The functions that use '>>' also
-- stop, e.g. 'Control.Monad.mapM_' and 'Control.Monad.forM_'.
--
-- The choice between them changes only the errors, never the result. With
-- @ApplicativeDo@, GHC turns the independent statements of a @do@ block that
-- ends with 'pure' into '<*>'. Then they collect errors.
newtype Parser a = Parser (S.Offset -> Result a)

-- | The errors of a parser and its value. The value of a parser with errors
-- is 'failed', so the field of the value is lazy.
--
-- '<*>' applies the values without a branch on the errors, and it joins the
-- errors apart from them. The optimizer can then combine the values of a
-- derived decoder as for a pure function, and the generic representation
-- goes away.
data Result a = Result !Errors a

-- | The errors of a parser in a tree, so that two sets of errors join in
-- constant time.
data Errors
  = NoErrors
  | -- | An error with the notes that go right after it, e.g. the first key of
    -- a duplicate key.
    OneError !S.Offset !String ![(S.Offset, String)]
  | BothErrors !Errors !Errors

bothErrors :: Errors -> Errors -> Errors
bothErrors :: Errors -> Errors -> Errors
bothErrors Errors
e1 Errors
e2 = case (Errors
e1, Errors
e2) of
  (Errors
NoErrors, Errors
_) -> Errors
e2
  (Errors
_, Errors
NoErrors) -> Errors
e1
  (Errors, Errors)
_ -> Errors -> Errors -> Errors
BothErrors Errors
e1 Errors
e2
-- If GHC inlines this function into '<*>', the branches on the errors take
-- the values of the parts with them. Then the inspection test of the derived
-- decoder with 100 fields fails.
{-# NOINLINE bothErrors #-}

-- | The value of a parser with errors. Nothing reads it, because each
-- consumer of a result looks at the errors first.
failed :: a
failed :: forall a. a
failed = [Char] -> a
forall a. [Char] -> a
errorWithoutStackTrace [Char]
"Yamlet.Decode: the value of a failed parser"

-- | A result with one error.
failure :: S.Offset -> String -> Result a
failure :: forall a. Offset -> [Char] -> Result a
failure Offset
off [Char]
msg = Errors -> a -> Result a
forall a. Errors -> a -> Result a
Result (Offset -> [Char] -> [(Offset, [Char])] -> Errors
OneError Offset
off [Char]
msg []) a
forall a. a
failed

instance Functor Parser where
  fmap :: forall a b. (a -> b) -> Parser a -> Parser b
fmap a -> b
f (Parser Offset -> Result a
g) = (Offset -> Result b) -> Parser b
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result b) -> Parser b)
-> (Offset -> Result b) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Offset
off -> case Offset -> Result a
g Offset
off of
    Result Errors
e a
a -> Errors -> b -> Result b
forall a. Errors -> a -> Result a
Result Errors
e (a -> b
f a
a)

-- '<*>' differs from 'ap', and '>>' differs from '*>', in the errors, but not
-- in the results.
instance Applicative Parser where
  pure :: forall a. a -> Parser a
pure a
a = (Offset -> Result a) -> Parser a
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result a) -> Parser a)
-> (Offset -> Result a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Offset
_ -> Errors -> a -> Result a
forall a. Errors -> a -> Result a
Result Errors
NoErrors a
a
  Parser Offset -> Result (a -> b)
f <*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
<*> Parser Offset -> Result a
g = (Offset -> Result b) -> Parser b
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result b) -> Parser b)
-> (Offset -> Result b) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Offset
off -> case Offset -> Result (a -> b)
f Offset
off of
    Result Errors
e1 a -> b
h -> case Offset -> Result a
g Offset
off of
      Result Errors
e2 a
a -> Errors -> b -> Result b
forall a. Errors -> a -> Result a
Result (Errors -> Errors -> Errors
bothErrors Errors
e1 Errors
e2) (a -> b
h a
a)

-- A statement of a @do@ block must not run after a failed check, e.g. an
-- index into a list after the check of its length. The default of '>>' uses
-- '>>=', which stops there.
instance Monad Parser where
  Parser Offset -> Result a
g >>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
k = (Offset -> Result b) -> Parser b
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result b) -> Parser b)
-> (Offset -> Result b) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Offset
off -> case Offset -> Result a
g Offset
off of
    Result Errors
NoErrors a
a -> let Parser Offset -> Result b
h = a -> Parser b
k a
a in Offset -> Result b
h Offset
off
    Result Errors
e a
_ -> Errors -> b -> Result b
forall a. Errors -> a -> Result a
Result Errors
e b
forall a. a
failed

instance MonadFail Parser where
  fail :: forall a. [Char] -> Parser a
fail [Char]
msg = (Offset -> Result a) -> Parser a
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result a) -> Parser a)
-> (Offset -> Result a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Offset
off -> Offset -> [Char] -> Result a
forall a. Offset -> [Char] -> Result a
failure Offset
off [Char]
msg

-- | Run a parser on a node. Each error is the offset of the node that caused
-- it and the message. The errors are in the order of the offsets, and equal
-- errors come only once. A note on an error comes right after it, e.g. the
-- first key of a duplicate key.
--
-- First, the function makes the checks of 'Yamlet.decodeDocument' on the
-- node, e.g. for duplicate keys. It also replaces each alias with the node
-- that the alias refers to. If a check fails, the result has only the error
-- of that check, with its notes.
runParser :: (S.Node -> Parser a) -> S.Node -> Either (NE.NonEmpty (S.Offset, String)) a
runParser :: forall a.
(Node -> Parser a) -> Node -> Either (NonEmpty (Offset, [Char])) a
runParser Node -> Parser a
f Node
n0 = Either (NonEmpty (Offset, [Char])) (a, Int)
-> Either (NonEmpty (Offset, [Char])) a
forall e a b. Either e (a, b) -> Either e a
firstOfResult (Either (NonEmpty (Offset, [Char])) (a, Int)
 -> Either (NonEmpty (Offset, [Char])) a)
-> Either (NonEmpty (Offset, [Char])) (a, Int)
-> Either (NonEmpty (Offset, [Char])) a
forall a b. (a -> b) -> a -> b
$ Int
-> Int
-> (Node -> Parser a)
-> Node
-> Either (NonEmpty (Offset, [Char])) (a, Int)
forall a.
Int
-> Int
-> (Node -> Parser a)
-> Node
-> Either (NonEmpty (Offset, [Char])) (a, Int)
runParserWithin ([Node] -> Int
aliasLimit [Node
n0]) Int
0 Node -> Parser a
f Node
n0

-- | 'runParser' with the visits of the aliases as for 'prepareWithin'.
runParserWithin
  :: Int
  -> Int
  -> (S.Node -> Parser a)
  -> S.Node
  -> Either (NE.NonEmpty (S.Offset, String)) (a, Int)
runParserWithin :: forall a.
Int
-> Int
-> (Node -> Parser a)
-> Node
-> Either (NonEmpty (Offset, [Char])) (a, Int)
runParserWithin Int
limit Int
added Node -> Parser a
f Node
n0 = case Int
-> Int -> Node -> Either (NonEmpty (Offset, [Char])) (Node, Int)
prepareWithin Int
limit Int
added Node
n0 of
  Left NonEmpty (Offset, [Char])
err -> NonEmpty (Offset, [Char])
-> Either (NonEmpty (Offset, [Char])) (a, Int)
forall a b. a -> Either a b
Left NonEmpty (Offset, [Char])
err
  Right (Node
n, Int
added') -> case (Node -> Parser a) -> Node -> Result a
forall a. (Node -> Parser a) -> Node -> Result a
runChecked Node -> Parser a
f Node
n of
    Result Errors
NoErrors a
a -> (a, Int) -> Either (NonEmpty (Offset, [Char])) (a, Int)
forall a b. b -> Either a b
Right (a
a, Int
added')
    Result Errors
e a
_ -> NonEmpty (Offset, [Char])
-> Either (NonEmpty (Offset, [Char])) (a, Int)
forall a b. a -> Either a b
Left ([(Offset, [Char])] -> NonEmpty (Offset, [Char])
forall a. HasCallStack => [a] -> NonEmpty a
NE.fromList (Errors -> [(Offset, [Char])]
sortedErrors Errors
e))
  where
    -- The errors in the order of their offsets, each with its notes after it.
    -- Errors at the same offset keep their order. An error comes only once:
    -- the nodes inside an alias have the offset of the alias, so the same
    -- error in several of them repeats at that offset.
    sortedErrors :: Errors -> [(S.Offset, String)]
    sortedErrors :: Errors -> [(Offset, [Char])]
sortedErrors =
      ((Offset, [Char], [(Offset, [Char])]) -> [(Offset, [Char])])
-> [(Offset, [Char], [(Offset, [Char])])] -> [(Offset, [Char])]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Offset
off, [Char]
msg, [(Offset, [Char])]
notes) -> (Offset
off, [Char]
msg) (Offset, [Char]) -> [(Offset, [Char])] -> [(Offset, [Char])]
forall a. a -> [a] -> [a]
: [(Offset, [Char])]
notes)
        ([(Offset, [Char], [(Offset, [Char])])] -> [(Offset, [Char])])
-> (Errors -> [(Offset, [Char], [(Offset, [Char])])])
-> Errors
-> [(Offset, [Char])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Offset, [Char], [(Offset, [Char])])]
-> [(Offset, [Char], [(Offset, [Char])])]
forall a. Ord a => [a] -> [a]
nubOrd
        ([(Offset, [Char], [(Offset, [Char])])]
 -> [(Offset, [Char], [(Offset, [Char])])])
-> (Errors -> [(Offset, [Char], [(Offset, [Char])])])
-> Errors
-> [(Offset, [Char], [(Offset, [Char])])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Offset, [Char], [(Offset, [Char])]) -> Offset)
-> [(Offset, [Char], [(Offset, [Char])])]
-> [(Offset, [Char], [(Offset, [Char])])]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn (\(Offset
off, [Char]
_, [(Offset, [Char])]
_) -> Offset
off)
        ([(Offset, [Char], [(Offset, [Char])])]
 -> [(Offset, [Char], [(Offset, [Char])])])
-> (Errors -> [(Offset, [Char], [(Offset, [Char])])])
-> Errors
-> [(Offset, [Char], [(Offset, [Char])])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Errors
 -> [(Offset, [Char], [(Offset, [Char])])]
 -> [(Offset, [Char], [(Offset, [Char])])])
-> [(Offset, [Char], [(Offset, [Char])])]
-> Errors
-> [(Offset, [Char], [(Offset, [Char])])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip Errors
-> [(Offset, [Char], [(Offset, [Char])])]
-> [(Offset, [Char], [(Offset, [Char])])]
go []
      where
        go
          :: Errors
          -> [(S.Offset, String, [(S.Offset, String)])]
          -> [(S.Offset, String, [(S.Offset, String)])]
        go :: Errors
-> [(Offset, [Char], [(Offset, [Char])])]
-> [(Offset, [Char], [(Offset, [Char])])]
go = \case
          Errors
NoErrors -> [(Offset, [Char], [(Offset, [Char])])]
-> [(Offset, [Char], [(Offset, [Char])])]
forall a. a -> a
id
          OneError Offset
off [Char]
msg [(Offset, [Char])]
notes -> ((Offset
off, [Char]
msg, [(Offset, [Char])]
notes) (Offset, [Char], [(Offset, [Char])])
-> [(Offset, [Char], [(Offset, [Char])])]
-> [(Offset, [Char], [(Offset, [Char])])]
forall a. a -> [a] -> [a]
:)
          BothErrors Errors
e1 Errors
e2 -> Errors
-> [(Offset, [Char], [(Offset, [Char])])]
-> [(Offset, [Char], [(Offset, [Char])])]
go Errors
e1 ([(Offset, [Char], [(Offset, [Char])])]
 -> [(Offset, [Char], [(Offset, [Char])])])
-> ([(Offset, [Char], [(Offset, [Char])])]
    -> [(Offset, [Char], [(Offset, [Char])])])
-> [(Offset, [Char], [(Offset, [Char])])]
-> [(Offset, [Char], [(Offset, [Char])])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Errors
-> [(Offset, [Char], [(Offset, [Char])])]
-> [(Offset, [Char], [(Offset, [Char])])]
go Errors
e2

-- | Run a parser on a node that passed 'prepareWithin'.
runChecked :: (S.Node -> Parser a) -> S.Node -> Result a
runChecked :: forall a. (Node -> Parser a) -> Node -> Result a
runChecked Node -> Parser a
f Node
n = let Parser Offset -> Result a
g = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser a
f Node
n in Offset -> Result a
g Node
n.offset

-- | The value of a parser on a node that passed 'prepareWithin', if it has no
-- errors.
succeeds :: (S.Node -> Parser a) -> S.Node -> Maybe a
succeeds :: forall a. (Node -> Parser a) -> Node -> Maybe a
succeeds Node -> Parser a
f Node
n = case (Node -> Parser a) -> Node -> Result a
forall a. (Node -> Parser a) -> Node -> Result a
runChecked Node -> Parser a
f Node
n of
  Result Errors
NoErrors a
a -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
  Result Errors
_ a
_ -> Maybe a
forall a. Maybe a
Nothing

-- | The parser with the note after each of its errors at the offset, e.g. to
-- say how the decoder read the node of the error.
withNote :: S.Offset -> (S.Offset, String) -> Parser a -> Parser a
withNote :: forall a. Offset -> (Offset, [Char]) -> Parser a -> Parser a
withNote Offset
off (Offset, [Char])
note (Parser Offset -> Result a
g) = (Offset -> Result a) -> Parser a
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result a) -> Parser a)
-> (Offset -> Result a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Offset
o -> case Offset -> Result a
g Offset
o of
  r :: Result a
r@(Result Errors
NoErrors a
_) -> Result a
r
  Result Errors
e a
a -> Errors -> a -> Result a
forall a. Errors -> a -> Result a
Result (Errors -> Errors
addNote Errors
e) a
a
  where
    addNote :: Errors -> Errors
    addNote :: Errors -> Errors
addNote = \case
      OneError Offset
eo [Char]
msg [(Offset, [Char])]
notes | Offset
eo Offset -> Offset -> Bool
forall a. Eq a => a -> a -> Bool
== Offset
off -> Offset -> [Char] -> [(Offset, [Char])] -> Errors
OneError Offset
eo [Char]
msg ([(Offset, [Char])]
notes [(Offset, [Char])] -> [(Offset, [Char])] -> [(Offset, [Char])]
forall a. [a] -> [a] -> [a]
++ [(Offset, [Char])
note])
      BothErrors Errors
e1 Errors
e2 -> Errors -> Errors -> Errors
BothErrors (Errors -> Errors
addNote Errors
e1) (Errors -> Errors
addNote Errors
e2)
      Errors
e -> Errors
e

-- | Run a parser on a node, so that 'fail' points to the node.
parseNode :: (S.Node -> Parser a) -> S.Node -> Parser a
parseNode :: forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser a
f Node
n = let Parser Offset -> Result a
g = Node -> Parser a
f Node
n in (Offset -> Result a) -> Parser a
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result a) -> Parser a)
-> (Offset -> Result a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Offset
_ -> Offset -> Result a
g Node
n.offset

-- | Fail with an error that points to the given node.
failAt :: S.Node -> String -> Parser a
failAt :: forall a. Node -> [Char] -> Parser a
failAt Node
n [Char]
msg = (Offset -> Result a) -> Parser a
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result a) -> Parser a)
-> (Offset -> Result a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Offset
_ -> Offset -> [Char] -> Result a
forall a. Offset -> [Char] -> Result a
failure Node
n.offset [Char]
msg

-- | Fail with an error that the node is not of the expected kind, e.g.
-- @typeMismatch "a list" n@ gives "expected a list, but got a string".
typeMismatch :: String -> S.Node -> Parser a
typeMismatch :: forall a. [Char] -> Node -> Parser a
typeMismatch [Char]
expected Node
n = Node -> [Char] -> Parser a
forall a. Node -> [Char] -> Parser a
failAt Node
n ([Char] -> Node -> [Char]
mismatchMessage [Char]
expected Node
n)

mismatchMessage :: String -> S.Node -> String
mismatchMessage :: [Char] -> Node -> [Char]
mismatchMessage [Char]
expected Node
n = [Char]
"expected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
expected [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", but got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Node -> [Char]
describeNode Node
n

-- | The null node for a missing value.
nullNode :: S.Node
nullNode :: Node
nullNode =
  Offset -> Offset -> Props -> Comments -> Content -> Node
S.Node Offset
S.noOffset Offset
S.noOffset Props
S.noProps Comments
S.noComments (ScalarStyle -> Text -> Content
S.ScalarContent ScalarStyle
S.Plain Text
"")

-- | Run the second parser if the first one fails. A port can be a number or
-- a name:
--
-- >>> :{
-- newtype Port = Port (Either Integer T.Text)
--   deriving stock (Show)
-- instance FromYaml Port where
--   parseYaml n =
--     Port <$> ((Left <$> withInt pure n) `orElse` (Right <$> withText pure n))
-- :}
--
-- >>> decodeText @Port "8080"
-- Right (Port (Left 8080))
--
-- >>> decodeText @Port "http"
-- Right (Port (Right "http"))
--
-- If both parsers fail, the result has only the errors of the second one:
--
-- >>> either printErrors print (decodeText @Port "[80]")
-- input.yaml:1:1: expected a string, but got a list
--   |
-- 1 | [80]
--   | ^
orElse :: Parser a -> Parser a -> Parser a
orElse :: forall a. Parser a -> Parser a -> Parser a
orElse (Parser Offset -> Result a
g) (Parser Offset -> Result a
h) = (Offset -> Result a) -> Parser a
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result a) -> Parser a)
-> (Offset -> Result a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Offset
off -> case Offset -> Result a
g Offset
off of
  r :: Result a
r@(Result Errors
NoErrors a
_) -> Result a
r
  Result a
_ -> Offset -> Result a
h Offset
off

infixl 3 `orElse`

----------------------------------------
-- Scalars

-- | Run the parser if the node is null.
withNull :: Parser a -> S.Node -> Parser a
withNull :: forall a. Parser a -> Node -> Parser a
withNull Parser a
p = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser a) -> Node -> Parser a)
-> (Node -> Parser a) -> Node -> Parser a
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node -> View
view Node
n of
  View
NullView -> Parser a
p
  View
_ -> [Char] -> Node -> Parser a
forall a. [Char] -> Node -> Parser a
typeMismatch [Char]
"null" Node
n

-- | The value of a boolean.
withBool :: (Bool -> Parser a) -> S.Node -> Parser a
withBool :: forall a. (Bool -> Parser a) -> Node -> Parser a
withBool Bool -> Parser a
f = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser a) -> Node -> Parser a)
-> (Node -> Parser a) -> Node -> Parser a
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node -> View
view Node
n of
  BoolView Bool
b -> Bool -> Parser a
f Bool
b
  StringView Text
t
    | S.ScalarContent ScalarStyle
S.Plain Text
_ <- Node
n.content
    , Tag
S.NoTag <- Node
n.props.tag
    , Text -> Bool
isYaml11Bool Text
t ->
        Node -> [Char] -> Parser a
forall a. Node -> [Char] -> Parser a
failAt Node
n ([Char] -> Parser a) -> [Char] -> Parser a
forall a b. (a -> b) -> a -> b
$
          [Char]
"expected a boolean, but got the string "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
showText Text
t
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", which is a boolean only in YAML 1.1, use true or false"
  View
_ -> [Char] -> Node -> Parser a
forall a. [Char] -> Node -> Parser a
typeMismatch [Char]
"a boolean" Node
n

-- | The value of an integer.
withInt :: (Integer -> Parser a) -> S.Node -> Parser a
withInt :: forall a. (Integer -> Parser a) -> Node -> Parser a
withInt Integer -> Parser a
f = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser a) -> Node -> Parser a)
-> (Node -> Parser a) -> Node -> Parser a
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node -> View
view Node
n of
  IntView Integer
i -> Integer -> Parser a
f Integer
i
  View
_ -> [Char] -> Node -> Parser a
forall a. [Char] -> Node -> Parser a
typeMismatch [Char]
"an integer" Node
n

-- | The nearest double. An integer counts as a floating-point number too.
withFloat :: (Double -> Parser a) -> S.Node -> Parser a
withFloat :: forall a. (Double -> Parser a) -> Node -> Parser a
withFloat = (Double -> Parser a) -> Node -> Parser a
forall b a. RealFloat b => (b -> Parser a) -> Node -> Parser a
withRealFloat

-- | The nearest value of a floating-point type, as for 'withFloat'.
withRealFloat :: RealFloat b => (b -> Parser a) -> S.Node -> Parser a
withRealFloat :: forall b a. RealFloat b => (b -> Parser a) -> Node -> Parser a
withRealFloat b -> Parser a
f = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser a) -> Node -> Parser a)
-> (Node -> Parser a) -> Node -> Parser a
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node -> View
view Node
n of
  FloatView FloatValue
v -> b -> Parser a
f (FloatValue -> b
forall a. RealFloat a => FloatValue -> a
floatValueToRealFloat FloatValue
v)
  IntView Integer
i -> b -> Parser a
f (Integer -> b
forall a. Num a => Integer -> a
fromInteger Integer
i)
  View
_ -> [Char] -> Node -> Parser a
forall a. [Char] -> Node -> Parser a
typeMismatch [Char]
"a number" Node
n

-- | The exact value of a finite number. An integer counts too, and negative
-- zero becomes 0.
--
-- A conversion to an exact type, e.g. with 'truncate', is safe for untrusted
-- input. An integer has the digits of its text, and the decoder rejects a
-- float whose exponent in scientific notation is beyond the range from -1000
-- to 1000, also in a node that a program built.
withScientific :: (Sci.Scientific -> Parser a) -> S.Node -> Parser a
withScientific :: forall a. (Scientific -> Parser a) -> Node -> Parser a
withScientific Scientific -> Parser a
f = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser a) -> Node -> Parser a)
-> (Node -> Parser a) -> Node -> Parser a
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node -> View
view Node
n of
  FloatView (Finite Scientific
s) -> Scientific -> Parser a
f Scientific
s
  FloatView FloatValue
NegativeZero -> Scientific -> Parser a
f Scientific
0
  IntView Integer
i -> Scientific -> Parser a
f (Integer -> Int -> Scientific
Sci.scientific Integer
i Int
0)
  FloatView FloatValue
_ -> [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expected a finite number"
  View
_ -> [Char] -> Node -> Parser a
forall a. [Char] -> Node -> Parser a
typeMismatch [Char]
"a number" Node
n

-- | The text of a string. The text is a copy, so it does not keep the input
-- alive. For a plain scalar that YAML reads as a number or a boolean, e.g.
-- @3.10@, the error suggests quotes.
withText :: (T.Text -> Parser a) -> S.Node -> Parser a
withText :: forall a. (Text -> Parser a) -> Node -> Parser a
withText Text -> Parser a
f = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser a) -> Node -> Parser a)
-> (Node -> Parser a) -> Node -> Parser a
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node -> View
view Node
n of
  StringView Text
t -> Text -> Parser a
f (Text -> Parser a) -> Text -> Parser a
forall a b. (a -> b) -> a -> b
$! Text -> Text
T.copy Text
t
  View
_ -> Node -> [Char] -> Parser a
forall a. Node -> [Char] -> Parser a
failAt Node
n (Node -> [Char]
stringMismatch Node
n)

-- | A string that is one of the names, e.g. the tags of the constructors. For
-- another node, the error suggests quotes only if the quoted text is a name,
-- e.g. not for @null@. Otherwise it lists the names.
withName :: [T.Text] -> (T.Text -> Parser a) -> S.Node -> Parser a
withName :: forall a. [Text] -> (Text -> Parser a) -> Node -> Parser a
withName [Text]
names Text -> Parser a
f = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser a) -> Node -> Parser a)
-> (Node -> Parser a) -> Node -> Parser a
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node -> View
view Node
n of
  StringView Text
t -> Text -> Parser a
f Text
t
  View
_ | Just [Char]
msg <- [Text] -> Node -> Maybe [Char]
unquotedName [Text]
names Node
n -> Node -> [Char] -> Parser a
forall a. Node -> [Char] -> Parser a
failAt Node
n [Char]
msg
  View
_ | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
names -> Node -> [Char] -> Parser a
forall a. Node -> [Char] -> Parser a
failAt Node
n [Char]
"no value is accepted"
  View
_ -> [Char] -> Node -> Parser a
forall a. [Char] -> Node -> Parser a
typeMismatch ([Char]
"one of: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
L.intercalate [Char]
", " ((Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
names)) Node
n

-- | The error for a plain scalar without a tag that is one of the names, but
-- not a string, e.g. @true@. Quotes would make it the name.
unquotedName :: [T.Text] -> S.Node -> Maybe String
unquotedName :: [Text] -> Node -> Maybe [Char]
unquotedName [Text]
names Node
n = case Node
n.content of
  S.ScalarContent ScalarStyle
S.Plain Text
t
    | Tag
S.NoTag <- Node
n.props.tag
    , Text
t Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
names ->
        [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just (Node -> [Char]
stringMismatch Node
n)
  Content
_ -> Maybe [Char]
forall a. Maybe a
Nothing

-- | The value that goes with the string in the list of pairs, e.g. for names
-- that the program knows only at run time. An empty list rejects every value.
-- The errors are the same as for the constructors of an enumeration. An
-- unknown name gets the closest name or the list of names:
--
-- >>> :{
-- newtype Size = Size Int
--   deriving stock (Show)
-- instance FromYaml Size where
--   parseYaml = oneOf [("small", Size 1), ("large", Size 2)]
-- :}
--
-- >>> decodeText @Size "large"
-- Right (Size 2)
--
-- >>> either printErrors print (decodeText @Size "lage")
-- input.yaml:1:1: unknown value "lage", did you mean "large"?
--   |
-- 1 | lage
--   | ^
oneOf :: [(T.Text, a)] -> S.Node -> Parser a
oneOf :: forall a. [(Text, a)] -> Node -> Parser a
oneOf [(Text, a)]
choices Node
n =
  [Text] -> (Text -> Parser a) -> Node -> Parser a
forall a. [Text] -> (Text -> Parser a) -> Node -> Parser a
withName [Text]
names (\Text
t -> Parser a -> (a -> Parser a) -> Maybe a -> Parser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> [Text] -> Node -> Text -> Parser a
forall a. [Char] -> [Text] -> Node -> Text -> Parser a
unknownName [Char]
"value" [Text]
names Node
n Text
t) a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [(Text, a)] -> Maybe a
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
t [(Text, a)]
choices)) Node
n
  where
    names :: [T.Text]
    names :: [Text]
names = ((Text, a) -> Text) -> [(Text, a)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text, a) -> Text
forall a b. (a, b) -> a
fst [(Text, a)]
choices

-- | The message for a node that is not a string, with the hint to quote a
-- plain number, boolean or written null.
stringMismatch :: S.Node -> String
stringMismatch :: Node -> [Char]
stringMismatch Node
n = [Char] -> Node -> [Char]
mismatchMessage [Char]
"a string" Node
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hint
  where
    hint :: String
    hint :: [Char]
hint = case Node
n.content of
      S.ScalarContent ScalarStyle
S.Plain Text
t
        | Tag
S.NoTag <- Node
n.props.tag
        , Text -> Bool
notString Text
t ->
            [Char]
", quote the value, e.g. '" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"'"
      Content
_ -> [Char]
""

    notString :: T.Text -> Bool
    notString :: Text -> Bool
notString Text
t = case Node -> View
view Node
n of
      IntView Integer
_ -> Bool
True
      FloatView FloatValue
_ -> Bool
True
      BoolView Bool
_ -> Bool
True
      -- An empty value is more likely a forgotten value than a string.
      View
NullView -> Bool -> Bool
not (Text -> Bool
T.null Text
t)
      View
_ -> Bool
False
-- Without the pragma, the interface file has no unfolding of 'withText', so
-- other modules cannot inline it.
{-# NOINLINE stringMismatch #-}

----------------------------------------
-- Collections

-- | The items of a sequence. As for 'withMapping', the comments of the
-- sequence stay with it, not with its first item.
withSequence :: ([S.Node] -> Parser a) -> S.Node -> Parser a
withSequence :: forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence [Node] -> Parser a
f = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser a) -> Node -> Parser a)
-> (Node -> Parser a) -> Node -> Parser a
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node
n.content of
  S.SequenceContent CollectionStyle
_ [Node]
xs -> [Node] -> Parser a
f [Node]
xs
  Content
_ -> [Char] -> Node -> Parser a
forall a. [Char] -> Node -> Parser a
typeMismatch [Char]
"a list" Node
n

-- | The values of the items, with the errors of all items, as with 'mapM'.
-- Unlike 'mapM', the stack does not grow with the number of items, because
-- the errors and the values are in accumulators until the end. A decoder of
-- a list is @withSequence (parseItems parseYaml)@.
parseItems :: forall a. (S.Node -> Parser a) -> [S.Node] -> Parser [a]
parseItems :: forall a. (Node -> Parser a) -> [Node] -> Parser [a]
parseItems Node -> Parser a
p [Node]
xs0 = (Offset -> Result [a]) -> Parser [a]
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result [a]) -> Parser [a])
-> (Offset -> Result [a]) -> Parser [a]
forall a b. (a -> b) -> a -> b
$ \Offset
off -> Offset -> Errors -> [a] -> [Node] -> Result [a]
go Offset
off Errors
NoErrors [] [Node]
xs0
  where
    go :: S.Offset -> Errors -> [a] -> [S.Node] -> Result [a]
    go :: Offset -> Errors -> [a] -> [Node] -> Result [a]
go Offset
off !Errors
errs [a]
acc = \case
      [] -> case Errors
errs of
        Errors
NoErrors -> Errors -> [a] -> Result [a]
forall a. Errors -> a -> Result a
Result Errors
NoErrors ([a] -> [a]
forall a. [a] -> [a]
reverse [a]
acc)
        Errors
_ -> Errors -> [a] -> Result [a]
forall a. Errors -> a -> Result a
Result Errors
errs [a]
forall a. a
failed
      Node
x : [Node]
xs ->
        let Parser Offset -> Result a
g = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser a
p Node
x
        in case Offset -> Result a
g Offset
off of
             Result Errors
e a
a -> Offset -> Errors -> [a] -> [Node] -> Result [a]
go Offset
off (Errors -> Errors -> Errors
bothErrors Errors
errs Errors
e) (a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
acc) [Node]
xs

-- | The entries of a mapping. As for 'withText', the tag of a string key does
-- not matter, so two string keys with the same text are an error, e.g. @a@
-- and @!foo a@.
--
-- The comments of the mapping stay with it, not with its first key, e.g. a
-- comment at the top of a file. A record has no place for them.
withMapping :: (Object -> Parser a) -> S.Node -> Parser a
withMapping :: forall a. (Object -> Parser a) -> Node -> Parser a
withMapping Object -> Parser a
f = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser a) -> Node -> Parser a)
-> (Node -> Parser a) -> Node -> Parser a
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node
n.content of
  S.MappingContent CollectionStyle
_ [(Node, Node)]
kvs -> case Node -> [(Node, Node)] -> (Errors, Object)
mkObject Node
n [(Node, Node)]
kvs of
    (Errors
NoErrors, Object
o) -> Object -> Parser a
f Object
o
    -- The errors of the fields come with the duplicate keys, and a field
    -- reads the value of the first key.
    (Errors
errs, Object
o) ->
      let Parser Offset -> Result a
g = Object -> Parser a
f Object
o
      in (Offset -> Result a) -> Parser a
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result a) -> Parser a)
-> (Offset -> Result a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Offset
off -> case Offset -> Result a
g Offset
off of
           Result Errors
e a
_ -> Errors -> a -> Result a
forall a. Errors -> a -> Result a
Result (Errors -> Errors -> Errors
bothErrors Errors
errs Errors
e) a
forall a. a
failed
  Content
_ -> [Char] -> Node -> Parser a
forall a. [Char] -> Node -> Parser a
typeMismatch [Char]
"a mapping" Node
n
  where
    -- The object and the errors of its duplicate keys. The index has the
    -- first of equal keys.
    --
    -- A list with linear lookups is faster only for a few keys, and it saves
    -- little of the time to decode a typical record.
    mkObject :: S.Node -> [(S.Node, S.Node)] -> (Errors, Object)
    mkObject :: Node -> [(Node, Node)] -> (Errors, Object)
mkObject Node
n [(Node, Node)]
kvs =
      case Map Text (Node, Node)
-> Errors
-> [(Node, Value)]
-> [(Node, Node)]
-> (Map Text (Node, Node), Errors, [(Node, Value)])
go Map Text (Node, Node)
forall k a. Map k a
M.empty Errors
NoErrors [] [(Node, Node)]
kvs of
        (Map Text (Node, Node)
index, Errors
errs, [(Node, Value)]
others) ->
          -- GHC does not know that the fold evaluated the index. Without the
          -- bang, it builds the object in a thunk, so that the index is
          -- evaluated only when the decoder uses the object.
          let !o :: Object
o =
                Object
                  { node :: Node
node = Node
n
                  , entries :: [(Node, Node)]
entries = [(Node, Node)]
kvs
                  , index :: Map Text (Node, Node)
index = Map Text (Node, Node)
index
                  , otherKeys :: [(Node, Value)]
otherKeys = [(Node, Value)]
others
                  , duplicates :: Bool
duplicates = case Errors
errs of
                      Errors
NoErrors -> Bool
False
                      Errors
_ -> Bool
True
                  }
          in (Errors
errs, Object
o)
      where
        -- The other keys are in reverse order until the end.
        go
          :: M.Map T.Text (S.Node, S.Node)
          -> Errors
          -> [(S.Node, Value)]
          -> [(S.Node, S.Node)]
          -> (M.Map T.Text (S.Node, S.Node), Errors, [(S.Node, Value)])
        go :: Map Text (Node, Node)
-> Errors
-> [(Node, Value)]
-> [(Node, Node)]
-> (Map Text (Node, Node), Errors, [(Node, Value)])
go !Map Text (Node, Node)
m !Errors
errs ![(Node, Value)]
others = \case
          [] -> (Map Text (Node, Node)
m, Errors
errs, [(Node, Value)] -> [(Node, Value)]
forall a. [a] -> [a]
reverse [(Node, Value)]
others)
          -- With 'view' instead, GHC builds the text of each key again for the
          -- map.
          kv :: (Node, Node)
kv@(Node
k, Node
_) : [(Node, Node)]
rest -> case Node -> Maybe Text
stringValue Node
k of
            Just Text
t -> case (Text -> (Node, Node) -> (Node, Node) -> (Node, Node))
-> Text
-> (Node, Node)
-> Map Text (Node, Node)
-> (Maybe (Node, Node), Map Text (Node, Node))
forall k a.
Ord k =>
(k -> a -> a -> a) -> k -> a -> Map k a -> (Maybe a, Map k a)
M.insertLookupWithKey (\Text
_ (Node, Node)
_ (Node, Node)
old -> (Node, Node)
old) Text
t (Node, Node)
kv Map Text (Node, Node)
m of
              (Just (Node
first, Node
_), Map Text (Node, Node)
_) ->
                Map Text (Node, Node)
-> Errors
-> [(Node, Value)]
-> [(Node, Node)]
-> (Map Text (Node, Node), Errors, [(Node, Value)])
go
                  Map Text (Node, Node)
m
                  ( Errors -> Errors -> Errors
bothErrors Errors
errs (Errors -> Errors) -> Errors -> Errors
forall a b. (a -> b) -> a -> b
$
                      Offset -> [Char] -> [(Offset, [Char])] -> Errors
OneError
                        Node
k.offset
                        ([Char]
"duplicate key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
showText Text
t)
                        [(Node
first.offset, [Char]
"the first key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
showText Text
t)]
                  )
                  [(Node, Value)]
others
                  [(Node, Node)]
rest
              (Maybe (Node, Node)
Nothing, Map Text (Node, Node)
m') -> Map Text (Node, Node)
-> Errors
-> [(Node, Value)]
-> [(Node, Node)]
-> (Map Text (Node, Node), Errors, [(Node, Value)])
go Map Text (Node, Node)
m' Errors
errs [(Node, Value)]
others [(Node, Node)]
rest
            Maybe Text
Nothing -> case Node
k.content of
              S.ScalarContent ScalarStyle
style Text
t ->
                Map Text (Node, Node)
-> Errors
-> [(Node, Value)]
-> [(Node, Node)]
-> (Map Text (Node, Node), Errors, [(Node, Value)])
go Map Text (Node, Node)
m Errors
errs ((Node
k, Tag -> ScalarStyle -> Text -> Value
scalarValue Node
k.props.tag ScalarStyle
style Text
t) (Node, Value) -> [(Node, Value)] -> [(Node, Value)]
forall a. a -> [a] -> [a]
: [(Node, Value)]
others) [(Node, Node)]
rest
              Content
_ -> Map Text (Node, Node)
-> Errors
-> [(Node, Value)]
-> [(Node, Node)]
-> (Map Text (Node, Node), Errors, [(Node, Value)])
go Map Text (Node, Node)
m Errors
errs [(Node, Value)]
others [(Node, Node)]
rest

-- | A mapping with fast access to the values of string keys.
data Object = Object
  { Object -> Node
node :: !S.Node
  , Object -> [(Node, Node)]
entries :: ![(S.Node, S.Node)]
  , Object -> Map Text (Node, Node)
index :: !(M.Map T.Text (S.Node, S.Node))
  , Object -> [(Node, Value)]
otherKeys :: ![(S.Node, Value)]
  -- ^ The scalar keys that are not strings, for the error of a lookup.
  , Object -> Bool
duplicates :: !Bool
  -- ^ Two string keys have the same text.
  }

-- | The node of the mapping.
objectNode :: Object -> S.Node
objectNode :: Object -> Node
objectNode Object
o = Object
o.node

-- | The entries of the mapping in the order of the input.
objectEntries :: Object -> [(S.Node, S.Node)]
objectEntries :: Object -> [(Node, Node)]
objectEntries Object
o = Object
o.entries

-- | The string keys of the mapping in the order of the input.
objectKeys :: Object -> [T.Text]
objectKeys :: Object -> [Text]
objectKeys Object
o = [Text
c | (Node
k, Node
_) <- Object
o.entries, Just Text
t <- [Node -> Maybe Text
stringValue Node
k], let !c :: Text
c = Text -> Text
T.copy Text
t]

-- | The value of a key, or 'Nothing' if the key is missing. As for
-- 'parseField', a key with the same text that is not a string, e.g. @404@,
-- is an error, so that its value does not go away.
lookupKey :: Object -> T.Text -> Parser (Maybe S.Node)
lookupKey :: Object -> Text -> Parser (Maybe Node)
lookupKey Object
o Text
key = ((Node, Node) -> Node) -> Maybe (Node, Node) -> Maybe Node
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Node, Node) -> Node
forall a b. (a, b) -> b
snd (Maybe (Node, Node) -> Maybe Node)
-> Parser (Maybe (Node, Node)) -> Parser (Maybe Node)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Text -> Parser (Maybe (Node, Node))
findKey Object
o Text
key

-- | The value of a key. It is an error if the key is missing.
parseField :: FromYaml a => Object -> T.Text -> Parser a
parseField :: forall a. FromYaml a => Object -> Text -> Parser a
parseField = ((Node, Node) -> Parser a) -> Object -> Text -> Parser a
forall a. ((Node, Node) -> Parser a) -> Object -> Text -> Parser a
entryField (Node, Node) -> Parser a
forall a. FromYaml a => (Node, Node) -> Parser a
parseEntry

-- | The value of a key, or 'Nothing' if the key is missing or its value is
-- null.
parseFieldMaybe :: FromYaml a => Object -> T.Text -> Parser (Maybe a)
parseFieldMaybe :: forall a. FromYaml a => Object -> Text -> Parser (Maybe a)
parseFieldMaybe = ((Node, Node) -> Parser a) -> Object -> Text -> Parser (Maybe a)
forall a.
((Node, Node) -> Parser a) -> Object -> Text -> Parser (Maybe a)
entryFieldMaybe (Node, Node) -> Parser a
forall a. FromYaml a => (Node, Node) -> Parser a
parseEntry

-- | The value of a key, or 'Nothing' if the key is missing. Unlike
-- 'parseFieldMaybe', a null value goes to the parser of the value, e.g.
-- @'Maybe' a@ gives @'Just' 'Nothing'@ for a null value.
--
-- >>> :{
-- newtype Limit = Limit (Maybe (Maybe Int))
--   deriving stock (Show)
-- instance FromYaml Limit where
--   parseYaml = withMapping $ \o -> Limit <$> parseFieldIfPresent o "limit"
-- :}
--
-- >>> decodeText @Limit "limit: null\n"
-- Right (Limit (Just Nothing))
--
-- >>> decodeText @Limit "{}"
-- Right (Limit Nothing)
parseFieldIfPresent :: FromYaml a => Object -> T.Text -> Parser (Maybe a)
parseFieldIfPresent :: forall a. FromYaml a => Object -> Text -> Parser (Maybe a)
parseFieldIfPresent = ((Node, Node) -> Parser a) -> Object -> Text -> Parser (Maybe a)
forall a.
((Node, Node) -> Parser a) -> Object -> Text -> Parser (Maybe a)
entryFieldIfPresent (Node, Node) -> Parser a
forall a. FromYaml a => (Node, Node) -> Parser a
parseEntry

-- | The value of a key, or the default if the key is missing or its value is
-- null.
--
-- >>> :{
-- newtype Server = Server Int
--   deriving stock (Show)
-- instance FromYaml Server where
--   parseYaml = withMapping $ \o -> Server <$> parseFieldDefault o "port" 80
-- :}
--
-- >>> decodeText @Server "{}"
-- Right (Server 80)
--
-- >>> decodeText @Server "port: null\n"
-- Right (Server 80)
--
-- >>> decodeText @Server "port: 8080\n"
-- Right (Server 8080)
parseFieldDefault :: FromYaml a => Object -> T.Text -> a -> Parser a
parseFieldDefault :: forall a. FromYaml a => Object -> Text -> a -> Parser a
parseFieldDefault Object
o Text
key a
def = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def (Maybe a -> a) -> Parser (Maybe a) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Text -> Parser (Maybe a)
forall a. FromYaml a => Object -> Text -> Parser (Maybe a)
parseFieldMaybe Object
o Text
key

-- | Like 'parseField', with the given parser for the value, e.g. to check a
-- value without a new type for it. The errors of the parser point to the
-- value. The parser gets only the value, so it cannot keep the comments of
-- the key, as a 'Yamlet.Commented' field does with 'parseField'.
--
-- >>> :{
-- newtype Port = Port Int
--   deriving stock (Show)
-- instance FromYaml Port where
--   parseYaml = withMapping $ \o -> Port <$> parseFieldWith number o "port"
--     where
--       number :: Node -> Parser Int
--       number = withInt $ \i ->
--         if i >= 1 && i <= 65535
--           then pure (fromInteger i)
--           else fail "expected a port from 1 to 65535"
-- :}
--
-- >>> decodeText @Port "port: 80\n"
-- Right (Port 80)
--
-- >>> either printErrors print (decodeText @Port "port: 70000\n")
-- input.yaml:1:7: port: expected a port from 1 to 65535
--   |
-- 1 | port: 70000
--   |       ^
parseFieldWith :: (S.Node -> Parser a) -> Object -> T.Text -> Parser a
parseFieldWith :: forall a. (Node -> Parser a) -> Object -> Text -> Parser a
parseFieldWith Node -> Parser a
p = ((Node, Node) -> Parser a) -> Object -> Text -> Parser a
forall a. ((Node, Node) -> Parser a) -> Object -> Text -> Parser a
entryField ((Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser a
p (Node -> Parser a)
-> ((Node, Node) -> Node) -> (Node, Node) -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, Node) -> Node
forall a b. (a, b) -> b
snd)

-- | Like 'parseFieldMaybe', with the given parser for the value, as in
-- 'parseFieldWith'. The result is 'Nothing' if the key is missing or its
-- value is null. The parser never gets a null value, so a missing key and a
-- null value mean the same.
--
-- >>> :{
-- newtype Job = Job (Maybe Int)
--   deriving stock (Show)
-- instance FromYaml Job where
--   parseYaml = withMapping $ \o -> Job <$> parseFieldMaybeWith positive o "retries"
--     where
--       positive :: Node -> Parser Int
--       positive = withInt $ \i ->
--         if i > 0 then pure (fromInteger i) else fail "expected a positive number"
-- :}
--
-- >>> decodeText @Job "{}"
-- Right (Job Nothing)
--
-- >>> decodeText @Job "retries: null\n"
-- Right (Job Nothing)
--
-- >>> decodeText @Job "retries: 3\n"
-- Right (Job (Just 3))
--
-- To give a null value to the parser, use 'parseFieldIfPresentWith'.
parseFieldMaybeWith :: (S.Node -> Parser a) -> Object -> T.Text -> Parser (Maybe a)
parseFieldMaybeWith :: forall a. (Node -> Parser a) -> Object -> Text -> Parser (Maybe a)
parseFieldMaybeWith Node -> Parser a
p = ((Node, Node) -> Parser a) -> Object -> Text -> Parser (Maybe a)
forall a.
((Node, Node) -> Parser a) -> Object -> Text -> Parser (Maybe a)
entryFieldMaybe ((Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser a
p (Node -> Parser a)
-> ((Node, Node) -> Node) -> (Node, Node) -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, Node) -> Node
forall a b. (a, b) -> b
snd)

-- | Like 'parseFieldIfPresent', with the given parser for the value, as in
-- 'parseFieldWith'. The result is 'Nothing' only if the key is missing.
-- A null value goes to the parser, so the parser can give it a meaning of
-- its own. Here a missing key takes the default limit, and null means no
-- limit:
--
-- >>> :{
-- data Limit = Unlimited | Limit Int
--   deriving stock (Show)
-- newtype Job = Job (Maybe Limit)
--   deriving stock (Show)
-- instance FromYaml Job where
--   parseYaml = withMapping $ \o -> Job <$> parseFieldIfPresentWith limit o "limit"
--     where
--       limit :: Node -> Parser Limit
--       limit n = case view n of
--         NullView -> pure Unlimited
--         _ -> withInt (pure . Limit . fromInteger) n
-- :}
--
-- >>> decodeText @Job "{}"
-- Right (Job Nothing)
--
-- >>> decodeText @Job "limit: null\n"
-- Right (Job (Just Unlimited))
--
-- >>> decodeText @Job "limit: 3\n"
-- Right (Job (Just (Limit 3)))
--
-- With 'parseFieldMaybeWith', the null value would give 'Nothing', the
-- same as the missing key.
parseFieldIfPresentWith :: (S.Node -> Parser a) -> Object -> T.Text -> Parser (Maybe a)
parseFieldIfPresentWith :: forall a. (Node -> Parser a) -> Object -> Text -> Parser (Maybe a)
parseFieldIfPresentWith Node -> Parser a
p = ((Node, Node) -> Parser a) -> Object -> Text -> Parser (Maybe a)
forall a.
((Node, Node) -> Parser a) -> Object -> Text -> Parser (Maybe a)
entryFieldIfPresent ((Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser a
p (Node -> Parser a)
-> ((Node, Node) -> Node) -> (Node, Node) -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, Node) -> Node
forall a b. (a, b) -> b
snd)

-- | Like 'parseFieldDefault', with the given parser for the value, as in
-- 'parseFieldWith'. The parser never gets a null value.
--
-- >>> :{
-- newtype Job = Job Int
--   deriving stock (Show)
-- instance FromYaml Job where
--   parseYaml = withMapping $ \o -> Job <$> parseFieldDefaultWith positive o "retries" 1
--     where
--       positive :: Node -> Parser Int
--       positive = withInt $ \i ->
--         if i > 0 then pure (fromInteger i) else fail "expected a positive number"
-- :}
--
-- >>> decodeText @Job "{}"
-- Right (Job 1)
--
-- >>> decodeText @Job "retries: 3\n"
-- Right (Job 3)
parseFieldDefaultWith :: (S.Node -> Parser a) -> Object -> T.Text -> a -> Parser a
parseFieldDefaultWith :: forall a. (Node -> Parser a) -> Object -> Text -> a -> Parser a
parseFieldDefaultWith Node -> Parser a
p Object
o Text
key a
def = a -> Maybe a -> a
forall a. a -> Maybe a -> a
fromMaybe a
def (Maybe a -> a) -> Parser (Maybe a) -> Parser a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node -> Parser a) -> Object -> Text -> Parser (Maybe a)
forall a. (Node -> Parser a) -> Object -> Text -> Parser (Maybe a)
parseFieldMaybeWith Node -> Parser a
p Object
o Text
key

-- | The value of a key, with the given parser for the entry.
entryField :: ((S.Node, S.Node) -> Parser a) -> Object -> T.Text -> Parser a
entryField :: forall a. ((Node, Node) -> Parser a) -> Object -> Text -> Parser a
entryField (Node, Node) -> Parser a
p Object
o Text
key = case Text -> Map Text (Node, Node) -> Maybe (Node, Node)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Object
o.index of
  Just (Node, Node)
entry -> (Node, Node) -> Parser a
p (Node, Node)
entry
  Maybe (Node, Node)
Nothing -> Object -> Text -> Parser a
forall a. Object -> Text -> Parser a
missingKey Object
o Text
key

-- | The value of a key that can be missing or null, with the given parser
-- for the entry.
entryFieldMaybe :: ((S.Node, S.Node) -> Parser a) -> Object -> T.Text -> Parser (Maybe a)
entryFieldMaybe :: forall a.
((Node, Node) -> Parser a) -> Object -> Text -> Parser (Maybe a)
entryFieldMaybe (Node, Node) -> Parser a
p Object
o Text
key =
  Object -> Text -> Parser (Maybe (Node, Node))
findKey Object
o Text
key Parser (Maybe (Node, Node))
-> (Maybe (Node, Node) -> Parser (Maybe a)) -> Parser (Maybe a)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (Node
_, Node
v) | Node -> Bool
isNullNode Node
v -> Maybe a -> Parser (Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    Maybe (Node, Node)
entry -> ((Node, Node) -> Parser a)
-> Maybe (Node, Node) -> Parser (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Node, Node) -> Parser a
p Maybe (Node, Node)
entry

-- | The value of a key that can be missing, with the given parser for the
-- entry.
entryFieldIfPresent
  :: ((S.Node, S.Node) -> Parser a) -> Object -> T.Text -> Parser (Maybe a)
entryFieldIfPresent :: forall a.
((Node, Node) -> Parser a) -> Object -> Text -> Parser (Maybe a)
entryFieldIfPresent (Node, Node) -> Parser a
p Object
o Text
key = Object -> Text -> Parser (Maybe (Node, Node))
findKey Object
o Text
key Parser (Maybe (Node, Node))
-> (Maybe (Node, Node) -> Parser (Maybe a)) -> Parser (Maybe a)
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Node, Node) -> Parser a)
-> Maybe (Node, Node) -> Parser (Maybe a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Node, Node) -> Parser a
p

-- | The value of an entry, with errors that point to the value.
parseEntry :: FromYaml a => (S.Node, S.Node) -> Parser a
parseEntry :: forall a. FromYaml a => (Node, Node) -> Parser a
parseEntry (Node
k, Node
v) = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode (Node -> Node -> Parser a
forall a. FromYaml a => Node -> Node -> Parser a
parseYamlField Node
k) Node
v

-- | The entry of a string key, or 'Nothing' if the key is missing. A key with
-- the same text that is not a string, e.g. 404, is an error, so that its
-- value does not go away. Only the same text counts, e.g. not True for true,
-- because quotes would not make True the key true.
findKey :: Object -> T.Text -> Parser (Maybe (S.Node, S.Node))
findKey :: Object -> Text -> Parser (Maybe (Node, Node))
findKey Object
o Text
key = case Text -> Map Text (Node, Node) -> Maybe (Node, Node)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
key Object
o.index of
  Just (Node, Node)
entry -> Maybe (Node, Node) -> Parser (Maybe (Node, Node))
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Node, Node) -> Maybe (Node, Node)
forall a. a -> Maybe a
Just (Node, Node)
entry)
  Maybe (Node, Node)
Nothing -> case ((Node, Value) -> Bool) -> [(Node, Value)] -> Maybe (Node, Value)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find (Node -> Bool
sameText (Node -> Bool) -> ((Node, Value) -> Node) -> (Node, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, Value) -> Node
forall a b. (a, b) -> a
fst) Object
o.otherKeys of
    Just (Node
k, Value
v) ->
      Node -> [Char] -> Parser (Maybe (Node, Node))
forall a. Node -> [Char] -> Parser a
failAt Node
k ([Char] -> Parser (Maybe (Node, Node)))
-> [Char] -> Parser (Maybe (Node, Node))
forall a b. (a -> b) -> a -> b
$ [Char]
"the key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
showText Text
key [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Value -> [Char]
describe Value
v [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", not a string"
    Maybe (Node, Value)
Nothing -> Maybe (Node, Node) -> Parser (Maybe (Node, Node))
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Node, Node)
forall a. Maybe a
Nothing
  where
    sameText :: S.Node -> Bool
    sameText :: Node -> Bool
sameText Node
k = case Node
k.content of
      S.ScalarContent ScalarStyle
_ Text
t -> Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
key
      Content
_ -> Bool
False

-- | The error for a key that is not in the index of string keys. As for
-- 'findKey', a key with the same text that is not a string is the error
-- instead.
missingKey :: Object -> T.Text -> Parser a
missingKey :: forall a. Object -> Text -> Parser a
missingKey Object
o Text
key = (Offset -> Result a) -> Parser a
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result a) -> Parser a)
-> (Offset -> Result a) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Offset
off ->
  let Parser Offset -> Result (Maybe (Node, Node))
g = Object -> Text -> Parser (Maybe (Node, Node))
findKey Object
o Text
key
  in case Offset -> Result (Maybe (Node, Node))
g Offset
off of
       Result Errors
NoErrors Maybe (Node, Node)
_
         | Text -> Map Text (Node, Node) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Text
"<<" Object
o.index ->
             Offset -> [Char] -> Result a
forall a. Offset -> [Char] -> Result a
failure Object
o.node.offset ([Char]
"missing key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
showText Text
key [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
noMergeKeys)
         | Bool
otherwise -> Offset -> [Char] -> Result a
forall a. Offset -> [Char] -> Result a
failure Object
o.node.offset ([Char]
"missing key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
showText Text
key)
       Result Errors
e Maybe (Node, Node)
_ -> Errors -> a -> Result a
forall a. Errors -> a -> Result a
Result Errors
e a
forall a. a
failed

-- | Fail at each key that is not in the list. If a key in the list is close
-- to an unknown key, e.g. "host" to "hots", its error suggests it. Otherwise
-- the error lists the known keys. An empty list accepts only an empty
-- mapping, e.g. for a value written as @{}@.
--
-- A key that is not a string, but has the text of a known key, e.g. @true@,
-- is left to the lookup of that key, e.g. 'parseField' or 'lookupKey',
-- which reports it.
rejectUnknownKeys :: [T.Text] -> Object -> Parser ()
rejectUnknownKeys :: [Text] -> Object -> Parser ()
rejectUnknownKeys [Text]
known Object
o
  -- The index has the text of each string key, so the keys are not viewed
  -- again, which saves the allocation of their text in the benchmarks
  -- derive.*.parseYaml.generic. The index has every key if the keys are
  -- strings without duplicates.
  | Map Text (Node, Node) -> Int
forall k a. Map k a -> Int
M.size Object
o.index Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [(Node, Node)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Object
o.entries
      Bool -> Bool -> Bool
&& (Bool -> Text -> (Node, Node) -> Bool)
-> Bool -> Map Text (Node, Node) -> Bool
forall a k b. (a -> k -> b -> a) -> a -> Map k b -> a
M.foldlWithKey' (\Bool
r Text
k (Node, Node)
_ -> Bool
r Bool -> Bool -> Bool
&& Text -> Bool
isKnown Text
k) Bool
True Object
o.index =
      () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  | Bool
otherwise = Bool -> [Text] -> [(Node, Node)] -> Parser ()
go Bool
True [] Object
o.entries
  where
    -- 'elem' is not specialized to 'T.Text' here, see the Core at -O, so it
    -- compares through the dictionary of 'Eq'.
    isKnown :: T.Text -> Bool
    isKnown :: Text -> Bool
isKnown Text
t = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t) [Text]
known

    -- The flag tells if no error listed the known keys yet. The list has the
    -- texts of the keys that a lookup reports: for each text, the first key
    -- that is not a string. The keys in a copy of an alias share one offset,
    -- so an offset cannot tell them apart.
    go :: Bool -> [T.Text] -> [(S.Node, S.Node)] -> Parser ()
    go :: Bool -> [Text] -> [(Node, Node)] -> Parser ()
go Bool
unlisted [Text]
reported = \case
      [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      (Node
k, Node
_) : [(Node, Node)]
rest -> case Node -> Maybe Text
stringValue Node
k of
        Just Text
t
          | Text -> Bool
isKnown Text
t -> Bool -> [Text] -> [(Node, Node)] -> Parser ()
go Bool
unlisted [Text]
reported [(Node, Node)]
rest
          | Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"<<" -> Node -> Text -> [Char] -> Parser ()
unknown Node
k Text
t [Char]
noMergeKeys Parser () -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> [Text] -> [(Node, Node)] -> Parser ()
go Bool
unlisted [Text]
reported [(Node, Node)]
rest
          | Just Text
s <- [Text] -> Text -> Maybe Text
closeName [Text]
known Text
t ->
              Node -> Text -> [Char] -> Parser ()
unknown Node
k Text
t (Text -> [Char]
didYouMean Text
s) Parser () -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> [Text] -> [(Node, Node)] -> Parser ()
go Bool
unlisted [Text]
reported [(Node, Node)]
rest
          | Bool
unlisted ->
              Node -> Text -> [Char] -> Parser ()
unknown
                Node
k
                Text
t
                ( if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
known
                    then [Char]
", the mapping must be empty"
                    else [Text] -> [Char]
expectedOneOf [Text]
known
                )
                Parser () -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> [Text] -> [(Node, Node)] -> Parser ()
go Bool
False [Text]
reported [(Node, Node)]
rest
          | Bool
otherwise -> Node -> Text -> [Char] -> Parser ()
unknown Node
k Text
t [Char]
"" Parser () -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> [Text] -> [(Node, Node)] -> Parser ()
go Bool
False [Text]
reported [(Node, Node)]
rest
        Maybe Text
_
          | S.ScalarContent ScalarStyle
_ Text
t <- Node
k.content
          , Text -> Bool
isKnown Text
t
          , Bool -> Bool
not (Text -> Map Text (Node, Node) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Text
t Object
o.index)
          , Bool -> Bool
not ((Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t) [Text]
reported) ->
              Bool -> [Text] -> [(Node, Node)] -> Parser ()
go Bool
unlisted (Text
t Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
reported) [(Node, Node)]
rest
          | Bool
otherwise ->
              [Char] -> Node -> Parser (ZonkAny 0)
forall a. [Char] -> Node -> Parser a
typeMismatch [Char]
"a string as the key" Node
k Parser (ZonkAny 0) -> Parser () -> Parser ()
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> [Text] -> [(Node, Node)] -> Parser ()
go Bool
unlisted [Text]
reported [(Node, Node)]
rest

    unknown :: S.Node -> T.Text -> String -> Parser ()
    unknown :: Node -> Text -> [Char] -> Parser ()
unknown Node
k Text
t [Char]
hint = Node -> [Char] -> Parser ()
forall a. Node -> [Char] -> Parser a
failAt Node
k ([Char] -> Parser ()) -> [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
showText Text
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hint

-- | The error at the node for a name that is none of the known names, e.g.
-- an unknown value, with the known name that is close to it, or else all
-- known names.
unknownName :: String -> [T.Text] -> S.Node -> T.Text -> Parser a
unknownName :: forall a. [Char] -> [Text] -> Node -> Text -> Parser a
unknownName [Char]
what [Text]
known Node
n Text
t =
  Node -> [Char] -> Parser a
forall a. Node -> [Char] -> Parser a
failAt Node
n ([Char] -> Parser a) -> [Char] -> Parser a
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
what [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
showText Text
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
hint
  where
    hint :: String
    hint :: [Char]
hint
      | [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
known = [Char]
", no " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
what [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is accepted"
      | Bool
otherwise = [Char] -> (Text -> [Char]) -> Maybe Text -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Text] -> [Char]
expectedOneOf [Text]
known) Text -> [Char]
didYouMean ([Text] -> Text -> Maybe Text
closeName [Text]
known Text
t)

didYouMean :: T.Text -> String
didYouMean :: Text -> [Char]
didYouMean Text
s = [Char]
", did you mean " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
showText Text
s [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"?"

expectedOneOf :: [T.Text] -> String
expectedOneOf :: [Text] -> [Char]
expectedOneOf [Text]
known = [Char]
", expected one of: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
L.intercalate [Char]
", " ((Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
T.unpack [Text]
known)

-- | The known name that is close to the name, e.g. "host" for "hots".
closeName :: [T.Text] -> T.Text -> Maybe T.Text
closeName :: [Text] -> Text -> Maybe Text
closeName [Text]
known Text
t =
  case ((Int, Text) -> Int) -> [(Int, Text)] -> [(Int, Text)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
L.sortOn
    (Int, Text) -> Int
forall a b. (a, b) -> a
fst
    [ (Int
d, Text
s)
    | Text
s <- [Text]
known
    , Int -> Int
forall a. Num a => a -> a
abs (Text -> Int
T.length Text
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxEdits
    , let d :: Int
d = [Char] -> [Char] -> Int
distance (Text -> [Char]
T.unpack Text
t) (Text -> [Char]
T.unpack Text
s)
    , Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
maxEdits
    , Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n
    ] of
    (Int
_, Text
s) : [(Int, Text)]
_ -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
    [] -> Maybe Text
forall a. Maybe a
Nothing
  where
    n :: Int
    n :: Int
n = Text -> Int
T.length Text
t

    -- A swap of two adjacent characters, e.g. "hots" for "host", takes two
    -- edits. The distance is at least the difference of the lengths, so a
    -- long input from an attacker needs no table of distances.
    maxEdits :: Int
    maxEdits :: Int
maxEdits = Int
2

    -- The Levenshtein distance: the number of characters to insert, delete
    -- or change. After i characters of xs, the row holds the distance from
    -- them to each prefix of ys.
    distance :: String -> String -> Int
    distance :: [Char] -> [Char] -> Int
distance [Char]
xs [Char]
ys = case [Int] -> [Int]
forall a. [a] -> [a]
reverse (([Int] -> (Int, Char) -> [Int]) -> [Int] -> [(Int, Char)] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' [Int] -> (Int, Char) -> [Int]
nextRow [Int
0 .. [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
ys] ([Int] -> [Char] -> [(Int, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] [Char]
xs)) of
      Int
d : [Int]
_ -> Int
d
      [] -> [Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
ys
      where
        nextRow :: [Int] -> (Int, Char) -> [Int]
        nextRow :: [Int] -> (Int, Char) -> [Int]
nextRow [Int]
row (Int
i, Char
x) = (Int -> (Char, Int, Int) -> Int)
-> Int -> [(Char, Int, Int)] -> [Int]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl Int -> (Char, Int, Int) -> Int
cell Int
i ([Char] -> [Int] -> [Int] -> [(Char, Int, Int)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 [Char]
ys [Int]
row (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int]
row))
          where
            -- The distances to the left, diagonally above and above.
            cell :: Int -> (Char, Int, Int) -> Int
            cell :: Int -> (Char, Int, Int) -> Int
cell Int
left (Char
y, Int
diagonal, Int
above) =
              [Int] -> Int
forall a. Ord a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
minimum [Int
left Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
above Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1, Int
diagonal Int -> Int -> Int
forall a. Num a => a -> a -> a
+ if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
y then Int
0 else Int
1]

----------------------------------------
-- Class

-- | Types that can be parsed from a node. A type with a
-- t'GHC.Generics.Generic' instance can derive the instance via
-- t'Yamlet.Generic.GenericYaml'.
--
-- An instance for a record reads a mapping with 'withMapping':
--
-- >>> :{
-- data Server = Server {host :: T.Text, port :: Int, tags :: [T.Text]}
--   deriving stock (Show)
-- instance FromYaml Server where
--   parseYaml = withMapping $ \o ->
--     rejectUnknownKeys ["host", "port", "tags"] o
--       *> ( Server
--              <$> parseField o "host"
--              <*> parseFieldDefault o "port" 80
--              <*> parseFieldDefault o "tags" []
--          )
-- :}
--
-- >>> decodeText @Server "host: example.com\ntags:\n- web\n"
-- Right (Server {host = "example.com", port = 80, tags = ["web"]})
--
-- The decoder reports the errors of all fields together:
--
-- >>> either printErrors print (decodeText @Server "hots: example.com\nport: http\n")
-- input.yaml:1:1: unknown key "hots", did you mean "host"?
--   |
-- 1 | hots: example.com
--   | ^
-- input.yaml:1:1: missing key "host"
--   |
-- 1 | hots: example.com
--   | ^
-- input.yaml:2:7: port: expected an integer, but got a string
--   |
-- 2 | port: http
--   |       ^
--
-- The instances of the library copy the texts that they keep, so a decoded
-- value does not keep the input in memory. A value from a hand-written
-- instance can keep the input while it has unevaluated parts, e.g. a lazy
-- list. Evaluate such a value, e.g. with 'Control.DeepSeq.force', to release
-- the input.
class FromYaml a where
  parseYaml :: S.Node -> Parser a

  -- | Parse a list. The instance for 'Char' parses a string instead.
  parseYamlList :: S.Node -> Parser [a]
  parseYamlList = ([Node] -> Parser [a]) -> Node -> Parser [a]
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence ((Node -> Parser a) -> [Node] -> Parser [a]
forall a. (Node -> Parser a) -> [Node] -> Parser [a]
parseItems Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml)

  -- | Parse the value of a mapping entry, with its key, e.g. to keep the
  -- comments of the key as 'Yamlet.Commented' does. 'parseField' and the
  -- other lookups without a parser argument, the derived decoders and the
  -- instances for maps use it. The default ignores the key.
  parseYamlField :: S.Node -> S.Node -> Parser a
  parseYamlField Node
_ = Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml

-- | The node of the syntax tree, with its styles and comments, e.g. to write
-- a part of a document back as it was written. An alias in the input gives a
-- copy of the node that it refers to.
--
-- The texts of the node are copies, so that a small part of a document does
-- not keep the whole input alive. For a whole document without a copy, use
-- 'Yamlet.Syntax.parseDocuments'.
instance FromYaml S.Node where
  parseYaml :: Node -> Parser Node
parseYaml Node
n = Node -> Parser Node
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Node -> Parser Node) -> Node -> Parser Node
forall a b. (a -> b) -> a -> b
$! Node -> Node
S.copyNode Node
n

-- | The value with the comments of its entry, or of its node if it has no key,
-- copied like every decoded text.
instance FromYaml a => FromYaml (S.Commented a) where
  parseYaml :: Node -> Parser (Commented a)
parseYaml Node
v =
    (a -> Comments -> Commented a) -> Comments -> a -> Commented a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Comments -> Commented a
forall a. a -> Comments -> Commented a
S.Commented (Comments -> Comments
S.copyComments Node
v.comments)
      (a -> Commented a) -> Parser a -> Parser (Commented a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml (Comments -> Node -> Node
S.withComments Comments
S.noComments Node
v)
  parseYamlField :: Node -> Node -> Parser (Commented a)
parseYamlField Node
k Node
v =
    (a -> Comments -> Commented a) -> Comments -> a -> Commented a
forall a b c. (a -> b -> c) -> b -> a -> c
flip
      a -> Comments -> Commented a
forall a. a -> Comments -> Commented a
S.Commented
      ( Comments -> Comments
S.copyComments
          (S.Comments {before :: [Line]
S.before = [Line]
before, inline :: Maybe Text
S.inline = Maybe Text
inline, after :: [Line]
S.after = Node
v.comments.after})
      )
      (a -> Commented a) -> Parser a -> Parser (Commented a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml Node
value
    where
      -- The lines above a value on the line of its key or in the flow style go
      -- above the entry, as the renderer writes them. The lines above the
      -- first entry of a block collection stay in the value, because the
      -- renderer writes them below the key.
      block :: Bool
      block :: Bool
block = case Node
v.content of
        S.SequenceContent CollectionStyle
S.Block (Node
_ : [Node]
_) -> Bool
True
        S.MappingContent CollectionStyle
S.Block ((Node, Node)
_ : [(Node, Node)]
_) -> Bool
True
        Content
_ -> Bool
False

      above :: [S.Line]
      above :: [Line]
above = Node
k.comments.before [Line] -> [Line] -> [Line]
forall a. [a] -> [a] -> [a]
++ if Bool
block then [] else Node
v.comments.before

      -- A line has one comment at its end. With an explicit key, both nodes
      -- can have one, and the renderer writes the comment of the key above.
      before :: [S.Line]
      inline :: Maybe T.Text
      ([Line]
before, Maybe Text
inline) = case (Node
k.comments.inline, Node
v.comments.inline) of
        (Just Text
kc, Just Text
vc) -> ([Line]
above [Line] -> [Line] -> [Line]
forall a. [a] -> [a] -> [a]
++ [Text -> Line
S.Comment Text
kc], Text -> Maybe Text
forall a. a -> Maybe a
Just Text
vc)
        (Maybe Text
kc, Maybe Text
vc) -> ([Line]
above, Maybe Text
vc Maybe Text -> Maybe Text -> Maybe Text
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Text
kc)

      -- The value without the comments of the entry.
      value :: S.Node
      value :: Node
value =
        let rest :: Comments
rest =
              S.Comments
                { before :: [Line]
S.before = if Bool
block then Node
v.comments.before else []
                , inline :: Maybe Text
S.inline = Maybe Text
forall a. Maybe a
Nothing
                , after :: [Line]
S.after = []
                }
        in Comments -> Node -> Node
S.withComments Comments
rest Node
v

-- | The value with the offset of its node. The key of an entry goes to the
-- value inside, e.g. for a 'Yamlet.Commented' value.
instance FromYaml a => FromYaml (S.Located a) where
  parseYaml :: Node -> Parser (Located a)
parseYaml Node
n = (a -> Offset -> Located a) -> Offset -> a -> Located a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Offset -> Located a
forall a. a -> Offset -> Located a
S.Located Node
n.offset (a -> Located a) -> Parser a -> Parser (Located a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml Node
n
  parseYamlField :: Node -> Node -> Parser (Located a)
parseYamlField Node
k Node
n = (a -> Offset -> Located a) -> Offset -> a -> Located a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Offset -> Located a
forall a. a -> Offset -> Located a
S.Located Node
n.offset (a -> Located a) -> Parser a -> Parser (Located a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Node -> Node -> Parser a
forall a. FromYaml a => Node -> Node -> Parser a
parseYamlField Node
k Node
n

-- | The value of the node, with the tags resolved and the aliases replaced.
instance FromYaml Value where
  parseYaml :: Node -> Parser Value
parseYaml Node
n = case Node -> Either (NonEmpty (Offset, [Char])) Value
representPrepared Node
n of
    -- The value is built lazily. The copy visits a node once per alias of
    -- it, as the limit of 'prepareWithin' allows.
    Right Value
r -> Value -> Parser Value
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Parser Value) -> Value -> Parser Value
forall a b. (a -> b) -> a -> b
$! Value -> Value
copy Value
r
    Left ((Offset
off, [Char]
msg) NE.:| [(Offset, [Char])]
notes) -> (Offset -> Result Value) -> Parser Value
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result Value) -> Parser Value)
-> (Offset -> Result Value) -> Parser Value
forall a b. (a -> b) -> a -> b
$ \Offset
_ -> Errors -> Value -> Result Value
forall a. Errors -> a -> Result a
Result (Offset -> [Char] -> [(Offset, [Char])] -> Errors
OneError Offset
off [Char]
msg [(Offset, [Char])]
notes) Value
forall a. a
failed
    where
      -- The value in normal form, with copies of its texts.
      copy :: Value -> Value
      copy :: Value -> Value
copy = \case
        String Text
t -> Text -> Value
String (Text -> Text
T.copy Text
t)
        Sequence [Value]
xs -> [Value] -> Value
Sequence ((Value -> Value) -> [Value] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
strictMap Value -> Value
copy [Value]
xs)
        Mapping [(Value, Value)]
kvs -> [(Value, Value)] -> Value
Mapping (((Value, Value) -> (Value, Value))
-> [(Value, Value)] -> [(Value, Value)]
forall a b. (a -> b) -> [a] -> [b]
strictMap (\(Value
k, Value
v) -> Value -> Value -> (Value, Value)
forall a b. a -> b -> (a, b)
strictPair (Value -> Value
copy Value
k) (Value -> Value
copy Value
v)) [(Value, Value)]
kvs)
        Tagged Text
tag Value
v -> Text -> Value -> Value
Tagged (Text -> Text
T.copy Text
tag) (Value -> Value
copy Value
v)
        Value
v -> Value
v

-- | An empty list, as a tuple without elements.
instance FromYaml () where
  parseYaml :: Node -> Parser ()
parseYaml = (Node -> Parser ()) -> Node -> Parser ()
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser ()) -> Node -> Parser ())
-> (Node -> Parser ()) -> Node -> Parser ()
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node -> View
view Node
n of
    SequenceView [] -> () -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    View
_ -> [Char] -> Node -> Parser ()
forall a. [Char] -> Node -> Parser a
typeMismatch [Char]
"an empty list" Node
n

instance FromYaml Bool where
  parseYaml :: Node -> Parser Bool
parseYaml = (Bool -> Parser Bool) -> Node -> Parser Bool
forall a. (Bool -> Parser a) -> Node -> Parser a
withBool Bool -> Parser Bool
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromYaml Integer where
  parseYaml :: Node -> Parser Integer
parseYaml = (Integer -> Parser Integer) -> Node -> Parser Integer
forall a. (Integer -> Parser a) -> Node -> Parser a
withInt Integer -> Parser Integer
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromYaml Natural where
  parseYaml :: Node -> Parser Natural
parseYaml = (Integer -> Parser Natural) -> Node -> Parser Natural
forall a. (Integer -> Parser a) -> Node -> Parser a
withInt ((Integer -> Parser Natural) -> Node -> Parser Natural)
-> (Integer -> Parser Natural) -> Node -> Parser Natural
forall a b. (a -> b) -> a -> b
$ \Integer
i ->
    if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
      then [Char] -> Parser Natural
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expected a non-negative integer"
      else Natural -> Parser Natural
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Natural
forall a. Num a => Integer -> a
fromInteger Integer
i)

instance FromYaml Int where parseYaml :: Node -> Parser Int
parseYaml = Node -> Parser Int
forall a. (Bounded a, Integral a) => Node -> Parser a
bounded
instance FromYaml Int8 where parseYaml :: Node -> Parser Int8
parseYaml = Node -> Parser Int8
forall a. (Bounded a, Integral a) => Node -> Parser a
bounded
instance FromYaml Int16 where parseYaml :: Node -> Parser Int16
parseYaml = Node -> Parser Int16
forall a. (Bounded a, Integral a) => Node -> Parser a
bounded
instance FromYaml Int32 where parseYaml :: Node -> Parser Int32
parseYaml = Node -> Parser Int32
forall a. (Bounded a, Integral a) => Node -> Parser a
bounded
instance FromYaml Int64 where parseYaml :: Node -> Parser Int64
parseYaml = Node -> Parser Int64
forall a. (Bounded a, Integral a) => Node -> Parser a
bounded
instance FromYaml Word where parseYaml :: Node -> Parser Word
parseYaml = Node -> Parser Word
forall a. (Bounded a, Integral a) => Node -> Parser a
bounded
instance FromYaml Word8 where parseYaml :: Node -> Parser Word8
parseYaml = Node -> Parser Word8
forall a. (Bounded a, Integral a) => Node -> Parser a
bounded
instance FromYaml Word16 where parseYaml :: Node -> Parser Word16
parseYaml = Node -> Parser Word16
forall a. (Bounded a, Integral a) => Node -> Parser a
bounded
instance FromYaml Word32 where parseYaml :: Node -> Parser Word32
parseYaml = Node -> Parser Word32
forall a. (Bounded a, Integral a) => Node -> Parser a
bounded
instance FromYaml Word64 where parseYaml :: Node -> Parser Word64
parseYaml = Node -> Parser Word64
forall a. (Bounded a, Integral a) => Node -> Parser a
bounded

-- | An integer in the range of a bounded type.
bounded :: forall a. (Bounded a, Integral a) => S.Node -> Parser a
bounded :: forall a. (Bounded a, Integral a) => Node -> Parser a
bounded = (Integer -> Parser a) -> Node -> Parser a
forall a. (Integer -> Parser a) -> Node -> Parser a
withInt ((Integer -> Parser a) -> Node -> Parser a)
-> (Integer -> Parser a) -> Node -> Parser a
forall a b. (a -> b) -> a -> b
$ \Integer
i ->
  if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< a -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
minBound @a) Bool -> Bool -> Bool
|| Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> a -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound @a)
    then
      [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser a) -> [Char] -> Parser a
forall a b. (a -> b) -> a -> b
$
        [Char]
"the integer is out of the range from "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show (a -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
minBound @a))
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" to "
          [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show (a -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound @a))
    else a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
i)

instance FromYaml Double where
  parseYaml :: Node -> Parser Double
parseYaml = (Double -> Parser Double) -> Node -> Parser Double
forall a. (Double -> Parser a) -> Node -> Parser a
withFloat Double -> Parser Double
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromYaml Sci.Scientific where
  parseYaml :: Node -> Parser Scientific
parseYaml = (Scientific -> Parser Scientific) -> Node -> Parser Scientific
forall a. (Scientific -> Parser a) -> Node -> Parser a
withScientific Scientific -> Parser Scientific
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

-- | @YYYY-MM-DD@, e.g. @2026-09-25@. The year has at most 15 digits, here and
-- in the other types with a date.
instance FromYaml Day where
  parseYaml :: Node -> Parser Day
parseYaml = [Char] -> (Text -> Either [Char] Day) -> Node -> Parser Day
forall a. [Char] -> (Text -> Either [Char] a) -> Node -> Parser a
withIso8601 [Char]
"expected a date such as 2026-09-25" Text -> Either [Char] Day
parseDay

-- | @HH:MM@, with optional seconds and a fraction of a second of at most 12
-- digits, e.g. @12:30:05.25@.
instance FromYaml TimeOfDay where
  parseYaml :: Node -> Parser TimeOfDay
parseYaml = [Char]
-> (Text -> Either [Char] TimeOfDay) -> Node -> Parser TimeOfDay
forall a. [Char] -> (Text -> Either [Char] a) -> Node -> Parser a
withIso8601 [Char]
"expected a time such as 12:30:00" Text -> Either [Char] TimeOfDay
parseTimeOfDay

-- | A date and a time, separated by @T@ or a space, e.g.
-- @2026-09-25T12:30:00@.
instance FromYaml LocalTime where
  parseYaml :: Node -> Parser LocalTime
parseYaml =
    [Char]
-> (Text -> Either [Char] LocalTime) -> Node -> Parser LocalTime
forall a. [Char] -> (Text -> Either [Char] a) -> Node -> Parser a
withIso8601 [Char]
"expected a date and a time such as 2026-09-25T12:30:00" Text -> Either [Char] LocalTime
parseLocalTime

-- | A date, a time and a time zone, e.g. @2026-09-25T12:30:00+02:00@. The
-- time zone is @Z@, @+HH:MM@, @+HHMM@ or @+HH@.
instance FromYaml ZonedTime where
  parseYaml :: Node -> Parser ZonedTime
parseYaml = [Char]
-> (Text -> Either [Char] ZonedTime) -> Node -> Parser ZonedTime
forall a. [Char] -> (Text -> Either [Char] a) -> Node -> Parser a
withIso8601 [Char]
zonedTimeMismatch Text -> Either [Char] ZonedTime
parseZonedTime

-- | Like t'ZonedTime', converted to UTC.
instance FromYaml UTCTime where
  parseYaml :: Node -> Parser UTCTime
parseYaml = [Char] -> (Text -> Either [Char] UTCTime) -> Node -> Parser UTCTime
forall a. [Char] -> (Text -> Either [Char] a) -> Node -> Parser a
withIso8601 [Char]
zonedTimeMismatch Text -> Either [Char] UTCTime
parseUTCTime

-- | A number of seconds, rounded down to a picosecond.
instance FromYaml NominalDiffTime where
  parseYaml :: Node -> Parser NominalDiffTime
parseYaml = (Scientific -> Parser NominalDiffTime)
-> Node -> Parser NominalDiffTime
forall a. (Scientific -> Parser a) -> Node -> Parser a
withScientific ((Scientific -> Parser NominalDiffTime)
 -> Node -> Parser NominalDiffTime)
-> (Scientific -> Parser NominalDiffTime)
-> Node
-> Parser NominalDiffTime
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Parser NominalDiffTime
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NominalDiffTime -> Parser NominalDiffTime)
-> (Scientific -> NominalDiffTime)
-> Scientific
-> Parser NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pico -> NominalDiffTime
secondsToNominalDiffTime (Pico -> NominalDiffTime)
-> (Scientific -> Pico) -> Scientific -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Pico
forall k (a :: k). Integer -> Fixed a
MkFixed (Integer -> Pico) -> (Scientific -> Integer) -> Scientific -> Pico
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Integer
picoseconds

-- | A number of seconds, rounded down to a picosecond.
instance FromYaml DiffTime where
  parseYaml :: Node -> Parser DiffTime
parseYaml = (Scientific -> Parser DiffTime) -> Node -> Parser DiffTime
forall a. (Scientific -> Parser a) -> Node -> Parser a
withScientific ((Scientific -> Parser DiffTime) -> Node -> Parser DiffTime)
-> (Scientific -> Parser DiffTime) -> Node -> Parser DiffTime
forall a b. (a -> b) -> a -> b
$ DiffTime -> Parser DiffTime
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime -> Parser DiffTime)
-> (Scientific -> DiffTime) -> Scientific -> Parser DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> DiffTime
picosecondsToDiffTime (Integer -> DiffTime)
-> (Scientific -> Integer) -> Scientific -> DiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Integer
picoseconds

-- | The text form with hyphens, e.g. @123e4567-e89b-12d3-a456-426614174000@.
instance FromYaml UUID.UUID where
  parseYaml :: Node -> Parser UUID
parseYaml =
    (Text -> Parser UUID) -> Node -> Parser UUID
forall a. (Text -> Parser a) -> Node -> Parser a
withText ((Text -> Parser UUID) -> Node -> Parser UUID)
-> (Text -> Parser UUID) -> Node -> Parser UUID
forall a b. (a -> b) -> a -> b
$
      Parser UUID -> (UUID -> Parser UUID) -> Maybe UUID -> Parser UUID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Parser UUID
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expected a UUID such as 123e4567-e89b-12d3-a456-426614174000") UUID -> Parser UUID
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Maybe UUID -> Parser UUID)
-> (Text -> Maybe UUID) -> Text -> Parser UUID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe UUID
UUID.fromText

-- | @YYYY-MM@, e.g. @2026-09@.
instance FromYaml Month where
  parseYaml :: Node -> Parser Month
parseYaml = [Char] -> (Text -> Either [Char] Month) -> Node -> Parser Month
forall a. [Char] -> (Text -> Either [Char] a) -> Node -> Parser a
withIso8601 [Char]
"expected a month such as 2026-09" Text -> Either [Char] Month
parseMonth

-- | @YYYY-qN@, e.g. @2026-q3@.
instance FromYaml Quarter where
  parseYaml :: Node -> Parser Quarter
parseYaml = [Char] -> (Text -> Either [Char] Quarter) -> Node -> Parser Quarter
forall a. [Char] -> (Text -> Either [Char] a) -> Node -> Parser a
withIso8601 [Char]
"expected a quarter such as 2026-q3" Text -> Either [Char] Quarter
parseQuarter

-- | @q1@ to @q4@.
instance FromYaml QuarterOfYear where
  parseYaml :: Node -> Parser QuarterOfYear
parseYaml = [Char]
-> (Text -> Either [Char] QuarterOfYear)
-> Node
-> Parser QuarterOfYear
forall a. [Char] -> (Text -> Either [Char] a) -> Node -> Parser a
withIso8601 [Char]
"expected a quarter of a year such as q3" Text -> Either [Char] QuarterOfYear
parseQuarterOfYear

-- | The English name in any case, e.g. @monday@.
instance FromYaml DayOfWeek where
  parseYaml :: Node -> Parser DayOfWeek
parseYaml = (Text -> Parser DayOfWeek) -> Node -> Parser DayOfWeek
forall a. (Text -> Parser a) -> Node -> Parser a
withText ((Text -> Parser DayOfWeek) -> Node -> Parser DayOfWeek)
-> (Text -> Parser DayOfWeek) -> Node -> Parser DayOfWeek
forall a b. (a -> b) -> a -> b
$ \Text
t ->
    Parser DayOfWeek
-> (DayOfWeek -> Parser DayOfWeek)
-> Maybe DayOfWeek
-> Parser DayOfWeek
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> Parser DayOfWeek
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expected a day of the week such as monday") DayOfWeek -> Parser DayOfWeek
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe DayOfWeek -> Parser DayOfWeek)
-> Maybe DayOfWeek -> Parser DayOfWeek
forall a b. (a -> b) -> a -> b
$
      Text -> [(Text, DayOfWeek)] -> Maybe DayOfWeek
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Text -> Text
T.toLower Text
t) [(Text -> Text
T.toLower ([Char] -> Text
T.pack (DayOfWeek -> [Char]
forall a. Show a => a -> [Char]
show DayOfWeek
d)), DayOfWeek
d) | DayOfWeek
d <- [DayOfWeek
Monday .. DayOfWeek
Sunday]]

-- | A mapping with the keys @months@ and @days@, e.g. @{months: 1, days: 2}@.
instance FromYaml CalendarDiffDays where
  parseYaml :: Node -> Parser CalendarDiffDays
parseYaml = (Object -> Parser CalendarDiffDays)
-> Node -> Parser CalendarDiffDays
forall a. (Object -> Parser a) -> Node -> Parser a
withMapping ((Object -> Parser CalendarDiffDays)
 -> Node -> Parser CalendarDiffDays)
-> (Object -> Parser CalendarDiffDays)
-> Node
-> Parser CalendarDiffDays
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    [Text] -> Object -> Parser ()
rejectUnknownKeys [Text
"months", Text
"days"] Object
o
      Parser () -> Parser CalendarDiffDays -> Parser CalendarDiffDays
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> Integer -> CalendarDiffDays
CalendarDiffDays (Integer -> Integer -> CalendarDiffDays)
-> Parser Integer -> Parser (Integer -> CalendarDiffDays)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Text -> Parser Integer
forall a. FromYaml a => Object -> Text -> Parser a
parseField Object
o Text
"months" Parser (Integer -> CalendarDiffDays)
-> Parser Integer -> Parser CalendarDiffDays
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Text -> Parser Integer
forall a. FromYaml a => Object -> Text -> Parser a
parseField Object
o Text
"days")

-- | A mapping with the keys @months@ and @time@, a number of seconds, e.g.
-- @{months: 1, time: 1.5}@.
instance FromYaml CalendarDiffTime where
  parseYaml :: Node -> Parser CalendarDiffTime
parseYaml = (Object -> Parser CalendarDiffTime)
-> Node -> Parser CalendarDiffTime
forall a. (Object -> Parser a) -> Node -> Parser a
withMapping ((Object -> Parser CalendarDiffTime)
 -> Node -> Parser CalendarDiffTime)
-> (Object -> Parser CalendarDiffTime)
-> Node
-> Parser CalendarDiffTime
forall a b. (a -> b) -> a -> b
$ \Object
o ->
    [Text] -> Object -> Parser ()
rejectUnknownKeys [Text
"months", Text
"time"] Object
o
      Parser () -> Parser CalendarDiffTime -> Parser CalendarDiffTime
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Integer -> NominalDiffTime -> CalendarDiffTime
CalendarDiffTime (Integer -> NominalDiffTime -> CalendarDiffTime)
-> Parser Integer -> Parser (NominalDiffTime -> CalendarDiffTime)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> Text -> Parser Integer
forall a. FromYaml a => Object -> Text -> Parser a
parseField Object
o Text
"months" Parser (NominalDiffTime -> CalendarDiffTime)
-> Parser NominalDiffTime -> Parser CalendarDiffTime
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> Text -> Parser NominalDiffTime
forall a. FromYaml a => Object -> Text -> Parser a
parseField Object
o Text
"time")

zonedTimeMismatch :: String
zonedTimeMismatch :: [Char]
zonedTimeMismatch = [Char]
"expected a date, a time and a time zone such as 2026-09-25T12:30:00Z"

-- | A string in an ISO 8601 format, with the same rules as aeson.
withIso8601 :: String -> (T.Text -> Either String a) -> S.Node -> Parser a
withIso8601 :: forall a. [Char] -> (Text -> Either [Char] a) -> Node -> Parser a
withIso8601 [Char]
mismatch Text -> Either [Char] a
p = (Text -> Parser a) -> Node -> Parser a
forall a. (Text -> Parser a) -> Node -> Parser a
withText ((Text -> Parser a) -> Node -> Parser a)
-> (Text -> Parser a) -> Node -> Parser a
forall a b. (a -> b) -> a -> b
$ ([Char] -> Parser a)
-> (a -> Parser a) -> Either [Char] a -> Parser a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Parser a -> [Char] -> Parser a
forall a b. a -> b -> a
const ([Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
mismatch)) a -> Parser a
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either [Char] a -> Parser a)
-> (Text -> Either [Char] a) -> Text -> Parser a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either [Char] a
p

-- | The picoseconds in a number of seconds, rounded down.
picoseconds :: Sci.Scientific -> Integer
picoseconds :: Scientific -> Integer
picoseconds Scientific
s
  | Integer
k Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
0 = Integer
c Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer
k
  | Bool
otherwise = Integer
c Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
10 Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Integer -> Integer
forall a. Num a => a -> a
negate Integer
k
  where
    c :: Integer
    c :: Integer
c = Scientific -> Integer
Sci.coefficient Scientific
s

    k :: Integer
    k :: Integer
k = Int -> Integer
forall a. Integral a => a -> Integer
toInteger (Scientific -> Int
Sci.base10Exponent Scientific
s) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
picoDecimals

-- | The nearest float. A conversion by way of 'Double' could round twice.
instance FromYaml Float where
  parseYaml :: Node -> Parser Float
parseYaml = (Float -> Parser Float) -> Node -> Parser Float
forall b a. RealFloat b => (b -> Parser a) -> Node -> Parser a
withRealFloat Float -> Parser Float
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromYaml T.Text where
  parseYaml :: Node -> Parser Text
parseYaml = (Text -> Parser Text) -> Node -> Parser Text
forall a. (Text -> Parser a) -> Node -> Parser a
withText Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance FromYaml TL.Text where
  parseYaml :: Node -> Parser Text
parseYaml = (Text -> Parser Text) -> Node -> Parser Text
forall a. (Text -> Parser a) -> Node -> Parser a
withText (Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Parser Text) -> (Text -> Text) -> Text -> Parser Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TL.fromStrict)

instance FromYaml Char where
  parseYaml :: Node -> Parser Char
parseYaml = (Text -> Parser Char) -> Node -> Parser Char
forall a. (Text -> Parser a) -> Node -> Parser a
withText ((Text -> Parser Char) -> Node -> Parser Char)
-> (Text -> Parser Char) -> Node -> Parser Char
forall a b. (a -> b) -> a -> b
$ \Text
t -> case Text -> [Char]
T.unpack Text
t of
    [Char
c] -> Char -> Parser Char
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Char
c
    [Char]
_ -> [Char] -> Parser Char
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expected a single character"
  parseYamlList :: Node -> Parser [Char]
parseYamlList = (Text -> Parser [Char]) -> Node -> Parser [Char]
forall a. (Text -> Parser a) -> Node -> Parser a
withText ([Char] -> Parser [Char]
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> Parser [Char])
-> (Text -> [Char]) -> Text -> Parser [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack)

instance FromYaml a => FromYaml [a] where
  parseYaml :: Node -> Parser [a]
parseYaml = Node -> Parser [a]
forall a. FromYaml a => Node -> Parser [a]
parseYamlList

instance FromYaml a => FromYaml (NE.NonEmpty a) where
  parseYaml :: Node -> Parser (NonEmpty a)
parseYaml = ([Node] -> Parser (NonEmpty a)) -> Node -> Parser (NonEmpty a)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser (NonEmpty a)) -> Node -> Parser (NonEmpty a))
-> ([Node] -> Parser (NonEmpty a)) -> Node -> Parser (NonEmpty a)
forall a b. (a -> b) -> a -> b
$ \case
    [] -> [Char] -> Parser (NonEmpty a)
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expected a non-empty list"
    Node
x : [Node]
xs -> a -> [a] -> NonEmpty a
forall a. a -> [a] -> NonEmpty a
(NE.:|) (a -> [a] -> NonEmpty a) -> Parser a -> Parser ([a] -> NonEmpty a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml Node
x Parser ([a] -> NonEmpty a) -> Parser [a] -> Parser (NonEmpty a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Node -> Parser a) -> [Node] -> Parser [a]
forall a. (Node -> Parser a) -> [Node] -> Parser [a]
parseItems Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml [Node]
xs

-- | Null is 'Nothing'. The key of an entry goes to the value inside, e.g. for
-- a 'Yamlet.Commented' value.
--
-- >>> decodeText @[Maybe Int] "- 1\n- null\n- ~\n-\n"
-- Right [Just 1,Nothing,Nothing,Nothing]
instance FromYaml a => FromYaml (Maybe a) where
  parseYaml :: Node -> Parser (Maybe a)
parseYaml Node
n = case Node -> View
view Node
n of
    View
NullView -> Maybe a -> Parser (Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    View
_ -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml Node
n
  parseYamlField :: Node -> Node -> Parser (Maybe a)
parseYamlField Node
k Node
n = case Node -> View
view Node
n of
    View
NullView -> Maybe a -> Parser (Maybe a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    View
_ -> a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> Parser a -> Parser (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Node -> Parser a
forall a. FromYaml a => Node -> Node -> Parser a
parseYamlField Node
k Node
n

-- | Two keys that convert to the same key, e.g. @1@ and @1.0@ for 'Double',
-- are an error.
--
-- Each key decodes with the instance of its type, so a map with
-- t'Data.Text.Text' keys rejects a key such as @404@ or @true@, because YAML
-- reads it as an integer or a boolean. Quote such a key in the input, e.g.
-- @\"404\": not found@, or use a key type that matches it, e.g. t'Int'.
--
-- >>> decodeText @(M.Map Int T.Text) "404: not found\n"
-- Right (fromList [(404,"not found")])
--
-- >>> either printErrors print (decodeText @(M.Map T.Text T.Text) "404: not found\n")
-- input.yaml:1:1: expected a string, but got an integer, quote the value, e.g. '404'
--   |
-- 1 | 404: not found
--   | ^
instance (Ord k, FromYaml k, FromYaml v) => FromYaml (M.Map k v) where
  parseYaml :: Node -> Parser (Map k v)
parseYaml = ((Maybe v -> (Bool, Maybe v)) -> k -> Map k v -> (Bool, Map k v))
-> Map k v -> Node -> Parser (Map k v)
forall k v m.
(Ord k, FromYaml k, FromYaml v) =>
((Maybe v -> (Bool, Maybe v)) -> k -> m -> (Bool, m))
-> m -> Node -> Parser m
uniqueEntries (Maybe v -> (Bool, Maybe v)) -> k -> Map k v -> (Bool, Map k v)
forall (f :: * -> *) k a.
(Functor f, Ord k) =>
(Maybe a -> f (Maybe a)) -> k -> Map k a -> f (Map k a)
M.alterF Map k v
forall k a. Map k a
M.empty

-- | Two keys that convert to the same key are an error.
instance FromYaml v => FromYaml (IM.IntMap v) where
  parseYaml :: Node -> Parser (IntMap v)
parseYaml = ((Maybe v -> (Bool, Maybe v))
 -> Int -> IntMap v -> (Bool, IntMap v))
-> IntMap v -> Node -> Parser (IntMap v)
forall k v m.
(Ord k, FromYaml k, FromYaml v) =>
((Maybe v -> (Bool, Maybe v)) -> k -> m -> (Bool, m))
-> m -> Node -> Parser m
uniqueEntries (Maybe v -> (Bool, Maybe v)) -> Int -> IntMap v -> (Bool, IntMap v)
forall (f :: * -> *) a.
Functor f =>
(Maybe a -> f (Maybe a)) -> Int -> IntMap a -> f (IntMap a)
IM.alterF IntMap v
forall a. IntMap a
IM.empty

-- | A list. Two elements that convert to the same value, e.g. @1@ and @1.0@
-- for 'Double', are an error.
instance (Ord a, FromYaml a) => FromYaml (Set.Set a) where
  parseYaml :: Node -> Parser (Set a)
parseYaml =
    ([Node] -> Parser (Set a)) -> Node -> Parser (Set a)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser (Set a)) -> Node -> Parser (Set a))
-> ([Node] -> Parser (Set a)) -> Node -> Parser (Set a)
forall a b. (a -> b) -> a -> b
$
      (Node -> Node)
-> (Node -> Parser a)
-> (a -> a)
-> (a -> Set a -> (Bool, Set a))
-> Set a
-> ([Char] -> [Char])
-> ([Char] -> [Char])
-> [Node]
-> Parser (Set a)
forall a x s c.
Ord c =>
(a -> Node)
-> (a -> Parser x)
-> (x -> c)
-> (x -> s -> (Bool, s))
-> s
-> ([Char] -> [Char])
-> ([Char] -> [Char])
-> [a]
-> Parser s
insertUnique
        Node -> Node
forall a. a -> a
id
        ((Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml)
        a -> a
forall a. a -> a
id
        ((Bool -> (Bool, Bool)) -> a -> Set a -> (Bool, Set a)
forall a (f :: * -> *).
(Ord a, Functor f) =>
(Bool -> f Bool) -> a -> Set a -> f (Set a)
Set.alterF (,Bool
True))
        Set a
forall a. Set a
Set.empty
        ([Char]
"duplicate element" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
        ([Char]
"the first element" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)

-- | A list. Two elements that convert to the same value, e.g. @1@ and @0x1@,
-- are an error.
instance FromYaml IS.IntSet where
  parseYaml :: Node -> Parser IntSet
parseYaml =
    ([Node] -> Parser IntSet) -> Node -> Parser IntSet
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser IntSet) -> Node -> Parser IntSet)
-> ([Node] -> Parser IntSet) -> Node -> Parser IntSet
forall a b. (a -> b) -> a -> b
$
      (Node -> Node)
-> (Node -> Parser Int)
-> (Int -> Int)
-> (Int -> IntSet -> (Bool, IntSet))
-> IntSet
-> ([Char] -> [Char])
-> ([Char] -> [Char])
-> [Node]
-> Parser IntSet
forall a x s c.
Ord c =>
(a -> Node)
-> (a -> Parser x)
-> (x -> c)
-> (x -> s -> (Bool, s))
-> s
-> ([Char] -> [Char])
-> ([Char] -> [Char])
-> [a]
-> Parser s
insertUnique
        Node -> Node
forall a. a -> a
id
        ((Node -> Parser Int) -> Node -> Parser Int
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser Int
forall a. FromYaml a => Node -> Parser a
parseYaml)
        Int -> Int
forall a. a -> a
id
        ((Bool -> (Bool, Bool)) -> Int -> IntSet -> (Bool, IntSet)
forall (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Int -> IntSet -> f IntSet
IS.alterF (,Bool
True))
        IntSet
IS.empty
        ([Char]
"duplicate element" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
        ([Char]
"the first element" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)

-- | A map from the entries of a mapping, with the alter function and the empty
-- map of its type. Two keys that convert to the same key are an error.
uniqueEntries
  :: (Ord k, FromYaml k, FromYaml v)
  => ((Maybe v -> (Bool, Maybe v)) -> k -> m -> (Bool, m)) -> m -> S.Node -> Parser m
uniqueEntries :: forall k v m.
(Ord k, FromYaml k, FromYaml v) =>
((Maybe v -> (Bool, Maybe v)) -> k -> m -> (Bool, m))
-> m -> Node -> Parser m
uniqueEntries (Maybe v -> (Bool, Maybe v)) -> k -> m -> (Bool, m)
alter m
none = (Node -> Parser m) -> Node -> Parser m
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode ((Node -> Parser m) -> Node -> Parser m)
-> (Node -> Parser m) -> Node -> Parser m
forall a b. (a -> b) -> a -> b
$ \Node
n -> case Node
n.content of
  -- The index of 'withMapping' would be of no use here.
  S.MappingContent CollectionStyle
_ [(Node, Node)]
kvs ->
    ((Node, Node) -> Node)
-> ((Node, Node) -> Parser (k, v))
-> ((k, v) -> k)
-> ((k, v) -> m -> (Bool, m))
-> m
-> ([Char] -> [Char])
-> ([Char] -> [Char])
-> [(Node, Node)]
-> Parser m
forall a x s c.
Ord c =>
(a -> Node)
-> (a -> Parser x)
-> (x -> c)
-> (x -> s -> (Bool, s))
-> s
-> ([Char] -> [Char])
-> ([Char] -> [Char])
-> [a]
-> Parser s
insertUnique
      (Node, Node) -> Node
forall a b. (a, b) -> a
fst
      (Node, Node) -> Parser (k, v)
forall k v.
(FromYaml k, FromYaml v) =>
(Node, Node) -> Parser (k, v)
entry
      (k, v) -> k
forall a b. (a, b) -> a
fst
      (\(k
k, v
v) -> (Maybe v -> (Bool, Maybe v)) -> k -> m -> (Bool, m)
alter (\Maybe v
old -> (Maybe v -> Bool
forall a. Maybe a -> Bool
isJust Maybe v
old, Maybe v
old Maybe v -> Maybe v -> Maybe v
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> v -> Maybe v
forall a. a -> Maybe a
Just v
v)) k
k)
      m
none
      (\[Char]
t -> [Char]
"duplicate key" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" after conversion")
      ([Char]
"the first key" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++)
      [(Node, Node)]
kvs
  Content
_ -> [Char] -> Node -> Parser m
forall a. [Char] -> Node -> Parser a
typeMismatch [Char]
"a mapping" Node
n
  where
    entry :: (FromYaml k, FromYaml v) => (S.Node, S.Node) -> Parser (k, v)
    entry :: forall k v.
(FromYaml k, FromYaml v) =>
(Node, Node) -> Parser (k, v)
entry (Node
k, Node
v) = (,) (k -> v -> (k, v)) -> Parser k -> Parser (v -> (k, v))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node -> Parser k) -> Node -> Parser k
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser k
forall a. FromYaml a => Node -> Parser a
parseYaml Node
k Parser (v -> (k, v)) -> Parser v -> Parser (k, v)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Node, Node) -> Parser v
forall a. FromYaml a => (Node, Node) -> Parser a
parseEntry (Node
k, Node
v)

-- | Decode the items and insert them in their order, with the errors of all
-- items. Each item that is already there is an error at its node, with the
-- note at the first equal item. The message and the note get the text of
-- their scalar after a space, or nothing for a collection. The insert tells
-- if the item was there, and the key tells which items are equal.
insertUnique
  :: forall a x s c
   . Ord c
  => (a -> S.Node)
  -> (a -> Parser x)
  -> (x -> c)
  -> (x -> s -> (Bool, s))
  -> s
  -> (String -> String)
  -> (String -> String)
  -> [a]
  -> Parser s
insertUnique :: forall a x s c.
Ord c =>
(a -> Node)
-> (a -> Parser x)
-> (x -> c)
-> (x -> s -> (Bool, s))
-> s
-> ([Char] -> [Char])
-> ([Char] -> [Char])
-> [a]
-> Parser s
insertUnique a -> Node
node a -> Parser x
item x -> c
key x -> s -> (Bool, s)
insert s
start [Char] -> [Char]
msg [Char] -> [Char]
note [a]
xs =
  (Offset -> Result s) -> Parser s
forall a. (Offset -> Result a) -> Parser a
Parser ((Offset -> Result s) -> Parser s)
-> (Offset -> Result s) -> Parser s
forall a b. (a -> b) -> a -> b
$ \Offset
off -> Offset
-> s -> Errors -> [(c, Node)] -> [Int] -> Int -> [a] -> Result s
go Offset
off s
start Errors
NoErrors [] [] Int
0 [a]
xs
  where
    -- The duplicates and the positions of the failed items are in reverse.
    -- The items in a copy of an alias share one offset, so an offset cannot
    -- tell the failed items apart.
    go :: S.Offset -> s -> Errors -> [(c, S.Node)] -> [Int] -> Int -> [a] -> Result s
    go :: Offset
-> s -> Errors -> [(c, Node)] -> [Int] -> Int -> [a] -> Result s
go Offset
off !s
acc Errors
errs [(c, Node)]
dups [Int]
fails !Int
i = \case
      [] -> case (Errors
errs, [(c, Node)]
dups) of
        (Errors
NoErrors, []) -> Errors -> s -> Result s
forall a. Errors -> a -> Result a
Result Errors
NoErrors s
acc
        (Errors, [(c, Node)])
_ ->
          Errors -> s -> Result s
forall a. Errors -> a -> Result a
Result
            ((Errors -> Errors -> Errors) -> Errors -> [Errors] -> Errors
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
L.foldl' Errors -> Errors -> Errors
bothErrors Errors
errs (((c, Node) -> Errors) -> [(c, Node)] -> [Errors]
forall a b. (a -> b) -> [a] -> [b]
map (Map c Node -> (c, Node) -> Errors
duplicateError (Offset -> [Int] -> Map c Node
firsts Offset
off [Int]
fails)) [(c, Node)]
dups))
            s
forall a. a
failed
      a
a : [a]
rest ->
        let Parser Offset -> Result x
p = a -> Parser x
item a
a
        in case Offset -> Result x
p Offset
off of
             Result Errors
NoErrors x
x -> case x -> s -> (Bool, s)
insert x
x s
acc of
               (Bool
False, s
acc') -> Offset
-> s -> Errors -> [(c, Node)] -> [Int] -> Int -> [a] -> Result s
go Offset
off s
acc' Errors
errs [(c, Node)]
dups [Int]
fails (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
rest
               (Bool
True, s
acc') -> Offset
-> s -> Errors -> [(c, Node)] -> [Int] -> Int -> [a] -> Result s
go Offset
off s
acc' Errors
errs ((x -> c
key x
x, a -> Node
node a
a) (c, Node) -> [(c, Node)] -> [(c, Node)]
forall a. a -> [a] -> [a]
: [(c, Node)]
dups) [Int]
fails (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
rest
             Result Errors
e x
_ ->
               Offset
-> s -> Errors -> [(c, Node)] -> [Int] -> Int -> [a] -> Result s
go Offset
off s
acc (Errors -> Errors -> Errors
bothErrors Errors
errs Errors
e) [(c, Node)]
dups (Int
i Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
fails) (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [a]
rest

    duplicateError :: M.Map c S.Node -> (c, S.Node) -> Errors
    duplicateError :: Map c Node -> (c, Node) -> Errors
duplicateError Map c Node
fs (c
c, Node
n) =
      Offset -> [Char] -> [(Offset, [Char])] -> Errors
OneError
        Node
n.offset
        ([Char] -> [Char]
msg (Node -> [Char]
text Node
n))
        [(Node
first.offset, [Char] -> [Char]
note (Node -> [Char]
text Node
first)) | Just Node
first <- [c -> Map c Node -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup c
c Map c Node
fs]]

    text :: S.Node -> String
    text :: Node -> [Char]
text = [Char] -> ([Char] -> [Char]) -> Maybe [Char] -> [Char]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Char]
"" (Char
' ' Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:) (Maybe [Char] -> [Char])
-> (Node -> Maybe [Char]) -> Node -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Maybe [Char]
inputText

    -- A second pass finds the first items, only if there are duplicates. It
    -- skips the failed items, because an item with a duplicate inside would
    -- decode its own items twice again, which doubles the time with each
    -- level of nesting.
    firsts :: S.Offset -> [Int] -> M.Map c S.Node
    firsts :: Offset -> [Int] -> Map c Node
firsts Offset
off [Int]
fails =
      (Node -> Node -> Node) -> [(c, Node)] -> Map c Node
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith
        (\Node
_ Node
old -> Node
old)
        [ (x -> c
key x
x, a -> Node
node a
a)
        | (Int
i, a
a) <- [Int] -> [a] -> [(Int, a)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [a]
xs
        , Bool -> Bool
not (Int
i Int -> IntSet -> Bool
`IS.member` IntSet
failedSet)
        , let Parser Offset -> Result x
p = a -> Parser x
item a
a
        , Result Errors
NoErrors x
x <- [Offset -> Result x
p Offset
off]
        ]
      where
        failedSet :: IS.IntSet
        failedSet :: IntSet
failedSet = [Int] -> IntSet
IS.fromList [Int]
fails

instance FromYaml a => FromYaml (Seq.Seq a) where
  parseYaml :: Node -> Parser (Seq a)
parseYaml = ([Node] -> Parser (Seq a)) -> Node -> Parser (Seq a)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([a] -> Seq a) -> Parser [a] -> Parser (Seq a)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [a] -> Seq a
forall a. [a] -> Seq a
Seq.fromList (Parser [a] -> Parser (Seq a))
-> ([Node] -> Parser [a]) -> [Node] -> Parser (Seq a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node -> Parser a) -> [Node] -> Parser [a]
forall a. (Node -> Parser a) -> [Node] -> Parser [a]
parseItems Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml)

-- | A list of the label and the subtrees, e.g. @[a, [[b, []]]]@.
instance FromYaml a => FromYaml (Tree.Tree a) where
  parseYaml :: Node -> Parser (Tree a)
parseYaml = ((a, [Tree a]) -> Tree a)
-> Parser (a, [Tree a]) -> Parser (Tree a)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> [Tree a] -> Tree a) -> (a, [Tree a]) -> Tree a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> [Tree a] -> Tree a
forall a. a -> [Tree a] -> Tree a
Tree.Node) (Parser (a, [Tree a]) -> Parser (Tree a))
-> (Node -> Parser (a, [Tree a])) -> Node -> Parser (Tree a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node -> Parser (a, [Tree a])
forall a. FromYaml a => Node -> Parser a
parseYaml

-- | @LT@, @EQ@ or @GT@.
instance FromYaml Ordering where
  parseYaml :: Node -> Parser Ordering
parseYaml = (Text -> Parser Ordering) -> Node -> Parser Ordering
forall a. (Text -> Parser a) -> Node -> Parser a
withText ((Text -> Parser Ordering) -> Node -> Parser Ordering)
-> (Text -> Parser Ordering) -> Node -> Parser Ordering
forall a b. (a -> b) -> a -> b
$ \case
    Text
"LT" -> Ordering -> Parser Ordering
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ordering
LT
    Text
"EQ" -> Ordering -> Parser Ordering
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ordering
EQ
    Text
"GT" -> Ordering -> Parser Ordering
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Ordering
GT
    Text
_ -> [Char] -> Parser Ordering
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expected LT, EQ or GT"

instance FromYaml Void where
  parseYaml :: Node -> Parser Void
parseYaml Node
_ = [Char] -> Parser Void
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"the type Void has no values"

-- | A mapping with the keys @numerator@ and @denominator@, e.g.
-- @{numerator: 1, denominator: 3}@.
instance (Integral a, FromYaml a) => FromYaml (Ratio a) where
  parseYaml :: Node -> Parser (Ratio a)
parseYaml = (Object -> Parser (Ratio a)) -> Node -> Parser (Ratio a)
forall a. (Object -> Parser a) -> Node -> Parser a
withMapping ((Object -> Parser (Ratio a)) -> Node -> Parser (Ratio a))
-> (Object -> Parser (Ratio a)) -> Node -> Parser (Ratio a)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    (n, d) <-
      [Text] -> Object -> Parser ()
rejectUnknownKeys [Text
"numerator", Text
"denominator"] Object
o
        Parser () -> Parser (a, a) -> Parser (a, a)
forall a b. Parser a -> Parser b -> Parser b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ( (,)
               (a -> a -> (a, a)) -> Parser a -> Parser (a -> (a, a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromYaml a => Object -> Text -> Parser a
parseField @a Object
o Text
"numerator"
               Parser (a -> (a, a)) -> Parser a -> Parser (a, a)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Node -> Parser a) -> Object -> Text -> Parser a
forall a. (Node -> Parser a) -> Object -> Text -> Parser a
parseFieldWith Node -> Parser a
nonZero Object
o Text
"denominator"
           )
    -- The reduction happens in Integer, where the gcd is fast. For another
    -- type, the gcd takes quadratic time in the number of digits, and in a
    -- bounded type, a negation can overflow, e.g. of minBound.
    let r = a -> Integer
forall a. Integral a => a -> Integer
toInteger a
n Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% a -> Integer
forall a. Integral a => a -> Integer
toInteger a
d
        fits :: Integer -> Bool
        fits Integer
x = a -> Integer
forall a. Integral a => a -> Integer
toInteger (forall a. Num a => Integer -> a
fromInteger @a Integer
x) Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
x
    if fits (numerator r) && fits (denominator r)
      then pure (fromInteger (numerator r) :% fromInteger (denominator r))
      else fail "the fraction is out of the range of the type"
    where
      nonZero :: S.Node -> Parser a
      nonZero :: Node -> Parser a
nonZero Node
n = do
        d <- Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml Node
n
        d <$ when (d == 0) (fail "the denominator is 0")

-- | A number that is a multiple of the step of the type, e.g. @1.25@ for
-- 'Centi'. A number with more digits after the point is an error, not a
-- rounded value.
--
-- If the resolution is not a product of 2s and 5s, e.g. 3, most multiples of
-- the step have no decimal form, so they cannot come from YAML. For such a
-- resolution, use 'Rational' instead.
instance HasResolution a => FromYaml (Fixed a) where
  parseYaml :: Node -> Parser (Fixed a)
parseYaml = (Scientific -> Parser (Fixed a)) -> Node -> Parser (Fixed a)
forall a. (Scientific -> Parser a) -> Node -> Parser a
withScientific ((Scientific -> Parser (Fixed a)) -> Node -> Parser (Fixed a))
-> (Scientific -> Parser (Fixed a)) -> Node -> Parser (Fixed a)
forall a b. (a -> b) -> a -> b
$ \Scientific
s ->
    let scaled :: Scientific
scaled = Scientific
s Scientific -> Scientific -> Scientific
forall a. Num a => a -> a -> a
* Integer -> Scientific
forall a. Num a => Integer -> a
fromInteger Integer
res
    in if Scientific -> Bool
Sci.isInteger Scientific
scaled
         then Fixed a -> Parser (Fixed a)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Fixed a
forall k (a :: k). Integer -> Fixed a
MkFixed (Scientific -> Integer
forall b. Integral b => Scientific -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate Scientific
scaled))
         else [Char] -> Parser (Fixed a)
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser (Fixed a)) -> [Char] -> Parser (Fixed a)
forall a b. (a -> b) -> a -> b
$ [Char]
"expected a multiple of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
step
    where
      res :: Integer
      res :: Integer
res = Proxy a -> Integer
forall k (a :: k) (p :: k -> *). HasResolution a => p a -> Integer
forall (p :: k -> *). p a -> Integer
resolution (forall (t :: k). Proxy t
forall {k} (t :: k). Proxy t
Proxy @a)

      -- 'show' rounds the step to the number of digits of the resolution, e.g.
      -- 0.03 for 1/40 and 0.4 for 1/3.
      step :: String
      step :: [Char]
step = case Integer -> Maybe Int
decimalPlaces Integer
res of
        Just Int
places ->
          FPFormat -> Maybe Int -> Scientific -> [Char]
Sci.formatScientific
            FPFormat
Sci.Fixed
            (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
places)
            (Integer -> Int -> Scientific
Sci.scientific (Integer
10 Integer -> Int -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^ Int
places Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`div` Integer
res) (Int -> Int
forall a. Num a => a -> a
negate Int
places))
        Maybe Int
Nothing -> [Char]
"1/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
res

-- | The value inside.
deriving newtype instance FromYaml a => FromYaml (Identity a)

-- | The value inside.
deriving newtype instance FromYaml a => FromYaml (Const a b)

-- | The value inside.
deriving newtype instance FromYaml a => FromYaml (Down a)

-- | The value inside.
deriving newtype instance FromYaml a => FromYaml (Sem.Min a)

-- | The value inside.
deriving newtype instance FromYaml a => FromYaml (Sem.Max a)

-- | The value inside.
deriving newtype instance FromYaml a => FromYaml (Sem.First a)

-- | The value inside.
deriving newtype instance FromYaml a => FromYaml (Sem.Last a)

-- | The value inside, or null for 'Nothing'.
deriving newtype instance FromYaml a => FromYaml (Mon.First a)

-- | The value inside, or null for 'Nothing'.
deriving newtype instance FromYaml a => FromYaml (Mon.Last a)

-- | The value inside.
deriving newtype instance FromYaml a => FromYaml (Sem.Dual a)

-- | The value inside.
deriving newtype instance FromYaml a => FromYaml (Sem.Sum a)

-- | The value inside.
deriving newtype instance FromYaml a => FromYaml (Sem.Product a)

-- | The value inside.
deriving newtype instance FromYaml Sem.All

-- | The value inside.
deriving newtype instance FromYaml Sem.Any

-- | A mapping with one key, @Left@ or @Right@, e.g. @{Left: 1}@.
--
-- >>> decodeText @(Either Int T.Text) "Left: 1\n"
-- Right (Left 1)
instance (FromYaml a, FromYaml b) => FromYaml (Either a b) where
  parseYaml :: Node -> Parser (Either a b)
parseYaml = (Object -> Parser (Either a b)) -> Node -> Parser (Either a b)
forall a. (Object -> Parser a) -> Node -> Parser a
withMapping ((Object -> Parser (Either a b)) -> Node -> Parser (Either a b))
-> (Object -> Parser (Either a b)) -> Node -> Parser (Either a b)
forall a b. (a -> b) -> a -> b
$ \Object
o -> case Object -> [(Node, Node)]
objectEntries Object
o of
    [(Node
k, Node
v)] -> case Node -> Maybe Text
stringValue Node
k of
      Just Text
"Left" -> a -> Either a b
forall a b. a -> Either a b
Left (a -> Either a b) -> Parser a -> Parser (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node, Node) -> Parser a
forall a. FromYaml a => (Node, Node) -> Parser a
parseEntry (Node
k, Node
v)
      Just Text
"Right" -> b -> Either a b
forall a b. b -> Either a b
Right (b -> Either a b) -> Parser b -> Parser (Either a b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Node, Node) -> Parser b
forall a. FromYaml a => (Node, Node) -> Parser a
parseEntry (Node
k, Node
v)
      Maybe Text
_ -> Node -> [Char] -> Parser (Either a b)
forall a. Node -> [Char] -> Parser a
failAt Node
k [Char]
"expected the key Left or Right"
    [(Node, Node)]
_ -> [Char] -> Parser (Either a b)
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expected a mapping with one key, Left or Right"

instance (FromYaml a1, FromYaml a2) => FromYaml (a1, a2) where
  parseYaml :: Node -> Parser (a1, a2)
parseYaml = ([Node] -> Parser (a1, a2)) -> Node -> Parser (a1, a2)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser (a1, a2)) -> Node -> Parser (a1, a2))
-> ([Node] -> Parser (a1, a2)) -> Node -> Parser (a1, a2)
forall a b. (a -> b) -> a -> b
$ \case
    [Node
a1, Node
a2] -> (,) (a1 -> a2 -> (a1, a2)) -> Parser a1 -> Parser (a2 -> (a1, a2))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser a1
forall a. FromYaml a => Node -> Parser a
element Node
a1 Parser (a2 -> (a1, a2)) -> Parser a2 -> Parser (a1, a2)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a2
forall a. FromYaml a => Node -> Parser a
element Node
a2
    [Node]
xs -> Int -> [Node] -> Parser (a1, a2)
forall a. Int -> [Node] -> Parser a
tupleSize Int
2 [Node]
xs

instance (FromYaml a1, FromYaml a2, FromYaml a3) => FromYaml (a1, a2, a3) where
  parseYaml :: Node -> Parser (a1, a2, a3)
parseYaml = ([Node] -> Parser (a1, a2, a3)) -> Node -> Parser (a1, a2, a3)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser (a1, a2, a3)) -> Node -> Parser (a1, a2, a3))
-> ([Node] -> Parser (a1, a2, a3)) -> Node -> Parser (a1, a2, a3)
forall a b. (a -> b) -> a -> b
$ \case
    [Node
a1, Node
a2, Node
a3] -> (,,) (a1 -> a2 -> a3 -> (a1, a2, a3))
-> Parser a1 -> Parser (a2 -> a3 -> (a1, a2, a3))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser a1
forall a. FromYaml a => Node -> Parser a
element Node
a1 Parser (a2 -> a3 -> (a1, a2, a3))
-> Parser a2 -> Parser (a3 -> (a1, a2, a3))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a2
forall a. FromYaml a => Node -> Parser a
element Node
a2 Parser (a3 -> (a1, a2, a3)) -> Parser a3 -> Parser (a1, a2, a3)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a3
forall a. FromYaml a => Node -> Parser a
element Node
a3
    [Node]
xs -> Int -> [Node] -> Parser (a1, a2, a3)
forall a. Int -> [Node] -> Parser a
tupleSize Int
3 [Node]
xs

instance
  (FromYaml a1, FromYaml a2, FromYaml a3, FromYaml a4)
  => FromYaml (a1, a2, a3, a4)
  where
  parseYaml :: Node -> Parser (a1, a2, a3, a4)
parseYaml = ([Node] -> Parser (a1, a2, a3, a4))
-> Node -> Parser (a1, a2, a3, a4)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser (a1, a2, a3, a4))
 -> Node -> Parser (a1, a2, a3, a4))
-> ([Node] -> Parser (a1, a2, a3, a4))
-> Node
-> Parser (a1, a2, a3, a4)
forall a b. (a -> b) -> a -> b
$ \case
    [Node
a1, Node
a2, Node
a3, Node
a4] -> (,,,) (a1 -> a2 -> a3 -> a4 -> (a1, a2, a3, a4))
-> Parser a1 -> Parser (a2 -> a3 -> a4 -> (a1, a2, a3, a4))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser a1
forall a. FromYaml a => Node -> Parser a
element Node
a1 Parser (a2 -> a3 -> a4 -> (a1, a2, a3, a4))
-> Parser a2 -> Parser (a3 -> a4 -> (a1, a2, a3, a4))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a2
forall a. FromYaml a => Node -> Parser a
element Node
a2 Parser (a3 -> a4 -> (a1, a2, a3, a4))
-> Parser a3 -> Parser (a4 -> (a1, a2, a3, a4))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a3
forall a. FromYaml a => Node -> Parser a
element Node
a3 Parser (a4 -> (a1, a2, a3, a4))
-> Parser a4 -> Parser (a1, a2, a3, a4)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a4
forall a. FromYaml a => Node -> Parser a
element Node
a4
    [Node]
xs -> Int -> [Node] -> Parser (a1, a2, a3, a4)
forall a. Int -> [Node] -> Parser a
tupleSize Int
4 [Node]
xs

instance
  (FromYaml a1, FromYaml a2, FromYaml a3, FromYaml a4, FromYaml a5)
  => FromYaml (a1, a2, a3, a4, a5)
  where
  parseYaml :: Node -> Parser (a1, a2, a3, a4, a5)
parseYaml = ([Node] -> Parser (a1, a2, a3, a4, a5))
-> Node -> Parser (a1, a2, a3, a4, a5)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser (a1, a2, a3, a4, a5))
 -> Node -> Parser (a1, a2, a3, a4, a5))
-> ([Node] -> Parser (a1, a2, a3, a4, a5))
-> Node
-> Parser (a1, a2, a3, a4, a5)
forall a b. (a -> b) -> a -> b
$ \case
    [Node
a1, Node
a2, Node
a3, Node
a4, Node
a5] ->
      (,,,,) (a1 -> a2 -> a3 -> a4 -> a5 -> (a1, a2, a3, a4, a5))
-> Parser a1
-> Parser (a2 -> a3 -> a4 -> a5 -> (a1, a2, a3, a4, a5))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser a1
forall a. FromYaml a => Node -> Parser a
element Node
a1 Parser (a2 -> a3 -> a4 -> a5 -> (a1, a2, a3, a4, a5))
-> Parser a2 -> Parser (a3 -> a4 -> a5 -> (a1, a2, a3, a4, a5))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a2
forall a. FromYaml a => Node -> Parser a
element Node
a2 Parser (a3 -> a4 -> a5 -> (a1, a2, a3, a4, a5))
-> Parser a3 -> Parser (a4 -> a5 -> (a1, a2, a3, a4, a5))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a3
forall a. FromYaml a => Node -> Parser a
element Node
a3 Parser (a4 -> a5 -> (a1, a2, a3, a4, a5))
-> Parser a4 -> Parser (a5 -> (a1, a2, a3, a4, a5))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a4
forall a. FromYaml a => Node -> Parser a
element Node
a4 Parser (a5 -> (a1, a2, a3, a4, a5))
-> Parser a5 -> Parser (a1, a2, a3, a4, a5)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a5
forall a. FromYaml a => Node -> Parser a
element Node
a5
    [Node]
xs -> Int -> [Node] -> Parser (a1, a2, a3, a4, a5)
forall a. Int -> [Node] -> Parser a
tupleSize Int
5 [Node]
xs

instance
  (FromYaml a1, FromYaml a2, FromYaml a3, FromYaml a4, FromYaml a5, FromYaml a6)
  => FromYaml (a1, a2, a3, a4, a5, a6)
  where
  parseYaml :: Node -> Parser (a1, a2, a3, a4, a5, a6)
parseYaml = ([Node] -> Parser (a1, a2, a3, a4, a5, a6))
-> Node -> Parser (a1, a2, a3, a4, a5, a6)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser (a1, a2, a3, a4, a5, a6))
 -> Node -> Parser (a1, a2, a3, a4, a5, a6))
-> ([Node] -> Parser (a1, a2, a3, a4, a5, a6))
-> Node
-> Parser (a1, a2, a3, a4, a5, a6)
forall a b. (a -> b) -> a -> b
$ \case
    [Node
a1, Node
a2, Node
a3, Node
a4, Node
a5, Node
a6] ->
      (,,,,,)
        (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> (a1, a2, a3, a4, a5, a6))
-> Parser a1
-> Parser (a2 -> a3 -> a4 -> a5 -> a6 -> (a1, a2, a3, a4, a5, a6))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser a1
forall a. FromYaml a => Node -> Parser a
element Node
a1
        Parser (a2 -> a3 -> a4 -> a5 -> a6 -> (a1, a2, a3, a4, a5, a6))
-> Parser a2
-> Parser (a3 -> a4 -> a5 -> a6 -> (a1, a2, a3, a4, a5, a6))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a2
forall a. FromYaml a => Node -> Parser a
element Node
a2
        Parser (a3 -> a4 -> a5 -> a6 -> (a1, a2, a3, a4, a5, a6))
-> Parser a3 -> Parser (a4 -> a5 -> a6 -> (a1, a2, a3, a4, a5, a6))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a3
forall a. FromYaml a => Node -> Parser a
element Node
a3
        Parser (a4 -> a5 -> a6 -> (a1, a2, a3, a4, a5, a6))
-> Parser a4 -> Parser (a5 -> a6 -> (a1, a2, a3, a4, a5, a6))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a4
forall a. FromYaml a => Node -> Parser a
element Node
a4
        Parser (a5 -> a6 -> (a1, a2, a3, a4, a5, a6))
-> Parser a5 -> Parser (a6 -> (a1, a2, a3, a4, a5, a6))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a5
forall a. FromYaml a => Node -> Parser a
element Node
a5
        Parser (a6 -> (a1, a2, a3, a4, a5, a6))
-> Parser a6 -> Parser (a1, a2, a3, a4, a5, a6)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a6
forall a. FromYaml a => Node -> Parser a
element Node
a6
    [Node]
xs -> Int -> [Node] -> Parser (a1, a2, a3, a4, a5, a6)
forall a. Int -> [Node] -> Parser a
tupleSize Int
6 [Node]
xs

instance
  ( FromYaml a1
  , FromYaml a2
  , FromYaml a3
  , FromYaml a4
  , FromYaml a5
  , FromYaml a6
  , FromYaml a7
  )
  => FromYaml (a1, a2, a3, a4, a5, a6, a7)
  where
  parseYaml :: Node -> Parser (a1, a2, a3, a4, a5, a6, a7)
parseYaml = ([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7))
-> Node -> Parser (a1, a2, a3, a4, a5, a6, a7)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7))
 -> Node -> Parser (a1, a2, a3, a4, a5, a6, a7))
-> ([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7))
-> Node
-> Parser (a1, a2, a3, a4, a5, a6, a7)
forall a b. (a -> b) -> a -> b
$ \case
    [Node
a1, Node
a2, Node
a3, Node
a4, Node
a5, Node
a6, Node
a7] ->
      (,,,,,,)
        (a1
 -> a2
 -> a3
 -> a4
 -> a5
 -> a6
 -> a7
 -> (a1, a2, a3, a4, a5, a6, a7))
-> Parser a1
-> Parser
     (a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> (a1, a2, a3, a4, a5, a6, a7))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser a1
forall a. FromYaml a => Node -> Parser a
element Node
a1
        Parser
  (a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> (a1, a2, a3, a4, a5, a6, a7))
-> Parser a2
-> Parser
     (a3 -> a4 -> a5 -> a6 -> a7 -> (a1, a2, a3, a4, a5, a6, a7))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a2
forall a. FromYaml a => Node -> Parser a
element Node
a2
        Parser (a3 -> a4 -> a5 -> a6 -> a7 -> (a1, a2, a3, a4, a5, a6, a7))
-> Parser a3
-> Parser (a4 -> a5 -> a6 -> a7 -> (a1, a2, a3, a4, a5, a6, a7))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a3
forall a. FromYaml a => Node -> Parser a
element Node
a3
        Parser (a4 -> a5 -> a6 -> a7 -> (a1, a2, a3, a4, a5, a6, a7))
-> Parser a4
-> Parser (a5 -> a6 -> a7 -> (a1, a2, a3, a4, a5, a6, a7))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a4
forall a. FromYaml a => Node -> Parser a
element Node
a4
        Parser (a5 -> a6 -> a7 -> (a1, a2, a3, a4, a5, a6, a7))
-> Parser a5 -> Parser (a6 -> a7 -> (a1, a2, a3, a4, a5, a6, a7))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a5
forall a. FromYaml a => Node -> Parser a
element Node
a5
        Parser (a6 -> a7 -> (a1, a2, a3, a4, a5, a6, a7))
-> Parser a6 -> Parser (a7 -> (a1, a2, a3, a4, a5, a6, a7))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a6
forall a. FromYaml a => Node -> Parser a
element Node
a6
        Parser (a7 -> (a1, a2, a3, a4, a5, a6, a7))
-> Parser a7 -> Parser (a1, a2, a3, a4, a5, a6, a7)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a7
forall a. FromYaml a => Node -> Parser a
element Node
a7
    [Node]
xs -> Int -> [Node] -> Parser (a1, a2, a3, a4, a5, a6, a7)
forall a. Int -> [Node] -> Parser a
tupleSize Int
7 [Node]
xs

instance
  ( FromYaml a1
  , FromYaml a2
  , FromYaml a3
  , FromYaml a4
  , FromYaml a5
  , FromYaml a6
  , FromYaml a7
  , FromYaml a8
  )
  => FromYaml (a1, a2, a3, a4, a5, a6, a7, a8)
  where
  parseYaml :: Node -> Parser (a1, a2, a3, a4, a5, a6, a7, a8)
parseYaml = ([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8))
-> Node -> Parser (a1, a2, a3, a4, a5, a6, a7, a8)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8))
 -> Node -> Parser (a1, a2, a3, a4, a5, a6, a7, a8))
-> ([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8))
-> Node
-> Parser (a1, a2, a3, a4, a5, a6, a7, a8)
forall a b. (a -> b) -> a -> b
$ \case
    [Node
a1, Node
a2, Node
a3, Node
a4, Node
a5, Node
a6, Node
a7, Node
a8] ->
      (,,,,,,,)
        (a1
 -> a2
 -> a3
 -> a4
 -> a5
 -> a6
 -> a7
 -> a8
 -> (a1, a2, a3, a4, a5, a6, a7, a8))
-> Parser a1
-> Parser
     (a2
      -> a3
      -> a4
      -> a5
      -> a6
      -> a7
      -> a8
      -> (a1, a2, a3, a4, a5, a6, a7, a8))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser a1
forall a. FromYaml a => Node -> Parser a
element Node
a1
        Parser
  (a2
   -> a3
   -> a4
   -> a5
   -> a6
   -> a7
   -> a8
   -> (a1, a2, a3, a4, a5, a6, a7, a8))
-> Parser a2
-> Parser
     (a3
      -> a4 -> a5 -> a6 -> a7 -> a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a2
forall a. FromYaml a => Node -> Parser a
element Node
a2
        Parser
  (a3
   -> a4 -> a5 -> a6 -> a7 -> a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
-> Parser a3
-> Parser
     (a4 -> a5 -> a6 -> a7 -> a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a3
forall a. FromYaml a => Node -> Parser a
element Node
a3
        Parser
  (a4 -> a5 -> a6 -> a7 -> a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
-> Parser a4
-> Parser
     (a5 -> a6 -> a7 -> a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a4
forall a. FromYaml a => Node -> Parser a
element Node
a4
        Parser (a5 -> a6 -> a7 -> a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
-> Parser a5
-> Parser (a6 -> a7 -> a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a5
forall a. FromYaml a => Node -> Parser a
element Node
a5
        Parser (a6 -> a7 -> a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
-> Parser a6
-> Parser (a7 -> a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a6
forall a. FromYaml a => Node -> Parser a
element Node
a6
        Parser (a7 -> a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
-> Parser a7 -> Parser (a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a7
forall a. FromYaml a => Node -> Parser a
element Node
a7
        Parser (a8 -> (a1, a2, a3, a4, a5, a6, a7, a8))
-> Parser a8 -> Parser (a1, a2, a3, a4, a5, a6, a7, a8)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a8
forall a. FromYaml a => Node -> Parser a
element Node
a8
    [Node]
xs -> Int -> [Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8)
forall a. Int -> [Node] -> Parser a
tupleSize Int
8 [Node]
xs

instance
  ( FromYaml a1
  , FromYaml a2
  , FromYaml a3
  , FromYaml a4
  , FromYaml a5
  , FromYaml a6
  , FromYaml a7
  , FromYaml a8
  , FromYaml a9
  )
  => FromYaml (a1, a2, a3, a4, a5, a6, a7, a8, a9)
  where
  parseYaml :: Node -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9)
parseYaml = ([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> Node -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9))
 -> Node -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> ([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> Node
-> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9)
forall a b. (a -> b) -> a -> b
$ \case
    [Node
a1, Node
a2, Node
a3, Node
a4, Node
a5, Node
a6, Node
a7, Node
a8, Node
a9] ->
      (,,,,,,,,)
        (a1
 -> a2
 -> a3
 -> a4
 -> a5
 -> a6
 -> a7
 -> a8
 -> a9
 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> Parser a1
-> Parser
     (a2
      -> a3
      -> a4
      -> a5
      -> a6
      -> a7
      -> a8
      -> a9
      -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser a1
forall a. FromYaml a => Node -> Parser a
element Node
a1
        Parser
  (a2
   -> a3
   -> a4
   -> a5
   -> a6
   -> a7
   -> a8
   -> a9
   -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> Parser a2
-> Parser
     (a3
      -> a4
      -> a5
      -> a6
      -> a7
      -> a8
      -> a9
      -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a2
forall a. FromYaml a => Node -> Parser a
element Node
a2
        Parser
  (a3
   -> a4
   -> a5
   -> a6
   -> a7
   -> a8
   -> a9
   -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> Parser a3
-> Parser
     (a4
      -> a5
      -> a6
      -> a7
      -> a8
      -> a9
      -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a3
forall a. FromYaml a => Node -> Parser a
element Node
a3
        Parser
  (a4
   -> a5
   -> a6
   -> a7
   -> a8
   -> a9
   -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> Parser a4
-> Parser
     (a5
      -> a6 -> a7 -> a8 -> a9 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a4
forall a. FromYaml a => Node -> Parser a
element Node
a4
        Parser
  (a5
   -> a6 -> a7 -> a8 -> a9 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> Parser a5
-> Parser
     (a6 -> a7 -> a8 -> a9 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a5
forall a. FromYaml a => Node -> Parser a
element Node
a5
        Parser
  (a6 -> a7 -> a8 -> a9 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> Parser a6
-> Parser (a7 -> a8 -> a9 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a6
forall a. FromYaml a => Node -> Parser a
element Node
a6
        Parser (a7 -> a8 -> a9 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> Parser a7
-> Parser (a8 -> a9 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a7
forall a. FromYaml a => Node -> Parser a
element Node
a7
        Parser (a8 -> a9 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> Parser a8 -> Parser (a9 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a8
forall a. FromYaml a => Node -> Parser a
element Node
a8
        Parser (a9 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9))
-> Parser a9 -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a9
forall a. FromYaml a => Node -> Parser a
element Node
a9
    [Node]
xs -> Int -> [Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9)
forall a. Int -> [Node] -> Parser a
tupleSize Int
9 [Node]
xs

instance
  ( FromYaml a1
  , FromYaml a2
  , FromYaml a3
  , FromYaml a4
  , FromYaml a5
  , FromYaml a6
  , FromYaml a7
  , FromYaml a8
  , FromYaml a9
  , FromYaml a10
  )
  => FromYaml (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
  where
  parseYaml :: Node -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
parseYaml = ([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Node -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
forall a. ([Node] -> Parser a) -> Node -> Parser a
withSequence (([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
 -> Node -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> ([Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Node
-> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
forall a b. (a -> b) -> a -> b
$ \case
    [Node
a1, Node
a2, Node
a3, Node
a4, Node
a5, Node
a6, Node
a7, Node
a8, Node
a9, Node
a10] ->
      (,,,,,,,,,)
        (a1
 -> a2
 -> a3
 -> a4
 -> a5
 -> a6
 -> a7
 -> a8
 -> a9
 -> a10
 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Parser a1
-> Parser
     (a2
      -> a3
      -> a4
      -> a5
      -> a6
      -> a7
      -> a8
      -> a9
      -> a10
      -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Parser a1
forall a. FromYaml a => Node -> Parser a
element Node
a1
        Parser
  (a2
   -> a3
   -> a4
   -> a5
   -> a6
   -> a7
   -> a8
   -> a9
   -> a10
   -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Parser a2
-> Parser
     (a3
      -> a4
      -> a5
      -> a6
      -> a7
      -> a8
      -> a9
      -> a10
      -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a2
forall a. FromYaml a => Node -> Parser a
element Node
a2
        Parser
  (a3
   -> a4
   -> a5
   -> a6
   -> a7
   -> a8
   -> a9
   -> a10
   -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Parser a3
-> Parser
     (a4
      -> a5
      -> a6
      -> a7
      -> a8
      -> a9
      -> a10
      -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a3
forall a. FromYaml a => Node -> Parser a
element Node
a3
        Parser
  (a4
   -> a5
   -> a6
   -> a7
   -> a8
   -> a9
   -> a10
   -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Parser a4
-> Parser
     (a5
      -> a6
      -> a7
      -> a8
      -> a9
      -> a10
      -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a4
forall a. FromYaml a => Node -> Parser a
element Node
a4
        Parser
  (a5
   -> a6
   -> a7
   -> a8
   -> a9
   -> a10
   -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Parser a5
-> Parser
     (a6
      -> a7
      -> a8
      -> a9
      -> a10
      -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a5
forall a. FromYaml a => Node -> Parser a
element Node
a5
        Parser
  (a6
   -> a7
   -> a8
   -> a9
   -> a10
   -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Parser a6
-> Parser
     (a7
      -> a8 -> a9 -> a10 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a6
forall a. FromYaml a => Node -> Parser a
element Node
a6
        Parser
  (a7
   -> a8 -> a9 -> a10 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Parser a7
-> Parser
     (a8 -> a9 -> a10 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a7
forall a. FromYaml a => Node -> Parser a
element Node
a7
        Parser
  (a8 -> a9 -> a10 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Parser a8
-> Parser (a9 -> a10 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a8
forall a. FromYaml a => Node -> Parser a
element Node
a8
        Parser (a9 -> a10 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Parser a9
-> Parser (a10 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a9
forall a. FromYaml a => Node -> Parser a
element Node
a9
        Parser (a10 -> (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10))
-> Parser a10 -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Parser a10
forall a. FromYaml a => Node -> Parser a
element Node
a10
    [Node]
xs -> Int -> [Node] -> Parser (a1, a2, a3, a4, a5, a6, a7, a8, a9, a10)
forall a. Int -> [Node] -> Parser a
tupleSize Int
10 [Node]
xs

-- | An element of a tuple.
element :: FromYaml a => S.Node -> Parser a
element :: forall a. FromYaml a => Node -> Parser a
element = (Node -> Parser a) -> Node -> Parser a
forall a. (Node -> Parser a) -> Node -> Parser a
parseNode Node -> Parser a
forall a. FromYaml a => Node -> Parser a
parseYaml

-- | The error for a list with the wrong number of elements for a tuple.
tupleSize :: Int -> [S.Node] -> Parser a
tupleSize :: forall a. Int -> [Node] -> Parser a
tupleSize Int
n [Node]
xs =
  [Char] -> Parser a
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser a) -> [Char] -> Parser a
forall a b. (a -> b) -> a -> b
$ [Char]
"expected a list of " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" elements, but got " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show ([Node] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Node]
xs)

-- $setup
-- >>> import Yamlet
-- >>> printErrors = mapM_ (putStrLn . prettyError "input.yaml")