diff options
Diffstat (limited to 'testsuite/tests/deSugar/should_compile')
20 files changed, 326 insertions, 22 deletions
diff --git a/testsuite/tests/deSugar/should_compile/Makefile b/testsuite/tests/deSugar/should_compile/Makefile index 792d4e7bc9..4600070c05 100644 --- a/testsuite/tests/deSugar/should_compile/Makefile +++ b/testsuite/tests/deSugar/should_compile/Makefile @@ -5,12 +5,21 @@ include $(TOP)/mk/test.mk T5252: $(RM) -f T5252.hi T5252.o $(RM) -f T5252a.hi T5252a.o - '$(TEST_HC)' $(TEST_HC_OPTS) -c T5252a.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -c T5252a.hs '$(TEST_HC)' $(TEST_HC_OPTS) -c T5252.hs # Failed when compiled *without* optimisation T5252Take2: $(RM) -f T5252Take2.hi T5252Take2.o $(RM) -f T5252Take2a.hi T5252Take2a.o - '$(TEST_HC)' $(TEST_HC_OPTS) -c T5252Take2a.hs + '$(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/T13870.hs b/testsuite/tests/deSugar/should_compile/T13870.hs new file mode 100644 index 0000000000..90ad9f072e --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T13870.hs @@ -0,0 +1,14 @@ +-- !!! T13870 -- missing-fields warnings for recprd-construction + +module ShouldCompile where + +import Data.Functor.Identity + +test1 :: Maybe Int +test1 = Just{} + +test2 :: Maybe Int +test2 = Nothing{} + +test3 :: Identity Int +test3 = Identity{} diff --git a/testsuite/tests/deSugar/should_compile/T13870.stderr b/testsuite/tests/deSugar/should_compile/T13870.stderr new file mode 100644 index 0000000000..55868069d3 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T13870.stderr @@ -0,0 +1,10 @@ + +T13870.hs:8:9: warning: [-Wmissing-fields (in -Wdefault)] + • Fields of ‘Just’ not initialised + • In the expression: Just {} + In an equation for ‘test1’: test1 = Just {} + +T13870.hs:14:9: warning: [-Wmissing-fields (in -Wdefault)] + • Fields of ‘Identity’ not initialised: runIdentity + • In the expression: Identity {} + In an equation for ‘test3’: test3 = Identity {} diff --git a/testsuite/tests/deSugar/should_compile/T14135.hs b/testsuite/tests/deSugar/should_compile/T14135.hs new file mode 100644 index 0000000000..fbdd5bd4c6 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14135.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# OPTIONS_GHC -Wincomplete-patterns #-} +{-# LANGUAGE GADTs #-} +module T14135 where + +data Foo a where + Foo1 :: a -> Foo a + Foo2 :: Int -> Foo Int + +pattern MyFoo2 :: (a ~ Int) => Int -> Foo a +pattern MyFoo2 i = Foo2 i + +{-# COMPLETE Foo1, MyFoo2 #-} + +f :: Foo a -> a +f (Foo1 x) = x diff --git a/testsuite/tests/deSugar/should_compile/T14135.stderr b/testsuite/tests/deSugar/should_compile/T14135.stderr new file mode 100644 index 0000000000..23a3e90aaf --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14135.stderr @@ -0,0 +1,4 @@ + +T14135.hs:16:1: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In an equation for ‘f’: Patterns not matched: (Foo2 _) diff --git a/testsuite/tests/deSugar/should_compile/T14546a.hs b/testsuite/tests/deSugar/should_compile/T14546a.hs new file mode 100644 index 0000000000..085ea3ced9 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14546a.hs @@ -0,0 +1,29 @@ +main :: IO () +main = do + case 0::Int of + 0 -> putStrLn "A" + 1 -> putStrLn "B" + _ -> putStrLn "C" + + case 0::Int of + 0 -> putStrLn "A" + 1 -> putStrLn "B" + 2 -> putStrLn "C" + + case 0::Integer of + 0 -> putStrLn "A" + 1 -> putStrLn "B" + _ -> putStrLn "C" + + case 0::Integer of + 0 -> putStrLn "A" + 1 -> putStrLn "B" + 2 -> putStrLn "C" + + case 0::Integer of + 1 -> putStrLn "B" + 2 -> putStrLn "C" + + case 3::Integer of + 1 -> putStrLn "B" + 2 -> putStrLn "C" diff --git a/testsuite/tests/deSugar/should_compile/T14546a.stderr b/testsuite/tests/deSugar/should_compile/T14546a.stderr new file mode 100644 index 0000000000..5918a45cc7 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14546a.stderr @@ -0,0 +1,56 @@ + +T14546a.hs:5:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: 1 -> ... + +T14546a.hs:6:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: _ -> ... + +T14546a.hs:10:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: 1 -> ... + +T14546a.hs:11:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: 2 -> ... + +T14546a.hs:15:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: 1 -> ... + +T14546a.hs:16:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: _ -> ... + +T14546a.hs:20:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: 1 -> ... + +T14546a.hs:21:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: 2 -> ... + +T14546a.hs:23:4: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In a case alternative: Patterns not matched: 0 + +T14546a.hs:24:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: 1 -> ... + +T14546a.hs:25:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: 2 -> ... + +T14546a.hs:27:4: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In a case alternative: Patterns not matched: 3 + +T14546a.hs:28:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: 1 -> ... + +T14546a.hs:29:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: 2 -> ... diff --git a/testsuite/tests/deSugar/should_compile/T14546b.hs b/testsuite/tests/deSugar/should_compile/T14546b.hs new file mode 100644 index 0000000000..7dd0b23384 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14546b.hs @@ -0,0 +1,11 @@ +main :: IO () +main = do + case "foo" of + ('f':_) -> putStrLn "A" + ('f':'o':_) -> putStrLn "B" + "bar" -> putStrLn "C" + + case "foo" of + "foo" -> putStrLn "A" + "bar" -> putStrLn "B" + "baz" -> putStrLn "C" diff --git a/testsuite/tests/deSugar/should_compile/T14546b.stderr b/testsuite/tests/deSugar/should_compile/T14546b.stderr new file mode 100644 index 0000000000..00b4286a48 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14546b.stderr @@ -0,0 +1,16 @@ + +T14546b.hs:5:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: ('f' : 'o' : _) -> ... + +T14546b.hs:6:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: "bar" -> ... + +T14546b.hs:10:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: "bar" -> ... + +T14546b.hs:11:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: "baz" -> ... diff --git a/testsuite/tests/deSugar/should_compile/T14546c.hs b/testsuite/tests/deSugar/should_compile/T14546c.hs new file mode 100644 index 0000000000..886511b65a --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14546c.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} + +import qualified Data.ByteString as B + +main :: IO () +main = do + case "foo" of + ('f':_) -> putStrLn "A" + ('f':'o':_) -> putStrLn "B" + "bar" -> putStrLn "C" + + case "foo" of + "foo" -> putStrLn "A" + "bar" -> putStrLn "B" + "baz" -> putStrLn "C" + + case ("foo" :: B.ByteString) of + "foo" -> putStrLn "A" + "bar" -> putStrLn "B" + "baz" -> putStrLn "C" diff --git a/testsuite/tests/deSugar/should_compile/T14546c.stderr b/testsuite/tests/deSugar/should_compile/T14546c.stderr new file mode 100644 index 0000000000..0ea6ca0012 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14546c.stderr @@ -0,0 +1,24 @@ + +T14546c.hs:9:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: ('f' : 'o' : _) -> ... + +T14546c.hs:10:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: "bar" -> ... + +T14546c.hs:14:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: "bar" -> ... + +T14546c.hs:15:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: "baz" -> ... + +T14546c.hs:19:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: "bar" -> ... + +T14546c.hs:20:7: warning: [-Woverlapping-patterns (in -Wdefault)] + Pattern match is redundant + In a case alternative: "baz" -> ... diff --git a/testsuite/tests/deSugar/should_compile/T14547.hs b/testsuite/tests/deSugar/should_compile/T14547.hs new file mode 100644 index 0000000000..02ff2e618c --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14547.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE TypeFamilies #-} + +module T14547 where + +class Foo f where + type It f + foo :: [It f] -> f + +data List a = Empty | a :! List a deriving Show + +instance Foo (List a) where + type It (List a) = a + foo [] = Empty + foo (x : xs) = x :! foo xs diff --git a/testsuite/tests/deSugar/should_compile/T14773a.hs b/testsuite/tests/deSugar/should_compile/T14773a.hs new file mode 100644 index 0000000000..6d1e9fca5d --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14773a.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MultiWayIf #-} + +module T14773a where + +foo :: Bool -> Int +foo b = if | b -> 1 + +bar :: Bool -> Int +bar b = if | b -> 1 + | otherwise -> 2 diff --git a/testsuite/tests/deSugar/should_compile/T14773a.stderr b/testsuite/tests/deSugar/should_compile/T14773a.stderr new file mode 100644 index 0000000000..49d1ef05fc --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14773a.stderr @@ -0,0 +1,5 @@ + +T14773a.hs:6:12: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In a multi-way if alternative: + Guards do not cover entire pattern space diff --git a/testsuite/tests/deSugar/should_compile/T14773b.hs b/testsuite/tests/deSugar/should_compile/T14773b.hs new file mode 100644 index 0000000000..d11bbfe5d5 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14773b.hs @@ -0,0 +1,8 @@ +module T14773b where + +b :: Bool +(Just b) | False = Nothing + +c :: Bool +(Just c) | False = Nothing + | True = Just True diff --git a/testsuite/tests/deSugar/should_compile/T14773b.stderr b/testsuite/tests/deSugar/should_compile/T14773b.stderr new file mode 100644 index 0000000000..557b10b8f0 --- /dev/null +++ b/testsuite/tests/deSugar/should_compile/T14773b.stderr @@ -0,0 +1,5 @@ + +T14773b.hs:4:10: warning: [-Wincomplete-patterns (in -Wextra)] + Pattern match(es) are non-exhaustive + In a pattern binding guards: + Guards do not cover entire pattern space diff --git a/testsuite/tests/deSugar/should_compile/T14815.hs b/testsuite/tests/deSugar/should_compile/T14815.hs new file mode 100644 index 0000000000..fc5a6ee26e --- /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 0000000000..f51afc4f54 --- /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/T2431.stderr b/testsuite/tests/deSugar/should_compile/T2431.stderr index aaa1696331..3c1c232887 100644 --- a/testsuite/tests/deSugar/should_compile/T2431.stderr +++ b/testsuite/tests/deSugar/should_compile/T2431.stderr @@ -11,60 +11,58 @@ T2431.$WRefl [InlPrag=INLINE[2]] :: forall a. a :~: a Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=False) - Tmpl= \ (@ a) -> - T2431.Refl @ a @ a @~ (<a>_N :: (a :: *) GHC.Prim.~# (a :: *))}] + Tmpl= \ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a GHC.Prim.~# a)}] T2431.$WRefl - = \ (@ a) -> - T2431.Refl @ a @ a @~ (<a>_N :: (a :: *) GHC.Prim.~# (a :: *)) + = \ (@ a) -> T2431.Refl @ a @ a @~ (<a>_N :: a GHC.Prim.~# a) -- RHS size: {terms: 4, types: 8, coercions: 0, joins: 0/0} absurd :: forall a. (Int :~: Bool) -> a -[GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>x] +[GblId, Arity=1, Caf=NoCafRefs, Str=<L,U>x, Unf=OtherCon []] absurd = \ (@ a) (x :: Int :~: Bool) -> case x of { } -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] $trModule1 = "main"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $trModule2 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] $trModule2 = GHC.Types.TrNameS $trModule1 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $trModule3 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] $trModule3 = "T2431"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $trModule4 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] $trModule4 = GHC.Types.TrNameS $trModule3 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} T2431.$trModule :: GHC.Types.Module -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] T2431.$trModule = GHC.Types.Module $trModule2 $trModule4 -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $krep :: GHC.Types.KindRep -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] $krep = GHC.Types.KindRepVar 0# -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $tc:~:1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] $tc:~:1 = ":~:"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $tc:~:2 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] $tc:~:2 = GHC.Types.TrNameS $tc:~:1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T2431.$tc:~: :: GHC.Types.TyCon -[GblId] +[GblId, Unf=OtherCon []] T2431.$tc:~: = GHC.Types.TyCon 4608886815921030019## @@ -76,34 +74,34 @@ T2431.$tc:~: -- RHS size: {terms: 3, types: 2, coercions: 0, joins: 0/0} $krep1 :: [GHC.Types.KindRep] -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] $krep1 = GHC.Types.: @ GHC.Types.KindRep $krep (GHC.Types.[] @ GHC.Types.KindRep) -- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} $krep2 :: [GHC.Types.KindRep] -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] $krep2 = GHC.Types.: @ GHC.Types.KindRep $krep $krep1 -- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} $krep3 :: GHC.Types.KindRep -[GblId] +[GblId, Unf=OtherCon []] $krep3 = GHC.Types.KindRepTyConApp T2431.$tc:~: $krep2 -- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} $tc'Refl1 :: GHC.Prim.Addr# -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] $tc'Refl1 = "'Refl"# -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} $tc'Refl2 :: GHC.Types.TrName -[GblId, Caf=NoCafRefs] +[GblId, Caf=NoCafRefs, Unf=OtherCon []] $tc'Refl2 = GHC.Types.TrNameS $tc'Refl1 -- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} T2431.$tc'Refl :: GHC.Types.TyCon -[GblId] +[GblId, Unf=OtherCon []] T2431.$tc'Refl = GHC.Types.TyCon 2478588351447975921## diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T index 7a39b1eed7..9951047e99 100644 --- a/testsuite/tests/deSugar/should_compile/all.T +++ b/testsuite/tests/deSugar/should_compile/all.T @@ -98,3 +98,12 @@ test('T13043', normal, compile, ['']) test('T13215', normal, compile, ['']) test('T13290', normal, compile, ['']) test('T13257', normal, compile, ['']) +test('T13870', normal, compile, ['']) +test('T14135', normal, compile, ['']) +test('T14546a', normal, compile, ['-Wincomplete-patterns']) +test('T14546b', normal, compile, ['-Wincomplete-patterns']) +test('T14546c', normal, compile, ['-Wincomplete-patterns']) +test('T14547', normal, compile, ['-Wincomplete-patterns']) +test('T14773a', normal, compile, ['-Wincomplete-patterns']) +test('T14773b', normal, compile, ['-Wincomplete-patterns']) +test('T14815', [], run_command, ['$MAKE -s --no-print-directory T14815']) |