{-# OPTIONS_HADDOCK not-home #-}

-- | The checks of a syntax tree before the decoder reads it, and the values
-- of its nodes.
--
-- This module is intended for internal use only, and may change without warning
-- in subsequent releases.
module Yamlet.Internal.Compose
  ( prepareWithin
  , aliasLimit
  , representPrepared
  , Failure
  , noMergeKeys
  ) where

import Control.Monad
import Data.Foldable
import Data.IntMap.Strict qualified as IM
import Data.List qualified as L
import Data.List.NonEmpty qualified as NE
import Data.Map.Strict qualified as M
import Data.Text qualified as T

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

-- | Check that the tags of a node are valid and that the keys of every
-- mapping are unique, and replace each alias with the node that it refers
-- to. The result has no aliases. A node without aliases comes back
-- unchanged.
--
-- The arguments are the limit of the visits that the aliases can add, see
-- 'aliasLimit', and the visits that the aliases of the documents before
-- added. The result also gives the visits that the aliases added with this
-- document.
prepareWithin :: Int -> Int -> S.Node -> Either Failure (S.Node, Int)
prepareWithin :: Int -> Int -> Node -> Either Failure (Node, Int)
prepareWithin Int
limit Int
added Node
root
  | Node -> Bool
needsNumbering Node
root = (Node -> Node
expandAliases Node
root,) (Int -> (Node, Int))
-> Either Failure Int -> Either Failure (Node, Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Int -> Node -> Either Failure Int
numberWithin Int
limit Int
added Node
root
  | Bool
otherwise = (Node
root, Int
added) (Node, Int) -> Either Failure () -> Either Failure (Node, Int)
forall a b. a -> Either Failure b -> Either Failure a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Node -> Either Failure ()
check Node
root
  where
    -- The node has an alias or a collection key inside it.
    needsNumbering :: S.Node -> Bool
    needsNumbering :: Node -> Bool
needsNumbering Node
n = case Node
n.content of
      S.ScalarContent {} -> Bool
False
      S.SequenceContent CollectionStyle
_ [Node]
xs -> (Node -> Bool) -> [Node] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Node -> Bool
needsNumbering [Node]
xs
      S.MappingContent CollectionStyle
_ [(Node, Node)]
kvs ->
        ((Node, Node) -> Bool) -> [(Node, Node)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\(Node
k, Node
v) -> Node -> Bool
isCollection Node
k Bool -> Bool -> Bool
|| Node -> Bool
needsNumbering Node
k Bool -> Bool -> Bool
|| Node -> Bool
needsNumbering Node
v) [(Node, Node)]
kvs
      S.AliasContent {} -> Bool
True
      where
        isCollection :: S.Node -> Bool
        isCollection :: Node -> Bool
isCollection Node
k = case Node
k.content of
          S.SequenceContent {} -> Bool
True
          S.MappingContent {} -> Bool
True
          Content
_ -> Bool
False

-- | The limit of the visits of a traversal that the aliases of the documents
-- can add together: as many visits as the documents have, or a fixed minimum
-- for small documents. A node is one visit and each character of its scalar,
-- tag and anchor is one more, because the decoder copies the texts of each
-- alias. Without a limit, the visits of a small input can be exponential in
-- its size. The documents of a stream share the limit, so that many small
-- documents cannot add the minimum each.
aliasLimit :: [S.Node] -> Int
aliasLimit :: [Node] -> Int
aliasLimit [Node]
roots = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
minExpansion ([Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Node -> Int) -> [Node] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Int
syntaxSize [Node]
roots))

-- | The visits of a traversal of a node without aliases.
syntaxSize :: S.Node -> Int
syntaxSize :: Node -> Int
syntaxSize Node
n =
  Node -> Int
ownVisits Node
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ case Node
n.content of
    S.SequenceContent CollectionStyle
_ [Node]
xs -> [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ((Node -> Int) -> [Node] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Int
syntaxSize [Node]
xs)
    S.MappingContent CollectionStyle
_ [(Node, Node)]
kvs -> [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Node -> Int
syntaxSize Node
k Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Node -> Int
syntaxSize Node
v | (Node
k, Node
v) <- [(Node, Node)]
kvs]
    Content
_ -> Int
0

-- | The visits of a node without the nodes inside it.
ownVisits :: S.Node -> Int
ownVisits :: Node -> Int
ownVisits Node
n = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
anchorChars Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
tagChars Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
scalarChars
  where
    anchorChars :: Int
    anchorChars :: Int
anchorChars = Int -> (Text -> Int) -> Maybe Text -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 Text -> Int
T.length Node
n.props.anchor

    tagChars :: Int
    tagChars :: Int
tagChars = case Node
n.props.tag of
      S.Tag Text
t -> Text -> Int
T.length Text
t
      Tag
_ -> Int
0

    scalarChars :: Int
    scalarChars :: Int
scalarChars = case Node
n.content of
      S.ScalarContent ScalarStyle
_ Text
t -> Text -> Int
T.length Text
t
      Content
_ -> Int
0

-- | The checks of 'prepareWithin' for a node with aliases or collection keys,
-- which compare by the numbers of their values, and the visits that the
-- aliases added. The limit is evaluated only at an alias, so that the size
-- of a document without aliases is not computed.
numberWithin :: Int -> Int -> S.Node -> Either Failure Int
numberWithin :: Int -> Int -> Node -> Either Failure Int
numberWithin Int
limit Int
added Node
root = do
  (_, st) <- Numbering -> Node -> Either Failure ((Value, Int), Numbering)
go (Map Text (Maybe (Value, Int, Int))
-> Map Shape Int -> Int -> Int -> Numbering
Numbering Map Text (Maybe (Value, Int, Int))
forall k a. Map k a
M.empty Map Shape Int
forall k a. Map k a
M.empty Int
0 Int
added) Node
root
  Right st.added
  where
    -- Each value comes with its number.
    go :: Numbering -> S.Node -> Either Failure ((Value, Int), Numbering)
    go :: Numbering -> Node -> Either Failure ((Value, Int), Numbering)
go Numbering
st Node
sn =
      let off :: Offset
off = Node
sn.offset; props :: Props
props = Node
sn.props
      in case Node
sn.content of
           S.AliasContent Text
name -> case Text
-> Map Text (Maybe (Value, Int, Int))
-> Maybe (Maybe (Value, Int, Int))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name Numbering
st.anchors of
             Just (Just (Value
v, Int
i, Int
visits))
               | Numbering
st.added Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
visits Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
limit ->
                   Failure -> Either Failure ((Value, Int), Numbering)
forall a b. a -> Either a b
Left (Failure -> Either Failure ((Value, Int), Numbering))
-> ([Char] -> Failure)
-> [Char]
-> Either Failure ((Value, Int), Numbering)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Offset -> [Char] -> Failure
failure Offset
off ([Char] -> Either Failure ((Value, Int), Numbering))
-> [Char] -> Either Failure ((Value, Int), Numbering)
forall a b. (a -> b) -> a -> b
$
                     [Char]
"the aliases add more than "
                       [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
limit
                       [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" nodes and characters"
               | Bool
otherwise ->
                   ((Value, Int), Numbering)
-> Either Failure ((Value, Int), Numbering)
forall a b. b -> Either a b
Right
                     ( (Value
v, Int
i)
                     , Numbering
st {visits = st.visits + visits, added = st.added + visits}
                     )
             Just Maybe (Value, Int, Int)
Nothing ->
               Failure -> Either Failure ((Value, Int), Numbering)
forall a b. a -> Either a b
Left (Failure -> Either Failure ((Value, Int), Numbering))
-> ([Char] -> Failure)
-> [Char]
-> Either Failure ((Value, Int), Numbering)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Offset -> [Char] -> Failure
failure Offset
off ([Char] -> Either Failure ((Value, Int), Numbering))
-> [Char] -> Either Failure ((Value, Int), Numbering)
forall a b. (a -> b) -> a -> b
$
                 [Char]
"the alias *" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
name [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" refers to a node that contains it"
             Maybe (Maybe (Value, Int, Int))
Nothing ->
               Failure -> Either Failure ((Value, Int), Numbering)
forall a b. a -> Either a b
Left (Failure -> Either Failure ((Value, Int), Numbering))
-> ([Char] -> Failure)
-> [Char]
-> Either Failure ((Value, Int), Numbering)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Offset -> [Char] -> Failure
failure Offset
off ([Char] -> Either Failure ((Value, Int), Numbering))
-> [Char] -> Either Failure ((Value, Int), Numbering)
forall a b. (a -> b) -> a -> b
$ [Char]
"undefined alias *" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
name
           S.ScalarContent ScalarStyle
style Text
t -> do
             v <- Offset -> Props -> ScalarStyle -> Text -> Either Failure Value
scalar Offset
off Props
props ScalarStyle
style Text
t
             let visits = Node -> Int
ownVisits Node
sn
             Right $ number props v (ScalarShape v) visits visits (open props st)
           S.SequenceContent CollectionStyle
_ [Node]
xs -> do
             tag <- Offset -> Props -> Text -> Either Failure Text
collectionTag Offset
off Props
props Text
seqTag
             (vs, st') <- goList (open props st) xs
             let v = Text -> Value -> Value
withTag Text
tag ([Value] -> Value
Sequence (((Value, Int) -> Value) -> [(Value, Int)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Value, Int) -> Value
forall a b. (a, b) -> a
fst [(Value, Int)]
vs))
             let own = Node -> Int
ownVisits Node
sn
             Right $
               number
                 props
                 v
                 (SequenceShape tag (map snd vs))
                 own
                 (st'.visits - st.visits + own)
                 st'
           S.MappingContent CollectionStyle
_ [(Node, Node)]
kvs -> do
             tag <- Offset -> Props -> Text -> Either Failure Text
collectionTag Offset
off Props
props Text
mapTag
             (entries, st') <- goPairs (open props st) kvs
             checkUniqueNumbers entries
             let v = Text -> Value -> Value
withTag Text
tag ([(Value, Value)] -> Value
Mapping [(Value
k, Value
x) | (Node
_, (Value
k, Int
_), (Value
x, Int
_)) <- [(Node, (Value, Int), (Value, Int))]
entries])
                 shape =
                   Text -> [(Int, Int)] -> Shape
MappingShape Text
tag ([(Int, Int)] -> [(Int, Int)]
forall a. Ord a => [a] -> [a]
L.sort [(Int
i, Int
j) | (Node
_, (Value
_, Int
i), (Value
_, Int
j)) <- [(Node, (Value, Int), (Value, Int))]
entries])
                 own = Node -> Int
ownVisits Node
sn
             Right $ number props v shape own (st'.visits - st.visits + own) st'

    -- The values are in reverse until the end, so that the stack does not
    -- grow with the number of items.
    goList :: Numbering -> [S.Node] -> Either Failure ([(Value, Int)], Numbering)
    goList :: Numbering -> [Node] -> Either Failure ([(Value, Int)], Numbering)
goList = [(Value, Int)]
-> Numbering
-> [Node]
-> Either Failure ([(Value, Int)], Numbering)
loop []
      where
        loop
          :: [(Value, Int)]
          -> Numbering
          -> [S.Node]
          -> Either Failure ([(Value, Int)], Numbering)
        loop :: [(Value, Int)]
-> Numbering
-> [Node]
-> Either Failure ([(Value, Int)], Numbering)
loop [(Value, Int)]
acc Numbering
st = \case
          [] -> ([(Value, Int)], Numbering)
-> Either Failure ([(Value, Int)], Numbering)
forall a b. b -> Either a b
Right ([(Value, Int)] -> [(Value, Int)]
forall a. [a] -> [a]
reverse [(Value, Int)]
acc, Numbering
st)
          Node
x : [Node]
xs -> case Numbering -> Node -> Either Failure ((Value, Int), Numbering)
go Numbering
st Node
x of
            Left Failure
err -> Failure -> Either Failure ([(Value, Int)], Numbering)
forall a b. a -> Either a b
Left Failure
err
            Right ((Value, Int)
v, Numbering
st') -> [(Value, Int)]
-> Numbering
-> [Node]
-> Either Failure ([(Value, Int)], Numbering)
loop ((Value, Int)
v (Value, Int) -> [(Value, Int)] -> [(Value, Int)]
forall a. a -> [a] -> [a]
: [(Value, Int)]
acc) Numbering
st' [Node]
xs

    -- The entries come with the nodes of their keys, in reverse as in
    -- 'goList'.
    goPairs
      :: Numbering
      -> [(S.Node, S.Node)]
      -> Either Failure ([(S.Node, (Value, Int), (Value, Int))], Numbering)
    goPairs :: Numbering
-> [(Node, Node)]
-> Either Failure ([(Node, (Value, Int), (Value, Int))], Numbering)
goPairs = [(Node, (Value, Int), (Value, Int))]
-> Numbering
-> [(Node, Node)]
-> Either Failure ([(Node, (Value, Int), (Value, Int))], Numbering)
loop []
      where
        loop
          :: [(S.Node, (Value, Int), (Value, Int))]
          -> Numbering
          -> [(S.Node, S.Node)]
          -> Either Failure ([(S.Node, (Value, Int), (Value, Int))], Numbering)
        loop :: [(Node, (Value, Int), (Value, Int))]
-> Numbering
-> [(Node, Node)]
-> Either Failure ([(Node, (Value, Int), (Value, Int))], Numbering)
loop [(Node, (Value, Int), (Value, Int))]
acc Numbering
st = \case
          [] -> ([(Node, (Value, Int), (Value, Int))], Numbering)
-> Either Failure ([(Node, (Value, Int), (Value, Int))], Numbering)
forall a b. b -> Either a b
Right ([(Node, (Value, Int), (Value, Int))]
-> [(Node, (Value, Int), (Value, Int))]
forall a. [a] -> [a]
reverse [(Node, (Value, Int), (Value, Int))]
acc, Numbering
st)
          (Node
k, Node
v) : [(Node, Node)]
kvs -> case Numbering -> Node -> Either Failure ((Value, Int), Numbering)
go Numbering
st Node
k of
            Left Failure
err -> Failure
-> Either Failure ([(Node, (Value, Int), (Value, Int))], Numbering)
forall a b. a -> Either a b
Left Failure
err
            Right ((Value, Int)
kv, Numbering
st') -> case Numbering -> Node -> Either Failure ((Value, Int), Numbering)
go Numbering
st' Node
v of
              Left Failure
err -> Failure
-> Either Failure ([(Node, (Value, Int), (Value, Int))], Numbering)
forall a b. a -> Either a b
Left Failure
err
              Right ((Value, Int)
vv, Numbering
st'') -> [(Node, (Value, Int), (Value, Int))]
-> Numbering
-> [(Node, Node)]
-> Either Failure ([(Node, (Value, Int), (Value, Int))], Numbering)
loop ((Node
k, (Value, Int)
kv, (Value, Int)
vv) (Node, (Value, Int), (Value, Int))
-> [(Node, (Value, Int), (Value, Int))]
-> [(Node, (Value, Int), (Value, Int))]
forall a. a -> [a] -> [a]
: [(Node, (Value, Int), (Value, Int))]
acc) Numbering
st'' [(Node, Node)]
kvs

    open :: S.Props -> Numbering -> Numbering
    open :: Props -> Numbering -> Numbering
open Props
props Numbering
st = case Props
props.anchor of
      Just Text
a -> Numbering
st {anchors = M.insert a Nothing st.anchors}
      Maybe Text
Nothing -> Numbering
st

    -- Give the value the number of its shape, and define its anchor. The
    -- own visits are those of the node alone, and the visits are those of the
    -- node and of everything inside it. The copy at an alias has no anchor,
    -- so its visits leave out the anchor. A node inside with the same anchor
    -- comes later in the document, so its definition stays.
    number
      :: S.Props -> Value -> Shape -> Int -> Int -> Numbering -> ((Value, Int), Numbering)
    number :: Props
-> Value
-> Shape
-> Int
-> Int
-> Numbering
-> ((Value, Int), Numbering)
number Props
props Value
v Shape
shape Int
own Int
visits Numbering
st =
      ((Value
v, Int
i), Numbering
st {anchors = anchors', shapes = shapes', visits = st.visits + own})
      where
        i :: Int
        shapes' :: M.Map Shape Int
        (Int
i, Map Shape Int
shapes') = case Shape -> Map Shape Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Shape
shape Numbering
st.shapes of
          Just Int
j -> (Int
j, Numbering
st.shapes)
          Maybe Int
Nothing -> let j :: Int
j = Map Shape Int -> Int
forall k a. Map k a -> Int
M.size Numbering
st.shapes in (Int
j, Shape -> Int -> Map Shape Int -> Map Shape Int
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Shape
shape Int
j Numbering
st.shapes)

        anchors' :: M.Map T.Text (Maybe (Value, Int, Int))
        anchors' :: Map Text (Maybe (Value, Int, Int))
anchors' = case Props
props.anchor of
          Just Text
a
            | Just Maybe (Value, Int, Int)
Nothing <- Text
-> Map Text (Maybe (Value, Int, Int))
-> Maybe (Maybe (Value, Int, Int))
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
a Numbering
st.anchors ->
                Text
-> Maybe (Value, Int, Int)
-> Map Text (Maybe (Value, Int, Int))
-> Map Text (Maybe (Value, Int, Int))
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
a ((Value, Int, Int) -> Maybe (Value, Int, Int)
forall a. a -> Maybe a
Just (Value
v, Int
i, Int
visits Int -> Int -> Int
forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
a)) Numbering
st.anchors
          Maybe Text
_ -> Numbering
st.anchors

    -- Unlike in 'duplicate', comparing all pairs is not faster for few keys.
    checkUniqueNumbers :: [(S.Node, (Value, Int), (Value, Int))] -> Either Failure ()
    checkUniqueNumbers :: [(Node, (Value, Int), (Value, Int))] -> Either Failure ()
checkUniqueNumbers = IntMap (Node, Value)
-> [(Node, (Value, Int), (Value, Int))] -> Either Failure ()
loop IntMap (Node, Value)
forall a. IntMap a
IM.empty
      where
        loop
          :: IM.IntMap (S.Node, Value)
          -> [(S.Node, (Value, Int), (Value, Int))]
          -> Either Failure ()
        loop :: IntMap (Node, Value)
-> [(Node, (Value, Int), (Value, Int))] -> Either Failure ()
loop IntMap (Node, Value)
seen = \case
          [] -> () -> Either Failure ()
forall a b. b -> Either a b
Right ()
          (Node
kn, (Value
k, Int
i), (Value, Int)
_) : [(Node, (Value, Int), (Value, Int))]
rest -> case Int -> IntMap (Node, Value) -> Maybe (Node, Value)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
i IntMap (Node, Value)
seen of
            Just (Node, Value)
first -> Failure -> Either Failure ()
forall a b. a -> Either a b
Left (Failure -> Either Failure ()) -> Failure -> Either Failure ()
forall a b. (a -> b) -> a -> b
$ (Node, Value) -> (Node, Value) -> Failure
duplicateKey (Node
kn, Value
k) (Node, Value)
first
            Maybe (Node, Value)
Nothing -> IntMap (Node, Value)
-> [(Node, (Value, Int), (Value, Int))] -> Either Failure ()
loop (Int
-> (Node, Value) -> IntMap (Node, Value) -> IntMap (Node, Value)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
i (Node
kn, Value
k) IntMap (Node, Value)
seen) [(Node, (Value, Int), (Value, Int))]
rest

-- | The value of a node that passed 'prepareWithin', so it has no aliases and its
-- keys are unique already.
representPrepared :: S.Node -> Either Failure Value
representPrepared :: Node -> Either Failure Value
representPrepared = Node -> Either Failure Value
go
  where
    go :: S.Node -> Either Failure Value
    go :: Node -> Either Failure Value
go Node
sn =
      let off :: Offset
off = Node
sn.offset; props :: Props
props = Node
sn.props
      in case Node
sn.content of
           S.ScalarContent ScalarStyle
style Text
t -> Offset -> Props -> ScalarStyle -> Text -> Either Failure Value
scalar Offset
off Props
props ScalarStyle
style Text
t
           S.SequenceContent CollectionStyle
_ [Node]
xs -> do
             tag <- Offset -> Props -> Text -> Either Failure Text
collectionTag Offset
off Props
props Text
seqTag
             vs <- mapEither go xs
             Right $ withTag tag (Sequence vs)
           S.MappingContent CollectionStyle
_ [(Node, Node)]
kvs -> do
             tag <- Offset -> Props -> Text -> Either Failure Text
collectionTag Offset
off Props
props Text
mapTag
             entries <- mapEither (\(Node
k, Node
v) -> (,) (Value -> Value -> (Value, Value))
-> Either Failure Value -> Either Failure (Value -> (Value, Value))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Node -> Either Failure Value
go Node
k Either Failure (Value -> (Value, Value))
-> Either Failure Value -> Either Failure (Value, Value)
forall a b.
Either Failure (a -> b) -> Either Failure a -> Either Failure b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Node -> Either Failure Value
go Node
v) kvs
             Right $ withTag tag (Mapping entries)
           S.AliasContent Text
_ -> Failure -> Either Failure Value
forall a b. a -> Either a b
Left (Failure -> Either Failure Value)
-> Failure -> Either Failure Value
forall a b. (a -> b) -> a -> b
$ Offset -> [Char] -> Failure
failure Offset
off [Char]
"unexpected alias"

-- | 'mapM' for 'Either', with a stack that does not grow with the length of
-- the list.
mapEither :: forall a e b. (a -> Either e b) -> [a] -> Either e [b]
mapEither :: forall a e b. (a -> Either e b) -> [a] -> Either e [b]
mapEither a -> Either e b
f = [b] -> [a] -> Either e [b]
go []
  where
    go :: [b] -> [a] -> Either e [b]
    go :: [b] -> [a] -> Either e [b]
go [b]
acc = \case
      [] -> [b] -> Either e [b]
forall a b. b -> Either a b
Right ([b] -> [b]
forall a. [a] -> [a]
reverse [b]
acc)
      a
x : [a]
xs -> case a -> Either e b
f a
x of
        Left e
err -> e -> Either e [b]
forall a b. a -> Either a b
Left e
err
        Right b
y -> [b] -> [a] -> Either e [b]
go (b
y b -> [b] -> [b]
forall a. a -> [a] -> [a]
: [b]
acc) [a]
xs

-- | The offset of the node that caused an error and the message, and the
-- notes that go after it, e.g. the first key of a duplicate key.
type Failure = NE.NonEmpty (S.Offset, String)

failure :: S.Offset -> String -> Failure
failure :: Offset -> [Char] -> Failure
failure Offset
off [Char]
msg = (Offset
off, [Char]
msg) (Offset, [Char]) -> [(Offset, [Char])] -> Failure
forall a. a -> [a] -> NonEmpty a
NE.:| []

-- | The checks of 'numberWithin' for a node without aliases and collection
-- keys.
-- Only the keys get values, for the comparison.
check :: S.Node -> Either Failure ()
check :: Node -> Either Failure ()
check Node
sn =
  let off :: Offset
off = Node
sn.offset; props :: Props
props = Node
sn.props
  in case Node
sn.content of
       S.ScalarContent ScalarStyle
style Text
t
         -- Only a number can fail without a tag.
         | Tag
S.NoTag <- Props
props.tag
         , ScalarStyle
style ScalarStyle -> ScalarStyle -> Bool
forall a. Eq a => a -> a -> Bool
/= ScalarStyle
S.Plain Bool -> Bool -> Bool
|| Bool -> Bool
not (Text -> Bool
maybeNumber Text
t) ->
             () -> Either Failure ()
forall a b. b -> Either a b
Right ()
         | Bool
otherwise -> Either Failure Value -> Either Failure ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Offset -> Props -> ScalarStyle -> Text -> Either Failure Value
scalar Offset
off Props
props ScalarStyle
style Text
t)
       S.SequenceContent CollectionStyle
_ [Node]
xs -> Offset -> Props -> Text -> Either Failure Text
collectionTag Offset
off Props
props Text
seqTag Either Failure Text -> Either Failure () -> Either Failure ()
forall a b.
Either Failure a -> Either Failure b -> Either Failure b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Node -> Either Failure ()) -> [Node] -> Either Failure ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ Node -> Either Failure ()
check [Node]
xs
       S.MappingContent CollectionStyle
_ [(Node, Node)]
kvs -> do
         _ <- Offset -> Props -> Text -> Either Failure Text
collectionTag Offset
off Props
props Text
mapTag
         keys <- mapEither (\(Node
k, Node
v) -> Node -> Either Failure (Node, Value)
key Node
k Either Failure (Node, Value)
-> Either Failure () -> Either Failure (Node, Value)
forall a b.
Either Failure a -> Either Failure b -> Either Failure a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Node -> Either Failure ()
check Node
v) kvs
         checkUniqueKeys keys
       S.AliasContent Text
_ -> Failure -> Either Failure ()
forall a b. a -> Either a b
Left (Failure -> Either Failure ()) -> Failure -> Either Failure ()
forall a b. (a -> b) -> a -> b
$ Offset -> [Char] -> Failure
failure Offset
off [Char]
"unexpected alias"
  where
    maybeNumber :: T.Text -> Bool
    maybeNumber :: Text -> Bool
maybeNumber Text
t = Bool -> ((Char, Text) -> Bool) -> Maybe (Char, Text) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Char -> Bool
startsNumber (Char -> Bool) -> ((Char, Text) -> Char) -> (Char, Text) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char, Text) -> Char
forall a b. (a, b) -> a
fst) (Text -> Maybe (Char, Text)
T.uncons Text
t)

    key :: S.Node -> Either Failure (S.Node, Value)
    key :: Node -> Either Failure (Node, Value)
key Node
k = case Node
k.content of
      S.ScalarContent ScalarStyle
style Text
t -> (Node
k,) (Value -> (Node, Value))
-> Either Failure Value -> Either Failure (Node, Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Offset -> Props -> ScalarStyle -> Text -> Either Failure Value
scalar Node
k.offset Node
k.props ScalarStyle
style Text
t
      Content
_ -> Failure -> Either Failure (Node, Value)
forall a b. a -> Either a b
Left (Failure -> Either Failure (Node, Value))
-> Failure -> Either Failure (Node, Value)
forall a b. (a -> b) -> a -> b
$ Offset -> [Char] -> Failure
failure Node
k.offset [Char]
"unexpected collection key"

    -- The keys come with their nodes.
    checkUniqueKeys :: [(S.Node, Value)] -> Either Failure ()
    checkUniqueKeys :: [(Node, Value)] -> Either Failure ()
checkUniqueKeys [(Node, Value)]
keys = case Maybe ((Node, Value), (Node, Value))
duplicate of
      Just ((Node, Value)
k, (Node, Value)
first) -> Failure -> Either Failure ()
forall a b. a -> Either a b
Left (Failure -> Either Failure ()) -> Failure -> Either Failure ()
forall a b. (a -> b) -> a -> b
$ (Node, Value) -> (Node, Value) -> Failure
duplicateKey (Node, Value)
k (Node, Value)
first
      Maybe ((Node, Value), (Node, Value))
Nothing -> () -> Either Failure ()
forall a b. b -> Either a b
Right ()
      where
        -- The first scalar key that is equal to an earlier one, and the
        -- earlier one. A document with a collection key gets numbers for its
        -- keys instead.
        duplicate :: Maybe ((S.Node, Value), (S.Node, Value))
        duplicate :: Maybe ((Node, Value), (Node, Value))
duplicate = case Int -> [(Node, Value)] -> [(Node, Value)]
forall a. Int -> [a] -> [a]
drop Int
maxPairwise [(Node, Value)]
keys of
          (Node, Value)
_ : [(Node, Value)]
_ -> Map Value Node
-> [(Node, Value)] -> Maybe ((Node, Value), (Node, Value))
viaMap Map Value Node
forall k a. Map k a
M.empty [(Node, Value)]
keys
          [] -> [(Node, Value)]
-> [(Node, Value)] -> Maybe ((Node, Value), (Node, Value))
pairwise [] [(Node, Value)]
keys

        -- Comparing all pairs is faster for 16 keys or fewer, by a
        -- measurement.
        maxPairwise :: Int
        maxPairwise :: Int
maxPairwise = Int
16

        viaMap
          :: M.Map Value S.Node
          -> [(S.Node, Value)]
          -> Maybe ((S.Node, Value), (S.Node, Value))
        viaMap :: Map Value Node
-> [(Node, Value)] -> Maybe ((Node, Value), (Node, Value))
viaMap Map Value Node
seen = \case
          [] -> Maybe ((Node, Value), (Node, Value))
forall a. Maybe a
Nothing
          k :: (Node, Value)
k@(Node
n, Value
v) : [(Node, Value)]
ks -> case Value -> Map Value Node -> Maybe Node
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Value
v Map Value Node
seen of
            Just Node
first -> ((Node, Value), (Node, Value))
-> Maybe ((Node, Value), (Node, Value))
forall a. a -> Maybe a
Just ((Node, Value)
k, (Node
first, Value
v))
            Maybe Node
Nothing -> Map Value Node
-> [(Node, Value)] -> Maybe ((Node, Value), (Node, Value))
viaMap (Value -> Node -> Map Value Node -> Map Value Node
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Value
v Node
n Map Value Node
seen) [(Node, Value)]
ks

        pairwise
          :: [(S.Node, Value)]
          -> [(S.Node, Value)]
          -> Maybe ((S.Node, Value), (S.Node, Value))
        pairwise :: [(Node, Value)]
-> [(Node, Value)] -> Maybe ((Node, Value), (Node, Value))
pairwise [(Node, Value)]
seen = \case
          [] -> Maybe ((Node, Value), (Node, Value))
forall a. Maybe a
Nothing
          k :: (Node, Value)
k@(Node
_, Value
v) : [(Node, Value)]
ks -> case ((Node, Value) -> Bool) -> [(Node, Value)] -> Maybe (Node, Value)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
L.find ((Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
v) (Value -> Bool)
-> ((Node, Value) -> Value) -> (Node, Value) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Node, Value) -> Value
forall a b. (a, b) -> b
snd) [(Node, Value)]
seen of
            Just (Node, Value)
first -> ((Node, Value), (Node, Value))
-> Maybe ((Node, Value), (Node, Value))
forall a. a -> Maybe a
Just ((Node, Value)
k, (Node, Value)
first)
            Maybe (Node, Value)
Nothing -> [(Node, Value)]
-> [(Node, Value)] -> Maybe ((Node, Value), (Node, Value))
pairwise ((Node, Value)
k (Node, Value) -> [(Node, Value)] -> [(Node, Value)]
forall a. a -> [a] -> [a]
: [(Node, Value)]
seen) [(Node, Value)]
ks

-- | Replace each alias with a copy of the node that it refers to. The copy
-- has the offsets and the comments of the alias, and no anchor. The nodes
-- inside the copy have the offsets of the alias too, so that an error inside
-- the copy names the place and the path where the document uses the value,
-- and not those of the anchor. They have no comments, because the comments
-- are at the anchor already. The node must pass 'numberWithin', so every
-- alias refers to an earlier anchor.
expandAliases :: S.Node -> S.Node
expandAliases :: Node -> Node
expandAliases = (Node, Map Text (Tag, Content)) -> Node
forall a b. (a, b) -> a
fst ((Node, Map Text (Tag, Content)) -> Node)
-> (Node -> (Node, Map Text (Tag, Content))) -> Node -> Node
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text (Tag, Content) -> Node -> (Node, Map Text (Tag, Content))
go Map Text (Tag, Content)
forall k a. Map k a
M.empty
  where
    go
      :: M.Map T.Text (S.Tag, S.Content)
      -> S.Node
      -> (S.Node, M.Map T.Text (S.Tag, S.Content))
    go :: Map Text (Tag, Content) -> Node -> (Node, Map Text (Tag, Content))
go Map Text (Tag, Content)
anchors Node
sn = case Node
sn.content of
      S.AliasContent Text
name -> case Text -> Map Text (Tag, Content) -> Maybe (Tag, Content)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
name Map Text (Tag, Content)
anchors of
        Just (Tag
tag, Content
content) ->
          ( S.Node
              { offset :: Offset
S.offset = Node
sn.offset
              , endOffset :: Offset
S.endOffset = Node
sn.endOffset
              , props :: Props
S.props = Maybe Text -> Tag -> Props
S.Props Maybe Text
forall a. Maybe a
Nothing Tag
tag
              , comments :: Comments
S.comments = Node
sn.comments
              , content :: Content
S.content = Node -> Content -> Content
copyAt Node
sn Content
content
              }
          , Map Text (Tag, Content)
anchors
          )
        Maybe (Tag, Content)
Nothing -> (Node
sn, Map Text (Tag, Content)
anchors)
      S.ScalarContent {} -> Node -> Map Text (Tag, Content) -> (Node, Map Text (Tag, Content))
define Node
sn Map Text (Tag, Content)
anchors
      S.SequenceContent CollectionStyle
style [Node]
xs ->
        let ([Node]
xs', Map Text (Tag, Content)
anchors') = Map Text (Tag, Content)
-> [Node] -> ([Node], Map Text (Tag, Content))
goList (Map Text (Tag, Content) -> Map Text (Tag, Content)
open Map Text (Tag, Content)
anchors) [Node]
xs
        in Node -> Map Text (Tag, Content) -> (Node, Map Text (Tag, Content))
close (Content -> Node
withContent (CollectionStyle -> [Node] -> Content
S.SequenceContent CollectionStyle
style [Node]
xs')) Map Text (Tag, Content)
anchors'
      S.MappingContent CollectionStyle
style [(Node, Node)]
kvs ->
        let ([(Node, Node)]
kvs', Map Text (Tag, Content)
anchors') = Map Text (Tag, Content)
-> [(Node, Node)] -> ([(Node, Node)], Map Text (Tag, Content))
goPairs (Map Text (Tag, Content) -> Map Text (Tag, Content)
open Map Text (Tag, Content)
anchors) [(Node, Node)]
kvs
        in Node -> Map Text (Tag, Content) -> (Node, Map Text (Tag, Content))
close (Content -> Node
withContent (CollectionStyle -> [(Node, Node)] -> Content
S.MappingContent CollectionStyle
style [(Node, Node)]
kvs')) Map Text (Tag, Content)
anchors'
      where
        withContent :: S.Content -> S.Node
        withContent :: Content -> Node
withContent Content
c =
          S.Node
            { offset :: Offset
S.offset = Node
sn.offset
            , endOffset :: Offset
S.endOffset = Node
sn.endOffset
            , props :: Props
S.props = Node
sn.props
            , comments :: Comments
S.comments = Node
sn.comments
            , content :: Content
S.content = Content
c
            }

        -- No alias inside refers to the anchor, so its old definition can
        -- go. A node inside with the same anchor comes later in the
        -- document, so its definition stays.
        open :: M.Map T.Text (S.Tag, S.Content) -> M.Map T.Text (S.Tag, S.Content)
        open :: Map Text (Tag, Content) -> Map Text (Tag, Content)
open = (Map Text (Tag, Content) -> Map Text (Tag, Content))
-> (Text -> Map Text (Tag, Content) -> Map Text (Tag, Content))
-> Maybe Text
-> Map Text (Tag, Content)
-> Map Text (Tag, Content)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Text (Tag, Content) -> Map Text (Tag, Content)
forall a. a -> a
id Text -> Map Text (Tag, Content) -> Map Text (Tag, Content)
forall k a. Ord k => k -> Map k a -> Map k a
M.delete Node
sn.props.anchor

        close
          :: S.Node
          -> M.Map T.Text (S.Tag, S.Content)
          -> (S.Node, M.Map T.Text (S.Tag, S.Content))
        close :: Node -> Map Text (Tag, Content) -> (Node, Map Text (Tag, Content))
close Node
n Map Text (Tag, Content)
anchors' = case Node
sn.props.anchor of
          Just Text
a | Text -> Map Text (Tag, Content) -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member Text
a Map Text (Tag, Content)
anchors' -> (Node
n, Map Text (Tag, Content)
anchors')
          Maybe Text
_ -> Node -> Map Text (Tag, Content) -> (Node, Map Text (Tag, Content))
define Node
n Map Text (Tag, Content)
anchors'

    define
      :: S.Node
      -> M.Map T.Text (S.Tag, S.Content)
      -> (S.Node, M.Map T.Text (S.Tag, S.Content))
    define :: Node -> Map Text (Tag, Content) -> (Node, Map Text (Tag, Content))
define Node
sn Map Text (Tag, Content)
anchors = case Node
sn.props.anchor of
      Just Text
a -> (Node
sn, Text
-> (Tag, Content)
-> Map Text (Tag, Content)
-> Map Text (Tag, Content)
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert Text
a (Node
sn.props.tag, Node
sn.content) Map Text (Tag, Content)
anchors)
      Maybe Text
Nothing -> (Node
sn, Map Text (Tag, Content)
anchors)

    -- The content at the alias.
    copyAt :: S.Node -> S.Content -> S.Content
    copyAt :: Node -> Content -> Content
copyAt Node
alias = \case
      S.SequenceContent CollectionStyle
style [Node]
xs -> CollectionStyle -> [Node] -> Content
S.SequenceContent CollectionStyle
style ((Node -> Node) -> [Node] -> [Node]
forall a b. (a -> b) -> [a] -> [b]
map Node -> Node
node [Node]
xs)
      S.MappingContent CollectionStyle
style [(Node, Node)]
kvs ->
        CollectionStyle -> [(Node, Node)] -> Content
S.MappingContent CollectionStyle
style [(Node -> Node
node Node
k, Node -> Node
node Node
v) | (Node
k, Node
v) <- [(Node, Node)]
kvs]
      Content
c -> Content
c
      where
        node :: S.Node -> S.Node
        node :: Node -> Node
node Node
n =
          S.Node
            { offset :: Offset
S.offset = Node
alias.offset
            , endOffset :: Offset
S.endOffset = Node
alias.endOffset
            , props :: Props
S.props = Node
n.props
            , comments :: Comments
S.comments = Comments
S.noComments
            , content :: Content
S.content = Node -> Content -> Content
copyAt Node
alias Node
n.content
            }

    goList
      :: M.Map T.Text (S.Tag, S.Content)
      -> [S.Node]
      -> ([S.Node], M.Map T.Text (S.Tag, S.Content))
    goList :: Map Text (Tag, Content)
-> [Node] -> ([Node], Map Text (Tag, Content))
goList Map Text (Tag, Content)
anchors = \case
      [] -> ([], Map Text (Tag, Content)
anchors)
      Node
x : [Node]
xs ->
        let (Node
x', Map Text (Tag, Content)
anchors') = Map Text (Tag, Content) -> Node -> (Node, Map Text (Tag, Content))
go Map Text (Tag, Content)
anchors Node
x
            ([Node]
xs', Map Text (Tag, Content)
anchors'') = Map Text (Tag, Content)
-> [Node] -> ([Node], Map Text (Tag, Content))
goList Map Text (Tag, Content)
anchors' [Node]
xs
        in (Node
x' Node -> [Node] -> [Node]
forall a. a -> [a] -> [a]
: [Node]
xs', Map Text (Tag, Content)
anchors'')

    goPairs
      :: M.Map T.Text (S.Tag, S.Content)
      -> [(S.Node, S.Node)]
      -> ([(S.Node, S.Node)], M.Map T.Text (S.Tag, S.Content))
    goPairs :: Map Text (Tag, Content)
-> [(Node, Node)] -> ([(Node, Node)], Map Text (Tag, Content))
goPairs Map Text (Tag, Content)
anchors = \case
      [] -> ([], Map Text (Tag, Content)
anchors)
      (Node
k, Node
v) : [(Node, Node)]
kvs ->
        let (Node
k', Map Text (Tag, Content)
anchors') = Map Text (Tag, Content) -> Node -> (Node, Map Text (Tag, Content))
go Map Text (Tag, Content)
anchors Node
k
            (Node
v', Map Text (Tag, Content)
anchors'') = Map Text (Tag, Content) -> Node -> (Node, Map Text (Tag, Content))
go Map Text (Tag, Content)
anchors' Node
v
            ([(Node, Node)]
kvs', Map Text (Tag, Content)
anchors''') = Map Text (Tag, Content)
-> [(Node, Node)] -> ([(Node, Node)], Map Text (Tag, Content))
goPairs Map Text (Tag, Content)
anchors'' [(Node, Node)]
kvs
        in ((Node
k', Node
v') (Node, Node) -> [(Node, Node)] -> [(Node, Node)]
forall a. a -> [a] -> [a]
: [(Node, Node)]
kvs', Map Text (Tag, Content)
anchors''')

-- | The value with the tag, in 'Tagged' if the tag is not the one of the core
-- schema for the value.
withTag :: T.Text -> Value -> Value
withTag :: Text -> Value -> Value
withTag Text
tag Value
v
  | Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Value -> Text
valueTag Value
v = Value
v
  | Bool
otherwise = Text -> Value -> Value
Tagged Text
tag Value
v

scalar :: S.Offset -> S.Props -> S.ScalarStyle -> T.Text -> Either Failure Value
scalar :: Offset -> Props -> ScalarStyle -> Text -> Either Failure Value
scalar Offset
off Props
props ScalarStyle
style Text
t = case Props
props.tag of
  Tag
S.NoTag
    | ScalarStyle
style ScalarStyle -> ScalarStyle -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarStyle
S.Plain -> case Text -> Either Value Value
resolvePlainExact Text
t of
        Right Value
v -> Value -> Either Failure Value
forall a b. b -> Either a b
Right Value
v
        -- The check comes before the decoder, which knows if the value is
        -- a string. A node that a program built has no input to quote.
        Left Value
_
          | Offset
off Offset -> Offset -> Bool
forall a. Eq a => a -> a -> Bool
== Offset
S.noOffset -> Failure -> Either Failure Value
forall a b. a -> Either a b
Left (Failure -> Either Failure Value)
-> Failure -> Either Failure Value
forall a b. (a -> b) -> a -> b
$ Offset -> [Char] -> Failure
failure Offset
off [Char]
exponentOutOfRange
          | Bool
otherwise ->
              Failure -> Either Failure Value
forall a b. a -> Either a b
Left (Failure -> Either Failure Value)
-> ([Char] -> Failure) -> [Char] -> Either Failure Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Offset -> [Char] -> Failure
failure Offset
off ([Char] -> Either Failure Value) -> [Char] -> Either Failure Value
forall a b. (a -> b) -> a -> b
$
                [Char]
exponentOutOfRange
                  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", quote the value if it is a string, 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]
"'"
    | Bool
otherwise -> Value -> Either Failure Value
forall a b. b -> Either a b
Right (Text -> Value
String Text
t)
  Tag
S.NonSpecificTag -> Value -> Either Failure Value
forall a b. b -> Either a b
Right (Text -> Value
String Text
t)
  S.Tag Text
tag
    | Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
seqTag Bool -> Bool -> Bool
|| Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
mapTag ->
        Failure -> Either Failure Value
forall a b. a -> Either a b
Left (Failure -> Either Failure Value)
-> ([Char] -> Failure) -> [Char] -> Either Failure Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Offset -> [Char] -> Failure
failure Offset
off ([Char] -> Either Failure Value) -> [Char] -> Either Failure Value
forall a b. (a -> b) -> a -> b
$
          [Char]
"the tag !!"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (Int -> Text -> Text
T.drop (Text -> Int
T.length Text
coreTagPrefix) Text
tag)
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" cannot be used on a scalar"
    | Bool
otherwise -> case Text -> Text -> Maybe (Either Value Value)
resolveTaggedExact Text
tag Text
t of
        Just (Right Value
v) -> Value -> Either Failure Value
forall a b. b -> Either a b
Right (Text -> Value -> Value
withTag Text
tag Value
v)
        Just (Left Value
_) -> Failure -> Either Failure Value
forall a b. a -> Either a b
Left (Failure -> Either Failure Value)
-> Failure -> Either Failure Value
forall a b. (a -> b) -> a -> b
$ Offset -> [Char] -> Failure
failure Offset
off [Char]
exponentOutOfRange
        Maybe (Either Value Value)
Nothing ->
          Failure -> Either Failure Value
forall a b. a -> Either a b
Left (Failure -> Either Failure Value)
-> ([Char] -> Failure) -> [Char] -> Either Failure Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Offset -> [Char] -> Failure
failure Offset
off ([Char] -> Either Failure Value) -> [Char] -> Either Failure Value
forall a b. (a -> b) -> a -> b
$
            [Char]
"invalid value for the tag !!"
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (Int -> Text -> Text
T.drop (Text -> Int
T.length Text
coreTagPrefix) Text
tag)
              [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ if Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
boolTag Bool -> Bool -> Bool
&& Text -> Bool
isYaml11Bool Text
t
                then [Char]
", " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
showText Text
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" is a boolean only in YAML 1.1"
                else [Char]
""

collectionTag :: S.Offset -> S.Props -> T.Text -> Either Failure T.Text
collectionTag :: Offset -> Props -> Text -> Either Failure Text
collectionTag Offset
off Props
props Text
def = case Props
props.tag of
  Tag
S.NoTag -> Text -> Either Failure Text
forall a b. b -> Either a b
Right Text
def
  Tag
S.NonSpecificTag -> Text -> Either Failure Text
forall a b. b -> Either a b
Right Text
def
  S.Tag Text
tag
    | Text
tag Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
def Bool -> Bool -> Bool
|| Bool -> Bool
not (Text -> Bool
isCoreTag Text
tag) -> Text -> Either Failure Text
forall a b. b -> Either a b
Right Text
tag
    | Bool
otherwise ->
        Failure -> Either Failure Text
forall a b. a -> Either a b
Left (Failure -> Either Failure Text)
-> ([Char] -> Failure) -> [Char] -> Either Failure Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Offset -> [Char] -> Failure
failure Offset
off ([Char] -> Either Failure Text) -> [Char] -> Either Failure Text
forall a b. (a -> b) -> a -> b
$
          [Char]
"the tag !!"
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack (Int -> Text -> Text
T.drop (Text -> Int
T.length Text
coreTagPrefix) Text
tag)
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" cannot be used on a "
            [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if Text
def Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
seqTag then [Char]
"sequence" else [Char]
"mapping")
  where
    isCoreTag :: T.Text -> Bool
    isCoreTag :: Text -> Bool
isCoreTag Text
tag =
      Text
tag Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
nullTag, Text
boolTag, Text
intTag, Text
floatTag, Text
strTag, Text
seqTag, Text
mapTag]

-- | The error at a key, with a note at the first key that is equal to it.
duplicateKey :: (S.Node, Value) -> (S.Node, Value) -> Failure
duplicateKey :: (Node, Value) -> (Node, Value) -> Failure
duplicateKey (Node
kn, Value
k) (Node
firstNode, Value
_) =
  (Node
kn.offset, [Char]
message) (Offset, [Char]) -> [(Offset, [Char])] -> Failure
forall a. a -> [a] -> NonEmpty a
NE.:| [(Node
firstNode.offset, [Char]
note)]
  where
    message :: String
    message :: [Char]
message = case (Value
k, Node -> Maybe [Char]
inputText Node
kn, Node -> Maybe [Char]
inputText Node
firstNode) of
      (String Text
"<<", Maybe [Char]
_, Maybe [Char]
_) -> [Char]
"duplicate key \"<<\"" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
noMergeKeys
      (Value
_, Just [Char]
t, Just [Char]
f)
        | [Char]
t [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
f -> [Char]
"duplicate key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
", the same value as the first key"
      (Value
_, Just [Char]
t, Maybe [Char]
_) -> [Char]
"duplicate key " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
t
      (Value
_, Maybe [Char]
Nothing, Maybe [Char]
_) -> [Char]
"duplicate key"

    note :: String
    note :: [Char]
note = [Char]
"the first key" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [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]
:) (Node -> Maybe [Char]
inputText Node
firstNode)

-- | The hint after the message of an error at a key @<<@. YAML 1.1 used it to
-- merge mappings, and some tools still do, but in YAML 1.2 it is a string.
noMergeKeys :: String
noMergeKeys :: [Char]
noMergeKeys = [Char]
", merge keys are not supported"

-- | The state of the composition of a document with aliases or collection
-- keys. Equal values get the same number, so that keys compare in constant
-- time, even if they are large collections or come from aliases that expand
-- to huge values.
data Numbering = Numbering
  { Numbering -> Map Text (Maybe (Value, Int, Int))
anchors :: !(M.Map T.Text (Maybe (Value, Int, Int)))
  -- ^ An anchor maps to its value, the number of the value and the visits of
  -- a traversal of the node. It maps to Nothing while its node is composed.
  , Numbering -> Map Shape Int
shapes :: !(M.Map Shape Int)
  , Numbering -> Int
visits :: !Int
  -- ^ The visits of a traversal of the nodes so far.
  , Numbering -> Int
added :: !Int
  -- ^ The visits that the aliases added so far, with those of the documents
  -- before in the stream.
  }

-- | A value with the numbers of its items or entries in place of them. The
-- entries of a mapping are sorted, so their order does not matter. A scalar
-- is small, so it stays a value.
data Shape
  = ScalarShape !Value
  | SequenceShape !T.Text ![Int]
  | MappingShape !T.Text ![(Int, Int)]
  deriving stock (Shape -> Shape -> Bool
(Shape -> Shape -> Bool) -> (Shape -> Shape -> Bool) -> Eq Shape
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Shape -> Shape -> Bool
== :: Shape -> Shape -> Bool
$c/= :: Shape -> Shape -> Bool
/= :: Shape -> Shape -> Bool
Eq, Eq Shape
Eq Shape =>
(Shape -> Shape -> Ordering)
-> (Shape -> Shape -> Bool)
-> (Shape -> Shape -> Bool)
-> (Shape -> Shape -> Bool)
-> (Shape -> Shape -> Bool)
-> (Shape -> Shape -> Shape)
-> (Shape -> Shape -> Shape)
-> Ord Shape
Shape -> Shape -> Bool
Shape -> Shape -> Ordering
Shape -> Shape -> Shape
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Shape -> Shape -> Ordering
compare :: Shape -> Shape -> Ordering
$c< :: Shape -> Shape -> Bool
< :: Shape -> Shape -> Bool
$c<= :: Shape -> Shape -> Bool
<= :: Shape -> Shape -> Bool
$c> :: Shape -> Shape -> Bool
> :: Shape -> Shape -> Bool
$c>= :: Shape -> Shape -> Bool
>= :: Shape -> Shape -> Bool
$cmax :: Shape -> Shape -> Shape
max :: Shape -> Shape -> Shape
$cmin :: Shape -> Shape -> Shape
min :: Shape -> Shape -> Shape
Ord)