diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # ChangeLog for yaml +## 0.10.2.0 + +* Add `EncodeOptions` and `FormatOptions` to control the style of the encoded YAML. [#153](https://github.com/snoyberg/yaml/pull/153) +* Default to using literal style for multiline strings [#152](https://github.com/snoyberg/yaml/issues/152) + ## 0.10.1.1 * Correctly declare libyaml dependency on system-libyaml flag [#151](https://github.com/snoyberg/yaml/pull/151) diff --git a/src/Data/Yaml.hs b/src/Data/Yaml.hs --- a/src/Data/Yaml.hs +++ b/src/Data/Yaml.hs @@ -28,7 +28,9 @@ #endif ( -- * Encoding encode + , encodeWith , encodeFile + , encodeFileWith -- * Decoding , decodeEither' , decodeFileEither @@ -66,6 +68,15 @@ -- * Classes , ToJSON (..) , FromJSON (..) + -- * Custom encoding + , isSpecialString + , EncodeOptions + , defaultEncodeOptions + , setStringStyle + , setFormat + , FormatOptions + , defaultFormatOptions + , setWidth -- * Deprecated , decode , decodeFile @@ -95,70 +106,131 @@ import qualified Data.HashMap.Strict as M import qualified Data.HashSet as HashSet import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text as T import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as TL import Data.Text.Lazy.Builder (toLazyText) import qualified Data.Vector as V import System.IO.Unsafe (unsafePerformIO) +import Data.Text (Text) import Data.Yaml.Internal -import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile) +import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile, encodeWith, encodeFileWith) import qualified Text.Libyaml as Y +-- | +-- @since 0.10.2.0 +data EncodeOptions = EncodeOptions + { encodeOptionsStringStyle :: Text -> ( Tag, Style ) + , encodeOptionsFormat :: FormatOptions + } + +-- | Set the string style in the encoded YAML. This is a function that decides +-- for each string the type of YAML string to output. +-- +-- __WARNING__: You must ensure that special strings (like @"yes"@\/@"no"@\/@"null"@\/@"1234"@) are not encoded with the 'Plain' style, because +-- then they will be decoded as boolean, null or numeric values. You can use 'isSpecialString' to detect them. +-- +-- By default, strings are encoded as follows: +-- +-- * Any string containing a newline character uses the 'Literal' style +-- +-- * Otherwise, any special string (see 'isSpecialString') uses 'SingleQuoted' +-- +-- * Otherwise, use 'Plain' +-- +-- @since 0.10.2.0 +setStringStyle :: (Text -> ( Tag, Style )) -> EncodeOptions -> EncodeOptions +setStringStyle s opts = opts { encodeOptionsStringStyle = s } + +-- | Set the encoding formatting for the encoded YAML. By default, this is `defaultFormatOptions`. +-- +-- @since 0.10.2.0 +setFormat :: FormatOptions -> EncodeOptions -> EncodeOptions +setFormat f opts = opts { encodeOptionsFormat = f } + +-- | Determine whether a string must be quoted in YAML and can't appear as plain text. +-- Useful if you want to use 'setStringStyle'. +-- +-- @since 0.10.2.0 +isSpecialString :: Text -> Bool +isSpecialString s = s `HashSet.member` specialStrings || isNumeric s + +-- | +-- @since 0.10.2.0 +defaultEncodeOptions :: EncodeOptions +defaultEncodeOptions = EncodeOptions + { encodeOptionsStringStyle = \s -> + -- Empty strings need special handling to ensure they get quoted. This avoids: + -- https://github.com/snoyberg/yaml/issues/24 + case () of + () + | "\n" `T.isInfixOf` s -> ( NoTag, Literal ) + | isSpecialString s -> ( NoTag, SingleQuoted ) + | otherwise -> ( StrTag, PlainNoTag ) + , encodeOptionsFormat = defaultFormatOptions + } + -- | Encode a value into its YAML representation. encode :: ToJSON a => a -> ByteString -encode obj = unsafePerformIO $ runConduitRes - $ CL.sourceList (objToEvents $ toJSON obj) - .| Y.encode +encode = encodeWith defaultEncodeOptions +-- | Encode a value into its YAML representation with custom styling. +-- +-- @since 0.10.2.0 +encodeWith :: ToJSON a => EncodeOptions -> a -> ByteString +encodeWith opts obj = unsafePerformIO $ runConduitRes + $ CL.sourceList (objToEvents opts $ toJSON obj) + .| Y.encodeWith (encodeOptionsFormat opts) + -- | Encode a value into its YAML representation and save to the given file. encodeFile :: ToJSON a => FilePath -> a -> IO () -encodeFile fp obj = runConduitRes - $ CL.sourceList (objToEvents $ toJSON obj) - .| Y.encodeFile fp +encodeFile = encodeFileWith defaultEncodeOptions -objToEvents :: Value -> [Y.Event] -objToEvents o = (:) EventStreamStart +-- | Encode a value into its YAML representation with custom styling and save to the given file. +-- +-- @since 0.10.2.0 +encodeFileWith :: ToJSON a => EncodeOptions -> FilePath -> a -> IO () +encodeFileWith opts fp obj = runConduitRes + $ CL.sourceList (objToEvents opts $ toJSON obj) + .| Y.encodeFileWith (encodeOptionsFormat opts) fp + +objToEvents :: EncodeOptions -> Value -> [Y.Event] +objToEvents opts o = (:) EventStreamStart . (:) EventDocumentStart $ objToEvents' o [ EventDocumentEnd , EventStreamEnd ] + where + objToEvents' :: Value -> [Y.Event] -> [Y.Event] + --objToEvents' (Scalar s) rest = scalarToEvent s : rest + objToEvents' (Array list) rest = + EventSequenceStart NoTag AnySequence Nothing + : foldr objToEvents' (EventSequenceEnd : rest) (V.toList list) + objToEvents' (Object pairs) rest = + EventMappingStart NoTag AnyMapping Nothing + : foldr pairToEvents (EventMappingEnd : rest) (M.toList pairs) + objToEvents' (String "") rest = EventScalar "" NoTag SingleQuoted Nothing : rest + + objToEvents' (String s) rest = EventScalar (encodeUtf8 s) tag style Nothing : rest + where + ( tag, style ) = encodeOptionsStringStyle opts s + objToEvents' Null rest = EventScalar "null" NullTag PlainNoTag Nothing : rest + objToEvents' (Bool True) rest = EventScalar "true" BoolTag PlainNoTag Nothing : rest + objToEvents' (Bool False) rest = EventScalar "false" BoolTag PlainNoTag Nothing : rest + -- Use aeson's implementation which gets rid of annoying decimal points + objToEvents' n@Number{} rest = EventScalar (TE.encodeUtf8 $ TL.toStrict $ toLazyText $ encodeToTextBuilder n) IntTag PlainNoTag Nothing : rest + + pairToEvents :: Pair -> [Y.Event] -> [Y.Event] + pairToEvents (k, v) = objToEvents' (String k) . objToEvents' v + {- FIXME scalarToEvent :: YamlScalar -> Event scalarToEvent (YamlScalar v t s) = EventScalar v t s Nothing -} -objToEvents' :: Value -> [Y.Event] -> [Y.Event] ---objToEvents' (Scalar s) rest = scalarToEvent s : rest -objToEvents' (Array list) rest = - EventSequenceStart NoTag AnySequence Nothing - : foldr objToEvents' (EventSequenceEnd : rest) (V.toList list) -objToEvents' (Object pairs) rest = - EventMappingStart NoTag AnyMapping Nothing - : foldr pairToEvents (EventMappingEnd : rest) (M.toList pairs) - --- Empty strings need special handling to ensure they get quoted. This avoids: --- https://github.com/snoyberg/yaml/issues/24 -objToEvents' (String "") rest = EventScalar "" NoTag SingleQuoted Nothing : rest - -objToEvents' (String s) rest = - event : rest - where - event - -- Make sure that special strings are encoded as strings properly. - -- See: https://github.com/snoyberg/yaml/issues/31 - | s `HashSet.member` specialStrings || isNumeric s = EventScalar (encodeUtf8 s) NoTag SingleQuoted Nothing - | otherwise = EventScalar (encodeUtf8 s) StrTag PlainNoTag Nothing -objToEvents' Null rest = EventScalar "null" NullTag PlainNoTag Nothing : rest -objToEvents' (Bool True) rest = EventScalar "true" BoolTag PlainNoTag Nothing : rest -objToEvents' (Bool False) rest = EventScalar "false" BoolTag PlainNoTag Nothing : rest --- Use aeson's implementation which gets rid of annoying decimal points -objToEvents' n@Number{} rest = EventScalar (TE.encodeUtf8 $ TL.toStrict $ toLazyText $ encodeToTextBuilder n) IntTag PlainNoTag Nothing : rest - -pairToEvents :: Pair -> [Y.Event] -> [Y.Event] -pairToEvents (k, v) = objToEvents' (String k) . objToEvents' v decode :: FromJSON a => ByteString diff --git a/src/Data/Yaml/Builder.hs b/src/Data/Yaml/Builder.hs --- a/src/Data/Yaml/Builder.hs +++ b/src/Data/Yaml/Builder.hs @@ -14,8 +14,12 @@ , scientific , number , toByteString + , toByteStringWith , writeYamlFile + , writeYamlFileWith , (.=) + , FormatOptions + , setWidth ) where import Prelude hiding (null) @@ -110,7 +114,17 @@ toSource = mapM_ yield . toEvents . toYaml toByteString :: ToYaml a => a -> ByteString -toByteString yb = unsafePerformIO $ runConduitRes $ toSource yb .| encode +toByteString = toByteStringWith defaultFormatOptions +-- | +-- @since 0.10.2.0 +toByteStringWith :: ToYaml a => FormatOptions -> a -> ByteString +toByteStringWith opts yb = unsafePerformIO $ runConduitRes $ toSource yb .| encodeWith opts + writeYamlFile :: ToYaml a => FilePath -> a -> IO () -writeYamlFile fp yb = runConduitRes $ toSource yb .| encodeFile fp +writeYamlFile = writeYamlFileWith defaultFormatOptions + +-- | +-- @since 0.10.2.0 +writeYamlFileWith :: ToYaml a => FormatOptions -> FilePath -> a -> IO () +writeYamlFileWith opts fp yb = runConduitRes $ toSource yb .| encodeFileWith opts fp diff --git a/src/Text/Libyaml.hs b/src/Text/Libyaml.hs --- a/src/Text/Libyaml.hs +++ b/src/Text/Libyaml.hs @@ -21,9 +21,14 @@ , Anchor -- * Encoding and decoding , encode + , encodeWith , decode , encodeFile , decodeFile + , encodeFileWith + , FormatOptions + , defaultFormatOptions + , setWidth -- * Error handling , YamlException (..) , YamlMark (..) @@ -348,6 +353,9 @@ foreign import ccall unsafe "yaml_emitter_set_output_file" c_yaml_emitter_set_output_file :: Emitter -> File -> IO () +foreign import ccall unsafe "yaml_emitter_set_width" + c_yaml_emitter_set_width :: Emitter -> CInt -> IO () + foreign import ccall unsafe "yaml_emitter_emit" c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt @@ -605,9 +613,34 @@ return $ Left $ YamlParseException problem context problemMark else Right <$> getEvent er +-- | Contains options relating to the formatting (indendation, width) of the YAML output. +-- +-- @since 0.10.2.0 +data FormatOptions = FormatOptions + { formatOptionsWidth :: Maybe Int + } + +-- | +-- @since 0.10.2.0 +defaultFormatOptions :: FormatOptions +defaultFormatOptions = FormatOptions + { formatOptionsWidth = Just 80 -- by default the width is set to 0 in the C code, which gets turned into 80 in yaml_emitter_emit_stream_start + } + +-- | Set the maximum number of columns in the YAML output, or 'Nothing' for infinite. By default, the limit is 80 characters. +-- +-- @since 0.10.2.0 +setWidth :: Maybe Int -> FormatOptions -> FormatOptions +setWidth w opts = opts { formatOptionsWidth = w } + encode :: MonadResource m => ConduitM Event o m ByteString -encode = - runEmitter alloc close +encode = encodeWith defaultFormatOptions + +-- | +-- @since 0.10.2.0 +encodeWith :: MonadResource m => FormatOptions -> ConduitM Event o m ByteString +encodeWith opts = + runEmitter opts alloc close where alloc emitter = do fbuf <- mallocForeignPtrBytes bufferSize @@ -620,11 +653,20 @@ fptr <- newForeignPtr_ $ castPtr ptr' return $ B.fromForeignPtr fptr 0 $ fromIntegral len + encodeFile :: MonadResource m => FilePath -> ConduitM Event o m () -encodeFile filePath = - bracketP getFile c_fclose $ \file -> runEmitter (alloc file) (\u _ -> return u) +encodeFile = encodeFileWith defaultFormatOptions + +-- | +-- @since 0.10.2.0 +encodeFileWith :: MonadResource m + => FormatOptions + -> FilePath + -> ConduitM Event o m () +encodeFileWith opts filePath = + bracketP getFile c_fclose $ \file -> runEmitter opts (alloc file) (\u _ -> return u) where getFile = do file <- openFile filePath write_flags "w" @@ -635,10 +677,11 @@ alloc file emitter = c_yaml_emitter_set_output_file emitter file runEmitter :: MonadResource m - => (Emitter -> IO a) -- ^ alloc + => FormatOptions + -> (Emitter -> IO a) -- ^ alloc -> (() -> a -> IO b) -- ^ close -> ConduitM Event o m b -runEmitter allocI closeI = +runEmitter opts allocI closeI = bracketP alloc cleanup go where alloc = mask_ $ do @@ -648,6 +691,9 @@ #ifndef __NO_UNICODE__ c_yaml_emitter_set_unicode emitter 1 #endif + c_yaml_emitter_set_width emitter $ case formatOptionsWidth opts of + Nothing -> -1 --infinite + Just width -> fromIntegral width a <- allocI emitter return (emitter, a) cleanup (emitter, _) = do diff --git a/yaml.cabal b/yaml.cabal --- a/yaml.cabal +++ b/yaml.cabal @@ -1,13 +1,13 @@ -cabal-version: >= 1.10 +cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.29.6. +-- This file has been generated from package.yaml by hpack version 0.30.0. -- -- see: https://github.com/sol/hpack -- --- hash: 35f17bf7ece306fc322476ea7dac5e0561ed45dfaf86b2cf65b37c02ed42833f +-- hash: 58011fe7948e28cb6cfcf77813829fd465ad17525a4a24c3babd4155e0df8acd name: yaml -version: 0.10.1.1 +version: 0.10.2.0 synopsis: Support for parsing and rendering YAML documents. description: README and API documentation are available at category: Data @@ -21,21 +21,21 @@ build-type: Simple extra-source-files: c/helper.h - ChangeLog.md - libyaml/LICENSE - libyaml/yaml.h libyaml/yaml_private.h - README.md - test/json.yaml + libyaml/yaml.h + libyaml/LICENSE test/largest-string.yaml - test/resources/accent/foo.yaml + test/json.yaml + test/resources/foo.yaml test/resources/bar.yaml test/resources/baz.yaml + test/resources/accent/foo.yaml + test/resources/loop/foo.yaml + test/resources/loop/bar.yaml test/resources/empty.yaml test/resources/empty2.yaml - test/resources/foo.yaml - test/resources/loop/bar.yaml - test/resources/loop/foo.yaml + README.md + ChangeLog.md source-repository head type: git