[project @ 2002-03-08 15:50:53 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs
index 0c40272..9f7dbc0 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -24,11 +24,12 @@ import Name         ( Name )
 import FieldLabel      ( fieldLabelName )
 import TcEnv           ( tcLookupClass, tcLookupDataCon, tcLookupGlobalId, tcLookupId )
 import TcMType                 ( tcInstTyVars, newTyVarTy, getTcTyVar, putTcTyVar )
-import TcType          ( TcType, TcTyVar, TcSigmaType,
+import TcType          ( TcType, TcTyVar, TcSigmaType, TyVarDetails(VanillaTv),
                          mkTyConApp, mkClassPred, liftedTypeKind, tcGetTyVar_maybe,
                          isHoleTyVar, openTypeKind )
-import TcUnify         ( tcSub, unifyTauTy, unifyListTy, unifyTupleTy, 
-                         mkCoercion, idCoercion, isIdCoercion, (<$>), PatCoFn )
+import TcUnify         ( tcSub, unifyTauTy, unifyListTy, unifyPArrTy,
+                         unifyTupleTy,  mkCoercion, idCoercion, isIdCoercion,
+                         (<$>), PatCoFn )
 import TcMonoType      ( tcHsSigType, UserTypeCtxt(..) )
 
 import TysWiredIn      ( stringTy )
@@ -149,8 +150,9 @@ tcPat tc_bndr WildPatIn pat_ty
 tcPat tc_bndr (ParPatIn parend_pat) pat_ty
   = tcPat tc_bndr parend_pat pat_ty
 
-tcPat tc_bndr (SigPatIn pat sig) pat_ty
-  = tcHsSigType PatSigCtxt sig         `thenTc` \ sig_ty ->
+tcPat tc_bndr pat_in@(SigPatIn pat sig) pat_ty
+  = tcAddErrCtxt (patCtxt pat_in)      $
+    tcHsSigType PatSigCtxt sig         `thenTc` \ sig_ty ->
     tcSubPat sig_ty pat_ty             `thenTc` \ (co_fn, lie_sig) ->
     tcPat tc_bndr pat sig_ty           `thenTc` \ (pat', lie_req, tvs, ids, lie_avail) ->
     returnTc (co_fn <$> pat', lie_req `plusLIE` lie_sig, tvs, ids, lie_avail)
@@ -159,7 +161,7 @@ tcPat tc_bndr (SigPatIn pat sig) pat_ty
 
 %************************************************************************
 %*                                                                     *
-\subsection{Explicit lists and tuples}
+\subsection{Explicit lists, parallel arrays, and tuples}
 %*                                                                     *
 %************************************************************************
 
@@ -170,6 +172,12 @@ tcPat tc_bndr pat_in@(ListPatIn pats) pat_ty
     tcPats tc_bndr pats (repeat elem_ty)       `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
     returnTc (ListPat elem_ty pats', lie_req, tvs, ids, lie_avail)
 
+tcPat tc_bndr pat_in@(PArrPatIn pats) pat_ty
+  = tcAddErrCtxt (patCtxt pat_in)              $
+    unifyPArrTy pat_ty                         `thenTc` \ elem_ty ->
+    tcPats tc_bndr pats (repeat elem_ty)       `thenTc` \ (pats', lie_req, tvs, ids, lie_avail) ->
+    returnTc (PArrPat elem_ty pats', lie_req, tvs, ids, lie_avail)
+
 tcPat tc_bndr pat_in@(TuplePatIn pats boxity) pat_ty
   = tcAddErrCtxt (patCtxt pat_in)      $
 
@@ -385,7 +393,7 @@ tcConstructor pat con_name
             -- behave differently when called, not when used for
             -- matching.
     in
-    tcInstTyVars (ex_tvs ++ tvs)       `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
+    tcInstTyVars VanillaTv (ex_tvs ++ tvs)     `thenNF_Tc` \ (all_tvs', ty_args', tenv) ->
     let
        ex_theta' = substTheta tenv ex_theta
        arg_tys'  = map (substTy tenv) arg_tys
@@ -456,7 +464,7 @@ tcSubPat does the work
 tcSubPat :: TcSigmaType -> TcSigmaType -> TcM (PatCoFn, LIE)
 
 tcSubPat sig_ty exp_ty
- = tcSub exp_ty sig_ty                 `thenTc` \ (co_fn, lie) ->
+ = tcSub sig_ty exp_ty                 `thenTc` \ (co_fn, lie) ->
        -- co_fn is a coercion on *expressions*, and we
        -- need to make a coercion on *patterns*
    if isIdCoercion co_fn then
@@ -465,7 +473,7 @@ tcSubPat sig_ty exp_ty
    else
    tcGetUnique                         `thenNF_Tc` \ uniq ->
    let
-       arg_id  = mkSysLocal SLIT("sub") uniq exp_ty
+       arg_id  = mkSysLocal FSLIT("sub") uniq exp_ty
        the_fn  = DictLam [arg_id] (co_fn <$> HsVar arg_id)
        pat_co_fn p = SigPat p exp_ty the_fn
    in
@@ -480,7 +488,7 @@ tcSubPat sig_ty exp_ty
 %************************************************************************
 
 \begin{code}
-patCtxt pat = hang (ptext SLIT("In the pattern:")) 
+patCtxt pat = hang (ptext SLIT("When checking the pattern:")) 
                 4 (ppr pat)
 
 badFieldCon :: Name -> Name -> SDoc