-- | The values of YAML documents: the content with resolved tags, without the
-- styles, comments and positions of the syntax tree.
--
-- A 'Value' has t'Yamlet.Decode.FromYaml' and t'Yamlet.Encode.ToYaml'
-- instances, e.g. to read a document whose structure a program does not
-- know:
--
-- >>> decodeText @Value "!point {x: 1, y: 2.5}\n"
-- Right (Tagged "!point" (Mapping [(String "x",Int 1),(String "y",Float (Finite 2.5))]))
--
-- An alias becomes a copy of the value that it refers to:
--
-- >>> decodeText @Value "base: &b [1, 2]\ncopy: *b\n"
-- Right (Mapping [(String "base",Sequence [Int 1,Int 2]),(String "copy",Sequence [Int 1,Int 2])])
--
-- A small input with many aliases can give a large value. To prevent this,
-- the decoder limits the aliases. Each node and each character of a scalar,
-- a tag or an anchor counts as one unit. The aliases can add 100000 units to
-- a document. For a document with more units, they can add as many units as
-- the document has.
-- The documents of a stream share the limit, as if they were one document.
-- A document beyond the limit is an error.
module Yamlet.Value
  ( -- * Values
    Value (..)
  , FloatValue (..)
  , floatValueToRealFloat
  , realFloatToFloatValue
  , describe

    -- * Tags
  , valueTag
  , nullTag
  , boolTag
  , intTag
  , floatTag
  , strTag
  , seqTag
  , mapTag
  ) where

import Control.DeepSeq
import Data.Scientific qualified as Sci
import Data.Text qualified as T
import GHC.Generics

import Yamlet.Internal.Utils

-- | The value of a node.
--
-- 'Eq' and 'Ord' compare the entries of mappings in order, so two mappings
-- with the same entries in a different order are not equal, unlike in YAML.
data Value
  = Null
  | Bool !Bool
  | Int !Integer
  | Float !FloatValue
  | String !T.Text
  | Sequence ![Value]
  | -- | The entries of a mapping in the order of the input. The keys are
    -- unique. The encoder does not check this for a mapping that a program
    -- builds, and a mapping with two equal keys does not read back. Keys are
    -- equal as in YAML, e.g. two mappings with the same entries in a
    -- different order are equal keys.
    Mapping ![(Value, Value)]
  | -- | A value with a tag that is not the tag of the core schema for it,
    -- e.g. @!point {x: 1}@. A scalar with a tag that the schema does not
    -- know is a v'String' inside, e.g. @!secret abc@.
    --
    -- The encoder writes the tag. Some values read back with a change:
    --
    -- * A value with its own tag of the core schema reads back without
    --   'Tagged', e.g. @Tagged intTag (Int 1)@ as @Int 1@.
    --
    -- * A value that does not fit a tag of the core schema does not read
    --   back, e.g. a v'String' with 'intTag'.
    --
    -- * A scalar other than a v'String' with a tag that the schema does not
    --   know reads back as a v'String', e.g. @Tagged "!x" (Int 5)@ as
    --   @Tagged "!x" (String "5")@.
    --
    -- * YAML has no syntax for the empty tag or a tag of one character, e.g.
    --   @x@ or @!@. The encoder drops such a tag, e.g. @Tagged "" (Int 1)@
    --   reads back as @Int 1@.
    --
    -- * A node has one tag, so the encoder writes only the outermost tag that
    --   it does not drop, e.g. @Tagged "!a" (Tagged "!b" (Sequence []))@
    --   reads back as @Tagged "!a" (Sequence [])@.
    Tagged !T.Text !Value
  deriving stock (Value -> Value -> Bool
(Value -> Value -> Bool) -> (Value -> Value -> Bool) -> Eq Value
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Value -> Value -> Bool
== :: Value -> Value -> Bool
$c/= :: Value -> Value -> Bool
/= :: Value -> Value -> Bool
Eq, Eq Value
Eq Value =>
(Value -> Value -> Ordering)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Bool)
-> (Value -> Value -> Value)
-> (Value -> Value -> Value)
-> Ord Value
Value -> Value -> Bool
Value -> Value -> Ordering
Value -> Value -> Value
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 :: Value -> Value -> Ordering
compare :: Value -> Value -> Ordering
$c< :: Value -> Value -> Bool
< :: Value -> Value -> Bool
$c<= :: Value -> Value -> Bool
<= :: Value -> Value -> Bool
$c> :: Value -> Value -> Bool
> :: Value -> Value -> Bool
$c>= :: Value -> Value -> Bool
>= :: Value -> Value -> Bool
$cmax :: Value -> Value -> Value
max :: Value -> Value -> Value
$cmin :: Value -> Value -> Value
min :: Value -> Value -> Value
Ord, Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [Value] -> ShowS
Show, (forall x. Value -> Rep Value x)
-> (forall x. Rep Value x -> Value) -> Generic Value
forall x. Rep Value x -> Value
forall x. Value -> Rep Value x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. Value -> Rep Value x
from :: forall x. Value -> Rep Value x
$cto :: forall x. Rep Value x -> Value
to :: forall x. Rep Value x -> Value
Generic)

-- The instances of the sum types are written by hand, because GHC does not
-- always remove the generic representation of a sum type. A strict field of
-- a type without lazy parts, e.g. a text, is already in normal form.
instance NFData Value where
  rnf :: Value -> ()
rnf = \case
    Value
Null -> ()
    Bool Bool
_ -> ()
    Int Integer
_ -> ()
    Float FloatValue
_ -> ()
    String Text
_ -> ()
    Sequence [Value]
xs -> [Value] -> ()
forall a. NFData a => a -> ()
rnf [Value]
xs
    Mapping [(Value, Value)]
kvs -> [(Value, Value)] -> ()
forall a. NFData a => a -> ()
rnf [(Value, Value)]
kvs
    Tagged Text
_ Value
v -> Value -> ()
forall a. NFData a => a -> ()
rnf Value
v

-- | The value of a floating-point number. A finite value is exact, e.g. @0.1@
-- is exactly one tenth.
--
-- Arithmetic on a t'Data.Scientific.Scientific' with a huge exponent, e.g.
-- @1e1000000000@, can use all memory. Convert a value from an untrusted input
-- with 'floatValueToRealFloat' or with the bounded conversions of
-- "Data.Scientific".
data FloatValue
  = -- | A finite value other than negative zero.
    --
    -- The encoder writes a value whose exponent in scientific notation is
    -- beyond the range from -1000 to 1000, e.g. @1.0e+1001@, but the decoder
    -- rejects it. The decoder never gives such a value, and a 'Double' is
    -- always in the range.
    Finite !Sci.Scientific
  | -- | Negative zero, e.g. @-0.0@, which a t'Data.Scientific.Scientific'
    -- cannot hold.
    NegativeZero
  | Infinity
  | NegativeInfinity
  | NaN
  deriving stock (FloatValue -> FloatValue -> Bool
(FloatValue -> FloatValue -> Bool)
-> (FloatValue -> FloatValue -> Bool) -> Eq FloatValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FloatValue -> FloatValue -> Bool
== :: FloatValue -> FloatValue -> Bool
$c/= :: FloatValue -> FloatValue -> Bool
/= :: FloatValue -> FloatValue -> Bool
Eq, Eq FloatValue
Eq FloatValue =>
(FloatValue -> FloatValue -> Ordering)
-> (FloatValue -> FloatValue -> Bool)
-> (FloatValue -> FloatValue -> Bool)
-> (FloatValue -> FloatValue -> Bool)
-> (FloatValue -> FloatValue -> Bool)
-> (FloatValue -> FloatValue -> FloatValue)
-> (FloatValue -> FloatValue -> FloatValue)
-> Ord FloatValue
FloatValue -> FloatValue -> Bool
FloatValue -> FloatValue -> Ordering
FloatValue -> FloatValue -> FloatValue
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 :: FloatValue -> FloatValue -> Ordering
compare :: FloatValue -> FloatValue -> Ordering
$c< :: FloatValue -> FloatValue -> Bool
< :: FloatValue -> FloatValue -> Bool
$c<= :: FloatValue -> FloatValue -> Bool
<= :: FloatValue -> FloatValue -> Bool
$c> :: FloatValue -> FloatValue -> Bool
> :: FloatValue -> FloatValue -> Bool
$c>= :: FloatValue -> FloatValue -> Bool
>= :: FloatValue -> FloatValue -> Bool
$cmax :: FloatValue -> FloatValue -> FloatValue
max :: FloatValue -> FloatValue -> FloatValue
$cmin :: FloatValue -> FloatValue -> FloatValue
min :: FloatValue -> FloatValue -> FloatValue
Ord, Int -> FloatValue -> ShowS
[FloatValue] -> ShowS
FloatValue -> String
(Int -> FloatValue -> ShowS)
-> (FloatValue -> String)
-> ([FloatValue] -> ShowS)
-> Show FloatValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FloatValue -> ShowS
showsPrec :: Int -> FloatValue -> ShowS
$cshow :: FloatValue -> String
show :: FloatValue -> String
$cshowList :: [FloatValue] -> ShowS
showList :: [FloatValue] -> ShowS
Show, (forall x. FloatValue -> Rep FloatValue x)
-> (forall x. Rep FloatValue x -> FloatValue) -> Generic FloatValue
forall x. Rep FloatValue x -> FloatValue
forall x. FloatValue -> Rep FloatValue x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. FloatValue -> Rep FloatValue x
from :: forall x. FloatValue -> Rep FloatValue x
$cto :: forall x. Rep FloatValue x -> FloatValue
to :: forall x. Rep FloatValue x -> FloatValue
Generic)

instance NFData FloatValue where
  rnf :: FloatValue -> ()
rnf = FloatValue -> ()
forall a. a -> ()
rwhnf

-- | The nearest value of a floating-point type, e.g. 'Double', infinite if
-- the value is out of its range. The decimal converts to the type directly,
-- so it is rounded once, e.g. a t'Float' does not go by way of a 'Double'.
--
-- >>> map (floatValueToRealFloat @Double) [Finite 0.1, Finite 1e400, NegativeZero]
-- [0.1,Infinity,-0.0]
floatValueToRealFloat :: RealFloat a => FloatValue -> a
floatValueToRealFloat :: forall a. RealFloat a => FloatValue -> a
floatValueToRealFloat = \case
  Finite Scientific
s -> Scientific -> a
forall a. RealFloat a => Scientific -> a
Sci.toRealFloat Scientific
s
  FloatValue
NegativeZero -> -a
0
  FloatValue
Infinity -> a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
0
  FloatValue
NegativeInfinity -> -(a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
0)
  FloatValue
NaN -> a
0 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
0
-- With INLINEABLE, GHC specializes the function at the type of a caller in
-- another module, also the conversion of "Data.Scientific" inside it, as a
-- probe with a newtype of Double showed. The specializations are for the
-- types of the instances of the library. Without them, the decode benchmarks
-- of the config and the JSON input allocate more.
{-# INLINEABLE floatValueToRealFloat #-}
{-# SPECIALIZE floatValueToRealFloat :: FloatValue -> Double #-}
{-# SPECIALIZE floatValueToRealFloat :: FloatValue -> Float #-}

-- | The value of a floating-point number, e.g. a 'Double'. A finite number
-- becomes the shortest decimal that reads back as the same number, e.g.
-- @0.1@.
--
-- >>> map (realFloatToFloatValue @Double) [0.1, -0, 1 / 0]
-- [Finite 0.1,NegativeZero,Infinity]
realFloatToFloatValue :: RealFloat a => a -> FloatValue
realFloatToFloatValue :: forall a. RealFloat a => a -> FloatValue
realFloatToFloatValue a
d
  | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
d = FloatValue
NaN
  | a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
d = if a
d a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
0 then FloatValue
Infinity else FloatValue
NegativeInfinity
  | a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
d = FloatValue
NegativeZero
  | Bool
otherwise = Scientific -> FloatValue
Finite (a -> Scientific
forall a. RealFloat a => a -> Scientific
Sci.fromFloatDigits a
d)
-- As for 'floatValueToRealFloat'. Without the specializations, the encode
-- benchmarks of the config and the JSON input are slower and allocate more.
{-# INLINEABLE realFloatToFloatValue #-}
{-# SPECIALIZE realFloatToFloatValue :: Double -> FloatValue #-}
{-# SPECIALIZE realFloatToFloatValue :: Float -> FloatValue #-}

-- | The kind of a value in plain words, for error messages, e.g. "a list".
-- The tag of 'Tagged' does not change it.
--
-- >>> describe (Tagged "!point" (Mapping []))
-- "a mapping"
describe :: Value -> String
describe :: Value -> String
describe = \case
  Value
Null -> String
"null"
  Bool Bool
_ -> String
"a boolean"
  Int Integer
_ -> String
"an integer"
  Float FloatValue
_ -> String
"a floating-point number"
  String Text
_ -> String
"a string"
  Sequence [Value]
_ -> String
"a list"
  Mapping [(Value, Value)]
_ -> String
"a mapping"
  Tagged Text
_ Value
v -> Value -> String
describe Value
v

-- | The tag of a value: the tag of 'Tagged', or else the tag of the core
-- schema, e.g. 'intTag' for an v'Int'.
--
-- >>> map valueTag [Int 1, Tagged "!point" (Mapping [])]
-- ["tag:yaml.org,2002:int","!point"]
valueTag :: Value -> T.Text
valueTag :: Value -> Text
valueTag = \case
  Value
Null -> Text
nullTag
  Bool Bool
_ -> Text
boolTag
  Int Integer
_ -> Text
intTag
  Float FloatValue
_ -> Text
floatTag
  String Text
_ -> Text
strTag
  Sequence [Value]
_ -> Text
seqTag
  Mapping [(Value, Value)]
_ -> Text
mapTag
  Tagged Text
tag Value
_ -> Text
tag

-- | @tag:yaml.org,2002:null@.
nullTag :: T.Text
nullTag :: Text
nullTag = Text
coreTagPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"null"

-- | @tag:yaml.org,2002:bool@.
boolTag :: T.Text
boolTag :: Text
boolTag = Text
coreTagPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"bool"

-- | @tag:yaml.org,2002:int@.
intTag :: T.Text
intTag :: Text
intTag = Text
coreTagPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"int"

-- | @tag:yaml.org,2002:float@.
floatTag :: T.Text
floatTag :: Text
floatTag = Text
coreTagPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"float"

-- | @tag:yaml.org,2002:str@.
strTag :: T.Text
strTag :: Text
strTag = Text
coreTagPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"str"

-- | @tag:yaml.org,2002:seq@.
seqTag :: T.Text
seqTag :: Text
seqTag = Text
coreTagPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"seq"

-- | @tag:yaml.org,2002:map@.
mapTag :: T.Text
mapTag :: Text
mapTag = Text
coreTagPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"map"

-- $setup
-- >>> import Yamlet