diff --git a/htools/Ganeti/HTools/QC.hs b/htools/Ganeti/HTools/QC.hs index 611d74dcd46ee16417ea5ddac2a14ab352b1d7a2..72a2d2760bf3a21fbfc5dcb5875ea74bfc6109f8 100644 --- a/htools/Ganeti/HTools/QC.hs +++ b/htools/Ganeti/HTools/QC.hs @@ -438,11 +438,7 @@ instance Arbitrary OpCodes.ReplaceDisksMode where instance Arbitrary OpCodes.OpCode where arbitrary = do - op_id <- elements [ "OP_TEST_DELAY" - , "OP_INSTANCE_REPLACE_DISKS" - , "OP_INSTANCE_FAILOVER" - , "OP_INSTANCE_MIGRATE" - ] + op_id <- elements OpCodes.allOpIDs case op_id of "OP_TEST_DELAY" -> OpCodes.OpTestDelay <$> arbitrary <*> arbitrary diff --git a/htools/Ganeti/OpCodes.hs b/htools/Ganeti/OpCodes.hs index 3ecc6455fd3a731529a548a2ca39564c60c12648..bda66a17eb2214350bb7243be2ebadaff9eb5db1 100644 --- a/htools/Ganeti/OpCodes.hs +++ b/htools/Ganeti/OpCodes.hs @@ -6,7 +6,7 @@ {- -Copyright (C) 2009, 2010, 2011 Google Inc. +Copyright (C) 2009, 2010, 2011, 2012 Google Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -29,6 +29,7 @@ module Ganeti.OpCodes ( OpCode(..) , ReplaceDisksMode(..) , opID + , allOpIDs ) where import Text.JSON (readJSON, showJSON, makeObj, JSON) @@ -78,8 +79,12 @@ $(genOpCode "OpCode" ]) ]) +-- | Returns the OP_ID for a given opcode value. $(genOpID ''OpCode "opID") +-- | A list of all defined/supported opcode IDs. +$(genAllOpIDs ''OpCode "allOpIDs") + instance JSON OpCode where readJSON = loadOpCode showJSON = saveOpCode diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 9fdf8cad8a1712311be65e03da7e56f0fe4bd6e8..c08e9217699fb9d6bc40942a1a68ebbb3c911155 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -33,6 +33,7 @@ module Ganeti.THH ( declareSADT , declareIADT , makeJSONInstance , genOpID + , genAllOpIDs , genOpCode , genStrOfOp , genStrOfKey @@ -399,6 +400,28 @@ genConstrToStr trans_fun name fname = do genOpID :: Name -> String -> Q [Dec] genOpID = genConstrToStr deCamelCase +-- | Builds a list with all defined constructor names for a type. +-- +-- @ +-- vstr :: String +-- vstr = [...] +-- @ +-- +-- Where the actual values of the string are the constructor names +-- mapped via @trans_fun@. +genAllConstr :: (String -> String) -> Name -> String -> Q [Dec] +genAllConstr trans_fun name vstr = do + cnames <- reifyConsNames name + let svalues = sort $ map trans_fun cnames + vname = mkName vstr + sig = SigD vname (AppT ListT (ConT ''String)) + body = NormalB (ListE (map (LitE . StringL) svalues)) + return $ [sig, ValD (VarP vname) body []] + +-- | Generates a list of all defined opcode IDs. +genAllOpIDs :: Name -> String -> Q [Dec] +genAllOpIDs = genAllConstr deCamelCase + -- | OpCode parameter (field) type. type OpParam = (String, Q Type, Q Exp)