[project @ 2002-02-14 14:01:40 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 7d5e823..0e57a0c 100644 (file)
--- a/ghc/compiler/typecheck/TcPat.lhs
+++ b/ghc/compiler/typecheck/TcPat.lhs
@@ -27,8 +27,9 @@ import TcMType                ( tcInstTyVars, newTyVarTy, getTcTyVar, putTcTyVar )
 import TcType          ( TcType, TcTyVar, TcSigmaType,
                          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 )
@@ -159,7 +160,7 @@ tcPat tc_bndr (SigPatIn pat sig) pat_ty
 
 %************************************************************************
 %*                                                                     *
-\subsection{Explicit lists and tuples}
+\subsection{Explicit lists, parallel arrays, and tuples}
 %*                                                                     *
 %************************************************************************
 
@@ -170,6 +171,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)      $
 
@@ -222,7 +229,10 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
   = tcAddErrCtxt (patCtxt pat) $
 
        -- Check the constructor itself
-    tcConstructor pat name pat_ty      `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys) ->
+    tcConstructor pat name             `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) ->
+
+       -- Check overall type matches (c.f. tcConPat)
+    tcSubPat con_res_ty pat_ty                 `thenTc` \ (co_fn, lie_req1) ->
     let
        -- Don't use zipEqual! If the constructor isn't really a record, then
        -- dataConFieldLabels will be empty (and each field in the pattern
@@ -232,10 +242,10 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty
     in
 
        -- Check the fields
-    tc_fields field_tys rpats          `thenTc` \ (rpats', lie_req, tvs, ids, lie_avail2) ->
+    tc_fields field_tys rpats          `thenTc` \ (rpats', lie_req2, tvs, ids, lie_avail2) ->
 
     returnTc (RecPat data_con pat_ty ex_tvs dicts rpats',
-             lie_req,
+             lie_req1 `plusLIE` lie_req2,
              listToBag ex_tvs `unionBags` tvs,
              ids,
              lie_avail1 `plusLIE` lie_avail2)
@@ -371,7 +381,7 @@ tcPats tc_bndr (ty:tys) (pat:pats)
 
 ------------------------------------------------------
 \begin{code}
-tcConstructor pat con_name pat_ty
+tcConstructor pat con_name
   =    -- Check that it's a constructor
     tcLookupDataCon con_name           `thenNF_Tc` \ data_con ->
 
@@ -393,10 +403,7 @@ tcConstructor pat con_name pat_ty
     in
     newDicts (PatOrigin pat) ex_theta' `thenNF_Tc` \ dicts ->
 
-       -- Check overall type matches
-    unifyTauTy pat_ty result_ty                `thenTc_`
-
-    returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys')
+    returnTc (data_con, ex_tvs', map instToId dicts, mkLIE dicts, arg_tys', result_ty)
 \end{code}           
 
 ------------------------------------------------------
@@ -405,7 +412,12 @@ tcConPat tc_bndr pat con_name arg_pats pat_ty
   = tcAddErrCtxt (patCtxt pat) $
 
        -- Check the constructor itself
-    tcConstructor pat con_name pat_ty  `thenTc` \ (data_con, ex_tvs', dicts, lie_avail1, arg_tys') ->
+    tcConstructor pat con_name         `thenTc` \ (data_con, ex_tvs, dicts, lie_avail1, arg_tys, con_res_ty) ->
+
+       -- Check overall type matches.
+       -- The pat_ty might be a for-all type, in which
+       -- case we must instantiate to match
+    tcSubPat con_res_ty pat_ty         `thenTc` \ (co_fn, lie_req1) ->
 
        -- Check correct arity
     let
@@ -416,11 +428,11 @@ tcConPat tc_bndr pat con_name arg_pats pat_ty
            (arityErr "Constructor" data_con con_arity no_of_args)      `thenTc_`
 
        -- Check arguments
-    tcPats tc_bndr arg_pats arg_tys'   `thenTc` \ (arg_pats', lie_req, tvs, ids, lie_avail2) ->
+    tcPats tc_bndr arg_pats arg_tys    `thenTc` \ (arg_pats', lie_req2, tvs, ids, lie_avail2) ->
 
-    returnTc (ConPat data_con pat_ty ex_tvs' dicts arg_pats',
-             lie_req,
-             listToBag ex_tvs' `unionBags` tvs,
+    returnTc (co_fn <$> ConPat data_con pat_ty ex_tvs dicts arg_pats',
+             lie_req1 `plusLIE` lie_req2,
+             listToBag ex_tvs `unionBags` tvs,
              ids,
              lie_avail1 `plusLIE` lie_avail2)
 \end{code}
@@ -451,7 +463,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