[project @ 2001-08-03 20:40:43 by sof]

[ghc-hetmet.git] / ghc / compiler / deSugar / Match.lhs

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index a537ee8..e56a8ab 100644 (file)
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -10,8 +10,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w
 
 import CmdLineOpts     ( DynFlag(..), dopt )
 import HsSyn           
-import TcHsSyn         ( TypecheckedPat, TypecheckedMatch )
-import DsHsSyn         ( outPatType )
+import TcHsSyn         ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType )
 import Check            ( check, ExhaustivePat )
 import CoreSyn
 import CoreUtils       ( bindNonRec )
@@ -23,7 +22,7 @@ import DataCon                ( dataConFieldLabels, dataConInstOrigArgTys )
 import MatchCon                ( matchConFamily )
 import MatchLit                ( matchLiterals )
 import PrelInfo                ( pAT_ERROR_ID )
-import Type            ( splitAlgTyConApp, mkTyVarTys, Type )
+import TcType          ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
 import TysWiredIn      ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
 import BasicTypes      ( Boxity(..) )
 import UniqSet
@@ -111,14 +110,14 @@ pp_context NoMatchContext msg rest_of_msg_fun
   = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
 
 pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
-  = addWarnLocHdrLine loc message (nest 8 (rest_of_msg_fun pref))
+  = addWarnLocHdrLine loc 
+       (ptext SLIT("Pattern match(es)") <+> msg)
+       (sep [ppr_match <> char ':', nest 4 (rest_of_msg_fun pref)])
   where
     (ppr_match, pref)
        = case kind of
             FunRhs fun -> (pprMatchContext kind,                   \ pp -> ppr fun <+> pp)
             other      -> (pprMatchContext kind <+> ppr_pats pats, \ pp -> pp)
-          
-    message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':'
 
 ppr_pats pats = sep (map ppr pats)
 
@@ -416,7 +415,7 @@ tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result
     pats            = map mk_pat tagged_arg_tys
 
        -- Boring stuff to find the arg-tys of the constructor
-    (_, inst_tys, _) = splitAlgTyConApp pat_ty
+    inst_tys         = tcTyConAppArgs pat_ty   -- Newtypes must be opaque
     con_arg_tys'     = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
     tagged_arg_tys   = con_arg_tys' `zip` (dataConFieldLabels data_con)
 
@@ -622,9 +621,8 @@ Call @match@ with all of this information!
 \end{enumerate}
 
 \begin{code}
-matchWrapper :: HsMatchContext         -- For shadowing warning messages
+matchWrapper :: TypecheckedMatchContext        -- For shadowing warning messages
             -> [TypecheckedMatch]      -- Matches being desugared
-            -> String                  -- Error message if the match fails
             -> DsM ([Id], CoreExpr)    -- Results
 \end{code}
 
@@ -651,11 +649,12 @@ one pattern, and match simply only accepts one pattern.
 JJQC 30-Nov-1997
 
 \begin{code}
-matchWrapper kind matches error_string
+matchWrapper ctxt matches
   = getDOptsDs                                 `thenDs` \ dflags ->
-    flattenMatches kind matches                        `thenDs` \ (result_ty, eqns_info) ->
+    flattenMatches ctxt matches                        `thenDs` \ (result_ty, eqns_info) ->
     let
        EqnInfo _ _ arg_pats _ : _ = eqns_info
+       error_string = matchContextErrString ctxt
     in
     mapDs selectMatchVar arg_pats              `thenDs` \ new_vars ->
     match_fun dflags new_vars eqns_info        `thenDs` \ match_result ->
@@ -664,7 +663,7 @@ matchWrapper kind matches error_string
     extractMatchResult match_result fail_expr          `thenDs` \ result_expr ->
     returnDs (new_vars, result_expr)
   where match_fun dflags
-           = case kind of 
+           = case ctxt of 
                 LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport 
                            | otherwise                          -> match
                 _                                               -> matchExport
@@ -681,11 +680,11 @@ situation where we want to match a single expression against a single
 pattern. It returns an expression.
 
 \begin{code}
-matchSimply :: CoreExpr                -- Scrutinee
-           -> HsMatchContext   -- Match kind
-           -> TypecheckedPat   -- Pattern it should match
-           -> CoreExpr         -- Return this if it matches
-           -> CoreExpr         -- Return this if it doesn't
+matchSimply :: CoreExpr                        -- Scrutinee
+           -> TypecheckedMatchContext  -- Match kind
+           -> TypecheckedPat           -- Pattern it should match
+           -> CoreExpr                 -- Return this if it matches
+           -> CoreExpr                 -- Return this if it doesn't
            -> DsM CoreExpr
 
 matchSimply scrut kind pat result_expr fail_expr
@@ -726,7 +725,7 @@ matchSinglePat scrut ctx pat match_result
 This is actually local to @matchWrapper@.
 
 \begin{code}
-flattenMatches :: HsMatchContext
+flattenMatches :: TypecheckedMatchContext
               -> [TypecheckedMatch]
               -> DsM (Type, [EquationInfo])
 
@@ -735,7 +734,7 @@ flattenMatches kind matches
     let
        result_ty = head result_tys
     in
-    ASSERT( all (== result_ty) result_tys )
+    ASSERT( all (tcEqType result_ty) result_tys )
     returnDs (result_ty, eqn_infos)
   where
     flatten_match (Match _ pats _ grhss, n)