diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,10 +1,110 @@ -### 0.1.1.2 +### 0.2.1.5 +_2025-03-11, Andreas Abel_ + +* Drop support for old dependencies predating LTS 7.24 (GHC 8.0). +* Relax bound on `containers`. +* Tested with GHC 8.0 - 9.12.1. + +### 0.2.1.4 + +_2024-04-25, Andreas Abel_ + +* Drop support for GHC 7. +* Testsuite: relax lower bounds to accommodate LTS 11.22 (GHC 8.2) for new Stack CI. +* Tested with GHC 8.0 - 9.10.0 (alpha3). + +### 0.2.1.3 + +_2023-10-14, Andreas Abel_ + +* Pacify `x-partial` warning of GHC 9.8. +* Tested with GHC 7.10 - 9.8.1. + +### 0.2.1.2 + +_2023-09-29, Andreas Abel_ + +* Add `default-extensions: TypeOperators` to silence warning under GHC ≥ 9.4. +* Support latest versions of dependencies. +* Tested with GHC 7.10 - 9.8.0. + +### 0.2.1.1 + +_2022-05-11, Andreas Abel_ + +* Compatibility with `mtl-2.3`. +* Tested with GHC 7.4 - 9.2. + +### 0.2.1.0 + +_2019-10-06, Herbert Valerio Riedel_ + +* Define `Functor Doc` instance ([#33](https://github.com/haskell-hvr/HsYAML/issues/33)) +* New `withScalar` function and also define `ToYAML Scalar` and `FromYAML Scalar` instances +* Export `Pair` `type` synonym from `Data.YAML` ([#31](https://github.com/haskell-hvr/HsYAML/issues/31)) +* New `Data.YAML.prettyPosWithSource` function for pretty-printing source locations (i.e. `Pos` values) +* Add export `docRoot :: Doc n -> n` field accessor for convenience ([#32](https://github.com/haskell-hvr/HsYAML/issues/32)) + +## 0.2.0.0 + +This release incorporates the work from [Vijay Tadikamalla's GSOC 2019 Project](https://vijayphoenix.github.io/blog/gsoc-the-conclusion/). +Highlights of this major release include support for emitting YAML as +well as providing direct access to source locations throughout the +parsing pipeline for improved error reporting. + +* Changes in `Data.YAML` module + * YAML 1.2 Schema encoders ([#21](https://github.com/haskell-hvr/HsYAML/pull/21)) + * New `ToYAML` class for encoding Haskell Data-types from which YAML nodes can be constructed ([#20](https://github.com/haskell-hvr/HsYAML/pull/20)) + * New functions like `encodeNode`, `encodeNode'` for constructing AST + * New functions like `encode`, `encode1`, `encodeStrict`, `encode1Strict` for supporting typeclass-based dumping + * Some ToYAML instances and other api + * Modify `typeMismatch` function to show error source location in error messages ([#19](https://github.com/haskell-hvr/HsYAML/pull/19)) + * Provide location-aware `failAtNode` alternative to `fail` + +* Changes in `Data.YAML.Event` module + * Preserve and round-trip Comments at Event level([#24](https://github.com/haskell-hvr/HsYAML/pull/24)) + * New `Comment` Event to preserve comments while parsing + * Some additional implementations to preserve and round-trip comments + * Fix issue [#22](https://github.com/haskell-hvr/HsYAML/issues/22) + * New `EvPos` type for recording event and their corresponding position ([#19](https://github.com/haskell-hvr/HsYAML/pull/19)) + * Preserve Flow Mapping and Flow sequence ([#18](https://github.com/haskell-hvr/HsYAML/pull/18)) + * Features to preserve Literal/Folded ScalarStyle ([#15](https://github.com/haskell-hvr/HsYAML/pull/15)) + * New `Chomp` type denoting Block Chomping Indicator + * New `IndentOfs` type denoting Block Indentation Indicator + * New `NodeStyle` type denoting flow/block style + * `Event(SequenceStart,MappingStart)` constructors now record `NodeStyle` + * `Style` type renamed to `ScalarType` + * New `writeEvents` and `writeEventsText` function + * `Event(DocumentStart)` now records YAML directive + * Event parser now rejects duplicate/unsupported YAML/TAG + directives as mandated by the YAML 1.2 specification + +* Move some schema related definitions from `Data.YAML` into the new `Data.YAML.Schema` module + +* Make `decode`, `decode1`, `decodeStrict`, `decode1Strict`, `decodeNode`, and `decodeNode'` treat + duplicate keys (under the respective YAML schema) in YAML mappings + as a loader-error (controllable via new + `schemaResolverMappingDuplicates` schema property) + +* Define `Generic` and `NFData` instances for most types + +* Fix `X38W` testcase ([#13](https://github.com/haskell-hvr/HsYAML/issues/13), [#14](https://github.com/haskell-hvr/HsYAML/issues/14)) + +--- + +#### 0.1.1.3 + +* Fix bug in float regexp being too lax in the JSON and Core schema ([#7](https://github.com/hvr/HsYAML/issues/7)) +* Remove dependency on `dlist` + +#### 0.1.1.2 + * Tolerate BOM at *each* `l-document-prefix` (rather than only at the first one encountered in a YAML stream) * Workaround broken `mtl-2.2.2` bundled in GHC 8.4.1 ([#1](https://github.com/hvr/HsYAML/issues/1)) * Relax to GPL-2.0-or-later -### 0.1.1.1 +#### 0.1.1.1 * Reject (illegal) non-scalar code-points in UTF-32 streams * Tolerate BOM at start of stream diff --git a/HsYAML.cabal b/HsYAML.cabal --- a/HsYAML.cabal +++ b/HsYAML.cabal @@ -1,40 +1,57 @@ cabal-version: 1.14 name: HsYAML -version: 0.1.1.2 +version: 0.2.1.5 -synopsis: Pure Haskell YAML 1.2 parser -homepage: https://github.com/hvr/HsYAML -bug-reports: https://github.com/hvr/HsYAML/issues +synopsis: Pure Haskell YAML 1.2 processor +homepage: https://github.com/haskell-hvr/HsYAML +bug-reports: https://github.com/haskell-hvr/HsYAML/issues license: GPL-2 X-SPDX-License-Identifier: GPL-2.0-or-later license-files: LICENSE.GPLv2 LICENSE.GPLv3 author: Herbert Valerio Riedel -maintainer: hvr@gnu.org +maintainer: https://github.com/haskell-hvr/HsYAML copyright: 2015-2018 Herbert Valerio Riedel , 2007-2008 Oren Ben-Kiki category: Text build-type: Simple -tested-with: GHC==8.4.3, GHC==8.4.1, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2 +tested-with: + GHC == 9.12.1 + GHC == 9.10.1 + GHC == 9.8.4 + GHC == 9.6.6 + GHC == 9.4.8 + GHC == 9.2.8 + GHC == 9.0.2 + GHC == 8.10.7 + GHC == 8.8.4 + GHC == 8.6.5 + GHC == 8.4.4 + GHC == 8.2.2 + GHC == 8.0.2 description: - @HsYAML@ is a [YAML 1.2](http://yaml.org/spec/1.2/spec.html) parser implementation for Haskell. + @HsYAML@ is a [YAML 1.2](http://yaml.org/spec/1.2/spec.html) processor, i.e. a library for parsing and serializing YAML documents. + . Features of @HsYAML@ include: . * Pure Haskell implementation with small dependency footprint and emphasis on strict compliance with the [YAML 1.2 specification](http://yaml.org/spec/1.2/spec.html). * Direct decoding to native Haskell types via (@aeson@-inspired) typeclass-based API (see "Data.YAML"). + * Allows round-tripping while preserving ordering, anchors, and comments at Event-level. * Support for constructing custom YAML node graph representation (including support for cyclic YAML data structures). - * Support for the standard (untyped) /Failsafe/, (strict) /JSON/, and (flexible) /Core/ \"schemas\" providing implicit typing rules as defined in the YAML 1.2 specification (including support for user-defined custom schemas). + * Support for the standard (untyped) /Failsafe/, (strict) /JSON/, and (flexible) /Core/ \"schemas\" providing implicit typing rules as defined in the YAML 1.2 specification (including support for user-defined custom schemas; see "Data.YAML.Schema"). + * Support for emitting YAML using /Failsafe/, (strict) /JSON/, and (flexible) /Core/ \"schemas\" (including support for user-defined custom encoding schemas; see "Data.YAML.Schema"). * Event-based API resembling LibYAML's Event-based API (see "Data.YAML.Event"). * Low-level API access to lexical token-based scanner (see "Data.YAML.Token"). . + See also the package which allows to decode and encode YAML by leveraging @aeson@'s 'FromJSON' and 'ToJSON' instances. extra-source-files: ChangeLog.md source-repository head type: git - location: https://github.com/hvr/HsYAML.git + location: https://github.com/haskell-hvr/HsYAML.git flag exe description: Enable @exe:yaml-test@ component @@ -44,15 +61,24 @@ library hs-source-dirs: src exposed-modules: Data.YAML + , Data.YAML.Schema , Data.YAML.Event , Data.YAML.Token other-modules: Data.YAML.Loader - , Data.YAML.Schema + , Data.YAML.Dumper + , Data.YAML.Internal + , Data.YAML.Event.Internal + , Data.YAML.Event.Writer + , Data.YAML.Pos + , Data.YAML.Schema.Internal , Data.YAML.Token.Encoding , Util + , Data.DList default-language: Haskell2010 - other-extensions: FlexibleContexts + default-extensions: TypeOperators + other-extensions: DeriveGeneric + FlexibleContexts FlexibleInstances FunctionalDependencies MultiParamTypeClasses @@ -65,21 +91,20 @@ Trustworthy TypeSynonymInstances - build-depends: base >=4.5 && <4.12 - , bytestring >=0.9 && <0.11 - , dlist >=0.8 && <0.9 - , containers >=0.4.2 && <0.6 - , text >=1.2.3 && <1.3 - , mtl >=2.2.1 && <2.3 - , parsec >=3.1.13.0 && < 3.2 - - if !impl(ghc >= 8.0) - build-depends: fail >=4.9.0.0 && <4.10 - - if !impl(ghc >= 7.10) - build-depends: nats >=1.1.2 && <1.2 + build-depends: + -- Lower bounds chosen from LTS-7.24 (GHC 8.0.1) + base >= 4.9 && < 5 + , bytestring >= 0.10.8.1 && < 0.13 + , containers >= 0.5.7.1 && < 1 + , deepseq >= 1.4.2.0 && < 1.6 + , text >= 1.2.3 && < 2.2 + , mtl >= 2.2.1 && < 2.4 + , parsec >= 3.1.13.0 && < 3.2 + , transformers >= 0.5.2.0 && < 0.7 - ghc-options: -Wall + ghc-options: + -Wall + -Wcompat executable yaml-test hs-source-dirs: src-test @@ -91,17 +116,38 @@ if flag(exe) build-depends: HsYAML -- inherited constraints - , bytestring >= 0.10.8.0 + , bytestring , base , text , containers , mtl -- non-inherited - , megaparsec >= 6.5.0 && < 6.6 + , megaparsec >= 7.0 && < 10 , microaeson == 0.1.* - , filepath == 1.4.* + , filepath >= 1.4 && < 1.6 , directory >= 1.2 && < 1.4 else buildable: False ghc-options: -rtsopts + +test-suite tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Tests.hs + + ghc-options: -rtsopts + + build-depends: HsYAML + -- inherited constraints + , bytestring >= 0.10.8.0 + , base + , text + , containers + , mtl + -- non-inherited + -- lower bounds chosen from lts-11.22 (GHC 8.2) + , QuickCheck >= 2.10.1 && < 2.16 + , tasty >= 1.0.1.1 && < 1.6 + , tasty-quickcheck >= 0.9.2 && < 1 diff --git a/src-test/Main.hs b/src-test/Main.hs --- a/src-test/Main.hs +++ b/src-test/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -32,6 +33,7 @@ import Data.YAML as Y import Data.YAML.Event as YE +import Data.YAML.Schema as Y import qualified Data.YAML.Token as YT import qualified TML @@ -47,20 +49,70 @@ hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command" exitFailure + ("yaml2event-pos":args') + | null args' -> cmdYaml2EventPos + | otherwise -> do + hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command" + exitFailure + + ("yaml2yaml-validate":args') + | null args' -> cmdYaml2YamlVal + | otherwise -> do + hPutStrLn stderr "unexpected arguments passed to check sub-command" + exitFailure + + ("yaml2event0":args') + | null args' -> cmdYaml2Event0 + | otherwise -> do + hPutStrLn stderr "unexpected arguments passed to yaml2event0 sub-command" + exitFailure + ("yaml2token":args') | null args' -> cmdYaml2Token | otherwise -> do hPutStrLn stderr "unexpected arguments passed to yaml2token sub-command" exitFailure + ("yaml2token0":args') + | null args' -> cmdYaml2Token0 + | otherwise -> do + hPutStrLn stderr "unexpected arguments passed to yaml2token0 sub-command" + exitFailure + ("yaml2json":args') | null args' -> cmdYaml2Json | otherwise -> do hPutStrLn stderr "unexpected arguments passed to yaml2json sub-command" exitFailure + ("yaml2yaml":args') + | null args' -> cmdYaml2Yaml + | otherwise -> do + hPutStrLn stderr "unexpected arguments passed to yaml2yaml sub-command" + exitFailure + + ("yaml2yaml-":args') + | null args' -> cmdYaml2Yaml' + | otherwise -> do + hPutStrLn stderr "unexpected arguments passed to yaml2yaml- sub-command" + exitFailure + + ("yaml2yaml-dump": args') + | null args' -> cmdDumpYAML + | otherwise -> do + hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command" + exitFailure + + ("yaml2node":args') + | null args' -> cmdPrintNode + | otherwise -> do + hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command" + exitFailure + ("run-tml":args') -> cmdRunTml args' + ("run-tml2":args') -> cmdRunTml' args' -- Temp function for check comment round-trip + ("testml-compiler":args') -> cmdTestmlCompiler args' _ -> do @@ -68,10 +120,20 @@ hPutStrLn stderr "" hPutStrLn stderr "Commands:" hPutStrLn stderr "" - hPutStrLn stderr " yaml2event reads YAML stream from STDIN and dumps events to STDOUT" - hPutStrLn stderr " yaml2json reads YAML stream from STDIN and dumps JSON to STDOUT" - hPutStrLn stderr " run-tml run/validate YAML-specific .tml file(s)" - hPutStrLn stderr " testml-compiler emulate testml-compiler" + hPutStrLn stderr " yaml2token reads YAML stream from STDIN and dumps tokens to STDOUT" + hPutStrLn stderr " yaml2token0 reads YAML stream from STDIN and prints count of tokens to STDOUT" + hPutStrLn stderr " yaml2event reads YAML stream from STDIN and dumps events to STDOUT" + hPutStrLn stderr " yaml2event0 reads YAML stream from STDIN and prints count of events to STDOUT" + hPutStrLn stderr " yaml2event-pos reads YAML stream from STDIN and dumps events & position to STDOUT" + hPutStrLn stderr " yaml2json reads YAML stream from STDIN and dumps JSON to STDOUT" + hPutStrLn stderr " yaml2yaml reads YAML stream from STDIN and dumps YAML to STDOUT (non-streaming version)" + hPutStrLn stderr " yaml2yaml- reads YAML stream from STDIN and dumps YAML to STDOUT (streaming version)" + hPutStrLn stderr " yaml2yaml-validate reads YAML stream from STDIN and dumps YAML to STDOUT and also outputs the no. of differences and differences after a round-trip" + hPutStrLn stderr " yaml2node reads YAML stream from STDIN and dumps YAML Nodes to STDOUT" + hPutStrLn stderr " yaml2yaml-dump reads YAML stream from STDIN and dumps YAML to STDOUT after a complete round-trip" + hPutStrLn stderr " run-tml run/validate YAML-specific .tml file(s)" + hPutStrLn stderr " run-tml2 run/validate YAML-specific .tml file(s) while preserving comments" + hPutStrLn stderr " testml-compiler emulate testml-compiler" exitFailure @@ -84,24 +146,115 @@ forM_ lgrp $ \YT.Token{..} -> do let tText' | null tText = "" | any (== ' ') tText = replicate tLineChar ' ' ++ show tText - | otherwise = replicate (tLineChar+1) ' ' ++ tail (init (show tText)) + | otherwise = replicate (tLineChar+1) ' ' ++ drop 1 (init (show tText)) hPutStrLn stdout $ printf ":%d:%d: %-15s| %s" tLine tLineChar (show tCode) tText' hPutStrLn stdout "" hFlush stdout +cmdYaml2Token0 :: IO () +cmdYaml2Token0 = do + inYamlDat <- BS.L.getContents + print (length (YT.tokenize inYamlDat False)) + +cmdYaml2Yaml :: IO () +cmdYaml2Yaml = do + inYamlDat <- BS.L.getContents + case sequence $ parseEvents inYamlDat of + Left (ofs,msg) -> do + hPutStrLn stderr ("Parsing error near byte offset " ++ show ofs ++ if null msg then "" else " (" ++ msg ++ ")") + exitFailure + Right events -> do + BS.L.hPutStr stdout (writeEvents YT.UTF8 (map eEvent events)) + hFlush stdout + +-- lazy streaming version +cmdYaml2Yaml' :: IO () +cmdYaml2Yaml' = do + inYamlDat <- BS.L.getContents + BS.L.hPutStr stdout $ writeEvents YT.UTF8 $ parseEvents' inYamlDat + hFlush stdout + where + parseEvents' = map (either (\(ofs,msg) -> error ("parsing error near byte offset " ++ show ofs ++ " (" ++ msg ++ ")")) (\evPos -> eEvent evPos)). filter (not. isComment). parseEvents + cmdYaml2Event :: IO () cmdYaml2Event = do inYamlDat <- BS.L.getContents forM_ (parseEvents inYamlDat) $ \ev -> case ev of Left (ofs,msg) -> do - case msg of - "" -> hPutStrLn stderr ("parsing error near byte offset " ++ show ofs) - _ -> hPutStrLn stderr ("parsing error near byte offset " ++ show ofs ++ " (" ++ msg ++ ")") + hPutStrLn stderr ("Parsing error near byte offset " ++ show ofs ++ if null msg then "" else " (" ++ msg ++ ")") exitFailure Right event -> do - hPutStrLn stdout (ev2str event) + hPutStrLn stdout (ev2str True (eEvent event)) hFlush stdout +cmdYaml2EventPos :: IO () +cmdYaml2EventPos = do + inYamlDat <- BS.L.getContents + let inYamlDatTxt = T.decodeUtf8 (BS.L.toStrict inYamlDat) + inYamlDatLns = T.lines inYamlDatTxt + maxLine = length inYamlDatLns + + forM_ (parseEvents inYamlDat) $ \ev -> case ev of + Left (ofs,msg) -> do + hPutStrLn stderr (prettyPosWithSource ofs inYamlDat (" error [" ++ show ofs ++ "]") ++ msg) + exitFailure + Right event -> do + let Pos{..} = ePos event + + putStrLn (prettyPosWithSource (ePos event) inYamlDat ("\t" ++ ev2str True (eEvent event))) + +cmdYaml2Event0 :: IO () +cmdYaml2Event0 = do + inYamlDat <- BS.L.getContents + print (length (parseEvents' inYamlDat)) + where + parseEvents' = map (either (\(ofs,msg) -> error ("parsing error near byte offset " ++ show ofs ++ " (" ++ msg ++ ")")) id) . parseEvents + +cmdYaml2YamlVal :: IO() +cmdYaml2YamlVal = do + inYamlDat <- BS.L.getContents + case sequence $ parseEvents inYamlDat of + Left (ofs,msg) -> do + hPutStrLn stderr ("Parsing error near byte offset " ++ show ofs ++ if null msg then "" else " (" ++ msg ++ ")") + exitFailure + Right oldEvents -> do + let output = writeEvents YT.UTF8 (map eEvent oldEvents) + BS.L.hPutStr stdout output + hFlush stdout + case sequence (parseEvents output) of + Left (ofs',msg') -> do + hPutStrLn stderr ("Parsing error in the generated YAML stream near byte offset " ++ show ofs' ++ if null msg' then "" else " (" ++ msg' ++ ")") + exitFailure + Right newEvents -> do + hPutStrLn stdout $ printf "\nInput Event Stream Length: %d\nOutput Event Stream Length: %d\n" (length oldEvents) (length newEvents) + let diffList = filter (uncurry (/=)) $ zipWith (\a b -> (eEvent a, eEvent b)) oldEvents newEvents + hPutStrLn stdout $ printf "No of difference detected: %d\n" $ length diffList + forM_ diffList $ \(old,new) -> do + hPutStrLn stdout $ "Input > " ++ show old + hPutStrLn stdout $ "Output < " ++ show new + +cmdPrintNode :: IO() +cmdPrintNode = do + str <- BS.L.getContents + case decode str :: Either (Pos, String) [Node Pos] of + Left (pos, s) -> do + hPutStrLn stdout s + hFlush stdout + Right nodeSeq -> forM_ nodeSeq $ \node -> do + printNode node + putStrLn "" + +cmdDumpYAML :: IO() +cmdDumpYAML = do + str <- BS.L.getContents + case decode str :: Either (Pos, String) [Node Pos] of + Left (pos, str) -> do + hPutStrLn stdout str + hFlush stdout + Right nodes -> do + BS.L.hPutStrLn stdout $ encode nodes + hFlush stdout + -- | 'J.Value' look-alike data Value' = Object' (Map Text Value') | Array' [Value'] @@ -123,7 +276,7 @@ Object' xs -> J.Object (fmap toProperValue xs) instance FromYAML Value' where - parseYAML (Y.Scalar s) = case s of + parseYAML (Y.Scalar _ s) = case s of SNull -> pure Null' SBool b -> pure (Bool' b) SFloat x -> pure (NumberD' x) @@ -131,11 +284,11 @@ SStr t -> pure (String' t) SUnknown _ t -> pure (String' t) -- HACK - parseYAML (Y.Sequence _ xs) = Array' <$> mapM parseYAML xs + parseYAML (Y.Sequence _ _ xs) = Array' <$> mapM parseYAML xs - parseYAML (Y.Mapping _ m) = Object' . Map.fromList <$> mapM parseKV (Map.toList m) + parseYAML (Y.Mapping _ _ m) = Object' . Map.fromList <$> mapM parseKV (Map.toList m) where - parseKV :: (Y.Node,Y.Node) -> Parser (Text,Value') + parseKV :: (Y.Node Pos,Y.Node Pos) -> Parser (Text,Value') parseKV (k,v) = (,) <$> parseK k <*> parseYAML v -- for numbers and !!null we apply implicit conversions @@ -150,9 +303,16 @@ _ -> pure $ T.decodeUtf8 $ J.encodeStrict $ toProperValue k -- _ -> fail ("dictionary entry had non-string key " ++ show k) -decodeAeson :: BS.L.ByteString -> Either String [J.Value] -decodeAeson = fmap (map toProperValue) . decode +decodeAeson :: BS.L.ByteString -> Either (Pos,String) [J.Value] +decodeAeson = fmap (map toProperValue) . decode' + where + -- TODO + decode' :: FromYAML v => BS.L.ByteString -> Either (Pos,String) [v] + decode' bs0 = case decodeNode' coreSchemaResolver { schemaResolverMappingDuplicates = True } False False bs0 of + Left (pos, err) -> Left (pos, err) + Right a -> Right a >>= mapM (parseEither . parseYAML . (\(Doc x) -> x)) + -- | Try to convert 'Double' into 'Int64', return 'Nothing' if not -- representable loss-free as integral 'Int64' value. doubleToInt64 :: Double -> Maybe Int64 @@ -174,7 +334,7 @@ inYamlDat <- BS.L.getContents case decodeAeson inYamlDat of - Left e -> fail e + Left (_, e) -> fail e Right vs -> do forM_ vs $ \v -> BS.L.putStrLn (J.encode v) @@ -187,12 +347,14 @@ data TestPass = PassExpErr -- ^ expected parse fail | PassEvs -- ^ events ok | PassEvsJson -- ^ events+json ok + | PassEvsJsonYaml deriving (Eq,Ord,Show) data TestFail = FailParse -- ^ unexpected parse fail | FailSuccess -- ^ unexpected parse success | FailEvs -- ^ events wrong/mismatched | FailJson -- ^ JSON wrong/mismatched + | FailYaml -- ^ YAML wrong/mismatched deriving (Eq,Ord,Show) data TestRes @@ -222,7 +384,9 @@ mInJsonDat :: Maybe [J.Value] mInJsonDat = (maybe (error ("invalid JSON in " ++ show fn)) id . J.decodeStrictN . T.encodeUtf8) <$> lookup "in-json" dats - case sequence (parseEvents inYamlDat) of + mOutYamlDat = BS.L.fromStrict . T.encodeUtf8 . unescapeSpcTab <$> lookup "out-yaml" dats + + case sequence $ filter (not. isComment) (parseEvents inYamlDat) of Left err | isErr -> do putStrLn "OK! (error)" @@ -248,21 +412,66 @@ pure (Fail FailParse) Right evs' -> do - let evs'' = map ev2str evs' + let events = map eEvent evs' + evs'' = map (ev2str False) events if evs'' == testEvDat then do + let outYamlDatIut = writeEvents YT.UTF8 (map toBlockStyle events) + where toBlockStyle ev = case ev of + SequenceStart a b _ -> SequenceStart a b Block + MappingStart a b _ -> MappingStart a b Block + otherwise -> ev + Right ev = sequence $ filter (not. isComment) (parseEvents outYamlDatIut) + outYamlEvsIut = either (const []) (map (ev2str False)) (Right (map eEvent ev)) + + unless (outYamlEvsIut == evs'') $ do + putStrLn' ("\nWARNING: (iut /= ref)") + + putStrLn' ("iut[yaml] = " ++ show outYamlDatIut) + putStrLn' ("ref[raw-evs] = " ++ show evs') + putStrLn' ("ref[evs] = " ++ show evs'') + putStrLn' ("iut[evs] = " ++ show outYamlEvsIut) + + putStrLn "" + + case mInJsonDat of Nothing -> do putStrLn "OK!" pure (Pass PassEvs) Just inJsonDat -> do - iutJson <- either fail pure $ decodeAeson inYamlDat + iutJson <- either (fail. snd) pure $ decodeAeson inYamlDat if iutJson == inJsonDat then do - putStrLn "OK! (+JSON)" - pure (Pass PassEvsJson) + case mOutYamlDat of + Nothing -> do + putStrLn "OK! (+JSON)" + pure (Pass PassEvsJson) + Just outYamlDat -> do + case () of + _ | outYamlDat == outYamlDatIut -> do + putStrLn "OK! (+JSON+YAML)" + pure (Pass PassEvsJsonYaml) + + | otherwise -> do + + putStrLn $ if outYamlEvsIut == evs'' then "OK (+JSON-YAML)" else "FAIL! (bad out-YAML)" + + putStrLn' ("ref = " ++ show outYamlDat) + putStrLn' ("iut = " ++ show outYamlDatIut) + putStrLn "" + putStrLn' ("ref = " ++ show evs'') + putStrLn' ("iut = " ++ show outYamlEvsIut) + + case outYamlEvsIut == evs'' of + True -> do + putStrLn' ("(iut == ref)") + pure (Pass PassEvsJson) + False -> pure (Fail FailYaml) + + else do putStrLn "FAIL! (bad JSON)" @@ -304,12 +513,167 @@ putStrLn $ concat [ "done -- passed: ", show ok - , " (ev: ", stat (Pass PassEvs), ", ev+json: ", stat (Pass PassEvsJson), ", err: ", stat (Pass PassExpErr), ") / " + , " (ev: ", stat (Pass PassEvs), ", ev+json: ", stat (Pass PassEvsJson), ", ev+json+yaml: ", stat (Pass PassEvsJsonYaml), ", err: ", stat (Pass PassExpErr), ") / " , "failed: ", show nok - , " (err: ", stat (Fail FailParse), ", ev:", stat (Fail FailEvs), ", json:", stat (Fail FailJson), ", ok:", stat (Fail FailSuccess), ")" + , " (err: ", stat (Fail FailParse), ", ev:", stat (Fail FailEvs), ", json:", stat (Fail FailJson), ", yaml:", stat (Fail FailYaml), ", ok:", stat (Fail FailSuccess), ")" ] +cmdRunTml' :: [FilePath] -> IO () +cmdRunTml' args = do + results <- forM args $ \fn -> do + tml <- BS.readFile fn + hPutStr stdout (fn ++ " : ") + hFlush stdout + + TML.Document _ blocks <- either (fail . T.unpack) pure $ TML.parse fn (T.decodeUtf8 tml) + + forM blocks $ \(TML.Block label points) -> do + + let dats = [ (k,v) | TML.PointStr k v <- points ] + + let isErr = isJust (lookup "error" dats) + + Just inYamlDat = BS.L.fromStrict . T.encodeUtf8 . unescapeSpcTab <$> lookup "in-yaml" dats + Just testEvDat = lines . T.unpack . unescapeSpcTab <$> lookup "test-event" dats + + mInJsonDat :: Maybe [J.Value] + mInJsonDat = (maybe (error ("invalid JSON in " ++ show fn)) id . J.decodeStrictN . T.encodeUtf8) <$> lookup "in-json" dats + + mOutYamlDat = BS.L.fromStrict . T.encodeUtf8 . unescapeSpcTab <$> lookup "out-yaml" dats + + case sequence $ parseEvents inYamlDat of -- allow parsing with comments + Left err + | isErr -> do + putStrLn "OK! (error)" + pure (Pass PassExpErr) + | otherwise -> do + putStrLn "FAIL!" + putStrLn "" + putStrLn "----------------------------------------------------------------------------" + putStrLn' (T.unpack label) + putStrLn "" + putStrLn' (show err) + putStrLn "" + putStrLn' (show testEvDat) + putStrLn "" + BS.L.putStr inYamlDat + putStrLn "" + testParse inYamlDat + putStrLn "" + -- forM_ (parseEvents inYamlDat) (putStrLn' . show) + putStrLn "" + putStrLn "----------------------------------------------------------------------------" + putStrLn "" + pure (Fail FailParse) + + Right evs' -> do + let events = map eEvent (filter (not. isComment'. eEvent) evs') -- filter comments before comparing + evs'' = map (ev2str False) events + if evs'' == testEvDat + then do + let outYamlDatIut = writeEvents YT.UTF8 (map eEvent evs') -- Allow both block and flow style + -- let outYamlDatIut = writeEvents YT.UTF8 (map (toBlockStyle. eEvent) evs') -- Allow only Block style + -- where toBlockStyle ev = case ev of + -- SequenceStart a b _ -> SequenceStart a b Block + -- MappingStart a b _ -> MappingStart a b Block + -- otherwise -> ev + Right ev = sequence $ parseEvents outYamlDatIut + outYamlEvsIut = either (const []) (map (ev2str False)) (Right (map eEvent (filter (not. isComment'. eEvent) ev))) + + unless (outYamlEvsIut == evs'') $ do + putStrLn' ("\nWARNING: (iut /= ref)") + + putStrLn' ("iut[yaml] = " ++ show outYamlDatIut) + putStrLn' ("ref[raw-evs] = " ++ show evs') + putStrLn' ("ref[evs] = " ++ show evs'') + putStrLn' ("iut[evs] = " ++ show outYamlEvsIut) + + putStrLn "" + + + case mInJsonDat of + Nothing -> do + putStrLn "OK!" + pure (Pass PassEvs) + Just inJsonDat -> do + iutJson <- either (fail. snd) pure $ decodeAeson inYamlDat + + if iutJson == inJsonDat + then do + case mOutYamlDat of + Nothing -> do + putStrLn "OK! (+JSON)" + pure (Pass PassEvsJson) + Just outYamlDat -> do + case () of + _ | outYamlDat == outYamlDatIut -> do + putStrLn "OK! (+JSON+YAML)" + pure (Pass PassEvsJsonYaml) + + | otherwise -> do + + putStrLn $ if outYamlEvsIut == evs'' then "OK (+JSON-YAML)" else "FAIL! (bad out-YAML)" + + putStrLn' ("ref = " ++ show outYamlDat) + putStrLn' ("iut = " ++ show outYamlDatIut) + putStrLn "" + putStrLn' ("ref = " ++ show evs'') + putStrLn' ("iut = " ++ show outYamlEvsIut) + + case outYamlEvsIut == evs'' of + True -> do + putStrLn' ("(iut == ref)") + pure (Pass PassEvsJson) + False -> pure (Fail FailYaml) + + + else do + putStrLn "FAIL! (bad JSON)" + + putStrLn' ("ref = " ++ show inJsonDat) + putStrLn' ("iut = " ++ show iutJson) + + pure (Fail FailJson) + + else do + if isErr + then putStrLn "FAIL! (unexpected parser success)" + else putStrLn "FAIL!" + + putStrLn "" + putStrLn "----------------------------------------------------------------------------" + putStrLn' (T.unpack label) + putStrLn "" + putStrLn' ("ref = " ++ show testEvDat) + putStrLn' ("iut = " ++ show evs'') + putStrLn "" + BS.L.putStr inYamlDat + putStrLn "" + testParse inYamlDat + putStrLn "" + -- forM_ (parseEvents inYamlDat) (putStrLn' . show) + putStrLn "" + putStrLn "----------------------------------------------------------------------------" + putStrLn "" + pure (Fail (if isErr then FailSuccess else FailEvs)) + + putStrLn "" + + let ok = length [ () | Pass _ <- results' ] + nok = length [ () | Fail _ <- results' ] + + stat j = show $ Map.findWithDefault 0 j $ Map.fromListWith (+) [ (k,1::Int) | k <- results' ] + + results' = concat results + + putStrLn $ concat + [ "done -- passed: ", show ok + , " (ev: ", stat (Pass PassEvs), ", ev+json: ", stat (Pass PassEvsJson), ", ev+json+yaml: ", stat (Pass PassEvsJsonYaml), ", err: ", stat (Pass PassExpErr), ") / " + , "failed: ", show nok + , " (err: ", stat (Fail FailParse), ", ev:", stat (Fail FailEvs), ", json:", stat (Fail FailJson), ", yaml:", stat (Fail FailYaml), ", ok:", stat (Fail FailSuccess), ")" + ] + -- | Incomplete proof-of-concept 'testml-compiler' operation cmdTestmlCompiler :: [FilePath] -> IO () cmdTestmlCompiler [fn0] = do @@ -328,48 +692,81 @@ putStrLn' :: String -> IO () putStrLn' msg = putStrLn (" " ++ msg) +printNode :: Node loc -> IO () +printNode node = case node of + (Y.Scalar _ a) -> hPutStrLn stdout $ "Scalar " ++ show a + (Y.Mapping _ a b) -> do + hPutStrLn stdout $ "Mapping " ++ show a + printMap b + (Y.Sequence _ a b) -> do + hPutStrLn stdout $ "Sequence " ++ show a + mapM_ printNode b + (Y.Anchor _ a b) -> do + hPutStr stdout $ "Anchor " ++ show a ++ " " + printNode b -ev2str :: Event -> String -ev2str StreamStart = "+STR" -ev2str (DocumentStart True) = "+DOC ---" -ev2str (DocumentStart False) = "+DOC" -ev2str MappingEnd = "-MAP" -ev2str (MappingStart manc mtag) = "+MAP" ++ ancTagStr manc mtag -ev2str SequenceEnd = "-SEQ" -ev2str (SequenceStart manc mtag) = "+SEQ" ++ ancTagStr manc mtag -ev2str (DocumentEnd True) = "-DOC ..." -ev2str (DocumentEnd False) = "-DOC" -ev2str StreamEnd = "-STR" -ev2str (Alias a) = "=ALI *" ++ T.unpack a -ev2str (YE.Scalar manc mtag sty v) = "=VAL" ++ ancTagStr manc mtag ++ v' - where - v' = case sty of - Plain -> " :" ++ quote2 v - DoubleQuoted -> " \"" ++ quote2 v - Literal -> " |" ++ quote2 v - Folded -> " >" ++ quote2 v - SingleQuoted -> " '" ++ quote2 v +printMap :: Map (Node loc) (Node loc) -> IO () +printMap b = forM_ (Map.toList b) $ \(k,v) -> do + hPutStr stdout "Key: " + printNode k + hPutStr stdout "Value: " + printNode v -ancTagStr manc mtag = anc' ++ tag' +isComment evPos = case evPos of + Right (YE.EvPos {eEvent = (YE.Comment _), ePos = _}) -> True + _ -> False + +isComment' ev = case ev of + (Comment _) -> True + _ -> False + +ev2str :: Bool -> Event -> String +ev2str withColSty = \case + StreamStart -> "+STR" + DocumentStart NoDirEndMarker-> "+DOC" + DocumentStart _ -> "+DOC ---" + MappingEnd -> "-MAP" + (MappingStart manc mtag Flow) + | withColSty -> "+MAP {}" ++ ancTagStr manc mtag + (MappingStart manc mtag _) -> "+MAP" ++ ancTagStr manc mtag + SequenceEnd -> "-SEQ" + (SequenceStart manc mtag Flow) + | withColSty -> "+SEQ []" ++ ancTagStr manc mtag + SequenceStart manc mtag _ -> "+SEQ" ++ ancTagStr manc mtag + DocumentEnd True -> "-DOC ..." + DocumentEnd False -> "-DOC" + StreamEnd -> "-STR" + Alias a -> "=ALI *" ++ T.unpack a + YE.Scalar manc mtag sty v -> "=VAL" ++ ancTagStr manc mtag ++ styStr sty ++ quote2 v + Comment comment -> "=COMMENT "++ quote2 comment where - anc' = case manc of - Nothing -> "" - Just anc -> " &" ++ T.unpack anc + styStr = \case + Plain -> " :" + DoubleQuoted -> " \"" + Literal _ _ -> " |" + Folded _ _ -> " >" + SingleQuoted -> " '" - tag' = case tagToText mtag of - Nothing -> "" - Just t -> " <" ++ T.unpack t ++ ">" + ancTagStr manc mtag = anc' ++ tag' + where + anc' = case manc of + Nothing -> "" + Just anc -> " &" ++ T.unpack anc + tag' = case tagToText mtag of + Nothing -> "" + Just t -> " <" ++ T.unpack t ++ ">" -quote2 :: T.Text -> String -quote2 = concatMap go . T.unpack - where - go c | c == '\n' = "\\n" - | c == '\t' = "\\t" - | c == '\b' = "\\b" - | c == '\r' = "\\r" - | c == '\\' = "\\\\" - | otherwise = [c] + + quote2 :: T.Text -> String + quote2 = concatMap go . T.unpack + where + go c | c == '\n' = "\\n" + | c == '\t' = "\\t" + | c == '\b' = "\\b" + | c == '\r' = "\\r" + | c == '\\' = "\\\\" + | otherwise = [c] diff --git a/src-test/TML.hs b/src-test/TML.hs --- a/src-test/TML.hs +++ b/src-test/TML.hs @@ -40,12 +40,11 @@ import Text.Megaparsec import Text.Megaparsec.Char import qualified Text.Megaparsec.Char.Lexer as L -import Text.Megaparsec.Expr type Parser = Parsec Void T.Text parse :: String -> T.Text -> Either T.Text Document -parse fn raw = either (Left . T.pack . parseErrorPretty' raw) +parse fn raw = either (Left . T.pack . errorBundlePretty) (Right .process_pseudo) (Text.Megaparsec.parse testml_document fn raw) @@ -318,7 +317,7 @@ block_definition = do -- block_heading string "===" *> ws - l <- T.pack <$> manyTill anyChar eol + l <- T.pack <$> manyTill anySingle eol -- TODO: user_defined ps <- many point_definition @@ -333,7 +332,7 @@ let single = do _ <- char ':' *> ws - x <- T.pack <$> manyTill anyChar eol + x <- T.pack <$> manyTill anySingle eol -- consume and ignore any point_lines _ <- point_lines pure $! case j of @@ -358,7 +357,7 @@ point_lines :: Parser T.Text point_lines = T.pack . unlines <$> go where - go = many (notFollowedBy point_boundary *> manyTill anyChar eol) + go = many (notFollowedBy point_boundary *> manyTill anySingle eol) point_boundary :: Parser () point_boundary = void (string "---") <|> void (string "===") <|> eof diff --git a/src/Data/DList.hs b/src/Data/DList.hs new file mode 100644 --- /dev/null +++ b/src/Data/DList.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE Safe #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2018 +-- SPDX-License-Identifier: GPL-2.0-or-later +-- +-- Minimal API-compatible rip-off of @Data.DList@ +module Data.DList + ( DList + , empty + , singleton + , append + , toList + ) where + +-- | A difference list is a function that, given a list, returns the original +-- contents of the difference list prepended to the given list. +newtype DList a = DList ([a] -> [a]) + +-- | Convert a dlist to a list +toList :: DList a -> [a] +toList (DList dl) = dl [] + +-- | Create dlist with a single element +singleton :: a -> DList a +singleton x = DList (x:) + +-- | Create a dlist containing no elements +empty :: DList a +empty = DList id + +-- | O(1). Append dlists +append :: DList a -> DList a -> DList a +append (DList xs) (DList ys) = DList (xs . ys) diff --git a/src/Data/YAML.hs b/src/Data/YAML.hs --- a/src/Data/YAML.hs +++ b/src/Data/YAML.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Safe #-} @@ -7,64 +9,51 @@ -- SPDX-License-Identifier: GPL-2.0-or-later -- -- Document oriented [YAML](http://yaml.org/spec/1.2/spec.html) parsing API inspired by [aeson](http://hackage.haskell.org/package/aeson). --- --- === Overview --- --- The diagram below depicts the standard layers of a [YAML 1.2](http://yaml.org/spec/1.2/spec.html) processor. This module covers the upper /Native/ and /Representation/ layers, whereas the "Data.YAML.Event" and "Data.YAML.Token" modules provide access to the lower /Serialization/ and /Presentation/ layers respectively. --- --- <> --- --- === Quick Start Tutorial --- --- Let's assume we want to decode (i.e. /load/) a simple YAML document --- --- > - name: Erik Weisz --- > age: 52 --- > magic: True --- > - name: Mina Crandon --- > age: 53 --- --- into a native Haskell data structure of type @[Person]@, i.e. a list of 'Person' records. --- --- The code below shows how to manually define a @Person@ record type together with a 'FromYAML' instance: --- --- > {-# LANGUAGE OverloadedStrings #-} --- > --- > import Data.YAML --- > --- > data Person = Person --- > { name :: Text --- > , age :: Int --- > , magic :: Bool --- > } deriving Show --- > --- > instance FromYAML Person where --- > parseYAML = withMap "Person" $ \m -> Person --- > <$> m .: "name" --- > <*> m .: "age" --- > <*> m .:? "magic" .!= False --- --- And now we can 'decode' the YAML document like so: --- --- >>> decode "- name: Erik Weisz\n age: 52\n magic: True\n- name: Mina Crandon\n age: 53" :: Either String [[Person]] --- Right [[Person {name = "Erik Weisz", age = 52, magic = True},Person {name = "Mina Crandon", age = 53, magic = False}]] --- --- + module Data.YAML ( + + -- * Overview + -- $overview + + -- * Quick Start Tutorial + -- $start + + -- ** Decoding/Loading YAML document + -- $loading + + -- ** Encoding/dumping + -- $dumping + -- * Typeclass-based resolving/decoding decode + , decode1 , decodeStrict + , decode1Strict , FromYAML(..) , Parser , parseEither + , failAtNode , typeMismatch - -- ** Accessors for YAML 'Mapping's + -- ** Accessors for YAML t'Mapping's , Mapping , (.:), (.:?), (.:!), (.!=) + -- * Typeclass-based dumping + , encode + , encode1 + , encodeStrict + , encode1Strict + , ToYAML(..) + + -- ** Accessors for encoding t'Mapping's + , Pair + , mapping + , (.=) + -- ** Prism-style parsers + , withScalar , withSeq , withBool , withFloat @@ -76,82 +65,194 @@ -- * \"Concrete\" AST , decodeNode , decodeNode' - , Doc(..) + , encodeNode + , encodeNode' + , Doc(Doc,docRoot) , Node(..) , Scalar(..) + -- * Source locations + , Pos(..) + , prettyPosWithSource + -- * YAML 1.2 Schema resolvers - , SchemaResolver(..) + -- + -- | See also "Data.YAML.Schema" + , SchemaResolver , failsafeSchemaResolver , jsonSchemaResolver , coreSchemaResolver + -- * YAML 1.2 Schema encoders + -- + -- | See also "Data.YAML.Schema" + , SchemaEncoder + , failsafeSchemaEncoder + , jsonSchemaEncoder + , coreSchemaEncoder + -- * Generalised AST construction , decodeLoader , Loader(..) + , LoaderT , NodeId ) where -import qualified Control.Monad.Fail as Fail -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BS.L -import qualified Data.Map as Map -import qualified Data.Text as T +import qualified Control.Monad.Fail as Fail +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS.L +import qualified Data.Map as Map +import qualified Data.Text as T -import Data.YAML.Event (Tag, isUntagged, tagToText) +import Data.YAML.Dumper +import Data.YAML.Event (isUntagged, tagToText) +import Data.YAML.Internal import Data.YAML.Loader -import Data.YAML.Schema +import Data.YAML.Pos +import Data.YAML.Schema.Internal import Util --- | YAML Document tree/graph -newtype Doc n = Doc n deriving (Eq,Ord,Show) +-- $overview +-- +-- The diagram below depicts the standard layers of a [YAML 1.2](http://yaml.org/spec/1.2/spec.html) processor. This module covers the upper /Native/ and /Representation/ layers, whereas the "Data.YAML.Event" and "Data.YAML.Token" modules provide access to the lower /Serialization/ and /Presentation/ layers respectively. +-- +-- <> +-- +-- $start +-- +-- This section contains basic information on the different ways to work with YAML data using this library. +-- +-- $loading +-- +-- We address the process of loading data from a YAML document as decoding. +-- +-- Let's assume we want to decode (i.e. /load/) a simple YAML document +-- +-- > - name: Erik Weisz +-- > age: 52 +-- > magic: True +-- > - name: Mina Crandon +-- > age: 53 +-- +-- into a native Haskell data structure of type @[Person]@, i.e. a list of @Person@ records. +-- +-- The code below shows how to manually define a @Person@ record type together with a 'FromYAML' instance: +-- +-- > {-# LANGUAGE OverloadedStrings #-} +-- > +-- > import Data.YAML +-- > +-- > data Person = Person +-- > { name :: Text +-- > , age :: Int +-- > , magic :: Bool +-- > } deriving Show +-- > +-- > instance FromYAML Person where +-- > parseYAML = withMap "Person" $ \m -> Person +-- > <$> m .: "name" +-- > <*> m .: "age" +-- > <*> m .:? "magic" .!= False +-- +-- And now we can 'decode' the YAML document like so: +-- +-- >>> decode "- name: Erik Weisz\n age: 52\n magic: True\n- name: Mina Crandon\n age: 53" :: Either (Pos,String) [[Person]] +-- Right [[Person {name = "Erik Weisz", age = 52, magic = True},Person {name = "Mina Crandon", age = 53, magic = False}]] +-- +-- There are predefined 'FromYAML' instance for many types. +-- +-- The example below shows decoding multiple YAML documents into a list of 'Int' lists: +-- +-- >>> decode "---\n- 1\n- 2\n- 3\n---\n- 4\n- 5\n- 6" :: Either (Pos,String) [[Int]] +-- Right [[1,2,3],[4,5,6]] +-- +-- If you are expecting exactly one YAML document then you can use convenience function 'decode1' +-- +-- >>> decode1 "- 1\n- 2\n- 3\n" :: Either (Pos,String) [Int] +-- Right [1,2,3] +-- +-- == Working with AST +-- +-- Sometimes we want to work with YAML data directly, without first converting it to a custom data type. +-- +-- We can easily do that by using the 'Node' type, which is an instance of 'FromYAML', is used to represent an arbitrary YAML AST (abstract syntax tree). For example, +-- +-- >>> decode1 "Name: Vijay" :: Either (Pos,String) (Node Pos) +-- Right (Mapping (Pos {posByteOffset = 0, posCharOffset = 0, posLine = 1, posColumn = 0}) Just "tag:yaml.org,2002:map" (fromList [(Scalar (Pos {posByteOffset = 0, posCharOffset = 0, posLine = 1, posColumn = 0}) (SStr "Name"),Scalar (Pos {posByteOffset = 6, posCharOffset = 6, posLine = 1, posColumn = 6}) (SStr "Vijay"))])) +-- +-- The type parameter 'Pos' is used to indicate the position of each YAML 'Node' in the document. +-- So using the 'Node' type we can easily decode any YAML document. +-- +-- == Pretty-printing source locations +-- +-- Syntax errors or even conversion errors are reported with a source location, e.g. +-- +-- >>> decode "- name: Erik Weisz\n age: 52\n magic: True\n- name: Mina Crandon\n age: young" :: Either (Pos,String) [[Person]] +-- Left (Pos {posByteOffset = 71, posCharOffset = 71, posLine = 5, posColumn = 7},"expected !!int instead of !!str") +-- +-- While accurate this isn't a very convenient error representation. Instead we can use the 'prettyPosWithSource' helper function to create more convenient error report like so +-- +-- @ +-- readPersons :: FilePath -> IO [Person] +-- readPersons fname = do +-- raw <- BS.L.readFile fname +-- case 'decode1' raw of +-- Left (loc,emsg) -> do +-- hPutStrLn stderr (fname ++ ":" ++ 'prettyPosWithSource' loc raw " error" ++ emsg) +-- pure [] +-- Right persons -> pure persons +-- @ +-- +-- which will then print errors in a common form such as +-- +-- > people.yaml:5:7: error +-- > | +-- > 5 | age: young +-- > | ^ +-- > expected !!int instead of !!str +-- --- | YAML Document node -data Node = Scalar !Scalar - | Mapping !Tag Mapping - | Sequence !Tag [Node] - | Anchor !NodeId !Node - deriving (Eq,Ord,Show) --- | YAML mapping -type Mapping = Map Node Node - --- | Retrieve value in 'Mapping' indexed by a @!!str@ 'Text' key. +-- | Retrieve value in t'Mapping' indexed by a @!!str@ 'Text' key. -- -- This parser fails if the key doesn't exist. -(.:) :: FromYAML a => Mapping -> Text -> Parser a -m .: k = maybe (fail $ "key " ++ show k ++ " not found") parseYAML (Map.lookup (Scalar (SStr k)) m) +(.:) :: FromYAML a => Mapping Pos -> Text -> Parser a +m .: k = maybe (fail $ "key " ++ show k ++ " not found") parseYAML (Map.lookup (Scalar fakePos (SStr k)) m) --- | Retrieve optional value in 'Mapping' indexed by a @!!str@ 'Text' key. +-- | Retrieve optional value in t'Mapping' indexed by a @!!str@ 'Text' key. -- -- 'Nothing' is returned if the key is missing or points to a @tag:yaml.org,2002:null@ node. -- This combinator only fails if the key exists but cannot be converted to the required type. -- -- See also '.:!'. -(.:?) :: FromYAML a => Mapping -> Text -> Parser (Maybe a) -m .:? k = maybe (pure Nothing) parseYAML (Map.lookup (Scalar (SStr k)) m) +(.:?) :: FromYAML a => Mapping Pos -> Text -> Parser (Maybe a) +m .:? k = maybe (pure Nothing) parseYAML (Map.lookup (Scalar fakePos (SStr k)) m) --- | Retrieve optional value in 'Mapping' indexed by a @!!str@ 'Text' key. +-- | Retrieve optional value in t'Mapping' indexed by a @!!str@ 'Text' key. -- -- 'Nothing' is returned if the key is missing. -- This combinator only fails if the key exists but cannot be converted to the required type. -- -- __NOTE__: This is a variant of '.:?' which doesn't map a @tag:yaml.org,2002:null@ node to 'Nothing'. -(.:!) :: FromYAML a => Mapping -> Text -> Parser (Maybe a) -m .:! k = maybe (pure Nothing) (fmap Just . parseYAML) (Map.lookup (Scalar (SStr k)) m) +(.:!) :: FromYAML a => Mapping Pos -> Text -> Parser (Maybe a) +m .:! k = maybe (pure Nothing) (fmap Just . parseYAML) (Map.lookup (Scalar fakePos (SStr k)) m) -- | Defaulting helper to be used with '.:?' or '.:!'. (.!=) :: Parser (Maybe a) -> a -> Parser a mv .!= def = fmap (maybe def id) mv +fakePos :: Pos +fakePos = Pos { posByteOffset = -1 , posCharOffset = -1 , posLine = 1 , posColumn = 0 } -- | Parse and decode YAML document(s) into 'Node' graphs -- --- This is a convenience wrapper over `decodeNode'` +-- This is a convenience wrapper over `decodeNode'`, i.e. -- --- > decodeNode = decodeNode' coreSchemaResolver False False +-- @ +-- decodeNode = decodeNode' 'coreSchemaResolver' False False +-- @ -- -- In other words, -- @@ -159,38 +260,54 @@ -- * Don't create 'Anchor' nodes -- * Disallow cyclic anchor references -- -decodeNode :: BS.L.ByteString -> Either String [Doc Node] +-- @since 0.2.0 +-- +decodeNode :: BS.L.ByteString -> Either (Pos, String) [Doc (Node Pos)] decodeNode = decodeNode' coreSchemaResolver False False -- | Customizable variant of 'decodeNode' -- +-- @since 0.2.0 +-- decodeNode' :: SchemaResolver -- ^ YAML Schema resolver to use -> Bool -- ^ Whether to emit anchor nodes -> Bool -- ^ Whether to allow cyclic references -> BS.L.ByteString -- ^ YAML document to parse - -> Either String [Doc Node] + -> Either (Pos, String) [Doc (Node Pos)] decodeNode' SchemaResolver{..} anchorNodes allowCycles bs0 = map Doc <$> runIdentity (decodeLoader failsafeLoader bs0) where - failsafeLoader = Loader { yScalar = \t s v -> pure $ fmap Scalar (schemaResolverScalar t s v) - , ySequence = \t vs -> pure $ schemaResolverSequence t >>= \t' -> Right (Sequence t' vs) - , yMapping = \t kvs -> pure $ schemaResolverMapping t >>= \t' -> Right (Mapping t' (Map.fromList kvs)) + failsafeLoader = Loader { yScalar = \t s v pos-> pure $ case schemaResolverScalar t s v of + Left e -> Left (pos,e) + Right v' -> Right (Scalar pos v') + , ySequence = \t vs pos -> pure $ case schemaResolverSequence t of + Left e -> Left (pos,e) + Right t' -> Right (Sequence pos t' vs) + , yMapping = \t kvs pos-> pure $ case schemaResolverMapping t of + Left e -> Left (pos,e) + Right t' -> Mapping pos t' <$> mkMap kvs , yAlias = if allowCycles - then \_ _ n -> pure $ Right n - else \_ c n -> pure $ if c then Left "cycle detected" else Right n + then \_ _ n _-> pure $ Right n + else \_ c n pos -> pure $ if c then Left (pos,"cycle detected") else Right n , yAnchor = if anchorNodes - then \j n -> pure $ Right (Anchor j n) - else \_ n -> pure $ Right n + then \j n pos -> pure $ Right (Anchor pos j n) + else \_ n _ -> pure $ Right n } + mkMap :: [(Node Pos, Node Pos)] -> Either (Pos, String) (Map (Node Pos) (Node Pos)) + mkMap kvs + | schemaResolverMappingDuplicates = Right $! Map.fromList kvs + | otherwise = case mapFromListNoDupes kvs of + Left (k,_) -> Left (nodeLoc k,"Duplicate key in mapping: " ++ show k) + Right m -> Right m ---------------------------------------------------------------------------- -- | YAML Parser 'Monad' used by 'FromYAML' -- -- See also 'parseEither' or 'decode' -newtype Parser a = P { unP :: Either String a } +newtype Parser a = P { unP :: Either (Pos, String) a } instance Functor Parser where fmap f (P x) = P (fmap f x) @@ -211,12 +328,23 @@ return = pure P m >>= k = P (m >>= unP . k) (>>) = (*>) +#if !(MIN_VERSION_base(4,13,0)) fail = Fail.fail +#endif + -- | @since 0.1.1.0 +-- +-- __NOTE__: 'fail' doesn't convey proper position information unless used within the @with*@-style helpers; consequently it's recommended to use 'failAtNode' when /not/ covered by the location scope of a @with*@-style combinator. instance Fail.MonadFail Parser where - fail = P . Left + fail s = P (Left (fakePos, s)) +-- | Trigger parsing failure located at a specific 'Node' +-- +-- @since 0.2.0.0 +failAtNode :: Node Pos -> String -> Parser a +failAtNode n s = P (Left (nodeLoc n, s)) + -- | @since 0.1.1.0 instance Alternative Parser where empty = fail "empty" @@ -232,7 +360,7 @@ -- | Run 'Parser' -- -- A common use-case is 'parseEither' 'parseYAML'. -parseEither :: Parser a -> Either String a +parseEither :: Parser a -> Either (Pos, String) a parseEither = unP -- | Informative failure helper @@ -245,22 +373,22 @@ -- -- @since 0.1.1.0 typeMismatch :: String -- ^ descriptive name of expected data - -> Node -- ^ actual node + -> Node Pos -- ^ actual node -> Parser a -typeMismatch expected node = fail ("expected " ++ expected ++ " instead of " ++ got) +typeMismatch expected node = failAtNode node ("expected " ++ expected ++ " instead of " ++ got) where got = case node of - Scalar (SBool _) -> "!!bool" - Scalar (SInt _) -> "!!int" - Scalar SNull -> "!!null" - Scalar (SStr _) -> "!!str" - Scalar (SFloat _) -> "!!float" - Scalar (SUnknown t v) - | isUntagged t -> tagged t ++ show v - | otherwise -> "(unsupported) " ++ tagged t ++ "scalar" - (Anchor _ _) -> "anchor" - (Mapping t _) -> tagged t ++ " mapping" - (Sequence t _) -> tagged t ++ " sequence" + Scalar _ (SBool _) -> "!!bool" + Scalar _ (SInt _) -> "!!int" + Scalar _ SNull -> "!!null" + Scalar _ (SStr _) -> "!!str" + Scalar _ (SFloat _) -> "!!float" + Scalar _ (SUnknown t v) + | isUntagged t -> tagged t ++ show v + | otherwise -> "(unsupported) " ++ tagged t ++ "scalar" + Anchor _ _ _ -> "anchor" + Mapping _ t _ -> tagged t ++ " mapping" + Sequence _ t _ -> tagged t ++ " sequence" tagged t0 = case tagToText t0 of Nothing -> "non-specifically ? tagged (i.e. unresolved) " @@ -268,50 +396,68 @@ -- | A type into which YAML nodes can be converted/deserialized class FromYAML a where - parseYAML :: Node -> Parser a + parseYAML :: Node Pos -> Parser a +-- This helper fixes up 'fakePos' locations to a better guess; this is +-- mostly used by the with*-style combinators +{-# INLINE fixupFailPos #-} +fixupFailPos :: Pos -> Parser a -> Parser a +fixupFailPos pos (P (Left (pos0,emsg))) + | pos0 == fakePos = P (Left (pos,emsg)) +fixupFailPos _ p = p + -- | Operate on @tag:yaml.org,2002:null@ node (or fail) -withNull :: String -> Parser a -> Node -> Parser a -withNull _ f (Scalar SNull) = f -withNull expected _ v = typeMismatch expected v +withNull :: String -> Parser a -> Node Pos -> Parser a +withNull _ f (Scalar pos SNull) = fixupFailPos pos f +withNull expected _ v = typeMismatch expected v +-- | Operate on t'Scalar' node (or fail) +-- +-- @since 0.2.1 +withScalar :: String -> (Scalar -> Parser a) -> Node Pos -> Parser a +withScalar _ f (Scalar pos sca) = fixupFailPos pos (f sca) +withScalar expected _ v = typeMismatch expected v -- | Trivial instance -instance FromYAML Node where +instance (loc ~ Pos) => FromYAML (Node loc) where parseYAML = pure +-- | @since 0.2.1 +instance FromYAML Scalar where + parseYAML = withScalar "scalar" pure + instance FromYAML Bool where parseYAML = withBool "!!bool" pure -- | Operate on @tag:yaml.org,2002:bool@ node (or fail) -withBool :: String -> (Bool -> Parser a) -> Node -> Parser a -withBool _ f (Scalar (SBool b)) = f b -withBool expected _ v = typeMismatch expected v +withBool :: String -> (Bool -> Parser a) -> Node Pos -> Parser a +withBool _ f (Scalar pos (SBool b)) = fixupFailPos pos (f b) +withBool expected _ v = typeMismatch expected v instance FromYAML Text where parseYAML = withStr "!!str" pure -- | Operate on @tag:yaml.org,2002:str@ node (or fail) -withStr :: String -> (Text -> Parser a) -> Node -> Parser a -withStr _ f (Scalar (SStr b)) = f b -withStr expected _ v = typeMismatch expected v +withStr :: String -> (Text -> Parser a) -> Node Pos -> Parser a +withStr _ f (Scalar pos (SStr b)) = fixupFailPos pos (f b) +withStr expected _ v = typeMismatch expected v instance FromYAML Integer where parseYAML = withInt "!!int" pure -- | Operate on @tag:yaml.org,2002:int@ node (or fail) -withInt :: String -> (Integer -> Parser a) -> Node -> Parser a -withInt _ f (Scalar (SInt b)) = f b -withInt expected _ v = typeMismatch expected v +withInt :: String -> (Integer -> Parser a) -> Node Pos -> Parser a +withInt _ f (Scalar pos (SInt b)) = fixupFailPos pos (f b) +withInt expected _ v = typeMismatch expected v --- | @since 0.1.0.0 +-- | @since 0.1.1.0 instance FromYAML Natural where parseYAML = withInt "!!int" $ \b -> if b < 0 then fail ("!!int " ++ show b ++ " out of range for 'Natural'") else pure (fromInteger b) -- helper for fixed-width integers {-# INLINE parseInt #-} -parseInt :: (Integral a, Bounded a) => [Char] -> Node -> Parser a +parseInt :: (Integral a, Bounded a) => [Char] -> Node Pos -> Parser a parseInt name = withInt "!!int" $ \b -> maybe (fail $ "!!int " ++ show b ++ " out of range for '" ++ name ++ "'") pure $ fromIntegerMaybe b @@ -331,32 +477,32 @@ parseYAML = withFloat "!!float" pure -- | Operate on @tag:yaml.org,2002:float@ node (or fail) -withFloat :: String -> (Double -> Parser a) -> Node -> Parser a -withFloat _ f (Scalar (SFloat b)) = f b -withFloat expected _ v = typeMismatch expected v +withFloat :: String -> (Double -> Parser a) -> Node Pos -> Parser a +withFloat _ f (Scalar pos (SFloat b)) = fixupFailPos pos (f b) +withFloat expected _ v = typeMismatch expected v instance (Ord k, FromYAML k, FromYAML v) => FromYAML (Map k v) where parseYAML = withMap "!!map" $ \xs -> Map.fromList <$> mapM (\(a,b) -> (,) <$> parseYAML a <*> parseYAML b) (Map.toList xs) --- | Operate on @tag:yaml.org,2002:seq@ node (or fail) -withMap :: String -> (Mapping -> Parser a) -> Node -> Parser a -withMap _ f (Mapping tag xs) - | tag == tagMap = f xs +-- | Operate on @tag:yaml.org,2002:map@ node (or fail) +withMap :: String -> (Mapping Pos -> Parser a) -> Node Pos -> Parser a +withMap _ f (Mapping pos tag xs) + | tag == tagMap = fixupFailPos pos (f xs) withMap expected _ v = typeMismatch expected v instance FromYAML v => FromYAML [v] where parseYAML = withSeq "!!seq" (mapM parseYAML) -- | Operate on @tag:yaml.org,2002:seq@ node (or fail) -withSeq :: String -> ([Node] -> Parser a) -> Node -> Parser a -withSeq _ f (Sequence tag xs) - | tag == tagSeq = f xs +withSeq :: String -> ([Node Pos] -> Parser a) -> Node Pos-> Parser a +withSeq _ f (Sequence pos tag xs) + | tag == tagSeq = fixupFailPos pos (f xs) withSeq expected _ v = typeMismatch expected v instance FromYAML a => FromYAML (Maybe a) where - parseYAML (Scalar SNull) = pure Nothing - parseYAML j = Just <$> parseYAML j + parseYAML (Scalar _ SNull) = pure Nothing + parseYAML j = Just <$> parseYAML j ---------------------------------------------------------------------------- @@ -428,13 +574,13 @@ -- the response list. Here's an example of decoding two concatenated -- YAML documents: -- --- >>> decode "Foo\n---\nBar" :: Either String [Text] +-- >>> decode "Foo\n---\nBar" :: Either (Pos,String) [Text] -- Right ["Foo","Bar"] -- -- Note that an empty stream doesn't contain any (non-comment) -- document nodes, and therefore results in an empty result list: -- --- >>> decode "# just a comment" :: Either String [Text] +-- >>> decode "# just a comment" :: Either (Pos,String) [Text] -- Right [] -- -- 'decode' uses the same settings as 'decodeNode' for tag-resolving. If @@ -445,11 +591,215 @@ -- decoding from YAML streams using the UTF-8, UTF-16 (LE or BE), or -- UTF-32 (LE or BE) encoding (which is auto-detected). -- -decode :: FromYAML v => BS.L.ByteString -> Either String [v] +-- @since 0.2.0 +-- +decode :: FromYAML v => BS.L.ByteString -> Either (Pos, String) [v] decode bs0 = decodeNode bs0 >>= mapM (parseEither . parseYAML . (\(Doc x) -> x)) +-- | Convenience wrapper over 'decode' expecting exactly one YAML document +-- +-- >>> decode1 "---\nBar\n..." :: Either (Pos,String) Text +-- Right "Bar" +-- +-- >>> decode1 "Foo\n---\nBar" :: Either (Pos,String) Text +-- Left (Pos {posByteOffset = 8, posCharOffset = 8, posLine = 3, posColumn = 0},"unexpected multiple YAML documents") +-- +-- >>> decode1 "# Just a comment" :: Either (Pos,String) Text +-- Left (Pos {posByteOffset = 0, posCharOffset = 0, posLine = 1, posColumn = 0},"empty YAML stream") +-- +-- @since 0.2.0 +-- +decode1 :: FromYAML v => BS.L.ByteString -> Either (Pos, String) v +decode1 bs0 = do + docs <- decodeNode bs0 + case docs of + [] -> Left (Pos { posByteOffset = 0, posCharOffset = 0, posLine = 1, posColumn = 0 }, "empty YAML stream") + [Doc v] -> parseEither $ parseYAML $ v + (_:Doc n:_) -> Left (nodeLoc n, "unexpected multiple YAML documents") + -- | Like 'decode' but takes a strict 'BS.ByteString' -- --- @since 0.1.1.0 -decodeStrict :: FromYAML v => BS.ByteString -> Either String [v] +-- @since 0.2.0 +-- +decodeStrict :: FromYAML v => BS.ByteString -> Either (Pos, String) [v] decodeStrict = decode . BS.L.fromChunks . (:[]) + +-- | Like 'decode1' but takes a strict 'BS.ByteString' +-- +-- @since 0.2.0 +-- +decode1Strict :: FromYAML v => BS.ByteString -> Either (Pos, String) v +decode1Strict = decode1 . BS.L.fromChunks . (:[]) + +-- $dumping +-- +-- We address the process of dumping information from a Haskell-data type(s) to a YAML document(s) as encoding. +-- +-- Suppose we want to 'encode' a Haskell-data type Person +-- +-- @ +-- data Person = Person +-- { name :: Text +-- , age :: Int +-- } deriving Show +-- @ +-- +-- To 'encode' data, we need to define a 'ToYAML' instance. +-- +-- @ +-- +-- instance 'ToYAML' Person where +-- \-- this generates a 'Node' +-- 'toYAML' (Person n a) = 'mapping' [ "name" .= n, "age" .= a] +-- +-- @ +-- +-- We can now 'encode' a node like so: +-- +-- >>> encode [Person {name = "Vijay", age = 19}] +-- "age: 19\nname: Vijay\n" +-- +-- There are predefined 'ToYAML' instances for many types. Here's an example encoding a complex Haskell Node' +-- +-- >>> encode1 $ toYAML ([1,2,3], Map.fromList [(1, 2)]) +-- "- - 1\n - 2\n - 3\n- 1: 2\n" +-- + + +-- | A type from which YAML nodes can be constructed +-- +-- @since 0.2.0.0 +class ToYAML a where + -- | Convert a Haskell Data-type to a YAML Node data type. + toYAML :: a -> Node () + +instance Loc loc => ToYAML (Node loc) where + toYAML = toUnit + +instance ToYAML Bool where + toYAML = Scalar () . SBool + +instance ToYAML Double where + toYAML = Scalar () . SFloat + +instance ToYAML Int where toYAML = Scalar () . SInt . toInteger +instance ToYAML Int8 where toYAML = Scalar () . SInt . toInteger +instance ToYAML Int16 where toYAML = Scalar () . SInt . toInteger +instance ToYAML Int32 where toYAML = Scalar () . SInt . toInteger +instance ToYAML Int64 where toYAML = Scalar () . SInt . toInteger +instance ToYAML Word where toYAML = Scalar () . SInt . toInteger +instance ToYAML Word8 where toYAML = Scalar () . SInt . toInteger +instance ToYAML Word16 where toYAML = Scalar () . SInt . toInteger +instance ToYAML Word32 where toYAML = Scalar () . SInt . toInteger +instance ToYAML Word64 where toYAML = Scalar () . SInt . toInteger +instance ToYAML Natural where toYAML = Scalar () . SInt . toInteger +instance ToYAML Integer where toYAML = Scalar () . SInt + + +instance ToYAML Text where + toYAML = Scalar () . SStr + +-- | @since 0.2.1 +instance ToYAML Scalar where + toYAML = Scalar () + +instance ToYAML a => ToYAML (Maybe a) where + toYAML Nothing = Scalar () SNull + toYAML (Just a) = toYAML a + +-- instance (ToYAML a, ToYAML b) => ToYAML (Either a b) where +-- toYAML (Left a) = toYAML a +-- toYAML (Right b) = toYAML b + +instance ToYAML a => ToYAML [a] where + toYAML = Sequence () tagSeq . map toYAML + +instance (Ord k, ToYAML k, ToYAML v) => ToYAML (Map k v) where + toYAML kv = Mapping () tagMap (Map.fromList $ map (\(k,v) -> (toYAML k , toYAML v)) (Map.toList kv)) + +instance (ToYAML a, ToYAML b) => ToYAML (a, b) where + toYAML (a,b) = toYAML [toYAML a, toYAML b] + +instance (ToYAML a, ToYAML b, ToYAML c) => ToYAML (a, b, c) where + toYAML (a,b,c) = toYAML [toYAML a, toYAML b, toYAML c] + +instance (ToYAML a, ToYAML b, ToYAML c, ToYAML d) => ToYAML (a, b, c, d) where + toYAML (a,b,c,d) = toYAML [toYAML a, toYAML b, toYAML c, toYAML d] + +instance (ToYAML a, ToYAML b, ToYAML c, ToYAML d, ToYAML e) => ToYAML (a, b, c, d, e) where + toYAML (a,b,c,d,e) = toYAML [toYAML a, toYAML b, toYAML c, toYAML d, toYAML e] + +instance (ToYAML a, ToYAML b, ToYAML c, ToYAML d, ToYAML e, ToYAML f) => ToYAML (a, b, c, d, e, f) where + toYAML (a,b,c,d,e,f) = toYAML [toYAML a, toYAML b, toYAML c, toYAML d, toYAML e, toYAML f] + +instance (ToYAML a, ToYAML b, ToYAML c, ToYAML d, ToYAML e, ToYAML f, ToYAML g) => ToYAML (a, b, c, d, e, f, g) where + toYAML (a,b,c,d,e,f,g) = toYAML [toYAML a, toYAML b, toYAML c, toYAML d, toYAML e, toYAML f, toYAML g] + + +-- | Serialize YAML Node(s) using the YAML 1.2 Core schema to a lazy 'Data.YAML.Token.UTF8' encoded 'BS.L.ByteString'. +-- +-- Each YAML Node produces exactly one YAML Document. +-- +-- Here is an example of encoding a list of strings to produce a list of YAML Documents +-- +-- >>> encode (["Document 1", "Document 2"] :: [Text]) +-- "Document 1\n...\nDocument 2\n" +-- +-- If we treat the above list of strings as a single sequence then we will produce a single YAML Document having a single sequence. +-- +-- >>> encode ([["Document 1", "Document 2"]] :: [[Text]]) +-- "- Document 1\n- Document 2\n" +-- +-- Alternatively, if you only need a single YAML document in a YAML stream you might want to use the convenience function 'encode1'; or, if you need more control over the encoding, see 'encodeNode''. +-- +-- @since 0.2.0 +encode :: ToYAML v => [v] -> BS.L.ByteString +encode vList = encodeNode $ map (Doc . toYAML) vList + +-- | Convenience wrapper over 'encode' taking exactly one YAML Node. +-- Hence it will always output exactly one YAML Document +-- +-- Here is example of encoding a list of strings to produce exactly one of YAML Documents +-- +-- >>> encode1 (["Document 1", "Document 2"] :: [Text]) +-- "- Document 1\n- Document 2\n" +-- +-- @since 0.2.0 +encode1 :: ToYAML v => v -> BS.L.ByteString +encode1 a = encode [a] + +-- | Like 'encode' but outputs 'BS.ByteString' +-- +-- @since 0.2.0 +encodeStrict :: ToYAML v => [v] -> BS.ByteString +encodeStrict = bsToStrict . encode + +-- | Like 'encode1' but outputs a strict 'BS.ByteString' +-- +-- @since 0.2.0 +encode1Strict :: ToYAML v => v -> BS.ByteString +encode1Strict = bsToStrict . encode1 + +-- Internal helper +class Loc loc where + toUnit :: Functor f => f loc -> f () + toUnit = (() <$) + +instance Loc Pos + +instance Loc () where toUnit = id + +-- | Represents a key-value pair in YAML t'Mapping's +-- +-- See also '.=' and 'mapping' +-- +-- @since 0.2.1 +type Pair = (Node (), Node ()) + +-- | @since 0.2.0 +(.=) :: ToYAML a => Text -> a -> Pair +name .= node = (toYAML name, toYAML node) + +-- | @since 0.2.0 +mapping :: [Pair] -> Node () +mapping = Mapping () tagMap . Map.fromList diff --git a/src/Data/YAML/Dumper.hs b/src/Data/YAML/Dumper.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Dumper.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-2.0-or-later +-- +module Data.YAML.Dumper + ( encodeNode + , encodeNode' + ) where + +import Data.YAML.Event.Internal as YE +import Data.YAML.Event.Writer (writeEvents) +import Data.YAML.Internal as YI +import Data.YAML.Schema.Internal as YS + +import qualified Data.ByteString.Lazy as BS.L +import qualified Data.Map as Map +import qualified Data.Text as T + +-- internal +type EvList = [Either String Event] +type Node2EvList = [Node ()] -> EvList + +-- | Dump YAML Nodes as a lazy 'UTF8' encoded 'BS.L.ByteString' +-- +-- Each YAML 'Node' is emitted as a individual YAML Document where each Document is terminated by a 'DocumentEnd' indicator. +-- +-- This is a convenience wrapper over `encodeNode'` +-- +-- @since 0.2.0 +encodeNode :: [Doc (Node ())] -> BS.L.ByteString +encodeNode = encodeNode' coreSchemaEncoder UTF8 + +-- | Customizable variant of 'encodeNode' +-- +-- __NOTE__: A leading will be emitted for all encodings /other than/ 'UTF8'. +-- +-- @since 0.2.0 +encodeNode' :: SchemaEncoder -> Encoding -> [Doc (Node ())] -> BS.L.ByteString +encodeNode' SchemaEncoder{..} encoding nodes = writeEvents encoding $ map getEvent (dumpEvents (map docRoot nodes)) + where + + getEvent :: Either String Event -> Event + getEvent = \x -> case x of + Right ev -> ev + Left str -> error str + + dumpEvents :: Node2EvList + dumpEvents nodes' = Right StreamStart: go0 nodes' + where + go0 :: [Node ()] -> EvList + go0 [] = [Right StreamEnd] + go0 n = Right (DocumentStart NoDirEndMarker): goNode (0 :: Int) n (\ev -> go0 ev) + + + goNode :: Int -> [Node ()] -> Node2EvList -> EvList + goNode _ [] _ = [Left "Dumper: unexpected pattern in goNode"] + goNode lvl (node: rest) cont = case node of + YI.Scalar _ scalar -> goScalar scalar Nothing: isDocEnd lvl rest cont + Mapping _ tag m -> Right (MappingStart Nothing (getTag schemaEncoderMapping tag) Block) : goMap (lvl + 1) m rest cont + Sequence _ tag s -> Right (SequenceStart Nothing (getTag schemaEncoderSequence tag) Block) : goSeq (lvl + 1) s rest cont + Anchor _ nid n -> goAnchor lvl nid n rest cont + + goScalar :: YS.Scalar -> Maybe Anchor -> Either String Event + goScalar s anc = case schemaEncoderScalar s of + Right (t, sty, text) -> Right (YE.Scalar anc t sty text) + Left err -> Left err + + goMap :: Int -> Mapping () -> [Node ()] -> Node2EvList -> EvList + goMap lvl m rest cont = case (mapToList m) of + [] -> Right MappingEnd : isDocEnd (lvl - 1) rest cont + list -> goNode lvl list g + where + g [] = Right MappingEnd : isDocEnd (lvl - 1) rest cont + g rest' = goNode lvl rest' g + mapToList = Map.foldrWithKey (\k v a -> k : v : a) [] + + goSeq :: Int -> [Node ()] -> [Node ()] -> Node2EvList -> EvList + goSeq lvl [] rest cont = Right SequenceEnd : isDocEnd (lvl - 1) rest cont + goSeq lvl nod rest cont = goNode lvl nod g + where + g [] = Right SequenceEnd : isDocEnd (lvl - 1) rest cont + g rest' = goNode lvl rest' g + + goAnchor :: Int -> NodeId -> Node () -> [Node ()] -> Node2EvList -> EvList + goAnchor lvl nid nod rest cont = case nod of + YI.Scalar _ scalar -> goScalar scalar (ancName nid): isDocEnd lvl rest cont + Mapping _ tag m -> Right (MappingStart (ancName nid) (getTag schemaEncoderMapping tag) Block) : goMap (lvl + 1) m rest cont + Sequence _ tag s -> Right (SequenceStart (ancName nid) (getTag schemaEncoderSequence tag) Block) : goSeq (lvl + 1) s rest cont + Anchor _ _ _ -> Left "Anchor has a anchor node" : (cont rest) + + isDocEnd :: Int -> [Node ()] -> Node2EvList -> EvList + isDocEnd lvl rest cont = if lvl == 0 then Right (DocumentEnd (rest /= [])): (cont rest) else (cont rest) + + ancName :: NodeId -> Maybe Anchor + ancName nid + | nid == (0-1) = Nothing + | otherwise = Just $! T.pack ("a" ++ show nid) + + getTag :: (Tag -> Either String Tag) -> Tag -> Tag + getTag f tag = case f tag of + Right t -> t + Left err -> error err + + diff --git a/src/Data/YAML/Event.hs b/src/Data/YAML/Event.hs --- a/src/Data/YAML/Event.hs +++ b/src/Data/YAML/Event.hs @@ -5,81 +5,49 @@ -- Copyright: © Herbert Valerio Riedel 2015-2018 -- SPDX-License-Identifier: GPL-2.0-or-later -- --- Event-stream oriented YAML parsing API +-- Event-stream oriented YAML parsing and serializing API module Data.YAML.Event - ( parseEvents + ( + -- * Tutorial + -- $start + + -- ** Parsing YAML Documents + -- $parsing + parseEvents + + -- ** Serializing Events to YAML Character Stream + -- $serialize + , writeEvents + , writeEventsText + + -- ** How to comment your yaml document for best results + -- $commenting + + -- ** Event-stream Internals , EvStream , Event(..) - , Style(..) + , EvPos(..) + , Directives(..) + , ScalarStyle(..) + , NodeStyle(..) + , Chomp(..) + , IndentOfs(..) , Tag, untagged, isUntagged, tagToText, mkTag , Anchor , Pos(..) ) where -import qualified Data.ByteString.Lazy as BS.L -import Data.Char -import qualified Data.Map as Map -import qualified Data.Text as T -import qualified Data.YAML.Token as Y -import Numeric (readHex) - -import Util - --- TODO: consider also non-essential attributes - --- | YAML Event Types --- --- The events correspond to the ones from [LibYAML](http://pyyaml.org/wiki/LibYAML) --- --- The grammar below defines well-formed streams of 'Event's: --- --- @ --- stream ::= 'StreamStart' document* 'StreamEnd' --- document ::= 'DocumentStart' node 'DocumentEnd' --- node ::= 'Alias' --- | 'Scalar' --- | sequence --- | mapping --- sequence ::= 'SequenceStart' node* 'SequenceEnd' --- mapping ::= 'MappingStart' (node node)* 'MappingEnd' --- @ -data Event - = StreamStart - | StreamEnd - | DocumentStart !Bool - | DocumentEnd !Bool - | Alias !Anchor - | Scalar !(Maybe Anchor) !Tag !Style !Text - | SequenceStart !(Maybe Anchor) !Tag - | SequenceEnd - | MappingStart !(Maybe Anchor) !Tag - | MappingEnd - deriving (Show, Eq) - --- | YAML Anchor identifiers -type Anchor = Text - --- | YAML Tags -newtype Tag = Tag (Maybe Text) - deriving (Eq,Ord) - -instance Show Tag where - show (Tag x) = show x - --- | Convert 'Tag' to its string representation --- --- Returns 'Nothing' for 'untagged' -tagToText :: Tag -> Maybe T.Text -tagToText (Tag x) = x +import Data.YAML.Event.Internal +import Data.YAML.Event.Writer (writeEvents, writeEventsText) --- | An \"untagged\" YAML tag -untagged :: Tag -untagged = Tag Nothing +import qualified Data.ByteString.Lazy as BS.L +import qualified Data.Char as C +import qualified Data.Map as Map +import qualified Data.Text as T +import qualified Data.YAML.Token as Y +import Numeric (readHex) --- | Equivalent to @(== 'untagged')@ -isUntagged :: Tag -> Bool -isUntagged (Tag Nothing) = True -isUntagged _ = False +import Util -- | Construct YAML tag mkTag :: String -> Tag @@ -103,33 +71,18 @@ mkTag'' "" = error "mkTag''" mkTag'' s = Tag (Just $! T.pack ("tag:yaml.org,2002:" ++ s)) - - --- | Event stream produced by 'parseEvents' --- --- A 'Left' value denotes parsing errors. The event stream ends --- immediately once a 'Left' value is returned. -type EvStream = [Either (Pos,String) Event] - --- | Position in parsed YAML source -data Pos = Pos - { posByteOffset :: !Int -- ^ 0-based byte offset - , posCharOffset :: !Int -- ^ 0-based character (Unicode code-point) offset - , posLine :: !Int -- ^ 1-based line number - , posColumn :: !Int -- ^ 0-based character (Unicode code-point) column number - } deriving Show - +-- Returns the position corresponding to the 'Token' tok2pos :: Y.Token -> Pos tok2pos Y.Token { Y.tByteOffset = posByteOffset, Y.tCharOffset = posCharOffset, Y.tLine = posLine, Y.tLineChar = posColumn } = Pos {..} --- | 'Scalar' node style -data Style = Plain - | SingleQuoted - | DoubleQuoted - | Literal - | Folded - deriving (Eq,Ord,Show) +-- Construct a 'EvPos' from the given 'Event' and 'Pos' +getEvPos :: Event -> Y.Token -> EvPos +getEvPos ev tok = EvPos { eEvent = ev , ePos = tok2pos tok } +-- Initial position('Pos' corresponding to the 'StreamStart') +initPos :: Pos +initPos = Pos { posByteOffset = 0 , posCharOffset = 0 , posLine = 1 , posColumn = 0 } + -- internal type TagHandle = Text type Props = (Maybe Text,Tag) @@ -165,13 +118,28 @@ -} +fixUpEOS :: EvStream -> EvStream +fixUpEOS = go initPos + where + go :: Pos -> EvStream -> EvStream + go _ [] = [] + go p [Right (EvPos StreamEnd _)] = [Right (EvPos StreamEnd p)] + go _ (e@(Right (EvPos _ p)):es) = e : go p es + go _ (e@(Left (p,_)):es) = e : go p es + -- | Parse YAML 'Event's from a lazy 'BS.L.ByteString'. -- +-- The parsed Events allow us to round-trip at the event-level while preserving many features and presentation details like +-- 'Comment's,'ScalarStyle','NodeStyle', 'Anchor's, 'Directives' marker along with YAML document version, +-- 'Chomp'ing Indicator,Indentation Indicator ('IndentOfs') ,ordering, etc. +-- It does not preserve non-content white spaces. +-- -- The input 'BS.L.ByteString' is expected to have a YAML 1.2 stream -- using the UTF-8, UTF-16 (LE or BE), or UTF-32 (LE or BE) encodings -- (which will be auto-detected). +-- parseEvents :: BS.L.ByteString -> EvStream -parseEvents = \bs0 -> Right StreamStart : (go0 mempty $ stripComments $ filter (not . isWhite) $ Y.tokenize bs0 False) +parseEvents = \bs0 -> fixUpEOS $ Right (EvPos StreamStart initPos) : (go0 $ filter (not . isWhite) $ Y.tokenize bs0 False) where isTCode tc = (== tc) . Y.tCode skipPast tc (t : ts) @@ -187,68 +155,121 @@ isWhite (Y.Token { Y.tCode = Y.Break }) = True isWhite _ = False - goDir :: Map TagHandle Text -> [Y.Token] -> EvStream - goDir m (Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } : - Y.Token { Y.tCode = Y.Meta, Y.tText = "YAML" } : - Y.Token { Y.tCode = Y.Meta } : - Y.Token { Y.tCode = Y.EndDirective } : - rest) = go0 m rest - goDir m (Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } : - Y.Token { Y.tCode = Y.Meta, Y.tText = "TAG" } : - rest) + go0 :: Tok2EvStream + go0 [] = [Right (EvPos StreamEnd initPos {- fixed up by fixUpEOS -} )] + go0 toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) = goComment toks0 go0 + go0 toks0@(Y.Token { Y.tCode = Y.BeginDocument } : _) = go1 dinfo0 toks0 + go0 (Y.Token { Y.tCode = Y.DocumentEnd } : rest) = go0 rest -- stray/redundant document-end markers cause this + go0 xs = err xs + + + go1 :: DInfo -> Tok2EvStream + go1 m (Y.Token { Y.tCode = Y.BeginDocument } : rest) = goDirs m rest + go1 _ (tok@Y.Token { Y.tCode = Y.EndDocument } : Y.Token { Y.tCode = Y.DocumentEnd } : rest) = ( Right (getEvPos (DocumentEnd True) tok )): go0 rest + go1 _ (tok@Y.Token { Y.tCode = Y.EndDocument } : rest) = ( Right (getEvPos (DocumentEnd False) tok )) : go0 rest + go1 m toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) = goComment toks0 (go1 m) + go1 m (Y.Token { Y.tCode = Y.BeginNode } : rest) = goNode0 m rest (go1 m) + go1 _ xs = err xs + + -- consume {Begin,End}Directives and emit DocumentStart event + goDirs :: DInfo -> Tok2EvStream + goDirs m (Y.Token { Y.tCode = Y.BeginDirective } : rest) = + goDir1 m rest + goDirs m toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) = + goComment toks0 (goDirs m) + goDirs m (tok@Y.Token { Y.tCode = Y.DirectivesEnd } : rest) + | Just (1,mi) <- diVer m = Right (getEvPos (DocumentStart (DirEndMarkerVersion mi)) tok) : go1 m rest + | otherwise = Right (getEvPos (DocumentStart DirEndMarkerNoVersion) tok) : go1 m rest + goDirs _ xs@(Y.Token { Y.tCode = Y.BeginDocument } : _) = + err xs + goDirs m xs@(tok : _) = + Right (getEvPos (DocumentStart NoDirEndMarker) tok) : go1 m xs + goDirs _ xs = + err xs + + -- single directive + goDir1 :: DInfo -> [Y.Token] -> EvStream + goDir1 m toks0@(Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } : + Y.Token { Y.tCode = Y.Meta, Y.tText = "YAML" } : + Y.Token { Y.tCode = Y.Meta, Y.tText = v } : + Y.Token { Y.tCode = Y.EndDirective } : + rest) + | diVer m /= Nothing = errMsg "Multiple %YAML directives" toks0 + | Just (1,mi) <- decodeVer v = goDirs (m { diVer = Just (1,mi) }) rest -- TODO: warn for non-1.2 + | otherwise = errMsg ("Unsupported YAML version " <> show v) toks0 + + goDir1 m toks0@(Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } : + Y.Token { Y.tCode = Y.Meta, Y.tText = "TAG" } : + rest) | Just (h, rest') <- getHandle rest - , Just (t, rest'') <- getUriTag rest' = go0 (Map.insert h t m) (skipPast Y.EndDirective rest'') + , Just (t, rest'') <- getUriTag rest' = case mapInsertNoDupe h t (diTags m) of + Just tm -> goDirs (m { diTags = tm }) (skipPast Y.EndDirective rest'') + Nothing -> errMsg ("Multiple %TAG definitions for handle " <> show h) toks0 - goDir m (Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } : + goDir1 m (Y.Token { Y.tCode = Y.Indicator, Y.tText = "%" } : Y.Token { Y.tCode = Y.Meta, Y.tText = l } : - rest) | l `notElem` ["TAG","YAML"] = go0 m (skipPast Y.EndDirective rest) - goDir _ xs = err xs + rest) | l `notElem` ["TAG","YAML"] = goDirs m (skipPast Y.EndDirective rest) + goDir1 _ xs = err xs - go0 :: Map.Map TagHandle Text -> Tok2EvStream - go0 _ [] = [Right StreamEnd] - go0 _ (Y.Token { Y.tCode = Y.White } : _) = error "the impossible happened" - go0 m (Y.Token { Y.tCode = Y.Indicator } : rest) = go0 m rest -- ignore indicators here - go0 m (Y.Token { Y.tCode = Y.DirectivesEnd } : rest) = go0 m rest - go0 m (Y.Token { Y.tCode = Y.BeginDocument } : Y.Token { Y.tCode = Y.DirectivesEnd } : rest) = Right (DocumentStart True) : go0 m rest -- hack - go0 m (Y.Token { Y.tCode = Y.BeginDocument } : rest@(Y.Token { Y.tCode = Y.BeginDirective } : _)) = Right (DocumentStart True) : go0 m rest -- hack - go0 m (Y.Token { Y.tCode = Y.BeginDocument } : rest) = Right (DocumentStart False) : go0 m rest - go0 _ (Y.Token { Y.tCode = Y.EndDocument } : Y.Token { Y.tCode = Y.DocumentEnd } : rest) = Right (DocumentEnd True) : go0 mempty rest - go0 _ (Y.Token { Y.tCode = Y.EndDocument } : rest) = Right (DocumentEnd False) : go0 mempty rest - go0 m (Y.Token { Y.tCode = Y.DocumentEnd } : rest) = go0 m rest -- should not occur - go0 m (Y.Token { Y.tCode = Y.BeginNode } : rest) = goNode0 m rest (go0 m) - go0 m (Y.Token { Y.tCode = Y.BeginDirective } : rest) = goDir m rest - go0 _ xs = err xs + -- | Decode versions of the form @.@ + decodeVer :: String -> Maybe (Word,Word) + decodeVer s = do + (lhs,'.':rhs) <- Just (break (=='.') s) + (,) <$> readMaybe lhs <*> readMaybe rhs +data DInfo = DInfo { diTags :: Map.Map TagHandle Text + , diVer :: Maybe (Word,Word) + } + +dinfo0 :: DInfo +dinfo0 = DInfo mempty Nothing + +errMsg :: String -> Tok2EvStream +errMsg msg (tok : _) = [Left (tok2pos tok, msg)] +errMsg msg [] = [Left ((Pos (-1) (-1) (-1) (-1)), ("Unexpected end of token stream: " <> msg))] + err :: Tok2EvStream err (tok@Y.Token { Y.tCode = Y.Error, Y.tText = msg } : _) = [Left (tok2pos tok, msg)] err (tok@Y.Token { Y.tCode = Y.Unparsed, Y.tText = txt } : _) = [Left (tok2pos tok, ("Lexical error near " ++ show txt))] err (tok@Y.Token { Y.tCode = code } : _) = [Left (tok2pos tok, ("Parse failure near " ++ show code ++ " token"))] err [] = [Left ((Pos (-1) (-1) (-1) (-1)), "Unexpected end of token stream")] -goNode0 :: Map TagHandle Text -> Tok2EvStreamCont -goNode0 tagmap = goNode +goNode0 :: DInfo -> Tok2EvStreamCont +goNode0 DInfo {..} = goNode where + seqInd "[" = Flow + seqInd "-" = Block + seqInd _ = error "seqInd: internal error" -- impossible + + mapInd "{" = Flow + mapInd _ = error "mapInd: internal error" -- impossible + goNode :: Tok2EvStreamCont - goNode (Y.Token { Y.tCode = Y.BeginScalar } : rest) cont = goScalar (mempty,untagged) rest (flip goNodeEnd cont) - goNode (Y.Token { Y.tCode = Y.BeginSequence } : rest) cont = Right (SequenceStart Nothing untagged) : goSeq rest (flip goNodeEnd cont) - goNode (Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (MappingStart Nothing untagged) : goMap rest (flip goNodeEnd cont) + goNode toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goNode cont) + goNode (tok@Y.Token { Y.tCode = Y.BeginScalar } : rest) cont = goScalar (tok2pos tok) (mempty,untagged) rest (flip goNodeEnd cont) + goNode (tok@Y.Token { Y.tCode = Y.BeginSequence } : Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) cont = Right (getEvPos (SequenceStart Nothing untagged (seqInd ind)) tok): goSeq rest (flip goNodeEnd cont) + goNode (tok@Y.Token { Y.tCode = Y.BeginMapping } : Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) cont = Right (getEvPos (MappingStart Nothing untagged (mapInd ind)) tok) : goMap rest (flip goNodeEnd cont) + goNode (tok@Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (getEvPos (MappingStart Nothing untagged Block) tok) : goMap rest (flip goNodeEnd cont) goNode (Y.Token { Y.tCode = Y.BeginProperties } : rest) cont = goProp (mempty,untagged) rest (\p rest' -> goNode' p rest' cont) - goNode (Y.Token { Y.tCode = Y.BeginAlias } : + goNode (tok@Y.Token { Y.tCode = Y.BeginAlias } : Y.Token { Y.tCode = Y.Indicator } : Y.Token { Y.tCode = Y.Meta, Y.tText = anchor } : Y.Token { Y.tCode = Y.EndAlias } : Y.Token { Y.tCode = Y.EndNode } : - rest) cont = Right (Alias (T.pack anchor)) : cont rest + rest) cont = Right (getEvPos (Alias (T.pack anchor)) tok) : cont rest goNode xs _cont = err xs goNode' :: Props -> Tok2EvStreamCont - goNode' props (Y.Token { Y.tCode = Y.BeginScalar } : rest) cont = goScalar props rest (flip goNodeEnd cont) - goNode' (manchor,mtag) (Y.Token { Y.tCode = Y.BeginSequence } : rest) cont = Right (SequenceStart manchor mtag) : goSeq rest (flip goNodeEnd cont) - goNode' (manchor,mtag) (Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (MappingStart manchor mtag) : goMap rest (flip goNodeEnd cont) + goNode' props toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip (goNode' props) cont) + goNode' props (tok@Y.Token { Y.tCode = Y.BeginScalar } : rest) cont = goScalar (tok2pos tok) props rest (flip goNodeEnd cont) + goNode' (manchor,mtag) (tok@Y.Token { Y.tCode = Y.BeginSequence } : Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) cont = Right (getEvPos (SequenceStart manchor mtag (seqInd ind)) tok) : goSeq rest (flip goNodeEnd cont) + goNode' (manchor,mtag) (tok@Y.Token { Y.tCode = Y.BeginMapping } : Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) cont = Right (getEvPos (MappingStart manchor mtag (mapInd ind)) tok) : goMap rest (flip goNodeEnd cont) + goNode' (manchor,mtag) (tok@Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (getEvPos (MappingStart manchor mtag Block) tok) : goMap rest (flip goNodeEnd cont) goNode' _ xs _cont = err xs goNodeEnd :: Tok2EvStreamCont + goNodeEnd toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goNodeEnd cont) goNodeEnd (Y.Token { Y.tCode = Y.EndNode } : rest) cont = cont rest goNodeEnd xs _cont = err xs @@ -277,7 +298,7 @@ Y.Token { Y.tCode = Y.Meta, Y.tText = tag } : Y.Token { Y.tCode = Y.EndTag } : rest) cont - | Just t' <- Map.lookup (T.pack ("!!")) tagmap + | Just t' <- Map.lookup (T.pack ("!!")) diTags = cont (anchor,mkTag (T.unpack t' ++ tag)) rest | otherwise = cont (anchor,mkTag'' tag) rest @@ -296,7 +317,7 @@ Y.Token { Y.tCode = Y.Meta, Y.tText = tag } : Y.Token { Y.tCode = Y.EndTag } : rest) cont - | Just t' <- Map.lookup (T.pack ("!" ++ h ++ "!")) tagmap + | Just t' <- Map.lookup (T.pack ("!" ++ h ++ "!")) diTags = cont (anchor,mkTag (T.unpack t' ++ tag)) rest | otherwise = err xs @@ -306,31 +327,42 @@ Y.Token { Y.tCode = Y.Meta, Y.tText = tag } : Y.Token { Y.tCode = Y.EndTag } : rest) cont - | Just t' <- Map.lookup (T.pack ("!")) tagmap + | Just t' <- Map.lookup (T.pack ("!")) diTags = cont (anchor,mkTag (T.unpack t' ++ tag)) rest | otherwise = cont (anchor,mkTag' ('!' : tag)) rest -- unresolved goTag _ xs _ = err xs - goScalar :: Props -> Tok2EvStreamCont - goScalar (manchor,tag) toks0 cont = go0 False Plain toks0 + goScalar :: Pos -> Props -> Tok2EvStreamCont + goScalar pos0 (manchor,tag) toks0 cont = go0 False Plain toks0 where go0 ii sty (Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) | "'" <- ind = go' ii "" SingleQuoted rest | "\"" <- ind = go' ii "" DoubleQuoted rest - | "|" <- ind = go0 True Literal rest - | ">" <- ind = go0 True Folded rest + | "|" <- ind = go0 True (Literal Clip IndentAuto) rest + | ">" <- ind = go0 True (Folded Clip IndentAuto) rest - | "+" <- ind = go0 ii sty rest - | "-" <- ind = go0 ii sty rest - | [c] <- ind, '1' <= c, c <= '9' = go0 False sty rest + | "+" <- ind = go0 ii (chn sty Keep) rest + | "-" <- ind = go0 ii (chn sty Strip) rest + | [c] <- ind, '1' <= c, c <= '9' = go0 False (chn' sty (C.digitToInt c)) rest + go0 ii sty tok@(Y.Token { Y.tCode = Y.BeginComment} : _) = goComment tok (go0 ii sty) go0 ii sty (Y.Token { Y.tCode = Y.Text, Y.tText = t } : rest) = go' ii t sty rest go0 ii sty (Y.Token { Y.tCode = Y.LineFold } : rest) = go' ii " " sty rest go0 ii sty (Y.Token { Y.tCode = Y.LineFeed } : rest) = go' ii "\n" sty rest - go0 _ sty (Y.Token { Y.tCode = Y.EndScalar } : rest) = Right (Scalar manchor tag sty mempty) : cont rest + go0 _ sty (Y.Token { Y.tCode = Y.EndScalar } : rest) = Right (EvPos (Scalar manchor tag sty mempty) pos0) : cont rest go0 _ _ xs = err xs + chn :: ScalarStyle -> Chomp -> ScalarStyle + chn (Literal _ digit) chmp = Literal chmp digit + chn (Folded _ digit) chmp = Folded chmp digit + chn _ _ = error "impossible" + + chn' :: ScalarStyle -> Int -> ScalarStyle + chn' (Literal b _) digit = Literal b (toEnum digit) + chn' (Folded b _) digit = Folded b (toEnum digit) + chn' _ _ = error "impossible" + ---------------------------------------------------------------------------- go' ii acc sty (Y.Token { Y.tCode = Y.Text, Y.tText = t } : rest) = go' ii (acc ++ t) sty rest @@ -380,10 +412,9 @@ go' ii acc sty (t@Y.Token { Y.tCode = Y.EndScalar } : rest) - | ii, hasLeadingSpace acc = [Left (tok2pos t, "leading empty lines contain more spaces than the first non-empty line in scalar")] - | otherwise = Right (Scalar manchor tag sty (T.pack acc)) : cont rest + | ii, hasLeadingSpace acc = [Left (tok2pos t, "leading empty lines contain more spaces than the first non-empty line in scalar: " ++ show acc)] + | otherwise = Right (EvPos (Scalar manchor tag sty (T.pack acc)) pos0) : cont rest - go' _ _ _ xs | False = error (show xs) go' _ _ _ xs = err xs hasLeadingSpace (' ':_) = True @@ -391,40 +422,56 @@ hasLeadingSpace _ = False goSeq :: Tok2EvStreamCont - goSeq (Y.Token { Y.tCode = Y.EndSequence } : rest) cont = Right SequenceEnd : cont rest + goSeq (tok@Y.Token { Y.tCode = Y.EndSequence } : rest) cont = Right (getEvPos SequenceEnd tok): cont rest + goSeq toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goSeq cont) goSeq (Y.Token { Y.tCode = Y.BeginNode } : rest) cont = goNode rest (flip goSeq cont) - goSeq (Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (MappingStart Nothing untagged) : goMap rest (flip goSeq cont) + goSeq (tok@Y.Token { Y.tCode = Y.BeginMapping } : Y.Token { Y.tCode = Y.Indicator, Y.tText = ind } : rest) cont = Right (getEvPos (MappingStart Nothing untagged (mapInd ind)) tok) : goMap rest (flip goSeq cont) + goSeq (tok@Y.Token { Y.tCode = Y.BeginMapping } : rest) cont = Right (getEvPos (MappingStart Nothing untagged Block) tok) : goMap rest (flip goSeq cont) goSeq (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goSeq rest cont -- goSeq xs _cont = error (show xs) goSeq xs _cont = err xs goMap :: Tok2EvStreamCont - goMap (Y.Token { Y.tCode = Y.EndMapping } : rest) cont = Right MappingEnd : cont rest + goMap (tok@Y.Token { Y.tCode = Y.EndMapping } : rest) cont = Right (getEvPos MappingEnd tok) : cont rest + goMap toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goMap cont) goMap (Y.Token { Y.tCode = Y.BeginPair } : rest) cont = goPair1 rest (flip goMap cont) goMap (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goMap rest cont goMap xs _cont = err xs goPair1 (Y.Token { Y.tCode = Y.BeginNode } : rest) cont = goNode rest (flip goPair2 cont) + goPair1 toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goPair1 cont) goPair1 (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goPair1 rest cont goPair1 xs _cont = err xs + goPair2 toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goPair2 cont) goPair2 (Y.Token { Y.tCode = Y.BeginNode } : rest) cont = goNode rest (flip goPairEnd cont) goPair2 (Y.Token { Y.tCode = Y.Indicator } : rest) cont = goPair2 rest cont goPair2 xs _cont = err xs + goPairEnd toks0@(Y.Token { Y.tCode = Y.BeginComment} : _) cont = goComment toks0 (flip goPairEnd cont) goPairEnd (Y.Token { Y.tCode = Y.EndPair } : rest) cont = cont rest goPairEnd xs _cont = err xs -stripComments :: [Y.Token] -> [Y.Token] -stripComments (Y.Token { Y.tCode = Y.BeginComment } : rest) = skip rest - where - skip (Y.Token { Y.tCode = Y.EndComment } : rest') = stripComments rest' - skip (_ : rest') = skip rest' - skip [] = error "the impossible happened" -stripComments (t : rest) = t : stripComments rest -stripComments [] = [] +goComment :: Tok2EvStreamCont +goComment (tok@Y.Token { Y.tCode = Y.BeginComment} : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "#" } : + Y.Token { Y.tCode = Y.Meta, Y.tText = comment } : + Y.Token { Y.tCode = Y.EndComment } : rest) cont = (Right (getEvPos (Comment (T.pack comment)) tok)) : cont rest +goComment (tok@Y.Token { Y.tCode = Y.BeginComment} : + Y.Token { Y.tCode = Y.Indicator, Y.tText = "#" } : + Y.Token { Y.tCode = Y.EndComment } : rest) cont = (Right (getEvPos (Comment T.empty) tok)) : cont rest +goComment xs _cont = err xs +-- stripComments :: [Y.Token] -> [Y.Token] +-- stripComments (Y.Token { Y.tCode = Y.BeginComment } : rest) = skip rest +-- where +-- skip (Y.Token { Y.tCode = Y.EndComment } : rest') = stripComments rest' +-- skip (_ : rest') = skip rest' +-- skip [] = error "the impossible happened" +-- stripComments (t : rest) = t : stripComments rest +-- stripComments [] = [] + type Tok2EvStream = [Y.Token] -> EvStream type Tok2EvStreamCont = [Y.Token] -> Cont EvStream [Y.Token] @@ -435,21 +482,21 @@ -- decode 8-hex-digit unicode code-point decodeCP2 :: String -> Maybe Char decodeCP2 s = case s of - [_,_,_,_,_,_,_,_] | all isHexDigit s + [_,_,_,_,_,_,_,_] | all C.isHexDigit s , [(j, "")] <- readHex s -> Just (chr (fromInteger j)) _ -> Nothing -- decode 4-hex-digit unicode code-point decodeCP :: String -> Maybe Char decodeCP s = case s of - [_,_,_,_] | all isHexDigit s + [_,_,_,_] | all C.isHexDigit s , [(j, "")] <- readHex s -> Just (chr (fromInteger j)) _ -> Nothing -- decode 2-hex-digit latin1 code-point decodeL1 :: String -> Maybe Char decodeL1 s = case s of - [_,_] | all isHexDigit s + [_,_] | all C.isHexDigit s , [(j, "")] <- readHex s -> Just (chr (fromInteger j)) _ -> Nothing @@ -482,3 +529,297 @@ ] unescape _ = Nothing +-- +-- $start +-- +-- "Data.YAML" module provides us with API which allow us to interact with YAML data at the cost of some presentation details. +-- In contrast, this module provide us with API which gives us access to a other significant details like 'ScalarStyle's, 'NodeStyle's, 'Comment's, etc. +-- +-- $parsing +-- +-- Suppose you want to parse this YAML Document while preserving its format and comments +-- +-- @ +-- # Home runs +-- hr: 65 +-- # Runs Batted In +-- rbi: 147 +-- @ +-- +-- then you might want to use the function 'parseEvents'. +-- +-- The following is a reference implementation of a function using 'parseEvents'. +-- It takes a YAML document as input and prints the parsed YAML 'Event's. +-- +-- @ +-- import Data.YAML.Event +-- import qualified Data.ByteString.Lazy as BS.L +-- +-- printEvents :: BS.L.ByteString -> IO () +-- printEvents input = +-- forM_ ('parseEvents' input) $ \ev -> case ev of +-- Left _ -> error "Failed to parse" +-- Right event -> print ('eEvent' event) +-- @ +-- +-- When we pass the above mentioned YAML document to the function /printEvents/ it outputs the following: +-- +-- > StreamStart +-- > DocumentStart NoDirEndMarker +-- > MappingStart Nothing Nothing Block +-- > Comment " Home runs" +-- > Scalar Nothing Nothing Plain "hr" +-- > Scalar Nothing Nothing Plain "65" +-- > Comment " Runs Batted In" +-- > Scalar Nothing Nothing Plain "rbi" +-- > Scalar Nothing Nothing Plain "147" +-- > MappingEnd +-- > DocumentEnd False +-- > StreamEnd +-- +-- Notice that now we have all the necessary details in the form of 'Event's. +-- +-- We can now write simple functions to work with this data without losing any more details. +-- +-- $serialize +-- +-- Now, suppose we want to generate back the YAML document after playing with the Event-stream, +-- then you might want to use 'writeEvents'. +-- +-- The following function takes a YAML document as a input and dumps it back to STDOUT after a round-trip. +-- +-- @ +-- import Data.YAML.Event +-- import qualified Data.YAML.Token as YT +-- import qualified Data.ByteString.Lazy as BS.L +-- +-- yaml2yaml :: BS.L.ByteString -> IO () +-- yaml2yaml input = case sequence $ parseEvents input of +-- Left _ -> error "Parsing Failure!" +-- Right events -> do +-- BS.L.hPutStr stdout (writeEvents YT.UTF8 (map eEvent events)) +-- hFlush stdout +-- @ +-- +-- Let this be the sample document passed to the above function +-- +-- @ +-- # This is a 'Directives' Marker +-- --- +-- # All 'Comment's are preserved +-- date : 2019-07-12 +-- bill-to : # 'Anchor' represents a map node +-- &id001 +-- address: +-- lines: # This a Block 'Scalar' with 'Keep' chomping Indicator and 'IndentAuto' Indentant indicator +-- |+ # Extra Indentation (non-content white space) will not be preserved +-- Vijay +-- IIT Hyderabad +-- +-- +-- # Trailing newlines are a preserved here as they are a part of the 'Scalar' node +-- country : India +-- ship-to : # This is an 'Alias' +-- *id001 +-- # Key is a 'Scalar' and Value is a Sequence +-- Other Details: +-- total: $ 3000 +-- # 'Tag's are also preserved +-- Online Payment: !!bool True +-- product: +-- - Item1 +-- # This comment is inside a Sequence +-- - Item2 +-- ... +-- # 'DocumentEnd' True +-- # 'StreamEnd' +-- @ +-- +-- This function outputs the following +-- +-- @ +-- # This is a 'Directives' Marker +-- --- +-- # All 'Comment's are preserved +-- date: 2019-07-12 +-- bill-to: # 'Anchor' represents a map node +-- &id001 +-- address: +-- lines: # This a Block 'Scalar' with 'Keep' chomping Indicator and 'IndentAuto' Indentant indicator +-- # Extra Indentation (non-content white space) will not be preserved +-- |+ +-- Vijay +-- IIT Hyderabad +-- +-- +-- # Trailing newlines are a preserved here as they are a part of the 'Scalar' node +-- country: India +-- ship-to: # This is an 'Alias' +-- *id001 +-- # Key is a 'Scalar' and Value is a Sequence +-- Other Details: +-- total: $ 3000 +-- # 'Tag's are also preserved +-- Online Payment: !!bool True +-- product: +-- - Item1 +-- # This comment is inside a Sequence +-- - Item2 +-- ... +-- # 'DocumentEnd' True +-- # 'StreamEnd' +-- @ +-- +-- $commenting +-- +-- Round-tripping at event-level will preserve all the comments and their relative position in the YAML-document but still, +-- we lose some information like the exact indentation and the position at which the comments were present previously. +-- This information sometimes can be quite important for human-perception of comments. +-- Below are some guildlines, so that you can avoid ambiguities. +-- +-- 1) Always try to start your comment in a newline. This step will avoid most of the ambiguities. +-- +-- 2) Comments automaticly get indented according to the level in which they are present. For example, +-- +-- Input YAML-document +-- +-- @ +-- # Level 0 +-- - a +-- # Level 0 +-- - - a +-- # Level 1 +-- - a +-- - - a +-- # Level 2 +-- - a +-- @ +-- +-- After a round-trip looks like +-- +-- @ +-- # Level 0 +-- - a +-- # Level 0 +-- - - a +-- # Level 1 +-- - a +-- - - a +-- # Level 2 +-- - a +-- @ +-- +-- 3) Comments immediately after a 'Scalar' node, start from a newline. So avoid commenting just after a scalar ends, as it may lead to some ambiguity. For example, +-- +-- Input YAML-document +-- +-- @ +-- - scalar # After scalar +-- - random : scalar # After scalar +-- key: 1 +-- # not after scalar +-- - random : scalar +-- key: 1 +-- - random : # not after scalar +-- scalar +-- # not after scalar +-- key: 1 +-- @ +-- +-- After a round-trip looks like +-- +-- @ +-- - scalar +-- # After scalar +-- - random: scalar +-- # After scalar +-- key: 1 +-- # not after scalar +-- - random: scalar +-- key: 1 +-- - random: # not after scalar +-- scalar +-- # not after scalar +-- key: 1 +-- @ +-- +-- 4) Similarly in flow-style, avoid commenting immediately after a /comma/ (@,@) seperator. Comments immediately after a /comma/ (@,@) seperator will start from a new line +-- +-- Input YAML-document +-- +-- @ +-- { +-- # comment 0 +-- Name: Vijay # comment 1 +-- , +-- # comment 2 +-- age: 19, # comment 3 +-- # comment 4 +-- country: India # comment 5 +-- } +-- @ +-- +-- After a round-trip looks like +-- +-- @ +-- { +-- # comment 0 +-- Name: Vijay, +-- # comment 1 +-- # comment 2 +-- age: 19, +-- # comment 3 +-- # comment 4 +-- country: India, +-- # comment 5 +-- } +-- @ +-- +-- 5) Avoid commenting in between syntatical elements. For example, +-- +-- Input YAML-document +-- +-- @ +-- ? # Complex key starts +-- [ +-- a, +-- b +-- ] +-- # Complex key ends +-- : # Complex Value starts +-- ? # Complex key starts +-- [ +-- a, +-- b +-- ] +-- # Complex key ends +-- : # Simple value +-- a +-- # Complex value ends +-- @ +-- +-- After a round-trip looks like +-- +-- @ +-- ? # Complex key starts +-- [ +-- a, +-- b +-- ] +-- : # Complex key ends +-- # Complex Value starts +-- +-- ? # Complex key starts +-- [ +-- a, +-- b +-- ] +-- : # Complex key ends +-- # Simple value +-- a +-- # Complex value ends +-- @ +-- +-- The above two YAML-documents, after parsing produce the same 'Event'-stream. +-- +-- So, these are some limitation of this Format-preserving YAML processor. diff --git a/src/Data/YAML/Event/Internal.hs b/src/Data/YAML/Event/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Event/Internal.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-2.0-or-later +-- +module Data.YAML.Event.Internal + ( EvStream + , Event(..) + , EvPos(..) + , Directives(..) + , ScalarStyle(..) + , Chomp(..) + , IndentOfs(..) + , NodeStyle(..) + , scalarNodeStyle + , Tag(..), untagged, isUntagged, tagToText + , Anchor + , Pos(..) + , Y.Encoding(..) + ) where + + +import qualified Data.Text as T +import Data.YAML.Pos (Pos (..)) +import qualified Data.YAML.Token as Y + +import Util + + +-- | YAML Event Types +-- +-- The events correspond to the ones from [LibYAML](http://pyyaml.org/wiki/LibYAML) +-- +-- The grammar below defines well-formed streams of 'Event's: +-- +-- @ +-- stream ::= 'StreamStart' document* 'StreamEnd' +-- document ::= 'DocumentStart' node 'DocumentEnd' +-- node ::= 'Alias' +-- | 'Scalar' +-- | 'Comment' +-- | sequence +-- | mapping +-- sequence ::= 'SequenceStart' node* 'SequenceEnd' +-- mapping ::= 'MappingStart' (node node)* 'MappingEnd' +-- @ +-- +-- @since 0.2.0 +data Event + = StreamStart + | StreamEnd + | DocumentStart !Directives + | DocumentEnd !Bool + | Comment !Text + | Alias !Anchor + | Scalar !(Maybe Anchor) !Tag !ScalarStyle !Text + | SequenceStart !(Maybe Anchor) !Tag !NodeStyle + | SequenceEnd + | MappingStart !(Maybe Anchor) !Tag !NodeStyle + | MappingEnd + deriving (Show, Eq, Generic) + +-- | @since 0.2.0 +instance NFData Event where + rnf StreamStart = () + rnf StreamEnd = () + rnf (DocumentStart _) = () + rnf (DocumentEnd _) = () + rnf (Comment _) = () + rnf (Alias _) = () + rnf (Scalar a _ _ _) = rnf a + rnf (SequenceStart a _ _) = rnf a + rnf SequenceEnd = () + rnf (MappingStart a _ _) = rnf a + rnf MappingEnd = () + +-- |'Event' with corresponding Pos in YAML stream +-- +-- @since 0.2.0 +data EvPos = EvPos + { eEvent :: !Event + , ePos :: !Pos + } deriving (Eq, Show, Generic) + +-- | @since 0.2.0 +instance NFData EvPos where rnf (EvPos ev p) = rnf (ev,p) + +-- | Encodes document @%YAML@ directives and the directives end-marker +-- +-- @since 0.2.0 +data Directives = NoDirEndMarker -- ^ no directives and also no @---@ marker + | DirEndMarkerNoVersion -- ^ @---@ marker present, but no explicit @%YAML@ directive present + | DirEndMarkerVersion !Word -- ^ @---@ marker present, as well as a @%YAML 1.mi@ version directive; the minor version @mi@ is stored in the 'Word' field. + deriving (Show, Eq, Generic) + +-- | @since 0.2.0 +instance NFData Directives where rnf !_ = () + +-- | 'Scalar'-specific node style +-- +-- This can be considered a more granular superset of 'NodeStyle'. +-- See also 'scalarNodeStyle'. +-- +-- @since 0.2.0 +data ScalarStyle = Plain + | SingleQuoted + | DoubleQuoted + | Literal !Chomp !IndentOfs + | Folded !Chomp !IndentOfs + deriving (Eq,Ord,Show,Generic) + +-- | @since 0.2.0 +instance NFData ScalarStyle where rnf !_ = () + +-- | +-- +-- @since 0.2.0 +data Chomp = Strip -- ^ Remove all trailing line breaks and shows the presence of @-@ chomping indicator. + | Clip -- ^ Keep first trailing line break; this also the default behavior used if no explicit chomping indicator is specified. + | Keep -- ^ Keep all trailing line breaks and shows the presence of @+@ chomping indicator. + deriving (Eq,Ord,Show,Generic) + +-- | @since 0.2.0 +instance NFData Chomp where rnf !_ = () + +-- | Block Indentation Indicator +-- +-- 'IndentAuto' is the special case for auto Block Indentation Indicator +-- +-- @since 0.2.0 +data IndentOfs = IndentAuto | IndentOfs1 | IndentOfs2 | IndentOfs3 | IndentOfs4 | IndentOfs5 | IndentOfs6 | IndentOfs7 | IndentOfs8 | IndentOfs9 + deriving (Eq, Ord, Show, Enum, Generic) + +-- | @since 0.2.0 +instance NFData IndentOfs where rnf !_ = () + +-- | Node style +-- +-- @since 0.2.0 +data NodeStyle = Flow + | Block + deriving (Eq,Ord,Show,Generic) + +-- | @since 0.2.0 +instance NFData NodeStyle where rnf !_ = () + +-- | Convert 'ScalarStyle' to 'NodeStyle' +-- +-- @since 0.2.0 +scalarNodeStyle :: ScalarStyle -> NodeStyle +scalarNodeStyle Plain = Flow +scalarNodeStyle SingleQuoted = Flow +scalarNodeStyle DoubleQuoted = Flow +scalarNodeStyle (Literal _ _) = Block +scalarNodeStyle (Folded _ _ ) = Block + +-- | YAML Anchor identifiers +type Anchor = Text + +-- | YAML Tags +newtype Tag = Tag (Maybe Text) + deriving (Eq,Ord,Generic) + +instance Show Tag where + show (Tag x) = show x + +-- | @since 0.2.0 +instance NFData Tag where rnf (Tag x) = rnf x + +-- | Event stream produced by 'Data.YAML.Event.parseEvents' +-- +-- A 'Left' value denotes parsing errors. The event stream ends +-- immediately once a 'Left' value is returned. +type EvStream = [Either (Pos,String) EvPos] + + +-- | Convert 'Tag' to its string representation +-- +-- Returns 'Nothing' for 'untagged' +tagToText :: Tag -> Maybe T.Text +tagToText (Tag x) = x + +-- | An \"untagged\" YAML tag +untagged :: Tag +untagged = Tag Nothing + +-- | Equivalent to @(== 'untagged')@ +isUntagged :: Tag -> Bool +isUntagged (Tag Nothing) = True +isUntagged _ = False + diff --git a/src/Data/YAML/Event/Writer.hs b/src/Data/YAML/Event/Writer.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Event/Writer.hs @@ -0,0 +1,519 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} + + +-- | +-- Copyright: © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-2.0-or-later +-- +-- Event-stream oriented YAML writer API +-- +module Data.YAML.Event.Writer + ( writeEvents + , writeEventsText + ) where + +import Data.YAML.Event.Internal + +import qualified Data.ByteString.Lazy as BS.L +import qualified Data.Char as C +import qualified Data.Map as Map +import qualified Data.Text as T +import Text.Printf (printf) + +import qualified Data.Text.Lazy as T.L +import qualified Data.Text.Lazy.Builder as T.B +import qualified Data.Text.Lazy.Encoding as T.L + +import Util + + +{- WARNING: the code that follows will make you cry; a safety pig is provided below for your benefit. + + _ + _._ _..._ .-', _.._(`)) +'-. ` ' /-._.-' ',/ + ) \ '. + / _ _ | \ + | a a / | + \ .-. ; + '-('' ).-' ,' ; + '-; | .' + \ \ / + | 7 .__ _.-\ \ + | | | ``/ /` / + /,_| | /,_/ / + /,_/ '`-' + +-} + +-- | Serialise 'Event's using specified UTF encoding to a lazy 'BS.L.ByteString' +-- +-- __NOTE__: This function is only well-defined for valid 'Event' streams +-- +-- @since 0.2.0.0 +writeEvents :: Encoding -> [Event] -> BS.L.ByteString +writeEvents UTF8 = T.L.encodeUtf8 . writeEventsText +writeEvents UTF16LE = T.L.encodeUtf16LE . T.L.cons '\xfeff' . writeEventsText +writeEvents UTF16BE = T.L.encodeUtf16BE . T.L.cons '\xfeff' . writeEventsText +writeEvents UTF32LE = T.L.encodeUtf32LE . T.L.cons '\xfeff' . writeEventsText +writeEvents UTF32BE = T.L.encodeUtf32BE . T.L.cons '\xfeff' . writeEventsText + +-- | Serialise 'Event's to lazy 'T.L.Text' +-- +-- __NOTE__: This function is only well-defined for valid 'Event' streams +-- +-- @since 0.2.0.0 +writeEventsText :: [Event] -> T.L.Text +writeEventsText [] = mempty +writeEventsText (StreamStart:xs) = T.B.toLazyText $ goStream xs (error "writeEvents: internal error") + where + -- goStream :: [Event] -> [Event] -> T.B.Builder + goStream [StreamEnd] _ = mempty + goStream (StreamEnd : _ : _ ) _cont = error "writeEvents: events after StreamEnd" + goStream (Comment com: rest) cont = goComment (0 :: Int) True BlockIn com (goStream rest cont) + goStream (DocumentStart marker : rest) cont + = case marker of + NoDirEndMarker -> putNode False rest (\zs -> goDoc zs cont) + DirEndMarkerNoVersion -> "---" <> putNode True rest (\zs -> goDoc zs cont) + DirEndMarkerVersion mi -> "%YAML 1." <> (T.B.fromString (show mi)) <> "\n---" <> putNode True rest (\zs -> goDoc zs cont) + goStream (x:_) _cont = error ("writeEvents: unexpected " ++ show x ++ " (expected DocumentStart or StreamEnd)") + goStream [] _cont = error ("writeEvents: unexpected end of stream (expected DocumentStart or StreamEnd)") + + goDoc (DocumentEnd marker : rest) cont + = (if marker then "...\n" else mempty) <> goStream rest cont + goDoc (Comment com: rest) cont = goComment (0 :: Int) True BlockIn com (goDoc rest cont) + goDoc ys _ = error (show ys) + + -- unexpected s l = error ("writeEvents: unexpected " ++ show l ++ " " ++ show s) + +writeEventsText (x:_) = error ("writeEvents: unexpected " ++ show x ++ " (expected StreamStart)") + +-- | Production context -- copied from Data.YAML.Token +data Context = BlockOut -- ^ Outside block sequence. + | BlockIn -- ^ Inside block sequence. + | BlockKey -- ^ Implicit block key. + | FlowOut -- ^ Outside flow collection. + | FlowIn -- ^ Inside flow collection. + | FlowKey -- ^ Implicit flow key. + deriving (Eq,Show) + +goComment :: Int -> Bool -> Context -> T.Text -> T.B.Builder -> T.B.Builder +goComment !n !sol c comment cont = doSol <> "#" <> (T.B.fromText comment) <> doEol <> doIndent <> cont + where + doEol + | not sol && n == 0 = mempty -- "--- " case + | sol && FlowIn == c = mempty + | otherwise = eol + + doSol + | not sol && (BlockOut == c || FlowOut == c) = ws + | sol = mkInd n' + | otherwise = eol <> mkInd n' + + n' + | BlockOut <- c = max 0 (n - 1) + | FlowOut <- c = n + 1 + | otherwise = n + + doIndent + | BlockOut <- c = mkInd n' + | FlowOut <- c = mkInd n' + | otherwise = mempty + +putNode :: Bool -> [Event] -> ([Event] -> T.B.Builder) -> T.B.Builder +putNode = \docMarker -> go (-1 :: Int) (not docMarker) BlockIn + where + + {- s-l+block-node(n,c) + + [196] s-l+block-node(n,c) ::= s-l+block-in-block(n,c) | s-l+flow-in-block(n) + + [197] s-l+flow-in-block(n) ::= s-separate(n+1,flow-out) ns-flow-node(n+1,flow-out) s-l-comments + + [198] s-l+block-in-block(n,c) ::= s-l+block-scalar(n,c) | s-l+block-collection(n,c) + + [199] s-l+block-scalar(n,c) ::= s-separate(n+1,c) ( c-ns-properties(n+1,c) s-separate(n+1,c) )? ( c-l+literal(n) | c-l+folded(n) ) + + [200] s-l+block-collection(n,c) ::= ( s-separate(n+1,c) c-ns-properties(n+1,c) )? s-l-comments + ( l+block-sequence(seq-spaces(n,c)) | l+block-mapping(n) ) + + [201] seq-spaces(n,c) ::= c = block-out ⇒ n-1 + c = block-in ⇒ n + + -} + + go :: Int -> Bool -> Context -> [Event] -> ([Event] -> T.B.Builder) -> T.B.Builder + go _ _ _ [] _cont = error ("putNode: expected node-start event instead of end-of-stream") + go !n !sol c (t : rest) cont = case t of + Scalar anc tag sty t' -> goStr (n+1) sol c anc tag sty t' (cont rest) + SequenceStart anc tag sty -> goSeq (n+1) sol (chn sty) anc tag sty rest cont + MappingStart anc tag sty -> goMap (n+1) sol (chn sty) anc tag sty rest cont + Alias a -> pfx <> goAlias c a (cont rest) + Comment com -> goComment (n+1) sol c com (go n sol c rest cont) + _ -> error ("putNode: expected node-start event instead of " ++ show t) + + where + pfx | sol = mempty + | BlockKey <- c = mempty + | FlowKey <- c = mempty + | otherwise = T.B.singleton ' ' + + chn sty + | Flow <-sty, (BlockIn == c || BlockOut == c) = FlowOut + | otherwise = c + + + goMap _ sol _ anc tag _ (MappingEnd : rest) cont = pfx $ "{}\n" <> cont rest + where + pfx cont' = wsSol sol <> anchorTag'' (Right ws) anc tag cont' + + goMap n sol c anc tag Block xs cont = case c of + BlockIn | not (not sol && n == 0) -- avoid "--- " case + -> wsSol sol <> anchorTag'' (Right (eol <> mkInd n)) anc tag + (putKey xs putValue') + _ -> anchorTag'' (Left ws) anc tag $ doEol <> g' xs + where + g' (MappingEnd : rest) = cont rest -- All comments should be part of the key + g' ys = pfx <> putKey ys putValue' + + g (Comment com: rest) = goComment n True c' com (g rest) -- For trailing comments + g (MappingEnd : rest) = cont rest + g ys = pfx <> putKey ys putValue' + + pfx = if c == BlockIn || c == BlockOut || c == BlockKey then mkInd n else ws + c' = if FlowIn == c then FlowKey else BlockKey + + doEol = case c of + FlowKey -> mempty + FlowIn -> mempty + _ -> eol + + putKey zs cont2 + | isSmallKey zs = go n (n == 0) c' zs (\ys -> ":" <> cont2 ys) + | Comment com: rest <- zs = "?" <> ws <> goComment 0 True BlockIn com (f rest cont2) + | otherwise = "?" <> go n False BlockIn zs (putValue cont2) + + f (Comment com: rest) cont2 = goComment (n + 1) True BlockIn com (f rest cont2) -- Comments should not change position in key + f zs cont2 = ws <> mkInd n <> go n False BlockIn zs (putValue cont2) + + putValue cont2 zs + | FlowIn <- c = ws <> mkInd (n - 1) <> ":" <> cont2 zs + | otherwise = mkInd n <> ":" <> cont2 zs + + putValue' (Comment com: rest) = goComment (n + 1) False BlockOut com (ws <> putValue' rest) -- Comments should not change position in value + putValue' zs = go n False (if FlowIn == c then FlowIn else BlockOut) zs g + + goMap n sol c anc tag Flow xs cont = + wsSol sol <> anchorTag'' (Right ws) anc tag ("{" <> f xs) + where + f (Comment com: rest) = eol <> wsSol sol <> goComment n' True (inFlow c) com (f rest) + f (MappingEnd : rest) = eol <> wsSol sol <> mkInd (n - 1) <> "}" <> doEol <> cont rest + f ys = eol <> mkInd n' <> putKey ys putValue' + + n' = n + 1 + + doEol = case c of + FlowKey -> mempty + FlowIn -> mempty + _ -> eol + + g (Comment com: rest) = "," <> eol <> wsSol sol <> goComment n' True (inFlow c) com (f rest) + g (MappingEnd : rest) = eol <> wsSol sol <> mkInd (n - 1) <> "}" <> doEol <> cont rest + g ys = "," <> eol <> mkInd n' <> putKey ys putValue' + + putKey zs cont2 + | (Comment com: rest) <- zs = goComment n' True c com (eol <> mkInd n' <> putKey rest cont2) + | isSmallKey zs = go n' (n == 0) FlowKey zs (if isComEv zs then putValue cont2 else (\ys -> ":" <> cont2 ys)) + | otherwise = "?" <> go n False FlowIn zs (putValue cont2) + + putValue cont2 zs + | Comment com: rest <- zs = eol <> wsSol sol <> goComment n' True (inFlow c) com (putValue cont2 rest) + | otherwise = eol <> mkInd n' <> ":" <> cont2 zs + + putValue' zs + | Comment com : rest <- zs = goComment n' False FlowOut com (putValue' rest) + | otherwise = go n' False FlowIn zs g + + + goSeq _ sol _ anc tag _ (SequenceEnd : rest) cont = pfx $ "[]\n" <> cont rest + where + pfx cont' = wsSol sol <> anchorTag'' (Right ws) anc tag cont' + + goSeq n sol c anc tag Block xs cont = case c of + BlockOut -> anchorTag'' (Left ws) anc tag (eol <> if isComEv xs then "-" <> eol <> f xs else g xs) + + BlockIn + | not sol && n == 0 {- "---" case -} -> goSeq n sol BlockOut anc tag Block xs cont + | Comment com: rest <- xs -> wsSol sol <> anchorTag'' (Right (eol <> mkInd n')) anc tag ("-" <> ws <> goComment 0 True BlockIn com (f rest)) + | otherwise -> wsSol sol <> anchorTag'' (Right (eol <> mkInd n')) anc tag ("-" <> go n' False BlockIn xs g) + + BlockKey -> error "sequence in block-key context not supported" + + _ -> error "Invalid Context in Block style" + + where + n' | BlockOut <- c = max 0 (n - 1) + | otherwise = n + + g (Comment com: rest) = goComment n' True BlockIn com (g rest) + g (SequenceEnd : rest) = cont rest + g ys = mkInd n' <> "-" <> go n' False BlockIn ys g + + f (Comment com: rest) = goComment n' True BlockIn com (f rest) + f (SequenceEnd : rest) = cont rest + f ys = ws <> mkInd n' <> go n' False BlockIn ys g + + goSeq n sol c anc tag Flow xs cont = + wsSol sol <> anchorTag'' (Right ws) anc tag ("[" <> f xs) + where + f (Comment com: rest) = eol <> wsSol sol <> goComment n' True (inFlow c) com (f rest) + f (SequenceEnd : rest) = eol <> wsSol sol <> mkInd (n - 1) <> "]" <> doEol <> cont rest + f ys = eol <> mkInd n' <> go n' False (inFlow c) ys g + + n' = n + 1 + + doEol = case c of + FlowKey -> mempty + FlowIn -> mempty + _ -> eol + + g (Comment com: rest) = "," <> eol <> wsSol sol <> goComment n' True (inFlow c) com (f rest) + g (SequenceEnd : rest) = eol <> wsSol sol <> mkInd (n - 1) <> "]" <> doEol <> cont rest + g ys = "," <> eol <> mkInd n' <> go n' False (inFlow c) ys g + + + goAlias c a cont = T.B.singleton '*' <> T.B.fromText a <> sep <> cont + where + sep = case c of + BlockIn -> eol + BlockOut -> eol + BlockKey -> T.B.singleton ' ' + FlowIn -> mempty + FlowOut -> eol + FlowKey -> T.B.singleton ' ' + + goStr :: Int -> Bool -> Context -> Maybe Anchor -> Tag -> ScalarStyle -> Text -> T.B.Builder -> T.B.Builder + goStr !n !sol c anc tag sty t cont = case sty of + -- flow-style + + Plain -- empty scalars + | t == "" -> case () of + _ | Nothing <- anc, Tag Nothing <- tag -> contEol -- not even node properties + | sol -> anchorTag0 anc tag (if c == BlockKey || c == FlowKey then ws <> cont else contEol) + | BlockKey <- c -> anchorTag0 anc tag (ws <> cont) + | FlowKey <- c -> anchorTag0 anc tag (ws <> cont) + | otherwise -> anchorTag'' (Left ws) anc tag contEol + + Plain -> pfx $ + let h [] = contEol + h (x:xs) = T.B.fromText x <> f' xs + where + f' [] = contEol + f' (y:ys) = eol <> mkInd (n+1) <> T.B.fromText y <> f' ys + in h (insFoldNls (T.lines t)) -- FIXME: unquoted plain-strings can't handle leading/trailing whitespace properly + + SingleQuoted -> pfx $ T.B.singleton '\'' <> f (insFoldNls $ T.lines (T.replace "'" "''" t) ++ [ mempty | T.isSuffixOf "\n" t]) (T.B.singleton '\'' <> contEol) -- FIXME: leading white-space (i.e. SPC) before/after LF + + DoubleQuoted -> pfx $ T.B.singleton '"' <> T.B.fromText (escapeDQ t) <> T.B.singleton '"' <> contEol + + -- block style + Folded chm iden -> pfx $ ">" <> goChomp chm <> goDigit iden <> g (insFoldNls' $ T.lines t) (fromEnum iden) cont + + Literal chm iden -> pfx $ "|" <> goChomp chm <> goDigit iden <> g (T.lines t) (fromEnum iden) cont + + where + goDigit :: IndentOfs -> T.B.Builder + goDigit iden = let ch = C.intToDigit.fromEnum $ iden + in if(ch == '0') then mempty else T.B.singleton ch + + goChomp :: Chomp -> T.B.Builder + goChomp chm = case chm of + Strip -> T.B.singleton '-' + Clip -> mempty + Keep -> T.B.singleton '+' + + pfx cont' = (if sol || c == BlockKey || c == FlowKey then mempty else ws) <> anchorTag'' (Right ws) anc tag cont' + + doEol = case c of + BlockKey -> False + FlowKey -> False + FlowIn -> False + _ -> True + + contEol + | doEol = eol <> cont + | otherwise = cont + + g [] _ cont' = eol <> cont' + g (x:xs) dig cont' + | T.null x = eol <> g xs dig cont' + | dig == 0 = eol <> (if n > 0 then mkInd n else mkInd' 1) <> T.B.fromText x <> g xs dig cont' + | otherwise = eol <> mkInd (n-1) <> mkInd' dig <> T.B.fromText x <> g xs dig cont' + + g' [] cont' = cont' + g' (x:xs) cont' = eol <> mkInd (n+1) <> T.B.fromText x <> g' xs cont' + + f [] cont' = cont' + f (x:xs) cont' = T.B.fromText x <> g' xs cont' + + + isSmallKey (Alias _ : _) = True + isSmallKey (Scalar _ _ (Folded _ _) _: _) = False + isSmallKey (Scalar _ _ (Literal _ _) _: _) = False + isSmallKey (Scalar _ _ _ _ : _) = True + isSmallKey (SequenceStart _ _ _ : _) = False + isSmallKey (MappingStart _ _ _ : _) = False + isSmallKey _ = False + + -- + inFlow c = case c of + FlowIn -> FlowIn + FlowOut -> FlowIn + BlockKey -> FlowKey + FlowKey -> FlowKey + _ -> error "Invalid context in Flow style" + + + putTag t cont + | Just t' <- T.stripPrefix "tag:yaml.org,2002:" t = "!!" <> T.B.fromText t' <> cont + | "!" `T.isPrefixOf` t = T.B.fromText t <> cont + | otherwise = "!<" <> T.B.fromText t <> T.B.singleton '>' <> cont + + anchorTag'' :: Either T.B.Builder T.B.Builder -> Maybe Anchor -> Tag -> T.B.Builder -> T.B.Builder + anchorTag'' _ Nothing (Tag Nothing) cont = cont + anchorTag'' (Right pad) Nothing (Tag (Just t)) cont = putTag t (pad <> cont) + anchorTag'' (Right pad) (Just a) (Tag Nothing) cont = T.B.singleton '&' <> T.B.fromText a <> pad <> cont + anchorTag'' (Right pad) (Just a) (Tag (Just t)) cont = T.B.singleton '&' <> T.B.fromText a <> T.B.singleton ' ' <> putTag t (pad <> cont) + anchorTag'' (Left pad) Nothing (Tag (Just t)) cont = pad <> putTag t cont + anchorTag'' (Left pad) (Just a) (Tag Nothing) cont = pad <> T.B.singleton '&' <> T.B.fromText a <> cont + anchorTag'' (Left pad) (Just a) (Tag (Just t)) cont = pad <> T.B.singleton '&' <> T.B.fromText a <> T.B.singleton ' ' <> putTag t cont + + anchorTag0 = anchorTag'' (Left mempty) + -- anchorTag = anchorTag'' (Right (T.B.singleton ' ')) + -- anchorTag' = anchorTag'' (Left (T.B.singleton ' ')) + +isComEv :: [Event] -> Bool +isComEv (Comment _: _) = True +isComEv _ = False + +-- indentation helper +mkInd :: Int -> T.B.Builder +mkInd (-1) = mempty +mkInd 0 = mempty +mkInd 1 = " " +mkInd 2 = " " +mkInd 3 = " " +mkInd 4 = " " +mkInd l + | l < 0 = error (show l) + | otherwise = T.B.fromText (T.replicate l " ") + +mkInd' :: Int -> T.B.Builder +mkInd' 1 = " " +mkInd' 2 = " " +mkInd' 3 = " " +mkInd' 4 = " " +mkInd' 5 = " " +mkInd' 6 = " " +mkInd' 7 = " " +mkInd' 8 = " " +mkInd' 9 = " " +mkInd' l = error ("Impossible Indentation-level" ++ show l) + +eol, ws:: T.B.Builder +eol = T.B.singleton '\n' +ws = T.B.singleton ' ' + +wsSol :: Bool -> T.B.Builder +wsSol sol = if sol then mempty else ws + +escapeDQ :: Text -> Text +escapeDQ t + | T.all (\c -> C.isPrint c && c /= '\\' && c /= '"') t = t + | otherwise = T.concatMap escapeChar t + +escapeChar :: Char -> Text +escapeChar c + | c == '\\' = "\\\\" + | c == '"' = "\\\"" + | C.isPrint c = T.singleton c + | Just e <- Map.lookup c emap = e + | x <= 0xff = T.pack (printf "\\x%02x" x) + | x <= 0xffff = T.pack (printf "\\u%04x" x) + | otherwise = T.pack (printf "\\U%08x" x) + where + x = ord c + + emap = Map.fromList [ (v,T.pack ['\\',k]) | (k,v) <- escapes ] + + +escapes :: [(Char,Char)] +escapes = + [ ('0', '\0') + , ('a', '\x7') + , ('b', '\x8') + , ('\x9', '\x9') + , ('t', '\x9') + , ('n', '\xa') + , ('v', '\xb') + , ('f', '\xc') + , ('r', '\xd') + , ('e', '\x1b') + , (' ', ' ') + , ('"', '"') + , ('/', '/') + , ('\\', '\\') + , ('N', '\x85') + , ('_', '\xa0') + , ('L', '\x2028') + , ('P', '\x2029') + ] + + +-- flow style line folding +-- FIXME: check single-quoted strings with leading '\n' or trailing '\n's +insFoldNls :: [Text] -> [Text] +insFoldNls [] = [] +insFoldNls z0@(z:zs) + | all T.null z0 = "" : z0 -- HACK + | otherwise = z : go zs + where + go [] = [] + go (l:ls) + | T.null l = l : go' ls + | otherwise = "" : l : go ls + + go' [] = [""] + go' (l:ls) + | T.null l = l : go' ls + | otherwise = "" : l : go ls + +{- block style line folding + +The combined effect of the block line folding rules is that each +“paragraph” is interpreted as a line, empty lines are interpreted as a +line feed, and the formatting of more-indented lines is preserved. + +-} +insFoldNls' :: [Text] -> [Text] +insFoldNls' = go' + where + go [] = [] + go (l:ls) + | T.null l = l : go ls + | isWhite (T.head l) = l : go' ls + | otherwise = "" : l : go ls + + go' [] = [] + go' (l:ls) + | T.null l = l : go' ls + | isWhite (T.head l) = l : go' ls + | otherwise = l : go ls + + -- @s-white@ + isWhite :: Char -> Bool + isWhite ' ' = True + isWhite '\t' = True + isWhite _ = False diff --git a/src/Data/YAML/Internal.hs b/src/Data/YAML/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Internal.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-2.0-or-later +-- +module Data.YAML.Internal + ( Node(..) + , nodeLoc + , NodeId + , Doc(..) + , Mapping + ) where + +import qualified Data.Map as Map + +import Data.YAML.Event (Tag) +import Data.YAML.Loader (NodeId) +import Data.YAML.Schema.Internal (Scalar (..)) + +import Util + +-- | YAML Document tree/graph +-- +-- __NOTE__: In future versions of this API meta-data about the YAML document might be included as additional fields inside 'Doc' +newtype Doc n = Doc + { docRoot :: n -- ^ @since 0.2.1 + } deriving (Eq,Ord,Show,Generic) + +-- | @since 0.2.0 +instance NFData n => NFData (Doc n) where + rnf (Doc n) = rnf n + +-- | @since 0.2.1 +instance Functor Doc where + fmap f (Doc n) = Doc (f n) + x <$ _ = Doc x + +-- | YAML mapping +type Mapping loc = Map (Node loc) (Node loc) + +-- | YAML Document node +-- +-- @since 0.2.0 +data Node loc + = Scalar !loc !Scalar + | Mapping !loc !Tag (Mapping loc) + | Sequence !loc !Tag [Node loc] + | Anchor !loc !NodeId !(Node loc) + deriving (Show,Generic) + +nodeLoc :: Node loc -> loc +nodeLoc (Scalar pos _) = pos +nodeLoc (Anchor pos _ _) = pos +nodeLoc (Mapping pos _ _) = pos +nodeLoc (Sequence pos _ _) = pos + +instance Functor Node where + fmap f node = case node of + Scalar x scalar -> Scalar (f x) scalar + Mapping x tag m -> Mapping (f x) tag (mappingFmapLoc f m) + Sequence x tag s -> Sequence (f x) tag (map (fmap f) s) + Anchor x n nod -> Anchor (f x) n (fmap f nod) + +mappingFmapLoc :: (a -> b) -> Mapping a -> Mapping b +mappingFmapLoc f = Map.mapKeysMonotonic (fmap f) . Map.map (fmap f) + +instance Eq (Node loc) where + Scalar _ a == Scalar _ a' = a == a' + Mapping _ a b == Mapping _ a' b' = a == a' && b == b' + Sequence _ a b == Sequence _ a' b' = a == a' && b == b' + Anchor _ a b == Anchor _ a' b' = a == a' && b == b' + _ == _ = False + +instance Ord (Node loc) where + compare (Scalar _ a) (Scalar _ a') = compare a a' + compare (Scalar _ _) (Mapping _ _ _) = LT + compare (Scalar _ _) (Sequence _ _ _) = LT + compare (Scalar _ _) (Anchor _ _ _) = LT + + compare (Mapping _ _ _) (Scalar _ _) = GT + compare (Mapping _ a b) (Mapping _ a' b') = compare (a,b) (a',b') + compare (Mapping _ _ _) (Sequence _ _ _) = LT + compare (Mapping _ _ _) (Anchor _ _ _) = LT + + compare (Sequence _ _ _) (Scalar _ _) = GT + compare (Sequence _ _ _) (Mapping _ _ _) = GT + compare (Sequence _ a b) (Sequence _ a' b') = compare (a,b) (a',b') + compare (Sequence _ _ _) (Anchor _ _ _) = LT + + compare (Anchor _ _ _) (Scalar _ _) = GT + compare (Anchor _ _ _) (Mapping _ _ _) = GT + compare (Anchor _ _ _) (Sequence _ _ _) = GT + compare (Anchor _ a b) (Anchor _ a' b') = compare (a,b) (a',b') diff --git a/src/Data/YAML/Loader.hs b/src/Data/YAML/Loader.hs --- a/src/Data/YAML/Loader.hs +++ b/src/Data/YAML/Loader.hs @@ -12,11 +12,13 @@ module Data.YAML.Loader ( decodeLoader , Loader(..) + , LoaderT , NodeId ) where -import Control.Monad.Except -import Control.Monad.State +import Control.Monad.State (MonadState(..), gets, modify, + StateT, evalStateT, state) +import Control.Monad.Trans (MonadTrans(..)) import qualified Data.ByteString.Lazy as BS.L import qualified Data.Map as Map import qualified Data.Set as Set @@ -32,28 +34,41 @@ -- | Structure defining how to construct a document tree/graph -- +-- @since 0.2.0 +-- data Loader m n = Loader - { yScalar :: Tag -> YE.Style -> Text -> m (Either String n) - , ySequence :: Tag -> [n] -> m (Either String n) - , yMapping :: Tag -> [(n,n)] -> m (Either String n) - , yAlias :: NodeId -> Bool -> n -> m (Either String n) - , yAnchor :: NodeId -> n -> m (Either String n) + { yScalar :: Tag -> YE.ScalarStyle -> Text -> LoaderT m n + , ySequence :: Tag -> [n] -> LoaderT m n + , yMapping :: Tag -> [(n,n)] -> LoaderT m n + , yAlias :: NodeId -> Bool -> n -> LoaderT m n + , yAnchor :: NodeId -> n -> LoaderT m n } +-- | Helper type for 'Loader' +-- +-- @since 0.2.0 +type LoaderT m n = YE.Pos -> m (Either (YE.Pos,String) n) + +-- TODO: newtype LoaderT m n = LoaderT { runLoaderT :: YE.Pos -> m (Either String n) } + -- | Generalised document tree/graph construction -- -- This doesn't yet perform any tag resolution (thus all scalars are --- represented as 'Text' values). See also 'decodeNode' for a more +-- represented as 'Text' values). See also 'Data.YAML.decodeNode' for a more -- convenient interface. +-- +-- @since 0.2.0 {-# INLINEABLE decodeLoader #-} -decodeLoader :: forall n m . MonadFix m => Loader m n -> BS.L.ByteString -> m (Either String [n]) +decodeLoader :: forall n m . MonadFix m => Loader m n -> BS.L.ByteString -> m (Either (YE.Pos, String) [n]) decodeLoader Loader{..} bs0 = do - case sequence . YE.parseEvents $ bs0 of - Left (pos,err) - | YE.posCharOffset pos < 0 -> return (Left err) - | otherwise -> return (Left $ ":" ++ show (YE.posLine pos) ++ ":" ++ show (YE.posColumn pos) ++ ": " ++ err) - Right evs -> runParserT goStream evs + case sequence $ filter (not. isComment) (YE.parseEvents bs0) of + Left (pos,err) -> return $ Left (pos,err) + Right evs -> runParserT goStream evs where + isComment evPos = case evPos of + Right (YE.EvPos {eEvent = (YE.Comment _), ePos = _}) -> True + _ -> False + goStream :: PT n m [n] goStream = do _ <- satisfy (== YE.StreamStart) @@ -73,122 +88,120 @@ getNewNid = state $ \s0 -> let i0 = sIdCnt s0 in (i0, s0 { sIdCnt = i0+1 }) - returnNode :: (Maybe YE.Anchor) -> Either String n -> PT n m n - returnNode _ (Left err) = throwError err - returnNode Nothing (Right node) = return node - returnNode (Just a) (Right node) = do + returnNode :: YE.Pos -> Maybe YE.Anchor -> Either (YE.Pos, String) n -> PT n m n + returnNode _ _ (Left err) = throwError err + returnNode _ Nothing (Right node) = return node + returnNode pos (Just a) (Right node) = do nid <- getNewNid - node0 <- lift $ yAnchor nid node - node' <- liftEither node0 + node' <- liftEither' =<< lift (yAnchor nid node pos) modify $ \s0 -> s0 { sDict = Map.insert a (nid,node') (sDict s0) } return node' - registerAnchor :: Maybe YE.Anchor -> PT n m n -> PT n m n - registerAnchor Nothing pn = pn - registerAnchor (Just a) pn = do + registerAnchor :: YE.Pos -> Maybe YE.Anchor -> PT n m n -> PT n m n + registerAnchor _ Nothing pn = pn + registerAnchor pos (Just a) pn = do modify $ \s0 -> s0 { sCycle = Set.insert a (sCycle s0) } nid <- getNewNid mdo modify $ \s0 -> s0 { sDict = Map.insert a (nid,n) (sDict s0) } n0 <- pn - n1 <- lift $ yAnchor nid n0 - n <- liftEither n1 + n <- liftEither' =<< lift (yAnchor nid n0 pos) return n exitAnchor :: Maybe YE.Anchor -> PT n m () - exitAnchor Nothing = return () + exitAnchor Nothing = return () exitAnchor (Just a) = modify $ \s0 -> s0 { sCycle = Set.delete a (sCycle s0) } goNode :: PT n m n goNode = do - n <- satisfy (const True) - case n of + n <- anyEv + let pos = YE.ePos n + case YE.eEvent n of YE.Scalar manc tag sty val -> do exitAnchor manc - n' <- lift $ yScalar tag sty val - returnNode manc $! n' + n' <- lift (yScalar tag sty val pos) + returnNode pos manc $! n' - YE.SequenceStart manc tag -> registerAnchor manc $ do + YE.SequenceStart manc tag _ -> registerAnchor pos manc $ do ns <- manyUnless (== YE.SequenceEnd) goNode exitAnchor manc - liftEither =<< (lift $ ySequence tag ns) + liftEither' =<< lift (ySequence tag ns pos) - YE.MappingStart manc tag -> registerAnchor manc $ do + YE.MappingStart manc tag _ -> registerAnchor pos manc $ do kvs <- manyUnless (== YE.MappingEnd) (liftM2 (,) goNode goNode) exitAnchor manc - liftEither =<< (lift $ yMapping tag kvs) + liftEither' =<< lift (yMapping tag kvs pos) YE.Alias a -> do d <- gets sDict cy <- gets sCycle case Map.lookup a d of - Nothing -> throwError ("anchor not found: " ++ show a) - Just (nid,n') -> liftEither =<< (lift $ yAlias nid (Set.member a cy) n') - - _ -> throwError "goNode: unexpected event" + Nothing -> throwError (pos, ("anchor not found: " ++ show a)) + Just (nid,n') -> liftEither' =<< lift (yAlias nid (Set.member a cy) n' pos) + _ -> throwError (pos, "goNode: unexpected event") ---------------------------------------------------------------------------- -- small parser framework -data S n = S { sEvs :: [YE.Event] +data S n = S { sEvs :: [YE.EvPos] , sDict :: Map YE.Anchor (Word,n) , sCycle :: Set YE.Anchor , sIdCnt :: !Word } -newtype PT n m a = PT (StateT (S n) (ExceptT String m) a) +newtype PT n m a = PT (StateT (S n) (ExceptT (YE.Pos, String) m) a) deriving ( Functor , Applicative , Monad , MonadState (S n) - , MonadError String + , MonadError (YE.Pos, String) , MonadFix ) instance MonadTrans (PT n) where lift = PT . lift . lift -runParserT :: Monad m => PT n m a -> [YE.Event] -> m (Either String a) +runParserT :: Monad m => PT n m a -> [YE.EvPos] -> m (Either (YE.Pos, String) a) runParserT (PT act) s0 = runExceptT $ evalStateT act (S s0 mempty mempty 0) -satisfy :: Monad m => (YE.Event -> Bool) -> PT n m YE.Event +satisfy :: Monad m => (YE.Event -> Bool) -> PT n m YE.EvPos satisfy p = do s0 <- get case sEvs s0 of - [] -> throwError "satisfy: premature eof" + [] -> throwError (fakePos, "satisfy: premature eof") (ev:rest) - | p ev -> do put (s0 { sEvs = rest}) - return ev - | otherwise -> throwError ("satisfy: predicate failed " ++ show ev) + | p (YE.eEvent ev) -> do put (s0 { sEvs = rest}) + return ev + | otherwise -> throwError (YE.ePos ev, ("satisfy: predicate failed " ++ show ev)) -peek :: Monad m => PT n m (Maybe YE.Event) +peek :: Monad m => PT n m (Maybe YE.EvPos) peek = do s0 <- get case sEvs s0 of [] -> return Nothing (ev:_) -> return (Just ev) -peek1 :: Monad m => PT n m YE.Event -peek1 = maybe (throwError "peek1: premature eof") return =<< peek +peek1 :: Monad m => PT n m YE.EvPos +peek1 = maybe (throwError (fakePos,"peek1: premature eof")) return =<< peek -anyEv :: Monad m => PT n m YE.Event +anyEv :: Monad m => PT n m YE.EvPos anyEv = satisfy (const True) eof :: Monad m => PT n m () eof = do s0 <- get case sEvs s0 of - [] -> return () - _ -> throwError "eof expected" + [] -> return () + (ev:_) -> throwError (YE.ePos ev, "eof expected") -- NB: consumes the end-event manyUnless :: Monad m => (YE.Event -> Bool) -> PT n m a -> PT n m [a] manyUnless p act = do t0 <- peek1 - if p t0 + if p (YE.eEvent t0) then anyEv >> return [] else liftM2 (:) act (manyUnless p act) @@ -204,3 +217,6 @@ isDocEnd :: YE.Event -> Bool isDocEnd (YE.DocumentEnd _) = True isDocEnd _ = False + +fakePos :: YE.Pos +fakePos = YE.Pos { posByteOffset = -1 , posCharOffset = -1 , posLine = 1 , posColumn = 0 } diff --git a/src/Data/YAML/Pos.hs b/src/Data/YAML/Pos.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Pos.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-2.0-or-later +-- +module Data.YAML.Pos + ( Pos(..) + , prettyPosWithSource + ) where + +import qualified Data.ByteString.Lazy as BL +import qualified Data.YAML.Token.Encoding as Enc +import Util + +-- | Position in parsed YAML source +-- +-- See also 'prettyPosWithSource'. +-- +-- __NOTE__: if 'posCharOffset' is negative the 'Pos' value doesn't refer to a proper location; this may be emitted in corner cases when no proper location can be inferred. +data Pos = Pos + { posByteOffset :: !Int -- ^ 0-based byte offset + , posCharOffset :: !Int -- ^ 0-based character (Unicode code-point) offset + , posLine :: !Int -- ^ 1-based line number + , posColumn :: !Int -- ^ 0-based character (Unicode code-point) column number + } deriving (Eq, Show, Generic) + +-- | @since 0.2.0 +instance NFData Pos where rnf !_ = () + +-- | Pretty prints a 'Pos' together with the line the 'Pos' refers and the column position. +-- +-- The input 'BL.ByteString' must be the same that was passed to the +-- YAML decoding function that produced the 'Pos' value. The 'String' +-- argument is inserted right after the @::@ in the +-- first line. The pretty-printed position result 'String' will be +-- terminated by a trailing newline. +-- +-- For instance, +-- +-- @ +-- 'prettyPosWithSource' somePos someInput " error" ++ "unexpected character\\n" +-- @ results in +-- +-- > 11:7: error +-- > | +-- > 11 | foo: | bar +-- > | ^ +-- > unexpected character +-- +-- @since 0.2.1 +prettyPosWithSource :: Pos -> BL.ByteString -> String -> String +prettyPosWithSource Pos{..} source msg + | posCharOffset < 0 || posByteOffset < 0 = "0:0:" ++ msg ++ "\n" -- unproper location + | otherwise = unlines + [ show posLine ++ ":" ++ show posColumn ++ ":" ++ msg + , lpfx + , lnostr ++ "| " ++ line + , lpfx ++ replicate posColumn ' ' ++ "^" + ] + + where + lnostr = " " ++ show posLine ++ " " + lpfx = (' ' <$ lnostr) ++ "| " + + (_,lstart) = findLineStartByByteOffset posByteOffset source + line = map snd $ takeWhile (not . isNL . snd) lstart + + isNL c = c == '\r' || c == '\n' + +findLineStartByByteOffset :: Int -> BL.ByteString -> (Int,[(Int,Char)]) +findLineStartByByteOffset bofs0 input = go 0 inputChars inputChars + where + (_,inputChars) = Enc.decode input + + go lsOfs lsChars [] = (lsOfs,lsChars) + go lsOfs lsChars ((ofs',_):_) + | bofs0 < ofs' = (lsOfs,lsChars) + + go _ _ ((_,'\r'):(ofs','\n'):rest) = go ofs' rest rest + go _ _ ((ofs','\r'):rest) = go ofs' rest rest + go _ _ ((ofs','\n'):rest) = go ofs' rest rest + go lsOfs lsChars (_:rest) = go lsOfs lsChars rest diff --git a/src/Data/YAML/Schema.hs b/src/Data/YAML/Schema.hs --- a/src/Data/YAML/Schema.hs +++ b/src/Data/YAML/Schema.hs @@ -7,339 +7,44 @@ -- Copyright: © Herbert Valerio Riedel 2015-2018 -- SPDX-License-Identifier: GPL-2.0-or-later -- --- YAML 1.2 Schema resolvers +-- Predefined YAML 1.2 Schema resolvers and encoders as well as support for defining custom resolvers and encoders. -- +-- @since 0.2.0.0 module Data.YAML.Schema - ( SchemaResolver(..) + ( -- * Schema resolvers + -- ** YAML 1.2 Schema resolvers + SchemaResolver(..) , failsafeSchemaResolver , jsonSchemaResolver , coreSchemaResolver - , Scalar(..) - , tagNull, tagBool, tagStr, tagInt, tagFloat, tagSeq, tagMap - ) where - -import Control.Monad.Except -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 (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) - - --- | 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.Style -> T.Text -> Either String Scalar - , schemaResolverSequence :: Tag -> Either String Tag - , schemaResolverMapping :: Tag -> Either String Tag - } - - -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.Style -> 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 - - -- 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 - - -- sequences - schemaResolverSequence t - | t == tagBang = Right tagSeq - | isUntagged t = Right tagSeq - | otherwise = Right t - --- | Core JSON 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 - - -- 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.many 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.many 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)) - ] + -- * Schema encoders + -- ** YAML 1.2 Schema encoders + , SchemaEncoder(..) + , failsafeSchemaEncoder + , jsonSchemaEncoder + , coreSchemaEncoder + -- ** Custom Schema encoding + -- + -- | According to YAML 1.2 the recommended default 'SchemaEncoder' is 'coreSchemaEncoder' under which '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 'Data.YAML.Event.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' + -- + , setScalarStyle + , isPlainChar + , isAmbiguous + , encodeDouble + , encodeBool + , encodeInt + ) where -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 "!" +import Data.YAML.Schema.Internal diff --git a/src/Data/YAML/Schema/Internal.hs b/src/Data/YAML/Schema/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Schema/Internal.hs @@ -0,0 +1,547 @@ +{-# 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 ). +-- +-- __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` (" ~$^+=%@`\\'\"" + +-- | 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 } + diff --git a/src/Data/YAML/Token.hs b/src/Data/YAML/Token.hs --- a/src/Data/YAML/Token.hs +++ b/src/Data/YAML/Token.hs @@ -1,16 +1,13 @@ -{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE PostfixOperators #-} {-# LANGUAGE Safe #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- FIXME - -- | -- Copyright: © Oren Ben-Kiki 2007, -- © Herbert Valerio Riedel 2015-2018 @@ -22,6 +19,7 @@ ( tokenize , Token(..) , Code(..) + , Encoding(..) ) where import qualified Data.ByteString.Lazy.Char8 as BLC @@ -126,8 +124,12 @@ | Error -- ^ Parsing error at this point. | Unparsed -- ^ Unparsed due to errors (or at end of test). | Detected -- ^ Detected parameter (for testing). - deriving (Show,Eq) + deriving (Show,Eq,Generic) +-- | @since 0.2.0 +instance NFData Code where + rnf x = seq x () + {- -- | @show code@ converts a 'Code' to the one-character YEAST token code char. -- The list of byte codes is also documented in the @yaml2yeast@ program. @@ -185,8 +187,11 @@ tLineChar :: !Int, -- ^ 0-based character in line. tCode :: !Code, -- ^ Specific token 'Code'. tText :: !String -- ^ Contained input chars, if any. - } deriving Show + } deriving (Show,Generic) +-- | @since 0.2.0 +instance NFData Token where + rnf Token { tText = txt } = rnf txt -- * Parsing framework -- @@ -208,7 +213,7 @@ -- so we maintain a single 'State' type rather than having a generic one that -- contains a polymorphic \"UserState\" field etc. --- | A 'Parser' is basically a function computing a 'Reply'. +-- | A 'Data.YAML.Token.Parser' is basically a function computing a 'Reply'. newtype Parser result = Parser (State -> Reply result) applyParser :: Parser result -> State -> Reply result @@ -220,14 +225,16 @@ | Result result -- ^ Parsing completed with a result. | More (Parser result) -- ^ Parsing is ongoing with a continuation. +{- -- Showing a 'Result' is only used in debugging. instance (Show result) => Show (Result result) where show result = case result of Failed message -> "Failed " ++ message Result result -> "Result " ++ (show result) More _ -> "More" +-} --- | Each invication of a 'Parser' yields a 'Reply'. The 'Result' is only one +-- | Each invocation of a 'Data.YAML.Token.Parser' yields a 'Reply'. The 'Result' is only one -- part of the 'Reply'. data Reply result = Reply { rResult :: !(Result result), -- ^ Parsing result. @@ -236,12 +243,14 @@ rState :: !State -- ^ The updated parser state. } +{- -- Showing a 'State' is only used in debugging. instance (Show result) => Show (Reply result) where show reply = "Result: " ++ (show $ reply^.rResult) ++ ", Tokens: " ++ (show $ D.toList $ reply^.rTokens) ++ ", Commit: " ++ (show $ reply^.rCommit) ++ ", State: { " ++ (show $ reply^.rState) ++ "}" +-} -- A 'Pattern' is a parser that doesn't have an (interesting) result. type Pattern = Parser () @@ -272,6 +281,7 @@ sInput :: ![(Int, Char)] -- ^ The decoded input characters. } +{- -- Showing a 'State' is only used in debugging. Note that forcing dump of -- @sInput@ will disable streaming it. instance Show State where @@ -292,6 +302,7 @@ ++ ", Code: " ++ (show $ state^.sCode) ++ ", Last: " ++ (show $ state^.sLast) -- ++ ", Input: >>>" ++ (show $ state^.sInput) ++ "<<<" +-} -- | @initialState name input@ returns an initial 'State' for parsing the -- /input/ (with /name/ for error messages). @@ -327,14 +338,17 @@ -- | @setLimit limit state@ sets the @sLimit@ field to /limit/. setLimit :: Int -> State -> State setLimit limit state = state { sLimit = limit } +{-# INLINE setLimit #-} -- | @setForbidden forbidden state@ sets the @sForbidden@ field to /forbidden/. setForbidden :: Maybe Pattern -> State -> State setForbidden forbidden state = state { sForbidden = forbidden } +{-# INLINE setForbidden #-} -- | @setCode code state@ sets the @sCode@ field to /code/. setCode :: Code -> State -> State setCode code state = state { sCode = code } +{-# INLINE setCode #-} -- ** Implicit parsers -- @@ -343,11 +357,11 @@ -- 'Match' class. -- | @Match parameter result@ specifies that we can convert the /parameter/ to --- a 'Parser' returning the /result/. +-- a 'Data.YAML.Token.Parser' returning the /result/. class Match parameter result | parameter -> result where match :: parameter -> Parser result --- | We don't need to convert a 'Parser', it already is one. +-- | We don't need to convert a 'Data.YAML.Token.Parser', it already is one. instance Match (Parser result) result where match = id @@ -442,8 +456,9 @@ (>>) = (*>) - -- @fail message@ does just that - fails with a /message/. - fail message = Parser $ \state -> failReply state message +-- | @fail message@ does just that - fails with a /message/. +pfail :: String -> Parser a +pfail message = Parser $ \state -> failReply state message -- ** Parsing operators -- @@ -483,17 +498,17 @@ -- | @parser % n@ repeats /parser/ exactly /n/ times. (%) :: (Match match result) => match -> Int -> Pattern parser % n - | n <= 0 = empty - | n > 0 = parser' *> (parser' % n .- 1) + | n <= 0 = empty + | otherwise = parser' *> (parser' % n .- 1) where parser' = match parser -- | @parser <% n@ matches fewer than /n/ occurrences of /parser/. (<%) :: (Match match result) => match -> Int -> Pattern -parser <% n - | n < 1 = fail "Fewer than 0 repetitions" - | n == 1 = reject parser Nothing - | n > 1 = DeLess ^ ( ((parser ! DeLess) *> (parser <% n .- 1)) <|> empty ) +parser <% n = case n `compare` 1 of + LT -> pfail "Fewer than 0 repetitions" + EQ -> reject parser Nothing + GT -> DeLess ^ ( ((parser ! DeLess) *> (parser <% n .- 1)) <|> empty ) data Decision = DeNone -- "" | DeStar -- "*" @@ -527,17 +542,17 @@ -- | @lookbehind match -> Parser result (?@ matches the current point without consuming any characters --- if it matches the lookahead parser (positive lookahead) +-- if it matches the lookahead parser (positive lookahead). (>?) :: (Match match result) => match -> Parser result (>?) lookahead = peek lookahead --- | @lookahead >?@ matches the current point without consuming any characters --- if it matches the lookahead parser (negative lookahead) +-- | @lookahead >!@ matches the current point without consuming any characters +-- if it matches the lookahead parser (negative lookahead). (>!) :: (Match match result) => match -> Pattern (>!) lookahead = reject lookahead Nothing @@ -577,7 +592,7 @@ -- | @first <|> second@ tries to parse /first/, and failing that parses -- /second/, unless /first/ has committed in which case is fails immediately. instance Alternative Parser where - empty = fail "empty" + empty = pfail "empty" left <|> right = Parser $ \state -> decideParser state D.empty left right state where @@ -694,7 +709,7 @@ -- | @eof@ matches the end of the input. eof :: Pattern eof = Parser $ \ state -> - if state^.sInput == [] + if null (state^.sInput) then returnReply state () else unexpectedReply state @@ -740,6 +755,7 @@ Failed _ -> reply { rState = setField parentValue $ reply^.rState } Result _ -> reply { rState = setField parentValue $ reply^.rState } More parser' -> reply { rResult = More $ withParser parentValue parser' } +{-# INLINE with #-} -- | @parser ``forbidding`` pattern@ parses the specified /parser/ ensuring -- that it does not contain anything matching the /forbidden/ parser. @@ -764,6 +780,7 @@ in case reply^.rResult of Failed _ -> reply Result _ -> limitedNextIf state + More _ -> error "unexpected Result More _ pattern" where limitedNextIf state = case state^.sLimit of @@ -796,7 +813,7 @@ where charsOf field charsField | state^.sIsPeek = -1 - | state^.sChars == [] = state^.field + | null (state^.sChars) = state^.field | otherwise = state^.charsField -- ** Producing tokens @@ -897,7 +914,7 @@ in case reply^.rResult of Result _ -> reply More more -> reply { rResult = More $ prefixErrorWith more prefix } - Failed message -> reply { rResult = More $ prefix & (fail message :: Parser result) } + Failed message -> reply { rResult = More $ prefix & (pfail message :: Parser result) } -- * Production parameters @@ -909,6 +926,7 @@ | BlockKey -- ^ Implicit block key. | FlowKey -- ^ Implicit flow key. +{- -- | @show context@ converts a 'Context' to a 'String'. instance Show Context where show context = case context of @@ -932,12 +950,14 @@ "block_key" -> BlockKey "flow_key" -> FlowKey _ -> error $ "unknown context: " ++ word +-} -- | Chomp method. data Chomp = Strip -- ^ Remove all trailing line breaks. | Clip -- ^ Keep first trailing line break. | Keep -- ^ Keep all trailing line breaks. +{- -- | @show chomp@ converts a 'Chomp' to a 'String'. instance Show Chomp where show chomp = case chomp of @@ -953,10 +973,11 @@ "clip" -> Clip "keep" -> Keep _ -> error $ "unknown chomp: " ++ word +-} -- * Tokenizers -- --- We encapsulate the 'Parser' inside a 'Tokenizer'. This allows us to hide the +-- We encapsulate the 'Data.YAML.Token.Parser' inside a 'Tokenizer'. This allows us to hide the -- implementation details from our callers. -- | 'Tokenizer' converts a input text into a list of 'Token'. Errors @@ -1058,7 +1079,7 @@ -- | @result value@ is the same as /return value/ except that we give the -- Haskell type deduction the additional boost it needs to figure out this is --- wrapped in a 'Parser'. +-- wrapped in a 'Data.YAML.Token.Parser'. result :: result -> Parser result result = return @@ -1215,6 +1236,7 @@ BlockIn -> s_block_line_prefix n FlowOut -> s_flow_line_prefix n FlowIn -> s_flow_line_prefix n + _ -> error "unexpected node style pattern in s_line_prefix" s_block_line_prefix n {- 68 -} = s_indent n s_flow_line_prefix n {- 69 -} = s_indent n & ( s_separate_in_line ?) @@ -1365,6 +1387,8 @@ FlowIn -> nb_double_multi_line n BlockKey -> nb_double_one_line FlowKey -> nb_double_one_line + _ -> error "unexpected node style pattern in nb_double_text" + nb_double_one_line {- 111 -} = ( nb_double_char *) s_double_escaped n {- 112 -} = ( s_white *) @@ -1394,6 +1418,8 @@ FlowIn -> nb_single_multi_line n BlockKey -> nb_single_one_line FlowKey -> nb_single_one_line + _ -> error "unexpected node style pattern in nb_single_text" + nb_single_one_line {- 122 -} = ( nb_single_char *) nb_ns_single_in_line {- 123 -} = ( ( s_white *) & ns_single_char *) @@ -1406,25 +1432,29 @@ -- 7.3.3 Plain Style ns_plain_first _c {- 126 -} = ns_char - c_indicator - / ( ':' / '?' / '-' ) & ( ns_char >?) + / ( ':' / '?' / '-' ) & ( (ns_plain_safe _c) >?) ns_plain_safe c {- 127 -} = case c of FlowOut -> ns_plain_safe_out FlowIn -> ns_plain_safe_in BlockKey -> ns_plain_safe_out FlowKey -> ns_plain_safe_in -ns_plain_safe_out {- 128 -} = ns_char - c_mapping_value - c_comment -ns_plain_safe_in {- 129 -} = ns_plain_safe_out - c_flow_indicator -ns_plain_char c {- 130 -} = ns_plain_safe c + _ -> error "unexpected node style pattern in ns_plain_safe" + +ns_plain_safe_out {- 128 -} = ns_char +ns_plain_safe_in {- 129 -} = ns_char - c_flow_indicator +ns_plain_char c {- 130 -} = ns_plain_safe c - ':' - '#' / ( ns_char ?) + / ':' & ( (ns_plain_safe c) >?) ns_plain n c {- 131 -} = wrapTokens BeginScalar EndScalar $ text (case c of FlowOut -> ns_plain_multi_line n c FlowIn -> ns_plain_multi_line n c BlockKey -> ns_plain_one_line c - FlowKey -> ns_plain_one_line c) + FlowKey -> ns_plain_one_line c + _ -> error "unexpected node style pattern in ns_plain") + nb_ns_plain_in_line c {- 132 -} = ( ( s_white *) & ns_plain_char c *) ns_plain_one_line c {- 133 -} = ns_plain_first c ! DeNode & nb_ns_plain_in_line c @@ -1440,6 +1470,7 @@ FlowIn -> FlowIn BlockKey -> FlowKey FlowKey -> FlowKey + _ -> error "unexpected node style pattern in in_flow" -- 7.4.1 Flow Sequences @@ -1471,9 +1502,9 @@ & e_node ) ns_flow_map_implicit_entry n c {- 144 -} = DePair - ^ ( ns_flow_map_yaml_key_entry n c - / c_ns_flow_map_empty_key_entry n c - / c_ns_flow_map_json_key_entry n c ) + ^ ( c_ns_flow_map_json_key_entry n c + / ns_flow_map_yaml_key_entry n c + / c_ns_flow_map_empty_key_entry n c ) ns_flow_map_yaml_key_entry n c {- 145 -} = ( DeNode ^ ns_flow_yaml_node n c ) ! DePair & ( ( ( s_separate n c ?) & c_ns_flow_map_separate_value n c ) @@ -1481,7 +1512,7 @@ c_ns_flow_map_empty_key_entry n c {- 146 -} = e_node & c_ns_flow_map_separate_value n c -c_ns_flow_map_separate_value n c {- 147 -} = c_mapping_value & ( ns_char >!) ! DePair +c_ns_flow_map_separate_value n c {- 147 -} = c_mapping_value & ( (ns_plain_safe c) >!) ! DePair & ( ( s_separate n c & ns_flow_node n c ) / e_node ) @@ -1668,7 +1699,7 @@ c_l_block_map_explicit_entry n {- 189 -} = c_l_block_map_explicit_key n & ( l_block_map_explicit_value n / e_node ) -c_l_block_map_explicit_key n {- 190 -} = c_mapping_key ! DeNode & s_l__block_indented n BlockOut +c_l_block_map_explicit_key n {- 190 -} = c_mapping_key & ( ns_char >!) ! DeNode & s_l__block_indented n BlockOut l_block_map_explicit_value n {- 191 -} = s_indent n & c_mapping_value & s_l__block_indented n BlockOut ns_l_block_map_implicit_entry n {- 192 -} = ( ns_s_block_map_implicit_key @@ -1711,6 +1742,7 @@ seq_spaces n c {- 201 -} = case c of BlockOut -> n .- 1 BlockIn -> n + _ -> error "unexpected node style pattern in seq_spaces" -- 9.1.1 Document Prefix diff --git a/src/Data/YAML/Token/Encoding.hs b/src/Data/YAML/Token/Encoding.hs --- a/src/Data/YAML/Token/Encoding.hs +++ b/src/Data/YAML/Token/Encoding.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE Safe #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} -- | -- Copyright: © Oren Ben-Kiki 2007, @@ -12,7 +13,7 @@ -- there, we get to tailor it exactly to our needs. We use lazy byte strings as -- input, which should give reasonable I\/O performance when reading large -- files. The output is a normal 'Char' list which is easy to work with and --- should be efficient enough as long as the 'Parser' does its job right. +-- should be efficient enough as long as the 'Data.YAML.Token.Parser' does its job right. -- module Data.YAML.Token.Encoding ( decode @@ -24,12 +25,13 @@ import Util --- | Recognized Unicode encodings. As of YAML 1.2 UTF-32 is also required. +-- | Denotes the /Unicode Transformation Format/ (UTF) used for serializing the YAML document data Encoding = UTF8 -- ^ UTF-8 encoding (or ASCII) | UTF16LE -- ^ UTF-16 little endian | UTF16BE -- ^ UTF-16 big endian | UTF32LE -- ^ UTF-32 little endian | UTF32BE -- ^ UTF-32 big endian + deriving (Eq,Generic) -- | @show encoding@ converts an 'Encoding' to the encoding name (with a "-") -- as used by most programs. @@ -40,28 +42,31 @@ show UTF32LE = "UTF-32LE" show UTF32BE = "UTF-32BE" --- | @decode bytes@ automatically detects the 'Encoding' used and converts the +-- | @since 0.2.0 +instance NFData Encoding where rnf !_ = () + +-- | @'decode' bytes@ automatically detects the 'Encoding' used and converts the -- /bytes/ to Unicode characters, with byte offsets. Note the offset is for -- past end of the character, not its beginning. decode :: BLC.ByteString -> (Encoding, [(Int, Char)]) decode text = (encoding, undoEncoding encoding text) - where encoding = detectEncoding $ BLC.unpack $ BLC.take 4 text + where + encoding = detectEncoding $ BL.unpack $ BL.take 4 text --- | @detectEncoding text@ examines the first few chars (bytes) of the /text/ +-- | @'detectEncoding' text@ examines the first few chars (bytes) of the /text/ -- to deduce the Unicode encoding used according to the YAML spec. -detectEncoding :: [Char] -> Encoding -detectEncoding text = - case text of - '\x00' : '\x00' : '\xFE' : '\xFF' : _ -> UTF32BE - '\x00' : '\x00' : '\x00' : _ : _ -> UTF32BE - '\xFF' : '\xFE' : '\x00' : '\x00' : _ -> UTF32LE - _ : '\x00' : '\x00' : '\x00' : _ -> UTF32LE - '\xFE' : '\xFF' : _ -> UTF16BE - '\x00' : _ : _ -> UTF16BE - '\xFF' : '\xFE' : _ -> UTF16LE - _ : '\x00' : _ -> UTF16LE - '\xEF' : '\xBB' : '\xBF' : _ -> UTF8 - _ -> UTF8 +detectEncoding :: [Word8] -> Encoding +detectEncoding text = case text of + 0x00 : 0x00 : 0xFE : 0xFF : _ -> UTF32BE + 0x00 : 0x00 : 0x00 : _ : _ -> UTF32BE + 0xFF : 0xFE : 0x00 : 0x00 : _ -> UTF32LE + _ : 0x00 : 0x00 : 0x00 : _ -> UTF32LE + 0xFE : 0xFF : _ -> UTF16BE + 0x00 : _ : _ -> UTF16BE + 0xFF : 0xFE : _ -> UTF16LE + _ : 0x00 : _ -> UTF16LE + 0xEF : 0xBB : 0xBF : _ -> UTF8 + _ -> UTF8 -- | @undoEncoding encoding bytes@ converts a /bytes/ stream to Unicode -- characters according to the /encoding/. @@ -104,10 +109,10 @@ fourth = BLC.head bytes''' rest = BLC.tail bytes''' in (offset + 4, - chr $ (ord first) - + 256 * ((ord second) - + 256 * ((ord third) - + 256 * ((ord fourth))))):(undoUTF32LE rest $ offset + 4) + chr $ ord first + + 256 * (ord second + + 256 * (ord third + + 256 * ord fourth))):(undoUTF32LE rest $ offset + 4) -- | @undoUTF32BE bytes offset@ decoded a UTF-32BE /bytes/ stream to Unicode -- chars. @@ -124,10 +129,10 @@ fourth = BLC.head bytes''' rest = BLC.tail bytes''' in (offset + 4, - chr $ (ord fourth) - + 256 * ((ord third) - + 256 * ((ord second) - + 256 * ((ord first))))):(undoUTF32BE rest $ offset + 4) + chr $ ord fourth + + 256 * (ord third + + 256 * (ord second + + 256 * ord first))):(undoUTF32BE rest $ offset + 4) -- ** UTF-16 decoding @@ -138,7 +143,7 @@ combinePairs (head'@(_, head_char):tail') | '\xD800' <= head_char && head_char <= '\xDBFF' = combineLead head' tail' | '\xDC00' <= head_char && head_char <= '\xDFFF' = error "UTF-16 contains trail surrogate without lead surrogate" - | otherwise = head':(combinePairs tail') + | otherwise = head':combinePairs tail' -- | @combineLead lead rest@ combines the /lead/ surrogate with the head of the -- /rest/ of the input chars, assumed to be a /trail/ surrogate, and continues @@ -156,7 +161,7 @@ -- | @combineSurrogates lead trail@ combines two UTF-16 surrogates into a single -- Unicode character. combineSurrogates :: Char -> Char -> Char -combineSurrogates lead trail = chr $ (ord lead) * 1024 + (ord trail) + surrogateOffset +combineSurrogates lead trail = chr $ ord lead * 1024 + ord trail + surrogateOffset -- | @undoUTF18LE bytes offset@ decoded a UTF-16LE /bytes/ stream to Unicode -- chars. @@ -168,7 +173,7 @@ bytes' = BLC.tail bytes high = BLC.head bytes' rest = BLC.tail bytes' - in (offset + 2, chr $ (ord low) + (ord high) * 256):(undoUTF16LE rest $ offset + 2) + in (offset + 2, chr $ ord low + ord high * 256):(undoUTF16LE rest $ offset + 2) -- | @undoUTF18BE bytes offset@ decoded a UTF-16BE /bytes/ stream to Unicode -- chars. @@ -180,13 +185,13 @@ bytes' = BLC.tail bytes low = BLC.head bytes' rest = BLC.tail bytes' - in (offset + 2, chr $ (ord low) + (ord high) * 256):(undoUTF16BE rest $ offset + 2) + in (offset + 2, chr $ ord low + ord high * 256):(undoUTF16BE rest $ offset + 2) -- ** UTF-8 decoding -- | @undoUTF8 bytes offset@ decoded a UTF-8 /bytes/ stream to Unicode chars. undoUTF8 :: BLC.ByteString -> Int -> [(Int, Char)] -undoUTF8 bytes offset = undoUTF8' (BL.unpack bytes) offset +undoUTF8 bytes = undoUTF8' (BL.unpack bytes) w2c :: Word8 -> Char w2c = chr . fromIntegral @@ -213,7 +218,7 @@ -- the /bytes/, and then continues to undo the UTF-8 encoding. decodeTwoUTF8 :: Word8 -> Int -> [Word8] -> [(Int, Char)] decodeTwoUTF8 first offset (second:rest) - | second < 0x80 || 0xBF < second = error $ "UTF-8 double byte char has invalid second byte" + | second < 0x80 || 0xBF < second = error "UTF-8 double byte char has invalid second byte" | otherwise = (offset', c) : undoUTF8' rest offset' where !offset' = offset + 2 @@ -230,9 +235,9 @@ | otherwise = (offset', c): undoUTF8' rest offset' where !offset' = offset + 3 - !c = chr(((w2i first) - 0xE0) * 0x1000 + - ((w2i second) - 0x80) * 0x40 + - ((w2i third) - 0x80)) + !c = chr((w2i first - 0xE0) * 0x1000 + + (w2i second - 0x80) * 0x40 + + (w2i third - 0x80)) decodeThreeUTF8 _ _ _ =error "UTF-8 triple byte char is missing bytes at eof" -- | @decodeFourUTF8 first offset bytes@ decodes a four-byte UTF-8 character, @@ -246,11 +251,9 @@ | otherwise = (offset', c) : undoUTF8' rest offset' where !offset' = offset + 4 - !c = chr(((w2i first) - 0xF0) * 0x40000 + - ((w2i second) - 0x80) * 0x1000 + - ((w2i third) - 0x80) * 0x40 + - ((w2i fourth) - 0x80)) + !c = chr((w2i first - 0xF0) * 0x40000 + + (w2i second - 0x80) * 0x1000 + + (w2i third - 0x80) * 0x40 + + (w2i fourth - 0x80)) decodeFourUTF8 _ _ _ = error "UTF-8 quad byte char is missing bytes at eof" - - diff --git a/src/Util.hs b/src/Util.hs --- a/src/Util.hs +++ b/src/Util.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE Safe #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -9,60 +10,58 @@ -- SPDX-License-Identifier: GPL-2.0-or-later -- module Util - ( liftEither + ( liftEither' , readMaybe , readEither , fromIntegerMaybe + , (<>) + , mapFromListNoDupes + , mapInsertNoDupe + + , bsToStrict + , module X ) where import Control.Applicative as X +import Control.DeepSeq as X (NFData (rnf)) import Control.Monad as X +import Data.Functor as X import Data.Int as X import Data.Word as X +import GHC.Generics as X (Generic) import Numeric.Natural as X (Natural) -#if !MIN_VERSION_mtl(2,2,2) || (__GLASGOW_HASKELL__ == 804 && __GLASGOW_HASKELL_PATCHLEVEL1__ < 2) -import Control.Monad.Except (MonadError (throwError)) -#else -import Control.Monad.Except (liftEither) -#endif - +import Control.Monad.Fix as X (MonadFix) +import Control.Monad.Except as X (MonadError (..)) import Control.Monad.Identity as X +import Control.Monad.Trans.Except as X (ExceptT (..), runExceptT) import Data.Char as X (chr, ord) import Data.Map as X (Map) +import qualified Data.Map as Map import Data.Monoid as X (Monoid (mappend, mempty)) +import Data.Semigroup ((<>)) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BS.L import Data.Set as X (Set) import Data.Text as X (Text) import Text.ParserCombinators.ReadP as P import Text.Read --- GHC 8.4.1 shipped with a phony `mtl-2.2.2` and so we have to assume --- pessimistically that on GHC 8.4.1 only, mtl-2.2.2 may be broken (even if it was reinstalled) -#if !MIN_VERSION_mtl(2,2,2) || (__GLASGOW_HASKELL__ == 804 && __GLASGOW_HASKELL_PATCHLEVEL1__ < 2) -liftEither :: MonadError e m => Either e a -> m a -liftEither = either throwError return -#endif - -#if !MIN_VERSION_base(4,6,0) -readMaybe :: Read a => String -> Maybe a -readMaybe = either (const Nothing) id . readEither - -readEither :: Read a => String -> Either String a -readEither s = case [ x | (x,"") <- readPrec_to_S read' minPrec s ] of - [x] -> Right x - [] -> Left "Prelude.read: no parse" - _ -> Left "Prelude.read: ambiguous parse" - where - read' = do x <- readPrec - Text.Read.lift P.skipSpaces - return x -#endif +-- GHC 8.4.1 shipped with a phony `mtl-2.2.2` and so we have no +-- bulletproof way to know when `Control.Monad.Except` exports liftEither +-- or not; after NixOS managed to break an otherwise effective workaround +-- I'll just throwing my hands up in the air and will consider +-- `Control.Monad.Except.liftEither` scorched earth for now. +liftEither' :: MonadError e m => Either e a -> m a +liftEither' = either throwError return +-- | Succeeds if the 'Integral' value is in the bounds of the given Data type. +-- 'Nothing' indicates that the value is outside the bounds. fromIntegerMaybe :: forall n . (Integral n, Bounded n) => Integer -> Maybe n fromIntegerMaybe j | l <= j, j <= u = Just (fromInteger j) @@ -71,3 +70,25 @@ u = toInteger (maxBound :: n) l = toInteger (minBound :: n) + +-- | A convience wrapper over 'mapInsertNoDupe' +mapFromListNoDupes :: Ord k => [(k,a)] -> Either (k,a) (Map k a) +mapFromListNoDupes = go mempty + where + go !m [] = Right m + go !m ((k,!v):rest) = case mapInsertNoDupe k v m of + Nothing -> Left (k,v) + Just m' -> go m' rest + +-- | A convience wrapper over 'Data.Map.insertLookupWithKey' +mapInsertNoDupe :: Ord k => k -> a -> Map k a -> Maybe (Map k a) +mapInsertNoDupe kx x t = case Map.insertLookupWithKey (\_ a _ -> a) kx x t of + (Nothing, m) -> Just m + (Just _, _) -> Nothing + + +-- | Equivalent to the function 'Data.ByteString.toStrict'. +-- O(n) Convert a lazy 'BS.L.ByteString' into a strict 'BS.ByteString'. +{-# INLINE bsToStrict #-} +bsToStrict :: BS.L.ByteString -> BS.ByteString +bsToStrict = BS.L.toStrict diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +import Control.Monad +import Control.Applicative +import Data.YAML as Y +import qualified Data.Text as T +import qualified Data.Map as Map +import qualified Data.ByteString.Lazy.Char8 as BS.L +import Test.Tasty (defaultMain, TestTree, testGroup) +import Test.Tasty.QuickCheck (testProperty,Arbitrary(..)) + +outputStr :: ToYAML a => a -> BS.L.ByteString +outputStr a = BS.L.init (encode1 a) -- TODO: remove trailing newline from Writer.hs + +roundTripInt :: Int -> Bool +roundTripInt i = BS.L.pack (show i) == outputStr i + +roundTripBool :: Bool -> Bool +roundTripBool b + | b = "true" == outputStr b + | otherwise = "false" == outputStr b + +roundTripDouble :: Double -> Double -> Bool +roundTripDouble num denom + | d /= d = ".nan" == outputStr d + | d == (1/0) = ".inf" == outputStr d + | d == (-1/0) = "-.inf" == outputStr d + | otherwise = BS.L.pack (show d) == outputStr d + where d = num / denom + +roundTrip :: (Eq a, FromYAML a, ToYAML a) => (a -> a -> Bool) -> a -> a -> Bool +roundTrip eq _ v = + case decode1 (encode1 v) :: (FromYAML a) => (Either (Pos, String) a) of + Left _ -> False + Right ans -> ans `eq` v + +approxEq :: Double -> Double -> Bool +approxEq a b = a == b || d < maxAbsoluteError || d / max (abs b) (abs a) <= maxRelativeError + where + d = abs (a - b) + maxAbsoluteError = 1e-15 + maxRelativeError = 1e-15 + +roundTripEq :: (Eq a, FromYAML a, ToYAML a) => a -> a -> Bool +roundTripEq x y = roundTrip (==) x y + +main :: IO () +main = defaultMain (testGroup "tests" tests) + +tests :: [TestTree] +tests = + [ testGroup "encode" + [ testProperty "encodeInt" roundTripInt + , testProperty "encodeBool" roundTripBool + , testProperty "encodeDouble" roundTripDouble + ] + , testGroup "roundTrip" + [ testProperty "Bool" $ roundTripEq True + , testProperty "Double" $ roundTrip approxEq (1::Double) + , testProperty "Int" $ roundTripEq (1::Int) + , testProperty "Integer" $ roundTripEq (1::Integer) + , testProperty "Text" $ roundTripEq T.empty + , testProperty "Seq" $ roundTripEq ([""]:: [T.Text]) + , testProperty "Map" $ roundTripEq (undefined :: Map.Map T.Text T.Text) + , testProperty "Foo" $ roundTripEq (undefined :: Foo) + ] + ] + +instance Arbitrary T.Text where + arbitrary = T.pack <$> arbitrary + +data Foo = Foo + { fooBool :: Bool + , fooInt :: Int + , fooTuple :: (T.Text, Int) + , fooSeq :: [T.Text] + , fooMap :: Map.Map T.Text T.Text + } deriving (Show,Eq) + +instance ToYAML Foo where + toYAML Foo{..} = mapping [ "fooBool" .= fooBool + , "fooInt" .= fooInt + , "fooTuple" .= fooTuple + , "fooSeq" .= fooSeq + , "fooMap" .= fooMap + ] + +instance FromYAML Foo where + parseYAML = withMap "Foo" $ \m -> Foo + <$> m .: "fooBool" + <*> m .: "fooInt" + <*> m .: "fooTuple" + <*> m .: "fooSeq" + <*> m .: "fooMap" + +instance Arbitrary Foo where + arbitrary = liftM5 Foo arbitrary arbitrary arbitrary arbitrary arbitrary