Revision 2af78b97

b/htools/Ganeti/Objects.hs
35 35 
  , PartialNicParams(..)
36 36 
  , FilledNicParams(..)
37 37 
  , fillNicParams
38 
  , allNicParamFields
38 39 
  , PartialNic(..)
39 40 
  , DiskMode(..)
40 41 
  , DiskType(..)
......
44 45 
  , PartialBeParams(..)
45 46 
  , FilledBeParams(..)
46 47 
  , fillBeParams
48 
  , allBeParamFields
47 49 
  , Hypervisor(..)
48 50 
  , AdminState(..)
49 51 
  , adminStateFromRaw
......
52 54 
  , PartialNDParams(..)
53 55 
  , FilledNDParams(..)
54 56 
  , fillNDParams
57 
  , allNDParamFields
55 58 
  , Node(..)
56 59 
  , NodeRole(..)
57 60 
  , nodeRoleToRaw
......
60 63 
  , FilledISpecParams(..)
61 64 
  , PartialISpecParams(..)
62 65 
  , fillISpecParams
66 
  , allISpecParamFields
63 67 
  , FilledIPolicy(..)
64 68 
  , PartialIPolicy(..)
65 69 
  , fillIPolicy
......
79 83 
  , UuidObject(..)
80 84 
  , SerialNoObject(..)
81 85 
  , TagsObject(..)
86 
  , DictObject(..) -- re-exported from THH
82 87 
  ) where
83 88 

  		





  84
  89
  
    
import Data.List (foldl')


  		












  

    
      b/htools/Ganeti/THH.hs
    
  






  51
  51
  
    
                  , buildObject


  		





  52
  52
  
    
                  , buildObjectSerialisation


  		





  53
  53
  
    
                  , buildParam


  		





  
  54
  
    
                  , DictObject(..)


  		





  54
  55
  
    
                  ) where


  		





  55
  56
  
    

  		





  56
  57
  
    
import Control.Monad (liftM)


  		





  ......




  64
  65
  
    

  		





  65
  66
  
    
-- * Exported types


  		





  66
  67
  
    

  		





  
  68
  
    
-- | Class of objects that can be converted to 'JSObject'


  		





  
  69
  
    
-- lists-format.


  		





  
  70
  
    
class DictObject a where


  		





  
  71
  
    
  toDict :: a -> [(String, JSON.JSValue)]


  		





  
  72
  
    

  		





  67
  73
  
    
-- | Serialised field data type.


  		





  68
  74
  
    
data Field = Field { fieldName        :: String


  		





  69
  75
  
    
                   , fieldType        :: Q Type


  		





  ......




  624
  630
  
    
                 [rdjson, shjson]


  		





  625
  631
  
    
  return $ savedecls ++ [loadsig, loadfn, instdecl]


  		





  626
  632
  
    

  		





  
  633
  
    
-- | The toDict function name for a given type.


  		





  
  634
  
    
toDictName :: String -> Name


  		





  
  635
  
    
toDictName sname = mkName ("toDict" ++ sname)


  		





  
  636
  
    

  		





  627
  637
  
    
-- | Generates the save object functionality.


  		





  628
  638
  
    
genSaveObject :: (Name -> Field -> Q Exp)


  		





  629
  639
  
    
              -> String -> [Field] -> Q [Dec]


  		





  ......




  631
  641
  
    
  let name = mkName sname


  		





  632
  642
  
    
  fnames <- mapM (newName . fieldVariable) fields


  		





  633
  643
  
    
  let pat = conP name (map varP fnames)


  		





  634
  
  
    
  let tdname = mkName ("toDict" ++ sname)


  		





  
  644
  
    
  let tdname = toDictName sname


  		





  635
  645
  
    
  tdsigt <- [t| $(conT name) -> [(String, JSON.JSValue)] |]


  		





  636
  646
  
    

  		





  637
  647
  
    
  let felems = map (uncurry save_fn) (zip fnames fields)


  		





  ......




  756
  766
  
    
  ser_decls_f <- buildObjectSerialisation sname_f fields


  		





  757
  767
  
    
  ser_decls_p <- buildPParamSerialisation sname_p fields


  		





  758
  768
  
    
  fill_decls <- fillParam sname field_pfx fields


  		





  759
  
  
    
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls


  		





  
  769
  
    
  return $ [declF, declP] ++ ser_decls_f ++ ser_decls_p ++ fill_decls ++


  		





  
  770
  
    
           buildParamAllFields sname fields ++


  		





  
  771
  
    
           buildDictObjectInst name_f sname_f


  		





  
  772
  
    

  		





  
  773
  
    
-- | Builds a list of all fields of a parameter.


  		





  
  774
  
    
buildParamAllFields :: String -> [Field] -> [Dec]


  		





  
  775
  
    
buildParamAllFields sname fields =


  		





  
  776
  
    
  let vname = mkName ("all" ++ sname ++ "ParamFields")


  		





  
  777
  
    
      sig = SigD vname (AppT ListT (ConT ''String))


  		





  
  778
  
    
      val = ListE $ map (LitE . StringL . fieldName) fields


  		





  
  779
  
    
  in [sig, ValD (VarP vname) (NormalB val) []]


  		





  
  780
  
    

  		





  
  781
  
    
-- | Builds the 'DictObject' instance for a filled parameter.


  		





  
  782
  
    
buildDictObjectInst :: Name -> String -> [Dec]


  		





  
  783
  
    
buildDictObjectInst name sname =


  		





  
  784
  
    
  [InstanceD [] (AppT (ConT ''DictObject) (ConT name))


  		





  
  785
  
    
   [ValD (VarP 'toDict) (NormalB (VarE (toDictName sname))) []]]


  		





  760
  786
  
    

  		





  761
  787
  
    
-- | Generates the serialisation for a partial parameter.


  		





  762
  788
  
    
buildPParamSerialisation :: String -> [Field] -> Q [Dec]


  		












Also available in:
  Unified diff