HsYAML 0.1.2.0 → 0.2.1.5
raw patch · 19 files changed
Files
- ChangeLog.md +92/−4
- HsYAML.cabal +74/−28
- src-test/Main.hs +456/−59
- src-test/TML.hs +4/−5
- src/Data/DList.hs +6/−0
- src/Data/YAML.hs +469/−153
- src/Data/YAML/Dumper.hs +108/−0
- src/Data/YAML/Event.hs +495/−154
- src/Data/YAML/Event/Internal.hs +194/−0
- src/Data/YAML/Event/Writer.hs +519/−0
- src/Data/YAML/Internal.hs +95/−0
- src/Data/YAML/Loader.hs +70/−54
- src/Data/YAML/Pos.hs +87/−0
- src/Data/YAML/Schema.hs +33/−328
- src/Data/YAML/Schema/Internal.hs +547/−0
- src/Data/YAML/Token.hs +60/−30
- src/Data/YAML/Token/Encoding.hs +46/−43
- src/Util.hs +49/−28
- tests/Tests.hs +98/−0
ChangeLog.md view
@@ -1,9 +1,97 @@-See also http://pvp.haskell.org/faq+### 0.2.1.5 -### 0.1.2.0+_2025-03-11, Andreas Abel_ -* Add convenience functions `decode1` and `decode1Strict` expecting exactly one YAML document ([#5](https://github.com/haskell-hvr/HsYAML/pull/5))-* Fix a couple corner-cases in the YAML tokenization ([#10](https://github.com/haskell-hvr/HsYAML/pull/10))+* 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
HsYAML.cabal view
@@ -1,40 +1,57 @@ cabal-version: 1.14-build-type: Simple name: HsYAML-version: 0.1.2.0+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-tested-with: GHC==8.6.5, GHC==8.4.4, 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+build-type: Simple+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 <//hackage.haskell.org/package/HsYAML-aeson HsYAML-aeson> 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,16 +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@@ -66,20 +91,20 @@ Trustworthy TypeSynonymInstances - build-depends: base >=4.5 && <4.13- , bytestring >=0.9 && <0.11- , containers >=0.4.2 && <0.7- , 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
src-test/Main.hs view
@@ -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 "<stdin>:%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]
src-test/TML.hs view
@@ -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
src/Data/DList.hs view
@@ -13,16 +13,22 @@ , 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)
src/Data/YAML.hs view
@@ -1,58 +1,30 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Safe #-}-{-# LANGUAGE CPP #-} -- | -- Copyright: © Herbert Valerio Riedel 2015-2018 -- 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.------ <<http://yaml.org/spec/1.2/overview2.png>>------ === 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@@ -61,13 +33,27 @@ , 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@@ -79,83 +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 Data.Maybe (listToMaybe)-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.+--+-- <<https://yaml.org/spec/1.2.2/img/overview2.svg>>+--+-- $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, --@@ -163,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)@@ -219,10 +332,19 @@ 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"@@ -238,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@@ -251,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) "@@ -274,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 @@ -337,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 ---------------------------------------------------------------------------- @@ -434,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@@ -451,39 +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 String Text+-- >>> decode1 "---\nBar\n..." :: Either (Pos,String) Text -- Right "Bar" ----- >>> decode1 "Foo\n---\nBar" :: Either String Text--- Left "unexpected multiple YAML documents"+-- >>> 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 String Text--- Left "empty YAML stream"+-- >>> decode1 "# Just a comment" :: Either (Pos,String) Text+-- Left (Pos {posByteOffset = 0, posCharOffset = 0, posLine = 1, posColumn = 0},"empty YAML stream") ----- @since 0.1.2.0-decode1 :: FromYAML v => BS.L.ByteString -> Either String v-decode1 text = do- vs <- decode text- case vs of- [] -> Left "empty YAML stream"- [v] -> Right v- _ -> Left "unexpected multiple YAML documents"+-- @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.1.2.0-decode1Strict :: FromYAML v => BS.ByteString -> Either String v-decode1Strict text = do- vs <- decodeStrict text- maybe (Left "expected unique") Right $ listToMaybe vs+-- @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
+ src/Data/YAML/Dumper.hs view
@@ -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 <https://en.wikipedia.org/wiki/Byte_order_mark BOM> 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++
src/Data/YAML/Event.hs view
@@ -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 @<major>.<minor>@+ 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.
+ src/Data/YAML/Event/Internal.hs view
@@ -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 !_ = ()++-- | <https://yaml.org/spec/1.2/spec.html#id2794534 Block Chomping Indicator>+--+-- @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+
+ src/Data/YAML/Event/Writer.hs view
@@ -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++ -- <https://yaml.org/spec/1.2/spec.html#in-flow(c) in-flow(c)>+ 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
+ src/Data/YAML/Internal.hs view
@@ -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')
src/Data/YAML/Loader.hs view
@@ -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 }
+ src/Data/YAML/Pos.hs view
@@ -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 @<line>:<column>:@ 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
src/Data/YAML/Schema.hs view
@@ -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 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.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))- ]+ -- * 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
+ src/Data/YAML/Schema/Internal.hs view
@@ -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 <https://yaml.org/spec/1.2/spec.html#c-indicator Indicator Characters>).+--+-- __NOTE__: This does not mean that other characters (like @"\\n"@ and other special characters like @"-?:,[]{}#&*!,>%\@`\"\'"@) cannot be used in 'Plain' 'Scalar's.+--+-- @since 0.2.0+isPlainChar :: Char -> Bool+isPlainChar c = C.isAlphaNum c || c `elem` (" ~$^+=</;._\\" :: String) -- not $ c `elem` "\n-?:,[]{}#&*!,>%@`\\'\""++-- | Returns True if the string can be decoded by the given 'SchemaResolver'+-- into a 'Scalar' which is not a of type 'SStr'.+--+-- >>> isAmbiguous coreSchemaResolver "true"+-- True+--+-- >>> isAmbiguous failSchemaResolver "true"+-- False+--+-- @since 0.2.0+isAmbiguous :: SchemaResolver -> T.Text -> Bool+isAmbiguous SchemaResolver{..} t = case schemaResolverScalar untagged Plain t of+ Left err -> error err+ Right (SStr _ ) -> False+ Right _ -> True++-- | According to YAML 1.2 'coreSchemaEncoder' is the default 'SchemaEncoder'+--+-- By default, 'Scalar's are encoded as follows:+--+-- * String which are made of Plain Characters (see 'isPlainChar'), unambiguous (see 'isAmbiguous') and do not contain any leading/trailing spaces are encoded as 'Plain' 'Scalar'.+--+-- * Rest of the strings are encoded in DoubleQuotes+--+-- * Booleans are encoded using 'encodeBool'+--+-- * Double values are encoded using 'encodeDouble'+--+-- * Integral values are encoded using 'encodeInt'+--+-- @since 0.2.0+defaultSchemaEncoder :: SchemaEncoder+defaultSchemaEncoder = coreSchemaEncoder++-- | Set the 'Scalar' style in the encoded YAML. This is a function that decides+-- for each 'Scalar' the type of YAML string to output.+--+-- __WARNING__: You must ensure that special strings (like @"true"@\/@"false"@\/@"null"@\/@"1234"@) are not encoded with the 'Plain' style, because+-- then they will be decoded as boolean, null or numeric values. You can use 'isAmbiguous' to detect them.+--+-- __NOTE__: For different 'SchemaResolver's, different strings are ambiguous. For example, @"true"@ is not ambiguous for 'failsafeSchemaResolver'.+--+-- @since 0.2.0+setScalarStyle :: (Scalar -> Either String (Tag, ScalarStyle, T.Text)) -> SchemaEncoder -> SchemaEncoder+setScalarStyle customScalarEncoder encoder = encoder { schemaEncoderScalar = customScalarEncoder }+
src/Data/YAML/Token.hs view
@@ -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 @@ -484,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 = pfail "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 -- "*"@@ -528,17 +542,17 @@ -- | @lookbehind <?@ matches the current point without consuming any -- characters, if the previous character matches the lookbehind parser (single--- character positive lookbehind)+-- character positive lookbehind). (<?) :: (Match match result) => match -> Parser result (<?) lookbehind = prev lookbehind -- | @lookahead >?@ 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 @@ -695,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 @@ -741,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.@@ -765,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@@ -797,7 +813,7 @@ where charsOf field charsField | state^.sIsPeek = -1- | state^.sChars == [] = state^.field+ | null (state^.sChars) = state^.field | otherwise = state^.charsField -- ** Producing tokens@@ -910,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@@ -933,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@@ -954,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@@ -1059,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 @@ -1216,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 ?)@@ -1366,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 *)@@ -1395,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 *)@@ -1414,7 +1439,8 @@ FlowIn -> ns_plain_safe_in BlockKey -> ns_plain_safe_out FlowKey -> ns_plain_safe_in- + _ -> 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 - ':' - '#'@@ -1426,7 +1452,9 @@ 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 @@ -1442,6 +1470,7 @@ FlowIn -> FlowIn BlockKey -> FlowKey FlowKey -> FlowKey+ _ -> error "unexpected node style pattern in in_flow" -- 7.4.1 Flow Sequences @@ -1473,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 )@@ -1669,7 +1698,7 @@ / ns_l_block_map_implicit_entry n c_l_block_map_explicit_entry n {- 189 -} = c_l_block_map_explicit_key n & ( l_block_map_explicit_value n- / e_node ) + / e_node ) 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 @@ -1713,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
src/Data/YAML/Token/Encoding.hs view
@@ -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"--
src/Util.hs view
@@ -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
+ tests/Tests.hs view
@@ -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