Commit 35391368 authored by Richard Eisenberg's avatar Richard Eisenberg Committed by Simon Peyton Jones

Applied lunaris's patch to allow promoted types and rich kinds in Template Haskell

parent 284a60f3
{-# LANGUAGE TemplateHaskell #-}
module TH_Promoted1Tuple where
import Language.Haskell.TH
$(sequence [tySynD (mkName "F") [] (appT (promotedTupleT 1) (conT ''Int))])
TH_Promoted1Tuple.hs:7:3:
Illegal promoted 1-tuple type
When splicing a TH declaration: type F = '(GHC.Types.Int)
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
module TH_PromotedList where
import Language.Haskell.TH
$(let ty = AppT (AppT PromotedConsT (ConT ''Int))
(AppT (AppT PromotedConsT (ConT ''Bool)) PromotedNilT)
in report False (pprint ty) >>
return [])
data Proxy a = Proxy
f :: Proxy (True ': $(appT (appT promotedConsT (conT 'False)) promotedNilT))
f = Proxy :: Proxy ('[True, False] :: [Bool])
TH_PromotedList.hs:11:3: Warning:
(':) GHC.Types.Int ((':) GHC.Types.Bool '[])
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
module TH_PromotedTuple where
import Language.Haskell.TH
data Equal a b where
Refl :: Equal a a
equal :: Equal '(Int, False) $(do ty <- [t| '(Int, False) |]
report False (show ty)
return ty)
equal = Refl
TH_PromotedTuple.hs:(14,32)-(16,43): Splicing type
do { ty <- [t| '(Int, False) |];
report False (show ty);
return ty }
======>
'(Int, False)
TH_PromotedTuple.hs:14:32: Warning:
AppT (AppT (PromotedTupleT 2) (ConT GHC.Types.Int)) (PromotedT GHC.Types.False)
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
module TH_RichKinds where
import GHC.Prim
import Language.Haskell.TH
$(do tys <- sequence [ [t| forall a. (a :: Bool) |]
, [t| forall a. (a :: Constraint) |]
, [t| forall a. (a :: [*]) |]
, [t| forall a. (a :: (*, Bool)) |]
, [t| forall a. (a :: ()) |]
, [t| forall a. (a :: (* -> Bool) -> ((*, * -> *) -> Bool)) |]
]
report False (pprint tys)
return [])
TH_RichKinds.hs:12:3: Warning:
forall a_0 . a_0 :: GHC.Types.Bool
forall a_1 . a_1 :: Constraint
forall a_2 . a_2 :: [*]
forall a_3 . a_3 :: (*, GHC.Types.Bool)
forall a_4 . a_4 :: GHC.Tuple.()
forall a_5 . a_5 :: (* -> GHC.Types.Bool) ->
(*, * -> *) -> GHC.Types.Bool
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
module TH_RichKinds2 where
import Data.Char
import Data.List
import Language.Haskell.TH
$(return [FamilyD TypeFam (mkName "Map") [KindedTV (mkName "f")
(AppT (AppT ArrowT (VarT (mkName "k1")))
(VarT (mkName "k2"))),
KindedTV (mkName "l")
(AppT ListT
(VarT (mkName "k1")))]
(Just (AppT ListT (VarT (mkName "k2"))))])
$( let fixKs :: String -> String -- need to remove TH renaming index from k variables
fixKs s =
case (elemIndex 'k' s) of
Nothing -> s
Just i ->
if i == (length s) || (s !! (i+1) /= '_') then s else
let (prefix, suffix) = splitAt (i+2) s -- the +2 for the "k_"
(index, rest) = span isDigit suffix in
if length index == 0 then s else
prefix ++ "0" ++ (fixKs rest)
in
do decls <- [d| data SMaybe :: (k -> *) -> (Maybe k) -> * where
SNothing :: SMaybe s 'Nothing
SJust :: s a -> SMaybe s ('Just a)
type instance Map f '[] = '[]
type instance Map f (h ': t) = ((f h) ': (Map f t))
|]
report False (fixKs (pprint decls))
return decls )
data SBool :: Bool -> * where
SFalse :: SBool 'False
STrue :: SBool 'True
mbool :: SMaybe SBool ('Just 'False)
mbool = SJust SFalse
TH_RichKinds2.hs:23:4: Warning:
data SMaybe_0 (t_1 :: k_0 ->
*) (t_2 :: Data.Maybe.Maybe k_0)
= forall . t_2 ~ 'Data.Maybe.Nothing => SNothing_3
| forall a_4 . t_2 ~ 'Data.Maybe.Just a_4 => SJust_5 (t_1 a_4)
type instance TH_RichKinds2.Map f_6 '[] = '[]
type instance TH_RichKinds2.Map f_7 ((':) h_8 t_9) = (':) (f_7 h_8)
(TH_RichKinds2.Map f_7 t_9)
......@@ -144,7 +144,7 @@ test('T2386', extra_clean(['T2386_Lib.hi', 'T2386_Lib.o']),
run_command,
['$MAKE -s --no-print-directory T2386'] )
test('T2685', extra_clean(['T2685a.hi','T2685a.o']),
test('T2685', extra_clean(['T2685a.hi','T2685a.o']),
multimod_compile, ['T2685','-v0'])
test('TH_sections', normal, compile, ['-v0'])
......@@ -166,10 +166,10 @@ test('T3572', normal, compile_and_run, [''])
test('T3100', normal, compile, ['-v0'])
test('T3920', normal, compile_and_run, ['-v0'])
test('T3600', extra_clean(['T3600a.hi','T3600a.o']),
test('T3600', extra_clean(['T3600a.hi','T3600a.o']),
multimod_compile, ['T3600','-v0'])
test('T3845', normal, compile, ['-v0'])
test('T3899', extra_clean(['T3899a.hi','T3899a.o']),
test('T3899', extra_clean(['T3899a.hi','T3899a.o']),
multimod_compile, ['T3899','-v0 -ddump-splices -dsuppress-uniques'])
test('T4056', normal, compile, ['-v0'])
test('T4188', normal, compile, ['-v0'])
......@@ -200,12 +200,12 @@ test('T5358', normal, compile_fail, [''])
test('T5379', normal, compile_and_run, [''])
test('T5404', normal, compile, ['-v0'])
test('T5410', normal, compile_and_run, ['-v0'])
test('TH_lookupName',
test('TH_lookupName',
extra_clean(['TH_lookupName_Lib.hi', 'TH_lookupName_Lib.o']),
multimod_compile_and_run,
['TH_lookupName.hs', ''])
test('T5452', normal, compile, ['-v0'])
test('T5434', extra_clean(['T5434a.hi','T5434a.o']),
test('T5434', extra_clean(['T5434a.hi','T5434a.o']),
multimod_compile, ['T5434','-v0 -Wall'])
test('T5508', normal, compile, ['-v0 -ddump-splices'])
test('TH_Depends',
......@@ -213,17 +213,24 @@ test('TH_Depends',
'TH_Depends_external.txt'])],
run_command,
['$MAKE -s --no-print-directory TH_Depends'])
test('T5597', extra_clean(['T5597a.hi','T5597a.o']),
test('T5597', extra_clean(['T5597a.hi','T5597a.o']),
multimod_compile, ['T5597','-v0'])
test('T5665', extra_clean(['T5665a.hi','T5665a.o']),
test('T5665', extra_clean(['T5665a.hi','T5665a.o']),
multimod_compile, ['T5665','-v0'])
test('T5700', extra_clean(['T5700a.hi','T5700a.o']),
test('T5700', extra_clean(['T5700a.hi','T5700a.o']),
multimod_compile, ['T5700','-v0 -ddump-splices'])
test('T5721', normal, compile, ['-v0'])
test('TH_PromotedTuple', normal, compile, ['-v0 -ddump-splices'])
test('TH_PromotedList', normal, compile, ['-v0'])
test('TH_Promoted1Tuple', normal, compile_fail, ['-v0'])
test('TH_RichKinds', normal, compile, ['-v0'])
test('TH_RichKinds2', normal, compile, ['-v0'])
test('T1541', normal, compile, ['-v0'])
test('T5883', normal, compile, ['-v0 -dsuppress-uniques -ddump-splices'])
test('T5882', normal, compile, ['-v0'])
test('T5886', extra_clean(['T5886a.hi','T5886a.o']),
test('T5886', extra_clean(['T5886a.hi','T5886a.o']),
multimod_compile, ['T5886','-v0'])
test('T4135', normal, compile, ['-v0'])
test('T5971', normal, compile_fail, ['-v0 -dsuppress-uniques'])
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment