X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcPat.lhs;h=097402fc2753cedd29d13df57bf3244a127e5c2b;hb=74b27e20425336403d80e942ee3faf00f8c36ef8;hp=5fda4f4bf82e7ad985ebb08b16331cb11c3e14d3;hpb=4e5faff9152918cd00dcdad9068b0f1eba1fcd68;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcPat.lhs b/compiler/typecheck/TcPat.lhs
index 5fda4f4..097402f 100644
--- a/compiler/typecheck/TcPat.lhs
+++ b/compiler/typecheck/TcPat.lhs
@@ -34,6 +34,7 @@ import Type
 import StaticFlags
 import TyCon
 import DataCon
+import DynFlags
 import PrelNames
 import BasicTypes hiding (SuccessFlag(..))
 import SrcLoc
@@ -228,7 +229,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.
@@ -470,7 +471,7 @@ tc_pat pstate pat@(NPlusKPat (L nm_loc name) lit ge minus) pat_ty thing_inside
 	; res <- tcExtendIdEnv1 name bndr_id (thing_inside pstate)
 	; returnM (NPlusKPat (L nm_loc bndr_id) lit' ge' minus', [], res) }
 
-tc_pat _ _other_pat _ _ = panic "tc_pat" 	-- DictPat, ConPatOut, SigPatOut, VarPatOut
+tc_pat _ _other_pat _ _ = panic "tc_pat" 	-- ConPatOut, SigPatOut, VarPatOut
 \end{code}
 
 
@@ -546,7 +547,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
 
@@ -583,9 +584,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
@@ -730,8 +730,11 @@ refineAlt con pstate ex_tvs [] pat_ty
   = return pstate	-- Common case: no equational constraints
 
 refineAlt con pstate ex_tvs co_vars pat_ty
-  | not (isRigidTy pat_ty)
-  = failWithTc (nonRigidMatch con)
+  = do	{ opt_gadt <- doptM Opt_GADTs	-- No type-refinement unless GADTs are on
+	; if (not opt_gadt) then return pstate
+	  else do 
+
+	{ checkTc (isRigidTy pat_ty) (nonRigidMatch con)
 	-- We are matching against a GADT constructor with non-trivial
 	-- constraints, but pattern type is wobbly.  For now we fail.
 	-- We can make sense of this, however:
@@ -746,8 +749,8 @@ refineAlt con pstate ex_tvs co_vars pat_ty
 	-- then unify these constraints to make pat_ty the right shape;
 	-- then proceed exactly as in the rigid case
 
-  | otherwise	-- In the rigid case, we perform type refinement
-  = case gadtRefine (pat_reft pstate) ex_tvs co_vars of {
+		-- In the rigid case, we perform type refinement
+	; case gadtRefine (pat_reft pstate) ex_tvs co_vars of {
 	    Failed msg     -> failWithTc (inaccessibleAlt msg) ;
 	    Succeeded reft -> do { traceTc trace_msg
 			  	 ; return (pstate { pat_reft = reft }) }
@@ -759,7 +762,7 @@ refineAlt con pstate ex_tvs co_vars pat_ty
 				vcat [ ppr con <+> ppr ex_tvs,
 				       ppr [(v, tyVarKind v) | v <- co_vars],
 				       ppr reft]
-	}
+	} } }
 \end{code}
 
 
@@ -813,6 +816,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
@@ -924,7 +940,7 @@ sigPatCtxt pats bound_tvs pat_tys body_ty tidy_env
   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
@@ -943,7 +959,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