| 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
|