Add a fillDict function

This is similar to the Python version, objects.py:FillDict.

Signed-off-by: Iustin Pop <iustin@google.com>
Reviewed-by: Agata Murawska <agatamurawska@google.com>

htools/Ganeti/HTools/QC.hs

@@ -51,6 +51,7 @@ module Ganeti.HTools.QC
   , testRpc
   , testQlang
   , testConfd
+  , testObjects
   ) where
 
 import qualified Test.HUnit as HUnit
@@ -2161,3 +2162,23 @@ testSuite "Confd"
   [ 'prop_Confd_req_sign
   , 'prop_Confd_bad_key
   ]
+
+-- * Objects tests
+
+-- | Tests that fillDict behaves correctly
+prop_Objects_fillDict :: [(Int, Int)] -> [(Int, Int)] -> Property
+prop_Objects_fillDict defaults custom =
+  let d_map = Map.fromList defaults
+      d_keys = map fst defaults
+      c_map = Map.fromList custom
+      c_keys = map fst custom
+  in printTestCase "Empty custom filling"
+      (Objects.fillDict d_map Map.empty [] == d_map) .&&.
+     printTestCase "Empty defaults filling"
+      (Objects.fillDict Map.empty c_map [] == c_map) .&&.
+     printTestCase "Delete all keys"
+      (Objects.fillDict d_map c_map (d_keys++c_keys) == Map.empty)
+
+testSuite "Objects"
+  [ 'prop_Objects_fillDict
+  ]

htools/Ganeti/Objects.hs

@@ -61,11 +61,14 @@ module Ganeti.Objects
   , NodeGroup(..)
   , IpFamily(..)
   , ipFamilyToVersion
+  , fillDict
   , Cluster(..)
   , ConfigData(..)
   ) where
 
+import Data.List (foldl')
 import Data.Maybe
+import qualified Data.Map as Map
 import Text.JSON (makeObj, showJSON, readJSON, JSON, JSValue(..))
 import qualified Text.JSON as J
 
@@ -74,6 +77,15 @@ import Ganeti.HTools.JSON
 
 import Ganeti.THH
 
+-- * Generic definitions
+
+-- | Fills one map with keys from the other map, if not already
+-- existing. Mirrors objects.py:FillDict.
+fillDict :: (Ord k) => Map.Map k v -> Map.Map k v -> [k] -> Map.Map k v
+fillDict defaults custom skip_keys =
+  let updated = Map.union custom defaults
+  in foldl' (flip Map.delete) updated skip_keys
+
 -- * NIC definitions
 
 $(declareSADT "NICMode"

htools/test.hs

@@ -71,6 +71,7 @@ allTests =
   , (True, testQlang)
   , (True, testRpc)
   , (True, testConfd)
+  , (True, testObjects)
   , (False, testCluster)
   ]