1{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE NoImplicitPrelude #-}
3{-# LANGUAGE DeriveGeneric #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE TupleSections #-}
6
7-- | Extensions to Aeson parsing of objects. This module is intended
8-- for internal use by Pantry and Stack only. The intention is to
9-- fully remove this module in the future. /DO NOT RELY ON IT/.
10module Pantry.Internal.AesonExtended (
11    module Export
12  -- * Extended failure messages
13  , (.:)
14  , (.:?)
15  -- * JSON Parser that emits warnings
16  , JSONWarning (..)
17  , WarningParser
18  , WithJSONWarnings (..)
19  , withObjectWarnings
20  , jsonSubWarnings
21  , jsonSubWarningsT
22  , jsonSubWarningsTT
23  , logJSONWarnings
24  , noJSONWarnings
25  , tellJSONField
26  , unWarningParser
27  , (..:)
28  , (...:)
29  , (..:?)
30  , (...:?)
31  , (..!=)
32  ) where
33
34import Control.Monad.Trans.Writer.Strict (WriterT, mapWriterT, runWriterT, tell)
35import Data.Aeson as Export hiding ((.:), (.:?))
36import qualified Data.Aeson as A
37import Data.Aeson.Types hiding ((.:), (.:?))
38import qualified Data.HashMap.Strict as HashMap
39import qualified Data.Set as Set
40import Data.Text (unpack)
41import qualified Data.Text as T
42import Generics.Deriving.Monoid (mappenddefault, memptydefault)
43import RIO
44import RIO.PrettyPrint.StylesUpdate (StylesUpdate)
45
46-- | Extends @.:@ warning to include field name.
47(.:) :: FromJSON a => Object -> Text -> Parser a
48(.:) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..: p)
49{-# INLINE (.:) #-}
50
51-- | Extends @.:?@ warning to include field name.
52(.:?) :: FromJSON a => Object -> Text -> Parser (Maybe a)
53(.:?) o p = modifyFailure (("failed to parse field '" <> unpack p <> "': ") <>) (o A..:? p)
54{-# INLINE (.:?) #-}
55
56-- | 'WarningParser' version of @.:@.
57(..:)
58    :: FromJSON a
59    => Object -> Text -> WarningParser a
60o ..: k = tellJSONField k >> lift (o .: k)
61
62-- | 'WarningParser' version of @.:?@.
63(..:?)
64    :: FromJSON a
65    => Object -> Text -> WarningParser (Maybe a)
66o ..:? k = tellJSONField k >> lift (o .:? k)
67
68-- | 'WarningParser' version of @.!=@.
69(..!=) :: WarningParser (Maybe a) -> a -> WarningParser a
70wp ..!= d =
71    flip mapWriterT wp $
72    \p ->
73         do a <- fmap snd p
74            fmap (, a) (fmap fst p .!= d)
75
76presentCount :: Object -> [Text] -> Int
77presentCount o ss = length . filter (\x -> HashMap.member x o) $ ss
78
79-- | Synonym version of @..:@.
80(...:) :: FromJSON a => Object -> [Text] -> WarningParser a
81_ ...: [] = fail "failed to find an empty key"
82o ...: ss@(key:_) = apply
83    where pc = presentCount o ss
84          apply | pc == 0   = fail $
85                                "failed to parse field " ++
86                                show key ++ ": " ++
87                                "keys " ++ show ss ++ " not present"
88                | pc >  1   = fail $
89                                "failed to parse field " ++
90                                show key ++ ": " ++
91                                "two or more synonym keys " ++
92                                show ss ++ " present"
93                | otherwise = asum $ map (o..:) ss
94
95-- | Synonym version of @..:?@.
96(...:?) :: FromJSON a => Object -> [Text] -> WarningParser (Maybe a)
97_ ...:? [] = fail "failed to find an empty key"
98o ...:? ss@(key:_) = apply
99    where pc = presentCount o ss
100          apply | pc == 0   = return Nothing
101                | pc >  1   = fail $
102                                "failed to parse field " ++
103                                show key ++ ": " ++
104                                "two or more synonym keys " ++
105                                show ss ++ " present"
106                | otherwise = asum $ map (o..:) ss
107
108-- | Tell warning parser about an expected field, so it doesn't warn about it.
109tellJSONField :: Text -> WarningParser ()
110tellJSONField key = tell (mempty { wpmExpectedFields = Set.singleton key})
111
112-- | 'WarningParser' version of 'withObject'.
113withObjectWarnings :: String
114                   -> (Object -> WarningParser a)
115                   -> Value
116                   -> Parser (WithJSONWarnings a)
117withObjectWarnings expected f =
118    withObject expected $
119    \obj ->
120         do (a,w) <- runWriterT (f obj)
121            let unrecognizedFields =
122                    Set.toList
123                        (Set.difference
124                             (Set.fromList (HashMap.keys obj))
125                             (wpmExpectedFields w))
126            return
127                (WithJSONWarnings a
128                    (wpmWarnings w ++
129                     case unrecognizedFields of
130                         [] -> []
131                         _ -> [JSONUnrecognizedFields expected unrecognizedFields]))
132
133-- | Convert a 'WarningParser' to a 'Parser'.
134unWarningParser :: WarningParser a -> Parser a
135unWarningParser wp = do
136    (a,_) <- runWriterT wp
137    return a
138
139-- | Log JSON warnings.
140logJSONWarnings
141    :: (MonadReader env m, HasLogFunc env, HasCallStack, MonadIO m)
142    => FilePath -> [JSONWarning] -> m ()
143logJSONWarnings fp =
144    mapM_ (\w -> logWarn ("Warning: " <> fromString fp <> ": " <> displayShow w))
145
146-- | Handle warnings in a sub-object.
147jsonSubWarnings :: WarningParser (WithJSONWarnings a) -> WarningParser a
148jsonSubWarnings f = do
149    WithJSONWarnings result warnings <- f
150    tell
151        (mempty
152         { wpmWarnings = warnings
153         })
154    return result
155
156-- | Handle warnings in a @Traversable@ of sub-objects.
157jsonSubWarningsT
158    :: Traversable t
159    => WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
160jsonSubWarningsT f =
161    mapM (jsonSubWarnings . return) =<< f
162
163-- | Handle warnings in a @Maybe Traversable@ of sub-objects.
164jsonSubWarningsTT
165    :: (Traversable t, Traversable u)
166    => WarningParser (u (t (WithJSONWarnings a)))
167    -> WarningParser (u (t a))
168jsonSubWarningsTT f =
169    mapM (jsonSubWarningsT . return) =<< f
170
171-- Parsed JSON value without any warnings
172noJSONWarnings :: a -> WithJSONWarnings a
173noJSONWarnings v = WithJSONWarnings v []
174
175-- | JSON parser that warns about unexpected fields in objects.
176type WarningParser a = WriterT WarningParserMonoid Parser a
177
178-- | Monoid used by 'WarningParser' to track expected fields and warnings.
179data WarningParserMonoid = WarningParserMonoid
180    { wpmExpectedFields :: !(Set Text)
181    , wpmWarnings :: [JSONWarning]
182    } deriving Generic
183instance Semigroup WarningParserMonoid where
184    (<>) = mappenddefault
185instance Monoid WarningParserMonoid where
186    mempty = memptydefault
187    mappend = (<>)
188instance IsString WarningParserMonoid where
189    fromString s = mempty { wpmWarnings = [fromString s] }
190
191-- Parsed JSON value with its warnings
192data WithJSONWarnings a = WithJSONWarnings a [JSONWarning]
193    deriving (Eq, Generic, Show)
194instance Functor WithJSONWarnings where
195    fmap f (WithJSONWarnings x w) = WithJSONWarnings (f x) w
196instance Monoid a => Semigroup (WithJSONWarnings a) where
197    (<>) = mappenddefault
198instance Monoid a => Monoid (WithJSONWarnings a) where
199    mempty = memptydefault
200    mappend = (<>)
201
202-- | Warning output from 'WarningParser'.
203data JSONWarning = JSONUnrecognizedFields String [Text]
204                 | JSONGeneralWarning !Text
205    deriving Eq
206instance Show JSONWarning where
207  show = T.unpack . utf8BuilderToText . display
208instance Display JSONWarning where
209  display (JSONUnrecognizedFields obj [field]) =
210    "Unrecognized field in " <> fromString obj <> ": " <> display field
211  display (JSONUnrecognizedFields obj fields) =
212    "Unrecognized fields in " <> fromString obj <> ": " <> display (T.intercalate ", " fields)
213  display (JSONGeneralWarning t) = display t
214
215instance IsString JSONWarning where
216  fromString = JSONGeneralWarning . T.pack
217
218instance FromJSON (WithJSONWarnings StylesUpdate) where
219  parseJSON v = noJSONWarnings <$> parseJSON v
220