Synnefo » snf-ganeti

import Data.Char

import Data.List

import Data.Maybe

import qualified Data.Set as Set

import Language.Haskell.TH

  = NotOptional           -- ^ Field is not optional

  | OptionalOmitNull      -- ^ Field is optional, null is not serialised

  | OptionalSerializeNull -- ^ Field is optional, null is serialised

  deriving (Show, Eq)

-- | Serialised field data type.

-- | Compute the actual field type (taking into account possible

-- optional status).

actualFieldType :: Field -> Q Type

                  where t = fieldType f

-- | Checks that a given field is not optional (for object types or

loadConstructor :: OpCodeConstructor -> Q Exp

loadConstructor (sname, _, _, fields, _) = do

  let name = mkName sname

  let (fnames, fstmts) = unzip fbinds

  let cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) fnames

      fstmts' = fstmts ++ [NoBindS (AppE (VarE 'return) cval)]

buildObjectSerialisation sname fields = do

  let name = mkName sname

  savedecls <- genSaveObject saveObjectField sname fields

  shjson <- objectShowJSON sname

  rdjson <- objectReadJSON sname

  let instdecl = InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name))

        Just fn -> [| let (actual, extra) = $fn $fvarE

                      in ($nameE, JSON.showJSON actual):extra

                    |]

  where nameE = stringE (fieldName field)

        fvarE = varE fvar

            FunD funname [Clause [VarP arg1] (NormalB (DoE fstmts')) []])

-- | Generates code for loading an object's field.

  let name = fieldVariable field

  fvar <- newName name

  -- these are used in all patterns below

  let objvar = varNameE "o"

      objfield = stringE (fieldName field)

      loadexp =

                 Just defv ->

                   [| $(varE 'fromObjWithDefault) $objvar

                      $objfield $defv |]

                 Nothing -> [| $fromObjE $objvar $objfield |]

  bexp <- loadFn field loadexp objvar

  return (fvar, BindS (VarP fvar) bexp)