1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE CPP #-}
4-- | NOTE: This module is a highly experimental preview release. It may change
5-- drastically, or be entirely removed, in a future release.
6module Data.Yaml.Builder
7    ( YamlBuilder (..)
8    , ToYaml (..)
9    , mapping
10    , namedMapping
11    , maybeNamedMapping
12    , mappingComplex
13    , namedMappingComplex
14    , maybeNamedMappingComplex
15    , array
16    , namedArray
17    , maybeNamedArray
18    , string
19    , namedString
20    , maybeNamedString
21    , bool
22    , namedBool
23    , maybeNamedBool
24    , null
25    , namedNull
26    , maybeNamedNull
27    , scientific
28    , namedScientific
29    , maybeNamedScientific
30    , alias
31    , number
32    , toByteString
33    , toByteStringWith
34    , writeYamlFile
35    , writeYamlFileWith
36    , (.=)
37    , FormatOptions
38    , setWidth
39    ) where
40
41import Prelude hiding (null)
42
43#if MIN_VERSION_aeson(1,0,0)
44import Data.Aeson.Text (encodeToTextBuilder)
45#else
46import Data.Aeson.Encode (encodeToTextBuilder)
47#endif
48import Data.Aeson.Types (Value(..))
49import Data.ByteString (ByteString)
50import qualified Data.ByteString.Char8 as S8
51import Data.Conduit
52import Data.Scientific (Scientific)
53import Data.Text (Text, unpack)
54import qualified Data.Text as T
55import qualified Data.Text.Encoding as TE
56import qualified Data.Text.Lazy as TL
57import Data.Text.Lazy.Builder (toLazyText)
58import System.IO.Unsafe (unsafePerformIO)
59
60import Data.Yaml.Internal
61import Text.Libyaml
62
63(.=) :: ToYaml a => Text -> a -> (Text, YamlBuilder)
64k .= v = (k, toYaml v)
65
66newtype YamlBuilder = YamlBuilder { unYamlBuilder :: [Event] -> [Event] }
67
68class ToYaml a where
69    toYaml :: a -> YamlBuilder
70instance ToYaml YamlBuilder where
71    toYaml = id
72instance (ToYaml a, ToYaml b) => ToYaml [(a, b)] where
73    toYaml = mappingComplex . map (\(k, v) -> (toYaml k, toYaml v))
74instance ToYaml a => ToYaml [a] where
75    toYaml = array . map toYaml
76instance ToYaml Text where
77    toYaml = string
78instance {-# OVERLAPPING #-} ToYaml String where
79    toYaml = string . T.pack
80instance ToYaml Int where
81    toYaml i = YamlBuilder (EventScalar (S8.pack $ show i) NoTag PlainNoTag Nothing:)
82instance ToYaml Double where
83    toYaml i = YamlBuilder (EventScalar (S8.pack $ show i) NoTag PlainNoTag Nothing:)
84instance ToYaml Scientific where
85    toYaml = scientific
86instance ToYaml Bool where
87    toYaml = bool
88instance ToYaml a => ToYaml (Maybe a) where
89    toYaml = maybe null toYaml
90
91-- |
92-- @since 0.10.3.0
93maybeNamedMapping :: Maybe Text -> [(Text, YamlBuilder)] -> YamlBuilder
94maybeNamedMapping anchor pairs = maybeNamedMappingComplex anchor complexPairs
95  where
96    complexPairs = map (\(k, v) -> (string k, v)) pairs
97
98-- |
99-- @since 0.8.7
100mapping :: [(Text, YamlBuilder)] -> YamlBuilder
101mapping = maybeNamedMapping Nothing
102
103-- |
104-- @since 0.10.3.0
105namedMapping :: Text -> [(Text, YamlBuilder)] -> YamlBuilder
106namedMapping name = maybeNamedMapping $ Just name
107
108-- |
109-- @since 0.11.2.0
110maybeNamedMappingComplex :: Maybe Text -> [(YamlBuilder, YamlBuilder)] -> YamlBuilder
111maybeNamedMappingComplex anchor pairs = YamlBuilder $ \rest ->
112    EventMappingStart NoTag AnyMapping (unpack <$> anchor) : foldr addPair (EventMappingEnd : rest) pairs
113  where
114    addPair (YamlBuilder key, YamlBuilder value) after = key $ value after
115
116-- |
117-- @since 0.11.2.0
118mappingComplex :: [(YamlBuilder, YamlBuilder)] -> YamlBuilder
119mappingComplex = maybeNamedMappingComplex Nothing
120
121-- |
122-- @since 0.11.2.0
123namedMappingComplex :: Text -> [(YamlBuilder, YamlBuilder)] -> YamlBuilder
124namedMappingComplex name = maybeNamedMappingComplex $ Just name
125
126-- |
127-- @since 0.10.3.0
128maybeNamedArray :: Maybe Text -> [YamlBuilder] -> YamlBuilder
129maybeNamedArray anchor bs =
130    YamlBuilder $ (EventSequenceStart NoTag AnySequence (unpack <$> anchor):) . flip (foldr go) bs . (EventSequenceEnd:)
131  where
132    go (YamlBuilder b) = b
133
134-- |
135-- @since 0.8.7
136array :: [YamlBuilder] -> YamlBuilder
137array = maybeNamedArray Nothing
138
139-- |
140-- @since 0.10.3.0
141namedArray :: Text -> [YamlBuilder] -> YamlBuilder
142namedArray name = maybeNamedArray $ Just name
143
144-- |
145-- @since 0.10.3.0
146maybeNamedString :: Maybe Text -> Text -> YamlBuilder
147maybeNamedString anchor s = YamlBuilder (stringScalar defaultStringStyle anchor s :)
148
149-- |
150-- @since 0.8.7
151string :: Text -> YamlBuilder
152string = maybeNamedString Nothing
153
154-- |
155-- @since 0.10.3.0
156namedString :: Text -> Text -> YamlBuilder
157namedString name = maybeNamedString $ Just name
158
159-- Use aeson's implementation which gets rid of annoying decimal points
160-- |
161-- @since 0.10.3.0
162maybeNamedScientific :: Maybe Text -> Scientific -> YamlBuilder
163maybeNamedScientific anchor n = YamlBuilder (EventScalar (TE.encodeUtf8 $ TL.toStrict $ toLazyText $ encodeToTextBuilder (Number n)) NoTag PlainNoTag (unpack <$> anchor) :)
164
165-- |
166-- @since 0.8.13
167scientific :: Scientific -> YamlBuilder
168scientific = maybeNamedScientific Nothing
169
170-- |
171-- @since 0.10.3.0
172namedScientific :: Text -> Scientific -> YamlBuilder
173namedScientific name = maybeNamedScientific $ Just name
174
175-- |
176-- @since 0.8.13
177{-# DEPRECATED number "Use scientific" #-}
178number :: Scientific -> YamlBuilder
179number = scientific
180
181-- |
182-- @since 0.10.3.0
183maybeNamedBool :: Maybe Text -> Bool -> YamlBuilder
184maybeNamedBool anchor True   = YamlBuilder (EventScalar "true" NoTag PlainNoTag (unpack <$> anchor) :)
185maybeNamedBool anchor False  = YamlBuilder (EventScalar "false" NoTag PlainNoTag (unpack <$> anchor) :)
186
187-- |
188-- @since 0.8.13
189bool :: Bool -> YamlBuilder
190bool = maybeNamedBool Nothing
191
192-- |
193-- @since 0.10.3.0
194namedBool :: Text -> Bool -> YamlBuilder
195namedBool name = maybeNamedBool $ Just name
196
197-- |
198-- @since 0.10.3.0
199maybeNamedNull :: Maybe Text -> YamlBuilder
200maybeNamedNull anchor = YamlBuilder (EventScalar "null" NoTag PlainNoTag (unpack <$> anchor) :)
201
202-- |
203-- @since 0.8.13
204null :: YamlBuilder
205null = maybeNamedNull Nothing
206
207-- |
208-- @since 0.10.3.0
209namedNull :: Text -> YamlBuilder
210namedNull name = maybeNamedNull $ Just name
211
212-- |
213-- @since 0.10.3.0
214alias :: Text -> YamlBuilder
215alias anchor = YamlBuilder (EventAlias (unpack anchor) :)
216
217toEvents :: YamlBuilder -> [Event]
218toEvents (YamlBuilder front) =
219    EventStreamStart : EventDocumentStart : front [EventDocumentEnd, EventStreamEnd]
220
221toSource :: (Monad m, ToYaml a) => a -> ConduitM i Event m ()
222toSource = mapM_ yield . toEvents . toYaml
223
224-- |
225-- @since 0.8.7
226toByteString :: ToYaml a => a -> ByteString
227toByteString = toByteStringWith defaultFormatOptions
228
229-- |
230-- @since 0.10.2.0
231toByteStringWith :: ToYaml a => FormatOptions -> a -> ByteString
232toByteStringWith opts yb = unsafePerformIO $ runConduitRes $ toSource yb .| encodeWith opts
233
234writeYamlFile :: ToYaml a => FilePath -> a -> IO ()
235writeYamlFile = writeYamlFileWith defaultFormatOptions
236
237-- |
238-- @since 0.10.2.0
239writeYamlFileWith :: ToYaml a => FormatOptions -> FilePath -> a -> IO ()
240writeYamlFileWith opts fp yb = runConduitRes $ toSource yb .| encodeFileWith opts fp
241