[project @ 2002-11-21 09:36:03 by simonpj]

-------------------------------
	Fix and tidy the desugaring of
	pattern-matching in do-notation
	-------------------------------

In the reorgansiation of HsPat, failureFreePat had become incorrect (due to
a catch-all case that caught a constructor that should have been matched).  So
pattern-match failure in do-notation wasn't handled right.

As it turned out, DsExpr.dsDo could be made much simpler and more elegant
by using matchSimply instead of matchWrapper, and this had the side benefit
of removing the last call to HsPat.failureFreePat.  So it's gone!

diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index 45cdacd..6ae0d0c 100644 (file)
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -15,7 +15,7 @@ import DsBinds                ( dsMonoBinds, AutoScc(..) )
 import DsGRHSs         ( dsGuarded )
 import DsCCall         ( dsCCall )
 import DsListComp      ( dsListComp, dsPArrComp )
-import DsUtils         ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr)
+import DsUtils         ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr, selectMatchVar )
 import DsMonad
 
 #ifdef GHCI
@@ -23,8 +23,7 @@ import DsMonad
 import DsMeta          ( dsBracket, dsReify )
 #endif
 
-import HsSyn           ( failureFreePat,
-                         HsExpr(..), Pat(..), HsLit(..), ArithSeqInfo(..),
+import HsSyn           ( HsExpr(..), Pat(..), HsLit(..), ArithSeqInfo(..),
                          Stmt(..), HsMatchContext(..), HsStmtContext(..), 
                          Match(..), HsBinds(..), MonoBinds(..), HsConDetails(..),
                          mkSimpleMatch, isDoExpr
@@ -41,6 +40,7 @@ import TcType         ( tcSplitAppTy, tcSplitFunTys, tcTyConAppArgs,
                          mkAppTy )
 import Type            ( splitFunTys )
 import CoreSyn
+import Literal         ( Literal(..) )
 import CoreUtils       ( exprType, mkIfThenElse, bindNonRec )
 
 import FieldLabel      ( FieldLabel, fieldLabelTyCon )
@@ -615,26 +615,20 @@ dsDo do_or_lc stmts ids result_ty
            dsLet binds rest
            
        go (BindStmt pat expr locn : stmts)
-         = putSrcLocDs locn $
-           dsExpr expr            `thenDs` \ expr2 ->
+         = go stmts                    `thenDs` \ body -> 
+           putSrcLocDs locn            $       -- Rest is associated with this location
+           dsExpr expr                 `thenDs` \ rhs ->
+           mkStringLit (mk_msg locn)   `thenDs` \ core_msg ->
            let
+               -- In a do expression, pattern-match failure just calls
+               -- the monadic 'fail' rather than throwing an exception
+               fail_expr  = mkApps (Var fail_id) [Type b_ty, core_msg]
                a_ty       = hsPatType pat
-               fail_expr  = HsApp (TyApp (HsVar fail_id) [b_ty])
-                                   (HsLit (HsString (mkFastString msg)))
-               msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn)
-               main_match = mkSimpleMatch [pat] 
-                                          (HsDo do_or_lc stmts ids result_ty locn)
-                                          result_ty locn
-               the_matches
-                 | failureFreePat pat = [main_match]
-                 | otherwise          =
-                     [ main_match
-                     , mkSimpleMatch [WildPat a_ty] fail_expr result_ty locn
-                     ]
            in
-           matchWrapper (StmtCtxt do_or_lc) the_matches        `thenDs` \ (binders, matching_code) ->
-           returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, expr2,
-                                           mkLams binders matching_code])
+           selectMatchVar pat                                  `thenDs` \ var ->
+           matchSimply (Var var) (StmtCtxt do_or_lc) pat
+                       body fail_expr                          `thenDs` \ match_code ->
+           returnDs (mkApps (Var bind_id) [Type a_ty, Type b_ty, rhs, Lam var match_code])
 
        go (RecStmt rec_vars rec_stmts rec_rets : stmts)
          = go (bind_stmt : stmts)
@@ -646,6 +640,7 @@ dsDo do_or_lc stmts ids result_ty
 
   where
     do_expr expr locn = putSrcLocDs locn (dsExpr expr)
+    mk_msg locn = "Pattern match failure in do expression at " ++ showSDoc (ppr locn)
 \end{code}
 
 Translation for RecStmt's: 

diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index 71aba6b..b12a7c6 100644 (file)
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -11,7 +11,7 @@ module HsPat (
 
        mkPrefixConPat, mkCharLitPat, mkNilPat,
 
-       failureFreePat, isWildPat, 
+       isWildPat, 
        patsAreAllCons, isConPat, isSigPat,
        patsAreAllLits, isLitPat,
        collectPatBinders, collectPatsBinders,
@@ -111,7 +111,7 @@ data Pat id
   | SigPatOut      (Pat id)            -- Pattern p
                    Type                -- Type, t, of the whole pattern
                    (HsExpr id)         -- Coercion function,
-                                               -- of type t -> typeof(p)
+                                       -- of type t -> typeof(p)
 
        ------------ Dictionary patterns (translation only) ---------------
   | DictPat        -- Used when destructing Dictionaries with an explicit case
@@ -250,34 +250,6 @@ patterns are treated specially, of course.
 
 The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
 \begin{code}
-failureFreePat :: OutPat id -> Bool
-
-failureFreePat (WildPat _)               = True
-failureFreePat (VarPat _)                = True
-failureFreePat (LazyPat        _)                = True
-failureFreePat (ParPat _)                = True
-failureFreePat (AsPat _ pat)             = failureFreePat pat
-
-failureFreePat (ListPat _ _)             = False
-failureFreePat (PArrPat _ _)             = False
-failureFreePat (TuplePat pats _)         = all failureFreePat pats
-
-failureFreePat (ConPatOut con ps _ _ _)   = only_con con && failure_free_con ps
-
-failureFreePat (SigPatOut p _ _)         = failureFreePat p
-
-failureFreePat (DictPat _ _)             = True
-
-failureFreePat other_pat                 = False   -- Literals, NPat
-
-failure_free_con (PrefixCon pats) = all failureFreePat pats
-failure_free_con (InfixCon p1 p2) = failureFreePat p1 && failureFreePat p2
-failure_free_con (RecCon fs)      = all (failureFreePat . snd) fs
-
-only_con con = maybeToBool (maybeTyConSingleCon (dataConTyCon con))
-\end{code}
-
-\begin{code}
 isWildPat (WildPat _) = True
 isWildPat other              = False