HsYAML-0.2.1.5: src/Data/YAML/Schema/Internal.hs
{-# 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 (Eq,Ord,Show,Generic)
-- | @since 0.2.0
instance NFData Scalar where
rnf SNull = ()
rnf (SBool _) = ()
rnf (SFloat _) = ()
rnf (SInt _) = ()
rnf (SStr _) = ()
rnf (SUnknown t _) = rnf 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
{ schemaResolverScalar :: Tag -> YE.ScalarStyle -> T.Text -> Either String Scalar
, schemaResolverSequence :: Tag -> Either String Tag
, schemaResolverMapping :: Tag -> Either String Tag
, 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 f tag sty val = f tag' val
where
tag' = case sty of
YE.Plain
| tag == untagged -> ScalarQMarkTag -- implicit ? tag
_ | tag == untagged -> ScalarBangTag -- implicit ! tag
| tag == tagBang -> ScalarBangTag -- explicit ! tag
| otherwise -> ScalarTag 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{..}
where
-- scalars
schemaResolverScalar = scalarTag go
where
go ScalarBangTag v = Right (SStr v)
go (ScalarTag t) v
| t == tagStr = Right (SStr v)
| otherwise = Right (SUnknown t v)
go ScalarQMarkTag v = Right (SUnknown untagged v) -- leave unresolved
-- mappings
schemaResolverMapping t
| t == tagBang = Right tagMap
| otherwise = Right t
schemaResolverMappingDuplicates = False
-- sequences
schemaResolverSequence t
| t == tagBang = Right tagSeq
| otherwise = Right 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{..}
where
-- scalars
schemaResolverScalar = scalarTag go
where
go ScalarBangTag v = Right (SStr v)
go (ScalarTag t) v
| t == tagStr = Right (SStr v)
| t == tagNull = if isNullLiteral v then Right SNull else Left ("invalid !!null " ++ show v)
| t == tagInt = maybe (Left $ "invalid !!int " ++ show v) (Right . SInt) $ jsonDecodeInt v
| t == tagFloat = maybe (Left $ "invalid !!float " ++ show v) (Right . SFloat) $ jsonDecodeFloat v
| t == tagBool = maybe (Left $ "invalid !!bool " ++ show v) (Right . SBool) $ jsonDecodeBool v
| otherwise = Right (SUnknown t v) -- unknown specific tag
go ScalarQMarkTag v
| isNullLiteral v = Right SNull
| Just b <- jsonDecodeBool v = Right $! SBool b
| Just i <- jsonDecodeInt v = Right $! SInt i
| Just f <- jsonDecodeFloat v = Right $! SFloat f
| otherwise = Right (SUnknown untagged v) -- leave unresolved -- FIXME: YAML 1.2 spec requires an error here
isNullLiteral = (== "null")
-- mappings
schemaResolverMapping t
| t == tagBang = Right tagMap
| isUntagged t = Right tagMap
| otherwise = Right t
schemaResolverMappingDuplicates = False
-- sequences
schemaResolverSequence t
| t == tagBang = Right tagSeq
| isUntagged t = Right tagSeq
| otherwise = Right 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{..}
where
-- scalars
schemaResolverScalar = scalarTag go
where
go ScalarBangTag v = Right (SStr v)
go (ScalarTag t) v
| t == tagStr = Right (SStr v)
| t == tagNull = if isNullLiteral v then Right SNull else Left ("invalid !!null " ++ show v)
| t == tagInt = maybe (Left $ "invalid !!int " ++ show v) (Right . SInt) $ coreDecodeInt v
| t == tagFloat = maybe (Left $ "invalid !!float " ++ show v) (Right . SFloat) $ coreDecodeFloat v
| t == tagBool = maybe (Left $ "invalid !!bool " ++ show v) (Right . SBool) $ coreDecodeBool v
| otherwise = Right (SUnknown t v) -- unknown specific tag
go ScalarQMarkTag v
| isNullLiteral v = Right SNull
| Just b <- coreDecodeBool v = Right $! SBool b
| Just i <- coreDecodeInt v = Right $! SInt i
| Just f <- coreDecodeFloat v = Right $! SFloat f
| otherwise = Right (SStr v) -- map to !!str by default
isNullLiteral = flip Set.member (Set.fromList [ "", "null", "NULL", "Null", "~" ])
-- mappings
schemaResolverMapping t
| t == tagBang = Right tagMap
| isUntagged t = Right tagMap
| otherwise = Right t
schemaResolverMappingDuplicates = False
-- sequences
schemaResolverSequence t
| t == tagBang = Right tagSeq
| isUntagged t = Right tagSeq
| otherwise = Right t
-- | @tag:yaml.org,2002:bool@ (JSON Schema)
jsonDecodeBool :: T.Text -> Maybe Bool
jsonDecodeBool "false" = Just False
jsonDecodeBool "true" = Just True
jsonDecodeBool _ = Nothing
-- | @tag:yaml.org,2002:bool@ (Core Schema)
coreDecodeBool :: T.Text -> Maybe Bool
coreDecodeBool = flip Map.lookup $
Map.fromList [ ("true", True)
, ("True", True)
, ("TRUE", True)
, ("false", False)
, ("False", False)
, ("FALSE", False)
]
-- | @tag:yaml.org,2002:int@ according to JSON Schema
--
-- > 0 | -? [1-9] [0-9]*
jsonDecodeInt :: T.Text -> Maybe Integer
jsonDecodeInt t | T.null t = Nothing
jsonDecodeInt "0" = Just 0
jsonDecodeInt t = do
-- [-]? [1-9] [0-9]*
let tabs | T.isPrefixOf "-" t = T.tail t
| otherwise = t
guard (not (T.null tabs))
guard (T.head tabs /= '0')
guard (T.all C.isDigit tabs)
readMaybe (T.unpack 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 t
| T.null t = Nothing
-- > 0x [0-9a-fA-F]+ (Base 16)
| Just rest <- T.stripPrefix "0x" t
, T.all C.isHexDigit rest
, [(j,"")] <- readHex (T.unpack rest)
= Just $! j
-- 0o [0-7]+ (Base 8)
| Just rest <- T.stripPrefix "0o" t
, T.all C.isOctDigit rest
, [(j,"")] <- readOct (T.unpack rest)
= Just $! j
-- [-+]? [0-9]+ (Base 10)
| T.all C.isDigit t
= Just $! read (T.unpack t)
| Just rest <- T.stripPrefix "+" t
, not (T.null rest)
, T.all C.isDigit rest
= Just $! read (T.unpack rest)
| Just rest <- T.stripPrefix "-" t
, not (T.null rest)
, T.all C.isDigit rest
= Just $! read (T.unpack t)
| otherwise = 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 = either (const Nothing) Just . parse float ""
where
float :: Parser Double
float = do
-- -?
p0 <- option "" ("-" <$ char '-')
-- ( 0 | [1-9] [0-9]* )
p1 <- do
d <- digit
if (d /= '0')
then (d:) <$> P.many digit
else pure [d]
-- ( \. [0-9]* )?
p2 <- option "" $ (:) <$> char '.' <*> option "0" (many1 digit)
-- ( [eE] [-+]? [0-9]+ )?
p3 <- option "" $ do
void (char 'e' P.<|> char 'E')
s <- option "" (("-" <$ char '-') P.<|> ("" <$ char '+'))
d <- P.many1 digit
pure ("e" ++ s ++ d)
eof
let t' = p0++p1++p2++p3
pure $! read 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 t
| Just j <- Map.lookup t literals = Just j -- short-cut
| otherwise = either (const Nothing) Just . parse float "" $ t
where
float :: Parser Double
float = do
-- [-+]?
p0 <- option "" (("-" <$ char '-') P.<|> "" <$ char '+')
-- ( \. [0-9]+ | [0-9]+ ( \. [0-9]* )? )
p1 <- (char '.' *> (("0."++) <$> many1 digit))
P.<|> do d1 <- many1 digit
d2 <- option "" $ (:) <$> char '.' <*> option "0" (many1 digit)
pure (d1++d2)
-- ( [eE] [-+]? [0-9]+ )?
p2 <- option "" $ do
void (char 'e' P.<|> char 'E')
s <- option "" (("-" <$ char '-') P.<|> ("" <$ char '+'))
d <- P.many1 digit
pure ("e" ++ s ++ d)
eof
let t' = p0++p1++p2
pure $! read t'
literals = Map.fromList
[ ("0" , 0)
, (".nan", (0/0))
, (".NaN", (0/0))
, (".NAN", (0/0))
, (".inf", (1/0))
, (".Inf", (1/0))
, (".INF", (1/0))
, ("+.inf", (1/0))
, ("+.Inf", (1/0))
, ("+.INF", (1/0))
, ("-.inf", (-1/0))
, ("-.Inf", (-1/0))
, ("-.INF", (-1/0))
]
-- | Some tags specified in YAML 1.2
tagNull, tagBool, tagStr, tagInt, tagFloat, tagSeq, tagMap, tagBang :: Tag
tagNull = mkTag "tag:yaml.org,2002:null"
tagStr = mkTag "tag:yaml.org,2002:str"
tagInt = mkTag "tag:yaml.org,2002:int"
tagFloat = mkTag "tag:yaml.org,2002:float"
tagBool = mkTag "tag:yaml.org,2002:bool"
tagSeq = mkTag "tag:yaml.org,2002:seq"
tagMap = mkTag "tag:yaml.org,2002:map"
tagBang = mkTag "!"
-- | @since 0.2.0
data SchemaEncoder = SchemaEncoder
{ schemaEncoderScalar :: Scalar -> Either String (Tag, ScalarStyle, T.Text)
, schemaEncoderSequence :: Tag -> Either String Tag
, schemaEncoderMapping :: Tag -> Either String Tag
}
mappingTag :: Tag -> Either String Tag
mappingTag t
| t == tagMap = Right untagged
| otherwise = Right t
seqTag :: Tag -> Either String Tag
seqTag t
| t == tagSeq = Right untagged
| otherwise = Right 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{..}
where
schemaEncoderScalar s = case s of
SNull -> Left "SNull scalar type not supported in failsafeSchemaEncoder"
SBool _ -> Left "SBool scalar type not supported in failsafeSchemaEncoder"
SFloat _ -> Left "SFloat scalar type not supported in failsafeSchemaEncoder"
SInt _ -> Left "SInt scalar type not supported in failsafeSchemaEncoder"
SStr text -> failEncodeStr text
SUnknown t v -> Right (t, DoubleQuoted, v)
schemaEncoderMapping = mappingTag
schemaEncoderSequence = 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{..}
where
schemaEncoderScalar s = case s of
SNull -> Right (untagged, Plain, "null")
SBool bool -> Right (untagged, Plain, encodeBool bool)
SFloat double -> Right (untagged, Plain, encodeDouble double)
SInt int -> Right (untagged, Plain, encodeInt int)
SStr text -> jsonEncodeStr text
SUnknown _ _ -> Left "SUnknown scalar type not supported in jsonSchemaEncoder"
schemaEncoderMapping = mappingTag
schemaEncoderSequence = 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{..}
where
schemaEncoderScalar s = case s of
SNull -> Right (untagged, Plain, "null")
SBool bool -> Right (untagged, Plain, encodeBool bool)
SFloat double -> Right (untagged, Plain, encodeDouble double)
SInt int -> Right (untagged, Plain, encodeInt int)
SStr text -> coreEncodeStr text
SUnknown t v -> Right (t, DoubleQuoted, v)
schemaEncoderMapping = mappingTag
schemaEncoderSequence = seqTag
-- | Encode Boolean
--
-- @since 0.2.0
encodeBool :: Bool -> T.Text
encodeBool b = if b then "true" else "false"
-- | Encode Double
--
-- @since 0.2.0
encodeDouble :: Double -> T.Text
encodeDouble d
| d /= d = ".nan"
| d == (1/0) = ".inf"
| d == (-1/0) = "-.inf"
| otherwise = T.pack . show $ d
-- | Encode Integer
--
-- @since 0.2.0
encodeInt :: Integer -> T.Text
encodeInt = T.pack . show
failEncodeStr :: T.Text -> Either String (Tag, ScalarStyle, T.Text)
failEncodeStr t
| T.isPrefixOf " " t = Right (untagged, DoubleQuoted, t)
| T.last t == ' ' = Right (untagged, DoubleQuoted, t)
| T.any (not. isPlainChar) t = Right (untagged, DoubleQuoted, t)
| otherwise = Right (untagged, Plain, t)
jsonEncodeStr :: T.Text -> Either String (Tag, ScalarStyle, T.Text)
jsonEncodeStr t
| T.null t = Right (untagged, DoubleQuoted, t)
| T.isPrefixOf " " t = Right (untagged, DoubleQuoted, t)
| T.last t == ' ' = Right (untagged, DoubleQuoted, t)
| T.any (not. isPlainChar) t = Right (untagged, DoubleQuoted, t)
| isAmbiguous jsonSchemaResolver t = Right (untagged, DoubleQuoted, t)
| otherwise = Right (untagged, Plain, t)
coreEncodeStr :: T.Text -> Either String (Tag, ScalarStyle, T.Text)
coreEncodeStr t
| T.null t = Right (untagged, DoubleQuoted, t)
| T.isPrefixOf " " t = Right (untagged, DoubleQuoted, t)
| T.last t == ' ' = Right (untagged, DoubleQuoted, t)
| T.any (not. isPlainChar) t = Right (untagged, DoubleQuoted, t)
| isAmbiguous coreSchemaResolver t = Right (untagged, DoubleQuoted, t)
| otherwise = Right (untagged, Plain, 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 c = C.isAlphaNum c || c `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{..} t = case schemaResolverScalar untagged Plain t of
Left err -> error err
Right (SStr _ ) -> False
Right _ -> 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 = 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 customScalarEncoder encoder = encoder { schemaEncoderScalar = customScalarEncoder }