Revision 94518cdb
| b/htools/Ganeti/THH.hs | ||
|---|---|---|
| 369 | 369 |
constructorName (RecC name _) = return name |
| 370 | 370 |
constructorName x = fail $ "Unhandled constructor " ++ show x |
| 371 | 371 |
|
| 372 |
-- | Extract all constructor names from a given type. |
|
| 373 |
reifyConsNames :: Name -> Q [String] |
|
| 374 |
reifyConsNames name = do |
|
| 375 |
reify_result <- reify name |
|
| 376 |
case reify_result of |
|
| 377 |
TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons |
|
| 378 |
o -> fail $ "Unhandled name passed to reifyConsNames, expected\ |
|
| 379 |
\ type constructor but got '" ++ show o ++ "'" |
|
| 380 |
|
|
| 372 | 381 |
-- | Builds the generic constructor-to-string function. |
| 373 | 382 |
-- |
| 374 | 383 |
-- This generates a simple function of the following form: |
| ... | ... | |
| 382 | 391 |
-- 'genToRaw' to actually generate the function |
| 383 | 392 |
genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec] |
| 384 | 393 |
genConstrToStr trans_fun name fname = do |
| 385 |
TyConI (DataD _ _ _ cons _) <- reify name |
|
| 386 |
cnames <- mapM (liftM nameBase . constructorName) cons |
|
| 394 |
cnames <- reifyConsNames name |
|
| 387 | 395 |
let svalues = map (Left . trans_fun) cnames |
| 388 | 396 |
genToRaw ''String (mkName fname) name $ zip cnames svalues |
| 389 | 397 |
|
Also available in: Unified diff