From: Iustin Pop <ius...@google.com>
This started from the fact that recent QuickCheck declares itself an arbitrary
instance "(Arbitrary a) => Arbitrary (Set a)", which conflicts with our
slightly more specific instance. The easiest way to fix this is (especially
since this is test code) an OverlappingInstances language extension, but that
is deprecated in GHC 7.10 :(
The solution is then to change this to a proper type, instead of an alias. In
the exercise, I found out that we were not really using TagSet, but instead
directly using Set, which is not nice. Plus many redefinitions at the call site
of the same arbitrary instance! Not happy with type synonims since they're just
smoke and mirrors…
Signed-off-by: Iustin Pop <ius...@google.com>
---
src/Ganeti/Objects.hs | 12 ++++++------
src/Ganeti/Objects/Lens.hs | 3 +--
src/Ganeti/THH/Field.hs | 18 ++++++++++++++----
src/Ganeti/Types.hs | 5 ++---
src/Ganeti/WConfd/Ssconf.hs | 2 +-
test/hs/Test/Ganeti/Objects.hs | 12 ++++++------
test/hs/Test/Ganeti/Query/Instance.hs | 3 +--
7 files changed, 31 insertions(+), 24 deletions(-)
diff --git a/src/Ganeti/Objects.hs b/src/Ganeti/Objects.hs
index 603f809..00bb7a2 100644
--- a/src/Ganeti/Objects.hs
+++ b/src/Ganeti/Objects.hs
@@ -80,11 +80,12 @@ module Ganeti.Objects
, Cluster(..)
, ConfigData(..)
, TimeStampObject(..) -- re-exported from Types
- , UuidObject(..) -- re-exported from Types
- , SerialNoObject(..) -- re-exported from Types
- , TagsObject(..) -- re-exported from Types
- , DictObject(..) -- re-exported from THH
- , TagSet -- re-exported from THH
+ , UuidObject(..) -- re-exported from Types
+ , SerialNoObject(..) -- re-exported from Types
+ , TagsObject(..) -- re-exported from Types
+ , DictObject(..) -- re-exported from THH
+ , TagSet(..) -- re-exported from THH
+ , emptyTagSet -- re-exported from THH
, Network(..)
, AddressPool(..)
, Ip4Address()
@@ -749,4 +750,3 @@ $(buildObject "MasterNetworkParameters"
"masterNetworkParameters"
, simpleField "netdev" [t| String |]
, simpleField "ip_family" [t| IpFamily |]
])
-
diff --git a/src/Ganeti/Objects/Lens.hs b/src/Ganeti/Objects/Lens.hs
index 3f27981..8b8da74 100644
--- a/src/Ganeti/Objects/Lens.hs
+++ b/src/Ganeti/Objects/Lens.hs
@@ -40,7 +40,6 @@ import qualified Data.ByteString as BS
import qualified Data.ByteString.UTF8 as UTF8
import Control.Lens (Simple)
import Control.Lens.Iso (Iso, iso)
-import qualified Data.Set as Set
import System.Time (ClockTime(..))
import Ganeti.Lens (makeCustomLenses, Lens')
@@ -64,7 +63,7 @@ class SerialNoObject a => SerialNoObjectL a where
-- | Class of objects that have tags.
class TagsObject a => TagsObjectL a where
- tagsL :: Lens' a (Set.Set String)
+ tagsL :: Lens' a (TagSet)
$(makeCustomLenses ''AddressPool)
diff --git a/src/Ganeti/THH/Field.hs b/src/Ganeti/THH/Field.hs
index 6047ca4..2dea7f7 100644
--- a/src/Ganeti/THH/Field.hs
+++ b/src/Ganeti/THH/Field.hs
@@ -43,7 +43,8 @@ module Ganeti.THH.Field
, timeStampFields
, uuidFields
, serialFields
- , TagSet
+ , TagSet(..)
+ , emptyTagSet
, tagsFields
, fileModeAsIntField
, processIdField
@@ -121,12 +122,21 @@ serialFields =
uuidFields :: [Field]
uuidFields = [ presentInForthcoming $ simpleField "uuid" [t| BS.ByteString |] ]
--- | Tag set type alias.
-type TagSet = Set.Set String
+-- | Tag set type.
+newtype TagSet = TagSet { fromTagSet :: Set.Set String }
+ deriving (Show, Eq)
+
+instance JSON.JSON TagSet where
+ readJSON = liftM TagSet . JSON.readJSON
+ showJSON = JSON.showJSON . fromTagSet
+
+-- | The empty tag set.
+emptyTagSet :: TagSet
+emptyTagSet = TagSet Set.empty
-- | Tag field description.
tagsFields :: [Field]
-tagsFields = [ defaultField [| Set.empty |] $
+tagsFields = [ defaultField [| emptyTagSet |] $
simpleField "tags" [t| TagSet |] ]
-- ** Fields related to POSIX data types
diff --git a/src/Ganeti/Types.hs b/src/Ganeti/Types.hs
index 437e62a..c332ba0 100644
--- a/src/Ganeti/Types.hs
+++ b/src/Ganeti/Types.hs
@@ -197,12 +197,12 @@ import Control.Monad (liftM)
import qualified Text.JSON as JSON
import Text.JSON (JSON, readJSON, showJSON)
import Data.Ratio (numerator, denominator)
-import qualified Data.Set as Set
import System.Time (ClockTime)
import qualified Ganeti.ConstantUtils as ConstantUtils
import Ganeti.JSON
import qualified Ganeti.THH as THH
+import qualified Ganeti.THH.Field as THH (TagSet)
import Ganeti.Utils
-- * Generic types
@@ -1071,5 +1071,4 @@ class SerialNoObject a where
-- | Class of objects that have tags.
class TagsObject a where
- tagsOf :: a -> Set.Set String
-
+ tagsOf :: a -> THH.TagSet
diff --git a/src/Ganeti/WConfd/Ssconf.hs b/src/Ganeti/WConfd/Ssconf.hs
index b8c83c0..941733d 100644
--- a/src/Ganeti/WConfd/Ssconf.hs
+++ b/src/Ganeti/WConfd/Ssconf.hs
@@ -88,7 +88,7 @@ mkSSConfHvparams cluster = map (id &&& hvparams)
[minBound..maxBound]
mkSSConf :: ConfigData -> SSConf
mkSSConf cdata = SSConf . M.fromList $
[ (SSClusterName, return $ clusterClusterName cluster)
- , (SSClusterTags, toList $ tagsOf cluster)
+ , (SSClusterTags, toList . fromTagSet $ tagsOf cluster)
, (SSFileStorageDir, return $ clusterFileStorageDir cluster)
, (SSSharedFileStorageDir, return $ clusterSharedFileStorageDir cluster)
, (SSGlusterStorageDir, return $ clusterGlusterStorageDir cluster)
diff --git a/test/hs/Test/Ganeti/Objects.hs b/test/hs/Test/Ganeti/Objects.hs
index ea17bc0..49cfb64 100644
--- a/test/hs/Test/Ganeti/Objects.hs
+++ b/test/hs/Test/Ganeti/Objects.hs
@@ -127,7 +127,7 @@ instance Arbitrary Node where
<*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
<*> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
<*> fmap UTF8.fromString genUUID <*> arbitrary
- <*> (Set.fromList <$> genTags)
+ <*> arbitrary -- TagSet
$(genArbitrary ''BlockDriver)
@@ -218,7 +218,7 @@ instance Arbitrary ForthcomingInstanceData where
-- serial
<*> arbitrary
-- tags
- <*> (Set.fromList <$> genTags)
+ <*> arbitrary
instance Arbitrary RealInstanceData where
arbitrary =
@@ -259,7 +259,7 @@ instance Arbitrary RealInstanceData where
-- serial
<*> arbitrary
-- tags
- <*> (Set.fromList <$> genTags)
+ <*> arbitrary
instance Arbitrary Instance where
arbitrary = frequency [ (1, ForthcomingInstance <$> arbitrary)
@@ -367,7 +367,7 @@ instance Arbitrary ClusterBeParams where
arbitrary = (GenericContainer . Map.fromList) <$> arbitrary
instance Arbitrary TagSet where
- arbitrary = Set.fromList <$> genTags
+ arbitrary = TagSet . Set.fromList <$> genTags
instance Arbitrary IAllocatorParams where
arbitrary = return $ GenericContainer Map.empty
@@ -462,7 +462,7 @@ genValidNetwork = do
ctime <- arbitrary
mtime <- arbitrary
let n = Network name mac_prefix (mkIp4Network net netmask) net6 gateway
- gateway6 res ext_res uuid ctime mtime 0 Set.empty
+ gateway6 res ext_res uuid ctime mtime 0 emptyTagSet
return n
-- | Generate an arbitrary string consisting of '0' and '1' of the given
length.
@@ -706,7 +706,7 @@ genNodeGroup = do
mtime <- arbitrary
uuid <- genFQDN `suchThat` (/= name)
serial <- arbitrary
- tags <- Set.fromList <$> genTags
+ tags <- arbitrary
let group = NodeGroup name members ndparams alloc_policy ipolicy diskparams
net_map hv_state disk_state ctime mtime (UTF8.fromString uuid)
serial tags
diff --git a/test/hs/Test/Ganeti/Query/Instance.hs
b/test/hs/Test/Ganeti/Query/Instance.hs
index 6a961c4..b095ba8 100644
--- a/test/hs/Test/Ganeti/Query/Instance.hs
+++ b/test/hs/Test/Ganeti/Query/Instance.hs
@@ -40,7 +40,6 @@ module Test.Ganeti.Query.Instance
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.Map as Map
-import qualified Data.Set as Set
import System.Time (ClockTime(..))
import Ganeti.JSON
@@ -64,7 +63,7 @@ createInstance name pnodeUuid adminState adminStateSource =
(PartialBeParams Nothing Nothing Nothing Nothing Nothing Nothing)
(GenericContainer Map.empty) (GenericContainer Map.empty)
adminState adminStateSource [] [] False Nothing epochTime epochTime
- (UTF8.fromString "") 0 Set.empty
+ (UTF8.fromString "") 0 emptyTagSet
where epochTime = TOD 0 0
-- | A fake InstanceInfo to be used to check values.
--
2.8.1
