+ ppr_ns (TH.Name _ (TH.NameG TH.DataName mod)) = text "data"
+ ppr_ns (TH.Name _ (TH.NameG TH.TcClsName mod)) = text "tc"
+ ppr_ns (TH.Name _ (TH.NameG TH.VarName mod)) = text "var"
+
+lookupThName :: TH.Name -> TcM Name
+lookupThName th_name@(TH.Name occ flavour)
+ = do { let rdr_name = thRdrName guessed_ns occ_str flavour
+
+ -- Repeat much of lookupOccRn, becase we want
+ -- to report errors in a TH-relevant way
+ ; rdr_env <- getLocalRdrEnv
+ ; case lookupLocalRdrEnv rdr_env rdr_name of
+ Just name -> return name
+ Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
+ -> lookupImportedName rdr_name
+ | otherwise -- Unqual, Qual
+ -> do {
+ mb_name <- lookupSrcOcc_maybe rdr_name
+ ; case mb_name of
+ Just name -> return name
+ Nothing -> failWithTc (notInScope th_name) }
+ }
+ where
+ -- guessed_ns is the name space guessed from looking at the TH name
+ guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName
+ | otherwise = OccName.varName
+ occ_str = TH.occString occ
+
+tcLookupTh :: Name -> TcM TcTyThing
+-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
+-- it gives a reify-related error message on failure, whereas in the normal
+-- tcLookup, failure is a bug.
+tcLookupTh name
+ = do { (gbl_env, lcl_env) <- getEnvs
+ ; case lookupNameEnv (tcl_env lcl_env) name of {
+ Just thing -> returnM thing;
+ Nothing -> do
+ { if nameIsLocalOrFrom (tcg_mod gbl_env) name
+ then -- It's defined in this module
+ case lookupNameEnv (tcg_type_env gbl_env) name of
+ Just thing -> return (AGlobal thing)
+ Nothing -> failWithTc (notInEnv name)
+
+ else do -- It's imported
+ { (eps,hpt) <- getEpsAndHpt
+ ; case lookupType hpt (eps_PTE eps) name of
+ Just thing -> return (AGlobal thing)
+ Nothing -> do { thing <- tcImportDecl name
+ ; return (AGlobal thing) }
+ -- Imported names should always be findable;
+ -- if not, we fail hard in tcImportDecl
+ }}}}
+
+notInScope :: TH.Name -> SDoc
+notInScope th_name = quotes (text (TH.pprint th_name)) <+>
+ ptext SLIT("is not in scope at a reify")
+ -- Ugh! Rather an indirect way to display the name
+
+notInEnv :: Name -> SDoc
+notInEnv name = quotes (ppr name) <+>
+ ptext SLIT("is not in the type environment at a reify")