[project @ 2000-09-22 15:56:12 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 e69c50a..7f6136a 100644 (file)
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -8,8 +8,6 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} DsExpr  ( dsExpr, dsLet  )
-
 import CmdLineOpts     ( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns,
                          opt_WarnSimplePatterns
                        )
@@ -23,23 +21,13 @@ import DsMonad
 import DsGRHSs         ( dsGRHSs )
 import DsUtils
 import Id              ( idType, recordSelectorFieldLabel, Id )
-import DataCon         ( dataConFieldLabels, dataConArgTys )
+import DataCon         ( dataConFieldLabels, dataConInstOrigArgTys )
 import MatchCon                ( matchConFamily )
 import MatchLit                ( matchLiterals )
 import PrelInfo                ( pAT_ERROR_ID )
-import Type            ( isUnLiftedType, splitAlgTyConApp,
-                         mkTyVarTys, Type
-                       )
-import TysPrim         ( intPrimTy, charPrimTy, floatPrimTy, doublePrimTy,
-                         addrPrimTy, wordPrimTy
-                       )
-import TysWiredIn      ( nilDataCon, consDataCon, mkTupleTy, mkListTy,
-                         charTy, charDataCon, intTy, intDataCon,
-                         floatTy, floatDataCon, doubleTy, tupleCon,
-                         doubleDataCon, addrTy,
-                         addrDataCon, wordTy, wordDataCon,
-                         mkUnboxedTupleTy, unboxedTupleCon
-                       )
+import Type            ( splitAlgTyConApp, mkTyVarTys, Type )
+import TysWiredIn      ( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
+import BasicTypes      ( Boxity(..) )
 import UniqSet
 import ErrUtils                ( addErrLocHdrLine, dontAddErrLoc )
 import Outputable
@@ -478,7 +466,7 @@ tidy1 v (RecPat data_con pat_ty ex_tvs dicts rpats) match_result
 
        -- Boring stuff to find the arg-tys of the constructor
     (_, inst_tys, _) = splitAlgTyConApp pat_ty
-    con_arg_tys'     = dataConArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
+    con_arg_tys'     = dataConInstOrigArgTys data_con (inst_tys ++ mkTyVarTys ex_tvs)
     tagged_arg_tys   = con_arg_tys' `zip` (dataConFieldLabels data_con)
 
        -- mk_pat picks a WildPat of the appropriate type for absent fields,
@@ -499,44 +487,31 @@ tidy1 v (ListPat ty pats) match_result
              (ConPat nilDataCon  list_ty [] [] [])
              pats
 
-tidy1 v (TuplePat pats True{-boxed-}) match_result
-  = returnDs (tuple_ConPat, match_result)
-  where
-    arity = length pats
-    tuple_ConPat
-      = ConPat (tupleCon arity)
-              (mkTupleTy arity (map outPatType pats)) [] [] 
-              pats
-
-tidy1 v (TuplePat pats False{-unboxed-}) match_result
+tidy1 v (TuplePat pats boxity) match_result
   = returnDs (tuple_ConPat, match_result)
   where
     arity = length pats
     tuple_ConPat
-      = ConPat (unboxedTupleCon arity)
-              (mkUnboxedTupleTy arity (map outPatType pats)) [] [] 
+      = ConPat (tupleCon boxity arity)
+              (mkTupleTy boxity arity (map outPatType pats)) [] [] 
               pats
 
 tidy1 v (DictPat dicts methods) match_result
   = case num_of_d_and_ms of
-       0 -> tidy1 v (TuplePat [] True) match_result
+       0 -> tidy1 v (TuplePat [] Boxed) match_result
        1 -> tidy1 v (head dict_and_method_pats) match_result
-       _ -> tidy1 v (TuplePat dict_and_method_pats True) match_result
+       _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result
   where
     num_of_d_and_ms     = length dicts + length methods
     dict_and_method_pats = map VarPat (dicts ++ methods)
 
-
--- deeply ugly mangling for some (common) NPats/LitPats
-
--- LitPats: the desugarer only sees these at well-known types
-
+-- LitPats: we *might* be able to replace these w/ a simpler form
 tidy1 v pat@(LitPat lit lit_ty) match_result
-  = returnDs (tidyLitPat lit lit_ty pat, match_result)
+  = returnDs (tidyLitPat lit pat, match_result)
 
 -- NPats: we *might* be able to replace these w/ a simpler form
 tidy1 v pat@(NPat lit lit_ty _) match_result
-  = returnDs (tidyLitPat lit lit_ty pat, match_result)
+  = returnDs (tidyNPat lit lit_ty pat, match_result)
 
 -- and everything else goes through unchanged...