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