Revision 94518cdb htools/Ganeti/THH.hs
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