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 <[email protected]> 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} _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
