/
Yaml.hs
291 lines (263 loc) · 9.94 KB
/
Yaml.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
-- | Provides a high-level interface for processing YAML files.
--
-- This module reuses most of the infrastructure from the @aeson@ package.
-- This means that you can use all of the existing tools for JSON
-- processing for processing YAML files. As a result, much of the
-- documentation below mentions JSON; do not let that confuse you, it's
-- intentional.
--
-- For the most part, YAML content translates directly into JSON, and
-- therefore there is very little data loss. If you need to deal with YAML
-- more directly (e.g., directly deal with aliases), you should use the
-- "Text.Libyaml" module instead.
--
-- For documentation on the @aeson@ types, functions, classes, and
-- operators, please see the @Data.Aeson@ module of the @aeson@ package.
--
-- Look in the examples directory of the source repository for some initial
-- pointers on how to use this library.
#if (defined (ghcjs_HOST_OS))
module Data.Yaml {-# WARNING "GHCJS is not supported yet (will break at runtime once called)." #-}
#else
module Data.Yaml
#endif
( -- * Encoding
encode
, encodeWith
, encodeFile
, encodeFileWith
-- * Decoding
, decodeEither'
, decodeFileEither
, decodeFileWithWarnings
, decodeThrow
, decodeFileThrow
-- ** More control over decoding
, decodeHelper
-- * Types
, Value (..)
, Parser
, Object
, Array
, ParseException(..)
, prettyPrintParseException
, YamlException (..)
, YamlMark (..)
-- * Constructors and accessors
, object
, array
, (.=)
, (.:)
, (.:?)
, (.!=)
-- ** With helpers (since 0.8.23)
, withObject
, withText
, withArray
, withScientific
, withBool
-- * Parsing
, parseMonad
, parseEither
, parseMaybe
-- * Classes
, ToJSON (..)
, FromJSON (..)
-- * Custom encoding
, isSpecialString
, EncodeOptions
, defaultEncodeOptions
, setStringStyle
, setFormat
, FormatOptions
, defaultFormatOptions
, setWidth
-- * Deprecated
, decode
, decodeFile
, decodeEither
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative((<$>))
#endif
import Control.Exception
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Trans.Resource (MonadThrow, throwM)
import Data.Aeson
( Value (..), ToJSON (..), FromJSON (..), object
, (.=) , (.:) , (.:?) , (.!=)
, Object, Array
, withObject, withText, withArray, withScientific, withBool
)
#if MIN_VERSION_aeson(1,0,0)
import Data.Aeson.Text (encodeToTextBuilder)
#else
import Data.Aeson.Encode (encodeToTextBuilder)
#endif
import Data.Aeson.Types (Pair, parseMaybe, parseEither, Parser)
import Data.ByteString (ByteString)
import Data.Conduit ((.|), runConduitRes)
import qualified Data.Conduit.List as CL
import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as HashSet
import Data.Text.Encoding (encodeUtf8)
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, 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 = 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 = encodeFileWith defaultEncodeOptions
-- | 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
-}
decode :: FromJSON a
=> ByteString
-> Maybe a
decode bs = unsafePerformIO
$ either (const Nothing) snd
<$> decodeHelper_ (Y.decode bs)
{-# DEPRECATED decode "Please use decodeEither or decodeThrow, which provide information on how the decode failed" #-}
decodeFile :: FromJSON a
=> FilePath
-> IO (Maybe a)
decodeFile fp = (fmap snd <$> decodeHelper (Y.decodeFile fp)) >>= either throwIO (return . either (const Nothing) id)
{-# DEPRECATED decodeFile "Please use decodeFileEither, which does not confused type-directed and runtime exceptions." #-}
-- | A version of 'decodeFile' which should not throw runtime exceptions.
--
-- @since 0.8.4
decodeFileEither
:: FromJSON a
=> FilePath
-> IO (Either ParseException a)
decodeFileEither = fmap (fmap snd) . decodeFileWithWarnings
-- | A version of `decodeFileEither` that returns warnings along with the parse
-- result.
--
-- @since 0.10.0
decodeFileWithWarnings
:: FromJSON a
=> FilePath
-> IO (Either ParseException ([Warning], a))
decodeFileWithWarnings = decodeHelper_ . Y.decodeFile
decodeEither :: FromJSON a => ByteString -> Either String a
decodeEither bs = unsafePerformIO
$ either (Left . prettyPrintParseException) id
<$> (fmap snd <$> decodeHelper (Y.decode bs))
{-# DEPRECATED decodeEither "Please use decodeEither' or decodeThrow, which provide more useful failures" #-}
-- | More helpful version of 'decodeEither' which returns the 'YamlException'.
--
-- @since 0.8.3
decodeEither' :: FromJSON a => ByteString -> Either ParseException a
decodeEither' = either Left (either (Left . AesonException) Right)
. unsafePerformIO
. fmap (fmap snd) . decodeHelper
. Y.decode
-- | A version of 'decodeEither'' lifted to MonadThrow
--
-- @since 0.8.31
decodeThrow :: (MonadThrow m, FromJSON a) => ByteString -> m a
decodeThrow = either throwM return . decodeEither'
-- | A version of 'decodeFileEither' lifted to MonadIO
--
-- @since 0.8.31
decodeFileThrow :: (MonadIO m, FromJSON a) => FilePath -> m a
decodeFileThrow f = liftIO $ decodeFileEither f >>= either throwIO return
-- | Construct a new 'Value' from a list of 'Value's.
array :: [Value] -> Value
array = Array . V.fromList
parseMonad :: Monad m => (a -> Parser b) -> a -> m b
parseMonad p = either fail return . parseEither p