Revision 6111e296 htools/Ganeti/THH.hs
b/htools/Ganeti/THH.hs | ||
---|---|---|
31 | 31 |
|
32 | 32 |
module Ganeti.THH ( declareSADT |
33 | 33 |
, makeJSONInstance |
34 |
, genOpID |
|
34 | 35 |
) where |
35 | 36 |
|
37 |
import Control.Monad (liftM) |
|
36 | 38 |
import Data.Char |
39 |
import Data.List |
|
37 | 40 |
import Language.Haskell.TH |
38 | 41 |
|
39 | 42 |
import qualified Text.JSON as JSON |
... | ... | |
54 | 57 |
fromStrName :: String -> Name |
55 | 58 |
fromStrName = mkName . (++ "FromString") . ensureLower |
56 | 59 |
|
60 |
-- | Converts a name to it's varE/litE representations. |
|
61 |
-- |
|
62 |
reprE :: Either String Name -> Q Exp |
|
63 |
reprE (Left name) = litE (StringL name) |
|
64 |
reprE (Right name) = varE name |
|
65 |
|
|
57 | 66 |
-- | Generates a data type declaration. |
58 | 67 |
-- |
59 | 68 |
-- The type will have a fixed list of instances. |
... | ... | |
72 | 81 |
-- nameToString Cons1 = var1 |
73 | 82 |
-- nameToString Cons2 = \"value2\" |
74 | 83 |
-- @ |
75 |
genToString :: Name -> Name -> [(String, Name)] -> Q [Dec] |
|
84 |
genToString :: Name -> Name -> [(String, Either String Name)] -> Q [Dec]
|
|
76 | 85 |
genToString fname tname constructors = do |
77 | 86 |
sigt <- [t| $(conT tname) -> String |] |
78 | 87 |
-- the body clauses, matching on the constructor and returning the |
79 | 88 |
-- string value |
80 | 89 |
clauses <- mapM (\(c, v) -> clause [recP (mkName c) []] |
81 |
(normalB (varE v)) []) constructors
|
|
90 |
(normalB (reprE v)) []) constructors
|
|
82 | 91 |
return [SigD fname sigt, FunD fname clauses] |
83 | 92 |
|
84 | 93 |
-- | Generates a fromString function. |
... | ... | |
135 | 144 |
declareSADT sname cons = do |
136 | 145 |
let name = mkName sname |
137 | 146 |
ddecl = strADTDecl name (map fst cons) |
138 |
tostr <- genToString (toStrName sname) name cons |
|
147 |
-- process cons in the format expected by genToString |
|
148 |
cons' = map (\(a, b) -> (a, Right b)) cons |
|
149 |
tostr <- genToString (toStrName sname) name cons' |
|
139 | 150 |
fromstr <- genFromString (fromStrName sname) name cons |
140 | 151 |
return $ ddecl:tostr ++ fromstr |
141 | 152 |
|
... | ... | |
184 | 195 |
showJ <- genShowJSON base |
185 | 196 |
readJ <- genReadJSON base |
186 | 197 |
return [InstanceD [] (AppT (ConT ''JSON.JSON) (ConT name)) (readJ:showJ)] |
198 |
|
|
199 |
-- | Transforms a CamelCase string into an_underscore_based_one. |
|
200 |
deCamelCase :: String -> String |
|
201 |
deCamelCase = |
|
202 |
intercalate "_" . map (map toUpper) . groupBy (\_ b -> not $ isUpper b) |
|
203 |
|
|
204 |
-- | Computes the name of a given constructor |
|
205 |
constructorName :: Con -> Q Name |
|
206 |
constructorName (NormalC name _) = return name |
|
207 |
constructorName (RecC name _) = return name |
|
208 |
constructorName x = fail $ "Unhandled constructor " ++ show x |
|
209 |
|
|
210 |
-- | Builds the constructor-to-string function. |
|
211 |
-- |
|
212 |
-- This generates a simple function of the following form: |
|
213 |
-- |
|
214 |
-- @ |
|
215 |
-- fname (ConStructorOne {}) = "CON_STRUCTOR_ONE" |
|
216 |
-- fname (ConStructorTwo {}) = "CON_STRUCTOR_TWO" |
|
217 |
-- @ |
|
218 |
-- |
|
219 |
-- This builds a custom list of name/string pairs and then uses |
|
220 |
-- 'genToString' to actually generate the function |
|
221 |
genOpID :: Name -> String -> Q [Dec] |
|
222 |
genOpID name fname = do |
|
223 |
TyConI (DataD _ _ _ cons _) <- reify name |
|
224 |
cnames <- mapM (liftM nameBase . constructorName) cons |
|
225 |
let svalues = map (Left . deCamelCase) cnames |
|
226 |
genToString (mkName fname) name $ zip cnames svalues |
Also available in: Unified diff