From afc920a40f0f6d26330de88dc8245b7e26b4ed61 Mon Sep 17 00:00:00 2001 From: Patrick Chilton Date: Thu, 6 Sep 2018 15:26:31 +0200 Subject: [PATCH 1/2] Don't wrap strings at 80 characters. --- src/Text/Libyaml.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/src/Text/Libyaml.hs b/src/Text/Libyaml.hs index 8c95af0..9021ec9 100644 --- a/src/Text/Libyaml.hs +++ b/src/Text/Libyaml.hs @@ -348,6 +348,9 @@ foreign import ccall unsafe "yaml_emitter_set_unicode" 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 @@ -648,6 +651,7 @@ runEmitter allocI closeI = #ifndef __NO_UNICODE__ c_yaml_emitter_set_unicode emitter 1 #endif + c_yaml_emitter_set_width emitter (-1) -- prevent libyaml from wrapping strings at 80 chars a <- allocI emitter return (emitter, a) cleanup (emitter, _) = do From 9819ecbcf11e1487e42603db3267873164d40c4c Mon Sep 17 00:00:00 2001 From: Patrick Chilton Date: Sun, 9 Sep 2018 13:06:03 +0200 Subject: [PATCH 2/2] Add configurable encodeWith/encodeFileWith. --- ChangeLog.md | 4 ++ package.yaml | 2 +- src/Data/Yaml.hs | 139 ++++++++++++++++++++++++++++----------- src/Data/Yaml/Builder.hs | 18 ++++- src/Text/Libyaml.hs | 56 ++++++++++++++-- 5 files changed, 171 insertions(+), 48 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 469bb26..f7b5fb8 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # 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) + ## 0.10.1.1 * Correctly declare libyaml dependency on system-libyaml flag [#151](https://github.com/snoyberg/yaml/pull/151) diff --git a/package.yaml b/package.yaml index 6a88674..1559297 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ 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 diff --git a/src/Data/Yaml.hs b/src/Data/Yaml.hs index bdc7edd..4a14203 100644 --- a/src/Data/Yaml.hs +++ b/src/Data/Yaml.hs @@ -28,7 +28,9 @@ module Data.Yaml #endif ( -- * Encoding encode + , encodeWith , encodeFile + , encodeFileWith -- * Decoding , decodeEither' , decodeFileEither @@ -66,6 +68,15 @@ module Data.Yaml -- * Classes , ToJSON (..) , FromJSON (..) + -- * Custom encoding + , isSpecialString + , EncodeOptions + , defaultEncodeOptions + , setStringStyle + , setFormat + , FormatOptions + , defaultFormatOptions + , setWidth -- * Deprecated , decode , decodeFile @@ -100,65 +111,117 @@ 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 with the `Plain` style, except special strings, which are encoded with `SingleQuoted`. +-- +-- @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 + if isSpecialString s + then ( NoTag, SingleQuoted ) + else ( 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 index 77557df..6839ad0 100644 --- a/src/Data/Yaml/Builder.hs +++ b/src/Data/Yaml/Builder.hs @@ -14,8 +14,12 @@ module Data.Yaml.Builder , scientific , number , toByteString + , toByteStringWith , writeYamlFile + , writeYamlFileWith , (.=) + , FormatOptions + , setWidth ) where import Prelude hiding (null) @@ -110,7 +114,17 @@ toSource :: (Monad m, ToYaml a) => a -> ConduitM i Event m () 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 index 9021ec9..81aa66e 100644 --- a/src/Text/Libyaml.hs +++ b/src/Text/Libyaml.hs @@ -21,9 +21,14 @@ module Text.Libyaml , Anchor -- * Encoding and decoding , encode + , encodeWith , decode , encodeFile , decodeFile + , encodeFileWith + , FormatOptions + , defaultFormatOptions + , setWidth -- * Error handling , YamlException (..) , YamlMark (..) @@ -608,9 +613,34 @@ parserParseOne' parser = allocaBytes eventSize $ \er -> do 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 @@ -623,11 +653,20 @@ encode = 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" @@ -638,10 +677,11 @@ encodeFile filePath = 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 @@ -651,7 +691,9 @@ runEmitter allocI closeI = #ifndef __NO_UNICODE__ c_yaml_emitter_set_unicode emitter 1 #endif - c_yaml_emitter_set_width emitter (-1) -- prevent libyaml from wrapping strings at 80 chars + 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