{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE Safe                #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- |
-- Copyright: © Herbert Valerio Riedel 2015-2018
-- SPDX-License-Identifier: GPL-2.0-or-later
--
-- YAML 1.2 Schema resolvers and encoders
--
module Data.YAML.Schema.Internal
    ( SchemaResolver(..)
    , failsafeSchemaResolver
    , jsonSchemaResolver
    , coreSchemaResolver
    , Scalar(..)

    , SchemaEncoder(..)
    , failsafeSchemaEncoder
    , jsonSchemaEncoder
    , coreSchemaEncoder

    , tagNull, tagBool, tagStr, tagInt, tagFloat, tagSeq, tagMap

    , isPlainChar , isAmbiguous, defaultSchemaEncoder, setScalarStyle
    , encodeDouble, encodeBool, encodeInt
    ) where

import qualified Data.Char        as C
import qualified Data.Map         as Map
import qualified Data.Set         as Set
import qualified Data.Text        as T
import           Numeric          (readHex, readOct)
import           Text.Parsec      as P
import           Text.Parsec.Text

import           Data.YAML.Event  (ScalarStyle (..), Tag, isUntagged, mkTag, untagged)
import qualified Data.YAML.Event  as YE

import           Util

-- | Primitive scalar types as defined in YAML 1.2
data Scalar = SNull            -- ^ @tag:yaml.org,2002:null@
            | SBool   !Bool    -- ^ @tag:yaml.org,2002:bool@
            | SFloat  !Double  -- ^ @tag:yaml.org,2002:float@
            | SInt    !Integer -- ^ @tag:yaml.org,2002:int@
            | SStr    !Text    -- ^ @tag:yaml.org,2002:str@

            | SUnknown !Tag !Text -- ^ unknown/unsupported tag or untagged (thus unresolved) scalar
            deriving (Scalar -> Scalar -> Bool
(Scalar -> Scalar -> Bool)
-> (Scalar -> Scalar -> Bool) -> Eq Scalar
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Scalar -> Scalar -> Bool
$c/= :: Scalar -> Scalar -> Bool
== :: Scalar -> Scalar -> Bool
$c== :: Scalar -> Scalar -> Bool
Eq,Eq Scalar
Eq Scalar =>
(Scalar -> Scalar -> Ordering)
-> (Scalar -> Scalar -> Bool)
-> (Scalar -> Scalar -> Bool)
-> (Scalar -> Scalar -> Bool)
-> (Scalar -> Scalar -> Bool)
-> (Scalar -> Scalar -> Scalar)
-> (Scalar -> Scalar -> Scalar)
-> Ord Scalar
Scalar -> Scalar -> Bool
Scalar -> Scalar -> Ordering
Scalar -> Scalar -> Scalar
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
min :: Scalar -> Scalar -> Scalar
$cmin :: Scalar -> Scalar -> Scalar
max :: Scalar -> Scalar -> Scalar
$cmax :: Scalar -> Scalar -> Scalar
>= :: Scalar -> Scalar -> Bool
$c>= :: Scalar -> Scalar -> Bool
> :: Scalar -> Scalar -> Bool
$c> :: Scalar -> Scalar -> Bool
<= :: Scalar -> Scalar -> Bool
$c<= :: Scalar -> Scalar -> Bool
< :: Scalar -> Scalar -> Bool
$c< :: Scalar -> Scalar -> Bool
compare :: Scalar -> Scalar -> Ordering
$ccompare :: Scalar -> Scalar -> Ordering
$cp1Ord :: Eq Scalar
Ord,Int -> Scalar -> ShowS
[Scalar] -> ShowS
Scalar -> String
(Int -> Scalar -> ShowS)
-> (Scalar -> String) -> ([Scalar] -> ShowS) -> Show Scalar
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Scalar] -> ShowS
$cshowList :: [Scalar] -> ShowS
show :: Scalar -> String
$cshow :: Scalar -> String
showsPrec :: Int -> Scalar -> ShowS
$cshowsPrec :: Int -> Scalar -> ShowS
Show,(forall x. Scalar -> Rep Scalar x)
-> (forall x. Rep Scalar x -> Scalar) -> Generic Scalar
forall x. Rep Scalar x -> Scalar
forall x. Scalar -> Rep Scalar x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Scalar x -> Scalar
$cfrom :: forall x. Scalar -> Rep Scalar x
Generic)

-- | @since 0.2.0
instance NFData Scalar where
  rnf :: Scalar -> ()
rnf SNull          = ()
  rnf (SBool _)      = ()
  rnf (SFloat _)     = ()
  rnf (SInt _)       = ()
  rnf (SStr _)       = ()
  rnf (SUnknown t :: Tag
t _) = Tag -> ()
forall a. NFData a => a -> ()
rnf Tag
t

-- | Definition of a [YAML 1.2 Schema](http://yaml.org/spec/1.2/spec.html#Schema)
--
-- A YAML schema defines how implicit tags are resolved to concrete tags and how data is represented textually in YAML.
data SchemaResolver = SchemaResolver
     { SchemaResolver
-> Tag -> ScalarStyle -> Text -> Either String Scalar
schemaResolverScalar            :: Tag -> YE.ScalarStyle -> T.Text -> Either String Scalar
     , SchemaResolver -> Tag -> Either String Tag
schemaResolverSequence          :: Tag -> Either String Tag
     , SchemaResolver -> Tag -> Either String Tag
schemaResolverMapping           :: Tag -> Either String Tag
     , SchemaResolver -> Bool
schemaResolverMappingDuplicates :: Bool -- TODO: use something different from 'Bool'
     }


data ScalarTag = ScalarBangTag   -- ^ non-specific ! tag
               | ScalarQMarkTag  -- ^ non-specific ? tag
               | ScalarTag !Tag  -- ^ specific tag

-- common logic for 'schemaResolverScalar'
scalarTag :: (ScalarTag -> T.Text -> Either String Scalar)
             -> Tag -> YE.ScalarStyle -> T.Text -> Either String Scalar
scalarTag :: (ScalarTag -> Text -> Either String Scalar)
-> Tag -> ScalarStyle -> Text -> Either String Scalar
scalarTag f :: ScalarTag -> Text -> Either String Scalar
f tag :: Tag
tag sty :: ScalarStyle
sty val :: Text
val = ScalarTag -> Text -> Either String Scalar
f ScalarTag
tag' Text
val
  where
    tag' :: ScalarTag
tag' = case ScalarStyle
sty of
             YE.Plain
               | Tag
tag Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
untagged -> ScalarTag
ScalarQMarkTag -- implicit ? tag

             _ | Tag
tag Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
untagged -> ScalarTag
ScalarBangTag -- implicit ! tag
               | Tag
tag Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagBang  -> ScalarTag
ScalarBangTag -- explicit ! tag
               | Bool
otherwise       -> Tag -> ScalarTag
ScalarTag Tag
tag


-- | \"Failsafe\" schema resolver as specified
-- in [YAML 1.2 / 10.1.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2803036)
failsafeSchemaResolver :: SchemaResolver
failsafeSchemaResolver :: SchemaResolver
failsafeSchemaResolver = SchemaResolver :: (Tag -> ScalarStyle -> Text -> Either String Scalar)
-> (Tag -> Either String Tag)
-> (Tag -> Either String Tag)
-> Bool
-> SchemaResolver
SchemaResolver{..}
  where
    -- scalars
    schemaResolverScalar :: Tag -> ScalarStyle -> Text -> Either String Scalar
schemaResolverScalar = (ScalarTag -> Text -> Either String Scalar)
-> Tag -> ScalarStyle -> Text -> Either String Scalar
scalarTag ScalarTag -> Text -> Either String Scalar
forall a. ScalarTag -> Text -> Either a Scalar
go
      where
        go :: ScalarTag -> Text -> Either a Scalar
go ScalarBangTag  v :: Text
v = Scalar -> Either a Scalar
forall a b. b -> Either a b
Right (Text -> Scalar
SStr Text
v)
        go (ScalarTag t :: Tag
t)  v :: Text
v
          | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagStr     = Scalar -> Either a Scalar
forall a b. b -> Either a b
Right (Text -> Scalar
SStr Text
v)
          | Bool
otherwise       = Scalar -> Either a Scalar
forall a b. b -> Either a b
Right (Tag -> Text -> Scalar
SUnknown Tag
t Text
v)
        go ScalarQMarkTag v :: Text
v = Scalar -> Either a Scalar
forall a b. b -> Either a b
Right (Tag -> Text -> Scalar
SUnknown Tag
untagged Text
v) -- leave unresolved

    -- mappings
    schemaResolverMapping :: Tag -> Either a Tag
schemaResolverMapping t :: Tag
t
      | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagBang = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
tagMap
      | Bool
otherwise    = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
t

    schemaResolverMappingDuplicates :: Bool
schemaResolverMappingDuplicates = Bool
False

    -- sequences
    schemaResolverSequence :: Tag -> Either a Tag
schemaResolverSequence t :: Tag
t
      | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagBang = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
tagSeq
      | Bool
otherwise    = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
t

-- | Strict JSON schema resolver as specified
-- in [YAML 1.2 / 10.2.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2804356)
jsonSchemaResolver :: SchemaResolver
jsonSchemaResolver :: SchemaResolver
jsonSchemaResolver = SchemaResolver :: (Tag -> ScalarStyle -> Text -> Either String Scalar)
-> (Tag -> Either String Tag)
-> (Tag -> Either String Tag)
-> Bool
-> SchemaResolver
SchemaResolver{..}
  where
    -- scalars
    schemaResolverScalar :: Tag -> ScalarStyle -> Text -> Either String Scalar
schemaResolverScalar = (ScalarTag -> Text -> Either String Scalar)
-> Tag -> ScalarStyle -> Text -> Either String Scalar
scalarTag ScalarTag -> Text -> Either String Scalar
go
      where
        go :: ScalarTag -> Text -> Either String Scalar
go ScalarBangTag  v :: Text
v = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Text -> Scalar
SStr Text
v)
        go (ScalarTag t :: Tag
t)  v :: Text
v
          | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagStr     = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Text -> Scalar
SStr Text
v)
          | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagNull  = if Text -> Bool
isNullLiteral Text
v then Scalar -> Either String Scalar
forall a b. b -> Either a b
Right Scalar
SNull else String -> Either String Scalar
forall a b. a -> Either a b
Left ("invalid !!null " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
v)
          | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagInt   = Either String Scalar
-> (Integer -> Either String Scalar)
-> Maybe Integer
-> Either String Scalar
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Scalar
forall a b. a -> Either a b
Left (String -> Either String Scalar) -> String -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ "invalid !!int " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
v)   (Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar)
-> (Integer -> Scalar) -> Integer -> Either String Scalar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scalar
SInt)   (Maybe Integer -> Either String Scalar)
-> Maybe Integer -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Integer
jsonDecodeInt   Text
v
          | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagFloat = Either String Scalar
-> (Double -> Either String Scalar)
-> Maybe Double
-> Either String Scalar
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Scalar
forall a b. a -> Either a b
Left (String -> Either String Scalar) -> String -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ "invalid !!float " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
v) (Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar)
-> (Double -> Scalar) -> Double -> Either String Scalar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Scalar
SFloat) (Maybe Double -> Either String Scalar)
-> Maybe Double -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Double
jsonDecodeFloat Text
v
          | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagBool  = Either String Scalar
-> (Bool -> Either String Scalar)
-> Maybe Bool
-> Either String Scalar
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Scalar
forall a b. a -> Either a b
Left (String -> Either String Scalar) -> String -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ "invalid !!bool " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
v)  (Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar)
-> (Bool -> Scalar) -> Bool -> Either String Scalar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Scalar
SBool)  (Maybe Bool -> Either String Scalar)
-> Maybe Bool -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Bool
jsonDecodeBool  Text
v
          | Bool
otherwise       = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Tag -> Text -> Scalar
SUnknown Tag
t Text
v) -- unknown specific tag
        go ScalarQMarkTag v :: Text
v
          | Text -> Bool
isNullLiteral Text
v             = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right Scalar
SNull
          | Just b :: Bool
b <- Text -> Maybe Bool
jsonDecodeBool  Text
v = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar) -> Scalar -> Either String Scalar
forall a b. (a -> b) -> a -> b
$! Bool -> Scalar
SBool Bool
b
          | Just i :: Integer
i <- Text -> Maybe Integer
jsonDecodeInt   Text
v = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar) -> Scalar -> Either String Scalar
forall a b. (a -> b) -> a -> b
$! Integer -> Scalar
SInt Integer
i
          | Just f :: Double
f <- Text -> Maybe Double
jsonDecodeFloat Text
v = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar) -> Scalar -> Either String Scalar
forall a b. (a -> b) -> a -> b
$! Double -> Scalar
SFloat Double
f
          | Bool
otherwise = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Tag -> Text -> Scalar
SUnknown Tag
untagged Text
v) -- leave unresolved  -- FIXME: YAML 1.2 spec requires an error here

    isNullLiteral :: Text -> Bool
isNullLiteral = (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== "null")

    -- mappings
    schemaResolverMapping :: Tag -> Either a Tag
schemaResolverMapping t :: Tag
t
      | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagBang = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
tagMap
      | Tag -> Bool
isUntagged Tag
t = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
tagMap
      | Bool
otherwise    = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
t

    schemaResolverMappingDuplicates :: Bool
schemaResolverMappingDuplicates = Bool
False

    -- sequences
    schemaResolverSequence :: Tag -> Either a Tag
schemaResolverSequence t :: Tag
t
      | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagBang = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
tagSeq
      | Tag -> Bool
isUntagged Tag
t = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
tagSeq
      | Bool
otherwise    = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
t

-- | Core schema resolver as specified
-- in [YAML 1.2 / 10.3.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2805071)
coreSchemaResolver :: SchemaResolver
coreSchemaResolver :: SchemaResolver
coreSchemaResolver = SchemaResolver :: (Tag -> ScalarStyle -> Text -> Either String Scalar)
-> (Tag -> Either String Tag)
-> (Tag -> Either String Tag)
-> Bool
-> SchemaResolver
SchemaResolver{..}
  where
    -- scalars
    schemaResolverScalar :: Tag -> ScalarStyle -> Text -> Either String Scalar
schemaResolverScalar = (ScalarTag -> Text -> Either String Scalar)
-> Tag -> ScalarStyle -> Text -> Either String Scalar
scalarTag ScalarTag -> Text -> Either String Scalar
go
      where
        go :: ScalarTag -> Text -> Either String Scalar
go ScalarBangTag  v :: Text
v = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Text -> Scalar
SStr Text
v)
        go (ScalarTag t :: Tag
t)  v :: Text
v
          | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagStr     = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Text -> Scalar
SStr Text
v)
          | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagNull  = if Text -> Bool
isNullLiteral Text
v then Scalar -> Either String Scalar
forall a b. b -> Either a b
Right Scalar
SNull else String -> Either String Scalar
forall a b. a -> Either a b
Left ("invalid !!null " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
v)
          | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagInt   = Either String Scalar
-> (Integer -> Either String Scalar)
-> Maybe Integer
-> Either String Scalar
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Scalar
forall a b. a -> Either a b
Left (String -> Either String Scalar) -> String -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ "invalid !!int " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
v)   (Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar)
-> (Integer -> Scalar) -> Integer -> Either String Scalar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> Scalar
SInt)   (Maybe Integer -> Either String Scalar)
-> Maybe Integer -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Integer
coreDecodeInt   Text
v
          | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagFloat = Either String Scalar
-> (Double -> Either String Scalar)
-> Maybe Double
-> Either String Scalar
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Scalar
forall a b. a -> Either a b
Left (String -> Either String Scalar) -> String -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ "invalid !!float " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
v) (Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar)
-> (Double -> Scalar) -> Double -> Either String Scalar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Scalar
SFloat) (Maybe Double -> Either String Scalar)
-> Maybe Double -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Double
coreDecodeFloat Text
v
          | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagBool  = Either String Scalar
-> (Bool -> Either String Scalar)
-> Maybe Bool
-> Either String Scalar
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Either String Scalar
forall a b. a -> Either a b
Left (String -> Either String Scalar) -> String -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ "invalid !!bool " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
v)  (Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar)
-> (Bool -> Scalar) -> Bool -> Either String Scalar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Scalar
SBool)  (Maybe Bool -> Either String Scalar)
-> Maybe Bool -> Either String Scalar
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Bool
coreDecodeBool  Text
v
          | Bool
otherwise       = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Tag -> Text -> Scalar
SUnknown Tag
t Text
v) -- unknown specific tag
        go ScalarQMarkTag v :: Text
v
          | Text -> Bool
isNullLiteral Text
v             = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right Scalar
SNull
          | Just b :: Bool
b <- Text -> Maybe Bool
coreDecodeBool  Text
v = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar) -> Scalar -> Either String Scalar
forall a b. (a -> b) -> a -> b
$! Bool -> Scalar
SBool Bool
b
          | Just i :: Integer
i <- Text -> Maybe Integer
coreDecodeInt   Text
v = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar) -> Scalar -> Either String Scalar
forall a b. (a -> b) -> a -> b
$! Integer -> Scalar
SInt Integer
i
          | Just f :: Double
f <- Text -> Maybe Double
coreDecodeFloat Text
v = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Scalar -> Either String Scalar) -> Scalar -> Either String Scalar
forall a b. (a -> b) -> a -> b
$! Double -> Scalar
SFloat Double
f
          | Bool
otherwise = Scalar -> Either String Scalar
forall a b. b -> Either a b
Right (Text -> Scalar
SStr Text
v) -- map to !!str by default

    isNullLiteral :: Text -> Bool
isNullLiteral = (Text -> Set Text -> Bool) -> Set Text -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Set Text -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member ([Text] -> Set Text
forall a. Ord a => [a] -> Set a
Set.fromList [ "", "null", "NULL", "Null", "~" ])

    -- mappings
    schemaResolverMapping :: Tag -> Either a Tag
schemaResolverMapping t :: Tag
t
      | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagBang = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
tagMap
      | Tag -> Bool
isUntagged Tag
t = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
tagMap
      | Bool
otherwise    = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
t

    schemaResolverMappingDuplicates :: Bool
schemaResolverMappingDuplicates = Bool
False

    -- sequences
    schemaResolverSequence :: Tag -> Either a Tag
schemaResolverSequence t :: Tag
t
      | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagBang = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
tagSeq
      | Tag -> Bool
isUntagged Tag
t = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
tagSeq
      | Bool
otherwise    = Tag -> Either a Tag
forall a b. b -> Either a b
Right Tag
t


-- | @tag:yaml.org,2002:bool@ (JSON Schema)
jsonDecodeBool :: T.Text -> Maybe Bool
jsonDecodeBool :: Text -> Maybe Bool
jsonDecodeBool "false" = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
jsonDecodeBool "true"  = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
jsonDecodeBool _       = Maybe Bool
forall a. Maybe a
Nothing

-- | @tag:yaml.org,2002:bool@ (Core Schema)
coreDecodeBool :: T.Text -> Maybe Bool
coreDecodeBool :: Text -> Maybe Bool
coreDecodeBool = (Text -> Map Text Bool -> Maybe Bool)
-> Map Text Bool -> Text -> Maybe Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Map Text Bool -> Maybe Bool
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (Map Text Bool -> Text -> Maybe Bool)
-> Map Text Bool -> Text -> Maybe Bool
forall a b. (a -> b) -> a -> b
$
  [(Text, Bool)] -> Map Text Bool
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [ ("true", Bool
True)
               , ("True", Bool
True)
               , ("TRUE", Bool
True)
               , ("false", Bool
False)
               , ("False", Bool
False)
               , ("FALSE", Bool
False)
               ]

-- | @tag:yaml.org,2002:int@ according to JSON Schema
--
-- > 0 | -? [1-9] [0-9]*
jsonDecodeInt  :: T.Text -> Maybe Integer
jsonDecodeInt :: Text -> Maybe Integer
jsonDecodeInt t :: Text
t | Text -> Bool
T.null Text
t = Maybe Integer
forall a. Maybe a
Nothing
jsonDecodeInt "0" = Integer -> Maybe Integer
forall a. a -> Maybe a
Just 0
jsonDecodeInt t :: Text
t = do
  -- [-]? [1-9] [0-9]*
  let tabs :: Text
tabs | Text -> Text -> Bool
T.isPrefixOf "-" Text
t = Text -> Text
T.tail Text
t
           | Bool
otherwise          = Text
t

  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Text -> Bool
T.null Text
tabs))
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Text -> Char
T.head Text
tabs Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '0')
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ((Char -> Bool) -> Text -> Bool
T.all Char -> Bool
C.isDigit Text
tabs)

  String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe (Text -> String
T.unpack Text
t)

-- | @tag:yaml.org,2002:int@ according to Core Schema
--
-- > [-+]? [0-9]+         (Base 10)
-- > 0o [0-7]+            (Base 8)
-- > 0x [0-9a-fA-F]+      (Base 16)
--
coreDecodeInt :: T.Text -> Maybe Integer
coreDecodeInt :: Text -> Maybe Integer
coreDecodeInt t :: Text
t
  | Text -> Bool
T.null Text
t = Maybe Integer
forall a. Maybe a
Nothing

  -- > 0x [0-9a-fA-F]+      (Base 16)
  | Just rest :: Text
rest <- Text -> Text -> Maybe Text
T.stripPrefix "0x" Text
t
  , (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
C.isHexDigit Text
rest
  , [(j :: Integer
j,"")] <- ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readHex (Text -> String
T.unpack Text
rest)
  = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$! Integer
j

  -- 0o [0-7]+            (Base 8)
  | Just rest :: Text
rest <- Text -> Text -> Maybe Text
T.stripPrefix "0o" Text
t
  , (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
C.isOctDigit Text
rest
  , [(j :: Integer
j,"")] <- ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readOct (Text -> String
T.unpack Text
rest)
  = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$! Integer
j

  -- [-+]? [0-9]+         (Base 10)
  | (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
C.isDigit Text
t
  = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$! String -> Integer
forall a. Read a => String -> a
read (Text -> String
T.unpack Text
t)

  | Just rest :: Text
rest <- Text -> Text -> Maybe Text
T.stripPrefix "+" Text
t
  , Bool -> Bool
not (Text -> Bool
T.null Text
rest)
  , (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
C.isDigit Text
rest
  = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$! String -> Integer
forall a. Read a => String -> a
read (Text -> String
T.unpack Text
rest)

  | Just rest :: Text
rest <- Text -> Text -> Maybe Text
T.stripPrefix "-" Text
t
  , Bool -> Bool
not (Text -> Bool
T.null Text
rest)
  , (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
C.isDigit Text
rest
  = Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Integer -> Maybe Integer) -> Integer -> Maybe Integer
forall a b. (a -> b) -> a -> b
$! String -> Integer
forall a. Read a => String -> a
read (Text -> String
T.unpack Text
t)

  | Bool
otherwise = Maybe Integer
forall a. Maybe a
Nothing


-- | @tag:yaml.org,2002:float@ according to JSON Schema
--
-- > -? ( 0 | [1-9] [0-9]* ) ( \. [0-9]* )? ( [eE] [-+]? [0-9]+ )?
--
jsonDecodeFloat :: T.Text -> Maybe Double
jsonDecodeFloat :: Text -> Maybe Double
jsonDecodeFloat = (ParseError -> Maybe Double)
-> (Double -> Maybe Double)
-> Either ParseError Double
-> Maybe Double
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Double -> ParseError -> Maybe Double
forall a b. a -> b -> a
const Maybe Double
forall a. Maybe a
Nothing) Double -> Maybe Double
forall a. a -> Maybe a
Just (Either ParseError Double -> Maybe Double)
-> (Text -> Either ParseError Double) -> Text -> Maybe Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Text () Double -> String -> Text -> Either ParseError Double
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec Text () Double
float ""
  where
    float :: Parser Double
    float :: Parsec Text () Double
float = do
      -- -?
      String
p0 <- String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option "" ("-" String
-> ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '-')

      -- ( 0 | [1-9] [0-9]* )
      String
p1 <- do
        Char
d <- ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
        if (Char
d Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= '0')
          then (Char
dChar -> ShowS
forall a. a -> [a] -> [a]
:) ShowS
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
P.many ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
          else String -> ParsecT Text () Identity String
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Char
d]

      -- ( \. [0-9]* )?
      String
p2 <- String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option "" (ParsecT Text () Identity String
 -> ParsecT Text () Identity String)
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall a b. (a -> b) -> a -> b
$ (:) (Char -> ShowS)
-> ParsecT Text () Identity Char -> ParsecT Text () Identity ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '.' ParsecT Text () Identity ShowS
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option "0" (ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)

      -- ( [eE] [-+]? [0-9]+ )?
      String
p3 <- String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option "" (ParsecT Text () Identity String
 -> ParsecT Text () Identity String)
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall a b. (a -> b) -> a -> b
$ do
        ParsecT Text () Identity Char -> ParsecT Text () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char 'e' ParsecT Text () Identity Char
-> ParsecT Text () Identity Char -> ParsecT Text () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
P.<|> Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char 'E')
        String
s <- String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option "" (("-" String
-> ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '-') ParsecT Text () Identity String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
P.<|> ("" String
-> ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '+'))
        String
d <- ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

        String -> ParsecT Text () Identity String
forall (f :: * -> *) a. Applicative f => a -> f a
pure ("e" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
d)

      ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

      let t' :: String
t' = String
p0String -> ShowS
forall a. [a] -> [a] -> [a]
++String
p1String -> ShowS
forall a. [a] -> [a] -> [a]
++String
p2String -> ShowS
forall a. [a] -> [a] -> [a]
++String
p3
      Double -> Parsec Text () Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Parsec Text () Double)
-> Double -> Parsec Text () Double
forall a b. (a -> b) -> a -> b
$! String -> Double
forall a. Read a => String -> a
read String
t'

-- | @tag:yaml.org,2002:float@ according to Core Schema
--
-- > [-+]? ( \. [0-9]+ | [0-9]+ ( \. [0-9]* )? ) ( [eE] [-+]? [0-9]+ )?
--
coreDecodeFloat :: T.Text -> Maybe Double
coreDecodeFloat :: Text -> Maybe Double
coreDecodeFloat t :: Text
t
  | Just j :: Double
j <- Text -> Map Text Double -> Maybe Double
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
t Map Text Double
literals = Double -> Maybe Double
forall a. a -> Maybe a
Just Double
j -- short-cut
  | Bool
otherwise = (ParseError -> Maybe Double)
-> (Double -> Maybe Double)
-> Either ParseError Double
-> Maybe Double
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe Double -> ParseError -> Maybe Double
forall a b. a -> b -> a
const Maybe Double
forall a. Maybe a
Nothing) Double -> Maybe Double
forall a. a -> Maybe a
Just (Either ParseError Double -> Maybe Double)
-> (Text -> Either ParseError Double) -> Text -> Maybe Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Text () Double -> String -> Text -> Either ParseError Double
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec Text () Double
float "" (Text -> Maybe Double) -> Text -> Maybe Double
forall a b. (a -> b) -> a -> b
$ Text
t
  where
    float :: Parser Double
    float :: Parsec Text () Double
float = do
      -- [-+]?
      String
p0 <- String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option "" (("-" String
-> ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '-') ParsecT Text () Identity String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
P.<|> "" String
-> ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '+')

      -- ( \. [0-9]+ | [0-9]+ ( \. [0-9]* )? )
      String
p1 <- (Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '.' ParsecT Text () Identity Char
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (("0."String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit))
            ParsecT Text () Identity String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
P.<|> do String
d1  <- ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
                     String
d2  <- String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option "" (ParsecT Text () Identity String
 -> ParsecT Text () Identity String)
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall a b. (a -> b) -> a -> b
$ (:) (Char -> ShowS)
-> ParsecT Text () Identity Char -> ParsecT Text () Identity ShowS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '.' ParsecT Text () Identity ShowS
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option "0" (ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)
                     String -> ParsecT Text () Identity String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
d1String -> ShowS
forall a. [a] -> [a] -> [a]
++String
d2)

      -- ( [eE] [-+]? [0-9]+ )?
      String
p2 <- String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option "" (ParsecT Text () Identity String
 -> ParsecT Text () Identity String)
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall a b. (a -> b) -> a -> b
$ do
        ParsecT Text () Identity Char -> ParsecT Text () Identity ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char 'e' ParsecT Text () Identity Char
-> ParsecT Text () Identity Char -> ParsecT Text () Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
P.<|> Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char 'E')
        String
s <- String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option "" (("-" String
-> ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '-') ParsecT Text () Identity String
-> ParsecT Text () Identity String
-> ParsecT Text () Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
P.<|> ("" String
-> ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char '+'))
        String
d <- ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
P.many1 ParsecT Text () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

        String -> ParsecT Text () Identity String
forall (f :: * -> *) a. Applicative f => a -> f a
pure ("e" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
d)

      ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof

      let t' :: String
t' = String
p0String -> ShowS
forall a. [a] -> [a] -> [a]
++String
p1String -> ShowS
forall a. [a] -> [a] -> [a]
++String
p2

      Double -> Parsec Text () Double
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Double -> Parsec Text () Double)
-> Double -> Parsec Text () Double
forall a b. (a -> b) -> a -> b
$! String -> Double
forall a. Read a => String -> a
read String
t'

    literals :: Map Text Double
literals = [(Text, Double)] -> Map Text Double
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ ("0"   , 0)

      , (".nan", (0Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))
      , (".NaN", (0Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))
      , (".NAN", (0Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))

      , (".inf", (1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))
      , (".Inf", (1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))
      , (".INF", (1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))

      , ("+.inf", (1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))
      , ("+.Inf", (1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))
      , ("+.INF", (1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))

      , ("-.inf", (-1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))
      , ("-.Inf", (-1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))
      , ("-.INF", (-1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0))
      ]

-- | Some tags specified in YAML 1.2
tagNull, tagBool, tagStr, tagInt, tagFloat, tagSeq, tagMap, tagBang :: Tag
tagNull :: Tag
tagNull  = String -> Tag
mkTag "tag:yaml.org,2002:null"
tagStr :: Tag
tagStr   = String -> Tag
mkTag "tag:yaml.org,2002:str"
tagInt :: Tag
tagInt   = String -> Tag
mkTag "tag:yaml.org,2002:int"
tagFloat :: Tag
tagFloat = String -> Tag
mkTag "tag:yaml.org,2002:float"
tagBool :: Tag
tagBool  = String -> Tag
mkTag "tag:yaml.org,2002:bool"
tagSeq :: Tag
tagSeq   = String -> Tag
mkTag "tag:yaml.org,2002:seq"
tagMap :: Tag
tagMap   = String -> Tag
mkTag "tag:yaml.org,2002:map"
tagBang :: Tag
tagBang  = String -> Tag
mkTag "!"


-- | @since 0.2.0
data SchemaEncoder = SchemaEncoder
    { SchemaEncoder -> Scalar -> Either String (Tag, ScalarStyle, Text)
schemaEncoderScalar   :: Scalar -> Either String (Tag, ScalarStyle, T.Text)
    , SchemaEncoder -> Tag -> Either String Tag
schemaEncoderSequence :: Tag -> Either String Tag
    , SchemaEncoder -> Tag -> Either String Tag
schemaEncoderMapping  :: Tag -> Either String Tag
    }

mappingTag :: Tag -> Either String Tag
mappingTag :: Tag -> Either String Tag
mappingTag t :: Tag
t
  | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagMap  = Tag -> Either String Tag
forall a b. b -> Either a b
Right Tag
untagged
  | Bool
otherwise    = Tag -> Either String Tag
forall a b. b -> Either a b
Right Tag
t

seqTag :: Tag -> Either String Tag
seqTag :: Tag -> Either String Tag
seqTag t :: Tag
t
  | Tag
t Tag -> Tag -> Bool
forall a. Eq a => a -> a -> Bool
== Tag
tagSeq  = Tag -> Either String Tag
forall a b. b -> Either a b
Right Tag
untagged
  | Bool
otherwise    = Tag -> Either String Tag
forall a b. b -> Either a b
Right Tag
t


-- | \"Failsafe\" schema encoder as specified
-- in [YAML 1.2 / 10.1.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2803036)
--
-- @since 0.2.0
failsafeSchemaEncoder :: SchemaEncoder
failsafeSchemaEncoder :: SchemaEncoder
failsafeSchemaEncoder = SchemaEncoder :: (Scalar -> Either String (Tag, ScalarStyle, Text))
-> (Tag -> Either String Tag)
-> (Tag -> Either String Tag)
-> SchemaEncoder
SchemaEncoder{..}
  where

    schemaEncoderScalar :: Scalar -> Either String (Tag, ScalarStyle, Text)
schemaEncoderScalar s :: Scalar
s = case Scalar
s of
      SNull        -> String -> Either String (Tag, ScalarStyle, Text)
forall a b. a -> Either a b
Left  "SNull scalar type not supported in failsafeSchemaEncoder"
      SBool  _     -> String -> Either String (Tag, ScalarStyle, Text)
forall a b. a -> Either a b
Left  "SBool scalar type not supported in failsafeSchemaEncoder"
      SFloat _     -> String -> Either String (Tag, ScalarStyle, Text)
forall a b. a -> Either a b
Left  "SFloat scalar type not supported in failsafeSchemaEncoder"
      SInt   _     -> String -> Either String (Tag, ScalarStyle, Text)
forall a b. a -> Either a b
Left  "SInt scalar type not supported in failsafeSchemaEncoder"
      SStr   text :: Text
text  -> Text -> Either String (Tag, ScalarStyle, Text)
failEncodeStr Text
text
      SUnknown t :: Tag
t v :: Text
v -> (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
t, ScalarStyle
DoubleQuoted, Text
v)

    schemaEncoderMapping :: Tag -> Either String Tag
schemaEncoderMapping  = Tag -> Either String Tag
mappingTag
    schemaEncoderSequence :: Tag -> Either String Tag
schemaEncoderSequence = Tag -> Either String Tag
seqTag

-- | Strict JSON schema encoder as specified
-- in [YAML 1.2 / 10.2.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2804356)
--
-- @since 0.2.0
jsonSchemaEncoder :: SchemaEncoder
jsonSchemaEncoder :: SchemaEncoder
jsonSchemaEncoder = SchemaEncoder :: (Scalar -> Either String (Tag, ScalarStyle, Text))
-> (Tag -> Either String Tag)
-> (Tag -> Either String Tag)
-> SchemaEncoder
SchemaEncoder{..}
  where

    schemaEncoderScalar :: Scalar -> Either String (Tag, ScalarStyle, Text)
schemaEncoderScalar s :: Scalar
s = case Scalar
s of
      SNull         -> (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
Plain, "null")
      SBool  bool :: Bool
bool   -> (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
Plain, Bool -> Text
encodeBool Bool
bool)
      SFloat double :: Double
double -> (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
Plain, Double -> Text
encodeDouble Double
double)
      SInt   int :: Integer
int    -> (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
Plain, Integer -> Text
encodeInt Integer
int)
      SStr   text :: Text
text   -> Text -> Either String (Tag, ScalarStyle, Text)
jsonEncodeStr Text
text
      SUnknown _ _  -> String -> Either String (Tag, ScalarStyle, Text)
forall a b. a -> Either a b
Left  "SUnknown scalar type not supported in jsonSchemaEncoder"

    schemaEncoderMapping :: Tag -> Either String Tag
schemaEncoderMapping  = Tag -> Either String Tag
mappingTag
    schemaEncoderSequence :: Tag -> Either String Tag
schemaEncoderSequence = Tag -> Either String Tag
seqTag

-- | Core schema encoder as specified
-- in [YAML 1.2 / 10.3.2. Tag Resolution](http://yaml.org/spec/1.2/spec.html#id2805071)
--
-- @since 0.2.0
coreSchemaEncoder :: SchemaEncoder
coreSchemaEncoder :: SchemaEncoder
coreSchemaEncoder = SchemaEncoder :: (Scalar -> Either String (Tag, ScalarStyle, Text))
-> (Tag -> Either String Tag)
-> (Tag -> Either String Tag)
-> SchemaEncoder
SchemaEncoder{..}
  where

    schemaEncoderScalar :: Scalar -> Either String (Tag, ScalarStyle, Text)
schemaEncoderScalar s :: Scalar
s = case Scalar
s of
      SNull         -> (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
Plain, "null")
      SBool  bool :: Bool
bool   -> (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
Plain, Bool -> Text
encodeBool Bool
bool)
      SFloat double :: Double
double -> (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
Plain, Double -> Text
encodeDouble Double
double)
      SInt   int :: Integer
int    -> (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
Plain, Integer -> Text
encodeInt Integer
int)
      SStr   text :: Text
text   -> Text -> Either String (Tag, ScalarStyle, Text)
coreEncodeStr Text
text
      SUnknown t :: Tag
t v :: Text
v  -> (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
t, ScalarStyle
DoubleQuoted, Text
v)

    schemaEncoderMapping :: Tag -> Either String Tag
schemaEncoderMapping  = Tag -> Either String Tag
mappingTag
    schemaEncoderSequence :: Tag -> Either String Tag
schemaEncoderSequence = Tag -> Either String Tag
seqTag

-- | Encode Boolean
--
-- @since 0.2.0
encodeBool :: Bool -> T.Text
encodeBool :: Bool -> Text
encodeBool b :: Bool
b = if Bool
b then "true" else "false"

-- | Encode Double
--
-- @since 0.2.0
encodeDouble :: Double -> T.Text
encodeDouble :: Double -> Text
encodeDouble d :: Double
d
  | Double
d Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
/= Double
d      = ".nan"
  | Double
d Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== (1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0)  = ".inf"
  | Double
d Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== (-1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0) = "-.inf"
  | Bool
otherwise   = String -> Text
T.pack (String -> Text) -> (Double -> String) -> Double -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> String
forall a. Show a => a -> String
show (Double -> Text) -> Double -> Text
forall a b. (a -> b) -> a -> b
$ Double
d

-- | Encode Integer
--
-- @since 0.2.0
encodeInt :: Integer -> T.Text
encodeInt :: Integer -> Text
encodeInt = String -> Text
T.pack (String -> Text) -> (Integer -> String) -> Integer -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> String
forall a. Show a => a -> String
show


failEncodeStr :: T.Text -> Either String (Tag, ScalarStyle, T.Text)
failEncodeStr :: Text -> Either String (Tag, ScalarStyle, Text)
failEncodeStr t :: Text
t
  | Text -> Text -> Bool
T.isPrefixOf " " Text
t               = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | Text -> Char
T.last Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' '                  = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | (Char -> Bool) -> Text -> Bool
T.any (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isPlainChar) Text
t       = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | Bool
otherwise                        = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
Plain, Text
t)

jsonEncodeStr :: T.Text -> Either String (Tag, ScalarStyle, T.Text)
jsonEncodeStr :: Text -> Either String (Tag, ScalarStyle, Text)
jsonEncodeStr t :: Text
t
  | Text -> Bool
T.null Text
t                         = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | Text -> Text -> Bool
T.isPrefixOf " " Text
t               = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | Text -> Char
T.last Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' '                  = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | (Char -> Bool) -> Text -> Bool
T.any (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isPlainChar) Text
t       = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | SchemaResolver -> Text -> Bool
isAmbiguous SchemaResolver
jsonSchemaResolver Text
t = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | Bool
otherwise                        = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
Plain, Text
t)

coreEncodeStr :: T.Text -> Either String (Tag, ScalarStyle, T.Text)
coreEncodeStr :: Text -> Either String (Tag, ScalarStyle, Text)
coreEncodeStr t :: Text
t
  | Text -> Bool
T.null Text
t                         = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | Text -> Text -> Bool
T.isPrefixOf " " Text
t               = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | Text -> Char
T.last Text
t Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' '                  = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | (Char -> Bool) -> Text -> Bool
T.any (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isPlainChar) Text
t       = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | SchemaResolver -> Text -> Bool
isAmbiguous SchemaResolver
coreSchemaResolver Text
t = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
DoubleQuoted, Text
t)
  | Bool
otherwise                        = (Tag, ScalarStyle, Text) -> Either String (Tag, ScalarStyle, Text)
forall a b. b -> Either a b
Right (Tag
untagged, ScalarStyle
Plain, Text
t)

-- | These are some characters which can be used in 'Plain' 'Scalar's safely without any quotes (see <https://yaml.org/spec/1.2/spec.html#c-indicator Indicator Characters>).
--
-- __NOTE__: This does not mean that other characters (like @"\\n"@ and other special characters like @"-?:,[]{}#&*!,>%\@`\"\'"@) cannot be used in 'Plain' 'Scalar's.
--
-- @since 0.2.0
isPlainChar :: Char -> Bool
isPlainChar :: Char -> Bool
isPlainChar c :: Char
c = Char -> Bool
C.isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (" ~$^+=</;._\\" :: String)  -- not $ c `elem` "\n-?:,[]{}#&*!,>%@`\\'\""

-- | Returns True if the string can be decoded by the given 'SchemaResolver'
-- into a 'Scalar' which is not a of type 'SStr'.
--
-- >>> isAmbiguous coreSchemaResolver "true"
-- True
--
-- >>> isAmbiguous failSchemaResolver "true"
-- False
--
-- @since 0.2.0
isAmbiguous :: SchemaResolver -> T.Text -> Bool
isAmbiguous :: SchemaResolver -> Text -> Bool
isAmbiguous SchemaResolver{..} t :: Text
t = case Tag -> ScalarStyle -> Text -> Either String Scalar
schemaResolverScalar Tag
untagged ScalarStyle
Plain Text
t of
  Left err :: String
err        -> String -> Bool
forall a. HasCallStack => String -> a
error String
err
  Right (SStr _ ) -> Bool
False
  Right _         -> Bool
True

-- | According to YAML 1.2 'coreSchemaEncoder' is the default 'SchemaEncoder'
--
-- By default, 'Scalar's are encoded as follows:
--
-- * String which are made of Plain Characters (see 'isPlainChar'), unambiguous (see 'isAmbiguous') and do not contain any leading/trailing spaces are encoded as 'Plain' 'Scalar'.
--
-- * Rest of the strings are encoded in DoubleQuotes
--
-- * Booleans are encoded using 'encodeBool'
--
-- * Double values are encoded using 'encodeDouble'
--
-- * Integral values are encoded using 'encodeInt'
--
-- @since 0.2.0
defaultSchemaEncoder :: SchemaEncoder
defaultSchemaEncoder :: SchemaEncoder
defaultSchemaEncoder = SchemaEncoder
coreSchemaEncoder

-- | Set the 'Scalar' style in the encoded YAML. This is a function that decides
-- for each 'Scalar' the type of YAML string to output.
--
-- __WARNING__: You must ensure that special strings (like @"true"@\/@"false"@\/@"null"@\/@"1234"@) are not encoded with the 'Plain' style, because
-- then they will be decoded as boolean, null or numeric values. You can use 'isAmbiguous' to detect them.
--
-- __NOTE__: For different 'SchemaResolver's, different strings are ambiguous. For example, @"true"@ is not ambiguous for 'failsafeSchemaResolver'.
--
-- @since 0.2.0
setScalarStyle :: (Scalar -> Either String (Tag, ScalarStyle, T.Text)) -> SchemaEncoder -> SchemaEncoder
setScalarStyle :: (Scalar -> Either String (Tag, ScalarStyle, Text))
-> SchemaEncoder -> SchemaEncoder
setScalarStyle customScalarEncoder :: Scalar -> Either String (Tag, ScalarStyle, Text)
customScalarEncoder encoder :: SchemaEncoder
encoder = SchemaEncoder
encoder { schemaEncoderScalar :: Scalar -> Either String (Tag, ScalarStyle, Text)
schemaEncoderScalar = Scalar -> Either String (Tag, ScalarStyle, Text)
customScalarEncoder }