We'll need this in another place shortly, so let's abstract it and add proper verification of whether we were passed a type name correctly; the previous version would have failed with a pattern match failure, instead of an explicit message.
Signed-off-by: Iustin Pop <[email protected]> --- htools/Ganeti/THH.hs | 12 ++++++++++-- 1 files changed, 10 insertions(+), 2 deletions(-) diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 76e3281..0480bb0 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -368,6 +368,15 @@ constructorName (NormalC name _) = return name constructorName (RecC name _) = return name constructorName x = fail $ "Unhandled constructor " ++ show x +-- | Extract all constructor names from a given type. +reifyConsNames :: Name -> Q [String] +reifyConsNames name = do + reify_result <- reify name + case reify_result of + TyConI (DataD _ _ _ cons _) -> mapM (liftM nameBase . constructorName) cons + o -> fail $ "Unhandled name passed to reifyConsNames, expected\ + \ type constructor but got '" ++ show o ++ "'" + -- | Builds the generic constructor-to-string function. -- -- This generates a simple function of the following form: @@ -381,8 +390,7 @@ constructorName x = fail $ "Unhandled constructor " ++ show x -- 'genToRaw' to actually generate the function genConstrToStr :: (String -> String) -> Name -> String -> Q [Dec] genConstrToStr trans_fun name fname = do - TyConI (DataD _ _ _ cons _) <- reify name - cnames <- mapM (liftM nameBase . constructorName) cons + cnames <- reifyConsNames name let svalues = map (Left . trans_fun) cnames genToRaw ''String (mkName fname) name $ zip cnames svalues -- 1.7.7.3
