git.iko.soy/typeable/yaml
on master help sign in
swap
5f5462d579 ahead, 0 behind
.github/workflows/tests.ymlnew file+44
since splitsnapshots
unifiedsplit
@@ -0,0 +1,44 @@
1+name: Tests
2+
3+on:
4+ pull_request:
5+ push:
6+ branches:
7+ - master
8+
9+jobs:
10+ build:
11+ name: CI
12+ runs-on: ${{ matrix.os }}
13+ strategy:
14+ fail-fast: false
15+ matrix:
16+ os: [ubuntu-latest, macos-latest, windows-latest]
17+ resolver: [nightly, lts-22, lts-20, lts-17]
18+ exclude:
19+ - os: windows-latest
20+ resolver: lts-15
21+ - os: windows-latest
22+ resolver: nightly
23+
24+ steps:
25+ - name: Clone project
26+ uses: actions/checkout@v3
27+
28+ - name: Cache dependencies
29+ if: ${{ runner.os != 'Windows' }}
30+ # Andreas Abel, 2023-06-10, switching off caching on Windows since ~/.stack is not the correct path here.
31+ uses: actions/cache@v3
32+ with:
33+ path: ~/.stack
34+ #NB: This path is not valid on Windows
35+ key: ${{ runner.os }}-${{ matrix.resolver }}-${{ hashFiles('stack.yaml') }}
36+ restore-keys: |
37+ ${{ runner.os }}-${{ matrix.resolver }}-
38+
39+ - name: Build and run tests
40+ shell: bash
41+ run: |
42+ set -ex
43+ stack upgrade || curl -sSL https://get.haskellstack.org/ | sh -s - -f
44+ stack test --bench --no-run-benchmarks --haddock --no-haddock-deps --no-terminal --resolver=${{ matrix.resolver }}
.gitignore+9
@@ -1,2 +1,11 @@
1dist
1dist
2*.swp
2*.swp
3+cabal-dev/
4+.cabal-sandbox/
5+cabal.sandbox.config
6+.stack-work/
7+*~
8+tarballs/
9+.dir-locals.el
10+*#
11+stack.yaml.lock
.gitmodulesnew file+3
@@ -0,0 +1,3 @@
1+[submodule "vendor/libyaml"]
2+ path = libyaml/vendor/libyaml
3+ url = https://github.com/snoyberg/libyaml
C2HS.hsdeleted−220
@@ -1,220 +0,0 @@
1−-- C->Haskell Compiler: Marshalling library
2−--
3−-- Copyright (c) [1999...2005] Manuel M T Chakravarty
4−--
5−-- Redistribution and use in source and binary forms, with or without
6−-- modification, are permitted provided that the following conditions are met:
7−--
8−-- 1. Redistributions of source code must retain the above copyright notice,
9−-- this list of conditions and the following disclaimer.
10−-- 2. Redistributions in binary form must reproduce the above copyright
11−-- notice, this list of conditions and the following disclaimer in the
12−-- documentation and/or other materials provided with the distribution.
13−-- 3. The name of the author may not be used to endorse or promote products
14−-- derived from this software without specific prior written permission.
15−--
16−-- THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
17−-- IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
18−-- OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN
19−-- NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
20−-- SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
21−-- TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
22−-- PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23−-- LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
24−-- NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
25−-- SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
26−--
27−--- Description ---------------------------------------------------------------
28−--
29−-- Language: Haskell 98
30−--
31−-- This module provides the marshaling routines for Haskell files produced by
32−-- C->Haskell for binding to C library interfaces. It exports all of the
33−-- low-level FFI (language-independent plus the C-specific parts) together
34−-- with the C->HS-specific higher-level marshalling routines.
35−--
36−
37−module C2HS (
38−
39− -- * Re-export the language-independent component of the FFI
40− module Foreign,
41−
42− -- * Re-export the C language component of the FFI
43− module CForeign,
44−
45− -- * Composite marshalling functions
46− withCStringLenIntConv, peekCStringLenIntConv, withIntConv, withFloatConv,
47− peekIntConv, peekFloatConv, withBool, peekBool, withEnum, peekEnum,
48−
49− -- * Conditional results using 'Maybe'
50− nothingIf, nothingIfNull,
51−
52− -- * Bit masks
53− combineBitMasks, containsBitMask, extractBitMasks,
54−
55− -- * Conversion between C and Haskell types
56− cIntConv, cFloatConv, cToBool, cFromBool, cToEnum, cFromEnum
57−) where
58−
59−
60−import Foreign
61− hiding (Word)
62− -- Should also hide the Foreign.Marshal.Pool exports in
63− -- compilers that export them
64−import CForeign
65−
66−import Monad (when, liftM)
67−
68−
69−-- Composite marshalling functions
70−-- -------------------------------
71−
72−-- Strings with explicit length
73−--
74−withCStringLenIntConv s f = withCStringLen s $ \(p, n) -> f (p, cIntConv n)
75−peekCStringLenIntConv (s, n) = peekCStringLen (s, cIntConv n)
76−
77−-- Marshalling of numerals
78−--
79−
80−withIntConv :: (Storable b, Integral a, Integral b)
81− => a -> (Ptr b -> IO c) -> IO c
82−withIntConv = with . cIntConv
83−
84−withFloatConv :: (Storable b, RealFloat a, RealFloat b)
85− => a -> (Ptr b -> IO c) -> IO c
86−withFloatConv = with . cFloatConv
87−
88−peekIntConv :: (Storable a, Integral a, Integral b)
89− => Ptr a -> IO b
90−peekIntConv = liftM cIntConv . peek
91−
92−peekFloatConv :: (Storable a, RealFloat a, RealFloat b)
93− => Ptr a -> IO b
94−peekFloatConv = liftM cFloatConv . peek
95−
96−-- Passing Booleans by reference
97−--
98−
99−withBool :: (Integral a, Storable a) => Bool -> (Ptr a -> IO b) -> IO b
100−withBool = with . fromBool
101−
102−peekBool :: (Integral a, Storable a) => Ptr a -> IO Bool
103−peekBool = liftM toBool . peek
104−
105−
106−-- Passing enums by reference
107−--
108−
109−withEnum :: (Enum a, Integral b, Storable b) => a -> (Ptr b -> IO c) -> IO c
110−withEnum = with . cFromEnum
111−
112−peekEnum :: (Enum a, Integral b, Storable b) => Ptr b -> IO a
113−peekEnum = liftM cToEnum . peek
114−
115−
116−-- Storing of 'Maybe' values
117−-- -------------------------
118−
119−instance Storable a => Storable (Maybe a) where
120− sizeOf _ = sizeOf (undefined :: Ptr ())
121− alignment _ = alignment (undefined :: Ptr ())
122−
123− peek p = do
124− ptr <- peek (castPtr p)
125− if ptr == nullPtr
126− then return Nothing
127− else liftM Just $ peek ptr
128−
129− poke p v = do
130− ptr <- case v of
131− Nothing -> return nullPtr
132− Just v' -> new v'
133− poke (castPtr p) ptr
134−
135−
136−-- Conditional results using 'Maybe'
137−-- ---------------------------------
138−
139−-- Wrap the result into a 'Maybe' type.
140−--
141−-- * the predicate determines when the result is considered to be non-existing,
142−-- ie, it is represented by `Nothing'
143−--
144−-- * the second argument allows to map a result wrapped into `Just' to some
145−-- other domain
146−--
147−nothingIf :: (a -> Bool) -> (a -> b) -> a -> Maybe b
148−nothingIf p f x = if p x then Nothing else Just $ f x
149−
150−-- |Instance for special casing null pointers.
151−--
152−nothingIfNull :: (Ptr a -> b) -> Ptr a -> Maybe b
153−nothingIfNull = nothingIf (== nullPtr)
154−
155−
156−-- Support for bit masks
157−-- ---------------------
158−
159−-- Given a list of enumeration values that represent bit masks, combine these
160−-- masks using bitwise disjunction.
161−--
162−combineBitMasks :: (Enum a, Bits b) => [a] -> b
163−combineBitMasks = foldl (.|.) 0 . map (fromIntegral . fromEnum)
164−
165−-- Tests whether the given bit mask is contained in the given bit pattern
166−-- (i.e., all bits set in the mask are also set in the pattern).
167−--
168−containsBitMask :: (Bits a, Enum b) => a -> b -> Bool
169−bits `containsBitMask` bm = let bm' = fromIntegral . fromEnum $ bm
170− in
171− bm' .&. bits == bm'
172−
173−-- |Given a bit pattern, yield all bit masks that it contains.
174−--
175−-- * This does *not* attempt to compute a minimal set of bit masks that when
176−-- combined yield the bit pattern, instead all contained bit masks are
177−-- produced.
178−--
179−extractBitMasks :: (Bits a, Enum b, Bounded b) => a -> [b]
180−extractBitMasks bits =
181− [bm | bm <- [minBound..maxBound], bits `containsBitMask` bm]
182−
183−
184−-- Conversion routines
185−-- -------------------
186−
187−-- |Integral conversion
188−--
189−cIntConv :: (Integral a, Integral b) => a -> b
190−cIntConv = fromIntegral
191−
192−-- |Floating conversion
193−--
194−cFloatConv :: (RealFloat a, RealFloat b) => a -> b
195−cFloatConv = realToFrac
196−-- As this conversion by default goes via `Rational', it can be very slow...
197−{-# RULES
198− "cFloatConv/Float->Float" forall (x::Float). cFloatConv x = x;
199− "cFloatConv/Double->Double" forall (x::Double). cFloatConv x = x
200− #-}
201−
202−-- |Obtain C value from Haskell 'Bool'.
203−--
204−cFromBool :: Num a => Bool -> a
205−cFromBool = fromBool
206−
207−-- |Obtain Haskell 'Bool' from C value.
208−--
209−cToBool :: Num a => a -> Bool
210−cToBool = toBool
211−
212−-- |Convert a C enumeration to Haskell.
213−--
214−cToEnum :: (Integral i, Enum e) => i -> e
215−cToEnum = toEnum . cIntConv
216−
217−-- |Convert a Haskell enumeration to C.
218−--
219−cFromEnum :: (Enum e, Integral i) => e -> i
220−cFromEnum = cIntConv . fromEnum
READMEdeleted−1
@@ -1 +0,0 @@
1−Support for serialising Haskell to and from Yaml.
README.mdnew file+23
@@ -0,0 +1,23 @@
1+# YAML Haskell Library
2+
3+[![Build Status](https://dev.azure.com/snoyberg/yaml/_apis/build/status/snoyberg.yaml?branchName=master)](https://dev.azure.com/snoyberg/yaml/_build/latest?definitionId=7&branchName=master)
4+
5+This project contains two haskell packages: `yaml` for higher-level parsing and writing of yaml documents, and `libyaml`
6+for lower-level event-based streaming.
7+
8+## `yaml` Package
9+
10+`yaml` provides a high-level interface based around the JSON datatypes provided by the `aeson` package. This allows
11+using JSON and YAML interchangeably in your code with the `aeson` typeclasses. See the
12+[yaml README](https://github.com/snoyberg/yaml/tree/master/yaml/README.md) for more details.
13+
14+## `libyaml` Package
15+
16+`libyaml` is a wrapper over the libyaml C library (and includes the source so no external library is needed). It is an
17+event-based streaming API. See the [libyaml README](https://github.com/snoyberg/yaml/tree/master/libyaml/README.md) for
18+more details.
19+
20+## License
21+
22+This project is licensed with the BSD 3-Clause license. Copies of the license can be found in both the `yaml` and
23+`libyaml` subdirectories
Text/Libyaml.chsdeleted−293
@@ -1,293 +0,0 @@
1−{-# LANGUAGE ForeignFunctionInterface #-}
2−module Text.Libyaml where
3−
4−#include <yaml.h>
5−#include "../../../c/helper.h"
6−
7−import C2HS
8−import qualified Data.ByteString.Internal as B
9−import Control.Monad
10−
11−{#context lib="yaml" #}
12−
13−{#pointer *yaml_parser_t as Parser newtype#}
14−parserSize :: Int
15−parserSize = {#sizeof yaml_parser_t#}
16−
17−{#pointer *yaml_event_t as EventRaw newtype#}
18−eventSize :: Int
19−eventSize = {#sizeof yaml_event_t#}
20−
21−{#fun unsafe yaml_parser_initialize
22− { id `Parser'
23− } -> `Int' #}
24−
25−{#fun unsafe yaml_parser_delete
26− { id `Parser'
27− } -> `()' #}
28−
29−withParser :: (Parser -> IO a) -> IO a
30−withParser f = do
31− allocaBytes parserSize $ \p -> do
32− let p' = Parser p
33− res <- yaml_parser_initialize p'
34− -- FIXME check res
35− ret <- f p'
36− yaml_parser_delete p'
37− return ret
38−
39−withEventRaw :: (EventRaw -> IO a) -> IO a
40−withEventRaw f = allocaBytes eventSize $ f . EventRaw
41−
42−{#fun unsafe yaml_parser_set_input_string
43− { id `Parser'
44− , id `Ptr CUChar'
45− , `Int'
46− } -> `()' #}
47−
48−parserSetInputString :: Parser -> B.ByteString -> IO ()
49−parserSetInputString parser bs = do
50− let (fptr, offset, len) = B.toForeignPtr bs
51− let fptr' = castForeignPtr fptr
52− withForeignPtr fptr' $ \ptr -> do
53− let ptr' = ptr `plusPtr` offset
54− yaml_parser_set_input_string parser ptr' len
55−
56−{#fun unsafe yaml_parser_parse
57− { id `Parser'
58− , id `EventRaw'
59− } -> `Int' #}
60−
61−{#fun unsafe yaml_event_delete
62− { id `EventRaw'
63− } -> `()' #}
64−
65−parserParse :: Parser -> IO [Event]
66−parserParse parser = do
67− event <- parserParseOne parser
68− case event of
69− EventStreamEnd -> return [event]
70− _ -> do
71− rest <- parserParse parser
72− return $! event : rest
73−
74−parserParseOne :: Parser -> IO Event
75−parserParseOne parser = withEventRaw $ \er -> do
76− res <- yaml_parser_parse parser er
77− when (res == 0) $ fail $ "parserParse: " ++ show res
78− event <- getEvent er
79− yaml_event_delete er
80− return event
81−
82−data Event =
83− EventNone
84− | EventStreamStart
85− | EventStreamEnd
86− | EventDocumentStart
87− | EventDocumentEnd
88− | EventAlias
89− | EventScalar B.ByteString
90− | EventSequenceStart
91− | EventSequenceEnd
92− | EventMappingStart
93− | EventMappingEnd
94− deriving (Show)
95−
96−{#enum yaml_event_type_e as EventType {underscoreToCase} deriving (Show) #}
97−getEvent :: EventRaw -> IO Event
98−getEvent (EventRaw ptr) = do
99− et <- {#get yaml_event_t.type#} ptr
100− case toEnum $ fromEnum et of
101− YamlNoEvent -> return EventNone
102− YamlStreamStartEvent -> return EventStreamStart
103− YamlStreamEndEvent -> return EventStreamEnd
104− YamlDocumentStartEvent -> return EventDocumentStart
105− YamlDocumentEndEvent -> return EventDocumentEnd
106− YamlAliasEvent -> return EventAlias
107− YamlScalarEvent -> do
108− yvalue <- {#get yaml_event_t.data.scalar.value#} ptr
109− ylen <- {#get yaml_event_t.data.scalar.length#} ptr
110− let yvalue' = castPtr yvalue
111− let ylen' = fromEnum ylen
112− let ylen'' = toEnum $ fromEnum ylen
113− bs <- B.create ylen' $ \dest -> B.memcpy dest yvalue' ylen''
114− return $ EventScalar bs
115− YamlSequenceStartEvent -> return EventSequenceStart
116− YamlSequenceEndEvent -> return EventSequenceEnd
117− YamlMappingStartEvent -> return EventMappingStart
118− YamlMappingEndEvent -> return EventMappingEnd
119−
120−-- Emitter
121−{#pointer *yaml_emitter_t as Emitter newtype#}
122−emitterSize :: Int
123−emitterSize = {#sizeof yaml_emitter_t#}
124−
125−{#fun unsafe yaml_emitter_initialize
126− { id `Emitter'
127− } -> `Int' #}
128−
129−{#fun unsafe yaml_emitter_delete
130− { id `Emitter'
131− } -> `()' #}
132−
133−{#pointer *buffer_t as Buffer newtype#}
134−bufferSize :: Int
135−bufferSize = {#sizeof buffer_t#}
136−
137−{#fun unsafe buffer_init
138− { id `Buffer'
139− } -> `()' #}
140−
141−withBuffer :: (Buffer -> IO ()) -> IO B.ByteString
142−withBuffer f = do
143− allocaBytes bufferSize $ \b -> do
144− let b' = Buffer b
145− buffer_init b'
146− f b'
147− ptr <- {#get buffer_t.buff#} b
148− len <- {#get buffer_t.used#} b
149− fptr <- newForeignPtr_ $ castPtr ptr
150− return $! B.fromForeignPtr fptr 0 $ fromIntegral len
151−
152−{#fun unsafe yaml_emitter_set_output
153− { id `Emitter'
154− , id `FunPtr (Ptr () -> Ptr CUChar -> CULong -> IO CInt)'
155− , id `Ptr ()'
156− } -> `()' #}
157−
158−foreign import ccall "buffer.h &buffer_append"
159− buffer_append :: FunPtr (Ptr () -> Ptr CUChar -> CULong -> IO CInt)
160−
161−withEmitter :: (Emitter -> IO ()) -> IO B.ByteString
162−withEmitter f = do
163− allocaBytes emitterSize $ \e -> do
164− let e' = Emitter e
165− res <- yaml_emitter_initialize e'
166− -- FIXME check res
167− bs <- withBuffer $ \(Buffer b) -> do
168− let fun = buffer_append
169− yaml_emitter_set_output e' buffer_append $ castPtr b
170− f e'
171− yaml_emitter_delete e'
172− return bs
173−
174−{#fun unsafe yaml_emitter_emit
175− { id `Emitter'
176− , id `EventRaw'
177− } -> `Int' #}
178−
179−{#fun unsafe print_emitter_error
180− { id `Emitter'
181− } -> `()' #}
182−
183−emitEvents :: Emitter -> [Event] -> IO ()
184−emitEvents emitter [] = return ()
185−emitEvents emitter (e:rest) = do
186− res <- toEventRaw e $ yaml_emitter_emit emitter
187− when (res == 0) $
188− print_emitter_error emitter >> fail "yaml_emitter_emit failed"
189− emitEvents emitter rest
190−
191−{#enum yaml_encoding_e as YamlEncoding {underscoreToCase} deriving (Show) #}
192−{#enum yaml_scalar_style_e as ScalarStyle {underscoreToCase}
193− deriving (Show) #}
194−
195−enumToIntegral :: (Enum e, Integral i) => e -> i
196−enumToIntegral = fromIntegral . fromEnum
197−
198−{#fun unsafe yaml_stream_start_event_initialize
199− { id `EventRaw'
200− , enumToIntegral `YamlEncoding'
201− } -> `Int' #}
202−
203−{#fun unsafe yaml_stream_end_event_initialize
204− { id `EventRaw'
205− } -> `Int' #}
206−
207−{#fun unsafe yaml_scalar_event_initialize
208− { id `EventRaw'
209− , id `Ptr CUChar' -- anchor
210− , id `Ptr CUChar' -- tag
211− , id `Ptr CUChar' -- value
212− , `Int'
213− , `Int'
214− , `Int'
215− , enumToIntegral `ScalarStyle'
216− } -> `Int' #}
217−
218−{#fun unsafe simple_document_start
219− { id `EventRaw'
220− } -> `Int' #}
221−
222−{#fun unsafe yaml_document_end_event_initialize
223− { id `EventRaw'
224− , `Int'
225− } -> `Int' #}
226−
227−{#fun unsafe yaml_sequence_start_event_initialize
228− { id `EventRaw'
229− , id `Ptr CUChar'
230− , id `Ptr CUChar'
231− , `Int'
232− , `Int'
233− } -> `Int' #}
234−
235−{#fun unsafe yaml_sequence_end_event_initialize
236− { id `EventRaw'
237− } -> `Int' #}
238−
239−{#fun unsafe yaml_mapping_start_event_initialize
240− { id `EventRaw'
241− , id `Ptr CUChar'
242− , id `Ptr CUChar'
243− , `Int'
244− , `Int'
245− } -> `Int' #}
246−
247−{#fun unsafe yaml_mapping_end_event_initialize
248− { id `EventRaw'
249− } -> `Int' #}
250−
251−toEventRaw :: Event -> (EventRaw -> IO a) -> IO a
252−toEventRaw e f = withEventRaw $ \er -> do
253− case e of
254− EventStreamStart ->
255− yaml_stream_start_event_initialize er YamlUtf8Encoding
256− EventStreamEnd ->
257− yaml_stream_end_event_initialize er
258− EventDocumentStart ->
259− simple_document_start er
260− EventDocumentEnd ->
261− yaml_document_end_event_initialize er 1
262− EventScalar bs -> do
263− let (fvalue, offset, len) = B.toForeignPtr bs
264− withForeignPtr fvalue $ \value -> do
265− let value' = value `plusPtr` offset
266− yaml_scalar_event_initialize
267− er
268− nullPtr
269− nullPtr
270− value'
271− len
272− 0
273− 1
274− YamlAnyScalarStyle
275− EventSequenceStart ->
276− yaml_sequence_start_event_initialize
277− er
278− nullPtr
279− nullPtr
280− 1
281− 0 -- YAML_ANY_SEQUENCE_STYLE
282− EventSequenceEnd ->
283− yaml_sequence_end_event_initialize er
284− EventMappingStart ->
285− yaml_mapping_start_event_initialize
286− er
287− nullPtr
288− nullPtr
289− 1
290− 0 -- YAML_ANY_SEQUENCE_STYLE
291− EventMappingEnd ->
292− yaml_mapping_end_event_initialize er
293− f er
Text/Yaml.hsdeleted−89
@@ -1,89 +0,0 @@
1−---------------------------------------------------------
2−--
3−-- Module : Text.Yaml
4−-- Copyright : Michael Snoyman
5−-- License : BSD3
6−--
7−-- Maintainer : Michael Snoyman <michael@snoyman.com>
8−-- Stability : Stable
9−-- Portability : portable
10−--
11−-- Provides a user friendly interface for serializing Yaml data.
12−--
13−---------------------------------------------------------
14−
15−module Text.Yaml
16− ( module Data.Object
17− , encode
18− , encodeFile
19− , decode
20− , decodeFile
21− ) where
22−
23−import Text.Libyaml
24−import qualified Data.ByteString as B
25−import Data.ByteString.Class
26−import Data.Object
27−import System.IO.Unsafe
28−
29−encodeFile :: IsObject o => FilePath -> o -> IO ()
30−encodeFile path o = B.writeFile path $ encode o
31−
32−decodeFile :: (Monad m, IsObject o) => FilePath -> IO (m o)
33−decodeFile path = decode `fmap` B.readFile path
34−
35−encode :: (StrictByteString bs, IsObject o) => o -> bs
36−encode o =
37− let events = objectToEvents $ toObject o
38− result = withEmitter $ flip emitEvents $ events
39− in fromStrictByteString $ unsafePerformIO result
40−
41−decode :: (Monad m, StrictByteString bs, IsObject o) => bs -> m o
42−decode bs = do
43− let eventsIO = withParser $ \p -> do
44− parserSetInputString p $ toStrictByteString bs
45− parserParse p
46− events = unsafePerformIO eventsIO
47− fromObject $ eventsToObject events
48−
49−objectToEvents :: Object -> [Event]
50−objectToEvents y = concat
51− [ [EventStreamStart, EventDocumentStart]
52− , writeSingle y
53− , [EventDocumentEnd, EventStreamEnd]] where
54− writeSingle :: Object -> [Event]
55− writeSingle (Scalar bs) = [EventScalar bs]
56− writeSingle (Sequence ys) =
57− (EventSequenceStart : concatMap writeSingle ys)
58− ++ [EventSequenceEnd]
59− writeSingle (Mapping pairs) =
60− EventMappingStart : concatMap writePair pairs ++ [EventMappingEnd]
61− writePair :: (B.ByteString, Object) -> [Event]
62− writePair (k, v) = EventScalar k : writeSingle v
63−
64−eventsToObject :: [Event] -> Object
65−eventsToObject = fst . readSingle . dropWhile isIgnored where
66− isIgnored EventAlias = False
67− isIgnored (EventScalar _) = False
68− isIgnored EventSequenceStart = False
69− isIgnored EventSequenceEnd = False
70− isIgnored EventMappingStart = False
71− isIgnored EventMappingEnd = False
72− isIgnored _ = True
73− readSingle :: [Event] -> (Object, [Event])
74− readSingle [] = error "readSingle: no more events"
75− readSingle (EventScalar bs:rest) = (Scalar bs, rest)
76− readSingle (EventSequenceStart:rest) = readList [] rest
77− readSingle (EventMappingStart:rest) = readMap [] rest
78− readSingle (x:rest) = error $ "readSingle: " ++ show x
79− readList :: [Object] -> [Event] -> (Object, [Event])
80− readList nodes (EventSequenceEnd:rest) =
81− (Sequence $ reverse nodes, rest)
82− readList nodes events =
83− let (next, rest) = readSingle events
84− in readList (next : nodes) rest
85− readMap :: [(B.ByteString, Object)] -> [Event] -> (Object, [Event])
86− readMap pairs (EventMappingEnd:rest) = (Mapping $ reverse pairs, rest)
87− readMap pairs (EventScalar bs:events) =
88− let (next, rest) = readSingle events
89− in readMap ((fromStrictByteString bs, next) : pairs) rest
c/helper.cdeleted−47
@@ -1,47 +0,0 @@
1−#include <stdlib.h>
2−#include <string.h>
3−#include <stdio.h>
4−#include "helper.h"
5−
6−void buffer_init(buffer_t *buffer)
7−{
8− buffer->buff = 0;
9− buffer->size = buffer->used = 0;
10−}
11−
12−int buffer_append(void *ext, unsigned char *str, size_t size)
13−{
14− buffer_t *b = ext;
15− int new_size, new_used;
16− char *tmp;
17−
18− new_used = b->used + size;
19− for (new_size = b->size || 8; new_size < new_used; new_size *= 2);
20−
21− if (new_size != b->size) {
22− tmp = realloc(b->buff, new_size);
23− if (!tmp) return 0;
24− b->buff = tmp;
25− b->size = new_size;
26− }
27−
28− memcpy(b->buff + b->used, str, size);
29− b->used = new_used;
30−
31− return 1;
32−}
33−
34−void print_emitter_error(yaml_emitter_t *e)
35−{
36− fprintf(stderr, "%s\n", e->problem);
37−}
38−
39−int simple_document_start(yaml_event_t *e)
40−{
41− return yaml_document_start_event_initialize
42− (e,
43− 0,
44− 0,
45− 0,
46− 1);
47−}
c/helper.hdeleted−16
@@ -1,16 +0,0 @@
1−#ifndef __HELPER_H__
2−#define __HELPER_H__
3−
4−#include <yaml.h>
5−
6−typedef struct buffer_s {
7− char *buff;
8− unsigned int size, used;
9−} buffer_t;
10−void buffer_init(buffer_t *buffer);
11−int buffer_append(void *ext, unsigned char *str, size_t size);
12−
13−void print_emitter_error(yaml_emitter_t *e);
14−int simple_document_start(yaml_event_t *e);
15−
16−#endif /* __HELPER_H__ */
libyaml/ChangeLog.mdnew file+27
@@ -0,0 +1,27 @@
1+# Changelog for libyaml
2+
3+## 0.1.4
4+
5+* Use libyaml-clib for the cbits
6+* Use pkg-config to link to system yaml
7+
8+## 0.1.3
9+
10+* Correct signature for `fclose`
11+
12+## 0.1.2
13+
14+* Upgrade `libyaml` to 0.2.2
15+
16+## 0.1.1.1
17+
18+* Work around GHC 8.6.5 issue on Windows preventing truncated files. [#178](https://github.com/snoyberg/yaml/issues/178)
19+
20+## 0.1.1.0
21+
22+* Add options to `FormatOptions` to govern when tags rendered explicitly and when they are left implicit. [#165](https://github.com/snoyberg/yaml/issues/165)
23+
24+## 0.1.0.0
25+
26+* Split `libyaml` into a separate package from `yaml`. This split occurred at
27+ `yaml` version 0.10.4.0.
LICENSE → libyaml/LICENSErenamed

The content is the same.

libyaml/Makefilenew file+4
@@ -0,0 +1,4 @@
1+libhelper.so : helper.o
2+ gcc -shared -Wl,-soname,libhelper.so -o libhelper.so helper.o
3+helper.o : c/helper.c
4+ gcc -c -fPIC c/helper.c -o helper.o
libyaml/README.mdnew file+3
@@ -0,0 +1,3 @@
1+# libyaml
2+
3+This package provides a haskell wrapper over the [libyaml C library version 0.2.2 by Kirill Simonov](https://github.com/yaml/libyaml). It contains the C source so you don't need to worry about any non-Haskell dependencies.
libyaml/Setup.hsnew file+2
@@ -0,0 +1,2 @@
1+import Distribution.Simple
2+main = defaultMain
libyaml/c/helper.cnew file+187
@@ -0,0 +1,187 @@
1+#include <stdlib.h>
2+#include <string.h>
3+#include <stdio.h>
4+#include "helper.h"
5+
6+void buffer_init(buffer_t *buffer)
7+{
8+ buffer->buff = 0;
9+ buffer->size = buffer->used = 0;
10+}
11+
12+int buffer_append(void *ext, unsigned char *str, size_t size)
13+{
14+ buffer_t *b = ext;
15+ int new_size, new_used;
16+ unsigned char *tmp;
17+
18+ new_used = b->used + size;
19+ for (new_size = b->size ? b->size : 8; new_size < new_used; new_size *= 2);
20+
21+ if (new_size != b->size) {
22+ tmp = realloc(b->buff, new_size);
23+ if (!tmp) return 0;
24+ b->buff = tmp;
25+ b->size = new_size;
26+ }
27+
28+ memcpy(b->buff + b->used, str, size);
29+ b->used = new_used;
30+
31+ return 1;
32+}
33+
34+unsigned char * get_buffer_buff(buffer_t *b)
35+{
36+ return b->buff;
37+}
38+
39+unsigned int get_buffer_used(buffer_t *b)
40+{
41+ return b->used;
42+}
43+
44+void my_emitter_set_output(yaml_emitter_t *e, buffer_t *b)
45+{
46+ yaml_emitter_set_output(e, buffer_append, b);
47+}
48+
49+char const * get_parser_error_problem(yaml_parser_t *p)
50+{
51+ return p->problem;
52+}
53+
54+char const * get_parser_error_context(yaml_parser_t *p)
55+{
56+ return p->context;
57+}
58+
59+const yaml_mark_t * get_parser_error_mark(yaml_parser_t *p)
60+{
61+ return &p->problem_mark;
62+}
63+
64+char const * get_emitter_error(yaml_emitter_t *e)
65+{
66+ return e->problem;
67+}
68+
69+int simple_document_start(yaml_event_t *e)
70+{
71+ return yaml_document_start_event_initialize
72+ (e,
73+ 0,
74+ 0,
75+ 0,
76+ 1);
77+}
78+
79+int get_event_type(yaml_event_t *e)
80+{
81+ return e->type;
82+}
83+
84+unsigned char * get_scalar_value(yaml_event_t *e)
85+{
86+ return e->data.scalar.value;
87+}
88+
89+unsigned long get_scalar_length(yaml_event_t *e)
90+{
91+ return e->data.scalar.length;
92+}
93+
94+unsigned char * get_scalar_tag(yaml_event_t *e)
95+{
96+ unsigned char *s = e->data.scalar.tag;
97+ if (!s) s = (unsigned char *) "";
98+ return s;
99+}
100+
101+int get_scalar_style(yaml_event_t *e)
102+{
103+ return e->data.scalar.style;
104+}
105+
106+unsigned char * get_scalar_anchor(yaml_event_t *e)
107+{
108+ return e->data.scalar.anchor;
109+}
110+
111+unsigned char * get_sequence_start_anchor(yaml_event_t *e)
112+{
113+ return e->data.sequence_start.anchor;
114+}
115+
116+int get_sequence_start_style(yaml_event_t *e)
117+{
118+ return e->data.sequence_start.style;
119+}
120+
121+unsigned char * get_sequence_start_tag(yaml_event_t *e)
122+{
123+ unsigned char *s = e->data.sequence_start.tag;
124+ if (!s) s = (unsigned char *) "";
125+ return s;
126+}
127+
128+unsigned char * get_mapping_start_anchor(yaml_event_t *e)
129+{
130+ return e->data.mapping_start.anchor;
131+}
132+
133+int get_mapping_start_style(yaml_event_t *e)
134+{
135+ return e->data.mapping_start.style;
136+}
137+
138+unsigned char * get_mapping_start_tag(yaml_event_t *e)
139+{
140+ unsigned char *s = e->data.mapping_start.tag;
141+ if (!s) s = (unsigned char *) "";
142+ return s;
143+}
144+
145+unsigned char * get_alias_anchor(yaml_event_t *e)
146+{
147+ return e->data.alias.anchor;
148+}
149+
150+const yaml_mark_t * get_start_mark(yaml_event_t *e)
151+{
152+ return &e->start_mark;
153+}
154+
155+const yaml_mark_t * get_end_mark(yaml_event_t *e)
156+{
157+ return &e->end_mark;
158+}
159+
160+unsigned int get_mark_index(yaml_mark_t *m)
161+{
162+ return m->index;
163+}
164+
165+unsigned int get_mark_line(yaml_mark_t *m)
166+{
167+ return m->line;
168+}
169+
170+unsigned int get_mark_column(yaml_mark_t *m)
171+{
172+ return m->column;
173+}
174+
175+int yaml_parser_set_input_filename(yaml_parser_t *parser, const char *filename)
176+{
177+ FILE *in = fopen(filename, "r");
178+ if (!in) return 0;
179+ yaml_parser_set_input_file(parser, in);
180+ return 1;
181+}
182+
183+int fclose_helper(FILE *file)
184+{
185+ if (! file) return 0;
186+ return fclose(file);
187+}
libyaml/include/helper.hnew file+43
@@ -0,0 +1,43 @@
1+#ifndef __HELPER_H__
2+#define __HELPER_H__
3+
4+#include <yaml.h>
5+
6+typedef struct buffer_s {
7+ unsigned char *buff;
8+ unsigned int size, used;
9+} buffer_t;
10+void buffer_init(buffer_t *buffer);
11+int buffer_append(void *ext, unsigned char *str, size_t size);
12+unsigned char * get_buffer_buff(buffer_t *b);
13+unsigned int get_buffer_used(buffer_t *b);
14+
15+void my_emitter_set_output(yaml_emitter_t *e, buffer_t *b);
16+
17+char const * get_parser_error_problem(yaml_parser_t *p);
18+char const * get_parser_error_context(yaml_parser_t *p);
19+unsigned int get_parser_error_offset(yaml_parser_t *p);
20+
21+char const * get_emitter_error(yaml_emitter_t *e);
22+
23+int simple_document_start(yaml_event_t *e);
24+
25+int get_event_type(yaml_event_t *e);
26+
27+unsigned char * get_scalar_value(yaml_event_t *e);
28+unsigned long get_scalar_length(yaml_event_t *e);
29+
30+unsigned char * get_scalar_tag(yaml_event_t *e);
31+unsigned char * get_sequence_start_tag(yaml_event_t *e);
32+unsigned char * get_mapping_start_tag(yaml_event_t *e);
33+
34+int get_scalar_style(yaml_event_t *e);
35+int get_sequence_start_style(yaml_event_t *e);
36+int get_mapping_start_style(yaml_event_t *e);
37+
38+unsigned char * get_scalar_anchor(yaml_event_t *e);
39+unsigned char * get_sequence_start_anchor(yaml_event_t *e);
40+unsigned char * get_mapping_start_anchor(yaml_event_t *e);
41+unsigned char * get_alias_anchor(yaml_event_t *e);
42+
43+#endif /* __HELPER_H__ */
libyaml/libyaml.cabalnew file+68
@@ -0,0 +1,68 @@
1+cabal-version: 1.12
2+
3+-- This file has been generated from package.yaml by hpack version 0.36.0.
4+--
5+-- see: https://github.com/sol/hpack
6+
7+name: libyaml
8+version: 0.1.4
9+synopsis: Low-level, streaming YAML interface.
10+description: README and API documentation are available at <https://www.stackage.org/package/libyaml>
11+category: Text
12+stability: stable
13+homepage: https://github.com/snoyberg/yaml#readme
14+bug-reports: https://github.com/snoyberg/yaml/issues
15+author: Michael Snoyman <michael@snoyman.com>, Anton Ageev <antage@gmail.com>,Kirill Simonov
16+maintainer: Michael Snoyman <michael@snoyman.com>
17+license: BSD3
18+license-file: LICENSE
19+build-type: Simple
20+extra-source-files:
21+ include/helper.h
22+ README.md
23+ ChangeLog.md
24+
25+source-repository head
26+ type: git
27+ location: https://github.com/snoyberg/yaml
28+
29+flag no-unicode
30+ description: Don't enable unicode output. Instead, unicode characters will be escaped.
31+ manual: False
32+ default: False
33+
34+flag system-libyaml
35+ description: Use the system-wide libyaml instead of the bundled copy
36+ manual: False
37+ default: False
38+
39+library
40+ exposed-modules:
41+ Text.Libyaml
42+ other-modules:
43+ Paths_libyaml
44+ hs-source-dirs:
45+ src
46+ ghc-options: -Wall
47+ include-dirs:
48+ include
49+ c-sources:
50+ c/helper.c
51+ build-depends:
52+ base >=4.9.1 && <5
53+ , bytestring >=0.9.1.4
54+ , conduit >=1.2.8 && <1.4
55+ , resourcet >=0.3 && <1.4
56+ default-language: Haskell2010
57+ if flag(no-unicode)
58+ cpp-options: -D__NO_UNICODE__
59+ if !(flag(system-libyaml))
60+ build-depends:
61+ libyaml-clib
62+ else
63+ pkgconfig-depends:
64+ yaml-0.1
65+ if os(windows)
66+ cpp-options: -DWINDOWS
67+ build-depends:
68+ directory
libyaml/package.yamlnew file+53
@@ -0,0 +1,53 @@
1+name: libyaml
2+version: 0.1.4
3+synopsis: Low-level, streaming YAML interface.
4+description: README and API documentation are available at <https://www.stackage.org/package/libyaml>
5+category: Text
6+author: Michael Snoyman <michael@snoyman.com>, Anton Ageev <antage@gmail.com>,Kirill Simonov
7+maintainer: Michael Snoyman <michael@snoyman.com>
8+license: BSD3
9+github: snoyberg/yaml
10+stability: stable
11+
12+extra-source-files:
13+- include/helper.h
14+- README.md
15+- ChangeLog.md
16+
17+flags:
18+ system-libyaml:
19+ description: Use the system-wide libyaml instead of the bundled copy
20+ manual: false
21+ default: false
22+ no-unicode:
23+ description: Don't enable unicode output. Instead, unicode characters will be escaped.
24+ manual: false
25+ default: false
26+
27+dependencies:
28+- base >=4.14 && <5 # GHC 8.10.1 and later
29+- bytestring >=0.9.1.4
30+- conduit >=1.2.8 && <1.4
31+- resourcet >=0.3 && <1.4
32+
33+library:
34+ c-sources: c/helper.c
35+ ghc-options: -Wall
36+ include-dirs:
37+ - include
38+ source-dirs: src
39+ when:
40+ - condition: flag(no-unicode)
41+ cpp-options: -D__NO_UNICODE__
42+ - condition: ! '!(flag(system-libyaml))'
43+ then:
44+ dependencies:
45+ - libyaml-clib
46+ else:
47+ pkg-config-dependencies:
48+ - yaml-0.1
49+ - condition: os(windows)
50+ cpp-options: -DWINDOWS
51+ dependencies:
52+ - directory
53+
libyaml/src/Text/Libyaml.hsnew file+856
@@ -0,0 +1,856 @@
1+{-# LANGUAGE EmptyDataDecls #-}
2+{-# LANGUAGE ForeignFunctionInterface #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE FlexibleContexts #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RankNTypes #-}
8+{-# LANGUAGE CPP #-}
9+{-# LANGUAGE TypeFamilies #-}
10+{-# LANGUAGE ScopedTypeVariables #-}
11+
12+-- | Low-level, streaming YAML interface. For a higher-level interface, see
13+-- "Data.Yaml".
14+module Text.Libyaml
15+ ( -- * The event stream
16+ MarkedEvent(..)
17+ , Event (..)
18+ , Style (..)
19+ , SequenceStyle (..)
20+ , MappingStyle (..)
21+ , Tag (..)
22+ , AnchorName
23+ , Anchor
24+ -- * Encoding and decoding
25+ , encode
26+ , encodeWith
27+ , decode
28+ , decodeMarked
29+ , encodeFile
30+ , decodeFile
31+ , decodeFileMarked
32+ , encodeFileWith
33+ , FormatOptions
34+ , defaultFormatOptions
35+ , setWidth
36+ , setTagRendering
37+ , renderScalarTags
38+ , renderAllTags
39+ , renderNoTags
40+ , renderUriTags
41+ -- * Error handling
42+ , YamlException (..)
43+ , YamlMark (..)
44+ ) where
45+
46+import Prelude hiding (pi)
47+
48+import Data.Bits ((.|.))
49+import Foreign.C
50+import Foreign.Ptr
51+import Foreign.ForeignPtr
52+#if MIN_VERSION_base(4,7,0)
53+import Foreign.ForeignPtr.Unsafe
54+#endif
55+import Foreign.Marshal.Alloc
56+import qualified System.Posix.Internals as Posix
57+
58+#if !MIN_VERSION_base(4,8,0)
59+import Control.Applicative
60+#endif
61+import Control.Exception (mask_, throwIO, Exception, finally)
62+import Control.Monad
63+import Control.Monad.IO.Class
64+import Control.Monad.Trans.Resource
65+import Data.Conduit hiding (Source, Sink, Conduit)
66+import Data.Data
67+
68+import Data.ByteString (ByteString, packCString, packCStringLen)
69+import qualified Data.ByteString.Char8 as B8
70+import qualified Data.ByteString.Internal as B
71+import qualified Data.ByteString.Unsafe as BU
72+
73+#if WINDOWS && __GLASGOW_HASKELL__ >= 806
74+import System.Directory (removeFile)
75+import qualified Control.Exception
76+#endif
77+
78+data Event =
79+ EventStreamStart
80+ | EventStreamEnd
81+ | EventDocumentStart
82+ | EventDocumentEnd
83+ | EventAlias !AnchorName
84+ | EventScalar !ByteString !Tag !Style !Anchor
85+ | EventSequenceStart !Tag !SequenceStyle !Anchor
86+ | EventSequenceEnd
87+ | EventMappingStart !Tag !MappingStyle !Anchor
88+ | EventMappingEnd
89+ deriving (Show, Eq)
90+
91+-- | Event with start and end marks.
92+--
93+-- @since 0.10.4.0
94+data MarkedEvent = MarkedEvent
95+ { yamlEvent :: Event
96+ , yamlStartMark :: YamlMark
97+ , yamlEndMark :: YamlMark
98+ }
99+
100+-- | Style for scalars - e.g. quoted / folded
101+--
102+data Style = Any
103+ | Plain
104+ | SingleQuoted
105+ | DoubleQuoted
106+ | Literal
107+ | Folded
108+ | PlainNoTag
109+ deriving (Show, Read, Eq, Enum, Bounded, Ord, Data, Typeable)
110+
111+-- | Style for sequences - e.g. block or flow
112+--
113+-- @since 0.9.0
114+data SequenceStyle = AnySequence | BlockSequence | FlowSequence
115+ deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable)
116+
117+-- | Style for mappings - e.g. block or flow
118+--
119+-- @since 0.9.0
120+data MappingStyle = AnyMapping | BlockMapping | FlowMapping
121+ deriving (Show, Eq, Enum, Bounded, Ord, Data, Typeable)
122+
123+data Tag = StrTag
124+ | FloatTag
125+ | NullTag
126+ | BoolTag
127+ | SetTag
128+ | IntTag
129+ | SeqTag
130+ | MapTag
131+ | UriTag String
132+ | NoTag
133+ deriving (Show, Eq, Read, Data, Typeable)
134+
135+tagSuppressed :: Tag -> Bool
136+tagSuppressed (NoTag) = True
137+tagSuppressed (UriTag "") = True
138+tagSuppressed _ = False
139+
140+type AnchorName = String
141+type Anchor = Maybe AnchorName
142+
143+tagToString :: Tag -> String
144+tagToString StrTag = "tag:yaml.org,2002:str"
145+tagToString FloatTag = "tag:yaml.org,2002:float"
146+tagToString NullTag = "tag:yaml.org,2002:null"
147+tagToString BoolTag = "tag:yaml.org,2002:bool"
148+tagToString SetTag = "tag:yaml.org,2002:set"
149+tagToString IntTag = "tag:yaml.org,2002:int"
150+tagToString SeqTag = "tag:yaml.org,2002:seq"
151+tagToString MapTag = "tag:yaml.org,2002:map"
152+tagToString (UriTag s) = s
153+tagToString NoTag = ""
154+
155+bsToTag :: ByteString -> Tag
156+bsToTag = stringToTag . B8.unpack
157+
158+stringToTag :: String -> Tag
159+stringToTag "tag:yaml.org,2002:str" = StrTag
160+stringToTag "tag:yaml.org,2002:float" = FloatTag
161+stringToTag "tag:yaml.org,2002:null" = NullTag
162+stringToTag "tag:yaml.org,2002:bool" = BoolTag
163+stringToTag "tag:yaml.org,2002:set" = SetTag
164+stringToTag "tag:yaml.org,2002:int" = IntTag
165+stringToTag "tag:yaml.org,2002:seq" = SeqTag
166+stringToTag "tag:yaml.org,2002:map" = MapTag
167+stringToTag "" = NoTag
168+stringToTag s = UriTag s
169+
170+data ParserStruct
171+type Parser = Ptr ParserStruct
172+parserSize :: Int
173+parserSize = 480
174+
175+data EventRawStruct
176+type EventRaw = Ptr EventRawStruct
177+eventSize :: Int
178+eventSize = 104
179+
180+foreign import ccall unsafe "yaml_parser_initialize"
181+ c_yaml_parser_initialize :: Parser -> IO CInt
182+
183+foreign import ccall unsafe "yaml_parser_delete"
184+ c_yaml_parser_delete :: Parser -> IO ()
185+
186+foreign import ccall unsafe "yaml_parser_set_input_string"
187+ c_yaml_parser_set_input_string :: Parser
188+ -> Ptr CUChar
189+ -> CULong
190+ -> IO ()
191+
192+foreign import ccall unsafe "yaml_parser_set_input_file"
193+ c_yaml_parser_set_input_file :: Parser
194+ -> File
195+ -> IO ()
196+
197+data MarkRawStruct
198+type MarkRaw = Ptr MarkRawStruct
199+
200+foreign import ccall unsafe "get_mark_index"
201+ c_get_mark_index :: MarkRaw -> IO CULong
202+
203+foreign import ccall unsafe "get_mark_line"
204+ c_get_mark_line :: MarkRaw -> IO CULong
205+
206+foreign import ccall unsafe "get_mark_column"
207+ c_get_mark_column :: MarkRaw -> IO CULong
208+
209+getMark :: MarkRaw -> IO YamlMark
210+getMark m = YamlMark
211+ <$> (fromIntegral <$> c_get_mark_index m)
212+ <*> (fromIntegral <$> c_get_mark_line m)
213+ <*> (fromIntegral <$> c_get_mark_column m)
214+
215+data FileStruct
216+type File = Ptr FileStruct
217+
218+#ifdef WINDOWS
219+foreign import ccall unsafe "_fdopen"
220+#else
221+foreign import ccall unsafe "fdopen"
222+#endif
223+ c_fdopen :: CInt
224+ -> Ptr CChar
225+ -> IO File
226+foreign import ccall unsafe "fclose"
227+ c_fclose :: File
228+ -> IO CInt
229+
230+foreign import ccall unsafe "fclose_helper"
231+ c_fclose_helper :: File -> IO CInt
232+
233+foreign import ccall unsafe "yaml_parser_parse"
234+ c_yaml_parser_parse :: Parser -> EventRaw -> IO CInt
235+
236+foreign import ccall unsafe "yaml_event_delete"
237+ c_yaml_event_delete :: EventRaw -> IO ()
238+
239+foreign import ccall "get_parser_error_problem"
240+ c_get_parser_error_problem :: Parser -> IO (Ptr CUChar)
241+
242+foreign import ccall "get_parser_error_context"
243+ c_get_parser_error_context :: Parser -> IO (Ptr CUChar)
244+
245+foreign import ccall unsafe "get_parser_error_mark"
246+ c_get_parser_error_mark :: Parser -> IO MarkRaw
247+
248+makeString :: MonadIO m => (a -> m (Ptr CUChar)) -> a -> m String
249+makeString f a = do
250+ cchar <- castPtr `liftM` f a
251+ if cchar == nullPtr
252+ then return ""
253+ else liftIO $ peekCString cchar
254+
255+data EventType = YamlNoEvent
256+ | YamlStreamStartEvent
257+ | YamlStreamEndEvent
258+ | YamlDocumentStartEvent
259+ | YamlDocumentEndEvent
260+ | YamlAliasEvent
261+ | YamlScalarEvent
262+ | YamlSequenceStartEvent
263+ | YamlSequenceEndEvent
264+ | YamlMappingStartEvent
265+ | YamlMappingEndEvent
266+ deriving (Enum,Show)
267+
268+foreign import ccall unsafe "get_event_type"
269+ c_get_event_type :: EventRaw -> IO CInt
270+
271+foreign import ccall unsafe "get_start_mark"
272+ c_get_start_mark :: EventRaw -> IO MarkRaw
273+
274+foreign import ccall unsafe "get_end_mark"
275+ c_get_end_mark :: EventRaw -> IO MarkRaw
276+
277+foreign import ccall unsafe "get_scalar_value"
278+ c_get_scalar_value :: EventRaw -> IO (Ptr CUChar)
279+
280+foreign import ccall unsafe "get_scalar_length"
281+ c_get_scalar_length :: EventRaw -> IO CULong
282+
283+foreign import ccall unsafe "get_scalar_tag"
284+ c_get_scalar_tag :: EventRaw -> IO (Ptr CUChar)
285+
286+foreign import ccall unsafe "get_scalar_style"
287+ c_get_scalar_style :: EventRaw -> IO CInt
288+
289+foreign import ccall unsafe "get_scalar_anchor"
290+ c_get_scalar_anchor :: EventRaw -> IO CString
291+
292+foreign import ccall unsafe "get_sequence_start_anchor"
293+ c_get_sequence_start_anchor :: EventRaw -> IO CString
294+
295+foreign import ccall unsafe "get_sequence_start_style"
296+ c_get_sequence_start_style :: EventRaw -> IO CInt
297+
298+foreign import ccall unsafe "get_sequence_start_tag"
299+ c_get_sequence_start_tag :: EventRaw -> IO (Ptr CUChar)
300+
301+foreign import ccall unsafe "get_mapping_start_anchor"
302+ c_get_mapping_start_anchor :: EventRaw -> IO CString
303+
304+foreign import ccall unsafe "get_mapping_start_style"
305+ c_get_mapping_start_style :: EventRaw -> IO CInt
306+
307+foreign import ccall unsafe "get_mapping_start_tag"
308+ c_get_mapping_start_tag :: EventRaw -> IO (Ptr CUChar)
309+
310+foreign import ccall unsafe "get_alias_anchor"
311+ c_get_alias_anchor :: EventRaw -> IO CString
312+
313+readAnchor :: (EventRaw -> IO CString) -> EventRaw -> IO Anchor
314+readAnchor getAnchor er = do
315+ yanchor <- getAnchor er
316+ if yanchor == nullPtr
317+ then return Nothing
318+ else Just <$> peekCString yanchor
319+
320+readStyle :: (Enum a) => (EventRaw -> IO CInt) -> EventRaw -> IO a
321+readStyle getStyle er = toEnum . fromEnum <$> getStyle er
322+
323+readTag :: (EventRaw -> IO (Ptr CUChar)) -> EventRaw -> IO Tag
324+readTag getTag er = bsToTag <$> (getTag er >>= packCString . castPtr)
325+
326+getEvent :: EventRaw -> IO (Maybe MarkedEvent)
327+getEvent er = do
328+ et <- c_get_event_type er
329+ startMark <- c_get_start_mark er >>= getMark
330+ endMark <- c_get_end_mark er >>= getMark
331+ event <- case toEnum $ fromEnum et of
332+ YamlNoEvent -> return Nothing
333+ YamlStreamStartEvent -> return $ Just EventStreamStart
334+ YamlStreamEndEvent -> return $ Just EventStreamEnd
335+ YamlDocumentStartEvent -> return $ Just EventDocumentStart
336+ YamlDocumentEndEvent -> return $ Just EventDocumentEnd
337+ YamlAliasEvent -> do
338+ yanchor <- c_get_alias_anchor er
339+ anchor <- if yanchor == nullPtr
340+ then error "got YamlAliasEvent with empty anchor"
341+ else peekCString yanchor
342+ return $ Just $ EventAlias anchor
343+ YamlScalarEvent -> do
344+ yvalue <- c_get_scalar_value er
345+ ylen <- c_get_scalar_length er
346+ let yvalue' = castPtr yvalue
347+ let ylen' = fromEnum ylen
348+ bs <- packCStringLen (yvalue', ylen')
349+ tag <- readTag c_get_scalar_tag er
350+ style <- readStyle c_get_scalar_style er
351+ anchor <- readAnchor c_get_scalar_anchor er
352+ return $ Just $ EventScalar bs tag style anchor
353+ YamlSequenceStartEvent -> do
354+ tag <- readTag c_get_sequence_start_tag er
355+ style <- readStyle c_get_sequence_start_style er
356+ anchor <- readAnchor c_get_sequence_start_anchor er
357+ return $ Just $ EventSequenceStart tag style anchor
358+ YamlSequenceEndEvent -> return $ Just EventSequenceEnd
359+ YamlMappingStartEvent -> do
360+ tag <- readTag c_get_mapping_start_tag er
361+ style <- readStyle c_get_mapping_start_style er
362+ anchor <- readAnchor c_get_mapping_start_anchor er
363+ return $ Just $ EventMappingStart tag style anchor
364+ YamlMappingEndEvent -> return $ Just EventMappingEnd
365+ return $ (\e -> MarkedEvent e startMark endMark) <$> event
366+
367+-- Emitter
368+
369+data EmitterStruct
370+type Emitter = Ptr EmitterStruct
371+emitterSize :: Int
372+emitterSize = 432
373+
374+foreign import ccall unsafe "yaml_emitter_initialize"
375+ c_yaml_emitter_initialize :: Emitter -> IO CInt
376+
377+foreign import ccall unsafe "yaml_emitter_delete"
378+ c_yaml_emitter_delete :: Emitter -> IO ()
379+
380+data BufferStruct
381+type Buffer = Ptr BufferStruct
382+bufferSize :: Int
383+bufferSize = 16
384+
385+foreign import ccall unsafe "buffer_init"
386+ c_buffer_init :: Buffer -> IO ()
387+
388+foreign import ccall unsafe "get_buffer_buff"
389+ c_get_buffer_buff :: Buffer -> IO (Ptr CUChar)
390+
391+foreign import ccall unsafe "get_buffer_used"
392+ c_get_buffer_used :: Buffer -> IO CULong
393+
394+foreign import ccall unsafe "my_emitter_set_output"
395+ c_my_emitter_set_output :: Emitter -> Buffer -> IO ()
396+
397+#ifndef __NO_UNICODE__
398+foreign import ccall unsafe "yaml_emitter_set_unicode"
399+ c_yaml_emitter_set_unicode :: Emitter -> CInt -> IO ()
400+#endif
401+
402+foreign import ccall unsafe "yaml_emitter_set_output_file"
403+ c_yaml_emitter_set_output_file :: Emitter -> File -> IO ()
404+
405+foreign import ccall unsafe "yaml_emitter_set_width"
406+ c_yaml_emitter_set_width :: Emitter -> CInt -> IO ()
407+
408+foreign import ccall unsafe "yaml_emitter_emit"
409+ c_yaml_emitter_emit :: Emitter -> EventRaw -> IO CInt
410+
411+foreign import ccall unsafe "yaml_stream_start_event_initialize"
412+ c_yaml_stream_start_event_initialize :: EventRaw -> CInt -> IO CInt
413+
414+foreign import ccall unsafe "yaml_stream_end_event_initialize"
415+ c_yaml_stream_end_event_initialize :: EventRaw -> IO CInt
416+
417+foreign import ccall unsafe "yaml_scalar_event_initialize"
418+ c_yaml_scalar_event_initialize
419+ :: EventRaw
420+ -> Ptr CUChar -- anchor
421+ -> Ptr CUChar -- tag
422+ -> Ptr CUChar -- value
423+ -> CInt -- length
424+ -> CInt -- plain_implicit
425+ -> CInt -- quoted_implicit
426+ -> CInt -- style
427+ -> IO CInt
428+
429+foreign import ccall unsafe "simple_document_start"
430+ c_simple_document_start :: EventRaw -> IO CInt
431+
432+foreign import ccall unsafe "yaml_document_end_event_initialize"
433+ c_yaml_document_end_event_initialize :: EventRaw -> CInt -> IO CInt
434+
435+foreign import ccall unsafe "yaml_sequence_start_event_initialize"
436+ c_yaml_sequence_start_event_initialize
437+ :: EventRaw
438+ -> Ptr CUChar
439+ -> Ptr CUChar
440+ -> CInt
441+ -> CInt
442+ -> IO CInt
443+
444+foreign import ccall unsafe "yaml_sequence_end_event_initialize"
445+ c_yaml_sequence_end_event_initialize :: EventRaw -> IO CInt
446+
447+foreign import ccall unsafe "yaml_mapping_start_event_initialize"
448+ c_yaml_mapping_start_event_initialize
449+ :: EventRaw
450+ -> Ptr CUChar
451+ -> Ptr CUChar
452+ -> CInt
453+ -> CInt
454+ -> IO CInt
455+
456+foreign import ccall unsafe "yaml_mapping_end_event_initialize"
457+ c_yaml_mapping_end_event_initialize :: EventRaw -> IO CInt
458+
459+foreign import ccall unsafe "yaml_alias_event_initialize"
460+ c_yaml_alias_event_initialize
461+ :: EventRaw
462+ -> Ptr CUChar
463+ -> IO CInt
464+
465+toEventRaw :: FormatOptions -> Event -> (EventRaw -> IO a) -> IO a
466+toEventRaw opts e f = allocaBytes eventSize $ \er -> do
467+ ret <- case e of
468+ EventStreamStart ->
469+ c_yaml_stream_start_event_initialize
470+ er
471+ 0 -- YAML_ANY_ENCODING
472+ EventStreamEnd ->
473+ c_yaml_stream_end_event_initialize er
474+ EventDocumentStart ->
475+ c_simple_document_start er
476+ EventDocumentEnd ->
477+ c_yaml_document_end_event_initialize er 1
478+ EventScalar bs thetag style0 anchor -> do
479+ BU.unsafeUseAsCStringLen bs $ \(value, len) -> do
480+ let value' = castPtr value :: Ptr CUChar
481+ len' = fromIntegral len :: CInt
482+ let thetag' = tagToString thetag
483+ withCString thetag' $ \tag' -> do
484+ let pi0 = tagsImplicit e
485+ (pi, style) =
486+ case style0 of
487+ PlainNoTag -> (1, Plain)
488+ x -> (pi0, x)
489+ style' = toEnum $ fromEnum style
490+ tagP = castPtr tag'
491+ case anchor of
492+ Nothing ->
493+ c_yaml_scalar_event_initialize
494+ er
495+ nullPtr -- anchor
496+ tagP -- tag
497+ value' -- value
498+ len' -- length
499+ pi -- plain_implicit
500+ pi -- quoted_implicit
501+ style' -- style
502+ Just anchor' ->
503+ withCString anchor' $ \anchorP' -> do
504+ let anchorP = castPtr anchorP'
505+ c_yaml_scalar_event_initialize
506+ er
507+ anchorP -- anchor
508+ tagP -- tag
509+ value' -- value
510+ len' -- length
511+ 0 -- plain_implicit
512+ pi -- quoted_implicit
513+ style' -- style
514+ EventSequenceStart tag style Nothing ->
515+ withCString (tagToString tag) $ \tag' -> do
516+ let tagP = castPtr tag'
517+ c_yaml_sequence_start_event_initialize
518+ er
519+ nullPtr
520+ tagP
521+ (tagsImplicit e)
522+ (toEnum $ fromEnum style)
523+ EventSequenceStart tag style (Just anchor) ->
524+ withCString (tagToString tag) $ \tag' -> do
525+ let tagP = castPtr tag'
526+ withCString anchor $ \anchor' -> do
527+ let anchorP = castPtr anchor'
528+ c_yaml_sequence_start_event_initialize
529+ er
530+ anchorP
531+ tagP
532+ (tagsImplicit e)
533+ (toEnum $ fromEnum style)
534+ EventSequenceEnd ->
535+ c_yaml_sequence_end_event_initialize er
536+ EventMappingStart tag style Nothing ->
537+ withCString (tagToString tag) $ \tag' -> do
538+ let tagP = castPtr tag'
539+ c_yaml_mapping_start_event_initialize
540+ er
541+ nullPtr
542+ tagP
543+ (tagsImplicit e)
544+ (toEnum $ fromEnum style)
545+ EventMappingStart tag style (Just anchor) ->
546+ withCString (tagToString tag) $ \tag' -> do
547+ withCString anchor $ \anchor' -> do
548+ let tagP = castPtr tag'
549+ let anchorP = castPtr anchor'
550+ c_yaml_mapping_start_event_initialize
551+ er
552+ anchorP
553+ tagP
554+ (tagsImplicit e)
555+ (toEnum $ fromEnum style)
556+ EventMappingEnd ->
557+ c_yaml_mapping_end_event_initialize er
558+ EventAlias anchor ->
559+ withCString anchor $ \anchorP' -> do
560+ let anchorP = castPtr anchorP'
561+ c_yaml_alias_event_initialize
562+ er
563+ anchorP
564+ unless (ret == 1) $ throwIO $ ToEventRawException ret
565+ f er
566+ where
567+ tagsImplicit (EventScalar _ t _ _) | tagSuppressed t = 1
568+ tagsImplicit (EventMappingStart t _ _) | tagSuppressed t = 1
569+ tagsImplicit (EventSequenceStart t _ _) | tagSuppressed t = 1
570+ tagsImplicit evt = toImplicitParam $ formatOptionsRenderTags opts evt
571+
572+newtype ToEventRawException = ToEventRawException CInt
573+ deriving (Show, Typeable)
574+instance Exception ToEventRawException
575+
576+-- | Create a conduit that yields events from a bytestring.
577+decode :: MonadResource m => B.ByteString -> ConduitM i Event m ()
578+decode = mapOutput yamlEvent . decodeMarked
579+
580+-- | Create a conduit that yields marked events from a bytestring.
581+--
582+-- This conduit will yield identical events to that of "decode", but also
583+-- includes start and end marks for each event.
584+--
585+-- @since 0.10.4.0
586+decodeMarked :: MonadResource m => B.ByteString -> ConduitM i MarkedEvent m ()
587+decodeMarked bs | B8.null bs = return ()
588+decodeMarked bs =
589+ bracketP alloc cleanup (runParser . fst)
590+ where
591+ alloc = mask_ $ do
592+ ptr <- mallocBytes parserSize
593+ res <- c_yaml_parser_initialize ptr
594+ if res == 0
595+ then do
596+ c_yaml_parser_delete ptr
597+ free ptr
598+ throwIO $ YamlException "Yaml out of memory"
599+ else do
600+ let (bsfptr, offset, len) = B.toForeignPtr bs
601+ let bsptrOrig = unsafeForeignPtrToPtr bsfptr
602+ let bsptr = castPtr bsptrOrig `plusPtr` offset
603+ c_yaml_parser_set_input_string ptr bsptr (fromIntegral len)
604+ return (ptr, bsfptr)
605+ cleanup (ptr, bsfptr) = do
606+ touchForeignPtr bsfptr
607+ c_yaml_parser_delete ptr
608+ free ptr
609+
610+-- XXX copied from GHC.IO.FD
611+std_flags, read_flags, output_flags, write_flags :: CInt
612+std_flags = Posix.o_NOCTTY
613+output_flags = std_flags .|. Posix.o_CREAT .|. Posix.o_TRUNC
614+read_flags = std_flags .|. Posix.o_RDONLY
615+write_flags = output_flags .|. Posix.o_WRONLY
616+
617+-- | Open a C FILE* from a file path, using internal GHC API to work correctly
618+-- on all platforms, even on non-ASCII filenames. The opening mode must be
619+-- indicated via both 'rawOpenFlags' and 'openMode'.
620+openFile :: FilePath -> CInt -> String -> IO File
621+openFile file rawOpenFlags openMode = do
622+ fd <- liftIO $ Posix.withFilePath file $ \file' ->
623+ Posix.c_open file' rawOpenFlags 0o666
624+ if fd /= (-1)
625+ then withCString openMode $ \openMode' -> c_fdopen fd openMode'
626+ else return nullPtr
627+
628+-- | Creata a conduit that yields events from a file.
629+decodeFile :: MonadResource m => FilePath -> ConduitM i Event m ()
630+decodeFile = mapOutput yamlEvent . decodeFileMarked
631+
632+-- | Create a conduit that yields marked events from a file.
633+--
634+-- This conduit will yield identical events to that of "decodeFile", but also
635+-- includes start and end marks for each event.
636+--
637+-- @since 0.10.4.0
638+decodeFileMarked :: MonadResource m => FilePath -> ConduitM i MarkedEvent m ()
639+decodeFileMarked file =
640+ bracketP alloc cleanup (runParser . fst)
641+ where
642+ alloc = mask_ $ do
643+ ptr <- mallocBytes parserSize
644+ res <- c_yaml_parser_initialize ptr
645+ if res == 0
646+ then do
647+ c_yaml_parser_delete ptr
648+ free ptr
649+ throwIO $ YamlException "Yaml out of memory"
650+ else do
651+ file' <- openFile file read_flags "r"
652+ if file' == nullPtr
653+ then do
654+ c_yaml_parser_delete ptr
655+ free ptr
656+ throwIO $ YamlException
657+ $ "Yaml file not found: " ++ file
658+ else do
659+ c_yaml_parser_set_input_file ptr file'
660+ return (ptr, file')
661+ cleanup (ptr, file') = do
662+ res <- c_fclose_helper file'
663+ when (res /= 0) $ throwIO $ YamlException $ "could not close file: " ++ file
664+ c_yaml_parser_delete ptr
665+ free ptr
666+
667+runParser :: MonadResource m => Parser -> ConduitM i MarkedEvent m ()
668+runParser parser = do
669+ e <- liftIO $ parserParseOne' parser
670+ case e of
671+ Left err -> liftIO $ throwIO err
672+ Right Nothing -> return ()
673+ Right (Just ev) -> yield ev >> runParser parser
674+
675+parserParseOne' :: Parser
676+ -> IO (Either YamlException (Maybe MarkedEvent))
677+parserParseOne' parser = allocaBytes eventSize $ \er -> do
678+ res <- liftIO $ c_yaml_parser_parse parser er
679+ flip finally (c_yaml_event_delete er) $
680+ if res == 0
681+ then do
682+ problem <- makeString c_get_parser_error_problem parser
683+ context <- makeString c_get_parser_error_context parser
684+ problemMark <- c_get_parser_error_mark parser >>= getMark
685+ return $ Left $ YamlParseException problem context problemMark
686+ else Right <$> getEvent er
687+
688+-- | Whether a tag should be rendered explicitly in the output or left
689+-- implicit.
690+--
691+-- @since 0.1.1.0
692+data TagRender = Explicit | Implicit
693+ deriving (Enum)
694+
695+toImplicitParam :: TagRender -> CInt
696+toImplicitParam Explicit = 0
697+toImplicitParam Implicit = 1
698+
699+-- | A value for 'formatOptionsRenderTags' that renders no
700+-- collection tags but all scalar tags (unless suppressed with styles
701+-- 'NoTag or 'PlainNoTag').
702+--
703+-- @since 0.1.1.0
704+renderScalarTags :: Event -> TagRender
705+renderScalarTags (EventScalar _ _ _ _) = Explicit
706+renderScalarTags (EventSequenceStart _ _ _) = Implicit
707+renderScalarTags (EventMappingStart _ _ _) = Implicit
708+renderScalarTags _ = Implicit
709+
710+-- | A value for 'formatOptionsRenderTags' that renders all
711+-- tags (except 'NoTag' tag and 'PlainNoTag' style).
712+--
713+-- @since 0.1.1.0
714+renderAllTags :: Event -> TagRender
715+renderAllTags _ = Explicit
716+
717+-- | A value for 'formatOptionsRenderTags' that renders no
718+-- tags.
719+--
720+-- @since 0.1.1.0
721+renderNoTags :: Event -> TagRender
722+renderNoTags _ = Implicit
723+
724+-- | A value for 'formatOptionsRenderCollectionTags' that renders tags
725+-- which are instances of 'UriTag'
726+--
727+-- @since 0.1.1.0
728+renderUriTags :: Event -> TagRender
729+renderUriTags (EventScalar _ UriTag{} _ _) = Explicit
730+renderUriTags (EventSequenceStart UriTag{} _ _) = Explicit
731+renderUriTags (EventMappingStart UriTag{} _ _) = Explicit
732+renderUriTags _ = Implicit
733+
734+-- | Contains options relating to the formatting (indendation, width) of the YAML output.
735+--
736+-- @since 0.10.2.0
737+data FormatOptions = FormatOptions
738+ { formatOptionsWidth :: Maybe Int
739+ , formatOptionsRenderTags :: Event -> TagRender
740+ }
741+
742+-- |
743+-- @since 0.10.2.0
744+defaultFormatOptions :: FormatOptions
745+defaultFormatOptions = FormatOptions
746+ { 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
747+ , formatOptionsRenderTags = renderScalarTags
748+ }
749+
750+-- | Set the maximum number of columns in the YAML output, or 'Nothing' for infinite. By default, the limit is 80 characters.
751+--
752+-- @since 0.10.2.0
753+setWidth :: Maybe Int -> FormatOptions -> FormatOptions
754+setWidth w opts = opts { formatOptionsWidth = w }
755+
756+-- | Control when and whether tags are rendered to output.
757+--
758+-- @since 0.1.1.0
759+setTagRendering :: (Event -> TagRender) -> FormatOptions -> FormatOptions
760+setTagRendering f opts = opts { formatOptionsRenderTags = f }
761+
762+encode :: MonadResource m => ConduitM Event o m ByteString
763+encode = encodeWith defaultFormatOptions
764+
765+-- |
766+-- @since 0.10.2.0
767+encodeWith :: MonadResource m => FormatOptions -> ConduitM Event o m ByteString
768+encodeWith opts =
769+ runEmitter opts alloc close
770+ where
771+ alloc emitter = do
772+ fbuf <- mallocForeignPtrBytes bufferSize
773+ withForeignPtr fbuf c_buffer_init
774+ withForeignPtr fbuf $ c_my_emitter_set_output emitter
775+ return fbuf
776+ close _ fbuf = withForeignPtr fbuf $ \b -> do
777+ ptr' <- c_get_buffer_buff b
778+ len <- c_get_buffer_used b
779+ fptr <- newForeignPtr finalizerFree $ castPtr ptr'
780+ return $ B.fromForeignPtr fptr 0 $ fromIntegral len
781+
782+
783+encodeFile :: MonadResource m
784+ => FilePath
785+ -> ConduitM Event o m ()
786+encodeFile = encodeFileWith defaultFormatOptions
787+
788+-- |
789+-- @since 0.10.2.0
790+encodeFileWith :: MonadResource m
791+ => FormatOptions
792+ -> FilePath
793+ -> ConduitM Event o m ()
794+encodeFileWith opts filePath =
795+ bracketP getFile cleanup $ \file -> runEmitter opts (alloc file) (\u _ -> return u)
796+ where
797+ cleanup file = do
798+ res <- c_fclose file
799+ when (res /= 0) $ throwIO $ YamlException $ "could not close file: " ++ filePath
800+
801+ getFile = do
802+#if WINDOWS && __GLASGOW_HASKELL__ >= 806
803+ -- See: https://github.com/snoyberg/yaml/issues/178#issuecomment-550180027
804+ removeFile filePath `Control.Exception.catch`
805+ (\(_ :: Control.Exception.IOException) -> pure ())
806+#endif
807+ file <- openFile filePath write_flags "w"
808+ if file == nullPtr
809+ then throwIO $ YamlException $ "could not open file for write: " ++ filePath
810+ else return file
811+
812+ alloc file emitter = c_yaml_emitter_set_output_file emitter file
813+
814+runEmitter :: MonadResource m
815+ => FormatOptions
816+ -> (Emitter -> IO a) -- ^ alloc
817+ -> (() -> a -> IO b) -- ^ close
818+ -> ConduitM Event o m b
819+runEmitter opts allocI closeI =
820+ bracketP alloc cleanup go
821+ where
822+ alloc = mask_ $ do
823+ emitter <- mallocBytes emitterSize
824+ res <- c_yaml_emitter_initialize emitter
825+ when (res == 0) $ throwIO $ YamlException "c_yaml_emitter_initialize failed"
826+#ifndef __NO_UNICODE__
827+ c_yaml_emitter_set_unicode emitter 1
828+#endif
829+ c_yaml_emitter_set_width emitter $ case formatOptionsWidth opts of
830+ Nothing -> -1 --infinite
831+ Just width -> fromIntegral width
832+ a <- allocI emitter
833+ return (emitter, a)
834+ cleanup (emitter, _) = do
835+ c_yaml_emitter_delete emitter
836+ free emitter
837+
838+ go (emitter, a) =
839+ loop
840+ where
841+ loop = await >>= maybe (close ()) push
842+
843+ push e = do
844+ _ <- liftIO $ toEventRaw opts e $ c_yaml_emitter_emit emitter
845+ loop
846+ close u = liftIO $ closeI u a
847+
848+-- | The pointer position
849+data YamlMark = YamlMark { yamlIndex :: Int, yamlLine :: Int, yamlColumn :: Int }
850+ deriving Show
851+
852+data YamlException = YamlException String
853+ -- | problem, context, index, position line, position column
854+ | YamlParseException { yamlProblem :: String, yamlContext :: String, yamlProblemMark :: YamlMark }
855+ deriving (Show, Typeable)
856+instance Exception YamlException
stack.yamlnew file+12
@@ -0,0 +1,12 @@
1+resolver: lts-22.13
2+
3+flags:
4+ yaml:
5+ no-examples: false
6+
7+packages:
8+ - yaml
9+ - libyaml
10+
11+extra-deps:
12+ - libyaml-clib-0.2.5
test/.gitignoredeleted−3
@@ -1,3 +0,0 @@
1−hebrew.txt
2−output.yaml
3−output2.yaml
test/hebrew.yamldeleted−1
@@ -1 +0,0 @@
1−שלום
test/input.yamldeleted−2
@@ -1,2 +0,0 @@
1−this is a testש: foobar
2−this is too: foobarbaz
test/test.hsdeleted−19
@@ -1,19 +0,0 @@
1−import Text.Yaml
2−import qualified Data.ByteString as B
3−import Control.Monad
4−
5−main = do
6− contents <- B.readFile "input.yaml"
7− o <- decode contents
8− let contents2 = encode (o :: Object)
9− B.writeFile "output.yaml" contents2
10− o2 <- decode contents2
11− print (o2 :: Object)
12− contents3 <- B.readFile "hebrew.yaml"
13− o3 <- decode contents3
14− print (o3 :: B.ByteString)
15− B.writeFile "hebrew.txt" o3
16−
17− o4 <- join $ decodeFile "input.yaml"
18− print (o4 :: Object)
19− encodeFile "output2.yaml" o4
yaml.cabaldeleted−26
@@ -1,26 +0,0 @@
1−name: yaml
2−version: 0.0.0
3−license: BSD3
4−license-file: LICENSE
5−author: Michael Snoyman <michael@snoyman.com>
6−maintainer: Michael Snoyman <michael@snoyman.com>
7−synopsis: Support for serialising Haskell to and from Yaml.
8−description: Binds to the libyaml library
9−category: Web
10−stability: unstable
11−cabal-version: >= 1.2
12−build-type: Simple
13−homepage: http://github.com/snoyberg/yaml/tree/master
14−
15−library
16− build-depends: base >= 4 && < 5,
17− bytestring-class,
18− data-object,
19− bytestring >= 0.9.1.4 && < 1,
20− haskell98
21− exposed-modules: Text.Yaml
22− other-modules: Text.Libyaml,
23− C2HS
24− ghc-options: -Wall
25− c-sources: c/helper.c
26− extra-libraries: yaml
yaml/ChangeLog.mdnew file+303
@@ -0,0 +1,303 @@
1+# ChangeLog for yaml
2+
3+## 0.11.11.2
4+
5+* Compat with aeson 2.2
6+
7+## 0.11.11.1
8+
9+* For optparse-applicative-0.18: use `pretty` instead of `text` [#216](https://github.com/snoyberg/yaml/pull/216)
10+
11+## 0.11.11.0
12+
13+* Fix ambiguous occurrence `AesonException`
14+
15+## 0.11.10.0
16+
17+* Undo previous change (breakage with aeson 2)
18+
19+## 0.11.9.0
20+
21+* Data.Yaml.Pretty: provide key-sorting function with path to parent object [#206](https://github.com/snoyberg/yaml/pull/206)
22+
23+## 0.11.8.0
24+
25+* Export `Parse` and `StringStyle` [#204](https://github.com/snoyberg/yaml/pull/204)
26+
27+## 0.11.7.0
28+
29+* Support `aeson` 2 [#202](https://github.com/snoyberg/yaml/pull/202)
30+
31+## 0.11.6.0
32+
33+* `yaml2json`: add `--help` and `--version` options [#197](https://github.com/snoyberg/yaml/pull/197)
34+* `json2yaml`: add `--help` and `--version` options [#198](https://github.com/snoyberg/yaml/pull/198)
35+* Add the `-o` options to both `yaml2json` and `json2yaml` [#200](https://github.com/snoyberg/yaml/pull/200)
36+
37+## 0.11.5.0
38+
39+* New functions capable of parsing YAML streams containing multiple documents into a list of results:
40+ * `decodeAllEither'`
41+ * `decodeAllFileEither`
42+ * `decodeAllFileWithWarnings`
43+ * `decodeAllThrow`
44+ * `decodeAllFileThrow`
45+
46+## 0.11.4.0
47+
48+* add `ToYaml` instance for `String` [#186](https://github.com/snoyberg/yaml/pull/186)
49+
50+## 0.11.3.0
51+
52+* Don't wrap up async exceptions [#185](https://github.com/snoyberg/yaml/issues/185)
53+
54+## 0.11.2.0
55+
56+* Reduces some of the code duplication between the `encode` and `encodePretty` functions
57+* The output of `encodePretty` has been improved:
58+ - Multiline strings now use `Literal` style instead of `SingleQuoted`
59+ - Special keys are now quoted in mappings [#179](https://github.com/snoyberg/yaml/issues/179)
60+* Support for complex keys in mappings: [#182](https://github.com/snoyberg/yaml/issues/182)
61+ - Adds `complexMapping` function to `Data.Yaml.Builder`
62+ - Decode functions now return a `NonStringKey` error when attempting to decode a mapping with a complex key as it is not possible to decode these to an Aeson `Value`
63+* Adds missing `ToYaml` instances
64+
65+## 0.11.1.2
66+
67+* Compiles with GHC 8.8.1 (`MonadFail` split)
68+
69+## 0.11.1.1
70+
71+* Use the appropriate `Scientific` rendering function to avoid a memory overflow when rendering. The previously used function from `aeson` would not use scientific notation, and could use large amounts of memory for values such as `1e9999999999999`.
72+
73+## 0.11.1.0
74+
75+* Better error messages in the `Data.Yaml.Config` module [#168](https://github.com/snoyberg/yaml/issues/168)
76+* Add `LoadSettingsException` exception and remove error printing from `loadYamlSettings` [#172](https://github.com/snoyberg/yaml/pull/172)
77+
78+## 0.11.0.0
79+
80+* Split out the `libyaml` and `Text.Libyaml` code into its own package. [#145](https://github.com/snoyberg/yaml/issues/145)
81+
82+## 0.10.4.0
83+
84+* Add `decodeMarked` and `decodeFileMarked` functions to `Text.Libyaml`, and
85+ extend native bindings to extract mark information. [#157](https://github.com/snoyberg/yaml/issues/157)
86+
87+## 0.10.3.0
88+
89+* Add support for anchors and aliases to Data.Yaml.Builder [#155](https://github.com/snoyberg/yaml/pull/155)
90+* Fix test suite for 32 bit machines [#158](https://github.com/snoyberg/yaml/issues/158)
91+
92+## 0.10.2.0
93+
94+* Add `EncodeOptions` and `FormatOptions` to control the style of the encoded YAML. [#153](https://github.com/snoyberg/yaml/pull/153)
95+* Default to using literal style for multiline strings [#152](https://github.com/snoyberg/yaml/issues/152)
96+
97+## 0.10.1.1
98+
99+* Correctly declare libyaml dependency on system-libyaml flag [#151](https://github.com/snoyberg/yaml/pull/151)
100+
101+## 0.10.1
102+
103+* Avoid incurring a `semigroups` dependency on recent GHCs.
104+* Fix a space leak that was introduced with `0.10.0` [#147](https://github.com/snoyberg/yaml/issues/147)
105+
106+## 0.10.0
107+
108+* Add `decodeFileWithWarnings` which returns warnings for duplicate fields
109+
110+## 0.9.0
111+
112+* Expose style and tags on mappings and sequences in Text.Libyaml [#141](https://github.com/snoyberg/yaml/pull/141)
113+
114+## 0.8.32
115+
116+* Escape keys as necessary [#137](https://github.com/snoyberg/yaml/issues/137)
117+* Support hexadecimal and octal number values [#135](https://github.com/snoyberg/yaml/issues/135)
118+* More resilient `isNumeric` (should reduce cases of unneeded quoting)
119+* hpackify
120+* src subdir
121+
122+## 0.8.31.1
123+
124+* Add a workaround for a cabal bug [haskell-infra/hackage-trustees#165](https://github.com/haskell-infra/hackage-trustees/issues/165)
125+
126+## 0.8.31
127+
128+* Add `decodeThrow` and `decodeFileThrow` convenience functions.
129+* Upgrade libyaml versions
130+* Deprecate `decode` and `decodeEither`
131+
132+## 0.8.30
133+
134+* Removed `AppSettings` mentioned in `loadYamlSettings` error message.
135+
136+## 0.8.29
137+
138+* Deprecated `decodeFile` [#129](https://github.com/snoyberg/yaml/issues/129)
139+* Turn off executables by default [#103](https://github.com/snoyberg/yaml/issues/103)
140+
141+## 0.8.28
142+
143+* Add `Data.Yaml.TH.yamlQQ`
144+
145+## 0.8.27
146+
147+* Support conduit 1.3
148+
149+## 0.8.26
150+
151+* Add `Semigroup` instance [#123](https://github.com/snoyberg/yaml/pull/123)
152+
153+## 0.8.25.2
154+
155+* Use `throwM` instead of `monadThrow`
156+
157+## 0.8.25.1
158+
159+* Drop aeson-qq dep (incompatible with Stackage Nightly)
160+
161+## 0.8.25
162+
163+* Tweaks to the executable `yaml2json` [#119](https://github.com/snoyberg/yaml/pull/119):
164+ - Add command-line option `-h` and `--help` to show help message
165+ - Error messages are now written to `stderr` instead of `stdout`
166+
167+## 0.8.24
168+
169+* New encodePretty option `setConfDropNull` to drop null values from objects [#116](https://github.com/snoyberg/yaml/issues/116)
170+
171+## 0.8.23.3
172+
173+* Avoid over-escaping `*` [#113](https://github.com/snoyberg/yaml/issues/113)
174+
175+## 0.8.23.2
176+
177+* Update libyaml [#110](https://github.com/snoyberg/yaml/issues/110)
178+
179+## 0.8.23.1
180+
181+* Update CPP `MIN_VERSION_*` checks [#109](https://github.com/snoyberg/yaml/pull/109)
182+
183+## 0.8.23
184+
185+* Re-export the with helpers from aeson
186+
187+## 0.8.22.1
188+
189+* Make numeric string detection slightly smarter so, e.g., `.` does
190+ not get quoted
191+
192+## 0.8.22
193+
194+* Update to libyaml hosted on Github [#105](https://github.com/snoyberg/yaml/issues/105)
195+
196+## 0.8.21.2
197+
198+* Fix wrong file not found exception in `Data.Yaml.Include` with pre-1.2.3.0 `directory` [#104](https://github.com/snoyberg/yaml/pull/104)
199+
200+## 0.8.21.1
201+
202+* Add missing test files [#102](https://github.com/snoyberg/yaml/pull/102)
203+
204+## 0.8.21
205+
206+* Decode empty inputs as Null [#101](https://github.com/snoyberg/yaml/pull/101)
207+
208+## 0.8.20
209+
210+* Upgrade to libyaml 0.1.7
211+
212+## 0.8.19.0
213+
214+* Add `Data.Yaml.TH` module
215+
216+## 0.8.18.7
217+
218+* Add `O_TRUNC` when opening files
219+
220+## 0.8.18.6
221+
222+* s/fdopen/_fdopen on Windows [#96](https://github.com/snoyberg/yaml/issues/96)
223+
224+## 0.8.18.5
225+
226+* Properly fix previous bug (fixes #94)
227+
228+## 0.8.18.4
229+
230+* Remove file with non-ASCII name due to Stack/cabal-install/Hackage
231+ restrictions (see [#92](https://github.com/snoyberg/yaml/issues/92))
232+
233+## 0.8.18.2
234+
235+* Handle non-ASCII filenames correctly on Windows [#91](https://github.com/snoyberg/yaml/pull/91)
236+
237+## 0.8.18.1
238+
239+* Improve prettyPrintParseException when context is empty [#89](https://github.com/snoyberg/yaml/pull/89)
240+
241+## 0.8.18
242+
243+* Switched yaml decode function for config file readers in `Data.Yaml.Config` to
244+ the one from `Data.Yaml.Include` that supports `!include` syntax.
245+
246+## 0.8.17.2
247+
248+* Fix pretty-printing order of UnexpectedEvent's fields (fixes [#84](https://github.com/snoyberg/yaml/issues/84)) [#85](https://github.com/snoyberg/yaml/pull/85)
249+
250+## 0.8.17.1
251+
252+* Avoid bug in Cabal [#83](https://github.com/snoyberg/yaml/pull/83)
253+
254+## 0.8.17
255+
256+* `loadYamlSettingsArgs`
257+
258+## 0.8.16.1
259+
260+* Slight doc improvement
261+
262+## 0.8.16
263+
264+Add env variable parsing. `loadYamlSettings` can read config values from the environment with Yaml that specifies an env var.
265+The syntax is
266+
267+`var: _env:ENV_VAR:default`
268+
269+## 0.8.15.3
270+
271+* Give a warning when compiling with GHCJS
272+
273+## 0.8.15.2
274+
275+* Canonicalise Monad instances [#76](https://github.com/snoyberg/yaml/pull/76)
276+
277+## 0.8.15.1
278+
279+* Compile with aeson below 0.7 [#70](https://github.com/snoyberg/yaml/pull/70)
280+
281+## 0.8.15
282+
283+* Parse `Scientific` directly, avoiding loss in precision. [#68](https://github.com/snoyberg/yaml/pull/68)
284+
285+## 0.8.14
286+
287+* Pretty print improvements for exceptions [#67](https://github.com/snoyberg/yaml/pull/67)
288+
289+## 0.8.13
290+
291+* Pretty module [#66](https://github.com/snoyberg/yaml/pull/66)
292+
293+## 0.8.12
294+
295+* Proper handling of `String "+123"` [#64](https://github.com/snoyberg/yaml/issues/64)
296+
297+## 0.8.11
298+
299+* Function to print prettier parse exceptions [#59](https://github.com/snoyberg/yaml/pull/59)
300+
301+## 0.8.10
302+
303+Add the Data.Yaml.Include module
yaml/LICENSEnew file+25
@@ -0,0 +1,25 @@
1+The following license covers this documentation, and the source code, except
2+where otherwise indicated.
3+
4+Copyright 2008, Michael Snoyman. All rights reserved.
5+
6+Redistribution and use in source and binary forms, with or without
7+modification, are permitted provided that the following conditions are met:
8+
9+* Redistributions of source code must retain the above copyright notice, this
10+ list of conditions and the following disclaimer.
11+
12+* Redistributions in binary form must reproduce the above copyright notice,
13+ this list of conditions and the following disclaimer in the documentation
14+ and/or other materials provided with the distribution.
15+
16+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
17+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
18+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
19+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
20+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
21+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
22+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
23+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
24+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
25+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
yaml/README.mdnew file+26
@@ -0,0 +1,26 @@
1+## yaml
2+
3+[![GitHub build and test status](https://github.com/snoyberg/yaml/actions/workflows/tests.yml/badge.svg?branch=master)](https://github.com/snoyberg/yaml/actions/workflows/tests.yml)
4+[![Appveyor build status](https://ci.appveyor.com/api/projects/status/hqy2jketp8m502so/branch/master?svg=true)](https://ci.appveyor.com/project/snoyberg/yaml/branch/master)
5+
6+Provides support for parsing and emitting Yaml documents.
7+
8+`Data.Yaml` provides a high-level interface based around the JSON datatypes provided by the `aeson` package. It uses `Text.Libyaml` from `libyaml` in its implementation of the low-level yaml encoder/decoder.
9+
10+### Examples
11+
12+Usage examples can be found in the `Data.Yaml` documentation or in the [examples](https://github.com/snoyberg/yaml/tree/master/yaml/examples) directory.
13+
14+### Additional `yaml` modules
15+
16+* `Data.Yaml.Include` supports adding `!include` directives to your YAML files.
17+* `Data.Yaml.Builder` and `Data.Yaml.Parser` allow more fine-grained control of parsing an rendering, as opposed to just using the aeson typeclass and datatype system for parsing and rendering.
18+* `Data.Yaml.Aeson` is currently a re-export of `Data.Yaml` to explicitly choose to use the aeson-compatible API.
19+
20+### Executables
21+
22+Converters `json2yaml` and `yaml2json` can be built by disabling flag `no-exe`, e.g., one of:
23+```
24+cabal install yaml -f-no-exe
25+stack install yaml --flag yaml:-no-exe
26+```
Setup.lhs → yaml/Setup.lhsrenamed

Only the mode changed.

yaml/builder-test.hsnew file+27
@@ -0,0 +1,27 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+import Data.Yaml.Builder
3+import qualified Data.ByteString as S
4+import Data.Text (Text)
5+
6+data Person = Person
7+ { name :: !Text
8+ , age :: !Int
9+ }
10+instance ToYaml Person where
11+ toYaml (Person n a) = mapping
12+ [ "name" .= n
13+ , "age" .= a
14+ ]
15+
16+main :: IO ()
17+main = do
18+ S.putStr $ toByteString
19+ [ Person "Alice" 57
20+ , Person "Bob" 23
21+ , Person "12345" 23
22+ ]
23+ writeYamlFile "/tmp/foo.yaml" $
24+ [ Person "Alice" 57
25+ , Person "Bob" 23
26+ , Person "12345" 23
27+ ]
yaml/examples/Config.hsnew file+55
@@ -0,0 +1,55 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE QuasiQuotes #-}
3+
4+module Config where
5+
6+import Data.Text (Text)
7+import qualified Data.Yaml as Y
8+import Data.Yaml (FromJSON(..), (.:))
9+import Text.RawString.QQ
10+import Data.ByteString (ByteString)
11+import Control.Applicative
12+import Prelude -- Ensure Applicative is in scope and we have no warnings, before/after AMP.
13+
14+configYaml :: ByteString
15+configYaml = [r|
16+resolver: lts-3.7
17+packages:
18+ - ./yesod-core
19+ - ./yesod-static
20+ - ./yesod-persistent
21+ - ./yesod-newsfeed
22+ - ./yesod-form
23+ - ./yesod-auth
24+ - ./yesod-auth-oauth
25+ - ./yesod-sitemap
26+ - ./yesod-test
27+ - ./yesod-bin
28+ - ./yesod
29+ - ./yesod-eventsource
30+ - ./yesod-websockets
31+
32+# Needed for LTS 2
33+extra-deps:
34+- wai-app-static-3.1.4.1
35+|]
36+
37+data Config =
38+ Config {
39+ resolver :: Text
40+ , packages :: [FilePath]
41+ , extraDeps :: [Text]
42+ } deriving (Eq, Show)
43+
44+instance FromJSON Config where
45+ parseJSON (Y.Object v) =
46+ Config <$>
47+ v .: "resolver" <*>
48+ v .: "packages" <*>
49+ v .: "extra-deps"
50+ parseJSON _ = fail "Expected Object for Config value"
51+
52+main :: IO ()
53+main = do
54+ config <- Y.decodeThrow configYaml
55+ print (config :: Config)
yaml/examples/Main.hsnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+import qualified Config
4+import qualified Simple
5+
6+main :: IO ()
7+main = do
8+ Simple.main
9+ Config.main
10+
yaml/examples/Simple.hsnew file+14
@@ -0,0 +1,14 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module Simple where
4+
5+import qualified Data.Yaml as Y
6+
7+main :: IO ()
8+main = do
9+ res <- Y.decodeThrow "[1,2,3]"
10+ print (res :: [Integer])
11+
12+-- You can go one step further and decode into a custom type by implementing
13+-- 'FromJSON' for that type. This is also appropriate where extra
14+-- normalization, formatting or manipulation of the YAML is required on decode.
yaml/exe/Common.hsnew file+68
@@ -0,0 +1,68 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE LambdaCase #-}
3+
4+-- | Code shared between @yaml2json@ and @json2yaml@.
5+
6+module Common where
7+
8+import Data.List ( intercalate )
9+#if !MIN_VERSION_base(4,11,0)
10+import Data.Semigroup ( Semigroup(..) )
11+#endif
12+import Data.Version ( Version(versionBranch) )
13+
14+import Options.Applicative ( Parser, help, hidden, infoOption, long, short )
15+
16+import qualified Paths_yaml as Paths
17+
18+-- * Version info and option
19+---------------------------------------------------------------------------
20+
21+-- | Homepage for @yaml2json@ and @json2yaml@.
22+
23+homepage :: String
24+homepage = "https://github.com/snoyberg/yaml/"
25+
26+-- | Version in @x.y.z@ format.
27+
28+version :: String
29+version = intercalate "." $ map show $ versionBranch Paths.version
30+
31+-- | The version header including given program name and 'homepage'.
32+
33+versionText :: String -> String
34+versionText self = unwords
35+ [ self
36+ , "version"
37+ , version
38+ , homepage -- concat [ "<", homepage, ">" ]
39+ ]
40+
41+-- | Option @--numeric-version@.
42+
43+numericVersionOption :: Parser (a -> a)
44+numericVersionOption =
45+ infoOption version
46+ $ long "numeric-version"
47+ <> hidden
48+ <> help "Show just version number."
49+
50+-- | Option @--version@.
51+
52+versionOption :: String -> Parser (a -> a)
53+versionOption self =
54+ infoOption (versionText self)
55+ $ long "version"
56+ <> short 'V'
57+ <> hidden
58+ <> help "Show version info."
59+
60+-- * Misc
61+---------------------------------------------------------------------------
62+
63+-- | @Just@ unless argument is @"-"@ (denoting @stdin@ or @stdout@).
64+
65+dashToNothing :: FilePath -> Maybe FilePath
66+dashToNothing = \case
67+ "-" -> Nothing
68+ file -> Just file
yaml/exe/json2yaml.hsnew file+106
@@ -0,0 +1,106 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE NamedFieldPuns #-}
3+
4+import qualified Data.Aeson as J
5+import qualified Data.ByteString as S
6+import qualified Data.ByteString.Lazy as L
7+import qualified Data.Yaml as Y
8+#if !MIN_VERSION_base(4,11,0)
9+import Data.Semigroup ( Semigroup(..) )
10+#endif
11+
12+import Options.Applicative
13+ ( Parser, (<|>)
14+ , action, execParser, footerDoc, headerDoc, help, helper, hidden, info
15+ , long, metavar, short, strArgument, strOption, value
16+ )
17+import Options.Applicative.Help.Pretty
18+ ( vcat, pretty )
19+
20+import System.Exit ( die )
21+
22+import Common ( dashToNothing, versionText, versionOption, numericVersionOption )
23+
24+data Options = Options
25+ { optInput :: Maybe FilePath
26+ -- ^ 'Nothing' means @stdin@.
27+ , optOutput :: Maybe FilePath
28+ -- ^ 'Nothing' means @stdout@.
29+ }
30+
31+-- | Name of the executable.
32+
33+self :: String
34+self = "json2yaml"
35+
36+-- | Parse options; handle parse errors, @--help@, @--version@.
37+
38+options :: IO Options
39+options =
40+ execParser $
41+ info (helper <*> versionOption self <*> numericVersionOption <*> programOptions)
42+ $ headerDoc hdoc
43+ <> footerDoc fdoc
44+
45+ where
46+ hdoc = Just $ vcat $ map pretty
47+ [ versionText self
48+ , "Convert JSON to YAML."
49+ ]
50+ fdoc = Just $ pretty $ concat
51+ [ "The old call pattern '"
52+ , self
53+ , " IN OUT' is also accepted, but deprecated."
54+ ]
55+
56+ programOptions :: Parser Options
57+ programOptions = Options <$> oInput <*> oOutput
58+
59+ oInput :: Parser (Maybe FilePath)
60+ oInput = dashToNothing <$> do
61+ strArgument
62+ $ metavar "IN"
63+ <> value "-"
64+ <> action "file"
65+ <> help "The input file containing the JSON document; use '-' for stdin (default)."
66+
67+ oOutput :: Parser (Maybe FilePath)
68+ oOutput = dashToNothing <$> do
69+ oOutputExplicit <|> oOutputImplicit
70+
71+ oOutputExplicit :: Parser FilePath
72+ oOutputExplicit =
73+ strOption
74+ $ long "output"
75+ <> short 'o'
76+ <> metavar "OUT"
77+ <> action "file"
78+ -- <> help "The file to hold the produced YAML document; use '-' for stdout (default)."
79+
80+ oOutputImplicit :: Parser FilePath
81+ oOutputImplicit =
82+ strArgument
83+ $ metavar "OUT"
84+ <> value "-"
85+ <> action "file"
86+ <> hidden
87+ <> help "The file to hold the produced YAML document; use '-' for stdout (default)."
88+
89+-- | Exit with 'self'-stamped error message.
90+
91+abort :: String -> IO a
92+abort msg = die $ concat [ self, ": ", msg ]
93+
94+main :: IO ()
95+main = do
96+ Options{ optInput, optOutput } <- options
97+
98+ -- Read JSON.
99+ mval <- J.decode <$> maybe L.getContents L.readFile optInput
100+
101+ -- Write YAML.
102+ case mval of
103+ Nothing -> abort "Invalid input JSON"
104+ Just val -> case optOutput of
105+ Nothing -> S.putStr $ Y.encode (val :: Y.Value)
106+ Just f -> Y.encodeFile f val
yaml/exe/yaml2json.hsnew file+87
@@ -0,0 +1,87 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE NamedFieldPuns #-}
4+
5+import Data.Aeson (encode, Value)
6+import qualified Data.ByteString as S (getContents)
7+import qualified Data.ByteString.Lazy as L (putStr, writeFile)
8+#if !MIN_VERSION_base(4,11,0)
9+import Data.Semigroup (Semigroup(..))
10+#endif
11+import Data.Yaml (decodeFileEither, decodeEither')
12+import System.Exit (die)
13+
14+import Options.Applicative
15+ ( Parser
16+ , action, execParser, headerDoc, help, helper, info
17+ , long, metavar, short, strArgument, strOption, value
18+ )
19+import Options.Applicative.Help.Pretty
20+ ( vcat, pretty )
21+
22+import Common
23+ ( versionText, versionOption, numericVersionOption, dashToNothing )
24+
25+data Options = Options
26+ { optInput :: Maybe FilePath
27+ -- ^ 'Nothing' means @stdin@.
28+ , optOutput :: Maybe FilePath
29+ -- ^ 'Nothing' means @stdout@.
30+ }
31+
32+-- | Name of the executable.
33+
34+self :: String
35+self = "yaml2json"
36+
37+-- | Parse options; handle parse errors, @--help@, @--version@.
38+
39+options :: IO Options
40+options =
41+ execParser $
42+ info (helper <*> versionOption self <*> numericVersionOption <*> programOptions)
43+ (headerDoc hdoc)
44+
45+ where
46+ hdoc = Just $ vcat $ map pretty
47+ [ versionText self
48+ , "Convert YAML to JSON."
49+ ]
50+
51+ programOptions = Options <$> oInput <*> oOutput
52+
53+ oInput :: Parser (Maybe FilePath)
54+ oInput = dashToNothing <$> do
55+ strArgument
56+ $ metavar "IN"
57+ <> value "-"
58+ <> action "file"
59+ <> help "The input file containing the YAML document; use '-' for stdin (default)."
60+
61+ oOutput :: Parser (Maybe FilePath)
62+ oOutput = dashToNothing <$> do
63+ strOption
64+ $ long "output"
65+ <> short 'o'
66+ <> value "-"
67+ <> metavar "OUT"
68+ <> action "file"
69+ <> help "The file to hold the produced JSON document; use '-' for stdout (default)."
70+
71+
72+main :: IO ()
73+main = do
74+ Options{ optInput, optOutput } <- options
75+
76+ -- Input YAML.
77+ result <- case optInput of
78+ -- strict getContents will read in all of stdin at once
79+ Nothing -> decodeEither' <$> S.getContents
80+ Just f -> decodeFileEither f
81+
82+ -- Output JSON.
83+ case result of
84+ Left err -> die $ show err
85+ Right val -> do
86+ let json = encode (val :: Value)
87+ maybe L.putStr L.writeFile optOutput json
yaml/package.yamlnew file+113
@@ -0,0 +1,113 @@
1+name: yaml
2+version: 0.11.11.2
3+synopsis: Support for parsing and rendering YAML documents.
4+description: README and API documentation are available at <https://www.stackage.org/package/yaml>
5+category: Data
6+author: Michael Snoyman <michael@snoyman.com>, Anton Ageev <antage@gmail.com>,Kirill Simonov
7+maintainer: Michael Snoyman <michael@snoyman.com>
8+license: BSD3
9+github: snoyberg/yaml
10+stability: stable
11+
12+extra-source-files:
13+- test/largest-string.yaml
14+- test/json.yaml
15+- test/resources/foo.yaml
16+- test/resources/bar.yaml
17+- test/resources/baz.yaml
18+- test/resources/accent/foo.yaml
19+- test/resources/loop/foo.yaml
20+- test/resources/loop/bar.yaml
21+- test/resources/empty.yaml
22+- test/resources/empty2.yaml
23+- README.md
24+- ChangeLog.md
25+
26+flags:
27+ no-exe:
28+ description: don't install the yaml2json or json2yaml executables
29+ manual: false
30+ default: true
31+ no-examples:
32+ description: don't build the examples
33+ manual: false
34+ default: true
35+
36+dependencies:
37+- base >=4.14 && <5 # GHC 8.10.1 and later
38+- bytestring >=0.9.1.4
39+- transformers >=0.1
40+- mtl
41+- conduit >=1.2.8 && <1.4
42+- resourcet >=0.3 && <1.4
43+- aeson >=0.11
44+- containers
45+- unordered-containers
46+- vector
47+- text
48+- attoparsec >=0.11.3.0
49+- scientific >= 0.3 # for Data.ByteString.Builder.Scientific
50+- filepath
51+- directory
52+- template-haskell
53+- libyaml >=0.1 && <0.2
54+
55+ghc-options: -Wall -Wcompat
56+
57+library:
58+ other-extensions:
59+ - LambdaCase
60+ source-dirs: src
61+
62+executables:
63+ json2yaml:
64+ main: json2yaml.hs
65+ source-dirs: exe
66+ dependencies:
67+ - optparse-applicative
68+ - yaml
69+ when:
70+ - condition: flag(no-exe)
71+ buildable: false
72+ yaml2json:
73+ main: yaml2json.hs
74+ source-dirs: exe
75+ dependencies:
76+ - optparse-applicative
77+ - yaml
78+ when:
79+ - condition: flag(no-exe)
80+ buildable: false
81+ other-extensions:
82+ - CPP
83+ - LambdaCase
84+ - NamedFieldPuns
85+ examples:
86+ main: Main.hs
87+ source-dirs: examples
88+ when:
89+ - condition: flag(no-examples)
90+ then:
91+ buildable: false
92+ else:
93+ dependencies:
94+ - raw-strings-qq
95+ - yaml
96+
97+tests:
98+ spec:
99+ main: Spec.hs
100+ source-dirs: test
101+ ghc-options: "-with-rtsopts=-K1K"
102+ cpp-options: -DTEST
103+ dependencies:
104+ - hspec >=1.3
105+ - HUnit
106+ - yaml
107+ - directory
108+ - mockery
109+ - base-compat
110+ - temporary
111+ - raw-strings-qq
112+ build-tools:
113+ - hspec-discover
yaml/parser-test.hsnew file+22
@@ -0,0 +1,22 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+import Data.Yaml.Parser
3+import Data.Conduit
4+import Text.Libyaml
5+import Control.Applicative
6+import Data.Text (Text)
7+
8+data Person = Person
9+ { name :: !Text
10+ , age :: !Int
11+ }
12+ deriving (Show)
13+
14+instance FromYaml Person where
15+ fromYaml = withMapping "Person" $ \o -> Person
16+ <$> o .: "name"
17+ <*> o .: "age"
18+
19+main :: IO ()
20+main = do
21+ persons <- readYamlFile "/tmp/foo.yaml"
22+ mapM_ print (persons :: [Person])
yaml/src/Data/Yaml.hsnew file+292
@@ -0,0 +1,292 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE ScopedTypeVariables #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+
5+-- | Provides a high-level interface for processing YAML files.
6+--
7+-- This module reuses most of the infrastructure from the @aeson@ package.
8+-- This means that you can use all of the existing tools for JSON
9+-- processing for processing YAML files. As a result, much of the
10+-- documentation below mentions JSON; do not let that confuse you, it's
11+-- intentional.
12+--
13+-- For the most part, YAML content translates directly into JSON, and
14+-- therefore there is very little data loss. If you need to deal with YAML
15+-- more directly (e.g., directly deal with aliases), you should use the
16+-- "Text.Libyaml" module instead.
17+--
18+-- For documentation on the @aeson@ types, functions, classes, and
19+-- operators, please see the @Data.Aeson@ module of the @aeson@ package.
20+--
21+-- Look in the examples directory of the source repository for some initial
22+-- pointers on how to use this library.
23+
24+#if (defined (ghcjs_HOST_OS))
25+module Data.Yaml {-# WARNING "GHCJS is not supported yet (will break at runtime once called)." #-}
26+#else
27+module Data.Yaml
28+#endif
29+ ( -- * Encoding
30+ encode
31+ , encodeWith
32+ , encodeFile
33+ , encodeFileWith
34+ -- * Decoding
35+ , decodeEither'
36+ , decodeFileEither
37+ , decodeFileWithWarnings
38+ , decodeThrow
39+ , decodeFileThrow
40+ -- ** Decoding multiple documents
41+ --
42+ -- | For situations where we need to be able to parse multiple documents
43+ -- separated by `---` in a YAML stream, these functions decode a list of
44+ -- values rather than a single value.
45+ , decodeAllEither'
46+ , decodeAllFileEither
47+ , decodeAllFileWithWarnings
48+ , decodeAllThrow
49+ , decodeAllFileThrow
50+ -- ** More control over decoding
51+ , decodeHelper
52+ -- * Types
53+ , Value (..)
54+ , Parser
55+ , Object
56+ , Array
57+ , ParseException(..)
58+ , prettyPrintParseException
59+ , YamlException (..)
60+ , YamlMark (..)
61+ -- * Constructors and accessors
62+ , object
63+ , array
64+ , (.=)
65+ , (.:)
66+ , (.:?)
67+ , (.!=)
68+ -- ** With helpers (since 0.8.23)
69+ , withObject
70+ , withText
71+ , withArray
72+ , withScientific
73+ , withBool
74+ -- * Parsing
75+ , parseMonad
76+ , parseEither
77+ , parseMaybe
78+ -- * Classes
79+ , ToJSON (..)
80+ , FromJSON (..)
81+ -- * Custom encoding
82+ , isSpecialString
83+ , EncodeOptions
84+ , defaultEncodeOptions
85+ , defaultStringStyle
86+ , setStringStyle
87+ , setFormat
88+ , FormatOptions
89+ , defaultFormatOptions
90+ , setWidth
91+ -- * Deprecated
92+ , decode
93+ , decodeFile
94+ , decodeEither
95+ ) where
96+#if !MIN_VERSION_base(4,8,0)
97+import Control.Applicative((<$>))
98+#endif
99+import Control.Exception
100+import Control.Monad.IO.Class (MonadIO, liftIO)
101+import Control.Monad.Trans.Resource (MonadThrow, throwM)
102+import Data.Aeson
103+ ( Value (..), ToJSON (..), FromJSON (..), object
104+ , (.=) , (.:) , (.:?) , (.!=)
105+ , Object, Array
106+ , withObject, withText, withArray, withScientific, withBool
107+ )
108+import Data.Aeson.Types (parseMaybe, parseEither, Parser)
109+import Data.ByteString (ByteString)
110+import Data.Conduit ((.|), runConduitRes)
111+import qualified Data.Conduit.List as CL
112+import qualified Data.Vector as V
113+import System.IO.Unsafe (unsafePerformIO)
114+import Data.Text (Text)
115+
116+import Data.Yaml.Internal
117+import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile, encodeWith, encodeFileWith)
118+import qualified Text.Libyaml as Y
119+
120+-- | Set the string style in the encoded YAML. This is a function that decides
121+-- for each string the type of YAML string to output.
122+--
123+-- __WARNING__: You must ensure that special strings (like @"yes"@\/@"no"@\/@"null"@\/@"1234"@) are not encoded with the 'Plain' style, because
124+-- then they will be decoded as boolean, null or numeric values. You can use 'isSpecialString' to detect them.
125+--
126+-- By default, strings are encoded as follows:
127+--
128+-- * Any string containing a newline character uses the 'Literal' style
129+--
130+-- * Otherwise, any special string (see 'isSpecialString') uses 'SingleQuoted'
131+--
132+-- * Otherwise, use 'Plain'
133+--
134+-- @since 0.10.2.0
135+setStringStyle :: (Text -> ( Tag, Style )) -> EncodeOptions -> EncodeOptions
136+setStringStyle s opts = opts { encodeOptionsStringStyle = s }
137+
138+-- | Set the encoding formatting for the encoded YAML. By default, this is `defaultFormatOptions`.
139+--
140+-- @since 0.10.2.0
141+setFormat :: FormatOptions -> EncodeOptions -> EncodeOptions
142+setFormat f opts = opts { encodeOptionsFormat = f }
143+
144+-- |
145+-- @since 0.10.2.0
146+data EncodeOptions = EncodeOptions
147+ { encodeOptionsStringStyle :: Text -> ( Tag, Style )
148+ , encodeOptionsFormat :: FormatOptions
149+ }
150+
151+-- |
152+-- @since 0.10.2.0
153+defaultEncodeOptions :: EncodeOptions
154+defaultEncodeOptions = EncodeOptions
155+ { encodeOptionsStringStyle = defaultStringStyle
156+ , encodeOptionsFormat = defaultFormatOptions
157+ }
158+
159+-- | Encode a value into its YAML representation.
160+encode :: ToJSON a => a -> ByteString
161+encode = encodeWith defaultEncodeOptions
162+
163+-- | Encode a value into its YAML representation with custom styling.
164+--
165+-- @since 0.10.2.0
166+encodeWith :: ToJSON a => EncodeOptions -> a -> ByteString
167+encodeWith opts obj = unsafePerformIO $ runConduitRes
168+ $ CL.sourceList (objToStream (encodeOptionsStringStyle opts) $ toJSON obj)
169+ .| Y.encodeWith (encodeOptionsFormat opts)
170+
171+-- | Encode a value into its YAML representation and save to the given file.
172+encodeFile :: ToJSON a => FilePath -> a -> IO ()
173+encodeFile = encodeFileWith defaultEncodeOptions
174+
175+-- | Encode a value into its YAML representation with custom styling and save to the given file.
176+--
177+-- @since 0.10.2.0
178+encodeFileWith :: ToJSON a => EncodeOptions -> FilePath -> a -> IO ()
179+encodeFileWith opts fp obj = runConduitRes
180+ $ CL.sourceList (objToStream (encodeOptionsStringStyle opts) $ toJSON obj)
181+ .| Y.encodeFileWith (encodeOptionsFormat opts) fp
182+
183+decode :: FromJSON a
184+ => ByteString
185+ -> Maybe a
186+decode bs = unsafePerformIO
187+ $ either (const Nothing) snd
188+ <$> decodeHelper_ (Y.decode bs)
189+{-# DEPRECATED decode "Please use decodeEither or decodeThrow, which provide information on how the decode failed" #-}
190+
191+decodeFile :: FromJSON a
192+ => FilePath
193+ -> IO (Maybe a)
194+decodeFile fp = (fmap snd <$> decodeHelper (Y.decodeFile fp)) >>= either throwIO (return . either (const Nothing) id)
195+{-# DEPRECATED decodeFile "Please use decodeFileEither, which does not confused type-directed and runtime exceptions." #-}
196+
197+-- | A version of 'decodeFile' which should not throw runtime exceptions.
198+--
199+-- @since 0.8.4
200+decodeFileEither
201+ :: FromJSON a
202+ => FilePath
203+ -> IO (Either ParseException a)
204+decodeFileEither = fmap (fmap snd) . decodeFileWithWarnings
205+
206+-- | Like `decodeFileEither`, but decode multiple documents.
207+--
208+-- @since 0.11.5.0
209+decodeAllFileEither
210+ :: FromJSON a
211+ => FilePath
212+ -> IO (Either ParseException [a])
213+decodeAllFileEither = fmap (fmap snd) . decodeAllFileWithWarnings
214+
215+-- | A version of `decodeFileEither` that returns warnings along with the parse
216+-- result.
217+--
218+-- @since 0.10.0
219+decodeFileWithWarnings
220+ :: FromJSON a
221+ => FilePath
222+ -> IO (Either ParseException ([Warning], a))
223+decodeFileWithWarnings = decodeHelper_ . Y.decodeFile
224+
225+-- | Like `decodeFileWithWarnings`, but decode multiple documents.
226+--
227+-- @since 0.11.5.0
228+decodeAllFileWithWarnings
229+ :: FromJSON a
230+ => FilePath
231+ -> IO (Either ParseException ([Warning], [a]))
232+decodeAllFileWithWarnings = decodeAllHelper_ . Y.decodeFile
233+
234+decodeEither :: FromJSON a => ByteString -> Either String a
235+decodeEither bs = unsafePerformIO
236+ $ either (Left . prettyPrintParseException) id
237+ <$> (fmap snd <$> decodeHelper (Y.decode bs))
238+{-# DEPRECATED decodeEither "Please use decodeEither' or decodeThrow, which provide more useful failures" #-}
239+
240+-- | More helpful version of 'decodeEither' which returns the 'YamlException'.
241+--
242+-- @since 0.8.3
243+decodeEither' :: FromJSON a => ByteString -> Either ParseException a
244+decodeEither' = either Left (either (Left . AesonException) Right)
245+ . unsafePerformIO
246+ . fmap (fmap snd) . decodeHelper
247+ . Y.decode
248+
249+-- | Like 'decodeEither'', but decode multiple documents.
250+--
251+-- @since 0.11.5.0
252+decodeAllEither' :: FromJSON a => ByteString -> Either ParseException [a]
253+decodeAllEither' = either Left (either (Left . AesonException) Right)
254+ . unsafePerformIO
255+ . fmap (fmap snd) . decodeAllHelper
256+ . Y.decode
257+
258+-- | A version of 'decodeEither'' lifted to MonadThrow
259+--
260+-- @since 0.8.31
261+decodeThrow :: (MonadThrow m, FromJSON a) => ByteString -> m a
262+decodeThrow = either throwM return . decodeEither'
263+
264+-- | Like `decodeThrow`, but decode multiple documents.
265+--
266+-- @since 0.11.5.0
267+decodeAllThrow :: (MonadThrow m, FromJSON a) => ByteString -> m [a]
268+decodeAllThrow = either throwM return . decodeAllEither'
269+
270+-- | A version of 'decodeFileEither' lifted to MonadIO
271+--
272+-- @since 0.8.31
273+decodeFileThrow :: (MonadIO m, FromJSON a) => FilePath -> m a
274+decodeFileThrow f = liftIO $ decodeFileEither f >>= either throwIO return
275+
276+-- | Like `decodeFileThrow`, but decode multiple documents.
277+--
278+-- @since 0.11.5.0
279+decodeAllFileThrow :: (MonadIO m, FromJSON a) => FilePath -> m [a]
280+decodeAllFileThrow f = liftIO $ decodeAllFileEither f >>= either throwIO return
281+
282+-- | Construct a new 'Value' from a list of 'Value's.
283+array :: [Value] -> Value
284+array = Array . V.fromList
285+
286+#if MIN_VERSION_base(4, 13, 0)
287+parseMonad :: MonadFail m => (a -> Parser b) -> a -> m b
288+#else
289+parseMonad :: Monad m => (a -> Parser b) -> a -> m b
290+#endif
291+parseMonad p = either fail return . parseEither p
292+{-# DEPRECATED parseMonad "With the MonadFail split, this function is going to be removed in the future. Please migrate to parseEither." #-}
yaml/src/Data/Yaml/Aeson.hsnew file+7
@@ -0,0 +1,7 @@
1+-- | Just a re-export of @Data.Yaml@. In the future, this will be the canonical
2+-- name for that module\'s contents.
3+module Data.Yaml.Aeson
4+ ( module Data.Yaml
5+ ) where
6+
7+import Data.Yaml
yaml/src/Data/Yaml/Builder.hsnew file+240
@@ -0,0 +1,240 @@
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.
6+module 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+
41+import Prelude hiding (null)
42+
43+#if MIN_VERSION_aeson(1,0,0)
44+import Data.Aeson.Text (encodeToTextBuilder)
45+#else
46+import Data.Aeson.Encode (encodeToTextBuilder)
47+#endif
48+import Data.Aeson.Types (Value(..))
49+import Data.ByteString (ByteString)
50+import qualified Data.ByteString.Char8 as S8
51+import Data.Conduit
52+import Data.Scientific (Scientific)
53+import Data.Text (Text, unpack)
54+import qualified Data.Text as T
55+import qualified Data.Text.Encoding as TE
56+import qualified Data.Text.Lazy as TL
57+import Data.Text.Lazy.Builder (toLazyText)
58+import System.IO.Unsafe (unsafePerformIO)
59+
60+import Data.Yaml.Internal
61+import Text.Libyaml
62+
63+(.=) :: ToYaml a => Text -> a -> (Text, YamlBuilder)
64+k .= v = (k, toYaml v)
65+
66+newtype YamlBuilder = YamlBuilder { unYamlBuilder :: [Event] -> [Event] }
67+
68+class ToYaml a where
69+ toYaml :: a -> YamlBuilder
70+instance ToYaml YamlBuilder where
71+ toYaml = id
72+instance (ToYaml a, ToYaml b) => ToYaml [(a, b)] where
73+ toYaml = mappingComplex . map (\(k, v) -> (toYaml k, toYaml v))
74+instance ToYaml a => ToYaml [a] where
75+ toYaml = array . map toYaml
76+instance ToYaml Text where
77+ toYaml = string
78+instance {-# OVERLAPPING #-} ToYaml String where
79+ toYaml = string . T.pack
80+instance ToYaml Int where
81+ toYaml i = YamlBuilder (EventScalar (S8.pack $ show i) NoTag PlainNoTag Nothing:)
82+instance ToYaml Double where
83+ toYaml i = YamlBuilder (EventScalar (S8.pack $ show i) NoTag PlainNoTag Nothing:)
84+instance ToYaml Scientific where
85+ toYaml = scientific
86+instance ToYaml Bool where
87+ toYaml = bool
88+instance ToYaml a => ToYaml (Maybe a) where
89+ toYaml = maybe null toYaml
90+
91+-- |
92+-- @since 0.10.3.0
93+maybeNamedMapping :: Maybe Text -> [(Text, YamlBuilder)] -> YamlBuilder
94+maybeNamedMapping anchor pairs = maybeNamedMappingComplex anchor complexPairs
95+ where
96+ complexPairs = map (\(k, v) -> (string k, v)) pairs
97+
98+-- |
99+-- @since 0.8.7
100+mapping :: [(Text, YamlBuilder)] -> YamlBuilder
101+mapping = maybeNamedMapping Nothing
102+
103+-- |
104+-- @since 0.10.3.0
105+namedMapping :: Text -> [(Text, YamlBuilder)] -> YamlBuilder
106+namedMapping name = maybeNamedMapping $ Just name
107+
108+-- |
109+-- @since 0.11.2.0
110+maybeNamedMappingComplex :: Maybe Text -> [(YamlBuilder, YamlBuilder)] -> YamlBuilder
111+maybeNamedMappingComplex 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
118+mappingComplex :: [(YamlBuilder, YamlBuilder)] -> YamlBuilder
119+mappingComplex = maybeNamedMappingComplex Nothing
120+
121+-- |
122+-- @since 0.11.2.0
123+namedMappingComplex :: Text -> [(YamlBuilder, YamlBuilder)] -> YamlBuilder
124+namedMappingComplex name = maybeNamedMappingComplex $ Just name
125+
126+-- |
127+-- @since 0.10.3.0
128+maybeNamedArray :: Maybe Text -> [YamlBuilder] -> YamlBuilder
129+maybeNamedArray 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
136+array :: [YamlBuilder] -> YamlBuilder
137+array = maybeNamedArray Nothing
138+
139+-- |
140+-- @since 0.10.3.0
141+namedArray :: Text -> [YamlBuilder] -> YamlBuilder
142+namedArray name = maybeNamedArray $ Just name
143+
144+-- |
145+-- @since 0.10.3.0
146+maybeNamedString :: Maybe Text -> Text -> YamlBuilder
147+maybeNamedString anchor s = YamlBuilder (stringScalar defaultStringStyle anchor s :)
148+
149+-- |
150+-- @since 0.8.7
151+string :: Text -> YamlBuilder
152+string = maybeNamedString Nothing
153+
154+-- |
155+-- @since 0.10.3.0
156+namedString :: Text -> Text -> YamlBuilder
157+namedString name = maybeNamedString $ Just name
158+
159+-- Use aeson's implementation which gets rid of annoying decimal points
160+-- |
161+-- @since 0.10.3.0
162+maybeNamedScientific :: Maybe Text -> Scientific -> YamlBuilder
163+maybeNamedScientific anchor n = YamlBuilder (EventScalar (TE.encodeUtf8 $ TL.toStrict $ toLazyText $ encodeToTextBuilder (Number n)) NoTag PlainNoTag (unpack <$> anchor) :)
164+
165+-- |
166+-- @since 0.8.13
167+scientific :: Scientific -> YamlBuilder
168+scientific = maybeNamedScientific Nothing
169+
170+-- |
171+-- @since 0.10.3.0
172+namedScientific :: Text -> Scientific -> YamlBuilder
173+namedScientific name = maybeNamedScientific $ Just name
174+
175+-- |
176+-- @since 0.8.13
177+{-# DEPRECATED number "Use scientific" #-}
178+number :: Scientific -> YamlBuilder
179+number = scientific
180+
181+-- |
182+-- @since 0.10.3.0
183+maybeNamedBool :: Maybe Text -> Bool -> YamlBuilder
184+maybeNamedBool anchor True = YamlBuilder (EventScalar "true" NoTag PlainNoTag (unpack <$> anchor) :)
185+maybeNamedBool anchor False = YamlBuilder (EventScalar "false" NoTag PlainNoTag (unpack <$> anchor) :)
186+
187+-- |
188+-- @since 0.8.13
189+bool :: Bool -> YamlBuilder
190+bool = maybeNamedBool Nothing
191+
192+-- |
193+-- @since 0.10.3.0
194+namedBool :: Text -> Bool -> YamlBuilder
195+namedBool name = maybeNamedBool $ Just name
196+
197+-- |
198+-- @since 0.10.3.0
199+maybeNamedNull :: Maybe Text -> YamlBuilder
200+maybeNamedNull anchor = YamlBuilder (EventScalar "null" NoTag PlainNoTag (unpack <$> anchor) :)
201+
202+-- |
203+-- @since 0.8.13
204+null :: YamlBuilder
205+null = maybeNamedNull Nothing
206+
207+-- |
208+-- @since 0.10.3.0
209+namedNull :: Text -> YamlBuilder
210+namedNull name = maybeNamedNull $ Just name
211+
212+-- |
213+-- @since 0.10.3.0
214+alias :: Text -> YamlBuilder
215+alias anchor = YamlBuilder (EventAlias (unpack anchor) :)
216+
217+toEvents :: YamlBuilder -> [Event]
218+toEvents (YamlBuilder front) =
219+ EventStreamStart : EventDocumentStart : front [EventDocumentEnd, EventStreamEnd]
220+
221+toSource :: (Monad m, ToYaml a) => a -> ConduitM i Event m ()
222+toSource = mapM_ yield . toEvents . toYaml
223+
224+-- |
225+-- @since 0.8.7
226+toByteString :: ToYaml a => a -> ByteString
227+toByteString = toByteStringWith defaultFormatOptions
228+
229+-- |
230+-- @since 0.10.2.0
231+toByteStringWith :: ToYaml a => FormatOptions -> a -> ByteString
232+toByteStringWith opts yb = unsafePerformIO $ runConduitRes $ toSource yb .| encodeWith opts
233+
234+writeYamlFile :: ToYaml a => FilePath -> a -> IO ()
235+writeYamlFile = writeYamlFileWith defaultFormatOptions
236+
237+-- |
238+-- @since 0.10.2.0
239+writeYamlFileWith :: ToYaml a => FormatOptions -> FilePath -> a -> IO ()
240+writeYamlFileWith opts fp yb = runConduitRes $ toSource yb .| encodeFileWith opts fp
yaml/src/Data/Yaml/Config.hsnew file+234
@@ -0,0 +1,234 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+-- | Functionality for using YAML as configuration files
4+--
5+-- In particular, merging environment variables with yaml values
6+--
7+-- 'loadYamlSettings' is a high-level API for loading YAML and merging environment variables.
8+-- A yaml value of @_env:ENV_VAR:default@ or just @_env:ENV_VAR@ will lookup the environment variable @ENV_VAR@.
9+--
10+-- On a historical note, this code was taken directly from the yesod web framework's configuration module.
11+module Data.Yaml.Config
12+ ( -- * High-level
13+ loadYamlSettings
14+ , loadYamlSettingsArgs
15+ -- ** EnvUsage
16+ , EnvUsage
17+ , ignoreEnv
18+ , useEnv
19+ , requireEnv
20+ , useCustomEnv
21+ , requireCustomEnv
22+ -- * Lower level
23+ , applyCurrentEnv
24+ , getCurrentEnv
25+ , applyEnvValue
26+ ) where
27+
28+
29+#if __GLASGOW_HASKELL__ < 710
30+import Control.Applicative ((<$>))
31+import Data.Monoid
32+#endif
33+import Data.Semigroup
34+import Data.List.NonEmpty (nonEmpty)
35+import Data.Aeson
36+#if MIN_VERSION_aeson(2,0,0)
37+import qualified Data.Aeson.Key as K
38+import qualified Data.Aeson.KeyMap as H
39+import Data.Aeson.KeyMap (KeyMap)
40+#else
41+import qualified Data.HashMap.Strict as H
42+#endif
43+import Data.Text (Text, pack)
44+import System.Environment (getArgs, getEnvironment)
45+import Control.Arrow ((***))
46+import Control.Monad (forM)
47+import Control.Exception (throwIO)
48+import Data.Text.Encoding (encodeUtf8)
49+import qualified Data.Yaml as Y
50+import qualified Data.Yaml.Include as YI
51+import Data.Maybe (fromMaybe)
52+import qualified Data.Text as T
53+
54+#if MIN_VERSION_aeson(2,0,0)
55+fromText :: T.Text -> Key
56+fromText = K.fromText
57+#else
58+fromText :: T.Text -> T.Text
59+fromText = id
60+
61+type KeyMap a = H.HashMap T.Text a
62+#endif
63+
64+newtype MergedValue = MergedValue { getMergedValue :: Value }
65+
66+instance Semigroup MergedValue where
67+ MergedValue x <> MergedValue y = MergedValue $ mergeValues x y
68+
69+-- | Left biased
70+mergeValues :: Value -> Value -> Value
71+mergeValues (Object x) (Object y) = Object $ H.unionWith mergeValues x y
72+mergeValues x _ = x
73+
74+-- | Override environment variable placeholders in the given @Value@ with
75+-- values from the environment.
76+--
77+-- If the first argument is @True@, then all placeholders _must_ be provided by
78+-- the actual environment. Otherwise, default values from the @Value@ will be
79+-- used.
80+--
81+-- @since 0.8.16
82+applyEnvValue :: Bool -- ^ require an environment variable to be present?
83+ -> KeyMap Text -> Value -> Value
84+applyEnvValue requireEnv' env =
85+ goV
86+ where
87+ goV (Object o) = Object $ goV <$> o
88+ goV (Array a) = Array (goV <$> a)
89+ goV (String t1) = fromMaybe (String t1) $ do
90+ t2 <- T.stripPrefix "_env:" t1
91+ let (name, t3) = T.break (== ':') t2
92+ mdef = fmap parseValue $ T.stripPrefix ":" t3
93+ Just $ case H.lookup (fromText name) env of
94+ Just val ->
95+ -- If the default value parses as a String, we treat the
96+ -- environment variable as a raw value and do not parse it.
97+ -- This means that things like numeric passwords just work.
98+ -- However, for originally numerical or boolean values (e.g.,
99+ -- port numbers), we still perform a normal YAML parse.
100+ --
101+ -- For details, see:
102+ -- https://github.com/yesodweb/yesod/issues/1061
103+ case mdef of
104+ Just (String _) -> String val
105+ _ -> parseValue val
106+ Nothing ->
107+ case mdef of
108+ Just val | not requireEnv' -> val
109+ _ -> Null
110+ goV v = v
111+
112+ parseValue val = either
113+ (const (String val))
114+ id
115+ (Y.decodeThrow $ encodeUtf8 val)
116+
117+-- | Get the actual environment as a @HashMap@ from @Text@ to @Text@.
118+--
119+-- @since 0.8.16
120+getCurrentEnv :: IO (KeyMap Text)
121+getCurrentEnv = fmap (H.fromList . map (fromText . pack *** pack)) getEnvironment
122+
123+-- | A convenience wrapper around 'applyEnvValue' and 'getCurrentEnv'
124+--
125+-- @since 0.8.16
126+applyCurrentEnv :: Bool -- ^ require an environment variable to be present?
127+ -> Value -> IO Value
128+applyCurrentEnv requireEnv' orig = flip (applyEnvValue requireEnv') orig <$> getCurrentEnv
129+
130+-- | Defines how we want to use the environment variables when loading a config
131+-- file. Use the smart constructors provided by this module.
132+--
133+-- @since 0.8.16
134+data EnvUsage = IgnoreEnv
135+ | UseEnv
136+ | RequireEnv
137+ | UseCustomEnv (KeyMap Text)
138+ | RequireCustomEnv (KeyMap Text)
139+
140+-- | Do not use any environment variables, instead relying on defaults values
141+-- in the config file.
142+--
143+-- @since 0.8.16
144+ignoreEnv :: EnvUsage
145+ignoreEnv = IgnoreEnv
146+
147+-- | Use environment variables when available, otherwise use defaults.
148+--
149+-- @since 0.8.16
150+useEnv :: EnvUsage
151+useEnv = UseEnv
152+
153+-- | Do not use default values from the config file, but instead take all
154+-- overrides from the environment. If a value is missing, loading the file will
155+-- throw an exception.
156+--
157+-- @since 0.8.16
158+requireEnv :: EnvUsage
159+requireEnv = RequireEnv
160+
161+-- | Same as 'useEnv', but instead of the actual environment, use the provided
162+-- @HashMap@ as the environment.
163+--
164+-- @since 0.8.16
165+useCustomEnv :: KeyMap Text -> EnvUsage
166+useCustomEnv = UseCustomEnv
167+
168+-- | Same as 'requireEnv', but instead of the actual environment, use the
169+-- provided @HashMap@ as the environment.
170+--
171+-- @since 0.8.16
172+requireCustomEnv :: KeyMap Text -> EnvUsage
173+requireCustomEnv = RequireCustomEnv
174+
175+-- | Load the settings from the following three sources:
176+--
177+-- * Run time config files
178+--
179+-- * Run time environment variables
180+--
181+-- * The default compile time config file
182+--
183+-- For example, to load up settings from @config/foo.yaml@ and allow overriding
184+-- from the actual environment, you can use:
185+--
186+-- > loadYamlSettings ["config/foo.yaml"] [] useEnv
187+--
188+-- Alternatively you can configure settings through the Yaml @Value@ directly in Haskell.
189+-- For example, to load up settings from only from environment variables, you can use:
190+--
191+-- > loadYamlSettings [] [object ["connectionString" .= ("_env:DATABASE_URL" :: String)]] requireEnv
192+--
193+-- @since 0.8.16
194+loadYamlSettings
195+ :: FromJSON settings
196+ => [FilePath] -- ^ run time config files to use, earlier files have precedence
197+ -> [Value] -- ^ any other values to use, usually from compile time config. overridden by files
198+ -> EnvUsage
199+ -> IO settings
200+loadYamlSettings runTimeFiles compileValues envUsage = do
201+ runValues <- forM runTimeFiles $ \fp -> do
202+ eres <- YI.decodeFileEither fp
203+ case eres of
204+ Left e -> throwIO (Y.LoadSettingsException fp e)
205+ Right value -> return value
206+
207+ value' <-
208+ case nonEmpty $ map MergedValue $ runValues ++ compileValues of
209+ Nothing -> error "loadYamlSettings: No configuration provided"
210+ Just ne -> return $ getMergedValue $ sconcat ne
211+ value <-
212+ case envUsage of
213+ IgnoreEnv -> return $ applyEnvValue False mempty value'
214+ UseEnv -> applyCurrentEnv False value'
215+ RequireEnv -> applyCurrentEnv True value'
216+ UseCustomEnv env -> return $ applyEnvValue False env value'
217+ RequireCustomEnv env -> return $ applyEnvValue True env value'
218+
219+ case Y.parseEither parseJSON value of
220+ Left s -> error $ "Could not convert to expected type: " ++ s
221+ Right settings -> return settings
222+
223+-- | Same as @loadYamlSettings@, but get the list of runtime config files from
224+-- the command line arguments.
225+--
226+-- @since 0.8.17
227+loadYamlSettingsArgs
228+ :: FromJSON settings
229+ => [Value] -- ^ any other values to use, usually from compile time config. overridden by files
230+ -> EnvUsage -- ^ use environment variables
231+ -> IO settings
232+loadYamlSettingsArgs values env = do
233+ args <- getArgs
234+ loadYamlSettings args values env
yaml/src/Data/Yaml/Include.hsnew file+94
@@ -0,0 +1,94 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE RankNTypes #-}
3+module Data.Yaml.Include (
4+ decodeFile
5+, decodeFileEither
6+, decodeFileWithWarnings
7+) where
8+
9+#if !MIN_VERSION_directory(1, 2, 3)
10+import Control.Exception (handleJust)
11+import Control.Monad (guard)
12+import System.IO.Error (ioeGetFileName, ioeGetLocation, isDoesNotExistError)
13+#endif
14+
15+import Control.Exception (throwIO)
16+import Control.Monad (when)
17+import Control.Monad.IO.Class (liftIO)
18+import Control.Monad.Trans.Resource (MonadResource)
19+import Data.Aeson (FromJSON)
20+import Data.Conduit
21+import qualified Data.Conduit.List as CL
22+import Data.Text (unpack)
23+import Data.Text.Encoding (decodeUtf8)
24+import System.Directory
25+import System.FilePath
26+
27+import Data.Yaml.Internal (ParseException(..), Warning(..), decodeHelper_, decodeHelper)
28+import Text.Libyaml hiding (decodeFile)
29+import qualified Text.Libyaml as Y
30+
31+eventsFromFile
32+ :: MonadResource m
33+ => FilePath
34+ -> ConduitM i Event m ()
35+eventsFromFile = go []
36+ where
37+ go :: MonadResource m => [FilePath] -> FilePath -> ConduitM i Event m ()
38+ go seen fp = do
39+ cfp <- liftIO $ handleNotFound $ canonicalizePath fp
40+ when (cfp `elem` seen) $ do
41+ liftIO $ throwIO CyclicIncludes
42+ Y.decodeFile cfp .| do
43+ awaitForever $ \event -> case event of
44+ EventScalar f (UriTag "!include") _ _ -> do
45+ let includeFile = takeDirectory cfp </> unpack (decodeUtf8 f)
46+ go (cfp : seen) includeFile .| CL.filter (`notElem` irrelevantEvents)
47+ _ -> yield event
48+
49+ irrelevantEvents = [EventStreamStart, EventDocumentStart, EventDocumentEnd, EventStreamEnd]
50+
51+#if !MIN_VERSION_directory(1, 2, 3)
52+ handleNotFound = handleJust
53+ (\e -> do
54+ guard (isDoesNotExistError e)
55+ guard (ioeGetLocation e == "canonicalizePath")
56+ ioeGetFileName e)
57+ (throwIO . YamlException . ("Yaml file not found: " ++))
58+#else
59+ handleNotFound = id
60+#endif
61+
62+-- | Like `Data.Yaml.decodeFile` but with support for relative and absolute
63+-- includes.
64+--
65+-- The syntax for includes follows the form:
66+--
67+-- > somekey: !include ./somefile.yaml
68+decodeFile
69+ :: FromJSON a
70+ => FilePath
71+ -> IO (Maybe a)
72+decodeFile fp = (fmap snd <$> decodeHelper (eventsFromFile fp)) >>= either throwIO (return . either (const Nothing) id)
73+
74+-- | Like `Data.Yaml.decodeFileEither` but with support for relative and
75+-- absolute includes.
76+--
77+-- The syntax for includes follows the form:
78+--
79+-- > somekey: !include ./somefile.yaml
80+decodeFileEither
81+ :: FromJSON a
82+ => FilePath
83+ -> IO (Either ParseException a)
84+decodeFileEither = fmap (fmap snd) . decodeFileWithWarnings
85+
86+-- | A version of `decodeFileEither` that returns warnings along with the parse
87+-- result.
88+--
89+-- @since 0.10.0
90+decodeFileWithWarnings
91+ :: FromJSON a
92+ => FilePath
93+ -> IO (Either ParseException ([Warning], a))
94+decodeFileWithWarnings = decodeHelper_ . eventsFromFile
yaml/src/Data/Yaml/Internal.hsnew file+469
@@ -0,0 +1,469 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE PatternGuards #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE BangPatterns #-}
6+module Data.Yaml.Internal
7+ (
8+ ParseException(..)
9+ , prettyPrintParseException
10+ , Warning(..)
11+ , parse
12+ , Parse
13+ , decodeHelper
14+ , decodeHelper_
15+ , decodeAllHelper
16+ , decodeAllHelper_
17+ , textToScientific
18+ , stringScalar
19+ , StringStyle
20+ , defaultStringStyle
21+ , isSpecialString
22+ , specialStrings
23+ , isNumeric
24+ , objToStream
25+ , objToEvents
26+ ) where
27+
28+#if !MIN_VERSION_base(4,8,0)
29+import Control.Applicative ((<$>), Applicative(..))
30+#endif
31+import Control.Applicative ((<|>))
32+import Control.Exception
33+import Control.Monad (when, unless)
34+import Control.Monad.Trans.Resource (ResourceT, runResourceT)
35+import Control.Monad.State.Strict
36+import Control.Monad.Reader
37+#if MIN_VERSION_aeson(2,1,2)
38+import Data.Aeson hiding (AesonException)
39+#else
40+import Data.Aeson
41+#endif
42+#if MIN_VERSION_aeson(2,0,0)
43+import qualified Data.Aeson.Key as K
44+import qualified Data.Aeson.KeyMap as M
45+import Data.Aeson.KeyMap (KeyMap)
46+#else
47+import qualified Data.HashMap.Strict as M
48+#endif
49+#if MIN_VERSION_aeson(2,2,0)
50+import Data.Aeson.Types hiding (AesonException, parse)
51+#else
52+import Data.Aeson.Types hiding (parse)
53+import Data.Aeson.Internal (JSONPath, JSONPathElement(..), formatError)
54+#endif
55+import qualified Data.Attoparsec.Text as Atto
56+import Data.Bits (shiftL, (.|.))
57+import Data.ByteString (ByteString)
58+import qualified Data.ByteString.Builder as BB
59+import qualified Data.ByteString.Lazy as BL
60+import Data.ByteString.Builder.Scientific (scientificBuilder)
61+import Data.Char (toUpper, ord)
62+import qualified Data.List as List
63+import Data.Conduit ((.|), ConduitM, runConduit)
64+import qualified Data.Conduit.List as CL
65+import qualified Data.HashSet as HashSet
66+import Data.Map (Map)
67+import qualified Data.Map as Map
68+import Data.Set (Set)
69+import qualified Data.Set as Set
70+import Data.Scientific (Scientific, base10Exponent, coefficient)
71+import Data.Text (Text)
72+import qualified Data.Text as T
73+import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
74+import Data.Text.Encoding.Error (lenientDecode)
75+import Data.Typeable
76+import qualified Data.Vector as V
77+import Data.Void (Void)
78+
79+import qualified Text.Libyaml as Y
80+import Text.Libyaml hiding (encode, decode, encodeFile, decodeFile)
81+
82+#if MIN_VERSION_aeson(2,0,0)
83+fromText :: T.Text -> K.Key
84+fromText = K.fromText
85+
86+toText :: K.Key -> T.Text
87+toText = K.toText
88+#else
89+fromText :: T.Text -> T.Text
90+fromText = id
91+
92+toText :: Key -> T.Text
93+toText = id
94+
95+type KeyMap a = M.HashMap Text a
96+type Key = Text
97+#endif
98+
99+data ParseException = NonScalarKey
100+ | UnknownAlias { _anchorName :: Y.AnchorName }
101+ | UnexpectedEvent { _received :: Maybe Event
102+ , _expected :: Maybe Event
103+ }
104+ | InvalidYaml (Maybe YamlException)
105+ | MultipleDocuments
106+ | AesonException String
107+ | OtherParseException SomeException
108+ | NonStringKey JSONPath
109+ | NonStringKeyAlias Y.AnchorName Value
110+ | CyclicIncludes
111+ | LoadSettingsException FilePath ParseException
112+ deriving (Show, Typeable)
113+
114+instance Exception ParseException where
115+#if MIN_VERSION_base(4, 8, 0)
116+ displayException = prettyPrintParseException
117+#endif
118+
119+-- | Alternative to 'show' to display a 'ParseException' on the screen.
120+-- Instead of displaying the data constructors applied to their arguments,
121+-- a more textual output is returned. For example, instead of printing:
122+--
123+-- > InvalidYaml (Just (YamlParseException {yamlProblem = "did not find expected ',' or '}'", yamlContext = "while parsing a flow mapping", yamlProblemMark = YamlMark {yamlIndex = 42, yamlLine = 2, yamlColumn = 12}})))
124+--
125+-- It looks more pleasant to print:
126+--
127+-- > YAML parse exception at line 2, column 12,
128+-- > while parsing a flow mapping:
129+-- > did not find expected ',' or '}'
130+--
131+-- Since 0.8.11
132+prettyPrintParseException :: ParseException -> String
133+prettyPrintParseException pe = case pe of
134+ NonScalarKey -> "Non scalar key"
135+ UnknownAlias anchor -> "Unknown alias `" ++ anchor ++ "`"
136+ UnexpectedEvent { _expected = mbExpected, _received = mbUnexpected } -> unlines
137+ [ "Unexpected event: expected"
138+ , " " ++ show mbExpected
139+ , "but received"
140+ , " " ++ show mbUnexpected
141+ ]
142+ InvalidYaml mbYamlError -> case mbYamlError of
143+ Nothing -> "Unspecified YAML error"
144+ Just yamlError -> case yamlError of
145+ YamlException s -> "YAML exception:\n" ++ s
146+ YamlParseException problem context mark -> concat
147+ [ "YAML parse exception at line " ++ show (yamlLine mark) ++
148+ ", column " ++ show (yamlColumn mark)
149+ , case context of
150+ "" -> ":\n"
151+ -- The context seems to include a leading "while" or similar.
152+ _ -> ",\n" ++ context ++ ":\n"
153+ , problem
154+ ]
155+ MultipleDocuments -> "Multiple YAML documents encountered"
156+ AesonException s -> "Aeson exception:\n" ++ s
157+ OtherParseException exc -> "Generic parse exception:\n" ++ show exc
158+ NonStringKey path -> formatError path "Non-string keys are not supported"
159+ NonStringKeyAlias anchor value -> unlines
160+ [ "Non-string key alias:"
161+ , " Anchor name: " ++ anchor
162+ , " Value: " ++ show value
163+ ]
164+ CyclicIncludes -> "Cyclic includes"
165+ LoadSettingsException fp exc -> "Could not parse file as YAML: " ++ fp ++ "\n" ++ prettyPrintParseException exc
166+
167+defineAnchor :: Value -> String -> ReaderT JSONPath (ConduitM e o Parse) ()
168+defineAnchor value name = modify (modifyAnchors $ Map.insert name value)
169+ where
170+ modifyAnchors :: (Map String Value -> Map String Value) -> ParseState -> ParseState
171+ modifyAnchors f st = st {parseStateAnchors = f (parseStateAnchors st)}
172+
173+lookupAnchor :: String -> ReaderT JSONPath (ConduitM e o Parse) (Maybe Value)
174+lookupAnchor name = gets (Map.lookup name . parseStateAnchors)
175+
176+data Warning = DuplicateKey JSONPath
177+ deriving (Eq, Show)
178+
179+addWarning :: Warning -> ReaderT JSONPath (ConduitM e o Parse) ()
180+addWarning w = modify (modifyWarnings (w :))
181+ where
182+ modifyWarnings :: ([Warning] -> [Warning]) -> ParseState -> ParseState
183+ modifyWarnings f st = st {parseStateWarnings = f (parseStateWarnings st)}
184+
185+data ParseState = ParseState {
186+ parseStateAnchors :: Map String Value
187+, parseStateWarnings :: [Warning]
188+}
189+
190+type Parse = StateT ParseState (ResourceT IO)
191+
192+requireEvent :: Event -> ReaderT JSONPath (ConduitM Event o Parse) ()
193+requireEvent e = do
194+ f <- lift CL.head
195+ unless (f == Just e) $ liftIO $ throwIO $ UnexpectedEvent f $ Just e
196+
197+parse :: ReaderT JSONPath (ConduitM Event o Parse) Value
198+parse = do
199+ docs <- parseAll
200+ case docs of
201+ [] -> return Null
202+ [doc] -> return doc
203+ _ -> liftIO $ throwIO MultipleDocuments
204+
205+parseAll :: ReaderT JSONPath (ConduitM Event o Parse) [Value]
206+parseAll = do
207+ streamStart <- lift CL.head
208+ case streamStart of
209+ Nothing ->
210+ -- empty string input
211+ return []
212+ Just EventStreamStart ->
213+ -- empty file input, comment only string/file input
214+ parseDocs
215+ _ -> missed streamStart
216+ where
217+ parseDocs = do
218+ documentStart <- lift CL.head
219+ case documentStart of
220+ Just EventStreamEnd -> return []
221+ Just EventDocumentStart -> do
222+ res <- parseO
223+ requireEvent EventDocumentEnd
224+ (res :) <$> parseDocs
225+ _ -> missed documentStart
226+ missed event = liftIO $ throwIO $ UnexpectedEvent event Nothing
227+
228+parseScalar :: ByteString -> Anchor -> Style -> Tag
229+ -> ReaderT JSONPath (ConduitM Event o Parse) Text
230+parseScalar v a style tag = do
231+ let res = decodeUtf8With lenientDecode v
232+ mapM_ (defineAnchor (textToValue style tag res)) a
233+ return res
234+
235+textToValue :: Style -> Tag -> Text -> Value
236+textToValue SingleQuoted _ t = String t
237+textToValue DoubleQuoted _ t = String t
238+textToValue _ StrTag t = String t
239+textToValue Folded _ t = String t
240+textToValue _ _ t
241+ | t `elem` ["null", "Null", "NULL", "~", ""] = Null
242+ | any (t `isLike`) ["y", "yes", "on", "true"] = Bool True
243+ | any (t `isLike`) ["n", "no", "off", "false"] = Bool False
244+ | Right x <- textToScientific t = Number x
245+ | otherwise = String t
246+ where x `isLike` ref = x `elem` [ref, T.toUpper ref, titleCased]
247+ where titleCased = toUpper (T.head ref) `T.cons` T.tail ref
248+
249+textToScientific :: Text -> Either String Scientific
250+textToScientific = Atto.parseOnly (num <* Atto.endOfInput)
251+ where
252+ num = (fromInteger <$> ("0x" *> Atto.hexadecimal))
253+ <|> (fromInteger <$> ("0o" *> octal))
254+ <|> Atto.scientific
255+
256+ octal = T.foldl' step 0 <$> Atto.takeWhile1 isOctalDigit
257+ where
258+ isOctalDigit c = (c >= '0' && c <= '7')
259+ step a c = (a `shiftL` 3) .|. fromIntegral (ord c - 48)
260+
261+parseO :: ReaderT JSONPath (ConduitM Event o Parse) Value
262+parseO = do
263+ me <- lift CL.head
264+ case me of
265+ Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag
266+ Just (EventSequenceStart _ _ a) -> parseS 0 a id
267+ Just (EventMappingStart _ _ a) -> parseM mempty a M.empty
268+ Just (EventAlias an) -> do
269+ m <- lookupAnchor an
270+ case m of
271+ Nothing -> liftIO $ throwIO $ UnknownAlias an
272+ Just v -> return v
273+ _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
274+
275+parseS :: Int
276+ -> Y.Anchor
277+ -> ([Value] -> [Value])
278+ -> ReaderT JSONPath (ConduitM Event o Parse) Value
279+parseS !n a front = do
280+ me <- lift CL.peek
281+ case me of
282+ Just EventSequenceEnd -> do
283+ lift $ CL.drop 1
284+ let res = Array $ V.fromList $ front []
285+ mapM_ (defineAnchor res) a
286+ return res
287+ _ -> do
288+ o <- local (Index n :) parseO
289+ parseS (succ n) a $ front . (:) o
290+
291+parseM :: Set Key
292+ -> Y.Anchor
293+ -> KeyMap Value
294+ -> ReaderT JSONPath (ConduitM Event o Parse) Value
295+parseM mergedKeys a front = do
296+ me <- lift CL.head
297+ case me of
298+ Just EventMappingEnd -> do
299+ let res = Object front
300+ mapM_ (defineAnchor res) a
301+ return res
302+ _ -> do
303+ s <- case me of
304+ Just (EventScalar v tag style a') -> fromText <$> parseScalar v a' style tag
305+ Just (EventAlias an) -> do
306+ m <- lookupAnchor an
307+ case m of
308+ Nothing -> liftIO $ throwIO $ UnknownAlias an
309+ Just (String t) -> return $ fromText t
310+ Just v -> liftIO $ throwIO $ NonStringKeyAlias an v
311+ _ -> do
312+ path <- ask
313+ liftIO $ throwIO $ NonStringKey path
314+
315+ (mergedKeys', al') <- local (Key s :) $ do
316+ o <- parseO
317+ let al = do
318+ when (M.member s front && Set.notMember s mergedKeys) $ do
319+ path <- reverse <$> ask
320+ addWarning (DuplicateKey path)
321+ return (Set.delete s mergedKeys, M.insert s o front)
322+ if s == "<<"
323+ then case o of
324+ Object l -> return (merge l)
325+ Array l -> return $ merge $ List.foldl' mergeObjects M.empty $ V.toList l
326+ _ -> al
327+ else al
328+ parseM mergedKeys' a al'
329+ where mergeObjects al (Object om) = M.union al om
330+ mergeObjects al _ = al
331+
332+ merge xs = (Set.fromList (M.keys xs List.\\ M.keys front), M.union front xs)
333+
334+parseSrc :: ReaderT JSONPath (ConduitM Event Void Parse) val
335+ -> ConduitM () Event Parse ()
336+ -> IO (val, ParseState)
337+parseSrc eventParser src = runResourceT $ runStateT
338+ (runConduit $ src .| runReaderT eventParser [])
339+ (ParseState Map.empty [])
340+
341+mkHelper :: ReaderT JSONPath (ConduitM Event Void Parse) val -- ^ parse libyaml events as Value or [Value]
342+ -> (SomeException -> IO (Either ParseException a)) -- ^ what to do with unhandled exceptions
343+ -> ((val, ParseState) -> Either ParseException a) -- ^ further transform and parse results
344+ -> ConduitM () Event Parse () -- ^ the libyaml event (string/file) source
345+ -> IO (Either ParseException a)
346+mkHelper eventParser onOtherExc extractResults src = catches
347+ (extractResults <$> parseSrc eventParser src)
348+ [ Handler $ \pe -> return $ Left (pe :: ParseException)
349+ , Handler $ \ye -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
350+ , Handler $ \sae -> throwIO (sae :: SomeAsyncException)
351+ , Handler onOtherExc
352+ ]
353+
354+decodeHelper :: FromJSON a
355+ => ConduitM () Y.Event Parse ()
356+ -> IO (Either ParseException ([Warning], Either String a))
357+decodeHelper = mkHelper parse throwIO $ \(v, st) ->
358+ Right (parseStateWarnings st, parseEither parseJSON v)
359+
360+decodeAllHelper :: FromJSON a
361+ => ConduitM () Event Parse ()
362+ -> IO (Either ParseException ([Warning], Either String [a]))
363+decodeAllHelper = mkHelper parseAll throwIO $ \(vs, st) ->
364+ Right (parseStateWarnings st, mapM (parseEither parseJSON) vs)
365+
366+catchLeft :: SomeException -> IO (Either ParseException a)
367+catchLeft = return . Left . OtherParseException
368+
369+decodeHelper_ :: FromJSON a
370+ => ConduitM () Event Parse ()
371+ -> IO (Either ParseException ([Warning], a))
372+decodeHelper_ = mkHelper parse catchLeft $ \(v, st) ->
373+ case parseEither parseJSON v of
374+ Left e -> Left $ AesonException e
375+ Right x -> Right (parseStateWarnings st, x)
376+
377+decodeAllHelper_ :: FromJSON a
378+ => ConduitM () Event Parse ()
379+ -> IO (Either ParseException ([Warning], [a]))
380+decodeAllHelper_ = mkHelper parseAll catchLeft $ \(vs, st) ->
381+ case mapM (parseEither parseJSON) vs of
382+ Left e -> Left $ AesonException e
383+ Right xs -> Right (parseStateWarnings st, xs)
384+
385+type StringStyle = Text -> ( Tag, Style )
386+
387+-- | Encodes a string with the supplied style. This function handles the empty
388+-- string case properly to avoid https://github.com/snoyberg/yaml/issues/24
389+--
390+-- @since 0.11.2.0
391+stringScalar :: StringStyle -> Maybe Text -> Text -> Event
392+stringScalar _ anchor "" = EventScalar "" NoTag SingleQuoted (T.unpack <$> anchor)
393+stringScalar stringStyle anchor s = EventScalar (encodeUtf8 s) tag style (T.unpack <$> anchor)
394+ where
395+ ( tag, style ) = stringStyle s
396+
397+-- |
398+-- @since 0.11.2.0
399+defaultStringStyle :: StringStyle
400+defaultStringStyle = \s ->
401+ case () of
402+ ()
403+ | "\n" `T.isInfixOf` s -> ( NoTag, Literal )
404+ | isSpecialString s -> ( NoTag, SingleQuoted )
405+ | otherwise -> ( NoTag, PlainNoTag )
406+
407+-- | Determine whether a string must be quoted in YAML and can't appear as plain text.
408+-- Useful if you want to use 'setStringStyle'.
409+--
410+-- @since 0.10.2.0
411+isSpecialString :: Text -> Bool
412+isSpecialString s = s `HashSet.member` specialStrings || isNumeric s
413+
414+-- | Strings which must be escaped so as not to be treated as non-string scalars.
415+--
416+-- @since 0.8.32
417+specialStrings :: HashSet.HashSet Text
418+specialStrings = HashSet.fromList $ T.words
419+ "y Y yes Yes YES n N no No NO true True TRUE false False FALSE on On ON off Off OFF null Null NULL ~ *"
420+
421+-- |
422+-- @since 0.8.32
423+isNumeric :: Text -> Bool
424+isNumeric = either (const False) (const True) . textToScientific
425+
426+-- | Encode a value as a YAML document stream.
427+--
428+-- @since 0.11.2.0
429+objToStream :: ToJSON a => StringStyle -> a -> [Y.Event]
430+objToStream stringStyle o =
431+ (:) EventStreamStart
432+ . (:) EventDocumentStart
433+ $ objToEvents stringStyle o
434+ [ EventDocumentEnd
435+ , EventStreamEnd
436+ ]
437+
438+-- | Encode a value as a list of 'Event's.
439+--
440+-- @since 0.11.2.0
441+objToEvents :: ToJSON a => StringStyle -> a -> [Y.Event] -> [Y.Event]
442+objToEvents stringStyle = objToEvents' . toJSON
443+ where
444+ objToEvents' (Array list) rest =
445+ EventSequenceStart NoTag AnySequence Nothing
446+ : foldr objToEvents' (EventSequenceEnd : rest) (V.toList list)
447+
448+ objToEvents' (Object o) rest =
449+ EventMappingStart NoTag AnyMapping Nothing
450+ : foldr pairToEvents (EventMappingEnd : rest) (M.toList o)
451+ where
452+ pairToEvents :: Pair -> [Y.Event] -> [Y.Event]
453+ pairToEvents (k, v) = objToEvents' (String $ toText k) . objToEvents' v
454+
455+ objToEvents' (String s) rest = stringScalar stringStyle Nothing s : rest
456+
457+ objToEvents' Null rest = EventScalar "null" NullTag PlainNoTag Nothing : rest
458+
459+ objToEvents' (Bool True) rest = EventScalar "true" BoolTag PlainNoTag Nothing : rest
460+ objToEvents' (Bool False) rest = EventScalar "false" BoolTag PlainNoTag Nothing : rest
461+
462+ objToEvents' (Number s) rest =
463+ let builder
464+ -- Special case the 0 exponent to remove the trailing .0
465+ | base10Exponent s == 0 = BB.integerDec $ coefficient s
466+ | otherwise = scientificBuilder s
467+ lbs = BB.toLazyByteString builder
468+ bs = BL.toStrict lbs
469+ in EventScalar bs IntTag PlainNoTag Nothing : rest
yaml/src/Data/Yaml/Parser.hsnew file+204
@@ -0,0 +1,204 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveDataTypeable #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+-- | NOTE: This module is a highly experimental preview release. It may change
5+-- drastically, or be entirely removed, in a future release.
6+module Data.Yaml.Parser where
7+
8+import Control.Applicative
9+import Control.Exception (Exception)
10+import Control.Monad (MonadPlus (..), liftM, ap)
11+import Control.Monad.Trans.Class (lift)
12+import Control.Monad.Trans.Resource (MonadThrow, throwM)
13+import Control.Monad.Trans.Writer.Strict (tell, WriterT)
14+import Data.ByteString (ByteString)
15+import Data.Conduit
16+import Data.Conduit.Lift (runWriterC)
17+import qualified Data.Map as Map
18+#if !MIN_VERSION_base(4,8,0)
19+import Data.Monoid (Monoid (..))
20+#endif
21+#if !MIN_VERSION_base(4,11,0)
22+import Data.Semigroup (Semigroup(..))
23+#endif
24+import Data.Text (Text, pack, unpack)
25+import Data.Text.Encoding (decodeUtf8)
26+import Data.Text.Read (signed, decimal)
27+import Data.Typeable (Typeable)
28+
29+import Text.Libyaml
30+
31+newtype YamlParser a = YamlParser
32+ { unYamlParser :: AnchorMap -> Either Text a
33+ }
34+instance Functor YamlParser where
35+ fmap = liftM
36+instance Applicative YamlParser where
37+ pure = YamlParser . const . Right
38+ (<*>) = ap
39+instance Alternative YamlParser where
40+ empty = fail "empty"
41+ (<|>) = mplus
42+instance Semigroup (YamlParser a) where
43+ (<>) = mplus
44+instance Monoid (YamlParser a) where
45+ mempty = fail "mempty"
46+#if !MIN_VERSION_base(4,11,0)
47+ mappend = (<>)
48+#endif
49+instance Monad YamlParser where
50+ return = pure
51+ YamlParser f >>= g = YamlParser $ \am ->
52+ case f am of
53+ Left t -> Left t
54+ Right x -> unYamlParser (g x) am
55+#if MIN_VERSION_base(4,13,0)
56+instance MonadFail YamlParser where
57+#endif
58+ fail = YamlParser . const . Left . pack
59+instance MonadPlus YamlParser where
60+ mzero = fail "mzero"
61+ mplus a b = YamlParser $ \am ->
62+ case unYamlParser a am of
63+ Left _ -> unYamlParser b am
64+ x -> x
65+
66+lookupAnchor :: AnchorName -> YamlParser (Maybe YamlValue)
67+lookupAnchor name = YamlParser $ Right . Map.lookup name
68+
69+withAnchor :: AnchorName -> Text -> (YamlValue -> YamlParser a) -> YamlParser a
70+withAnchor name expected f = do
71+ mv <- lookupAnchor name
72+ case mv of
73+ Nothing -> fail $ unpack expected ++ ": unknown alias " ++ name
74+ Just v -> f v
75+
76+withMapping :: Text -> ([(Text, YamlValue)] -> YamlParser a) -> YamlValue -> YamlParser a
77+withMapping _ f (Mapping m _) = f m
78+withMapping expected f (Alias an) = withAnchor an expected $ withMapping expected f
79+withMapping expected _ v = typeMismatch expected v
80+
81+withSequence :: Text -> ([YamlValue] -> YamlParser a) -> YamlValue -> YamlParser a
82+withSequence _ f (Sequence s _) = f s
83+withSequence expected f (Alias an) = withAnchor an expected $ withSequence expected f
84+withSequence expected _ v = typeMismatch expected v
85+
86+withText :: Text -> (Text -> YamlParser a) -> YamlValue -> YamlParser a
87+withText _ f (Scalar s _ _ _) = f $ decodeUtf8 s
88+withText expected f (Alias an) = withAnchor an expected $ withText expected f
89+withText expected _ v = typeMismatch expected v
90+
91+typeMismatch :: Text -> YamlValue -> YamlParser a
92+typeMismatch expected v =
93+ fail $ concat
94+ [ "Expected "
95+ , unpack expected
96+ , ", but got: "
97+ , t
98+ ]
99+ where
100+ t = case v of
101+ Mapping _ _ -> "mapping"
102+ Sequence _ _ -> "sequence"
103+ Scalar _ _ _ _ -> "scalar"
104+ Alias _ -> "alias"
105+
106+class FromYaml a where
107+ fromYaml :: YamlValue -> YamlParser a
108+instance FromYaml YamlValue where
109+ fromYaml = return
110+instance FromYaml a => FromYaml [a] where
111+ fromYaml = withSequence "[a]" (mapM fromYaml)
112+instance FromYaml Text where
113+ fromYaml = withText "Text" return
114+instance FromYaml Int where
115+ fromYaml =
116+ withText "Int" go
117+ where
118+ go t =
119+ case signed decimal t of
120+ Right (i, "") -> return i
121+ _ -> fail $ "Invalid Int: " ++ unpack t
122+
123+data YamlValue
124+ = Mapping [(Text, YamlValue)] Anchor
125+ | Sequence [YamlValue] Anchor
126+ | Scalar ByteString Tag Style Anchor
127+ | Alias AnchorName
128+ deriving Show
129+
130+type AnchorMap = Map.Map AnchorName YamlValue
131+data RawDoc = RawDoc YamlValue AnchorMap
132+ deriving Show
133+
134+parseRawDoc :: (FromYaml a, MonadThrow m) => RawDoc -> m a
135+parseRawDoc (RawDoc val am) =
136+ case unYamlParser (fromYaml val) am of
137+ Left t -> throwM $ FromYamlException t
138+ Right x -> return x
139+
140+(.:) :: FromYaml a => [(Text, YamlValue)] -> Text -> YamlParser a
141+o .: k =
142+ case lookup k o of
143+ Nothing -> fail $ "Key not found: " ++ unpack k
144+ Just v -> fromYaml v
145+
146+data YamlParseException
147+ = UnexpectedEndOfEvents
148+ | UnexpectedEvent Event
149+ | FromYamlException Text
150+ deriving (Show, Typeable)
151+instance Exception YamlParseException
152+
153+sinkValue :: MonadThrow m => ConduitM Event o (WriterT AnchorMap m) YamlValue
154+sinkValue =
155+ start
156+ where
157+ start = await >>= maybe (throwM UnexpectedEndOfEvents) go
158+
159+ tell' Nothing val = return val
160+ tell' (Just name) val = do
161+ lift $ tell $ Map.singleton name val
162+ return val
163+
164+ go EventStreamStart = start
165+ go EventDocumentStart = start
166+ go (EventAlias a) = return $ Alias a
167+ go (EventScalar a b c d) = tell' d $ Scalar a b c d
168+ go (EventSequenceStart _tag _style mname) = do
169+ vals <- goS id
170+ let val = Sequence vals mname
171+ tell' mname val
172+ go (EventMappingStart _tag _style mname) = do
173+ pairs <- goM id
174+ let val = Mapping pairs mname
175+ tell' mname val
176+
177+ go e = throwM $ UnexpectedEvent e
178+
179+ goS front = do
180+ me <- await
181+ case me of
182+ Nothing -> throwM UnexpectedEndOfEvents
183+ Just EventSequenceEnd -> return $ front []
184+ Just e -> do
185+ val <- go e
186+ goS (front . (val:))
187+
188+ goM front = do
189+ mk <- await
190+ case mk of
191+ Nothing -> throwM UnexpectedEndOfEvents
192+ Just EventMappingEnd -> return $ front []
193+ Just (EventScalar a b c d) -> do
194+ _ <- tell' d $ Scalar a b c d
195+ let k = decodeUtf8 a
196+ v <- start
197+ goM (front . ((k, v):))
198+ Just e -> throwM $ UnexpectedEvent e
199+
200+sinkRawDoc :: MonadThrow m => ConduitM Event o m RawDoc
201+sinkRawDoc = uncurry RawDoc <$> runWriterC sinkValue
202+
203+readYamlFile :: FromYaml a => FilePath -> IO a
204+readYamlFile fp = runConduitRes (decodeFile fp .| sinkRawDoc) >>= parseRawDoc
yaml/src/Data/Yaml/Pretty.hsnew file+102
@@ -0,0 +1,102 @@
1+{-# LANGUAGE CPP #-}
2+-- | Prettier YAML encoding.
3+--
4+-- @since 0.8.13
5+module Data.Yaml.Pretty
6+ ( encodePretty
7+ , Config
8+ , getConfCompare
9+ , setConfCompare
10+ , getConfDropNull
11+ , setConfDropNull
12+ , defConfig
13+ , pretty
14+ ) where
15+
16+import Prelude hiding (null)
17+
18+#if !MIN_VERSION_base(4,8,0)
19+import Control.Applicative ((<$>))
20+#endif
21+import Data.Bifunctor (first)
22+#if MIN_VERSION_aeson(2,0,0)
23+import qualified Data.Aeson.Key as K
24+import qualified Data.Aeson.KeyMap as HM
25+#else
26+import qualified Data.HashMap.Strict as HM
27+#endif
28+import Data.Aeson.Types
29+import Data.ByteString (ByteString)
30+import Data.Function (on)
31+import Data.List (sortBy)
32+#if !MIN_VERSION_base(4,8,0)
33+import Data.Monoid
34+#endif
35+import Data.Text (Text)
36+import qualified Data.Vector as V
37+
38+import Data.Yaml.Builder
39+
40+#if MIN_VERSION_aeson(2,0,0)
41+toText :: Key -> Text
42+toText = K.toText
43+#else
44+toText :: Key -> Text
45+toText = id
46+
47+type Key = Text
48+#endif
49+
50+-- |
51+-- @since 0.8.13
52+data Config = Config
53+ { confCompare :: Text -> Text -> Ordering -- ^ Function used to sort keys in objects
54+ , confDropNull :: Bool -- ^ Drop null values from objects
55+ }
56+
57+-- | The default configuration: do not sort objects or drop keys
58+--
59+-- @since 0.8.13
60+defConfig :: Config
61+defConfig = Config mempty False
62+
63+-- |
64+-- @since 0.8.13
65+getConfCompare :: Config -> Text -> Text -> Ordering
66+getConfCompare = confCompare
67+
68+-- | Sets ordering for object keys
69+--
70+-- @since 0.8.13
71+setConfCompare :: (Text -> Text -> Ordering) -> Config -> Config
72+setConfCompare cmp c = c { confCompare = cmp }
73+
74+-- |
75+-- @since 0.8.24
76+getConfDropNull :: Config -> Bool
77+getConfDropNull = confDropNull
78+
79+-- | Drop entries with `Null` value from objects, if set to `True`
80+--
81+-- @since 0.8.24
82+setConfDropNull :: Bool -> Config -> Config
83+setConfDropNull m c = c { confDropNull = m }
84+
85+pretty :: Config -> Value -> YamlBuilder
86+pretty cfg = go
87+ where go (Object o) = let sort = sortBy (confCompare cfg `on` fst)
88+ select
89+ | confDropNull cfg = HM.filter (/= Null)
90+ | otherwise = id
91+ in mapping (sort $ fmap (first toText) $ HM.toList $ HM.map go $ select o)
92+ go (Array a) = array (go <$> V.toList a)
93+ go Null = null
94+ go (String s) = string s
95+ go (Number n) = scientific n
96+ go (Bool b) = bool b
97+
98+-- | Configurable 'encode'.
99+--
100+-- @since 0.8.13
101+encodePretty :: ToJSON a => Config -> a -> ByteString
102+encodePretty cfg = toByteString . pretty cfg . toJSON
yaml/src/Data/Yaml/TH.hsnew file+80
@@ -0,0 +1,80 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE LambdaCase #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+module Data.Yaml.TH
6+ ( -- * Decoding
7+ yamlQQ
8+#if MIN_VERSION_template_haskell(2,9,0)
9+ , decodeFile
10+#endif
11+ -- * Re-exports from "Data.Yaml"
12+ , Value (..)
13+ , Parser
14+ , Object
15+ , Array
16+ , object
17+ , array
18+ , (.=)
19+ , (.:)
20+ , (.:?)
21+ , (.!=)
22+ , FromJSON (..)
23+ ) where
24+
25+import Data.Text.Encoding
26+import qualified Data.Text as T
27+import Language.Haskell.TH
28+import Language.Haskell.TH.Syntax
29+import Language.Haskell.TH.Quote
30+
31+import Data.Yaml hiding (decodeFile)
32+
33+-- | Decode a YAML file at compile time. Only available on GHC version @7.8.1@
34+-- or higher.
35+--
36+-- @since 0.8.19.0
37+--
38+-- ==== __Examples__
39+--
40+-- @
41+-- {-\# LANGUAGE TemplateHaskell \#-}
42+--
43+-- config :: Config
44+-- config = $$('decodeFile' "config.yaml")
45+-- @
46+decodeFile :: forall a. (Lift a, FromJSON a) => FilePath -> Q (TExp a)
47+decodeFile path = do
48+ addDependentFile path
49+ x <- runIO $ decodeFileThrow path
50+ fmap TExp (lift (x :: a))
51+
52+yamlExp :: String -> Q Exp
53+yamlExp input = do
54+ val <- runIO $ decodeThrow $ encodeUtf8 $ T.pack input
55+ lift (val :: Value)
56+
57+-- | A @QuasiQuoter@ for YAML.
58+--
59+-- @since 0.8.28.0
60+--
61+-- ==== __Examples__
62+--
63+-- @
64+-- {-\# LANGUAGE QuasiQuotes \#-}
65+-- import Data.Yaml.TH
66+--
67+-- value :: Value
68+-- value = [yamlQQ|
69+-- name: John Doe
70+-- age: 23
71+-- |]
72+-- @
73+yamlQQ :: QuasiQuoter
74+yamlQQ = QuasiQuoter {
75+ quoteExp = yamlExp
76+, quotePat = notDefined "quotePat"
77+, quoteType = notDefined "quoteType"
78+, quoteDec = notDefined "quoteDec"
79+} where
80+ notDefined name _ = fail (name ++ " is not defined for yamlQQ")
yaml/test/Data/Yaml/IncludeSpec.hsnew file+139
@@ -0,0 +1,139 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE QuasiQuotes #-}
3+{-# LANGUAGE OverloadedStrings #-}
4+module Data.Yaml.IncludeSpec (main, spec) where
5+
6+import Test.Hspec
7+import Data.List (isPrefixOf)
8+import qualified Data.ByteString.Lazy as LB
9+import Data.Aeson
10+#if MIN_VERSION_aeson(2,2,0)
11+import Data.Aeson.Types (JSONPathElement(..))
12+#else
13+import Data.Aeson.Internal (JSONPathElement(..))
14+#endif
15+import Data.Yaml (ParseException(InvalidYaml))
16+import Data.Yaml.Include
17+import Data.Yaml.Internal
18+import Text.Libyaml (YamlException(YamlException))
19+import Test.Mockery.Directory
20+import Text.RawString.QQ
21+import Data.Yaml.TH (yamlQQ)
22+
23+main :: IO ()
24+main = hspec spec
25+
26+asInt :: Int -> Int
27+asInt = id
28+
29+spec :: Spec
30+spec = do
31+ describe "decodeFile" $ do
32+ it "supports includes" $ do
33+ decodeFile "test/resources/foo.yaml" `shouldReturn` Just (object
34+ [ "foo" .= asInt 23
35+ , "bar" .= object
36+ [ "one" .= asInt 1
37+ , "two" .= asInt 2
38+ ]
39+ , "baz" .= asInt 42
40+ ])
41+
42+ it "supports recursive includes" $ do
43+ decodeFile "test/resources/baz.yaml" `shouldReturn` Just (object
44+ [ "foo" .= object
45+ [ "foo" .= asInt 23
46+ , "bar" .= object
47+ [ "one" .= asInt 1
48+ , "two" .= asInt 2
49+ ]
50+ , "baz" .= asInt 42
51+ ]
52+ ])
53+
54+ it "aborts on cyclic includes" $ do
55+ (decodeFile "test/resources/loop/foo.yaml" :: IO (Maybe Value)) `shouldThrow` anyException
56+
57+ context "when file does not exist" $ do
58+ it "throws Left (InvalidYaml (Just (YamlException \"Yaml file not found: ...\")))" $ do
59+ (decodeFile "./does_not_exist.yaml" :: IO (Maybe Value)) `shouldThrow` isYamlFileNotFoundException
60+
61+ context "with a 1K stack size limit" $ around_ inTempDirectory $ do
62+ context "with a large list" $ do
63+ it "succeeds" $ do
64+ let
65+ xs :: [Value]
66+ xs = replicate 5000 (Number 23)
67+ LB.writeFile "foo.yaml" (encode xs)
68+ decodeFile "foo.yaml" `shouldReturn` Just xs
69+
70+ describe "decodeFileEither" $ do
71+ context "when file does not exist" $ do
72+ it "returns Left (InvalidYaml (Just (YamlException \"Yaml file not found: ...\")))" $ do
73+ (decodeFileEither "./does_not_exist.yaml" :: IO (Either ParseException Value)) >>=
74+ (`shouldSatisfy` either isYamlFileNotFoundException (const False))
75+
76+ describe "decodeFileWithWarnings" $ around_ inTempDirectory $ do
77+ it "warns on duplicate keys" $ do
78+ writeFile "foo.yaml" [r|
79+ foo: 23
80+ foo: bar
81+ |]
82+ Right result <- decodeFileWithWarnings "foo.yaml"
83+ result `shouldBe` ([DuplicateKey [Key "foo"]], [yamlQQ|
84+ foo: bar
85+ |])
86+
87+ it "warns on nested duplicate keys" $ do
88+ writeFile "foo.yaml" [r|
89+ foo:
90+ - 42
91+ - bar: 23
92+ bar: baz
93+ |]
94+ Right result <- decodeFileWithWarnings "foo.yaml"
95+ result `shouldBe` ([DuplicateKey [Key "foo", Index 1, Key "bar"]], [yamlQQ|
96+ foo:
97+ - 42
98+ - bar: baz
99+ |])
100+
101+ context "when overriding a merged key" $ do
102+ it "does not warn" $ do
103+ writeFile "foo.yaml" [r|
104+ foo-1: &my-ref
105+ bar: 23
106+ foo-2:
107+ <<: *my-ref
108+ bar: 42
109+ |]
110+ Right result <- decodeFileWithWarnings "foo.yaml"
111+ result `shouldBe` ([], [yamlQQ|
112+ foo-1:
113+ bar: 23
114+ foo-2:
115+ bar: 42
116+ |])
117+
118+ context "when overriding twice" $ do
119+ it "warns" $ do
120+ writeFile "foo.yaml" [r|
121+ foo-1: &my-ref
122+ bar: 23
123+ foo-2:
124+ <<: *my-ref
125+ bar: 42
126+ bar: 65
127+ |]
128+ Right result <- decodeFileWithWarnings "foo.yaml"
129+ result `shouldBe` ([DuplicateKey [Key "foo-2", Key "bar"]], [yamlQQ|
130+ foo-1:
131+ bar: 23
132+ foo-2:
133+ bar: 65
134+ |])
135+
136+isYamlFileNotFoundException :: ParseException -> Bool
137+isYamlFileNotFoundException (InvalidYaml (Just (YamlException msg)))
138+ | "Yaml file not found: " `isPrefixOf` msg = True
139+isYamlFileNotFoundException _ = False
yaml/test/Data/Yaml/THSpec.hsnew file+17
@@ -0,0 +1,17 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE QuasiQuotes #-}
3+module Data.Yaml.THSpec (spec) where
4+
5+import Test.Hspec
6+import Data.Aeson
7+
8+import Data.Yaml.TH
9+
10+spec :: Spec
11+spec = do
12+ describe "yamlQQ" $ do
13+ it "parses yaml" $ do
14+ [yamlQQ|
15+ name: John Doe
16+ age: 23
17+ |] `shouldBe` object ["name" .= String "John Doe", "age" .= Number 23]
yaml/test/Data/YamlSpec.hsnew file+899
@@ -0,0 +1,899 @@
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE PackageImports #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE TemplateHaskell #-}
6+{-# LANGUAGE TupleSections #-}
7+
8+module Data.YamlSpec (main, spec) where
9+
10+import qualified Text.Libyaml as Y
11+import qualified Data.ByteString as BS
12+import qualified Data.ByteString.Char8 as B8
13+import Data.Int (Int64)
14+import qualified Data.Scientific as S
15+
16+import Test.HUnit hiding (Test, path)
17+
18+import Data.Conduit (runConduitRes, (.|), ConduitM)
19+import qualified Data.Conduit.List as CL
20+
21+import Control.Monad
22+import Control.Exception (try, SomeException)
23+import Test.Hspec
24+import Test.Hspec.QuickCheck
25+import Data.Either.Compat
26+import System.Directory (createDirectory, createDirectoryIfMissing)
27+import Test.Mockery.Directory
28+
29+import qualified Data.Yaml as D
30+import qualified Data.Yaml.Builder as B
31+import qualified Data.Yaml.Internal as Internal
32+import qualified Data.Yaml.Pretty as Pretty
33+import Data.Yaml (object, array, (.=))
34+import Data.Maybe
35+import qualified Data.HashMap.Strict as HM
36+#if MIN_VERSION_aeson(2,0,0)
37+import qualified Data.Aeson.KeyMap as M
38+import qualified Data.Aeson.Key as K
39+import Data.Aeson.KeyMap (KeyMap)
40+#else
41+import qualified Data.HashMap.Strict as M
42+#endif
43+import qualified Data.Text as T
44+import Data.Aeson.TH
45+import Data.Scientific (Scientific)
46+import Data.String (fromString)
47+import Data.Text (Text)
48+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
49+import Data.Vector (Vector)
50+import qualified Data.Vector as V
51+import Data.HashMap.Strict (HashMap)
52+import qualified Data.HashMap.Strict as HM
53+import System.IO (hClose)
54+import System.IO.Temp (withSystemTempFile)
55+
56+#if MIN_VERSION_aeson(2,0,0)
57+fromText :: T.Text -> K.Key
58+fromText = K.fromText
59+
60+toText :: K.Key -> T.Text
61+toText = K.toText
62+#else
63+fromText :: T.Text -> T.Text
64+fromText = id
65+
66+toText :: Key -> T.Text
67+toText = id
68+
69+type KeyMap a = M.HashMap Text a
70+type Key = Text
71+#endif
72+
73+data TestJSON = TestJSON
74+ { string :: Text
75+ , number :: Int
76+ , anArray :: Vector Text
77+ , hash :: HashMap Text Text
78+ , extrastring :: Text
79+ } deriving (Show, Eq)
80+
81+deriveJSON defaultOptions ''TestJSON
82+
83+testJSON :: TestJSON
84+testJSON = TestJSON
85+ { string = "str"
86+ , number = 2
87+ , anArray = V.fromList ["a", "b"]
88+ , hash = HM.fromList [("key1", "value1"), ("key2", "value2")]
89+ , extrastring = "1234-foo"
90+ }
91+
92+shouldDecode :: (Show a, D.FromJSON a, Eq a) => B8.ByteString -> a -> IO ()
93+shouldDecode bs expected = do
94+ actual <- D.decodeThrow bs
95+ actual `shouldBe` expected
96+
97+shouldDecodeAll :: (Show a, D.FromJSON a, Eq a) => B8.ByteString -> [a] -> IO ()
98+shouldDecodeAll bs expected = do
99+ actual <- D.decodeAllThrow bs
100+ actual `shouldBe` expected
101+
102+shouldDecodeEvents :: B8.ByteString -> [Y.Event] -> IO ()
103+shouldDecodeEvents bs expected = do
104+ actual <- runConduitRes $ Y.decode bs .| CL.consume
105+ map anyStyle actual `shouldBe` map anyStyle expected
106+
107+anyStyle :: Y.Event -> Y.Event
108+anyStyle (Y.EventScalar bs tag _ anchor) = Y.EventScalar bs tag Y.Any anchor
109+anyStyle (Y.EventSequenceStart tag _ anchor) = Y.EventSequenceStart tag Y.AnySequence anchor
110+anyStyle (Y.EventMappingStart tag _ anchor) = Y.EventMappingStart tag Y.AnyMapping anchor
111+anyStyle event = event
112+
113+testEncodeWith :: Y.FormatOptions -> [Y.Event] -> IO BS.ByteString
114+testEncodeWith opts es = runConduitRes $ CL.sourceList (eventStream es) .| Y.encodeWith opts
115+
116+eventStream :: [Y.Event] -> [Y.Event]
117+eventStream events =
118+ [Y.EventStreamStart, Y.EventDocumentStart]
119+ ++ events
120+ ++ [Y.EventDocumentEnd, Y.EventStreamEnd]
121+
122+main :: IO ()
123+main = hspec spec
124+
125+spec :: Spec
126+spec = do
127+ describe "streaming" $ do
128+ it "count scalars with anchor" caseCountScalarsWithAnchor
129+ it "count sequences with anchor" caseCountSequencesWithAnchor
130+ it "count mappings with anchor" caseCountMappingsWithAnchor
131+ it "count sequences with custom tag" caseCountSequenceTags
132+ it "count mappings with custom tag" caseCountMappingTags
133+ it "count count sequences with ! tag" caseCountEmptySequenceTags
134+ it "count count mappings with ! tag" caseCountEmptyMappingTags
135+ it "count block style sequences" caseCountBlockStyleSequences
136+ it "count flow style sequences" caseCountFlowStyleSequences
137+ it "count block style mappings" caseCountBlockStyleMappings
138+ it "count flow style mappings" caseCountFlowStyleMappings
139+ it "count aliases" caseCountAliases
140+ it "count scalars" caseCountScalars
141+ it "largest string" caseLargestString
142+ it "encode/decode" caseEncodeDecode
143+ it "encode/decode events" caseEncodeDecodeEvents
144+ it "encode/decode file" caseEncodeDecodeFile
145+ it "interleaved encode/decode" caseInterleave
146+ it "decode invalid document (without segfault)" caseDecodeInvalidDocument
147+ describe "Data.Yaml" $ do
148+ it "encode/decode" caseEncodeDecodeData
149+ it "encode/decode file" caseEncodeDecodeFileData
150+ it "encode/decode files with non-ASCII names" caseEncodeDecodeNonAsciiFileData
151+ it "encode/decode strings" caseEncodeDecodeStrings
152+ it "decode invalid file" caseDecodeInvalid
153+ it "processes datatypes" caseDataTypes
154+ it "encode invalid numbers" caseEncodeInvalidNumbers
155+ describe "Data.Yaml.Pretty" $ do
156+ it "encode/decode" caseEncodeDecodeDataPretty
157+ it "encode/decode strings" caseEncodeDecodeStringsPretty
158+ it "processes datatypes" caseDataTypesPretty
159+ describe "Data.Yaml.Builder" $ do
160+ it "encode/decode" caseEncodeDecodeDataBuilder
161+ it "encode/decode complex mapping" caseEncodeDecodeComplexMappingBuilder
162+ describe "Data.Yaml aliases" $ do
163+ it "simple scalar alias" caseSimpleScalarAlias
164+ it "simple sequence alias" caseSimpleSequenceAlias
165+ it "simple mapping alias" caseSimpleMappingAlias
166+ it "mapping alias before anchor" caseMappingAliasBeforeAnchor
167+ it "mapping alias inside anchor" caseMappingAliasInsideAnchor
168+ it "scalar alias overriding" caseScalarAliasOverriding
169+ describe "Data.Yaml merge keys" $ do
170+ it "test uniqueness of keys" caseAllKeysShouldBeUnique
171+ it "test mapping merge" caseSimpleMappingMerge
172+ it "test sequence of mappings merging" caseMergeSequence
173+ describe "numbers" $ do
174+ it "parses as string when quoted" caseQuotedNumber
175+ it "parses as number when unquoted" caseUnquotedNumber
176+ it "parses as number !!str is present" caseAttribNumber
177+ it "integers have no decimals" caseIntegerDecimals
178+ describe "booleans" $ do
179+ it "parses when all lowercase" caseLowercaseBool
180+ it "parses when all uppercase" caseUppercaseBool
181+ it "parses when titlecase" caseTitlecaseBool
182+ describe "empty input" $ do
183+ it "parses as Null" caseEmptyInput
184+ it "parses as Null from file" caseEmptyInputFile
185+ describe "comment only input" $ do
186+ it "parses as Null" caseCommentOnlyInput
187+ it "parses as Null from file" caseCommentOnlyInputFile
188+ describe "alias stripping" $ do
189+ it "works" caseStripAlias
190+ describe "nulls" $ do
191+ checkNull "null"
192+ checkNull "Null"
193+ checkNull "NULL"
194+ checkNull "~"
195+ checkNull ""
196+
197+ describe "pretty output" $ do
198+ it "simple nulls" $ D.encode (object ["foo" .= D.Null]) `shouldBe` "foo: null\n"
199+ it "simple numbers" $ D.encode (object ["foo" .= (4 :: Int)]) `shouldBe` "foo: 4\n"
200+ it "True" $ D.encode (object ["foo" .= True]) `shouldBe` "foo: true\n"
201+ it "False" $ D.encode (object ["foo" .= False]) `shouldBe` "foo: false\n"
202+ it "simple string" $ D.encode (object ["foo" .= ("bar" :: T.Text)]) `shouldBe` "foo: bar\n"
203+ it "*" $ D.encode (object ["foo" .= ("*" :: T.Text)]) `shouldBe` "foo: '*'\n"
204+
205+ describe "special keys" $ do
206+ let tester key = it (T.unpack key) $
207+ let value = object [fromText key .= True]
208+ in D.encode value `shouldDecode` value
209+ mapM_ tester specialStrings
210+
211+ describe "special values" $ do
212+ let tester value = it (T.unpack value) $
213+ let value' = object ["foo" .= value]
214+ in D.encode value' `shouldDecode` value'
215+ mapM_ tester specialStrings
216+
217+ describe "decodeFileEither" $ do
218+ it "loads YAML through JSON into Haskell data" $ do
219+ tj <- either (error . show) id `fmap` D.decodeFileEither "test/json.yaml"
220+ tj `shouldBe` testJSON
221+
222+ context "when file does not exist" $ do
223+ it "returns Left" $ do
224+ (D.decodeFileEither "./does_not_exist.yaml" :: IO (Either D.ParseException D.Value)) >>= (`shouldSatisfy` isLeft)
225+
226+ describe "multiple document support" $ do
227+ it "decodes zero-length input" $
228+ "" `shouldDecodeAll` ([] :: [D.Value])
229+ it "decodes comment-only input" $
230+ "# foo\n# bar" `shouldDecodeAll` ([] :: [D.Value])
231+ it "decodes a single document stream" $
232+ "foo: true" `shouldDecodeAll` [object ["foo" .= True]]
233+ it "decodes multiple documents" $
234+ "--- 1\n--- 2" `shouldDecodeAll` [D.Number 1, D.Number 2]
235+
236+ describe "round-tripping of special scalars" $ do
237+ let special = words "y Y On ON false 12345 12345.0 12345a 12e3"
238+ forM_ special $ \w -> it w $
239+ let v = object ["word" .= w]
240+ in D.encode v `shouldDecode` v
241+ it "no tags" $ D.encode (object ["word" .= ("true" :: String)]) `shouldBe` "word: 'true'\n"
242+
243+ it "aliases in keys #49" caseIssue49
244+
245+ it "serialization of +123 #64" $ do
246+ D.encode ("+123" :: String) `shouldDecode` ("+123" :: String)
247+
248+ it "preserves Scientific precision" casePreservesScientificPrecision
249+
250+ it "truncates files" caseTruncatesFiles
251+
252+ it "encode quotes special keys #137" $ caseSpecialKeys D.encode
253+
254+ it "encodePretty quotes special keys #179" $ caseSpecialKeys (Pretty.encodePretty Pretty.defConfig)
255+
256+ describe "non-decimal numbers #135" $ do
257+ let go str val = it str $ encodeUtf8 (T.pack str) `shouldDecode` val
258+ go "12345" (12345 :: Int)
259+ go "+12345" (12345 :: Int)
260+ go "0o14" (12 :: Int)
261+ go "0o123" (83 :: Int)
262+ go "0xC" (12 :: Int)
263+ go "0xc" (12 :: Int)
264+ go "0xdeadBEEF" (3735928559 :: Int64)
265+ go "0xDEADBEEF" (3735928559 :: Int64)
266+ go "1.23015e+3" (1230.15 :: Scientific)
267+ go "12.3015e+02" (1230.15 :: Scientific)
268+ go "1230.15" (1230.15 :: Scientific)
269+
270+ describe "Text.Libyaml with default tag rendering" $ do
271+ let enc = testEncodeWith Y.defaultFormatOptions
272+ it "elides custom sequence tags" $
273+ enc taggedSequence `shouldReturn` "[]\n"
274+ it "elides custom mapping tags" $
275+ enc taggedMapping `shouldReturn` "{}\n"
276+ it "elides default sequence tags" $
277+ enc defaultTaggedSequence `shouldReturn` "[]\n"
278+ it "elides default mapping tags" $
279+ enc defaultTaggedMapping `shouldReturn` "{}\n"
280+ it "handles NoTag on sequences" $
281+ enc untaggedSequence `shouldReturn` "[]\n"
282+ it "handles NoTag on mappings" $
283+ enc untaggedMapping `shouldReturn` "{}\n"
284+ it "handles mixed tag usages but elides all mapping and sequence tags" $
285+ enc mixedTagSampleA `shouldReturn` "- {}\n"
286+ it "in combination of tags, anchors and styles, outputs only the scalar tags" $
287+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c [&d !!null '']\n"
288+ it "outputs tags when double quoted" $
289+ enc [Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing] `shouldReturn` "!!str \"foo\"\n"
290+ it "outputs tags when single quoted" $
291+ enc [Y.EventScalar "foo" Y.StrTag Y.SingleQuoted Nothing] `shouldReturn` "!!str 'foo'\n"
292+ it "outputs tags on literal text" $
293+ enc [Y.EventScalar "foo" Y.StrTag Y.Literal Nothing] `shouldReturn` "!!str |-\n foo\n"
294+ it "outputs tags on folded text" $
295+ enc [Y.EventScalar "foo" Y.StrTag Y.Folded Nothing] `shouldReturn` "!!str >-\n foo\n"
296+ describe "Text.Libyaml with all tags on" $ do
297+ let enc = testEncodeWith $ Y.setTagRendering Y.renderAllTags Y.defaultFormatOptions
298+ it "will output custom sequence tags" $
299+ enc taggedSequence `shouldReturn` "!foo []\n"
300+ it "will output custom mapping tags" $
301+ enc taggedMapping `shouldReturn` "!foo {}\n"
302+ it "will output default sequence tags" $
303+ enc defaultTaggedSequence `shouldReturn` "!!seq []\n"
304+ it "will output default mapping tags" $
305+ enc defaultTaggedMapping `shouldReturn` "!!map {}\n"
306+ it "handles NoTag on sequences" $
307+ enc untaggedSequence `shouldReturn` "[]\n"
308+ it "handles NoTag on mappings" $
309+ enc untaggedMapping `shouldReturn` "{}\n"
310+ it "handles mixed tag usages outputting all mapping and sequence tags" $
311+ enc mixedTagSampleA `shouldReturn` "- !foo {}\n"
312+ it "in combination of tags, anchors and styles, outputs all the tags" $
313+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c !baz [&d !!null '']\n"
314+ it "outputs plain tags" $
315+ enc [Y.EventScalar "foo" Y.StrTag Y.Plain Nothing] `shouldReturn` "!!str foo\n"
316+ it "respects PlainNoTag tags" $
317+ enc [Y.EventScalar "foo" Y.StrTag Y.PlainNoTag Nothing] `shouldReturn` "foo\n"
318+ describe "Text.Libyaml with uri tags on" $ do
319+ let enc = testEncodeWith $ Y.setTagRendering Y.renderUriTags Y.defaultFormatOptions
320+ it "will output custom sequence tags" $
321+ enc taggedSequence `shouldReturn` "!foo []\n"
322+ it "will output custom mapping tags" $
323+ enc taggedMapping `shouldReturn` "!foo {}\n"
324+ it "will output default sequence tags" $
325+ enc defaultTaggedSequence `shouldReturn` "[]\n"
326+ it "will output default mapping tags" $
327+ enc defaultTaggedMapping `shouldReturn` "{}\n"
328+ it "handles NoTag on sequences" $
329+ enc untaggedSequence `shouldReturn` "[]\n"
330+ it "handles NoTag on mappings" $
331+ enc untaggedMapping `shouldReturn` "{}\n"
332+ it "handles mixed tag usages outputting all mapping and sequence tags" $
333+ enc mixedTagSampleA `shouldReturn` "- !foo {}\n"
334+ it "in combination of tags, anchors and styles, outputs all the tags" $
335+ enc mixedTagSampleB `shouldReturn` "&a\n&b !<bar> foo: &c !baz [&d '']\n"
336+ describe "Text.Libyaml with tags off" $ do
337+ let enc = testEncodeWith $ Y.setTagRendering Y.renderNoTags Y.defaultFormatOptions
338+ it "outputs plain tags" $
339+ enc [Y.EventScalar "foo" Y.StrTag Y.Plain Nothing] `shouldReturn` "foo\n"
340+ it "respects PlainNoTag tags" $
341+ enc [Y.EventScalar "foo" Y.StrTag Y.PlainNoTag Nothing] `shouldReturn` "foo\n"
342+ it "elides tags when double quoted" $
343+ enc [Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing] `shouldReturn` "\"foo\"\n"
344+ it "elides tags when single quoted" $
345+ enc [Y.EventScalar "foo" Y.StrTag Y.SingleQuoted Nothing] `shouldReturn` "'foo'\n"
346+ it "elides tags on literal text" $
347+ enc [Y.EventScalar "foo" Y.StrTag Y.Literal Nothing] `shouldReturn` "|-\n foo\n"
348+ it "elides tags on folded text" $
349+ enc [Y.EventScalar "foo" Y.StrTag Y.Folded Nothing] `shouldReturn` ">-\n foo\n"
350+ describe "Text.Libyaml with only UriTags set to render " $ do
351+ let enc =
352+ testEncodeWith $
353+ Y.setTagRendering Y.renderUriTags $ Y.defaultFormatOptions
354+ it "outputs only UriTags" $
355+ enc
356+ [ Y.EventSequenceStart Y.NoTag Y.FlowSequence Nothing
357+ , Y.EventScalar "foo" Y.StrTag Y.DoubleQuoted Nothing
358+ , Y.EventScalar "99" Y.IntTag Y.Plain Nothing
359+ , Y.EventScalar "99.99" Y.FloatTag Y.Plain Nothing
360+ , Y.EventScalar "bar" Y.NoTag Y.Plain Nothing
361+ , Y.EventScalar "foo" (Y.UriTag "!foo") Y.DoubleQuoted Nothing
362+ , Y.EventScalar "foo" (Y.UriTag "!foo") Y.Plain Nothing
363+ , Y.EventSequenceEnd
364+ ] `shouldReturn`
365+ "[\"foo\", 99, 99.99, bar, !foo \"foo\", !foo foo]\n"
366+
367+ prop "Scientific values round-trip" $ \coeff expon -> do
368+ let val = D.Number $ S.scientific coeff expon
369+ let rendered = D.encode val
370+ case D.decodeEither' rendered of
371+ Left e -> error $ show (coeff, expon, e)
372+ Right val' -> val' `shouldBe` val
373+
374+specialStrings :: [T.Text]
375+specialStrings =
376+ [ "fo\"o"
377+ , "fo\'o"
378+ , "fo\\'o"
379+ , "fo: o"
380+ , "foo\nbar\nbaz\n"
381+ ]
382+
383+counter :: Monad m => (Y.Event -> Bool) -> ConduitM Y.Event o m Int
384+counter pred' =
385+ CL.fold (\cnt e -> (if pred' e then 1 else 0) + cnt) 0
386+
387+caseHelper :: String
388+ -> (Y.Event -> Bool)
389+ -> Int
390+ -> Assertion
391+caseHelper yamlString pred' expRes = do
392+ res <- runConduitRes $ Y.decode (B8.pack yamlString) .| counter pred'
393+ res @?= expRes
394+
395+caseCountScalarsWithAnchor :: Assertion
396+caseCountScalarsWithAnchor =
397+ caseHelper yamlString isScalarA 1
398+ where
399+ yamlString = "foo:\n - &anchor bin1\n - bin2\n - bin3"
400+ isScalarA (Y.EventScalar _ _ _ (Just _)) = True
401+ isScalarA _ = False
402+
403+caseCountSequencesWithAnchor :: Assertion
404+caseCountSequencesWithAnchor =
405+ caseHelper yamlString isSequenceStartA 1
406+ where
407+ yamlString = "foo: &anchor\n - bin1\n - bin2\n - bin3"
408+ isSequenceStartA (Y.EventSequenceStart Y.NoTag _ (Just _)) = True
409+ isSequenceStartA _ = False
410+
411+caseCountMappingsWithAnchor :: Assertion
412+caseCountMappingsWithAnchor =
413+ caseHelper yamlString isMappingA 1
414+ where
415+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3"
416+ isMappingA (Y.EventMappingStart _ _ (Just _)) = True
417+ isMappingA _ = False
418+
419+caseCountAliases :: Assertion
420+caseCountAliases =
421+ caseHelper yamlString isAlias 1
422+ where
423+ yamlString = "foo: &anchor\n key1: bin1\n key2: bin2\n key3: bin3\nboo: *anchor"
424+ isAlias Y.EventAlias{} = True
425+ isAlias _ = False
426+
427+caseCountMappingTags :: Assertion
428+caseCountMappingTags =
429+ caseHelper yamlString isCustomTaggedMapping 1
430+ where
431+ yamlString = "foo: !bar\n k: v\n k2: v2"
432+ isCustomTaggedMapping (Y.EventMappingStart (Y.UriTag "!bar") _ _) = True
433+ isCustomTaggedMapping _ = False
434+
435+caseCountEmptyMappingTags :: Assertion
436+caseCountEmptyMappingTags =
437+ caseHelper yamlString isCustomTaggedMapping 1
438+ where
439+ yamlString = "foo: !\n k: v\n k2: v2"
440+ isCustomTaggedMapping (Y.EventMappingStart (Y.UriTag "!") _ _) = True
441+ isCustomTaggedMapping _ = False
442+
443+caseCountSequenceTags :: Assertion
444+caseCountSequenceTags =
445+ caseHelper yamlString isCustomTaggedSequence 1
446+ where
447+ yamlString = "foo: !bar [x, y, z]"
448+ isCustomTaggedSequence (Y.EventSequenceStart (Y.UriTag "!bar") _ _) = True
449+ isCustomTaggedSequence _ = False
450+
451+caseCountEmptySequenceTags :: Assertion
452+caseCountEmptySequenceTags =
453+ caseHelper yamlString isCustomTaggedSequence 1
454+ where
455+ yamlString = "foo: ! [x, y, z]"
456+ isCustomTaggedSequence (Y.EventSequenceStart (Y.UriTag "!") _ _) = True
457+ isCustomTaggedSequence _ = False
458+
459+caseCountFlowStyleSequences :: Assertion
460+caseCountFlowStyleSequences =
461+ caseHelper yamlString isFlowStyleSequence 1
462+ where
463+ yamlString = "foo: [x, y, z]"
464+ isFlowStyleSequence (Y.EventSequenceStart _ Y.FlowSequence _) = True
465+ isFlowStyleSequence _ = False
466+
467+caseCountBlockStyleSequences :: Assertion
468+caseCountBlockStyleSequences =
469+ caseHelper yamlString isBlockStyleSequence 1
470+ where
471+ yamlString = "foo:\n- x\n- y\n- z\n"
472+ isBlockStyleSequence (Y.EventSequenceStart _ Y.BlockSequence _) = True
473+ isBlockStyleSequence _ = False
474+
475+caseCountFlowStyleMappings :: Assertion
476+caseCountFlowStyleMappings =
477+ caseHelper yamlString isFlowStyleMapping 1
478+ where
479+ yamlString = "foo: { bar: 1, baz: 2 }"
480+ isFlowStyleMapping (Y.EventMappingStart _ Y.FlowMapping _) = True
481+ isFlowStyleMapping _ = False
482+
483+caseCountBlockStyleMappings :: Assertion
484+caseCountBlockStyleMappings =
485+ caseHelper yamlString isBlockStyleMapping 1
486+ where
487+ yamlString = "foo: bar\nbaz: quux"
488+ isBlockStyleMapping (Y.EventMappingStart _ Y.BlockMapping _) = True
489+ isBlockStyleMapping _ = False
490+
491+caseCountScalars :: Assertion
492+caseCountScalars = do
493+ res <- runConduitRes $ Y.decode yamlBS .| CL.fold adder accum
494+ res @?= (7, 1, 2)
495+ where
496+ yamlString = "foo:\n baz: [bin1, bin2, bin3]\nbaz: bazval"
497+ yamlBS = B8.pack yamlString
498+ adder (s, l, m) (Y.EventScalar{}) = (s + 1, l, m)
499+ adder (s, l, m) (Y.EventSequenceStart{}) = (s, l + 1, m)
500+ adder (s, l, m) (Y.EventMappingStart{}) = (s, l, m + 1)
501+ adder a _ = a
502+ accum = (0, 0, 0) :: (Int, Int, Int)
503+
504+caseLargestString :: Assertion
505+caseLargestString = do
506+ res <- runConduitRes $ Y.decodeFile filePath .| CL.fold adder accum
507+ res @?= (length expected, expected)
508+ where
509+ expected = "this one is just a little bit bigger than the others"
510+ filePath = "test/largest-string.yaml"
511+ adder (i, s) (Y.EventScalar bs _ _ _) =
512+ let s' = B8.unpack bs
513+ i' = length s'
514+ in if i' > i then (i', s') else (i, s)
515+ adder acc _ = acc
516+ accum = (0, "no strings found")
517+
518+newtype MyEvent = MyEvent Y.Event deriving Show
519+instance Eq MyEvent where
520+ (MyEvent (Y.EventScalar s t _ _)) == (MyEvent (Y.EventScalar s' t' _ _)) =
521+ s == s' && t == t'
522+ MyEvent e1 == MyEvent e2 = e1 == e2
523+
524+caseEncodeDecode :: Assertion
525+caseEncodeDecode = do
526+ eList <- runConduitRes $ Y.decode yamlBS .| CL.consume
527+ bs <- runConduitRes $ CL.sourceList eList .| Y.encode
528+ eList2 <- runConduitRes $ Y.decode bs .| CL.consume
529+ map MyEvent eList @=? map MyEvent eList2
530+ where
531+ yamlString = "foo: bar\nbaz:\n - bin1\n - bin2\n"
532+ yamlBS = B8.pack yamlString
533+
534+caseEncodeDecodeEvents :: Assertion
535+caseEncodeDecodeEvents = do
536+ let events = Internal.objToEvents D.defaultStringStyle testJSON []
537+ result <- Internal.decodeHelper_ . CL.sourceList $ eventStream events
538+ let (_, value) = either (error . show) id result
539+ value @?= testJSON
540+
541+caseEncodeDecodeFile :: Assertion
542+caseEncodeDecodeFile = withFile "" $ \tmpPath -> do
543+ eList <- runConduitRes $ Y.decodeFile filePath .| CL.consume
544+ runConduitRes $ CL.sourceList eList .| Y.encodeFile tmpPath
545+ eList2 <- runConduitRes $ Y.decodeFile filePath .| CL.consume
546+ map MyEvent eList @=? map MyEvent eList2
547+ where
548+ filePath = "test/largest-string.yaml"
549+
550+caseInterleave :: Assertion
551+caseInterleave = withFile "" $ \tmpPath -> withFile "" $ \tmpPath2 -> do
552+ () <- runConduitRes $ Y.decodeFile filePath .| Y.encodeFile tmpPath
553+ () <- runConduitRes $ Y.decodeFile tmpPath .| Y.encodeFile tmpPath2
554+ f1 <- readFile tmpPath
555+ f2 <- readFile tmpPath2
556+ f1 @=? f2
557+ where
558+ filePath = "test/largest-string.yaml"
559+
560+caseDecodeInvalidDocument :: Assertion
561+caseDecodeInvalidDocument = do
562+ x <- try $ runConduitRes $ Y.decode yamlBS .| CL.sinkNull
563+ case x of
564+ Left (_ :: SomeException) -> return ()
565+ Right y -> do
566+ putStrLn $ "bad return value: " ++ show y
567+ assertFailure "expected parsing exception, but got no errors"
568+ where
569+ yamlString = " - foo\n - baz\nbuz"
570+ yamlBS = B8.pack yamlString
571+
572+mkScalar :: String -> D.Value
573+mkScalar = mkStrScalar
574+
575+mkStrScalar :: String -> D.Value
576+mkStrScalar = D.String . T.pack
577+
578+mappingKey :: D.Value-> String -> D.Value
579+mappingKey (D.Object m) k = (fromJust . M.lookup (fromText $ T.pack k) $ m)
580+mappingKey _ _ = error "expected Object"
581+
582+sample :: D.Value
583+sample = array
584+ [ D.String "foo"
585+ , object
586+ [ ("bar1", D.String "bar2")
587+ , ("bar3", D.String "")
588+ ]
589+ , D.String ""
590+ , D.Number 1
591+ , D.Number 0.1
592+ , D.Bool True
593+ , D.Null
594+ ]
595+
596+sampleBuilder :: B.YamlBuilder
597+sampleBuilder = B.array
598+ [ B.string "foo"
599+ , B.mapping
600+ [ ("bar1", B.string "bar2")
601+ , ("bar3", B.string "")
602+ ]
603+ , B.string ""
604+ , B.scientific 1
605+ , B.scientific 0.1
606+ , B.bool True
607+ , B.null
608+ ]
609+
610+caseEncodeDecodeData :: Assertion
611+caseEncodeDecodeData = D.encode sample `shouldDecode` sample
612+
613+caseEncodeDecodeDataPretty :: Assertion
614+caseEncodeDecodeDataPretty =
615+ Pretty.encodePretty Pretty.defConfig sample `shouldDecode` sample
616+
617+caseEncodeDecodeDataBuilder :: Assertion
618+caseEncodeDecodeDataBuilder = do
619+ let events = B.unYamlBuilder sampleBuilder []
620+ bs <- testEncodeWith Y.defaultFormatOptions events
621+ bs `shouldDecodeEvents` eventStream events
622+
623+caseEncodeDecodeComplexMappingBuilder :: Assertion
624+caseEncodeDecodeComplexMappingBuilder = do
625+ let events = B.unYamlBuilder builder []
626+ bs <- testEncodeWith Y.defaultFormatOptions events
627+ bs `shouldDecodeEvents` eventStream events
628+ where
629+ builder :: B.YamlBuilder
630+ builder = B.mappingComplex
631+ [ ( B.mapping
632+ [ ("foo", B.scientific 1)
633+ , ("bar", B.scientific 2)
634+ ]
635+ , B.bool True
636+ )
637+ ]
638+
639+caseEncodeDecodeFileData :: Assertion
640+caseEncodeDecodeFileData = withFile "" $ \fp -> do
641+ D.encodeFile fp sample
642+ out <- D.decodeFileThrow fp
643+ out @?= sample
644+
645+caseEncodeDecodeNonAsciiFileData :: Assertion
646+caseEncodeDecodeNonAsciiFileData = do
647+ let mySample = (object ["foo" .= True])
648+ inTempDirectory $ do
649+ createDirectory "accenté"
650+ D.encodeFile "accenté/bar.yaml" mySample
651+ out1 <- D.decodeFileThrow "accenté/bar.yaml"
652+ out1 @?= mySample
653+
654+ c <- readFile "test/resources/accent/foo.yaml"
655+ inTempDirectory $ do
656+ createDirectoryIfMissing True "test/resources/unicode/accenté/"
657+ writeFile "test/resources/unicode/accenté/foo.yaml" c
658+ out2 <- D.decodeFileThrow "test/resources/unicode/accenté/foo.yaml"
659+ out2 @?= mySample
660+
661+caseEncodeDecodeStrings :: Assertion
662+caseEncodeDecodeStrings = D.encode sample `shouldDecode` sample
663+
664+caseEncodeDecodeStringsPretty :: Assertion
665+caseEncodeDecodeStringsPretty =
666+ Pretty.encodePretty Pretty.defConfig sample `shouldDecode` sample
667+
668+caseDecodeInvalid :: Assertion
669+caseDecodeInvalid =
670+ D.decodeThrow "\tthis is 'not' valid :-)" `shouldBe`
671+ (Nothing :: Maybe D.Value)
672+
673+caseSimpleScalarAlias :: Assertion
674+caseSimpleScalarAlias =
675+ "- &anch foo\n- baz\n- *anch" `shouldDecode`
676+ array [(mkScalar "foo"), (mkScalar "baz"), (mkScalar "foo")]
677+
678+caseSimpleSequenceAlias :: Assertion
679+caseSimpleSequenceAlias =
680+ "seq: &anch\n - foo\n - baz\nseq2: *anch" `shouldDecode`
681+ object [("seq", array [(mkScalar "foo"), (mkScalar "baz")]), ("seq2", array [(mkScalar "foo"), (mkScalar "baz")])]
682+
683+caseSimpleMappingAlias :: Assertion
684+caseSimpleMappingAlias =
685+ "map: &anch\n key1: foo\n key2: baz\nmap2: *anch" `shouldDecode`
686+ object [(packStr "map", object [("key1", mkScalar "foo"), ("key2", (mkScalar "baz"))]), (packStr "map2", object [("key1", (mkScalar "foo")), ("key2", mkScalar "baz")])]
687+ where
688+ packStr = fromText . T.pack
689+
690+caseMappingAliasBeforeAnchor :: Assertion
691+caseMappingAliasBeforeAnchor =
692+ case D.decodeThrow "map: *anch\nmap2: &anch\n key1: foo\n key2: baz" of
693+ Nothing -> pure ()
694+ Just (_ :: D.Value) -> error "decode should return Nothing due to unknown alias"
695+
696+caseMappingAliasInsideAnchor :: Assertion
697+caseMappingAliasInsideAnchor = do
698+ case D.decodeThrow "map: &anch\n key1: foo\n key2: *anch" of
699+ Nothing -> pure ()
700+ Just (_ :: D.Value) -> error "decode should return Nothing due to unknown alias"
701+
702+caseScalarAliasOverriding :: Assertion
703+caseScalarAliasOverriding =
704+ "- &anch foo\n- baz\n- *anch\n- &anch boo\n- buz\n- *anch" `shouldDecode`
705+ array [(mkScalar "foo"), (mkScalar "baz"), (mkScalar "foo"), (mkScalar "boo"), (mkScalar "buz"), (mkScalar "boo")]
706+
707+caseAllKeysShouldBeUnique :: Assertion
708+caseAllKeysShouldBeUnique = do
709+ res <- D.decodeThrow "foo1: foo\nfoo2: baz\nfoo1: buz"
710+ mappingKey res "foo1" `shouldBe` mkScalar "buz"
711+
712+caseSimpleMappingMerge :: Assertion
713+caseSimpleMappingMerge = do
714+ res <- D.decodeThrow "foo1: foo\nfoo2: baz\n<<:\n foo1: buz\n foo3: fuz"
715+ mappingKey res "foo1" `shouldBe` mkScalar "foo"
716+ mappingKey res "foo3" `shouldBe` mkScalar "fuz"
717+
718+caseMergeSequence :: Assertion
719+caseMergeSequence = do
720+ res <- D.decodeThrow "m1: &m1\n k1: !!str 1\n k2: !!str 2\nm2: &m2\n k1: !!str 3\n k3: !!str 4\nfoo1: foo\n<<: [ *m1, *m2 ]"
721+ mappingKey res "foo1" @?= (mkScalar "foo")
722+ mappingKey res "k1" @?= (D.String "1")
723+ mappingKey res "k2" @?= (D.String "2")
724+ mappingKey res "k3" @?= (D.String "4")
725+
726+caseDataTypes :: Assertion
727+caseDataTypes =
728+ D.encode val `shouldDecode` val
729+ where
730+ val = object
731+ [ ("string", D.String "foo")
732+ , ("int", D.Number 5)
733+ , ("float", D.Number 4.3)
734+ , ("true", D.Bool True)
735+ , ("false", D.Bool False)
736+ , ("null", D.Null)
737+ ]
738+
739+caseEncodeInvalidNumbers :: Assertion
740+caseEncodeInvalidNumbers =
741+ D.encode (D.String ".") `shouldBe` ".\n"
742+
743+caseDataTypesPretty :: Assertion
744+caseDataTypesPretty =
745+ Pretty.encodePretty Pretty.defConfig val `shouldDecode` val
746+ where
747+ val = object
748+ [ ("string", D.String "foo")
749+ , ("int", D.Number 5)
750+ , ("float", D.Number 4.3)
751+ , ("true", D.Bool True)
752+ , ("false", D.Bool False)
753+ , ("null", D.Null)
754+ ]
755+caseQuotedNumber, caseUnquotedNumber, caseAttribNumber, caseIntegerDecimals :: Assertion
756+caseQuotedNumber = "foo: \"1234\"" `shouldDecode` object [("foo", D.String "1234")]
757+caseUnquotedNumber = "foo: 1234" `shouldDecode` object [("foo", D.Number 1234)]
758+caseAttribNumber = "foo: !!str 1234" `shouldDecode` object [("foo", D.String "1234")]
759+caseIntegerDecimals = "1\n" `shouldDecode` (1 :: Int)
760+
761+obj :: D.Value
762+obj = object [("foo", D.Bool False), ("bar", D.Bool True), ("baz", D.Bool True)]
763+
764+caseLowercaseBool, caseUppercaseBool, caseTitlecaseBool :: Assertion
765+caseLowercaseBool = "foo: off\nbar: y\nbaz: true" `shouldDecode` obj
766+caseUppercaseBool = "foo: FALSE\nbar: Y\nbaz: ON" `shouldDecode` obj
767+caseTitlecaseBool = "foo: No\nbar: Yes\nbaz: True" `shouldDecode` obj
768+
769+caseEmptyInput :: Assertion
770+caseEmptyInput = B8.empty `shouldDecode` D.Null
771+
772+caseEmptyInputFile :: Assertion
773+caseEmptyInputFile = do
774+ out <- D.decodeFileEither "test/resources/empty.yaml"
775+ either (Left . D.prettyPrintParseException) Right out @?= Right D.Null
776+
777+caseCommentOnlyInput :: Assertion
778+caseCommentOnlyInput = "# comment\n" `shouldDecode` D.Null
779+
780+caseCommentOnlyInputFile :: Assertion
781+caseCommentOnlyInputFile = do
782+ out <- D.decodeFileEither "test/resources/empty2.yaml"
783+ either (Left . D.prettyPrintParseException) Right out @?= Right D.Null
784+
785+checkNull :: T.Text -> Spec
786+checkNull x =
787+ it ("null recognized: " ++ show x) $
788+ B8.pack ("foo: " ++ T.unpack x) `shouldDecode` object [("foo", D.Null)]
789+
790+caseStripAlias :: Assertion
791+caseStripAlias =
792+ src `shouldDecode` object
793+ [ "Default" .= object
794+ [ "foo" .= (1 :: Int)
795+ , "bar" .= (2 :: Int)
796+ ]
797+ , "Obj" .= object
798+ [ "foo" .= (1 :: Int)
799+ , "bar" .= (2 :: Int)
800+ , "key" .= (3 :: Int)
801+ ]
802+ ]
803+ where
804+ src = "Default: &def\n foo: 1\n bar: 2\nObj:\n <<: *def\n key: 3\n"
805+
806+caseIssue49 :: Assertion
807+caseIssue49 =
808+ src `shouldDecode` object
809+ [ "a" .= object [ "value" .= (1.0 :: Double) ]
810+ , "b" .= object [ "value" .= (1.2 :: Double) ]
811+ ]
812+ where
813+ src = "---\na:\n &id5 value: 1.0\nb:\n *id5: 1.2"
814+
815+-- | We cannot guarantee this before aeson started using 'Scientific'.
816+casePreservesScientificPrecision :: Assertion
817+casePreservesScientificPrecision = do
818+ "x: 1e-100000" `shouldDecode` object
819+ [ "x" .= D.Number (read "1e-100000") ]
820+ -- Note that this ought to work also without 'Scientific', given
821+ -- that @read (show "9.78159610558926e-5") == 9.78159610558926e-5@.
822+ -- However, it didn't work (and still doesn't work with aeson < 0.7)
823+ -- for two reasons:
824+ --
825+ -- - We use 'Data.Text.Read.double', which is not as accurate as it
826+ -- can be;
827+ -- - Even if we used 'Data.Text.Read.rational' we would not get good
828+ -- results, because of <https://github.com/bos/text/issues/34>.
829+ "x: 9.78159610558926e-5" `shouldDecode` object
830+ [ "x" .= D.Number (read "9.78159610558926e-5") ]
831+
832+caseTruncatesFiles :: Assertion
833+caseTruncatesFiles = withSystemTempFile "truncate.yaml" $ \fp h -> do
834+ replicateM_ 500 $ B8.hPut h "HELLO WORLD!!!!!\n"
835+ hClose h
836+ let val = object ["hello" .= ("world" :: String)]
837+ D.encodeFile fp val
838+ res <- D.decodeFileEither fp
839+ either (Left . show) Right res `shouldBe` Right val
840+
841+caseSpecialKeys :: (KeyMap () -> B8.ByteString) -> Assertion
842+caseSpecialKeys encoder = do
843+ let keys = T.words "true false NO YES 1.2 1e5 null"
844+ bs = encoder $ M.fromList $ map (, ()) $ fmap fromText keys
845+ text = decodeUtf8 bs
846+ forM_ keys $ \key -> do
847+ let quoted = T.concat ["'", key, "'"]
848+ unless (quoted `T.isInfixOf` text) $ error $ concat
849+ [ "Could not find quoted key: "
850+ , T.unpack quoted
851+ , "\n\n"
852+ , T.unpack text
853+ ] :: IO ()
854+
855+taggedSequence :: [Y.Event]
856+taggedSequence =
857+ [ Y.EventSequenceStart (Y.UriTag "!foo") Y.FlowSequence Nothing
858+ , Y.EventSequenceEnd
859+ ]
860+
861+taggedMapping :: [Y.Event]
862+taggedMapping =
863+ [ Y.EventMappingStart (Y.UriTag "!foo") Y.FlowMapping Nothing
864+ , Y.EventMappingEnd
865+ ]
866+
867+defaultTaggedSequence :: [Y.Event]
868+defaultTaggedSequence =
869+ [Y.EventSequenceStart Y.SeqTag Y.FlowSequence Nothing, Y.EventSequenceEnd]
870+
871+defaultTaggedMapping :: [Y.Event]
872+defaultTaggedMapping =
873+ [Y.EventMappingStart Y.MapTag Y.FlowMapping Nothing, Y.EventMappingEnd]
874+
875+untaggedSequence :: [Y.Event]
876+untaggedSequence =
877+ [Y.EventSequenceStart Y.NoTag Y.FlowSequence Nothing, Y.EventSequenceEnd]
878+
879+untaggedMapping :: [Y.Event]
880+untaggedMapping =
881+ [Y.EventMappingStart Y.NoTag Y.FlowMapping Nothing, Y.EventMappingEnd]
882+
883+mixedTagSampleA :: [Y.Event]
884+mixedTagSampleA =
885+ [ Y.EventSequenceStart Y.NoTag Y.BlockSequence Nothing
886+ , Y.EventMappingStart (Y.UriTag "!foo") Y.FlowMapping Nothing
887+ , Y.EventMappingEnd
888+ , Y.EventSequenceEnd
889+ ]
890+
891+mixedTagSampleB :: [Y.Event]
892+mixedTagSampleB =
893+ [ Y.EventMappingStart Y.NoTag Y.BlockMapping (Just "a")
894+ , Y.EventScalar "foo" (Y.UriTag "bar") Y.Plain (Just "b")
895+ , Y.EventSequenceStart (Y.UriTag "!baz") Y.FlowSequence (Just "c")
896+ , Y.EventScalar "" Y.NullTag Y.Plain (Just "d")
897+ , Y.EventSequenceEnd
898+ , Y.EventMappingEnd
899+ ]
yaml/test/Spec.hsnew file+1
@@ -0,0 +1 @@
1+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
yaml/test/json.yamlnew file+9
@@ -0,0 +1,9 @@
1+string: str
2+number: 2
3+anArray:
4+ - a
5+ - b
6+hash:
7+ key1: value1
8+ key2: value2
9+extrastring: 1234-foo
yaml/test/largest-string.yamlnew file+6
@@ -0,0 +1,6 @@
1+this is a long string: but this one is even longer
2+this is shorter:
3+ - many
4+ - tiny
5+ - string
6+one the other hand: this one is just a little bit bigger than the others
yaml/test/resources/accent/foo.yamlnew file+1
@@ -0,0 +1 @@
1+foo: true
yaml/test/resources/bar.yamlnew file+2
@@ -0,0 +1,2 @@
1+one: 1
2+two: 2
yaml/test/resources/baz.yamlnew file+1
@@ -0,0 +1 @@
1+foo: !include foo.yaml
yaml/test/resources/empty.yamlnew file

No changes to the content.

yaml/test/resources/empty2.yamlnew file+1
@@ -0,0 +1 @@
1+# comment
yaml/test/resources/foo.yamlnew file+3
@@ -0,0 +1,3 @@
1+foo: 23
2+bar: !include bar.yaml
3+baz: 42
yaml/test/resources/loop/bar.yamlnew file+2
@@ -0,0 +1,2 @@
1+one: 1
2+two: !include foo.yaml
yaml/test/resources/loop/foo.yamlnew file+3
@@ -0,0 +1,3 @@
1+foo: 23
2+bar: !include bar.yaml
3+baz: 42
yaml/yaml.cabalnew file+228
@@ -0,0 +1,228 @@
1+cabal-version: 1.12
2+
3+-- This file has been generated from package.yaml by hpack version 0.35.1.
4+--
5+-- see: https://github.com/sol/hpack
6+
7+name: yaml
8+version: 0.11.11.2
9+synopsis: Support for parsing and rendering YAML documents.
10+description: README and API documentation are available at <https://www.stackage.org/package/yaml>
11+category: Data
12+stability: stable
13+homepage: https://github.com/snoyberg/yaml#readme
14+bug-reports: https://github.com/snoyberg/yaml/issues
15+author: Michael Snoyman <michael@snoyman.com>, Anton Ageev <antage@gmail.com>,Kirill Simonov
16+maintainer: Michael Snoyman <michael@snoyman.com>
17+license: BSD3
18+license-file: LICENSE
19+build-type: Simple
20+extra-source-files:
21+ test/largest-string.yaml
22+ test/json.yaml
23+ test/resources/foo.yaml
24+ test/resources/bar.yaml
25+ test/resources/baz.yaml
26+ test/resources/accent/foo.yaml
27+ test/resources/loop/foo.yaml
28+ test/resources/loop/bar.yaml
29+ test/resources/empty.yaml
30+ test/resources/empty2.yaml
31+ README.md
32+ ChangeLog.md
33+
34+source-repository head
35+ type: git
36+ location: https://github.com/snoyberg/yaml
37+
38+flag no-examples
39+ description: don't build the examples
40+ manual: False
41+ default: True
42+
43+flag no-exe
44+ description: don't install the yaml2json or json2yaml executables
45+ manual: False
46+ default: True
47+
48+library
49+ exposed-modules:
50+ Data.Yaml
51+ Data.Yaml.Aeson
52+ Data.Yaml.Builder
53+ Data.Yaml.Config
54+ Data.Yaml.Include
55+ Data.Yaml.Internal
56+ Data.Yaml.Parser
57+ Data.Yaml.Pretty
58+ Data.Yaml.TH
59+ other-modules:
60+ Paths_yaml
61+ hs-source-dirs:
62+ src
63+ other-extensions:
64+ LambdaCase
65+ ghc-options: -Wall -Wcompat
66+ build-depends:
67+ aeson >=0.11
68+ , attoparsec >=0.11.3.0
69+ , base >=4.9.1 && <5
70+ , bytestring >=0.9.1.4
71+ , conduit >=1.2.8 && <1.4
72+ , containers
73+ , directory
74+ , filepath
75+ , libyaml ==0.1.*
76+ , mtl
77+ , resourcet >=0.3 && <1.4
78+ , scientific >=0.3
79+ , template-haskell
80+ , text
81+ , transformers >=0.1
82+ , unordered-containers
83+ , vector
84+ default-language: Haskell2010
85+
86+executable examples
87+ main-is: Main.hs
88+ other-modules:
89+ Config
90+ Simple
91+ Paths_yaml
92+ hs-source-dirs:
93+ examples
94+ ghc-options: -Wall -Wcompat
95+ build-depends:
96+ aeson >=0.11
97+ , attoparsec >=0.11.3.0
98+ , base >=4.9.1 && <5
99+ , bytestring >=0.9.1.4
100+ , conduit >=1.2.8 && <1.4
101+ , containers
102+ , directory
103+ , filepath
104+ , libyaml ==0.1.*
105+ , mtl
106+ , resourcet >=0.3 && <1.4
107+ , scientific >=0.3
108+ , template-haskell
109+ , text
110+ , transformers >=0.1
111+ , unordered-containers
112+ , vector
113+ default-language: Haskell2010
114+ if flag(no-examples)
115+ buildable: False
116+ else
117+ build-depends:
118+ raw-strings-qq
119+ , yaml
120+
121+executable json2yaml
122+ main-is: json2yaml.hs
123+ other-modules:
124+ Common
125+ Paths_yaml
126+ hs-source-dirs:
127+ exe
128+ ghc-options: -Wall -Wcompat
129+ build-depends:
130+ aeson >=0.11
131+ , attoparsec >=0.11.3.0
132+ , base >=4.9.1 && <5
133+ , bytestring >=0.9.1.4
134+ , conduit >=1.2.8 && <1.4
135+ , containers
136+ , directory
137+ , filepath
138+ , libyaml ==0.1.*
139+ , mtl
140+ , optparse-applicative
141+ , resourcet >=0.3 && <1.4
142+ , scientific >=0.3
143+ , template-haskell
144+ , text
145+ , transformers >=0.1
146+ , unordered-containers
147+ , vector
148+ , yaml
149+ default-language: Haskell2010
150+ if flag(no-exe)
151+ buildable: False
152+
153+executable yaml2json
154+ main-is: yaml2json.hs
155+ other-modules:
156+ Common
157+ Paths_yaml
158+ hs-source-dirs:
159+ exe
160+ other-extensions:
161+ CPP
162+ LambdaCase
163+ NamedFieldPuns
164+ ghc-options: -Wall -Wcompat
165+ build-depends:
166+ aeson >=0.11
167+ , attoparsec >=0.11.3.0
168+ , base >=4.9.1 && <5
169+ , bytestring >=0.9.1.4
170+ , conduit >=1.2.8 && <1.4
171+ , containers
172+ , directory
173+ , filepath
174+ , libyaml ==0.1.*
175+ , mtl
176+ , optparse-applicative
177+ , resourcet >=0.3 && <1.4
178+ , scientific >=0.3
179+ , template-haskell
180+ , text
181+ , transformers >=0.1
182+ , unordered-containers
183+ , vector
184+ , yaml
185+ default-language: Haskell2010
186+ if flag(no-exe)
187+ buildable: False
188+
189+test-suite spec
190+ type: exitcode-stdio-1.0
191+ main-is: Spec.hs
192+ other-modules:
193+ Data.Yaml.IncludeSpec
194+ Data.Yaml.THSpec
195+ Data.YamlSpec
196+ Paths_yaml
197+ hs-source-dirs:
198+ test
199+ ghc-options: -Wall -Wcompat -with-rtsopts=-K1K
200+ cpp-options: -DTEST
201+ build-tool-depends:
202+ hspec-discover:hspec-discover
203+ build-depends:
204+ HUnit
205+ , aeson >=0.11
206+ , attoparsec >=0.11.3.0
207+ , base >=4.9.1 && <5
208+ , base-compat
209+ , bytestring >=0.9.1.4
210+ , conduit >=1.2.8 && <1.4
211+ , containers
212+ , directory
213+ , filepath
214+ , hspec >=1.3
215+ , libyaml ==0.1.*
216+ , mockery
217+ , mtl
218+ , raw-strings-qq
219+ , resourcet >=0.3 && <1.4
220+ , scientific >=0.3
221+ , template-haskell
222+ , temporary
223+ , text
224+ , transformers >=0.1
225+ , unordered-containers
226+ , vector
227+ , yaml
228+ default-language: Haskell2010