X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FdeSugar%2FMatch.lhs;h=67f48517a447c893139d9816671a11a32b211da1;hb=90fa6b84fdc99ba99c0b7df9691ca69d50b62530;hp=7d0e47fffdb651144b6797e7d988472b3466be86;hpb=495ef8bd9ef30bffe50ea399b91e3ba09646b59a;p=ghc-hetmet.git

diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index 7d0e47f..67f4851 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -8,11 +8,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w
 
 #include "HsVersions.h"
 
-import {-# SOURCE #-} DsExpr  ( dsExpr, dsLet  )
-
-import CmdLineOpts	( opt_WarnIncompletePatterns, opt_WarnOverlappingPatterns,
-			  opt_WarnSimplePatterns
-     			)
+import CmdLineOpts	( DynFlag(..), dopt )
 import HsSyn		
 import TcHsSyn		( TypecheckedPat, TypecheckedMatch )
 import DsHsSyn		( outPatType )
@@ -23,22 +19,12 @@ 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
-			)
+import Type		( splitAlgTyConApp, mkTyVarTys, Type )
+import TysWiredIn	( nilDataCon, consDataCon, mkTupleTy, mkListTy, tupleCon )
 import BasicTypes	( Boxity(..) )
 import UniqSet
 import ErrUtils		( addErrLocHdrLine, dontAddErrLoc )
@@ -57,7 +43,12 @@ matchExport :: [Id]	        -- Vars rep'ing the exprs we're matching with
             -> [EquationInfo]   -- Info about patterns, etc. (type synonym below)
             -> DsM MatchResult  -- Desugared result!
 
-matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
+
+matchExport vars qs
+   = getDOptsDs 				`thenDs` \ dflags ->
+     matchExport_really dflags vars qs
+
+matchExport_really dflags vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
   | incomplete && shadow = 
       dsShadowWarn ctx eqns_shadow		`thenDs`   \ () ->
       dsIncompleteWarn ctx pats			`thenDs`   \ () ->
@@ -71,8 +62,10 @@ matchExport vars qs@((EqnInfo _ ctx _ (MatchResult _ _)) : _)
   | otherwise             =
       match vars qs
   where (pats,indexs) = check qs
-        incomplete    = opt_WarnIncompletePatterns && (length pats /= 0)
-        shadow        = opt_WarnOverlappingPatterns && sizeUniqSet indexs < no_eqns
+        incomplete    = dopt Opt_WarnIncompletePatterns dflags
+			&& (length pats /= 0)
+        shadow        = dopt Opt_WarnOverlappingPatterns dflags
+			&& sizeUniqSet indexs < no_eqns
         no_eqns       = length qs
 	unused_eqns   = uniqSetToList (mkUniqSet [1..no_eqns] `minusUniqSet` indexs)
 	eqns_shadow   = map (\n -> qs!!(n - 1)) unused_eqns
@@ -478,7 +471,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,
@@ -517,17 +510,13 @@ tidy1 v (DictPat dicts methods) match_result
     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...
 
@@ -717,20 +706,22 @@ JJQC 30-Nov-1997
 
 \begin{code}
 matchWrapper kind matches error_string
-  = flattenMatches kind matches			`thenDs` \ (result_ty, eqns_info) ->
+  = getDOptsDs					`thenDs` \ dflags ->
+    flattenMatches kind matches			`thenDs` \ (result_ty, eqns_info) ->
     let
 	EqnInfo _ _ arg_pats _ : _ = eqns_info
     in
-    mapDs selectMatchVar arg_pats			`thenDs` \ new_vars ->
-    match_fun new_vars eqns_info 		 	`thenDs` \ match_result ->
+    mapDs selectMatchVar arg_pats		`thenDs` \ new_vars ->
+    match_fun dflags new_vars eqns_info 	`thenDs` \ match_result ->
 
     mkErrorAppDs pAT_ERROR_ID result_ty error_string	`thenDs` \ fail_expr ->
     extractMatchResult match_result fail_expr		`thenDs` \ result_expr ->
     returnDs (new_vars, result_expr)
-  where match_fun = case kind of 
-                      LambdaMatch | opt_WarnSimplePatterns -> matchExport 
-                                  | otherwise              -> match
-                      _                                    -> matchExport
+  where match_fun dflags
+           = case kind of 
+                LambdaMatch | dopt Opt_WarnSimplePatterns dflags -> matchExport 
+                            | otherwise                          -> match
+                _                                                -> matchExport
 \end{code}
 
 %************************************************************************
@@ -765,10 +756,12 @@ matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat
 	       -> MatchResult -> DsM MatchResult
 
 matchSinglePat (Var var) ctx pat match_result
-  = match_fn [var] [EqnInfo 1 ctx [pat] match_result]
+  = getDOptsDs					`thenDs` \ dflags ->
+    match_fn dflags [var] [EqnInfo 1 ctx [pat] match_result]
   where
-    match_fn | opt_WarnSimplePatterns = matchExport
-	     | otherwise	      = match
+    match_fn dflags
+       | dopt Opt_WarnSimplePatterns dflags = matchExport
+       | otherwise	                    = match
 
 matchSinglePat scrut ctx pat match_result
   = selectMatchVar pat		 	 		`thenDs` \ var ->