Revision ef3ad027 htools/Ganeti/THH.hs

b/htools/Ganeti/THH.hs
53 53
                  , buildObjectSerialisation
54 54
                  , buildParam
55 55
                  , DictObject(..)
56
                  , genException
57
                  , excErrMsg
56 58
                  ) where
57 59

  
58 60
import Control.Monad (liftM)
......
63 65
import Language.Haskell.TH
64 66

  
65 67
import qualified Text.JSON as JSON
68
import Text.JSON.Pretty (pp_value)
66 69

  
67 70
-- * Exported types
68 71

  
......
881 884
                (NormalB $ LetE (le_full:le_part:le_new) obj_new) []
882 885
      fun = FunD fun_name [fclause]
883 886
  return [sig, fun]
887

  
888
-- * Template code for exceptions
889

  
890
-- | Exception simple error message field.
891
excErrMsg :: (String, Q Type)
892
excErrMsg = ("errMsg", [t| String |])
893

  
894
-- | Builds an exception type definition.
895
genException :: String                  -- ^ Name of new type
896
             -> SimpleObject -- ^ Constructor name and parameters
897
             -> Q [Dec]
898
genException name cons = do
899
  let tname = mkName name
900
  declD <- buildSimpleCons tname cons
901
  (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $
902
                         uncurry saveExcCons
903
  (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons
904
  return [declD, loadsig, loadfn, savesig, savefn]
905

  
906
-- | Generates the \"save\" clause for an entire exception constructor.
907
--
908
-- This matches the exception with variables named the same as the
909
-- constructor fields (just so that the spliced in code looks nicer),
910
-- and calls showJSON on it.
911
saveExcCons :: String        -- ^ The constructor name
912
            -> [SimpleField] -- ^ The parameter definitions for this
913
                             -- constructor
914
            -> Q Clause      -- ^ Resulting clause
915
saveExcCons sname fields = do
916
  let cname = mkName sname
917
  fnames <- mapM (newName . fst) fields
918
  let pat = conP cname (map varP fnames)
919
      felems = if null fnames
920
                 then conE '() -- otherwise, empty list has no type
921
                 else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames
922
  let tup = tupE [ litE (stringL sname), felems ]
923
  clause [pat] (normalB [| JSON.showJSON $tup |]) []
924

  
925
-- | Generates load code for a single constructor of an exception.
926
--
927
-- Generates the code (if there's only one argument, we will use a
928
-- list, not a tuple:
929
--
930
-- @
931
-- do
932
--  (x1, x2, ...) <- readJSON args
933
--  return $ Cons x1 x2 ...
934
-- @
935
loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp
936
loadExcConstructor inname sname fields = do
937
  let name = mkName sname
938
  f_names <- mapM (newName . fst) fields
939
  let read_args = AppE (VarE 'JSON.readJSON) (VarE inname)
940
  let binds = case f_names of
941
                [x] -> BindS (ListP [VarP x])
942
                _   -> BindS (TupP (map VarP f_names))
943
      cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names
944
  return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)]
945

  
946
{-| Generates the loadException function.
947

  
948
This generates a quite complicated function, along the lines of:
949

  
950
@
951
loadFn (JSArray [JSString name, args]) = case name of
952
   "A1" -> do
953
     (x1, x2, ...) <- readJSON args
954
     return $ A1 x1 x2 ...
955
   "a2" -> ...
956
   s -> fail $ "Unknown exception" ++ s
957
loadFn v = fail $ "Expected array but got " ++ show v
958
@
959
-}
960
genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec)
961
genLoadExc tname sname opdefs = do
962
  let fname = mkName sname
963
  exc_name <- newName "name"
964
  exc_args <- newName "args"
965
  exc_else <- newName "s"
966
  arg_else <- newName "v"
967
  fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |]
968
  -- default match for unknown exception name
969
  let defmatch = Match (VarP exc_else) (NormalB fails) []
970
  -- the match results (per-constructor blocks)
971
  str_matches <-
972
    mapM (\(s, params) -> do
973
            body_exp <- loadExcConstructor exc_args s params
974
            return $ Match (LitP (StringL s)) (NormalB body_exp) [])
975
    opdefs
976
  -- the first function clause; we can't use [| |] due to TH
977
  -- limitations, so we have to build the AST by hand
978
  let clause1 = Clause [ConP 'JSON.JSArray
979
                               [ListP [ConP 'JSON.JSString [VarP exc_name],
980
                                            VarP exc_args]]]
981
                (NormalB (CaseE (AppE (VarE 'JSON.fromJSString)
982
                                        (VarE exc_name))
983
                          (str_matches ++ [defmatch]))) []
984
  -- the fail expression for the second function clause
985
  fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++
986
                  "      but got " ++ show (pp_value $(varE arg_else)) ++ "'"
987
                |]
988
  -- the second function clause
989
  let clause2 = Clause [VarP arg_else] (NormalB fail_type) []
990
  sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |]
991
  return $ (SigD fname sigt, FunD fname [clause1, clause2])

Also available in: Unified diff