Better error message for Template Haskell pattern brackets

[ghc-hetmet.git] / ghc / compiler / typecheck / TcSplice.lhs

diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index 500e194..34e0394 100644 (file)
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -41,7 +41,7 @@ import NameEnv                ( lookupNameEnv )
 import HscTypes                ( lookupType, ExternalPackageState(..), emptyModDetails )
 import OccName
 import Var             ( Id, TyVar, idType )
-import Module          ( moduleUserString )
+import Module          ( moduleString )
 import TcRnMonad
 import IfaceEnv                ( lookupOrig )
 import Class           ( Class, classExtraBigSig )
@@ -149,6 +149,9 @@ tc_bracket (DecBr decls)
        ; return (mkAppTy q_ty (mkListTy decl_ty))
        -- Result type is Q [Dec]
     }
+
+tc_bracket (PatBr _)
+  = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet"))
 \end{code}
 
 
@@ -416,7 +419,7 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where
   qReport True msg  = addErr (text msg)
   qReport False msg = addReport (text msg)
 
-  qCurrentModule = do { m <- getModule; return (moduleUserString m) }
+  qCurrentModule = do { m <- getModule; return (moduleString m) }
   qReify v = reify v
   qRecover = recoverM
 
@@ -472,8 +475,8 @@ reify th_name
     ppr_ns (TH.Name _ (TH.NameG TH.VarName mod)) = text "var"
 
 lookupThName :: TH.Name -> TcM Name
-lookupThName th_name
-  =  do { let rdr_name = thRdrName guessed_ns th_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
@@ -491,9 +494,9 @@ lookupThName th_name
        }
   where
        -- guessed_ns is the name space guessed from looking at the TH name
-    guessed_ns | isLexCon occ_fs = OccName.dataName
-              | otherwise       = OccName.varName
-    occ_fs = mkFastString (TH.nameBase 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
@@ -659,8 +662,8 @@ reifyName thing
        -- have free variables, we may need to generate NameL's for them.
   where
     name    = getName thing
-    mod     = moduleUserString (nameModule name)
-    occ_str = occNameUserString occ
+    mod     = moduleString (nameModule name)
+    occ_str = occNameString occ
     occ     = nameOccName name
     mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
            | OccName.isVarOcc  occ = TH.mkNameG_v