@@ -6,6 +6,7 @@ module Data.Yaml.Internal
66 (
77 ParseException(..)
88 , prettyPrintParseException
9+ , Warning(..)
910 , parse
1011 , decodeHelper
1112 , decodeHelper_
@@ -19,23 +20,25 @@ import Control.Applicative ((<$>), Applicative(..))
1920#endif
2021import Control.Applicative ((<|>))
2122import Control.Exception
22−import Control.Monad (liftM, ap, unless)
23−import Control.Monad.IO.Class (MonadIO, liftIO)
24−import Control.Monad.Trans.Class (MonadTrans, lift)
23+import Control.Monad (when, unless)
2524import Control.Monad.Trans.Resource (ResourceT, runResourceT)
26−import Control.Monad.Trans.State
25+import Control.Monad.RWS
2726import Data.Aeson
27+import Data.Aeson.Internal (JSONPath, JSONPathElement(..))
2828import Data.Aeson.Types hiding (parse)
2929import qualified Data.Attoparsec.Text as Atto
3030import Data.Bits (shiftL, (.|.))
3131import Data.ByteString (ByteString)
3232import Data.Char (toUpper, ord)
33+import Data.List
3334import Data.Conduit ((.|), ConduitM, runConduit)
3435import qualified Data.Conduit.List as CL
3536import qualified Data.HashMap.Strict as M
3637import qualified Data.HashSet as HashSet
3738import Data.Map (Map)
3839import qualified Data.Map as Map
40+import Data.Set (Set)
41+import qualified Data.Set as Set
3942import Data.Scientific (Scientific)
4043import Data.Text (Text, pack)
4144import qualified Data.Text as T
@@ -109,31 +112,19 @@ prettyPrintParseException pe = case pe of
109112 ]
110113 CyclicIncludes -> "Cyclic includes"
111114
112−newtype PErrorT m a = PErrorT { runPErrorT :: m (Either ParseException a) }
113−instance Monad m => Functor (PErrorT m) where
114− fmap = liftM
115−instance Monad m => Applicative (PErrorT m) where
116− pure = PErrorT . return . Right
117− (<*>) = ap
118−instance Monad m => Monad (PErrorT m) where
119− return = pure
120− (PErrorT m) >>= f = PErrorT $ do
121− e <- m
122− case e of
123− Left e' -> return $ Left e'
124− Right a -> runPErrorT $ f a
125−instance MonadTrans PErrorT where
126− lift = PErrorT . liftM Right
127−instance MonadIO m => MonadIO (PErrorT m) where
128− liftIO = lift . liftIO
129−
130115defineAnchor :: Value -> String -> ConduitM e o Parse ()
131−defineAnchor value name = lift $ modify $ Map.insert name value
116+defineAnchor value name = modify $ Map.insert name value
132117
133118lookupAnchor :: String -> ConduitM e o Parse (Maybe Value)
134−lookupAnchor name = lift $ gets (Map.lookup name)
119+lookupAnchor name = gets (Map.lookup name)
120+
121+data Warning = DuplicateKey JSONPath
122+ deriving (Eq, Show)
135123
136−type Parse = StateT (Map String Value) (ResourceT IO)
124+addWarning :: Warning -> ConduitM e o Parse ()
125+addWarning = tell . return
126+
127+type Parse = RWST JSONPath [Warning] (Map String Value) (ResourceT IO)
137128
138129requireEvent :: Event -> ConduitM Event o Parse ()
139130requireEvent e = do
@@ -199,8 +190,8 @@ parseO = do
199190 me <- CL.head
200191 case me of
201192 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
193+ Just (EventSequenceStart _ _ a) -> parseS 0 a id
194+ Just (EventMappingStart _ _ a) -> parseM mempty a M.empty
204195 Just (EventAlias an) -> do
205196 m <- lookupAnchor an
206197 case m of
@@ -208,10 +199,11 @@ parseO = do
208199 Just v -> return v
209200 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
210201
211−parseS :: Y.Anchor
202+parseS :: Int
203+ -> Y.Anchor
212204 -> ([Value] -> [Value])
213205 -> ConduitM Event o Parse Value
214−parseS a front = do
206+parseS n a front = do
215207 me <- CL.peek
216208 case me of
217209 Just EventSequenceEnd -> do
@@ -220,13 +212,14 @@ parseS a front = do
220212 mapM_ (defineAnchor res) a
221213 return res
222214 _ -> do
223− o <- parseO
224− parseS a $ front . (:) o
215+ o <- local (Index n :) parseO
216+ parseS (succ n) a $ front . (:) o
225217
226−parseM :: Y.Anchor
218+parseM :: Set Text
219+ -> Y.Anchor
227220 -> M.HashMap Text Value
228221 -> ConduitM Event o Parse Value
229−parseM a front = do
222+parseM mergedKeys a front = do
230223 me <- CL.head
231224 case me of
232225 Just EventMappingEnd -> do
@@ -243,48 +236,55 @@ parseM a front = do
243236 Just (String t) -> return t
244237 Just v -> liftIO $ throwIO $ NonStringKeyAlias an v
245238 _ -> liftIO $ throwIO $ UnexpectedEvent me Nothing
246− o <- parseO
247239
248− let al = M.insert s o front
249− al' = if s == pack "<<"
240+ (mergedKeys', al') <- local (Key s :) $ do
241+ o <- parseO
242+ let al = do
243+ when (M.member s front && Set.notMember s mergedKeys) $ do
244+ path <- reverse <$> ask
245+ addWarning (DuplicateKey path)
246+ return (Set.delete s mergedKeys, M.insert s o front)
247+ if s == pack "<<"
250248 then case o of
251− Object l -> M.union front l
252− Array l -> M.union front $ foldl mergeObjects M.empty $ V.toList l
249+ Object l -> return (merge l)
250+ Array l -> return $ merge $ foldl mergeObjects M.empty $ V.toList l
253251 _ -> al
254252 else al
255− parseM a al'
253+ parseM mergedKeys' a al'
256254 where mergeObjects al (Object om) = M.union al om
257255 mergeObjects al _ = al
258256
257+ merge xs = (Set.fromList (M.keys xs \\ M.keys front), M.union front xs)
258+
259259decodeHelper :: FromJSON a
260260 => ConduitM () Y.Event Parse ()
261− -> IO (Either ParseException (Either String a))
261+ -> IO (Either ParseException ([Warning], Either String a))
262262decodeHelper src = do
263263 -- This used to be tryAny, but the fact is that catching async
264264 -- exceptions is fine here. We'll rethrow them immediately in the
265265 -- otherwise clause.
266− x <- try $ runResourceT $ flip evalStateT Map.empty $ runConduit $ src .| parse
266+ x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty
267267 case x of
268268 Left e
269269 | Just pe <- fromException e -> return $ Left pe
270270 | Just ye <- fromException e -> return $ Left $ InvalidYaml $ Just (ye :: YamlException)
271271 | otherwise -> throwIO e
272− Right y -> return $ Right $ parseEither parseJSON y
272+ Right (y, warnings) -> return $ Right (warnings, parseEither parseJSON y)
273273
274274decodeHelper_ :: FromJSON a
275275 => ConduitM () Event Parse ()
276− -> IO (Either ParseException a)
276+ -> IO (Either ParseException ([Warning], a))
277277decodeHelper_ src = do
278− x <- try $ runResourceT $ flip evalStateT Map.empty $ runConduit $ src .| parse
278+ x <- try $ runResourceT $ evalRWST (runConduit $ src .| parse) [] Map.empty
279279 return $ case x of
280280 Left e
281281 | Just pe <- fromException e -> Left pe
282282 | Just ye <- fromException e -> Left $ InvalidYaml $ Just (ye :: YamlException)
283283 | otherwise -> Left $ OtherParseException e
284− Right y -> either
284+ Right (y, warnings) -> either
285285 (Left . AesonException)
286286 Right
287− (parseEither parseJSON y)
287+ ((,) warnings <$> parseEither parseJSON y)
288288
289289-- | Strings which must be escaped so as not to be treated as non-string scalars.
290290specialStrings :: HashSet.HashSet Text