@@ -34,6 +34,7 @@ import Data.Conduit ((.|), ConduitM, runConduit)
3434import qualified Data.Conduit.List as CL
3535import qualified Data.HashMap.Strict as M
3636import qualified Data.HashSet as HashSet
37+import Data.Map (Map)
3738import qualified Data.Map as Map
3839import Data.Scientific (Scientific)
3940import Data.Text (Text, pack)
@@ -126,7 +127,13 @@ instance MonadTrans PErrorT where
126127instance MonadIO m => MonadIO (PErrorT m) where
127128 liftIO = lift . liftIO
128129
129−type Parse = StateT (Map.Map String Value) (ResourceT IO)
130+defineAnchor :: Value -> String -> ConduitM e o Parse ()
131+defineAnchor value name = lift $ modify $ Map.insert name value
132+
133+lookupAnchor :: String -> ConduitM e o Parse (Maybe Value)
134+lookupAnchor name = lift $ gets (Map.lookup name)
135+
136+type Parse = StateT (Map String Value) (ResourceT IO)
130137
131138requireEvent :: Event -> ConduitM Event o Parse ()
132139requireEvent e = do
@@ -158,11 +165,8 @@ parseScalar :: ByteString -> Anchor -> Style -> Tag
158165 -> ConduitM Event o Parse Text
159166parseScalar v a style tag = do
160167 let res = decodeUtf8With lenientDecode v
161− case a of
162− Nothing -> return res
163− Just an -> do
164− lift $ modify (Map.insert an $ textToValue style tag res)
165− return res
168+ mapM_ (defineAnchor (textToValue style tag res)) a
169+ return res
166170
167171textToValue :: Style -> Tag -> Text -> Value
168172textToValue SingleQuoted _ t = String t
@@ -198,8 +202,8 @@ parseO = do
198202 Just (EventSequenceStart _ _ a) -> parseS a id
199203 Just (EventMappingStart _ _ a) -> parseM a M.empty
200204 Just (EventAlias an) -> do
201− m <- lift get
202− case Map.lookup an m of
205+ m <- lookupAnchor an
206+ case m of
203207 Nothing -> liftIO $ throwIO $ UnknownAlias an
204208 Just v -> return v
205209 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
@@ -213,11 +217,8 @@ parseS a front = do
213217 Just EventSequenceEnd -> do
214218 CL.drop 1
215219 let res = Array $ V.fromList $ front []
216− case a of
217− Nothing -> return res
218− Just an -> do
219− lift $ modify $ Map.insert an res
220− return res
220+ mapM_ (defineAnchor res) a
221+ return res
221222 _ -> do
222223 o <- parseO
223224 parseS a $ front . (:) o
@@ -226,23 +227,18 @@ parseM :: Y.Anchor
226227 -> M.HashMap Text Value
227228 -> ConduitM Event o Parse Value
228229parseM a front = do
229− me <- CL.peek
230+ me <- CL.head
230231 case me of
231232 Just EventMappingEnd -> do
232− CL.drop 1
233233 let res = Object front
234− case a of
235− Nothing -> return res
236− Just an -> do
237− lift $ modify $ Map.insert an res
238− return res
234+ mapM_ (defineAnchor res) a
235+ return res
239236 _ -> do
240− CL.drop 1
241237 s <- case me of
242238 Just (EventScalar v tag style a') -> parseScalar v a' style tag
243239 Just (EventAlias an) -> do
244− m <- lift get
245− case Map.lookup an m of
240+ m <- lookupAnchor an
241+ case m of
246242 Nothing -> liftIO $ throwIO $ UnknownAlias an
247243 Just (String t) -> return t
248244 Just v -> liftIO $ throwIO $ NonStringKeyAlias an v
@@ -253,12 +249,12 @@ parseM a front = do
253249 al' = if s == pack "<<"
254250 then case o of
255251 Object l -> M.union front l
256− Array l -> M.union front $ foldl merge' M.empty $ V.toList l
252+ Array l -> M.union front $ foldl mergeObjects M.empty $ V.toList l
257253 _ -> al
258254 else al
259255 parseM a al'
260− where merge' al (Object om) = M.union al om
261− merge' al _ = al
256+ where mergeObjects al (Object om) = M.union al om
257+ mergeObjects al _ = al
262258
263259decodeHelper :: FromJSON a
264260 => ConduitM () Y.Event Parse ()