[project @ 2002-04-29 14:03:38 by simonmar]

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

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 958c333..d76fccf 100644 (file)
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -8,6 +8,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w
 
 #include "HsVersions.h"
 
+import {-# SOURCE #-} DsExpr( dsExpr )
 import CmdLineOpts     ( DynFlag(..), dopt )
 import HsSyn           
 import TcHsSyn         ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType )
@@ -23,11 +24,12 @@ import MatchCon             ( matchConFamily )
 import MatchLit                ( matchLiterals )
 import PrelInfo                ( pAT_ERROR_ID )
 import TcType          ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
-import TysWiredIn      ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
+import TysWiredIn      ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+                         tupleCon, parrFakeCon, mkPArrTy )
 import BasicTypes      ( Boxity(..) )
 import UniqSet
 import ErrUtils                ( addWarnLocHdrLine, dontAddErrLoc )
-import Util             ( lengthExceeds )
+import Util             ( lengthExceeds, notNull )
 import Outputable
 \end{code}
 
@@ -63,7 +65,7 @@ matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
       match vars qs
   where (pats,indexs) = check qs
         incomplete    = dopt Opt_WarnIncompletePatterns dflags
-                       && (not (null pats))
+                       && (notNull pats)
         shadow        = dopt Opt_WarnOverlappingPatterns dflags
                        && sizeUniqSet indexs < no_eqns
         no_eqns       = length qs
@@ -123,7 +125,7 @@ pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun
 ppr_pats pats = sep (map ppr pats)
 
 ppr_shadow_pats kind pats
-  = sep [ppr_pats pats, ptext (matchSeparator kind), ptext SLIT("...")]
+  = sep [ppr_pats pats, matchSeparator kind, ptext SLIT("...")]
     
 ppr_incomplete_pats kind (pats,[]) = ppr_pats pats
 ppr_incomplete_pats kind (pats,constraints) = 
@@ -238,21 +240,13 @@ And gluing the ``success expressions'' together isn't quite so pretty.
 
 \begin{code}
 match [] eqns_info
-  = complete_matches eqns_info
+  = returnDs (foldr1 combineMatchResults match_results)
   where
-    complete_matches [eqn] 
-       = complete_match eqn
- 
-    complete_matches (eqn:eqns)
-       = complete_match eqn            `thenDs` \ match_result1 ->
-         complete_matches eqns         `thenDs` \ match_result2 ->
-         returnDs (combineMatchResults match_result1 match_result2)
-
-    complete_match (EqnInfo _ _ pats match_result)
-       = ASSERT( null pats )
-         returnDs match_result
+    match_results = [ ASSERT( null pats) mr
+                   | EqnInfo _ _ pats mr <- eqns_info ]
 \end{code}
 
+
 %************************************************************************
 %*                                                                     *
 %*  match: non-empty rule                                              *
@@ -321,7 +315,8 @@ Replace the `as' pattern @x@@p@ with the pattern p and a binding @x = v@.
 \item
 Removing lazy (irrefutable) patterns (you don't want to know...).
 \item
-Converting explicit tuple- and list-pats into ordinary @ConPats@.
+Converting explicit tuple-, list-, and parallel-array-pats into ordinary
+@ConPats@. 
 \item
 Convert the literal pat "" to [].
 \end{itemize}
@@ -382,6 +377,16 @@ tidy1 v (AsPat var pat) match_result
     match_result' | v == var  = match_result
                  | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result
 
+tidy1 v (SigPat pat ty fn) match_result
+  = selectMatchVar pat         `thenDs` \ v' ->
+    tidy1 v' pat match_result  `thenDs` \ (WildPat _, match_result') ->
+       -- The ice is a little thin here
+       -- We only expect a SigPat (with a non-trivial coercion) wrapping
+       -- a variable pattern. If it was a constructor or literal pattern
+       -- there would be no interesting polymorphism, and hence no coercion.
+    dsExpr (HsApp fn (HsVar v))        `thenDs` \ e ->
+    returnDs (WildPat ty, adjustMatchResult (bindNonRec v' e) match_result')
+
 tidy1 v (WildPat ty) match_result
   = returnDs (WildPat ty, match_result)
 
@@ -438,6 +443,15 @@ tidy1 v (ListPat ty pats) match_result
              (ConPat nilDataCon  list_ty [] [] [])
              pats
 
+-- introduce fake parallel array constructors to be able to handle parallel
+-- arrays with the existing machinery for constructor pattern
+--
+tidy1 v (PArrPat ty pats) match_result
+  = returnDs (parrConPat, match_result)
+  where
+    arity      = length pats
+    parrConPat = ConPat (parrFakeCon arity) (mkPArrTy ty) [] [] pats
+
 tidy1 v (TuplePat pats boxity) match_result
   = returnDs (tuple_ConPat, match_result)
   where
@@ -573,7 +587,7 @@ matchUnmixedEqns all_vars@(var:vars) eqns_info
 
   where
     first_pat          = head column_1_pats
-    column_1_pats      = [pat                       | EqnInfo _ _ (pat:_)  _            <- eqns_info]
+    column_1_pats      = [pat                             | EqnInfo _ _   (pat:_)  _            <- eqns_info]
     remaining_eqns_info = [EqnInfo n ctx pats match_result | EqnInfo n ctx (_:pats) match_result <- eqns_info]
 \end{code}