Major Overhaul of Pattern Match Checking (Fixes #595)
[ghc.git] / compiler / deSugar / DsExpr.hs
index 44e0aa0..e4c6ff8 100644 (file)
@@ -150,7 +150,7 @@ dsUnliftedBind (FunBind { fun_id = L _ fun
                         , fun_tick = tick }) body
                -- Can't be a bang pattern (that looks like a PatBind)
                -- so must be simply unboxed
-  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) matches
+  = do { (args, rhs) <- matchWrapper (FunRhs (idName fun)) Nothing matches
        ; MASSERT( null args ) -- Functions aren't lifted
        ; MASSERT( isIdHsWrapper co_fn )
        ; let rhs' = mkOptTickBox tick rhs
@@ -196,7 +196,8 @@ dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
 dsExpr :: HsExpr Id -> DsM CoreExpr
 dsExpr (HsPar e)              = dsLExpr e
 dsExpr (ExprWithTySigOut e _) = dsLExpr e
-dsExpr (HsVar var)            = return (varToCoreExpr var)   -- See Note [Desugaring vars]
+dsExpr (HsVar (L _ var))      = return (varToCoreExpr var)
+                                -- See Note [Desugaring vars]
 dsExpr (HsUnboundVar {})      = panic "dsExpr: HsUnboundVar" -- Typechecker eliminates them
 dsExpr (HsIPVar _)            = panic "dsExpr: HsIPVar"
 dsExpr (HsOverLabel _)        = panic "dsExpr: HsOverLabel"
@@ -214,11 +215,11 @@ dsExpr (NegApp expr neg_expr)
   = App <$> dsExpr neg_expr <*> dsLExpr expr
 
 dsExpr (HsLam a_Match)
-  = uncurry mkLams <$> matchWrapper LambdaExpr a_Match
+  = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
 
 dsExpr (HsLamCase arg matches)
   = do { arg_var <- newSysLocalDs arg
-       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
        ; return $ Lam arg_var $ bindNonRec discrim_var (Var arg_var) matching_code }
 
 dsExpr e@(HsApp fun arg)
@@ -318,7 +319,7 @@ dsExpr (HsCoreAnn _ _ expr)
 
 dsExpr (HsCase discrim matches)
   = do { core_discrim <- dsLExpr discrim
-       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt matches
+       ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
        ; return (bindNonRec discrim_var core_discrim matching_code) }
 
 -- Pepe: The binds are in scope in the body but NOT in the binding group
@@ -445,7 +446,7 @@ dsExpr (HsStatic expr@(L loc _)) = do
                  , moduleNameFS $ moduleName $ nameModule n'
                  , occNameFS    $ nameOccName n'
                  ]
-    let tvars = varSetElems $ tyVarsOfType ty
+    let tvars = tyVarsOfTypeList ty
         speTy = mkForAllTys tvars $ mkTyConApp staticPtrTyCon [ty]
         speId = mkExportedLocalId VanillaId n' speTy
         fp@(Fingerprint w0 w1) = fingerprintName $ idName speId
@@ -575,11 +576,11 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
         -- constructor aguments.
         ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
         ; ([discrim_var], matching_code)
-                <- matchWrapper RecUpd (MG { mg_alts = noLoc alts
-                                           , mg_arg_tys = [in_ty]
-                                           , mg_res_ty = out_ty, mg_origin = FromSource })
-                                           -- FromSource is not strictly right, but we
-                                           -- want incomplete pattern-match warnings
+                <- matchWrapper RecUpd Nothing (MG { mg_alts = noLoc alts
+                                                   , mg_arg_tys = [in_ty]
+                                                   , mg_res_ty = out_ty, mg_origin = FromSource })
+                                                   -- FromSource is not strictly right, but we
+                                                   -- want incomplete pattern-match warnings
 
         ; return (add_field_binds field_binds' $
                   bindNonRec discrim_var record_expr' matching_code) }
@@ -624,7 +625,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
                  -- SAFE: the typechecker will complain if the synonym is
                  -- not bidirectional
                  wrap_id = expectJust "dsExpr:mk_alt" (conLikeWrapId_maybe con)
-                 inst_con = noLoc $ HsWrap wrap (HsVar wrap_id)
+                 inst_con = noLoc $ HsWrap wrap (HsVar (noLoc wrap_id))
                         -- Reconstruct with the WrapId so that unpacking happens
                  -- The order here is because of the order in `TcPatSyn`.
                  wrap =
@@ -652,7 +653,7 @@ dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = fields
                             Nothing  -> mkTcReflCo Nominal ty
                         in if null eq_spec
                              then rhs
-                             else mkLHsWrap (mkWpCast (mkTcSubCo wrap_co)) rhs
+                             else mkLHsWrap (mkWpCastN wrap_co) rhs
                     -- eq_spec is always null for a PatSynCon
                     PatSynCon _ -> rhs