Revision 84835174 htools/Ganeti/THH.hs

b/htools/Ganeti/THH.hs
54 54
                  , Container
55 55
                  ) where
56 56

  
57
import Control.Arrow
58 57
import Control.Monad (liftM, liftM2)
59 58
import Data.Char
60 59
import Data.List
61
import qualified Data.Map as M
62 60
import qualified Data.Set as Set
63 61
import Language.Haskell.TH
64 62

  
......
68 66

  
69 67
-- * Exported types
70 68

  
71
type Container = M.Map String
72

  
73 69
-- | Serialised field data type.
74 70
data Field = Field { fieldName        :: String
75 71
                   , fieldType        :: Q Type
......
155 151
       -> Q Exp   -- ^ The entire object in JSON object format
156 152
       -> Q Exp   -- ^ Resulting expression
157 153
loadFn (Field { fieldIsContainer = True }) expr _ =
158
  [| $expr >>= readContainer |]
154
  [| $expr |]
159 155
loadFn (Field { fieldRead = Just readfn }) expr o = [| $expr >>= $readfn $o |]
160 156
loadFn _ expr _ = expr
161 157

  
......
225 221
appFn f x | f == VarE 'id = x
226 222
          | otherwise = AppE f x
227 223

  
228
-- | Container loader
229
readContainer :: (Monad m, JSON.JSON a) =>
230
                 JSON.JSObject JSON.JSValue -> m (Container a)
231
readContainer obj = do
232
  let kjvlist = JSON.fromJSObject obj
233
  kalist <- mapM (\(k, v) -> fromKeyValue k v >>= \a -> return (k, a)) kjvlist
234
  return $ M.fromList kalist
235

  
236
-- | Container dumper
237
showContainer :: (JSON.JSON a) => Container a -> JSON.JSValue
238
showContainer = JSON.makeObj . map (second JSON.showJSON) . M.toList
239

  
240 224
-- * Template code for simple raw type-equivalent ADTs
241 225

  
242 226
-- | Generates a data type declaration.
......
639 623

  
640 624
saveObjectField :: Name -> Field -> Q Exp
641 625
saveObjectField fvar field
642
  | isContainer = [| [( $nameE , JSON.showJSON . showContainer $ $fvarE)] |]
626
  | isContainer = [| [( $nameE , JSON.showJSON $fvarE)] |]
643 627
  | fisOptional = [| case $(varE fvar) of
644 628
                      Nothing -> []
645 629
                      Just v -> [( $nameE, JSON.showJSON v)]

Also available in: Unified diff