X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=5384e4afbc095da6bfcd4603ff16671ca68768d8;hb=ab241c5d6187a93acffc609bdbffdae30ff9b284;hp=f9452924e863ca08796d45aa586c7d7715ea37f5;hpb=36d207aa8c9cedbf58e739178971292048bd41d0;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index f945292..5384e4a 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -228,7 +228,7 @@ unBoxArgType ty pp_this
 
 Note [Nesting]
 ~~~~~~~~~~~~~~
-tcPat takes a "thing inside" over which the patter scopes.  This is partly
+tcPat takes a "thing inside" over which the pattern scopes.  This is partly
 so that tcPat can extend the environment for the thing_inside, but also 
 so that constraints arising in the thing_inside can be discharged by the
 pattern.
@@ -546,7 +546,7 @@ tcConPat :: PatState -> SrcSpan -> DataCon -> TyCon
 	 -> HsConDetails Name (LPat Name) -> (PatState -> TcM a)
 	 -> TcM (Pat TcId, [TcTyVar], a)
 tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
-  = do	{ let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys) = dataConFullSig data_con
+  = do	{ let (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 	      skol_info = PatSkol data_con
 	      origin    = SigOrigin skol_info
 
@@ -555,7 +555,7 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 	; ex_tvs' <- tcInstSkolTyVars skol_info ex_tvs	-- Get location from monad,
 							-- not from ex_tvs
 	; let tenv     = zipTopTvSubst (univ_tvs ++ ex_tvs)
-				      (ctxt_res_tys ++ mkTyVarTys ex_tvs')
+				       (ctxt_res_tys ++ mkTyVarTys ex_tvs')
 	      eq_spec' = substEqSpec tenv eq_spec
 	      theta'   = substTheta  tenv theta
 	      arg_tys' = substTys    tenv arg_tys
@@ -583,9 +583,8 @@ tcConPat pstate con_span data_con tycon pat_ty arg_pats thing_inside
 	     ex_tvs' ++ inner_tvs, res)
 	}
   where
-    -- Split against the family tycon if the pattern constructor belongs to a
-    -- representation tycon.
-    --
+    -- Split against the family tycon if the pattern constructor 
+    -- belongs to a family instance tycon.
     boxySplitTyConAppWithFamily tycon pat_ty =
       traceTc traceMsg >>
       case tyConFamInst_maybe tycon of
@@ -813,6 +812,19 @@ tcOverloadedLit orig lit@(HsFractional r fr) res_ty
   = do 	{ expr <- newLitInst orig lit res_ty
 	; return (HsFractional r expr) }
 
+tcOverloadedLit orig lit@(HsIsString s fr) res_ty
+  | not (fr `isHsVar` fromStringName)	-- c.f. HsIntegral case
+  = do	{ str_ty <- tcMetaTy stringTyConName
+	; fr' <- tcSyntaxOp orig fr (mkFunTy str_ty res_ty)
+	; return (HsIsString s (HsApp (noLoc fr') (nlHsLit (HsString s)))) }
+
+  | Just expr <- shortCutStringLit s res_ty 
+  = return (HsIsString s expr)
+
+  | otherwise
+  = do 	{ expr <- newLitInst orig lit res_ty
+	; return (HsIsString s expr) }
+
 newLitInst :: InstOrigin -> HsOverLit Name -> BoxyRhoType -> TcM (HsExpr TcId)
 newLitInst orig lit res_ty	-- Make a LitInst
   = do 	{ loc <- getInstLoc orig
@@ -919,13 +931,12 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
 		 sep [ptext SLIT("When checking an existential match that binds"),
 		      nest 4 (vcat (zipWith ppr_id show_ids tidy_tys)),
 		      ptext SLIT("The pattern(s) have type(s):") <+> vcat (map ppr tidy_pat_tys),
-		      ptext SLIT("The body has type:") <+> ppr tidy_body_ty,
-		      ppr pats
+		      ptext SLIT("The body has type:") <+> ppr tidy_body_ty
 		]) }
   where
     bound_ids = collectPatsBinders pats
     show_ids = filter is_interesting bound_ids
-    is_interesting id = any (`elemVarSet` idFreeTyVars id) bound_tvs
+    is_interesting id = any (`elemVarSet` varTypeTyVars id) bound_tvs
 
     ppr_id id ty = ppr id <+> dcolon <+> ppr ty
 	-- Don't zonk the types so we get the separate, un-unified versions
@@ -944,7 +955,7 @@ badTypePat pat = ptext SLIT("Illegal type pattern") <+> ppr pat
 
 lazyPatErr pat tvs
   = failWithTc $
-    hang (ptext SLIT("A lazy (~) pattern connot bind existential type variables"))
+    hang (ptext SLIT("A lazy (~) pattern cannot bind existential type variables"))
        2 (vcat (map pprSkolTvBinding tvs))
 
 nonRigidMatch con