Revision 2af78b97 htools/Ganeti/THH.hs

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