diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/HsYAML.cabal b/HsYAML.cabal --- a/HsYAML.cabal +++ b/HsYAML.cabal @@ -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 diff --git a/LICENSE.GPLv2 b/LICENSE.GPLv2 --- a/LICENSE.GPLv2 +++ b/LICENSE.GPLv2 @@ -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. + + + + + + + + + diff --git a/LICENSE.GPLv3 b/LICENSE.GPLv3 --- a/LICENSE.GPLv3 +++ b/LICENSE.GPLv3 @@ -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 . + + + + diff --git a/src-test/Main.hs b/src-test/Main.hs --- a/src-test/Main.hs +++ b/src-test/Main.hs @@ -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 diff --git a/src/Data/YAML.hs b/src/Data/YAML.hs --- a/src/Data/YAML.hs +++ b/src/Data/YAML.hs @@ -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 diff --git a/src/Data/YAML/Dumper.hs b/src/Data/YAML/Dumper.hs --- a/src/Data/YAML/Dumper.hs +++ b/src/Data/YAML/Dumper.hs @@ -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 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 diff --git a/src/Data/YAML/Event/Internal.hs b/src/Data/YAML/Event/Internal.hs --- a/src/Data/YAML/Event/Internal.hs +++ b/src/Data/YAML/Event/Internal.hs @@ -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 -- diff --git a/src/Data/YAML/Internal.hs b/src/Data/YAML/Internal.hs --- a/src/Data/YAML/Internal.hs +++ b/src/Data/YAML/Internal.hs @@ -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) diff --git a/src/Data/YAML/Pos.hs b/src/Data/YAML/Pos.hs new file mode 100644 --- /dev/null +++ b/src/Data/YAML/Pos.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE Safe #-} + +-- | +-- Copyright: © Herbert Valerio Riedel 2015-2018 +-- SPDX-License-Identifier: GPL-2.0-or-later +-- +module Data.YAML.Pos + ( Pos(..) + , prettyPosWithSource + ) where + +import qualified Data.ByteString.Lazy as BL +import qualified Data.YAML.Token.Encoding as Enc +import Util + +-- | Position in parsed YAML source +-- +-- See also 'prettyPosWithSource'. +-- +-- __NOTE__: if 'posCharOffset' is negative the 'Pos' value doesn't refer to a proper location; this may be emitted in corner cases when no proper location can be inferred. +data Pos = Pos + { posByteOffset :: !Int -- ^ 0-based byte offset + , posCharOffset :: !Int -- ^ 0-based character (Unicode code-point) offset + , posLine :: !Int -- ^ 1-based line number + , posColumn :: !Int -- ^ 0-based character (Unicode code-point) column number + } deriving (Eq, Show, Generic) + +-- | @since 0.2.0 +instance NFData Pos where rnf !_ = () + +-- | Pretty prints a 'Pos' together with the line the 'Pos' refers and the column position. +-- +-- The input 'BL.ByteString' must be the same that was passed to the +-- YAML decoding function that produced the 'Pos' value. The 'String' +-- argument is inserted right after the @::@ in the +-- first line. The pretty-printed position result 'String' will be +-- terminated by a trailing newline. +-- +-- For instance, +-- +-- @ +-- 'prettyPosWithSource' somePos someInput " error" ++ "unexpected character\\n" +-- @ results in +-- +-- > 11:7: error +-- > | +-- > 11 | foo: | bar +-- > | ^ +-- > unexpected character +-- +-- @since 0.2.1 +prettyPosWithSource :: Pos -> BL.ByteString -> String -> String +prettyPosWithSource Pos{..} source msg + | posCharOffset < 0 || posByteOffset < 0 = "0:0:" ++ msg ++ "\n" -- unproper location + | otherwise = unlines + [ show posLine ++ ":" ++ show posColumn ++ ":" ++ msg + , lpfx + , lnostr ++ "| " ++ line + , lpfx ++ replicate posColumn ' ' ++ "^" + ] + + where + lnostr = " " ++ show posLine ++ " " + lpfx = (' ' <$ lnostr) ++ "| " + + (_,lstart) = findLineStartByByteOffset posByteOffset source + line = map snd $ takeWhile (not . isNL . snd) lstart + + isNL c = c == '\r' || c == '\n' + +findLineStartByByteOffset :: Int -> BL.ByteString -> (Int,[(Int,Char)]) +findLineStartByByteOffset bofs0 input = go 0 inputChars inputChars + where + (_,inputChars) = Enc.decode input + + go lsOfs lsChars [] = (lsOfs,lsChars) + go lsOfs lsChars ((ofs',_):_) + | bofs0 < ofs' = (lsOfs,lsChars) + + go _ _ ((_,'\r'):(ofs','\n'):rest) = go ofs' rest rest + go _ _ ((ofs','\r'):rest) = go ofs' rest rest + go _ _ ((ofs','\n'):rest) = go ofs' rest rest + go lsOfs lsChars (_:rest) = go lsOfs lsChars rest diff --git a/src/Data/YAML/Token/Encoding.hs b/src/Data/YAML/Token/Encoding.hs --- a/src/Data/YAML/Token/Encoding.hs +++ b/src/Data/YAML/Token/Encoding.hs @@ -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/.