[Git][ghc/ghc][wip/or-pats] Add tests
David (@knothed)
gitlab at gitlab.haskell.org
Mon Dec 5 15:03:34 UTC 2022
David pushed to branch wip/or-pats at Glasgow Haskell Compiler / GHC
Commits:
9df48e0b by David Knothe at 2022-12-05T16:03:28+01:00
Add tests
- - - - -
14 changed files:
- + testsuite/tests/deSugar/should_run/Or5.hs
- + testsuite/tests/deSugar/should_run/Or5.stderr
- + testsuite/tests/deSugar/should_run/Or5.stdout
- testsuite/tests/deSugar/should_run/all.T
- + testsuite/tests/parser/should_fail/Or1.hs
- + testsuite/tests/parser/should_fail/Or1.stderr
- + testsuite/tests/parser/should_fail/Or2.hs
- + testsuite/tests/parser/should_fail/Or2.stderr
- + testsuite/tests/parser/should_fail/Or3.hs
- + testsuite/tests/parser/should_fail/Or3.stderr
- testsuite/tests/parser/should_fail/all.T
- + testsuite/tests/rename/should_fail/Or4.hs
- + testsuite/tests/rename/should_fail/Or4.stderr
- testsuite/tests/rename/should_fail/all.T
Changes:
=====================================
testsuite/tests/deSugar/should_run/Or5.hs
=====================================
@@ -0,0 +1,42 @@
+{-# LANGUAGE OrPatterns #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Main where
+
+main = do
+ print ((f1 3) == 1)
+ print ((f1 5) == 3)
+ print ((f2 [0,2,4]) == 1)
+ print ((f2 [1,3]) == 2)
+ print ((f3 4 4) == True)
+ print ((f3 3 8) == True)
+ print (a3 == 3)
+ print (a4 == True)
+ print (a5 == True)
+ print (a6 == False)
+ print backtrack
+
+f1 x = case x of
+ 3 -> 1
+ 4 -> 2
+ (one of 3,4,5) -> 3
+
+f2 y = case y of
+ (one of _:2:_, 1:_) | length y /= 2 -> 1
+ (one of [1,2], 1:3:_)-> 2
+ (one of _, _) -> 3
+
+f3 :: (Eq a, Show a) => a -> a -> Bool
+f3 a (one of (== a) -> True, show -> "8") = True
+f3 _ _ = False
+
+a3 = (\(one of 1, 2) -> 3) 1
+a4 = (\(one of Left 0, Right 1) -> True) (Right 1)
+a5 = (\(one of (one of [1], [2, _]), (one of [3, _, _], [4, _, _, _])) -> True) [4, undefined, undefined, undefined]
+a6 = (\(one of 1, 2, 3) -> False) 3
+
+backtrack :: String
+backtrack = case (True, error "backtracking") of
+ (one of (True, _), (_, True))
+ | False -> error "inaccessible"
+ _ -> error "no backtracking"
\ No newline at end of file
=====================================
testsuite/tests/deSugar/should_run/Or5.stderr
=====================================
@@ -0,0 +1,3 @@
+Or5: no backtracking
+CallStack (from HasCallStack):
+ error, called at Or5.hs:42:8 in main:Main
=====================================
testsuite/tests/deSugar/should_run/Or5.stdout
=====================================
@@ -0,0 +1,10 @@
+True
+True
+True
+True
+True
+True
+True
+True
+True
+True
=====================================
testsuite/tests/deSugar/should_run/all.T
=====================================
@@ -74,3 +74,5 @@ test('T19289', normal, compile_and_run, [''])
test('T19680', normal, compile_and_run, [''])
test('T19680A', normal, compile_and_run, [''])
test('T20024', exit_code(1), compile_and_run, [''])
+
+test('Or5', exit_code(1), compile_and_run, [''])
=====================================
testsuite/tests/parser/should_fail/Or1.hs
=====================================
@@ -0,0 +1,4 @@
+module Main where
+
+main = case 1 of
+ (one of 2, 3) -> True
\ No newline at end of file
=====================================
testsuite/tests/parser/should_fail/Or1.stderr
=====================================
@@ -0,0 +1,4 @@
+
+Or1.hs:4:4: error: [GHC-29847]
+ Illegal or-pattern: one of 2, 3
+ Suggested fix: Perhaps you intended to use OrPatterns
=====================================
testsuite/tests/parser/should_fail/Or2.hs
=====================================
@@ -0,0 +1,4 @@
+module Main where
+
+main = case 3 of
+ one of 4, 5 -> False
\ No newline at end of file
=====================================
testsuite/tests/parser/should_fail/Or2.stderr
=====================================
@@ -0,0 +1,2 @@
+
+Or2.hs:4:7: error: [GHC-58481] parse error on input ‘of’
=====================================
testsuite/tests/parser/should_fail/Or3.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE OrPatterns #-}
+
+module Main where
+
+main = case 3 of
+ (one of 4) -> False
+ (one of x, _) -> x == 3
\ No newline at end of file
=====================================
testsuite/tests/parser/should_fail/Or3.stderr
=====================================
@@ -0,0 +1,3 @@
+
+Or3.hs:6:4: error: [GHC-96152]
+ Or-pattern needs at least two alternatives: one of 4
=====================================
testsuite/tests/parser/should_fail/all.T
=====================================
@@ -215,3 +215,7 @@ test('T21843c', normal, compile_fail, [''])
test('T21843d', normal, compile_fail, [''])
test('T21843e', normal, compile_fail, [''])
test('T21843f', normal, compile_fail, [''])
+
+test('Or1', normal, compile_fail, [''])
+test('Or2', normal, compile_fail, [''])
+test('Or3', normal, compile_fail, [''])
=====================================
testsuite/tests/rename/should_fail/Or4.hs
=====================================
@@ -0,0 +1,13 @@
+{-# LANGUAGE OrPatterns #-}
+{-# LANGUAGE GADTs #-}
+
+module Main where
+
+data GADT a where
+ IsInt1 :: GADT Int
+ IsInt2 :: GADT Int
+
+foo :: a -> GADT a -> a
+foo x (one of IsInt1 {}, IsInt2 {}) = x + 1
+
+main = print $ foo 3 IsInt1
\ No newline at end of file
=====================================
testsuite/tests/rename/should_fail/Or4.stderr
=====================================
@@ -0,0 +1,131 @@
+*** Core Lint errors : in result of Desugar (before optimization) ***
+Or4.hs:11:5: warning:
+ Out of scope: $dNum_aDz :: Num a_aDq
+ [LclId]
+ In the RHS of foo :: forall a. a -> GADT a -> a
+ In the body of lambda with binder a_aDq :: *
+ In the body of lambda with binder x_aw0 :: a_aDq
+ In the body of lambda with binder ds_dMh :: GADT a_aDq
+ In the body of lambda with binder ds_dMt :: (# #)
+ In an occurrence of $dNum_aDz :: Num a_aDq
+ Substitution: <InScope = {a_aDq}
+ IdSubst = []
+ TvSubst = [aDq :-> a_aDq]
+ CvSubst = []>
+*** Offending Program ***
+Rec {
+$tcGADT :: TyCon
+[LclIdX]
+$tcGADT
+ = TyCon
+ 7315894308497656774#Word64
+ 13366801423186927574#Word64
+ $trModule
+ (TrNameS "GADT"#)
+ 0#
+ krep$*Arr*
+
+$tc'IsInt1 :: TyCon
+[LclIdX]
+$tc'IsInt1
+ = TyCon
+ 1090152040133353571#Word64
+ 3950193049621776869#Word64
+ $trModule
+ (TrNameS "'IsInt1"#)
+ 0#
+ $krep_aLk
+
+$tc'IsInt2 :: TyCon
+[LclIdX]
+$tc'IsInt2
+ = TyCon
+ 838859291769359256#Word64
+ 1629192201818783450#Word64
+ $trModule
+ (TrNameS "'IsInt2"#)
+ 0#
+ $krep_aLk
+
+$krep_aLk [InlPrag=[~]] :: KindRep
+[LclId]
+$krep_aLk
+ = KindRepTyConApp $tcGADT (: @KindRep $krep_aLl ([] @KindRep))
+
+$krep_aLl [InlPrag=[~]] :: KindRep
+[LclId]
+$krep_aLl = KindRepTyConApp $tcInt ([] @KindRep)
+
+$trModule :: Module
+[LclIdX]
+$trModule = Module (TrNameS "main"#) (TrNameS "Main"#)
+
+foo :: forall a. a -> GADT a -> a
+[LclIdX]
+foo
+ = \ (@a_aDq) (x_aw0 :: a_aDq) (ds_dMh :: GADT a_aDq) ->
+ let {
+ success_dMs :: (# #) -> a_aDq
+ [LclId]
+ success_dMs
+ = \ (ds_dMt [OS=OneShot] :: (# #)) ->
+ + @a_aDq
+ $dNum_aDz
+ x_aw0
+ (fromInteger @a_aDq $dNum_aDB (IS 1#)) } in
+ case ds_dMh of wild_00 {
+ IsInt1 co_aDt -> success_dMs (##);
+ IsInt2 co_aDv ->
+ let {
+ $dNum_aL2 :: Num Int
+ [LclId]
+ $dNum_aL2 = $fNumInt } in
+ let {
+ $dNum_aDB :: Num a_aDq
+ [LclId]
+ $dNum_aDB
+ = $dNum_aL2
+ `cast` (Sub (Sym (Num co_aDt)_N) :: Num Int ~R# Num a_aDq) } in
+ let {
+ $dNum_aDz :: Num a_aDq
+ [LclId]
+ $dNum_aDz
+ = $dNum_aL2
+ `cast` (Sub (Sym (Num co_aDt)_N) :: Num Int ~R# Num a_aDq) } in
+ success_dMs (##)
+ }
+
+main :: IO ()
+[LclIdX]
+main
+ = let {
+ $dNum_aKU :: Num Int
+ [LclId]
+ $dNum_aKU = $fNumInt } in
+ let {
+ $dShow_aKR :: Show Int
+ [LclId]
+ $dShow_aKR = $fShowInt } in
+ letrec {
+ main_aDF :: IO ()
+ [LclId]
+ main_aDF
+ = $ @LiftedRep
+ @Int
+ @(IO ())
+ (print @Int $dShow_aKR)
+ (foo @Int (I# 3#) $WIsInt1); } in
+ main_aDF
+
+main :: IO ()
+[LclIdX]
+main = runMainIO @() main
+end Rec }
+
+*** End of Offense ***
+
+
+<no location info>: error:
+Compilation had errors
+
+
=====================================
testsuite/tests/rename/should_fail/all.T
=====================================
@@ -180,3 +180,5 @@ test('T20147', normal, compile_fail, [''])
test('RnEmptyStatementGroup1', normal, compile_fail, [''])
test('RnImplicitBindInMdoNotation', normal, compile_fail, [''])
+
+test('Or4', normal, compile_fail, [''])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9df48e0b04ded38b535f7da84cc8a223d39e265d
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/9df48e0b04ded38b535f7da84cc8a223d39e265d
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20221205/ddf3ae92/attachment-0001.html>
More information about the ghc-commits
mailing list