a326e53 · typeable/yaml

git.iko.soy/typeable/yaml

on master help sign in

Merge pull request #148 from snoyberg/fix-space-leak

a326e53Michael Snoyman8 years ago

ChangeLog.md+1

compare with master

unifiedsplit

@@ -3,6 +3,7 @@

3## Next

5* Avoid incurring a `semigroups` dependency on recent GHCs.

6+* Fix a space leak that was introduced with `0.10.0` [#147](https://github.com/snoyberg/yaml/issues/147)

7## 0.10.0

8## 0.10.0

package.yaml+1−1

@@ -127,7 +127,7 @@ tests:

127 spec:

128 main: Spec.hs

129 source-dirs: test

130− ghc-options: -Wall

130+ ghc-options: -Wall "-with-rtsopts=-K1K"

131 cpp-options: -DTEST

132 dependencies:

133 - hspec >=1.3

src/Data/Yaml/Internal.hs+41−28

@@ -2,6 +2,7 @@

2{-# LANGUAGE DeriveDataTypeable #-}

3{-# LANGUAGE PatternGuards #-}

4{-# LANGUAGE OverloadedStrings #-}

5+{-# LANGUAGE BangPatterns #-}

5module Data.Yaml.Internal

6module Data.Yaml.Internal

6 (

7 (

7 ParseException(..)

8 ParseException(..)

@@ -22,7 +23,8 @@ import Control.Applicative ((<|>))

22import Control.Exception

23import Control.Exception

23import Control.Monad (when, unless)

24import Control.Monad (when, unless)

24import Control.Monad.Trans.Resource (ResourceT, runResourceT)

25import Control.Monad.Trans.Resource (ResourceT, runResourceT)

25−import Control.Monad.RWS

26+import Control.Monad.State.Strict

27+import Control.Monad.Reader

26import Data.Aeson

28import Data.Aeson

27import Data.Aeson.Internal (JSONPath, JSONPathElement(..))

29import Data.Aeson.Internal (JSONPath, JSONPathElement(..))

28import Data.Aeson.Types hiding (parse)

30import Data.Aeson.Types hiding (parse)

@@ -112,34 +114,45 @@ prettyPrintParseException pe = case pe of

112 ]

114 ]

113 CyclicIncludes -> "Cyclic includes"

115 CyclicIncludes -> "Cyclic includes"

114

116

115−defineAnchor :: Value -> String -> ConduitM e o Parse ()

117+defineAnchor :: Value -> String -> ReaderT JSONPath (ConduitM e o Parse) ()

116−defineAnchor value name = modify $ Map.insert name value

118+defineAnchor value name = modify (modifyAnchors $ Map.insert name value)

119+ where

120+ modifyAnchors :: (Map String Value -> Map String Value) -> ParseState -> ParseState

121+ modifyAnchors f st = st {parseStateAnchors = f (parseStateAnchors st)}

117

122

118−lookupAnchor :: String -> ConduitM e o Parse (Maybe Value)

123+lookupAnchor :: String -> ReaderT JSONPath (ConduitM e o Parse) (Maybe Value)

119−lookupAnchor name = gets (Map.lookup name)

124+lookupAnchor name = gets (Map.lookup name . parseStateAnchors)

120

125

121data Warning = DuplicateKey JSONPath

126data Warning = DuplicateKey JSONPath

122 deriving (Eq, Show)

127 deriving (Eq, Show)

123

128

124−addWarning :: Warning -> ConduitM e o Parse ()

129+addWarning :: Warning -> ReaderT JSONPath (ConduitM e o Parse) ()

125−addWarning = tell . return

130+addWarning w = modify (modifyWarnings (w :))

131+ where

132+ modifyWarnings :: ([Warning] -> [Warning]) -> ParseState -> ParseState

133+ modifyWarnings f st = st {parseStateWarnings = f (parseStateWarnings st)}

134+

135+data ParseState = ParseState {

136+ parseStateAnchors :: Map String Value

137+, parseStateWarnings :: [Warning]

138+}

126

139

127−type Parse = RWST JSONPath [Warning] (Map String Value) (ResourceT IO)

140+type Parse = StateT ParseState (ResourceT IO)

128

141

129−requireEvent :: Event -> ConduitM Event o Parse ()

142+requireEvent :: Event -> ReaderT JSONPath (ConduitM Event o Parse) ()

130requireEvent e = do

143requireEvent e = do

131− f <- CL.head

144+ f <- lift CL.head

132 unless (f == Just e) $ liftIO $ throwIO $ UnexpectedEvent f $ Just e

145 unless (f == Just e) $ liftIO $ throwIO $ UnexpectedEvent f $ Just e

133

146

134−parse :: ConduitM Event o Parse Value

147+parse :: ReaderT JSONPath (ConduitM Event o Parse) Value

135parse = do

148parse = do

136− streamStart <- CL.head

149+ streamStart <- lift CL.head

137 case streamStart of

150 case streamStart of

138 Nothing ->

151 Nothing ->

139 -- empty string input

152 -- empty string input

140 return Null

153 return Null

141 Just EventStreamStart -> do

154 Just EventStreamStart -> do

142− documentStart <- CL.head

155+ documentStart <- lift CL.head

143 case documentStart of

156 case documentStart of

144 Just EventStreamEnd ->

157 Just EventStreamEnd ->

145 -- empty file input, comment only string/file input

158 -- empty file input, comment only string/file input

@@ -153,7 +166,7 @@ parse = do

153 _ -> liftIO $ throwIO $ UnexpectedEvent streamStart Nothing

166 _ -> liftIO $ throwIO $ UnexpectedEvent streamStart Nothing

154

167

155parseScalar :: ByteString -> Anchor -> Style -> Tag

168parseScalar :: ByteString -> Anchor -> Style -> Tag

156− -> ConduitM Event o Parse Text

169+ -> ReaderT JSONPath (ConduitM Event o Parse) Text

157parseScalar v a style tag = do

170parseScalar v a style tag = do

158 let res = decodeUtf8With lenientDecode v

171 let res = decodeUtf8With lenientDecode v

159 mapM_ (defineAnchor (textToValue style tag res)) a

172 mapM_ (defineAnchor (textToValue style tag res)) a

@@ -185,9 +198,9 @@ textToScientific = Atto.parseOnly (num <* Atto.endOfInput)

185 isOctalDigit c = (c >= '0' && c <= '7')

198 isOctalDigit c = (c >= '0' && c <= '7')

186 step a c = (a `shiftL` 3) .|. fromIntegral (ord c - 48)

199 step a c = (a `shiftL` 3) .|. fromIntegral (ord c - 48)

187

200

188−parseO :: ConduitM Event o Parse Value

201+parseO :: ReaderT JSONPath (ConduitM Event o Parse) Value

189parseO = do

202parseO = do

190− me <- CL.head

203+ me <- lift CL.head

191 case me of

204 case me of

192 Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag

205 Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag

193 Just (EventSequenceStart _ _ a) -> parseS 0 a id

206 Just (EventSequenceStart _ _ a) -> parseS 0 a id

@@ -202,12 +215,12 @@ parseO = do

202parseS :: Int

215parseS :: Int

203 -> Y.Anchor

216 -> Y.Anchor

204 -> ([Value] -> [Value])

217 -> ([Value] -> [Value])

205− -> ConduitM Event o Parse Value

218+ -> ReaderT JSONPath (ConduitM Event o Parse) Value

206−parseS n a front = do

219+parseS !n a front = do

207− me <- CL.peek

220+ me <- lift CL.peek

208 case me of

221 case me of

209 Just EventSequenceEnd -> do

222 Just EventSequenceEnd -> do

210− CL.drop 1

223+ lift $ CL.drop 1

211 let res = Array $ V.fromList $ front []

224 let res = Array $ V.fromList $ front []

212 mapM_ (defineAnchor res) a

225 mapM_ (defineAnchor res) a

213 return res

226 return res

@@ -218,9 +231,9 @@ parseS n a front = do

218parseM :: Set Text

231parseM :: Set Text

219 -> Y.Anchor

232 -> Y.Anchor

220 -> M.HashMap Text Value

233 -> M.HashMap Text Value

221− -> ConduitM Event o Parse Value

234+ -> ReaderT JSONPath (ConduitM Event o Parse) Value

222parseM mergedKeys a front = do

235parseM mergedKeys a front = do

223− me <- CL.head

236+ me <- lift CL.head

224 case me of

237 case me of

225 Just EventMappingEnd -> do

238 Just EventMappingEnd -> do

226 let res = Object front

239 let res = Object front

@@ -247,7 +260,7 @@ parseM mergedKeys a front = do

247 if s == pack "<<"

260 if s == pack "<<"

248 then case o of

261 then case o of

249 Object l -> return (merge l)

262 Object l -> return (merge l)

250− Array l -> return $ merge $ foldl mergeObjects M.empty $ V.toList l

263+ Array l -> return $ merge $ foldl' mergeObjects M.empty $ V.toList l

251 _ -> al

264 _ -> al

252 else al

265 else al

253 parseM mergedKeys' a al'

266 parseM mergedKeys' a al'

@@ -263,28 +276,28 @@ decodeHelper src = do

263 -- This used to be tryAny, but the fact is that catching async

276 -- This used to be tryAny, but the fact is that catching async

264 -- exceptions is fine here. We'll rethrow them immediately in the

277 -- exceptions is fine here. We'll rethrow them immediately in the

265 -- otherwise clause.

278 -- otherwise clause.

266− x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty

279+ x <- try $ runResourceT $ runStateT (runConduit $ src .| runReaderT parse []) (ParseState Map.empty [])

267 case x of

280 case x of

268 Left e

281 Left e

269 | Just pe <- fromException e -> return $ Left pe

282 | Just pe <- fromException e -> return $ Left pe

270 | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)

283 | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)

271 | otherwise -> throwIO e

284 | otherwise -> throwIO e

272− Right (y, warnings) -> return $ Right (warnings, parseEither parseJSON y)

285+ Right (y, st) -> return $ Right (parseStateWarnings st, parseEither parseJSON y)

273

286

274decodeHelper_ :: FromJSON a

287decodeHelper_ :: FromJSON a

275 => ConduitM () Event Parse ()

288 => ConduitM () Event Parse ()

276 -> IO (Either ParseException ([Warning], a))

289 -> IO (Either ParseException ([Warning], a))

277decodeHelper_ src = do

290decodeHelper_ src = do

278− x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty

291+ x <- try $ runResourceT $ runStateT (runConduit $ src .| runReaderT parse []) (ParseState Map.empty [])

279 return $ case x of

292 return $ case x of

280 Left e

293 Left e

281 | Just pe <- fromException e -> Left pe

294 | Just pe <- fromException e -> Left pe

282 | Just ye <- fromException e -> Left $ InvalidYaml $ Just (ye :: YamlException)

295 | Just ye <- fromException e -> Left $ InvalidYaml $ Just (ye :: YamlException)

283 | otherwise -> Left $ OtherParseException e

296 | otherwise -> Left $ OtherParseException e

284− Right (y, warnings) -> either

297+ Right (y, st) -> either

285 (Left . AesonException)

298 (Left . AesonException)

286 Right

299 Right

287− ((,) warnings <$> parseEither parseJSON y)

300+ ((,) (parseStateWarnings st) <$> parseEither parseJSON y)

288

301

289-- | Strings which must be escaped so as not to be treated as non-string scalars.

302-- | Strings which must be escaped so as not to be treated as non-string scalars.

290specialStrings :: HashSet.HashSet Text

303specialStrings :: HashSet.HashSet Text

test/Data/Yaml/IncludeSpec.hs+10

@@ -4,6 +4,7 @@ module Data.Yaml.IncludeSpec (main, spec) where

5import Test.Hspec

6import Data.List (isPrefixOf)

7+import qualified Data.ByteString.Lazy as LB

7import Data.Aeson

8import Data.Aeson

8import Data.Aeson.Internal (JSONPathElement(..))

9import Data.Aeson.Internal (JSONPathElement(..))

9import Data.Yaml (ParseException(InvalidYaml))

10import Data.Yaml (ParseException(InvalidYaml))

@@ -52,6 +53,15 @@ spec = do

52 it "throws Left (InvalidYaml (Just (YamlException \"Yaml file not found: ...\")))" $ do

53 it "throws Left (InvalidYaml (Just (YamlException \"Yaml file not found: ...\")))" $ do

53 (decodeFile "./does_not_exist.yaml" :: IO (Maybe Value)) `shouldThrow` isYamlFileNotFoundException

54 (decodeFile "./does_not_exist.yaml" :: IO (Maybe Value)) `shouldThrow` isYamlFileNotFoundException

56+ context "with a 1K stack size limit" $ around_ inTempDirectory $ do

57+ context "with a large list" $ do

58+ it "succeeds" $ do

59+ let

60+ xs :: [Value]

61+ xs = replicate 5000 (Number 23)

62+ LB.writeFile "foo.yaml" (encode xs)

63+ decodeFile "foo.yaml" `shouldReturn` Just xs

64+

55 describe "decodeFileEither" $ do

65 describe "decodeFileEither" $ do

56 context "when file does not exist" $ do

66 context "when file does not exist" $ do

57 it "returns Left (InvalidYaml (Just (YamlException \"Yaml file not found: ...\")))" $ do

67 it "returns Left (InvalidYaml (Just (YamlException \"Yaml file not found: ...\")))" $ do