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

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