[commit: ghc] master: Improve desugaring of lazy pattern match (b5cf17f)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/b5cf17f2f39993595e6ec7bd6bfe000c58a09fd8/ghc

>---------------------------------------------------------------

commit b5cf17f2f39993595e6ec7bd6bfe000c58a09fd8
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Mon May 12 16:03:48 2014 +0100

    Improve desugaring of lazy pattern match
    
    This patch implements a simpler, and nicer, desugaring for
    lazy pattern matching, fixing Trac #9098


>---------------------------------------------------------------

b5cf17f2f39993595e6ec7bd6bfe000c58a09fd8
 compiler/deSugar/DsUtils.lhs | 17 ++++++++---------
 compiler/types/Coercion.lhs  |  7 +++----
 2 files changed, 11 insertions(+), 13 deletions(-)

diff --git a/compiler/deSugar/DsUtils.lhs b/compiler/deSugar/DsUtils.lhs
index 2ad70c6..924ba88 100644
--- a/compiler/deSugar/DsUtils.lhs
+++ b/compiler/deSugar/DsUtils.lhs
@@ -64,7 +64,6 @@ import ConLike
 import DataCon
 import PatSyn
 import Type
-import Coercion
 import TysPrim
 import TysWiredIn
 import BasicTypes
@@ -638,12 +637,13 @@ mkSelectorBinds ticks pat val_expr
         -- efficient too.
 
         -- For the error message we make one error-app, to avoid duplication.
-        -- But we need it at different types... so we use coerce for that
-       ; err_expr <- mkErrorAppDs iRREFUT_PAT_ERROR_ID  unitTy (ppr pat)
-       ; err_var <- newSysLocalDs unitTy
-       ; binds <- zipWithM (mk_bind val_var err_var) ticks' binders
+        -- But we need it at different types, so we make it polymorphic:
+        --     err_var = /\a. iRREFUT_PAT_ERR a "blah blah blah"
+       ; err_app <- mkErrorAppDs iRREFUT_PAT_ERROR_ID alphaTy (ppr pat)
+       ; err_var <- newSysLocalDs (mkForAllTy alphaTyVar alphaTy)
+       ; binds   <- zipWithM (mk_bind val_var err_var) ticks' binders
        ; return ( (val_var, val_expr) :
-                  (err_var, err_expr) :
+                  (err_var, Lam alphaTyVar err_app) :
                   binds ) }
 
   | otherwise
@@ -665,14 +665,13 @@ mkSelectorBinds ticks pat val_expr
 
     mk_bind scrut_var err_var tick bndr_var = do
     -- (mk_bind sv err_var) generates
-    --          bv = case sv of { pat -> bv; other -> coerce (type-of-bv) err_var }
+    --          bv = case sv of { pat -> bv; other -> err_var @ type-of-bv }
     -- Remember, pat binds bv
         rhs_expr <- matchSimply (Var scrut_var) PatBindRhs pat
                                 (Var bndr_var) error_expr
         return (bndr_var, mkOptTickBox tick rhs_expr)
       where
-        error_expr = mkCast (Var err_var) co
-        co         = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
+        error_expr = Var err_var `App` Type (idType bndr_var)
 
     is_simple_lpat p = is_simple_pat (unLoc p)
 
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 53326e6..195bc4c 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -1048,10 +1048,9 @@ ok_tc_app ty n = case splitTyConApp_maybe ty of
 mkInstCo :: Coercion -> Type -> Coercion
 mkInstCo co ty = InstCo co ty
 
--- | Manufacture a coercion from thin air. Needless to say, this is
---   not usually safe, but it is used when we know we are dealing with
---   bottom, which is one case in which it is safe.  This is also used
---   to implement the @unsafeCoerce#@ primitive.  Optimise by pushing
+-- | Manufacture an unsafe coercion from thin air.
+--   Currently (May 14) this is used only to implement the
+--   @unsafeCoerce#@ primitive.  Optimise by pushing
 --   down through type constructors.
 mkUnsafeCo :: Type -> Type -> Coercion
 mkUnsafeCo = mkUnivCo Representational