[commit: ghc] ghc-8.0: Refine ASSERT in buildPatSyn for the nullary case. (c33aad1)

[git at git.haskell.org]

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

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/c33aad1e77bdfa929f52cefa8ebf7c5917b60405/ghc

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

commit c33aad1e77bdfa929f52cefa8ebf7c5917b60405
Author: Matthew Pickering <matthewtpickering at gmail.com>
Date:   Wed Oct 26 11:19:48 2016 -0400

    Refine ASSERT in buildPatSyn for the nullary case.
    
    For a nullary pattern synonym we add an extra void argument to the
    matcher in order to preserve laziness. The check in buildPatSyn
    wasn't aware of this special case which was causing the assertion to
    fail.
    
    Reviewers: austin, simonpj, bgamari
    
    Reviewed By: simonpj, bgamari
    
    Subscribers: simonpj, thomie
    
    Differential Revision: https://phabricator.haskell.org/D2624
    
    GHC Trac Issues: #12746
    
    (cherry picked from commit 23143f60680f78f80762754fe060a3e8c6dc9a01)


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

c33aad1e77bdfa929f52cefa8ebf7c5917b60405
 compiler/iface/BuildTyCl.hs                      | 10 +++++++++-
 testsuite/tests/patsyn/should_compile/T12746.hs  |  7 +++++++
 testsuite/tests/patsyn/should_compile/T12746A.hs |  5 +++++
 testsuite/tests/patsyn/should_compile/all.T      |  1 +
 4 files changed, 22 insertions(+), 1 deletion(-)

diff --git a/compiler/iface/BuildTyCl.hs b/compiler/iface/BuildTyCl.hs
index a012906..30c744c 100644
--- a/compiler/iface/BuildTyCl.hs
+++ b/compiler/iface/BuildTyCl.hs
@@ -19,6 +19,7 @@ module BuildTyCl (
 import IfaceEnv
 import FamInstEnv( FamInstEnvs, mkNewTypeCoAxiom )
 import TysWiredIn( isCTupleTyConName )
+import TysPrim ( voidPrimTy )
 import DataCon
 import PatSyn
 import Var
@@ -197,7 +198,7 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
                  , pat_ty `eqType` substTy subst pat_ty1
                  , prov_theta `eqTypes` substTys subst prov_theta1
                  , req_theta `eqTypes` substTys subst req_theta1
-                 , arg_tys `eqTypes` substTys subst arg_tys1
+                 , compareArgTys arg_tys (substTys subst arg_tys1)
                  ])
             , (vcat [ ppr univ_tvs <+> twiddle <+> ppr univ_tvs1
                     , ppr ex_tvs <+> twiddle <+> ppr ex_tvs1
@@ -218,6 +219,13 @@ buildPatSyn src_name declared_infix matcher@(matcher_id,_) builder
     subst = zipTvSubst (univ_tvs1 ++ ex_tvs1)
                        (mkTyVarTys (univ_tvs ++ ex_tvs))
 
+    -- For a nullary pattern synonym we add a single void argument to the
+    -- matcher to preserve laziness in the case of unlifted types.
+    -- See #12746
+    compareArgTys :: [Type] -> [Type] -> Bool
+    compareArgTys [] [x] = x `eqType` voidPrimTy
+    compareArgTys arg_tys matcher_arg_tys = arg_tys `eqTypes` matcher_arg_tys
+
 ------------------------------------------------------
 type TcMethInfo     -- A temporary intermediate, to communicate
                     -- between tcClassSigs and buildClass.
diff --git a/testsuite/tests/patsyn/should_compile/T12746.hs b/testsuite/tests/patsyn/should_compile/T12746.hs
new file mode 100644
index 0000000..4c44c0f
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T12746.hs
@@ -0,0 +1,7 @@
+module T12746 where
+
+import T12746A
+
+foo a = case a of
+        Foo -> True
+        _ -> False
diff --git a/testsuite/tests/patsyn/should_compile/T12746A.hs b/testsuite/tests/patsyn/should_compile/T12746A.hs
new file mode 100644
index 0000000..4cf7b07
--- /dev/null
+++ b/testsuite/tests/patsyn/should_compile/T12746A.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE ScopedTypeVariables, PatternSynonyms #-}
+module T12746A where
+
+pattern Foo :: Int
+pattern Foo = 0x00000001
diff --git a/testsuite/tests/patsyn/should_compile/all.T b/testsuite/tests/patsyn/should_compile/all.T
index 875449c..dd52a48 100644
--- a/testsuite/tests/patsyn/should_compile/all.T
+++ b/testsuite/tests/patsyn/should_compile/all.T
@@ -59,3 +59,4 @@ test('T12615', normal, compile, [''])
 test('T11987', normal, multimod_compile, ['T11987', '-v0'])
 test('T12615', normal, compile, [''])
 test('T12698', normal, compile, [''])
+test('T12746', normal, multi_compile, ['T12746', [('T12746A.hs', '-c')],'-v0'])