@@ -28,7 +28,9 @@ module Data.Yaml
2828#endif
2929 ( -- * Encoding
3030 encode
31+ , encodeWith
3132 , encodeFile
33+ , encodeFileWith
3234 -- * Decoding
3335 , decodeEither'
3436 , decodeFileEither
@@ -66,6 +68,15 @@ module Data.Yaml
6668 -- * Classes
6769 , ToJSON (..)
6870 , FromJSON (..)
71+ -- * Custom encoding
72+ , isSpecialString
73+ , EncodeOptions
74+ , defaultEncodeOptions
75+ , setStringStyle
76+ , setFormat
77+ , FormatOptions
78+ , defaultFormatOptions
79+ , setWidth
6980 -- * Deprecated
7081 , decode
7182 , decodeFile
@@ -100,65 +111,117 @@ import qualified Data.Text.Lazy as TL
100111import Data.Text.Lazy.Builder (toLazyText)
101112import qualified Data.Vector as V
102113import System.IO.Unsafe (unsafePerformIO)
114+import Data.Text (Text)
103115
104116import Data.Yaml.Internal
105−import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
117+import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile, encodeWith, encodeFileWith)
106118import qualified Text.Libyaml as Y
107119
120+-- |
121+-- @since 0.10.2.0
122+data EncodeOptions = EncodeOptions
123+ { encodeOptionsStringStyle :: Text -> ( Tag, Style )
124+ , encodeOptionsFormat :: FormatOptions
125+ }
126+
127+-- | Set the string style in the encoded YAML. This is a function that decides
128+-- for each string the type of YAML string to output.
129+--
130+-- __WARNING__: You must ensure that special strings (like @"yes"@\/@"no"@\/@"null"@\/@"1234"@) are not encoded with the 'Plain' style, because
131+-- then they will be decoded as boolean, null or numeric values. You can use 'isSpecialString' to detect them.
132+--
133+-- By default, strings are encoded with the `Plain` style, except special strings, which are encoded with `SingleQuoted`.
134+--
135+-- @since 0.10.2.0
136+setStringStyle :: (Text -> ( Tag, Style )) -> EncodeOptions -> EncodeOptions
137+setStringStyle s opts = opts { encodeOptionsStringStyle = s }
138+
139+-- | Set the encoding formatting for the encoded YAML. By default, this is `defaultFormatOptions`.
140+--
141+-- @since 0.10.2.0
142+setFormat :: FormatOptions -> EncodeOptions -> EncodeOptions
143+setFormat f opts = opts { encodeOptionsFormat = f }
144+
145+-- | Determine whether a string must be quoted in YAML and can't appear as plain text.
146+-- Useful if you want to use 'setStringStyle'.
147+--
148+-- @since 0.10.2.0
149+isSpecialString :: Text -> Bool
150+isSpecialString s = s `HashSet.member` specialStrings || isNumeric s
151+
152+-- |
153+-- @since 0.10.2.0
154+defaultEncodeOptions :: EncodeOptions
155+defaultEncodeOptions = EncodeOptions
156+ { encodeOptionsStringStyle = \s ->
157+ -- Empty strings need special handling to ensure they get quoted. This avoids:
158+ -- https://github.com/snoyberg/yaml/issues/24
159+ if isSpecialString s
160+ then ( NoTag, SingleQuoted )
161+ else ( StrTag, PlainNoTag )
162+ , encodeOptionsFormat = defaultFormatOptions
163+ }
164+
108165-- | Encode a value into its YAML representation.
109166encode :: ToJSON a => a -> ByteString
110−encode obj = unsafePerformIO $ runConduitRes
111− $ CL.sourceList (objToEvents $ toJSON obj)
112− .| Y.encode
167+encode = encodeWith defaultEncodeOptions
168+
169+-- | Encode a value into its YAML representation with custom styling.
170+--
171+-- @since 0.10.2.0
172+encodeWith :: ToJSON a => EncodeOptions -> a -> ByteString
173+encodeWith opts obj = unsafePerformIO $ runConduitRes
174+ $ CL.sourceList (objToEvents opts $ toJSON obj)
175+ .| Y.encodeWith (encodeOptionsFormat opts)
113176
114177-- | Encode a value into its YAML representation and save to the given file.
115178encodeFile :: ToJSON a => FilePath -> a -> IO ()
116−encodeFile fp obj = runConduitRes
117− $ CL.sourceList (objToEvents $ toJSON obj)
118− .| Y.encodeFile fp
179+encodeFile = encodeFileWith defaultEncodeOptions
119180
120−objToEvents :: Value -> [Y.Event]
121−objToEvents o = (:) EventStreamStart
181+-- | Encode a value into its YAML representation with custom styling and save to the given file.
182+--
183+-- @since 0.10.2.0
184+encodeFileWith :: ToJSON a => EncodeOptions -> FilePath -> a -> IO ()
185+encodeFileWith opts fp obj = runConduitRes
186+ $ CL.sourceList (objToEvents opts $ toJSON obj)
187+ .| Y.encodeFileWith (encodeOptionsFormat opts) fp
188+
189+objToEvents :: EncodeOptions -> Value -> [Y.Event]
190+objToEvents opts o = (:) EventStreamStart
122191 . (:) EventDocumentStart
123192 $ objToEvents' o
124193 [ EventDocumentEnd
125194 , EventStreamEnd
126195 ]
196+ where
197+ objToEvents' :: Value -> [Y.Event] -> [Y.Event]
198+ --objToEvents' (Scalar s) rest = scalarToEvent s : rest
199+ objToEvents' (Array list) rest =
200+ EventSequenceStart NoTag AnySequence Nothing
201+ : foldr objToEvents' (EventSequenceEnd : rest) (V.toList list)
202+ objToEvents' (Object pairs) rest =
203+ EventMappingStart NoTag AnyMapping Nothing
204+ : foldr pairToEvents (EventMappingEnd : rest) (M.toList pairs)
205+
206+ objToEvents' (String "") rest = EventScalar "" NoTag SingleQuoted Nothing : rest
207+
208+ objToEvents' (String s) rest = EventScalar (encodeUtf8 s) tag style Nothing : rest
209+ where
210+ ( tag, style ) = encodeOptionsStringStyle opts s
211+ objToEvents' Null rest = EventScalar "null" NullTag PlainNoTag Nothing : rest
212+ objToEvents' (Bool True) rest = EventScalar "true" BoolTag PlainNoTag Nothing : rest
213+ objToEvents' (Bool False) rest = EventScalar "false" BoolTag PlainNoTag Nothing : rest
214+ -- Use aeson's implementation which gets rid of annoying decimal points
215+ objToEvents' n@Number{} rest = EventScalar (TE.encodeUtf8 $ TL.toStrict $ toLazyText $ encodeToTextBuilder n) IntTag PlainNoTag Nothing : rest
216+
217+ pairToEvents :: Pair -> [Y.Event] -> [Y.Event]
218+ pairToEvents (k, v) = objToEvents' (String k) . objToEvents' v
127219
128220{- FIXME
129221scalarToEvent :: YamlScalar -> Event
130222scalarToEvent (YamlScalar v t s) = EventScalar v t s Nothing
131223-}
132224
133−objToEvents' :: Value -> [Y.Event] -> [Y.Event]
134−--objToEvents' (Scalar s) rest = scalarToEvent s : rest
135−objToEvents' (Array list) rest =
136− EventSequenceStart NoTag AnySequence Nothing
137− : foldr objToEvents' (EventSequenceEnd : rest) (V.toList list)
138−objToEvents' (Object pairs) rest =
139− EventMappingStart NoTag AnyMapping Nothing
140− : foldr pairToEvents (EventMappingEnd : rest) (M.toList pairs)
141−
142−-- Empty strings need special handling to ensure they get quoted. This avoids:
143−-- https://github.com/snoyberg/yaml/issues/24
144−objToEvents' (String "") rest = EventScalar "" NoTag SingleQuoted Nothing : rest
145−
146−objToEvents' (String s) rest =
147− event : rest
148− where
149− event
150− -- Make sure that special strings are encoded as strings properly.
151− -- See: https://github.com/snoyberg/yaml/issues/31
152− | s `HashSet.member` specialStrings || isNumeric s = EventScalar (encodeUtf8 s) NoTag SingleQuoted Nothing
153− | otherwise = EventScalar (encodeUtf8 s) StrTag PlainNoTag Nothing
154−objToEvents' Null rest = EventScalar "null" NullTag PlainNoTag Nothing : rest
155−objToEvents' (Bool True) rest = EventScalar "true" BoolTag PlainNoTag Nothing : rest
156−objToEvents' (Bool False) rest = EventScalar "false" BoolTag PlainNoTag Nothing : rest
157−-- Use aeson's implementation which gets rid of annoying decimal points
158−objToEvents' n@Number{} rest = EventScalar (TE.encodeUtf8 $ TL.toStrict $ toLazyText $ encodeToTextBuilder n) IntTag PlainNoTag Nothing : rest
159−
160−pairToEvents :: Pair -> [Y.Event] -> [Y.Event]
161−pairToEvents (k, v) = objToEvents' (String k) . objToEvents' v
162225
163226decode :: FromJSON a
164227 => ByteString