Add 'fromDictWKeys' to 'DictObject' that also returns the set of used keys (or signals that all fields are always consumed by AndRestArguments). Implement this function for generated 'DictObject' instances.
Signed-off-by: Petr Pudlak <[email protected]> --- src/Ganeti/JSON.hs | 34 ++++++++++++++++++++++++++++++++-- src/Ganeti/THH.hs | 8 ++++++-- 2 files changed, 38 insertions(+), 4 deletions(-) diff --git a/src/Ganeti/JSON.hs b/src/Ganeti/JSON.hs index d2f4689..ee1cfbd 100644 --- a/src/Ganeti/JSON.hs +++ b/src/Ganeti/JSON.hs @@ -50,6 +50,8 @@ module Ganeti.JSON , optFieldsToObj , lookupContainer , readContainer + , mkUsedKeys + , allUsedKeys , DictObject(..) , showJSONtoDict , readJSONfromDict @@ -62,13 +64,15 @@ module Ganeti.JSON ) where +import Control.Applicative import Control.DeepSeq -import Control.Monad (liftM) import Control.Monad.Error.Class +import Control.Monad.Writer import qualified Data.Foldable as F import qualified Data.Traversable as F import Data.Maybe (fromMaybe, catMaybes) import qualified Data.Map as Map +import qualified Data.Set as Set import System.Time (ClockTime(..)) import Text.Printf (printf) @@ -352,11 +356,25 @@ instance (HasStringRepr a, Ord a, J.JSON b) => -- * Types that (de)serialize in a special form of JSON +newtype UsedKeys = UsedKeys (Maybe (Set.Set String)) + +instance Monoid UsedKeys where + mempty = UsedKeys (Just Set.empty) + mappend (UsedKeys xs) (UsedKeys ys) = UsedKeys $ liftA2 Set.union xs ys + +mkUsedKeys :: Set.Set String -> UsedKeys +mkUsedKeys = UsedKeys . Just + +allUsedKeys :: UsedKeys +allUsedKeys = UsedKeys Nothing + -- | Class of objects that can be converted from and to 'JSObject' -- lists-format. class DictObject a where toDict :: a -> [(String, J.JSValue)] + fromDictWKeys :: [(String, J.JSValue)] -> WriterT UsedKeys J.Result a fromDict :: [(String, J.JSValue)] -> J.Result a + fromDict = liftM fst . runWriterT . fromDictWKeys -- | A default implementation of 'showJSON' using 'toDict'. showJSONtoDict :: (DictObject a) => a -> J.JSValue @@ -368,7 +386,19 @@ showJSONtoDict = J.makeObj . toDict -- Also checks the input contains only the used keys returned by 'fromDict'. readJSONfromDict :: (DictObject a) => J.JSValue -> J.Result a -readJSONfromDict = fromDict <=< liftM J.fromJSObject . J.readJSON +readJSONfromDict jsv = do + dict <- liftM J.fromJSObject $ J.readJSON jsv + (r, UsedKeys keys) <- runWriterT $ fromDictWKeys dict + -- check that no superfluous dictionary keys are present + case keys of + Just allowedSet | not (Set.null superfluous) -> + fail $ "Superfluous dictionary keys: " + ++ show (Set.toAscList superfluous) ++ ", but only " + ++ show (Set.toAscList allowedSet) ++ " allowed." + where + superfluous = Set.fromList (map fst dict) Set.\\ allowedSet + _ -> return () + return r -- | Class of objects that can be converted from and to @[JSValue]@ with -- a fixed length and order. diff --git a/src/Ganeti/THH.hs b/src/Ganeti/THH.hs index 3dab68a..3171970 100644 --- a/src/Ganeti/THH.hs +++ b/src/Ganeti/THH.hs @@ -67,6 +67,8 @@ import Control.Arrow ((&&&)) import Control.Applicative import Control.Monad import Control.Monad.Base () -- Needed to prevent spurious GHC linking errors. +import Control.Monad.Writer (tell) +import qualified Control.Monad.Trans as MT import Data.Attoparsec () -- Needed to prevent spurious GHC 7.4 linking errors. -- See issue #683 and https://ghc.haskell.org/trac/ghc/ticket/4899 import Data.Char @@ -74,6 +76,7 @@ import Data.Function (on) import Data.List import Data.Maybe import qualified Data.Map as M +import qualified Data.Set as S import Language.Haskell.TH import Language.Haskell.TH.Syntax (lift) @@ -991,14 +994,15 @@ genDictObject save_fn load_fn sname fields = do tdexp = [| concat $(listE $ zipWith save_fn fnames fields) |] tdclause <- clause [pat] (normalB tdexp) [] -- fromDict - fdexp <- loadConstructor name load_fn fields + fdexp <- [| MT.lift $(loadConstructor name load_fn fields) + <* tell $(fieldsUsedKeysQ fields) |] let fdclause = Clause [VarP objVarName] (NormalB fdexp) [] -- the ArrayObject instance generated from DictObject arrdec <- genArrayObjectInstance name fields -- the final instance return $ [InstanceD [] (AppT (ConT ''DictObject) (ConT name)) [ FunD 'toDict [tdclause] - , FunD 'fromDict [fdclause] + , FunD 'fromDictWKeys [fdclause] ]] ++ [arrdec] -- 2.0.0.526.g5318336
