[commit: ghc] type-holes-branch: Add a new separate MetaInfo for holes, HoleTv, so after typechecking it can be verified if a class constraint was on a hole. (006d203)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : type-holes-branch

http://hackage.haskell.org/trac/ghc/changeset/006d2030b08767c41a08303dcb31dc210bea6612

>---------------------------------------------------------------

commit 006d2030b08767c41a08303dcb31dc210bea6612
Author: Thijs Alkemade <thijsalkemade at gmail.com>
Date:   Sun Apr 22 15:58:19 2012 +0200

    Add a new separate MetaInfo for holes, HoleTv, so after typechecking it can be verified if a class constraint was on a hole.

>---------------------------------------------------------------

 compiler/typecheck/TcErrors.lhs |    5 +++++
 compiler/typecheck/TcExpr.lhs   |    3 ++-
 compiler/typecheck/TcMType.lhs  |    1 +
 compiler/typecheck/TcType.lhs   |    4 ++++
 compiler/typecheck/TcUnify.lhs  |    9 +++++++--
 5 files changed, 19 insertions(+), 3 deletions(-)

diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index 3d7e2d7..c2f517e 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -163,7 +163,12 @@ reportTidyWanteds ctxt insols flats implics
      }
        where isHole ct = case classifyPredType (ctPred ct) of
                             HolePred {} -> True
+                            ClassPred nm ty -> any isHoleTyVar ty
                             _           -> False
+             isHoleTyVar (TyVarTy tv) = case tcTyVarDetails tv of
+                  MetaTv HoleTv _ -> True
+                  _ -> False
+             isHoleTyVar _ = False
              
 
 deferToRuntime :: EvBindsVar -> ReportErrCtxt -> (ReportErrCtxt -> Ct -> TcM ErrMsg) 
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index fdbaf29..0df74e1 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -221,7 +221,8 @@ tcExpr (HsType ty) _
 tcExpr (HsHole name) res_ty
   = do { traceTc "tcExpr.HsHole" (ppr $ res_ty)
        ; let origin = OccurrenceOf name
-       ; ty <- newFlexiTyVarTy liftedTypeKind
+       ; tyvar <- newMetaTyVar HoleTv liftedTypeKind
+       ; let ty = TyVarTy tyvar
        
        -- Emit the constraint
        ; var <- emitWanted origin (mkHolePred name ty)
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index e50392b..7a2c35a 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -317,6 +317,7 @@ newMetaTyVar meta_info kind
                         TauTv -> fsLit "t"
                         TcsTv -> fsLit "u"
                         SigTv -> fsLit "a"
+                        HoleTv -> fsLit "h"
 	; return (mkTcTyVar name kind (MetaTv meta_info ref)) }
 
 mkTcTyVarName :: Unique -> FastString -> Name
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index e41d33c..a37a950 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -342,6 +342,7 @@ data MetaInfo
      		   -- Its particular property is that it is always "touchable"
 		   -- Nevertheless, the constraint solver has to try to guess
 		   -- what type to instantiate it to
+   | HoleTv
 
 -------------------------------------
 -- UserTypeCtxt describes the origin of the polymorphic type
@@ -351,6 +352,7 @@ instance Outputable MetaInfo where
   ppr TauTv = ptext (sLit "TauTv")
   ppr SigTv = ptext (sLit "SigTv")
   ppr TcsTv = ptext (sLit "TcsTv")
+  ppr HoleTv = ptext (sLit "HoleTv")
 
 data UserTypeCtxt
   = FunSigCtxt Name	-- Function type signature
@@ -426,6 +428,7 @@ pprTcTyVarDetails (FlatSkol {})    = ptext (sLit "fsk")
 pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau")
 pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs")
 pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig")
+pprTcTyVarDetails (MetaTv HoleTv _) = ptext (sLit "hole")
 
 pprUserTypeCtxt :: UserTypeCtxt -> SDoc
 pprUserTypeCtxt (InfSigCtxt n)    = ptext (sLit "the inferred type for") <+> quotes (ppr n)
@@ -741,6 +744,7 @@ isMetaTyVar tv
 isAmbiguousTyVar tv 
   = ASSERT2( isTcTyVar tv, ppr tv )
     case tcTyVarDetails tv of
+        MetaTv HoleTv _ -> False
 	MetaTv {}     -> True
 	RuntimeUnk {} -> True
 	_             -> False
diff --git a/compiler/typecheck/TcUnify.lhs b/compiler/typecheck/TcUnify.lhs
index d22fbda..cc1cf71 100644
--- a/compiler/typecheck/TcUnify.lhs
+++ b/compiler/typecheck/TcUnify.lhs
@@ -777,7 +777,8 @@ uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2)
 uUnfilledVar origin swapped tv1 details1 non_var_ty2  -- ty2 is not a type variable
   = case details1 of
       MetaTv TauTv ref1 
-        -> do { mb_ty2' <- checkTauTvUpdate tv1 non_var_ty2
+        -> do { traceTc "uUnfilledVar" empty
+              ; mb_ty2' <- checkTauTvUpdate tv1 non_var_ty2
               ; case mb_ty2' of
                   Nothing   -> do { traceTc "Occ/kind defer" (ppr tv1); defer }
                   Just ty2' -> updateMeta tv1 ref1 ty2'
@@ -809,6 +810,7 @@ uUnfilledVars origin swapped tv1 details1 tv2 details2
        ; let ctxt = mkKindErrorCtxt ty1 ty2 k1 k2
        ; sub_kind <- addErrCtxtM ctxt $ unifyKind k1 k2
 
+       ; traceTc "uUnfilledVars" ( text "details1:" <+> ppr details1 <+> text "details2:" <+> ppr details2)
        ; case (sub_kind, details1, details2) of
            -- k1 < k2, so update tv2
            (LT, _, MetaTv _ ref2) -> updateMeta tv2 ref2 ty1
@@ -832,6 +834,8 @@ uUnfilledVars origin swapped tv1 details1 tv2 details2
     ty1      = mkTyVarTy tv1
     ty2      = mkTyVarTy tv2
 
+    nicer_to_update_tv1 _     HoleTv = True
+    nicer_to_update_tv1 HoleTv _     = False
     nicer_to_update_tv1 _     SigTv = True
     nicer_to_update_tv1 SigTv _     = False
     nicer_to_update_tv1 _         _ = isSystemName (Var.varName tv1)
@@ -984,7 +988,8 @@ lookupTcTyVar tyvar
 
 updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM TcCoercion
 updateMeta tv1 ref1 ty2
-  = do { writeMetaTyVarRef tv1 ref1 ty2
+  = do { traceTc "updateMeta" (ppr tv1 <+> ppr ty2)
+       ; writeMetaTyVarRef tv1 ref1 ty2
        ; return (mkTcReflCo ty2) }
 \end{code}