X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/18049dad6e4a44919c1ce6359ed0b36a8b3b81fe..ef3ad027d9187f07101489f6fa081529c55e2a36:/htools/Ganeti/THH.hs diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 9bdde6f..bf9802e 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -53,6 +53,8 @@ module Ganeti.THH ( declareSADT , buildObjectSerialisation , buildParam , DictObject(..) + , genException + , excErrMsg ) where import Control.Monad (liftM) @@ -63,6 +65,7 @@ import qualified Data.Set as Set import Language.Haskell.TH import qualified Text.JSON as JSON +import Text.JSON.Pretty (pp_value) -- * Exported types @@ -180,6 +183,17 @@ tagsFields :: [Field] tagsFields = [ defaultField [| Set.empty |] $ simpleField "tags" [t| TagSet |] ] +-- * Internal types + +-- | A simple field, in constrast to the customisable 'Field' type. +type SimpleField = (String, Q Type) + +-- | A definition for a single constructor for a simple object. +type SimpleConstructor = (String, [SimpleField]) + +-- | A definition for ADTs with simple fields. +type SimpleObject = [SimpleConstructor] + -- * Helper functions -- | Ensure first letter is lowercase. @@ -225,6 +239,32 @@ appFn :: Exp -> Exp -> Exp appFn f x | f == VarE 'id = x | otherwise = AppE f x +-- | Builds a field for a normal constructor. +buildConsField :: Q Type -> StrictTypeQ +buildConsField ftype = do + ftype' <- ftype + return (NotStrict, ftype') + +-- | Builds a constructor based on a simple definition (not field-based). +buildSimpleCons :: Name -> SimpleObject -> Q Dec +buildSimpleCons tname cons = do + decl_d <- mapM (\(cname, fields) -> do + fields' <- mapM (buildConsField . snd) fields + return $ NormalC (mkName cname) fields') cons + return $ DataD [] tname [] decl_d [''Show, ''Read, ''Eq] + +-- | Generate the save function for a given type. +genSaveSimpleObj :: Name -- ^ Object type + -> String -- ^ Function name + -> SimpleObject -- ^ Object definition + -> (SimpleConstructor -> Q Clause) -- ^ Constructor save fn + -> Q (Dec, Dec) +genSaveSimpleObj tname sname opdefs fn = do + let sigt = AppT (AppT ArrowT (ConT tname)) (ConT ''JSON.JSValue) + fname = mkName sname + cclauses <- mapM fn opdefs + return $ (SigD fname sigt, FunD fname cclauses) + -- * Template code for simple raw type-equivalent ADTs -- | Generates a data type declaration. @@ -547,9 +587,6 @@ genStrOfOp = genConstrToStr id genStrOfKey :: Name -> String -> Q [Dec] genStrOfKey = genConstrToStr ensureLower --- | LuxiOp parameter type. -type LuxiParam = (String, Q Type) - -- | Generates the LuxiOp data type. -- -- This takes a Luxi operation definition and builds both the @@ -563,28 +600,24 @@ type LuxiParam = (String, Q Type) -- -- * type -- -genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec] +genLuxiOp :: String -> SimpleObject -> Q [Dec] genLuxiOp name cons = do - decl_d <- mapM (\(cname, fields) -> do - fields' <- mapM (\(_, qt) -> - qt >>= \t -> return (NotStrict, t)) - fields - return $ NormalC (mkName cname) fields') - cons - let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq] - (savesig, savefn) <- genSaveLuxiOp cons + let tname = mkName name + declD <- buildSimpleCons tname cons + (savesig, savefn) <- genSaveSimpleObj tname "opToArgs" + cons saveLuxiConstructor req_defs <- declareSADT "LuxiReq" . map (\(str, _) -> ("Req" ++ str, mkName ("luxiReq" ++ str))) $ cons return $ [declD, savesig, savefn] ++ req_defs -- | Generates the \"save\" expression for a single luxi parameter. -saveLuxiField :: Name -> LuxiParam -> Q Exp +saveLuxiField :: Name -> SimpleField -> Q Exp saveLuxiField fvar (_, qt) = [| JSON.showJSON $(varE fvar) |] -- | Generates the \"save\" clause for entire LuxiOp constructor. -saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause +saveLuxiConstructor :: SimpleConstructor -> Q Clause saveLuxiConstructor (sname, fields) = do let cname = mkName sname fnames = map (mkName . fst) fields @@ -595,14 +628,6 @@ saveLuxiConstructor (sname, fields) = do else [| JSON.showJSON $(listE flist) |] clause [pat] (normalB finval) [] --- | Generates the main save LuxiOp function. -genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec) -genSaveLuxiOp opdefs = do - sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |] - let fname = mkName "opToArgs" - cclauses <- mapM saveLuxiConstructor opdefs - return $ (SigD fname sigt, FunD fname cclauses) - -- * "Objects" functionality -- | Extract the field's declaration from a Field structure. @@ -859,3 +884,108 @@ fillParam sname field_pfx fields = do (NormalB $ LetE (le_full:le_part:le_new) obj_new) [] fun = FunD fun_name [fclause] return [sig, fun] + +-- * Template code for exceptions + +-- | Exception simple error message field. +excErrMsg :: (String, Q Type) +excErrMsg = ("errMsg", [t| String |]) + +-- | Builds an exception type definition. +genException :: String -- ^ Name of new type + -> SimpleObject -- ^ Constructor name and parameters + -> Q [Dec] +genException name cons = do + let tname = mkName name + declD <- buildSimpleCons tname cons + (savesig, savefn) <- genSaveSimpleObj tname ("save" ++ name) cons $ + uncurry saveExcCons + (loadsig, loadfn) <- genLoadExc tname ("load" ++ name) cons + return [declD, loadsig, loadfn, savesig, savefn] + +-- | Generates the \"save\" clause for an entire exception constructor. +-- +-- This matches the exception with variables named the same as the +-- constructor fields (just so that the spliced in code looks nicer), +-- and calls showJSON on it. +saveExcCons :: String -- ^ The constructor name + -> [SimpleField] -- ^ The parameter definitions for this + -- constructor + -> Q Clause -- ^ Resulting clause +saveExcCons sname fields = do + let cname = mkName sname + fnames <- mapM (newName . fst) fields + let pat = conP cname (map varP fnames) + felems = if null fnames + then conE '() -- otherwise, empty list has no type + else listE $ map (\f -> [| JSON.showJSON $(varE f) |]) fnames + let tup = tupE [ litE (stringL sname), felems ] + clause [pat] (normalB [| JSON.showJSON $tup |]) [] + +-- | Generates load code for a single constructor of an exception. +-- +-- Generates the code (if there's only one argument, we will use a +-- list, not a tuple: +-- +-- @ +-- do +-- (x1, x2, ...) <- readJSON args +-- return $ Cons x1 x2 ... +-- @ +loadExcConstructor :: Name -> String -> [SimpleField] -> Q Exp +loadExcConstructor inname sname fields = do + let name = mkName sname + f_names <- mapM (newName . fst) fields + let read_args = AppE (VarE 'JSON.readJSON) (VarE inname) + let binds = case f_names of + [x] -> BindS (ListP [VarP x]) + _ -> BindS (TupP (map VarP f_names)) + cval = foldl (\accu fn -> AppE accu (VarE fn)) (ConE name) f_names + return $ DoE [binds read_args, NoBindS (AppE (VarE 'return) cval)] + +{-| Generates the loadException function. + +This generates a quite complicated function, along the lines of: + +@ +loadFn (JSArray [JSString name, args]) = case name of + "A1" -> do + (x1, x2, ...) <- readJSON args + return $ A1 x1 x2 ... + "a2" -> ... + s -> fail $ "Unknown exception" ++ s +loadFn v = fail $ "Expected array but got " ++ show v +@ +-} +genLoadExc :: Name -> String -> SimpleObject -> Q (Dec, Dec) +genLoadExc tname sname opdefs = do + let fname = mkName sname + exc_name <- newName "name" + exc_args <- newName "args" + exc_else <- newName "s" + arg_else <- newName "v" + fails <- [| fail $ "Unknown exception '" ++ $(varE exc_else) ++ "'" |] + -- default match for unknown exception name + let defmatch = Match (VarP exc_else) (NormalB fails) [] + -- the match results (per-constructor blocks) + str_matches <- + mapM (\(s, params) -> do + body_exp <- loadExcConstructor exc_args s params + return $ Match (LitP (StringL s)) (NormalB body_exp) []) + opdefs + -- the first function clause; we can't use [| |] due to TH + -- limitations, so we have to build the AST by hand + let clause1 = Clause [ConP 'JSON.JSArray + [ListP [ConP 'JSON.JSString [VarP exc_name], + VarP exc_args]]] + (NormalB (CaseE (AppE (VarE 'JSON.fromJSString) + (VarE exc_name)) + (str_matches ++ [defmatch]))) [] + -- the fail expression for the second function clause + fail_type <- [| fail $ "Invalid exception: expected '(string, [args])' " ++ + " but got " ++ show (pp_value $(varE arg_else)) ++ "'" + |] + -- the second function clause + let clause2 = Clause [VarP arg_else] (NormalB fail_type) [] + sigt <- [t| JSON.JSValue -> JSON.Result $(conT tname) |] + return $ (SigD fname sigt, FunD fname [clause1, clause2])