Commit 2e202a9b authored by Iustin Pop's avatar Iustin Pop
Browse files

Abstract a few types in THH.hs



This 'simple' way of defining objects will be used also for errors, so
let's make it less Luxi-specific.
Signed-off-by: default avatarIustin Pop <iustin@google.com>
Reviewed-by: default avatarMichael Hanselmann <hansmi@google.com>
parent 9e995e4f
...@@ -180,6 +180,17 @@ tagsFields :: [Field] ...@@ -180,6 +180,17 @@ tagsFields :: [Field]
tagsFields = [ defaultField [| Set.empty |] $ tagsFields = [ defaultField [| Set.empty |] $
simpleField "tags" [t| TagSet |] ] 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 -- * Helper functions
-- | Ensure first letter is lowercase. -- | Ensure first letter is lowercase.
...@@ -547,9 +558,6 @@ genStrOfOp = genConstrToStr id ...@@ -547,9 +558,6 @@ genStrOfOp = genConstrToStr id
genStrOfKey :: Name -> String -> Q [Dec] genStrOfKey :: Name -> String -> Q [Dec]
genStrOfKey = genConstrToStr ensureLower genStrOfKey = genConstrToStr ensureLower
-- | LuxiOp parameter type.
type LuxiParam = (String, Q Type)
-- | Generates the LuxiOp data type. -- | Generates the LuxiOp data type.
-- --
-- This takes a Luxi operation definition and builds both the -- This takes a Luxi operation definition and builds both the
...@@ -563,7 +571,7 @@ type LuxiParam = (String, Q Type) ...@@ -563,7 +571,7 @@ type LuxiParam = (String, Q Type)
-- --
-- * type -- * type
-- --
genLuxiOp :: String -> [(String, [LuxiParam])] -> Q [Dec] genLuxiOp :: String -> SimpleObject -> Q [Dec]
genLuxiOp name cons = do genLuxiOp name cons = do
decl_d <- mapM (\(cname, fields) -> do decl_d <- mapM (\(cname, fields) -> do
fields' <- mapM (\(_, qt) -> fields' <- mapM (\(_, qt) ->
...@@ -579,12 +587,12 @@ genLuxiOp name cons = do ...@@ -579,12 +587,12 @@ genLuxiOp name cons = do
return $ [declD, savesig, savefn] ++ req_defs return $ [declD, savesig, savefn] ++ req_defs
-- | Generates the \"save\" expression for a single luxi parameter. -- | Generates the \"save\" expression for a single luxi parameter.
saveLuxiField :: Name -> LuxiParam -> Q Exp saveLuxiField :: Name -> SimpleField -> Q Exp
saveLuxiField fvar (_, qt) = saveLuxiField fvar (_, qt) =
[| JSON.showJSON $(varE fvar) |] [| JSON.showJSON $(varE fvar) |]
-- | Generates the \"save\" clause for entire LuxiOp constructor. -- | Generates the \"save\" clause for entire LuxiOp constructor.
saveLuxiConstructor :: (String, [LuxiParam]) -> Q Clause saveLuxiConstructor :: SimpleConstructor -> Q Clause
saveLuxiConstructor (sname, fields) = do saveLuxiConstructor (sname, fields) = do
let cname = mkName sname let cname = mkName sname
fnames = map (mkName . fst) fields fnames = map (mkName . fst) fields
...@@ -596,7 +604,7 @@ saveLuxiConstructor (sname, fields) = do ...@@ -596,7 +604,7 @@ saveLuxiConstructor (sname, fields) = do
clause [pat] (normalB finval) [] clause [pat] (normalB finval) []
-- | Generates the main save LuxiOp function. -- | Generates the main save LuxiOp function.
genSaveLuxiOp :: [(String, [LuxiParam])]-> Q (Dec, Dec) genSaveLuxiOp :: SimpleObject-> Q (Dec, Dec)
genSaveLuxiOp opdefs = do genSaveLuxiOp opdefs = do
sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |] sigt <- [t| $(conT (mkName "LuxiOp")) -> JSON.JSValue |]
let fname = mkName "opToArgs" let fname = mkName "opToArgs"
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment