Revision 948f6540 src/Ganeti/THH.hs

b/src/Ganeti/THH.hs
67 67 
                  , buildObjectSerialisation
68 68 
                  , buildParam
69 69 
                  , DictObject(..)
70 
                  , ArrayObject(..)
70 71 
                  , genException
71 72 
                  , excErrMsg
72 73 
                  ) where
......
83 84 
import qualified Data.Map as M
84 85 
import qualified Data.Set as Set
85 86 
import Language.Haskell.TH
87 
import Language.Haskell.TH.Syntax (lift)
86 88 
import System.Time (ClockTime(..))
87 89 

  		





  88
  90
  
    
import qualified Text.JSON as JSON


  		





  ......




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


  		





  102
  104
  
    
  fromDict :: [(String, JSON.JSValue)] -> JSON.Result a


  		





  103
  105
  
    

  		





  
  106
  
    
-- | Class of objects that can be converted from and to @[JSValue]@ with


  		





  
  107
  
    
-- a fixed length and order.


  		





  
  108
  
    
class ArrayObject a where


  		





  
  109
  
    
  toJSArray :: a -> [JSON.JSValue]


  		





  
  110
  
    
  fromJSArray :: [JSON.JSValue] -> JSON.Result a


  		





  
  111
  
    

  		





  104
  112
  
    
-- | Optional field information.


  		





  105
  113
  
    
data OptionalType


  		





  106
  114
  
    
  = NotOptional           -- ^ Field is not optional


  		





  ......




  1008
  1016
  
    
objVarName :: Name


  		





  1009
  1017
  
    
objVarName = mkName "_o"


  		





  1010
  1018
  
    

  		





  
  1019
  
    
-- | Provides a default 'toJSArray' for 'ArrayObject' instance using its


  		





  
  1020
  
    
-- existing 'DictObject' instance. The keys are serialized in the order


  		





  
  1021
  
    
-- they're declared. The list must contain all keys possibly generated by


  		





  
  1022
  
    
-- 'toDict'.


  		





  
  1023
  
    
defaultToJSArray :: (DictObject a) => [String] -> a -> [JSON.JSValue]


  		





  
  1024
  
    
defaultToJSArray keys o =


  		





  
  1025
  
    
  let m = M.fromList $ toDict o


  		





  
  1026
  
    
  in map (fromMaybe JSON.JSNull . flip M.lookup m) keys


  		





  
  1027
  
    

  		





  
  1028
  
    
-- | Provides a default 'fromJSArray' for 'ArrayObject' instance using its


  		





  
  1029
  
    
-- existing 'DictObject' instance. The fields are deserialized in the order


  		





  
  1030
  
    
-- they're declared.


  		





  
  1031
  
    
defaultFromJSArray :: (DictObject a)


  		





  
  1032
  
    
                   => [String] -> [JSON.JSValue] -> JSON.Result a


  		





  
  1033
  
    
defaultFromJSArray keys xs = do


  		





  
  1034
  
    
  let xslen = length xs


  		





  
  1035
  
    
      explen = length keys


  		





  
  1036
  
    
  unless (xslen == explen) (fail $ "Expected " ++ show explen


  		





  
  1037
  
    
                                   ++ " arguments, got " ++ show xslen)


  		





  
  1038
  
    
  fromDict $ zip keys xs


  		





  
  1039
  
    

  		





  
  1040
  
    
-- | Generates an additional 'ArrayObject' instance using its


  		





  
  1041
  
    
-- existing 'DictObject' instance.


  		





  
  1042
  
    
--


  		





  
  1043
  
    
-- See 'defaultToJSArray' and 'defaultFromJSArray'.


  		





  
  1044
  
    
genArrayObjectInstance :: Name -> [Field] -> Q Dec


  		





  
  1045
  
    
genArrayObjectInstance name fields = do


  		





  
  1046
  
    
  let fnames = concatMap (liftA2 (:) fieldName fieldExtraKeys) fields


  		





  
  1047
  
    
  instanceD (return []) (appT (conT ''ArrayObject) (conT name))


  		





  
  1048
  
    
    [ valD (varP 'toJSArray) (normalB [| defaultToJSArray $(lift fnames) |]) []


  		





  
  1049
  
    
    , valD (varP 'fromJSArray) (normalB [| defaultFromJSArray fnames |]) []


  		





  
  1050
  
    
    ]


  		





  
  1051
  
    

  		





  1011
  1052
  
    
-- | Generates 'DictObject' instance.


  		





  1012
  1053
  
    
genDictObject :: (Name -> Field -> Q Exp)  -- ^ a saving function


  		





  1013
  1054
  
    
              -> (Field -> Q Exp)          -- ^ a loading function


  		





  ......




  1024
  1065
  
    
  -- fromDict


  		





  1025
  1066
  
    
  fdexp <- loadConstructor name load_fn fields


  		





  1026
  1067
  
    
  let fdclause = Clause [VarP objVarName] (NormalB fdexp) []


  		





  
  1068
  
    
  -- the ArrayObject instance generated from DictObject


  		





  
  1069
  
    
  arrdec <- genArrayObjectInstance name fields


  		





  1027
  1070
  
    
  -- the final instance


  		





  1028
  
  
    
  return [InstanceD [] (AppT (ConT ''DictObject) (ConT name))


  		





  1029
  
  
    
           [ FunD 'toDict [tdclause]


  		





  1030
  
  
    
           , FunD 'fromDict [fdclause]


  		





  1031
  
  
    
           ]]


  		





  
  1071
  
    
  return $ [InstanceD [] (AppT (ConT ''DictObject) (ConT name))


  		





  
  1072
  
    
             [ FunD 'toDict [tdclause]


  		





  
  1073
  
    
             , FunD 'fromDict [fdclause]


  		





  
  1074
  
    
             ]]


  		





  
  1075
  
    
         ++ [arrdec]


  		





  1032
  1076
  
    

  		





  1033
  1077
  
    
-- | Generates the save object functionality.


  		





  1034
  1078
  
    
genSaveObject :: String -> Q [Dec]


  		












Also available in:
  Unified diff