Embrace -XTypeInType, add -XStarIsType
[ghc.git] / testsuite / tests / simplCore / should_run / T3959.hs
1 {-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-}
2 module Main(main,f) where
3
4 import Data.List (isPrefixOf)
5 import Data.Dynamic
6 import Control.Exception as E
7
8 data Failure = Failure
9 deriving (Show, Typeable)
10
11 instance Exception Failure
12
13 test = (E.throw Failure >> return ())
14 `E.catch`
15 (\(x::Failure) -> return ())
16
17 main :: IO ()
18 main = print =<< test
19
20 f :: Bool -> Bool -> Bool
21 f True = error "urk"
22 -- f False = \y -> y
23
24 {-
25 Uderlying cause: we call
26 catch# thing handler
27 and expect that (thing state-token) will
28 - either diverge/throw an exception
29 - or return (# x,y #)
30 But it does neither: it returns a PAP, because
31 thing = \p q. blah
32
33 In particular, 'thing = lvl_sxo' is
34 lvl_sxc :: IO Any
35 lvl_sxc = error "urk"
36
37 lvl_sxo :: IO ()
38 = lvl_sxc >> return ()
39
40 -- inline (>>) --
41
42 = (\(eta::S#). case lvl_sxc |> g1 eta of ...) |> g2
43 where
44 g1 :: IO Any ~ S# -> (# S#, Any #)
45 g2 :: S# -> (# S#, () #) -> IO ()
46
47 -- case-of-bottomming function --
48
49 = (\ (eta::S#). lvl_sxc |> g1 |> ug3) |> g2
50 where
51 ug3(unsafe) :: S# -> (S#, Any) ~ (# S#, () #)
52
53 This is all fine. But it's crucial that lvl_sxc actually diverges.
54 Do not eta-expand it to
55
56 lvl_sxc :: IO Any
57 lvl_sxc = \eta. error "urk" |> ug4
58 where
59 ug4(unsafe) :: S# -> (# S#, Any #) ~ IO Any
60
61 In contrast, if we had
62 case x of
63 True -> \a -> 3
64 False -> error "urk"
65 we can, and must, eta-expand the error
66
67 -}