Fix #11287.
[ghc.git] / testsuite / tests / th / TH_RichKinds2.hs
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE GADTs #-}
3 {-# LANGUAGE KindSignatures #-}
4 {-# LANGUAGE PolyKinds #-}
5 {-# LANGUAGE TemplateHaskell #-}
6 {-# LANGUAGE TypeFamilies #-}
7 {-# LANGUAGE TypeOperators #-}
8
9 module TH_RichKinds2 where
10
11 import Data.Char
12 import Data.List
13 import Language.Haskell.TH
14
15 $(return [OpenTypeFamilyD (TypeFamilyHead
16 (mkName "Map") [KindedTV (mkName "f")
17 (AppT (AppT ArrowT (VarT (mkName "k1")))
18 (VarT (mkName "k2"))),
19 KindedTV (mkName "l")
20 (AppT ListT
21 (VarT (mkName "k1")))]
22 (KindSig (AppT ListT (VarT (mkName "k2")))) Nothing)])
23
24 $( let fixKs :: String -> String -- need to remove TH renaming index from k variables
25 fixKs s =
26 case (elemIndex 'k' s) of
27 Nothing -> s
28 Just i ->
29 if i == (length s) || (s !! (i+1) /= '_') then s else
30 let (prefix, suffix) = splitAt (i+2) s -- the +2 for the "k_"
31 (index, rest) = span isDigit suffix in
32 if length index == 0 then s else
33 prefix ++ "0" ++ (fixKs rest)
34 in
35 do decls <- [d| data SMaybe :: (k -> *) -> (Maybe k) -> * where
36 SNothing :: SMaybe s 'Nothing
37 SJust :: s a -> SMaybe s ('Just a)
38
39 type instance Map f '[] = '[]
40 type instance Map f (h ': t) = ((f h) ': (Map f t))
41 |]
42 reportWarning (fixKs (pprint decls))
43 return decls )
44
45 data SBool :: Bool -> * where
46 SFalse :: SBool 'False
47 STrue :: SBool 'True
48
49 mbool :: SMaybe SBool ('Just 'False)
50 mbool = SJust SFalse