HsYAML 0.2.0.0 → 0.2.1.0

raw patch · 11 files changed

+226/−73 lines, 11 filesdep ~QuickCheckdep ~basedep ~bytestringPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: QuickCheck, base, bytestring, megaparsec, tasty, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +12/−4
• HsYAML.cabal +2/−1
• LICENSE.GPLv2 +9/−0
• LICENSE.GPLv3 +4/−0
• src-test/Main.hs +21/−28
• src/Data/YAML.hs +59/−6
• src/Data/YAML/Dumper.hs +4/−2
• src/Data/YAML/Event/Internal.hs +1/−13
• src/Data/YAML/Internal.hs +10/−1
• src/Data/YAML/Pos.hs +87/−0
• src/Data/YAML/Token/Encoding.hs +17/−18

@@ -1,5 +1,13 @@ See also http://pvp.haskell.org/faq +### 0.2.1.0++* 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/).@@ -14,7 +22,7 @@         * 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'+    * 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))@@ -47,18 +55,18 @@  --- -### 0.1.1.3+#### 0.1.1.3  * Fix bug in float regexp being too lax in the JSON and Core schema ([#7](https://github.com/hvr/HsYAML/issues/7)) * Remove dependency on `dlist` -### 0.1.1.2+#### 0.1.1.2  * Tolerate BOM at *each* `l-document-prefix` (rather than only at the first one encountered in a YAML stream) * Workaround broken `mtl-2.2.2` bundled in GHC 8.4.1 ([#1](https://github.com/hvr/HsYAML/issues/1)) * Relax to GPL-2.0-or-later -### 0.1.1.1+#### 0.1.1.1  * Reject (illegal) non-scalar code-points in UTF-32 streams * Tolerate BOM at start of stream

@@ -1,6 +1,6 @@ cabal-version:       1.14 name:                HsYAML-version:             0.2.0.0+version:             0.2.1.0  synopsis:            Pure Haskell YAML 1.2 processor homepage:            https://github.com/hvr/HsYAML@@ -56,6 +56,7 @@                      , Data.YAML.Internal                      , Data.YAML.Event.Internal                      , Data.YAML.Event.Writer+                     , Data.YAML.Pos                      , Data.YAML.Schema.Internal                      , Data.YAML.Token.Encoding                      , Util

@@ -337,3 +337,12 @@ consider it more useful to permit linking proprietary applications with the library.  If this is what you want to do, use the GNU Lesser General Public License instead of this License.++++++              +++ 

@@ -672,3 +672,7 @@ the library.  If this is what you want to do, use the GNU Lesser General Public License instead of this License.  But first, please read <http://www.gnu.org/philosophy/why-not-lgpl.html>.+++  +     

@@ -32,8 +32,8 @@ import qualified Data.Text.IO               as T  import           Data.YAML                  as Y-import           Data.YAML.Schema           as Y import           Data.YAML.Event            as YE+import           Data.YAML.Schema           as Y import qualified Data.YAML.Token            as YT  import qualified TML@@ -98,7 +98,7 @@           exitFailure      ("yaml2yaml-dump": args')-      | null args' -> cmdDumpYAML +      | null args' -> cmdDumpYAML       | otherwise  -> do           hPutStrLn stderr "unexpected arguments passed to yaml2event sub-command"           exitFailure@@ -183,9 +183,9 @@     Left (ofs,msg) -> do       hPutStrLn stderr ("Parsing error near byte offset " ++ show ofs ++ if null msg then "" else " (" ++ msg ++ ")")       exitFailure-    Right event -> print (eEvent event)-      -- hPutStrLn stdout (ev2str True (eEvent event))-      -- hFlush stdout+    Right event -> do+      hPutStrLn stdout (ev2str True (eEvent event))+      hFlush stdout  cmdYaml2EventPos :: IO () cmdYaml2EventPos = do@@ -196,19 +196,12 @@    forM_ (parseEvents inYamlDat) $ \ev -> case ev of     Left (ofs,msg) -> do-      hPutStrLn stderr ("Parsing error near byte offset " ++ show ofs ++ if null msg then "" else " (" ++ msg ++ ")")+      hPutStrLn stderr (prettyPosWithSource ofs inYamlDat (" error [" ++ show ofs ++ "]") ++ msg)       exitFailure     Right event -> do       let Pos{..} = ePos event -      putStrLn ""-      putStrLn (show posLine ++ ":" ++ show posColumn ++ ":\t" ++ show (eEvent event))-      when (posLine <= maxLine) $ do-        T.putStrLn ("| " <> (inYamlDatLns !! (posLine-1)))-        putStrLn (replicate (posColumn+2) ' ' <> "^")--      -- hPutStrLn stdout (ev2str True (eEvent event))-      -- hFlush stdout+      putStrLn (prettyPosWithSource (ePos event) inYamlDat ("\t" ++ ev2str True (eEvent event)))  cmdYaml2Event0 :: IO () cmdYaml2Event0 = do@@ -217,7 +210,7 @@   where     parseEvents' = map (either (\(ofs,msg) -> error ("parsing error near byte offset " ++ show ofs ++ " (" ++ msg ++ ")")) id) . parseEvents -cmdYaml2YamlVal :: IO() +cmdYaml2YamlVal :: IO() cmdYaml2YamlVal = do   inYamlDat <- BS.L.getContents   case sequence $ parseEvents inYamlDat of@@ -235,8 +228,8 @@         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 $ printf "No of difference detected: %d\n" $ length diffList+          forM_ diffList $ \(old,new) -> do             hPutStrLn stdout $ "Input  > " ++ show old             hPutStrLn stdout $ "Output < " ++ show new @@ -316,7 +309,7 @@     -- 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) +                  Left (pos, err) -> Left (pos, err)                   Right a         -> Right a >>= mapM (parseEither . parseYAML . (\(Doc x) -> x))  @@ -420,7 +413,7 @@          Right evs' -> do           let events = map eEvent evs'-              evs'' = map (ev2str False) events +              evs'' = map (ev2str False) events           if evs'' == testEvDat              then do @@ -576,7 +569,7 @@          Right evs' -> do           let events = map eEvent (filter (not. isComment'. eEvent) evs')                     -- filter comments before comparing-              evs'' = map (ev2str False) events +              evs'' = map (ev2str False) events           if evs'' == testEvDat              then do                let outYamlDatIut = writeEvents YT.UTF8 (map eEvent evs')                -- Allow both block and flow style@@ -700,32 +693,32 @@ putStrLn' msg = putStrLn ("  " ++ msg)  printNode :: Node loc -> IO ()-printNode node = case node of  +printNode node = case node of     (Y.Scalar _ a)      -> hPutStrLn stdout $  "Scalar "   ++ show a     (Y.Mapping _ a b)   -> do-                              hPutStrLn stdout $  "Mapping "  ++ show a +                              hPutStrLn stdout $  "Mapping "  ++ show a                               printMap b-    (Y.Sequence _ a b)  -> do -                              hPutStrLn stdout $  "Sequence " ++ show a +    (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  printMap :: Map (Node loc) (Node loc) -> IO ()-printMap b = forM_ (Map.toList b) $ \(k,v) -> do +printMap b = forM_ (Map.toList b) $ \(k,v) -> do               hPutStr stdout "Key: "-              printNode k +              printNode k               hPutStr stdout "Value: "               printNode v  isComment evPos = case evPos of   Right (YE.EvPos {eEvent = (YE.Comment _), ePos = _}) -> True-  _ -> False +  _                                                    -> False  isComment' ev = case ev of   (Comment _) -> True-  _ -> False +  _           -> False  ev2str :: Bool -> Event -> String ev2str withColSty = \case

@@ -47,11 +47,13 @@     , encode1Strict     , ToYAML(..) -      -- ** Accessors for encoding+      -- ** Accessors for encoding t'Mapping's+    , Pair     , mapping     , (.=)        -- ** Prism-style parsers+    , withScalar     , withSeq     , withBool     , withFloat@@ -65,10 +67,13 @@     , decodeNode'     , encodeNode     , encodeNode'-    , Doc(Doc)+    , Doc(Doc,docRoot)     , Node(..)     , Scalar(..)++      -- * Source locations     , Pos(..)+    , prettyPosWithSource        -- * YAML 1.2 Schema resolvers       --@@ -101,9 +106,10 @@ import qualified Data.Text                 as T  import           Data.YAML.Dumper-import           Data.YAML.Event           (Pos (..), isUntagged, tagToText)+import           Data.YAML.Event           (isUntagged, tagToText) import           Data.YAML.Internal import           Data.YAML.Loader+import           Data.YAML.Pos import           Data.YAML.Schema.Internal  import           Util@@ -178,6 +184,35 @@ -- -- 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+--   -- | Retrieve value in t'Mapping' indexed by a @!!str@ 'Text' key.@@ -376,11 +411,21 @@ 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 (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 @@ -654,6 +699,10 @@ 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@@ -687,8 +736,7 @@   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 'BS.L.ByteString'.+-- | 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. --@@ -702,7 +750,7 @@ -- >>> 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'.+-- 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@@ -741,6 +789,11 @@  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

@@ -24,7 +24,7 @@ type EvList = [Either String Event] type Node2EvList = [Node ()] -> EvList --- | Dump YAML Nodes as a lazy 'BS.L.ByteString'+-- | 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. --@@ -36,9 +36,11 @@  -- | 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 getDoc nodes))+encodeNode' SchemaEncoder{..} encoding nodes = writeEvents encoding $ map getEvent (dumpEvents (map docRoot nodes))   where      getEvent :: Either String Event -> Event

@@ -24,6 +24,7 @@   import qualified Data.Text       as T+import           Data.YAML.Pos   (Pos (..)) import qualified Data.YAML.Token as Y  import           Util@@ -175,19 +176,6 @@ -- immediately once a 'Left' value is returned. type EvStream = [Either (Pos,String) EvPos] ---- | Position in parsed YAML source------ __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 !_ = ()  -- | Convert 'Tag' to its string representation --

@@ -22,11 +22,20 @@ import           Util  -- | YAML Document tree/graph-newtype Doc n = Doc { getDoc :: n } deriving (Eq,Ord,Show,Generic)+--+-- __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)

@@ -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

@@ -25,7 +25,7 @@  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@@ -42,32 +42,31 @@     show UTF32LE = "UTF-32LE"     show UTF32BE = "UTF-32BE" - -- | @since 0.2.0 instance NFData Encoding where rnf !_ = () --- | @decode bytes@ automatically detects the 'Encoding' used and converts the+-- | @'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/.