[project @ 2002-04-05 15:18:25 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 5aa3fdc..1f9fcda 100644 (file)
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -8,10 +8,10 @@ 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 )
-import DsHsSyn         ( outPatType )
+import TcHsSyn         ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, outPatType )
 import Check            ( check, ExhaustivePat )
 import CoreSyn
 import CoreUtils       ( bindNonRec )
@@ -23,11 +23,13 @@ import DataCon              ( dataConFieldLabels, dataConInstOrigArgTys )
 import MatchCon                ( matchConFamily )
 import MatchLit                ( matchLiterals )
 import PrelInfo                ( pAT_ERROR_ID )
-import TcType          ( mkTyVarTys, Type, tcSplitTyConApp, tcEqType )
-import TysWiredIn      ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
+import TcType          ( mkTyVarTys, Type, tcTyConAppArgs, tcEqType )
+import TysWiredIn      ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
+                         tupleCon, parrFakeCon, mkPArrTy )
 import BasicTypes      ( Boxity(..) )
 import UniqSet
 import ErrUtils                ( addWarnLocHdrLine, dontAddErrLoc )
+import Util             ( lengthExceeds )
 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
-                       && (length pats /= 0)
+                       && (not (null pats))
         shadow        = dopt Opt_WarnOverlappingPatterns dflags
                        && sizeUniqSet indexs < no_eqns
         no_eqns       = length qs
@@ -86,7 +88,7 @@ The next two functions create the warning message.
 dsShadowWarn :: DsMatchContext -> [EquationInfo] -> DsM ()
 dsShadowWarn ctx@(DsMatchContext kind _ _) qs = dsWarn warn 
        where
-         warn | length qs > maximum_output
+         warn | qs `lengthExceeds` maximum_output
                = pp_context ctx (ptext SLIT("are overlapped"))
                            (\ f -> vcat (map (ppr_eqn f kind) (take maximum_output qs)) $$
                            ptext SLIT("..."))
@@ -104,8 +106,8 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn
                                                  (take maximum_output pats))
                                      $$ dots))
 
-         dots | length pats > maximum_output = ptext SLIT("...")
-              | otherwise                    = empty
+         dots | pats `lengthExceeds` maximum_output = ptext SLIT("...")
+              | otherwise                           = empty
 
 pp_context NoMatchContext msg rest_of_msg_fun
   = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id))
@@ -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)
 
@@ -416,7 +421,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)    = tcSplitTyConApp 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)
 
@@ -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}
 
@@ -738,7 +752,7 @@ flattenMatches kind matches
     ASSERT( all (tcEqType result_ty) result_tys )
     returnDs (result_ty, eqn_infos)
   where
-    flatten_match (Match _ pats _ grhss, n)
+    flatten_match (Match pats _ grhss, n)
       = dsGRHSs kind pats grhss                `thenDs` \ (ty, match_result) ->
         getSrcLocDs                            `thenDs` \ locn ->
        returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result)