@@ -2,6 +2,7 @@
22{-# LANGUAGE DeriveDataTypeable #-}
33{-# LANGUAGE PatternGuards #-}
44{-# LANGUAGE OverloadedStrings #-}
5+{-# LANGUAGE BangPatterns #-}
56module Data.Yaml.Internal
67 (
78 ParseException(..)
@@ -22,7 +23,8 @@ import Control.Applicative ((<|>))
2223import Control.Exception
2324import Control.Monad (when, unless)
2425import Control.Monad.Trans.Resource (ResourceT, runResourceT)
25−import Control.Monad.RWS
26+import Control.Monad.State.Strict
27+import Control.Monad.Reader
2628import Data.Aeson
2729import Data.Aeson.Internal (JSONPath, JSONPathElement(..))
2830import Data.Aeson.Types hiding (parse)
@@ -112,34 +114,45 @@ prettyPrintParseException pe = case pe of
112114 ]
113115 CyclicIncludes -> "Cyclic includes"
114116
115−defineAnchor :: Value -> String -> ConduitM e o Parse ()
116−defineAnchor value name = modify $ Map.insert name value
117+defineAnchor :: Value -> String -> ReaderT JSONPath (ConduitM e o Parse) ()
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)}
117122
118−lookupAnchor :: String -> ConduitM e o Parse (Maybe Value)
119−lookupAnchor name = gets (Map.lookup name)
123+lookupAnchor :: String -> ReaderT JSONPath (ConduitM e o Parse) (Maybe Value)
124+lookupAnchor name = gets (Map.lookup name . parseStateAnchors)
120125
121126data Warning = DuplicateKey JSONPath
122127 deriving (Eq, Show)
123128
124−addWarning :: Warning -> ConduitM e o Parse ()
125−addWarning = tell . return
129+addWarning :: Warning -> ReaderT JSONPath (ConduitM e o Parse) ()
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+}
126139
127−type Parse = RWST JSONPath [Warning] (Map String Value) (ResourceT IO)
140+type Parse = StateT ParseState (ResourceT IO)
128141
129−requireEvent :: Event -> ConduitM Event o Parse ()
142+requireEvent :: Event -> ReaderT JSONPath (ConduitM Event o Parse) ()
130143requireEvent e = do
131− f <- CL.head
144+ f <- lift CL.head
132145 unless (f == Just e) $ liftIO $ throwIO $ UnexpectedEvent f $ Just e
133146
134−parse :: ConduitM Event o Parse Value
147+parse :: ReaderT JSONPath (ConduitM Event o Parse) Value
135148parse = do
136− streamStart <- CL.head
149+ streamStart <- lift CL.head
137150 case streamStart of
138151 Nothing ->
139152 -- empty string input
140153 return Null
141154 Just EventStreamStart -> do
142− documentStart <- CL.head
155+ documentStart <- lift CL.head
143156 case documentStart of
144157 Just EventStreamEnd ->
145158 -- empty file input, comment only string/file input
@@ -153,7 +166,7 @@ parse = do
153166 _ -> liftIO $ throwIO $ UnexpectedEvent streamStart Nothing
154167
155168parseScalar :: ByteString -> Anchor -> Style -> Tag
156− -> ConduitM Event o Parse Text
169+ -> ReaderT JSONPath (ConduitM Event o Parse) Text
157170parseScalar v a style tag = do
158171 let res = decodeUtf8With lenientDecode v
159172 mapM_ (defineAnchor (textToValue style tag res)) a
@@ -185,9 +198,9 @@ textToScientific = Atto.parseOnly (num <* Atto.endOfInput)
185198 isOctalDigit c = (c >= '0' && c <= '7')
186199 step a c = (a `shiftL` 3) .|. fromIntegral (ord c - 48)
187200
188−parseO :: ConduitM Event o Parse Value
201+parseO :: ReaderT JSONPath (ConduitM Event o Parse) Value
189202parseO = do
190− me <- CL.head
203+ me <- lift CL.head
191204 case me of
192205 Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag
193206 Just (EventSequenceStart _ _ a) -> parseS 0 a id
@@ -202,12 +215,12 @@ parseO = do
202215parseS :: Int
203216 -> Y.Anchor
204217 -> ([Value] -> [Value])
205− -> ConduitM Event o Parse Value
206−parseS n a front = do
207− me <- CL.peek
218+ -> ReaderT JSONPath (ConduitM Event o Parse) Value
219+parseS !n a front = do
220+ me <- lift CL.peek
208221 case me of
209222 Just EventSequenceEnd -> do
210− CL.drop 1
223+ lift $ CL.drop 1
211224 let res = Array $ V.fromList $ front []
212225 mapM_ (defineAnchor res) a
213226 return res
@@ -218,9 +231,9 @@ parseS n a front = do
218231parseM :: Set Text
219232 -> Y.Anchor
220233 -> M.HashMap Text Value
221− -> ConduitM Event o Parse Value
234+ -> ReaderT JSONPath (ConduitM Event o Parse) Value
222235parseM mergedKeys a front = do
223− me <- CL.head
236+ me <- lift CL.head
224237 case me of
225238 Just EventMappingEnd -> do
226239 let res = Object front
@@ -247,7 +260,7 @@ parseM mergedKeys a front = do
247260 if s == pack "<<"
248261 then case o of
249262 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
251264 _ -> al
252265 else al
253266 parseM mergedKeys' a al'
@@ -263,28 +276,28 @@ decodeHelper src = do
263276 -- This used to be tryAny, but the fact is that catching async
264277 -- exceptions is fine here. We'll rethrow them immediately in the
265278 -- otherwise clause.
266− x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty
279+ x <- try $ runResourceT $ runStateT (runConduit $ src .| runReaderT parse []) (ParseState Map.empty [])
267280 case x of
268281 Left e
269282 | Just pe <- fromException e -> return $ Left pe
270283 | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
271284 | otherwise -> throwIO e
272− Right (y, warnings) -> return $ Right (warnings, parseEither parseJSON y)
285+ Right (y, st) -> return $ Right (parseStateWarnings st, parseEither parseJSON y)
273286
274287decodeHelper_ :: FromJSON a
275288 => ConduitM () Event Parse ()
276289 -> IO (Either ParseException ([Warning], a))
277290decodeHelper_ src = do
278− x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty
291+ x <- try $ runResourceT $ runStateT (runConduit $ src .| runReaderT parse []) (ParseState Map.empty [])
279292 return $ case x of
280293 Left e
281294 | Just pe <- fromException e -> Left pe
282295 | Just ye <- fromException e -> Left $ InvalidYaml $ Just (ye :: YamlException)
283296 | otherwise -> Left $ OtherParseException e
284− Right (y, warnings) -> either
297+ Right (y, st) -> either
285298 (Left . AesonException)
286299 Right
287− ((,) warnings <$> parseEither parseJSON y)
300+ ((,) (parseStateWarnings st) <$> parseEither parseJSON y)
288301
289302-- | Strings which must be escaped so as not to be treated as non-string scalars.
290303specialStrings :: HashSet.HashSet Text