Testsuite: tabs -> spaces [skip ci]
[ghc.git] / testsuite / tests / gadt / T9380.hs
1 {-# LANGUAGE ExistentialQuantification #-}
2 {-# LANGUAGE KindSignatures #-}
3 {-# LANGUAGE DataKinds #-}
4 {-# LANGUAGE GADTs #-}
5 module Main where
6
7 import Foreign
8 import Unsafe.Coerce
9
10 data M = A | B deriving (Show, Eq)
11
12 newtype S (a :: M) = S Int
13
14 data SomeS = forall a . SomeS (S a)
15
16 data V0 :: M -> * where
17 V0A :: Int -> V0 A
18 V0B :: Double -> V0 B
19
20 data V1 :: M -> * where
21 V1A :: Int -> V1 A
22 V1B :: Double -> V1 B
23 V1a :: () -> V1 a
24
25 viewV0 :: S a -> V0 a
26 viewV0 (S i)
27 | even i = unsafeCoerce $ V0A 1
28 | otherwise = unsafeCoerce $ V0B 2
29
30 viewV1 :: S a -> V1 a
31 viewV1 (S i)
32 | even i = unsafeCoerce $ V1A 1
33 | otherwise = unsafeCoerce $ V1B 2
34
35
36 typeOf :: S a -> M
37 typeOf (S i) = if even i then A else B
38
39 cast :: M -> SomeS -> S a
40 cast ty (SomeS s@(S i))
41 | ty == typeOf s = S i
42 | otherwise = error "cast"
43
44 test0 :: IO ()
45 test0 =
46 let s = cast A (SomeS (S 0))
47 in case viewV0 s of
48 V0A{} -> putStrLn "test0 - A"
49 V0B{} -> putStrLn "test0 - B"
50
51 test1 :: IO ()
52 test1 =
53 let s = cast A (SomeS (S 2)) :: S A
54 in case viewV0 s of
55 V0A{} -> putStrLn "test1 - A"
56
57 test2 :: IO ()
58 test2 =
59 let s = cast A (SomeS (S 4))
60 in case viewV1 s of
61 V1A{} -> putStrLn "test2 - A"
62 V1B{} -> putStrLn "test2 - B"
63 V1a{} -> putStrLn "test2 - O_o"
64
65 main = do
66 test0 -- no ouput at all
67 test1 -- A
68 test2 -- O_o