Make quoting and reification return the same types
[ghc.git] / testsuite / tests / th / T11629.hs
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE TemplateHaskell #-}
3 {-# LANGUAGE KindSignatures #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 module T11629 where
6
7 import Control.Monad
8 import Language.Haskell.TH
9
10 class C (a :: Bool)
11 class D (a :: (Bool, Bool))
12 class E (a :: [Bool])
13
14 instance C True
15 instance C 'False
16
17 instance D '(True, False)
18 instance D '(False, True)
19
20 instance E '[True, False]
21 instance E '[False, True]
22
23 do
24 let getType (InstanceD _ _ ty _) = ty
25 getType _ = error "getType: only defined for InstanceD"
26
27 failMsg a ty1 ty2 = fail $ "example " ++ a
28 ++ ": ty1 /= ty2, where\n ty1 = "
29 ++ show ty1 ++ "\n ty2 = " ++ show ty2
30
31 withoutSig (ForallT tvs cxt ty) = ForallT tvs cxt (withoutSig ty)
32 withoutSig (AppT ty1 ty2) = AppT (withoutSig ty1) (withoutSig ty2)
33 withoutSig (SigT ty ki) = withoutSig ty
34 withoutSig ty = ty
35
36 -- test #1: type quotations and reified types should agree.
37 ty1 <- [t| C True |]
38 ty2 <- [t| C 'False |]
39 ClassI _ insts <- reify ''C
40 let [ty1', ty2'] = map getType insts
41
42 when (ty1 /= ty1') $ failMsg "A" ty1 ty1'
43 when (ty2 /= ty2') $ failMsg "B" ty2 ty2'
44
45 -- test #2: type quotations and reified types should agree wrt
46 -- promoted tuples.
47 ty3 <- [t| D '(True, False) |]
48 ty4 <- [t| D (False, True) |]
49 ClassI _ insts <- reify ''D
50 let [ty3', ty4'] = map (withoutSig . getType) insts
51
52 when (ty3 /= ty3') $ failMsg "C" ty3 ty3'
53 -- The following won't work. See https://ghc.haskell.org/trac/ghc/ticket/12853
54 -- when (ty4 /= ty4') $ failMsg "D" ty4 ty4'
55
56 -- test #3: type quotations and reified types should agree wrt to
57 -- promoted lists.
58 ty5 <- [t| E '[True, False] |]
59 ty6 <- [t| E [False, True] |]
60
61 ClassI _ insts <- reify ''E
62 let [ty5', ty6'] = map (withoutSig . getType) insts
63
64 when (ty5 /= ty5') $ failMsg "C" ty5 ty5'
65 when (ty6 /= ty6') $ failMsg "D" ty6 ty6'
66
67 return []