{-# OPTIONS_HADDOCK not-home #-}

-- | The values of the nodes of a syntax tree.
--
-- This module is intended for internal use only, and may change without warning
-- in subsequent releases.
module Yamlet.Internal.View
  ( View (..)
  , view
  , scalarValue
  , describeNode
  , isNullNode
  , stringValue
  , inputText
  ) where

import Data.Maybe
import Data.Text qualified as T
import GHC.Generics

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

-- | The value of a node with its tag resolved. The items and the entries of a
-- collection stay nodes of the syntax tree. A tag that the schema does not
-- know does not matter, e.g. @!secret abc@ is a string.
data View
  = NullView
  | BoolView !Bool
  | IntView !Integer
  | FloatView !FloatValue
  | StringView !T.Text
  | SequenceView ![S.Node]
  | MappingView ![(S.Node, S.Node)]
  | -- | An alias, e.g. in a node from 'Yamlet.Syntax.parseDocuments'.
    -- 'Yamlet.Decode.runParser' replaces the aliases, so a parser never sees
    -- one.
    AliasView !T.Text
  deriving stock (View -> View -> Bool
(View -> View -> Bool) -> (View -> View -> Bool) -> Eq View
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: View -> View -> Bool
== :: View -> View -> Bool
$c/= :: View -> View -> Bool
/= :: View -> View -> Bool
Eq, Int -> View -> ShowS
[View] -> ShowS
View -> String
(Int -> View -> ShowS)
-> (View -> String) -> ([View] -> ShowS) -> Show View
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> View -> ShowS
showsPrec :: Int -> View -> ShowS
$cshow :: View -> String
show :: View -> String
$cshowList :: [View] -> ShowS
showList :: [View] -> ShowS
Show, (forall x. View -> Rep View x)
-> (forall x. Rep View x -> View) -> Generic View
forall x. Rep View x -> View
forall x. View -> Rep View x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. View -> Rep View x
from :: forall x. View -> Rep View x
$cto :: forall x. Rep View x -> View
to :: forall x. Rep View x -> View
Generic)

-- | The view of a node.
view :: S.Node -> View
view :: Node -> View
view Node
n = case Node
n.content of
  S.ScalarContent ScalarStyle
style Text
t -> case Tag -> ScalarStyle -> Text -> Value
scalarValue Node
n.props.tag ScalarStyle
style Text
t of
    Value
Null -> View
NullView
    Bool Bool
b -> Bool -> View
BoolView Bool
b
    Int Integer
i -> Integer -> View
IntView Integer
i
    Float FloatValue
f -> FloatValue -> View
FloatView FloatValue
f
    Value
_ -> Text -> View
StringView Text
t
  S.SequenceContent CollectionStyle
_ [Node]
xs -> [Node] -> View
SequenceView [Node]
xs
  S.MappingContent CollectionStyle
_ [(Node, Node)]
kvs -> [(Node, Node)] -> View
MappingView [(Node, Node)]
kvs
  S.AliasContent Text
name -> Text -> View
AliasView Text
name
-- GHC does not inline it without the pragma. Inlined, a match on the view
-- allocates no view. Without it, the decode benchmarks and the parseYaml
-- benchmarks of the derived instances allocated more.
{-# INLINE view #-}

-- | The value of a scalar with the tag and the style, without the tag.
scalarValue :: S.Tag -> S.ScalarStyle -> T.Text -> Value
scalarValue :: Tag -> ScalarStyle -> Text -> Value
scalarValue Tag
tag ScalarStyle
style Text
t = case Tag
tag of
  Tag
S.NoTag
    | ScalarStyle
style ScalarStyle -> ScalarStyle -> Bool
forall a. Eq a => a -> a -> Bool
== ScalarStyle
S.Plain -> Text -> Value
resolvePlain Text
t
    | Bool
otherwise -> Text -> Value
String Text
t
  Tag
S.NonSpecificTag -> Text -> Value
String Text
t
  -- 'Yamlet.Decode.runParser' rejects a value that is not valid for its tag.
  S.Tag Text
tag' -> Value -> Maybe Value -> Value
forall a. a -> Maybe a -> a
fromMaybe (Text -> Value
String Text
t) (Text -> Text -> Maybe Value
resolveTagged Text
tag' Text
t)
-- Inlined, it saves little of the allocation of a decoder in the decode
-- benchmarks, but each match on 'view' gets a copy of it, and a small
-- instance grows much.
{-# NOINLINE scalarValue #-}

-- | The kind of a node in plain words, e.g. "a list".
--
-- >>> map describeNode <$> decodeText @[Node] "- [1, 2]\n- 3.5\n- ~\n- !!str 12\n"
-- Right ["a list","a floating-point number","null","a string"]
describeNode :: S.Node -> String
describeNode :: Node -> String
describeNode Node
n = case Node
n.content of
  S.ScalarContent ScalarStyle
style Text
t -> Value -> String
describe (Tag -> ScalarStyle -> Text -> Value
scalarValue Node
n.props.tag ScalarStyle
style Text
t)
  S.SequenceContent CollectionStyle
_ [Node]
_ -> String
"a list"
  S.MappingContent CollectionStyle
_ [(Node, Node)]
_ -> String
"a mapping"
  S.AliasContent Text
_ -> String
"an alias"

-- | The node is null.
isNullNode :: S.Node -> Bool
isNullNode :: Node -> Bool
isNullNode Node
n = case Node -> View
view Node
n of
  View
NullView -> Bool
True
  View
_ -> Bool
False

-- | The text of a string node.
stringValue :: S.Node -> Maybe T.Text
stringValue :: Node -> Maybe Text
stringValue Node
n = case Node -> View
view Node
n of
  StringView Text
t -> Text -> Maybe Text
forall a. a -> Maybe a
Just Text
t
  View
_ -> Maybe Text
forall a. Maybe a
Nothing

-- | A key or an item as the input writes it, for an error: a string in
-- quotes, an alias with its @*@ and another scalar as it is. A collection
-- and an empty scalar have no text.
inputText :: S.Node -> Maybe String
inputText :: Node -> Maybe String
inputText Node
n = case Node
n.content of
  S.AliasContent Text
name -> String -> Maybe String
forall a. a -> Maybe a
Just (Char
'*' Char -> ShowS
forall a. a -> [a] -> [a]
: Text -> String
T.unpack Text
name)
  S.ScalarContent ScalarStyle
_ Text
t
    | Just Text
s <- Node -> Maybe Text
stringValue Node
n -> String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
showText Text
s)
    | Bool -> Bool
not (Text -> Bool
T.null Text
t) -> String -> Maybe String
forall a. a -> Maybe a
Just (Text -> String
T.unpack Text
t)
  Content
_ -> Maybe String
forall a. Maybe a
Nothing

-- $setup
-- >>> import Yamlet