Template Haskell support for equality constraints

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

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index f025ac2..0bdcbbd 100644 (file)
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -565,7 +565,7 @@ kcTopSpliceType expr
        ; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
        ; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
 
-       ; kcHsType hs_ty3 }
+       ; kcLHsType hs_ty3 }
 \end{code}
 
 %************************************************************************
@@ -825,11 +825,7 @@ lookupThName_maybe th_name
             ; rdr_env <- getLocalRdrEnv
             ; case lookupLocalRdrEnv rdr_env rdr_name of
                 Just name -> return (Just name)
-                Nothing | not (isSrcRdrName rdr_name)  -- Exact, Orig
-                        -> do { name <- lookupImportedName rdr_name
-                              ; return (Just name) }
-                        | otherwise                    -- Unqual, Qual
-                        -> lookupSrcOcc_maybe rdr_name }
+                Nothing   -> lookupGlobalOccRn_maybe rdr_name }
 
 tcLookupTh :: Name -> TcM TcTyThing
 -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that
@@ -876,7 +872,7 @@ reifyThing (AGlobal (AnId id))
   = do { ty <- reifyType (idType id)
        ; fix <- reifyFixity (idName id)
        ; let v = reifyName id
-       ; case globalIdDetails id of
+       ; case idDetails id of
            ClassOpId cls    -> return (TH.ClassOpI v ty (reifyName cls) fix)
            _                -> return (TH.VarI     v ty Nothing fix)
     }
@@ -922,7 +918,7 @@ reifyTyCon tc
              r_tvs  = reifyTyVars tvs
              deriv = []        -- Don't know about deriving
              decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
-                  | otherwise     = TH.DataD    cxt name r_tvs cons      deriv
+                  | otherwise     = TH.DataD    cxt name r_tvs cons        deriv
        ; return (TH.TyConI decl) }
 
 reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
@@ -974,7 +970,8 @@ reifyType (PredTy {}) = panic "reifyType PredTy"
 
 reifyTypes :: [Type] -> TcM [TH.Type]
 reifyTypes = mapM reifyType
-reifyCxt :: [PredType] -> TcM [TH.Type]
+
+reifyCxt :: [PredType] -> TcM [TH.Pred]
 reifyCxt   = mapM reifyPred
 
 reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
@@ -987,10 +984,17 @@ reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
 reify_tc_app tc tys = do { tys' <- reifyTypes tys 
                         ; return (foldl TH.AppT (TH.ConT tc) tys') }
 
-reifyPred :: TypeRep.PredType -> TcM TH.Type
-reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
+reifyPred :: TypeRep.PredType -> TcM TH.Pred
+reifyPred (ClassP cls tys) 
+  = do { tys' <- reifyTypes tys 
+       ; return $ TH.ClassP (reifyName cls) tys'
+       }
 reifyPred p@(IParam _ _)   = noTH (sLit "implicit parameters") (ppr p)
-reifyPred (EqPred {})      = panic "reifyPred EqPred"
+reifyPred (EqPred ty1 ty2) 
+  = do { ty1' <- reifyType ty1
+       ; ty2' <- reifyType ty2
+       ; return $ TH.EqualP ty1' ty2'
+       }
 
 
 ------------------------------