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