X-Git-Url: https://code.grnet.gr/git/ganeti-local/blobdiff_plain/18049dad6e4a44919c1ce6359ed0b36a8b3b81fe..1ba01ff70134bef829b377c26cff133f5cfd31c9:/htools/Ganeti/THH.hs?ds=sidebyside diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 9bdde6f..2fb5084 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -33,6 +33,7 @@ module Ganeti.THH ( declareSADT , declareIADT , makeJSONInstance , genOpID + , genAllConstr , genAllOpIDs , genOpCode , genStrOfOp @@ -42,6 +43,7 @@ module Ganeti.THH ( declareSADT , simpleField , defaultField , optionalField + , optionalNullSerField , renameField , customField , timeStampFields @@ -53,6 +55,8 @@ module Ganeti.THH ( declareSADT , buildObjectSerialisation , buildParam , DictObject(..) + , genException + , excErrMsg ) where import Control.Monad (liftM) @@ -63,6 +67,9 @@ import qualified Data.Set as Set import Language.Haskell.TH import qualified Text.JSON as JSON +import Text.JSON.Pretty (pp_value) + +import Ganeti.JSON -- * Exported types @@ -71,14 +78,22 @@ import qualified Text.JSON as JSON class DictObject a where toDict :: a -> [(String, JSON.JSValue)] +-- | Optional field information. +data OptionalType + = 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. data Field = Field { fieldName :: String , fieldType :: Q Type , fieldRead :: Maybe (Q Exp) , fieldShow :: Maybe (Q Exp) + , fieldExtraKeys :: [String] , fieldDefault :: Maybe (Q Exp) , fieldConstr :: Maybe String - , fieldIsOptional :: Bool + , fieldIsOptional :: OptionalType } -- | Generates a simple field. @@ -88,9 +103,10 @@ simpleField fname ftype = , fieldType = ftype , fieldRead = Nothing , fieldShow = Nothing + , fieldExtraKeys = [] , fieldDefault = Nothing , fieldConstr = Nothing - , fieldIsOptional = False + , fieldIsOptional = NotOptional } -- | Sets the renamed constructor field. @@ -104,15 +120,22 @@ defaultField defval field = field { fieldDefault = Just defval } -- | Marks a field optional (turning its base type into a Maybe). optionalField :: Field -> Field -optionalField field = field { fieldIsOptional = True } +optionalField field = field { fieldIsOptional = OptionalOmitNull } + +-- | Marks a field optional (turning its base type into a Maybe), but +-- with 'Nothing' serialised explicitly as /null/. +optionalNullSerField :: Field -> Field +optionalNullSerField field = field { fieldIsOptional = OptionalSerializeNull } -- | Sets custom functions on a field. -customField :: Name -- ^ The name of the read function - -> Name -- ^ The name of the show function - -> Field -- ^ The original field - -> Field -- ^ Updated field -customField readfn showfn field = - field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn) } +customField :: Name -- ^ The name of the read function + -> Name -- ^ The name of the show function + -> [String] -- ^ The name of extra field keys + -> Field -- ^ The original field + -> Field -- ^ Updated field +customField readfn showfn extra field = + field { fieldRead = Just (varE readfn), fieldShow = Just (varE showfn) + , fieldExtraKeys = extra } -- | Computes the record name for a given field, based on either the -- string value in the JSON serialisation or the custom named if any @@ -131,13 +154,21 @@ fieldVariable f = Just name -> ensureLower name _ -> map (\c -> if c == '-' then '_' else c) $ fieldName f +-- | Compute the actual field type (taking into account possible +-- optional status). actualFieldType :: Field -> Q Type -actualFieldType f | fieldIsOptional f = [t| Maybe $t |] +actualFieldType f | fieldIsOptional f /= NotOptional = [t| Maybe $t |] | otherwise = t where t = fieldType f +-- | Checks that a given field is not optional (for object types or +-- fields which should not allow this case). checkNonOptDef :: (Monad m) => Field -> m () -checkNonOptDef (Field { fieldIsOptional = True, fieldName = name }) = +checkNonOptDef (Field { fieldIsOptional = OptionalOmitNull + , fieldName = name }) = + fail $ "Optional field " ++ name ++ " used in parameter declaration" +checkNonOptDef (Field { fieldIsOptional = OptionalSerializeNull + , fieldName = name }) = fail $ "Optional field " ++ name ++ " used in parameter declaration" checkNonOptDef (Field { fieldDefault = (Just _), fieldName = name }) = fail $ "Default field " ++ name ++ " used in parameter declaration" @@ -180,6 +211,20 @@ 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] + +-- | A type alias for a constructor of a regular object. +type Constructor = (String, [Field]) + -- * Helper functions -- | Ensure first letter is lowercase. @@ -203,7 +248,15 @@ varNameE = varE . mkName -- | showJSON as an expression, for reuse. showJSONE :: Q Exp -showJSONE = varNameE "showJSON" +showJSONE = varE 'JSON.showJSON + +-- | makeObj as an expression, for reuse. +makeObjE :: Q Exp +makeObjE = varE 'JSON.makeObj + +-- | fromObj (Ganeti specific) as an expression, for reuse. +fromObjE :: Q Exp +fromObjE = varE 'fromObj -- | ToRaw function name. toRawName :: String -> Name @@ -225,6 +278,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, ''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. @@ -234,7 +313,7 @@ strADTDecl :: Name -> [String] -> Dec strADTDecl name constructors = DataD [] name [] (map (flip NormalC [] . mkName) constructors) - [''Show, ''Read, ''Eq, ''Enum, ''Bounded, ''Ord] + [''Show, ''Eq, ''Enum, ''Bounded, ''Ord] -- | Generates a toRaw function. -- @@ -332,7 +411,7 @@ declareSADT = declareADT ''String genShowJSON :: String -> Q Dec genShowJSON name = do body <- [| JSON.showJSON . $(varE (toRawName name)) |] - return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []] + return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []] -- | Creates the readJSON member of a JSON instance declaration. -- @@ -355,7 +434,7 @@ genReadJSON name = do $(stringE name) ++ ": " ++ e ++ " from " ++ show $(varE s) |] - return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []] + return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []] -- | Generates a JSON instance for a given type. -- @@ -447,28 +526,43 @@ type OpParam = (String, Q Type, Q Exp) -- datatype and the JSON serialisation out of it. We can't use a -- generic serialisation since we need to be compatible with Ganeti's -- own, so we have a few quirks to work around. -genOpCode :: String -- ^ Type name to use - -> [(String, [Field])] -- ^ Constructor name and parameters +genOpCode :: String -- ^ Type name to use + -> [Constructor] -- ^ Constructor name and parameters -> Q [Dec] genOpCode name cons = do + let tname = mkName name decl_d <- mapM (\(cname, fields) -> do -- we only need the type of the field, without Q - fields' <- mapM actualFieldType fields - let fields'' = zip (repeat NotStrict) fields' - return $ NormalC (mkName cname) fields'') + fields' <- mapM (fieldTypeInfo "op") fields + return $ RecC (mkName cname) fields') cons - let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq] + let declD = DataD [] tname [] decl_d [''Show, ''Eq] - (savesig, savefn) <- genSaveOpCode cons + let (allfsig, allffn) = genAllOpFields "allOpFields" cons + save_decs <- genSaveOpCode tname "saveOpCode" "toDictOpCode" + cons (uncurry saveConstructor) True (loadsig, loadfn) <- genLoadOpCode cons - return [declD, loadsig, loadfn, savesig, savefn] - --- | Checks whether a given parameter is options. --- --- This requires that it's a 'Maybe'. -isOptional :: Type -> Bool -isOptional (AppT (ConT dt) _) | dt == ''Maybe = True -isOptional _ = False + return $ [declD, allfsig, allffn, loadsig, loadfn] ++ save_decs + +-- | Generates the function pattern returning the list of fields for a +-- given constructor. +genOpConsFields :: Constructor -> Clause +genOpConsFields (cname, fields) = + let op_id = deCamelCase cname + fvals = map (LitE . StringL) . sort . nub $ + concatMap (\f -> fieldName f:fieldExtraKeys f) fields + in Clause [LitP (StringL op_id)] (NormalB $ ListE fvals) [] + +-- | Generates a list of all fields of an opcode constructor. +genAllOpFields :: String -- ^ Function name + -> [Constructor] -- ^ Object definition + -> (Dec, Dec) +genAllOpFields sname opdefs = + let cclauses = map genOpConsFields opdefs + other = Clause [WildP] (NormalB (ListE [])) [] + fname = mkName sname + sigt = AppT (AppT ArrowT (ConT ''String)) (AppT ListT (ConT ''String)) + in (SigD fname sigt, FunD fname (cclauses++[other])) -- | Generates the \"save\" clause for an entire opcode constructor. -- @@ -489,19 +583,36 @@ saveConstructor sname fields = do JSON.showJSON $(stringE . deCamelCase $ sname) )] |] flist = listE (opid:felems) -- and finally convert all this to a json object - flist' = [| $(varNameE "makeObj") (concat $flist) |] + flist' = [| concat $flist |] clause [pat] (normalB flist') [] -- | Generates the main save opcode function. -- -- This builds a per-constructor match clause that contains the -- respective constructor-serialisation code. -genSaveOpCode :: [(String, [Field])] -> Q (Dec, Dec) -genSaveOpCode opdefs = do - cclauses <- mapM (uncurry saveConstructor) opdefs - let fname = mkName "saveOpCode" - sigt <- [t| $(conT (mkName "OpCode")) -> JSON.JSValue |] - return $ (SigD fname sigt, FunD fname cclauses) +genSaveOpCode :: Name -- ^ Object ype + -> String -- ^ To 'JSValue' function name + -> String -- ^ To 'JSObject' function name + -> [Constructor] -- ^ Object definition + -> (Constructor -> Q Clause) -- ^ Constructor save fn + -> Bool -- ^ Whether to generate + -- obj or just a + -- list\/tuple of values + -> Q [Dec] +genSaveOpCode tname jvalstr tdstr opdefs fn gen_object = do + tdclauses <- mapM fn opdefs + let typecon = ConT tname + jvalname = mkName jvalstr + jvalsig = AppT (AppT ArrowT typecon) (ConT ''JSON.JSValue) + tdname = mkName tdstr + tdsig <- [t| $(return typecon) -> [(String, JSON.JSValue)] |] + jvalclause <- if gen_object + then [| $makeObjE . $(varE tdname) |] + else [| JSON.showJSON . map snd . $(varE tdname) |] + return [ SigD tdname tdsig + , FunD tdname tdclauses + , SigD jvalname jvalsig + , ValD (VarP jvalname) (NormalB jvalclause) []] -- | Generates load code for a single constructor of the opcode data type. loadConstructor :: String -> [Field] -> Q Exp @@ -514,7 +625,7 @@ loadConstructor sname fields = do return $ DoE fstmts' -- | Generates the loadOpCode function. -genLoadOpCode :: [(String, [Field])] -> Q (Dec, Dec) +genLoadOpCode :: [Constructor] -> Q (Dec, Dec) genLoadOpCode opdefs = do let fname = mkName "loadOpCode" arg1 = mkName "v" @@ -522,8 +633,7 @@ genLoadOpCode opdefs = do opid = mkName "op_id" st1 <- bindS (varP objname) [| liftM JSON.fromJSObject (JSON.readJSON $(varE arg1)) |] - st2 <- bindS (varP opid) [| $(varNameE "fromObj") - $(varE objname) $(stringE "OP_ID") |] + st2 <- bindS (varP opid) [| $fromObjE $(varE objname) $(stringE "OP_ID") |] -- the match results (per-constructor blocks) mexps <- mapM (uncurry loadConstructor) opdefs fails <- [| fail $ "Unknown opcode " ++ $(varE opid) |] @@ -547,9 +657,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,45 +670,32 @@ type LuxiParam = (String, Q Type) -- -- * type -- -genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec] +genLuxiOp :: String -> [Constructor] -> Q [Dec] genLuxiOp name cons = do + let tname = mkName name decl_d <- mapM (\(cname, fields) -> do - fields' <- mapM (\(_, qt) -> - qt >>= \t -> return (NotStrict, t)) - fields - return $ NormalC (mkName cname) fields') + -- we only need the type of the field, without Q + fields' <- mapM actualFieldType fields + let fields'' = zip (repeat NotStrict) fields' + return $ NormalC (mkName cname) fields'') cons - let declD = DataD [] (mkName name) [] decl_d [''Show, ''Read, ''Eq] - (savesig, savefn) <- genSaveLuxiOp cons + let declD = DataD [] (mkName name) [] decl_d [''Show, ''Eq] + save_decs <- genSaveOpCode tname "opToArgs" "opToDict" + cons saveLuxiConstructor False 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 fvar (_, qt) = - [| JSON.showJSON $(varE fvar) |] + return $ declD:save_decs ++ req_defs -- | Generates the \"save\" clause for entire LuxiOp constructor. -saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause +saveLuxiConstructor :: Constructor -> Q Clause saveLuxiConstructor (sname, fields) = do let cname = mkName sname - fnames = map (mkName . fst) fields - pat = conP cname (map varP fnames) - flist = map (uncurry saveLuxiField) (zip fnames fields) - finval = if null flist - then [| JSON.showJSON () |] - 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) + fnames <- mapM (newName . fieldVariable) fields + let pat = conP cname (map varP fnames) + let felems = map (uncurry saveObjectField) (zip fnames fields) + flist = [| concat $(listE felems) |] + clause [pat] (normalB flist) [] -- * "Objects" functionality @@ -618,7 +712,7 @@ buildObject sname field_pfx fields = do let name = mkName sname fields_d <- mapM (fieldTypeInfo field_pfx) fields let decl_d = RecC name fields_d - let declD = DataD [] name [] [decl_d] [''Show, ''Read, ''Eq] + let declD = DataD [] name [] [decl_d] [''Show, ''Eq] ser_decls <- buildObjectSerialisation sname fields return $ declD:ser_decls @@ -654,7 +748,7 @@ genSaveObject save_fn sname fields = do tdlist = [| concat $flist |] iname = mkName "i" tclause <- clause [pat] (normalB tdlist) [] - cclause <- [| $(varNameE "makeObj") . $(varE tdname) |] + cclause <- [| $makeObjE . $(varE tdname) |] let fname = mkName ("save" ++ sname) sigt <- [t| $(conT name) -> JSON.JSValue |] return [SigD tdname tdsigt, FunD tdname [tclause], @@ -663,25 +757,33 @@ genSaveObject save_fn sname fields = do -- | Generates the code for saving an object's field, handling the -- various types of fields that we have. saveObjectField :: Name -> Field -> Q Exp -saveObjectField fvar field - | fisOptional = [| case $(varE fvar) of - Nothing -> [] - Just v -> [( $nameE, JSON.showJSON v)] - |] - | otherwise = case fieldShow field of - Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |] - Just fn -> [| let (actual, extra) = $fn $fvarE - in extra ++ [( $nameE, JSON.showJSON actual)] - |] - where fisOptional = fieldIsOptional field - nameE = stringE (fieldName field) +saveObjectField fvar field = + case fieldIsOptional field of + OptionalOmitNull -> [| case $(varE fvar) of + Nothing -> [] + Just v -> [( $nameE, JSON.showJSON v )] + |] + OptionalSerializeNull -> [| case $(varE fvar) of + Nothing -> [( $nameE, JSON.JSNull )] + Just v -> [( $nameE, JSON.showJSON v )] + |] + NotOptional -> + case fieldShow field of + -- Note: the order of actual:extra is important, since for + -- some serialisation types (e.g. Luxi), we use tuples + -- (positional info) rather than object (name info) + Nothing -> [| [( $nameE, JSON.showJSON $fvarE)] |] + Just fn -> [| let (actual, extra) = $fn $fvarE + in ($nameE, JSON.showJSON actual):extra + |] + where nameE = stringE (fieldName field) fvarE = varE fvar -- | Generates the showJSON clause for a given object name. objectShowJSON :: String -> Q Dec objectShowJSON name = do body <- [| JSON.showJSON . $(varE . mkName $ "save" ++ name) |] - return $ FunD (mkName "showJSON") [Clause [] (NormalB body) []] + return $ FunD 'JSON.showJSON [Clause [] (NormalB body) []] -- | Generates the load object functionality. genLoadObject :: (Field -> Q (Name, Stmt)) @@ -711,13 +813,16 @@ loadObjectField field = do let objvar = varNameE "o" objfield = stringE (fieldName field) loadexp = - if fieldIsOptional field - then [| $(varNameE "maybeFromObj") $objvar $objfield |] + if fieldIsOptional field /= NotOptional + -- we treat both optional types the same, since + -- 'maybeFromObj' can deal with both missing and null values + -- appropriately (the same) + then [| $(varE 'maybeFromObj) $objvar $objfield |] else case fieldDefault field of Just defv -> - [| $(varNameE "fromObjWithDefault") $objvar + [| $(varE 'fromObjWithDefault) $objvar $objfield $defv |] - Nothing -> [| $(varNameE "fromObj") $objvar $objfield |] + Nothing -> [| $fromObjE $objvar $objfield |] bexp <- loadFn field loadexp objvar return (fvar, BindS (VarP fvar) bexp) @@ -732,7 +837,7 @@ objectReadJSON name = do JSON.Error $ "Can't parse value for type " ++ $(stringE name) ++ ": " ++ e |] - return $ FunD (mkName "readJSON") [Clause [VarP s] (NormalB body) []] + return $ FunD 'JSON.readJSON [Clause [VarP s] (NormalB body) []] -- * Inheritable parameter tables implementation @@ -765,8 +870,8 @@ buildParam sname field_pfx fields = do fields_p <- mapM (paramFieldTypeInfo field_pfx) fields let decl_f = RecC name_f fields_f decl_p = RecC name_p fields_p - let declF = DataD [] name_f [] [decl_f] [''Show, ''Read, ''Eq] - declP = DataD [] name_p [] [decl_p] [''Show, ''Read, ''Eq] + let declF = DataD [] name_f [] [decl_f] [''Show, ''Eq] + declP = DataD [] name_p [] [decl_p] [''Show, ''Eq] ser_decls_f <- buildObjectSerialisation sname_f fields ser_decls_p <- buildPParamSerialisation sname_p fields fill_decls <- fillParam sname field_pfx fields @@ -823,7 +928,7 @@ loadPParamField field = do -- these are used in all patterns below let objvar = varNameE "o" objfield = stringE name - loadexp = [| $(varNameE "maybeFromObj") $objvar $objfield |] + loadexp = [| $(varE 'maybeFromObj) $objvar $objfield |] bexp <- loadFn field loadexp objvar return (fvar, BindS (VarP fvar) bexp) @@ -831,7 +936,7 @@ loadPParamField field = do buildFromMaybe :: String -> Q Dec buildFromMaybe fname = valD (varP (mkName $ "n_" ++ fname)) - (normalB [| $(varNameE "fromMaybe") + (normalB [| $(varE 'fromMaybe) $(varNameE $ "f_" ++ fname) $(varNameE $ "p_" ++ fname) |]) [] @@ -859,3 +964,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])