[commit: ghc] master: Add a test for #14815: (f7f567d)

[git at git.haskell.org]

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

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

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

commit f7f567d5003d15308bf5404301e29300b664e770
Author: Ömer Sinan Ağacan <omeragacan at gmail.com>
Date:   Thu Apr 19 11:32:26 2018 -0400

    Add a test for #14815:
    
    Because the program doesn't have any binders that -XStrict can make
    strict, the desugarer output should be identical when it's compiled with
    and without -XStrict. This wasn't the case with GHC 8.2.2, but
    apparently it was fixed some time between 8.2.2 and 8.4.1. We now add a
    test case to make sure it stays fixed.
    
    Reviewers: bgamari
    
    Reviewed By: bgamari
    
    Subscribers: simonpj, rwbarton, thomie, carter
    
    GHC Trac Issues: #14815
    
    Differential Revision: https://phabricator.haskell.org/D4531


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

f7f567d5003d15308bf5404301e29300b664e770
 testsuite/tests/deSugar/should_compile/Makefile    |  9 +++++
 testsuite/tests/deSugar/should_compile/T14815.hs   | 43 ++++++++++++++++++++++
 .../tests/deSugar/should_compile/T14815.stdout     |  2 +
 testsuite/tests/deSugar/should_compile/all.T       |  1 +
 4 files changed, 55 insertions(+)

diff --git a/testsuite/tests/deSugar/should_compile/Makefile b/testsuite/tests/deSugar/should_compile/Makefile
index 792d4e7..4600070 100644
--- a/testsuite/tests/deSugar/should_compile/Makefile
+++ b/testsuite/tests/deSugar/should_compile/Makefile
@@ -14,3 +14,12 @@ T5252Take2:
 	$(RM) -f T5252Take2a.hi T5252Take2a.o
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c T5252Take2a.hs
 	'$(TEST_HC)' $(TEST_HC_OPTS) -c T5252Take2.hs
+
+T14815:
+	'$(TEST_HC)' $(TEST_HC_OPTS) T14815.hs -ddump-ds -dsuppress-uniques -ddump-to-file -dumpdir lazy -fforce-recomp
+	'$(TEST_HC)' $(TEST_HC_OPTS) T14815.hs -XStrict -ddump-ds -dsuppress-uniques -ddump-to-file -dumpdir strict -fforce-recomp
+	# Drop time stamps from both files
+	tail -n +5 lazy/T14815.dump-ds >lazy_out
+	tail -n +5 strict/T14815.dump-ds >strict_out
+	# Finally compare outputs
+	diff lazy_out strict_out -q
diff --git a/testsuite/tests/deSugar/should_compile/T14815.hs b/testsuite/tests/deSugar/should_compile/T14815.hs
new file mode 100644
index 0000000..fc5a6ee
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14815.hs
@@ -0,0 +1,43 @@
+-- Desugarer outputs of this program when compiled with and without -XStrict
+-- should be the same because this program has only one binder (`a` in function
+-- `primitive`), but the binder is annotated with a laziness annotation, so
+-- -XStrict should have no effect on that binder.
+--
+-- Derived methods are also effected by -XStrict, but in our case we derive via
+-- GND which just generates coercions like
+--
+--     instance Functor m => Functor (StateT s m) where
+--       fmap
+--         = coerce
+--             @(forall (a_aJ2 :: TYPE LiftedRep) (b_aJ3 :: TYPE LiftedRep).
+--               a_aJ2 -> b_aJ3
+--               -> StateT s_aDW m_aDX a_aJ2 -> StateT s_aDW m_aDX b_aJ3)
+--             @(forall (a_aJ2 :: TYPE LiftedRep) (b_aJ3 :: TYPE LiftedRep).
+--               a_aJ2 -> b_aJ3
+--               -> StateT s_aDW m_aDX a_aJ2 -> StateT s_aDW m_aDX b_aJ3)
+--             fmap
+--
+-- So really -XStrict shouldn't have any effect on this program.
+
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UnboxedTuples              #-}
+
+module K where
+
+import qualified Control.Monad.State.Strict as S
+import Control.Monad.Trans
+import GHC.Exts
+
+class Monad m => PrimMonad m where
+  type PrimState m
+  primitive :: (State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
+
+newtype StateT s m a = StateT (S.StateT s m a)
+  deriving (Functor, Applicative, Monad, MonadTrans)
+
+instance PrimMonad m => PrimMonad (StateT s m) where
+  type PrimState (StateT s m) = PrimState m
+  primitive ~a = lift (primitive a) ; {-# INLINE primitive #-}
diff --git a/testsuite/tests/deSugar/should_compile/T14815.stdout b/testsuite/tests/deSugar/should_compile/T14815.stdout
new file mode 100644
index 0000000..f51afc4
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T14815.stdout
@@ -0,0 +1,2 @@
+[1 of 1] Compiling K                ( T14815.hs, T14815.o )
+[1 of 1] Compiling K                ( T14815.hs, T14815.o )
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T
index 2608b7d..2d36146 100644
--- a/testsuite/tests/deSugar/should_compile/all.T
+++ b/testsuite/tests/deSugar/should_compile/all.T
@@ -102,3 +102,4 @@ test('T13870', normal, compile, [''])
 test('T14135', normal, compile, [''])
 test('T14773a', normal, compile, ['-Wincomplete-patterns'])
 test('T14773b', normal, compile, ['-Wincomplete-patterns'])
+test('T14815', [], run_command, ['$MAKE -s --no-print-directory T14815'])