Allow absent State# RealWorld arguments

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

diff --git a/compiler/deSugar/Match.lhs b/compiler/deSugar/Match.lhs
index d90f904..4bc0c4b 100644 (file)
--- a/compiler/deSugar/Match.lhs
+++ b/compiler/deSugar/Match.lhs
@@ -35,7 +35,6 @@ import Id
 import DataCon
 import MatchCon
 import MatchLit
-import PrelInfo
 import Type
 import TysWiredIn
 import ListSetOps
@@ -43,9 +42,10 @@ import SrcLoc
 import Maybes
 import Util
 import Name
-import FiniteMap
 import Outputable
 import FastString
+
+import qualified Data.Map as Map
 \end{code}
 
 This function is a wrapper of @match@, it must be called from all the parts where 
@@ -293,7 +293,7 @@ match vars@(v:_) ty eqns
        ; let grouped = groupEquations tidy_eqns
 
          -- print the view patterns that are commoned up to help debug
-       ; ifOptM Opt_D_dump_view_pattern_commoning (debug grouped)
+       ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped)
 
        ; match_results <- mapM match_group grouped
        ; return (adjustMatchResult (foldr1 (.) aux_binds) $
@@ -344,10 +344,11 @@ matchCoercion :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the coercion to the match variable and then match that
 matchCoercion (var:vars) ty (eqns@(eqn1:_))
   = do { let CoPat co pat _ = firstPat eqn1
-       ; var' <- newUniqueId (idName var) (hsPatType pat)
+       ; var' <- newUniqueId var (hsPatType pat)
        ; match_result <- match (var':vars) ty (map decomposeFirst_Coercion eqns)
-       ; rhs <- dsCoercion co (return (Var var))
-       ; return (mkCoLetMatchResult (NonRec var' rhs) match_result) }
+       ; co' <- dsHsWrapper co
+        ; let rhs' = co' (Var var)
+       ; return (mkCoLetMatchResult (NonRec var' rhs') match_result) }
 
 matchView :: [Id] -> Type -> [EquationInfo] -> DsM MatchResult
 -- Apply the view function to the match variable and then match that
@@ -357,7 +358,7 @@ matchView (var:vars) ty (eqns@(eqn1:_))
          -- to figure out the type of the fresh variable
          let ViewPat viewExpr (L _ pat) _ = firstPat eqn1
          -- do the rest of the compilation 
-       ; var' <- newUniqueId (idName var) (hsPatType pat)
+       ; var' <- newUniqueId var (hsPatType pat)
        ; match_result <- match (var':vars) ty (map decomposeFirst_View eqns)
          -- compile the view expressions
        ; viewExpr' <- dsLExpr viewExpr
@@ -463,8 +464,8 @@ tidy1 v (VarPat var)
   = return (wrapBind var v, WildPat (idType var)) 
 
 tidy1 v (VarPatOut var binds)
-  = do { prs <- dsLHsBinds binds
-       ; return (wrapBind var v . mkCoreLet (Rec prs),
+  = do { ds_ev_binds <- dsTcEvBinds binds
+       ; return (wrapBind var v . wrapDsEvBinds ds_ev_binds,
                  WildPat (idType var)) }
 
        -- case v of { x@p -> mr[] }
@@ -699,21 +700,14 @@ matchEquations  :: HsMatchContext Name
                -> [Id] -> [EquationInfo] -> Type
                -> DsM CoreExpr
 matchEquations ctxt vars eqns_info rhs_ty
-  = do { dflags <- getDOptsDs
-       ; locn   <- getSrcSpanDs
-       ; let   ds_ctxt      = DsMatchContext ctxt locn
+  = do { locn <- getSrcSpanDs
+       ; let   ds_ctxt   = DsMatchContext ctxt locn
                error_doc = matchContextErrString ctxt
 
-       ; match_result <- match_fun dflags ds_ctxt vars rhs_ty eqns_info
+       ; match_result <- matchCheck ds_ctxt vars rhs_ty eqns_info
 
        ; fail_expr <- mkErrorAppDs pAT_ERROR_ID rhs_ty error_doc
        ; extractMatchResult match_result fail_expr }
-  where 
-    match_fun dflags ds_ctxt
-       = case ctxt of 
-           LambdaExpr | dopt Opt_WarnSimplePatterns dflags -> matchCheck ds_ctxt
-                      | otherwise                          -> match
-           _                                               -> matchCheck ds_ctxt
 \end{code}
 
 %************************************************************************
@@ -733,7 +727,7 @@ matchSimply :: CoreExpr                     -- Scrutinee
            -> CoreExpr                 -- Return this if it matches
            -> CoreExpr                 -- Return this if it doesn't
            -> DsM CoreExpr
-
+-- Do not warn about incomplete patterns; see matchSinglePat comments
 matchSimply scrut hs_ctx pat result_expr fail_expr = do
     let
       match_result = cantFailMatchResult result_expr
@@ -745,16 +739,11 @@ matchSimply scrut hs_ctx pat result_expr fail_expr = do
 
 matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id
               -> Type -> MatchResult -> DsM MatchResult
-matchSinglePat (Var var) hs_ctx (L _ pat) ty match_result = do
-    dflags <- getDOptsDs
-    locn <- getSrcSpanDs
-    let
-        match_fn dflags
-           | dopt Opt_WarnSimplePatterns dflags = matchCheck ds_ctx
-           | otherwise                          = match
-           where
-             ds_ctx = DsMatchContext hs_ctx locn
-    match_fn dflags [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }]
+-- Do not warn about incomplete patterns
+-- Used for things like [ e | pat <- stuff ], where 
+-- incomplete patterns are just fine
+matchSinglePat (Var var) _ (L _ pat) ty match_result 
+  = match [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs  = match_result }]
 
 matchSinglePat scrut hs_ctx pat ty match_result = do
     var <- selectSimpleMatchVarL pat
@@ -801,14 +790,14 @@ subGroup :: Ord a => [(a, EquationInfo)] -> [[EquationInfo]]
 -- Each sub-list in the result has the same PatGroup
 -- See Note [Take care with pattern order]
 subGroup group 
-    = map reverse $ eltsFM $ foldl accumulate emptyFM group
+    = map reverse $ Map.elems $ foldl accumulate Map.empty group
   where
     accumulate pg_map (pg, eqn)
-      = case lookupFM pg_map pg of
-          Just eqns -> addToFM pg_map pg (eqn:eqns)
-          Nothing   -> addToFM pg_map pg [eqn]
+      = case Map.lookup pg pg_map of
+          Just eqns -> Map.insert pg (eqn:eqns) pg_map
+          Nothing   -> Map.insert pg [eqn]      pg_map
 
-    -- pg_map :: FiniteMap a [EquationInfo]
+    -- pg_map :: Map a [EquationInfo]
     -- Equations seen so far in reverse order of appearance
 \end{code}
 
@@ -874,7 +863,7 @@ viewLExprEq (e1,_) (e2,_) =
         wrap WpHole WpHole = True
         wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
         wrap (WpCast c)  (WpCast c')  = tcEqType c c'
-        wrap (WpApp d)   (WpApp d')   = d == d'
+        wrap (WpEvApp _) (WpEvApp _) = panic "ToDo: Match.viewLExprEq"
         wrap (WpTyApp t) (WpTyApp t') = tcEqType t t'
         -- Enhancement: could implement equality for more wrappers
         --   if it seems useful (lams and lets)