@@ -6,6 +6,7 @@ module Data.Yaml.Internal
66 (
77 ParseException(..)
88 , prettyPrintParseException
9+ , Warning(..)
910 , parse
1011 , decodeHelper
1112 , decodeHelper_
@@ -19,23 +20,27 @@ import Control.Applicative ((<$>), Applicative(..))
1920#endif
2021import Control.Applicative ((<|>))
2122import Control.Exception
22−import Control.Monad (liftM, ap, unless)
23+import Control.Monad (liftM, ap, when, unless)
2324import Control.Monad.IO.Class (MonadIO, liftIO)
2425import Control.Monad.Trans.Class (MonadTrans, lift)
2526import Control.Monad.Trans.Resource (ResourceT, runResourceT)
26−import Control.Monad.Trans.State
27+import Control.Monad.RWS
2728import Data.Aeson
29+import Data.Aeson.Internal (JSONPath, JSONPathElement(..))
2830import Data.Aeson.Types hiding (parse)
2931import qualified Data.Attoparsec.Text as Atto
3032import Data.Bits (shiftL, (.|.))
3133import Data.ByteString (ByteString)
3234import Data.Char (toUpper, ord)
35+import Data.List
3336import Data.Conduit ((.|), ConduitM, runConduit)
3437import qualified Data.Conduit.List as CL
3538import qualified Data.HashMap.Strict as M
3639import qualified Data.HashSet as HashSet
3740import Data.Map (Map)
3841import qualified Data.Map as Map
42+import Data.Set (Set)
43+import qualified Data.Set as Set
3944import Data.Scientific (Scientific)
4045import Data.Text (Text, pack)
4146import qualified Data.Text as T
@@ -125,15 +130,21 @@ instance Monad m => Monad (PErrorT m) where
125130instance MonadTrans PErrorT where
126131 lift = PErrorT . liftM Right
127132instance MonadIO m => MonadIO (PErrorT m) where
128− liftIO = lift . liftIO
133+ liftIO = liftIO
129134
130135defineAnchor :: Value -> String -> ConduitM e o Parse ()
131−defineAnchor value name = lift $ modify $ Map.insert name value
136+defineAnchor value name = modify $ Map.insert name value
132137
133138lookupAnchor :: String -> ConduitM e o Parse (Maybe Value)
134−lookupAnchor name = lift $ gets (Map.lookup name)
139+lookupAnchor name = gets (Map.lookup name)
135140
136−type Parse = StateT (Map String Value) (ResourceT IO)
141+data Warning = DuplicateKey JSONPath
142+ deriving (Eq, Show)
143+
144+addWarning :: Warning -> ConduitM e o Parse ()
145+addWarning = tell . return
146+
147+type Parse = RWST JSONPath [Warning] (Map String Value) (ResourceT IO)
137148
138149requireEvent :: Event -> ConduitM Event o Parse ()
139150requireEvent e = do
@@ -199,8 +210,8 @@ parseO = do
199210 me <- CL.head
200211 case me of
201212 Just (EventScalar v tag style a) -> textToValue style tag <$> parseScalar v a style tag
202− Just (EventSequenceStart _ _ a) -> parseS a id
203− Just (EventMappingStart _ _ a) -> parseM a M.empty
213+ Just (EventSequenceStart _ _ a) -> parseS 0 a id
214+ Just (EventMappingStart _ _ a) -> parseM mempty a M.empty
204215 Just (EventAlias an) -> do
205216 m <- lookupAnchor an
206217 case m of
@@ -208,10 +219,11 @@ parseO = do
208219 Just v -> return v
209220 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
210221
211−parseS :: Y.Anchor
222+parseS :: Int
223+ -> Y.Anchor
212224 -> ([Value] -> [Value])
213225 -> ConduitM Event o Parse Value
214−parseS a front = do
226+parseS n a front = do
215227 me <- CL.peek
216228 case me of
217229 Just EventSequenceEnd -> do
@@ -220,13 +232,14 @@ parseS a front = do
220232 mapM_ (defineAnchor res) a
221233 return res
222234 _ -> do
223− o <- parseO
224− parseS a $ front . (:) o
235+ o <- local (Index n :) parseO
236+ parseS (succ n) a $ front . (:) o
225237
226−parseM :: Y.Anchor
238+parseM :: Set Text
239+ -> Y.Anchor
227240 -> M.HashMap Text Value
228241 -> ConduitM Event o Parse Value
229−parseM a front = do
242+parseM mergedKeys a front = do
230243 me <- CL.head
231244 case me of
232245 Just EventMappingEnd -> do
@@ -243,48 +256,55 @@ parseM a front = do
243256 Just (String t) -> return t
244257 Just v -> liftIO $ throwIO $ NonStringKeyAlias an v
245258 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
246− o <- parseO
247259
248− let al = M.insert s o front
249− al' = if s == pack "<<"
260+ (mergedKeys', al') <- local (Key s :) $ do
261+ o <- parseO
262+ let al = do
263+ when (M.member s front && Set.notMember s mergedKeys) $ do
264+ path <- reverse <$> ask
265+ addWarning (DuplicateKey path)
266+ return (Set.delete s mergedKeys, M.insert s o front)
267+ if s == pack "<<"
250268 then case o of
251− Object l -> M.union front l
252− Array l -> M.union front $ foldl mergeObjects M.empty $ V.toList l
269+ Object l -> return (merge l)
270+ Array l -> return $ merge $ foldl mergeObjects M.empty $ V.toList l
253271 _ -> al
254272 else al
255− parseM a al'
273+ parseM mergedKeys' a al'
256274 where mergeObjects al (Object om) = M.union al om
257275 mergeObjects al _ = al
258276
277+ merge xs = (Set.fromList (M.keys xs \\ M.keys front), M.union front xs)
278+
259279decodeHelper :: FromJSON a
260280 => ConduitM () Y.Event Parse ()
261− -> IO (Either ParseException (Either String a))
281+ -> IO (Either ParseException ([Warning], Either String a))
262282decodeHelper src = do
263283 -- This used to be tryAny, but the fact is that catching async
264284 -- exceptions is fine here. We'll rethrow them immediately in the
265285 -- otherwise clause.
266− x <- try $ runResourceT $ flip evalStateT Map.empty $ runConduit $ src .| parse
286+ x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty
267287 case x of
268288 Left e
269289 | Just pe <- fromException e -> return $ Left pe
270290 | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
271291 | otherwise -> throwIO e
272− Right y -> return $ Right $ parseEither parseJSON y
292+ Right (y, warnings) -> return $ Right (warnings, parseEither parseJSON y)
273293
274294decodeHelper_ :: FromJSON a
275295 => ConduitM () Event Parse ()
276− -> IO (Either ParseException a)
296+ -> IO (Either ParseException ([Warning], a))
277297decodeHelper_ src = do
278− x <- try $ runResourceT $ flip evalStateT Map.empty $ runConduit $ src .| parse
298+ x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty
279299 return $ case x of
280300 Left e
281301 | Just pe <- fromException e -> Left pe
282302 | Just ye <- fromException e -> Left $ InvalidYaml $ Just (ye :: YamlException)
283303 | otherwise -> Left $ OtherParseException e
284− Right y -> either
304+ Right (y, warnings) -> either
285305 (Left . AesonException)
286306 Right
287− (parseEither parseJSON y)
307+ ((,) warnings <$> parseEither parseJSON y)
288308
289309-- | Strings which must be escaped so as not to be treated as non-string scalars.
290310specialStrings :: HashSet.HashSet Text