From 94518cdb973cc82d62ef38f970b6498b131b8536 Mon Sep 17 00:00:00 2001 From: Iustin Pop <iustin@google.com> Date: Sun, 19 Aug 2012 15:20:48 +0200 Subject: [PATCH] TH: Abstract function for computing constructor names 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 <iustin@google.com> Reviewed-by: Agata Murawska <agatamurawska@google.com> --- htools/Ganeti/THH.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/htools/Ganeti/THH.hs b/htools/Ganeti/THH.hs index 2704b1bb0..9fdf8cad8 100644 --- a/htools/Ganeti/THH.hs +++ b/htools/Ganeti/THH.hs @@ -369,6 +369,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: @@ -382,8 +391,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 -- GitLab