[project @ 2001-06-11 12:24:51 by simonpj]

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

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index f65de3c..92dae22 100644 (file)
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -8,9 +8,9 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w
 
 #include "HsVersions.h"
 
-import CmdLineOpts     ( DynFlag(..), DynFlags, dopt )
+import CmdLineOpts     ( DynFlag(..), dopt )
 import HsSyn           
-import TcHsSyn         ( TypecheckedPat, TypecheckedMatch )
+import TcHsSyn         ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext )
 import DsHsSyn         ( outPatType )
 import Check            ( check, ExhaustivePat )
 import CoreSyn
@@ -27,7 +27,7 @@ import Type           ( splitAlgTyConApp, mkTyVarTys, Type )
 import TysWiredIn      ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
 import BasicTypes      ( Boxity(..) )
 import UniqSet
-import ErrUtils                ( addErrLocHdrLine, dontAddErrLoc )
+import ErrUtils                ( addWarnLocHdrLine, dontAddErrLoc )
 import Outputable
 \end{code}
 
@@ -108,76 +108,22 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
               | otherwise                    = empty
 
 pp_context NoMatchContext msg rest_of_msg_fun
-  = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
+  = 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
-  = case pp_match kind pats of
-      (ppr_match, pref) ->
-          addErrLocHdrLine loc message (nest 8 (rest_of_msg_fun pref))
-       where
-         message = ptext SLIT("Pattern match(es)") <+> msg <+> ppr_match <> char ':'
- where
-    pp_match (FunMatch fun) pats
-      = let ppr_fun = ppr fun in
-        ( hsep [ptext SLIT("in the definition of function"), quotes ppr_fun]
-       , (\ x -> ppr_fun <+> x)
-       )
-
-    pp_match CaseMatch pats
-      = (hang (ptext SLIT("in a group of case alternatives beginning"))
-          4 (ppr_pats pats)
-       , id
-       )
-
-    pp_match RecUpdMatch pats
-      = (hang (ptext SLIT("in a record-update construct"))
-          4 (ppr_pats pats)
-       , id
-       )
-
-    pp_match PatBindMatch pats
-      = ( hang (ptext SLIT("in a pattern binding"))
-           4 (ppr_pats pats)
-       , id
-       )
-
-    pp_match LambdaMatch pats
-      = ( hang (ptext SLIT("in a lambda abstraction"))
-           4 (ppr_pats pats)
-       , id
-       )
-
-    pp_match DoBindMatch pats
-      = ( hang (ptext SLIT("in a `do' pattern binding"))
-            4 (ppr_pats pats)
-       , id
-       )
-
-    pp_match ListCompMatch pats
-      = ( hang (ptext SLIT("in a `list comprension' pattern binding"))
-            4 (ppr_pats pats)
-       , id
-       ) 
-
-    pp_match LetMatch pats
-      = ( hang (ptext SLIT("in a `let' pattern binding"))
-            4 (ppr_pats pats)
-       , id
-       )
+  = 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)
 
 ppr_pats pats = sep (map ppr pats)
 
-separator (FunMatch _)    = SLIT("=")
-separator (CaseMatch)     = SLIT("->") 
-separator (LambdaMatch)   = SLIT("->") 
-separator (PatBindMatch)  = panic "When is this used?"
-separator (RecUpdMatch)   = panic "When is this used?"
-separator (DoBindMatch)   = SLIT("<-")  
-separator (ListCompMatch) = SLIT("<-")  
-separator (LetMatch)      = SLIT("=")
-                 
 ppr_shadow_pats kind pats
-  = sep [ppr_pats pats, ptext (separator kind), ptext SLIT("...")]
+  = sep [ppr_pats pats, ptext (matchSeparator kind), ptext SLIT("...")]
     
 ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
 ppr_incomplete_pats kind (pats,constraints) = 
@@ -676,9 +622,8 @@ Call @match@ with all of this information!
 \end{enumerate}
 
 \begin{code}
-matchWrapper :: DsMatchKind                    -- For shadowing warning messages
-            -> [TypecheckedMatch]              -- Matches being desugared
-            -> String                          -- Error message if the match fails
+matchWrapper :: TypecheckedMatchContext        -- For shadowing warning messages
+            -> [TypecheckedMatch]      -- Matches being desugared
             -> DsM ([Id], CoreExpr)    -- Results
 \end{code}
 
@@ -705,11 +650,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 ->
@@ -718,10 +664,10 @@ 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 
-                LambdaMatch | dopt Opt_WarnSimplePatterns dflags -> matchExport 
-                            | otherwise                          -> match
-                _                                                -> matchExport
+           = case ctxt of 
+                LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchExport 
+                           | otherwise                          -> match
+                _                                               -> matchExport
 \end{code}
 
 %************************************************************************
@@ -736,7 +682,7 @@ pattern. It returns an expression.
 
 \begin{code}
 matchSimply :: CoreExpr                        -- Scrutinee
-           -> DsMatchKind              -- Match kind
+           -> TypecheckedMatchContext  -- Match kind
            -> TypecheckedPat           -- Pattern it should match
            -> CoreExpr                 -- Return this if it matches
            -> CoreExpr                 -- Return this if it doesn't
@@ -780,10 +726,9 @@ matchSinglePat scrut ctx pat match_result
 This is actually local to @matchWrapper@.
 
 \begin{code}
-flattenMatches
-       :: DsMatchKind
-       -> [TypecheckedMatch]
-       -> DsM (Type, [EquationInfo])
+flattenMatches :: TypecheckedMatchContext
+              -> [TypecheckedMatch]
+              -> DsM (Type, [EquationInfo])
 
 flattenMatches kind matches
   = mapAndUnzipDs flatten_match (matches `zip` [1..])  `thenDs` \ (result_tys, eqn_infos) ->