diff options
Diffstat (limited to 'testsuite/tests/th')
321 files changed, 4048 insertions, 0 deletions
diff --git a/testsuite/tests/th/ClosedFam1TH.hs b/testsuite/tests/th/ClosedFam1TH.hs new file mode 100644 index 0000000000..262e9a1e48 --- /dev/null +++ b/testsuite/tests/th/ClosedFam1TH.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, PolyKinds, DataKinds #-} + +module ClosedFam1 where + +import Language.Haskell.TH + +$(do { decl <- [d| type family Foo a (b :: k) where + Foo Int Bool = Int + Foo a Maybe = Bool + Foo b (x :: Bool) = Char |] + ; reportWarning (pprint decl) + ; return [] }) + diff --git a/testsuite/tests/th/ClosedFam1TH.stderr b/testsuite/tests/th/ClosedFam1TH.stderr new file mode 100644 index 0000000000..b2d0a9bac4 --- /dev/null +++ b/testsuite/tests/th/ClosedFam1TH.stderr @@ -0,0 +1,6 @@ + +ClosedFam1TH.hs:7:3: Warning: + type family Foo_0 a_1 (b_2 :: k_3) where + Foo_0 GHC.Types.Int GHC.Types.Bool = GHC.Types.Int + Foo_0 a_4 Data.Maybe.Maybe = GHC.Types.Bool + Foo_0 b_5 (x_6 :: GHC.Types.Bool) = GHC.Types.Char diff --git a/testsuite/tests/th/ClosedFam2TH.hs b/testsuite/tests/th/ClosedFam2TH.hs new file mode 100644 index 0000000000..cd2dc2de60 --- /dev/null +++ b/testsuite/tests/th/ClosedFam2TH.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, PolyKinds #-} + +module ClosedFam2 where + +import Language.Haskell.TH + +$( return [ ClosedTypeFamilyD (mkName "Equals") + [ KindedTV (mkName "a") (VarT (mkName "k")) + , KindedTV (mkName "b") (VarT (mkName "k")) ] + Nothing + [ TySynEqn [ (VarT (mkName "a")) + , (VarT (mkName "a")) ] + (ConT (mkName "Int")) + , TySynEqn [ (VarT (mkName "a")) + , (VarT (mkName "b")) ] + (ConT (mkName "Bool")) ] ]) + +a :: Equals b b +a = (5 :: Int) + +b :: Equals Int Bool +b = False diff --git a/testsuite/tests/th/Makefile b/testsuite/tests/th/Makefile new file mode 100644 index 0000000000..b06042bd40 --- /dev/null +++ b/testsuite/tests/th/Makefile @@ -0,0 +1,39 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# Trac 2386 requires batch-compile not --make +# Very important: without -O +T2386: + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -v0 -c T2386_Lib.hs + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -v0 -c T2386.hs + +T7445: + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -v0 -c T7445a.hs + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -v0 -c T7445.hs + +HC_OPTS = -XTemplateHaskell -package template-haskell + +TH_spliceE5_prof:: + $(RM) TH_spliceE5_prof*.o TH_spliceE5_prof*.hi TH_spliceE5_prof*.p.o + '$(TEST_HC)' $(TEST_HC_OPTS) $(HC_OPTS) --make -v0 TH_spliceE5_prof.hs -c + '$(TEST_HC)' $(TEST_HC_OPTS) $(HC_OPTS) --make -v0 TH_spliceE5_prof.hs -prof -auto-all -osuf p.o -o $@ + ./$@ + +.PHONY: TH_Depends +TH_Depends: + $(RM) TH_Depends_external.txt + $(RM) TH_Depends TH_Depends.exe + $(RM) TH_Depends.o TH_Depends.hi + $(RM) TH_Depends_External.o TH_Depends_External.hi + echo "first run" > TH_Depends_external.txt + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -v0 TH_Depends + ./TH_Depends + sleep 2 + echo "second run" > TH_Depends_external.txt + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --make -v0 TH_Depends + ./TH_Depends + + +T8333: + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) --interactive -v0 T8333.hs < /dev/null diff --git a/testsuite/tests/th/T1541.hs b/testsuite/tests/th/T1541.hs new file mode 100644 index 0000000000..c570e75b22 --- /dev/null +++ b/testsuite/tests/th/T1541.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module T1541 where + +$( [d| infixr 3 +++ + (+++) :: Int -> Bool -> Bool + (+++) x y = error "ruk" + |]) + +-- This definition will only typecheck if the +-- the fixity of (+++) is infixr +foo p q r = p +++ q +++ r diff --git a/testsuite/tests/th/T1835.hs b/testsuite/tests/th/T1835.hs new file mode 100644 index 0000000000..d0c4dba308 --- /dev/null +++ b/testsuite/tests/th/T1835.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE TemplateHaskell, FlexibleInstances, + MultiParamTypeClasses, TypeSynonymInstances #-} +module Main where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +class Eq a => MyClass a +data Foo = Foo deriving Eq + +instance MyClass Foo + +data Bar = Bar + deriving Eq + +type Baz = Bar +instance MyClass Baz + +data Quux a = Quux a deriving Eq +data Quux2 a = Quux2 a deriving Eq +instance Eq a => MyClass (Quux a) +instance Ord a => MyClass (Quux2 a) + +class MyClass2 a b +instance MyClass2 Int Bool + +$(return []) + +main = do + putStrLn $(do { info <- reify ''MyClass; lift (pprint info) }) + print $(isInstance ''Eq [ConT ''Foo] >>= lift) + print $(isInstance ''MyClass [ConT ''Foo] >>= lift) + print $ not $(isInstance ''Show [ConT ''Foo] >>= lift) + print $(isInstance ''MyClass [ConT ''Bar] >>= lift) -- this one + print $(isInstance ''MyClass [ConT ''Baz] >>= lift) + print $(isInstance ''MyClass [AppT (ConT ''Quux) (ConT ''Int)] >>= lift) --this one + print $(isInstance ''MyClass [AppT (ConT ''Quux2) (ConT ''Int)] >>= lift) -- this one + print $(isInstance ''MyClass2 [ConT ''Int, ConT ''Bool] >>= lift) + print $(isInstance ''MyClass2 [ConT ''Bool, ConT ''Bool] >>= lift) diff --git a/testsuite/tests/th/T1835.stdout b/testsuite/tests/th/T1835.stdout new file mode 100644 index 0000000000..ba8e65f418 --- /dev/null +++ b/testsuite/tests/th/T1835.stdout @@ -0,0 +1,14 @@ +class GHC.Classes.Eq a_0 => Main.MyClass a_0 +instance Main.MyClass Main.Foo +instance Main.MyClass Main.Baz +instance GHC.Classes.Eq a_1 => Main.MyClass (Main.Quux a_1) +instance GHC.Classes.Ord a_2 => Main.MyClass (Main.Quux2 a_2) +True +True +True +True +True +True +True +True +False diff --git a/testsuite/tests/th/T1849.script b/testsuite/tests/th/T1849.script new file mode 100644 index 0000000000..861b8d43d3 --- /dev/null +++ b/testsuite/tests/th/T1849.script @@ -0,0 +1,10 @@ +:set -XTemplateHaskell +import Language.Haskell.TH +let seeType n = do VarI _ t _ _ <- reify n; runIO $ putStrLn $ show t; [| return True |] +let f = undefined :: Int -> Int +let g = undefined :: [Int] +let h = undefined :: (Int, Int) +$(seeType (mkName "f")) +$(seeType (mkName "g")) +$(seeType (mkName "h")) + diff --git a/testsuite/tests/th/T1849.stdout b/testsuite/tests/th/T1849.stdout new file mode 100644 index 0000000000..3d48e778a5 --- /dev/null +++ b/testsuite/tests/th/T1849.stdout @@ -0,0 +1,6 @@ +AppT (AppT ArrowT (ConT GHC.Types.Int)) (ConT GHC.Types.Int) +True +AppT ListT (ConT GHC.Types.Int) +True +AppT (AppT (TupleT 2) (ConT GHC.Types.Int)) (ConT GHC.Types.Int) +True diff --git a/testsuite/tests/th/T2014/A.hs b/testsuite/tests/th/T2014/A.hs new file mode 100644 index 0000000000..d843c00b78 --- /dev/null +++ b/testsuite/tests/th/T2014/A.hs @@ -0,0 +1 @@ +module A where diff --git a/testsuite/tests/th/T2014/A.hs-boot b/testsuite/tests/th/T2014/A.hs-boot new file mode 100644 index 0000000000..d843c00b78 --- /dev/null +++ b/testsuite/tests/th/T2014/A.hs-boot @@ -0,0 +1 @@ +module A where diff --git a/testsuite/tests/th/T2014/B.hs b/testsuite/tests/th/T2014/B.hs new file mode 100644 index 0000000000..0233a40209 --- /dev/null +++ b/testsuite/tests/th/T2014/B.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} +module B where + +import {-# SOURCE #-} A () +--import A () +import Language.Haskell.TH + +expQ :: ExpQ +expQ = [| () |] diff --git a/testsuite/tests/th/T2014/C.hs b/testsuite/tests/th/T2014/C.hs new file mode 100644 index 0000000000..5ddff11497 --- /dev/null +++ b/testsuite/tests/th/T2014/C.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module C where + +import B + +foo :: a +foo = undefined + where second = $( expQ ) diff --git a/testsuite/tests/th/T2014/Makefile b/testsuite/tests/th/T2014/Makefile new file mode 100644 index 0000000000..0cdf67ae02 --- /dev/null +++ b/testsuite/tests/th/T2014/Makefile @@ -0,0 +1,9 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +T2014 : + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -fforce-recomp -c A.hs-boot + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -fforce-recomp -c A.hs + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -fforce-recomp -c B.hs + '$(TEST_HC)' $(TEST_HC_OPTS) $(ghcThWayFlags) -fforce-recomp -c C.hs -v0 diff --git a/testsuite/tests/th/T2014/all.T b/testsuite/tests/th/T2014/all.T new file mode 100644 index 0000000000..77709c23c5 --- /dev/null +++ b/testsuite/tests/th/T2014/all.T @@ -0,0 +1,8 @@ +setTestOpts(when(compiler_profiled(), skip)) + +test('T2014', + [req_interp, + extra_clean(['A.hi-boot','A.hi','A.o','A.o-boot', + 'B.hi', 'B.o', 'C.hi', 'C.o'])], + run_command, + ['$MAKE -s --no-print-directory T2014']) diff --git a/testsuite/tests/th/T2222.hs b/testsuite/tests/th/T2222.hs new file mode 100644 index 0000000000..bba923183a --- /dev/null +++ b/testsuite/tests/th/T2222.hs @@ -0,0 +1,42 @@ + +{-# LANGUAGE TemplateHaskell #-} +module ReifyPlusTypeInferenceBugs where + +import Language.Haskell.TH +import System.IO + +a = 1 + +$(return []) + +b = $(do VarI _ t _ _ <- reify 'a + runIO $ putStrLn ("inside b: " ++ pprint t) + [| undefined |]) + +c = $([| True |]) + +$(return []) + +d = $(do VarI _ t _ _ <- reify 'c + runIO $ putStrLn ("inside d: " ++ pprint t) + [| undefined |] ) + +$(do VarI _ t _ _ <- reify 'c + runIO $ putStrLn ("type of c: " ++ pprint t) + return [] ) + +e = $([| True |]) + +$(return []) + +f = $(do VarI _ t _ _ <- reify 'e + runIO $ putStrLn ("inside f: " ++ pprint t) + [| undefined |] ) + +$(do VarI _ t _ _ <- reify 'e + runIO $ putStrLn ("type of e: " ++ pprint t) + return [] ) + +$( runIO $ do hFlush stdout + hFlush stderr + return [] ) diff --git a/testsuite/tests/th/T2222.stderr b/testsuite/tests/th/T2222.stderr new file mode 100644 index 0000000000..b0a7e9f799 --- /dev/null +++ b/testsuite/tests/th/T2222.stderr @@ -0,0 +1,5 @@ +inside b: a_0 +inside d: GHC.Types.Bool +type of c: GHC.Types.Bool +inside f: GHC.Types.Bool +type of e: GHC.Types.Bool diff --git a/testsuite/tests/th/T2386.hs b/testsuite/tests/th/T2386.hs new file mode 100644 index 0000000000..b7a03469cf --- /dev/null +++ b/testsuite/tests/th/T2386.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Test Trac #2386 + +module T2386 where + +import T2386_Lib + +foo = $(makeOne) diff --git a/testsuite/tests/th/T2386_Lib.hs b/testsuite/tests/th/T2386_Lib.hs new file mode 100644 index 0000000000..4322cc9584 --- /dev/null +++ b/testsuite/tests/th/T2386_Lib.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T2386_Lib(ExportedAbstract, makeOne) where + +data ExportedAbstract = Yay String | NonYay Bool + +makeOne = [| Yay "Yep" |] diff --git a/testsuite/tests/th/T2597a.hs b/testsuite/tests/th/T2597a.hs new file mode 100644 index 0000000000..3d8c319b47 --- /dev/null +++ b/testsuite/tests/th/T2597a.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-}
+
+-- Test Trac #2597 (first bug)
+
+module ShouldCompile where
+import T2597a_Lib
+
+bug = $mkBug
diff --git a/testsuite/tests/th/T2597a_Lib.hs b/testsuite/tests/th/T2597a_Lib.hs new file mode 100644 index 0000000000..0e8f794dc6 --- /dev/null +++ b/testsuite/tests/th/T2597a_Lib.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-}
+-- Library module for T2597a
+
+module T2597a_Lib where
+import Language.Haskell.TH
+
+
+mkBug :: ExpQ
+mkBug = return $ CompE [BindS (VarP $ mkName "p") (ListE []), NoBindS
+ (VarE $ mkName "p")]
+
+
diff --git a/testsuite/tests/th/T2597b.hs b/testsuite/tests/th/T2597b.hs new file mode 100644 index 0000000000..2fde008388 --- /dev/null +++ b/testsuite/tests/th/T2597b.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-}
+
+-- Test Trac #2597 (second bug)
+
+module ShouldCompile where
+import T2597b_Lib
+
+bug2 = $mkBug2
+
diff --git a/testsuite/tests/th/T2597b.stderr b/testsuite/tests/th/T2597b.stderr new file mode 100644 index 0000000000..99ff754ae1 --- /dev/null +++ b/testsuite/tests/th/T2597b.stderr @@ -0,0 +1,5 @@ + +T2597b.hs:8:8: + Empty stmt list in do-block + When splicing a TH expression: do + In the splice: $mkBug2 diff --git a/testsuite/tests/th/T2597b_Lib.hs b/testsuite/tests/th/T2597b_Lib.hs new file mode 100644 index 0000000000..1f70c3923a --- /dev/null +++ b/testsuite/tests/th/T2597b_Lib.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-}
+-- Library module for T2597b
+
+module T2597b_Lib where
+import Language.Haskell.TH
+
+
+mkBug2 :: ExpQ
+mkBug2 = return $ DoE []
diff --git a/testsuite/tests/th/T2632.hs b/testsuite/tests/th/T2632.hs new file mode 100644 index 0000000000..31429e28d9 --- /dev/null +++ b/testsuite/tests/th/T2632.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Trac #2632 + +module MkData where + +import Language.Haskell.TH + +op :: Num v => v -> v -> v +op a b = a + b + +decl1 = [d| func = 0 `op` 3 |] + +decl2 = [d| op x y = x + func = 0 `op` 3 |] + diff --git a/testsuite/tests/th/T2674.hs b/testsuite/tests/th/T2674.hs new file mode 100644 index 0000000000..3413193343 --- /dev/null +++ b/testsuite/tests/th/T2674.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Trac #2674 + +module ShouldFail where + +import Language.Haskell.TH + +$(return [FunD (mkName "foo") []]) diff --git a/testsuite/tests/th/T2674.stderr b/testsuite/tests/th/T2674.stderr new file mode 100644 index 0000000000..6875684dda --- /dev/null +++ b/testsuite/tests/th/T2674.stderr @@ -0,0 +1,4 @@ + +T2674.hs:9:3: + Function binding for ‛foo’ has no equations + When splicing a TH declaration: diff --git a/testsuite/tests/th/T2685.hs b/testsuite/tests/th/T2685.hs new file mode 100644 index 0000000000..c4bc0aa335 --- /dev/null +++ b/testsuite/tests/th/T2685.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module T2685 where + +import T2685a + +$( th ) diff --git a/testsuite/tests/th/T2685a.hs b/testsuite/tests/th/T2685a.hs new file mode 100644 index 0000000000..a92c9720ef --- /dev/null +++ b/testsuite/tests/th/T2685a.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} +module T2685a (th) where + +import Language.Haskell.TH + +newtype NT = C (() -> ()) + +th :: Q [Dec] +th = [d| foo = C undefined |] diff --git a/testsuite/tests/th/T2700.hs b/testsuite/tests/th/T2700.hs new file mode 100644 index 0000000000..68a6e6247a --- /dev/null +++ b/testsuite/tests/th/T2700.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-}
+
+module T2700 where
+import Language.Haskell.TH
+import System.IO
+
+$( do { d <- sigD (mkName "foo") [t| (Int -> Bool) -> Bool |]
+ ; runIO (hPutStrLn stderr (pprint d))
+ ; return [] }
+ )
diff --git a/testsuite/tests/th/T2700.stderr b/testsuite/tests/th/T2700.stderr new file mode 100644 index 0000000000..004521c197 --- /dev/null +++ b/testsuite/tests/th/T2700.stderr @@ -0,0 +1 @@ +foo :: (GHC.Types.Int -> GHC.Types.Bool) -> GHC.Types.Bool
diff --git a/testsuite/tests/th/T2700.stderr-ghc-7.0 b/testsuite/tests/th/T2700.stderr-ghc-7.0 new file mode 100644 index 0000000000..6637147112 --- /dev/null +++ b/testsuite/tests/th/T2700.stderr-ghc-7.0 @@ -0,0 +1 @@ +foo :: (GHC.Types.Int -> GHC.Bool.Bool) -> GHC.Bool.Bool
diff --git a/testsuite/tests/th/T2713.hs b/testsuite/tests/th/T2713.hs new file mode 100644 index 0000000000..980d499603 --- /dev/null +++ b/testsuite/tests/th/T2713.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-}
+module Fixity where
+
+class MyClass a where
+ (.*.) :: a -> a -> a
+
+f x = x
+
+$( [d| x = undefined |] )
+
+infixr 3 .*.
+f :: Int -> Int
diff --git a/testsuite/tests/th/T2713.stderr b/testsuite/tests/th/T2713.stderr new file mode 100644 index 0000000000..c036b43848 --- /dev/null +++ b/testsuite/tests/th/T2713.stderr @@ -0,0 +1,8 @@ + +T2713.hs:11:10: + The fixity signature for ‛.*.’ lacks an accompanying binding + (The fixity signature must be given where ‛.*.’ is declared) + +T2713.hs:12:1: + The type signature for ‛f’ lacks an accompanying binding + (The type signature must be given where ‛f’ is declared) diff --git a/testsuite/tests/th/T2817.hs b/testsuite/tests/th/T2817.hs new file mode 100644 index 0000000000..6bdee60994 --- /dev/null +++ b/testsuite/tests/th/T2817.hs @@ -0,0 +1,11 @@ +{-# OPTIONS -XTemplateHaskell #-} +module TH( x ) where +import Language.Haskell.TH + +data T f = MkT (f Int) + +x = $(return (SigE (VarE 'x) (AppT (ConT ''T) (AppT ArrowT (ConT ''Int))))) + + + + diff --git a/testsuite/tests/th/T2931.hs b/testsuite/tests/th/T2931.hs new file mode 100644 index 0000000000..f7b9afe0a7 --- /dev/null +++ b/testsuite/tests/th/T2931.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +-- Trac #2931 + +module Foo where +a = 1 + +-- NB: no newline after the 'a'! +b = 'a
\ No newline at end of file diff --git a/testsuite/tests/th/T3100.hs b/testsuite/tests/th/T3100.hs new file mode 100644 index 0000000000..edb943933a --- /dev/null +++ b/testsuite/tests/th/T3100.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE RankNTypes, FlexibleContexts, ImplicitParams, TemplateHaskell #-} + +-- This test makes sure TH understands types where +-- there is a predicate but no 'forall' +-- +-- There are two tests in here; both should be fine +-- Trac ticket: #3100 + +module T3100 where + +import Language.Haskell.TH + +flop :: Ord Int => Int -> Int +flop x = x + +$(do { t <- reify 'flop; return [] }) + +type T a = Eq a => a + +$(do { reify ''T; return []}) diff --git a/testsuite/tests/th/T3177.hs b/testsuite/tests/th/T3177.hs new file mode 100644 index 0000000000..c46a1f4c46 --- /dev/null +++ b/testsuite/tests/th/T3177.hs @@ -0,0 +1,14 @@ +{- LANGUAGE TemplateHaskell #-} + +-- Template Haskell type splices +module T3177 where + +f :: $(id [t| Int |]) +f = 3 + +class C a where + op :: a -> a + +instance C a => C ($([t| Maybe |]) a) where + op x = fmap op x + diff --git a/testsuite/tests/th/T3177a.hs b/testsuite/tests/th/T3177a.hs new file mode 100644 index 0000000000..8746901753 --- /dev/null +++ b/testsuite/tests/th/T3177a.hs @@ -0,0 +1,13 @@ +{- LANGUAGE TemplateHaskell #-} + +-- Template Haskell type splices +-- Should fail, with a decent error message + +module T3177a where + +f :: $(id [t| Int Int |]) +f = 3 + +g :: Int Int +g = 3 + diff --git a/testsuite/tests/th/T3177a.stderr b/testsuite/tests/th/T3177a.stderr new file mode 100644 index 0000000000..94d4f2e2d1 --- /dev/null +++ b/testsuite/tests/th/T3177a.stderr @@ -0,0 +1,8 @@ + +T3177a.hs:8:6: + ‛Int’ is applied to too many type arguments + In the type signature for ‛f’: f :: Int Int + +T3177a.hs:11:6: + ‛Int’ is applied to too many type arguments + In the type signature for ‛g’: g :: Int Int diff --git a/testsuite/tests/th/T3319.hs b/testsuite/tests/th/T3319.hs new file mode 100644 index 0000000000..afe7f01c10 --- /dev/null +++ b/testsuite/tests/th/T3319.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell,ForeignFunctionInterface #-} + +module T3319 where + +import Foreign.Ptr +import Language.Haskell.TH + +$(return [ForeignD (ImportF CCall Unsafe "&" (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))]) + +-- Should generate the same as this: +foreign import ccall unsafe "&" foo1 :: Ptr () diff --git a/testsuite/tests/th/T3319.stderr b/testsuite/tests/th/T3319.stderr new file mode 100644 index 0000000000..214b1eff9f --- /dev/null +++ b/testsuite/tests/th/T3319.stderr @@ -0,0 +1,8 @@ +T3319.hs:1:1: Splicing declarations + return + [ForeignD + (ImportF + CCall Unsafe "&" (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))] + ======> + T3319.hs:8:3-93 + foreign import ccall unsafe "static &foo" foo :: Ptr GHC.Tuple.() diff --git a/testsuite/tests/th/T3395.hs b/testsuite/tests/th/T3395.hs new file mode 100644 index 0000000000..ff3ee4384a --- /dev/null +++ b/testsuite/tests/th/T3395.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-}
+module T3395 where
+
+import Language.Haskell.TH
+
+foo = $(return $
+ CompE
+ [NoBindS (VarE $ mkName "undefined")
+ ,BindS (VarP $ mkName "r1") (VarE $ mkName "undefined") ])
diff --git a/testsuite/tests/th/T3395.stderr b/testsuite/tests/th/T3395.stderr new file mode 100644 index 0000000000..b3d9874a07 --- /dev/null +++ b/testsuite/tests/th/T3395.stderr @@ -0,0 +1,11 @@ + +T3395.hs:6:9: + Illegal last statement of a list comprehension: + r1 <- undefined + (It should be an expression.) + When splicing a TH expression: [r1 <- undefined | undefined] + In the splice: + $(return + $ CompE + [NoBindS (VarE $ mkName "undefined"), + BindS (VarP $ mkName "r1") (VarE $ mkName "undefined")]) diff --git a/testsuite/tests/th/T3467.hs b/testsuite/tests/th/T3467.hs new file mode 100644 index 0000000000..b439470f31 --- /dev/null +++ b/testsuite/tests/th/T3467.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-}
+
+-- Test Trac #3467
+
+module T3467 where
+
+import Language.Haskell.TH
+import Foreign
+
+sizeq :: Name -> Q Exp
+sizeq n = [| sizeOf (undefined :: $(conT n)) |]
diff --git a/testsuite/tests/th/T3572.hs b/testsuite/tests/th/T3572.hs new file mode 100644 index 0000000000..4717fd2735 --- /dev/null +++ b/testsuite/tests/th/T3572.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE EmptyDataDecls #-} + +-- Trac #3572 + +module Main where + +import Language.Haskell.TH +import Language.Haskell.TH.Ppr + +main = putStrLn . pprint =<< runQ [d| data Void |] diff --git a/testsuite/tests/th/T3572.stdout b/testsuite/tests/th/T3572.stdout new file mode 100644 index 0000000000..9df7a449ff --- /dev/null +++ b/testsuite/tests/th/T3572.stdout @@ -0,0 +1 @@ +data Void_0
diff --git a/testsuite/tests/th/T3600.hs b/testsuite/tests/th/T3600.hs new file mode 100644 index 0000000000..84b0eefea1 --- /dev/null +++ b/testsuite/tests/th/T3600.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -ddump-splices #-} +module T3600 where +import T3600a +$(test) diff --git a/testsuite/tests/th/T3600.stderr b/testsuite/tests/th/T3600.stderr new file mode 100644 index 0000000000..2cd8332ce9 --- /dev/null +++ b/testsuite/tests/th/T3600.stderr @@ -0,0 +1,5 @@ +T3600.hs:1:1: Splicing declarations + test + ======> + T3600.hs:5:3-6 + myFunction = (testFun1 [], testFun2 [], testFun2 "x") diff --git a/testsuite/tests/th/T3600a.hs b/testsuite/tests/th/T3600a.hs new file mode 100644 index 0000000000..d328d8e6a7 --- /dev/null +++ b/testsuite/tests/th/T3600a.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE TemplateHaskell #-} +module T3600a where + +import Language.Haskell.TH + +test :: Q [Dec] +test = do + let args1 = [] :: [String] + args2 = [] :: String + args3 = "x" :: String + body = [| (testFun1 args1, testFun2 args2, testFun2 args3) |] + decNm = mkName "myFunction" + (:[]) `fmap` funD decNm [clause [] (normalB body) []] + +testFun1 :: [String] -> String +testFun1 _ = "hello" + +testFun2 :: String -> String +testFun2 _ = "goodbye" diff --git a/testsuite/tests/th/T3845.hs b/testsuite/tests/th/T3845.hs new file mode 100644 index 0000000000..29dc51fbda --- /dev/null +++ b/testsuite/tests/th/T3845.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + +module THBug1 where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +data HCons a b = HCons a b +data HNil = HNil + +mhlt :: [Q Type] -> Q Type +mhlt xss = [t| $(foldThing xss)|] + where + foldThing (x:xs) = [t| HCons $x $(foldThing xs)|] + foldThing [] = [t| HNil |] + +mhlt1 :: [Int] -> Q Exp +mhlt1 xss = [| $(foldThing1 xss) |] + where + foldThing1 (x:xs) = [| x : $(foldThing1 xs)|] + foldThing1 [] = [| [] |] diff --git a/testsuite/tests/th/T3899.hs b/testsuite/tests/th/T3899.hs new file mode 100644 index 0000000000..1b56643d59 --- /dev/null +++ b/testsuite/tests/th/T3899.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module T3899 where + +import T3899a + +f = $(nestedTuple 3) diff --git a/testsuite/tests/th/T3899.stderr b/testsuite/tests/th/T3899.stderr new file mode 100644 index 0000000000..2b4a76a4e5 --- /dev/null +++ b/testsuite/tests/th/T3899.stderr @@ -0,0 +1,2 @@ +T3899.hs:6:7-19: Splicing expression + nestedTuple 3 ======> \ (Cons x (Cons x (Cons x Nil))) -> (x, x, x) diff --git a/testsuite/tests/th/T3899a.hs b/testsuite/tests/th/T3899a.hs new file mode 100644 index 0000000000..2ac985136f --- /dev/null +++ b/testsuite/tests/th/T3899a.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-} +module T3899a where + + +import Language.Haskell.TH +import Control.Monad + +data Cons a b = Cons a b +data Nil = Nil + +nestedTuple n = do + xs <- replicateM n (newName "x") + return $ LamE [foldr (\v prev -> ConP 'Cons [VarP v,prev]) (ConP 'Nil []) xs] + (TupE $ map VarE xs) diff --git a/testsuite/tests/th/T3920.hs b/testsuite/tests/th/T3920.hs new file mode 100644 index 0000000000..4d7ccef509 --- /dev/null +++ b/testsuite/tests/th/T3920.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE EmptyDataDecls, TypeFamilies, TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +type family S :: (* -> (* -> * -> *)) -> (* -> *) -> * + +$(return []) + +test :: String +test = $(do + test <- [d| + type family T :: (* -> (* -> * -> *)) -> (* -> *) -> * |] + blah <- reify ''S + return (LitE (StringL (pprint test ++ "\n" ++ pprint blah)))) + +main = putStrLn test diff --git a/testsuite/tests/th/T3920.stdout b/testsuite/tests/th/T3920.stdout new file mode 100644 index 0000000000..ddc9748894 --- /dev/null +++ b/testsuite/tests/th/T3920.stdout @@ -0,0 +1,2 @@ +type family T_0 :: (* -> * -> * -> *) -> (* -> *) -> *
+type family Main.S :: (* -> * -> * -> *) -> (* -> *) -> *
diff --git a/testsuite/tests/th/T4056.hs b/testsuite/tests/th/T4056.hs new file mode 100644 index 0000000000..211d2b51f4 --- /dev/null +++ b/testsuite/tests/th/T4056.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, RankNTypes, FlexibleContexts #-} + +module T4056 where +import Language.Haskell.TH + +astTest :: Q [Dec] +astTest = [d| + class C t where + op :: [t] -> [t] + op = undefined + |] + +class D t where + bop :: [t] -> [t] + bop = undefined diff --git a/testsuite/tests/th/T4124.hs b/testsuite/tests/th/T4124.hs new file mode 100644 index 0000000000..a3dddda599 --- /dev/null +++ b/testsuite/tests/th/T4124.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module T4124 where + +class Storable a where +data X = X +[d| instance Storable $( [t| X |] ) where |] diff --git a/testsuite/tests/th/T4128.hs b/testsuite/tests/th/T4128.hs new file mode 100644 index 0000000000..961ba4c309 --- /dev/null +++ b/testsuite/tests/th/T4128.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module T4128 where + +import Language.Haskell.TH +class C a where +data X = X +fmap return $ instanceD (cxt []) [t| C $(conT ''X) |] [] diff --git a/testsuite/tests/th/T4135.hs b/testsuite/tests/th/T4135.hs new file mode 100644 index 0000000000..03ff2fe1f9 --- /dev/null +++ b/testsuite/tests/th/T4135.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TypeFamilies,TemplateHaskell #-} +module Bug where + +import Language.Haskell.TH +import System.IO + +class C a where + type T a + +$(do { ds <- [d| + instance C (Maybe a) where + type T (Maybe a) = Char + |] + ; runIO $ do { putStrLn (pprint ds); hFlush stdout } + ; return ds }) + diff --git a/testsuite/tests/th/T4135.stderr b/testsuite/tests/th/T4135.stderr new file mode 100644 index 0000000000..30df0def66 --- /dev/null +++ b/testsuite/tests/th/T4135.stderr @@ -0,0 +1,2 @@ +instance Bug.C (Data.Maybe.Maybe a_0) + where type Bug.T (Data.Maybe.Maybe a_0) = GHC.Types.Char diff --git a/testsuite/tests/th/T4135a.hs b/testsuite/tests/th/T4135a.hs new file mode 100644 index 0000000000..41549cad40 --- /dev/null +++ b/testsuite/tests/th/T4135a.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses, TypeFamilies, + FlexibleInstances, OverlappingInstances #-} + +module T4135a where + +import Control.Monad +import Language.Haskell.TH + +class Foo a where + type FooType a + +createInstance' :: Q Type -> Q Dec +createInstance' t = liftM head [d| + instance Foo $t where + type FooType $t = String |] diff --git a/testsuite/tests/th/T4169.hs b/testsuite/tests/th/T4169.hs new file mode 100644 index 0000000000..1fa3ad7cb7 --- /dev/null +++ b/testsuite/tests/th/T4169.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Crashed GHC 6.12 + +module T4165 where + +import Language.Haskell.TH +class Numeric a where + fromIntegerNum :: a + fromIntegerNum = undefined + +ast :: Q [Dec] +ast = [d| + instance Numeric Int + |] diff --git a/testsuite/tests/th/T4170.hs b/testsuite/tests/th/T4170.hs new file mode 100644 index 0000000000..87ccad6c5b --- /dev/null +++ b/testsuite/tests/th/T4170.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +module T4170 where + +import Language.Haskell.TH + +class LOL a + +lol :: Q [Dec] +lol = [d| + instance LOL Int + |] + +instance LOL Int diff --git a/testsuite/tests/th/T4188.hs b/testsuite/tests/th/T4188.hs new file mode 100644 index 0000000000..73fd925302 --- /dev/null +++ b/testsuite/tests/th/T4188.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TemplateHaskell, GADTs #-}
+
+module T4188 where
+
+import Language.Haskell.TH
+import System.IO
+
+class C a where {}
+
+data T1 a where
+ MkT1 :: a -> b -> T1 a
+
+data T2 a where
+ MkT2 :: (C a, C b) => a -> b -> T2 a
+
+data T3 x where
+ MkT3 :: (C x, C y) => x -> y -> T3 (x,y)
+
+$(do { dec1 <- reify ''T1
+ ; runIO (putStrLn (pprint dec1))
+ ; dec2 <- reify ''T2
+ ; runIO (putStrLn (pprint dec2))
+ ; dec3 <- reify ''T3
+ ; runIO (putStrLn (pprint dec3))
+ ; runIO (hFlush stdout)
+ ; return [] })
+
+
diff --git a/testsuite/tests/th/T4188.stderr b/testsuite/tests/th/T4188.stderr new file mode 100644 index 0000000000..02b997788b --- /dev/null +++ b/testsuite/tests/th/T4188.stderr @@ -0,0 +1,6 @@ +data T4188.T1 a_0 = forall b_1 . T4188.MkT1 a_0 b_1 +data T4188.T2 a_0 + = forall b_1 . (T4188.C a_0, T4188.C b_1) => T4188.MkT2 a_0 b_1 +data T4188.T3 x_0 + = forall x_1 y_2 . (x_0 ~ (x_1, y_2), T4188.C x_1, T4188.C y_2) => + T4188.MkT3 x_1 y_2 diff --git a/testsuite/tests/th/T4233.hs b/testsuite/tests/th/T4233.hs new file mode 100644 index 0000000000..87712d064d --- /dev/null +++ b/testsuite/tests/th/T4233.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} +module T4233 where +import Language.Haskell.TH + +w :: Q Type +w = varT (mkName "w") + +f :: Q Type +f = [t| $w -> $w |] diff --git a/testsuite/tests/th/T4255.hs b/testsuite/tests/th/T4255.hs new file mode 100644 index 0000000000..8509f0ece9 --- /dev/null +++ b/testsuite/tests/th/T4255.hs @@ -0,0 +1,5 @@ + +{-# LANGUAGE TemplateHaskell #-} +module T4255 where + +f x = $([| x |]) diff --git a/testsuite/tests/th/T4255.stderr b/testsuite/tests/th/T4255.stderr new file mode 100644 index 0000000000..e2c4f2f055 --- /dev/null +++ b/testsuite/tests/th/T4255.stderr @@ -0,0 +1,2 @@ +ghc: T4255.hs:2:14-28: You can't use Template Haskell with a profiled compiler +Usage: For basic information, try the `--help' option. diff --git a/testsuite/tests/th/T4364.hs b/testsuite/tests/th/T4364.hs new file mode 100644 index 0000000000..1278c2aed9 --- /dev/null +++ b/testsuite/tests/th/T4364.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module T4364 where + +data Z + +type N0 = $( [t| Z |] ) +type N1 = $( [t| Z |] ) diff --git a/testsuite/tests/th/T4436.hs b/testsuite/tests/th/T4436.hs new file mode 100644 index 0000000000..2d39120eba --- /dev/null +++ b/testsuite/tests/th/T4436.hs @@ -0,0 +1,9 @@ +{-# OPTIONS -XTemplateHaskell #-} +module TH( x ) where +import Language.Haskell.TH + +x = $(return (LitE (StringL "hello\ngoodbye\nand then"))) + + + + diff --git a/testsuite/tests/th/T4436.stderr b/testsuite/tests/th/T4436.stderr new file mode 100644 index 0000000000..1b7fdf6277 --- /dev/null +++ b/testsuite/tests/th/T4436.stderr @@ -0,0 +1,11 @@ +T4436.hs:5:7-56: Splicing expression + return + (LitE + (StringL + "hello\n\ + \goodbye\n\ + \and then")) + ======> + "hello\n\ + \goodbye\n\ + \and then" diff --git a/testsuite/tests/th/T4949.hs b/testsuite/tests/th/T4949.hs new file mode 100644 index 0000000000..a1cb8b4d99 --- /dev/null +++ b/testsuite/tests/th/T4949.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module Foo where + +import Language.Haskell.TH + +x :: Int +x = let args = [| show $(varE (mkName "x")) |] + in undefined diff --git a/testsuite/tests/th/T5037.hs b/testsuite/tests/th/T5037.hs new file mode 100644 index 0000000000..06f42ab88c --- /dev/null +++ b/testsuite/tests/th/T5037.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module T5037 where +import Language.Haskell.TH +import System.IO + +$( do ds <- [d| f :: Maybe Int -> Int + f Nothing = 3 + f (Just x) = $(varE (mkName "x")) + |] + runIO $ (putStrLn (pprint ds) >> hFlush stdout) + return ds ) diff --git a/testsuite/tests/th/T5037.stderr b/testsuite/tests/th/T5037.stderr new file mode 100644 index 0000000000..391368c93b --- /dev/null +++ b/testsuite/tests/th/T5037.stderr @@ -0,0 +1,3 @@ +f_0 :: Data.Maybe.Maybe GHC.Types.Int -> GHC.Types.Int
+f_0 (Data.Maybe.Nothing) = 3
+f_0 (Data.Maybe.Just x_1) = x
diff --git a/testsuite/tests/th/T5126.hs b/testsuite/tests/th/T5126.hs new file mode 100644 index 0000000000..668f82ae0b --- /dev/null +++ b/testsuite/tests/th/T5126.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +module T5126 where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +f :: Q [Dec] +f = + [d| + x2 :: $(conT ''Int) + x2 = undefined + |] diff --git a/testsuite/tests/th/T5217.hs b/testsuite/tests/th/T5217.hs new file mode 100644 index 0000000000..9dd1f1cb3f --- /dev/null +++ b/testsuite/tests/th/T5217.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTs #-}
+
+module T5217 where
+import Language.Haskell.TH
+
+$([d| data T a b where { T1 :: Int -> T Int Char
+ ; T2 :: a -> T a a
+ ; T3 :: a -> T [a] a
+ ; T4 :: a -> b -> T b [a] } |])
+
+
diff --git a/testsuite/tests/th/T5217.stderr b/testsuite/tests/th/T5217.stderr new file mode 100644 index 0000000000..891bb7f94a --- /dev/null +++ b/testsuite/tests/th/T5217.stderr @@ -0,0 +1,14 @@ +T5217.hs:1:1: Splicing declarations
+ [d| data T a b
+ where
+ T1 :: Int -> T Int Char
+ T2 :: a -> T a a
+ T3 :: a -> T [a] a
+ T4 :: a -> b -> T b [a] |]
+ ======>
+ T5217.hs:(6,3)-(9,53)
+ data T a b
+ = (b ~ Char, a ~ Int) => T1 Int |
+ b ~ a => T2 a |
+ a ~ [b] => T3 b |
+ forall a. b ~ [a] => T4 a a
diff --git a/testsuite/tests/th/T5290.hs b/testsuite/tests/th/T5290.hs new file mode 100644 index 0000000000..7973a13d24 --- /dev/null +++ b/testsuite/tests/th/T5290.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T5290 where + +import Language.Haskell.TH + +$( let n = mkName "T" + in return [DataD [] n [] [NormalC n [(Unpacked,ConT ''Int)]] []] ) diff --git a/testsuite/tests/th/T5290.stderr b/testsuite/tests/th/T5290.stderr new file mode 100644 index 0000000000..9f7067be06 --- /dev/null +++ b/testsuite/tests/th/T5290.stderr @@ -0,0 +1,6 @@ +T5290.hs:1:1: Splicing declarations + let n = mkName "T" + in return [DataD [] n [] [NormalC n [(Unpacked, ConT ''Int)]] []] + ======> + T5290.hs:(7,4)-(8,67) + data T = T {-# UNPACK #-} !Int diff --git a/testsuite/tests/th/T5358.hs b/testsuite/tests/th/T5358.hs new file mode 100644 index 0000000000..6a1d8179c4 --- /dev/null +++ b/testsuite/tests/th/T5358.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE TemplateHaskell #-} +module T5358 where + +import Language.Haskell.TH + +t1, t2 :: Int +t1 x = x +t2 x = x + +prop_x1 x = t1 x == t2 x + +$(return []) + +runTests = $( do VarI _ t _ _ <- reify (mkName "prop_x1") + error $ ("runTest called error: " ++ pprint t) + ) diff --git a/testsuite/tests/th/T5358.stderr b/testsuite/tests/th/T5358.stderr new file mode 100644 index 0000000000..fd7e32c58a --- /dev/null +++ b/testsuite/tests/th/T5358.stderr @@ -0,0 +1,9 @@ + +T5358.hs:14:15: + Exception when trying to run compile-time code: + runTest called error: forall t_0 . t_0 -> GHC.Types.Bool + Code: do { VarI _ t _ _ <- reify (mkName "prop_x1"); + ($) error ((++) "runTest called error: " pprint t) } + In the splice: + $(do { VarI _ t _ _ <- reify (mkName "prop_x1"); + error $ ("runTest called error: " ++ pprint t) }) diff --git a/testsuite/tests/th/T5362.hs b/testsuite/tests/th/T5362.hs new file mode 100644 index 0000000000..4a1e67fb4a --- /dev/null +++ b/testsuite/tests/th/T5362.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T5362() where + +import System.IO +import Language.Haskell.TH + +$( + do fName <- newName "f" + gName <- newName "g" + let gExp = varE gName + + sdf <- sigD fName [t| () |] + sdg <- sigD gName [t| () |] + fdf <- funD fName [clause [] (normalB [| undefined $gExp |]) []] + fdg <- funD gName [clause [] (normalB [| undefined |]) []] + let ds = [sdf, fdf, sdg, fdg] + runIO $ do { putStrLn (pprint ds); hFlush stdout } + return ds + ) + + + diff --git a/testsuite/tests/th/T5362.stderr b/testsuite/tests/th/T5362.stderr new file mode 100644 index 0000000000..99e81086d2 --- /dev/null +++ b/testsuite/tests/th/T5362.stderr @@ -0,0 +1,4 @@ +f_0 :: () +f_0 = GHC.Err.undefined g_1 +g_1 :: () +g_1 = GHC.Err.undefined diff --git a/testsuite/tests/th/T5379.hs b/testsuite/tests/th/T5379.hs new file mode 100644 index 0000000000..d978032534 --- /dev/null +++ b/testsuite/tests/th/T5379.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +$( [d| g = 0 + h = $( return $ LamE [VarP (mkName "g")] (VarE 'g) ) |] ) + -- The 'g should bind to the g=0 definition + +-- Should print 0, not 1! +main = print (h 1) diff --git a/testsuite/tests/th/T5379.stdout b/testsuite/tests/th/T5379.stdout new file mode 100644 index 0000000000..573541ac97 --- /dev/null +++ b/testsuite/tests/th/T5379.stdout @@ -0,0 +1 @@ +0 diff --git a/testsuite/tests/th/T5404.hs b/testsuite/tests/th/T5404.hs new file mode 100644 index 0000000000..18f21d6914 --- /dev/null +++ b/testsuite/tests/th/T5404.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-}
+
+module T5404 where
+
+foobar :: Int
+foobar = $([|
+ let
+ bar :: Int
+ bar = 5
+ in bar
+ |])
+
diff --git a/testsuite/tests/th/T5410.hs b/testsuite/tests/th/T5410.hs new file mode 100644 index 0000000000..da9e51aa7f --- /dev/null +++ b/testsuite/tests/th/T5410.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+$([d| instance Show (a -> b) where
+ showsPrec _ _ = showString "<function>"
+ |])
+
+main = print id
\ No newline at end of file diff --git a/testsuite/tests/th/T5410.stdout b/testsuite/tests/th/T5410.stdout new file mode 100644 index 0000000000..cc9bc03d31 --- /dev/null +++ b/testsuite/tests/th/T5410.stdout @@ -0,0 +1 @@ +<function>
diff --git a/testsuite/tests/th/T5434.hs b/testsuite/tests/th/T5434.hs new file mode 100644 index 0000000000..63047229ac --- /dev/null +++ b/testsuite/tests/th/T5434.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T5434 where + +import T5434a + +$(genShadow1) + +v :: Bool +v = True + +$(genShadow2) diff --git a/testsuite/tests/th/T5434.stderr b/testsuite/tests/th/T5434.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/th/T5434.stderr diff --git a/testsuite/tests/th/T5434a.hs b/testsuite/tests/th/T5434a.hs new file mode 100644 index 0000000000..f4d052ca2b --- /dev/null +++ b/testsuite/tests/th/T5434a.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T5434a where + +import Language.Haskell.TH + +genShadow1 :: Q [Dec] +genShadow1 = + [d| x :: Char + x = 'x' + |] + +genShadow2 :: Q [Dec] +genShadow2 = + [d| z :: Char + z = succ x + where x = 'y' + |] diff --git a/testsuite/tests/th/T5452.hs b/testsuite/tests/th/T5452.hs new file mode 100644 index 0000000000..b727df5a47 --- /dev/null +++ b/testsuite/tests/th/T5452.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell, KindSignatures, FlexibleInstances #-} + +module T5452 where +import Language.Haskell.TH + +class C (f :: * -> *) +class D (f :: * -> *) + +instance C ((,) Int) + +$(do { ClassI _ [inst_dec] <- reify ''C + ; let InstanceD cxt (AppT _ ty) _ = inst_dec + ; return [InstanceD cxt + (foldl AppT (ConT ''D) [ty]) + [] + ] }) + diff --git a/testsuite/tests/th/T5508.hs b/testsuite/tests/th/T5508.hs new file mode 100644 index 0000000000..ee82e8ff9b --- /dev/null +++ b/testsuite/tests/th/T5508.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T5508 where + +import Language.Haskell.TH + +thb = $(do { let x = mkName "x" + v = return (LamE [VarP x] $ VarE x) + ; [| $v . id |] }) diff --git a/testsuite/tests/th/T5508.stderr b/testsuite/tests/th/T5508.stderr new file mode 100644 index 0000000000..3cd9bf27ed --- /dev/null +++ b/testsuite/tests/th/T5508.stderr @@ -0,0 +1,7 @@ +T5508.hs:(7,9)-(9,28): Splicing expression + do { let x = mkName "x" + v = return (LamE [VarP x] $ VarE x); + [| $v . id |] + pending(rn) [<splice, v>] } + ======> + ((\ x -> x) . id) diff --git a/testsuite/tests/th/T5555.hs b/testsuite/tests/th/T5555.hs new file mode 100644 index 0000000000..a874a7349c --- /dev/null +++ b/testsuite/tests/th/T5555.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +import qualified T5555_Lib as L + +test :: String +test = [L.s|hello world|] + +main :: IO () +main = putStrLn test diff --git a/testsuite/tests/th/T5555.stdout b/testsuite/tests/th/T5555.stdout new file mode 100644 index 0000000000..3b18e512db --- /dev/null +++ b/testsuite/tests/th/T5555.stdout @@ -0,0 +1 @@ +hello world diff --git a/testsuite/tests/th/T5555_Lib.hs b/testsuite/tests/th/T5555_Lib.hs new file mode 100644 index 0000000000..66c18d228b --- /dev/null +++ b/testsuite/tests/th/T5555_Lib.hs @@ -0,0 +1,10 @@ +module T5555_Lib(s) where + +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +s :: QuasiQuoter +s = QuasiQuoter expr undefined undefined undefined + +expr :: String -> Q Exp +expr = stringE diff --git a/testsuite/tests/th/T5597.hs b/testsuite/tests/th/T5597.hs new file mode 100644 index 0000000000..b6ab9da6d8 --- /dev/null +++ b/testsuite/tests/th/T5597.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +module T5597 where +import T5597a( f ) + +g = $(f [t| (Int, Int) |]) diff --git a/testsuite/tests/th/T5597a.hs b/testsuite/tests/th/T5597a.hs new file mode 100644 index 0000000000..eeea7f52c1 --- /dev/null +++ b/testsuite/tests/th/T5597a.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module T5597a where +import Language.Haskell.TH + +f :: Q Type -> Q Exp +f t = [| (3,4) :: $t |] diff --git a/testsuite/tests/th/T5665.hs b/testsuite/tests/th/T5665.hs new file mode 100644 index 0000000000..2434e43427 --- /dev/null +++ b/testsuite/tests/th/T5665.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-}
+
+module T5665 where
+
+import T5665a
+
+data Record = Record { recordField :: Int }
+
+$(doSomeTH "SomeType" ''Int)
diff --git a/testsuite/tests/th/T5665a.hs b/testsuite/tests/th/T5665a.hs new file mode 100644 index 0000000000..eba5a1a168 --- /dev/null +++ b/testsuite/tests/th/T5665a.hs @@ -0,0 +1,6 @@ +module T5665a where
+
+import Language.Haskell.TH
+
+doSomeTH s tp = return [NewtypeD [] n [] (NormalC n [(NotStrict, ConT tp)]) []]
+ where n = mkName s
diff --git a/testsuite/tests/th/T5700.hs b/testsuite/tests/th/T5700.hs new file mode 100644 index 0000000000..542058d87e --- /dev/null +++ b/testsuite/tests/th/T5700.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +module T5700 where + +import T5700a + +data D = D + +$(mkC ''D) diff --git a/testsuite/tests/th/T5700.stderr b/testsuite/tests/th/T5700.stderr new file mode 100644 index 0000000000..dd1ece7583 --- /dev/null +++ b/testsuite/tests/th/T5700.stderr @@ -0,0 +1,7 @@ +T5700.hs:1:1: Splicing declarations + mkC ''D + ======> + T5700.hs:8:3-9 + instance C D where + {-# INLINE inlinable #-} + inlinable _ = GHC.Tuple.() diff --git a/testsuite/tests/th/T5700a.hs b/testsuite/tests/th/T5700a.hs new file mode 100644 index 0000000000..31dbfa9120 --- /dev/null +++ b/testsuite/tests/th/T5700a.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +module T5700a where + +import Language.Haskell.TH + +class C a where + inlinable :: a -> () + +mkC :: Name -> Q [Dec] +mkC n = return + [InstanceD [] (AppT (ConT ''C) (ConT n)) + [ FunD 'inlinable [Clause [WildP] (NormalB (ConE '())) []], + PragmaD (InlineP 'inlinable Inline FunLike AllPhases) + ] + ] diff --git a/testsuite/tests/th/T5721.hs b/testsuite/tests/th/T5721.hs new file mode 100644 index 0000000000..9fcecc74a6 --- /dev/null +++ b/testsuite/tests/th/T5721.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} + +module T5371 where +import Language.Haskell.TH + +f :: a -> Name +f (x :: a) = ''a diff --git a/testsuite/tests/th/T5737.hs b/testsuite/tests/th/T5737.hs new file mode 100644 index 0000000000..1458c78517 --- /dev/null +++ b/testsuite/tests/th/T5737.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-}
+module T5737 where
+
+import Language.Haskell.TH
+makeAlpha n = [d| data Alpha = Alpha $(conT n) deriving (Show, Read) |]
diff --git a/testsuite/tests/th/T5795.hs b/testsuite/tests/th/T5795.hs new file mode 100644 index 0000000000..ea41ce0555 --- /dev/null +++ b/testsuite/tests/th/T5795.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module T5795 where + +import Language.Haskell.TH + +ty :: Q Type +ty = [t| Int |] + +f :: $ty +f = undefined diff --git a/testsuite/tests/th/T5795.stderr b/testsuite/tests/th/T5795.stderr new file mode 100644 index 0000000000..757ba72cfd --- /dev/null +++ b/testsuite/tests/th/T5795.stderr @@ -0,0 +1,6 @@ + +T5795.hs:9:6: + GHC stage restriction: + ‛ty’ is used in a top-level splice or annotation, + and must be imported, not defined locally + In the splice: $ty diff --git a/testsuite/tests/th/T5882.hs b/testsuite/tests/th/T5882.hs new file mode 100644 index 0000000000..73805bf082 --- /dev/null +++ b/testsuite/tests/th/T5882.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE GADTSyntax, TemplateHaskell, KindSignatures #-} + +module T5882 where +data Foo :: * -> * where + Foo :: a -> Foo a + +$( [d| data Bar :: * -> * where + Bar :: a -> Bar a + |] ) + +f (Bar x) = Foo x diff --git a/testsuite/tests/th/T5883.hs b/testsuite/tests/th/T5883.hs new file mode 100644 index 0000000000..c33cc69ab6 --- /dev/null +++ b/testsuite/tests/th/T5883.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +module T5883 where + +import Language.Haskell.TH + +$( [d| + data Unit = Unit + instance Show Unit where + show _ = "" + {-# INLINE show #-} + |]) diff --git a/testsuite/tests/th/T5883.stderr b/testsuite/tests/th/T5883.stderr new file mode 100644 index 0000000000..0b0f705823 --- /dev/null +++ b/testsuite/tests/th/T5883.stderr @@ -0,0 +1,12 @@ +T5883.hs:1:1: Splicing declarations + [d| data Unit = Unit + + instance Show Unit where + show _ = "" + {-# INLINE show #-} |] + ======> + T5883.hs:(7,4)-(12,4) + data Unit = Unit + instance Show Unit where + {-# INLINE show #-} + show _ = "" diff --git a/testsuite/tests/th/T5886.hs b/testsuite/tests/th/T5886.hs new file mode 100644 index 0000000000..5465815ae3 --- /dev/null +++ b/testsuite/tests/th/T5886.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module T5886 where + +import T5886a + +$(bang) diff --git a/testsuite/tests/th/T5886a.hs b/testsuite/tests/th/T5886a.hs new file mode 100644 index 0000000000..4d2cec6207 --- /dev/null +++ b/testsuite/tests/th/T5886a.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module T5886a where + +import Language.Haskell.TH + +class C α where + type AT α ∷ ★ + +bang ∷ DecsQ +bang = return [InstanceD [] (AppT (ConT ''C) (ConT ''Int)) + [TySynInstD ''AT (TySynEqn [ConT ''Int] (ConT ''Int))]] diff --git a/testsuite/tests/th/T5968.hs b/testsuite/tests/th/T5968.hs new file mode 100644 index 0000000000..d483d84dcf --- /dev/null +++ b/testsuite/tests/th/T5968.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module T5968 where + +data Bar a = Bar $( [t| a |] ) + + diff --git a/testsuite/tests/th/T5971.hs b/testsuite/tests/th/T5971.hs new file mode 100644 index 0000000000..bca58ea0c7 --- /dev/null +++ b/testsuite/tests/th/T5971.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} +module T5971 where + +import Language.Haskell.TH + +_ = $(newName "x" >>= varE) diff --git a/testsuite/tests/th/T5971.stderr b/testsuite/tests/th/T5971.stderr new file mode 100644 index 0000000000..9d647d1ea7 --- /dev/null +++ b/testsuite/tests/th/T5971.stderr @@ -0,0 +1,7 @@ + +T5971.hs:6:7: + The exact Name ‛x’ is not in scope + Probable cause: you used a unique Template Haskell name (NameU), + perhaps via newName, but did not bind it + If that's it, then -ddump-splices might be useful + In the splice: $(newName "x" >>= varE) diff --git a/testsuite/tests/th/T5976.hs b/testsuite/tests/th/T5976.hs new file mode 100644 index 0000000000..aa388c764e --- /dev/null +++ b/testsuite/tests/th/T5976.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TemplateHaskell #-} + +$( error ("foo " ++ error "bar") ) diff --git a/testsuite/tests/th/T5976.stderr b/testsuite/tests/th/T5976.stderr new file mode 100644 index 0000000000..64cf33acef --- /dev/null +++ b/testsuite/tests/th/T5976.stderr @@ -0,0 +1,5 @@ + +T5976.hs:1:1: + Exception when trying to run compile-time code: + bar + Code: error ((++) "foo " error "bar") diff --git a/testsuite/tests/th/T5984.hs b/testsuite/tests/th/T5984.hs new file mode 100644 index 0000000000..63f21b6548 --- /dev/null +++ b/testsuite/tests/th/T5984.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T5984 where + +import T5984_Lib + +$nt +$dt diff --git a/testsuite/tests/th/T5984.stderr b/testsuite/tests/th/T5984.stderr new file mode 100644 index 0000000000..50c7cbfdd0 --- /dev/null +++ b/testsuite/tests/th/T5984.stderr @@ -0,0 +1,10 @@ +T5984.hs:1:1: Splicing declarations + nt + ======> + T5984.hs:7:1-3 + newtype Foo = Foo Int +T5984.hs:1:1: Splicing declarations + dt + ======> + T5984.hs:8:1-3 + data Bar = Bar Int diff --git a/testsuite/tests/th/T5984_Lib.hs b/testsuite/tests/th/T5984_Lib.hs new file mode 100644 index 0000000000..c3abfa21f9 --- /dev/null +++ b/testsuite/tests/th/T5984_Lib.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T5984_Lib where + +import Language.Haskell.TH + +nt :: Q [Dec] +nt = return [NewtypeD [] foo [] (NormalC foo [(NotStrict, ConT ''Int)]) []] + where foo = mkName "Foo" + +dt :: Q [Dec] +dt = return [DataD [] bar [] [NormalC bar [(NotStrict, ConT ''Int)]] []] + where bar = mkName "Bar" diff --git a/testsuite/tests/th/T6005.hs b/testsuite/tests/th/T6005.hs new file mode 100644 index 0000000000..666aecf1ec --- /dev/null +++ b/testsuite/tests/th/T6005.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell, DataKinds, PolyKinds #-} + +module T6005 where + +$( [d| + data Nat = Zero | Succ Nat + data Proxy a = Proxy + foo :: Proxy 'Zero + foo = foo + |]) diff --git a/testsuite/tests/th/T6005a.hs b/testsuite/tests/th/T6005a.hs new file mode 100644 index 0000000000..a206913ff3 --- /dev/null +++ b/testsuite/tests/th/T6005a.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T6005a where + +-- The point here is that we don't need to generate the +-- derived code inside the bracket; doing so is troublesome +-- and it should never be type incorrect, so it's also a +-- waste of effort. + +$( [d| + data Nat = Zero | Succ Nat deriving( Show ) + |] ) + +foo :: String +foo = show (Succ Zero) diff --git a/testsuite/tests/th/T6062.hs b/testsuite/tests/th/T6062.hs new file mode 100644 index 0000000000..330b3f2b8b --- /dev/null +++ b/testsuite/tests/th/T6062.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE TemplateHaskell #-} +module T6062 where +x = [| False True |] diff --git a/testsuite/tests/th/T6114.hs b/testsuite/tests/th/T6114.hs new file mode 100644 index 0000000000..bea852c2b6 --- /dev/null +++ b/testsuite/tests/th/T6114.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module T6114 where +import Language.Haskell.TH +import Control.Monad.Instances () + +instanceVar = $(do + xName <- newName "x" + instanceType <- [t| $(varT xName) |] + _ <- reifyInstances ''Eq [instanceType] + undefined + ) diff --git a/testsuite/tests/th/T6114.stderr b/testsuite/tests/th/T6114.stderr new file mode 100644 index 0000000000..6267aa6405 --- /dev/null +++ b/testsuite/tests/th/T6114.stderr @@ -0,0 +1,12 @@ + +T6114.hs:6:17: + The exact Name ‛x’ is not in scope + Probable cause: you used a unique Template Haskell name (NameU), + perhaps via newName, but did not bind it + If that's it, then -ddump-splices might be useful + In the argument of reifyInstances: GHC.Classes.Eq x_0 + In the splice: + $(do { xName <- newName "x"; + instanceType <- [t| $(varT xName) |]; + _ <- reifyInstances ''Eq [instanceType]; + .... }) diff --git a/testsuite/tests/th/T7064.hs b/testsuite/tests/th/T7064.hs new file mode 100644 index 0000000000..2ce08c1dfd --- /dev/null +++ b/testsuite/tests/th/T7064.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import T7064a + +$(decls) + +main = hsToTh diff --git a/testsuite/tests/th/T7064.stdout b/testsuite/tests/th/T7064.stdout new file mode 100644 index 0000000000..3cbac10ac9 --- /dev/null +++ b/testsuite/tests/th/T7064.stdout @@ -0,0 +1,26 @@ +f1_0 x_1 = 1 +f2_0 x_1 = 2 +f3_0 x_1 = 3 +{-# INLINE f1_0 #-} +{-# INLINE [2] f2_0 #-} +{-# INLINE CONLIKE [~2] f3_0 #-} +g1_0 x_1 = 1 +g2_0 x_1 = 2 +g3_0 x_1 = 3 +{-# SPECIALISE g1_0 :: GHC.Types.Int -> GHC.Types.Int #-} +{-# SPECIALISE [2] g2_0 :: GHC.Types.Int -> GHC.Types.Int #-} +{-# SPECIALISE INLINE [~2] g3_0 :: + GHC.Types.Int -> GHC.Types.Int #-} +data T_0 a_1 = T_2 a_1 +instance GHC.Classes.Eq a_0 => GHC.Classes.Eq (T_1 a_0) + where (GHC.Classes.==) (T_2 x_3) (T_2 y_4) = x_3 GHC.Classes.== y_4 + {-# SPECIALISE instance GHC.Classes.Eq (T_1 GHC.Types.Int) #-} +{-# RULES "rule1" + GHC.Real.fromIntegral + = GHC.Base.id :: forall a_0 . a_0 -> a_0 #-} +{-# RULES "rule2" [1] + forall (x_0 :: a_1) . GHC.Real.fromIntegral x_0 + = x_0 #-} +{-# RULES "rule3" [~1] + forall (x_0 :: a_1) . GHC.Real.fromIntegral x_0 + = x_0 #-} diff --git a/testsuite/tests/th/T7064a.hs b/testsuite/tests/th/T7064a.hs new file mode 100644 index 0000000000..a61201d85c --- /dev/null +++ b/testsuite/tests/th/T7064a.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T7064a (decls, hsToTh) where + +import Language.Haskell.TH + +decls = [d| + f1 x = 1; f2 x = 2; f3 x = 3 + {-# INLINE f1 #-} + {-# INLINE [2] f2 #-} + {-# INLINE CONLIKE [~2] f3 #-} + g1 x = 1; g2 x = 2; g3 x = 3 + {-# SPECIALISE g1 :: Int -> Int #-} + {-# SPECIALISE [2] g2 :: Int -> Int #-} + {-# SPECIALISE INLINE [~2] g3 :: Int -> Int #-} + data T a = T a + instance Eq a => Eq (T a) where + {-# SPECIALISE instance Eq (T Int) #-} + (T x) == (T y) = x == y + {-# RULES + "rule1" fromIntegral = id :: a -> a ; + "rule2" [1] forall (x :: a) . fromIntegral x = x ; + "rule3" [~1] forall (x :: a) . fromIntegral x = x + #-} + |] + +hsToTh = do + decls' <- runQ decls + mapM (print . ppr) decls' diff --git a/testsuite/tests/th/T7092.hs b/testsuite/tests/th/T7092.hs new file mode 100644 index 0000000000..78c4a78a57 --- /dev/null +++ b/testsuite/tests/th/T7092.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fwarn-name-shadowing #-} + +-- Should not produce a name-shadowing warning (GHC 7.4 did) + +module T7092 where + +import T7092a + +blah = $(code) diff --git a/testsuite/tests/th/T7092a.hs b/testsuite/tests/th/T7092a.hs new file mode 100644 index 0000000000..abe7931b51 --- /dev/null +++ b/testsuite/tests/th/T7092a.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +module T7092a where + +import Language.Haskell.TH + +code :: Q Exp +code = do + n1 <- newName "foo" + n2 <- newName "foo" + letE [valD (varP n1) (normalB [| (1 :: Int) |]) []] + $ letE [valD (varP n2) (normalB [| (2 :: Int) |]) []] + $ appE (appE [| ((+) :: Int -> Int -> Int)|] (varE n1)) (varE n2) diff --git a/testsuite/tests/th/T7276.hs b/testsuite/tests/th/T7276.hs new file mode 100644 index 0000000000..59a9ec0e8c --- /dev/null +++ b/testsuite/tests/th/T7276.hs @@ -0,0 +1,6 @@ +{-# OPTIONS_GHC -fdefer-type-errors #-} +{-# LANGUAGE TemplateHaskell #-} + +module T7276 where + +x = $( [d| y = 3 |] ) diff --git a/testsuite/tests/th/T7276.stderr b/testsuite/tests/th/T7276.stderr new file mode 100644 index 0000000000..7b76966617 --- /dev/null +++ b/testsuite/tests/th/T7276.stderr @@ -0,0 +1,8 @@ + +T7276.hs:6:8: + Couldn't match type ‛[Language.Haskell.TH.Syntax.Dec]’ + with ‛Language.Haskell.TH.Syntax.Exp’ + Expected type: Language.Haskell.TH.Lib.ExpQ + Actual type: Language.Haskell.TH.Lib.DecsQ + In the expression: [d| y = 3 |] + In the splice: $([d| y = 3 |]) diff --git a/testsuite/tests/th/T7276a.script b/testsuite/tests/th/T7276a.script new file mode 100644 index 0000000000..5ebd911233 --- /dev/null +++ b/testsuite/tests/th/T7276a.script @@ -0,0 +1,4 @@ +:set -XTemplateHaskell -fdefer-type-errors +import Language.Haskell.TH +let x = [d|a = ()|] :: Q Exp +:t $x diff --git a/testsuite/tests/th/T7276a.stdout b/testsuite/tests/th/T7276a.stdout new file mode 100644 index 0000000000..2edeaaeb3f --- /dev/null +++ b/testsuite/tests/th/T7276a.stdout @@ -0,0 +1,19 @@ + +<interactive>:4:9: Warning: + Couldn't match type ‛[Dec]’ with ‛Exp’ + Expected type: Q Exp + Actual type: DecsQ + In the expression: [d| a = () |] :: Q Exp + In an equation for ‛x’: x = [d| a = () |] :: Q Exp + +<interactive>:1:1: + Exception when trying to run compile-time code: + <interactive>:4:9: + Couldn't match type ‛[Dec]’ with ‛Exp’ + Expected type: Q Exp + Actual type: DecsQ + In the expression: [d| a = () |] :: Q Exp + In an equation for ‛x’: x = [d| a = () |] :: Q Exp +(deferred type error) + Code: x + In the splice: $x diff --git a/testsuite/tests/th/T7445.hs b/testsuite/tests/th/T7445.hs new file mode 100644 index 0000000000..03371e3747 --- /dev/null +++ b/testsuite/tests/th/T7445.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T7445 where +import T7445a + +moo = $(foo) diff --git a/testsuite/tests/th/T7445a.hs b/testsuite/tests/th/T7445a.hs new file mode 100644 index 0000000000..75719a16d9 --- /dev/null +++ b/testsuite/tests/th/T7445a.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-} +module T7445a ( foo ) where + +import Data.Data +import Language.Haskell.TH.Quote +import Language.Haskell.TH + +data Expr + = IntExpr Integer + deriving (Show, Typeable, Data) + +foo :: ExpQ +foo = dataToExpQ (const Nothing) (IntExpr 1) diff --git a/testsuite/tests/th/T7477.hs b/testsuite/tests/th/T7477.hs new file mode 100644 index 0000000000..4e4d018397 --- /dev/null +++ b/testsuite/tests/th/T7477.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE DataKinds, KindSignatures, PolyKinds, TypeFamilies, TemplateHaskell #-} + +module T7477 where + +import Language.Haskell.TH + +type family F (a :: k) +type instance F Int = Bool + +$( do { info <- reifyInstances ''F [ConT ''Int] + ; reportWarning (pprint info) + ; return [] }) diff --git a/testsuite/tests/th/T7477.stderr b/testsuite/tests/th/T7477.stderr new file mode 100644 index 0000000000..f6a9e0de89 --- /dev/null +++ b/testsuite/tests/th/T7477.stderr @@ -0,0 +1,3 @@ + +T7477.hs:10:4: Warning: + type instance T7477.F GHC.Prim.* GHC.Types.Int = GHC.Types.Bool diff --git a/testsuite/tests/th/T7532.hs b/testsuite/tests/th/T7532.hs new file mode 100644 index 0000000000..3a641ea97a --- /dev/null +++ b/testsuite/tests/th/T7532.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -ddump-rn -ddump-splices #-} +{-# LANGUAGE TemplateHaskell, TypeFamilies #-} +module T7532 where + +import Language.Haskell.TH +import T7532a + +instance C Bool where + data D Bool = MkD + +$(bang) diff --git a/testsuite/tests/th/T7532.stderr b/testsuite/tests/th/T7532.stderr new file mode 100644 index 0000000000..0890ae2f89 --- /dev/null +++ b/testsuite/tests/th/T7532.stderr @@ -0,0 +1,16 @@ + +==================== Renamer ==================== +instance C Bool where + data D Bool = T7532.MkD + +T7532.hs:1:1: Splicing declarations + bang + ======> + T7532.hs:11:3-6 + instance C Int where + data D Int = T + +==================== Renamer ==================== +instance C Int where + data D Int = T7532.T + diff --git a/testsuite/tests/th/T7532a.hs b/testsuite/tests/th/T7532a.hs new file mode 100644 index 0000000000..5a5f45adb7 --- /dev/null +++ b/testsuite/tests/th/T7532a.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module T7532a where + +import Language.Haskell.TH + +class C a where + data D a + +bang :: DecsQ +bang = return [ + InstanceD [] (AppT (ConT ''C) (ConT ''Int)) [ + DataInstD [] ''D [ConT ''Int] [ + NormalC (mkName "T") []] []]] diff --git a/testsuite/tests/th/T7667.hs b/testsuite/tests/th/T7667.hs new file mode 100644 index 0000000000..59287f1448 --- /dev/null +++ b/testsuite/tests/th/T7667.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell, TypeOperators #-} + +module T7667 where + +import Language.Haskell.TH + +$( return [ TySynD (mkName "+") [PlainTV (mkName "a"), PlainTV (mkName "b")] + (AppT (AppT (ConT ''Either) (VarT $ mkName "a")) (VarT $ mkName "b")) ] )
\ No newline at end of file diff --git a/testsuite/tests/th/T7667a.hs b/testsuite/tests/th/T7667a.hs new file mode 100644 index 0000000000..9f829a0e6d --- /dev/null +++ b/testsuite/tests/th/T7667a.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T7667a where + +import Language.Haskell.TH + + -- to be correct, this should be ConE, not VarE! +false = $( return $ VarE (mkName "False") )
\ No newline at end of file diff --git a/testsuite/tests/th/T7667a.stderr b/testsuite/tests/th/T7667a.stderr new file mode 100644 index 0000000000..7e85d06017 --- /dev/null +++ b/testsuite/tests/th/T7667a.stderr @@ -0,0 +1,5 @@ + +T7667a.hs:8:12: + Illegal variable name: ‛False’ + When splicing a TH expression: False + In the splice: $(return $ VarE (mkName "False")) diff --git a/testsuite/tests/th/T7681.hs b/testsuite/tests/th/T7681.hs new file mode 100644 index 0000000000..c7f43e7798 --- /dev/null +++ b/testsuite/tests/th/T7681.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE EmptyCase, TemplateHaskell, LambdaCase #-} + +module T7681 where + +data Void + +foo :: Void -> a +foo x = $( [| case x of {} |] ) + +bar :: Void -> a +bar = $( [| \case {} |] ) + diff --git a/testsuite/tests/th/T7910.hs b/testsuite/tests/th/T7910.hs new file mode 100644 index 0000000000..d62afc8160 --- /dev/null +++ b/testsuite/tests/th/T7910.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE TemplateHaskell #-} +module Main where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax + +class C a +instance C Int + +type D a = C a + +$(return []) + +main = print $( + do isCInst <- isInstance ''C [ConT ''Int] + isDInst <- isInstance ''D [ConT ''Int] + lift (isCInst,isDInst)) diff --git a/testsuite/tests/th/T7910.stdout b/testsuite/tests/th/T7910.stdout new file mode 100644 index 0000000000..1fa0b54b36 --- /dev/null +++ b/testsuite/tests/th/T7910.stdout @@ -0,0 +1 @@ +(True,True) diff --git a/testsuite/tests/th/T8028.hs b/testsuite/tests/th/T8028.hs new file mode 100644 index 0000000000..fec993a596 --- /dev/null +++ b/testsuite/tests/th/T8028.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} + +module T8028 where + +import T8028a + +$(x)
\ No newline at end of file diff --git a/testsuite/tests/th/T8028.stderr b/testsuite/tests/th/T8028.stderr new file mode 100644 index 0000000000..20cf1c7cf2 --- /dev/null +++ b/testsuite/tests/th/T8028.stderr @@ -0,0 +1,4 @@ + +T8028.hs:7:3: + Illegal empty closed type family + When splicing a TH declaration: type family F_0 where diff --git a/testsuite/tests/th/T8028a.hs b/testsuite/tests/th/T8028a.hs new file mode 100644 index 0000000000..928a96e52c --- /dev/null +++ b/testsuite/tests/th/T8028a.hs @@ -0,0 +1,6 @@ +module T8028a where + +import Language.Haskell.TH + +x = do n <- newName "F" + return [ClosedTypeFamilyD n [] Nothing []] diff --git a/testsuite/tests/th/T8186.hs b/testsuite/tests/th/T8186.hs new file mode 100644 index 0000000000..1580a9cac4 --- /dev/null +++ b/testsuite/tests/th/T8186.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell, ParallelListComp #-} + +module Main where + +list = [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,6..50] ] + +list' = $( [| [ (x,y) | x <- [1..10], x `mod` 2 == 0 | y <- [2,6..50] ] |] ) + +main = do putStrLn (show list) + putStrLn (show list') + putStrLn $ show (list == list')
\ No newline at end of file diff --git a/testsuite/tests/th/T8186.stdout b/testsuite/tests/th/T8186.stdout new file mode 100644 index 0000000000..cd4aa8bda3 --- /dev/null +++ b/testsuite/tests/th/T8186.stdout @@ -0,0 +1,3 @@ +[(2,2),(4,6),(6,10),(8,14),(10,18)] +[(2,2),(4,6),(6,10),(8,14),(10,18)] +True diff --git a/testsuite/tests/th/T8333.hs b/testsuite/tests/th/T8333.hs new file mode 100644 index 0000000000..e81f07c53e --- /dev/null +++ b/testsuite/tests/th/T8333.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + +main :: IO () +main = return () diff --git a/testsuite/tests/th/T8333.stdout b/testsuite/tests/th/T8333.stdout new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/th/T8333.stdout diff --git a/testsuite/tests/th/T8412.hs b/testsuite/tests/th/T8412.hs new file mode 100644 index 0000000000..074bb50121 --- /dev/null +++ b/testsuite/tests/th/T8412.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell #-} + +import Language.Haskell.TH + +type T = $(return $ LitT $ NumTyLit (-1)) diff --git a/testsuite/tests/th/T8412.stderr b/testsuite/tests/th/T8412.stderr new file mode 100644 index 0000000000..64e2d41694 --- /dev/null +++ b/testsuite/tests/th/T8412.stderr @@ -0,0 +1,4 @@ + +T8412.hs:5:12: + Illegal literal in type (type literals must not be negative): -1 + In the splice: $(return $ LitT $ NumTyLit (- 1)) diff --git a/testsuite/tests/th/T8455.hs b/testsuite/tests/th/T8455.hs new file mode 100644 index 0000000000..9023c7d586 --- /dev/null +++ b/testsuite/tests/th/T8455.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE TemplateHaskell, DataKinds #-} + +module T8455 where + +ty = [t| 5 |]
\ No newline at end of file diff --git a/testsuite/tests/th/T8499.hs b/testsuite/tests/th/T8499.hs new file mode 100644 index 0000000000..353bb9fbc0 --- /dev/null +++ b/testsuite/tests/th/T8499.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell, PolyKinds, DataKinds #-} +{-# OPTIONS_GHC -Wall #-} + +module T8499 where + +import Language.Haskell.TH + +$( do TyConI (DataD _ _ [PlainTV tvb_a] _ _) <- reify ''Maybe + my_a <- newName "a" + return [TySynD (mkName "SMaybe") + [KindedTV my_a (AppT (ConT ''Maybe) (VarT tvb_a))] + (TupleT 0)] ) diff --git a/testsuite/tests/th/T8507.hs b/testsuite/tests/th/T8507.hs new file mode 100644 index 0000000000..978dbb0507 --- /dev/null +++ b/testsuite/tests/th/T8507.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ConstraintKinds #-} + +module T8507 where + +type Stringy1 a = (Read a, Show a) + +$([d|type Stringy2 a = (Read a, Show a) |]) diff --git a/testsuite/tests/th/T8540.hs b/testsuite/tests/th/T8540.hs new file mode 100644 index 0000000000..50374976b8 --- /dev/null +++ b/testsuite/tests/th/T8540.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} +module T8540 where + +import T8540a + +baz :: Int +baz = $foo diff --git a/testsuite/tests/th/T8540a.hs b/testsuite/tests/th/T8540a.hs new file mode 100644 index 0000000000..a3ffbb268c --- /dev/null +++ b/testsuite/tests/th/T8540a.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module T8540a (foo) where + +import Language.Haskell.TH + +foo :: Q Exp +foo = [| bar |] + +bar :: Int +bar = 5 diff --git a/testsuite/tests/th/T8577.hs b/testsuite/tests/th/T8577.hs new file mode 100644 index 0000000000..8a467e448a --- /dev/null +++ b/testsuite/tests/th/T8577.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module T8577 where + +import Language.Haskell.TH + +import T8577a + +foo2 :: A Bool +foo2 = $$(y) + diff --git a/testsuite/tests/th/T8577.stderr b/testsuite/tests/th/T8577.stderr new file mode 100644 index 0000000000..6e35e4a6b5 --- /dev/null +++ b/testsuite/tests/th/T8577.stderr @@ -0,0 +1,7 @@ + +T8577.hs:9:11: + Couldn't match type ‛Int’ with ‛Bool’ + Expected type: Q (TExp (A Bool)) + Actual type: Q (TExp (A Int)) + In the expression: y + In the Template Haskell splice $$y diff --git a/testsuite/tests/th/T8577a.hs b/testsuite/tests/th/T8577a.hs new file mode 100644 index 0000000000..807350c3a2 --- /dev/null +++ b/testsuite/tests/th/T8577a.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} +module T8577a where +import Language.Haskell.TH + +data A a = A + +x :: Q (TExp (A a)) +x = [|| A ||] + +y :: Q (TExp (A Int)) +y = x diff --git a/testsuite/tests/th/T8625.script b/testsuite/tests/th/T8625.script new file mode 100644 index 0000000000..5b3c7b28c9 --- /dev/null +++ b/testsuite/tests/th/T8625.script @@ -0,0 +1,6 @@ +:set -XTemplateHaskell +:m + Language.Haskell.TH + +class Member a +runQ [d| instance ( y ~ (t->t) ) => Member Bool |] +runQ [d| f :: (y ~ (t->t)) => y -> t; f x = x |] diff --git a/testsuite/tests/th/T8625.stdout b/testsuite/tests/th/T8625.stdout new file mode 100644 index 0000000000..e6ce48be3a --- /dev/null +++ b/testsuite/tests/th/T8625.stdout @@ -0,0 +1,2 @@ +[InstanceD [EqualP (VarT y_0) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.Member) (ConT GHC.Types.Bool)) []] +[SigD f_2 (ForallT [PlainTV y_3,PlainTV t_4] [EqualP (VarT y_3) (AppT (AppT ArrowT (VarT t_4)) (VarT t_4))] (AppT (AppT ArrowT (VarT y_3)) (VarT t_4))),FunD f_2 [Clause [VarP x_5] (NormalB (VarE x_5)) []]] diff --git a/testsuite/tests/th/T8633.hs b/testsuite/tests/th/T8633.hs new file mode 100644 index 0000000000..79f1ec697c --- /dev/null +++ b/testsuite/tests/th/T8633.hs @@ -0,0 +1,19 @@ +module Main where
+import Language.Haskell.TH.Syntax
+
+t1 = case mkName "^.." of
+ Name (OccName ".") (NameQ (ModName "^")) -> error "bug0"
+ Name (OccName "^..") NameS -> return ()
+
+t2 = case mkName "Control.Lens.^.." of
+ Name (OccName ".") (NameQ (ModName "Control.Lens.^")) -> error "bug1"
+ Name (OccName "^..") (NameQ (ModName "Control.Lens")) -> return ()
+
+t3 = case mkName "Data.Bits..&." of
+ Name (OccName ".&.") (NameQ (ModName "Data.Bits")) -> return ()
+
+t4 = case mkName "abcde" of
+ Name (OccName "abcde") NameS -> return ()
+
+main :: IO ()
+main = do t1; t2; t3; t4
\ No newline at end of file diff --git a/testsuite/tests/th/TH_1tuple.hs b/testsuite/tests/th/TH_1tuple.hs new file mode 100644 index 0000000000..3674a5a76c --- /dev/null +++ b/testsuite/tests/th/TH_1tuple.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-}
+
+-- Trac #2358
+
+module ShouldFail where
+import Language.Haskell.TH
+
+x = $(sigE [|1|] (tupleT 1 `appT` conT ''Int))
+ -- 1 :: (Int) ( a 1-tuple type)
+
+y = $(sigE [|1|] (tupleT 1))
+ -- 1 :: (1) (a 1-tuple tycon not applied)
+
+z = $(tupE [ [| "yes" |] ])
+ -- ("yes") (a 1-tuple expression)
diff --git a/testsuite/tests/th/TH_1tuple.stderr b/testsuite/tests/th/TH_1tuple.stderr new file mode 100644 index 0000000000..4e1d38b879 --- /dev/null +++ b/testsuite/tests/th/TH_1tuple.stderr @@ -0,0 +1,5 @@ + +TH_1tuple.hs:11:7: + Illegal 1-tuple type constructor + When splicing a TH expression: 1 :: () + In the splice: $(sigE [| 1 |] (tupleT 1)) diff --git a/testsuite/tests/th/TH_Depends.hs b/testsuite/tests/th/TH_Depends.hs new file mode 100644 index 0000000000..94ab51178a --- /dev/null +++ b/testsuite/tests/th/TH_Depends.hs @@ -0,0 +1,9 @@ + +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import TH_Depends_External (loadStringFromFile) + +main :: IO () +main = putStrLn $loadStringFromFile diff --git a/testsuite/tests/th/TH_Depends.stdout b/testsuite/tests/th/TH_Depends.stdout new file mode 100644 index 0000000000..3304582bde --- /dev/null +++ b/testsuite/tests/th/TH_Depends.stdout @@ -0,0 +1,4 @@ +first run + +second run + diff --git a/testsuite/tests/th/TH_Depends_External.hs b/testsuite/tests/th/TH_Depends_External.hs new file mode 100644 index 0000000000..6e5e6d53b2 --- /dev/null +++ b/testsuite/tests/th/TH_Depends_External.hs @@ -0,0 +1,12 @@ + +module TH_Depends_External where + +import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Lib + +loadStringFromFile :: Q Exp +loadStringFromFile = do + let externalDependency = "TH_Depends_external.txt" + qAddDependentFile externalDependency + s <- qRunIO $ readFile externalDependency + stringE s diff --git a/testsuite/tests/th/TH_NestedSplices.hs b/testsuite/tests/th/TH_NestedSplices.hs new file mode 100644 index 0000000000..e16e6da8ff --- /dev/null +++ b/testsuite/tests/th/TH_NestedSplices.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE TemplateHaskell #-}
+module TH_NestedSplices where
+
+import Language.Haskell.TH
+
+import TH_NestedSplices_Lib
+-- This import brings in
+-- spliceExpr :: String -> Q Exp -> Q Exp
+-- declareFun :: String -> Q [Dec]
+
+-- Top level splice without $
+declareFun "a"
+
+-- Splice inside splice
+$(declareFun $(stringE "b"))
+
+-- Splice inside splice without outer $
+declareFun $(stringE "c")
+
+-- Ordinary splicing
+f x = $(spliceExpr "boo" [| x |])
+
+-- Splice inside splice
+g x = $(spliceExpr $(litE (stringL "boo")) [| x |])
+
+-- Ordinary splice inside bracket
+h1 = [| $(litE (integerL 3)) |]
+
+-- Splice inside splice inside bracket
+h2 = [| $(litE ($(varE 'integerL) 3)) |]
+
diff --git a/testsuite/tests/th/TH_NestedSplices_Lib.hs b/testsuite/tests/th/TH_NestedSplices_Lib.hs new file mode 100644 index 0000000000..91d6173b91 --- /dev/null +++ b/testsuite/tests/th/TH_NestedSplices_Lib.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TemplateHaskell #-}
+module TH_NestedSplices_Lib where
+
+import Language.Haskell.TH
+
+spliceExpr :: String -> Q Exp -> Q Exp
+spliceExpr s e = [| (s, $e) |]
+
+declareFun :: String -> Q [Dec]
+declareFun s
+ = do { n <- newName s
+ ; d <- funD n [clause [] (normalB [| 22 |]) []]
+ ; return [d] }
+
diff --git a/testsuite/tests/th/TH_Promoted1Tuple.hs b/testsuite/tests/th/TH_Promoted1Tuple.hs new file mode 100644 index 0000000000..d966d05207 --- /dev/null +++ b/testsuite/tests/th/TH_Promoted1Tuple.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} + +module TH_Promoted1Tuple where + +import Language.Haskell.TH + +$(sequence [tySynD (mkName "F") [] (appT (promotedTupleT 1) (conT ''Int))]) diff --git a/testsuite/tests/th/TH_Promoted1Tuple.stderr b/testsuite/tests/th/TH_Promoted1Tuple.stderr new file mode 100644 index 0000000000..bcda8189e0 --- /dev/null +++ b/testsuite/tests/th/TH_Promoted1Tuple.stderr @@ -0,0 +1,4 @@ + +TH_Promoted1Tuple.hs:7:3: + Illegal promoted 1-tuple type + When splicing a TH declaration: type F = '(GHC.Types.Int) diff --git a/testsuite/tests/th/TH_PromotedList.hs b/testsuite/tests/th/TH_PromotedList.hs new file mode 100644 index 0000000000..1f4d48c540 --- /dev/null +++ b/testsuite/tests/th/TH_PromotedList.hs @@ -0,0 +1,20 @@ +{-# 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 reportWarning (pprint ty) >> + return []) + +data Proxy a = Proxy + +f :: Proxy (True ': $(appT (appT promotedConsT (conT 'False)) promotedNilT)) +f = Proxy :: Proxy ('[True, False] :: [Bool]) diff --git a/testsuite/tests/th/TH_PromotedList.stderr b/testsuite/tests/th/TH_PromotedList.stderr new file mode 100644 index 0000000000..8a6422f6ec --- /dev/null +++ b/testsuite/tests/th/TH_PromotedList.stderr @@ -0,0 +1,3 @@ + +TH_PromotedList.hs:11:3: Warning: + (':) GHC.Types.Int ((':) GHC.Types.Bool '[]) diff --git a/testsuite/tests/th/TH_PromotedTuple.hs b/testsuite/tests/th/TH_PromotedTuple.hs new file mode 100644 index 0000000000..0a9ed633c2 --- /dev/null +++ b/testsuite/tests/th/TH_PromotedTuple.hs @@ -0,0 +1,18 @@ +{-# 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) |] + reportWarning (show ty) + return ty) + +equal = Refl diff --git a/testsuite/tests/th/TH_PromotedTuple.stderr b/testsuite/tests/th/TH_PromotedTuple.stderr new file mode 100644 index 0000000000..06260a7bee --- /dev/null +++ b/testsuite/tests/th/TH_PromotedTuple.stderr @@ -0,0 +1,9 @@ +TH_PromotedTuple.hs:(14,32)-(16,43): Splicing type + do { ty <- [t| '(Int, False) |]; + reportWarning (show ty); + return ty } + ======> + '(Int, False) + +TH_PromotedTuple.hs:14:32: Warning: + AppT (AppT (PromotedTupleT 2) (ConT GHC.Types.Int)) (PromotedT GHC.Types.False) diff --git a/testsuite/tests/th/TH_RichKinds.hs b/testsuite/tests/th/TH_RichKinds.hs new file mode 100644 index 0000000000..69e4239f43 --- /dev/null +++ b/testsuite/tests/th/TH_RichKinds.hs @@ -0,0 +1,21 @@ +{-# 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)) |] + ] + + reportWarning (pprint tys) + return []) diff --git a/testsuite/tests/th/TH_RichKinds.stderr b/testsuite/tests/th/TH_RichKinds.stderr new file mode 100644 index 0000000000..c52667ed04 --- /dev/null +++ b/testsuite/tests/th/TH_RichKinds.stderr @@ -0,0 +1,9 @@ + +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 diff --git a/testsuite/tests/th/TH_RichKinds2.hs b/testsuite/tests/th/TH_RichKinds2.hs new file mode 100644 index 0000000000..b804688b6a --- /dev/null +++ b/testsuite/tests/th/TH_RichKinds2.hs @@ -0,0 +1,49 @@ +{-# 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)) + |] + reportWarning (fixKs (pprint decls)) + return decls ) + +data SBool :: Bool -> * where + SFalse :: SBool 'False + STrue :: SBool 'True + +mbool :: SMaybe SBool ('Just 'False) +mbool = SJust SFalse diff --git a/testsuite/tests/th/TH_RichKinds2.stderr b/testsuite/tests/th/TH_RichKinds2.stderr new file mode 100644 index 0000000000..625d03e961 --- /dev/null +++ b/testsuite/tests/th/TH_RichKinds2.stderr @@ -0,0 +1,9 @@ + +TH_RichKinds2.hs:23:4: Warning: + data SMaybe_0 (t_1 :: k_0 -> *) (t_3 :: Data.Maybe.Maybe k_0) + = forall . t_3 ~ 'Data.Maybe.Nothing => SNothing_4 + | forall a_5 . t_3 ~ 'Data.Maybe.Just a_5 => SJust_6 (t_1 a_5) +type instance TH_RichKinds2.Map f_7 '[] = '[] +type instance TH_RichKinds2.Map f_8 + ('GHC.Types.: h_9 t_10) = 'GHC.Types.: (f_8 h_9) + (TH_RichKinds2.Map f_8 t_10) diff --git a/testsuite/tests/th/TH_Roles1.hs b/testsuite/tests/th/TH_Roles1.hs new file mode 100644 index 0000000000..d746fc9cd8 --- /dev/null +++ b/testsuite/tests/th/TH_Roles1.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-} + +module TH_Roles1 where + +import Language.Haskell.TH + +$( return [ DataD [] (mkName "T") [PlainTV (mkName "a")] [] [] + , RoleAnnotD (mkName "T") [RepresentationalR] ] ) + diff --git a/testsuite/tests/th/TH_Roles1.stderr b/testsuite/tests/th/TH_Roles1.stderr new file mode 100644 index 0000000000..f819da1eca --- /dev/null +++ b/testsuite/tests/th/TH_Roles1.stderr @@ -0,0 +1,5 @@ + +TH_Roles1.hs:7:4: + Illegal role annotation for T; + did you intend to use RoleAnnotations? + while checking a role annotation for ‛T’ diff --git a/testsuite/tests/th/TH_Roles2.hs b/testsuite/tests/th/TH_Roles2.hs new file mode 100644 index 0000000000..30f4fc7631 --- /dev/null +++ b/testsuite/tests/th/TH_Roles2.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell, RoleAnnotations, PolyKinds #-} + +module TH_Roles2 where + +import Language.Haskell.TH + +$( return [ DataD [] (mkName "T") [KindedTV (mkName "a") (VarT (mkName "k"))] [] [] + , RoleAnnotD (mkName "T") [RepresentationalR] ] ) + diff --git a/testsuite/tests/th/TH_Roles2.stderr b/testsuite/tests/th/TH_Roles2.stderr new file mode 100644 index 0000000000..5d8536d355 --- /dev/null +++ b/testsuite/tests/th/TH_Roles2.stderr @@ -0,0 +1,17 @@ +TYPE SIGNATURES +TYPE CONSTRUCTORS + T :: k -> * + data T (k::BOX) (a::k) + No C type associated + Roles: [nominal, representational] + RecFlag NonRecursive, Not promotable + = + FamilyInstance: none +COERCION AXIOMS +Dependent modules: [] +Dependent packages: [array-0.5.0.0, base, containers-0.5.3.1, + deepseq-1.3.0.2, ghc-prim, integer-gmp, pretty-1.1.1.1, + template-haskell] + +==================== Typechecker ==================== + diff --git a/testsuite/tests/th/TH_Roles3.hs b/testsuite/tests/th/TH_Roles3.hs new file mode 100644 index 0000000000..ac96835763 --- /dev/null +++ b/testsuite/tests/th/TH_Roles3.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell, PolyKinds, RoleAnnotations #-} + +module Roles3 where + +import Language.Haskell.TH +import System.IO + +$( do { decls <- [d| data Foo a (b :: k) c (d :: k) + type role Foo _ _ representational nominal |] + ; runIO $ putStrLn (pprint decls) >> hFlush stdout + ; return decls }) diff --git a/testsuite/tests/th/TH_Roles3.stderr b/testsuite/tests/th/TH_Roles3.stderr new file mode 100644 index 0000000000..d3f71d22ba --- /dev/null +++ b/testsuite/tests/th/TH_Roles3.stderr @@ -0,0 +1,2 @@ +data Foo_0 a_1 (b_2 :: k_3) c_4 (d_5 :: k_3) +type role Foo_0 _ _ representational nominal diff --git a/testsuite/tests/th/TH_Roles4.hs b/testsuite/tests/th/TH_Roles4.hs new file mode 100644 index 0000000000..16dbb67102 --- /dev/null +++ b/testsuite/tests/th/TH_Roles4.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Roles4 where + +import Language.Haskell.TH +import System.IO + +data Sticky a b = MkSticky (a b) + +$( do roles <- reifyRoles (mkName "Sticky") + runIO $ putStrLn (show roles) >> hFlush stdout + return [] ) diff --git a/testsuite/tests/th/TH_Roles4.stderr b/testsuite/tests/th/TH_Roles4.stderr new file mode 100644 index 0000000000..1c988e89e8 --- /dev/null +++ b/testsuite/tests/th/TH_Roles4.stderr @@ -0,0 +1 @@ +[RepresentationalR,NominalR] diff --git a/testsuite/tests/th/TH_StringPrimL.hs b/testsuite/tests/th/TH_StringPrimL.hs new file mode 100644 index 0000000000..92f791fb56 --- /dev/null +++ b/testsuite/tests/th/TH_StringPrimL.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE MagicHash #-} +module Main where + +import Language.Haskell.TH +import GHC.Prim(Addr#) +import GHC.Ptr +import Foreign.Marshal.Array (peekArray) +import Data.Word (Word8) + +check_equal :: [Word8] -> Addr# -> IO () +check_equal bytes addr = do + bytes' <- peekArray (length bytes) (Ptr addr) + print (bytes == bytes') + +main = do + -- check round-trip + check_equal [0..255] $(litE $ stringPrimL [0..255]) + + -- check printing + let e = LitE (StringPrimL [0..255]) + print e + putStrLn (pprint e) diff --git a/testsuite/tests/th/TH_StringPrimL.stdout b/testsuite/tests/th/TH_StringPrimL.stdout new file mode 100644 index 0000000000..1bd3b3e9ee --- /dev/null +++ b/testsuite/tests/th/TH_StringPrimL.stdout @@ -0,0 +1,4 @@ +True +LitE (StringPrimL [0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50,51,52,53,54,55,56,57,58,59,60,61,62,63,64,65,66,67,68,69,70,71,72,73,74,75,76,77,78,79,80,81,82,83,84,85,86,87,88,89,90,91,92,93,94,95,96,97,98,99,100,101,102,103,104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125,126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143,144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161,162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179,180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197,198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215,216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233,234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251,252,253,254,255]) +"\NUL\SOH\STX\ETX\EOT\ENQ\ACK\a\b\t\n\ +\\v\f\r\SO\SI\DLE\DC1\DC2\DC3\DC4\NAK\SYN\ETB\CAN\EM\SUB\ESC\FS\GS\RS\US !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~\DEL\128\129\130\131\132\133\134\135\136\137\138\139\140\141\142\143\144\145\146\147\148\149\150\151\152\153\154\155\156\157\158\159\160\161\162\163\164\165\166\167\168\169\170\171\172\173\174\175\176\177\178\179\180\181\182\183\184\185\186\187\188\189\190\191\192\193\194\195\196\197\198\199\200\201\202\203\204\205\206\207\208\209\210\211\212\213\214\215\216\217\218\219\220\221\222\223\224\225\226\227\228\229\230\231\232\233\234\235\236\237\238\239\240\241\242\243\244\245\246\247\248\249\250\251\252\253\254\255"# diff --git a/testsuite/tests/th/TH_TyInstWhere1.hs b/testsuite/tests/th/TH_TyInstWhere1.hs new file mode 100644 index 0000000000..d8c07d7642 --- /dev/null +++ b/testsuite/tests/th/TH_TyInstWhere1.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE PolyKinds, DataKinds, TemplateHaskell, TypeFamilies #-} + +module TH_TyInstWhere1 where + +$([d| type family F (a :: k) (b :: k) :: Bool where + F a a = True + F a b = False |]) + +data Proxy a = P + +f :: Proxy True -> Proxy (F Int Int) +f x = x + +g :: Proxy False -> Proxy (F Int Bool) +g x = x
\ No newline at end of file diff --git a/testsuite/tests/th/TH_TyInstWhere1.stderr b/testsuite/tests/th/TH_TyInstWhere1.stderr new file mode 100644 index 0000000000..5a830aa792 --- /dev/null +++ b/testsuite/tests/th/TH_TyInstWhere1.stderr @@ -0,0 +1,9 @@ +TH_TyInstWhere1.hs:1:1: Splicing declarations + [d| type family F (a :: k) (b :: k) :: Bool where + F a a = True + F a b = False |] + ======> + TH_TyInstWhere1.hs:(5,3)-(7,24) + type family F (a :: k) (b :: k) :: Bool where + F a a = True + F a b = False diff --git a/testsuite/tests/th/TH_TyInstWhere2.hs b/testsuite/tests/th/TH_TyInstWhere2.hs new file mode 100644 index 0000000000..47fedad8da --- /dev/null +++ b/testsuite/tests/th/TH_TyInstWhere2.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE PolyKinds, DataKinds, TemplateHaskell, TypeFamilies #-} + +module TH_TyInstWhere2 where + +import Language.Haskell.TH + +$( do { decs <- [d| type family F (a :: k) (b :: k) :: Bool where + F a a = True + F a b = False |] + ; reportWarning (pprint decs) + ; return [] }) + + diff --git a/testsuite/tests/th/TH_TyInstWhere2.stderr b/testsuite/tests/th/TH_TyInstWhere2.stderr new file mode 100644 index 0000000000..17caf61bad --- /dev/null +++ b/testsuite/tests/th/TH_TyInstWhere2.stderr @@ -0,0 +1,5 @@ + +TH_TyInstWhere2.hs:7:4: Warning: + type family F_0 (a_1 :: k_2) (b_3 :: k_2) :: GHC.Types.Bool where + F_0 a_4 a_4 = 'GHC.Types.True + F_0 a_5 b_6 = 'GHC.Types.False diff --git a/testsuite/tests/th/TH_bracket1.hs b/testsuite/tests/th/TH_bracket1.hs new file mode 100644 index 0000000000..393ca47fbd --- /dev/null +++ b/testsuite/tests/th/TH_bracket1.hs @@ -0,0 +1,7 @@ +-- Check that declarations in a bracket shadow the top-level +-- declarations, rather than clashing with them. + +module TH_bracket1 where + +foo = 1 +bar = [d| foo = 1 |] diff --git a/testsuite/tests/th/TH_bracket2.hs b/testsuite/tests/th/TH_bracket2.hs new file mode 100644 index 0000000000..2b06b9eecb --- /dev/null +++ b/testsuite/tests/th/TH_bracket2.hs @@ -0,0 +1,7 @@ +module TH_bracket2 where + +d_show = [d| data A = A + + instance Show A where + show _ = "A" + |] diff --git a/testsuite/tests/th/TH_bracket3.hs b/testsuite/tests/th/TH_bracket3.hs new file mode 100644 index 0000000000..c746d61cd3 --- /dev/null +++ b/testsuite/tests/th/TH_bracket3.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module TH_bracket3 where + +d_class = [d| class Classy a b where + f :: a -> b + + instance Classy Int Bool where + f x = if x == 0 then True else False + |] diff --git a/testsuite/tests/th/TH_class1.hs b/testsuite/tests/th/TH_class1.hs new file mode 100644 index 0000000000..334a7d2301 --- /dev/null +++ b/testsuite/tests/th/TH_class1.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} + +module TH_class1 where + +$( [d| class Classy a b c d | a -> b c, c -> d where + f :: a -> b -> c -> d + |] ) diff --git a/testsuite/tests/th/TH_dataD1.hs b/testsuite/tests/th/TH_dataD1.hs new file mode 100644 index 0000000000..f65d612795 --- /dev/null +++ b/testsuite/tests/th/TH_dataD1.hs @@ -0,0 +1,11 @@ + +module TH_dataD1 where + +import Language.Haskell.TH + +ds :: Q [Dec] +ds = [d| + $(do { d <- dataD (cxt []) (mkName "D") [] [normalC (mkName "K") []] [] + ; return [d]}) + |] + diff --git a/testsuite/tests/th/TH_dataD1.stderr b/testsuite/tests/th/TH_dataD1.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/th/TH_dataD1.stderr diff --git a/testsuite/tests/th/TH_dupdecl.hs b/testsuite/tests/th/TH_dupdecl.hs new file mode 100644 index 0000000000..80f1da4068 --- /dev/null +++ b/testsuite/tests/th/TH_dupdecl.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Two sliced declarations bind the same variable. +-- This test checks that there's a reasonable error message + +module ShouldCompile where + +$( [d| x = 1 |] ) + +$( [d| x = 2 |] ) diff --git a/testsuite/tests/th/TH_dupdecl.stderr b/testsuite/tests/th/TH_dupdecl.stderr new file mode 100644 index 0000000000..4bd90febad --- /dev/null +++ b/testsuite/tests/th/TH_dupdecl.stderr @@ -0,0 +1,5 @@ + +TH_dupdecl.hs:10:4: + Multiple declarations of ‛x’ + Declared at: TH_dupdecl.hs:8:4 + TH_dupdecl.hs:10:4 diff --git a/testsuite/tests/th/TH_emptycase.hs b/testsuite/tests/th/TH_emptycase.hs new file mode 100644 index 0000000000..fc75cfe5b0 --- /dev/null +++ b/testsuite/tests/th/TH_emptycase.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell, EmptyCase #-} +-- Trac #2431: empty case expression +-- now accepted + +module Main where + +import Language.Haskell.TH + +f :: Int +f = $(caseE (litE $ CharL 'a') []) + +main = print f diff --git a/testsuite/tests/th/TH_exn1.hs b/testsuite/tests/th/TH_exn1.hs new file mode 100644 index 0000000000..b401ca40d5 --- /dev/null +++ b/testsuite/tests/th/TH_exn1.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Test error message when the code in a splice +-- fails in an immediate fashion (e.g. with a +-- pattern match failure) + +module ShouldCompile where + +$( case reverse "no" of + [] -> return [] + ) diff --git a/testsuite/tests/th/TH_exn1.stderr b/testsuite/tests/th/TH_exn1.stderr new file mode 100644 index 0000000000..63548613d8 --- /dev/null +++ b/testsuite/tests/th/TH_exn1.stderr @@ -0,0 +1,6 @@ + +TH_exn1.hs:1:1: + Exception when trying to run compile-time code: + TH_exn1.hs:(9,4)-(10,23): Non-exhaustive patterns in case + + Code: case reverse "no" of { [] -> return [] } diff --git a/testsuite/tests/th/TH_exn2.hs b/testsuite/tests/th/TH_exn2.hs new file mode 100644 index 0000000000..ce742d906e --- /dev/null +++ b/testsuite/tests/th/TH_exn2.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Test error message when the code in a splice +-- fails in a lazy fashion (e.g. a (head []) +-- thunk is embedded in the returned structure). + +module TH where + +$( do { ds <- [d| |] + ; return (tail ds) } + ) diff --git a/testsuite/tests/th/TH_exn2.stderr b/testsuite/tests/th/TH_exn2.stderr new file mode 100644 index 0000000000..79ec99171a --- /dev/null +++ b/testsuite/tests/th/TH_exn2.stderr @@ -0,0 +1,6 @@ + +TH_exn2.hs:1:1: + Exception when trying to run compile-time code: + Prelude.tail: empty list + Code: do { ds <- [d| |]; + return (tail ds) } diff --git a/testsuite/tests/th/TH_fail.hs b/testsuite/tests/th/TH_fail.hs new file mode 100644 index 0000000000..174939c5cb --- /dev/null +++ b/testsuite/tests/th/TH_fail.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Test for sane reporting on TH code giving up. + +module ShouldCompile where + +$( fail "Code not written yet..." ) diff --git a/testsuite/tests/th/TH_fail.stderr b/testsuite/tests/th/TH_fail.stderr new file mode 100644 index 0000000000..b73acbbb22 --- /dev/null +++ b/testsuite/tests/th/TH_fail.stderr @@ -0,0 +1,2 @@ + +TH_fail.hs:7:4: Code not written yet... diff --git a/testsuite/tests/th/TH_foreignInterruptible.hs b/testsuite/tests/th/TH_foreignInterruptible.hs new file mode 100644 index 0000000000..d025c355a3 --- /dev/null +++ b/testsuite/tests/th/TH_foreignInterruptible.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell, ForeignFunctionInterface, InterruptibleFFI #-} + +module TH_foreign where + +import Foreign.Ptr +import Language.Haskell.TH + +$(return [ForeignD (ImportF CCall Interruptible "&" (mkName "foo") (AppT (ConT ''Ptr) (ConT ''())))]) + +-- Should generate the same as this: +foreign import ccall interruptible "&" foo1 :: Ptr () diff --git a/testsuite/tests/th/TH_foreignInterruptible.stderr b/testsuite/tests/th/TH_foreignInterruptible.stderr new file mode 100644 index 0000000000..6893d0a773 --- /dev/null +++ b/testsuite/tests/th/TH_foreignInterruptible.stderr @@ -0,0 +1,13 @@ +TH_foreignInterruptible.hs:1:1: Splicing declarations + return + [ForeignD + (ImportF + CCall + Interruptible + "&" + (mkName "foo") + (AppT (ConT ''Ptr) (ConT ''())))] + ======> + TH_foreignInterruptible.hs:8:3-100 + foreign import ccall interruptible "static &foo" foo + :: Ptr GHC.Tuple.() diff --git a/testsuite/tests/th/TH_genEx.hs b/testsuite/tests/th/TH_genEx.hs new file mode 100644 index 0000000000..fdc47960ad --- /dev/null +++ b/testsuite/tests/th/TH_genEx.hs @@ -0,0 +1,14 @@ +{-# OPTIONS -ddump-splices -XExistentialQuantification #-} +{-# LANGUAGE TemplateHaskell #-} + +module TH_genEx where + +import TH_genExLib +import Language.Haskell.TH + +class MyInterface a where + foo :: a -> Int + foo1 :: Int -> a -> Int + +$(genAny (reify ''MyInterface)) + diff --git a/testsuite/tests/th/TH_genEx.stderr b/testsuite/tests/th/TH_genEx.stderr new file mode 100644 index 0000000000..843959f693 --- /dev/null +++ b/testsuite/tests/th/TH_genEx.stderr @@ -0,0 +1,6 @@ +TH_genEx.hs:1:1: Splicing declarations + genAny (reify ''MyInterface) + ======> + TH_genEx.hs:13:3-30 + data AnyMyInterface1111 + = forall a. MyInterface a => AnyMyInterface1111 a diff --git a/testsuite/tests/th/TH_genExLib.hs b/testsuite/tests/th/TH_genExLib.hs new file mode 100644 index 0000000000..02784ac87b --- /dev/null +++ b/testsuite/tests/th/TH_genExLib.hs @@ -0,0 +1,20 @@ + +module TH_genExLib where + +import Language.Haskell.TH + +genAny :: Q Info -> Q [Dec] +genAny decl = do { d <- decl + ; case d of + ClassI (ClassD _ name _ _ decls) _ -> return [genAnyClass name decls] + _ -> error "genAny can be applied to classes only" + } + +genAnyClass :: Name -> [Dec] -> Dec +genAnyClass name decls + = DataD [] anyName [] [constructor] [] + where + anyName = mkName ("Any" ++ nameBase name ++ "1111") + constructor = ForallC [PlainTV var_a] [ClassP name [VarT var_a]] $ + NormalC anyName [(NotStrict, VarT var_a)] + var_a = mkName "a" diff --git a/testsuite/tests/th/TH_ghci1.script b/testsuite/tests/th/TH_ghci1.script new file mode 100644 index 0000000000..bcc752b9f4 --- /dev/null +++ b/testsuite/tests/th/TH_ghci1.script @@ -0,0 +1,6 @@ +:m +Language.Haskell.TH +let { g1 :: Q Exp -> Q Exp; g1 x = x } +let { g2 :: Name -> Q Exp; g2 x = return (VarE x) } +let h x = x::Int +$(g1 [| h |]) 5 +$(g2 'h) 6 diff --git a/testsuite/tests/th/TH_ghci1.stdout b/testsuite/tests/th/TH_ghci1.stdout new file mode 100644 index 0000000000..6613b56886 --- /dev/null +++ b/testsuite/tests/th/TH_ghci1.stdout @@ -0,0 +1,2 @@ +5 +6 diff --git a/testsuite/tests/th/TH_import_loop/Main.hs b/testsuite/tests/th/TH_import_loop/Main.hs new file mode 100644 index 0000000000..4cd66a0173 --- /dev/null +++ b/testsuite/tests/th/TH_import_loop/Main.hs @@ -0,0 +1,7 @@ + +module Main where + +import ModuleA + +main = return () + diff --git a/testsuite/tests/th/TH_import_loop/Makefile b/testsuite/tests/th/TH_import_loop/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/th/TH_import_loop/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/th/TH_import_loop/ModuleA.hs b/testsuite/tests/th/TH_import_loop/ModuleA.hs new file mode 100644 index 0000000000..799f177dfe --- /dev/null +++ b/testsuite/tests/th/TH_import_loop/ModuleA.hs @@ -0,0 +1,5 @@ + +module ModuleA where + +import ModuleB + diff --git a/testsuite/tests/th/TH_import_loop/ModuleA.hs-boot b/testsuite/tests/th/TH_import_loop/ModuleA.hs-boot new file mode 100644 index 0000000000..a5976fdcc6 --- /dev/null +++ b/testsuite/tests/th/TH_import_loop/ModuleA.hs-boot @@ -0,0 +1,3 @@ + +module ModuleA where + diff --git a/testsuite/tests/th/TH_import_loop/ModuleB.hs b/testsuite/tests/th/TH_import_loop/ModuleB.hs new file mode 100644 index 0000000000..9aaffb613f --- /dev/null +++ b/testsuite/tests/th/TH_import_loop/ModuleB.hs @@ -0,0 +1,9 @@ + +{-# LANGUAGE TemplateHaskell #-} + +module ModuleB where + +import ModuleC + +$(nothing) + diff --git a/testsuite/tests/th/TH_import_loop/ModuleC.hs b/testsuite/tests/th/TH_import_loop/ModuleC.hs new file mode 100644 index 0000000000..3047a8f0d4 --- /dev/null +++ b/testsuite/tests/th/TH_import_loop/ModuleC.hs @@ -0,0 +1,9 @@ + +module ModuleC where + +import Language.Haskell.TH + +import {-# SOURCE #-} ModuleA + +nothing = return [] :: Q [Dec] + diff --git a/testsuite/tests/th/TH_import_loop/TH_import_loop.T b/testsuite/tests/th/TH_import_loop/TH_import_loop.T new file mode 100644 index 0000000000..8a4a180c28 --- /dev/null +++ b/testsuite/tests/th/TH_import_loop/TH_import_loop.T @@ -0,0 +1,10 @@ + +setTestOpts(when(compiler_profiled(), skip)) + +test('TH_import_loop', + [extra_clean(['ModuleA.o-boot', 'ModuleA.hi-boot', + 'ModuleC.o', 'ModuleC.hi']), + expect_broken(1012)], + multimod_compile_and_run, + ['Main', '-v0']) + diff --git a/testsuite/tests/th/TH_lookupName.hs b/testsuite/tests/th/TH_lookupName.hs new file mode 100644 index 0000000000..b1c051a731 --- /dev/null +++ b/testsuite/tests/th/TH_lookupName.hs @@ -0,0 +1,35 @@ +-- test 'lookupTypeName' and 'lookupValueName' + +import Language.Haskell.TH + +import qualified TH_lookupName_Lib +import qualified TH_lookupName_Lib as TheLib + +f :: String +f = "TH_lookupName.f" + +data D = D + +$(return []) + +main = mapM_ print [ + -- looking up values + $(do { Just n <- lookupValueName "f" ; varE n }), + $(do { Nothing <- lookupTypeName "f"; [| "" |] }), + -- looking up types + $(do { Just n <- lookupTypeName "String"; sigE [| "" |] (conT n) }), + $(do { Nothing <- lookupValueName "String"; [| "" |] }), + -- namespacing + $(do { Just n <- lookupValueName "D"; DataConI{} <- reify n; [| "" |] }), + $(do { Just n <- lookupTypeName "D"; TyConI{} <- reify n; [| "" |] }), + -- qualified lookup + $(do { Just n <- lookupValueName "TH_lookupName_Lib.f"; varE n }), + $(do { Just n <- lookupValueName "TheLib.f"; varE n }), + -- shadowing + $(TheLib.lookup_f), + $( [| let f = "local f" in $(TheLib.lookup_f) |] ), + $( [| let f = "local f" in $(do { Just n <- lookupValueName "f"; varE n }) |] ), + $( [| let f = "local f" in $(varE 'f) |] ), + let f = "local f" in $(TheLib.lookup_f), + let f = "local f" in $(varE 'f) + ] diff --git a/testsuite/tests/th/TH_lookupName.stdout b/testsuite/tests/th/TH_lookupName.stdout new file mode 100644 index 0000000000..21a8f43de3 --- /dev/null +++ b/testsuite/tests/th/TH_lookupName.stdout @@ -0,0 +1,14 @@ +"TH_lookupName.f" +"" +"" +"" +"" +"" +"TH_lookupName_Lib.f" +"TH_lookupName_Lib.f" +"TH_lookupName.f" +"TH_lookupName.f" +"TH_lookupName.f" +"local f" +"local f" +"local f" diff --git a/testsuite/tests/th/TH_lookupName_Lib.hs b/testsuite/tests/th/TH_lookupName_Lib.hs new file mode 100644 index 0000000000..a7b4c4b212 --- /dev/null +++ b/testsuite/tests/th/TH_lookupName_Lib.hs @@ -0,0 +1,9 @@ +module TH_lookupName_Lib where + +import Language.Haskell.TH + +f :: String +f = "TH_lookupName_Lib.f" + +lookup_f :: Q Exp +lookup_f = do { Just n <- lookupValueName "f"; varE n } diff --git a/testsuite/tests/th/TH_mkName.hs b/testsuite/tests/th/TH_mkName.hs new file mode 100644 index 0000000000..44cddc89aa --- /dev/null +++ b/testsuite/tests/th/TH_mkName.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Test name quoting and splicing, for built-in syntax + +module TH_mkName where + +import Language.Haskell.TH + +x1 = $( return (ConE '())) +x2 = $( return (ConE '(,))) +x3 = $( return (ConE '[])) +x4 = $( return (ConE '(:))) +x5 = $( return (ConE 'Just)) + +y1 = $( return (ConE (mkName "()"))) +y2 = $( return (ConE (mkName "(,)"))) +y3 = $( return (ConE (mkName "[]"))) +y4 = $( return (ConE (mkName ":"))) +y5 = $( return (ConE (mkName "Just"))) + diff --git a/testsuite/tests/th/TH_ppr1.hs b/testsuite/tests/th/TH_ppr1.hs new file mode 100644 index 0000000000..763d7682e0 --- /dev/null +++ b/testsuite/tests/th/TH_ppr1.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module Main (main) where + +import Language.Haskell.TH + +u1 :: a +u1 = undefined + +u2 :: a +u2 = undefined + +f :: a +f = undefined + +(.+.) :: a +(.+.) = undefined + +main :: IO () +main = do runQ [| f u1 u2 |] >>= p + runQ [| u1 `f` u2 |] >>= p + runQ [| (.+.) u1 u2 |] >>= p + runQ [| u1 .+. u2 |] >>= p + runQ [| (:) u1 u2 |] >>= p + runQ [| u1 : u2 |] >>= p + runQ [| \((:) x xs) -> x |] >>= p + runQ [| \(x : xs) -> x |] >>= p + runQ [d| class Foo a b where + foo :: a -> b |] >>= p + runQ [| \x -> (x, 1 `x` 2) |] >>= p + runQ [| \(+) -> ((+), 1 + 2) |] >>= p + runQ [| (f, 1 `f` 2) |] >>= p + runQ [| ((.+.), 1 .+. 2) |] >>= p + +p :: Ppr a => a -> IO () +p = putStrLn . pprint + diff --git a/testsuite/tests/th/TH_ppr1.stdout b/testsuite/tests/th/TH_ppr1.stdout new file mode 100644 index 0000000000..e969c176c3 --- /dev/null +++ b/testsuite/tests/th/TH_ppr1.stdout @@ -0,0 +1,14 @@ +Main.f Main.u1 Main.u2
+Main.u1 `Main.f` Main.u2
+(Main..+.) Main.u1 Main.u2
+Main.u1 Main..+. Main.u2
+(GHC.Types.:) Main.u1 Main.u2
+Main.u1 GHC.Types.: Main.u2
+\((GHC.Types.:) x_0 xs_1) -> x_0
+\(x_0 GHC.Types.: xs_1) -> x_0
+class Foo_0 a_1 b_2
+ where foo_3 :: a_1 -> b_2
+\x_0 -> (x_0, 1 `x_0` 2)
+\(+_0) -> ((+_0), 1 +_0 2)
+(Main.f, 1 `Main.f` 2)
+((Main..+.), 1 Main..+. 2)
diff --git a/testsuite/tests/th/TH_pragma.hs b/testsuite/tests/th/TH_pragma.hs new file mode 100644 index 0000000000..a78b5483fe --- /dev/null +++ b/testsuite/tests/th/TH_pragma.hs @@ -0,0 +1,12 @@ +{-# OPTIONS -ddump-splices #-} +{-# LANGUAGE TemplateHaskell #-} +module TH_pragma where + + +$( [d| foo :: Int -> Int + {-# NOINLINE foo #-} + foo x = x + 1 |] ) + +$( [d| bar :: Num a => a -> a + {-# SPECIALISE INLINE [~1] bar :: Float -> Float #-} + bar x = x * 10 |] ) diff --git a/testsuite/tests/th/TH_pragma.stderr b/testsuite/tests/th/TH_pragma.stderr new file mode 100644 index 0000000000..15feece963 --- /dev/null +++ b/testsuite/tests/th/TH_pragma.stderr @@ -0,0 +1,18 @@ +TH_pragma.hs:1:1: Splicing declarations + [d| foo :: Int -> Int + {-# NOINLINE foo #-} + foo x = x + 1 |] + ======> + TH_pragma.hs:(6,4)-(8,26) + foo :: Int -> Int + {-# NOINLINE foo #-} + foo x = (x + 1) +TH_pragma.hs:1:1: Splicing declarations + [d| bar :: Num a => a -> a + {-# SPECIALIZE INLINE[~1] bar :: Float -> Float #-} + bar x = x * 10 |] + ======> + TH_pragma.hs:(10,4)-(12,31) + bar :: forall a. Num a => a -> a + {-# SPECIALIZE INLINE[~1] bar :: Float -> Float #-} + bar x = (x * 10) diff --git a/testsuite/tests/th/TH_raiseErr1.hs b/testsuite/tests/th/TH_raiseErr1.hs new file mode 100644 index 0000000000..97396f16c5 --- /dev/null +++ b/testsuite/tests/th/TH_raiseErr1.hs @@ -0,0 +1,4 @@ +module TH_raiseErr1 where +import Language.Haskell.TH + +foo = $(do { report True "Error test succeeded"; fail "" }) diff --git a/testsuite/tests/th/TH_recover.hs b/testsuite/tests/th/TH_recover.hs new file mode 100644 index 0000000000..50527da85c --- /dev/null +++ b/testsuite/tests/th/TH_recover.hs @@ -0,0 +1,12 @@ +module Main where + +import Language.Haskell.TH + +-- The recover successfully find that 'ola' is not in scope +-- and use '1' instead + +y = $(recover (return (LitE (IntegerL 1))) + (reify (mkName ("ola")) >> return (LitE (IntegerL 2)))) + +main = print y + diff --git a/testsuite/tests/th/TH_recover.stdout b/testsuite/tests/th/TH_recover.stdout new file mode 100644 index 0000000000..d00491fd7e --- /dev/null +++ b/testsuite/tests/th/TH_recover.stdout @@ -0,0 +1 @@ +1 diff --git a/testsuite/tests/th/TH_reifyDecl1.hs b/testsuite/tests/th/TH_reifyDecl1.hs new file mode 100644 index 0000000000..4c444f2d5c --- /dev/null +++ b/testsuite/tests/th/TH_reifyDecl1.hs @@ -0,0 +1,88 @@ +-- test reification of data declarations + +{-# LANGUAGE TypeFamilies #-} +module TH_reifyDecl1 where + +import System.IO +import Language.Haskell.TH +import Text.PrettyPrint.HughesPJ + +infixl 3 `m1` + +-- simple +data T = A | B + +-- parametric +data R a = C a | D + +-- recursive +data List a = Nil | Cons a (List a) + +-- infix operator +data Tree a = Leaf | Tree a :+: Tree a + +-- type declaration +type IntList = [Int] + +-- newtype declaration +newtype Length = Length Int + +-- simple class +class C1 a where + m1 :: a -> Int + +-- class with instances +class C2 a where + m2 :: a -> Int +instance C2 Int where + m2 x = x + +-- associated types +class C3 a where + type AT1 a + data AT2 a + +instance C3 Int where + type AT1 Int = Bool + data AT2 Int = AT2Int + +-- type family +type family TF1 a + +-- type family, with instances +type family TF2 a +type instance TF2 Bool = Bool + +-- data family +data family DF1 a + +-- data family, with instances +data family DF2 a +data instance DF2 Bool = DBool + +$(return []) + +test :: () +test = $(let + display :: Name -> Q () + display q = do { i <- reify q; runIO $ hPutStrLn stderr (pprint i) } + in do { display ''T + ; display ''R + ; display ''List + ; display ''Tree + ; display ''IntList + ; display ''Length + ; display 'Leaf + ; display 'm1 + ; display ''C1 + ; display ''C2 + ; display ''C3 + ; display ''AT1 + ; display ''AT2 + ; display ''TF1 + ; display ''TF2 + ; display ''DF1 + ; display ''DF2 + ; [| () |] }) + + diff --git a/testsuite/tests/th/TH_reifyDecl1.stderr b/testsuite/tests/th/TH_reifyDecl1.stderr new file mode 100644 index 0000000000..82a4f572ce --- /dev/null +++ b/testsuite/tests/th/TH_reifyDecl1.stderr @@ -0,0 +1,35 @@ +data TH_reifyDecl1.T = TH_reifyDecl1.A | TH_reifyDecl1.B +data TH_reifyDecl1.R a_0 = TH_reifyDecl1.C a_0 | TH_reifyDecl1.D +data TH_reifyDecl1.List a_0 + = TH_reifyDecl1.Nil + | TH_reifyDecl1.Cons a_0 (TH_reifyDecl1.List a_0) +data TH_reifyDecl1.Tree a_0 + = TH_reifyDecl1.Leaf + | (TH_reifyDecl1.Tree a_0) TH_reifyDecl1.:+: (TH_reifyDecl1.Tree a_0) +type TH_reifyDecl1.IntList = [GHC.Types.Int] +newtype TH_reifyDecl1.Length = TH_reifyDecl1.Length GHC.Types.Int +Constructor from TH_reifyDecl1.Tree: TH_reifyDecl1.Leaf :: forall a_0 . TH_reifyDecl1.Tree a_0 +Class op from TH_reifyDecl1.C1: TH_reifyDecl1.m1 :: forall a_0 . TH_reifyDecl1.C1 a_0 => + a_0 -> GHC.Types.Int + infixl 3 TH_reifyDecl1.m1 +class TH_reifyDecl1.C1 a_0 + where TH_reifyDecl1.m1 :: forall a_0 . TH_reifyDecl1.C1 a_0 => + a_0 -> GHC.Types.Int +class TH_reifyDecl1.C2 a_0 + where TH_reifyDecl1.m2 :: forall a_0 . TH_reifyDecl1.C2 a_0 => + a_0 -> GHC.Types.Int +instance TH_reifyDecl1.C2 GHC.Types.Int +class TH_reifyDecl1.C3 a_0 +instance TH_reifyDecl1.C3 GHC.Types.Int +type family TH_reifyDecl1.AT1 a_0 :: * -> * +type instance TH_reifyDecl1.AT1 GHC.Types.Int = GHC.Types.Bool +data family TH_reifyDecl1.AT2 a_0 :: * -> * +data instance TH_reifyDecl1.AT2 GHC.Types.Int + = TH_reifyDecl1.AT2Int +type family TH_reifyDecl1.TF1 a_0 :: * -> * +type family TH_reifyDecl1.TF2 a_0 :: * -> * +type instance TH_reifyDecl1.TF2 GHC.Types.Bool = GHC.Types.Bool +data family TH_reifyDecl1.DF1 a_0 :: * -> * +data family TH_reifyDecl1.DF2 a_0 :: * -> * +data instance TH_reifyDecl1.DF2 GHC.Types.Bool + = TH_reifyDecl1.DBool diff --git a/testsuite/tests/th/TH_reifyDecl2.hs b/testsuite/tests/th/TH_reifyDecl2.hs new file mode 100644 index 0000000000..44c14e0247 --- /dev/null +++ b/testsuite/tests/th/TH_reifyDecl2.hs @@ -0,0 +1,12 @@ + +module TH_reifyDecl2 where + +import Language.Haskell.TH +import System.IO + +$( + do x <- reify ''Maybe + runIO $ hPutStrLn stderr $ pprint x + return [] + ) + diff --git a/testsuite/tests/th/TH_reifyDecl2.stderr b/testsuite/tests/th/TH_reifyDecl2.stderr new file mode 100644 index 0000000000..802cf293c6 --- /dev/null +++ b/testsuite/tests/th/TH_reifyDecl2.stderr @@ -0,0 +1,2 @@ +data Data.Maybe.Maybe a_0 + = Data.Maybe.Nothing | Data.Maybe.Just a_0 diff --git a/testsuite/tests/th/TH_reifyInstances.hs b/testsuite/tests/th/TH_reifyInstances.hs new file mode 100644 index 0000000000..431a02244e --- /dev/null +++ b/testsuite/tests/th/TH_reifyInstances.hs @@ -0,0 +1,49 @@ +-- test reifyInstances + +{-# LANGUAGE TypeFamilies #-} +module TH_reifyInstances where + +import System.IO +import Language.Haskell.TH +import Text.PrettyPrint.HughesPJ + +-- classes +class C1 a where f1 :: a + +class C2 a where f2 :: a +instance C2 Int where f2 = 0 +instance C2 Bool where f2 = True + +-- type families +type family T1 a + +type family T2 a +type instance T2 Int = Char +type instance T2 Bool = Int + +-- data families +data family D1 a + +data family D2 a +data instance D2 Int = DInt | DInt2 +data instance D2 Bool = DBool + +$(return []) + +test :: () +test = $(let + display :: Name -> Q () + display n = do + { intTy <- [t| Int |] + ; is1 <- reifyInstances n [intTy] + ; runIO $ hPutStrLn stderr (nameBase n) + ; runIO $ hPutStrLn stderr (pprint is1) + } + in do { display ''C1 + ; display ''C2 + ; display ''T1 + ; display ''T2 + ; display ''D1 + ; display ''D2 + ; [| () |] + }) diff --git a/testsuite/tests/th/TH_reifyInstances.stderr b/testsuite/tests/th/TH_reifyInstances.stderr new file mode 100644 index 0000000000..21d2ff484a --- /dev/null +++ b/testsuite/tests/th/TH_reifyInstances.stderr @@ -0,0 +1,13 @@ +C1 + +C2 +instance TH_reifyInstances.C2 GHC.Types.Int +T1 + +T2 +type instance TH_reifyInstances.T2 GHC.Types.Int = GHC.Types.Char +D1 + +D2 +data instance TH_reifyInstances.D2 GHC.Types.Int + = TH_reifyInstances.DInt | TH_reifyInstances.DInt2 diff --git a/testsuite/tests/th/TH_reifyMkName.hs b/testsuite/tests/th/TH_reifyMkName.hs new file mode 100644 index 0000000000..7c4d7196e0 --- /dev/null +++ b/testsuite/tests/th/TH_reifyMkName.hs @@ -0,0 +1,14 @@ +-- Trac #2339 + +module Foo where + +import System.IO +import Language.Haskell.TH + +type C = Int + +$(do + a <- reify $ mkName "C" + runIO $ hPutStrLn stderr (show a) + return [] + ) diff --git a/testsuite/tests/th/TH_reifyMkName.stderr b/testsuite/tests/th/TH_reifyMkName.stderr new file mode 100644 index 0000000000..a82707f987 --- /dev/null +++ b/testsuite/tests/th/TH_reifyMkName.stderr @@ -0,0 +1 @@ +TyConI (TySynD Foo.C [] (ConT GHC.Types.Int)) diff --git a/testsuite/tests/th/TH_reifyType1.hs b/testsuite/tests/th/TH_reifyType1.hs new file mode 100644 index 0000000000..d8b45db271 --- /dev/null +++ b/testsuite/tests/th/TH_reifyType1.hs @@ -0,0 +1,13 @@ +-- test reification of monomorphic types + +module TH_reifyType1 +where + +import Language.Haskell.TH + +foo :: Int -> Int +foo x = x + 1 + +type_foo :: InfoQ +type_foo = reify 'foo + diff --git a/testsuite/tests/th/TH_reifyType2.hs b/testsuite/tests/th/TH_reifyType2.hs new file mode 100644 index 0000000000..85615b5382 --- /dev/null +++ b/testsuite/tests/th/TH_reifyType2.hs @@ -0,0 +1,9 @@ +-- test reification of polymorphic types + +module TH_reifyType1 +where + +import Language.Haskell.TH + +type_length :: InfoQ +type_length = reify 'length diff --git a/testsuite/tests/th/TH_repE1.hs b/testsuite/tests/th/TH_repE1.hs new file mode 100644 index 0000000000..1938a9bdc3 --- /dev/null +++ b/testsuite/tests/th/TH_repE1.hs @@ -0,0 +1,30 @@ +-- test the representation of literals and also explicit type annotations + +module TH_repE1 +where + +import Language.Haskell.TH + +integralExpr :: ExpQ +integralExpr = [| 42 |] + +intExpr :: ExpQ +intExpr = [| 42 :: Int |] + +integerExpr :: ExpQ +integerExpr = [| 42 :: Integer |] + +charExpr :: ExpQ +charExpr = [| 'x' |] + +stringExpr :: ExpQ +stringExpr = [| "A String" |] + +fractionalExpr :: ExpQ +fractionalExpr = [| 1.2 |] + +floatExpr :: ExpQ +floatExpr = [| 1.2 :: Float |] + +doubleExpr :: ExpQ +doubleExpr = [| 1.2 :: Double |] diff --git a/testsuite/tests/th/TH_repE2.hs b/testsuite/tests/th/TH_repE2.hs new file mode 100644 index 0000000000..bc27bfeefd --- /dev/null +++ b/testsuite/tests/th/TH_repE2.hs @@ -0,0 +1,36 @@ +-- test the representation of literals and also explicit type annotations + +module Main +where + +import Language.Haskell.TH + +main :: IO () +main = mapM_ putStrLn [show an_integral, show an_int, show an_integer, + show an_char, show an_string, show an_fractional, + show an_float, show an_double] + +an_integral :: Integer +an_integral = $( [| 42 |] ) + +an_int :: Int +an_int = $( [| 42 :: Int |] ) + +an_integer :: Integer +an_integer = $( [| 98765432123456789876 :: Integer |] ) + +an_char :: Char +an_char = $( [| 'x' |] ) + +an_string :: String +an_string = $( [| "A String" |] ) + +an_fractional :: Double +an_fractional = $( [| 1.2 |] ) + +an_float :: Float +an_float = $( [| 1.2 :: Float |] ) + +an_double :: Double +an_double = $( [| 1.2 :: Double |] ) + diff --git a/testsuite/tests/th/TH_repE2.stdout b/testsuite/tests/th/TH_repE2.stdout new file mode 100644 index 0000000000..fe25631577 --- /dev/null +++ b/testsuite/tests/th/TH_repE2.stdout @@ -0,0 +1,8 @@ +42 +42 +98765432123456789876 +'x' +"A String" +1.2 +1.2 +1.2 diff --git a/testsuite/tests/th/TH_repE3.hs b/testsuite/tests/th/TH_repE3.hs new file mode 100644 index 0000000000..5f0453c1a7 --- /dev/null +++ b/testsuite/tests/th/TH_repE3.hs @@ -0,0 +1,19 @@ +-- test the representation of literals and also explicit type annotations + +module TH_repE1 +where + +import Language.Haskell.TH + +emptyListExpr :: ExpQ +emptyListExpr = [| [] |] + +singletonListExpr :: ExpQ +singletonListExpr = [| [4] |] + +listExpr :: ExpQ +listExpr = [| [4,5,6] |] + +consExpr :: ExpQ +consExpr = [| 4:5:6:[] |] + diff --git a/testsuite/tests/th/TH_repGuard.hs b/testsuite/tests/th/TH_repGuard.hs new file mode 100644 index 0000000000..b2ab4af6d6 --- /dev/null +++ b/testsuite/tests/th/TH_repGuard.hs @@ -0,0 +1,35 @@ + +module Main +where + +import Language.Haskell.TH +import System.IO + +$( + do ds <- [d| + foo :: Int -> Int + foo x + | x == 5 = 6 + foo x = 7 + |] + runIO $ do { putStrLn (pprint ds); hFlush stdout } + return ds + ) + +$( + do ds <- [d| + bar :: Maybe Int -> Int + bar x + | Just y <- x = y + bar _ = 9 + |] + runIO $ do { putStrLn (pprint ds) ; hFlush stdout } + return ds + ) + +main :: IO () +main = do putStrLn $ show $ foo 5 + putStrLn $ show $ foo 8 + putStrLn $ show $ bar (Just 2) + putStrLn $ show $ bar Nothing + diff --git a/testsuite/tests/th/TH_repGuard.stderr b/testsuite/tests/th/TH_repGuard.stderr new file mode 100644 index 0000000000..c0a4dd7cba --- /dev/null +++ b/testsuite/tests/th/TH_repGuard.stderr @@ -0,0 +1,7 @@ +foo_0 :: GHC.Types.Int -> GHC.Types.Int
+foo_0 x_1 | x_1 GHC.Classes.== 5 = 6
+foo_0 x_2 = 7
+bar_0 :: Data.Maybe.Maybe GHC.Types.Int -> GHC.Types.Int
+bar_0 x_1 | Data.Maybe.Just y_2 <- x_1
+ = y_2
+bar_0 _ = 9
diff --git a/testsuite/tests/th/TH_repGuardOutput.hs b/testsuite/tests/th/TH_repGuardOutput.hs new file mode 100644 index 0000000000..8335bf3231 --- /dev/null +++ b/testsuite/tests/th/TH_repGuardOutput.hs @@ -0,0 +1,29 @@ +-- test the representation of unboxed literals + +module Main +where + +$( + [d| + foo :: Int -> Int + foo x + | x == 5 = 6 + foo x = 7 + |] + ) + +$( + [d| + bar :: Maybe Int -> Int + bar x + | Just y <- x = y + bar _ = 9 + |] + ) + +main :: IO () +main = do putStrLn $ show $ foo 5 + putStrLn $ show $ foo 8 + putStrLn $ show $ bar (Just 2) + putStrLn $ show $ bar Nothing + diff --git a/testsuite/tests/th/TH_repGuardOutput.stdout b/testsuite/tests/th/TH_repGuardOutput.stdout new file mode 100644 index 0000000000..2cf95803c4 --- /dev/null +++ b/testsuite/tests/th/TH_repGuardOutput.stdout @@ -0,0 +1,4 @@ +6 +7 +2 +9 diff --git a/testsuite/tests/th/TH_repPatSig.hs b/testsuite/tests/th/TH_repPatSig.hs new file mode 100644 index 0000000000..3f504ff372 --- /dev/null +++ b/testsuite/tests/th/TH_repPatSig.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- test the representation of unboxed literals + +module Main +where + +import Language.Haskell.TH + +$( + [d| + foo :: Int -> Int + foo (x :: Int) = x + |] + ) + +main :: IO () +main = return () + diff --git a/testsuite/tests/th/TH_repPatSig.stderr b/testsuite/tests/th/TH_repPatSig.stderr new file mode 100644 index 0000000000..7269068d7d --- /dev/null +++ b/testsuite/tests/th/TH_repPatSig.stderr @@ -0,0 +1,4 @@ + +TH_repPatSig.hs:10:3: + Type signatures in patterns not (yet) handled by Template Haskell + x :: Int diff --git a/testsuite/tests/th/TH_repPrim.hs b/testsuite/tests/th/TH_repPrim.hs new file mode 100644 index 0000000000..2be35b1424 --- /dev/null +++ b/testsuite/tests/th/TH_repPrim.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE MagicHash #-} +-- test the representation of unboxed literals + +module Main where + +import GHC.Exts +import GHC.Float +import Language.Haskell.TH +import Text.PrettyPrint +import System.IO + +main :: IO () +main = do putStrLn $ show $ $( do e <- [| I# 20# |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + return e ) + putStrLn $ show $ $( do e <- [| W# 32## |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + return e ) + putStrLn $ show $ $( do e <- [| F# 12.3# |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + return e ) + putStrLn $ show $ $( do e <- [| D# 24.6## |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + return e ) + diff --git a/testsuite/tests/th/TH_repPrim.stderr b/testsuite/tests/th/TH_repPrim.stderr new file mode 100644 index 0000000000..33317c6205 --- /dev/null +++ b/testsuite/tests/th/TH_repPrim.stderr @@ -0,0 +1,8 @@ +AppE (ConE GHC.Types.I#) (LitE (IntPrimL 20)) +GHC.Types.I# 20# +AppE (ConE GHC.Types.W#) (LitE (WordPrimL 32)) +GHC.Types.W# 32## +AppE (ConE GHC.Types.F#) (LitE (FloatPrimL (123 % 10))) +GHC.Types.F# 12.3# +AppE (ConE GHC.Types.D#) (LitE (DoublePrimL (123 % 5))) +GHC.Types.D# 24.6## diff --git a/testsuite/tests/th/TH_repPrim2.hs b/testsuite/tests/th/TH_repPrim2.hs new file mode 100644 index 0000000000..994390a767 --- /dev/null +++ b/testsuite/tests/th/TH_repPrim2.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +-- test the representation of unboxed literals + +module Main where + +import GHC.Exts +import GHC.Float +import Language.Haskell.TH +import Text.PrettyPrint +import System.IO + +main :: IO () +main = do putStrLn $ show $ $( do e <- [| 20# |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + [| I# $( return e) |] ) + putStrLn $ show $ $( do e <- [| 32## |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + [| W# $(return e) |] ) + putStrLn $ show $ $( do e <- [| 12.3# |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + [| F# $(return e) |] ) + putStrLn $ show $ $( do e <- [| 24.6## |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + [| D# $(return e) |] ) + diff --git a/testsuite/tests/th/TH_repPrim2.stderr b/testsuite/tests/th/TH_repPrim2.stderr new file mode 100644 index 0000000000..e2a9458d45 --- /dev/null +++ b/testsuite/tests/th/TH_repPrim2.stderr @@ -0,0 +1,8 @@ +LitE (IntPrimL 20) +20# +LitE (WordPrimL 32) +32## +LitE (FloatPrimL (123 % 10)) +12.3# +LitE (DoublePrimL (123 % 5)) +24.6## diff --git a/testsuite/tests/th/TH_repPrimOutput.hs b/testsuite/tests/th/TH_repPrimOutput.hs new file mode 100644 index 0000000000..721b15dd2c --- /dev/null +++ b/testsuite/tests/th/TH_repPrimOutput.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE MagicHash #-} +-- test the representation of unboxed literals + +module Main +where + +import GHC.Exts +import GHC.Float +import Language.Haskell.TH +import Text.PrettyPrint +import System.IO + +main :: IO () +main = do putStrLn $ show $ $( do e <- [| I# 20# |] + return e ) + putStrLn $ show $ $( do e <- [| W# 32## |] + return e ) + putStrLn $ show $ $( do e <- [| F# 12.3# |] + return e ) + putStrLn $ show $ $( do e <- [| D# 24.6## |] + return e ) + + diff --git a/testsuite/tests/th/TH_repPrimOutput.stdout b/testsuite/tests/th/TH_repPrimOutput.stdout new file mode 100644 index 0000000000..0dcc51aeb6 --- /dev/null +++ b/testsuite/tests/th/TH_repPrimOutput.stdout @@ -0,0 +1,4 @@ +20 +32 +12.3 +24.6 diff --git a/testsuite/tests/th/TH_repPrimOutput2.hs b/testsuite/tests/th/TH_repPrimOutput2.hs new file mode 100644 index 0000000000..a7282064db --- /dev/null +++ b/testsuite/tests/th/TH_repPrimOutput2.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE MagicHash, UnboxedTuples #-} +-- test the representation of unboxed literals + +module Main +where + +import GHC.Exts +import GHC.Float +import Language.Haskell.TH +import Text.PrettyPrint +import System.IO + +main :: IO () +main = do putStrLn $ show $ $( do e <- [| 20# |] + [| I# $(return e) |] ) + putStrLn $ show $ $( do e <- [| 32## |] + [| W# $(return e) |] ) + putStrLn $ show $ $( do e <- [| 12.3# |] + [| F# $(return e) |] ) + putStrLn $ show $ $( do e <- [| 24.6## |] + [| D# $(return e) |] ) + + diff --git a/testsuite/tests/th/TH_repPrimOutput2.stdout b/testsuite/tests/th/TH_repPrimOutput2.stdout new file mode 100644 index 0000000000..0dcc51aeb6 --- /dev/null +++ b/testsuite/tests/th/TH_repPrimOutput2.stdout @@ -0,0 +1,4 @@ +20 +32 +12.3 +24.6 diff --git a/testsuite/tests/th/TH_repUnboxedTuples.hs b/testsuite/tests/th/TH_repUnboxedTuples.hs new file mode 100644 index 0000000000..30b6a5e2a8 --- /dev/null +++ b/testsuite/tests/th/TH_repUnboxedTuples.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE TemplateHaskell, UnboxedTuples #-} +-- test the representation of unboxed tuples + +module Main where + +import GHC.Exts +import GHC.Float +import Language.Haskell.TH +import Text.PrettyPrint +import System.IO + +main :: IO () +main = case bar () of + (# str, int #) -> + print (str, int) + +bar :: () -> (# String, Int #) +bar () = $( do e <- [| case (# 'b', False #) of + (# 'a', True #) -> (# "One", 1 #) + (# 'b', False #) -> (# "Two", 2 #) + (# _, _ #) -> (# "Three", 3 #) + |] + runIO $ putStrLn $ show e + runIO $ putStrLn $ pprint e + runIO $ hFlush stdout + return e ) + diff --git a/testsuite/tests/th/TH_repUnboxedTuples.stderr b/testsuite/tests/th/TH_repUnboxedTuples.stderr new file mode 100644 index 0000000000..d5bfa68bec --- /dev/null +++ b/testsuite/tests/th/TH_repUnboxedTuples.stderr @@ -0,0 +1,5 @@ +CaseE (UnboxedTupE [LitE (CharL 'b'),ConE GHC.Types.False]) [Match (UnboxedTupP [LitP (CharL 'a'),ConP GHC.Types.True []]) (NormalB (UnboxedTupE [LitE (StringL "One"),LitE (IntegerL 1)])) [],Match (UnboxedTupP [LitP (CharL 'b'),ConP GHC.Types.False []]) (NormalB (UnboxedTupE [LitE (StringL "Two"),LitE (IntegerL 2)])) [],Match (UnboxedTupP [WildP,WildP]) (NormalB (UnboxedTupE [LitE (StringL "Three"),LitE (IntegerL 3)])) []] +case (# 'b', GHC.Types.False #) of + (# 'a', GHC.Types.True #) -> (# "One", 1 #) + (# 'b', GHC.Types.False #) -> (# "Two", 2 #) + (# _, _ #) -> (# "Three", 3 #) diff --git a/testsuite/tests/th/TH_runIO.hs b/testsuite/tests/th/TH_runIO.hs new file mode 100644 index 0000000000..7a1f4c3d70 --- /dev/null +++ b/testsuite/tests/th/TH_runIO.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- See Trac #1678 + +module TH where + +import Language.Haskell.TH + + +-- foo = $(fail "hi") + +foo = $(runIO (fail "hi")) diff --git a/testsuite/tests/th/TH_runIO.stderr b/testsuite/tests/th/TH_runIO.stderr new file mode 100644 index 0000000000..8173e8337c --- /dev/null +++ b/testsuite/tests/th/TH_runIO.stderr @@ -0,0 +1,6 @@ + +TH_runIO.hs:12:9: + Exception when trying to run compile-time code: + user error (hi) + Code: runIO (fail "hi") + In the splice: $(runIO (fail "hi")) diff --git a/testsuite/tests/th/TH_scope.hs b/testsuite/tests/th/TH_scope.hs new file mode 100644 index 0000000000..7674a5d1c0 --- /dev/null +++ b/testsuite/tests/th/TH_scope.hs @@ -0,0 +1,8 @@ +-- Test for Trac #2188 + +module TH_scope where + +f g = [d| f :: Int + f = g + g :: Int + g = 4 |] diff --git a/testsuite/tests/th/TH_scopedTvs.hs b/testsuite/tests/th/TH_scopedTvs.hs new file mode 100644 index 0000000000..015911fde8 --- /dev/null +++ b/testsuite/tests/th/TH_scopedTvs.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell, ScopedTypeVariables #-} +module Foo where + + +$([d| f :: forall a. a->a + f x = x::a + |]) diff --git a/testsuite/tests/th/TH_sections.hs b/testsuite/tests/th/TH_sections.hs new file mode 100644 index 0000000000..26d7db41ef --- /dev/null +++ b/testsuite/tests/th/TH_sections.hs @@ -0,0 +1,11 @@ + +-- Test for trac #2956 + +module TH_sections where + +two :: Int +two = $( [| (1 +) 1 |] ) + +three :: Int +three = $( [| (+ 2) 1 |] ) + diff --git a/testsuite/tests/th/TH_spliceD1.hs b/testsuite/tests/th/TH_spliceD1.hs new file mode 100644 index 0000000000..f641874672 --- /dev/null +++ b/testsuite/tests/th/TH_spliceD1.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- We should get a civilised report of conflicting variable +-- bindings in the definition spliced in by foo + +module TH_spliceD1 where + +import TH_spliceD1_Lib + +$(foo) diff --git a/testsuite/tests/th/TH_spliceD1.stderr b/testsuite/tests/th/TH_spliceD1.stderr new file mode 100644 index 0000000000..2a93bb4f5a --- /dev/null +++ b/testsuite/tests/th/TH_spliceD1.stderr @@ -0,0 +1,6 @@ + +TH_spliceD1.hs:10:3: + Conflicting definitions for ‛c’ + Bound at: TH_spliceD1.hs:10:3-5 + TH_spliceD1.hs:10:3-5 + In an equation for ‛f’ diff --git a/testsuite/tests/th/TH_spliceD1_Lib.hs b/testsuite/tests/th/TH_spliceD1_Lib.hs new file mode 100644 index 0000000000..47ffa4e4e6 --- /dev/null +++ b/testsuite/tests/th/TH_spliceD1_Lib.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} + +module TH_spliceD1_Lib where +import Language.Haskell.TH + +foo :: Q [Dec] +foo = sequence [funD (mkName "f") + [ + clause + [varP $ mkName "c",varP $ mkName "c"] + (normalB $ [| undefined |]) + [] + ]] diff --git a/testsuite/tests/th/TH_spliceD2.hs b/testsuite/tests/th/TH_spliceD2.hs new file mode 100644 index 0000000000..f42672eda3 --- /dev/null +++ b/testsuite/tests/th/TH_spliceD2.hs @@ -0,0 +1,5 @@ +module TH_spliceD2 where + +import qualified TH_spliceD2_Lib + +$( [d| data T = T TH_spliceD2_Lib.T |] ) diff --git a/testsuite/tests/th/TH_spliceD2_Lib.hs b/testsuite/tests/th/TH_spliceD2_Lib.hs new file mode 100644 index 0000000000..5a8799f4d0 --- /dev/null +++ b/testsuite/tests/th/TH_spliceD2_Lib.hs @@ -0,0 +1,3 @@ +module TH_spliceD2_Lib where + +data T = T Int diff --git a/testsuite/tests/th/TH_spliceDecl1.hs b/testsuite/tests/th/TH_spliceDecl1.hs new file mode 100644 index 0000000000..618218d3eb --- /dev/null +++ b/testsuite/tests/th/TH_spliceDecl1.hs @@ -0,0 +1,10 @@ +-- test splicing of a generated data declarations + +module TH_spliceDecl1 +where + +import Language.Haskell.TH + + +-- splice a simple data declaration +$(return [DataD [] (mkName "T") [] [NormalC (mkName "C") []] []]) diff --git a/testsuite/tests/th/TH_spliceDecl2.hs b/testsuite/tests/th/TH_spliceDecl2.hs new file mode 100644 index 0000000000..e7f92d2c11 --- /dev/null +++ b/testsuite/tests/th/TH_spliceDecl2.hs @@ -0,0 +1,11 @@ +-- test splicing of quoted data and newtype declarations + +module TH_spliceDecl2 +where + +import Language.Haskell.TH + +-- splice a simple quoted declaration (x 2) +$([d| data T1 = C1 |]) + +$([d| newtype T2 = C2 String |]) diff --git a/testsuite/tests/th/TH_spliceDecl3.hs b/testsuite/tests/th/TH_spliceDecl3.hs new file mode 100644 index 0000000000..28ea4b6d64 --- /dev/null +++ b/testsuite/tests/th/TH_spliceDecl3.hs @@ -0,0 +1,11 @@ +-- test splicing of reified and renamed data declarations + +module TH_spliceDecl3 +where + +import Language.Haskell.TH +import TH_spliceDecl3_Lib + +data T = C + +$(do { TyConI d <- reify ''T; rename' d}) diff --git a/testsuite/tests/th/TH_spliceDecl3_Lib.hs b/testsuite/tests/th/TH_spliceDecl3_Lib.hs new file mode 100644 index 0000000000..1b8d44e781 --- /dev/null +++ b/testsuite/tests/th/TH_spliceDecl3_Lib.hs @@ -0,0 +1,12 @@ +module TH_spliceDecl3_Lib +where + +import Language.Haskell.TH + +rename' :: Dec -> Q [Dec] +rename' (DataD ctxt tyName tyvars cons derivs) = + return [DataD ctxt (stripMod tyName) tyvars (map renameCons cons) derivs] + where + renameCons (NormalC conName tys) = NormalC (stripMod conName) tys + -- + stripMod v = mkName (nameBase v ++ "'") diff --git a/testsuite/tests/th/TH_spliceDecl4.hs b/testsuite/tests/th/TH_spliceDecl4.hs new file mode 100644 index 0000000000..795ed2ae00 --- /dev/null +++ b/testsuite/tests/th/TH_spliceDecl4.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell, UndecidableInstances, FlexibleInstances, TypeSynonymInstances #-} + +module TH_spliceDecl4 where + +import TH_spliceDecl4_Lib + +instance IncrSelf String where + incrSelf x = x ++ "x" + +$(instanceIncrSelfTuple 2) + + diff --git a/testsuite/tests/th/TH_spliceDecl4_Lib.hs b/testsuite/tests/th/TH_spliceDecl4_Lib.hs new file mode 100644 index 0000000000..104cba33c6 --- /dev/null +++ b/testsuite/tests/th/TH_spliceDecl4_Lib.hs @@ -0,0 +1,21 @@ + +{-# LANGUAGE TemplateHaskell, UndecidableInstances #-} + +module TH_spliceDecl4_Lib( + instanceIncrSelfTuple, + IncrSelf(..) +) +where +import Control.Monad +import Data.Maybe +import Language.Haskell.TH + +class IncrSelf a where + incrSelf :: a -> a + + + +instanceIncrSelfTuple :: Int -> Q [Dec] +instanceIncrSelfTuple n = [d| incrSelf value = True |] + + diff --git a/testsuite/tests/th/TH_spliceE1.hs b/testsuite/tests/th/TH_spliceE1.hs new file mode 100644 index 0000000000..bb12cbf277 --- /dev/null +++ b/testsuite/tests/th/TH_spliceE1.hs @@ -0,0 +1,6 @@ +module Main where + +my_id :: a -> a +my_id x = $( [| x |] ) + +main = print (my_id "hello") diff --git a/testsuite/tests/th/TH_spliceE1.stdout b/testsuite/tests/th/TH_spliceE1.stdout new file mode 100644 index 0000000000..3580093b9d --- /dev/null +++ b/testsuite/tests/th/TH_spliceE1.stdout @@ -0,0 +1 @@ +"hello" diff --git a/testsuite/tests/th/TH_spliceE3.hs b/testsuite/tests/th/TH_spliceE3.hs new file mode 100644 index 0000000000..c72ab79b50 --- /dev/null +++ b/testsuite/tests/th/TH_spliceE3.hs @@ -0,0 +1,25 @@ +-- test the representation of literals and also explicit type annotations + +module TH_repE1 +where + +import Language.Haskell.TH + +$( do let emptyListExpr :: ExpQ + emptyListExpr = [| [] |] + + singletonListExpr :: ExpQ + singletonListExpr = [| [4] |] + + listExpr :: ExpQ + listExpr = [| [4,5,6] |] + + consExpr :: ExpQ + consExpr = [| 4:5:6:[] |] + + [d| foo = ($emptyListExpr, $singletonListExpr, $listExpr, $consExpr) |] + ) + +bar = $( [| case undefined of + [1] -> 1 |] ) + diff --git a/testsuite/tests/th/TH_spliceE4.hs b/testsuite/tests/th/TH_spliceE4.hs new file mode 100644 index 0000000000..99ee7a7648 --- /dev/null +++ b/testsuite/tests/th/TH_spliceE4.hs @@ -0,0 +1,13 @@ + +module Main where + +import Language.Haskell.TH + +$( do let h x = x + foo = [| \x -> $(h [| x |]) |] + + [d| baz = $foo |] + ) + +main = print (baz "Hello") + diff --git a/testsuite/tests/th/TH_spliceE4.stdout b/testsuite/tests/th/TH_spliceE4.stdout new file mode 100644 index 0000000000..4b849dbdb3 --- /dev/null +++ b/testsuite/tests/th/TH_spliceE4.stdout @@ -0,0 +1 @@ +"Hello" diff --git a/testsuite/tests/th/TH_spliceE5.hs b/testsuite/tests/th/TH_spliceE5.hs new file mode 100644 index 0000000000..a8b25f0490 --- /dev/null +++ b/testsuite/tests/th/TH_spliceE5.hs @@ -0,0 +1,15 @@ + +module Main where + +import TH_spliceE5_Lib + +v1 = "foo" + +main = putStrLn $(expandVars ["v1","v2"]) +-- The splice expands to refer to both v1 and v2, +-- and the test checks that we don't dependency-analyse +-- the program so that one or the other isn't in scope +-- to the type checker + + +v2 = "bar" diff --git a/testsuite/tests/th/TH_spliceE5.stdout b/testsuite/tests/th/TH_spliceE5.stdout new file mode 100644 index 0000000000..323fae03f4 --- /dev/null +++ b/testsuite/tests/th/TH_spliceE5.stdout @@ -0,0 +1 @@ +foobar diff --git a/testsuite/tests/th/TH_spliceE5_Lib.hs b/testsuite/tests/th/TH_spliceE5_Lib.hs new file mode 100644 index 0000000000..20a9300df4 --- /dev/null +++ b/testsuite/tests/th/TH_spliceE5_Lib.hs @@ -0,0 +1,10 @@ + +module TH_spliceE5_Lib where + +import Language.Haskell.TH + +expandVars :: [String] -> Q Exp +expandVars s = [| concat $(return (ListE (map f s))) |] + where + f x = VarE (mkName x) + diff --git a/testsuite/tests/th/TH_spliceE5_prof.hs b/testsuite/tests/th/TH_spliceE5_prof.hs new file mode 100644 index 0000000000..8c799193e5 --- /dev/null +++ b/testsuite/tests/th/TH_spliceE5_prof.hs @@ -0,0 +1,15 @@ + +module Main where + +import TH_spliceE5_prof_Lib + +v1 = "foo" + +main = putStrLn $(expandVars ["v1","v2"]) +-- The splice expands to refer to both v1 and v2, +-- and the test checks that we don't dependency-analyse +-- the program so that one or the other isn't in scope +-- to the type checker + + +v2 = "bar" diff --git a/testsuite/tests/th/TH_spliceE5_prof.stdout b/testsuite/tests/th/TH_spliceE5_prof.stdout new file mode 100644 index 0000000000..323fae03f4 --- /dev/null +++ b/testsuite/tests/th/TH_spliceE5_prof.stdout @@ -0,0 +1 @@ +foobar diff --git a/testsuite/tests/th/TH_spliceE5_prof_Lib.hs b/testsuite/tests/th/TH_spliceE5_prof_Lib.hs new file mode 100644 index 0000000000..1d1417e7ac --- /dev/null +++ b/testsuite/tests/th/TH_spliceE5_prof_Lib.hs @@ -0,0 +1,10 @@ + +module TH_spliceE5_prof_Lib where + +import Language.Haskell.TH + +expandVars :: [String] -> Q Exp +expandVars s = [| concat $(return (ListE (map f s))) |] + where + f x = VarE (mkName x) + diff --git a/testsuite/tests/th/TH_spliceE6.hs b/testsuite/tests/th/TH_spliceE6.hs new file mode 100644 index 0000000000..0ba1ba5fc4 --- /dev/null +++ b/testsuite/tests/th/TH_spliceE6.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- This failed in 6.10.1, as the Name's for True and False in +-- Language.Haskell.TH.Syntax.{trueName,falseName} were wrong. + +module TH_spliceE6 where + +a = $( (\b -> [| b |]) True ) +b = $( (\m -> [| m |]) (Just 'm') ) +c = $( (\e -> [| e |]) (Left 'e' :: Either Char Bool) ) + diff --git a/testsuite/tests/th/TH_spliceExpr1.hs b/testsuite/tests/th/TH_spliceExpr1.hs new file mode 100644 index 0000000000..1a22f6f667 --- /dev/null +++ b/testsuite/tests/th/TH_spliceExpr1.hs @@ -0,0 +1,10 @@ +-- test representation and splicing of left-parenthesised right infix operators + +module TH_spliceExpr1 +where + +import Language.Haskell.TH + +foo :: Int +foo = $( [| ((+) $ 2) $ 2 |] ) + diff --git a/testsuite/tests/th/TH_spliceGuard.hs b/testsuite/tests/th/TH_spliceGuard.hs new file mode 100644 index 0000000000..4c220e85b5 --- /dev/null +++ b/testsuite/tests/th/TH_spliceGuard.hs @@ -0,0 +1,13 @@ +{-# OPTIONS_GHC -XTemplateHaskell #-} + +-- Trac #2017 + +module ShouldCompile where + + import Language.Haskell.TH + + $(do e <- [d| f a b + | a == b = a + | otherwise = b |] + return e) + diff --git a/testsuite/tests/th/TH_spliceInst.hs b/testsuite/tests/th/TH_spliceInst.hs new file mode 100644 index 0000000000..fd0918ce78 --- /dev/null +++ b/testsuite/tests/th/TH_spliceInst.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Tickles a GHC 6.4 buglet + +module ShouldCompile where + +class Foo a where + foo :: a -> a + foo = id + +-- Splice an instance decl that uses the default method +$( [d| instance Foo () where |] ) + + + diff --git a/testsuite/tests/th/TH_spliceViewPat/A.hs b/testsuite/tests/th/TH_spliceViewPat/A.hs new file mode 100644 index 0000000000..0147d2eca2 --- /dev/null +++ b/testsuite/tests/th/TH_spliceViewPat/A.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ViewPatterns #-} +module A where + +import Language.Haskell.TH.Quote +import Language.Haskell.TH + +foo :: QuasiQuoter +foo = QuasiQuoter{quotePat = \s -> viewP [|(*2)|] (varP . mkName $ s)} + +bar :: QuasiQuoter +bar = QuasiQuoter{quotePat = \_ -> [p|((*3) -> fixed_var)|] } diff --git a/testsuite/tests/th/TH_spliceViewPat/Main.hs b/testsuite/tests/th/TH_spliceViewPat/Main.hs new file mode 100644 index 0000000000..675ae99bf9 --- /dev/null +++ b/testsuite/tests/th/TH_spliceViewPat/Main.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE QuasiQuotes, ViewPatterns #-} + +module Main where + +import A + +main = do + case 1 of + [foo|x|] -> print x + case 1 of + [bar|<!anything~|] -> print fixed_var diff --git a/testsuite/tests/th/TH_spliceViewPat/Makefile b/testsuite/tests/th/TH_spliceViewPat/Makefile new file mode 100644 index 0000000000..4a268530f1 --- /dev/null +++ b/testsuite/tests/th/TH_spliceViewPat/Makefile @@ -0,0 +1,4 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + diff --git a/testsuite/tests/th/TH_spliceViewPat/TH_spliceViewPat.stdout b/testsuite/tests/th/TH_spliceViewPat/TH_spliceViewPat.stdout new file mode 100644 index 0000000000..4792e70f33 --- /dev/null +++ b/testsuite/tests/th/TH_spliceViewPat/TH_spliceViewPat.stdout @@ -0,0 +1,2 @@ +2 +3 diff --git a/testsuite/tests/th/TH_spliceViewPat/test.T b/testsuite/tests/th/TH_spliceViewPat/test.T new file mode 100644 index 0000000000..c08e7cb6f5 --- /dev/null +++ b/testsuite/tests/th/TH_spliceViewPat/test.T @@ -0,0 +1,14 @@ +def f(name, opts): + opts.extra_hc_opts = '-XTemplateHaskell -package template-haskell' + if (ghc_with_interpreter == 0): + opts.skip = 1 + +setTestOpts(f) +setTestOpts(only_compiler_types(['ghc'])) +setTestOpts(only_ways(['normal','ghci'])) +setTestOpts(when(compiler_profiled(), skip)) + +test('TH_spliceViewPat', + extra_clean(['Main.o', 'Main.hi', 'A.o', 'A.hi']), + multimod_compile_and_run, + ['Main', config.ghc_th_way_flags]) diff --git a/testsuite/tests/th/TH_tf1.hs b/testsuite/tests/th/TH_tf1.hs new file mode 100644 index 0000000000..2b5d3f8887 --- /dev/null +++ b/testsuite/tests/th/TH_tf1.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TypeFamilies #-} + +module TH_tf1 where + +$( [d| data family T a |] ) +$( [d| data instance T Int = TInt Bool |] ) + +foo :: Bool -> T Int +foo b = TInt (b && b) + +$( [d| type family S a |] ) +$( [d| type instance S Int = Bool |] ) + +bar :: S Int -> Int +bar c = if c then 1 else 2 + +$( [d| type family R (a :: * -> *) :: * -> * |] ) +$( [d| type instance R Maybe = [] |] ) + +baz :: R Maybe Int -> Int +baz = head diff --git a/testsuite/tests/th/TH_tf2.hs b/testsuite/tests/th/TH_tf2.hs new file mode 100644 index 0000000000..94be291324 --- /dev/null +++ b/testsuite/tests/th/TH_tf2.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TypeFamilies #-} + +module TH_tf2 where + +{- +$( [d| class C a where + data T a + foo :: Bool -> T a |] ) + +$( [d| instance C Int where + data T Int = TInt Bool + foo b = TInt (b && b) |] ) + +$( [d| instance C Float where + data T Float = TFloat {flag :: Bool} + foo b = TFloat {flag = b && b} |] ) +-} + +class D a where + type S a + bar :: S a -> Int + +instance D Int where + type S Int = Bool + bar c = if c then 1 else 2 diff --git a/testsuite/tests/th/TH_tf3.hs b/testsuite/tests/th/TH_tf3.hs new file mode 100644 index 0000000000..08e089fdf1 --- /dev/null +++ b/testsuite/tests/th/TH_tf3.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances, UndecidableInstances #-} + +module TH_tf3 where + +type family T a + +$( [d| foo :: T [a] ~ Bool => a -> a + foo x = x |] ) + +$( [d| class C a + instance a ~ Int => C a |] )
\ No newline at end of file diff --git a/testsuite/tests/th/TH_tuple1.hs b/testsuite/tests/th/TH_tuple1.hs new file mode 100644 index 0000000000..c3469e4a97 --- /dev/null +++ b/testsuite/tests/th/TH_tuple1.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- Test the use of tupleDataName, tupleTypeName + +module ShouldCompile where + +import Language.Haskell.TH + +foo = $( sigE (appsE [conE (tupleDataName 2), + litE (integerL 1), + litE (integerL 2)]) + (appT (appT (conT (tupleTypeName 2)) + (conT ''Integer)) + (conT ''Integer)) + ) diff --git a/testsuite/tests/th/TH_unboxedSingleton.hs b/testsuite/tests/th/TH_unboxedSingleton.hs new file mode 100644 index 0000000000..d932285870 --- /dev/null +++ b/testsuite/tests/th/TH_unboxedSingleton.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell, UnboxedTuples #-} + +module TH_unboxedSingleton where + +f :: () -> (# Int #) +f () = $( [| (# 3 #) |] ) + diff --git a/testsuite/tests/th/TH_unresolvedInfix.hs b/testsuite/tests/th/TH_unresolvedInfix.hs new file mode 100644 index 0000000000..03e97cf804 --- /dev/null +++ b/testsuite/tests/th/TH_unresolvedInfix.hs @@ -0,0 +1,109 @@ +{-# LANGUAGE QuasiQuotes #-} + +module Main where + +import TH_unresolvedInfix_Lib +import Language.Haskell.TH + +-------------------------------------------------------------------------------- +-- Expressions -- +-------------------------------------------------------------------------------- +exprs = [ +-------------- Completely-unresolved bindings + $( n +? (n *? n) ), + $( (n +? n) *? n ), + $( n +? (n +? n) ), + $( (n +? n) +? n ), + -- VarE version + $( uInfixE n plus2 (uInfixE n plus2 n) ), + $( uInfixE (uInfixE n plus2 n) plus2 n ), + $( uInfixE n plus3 (uInfixE n plus3 n) ), + $( uInfixE (uInfixE n plus3 n) plus3 n ), + +--------------- Completely-resolved bindings + $( n +! (n *! n) ), + $( (n +! n) *! n ), + $( n +! (n +! n) ), + $( (n +! n) +! n ), + +-------------- Mixed resolved/unresolved + $( (n +! n) *? (n +? n) ), + $( (n +? n) *? (n +! n) ), + $( (n +? n) *! (n +! n) ), + $( (n +? n) *! (n +? n) ), + +-------------- Parens + $( ((parensE ((n +? n) *? n)) +? n) *? n ), + $( (parensE (n +? n)) *? (parensE (n +? n)) ), + $( parensE ((n +? n) *? (n +? n)) ), + +-------------- Sections + $( infixE (Just $ n +? n) plus Nothing ) N, + -- see B.hs for the (non-compiling) other version of the above + $( infixE Nothing plus (Just $ parensE $ uInfixE n plus n) ) N, + +-------------- Dropping constructors + $( n *? tupE [n +? n] ) + ] + +-------------------------------------------------------------------------------- +-- Patterns -- +-------------------------------------------------------------------------------- +patterns = [ +-------------- Completely-unresolved patterns + case N :+ (N :* N) of + [p1|unused|] -> True, + case N :+ (N :* N) of + [p2|unused|] -> True, + case (N :+ N) :+ N of + [p3|unused|] -> True, + case (N :+ N) :+ N of + [p4|unused|] -> True, +-------------- Completely-resolved patterns + case N :+ (N :* N) of + [p5|unused|] -> True, + case (N :+ N) :* N of + [p6|unused|] -> True, + case N :+ (N :+ N) of + [p7|unused|] -> True, + case (N :+ N) :+ N of + [p8|unused|] -> True, +-------------- Mixed resolved/unresolved + case ((N :+ N) :* N) :+ N of + [p9|unused|] -> True, + case N :+ (N :* (N :+ N)) of + [p10|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p11|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p12|unused|] -> True, +-------------- Parens + case (N :+ (N :* N)) :+ (N :* N) of + [p13|unused|] -> True, + case (N :+ N) :* (N :+ N) of + [p14|unused|] -> True, + case (N :+ (N :* N)) :+ N of + [p15|unused|] -> True, +-------------- Dropping constructors + case (N :* (N :+ N)) of + [p16|unused|] -> True + ] + +main = do + mapM_ print exprs + mapM_ print patterns + -- check that there are no Parens or UInfixes in the output + runQ [|N :* N :+ N|] >>= print + runQ [|(N :* N) :+ N|] >>= print + runQ [p|N :* N :+ N|] >>= print + runQ [p|(N :* N) :+ N|] >>= print + + -- pretty-printing of unresolved infix expressions + let ne = ConE $ mkName "N" + np = ConP (mkName "N") [] + plusE = ConE (mkName ":+") + plusP = (mkName ":+") + putStrLn $ pprint (InfixE (Just ne) plusE (Just $ UInfixE ne plusE (UInfixE ne plusE ne))) + putStrLn $ pprint (ParensE ne) + putStrLn $ pprint (InfixP np plusP (UInfixP np plusP (UInfixP np plusP np))) + putStrLn $ pprint (ParensP np) diff --git a/testsuite/tests/th/TH_unresolvedInfix.stdout b/testsuite/tests/th/TH_unresolvedInfix.stdout new file mode 100644 index 0000000000..9ef0da4f79 --- /dev/null +++ b/testsuite/tests/th/TH_unresolvedInfix.stdout @@ -0,0 +1,46 @@ +(N :+ (N :* N)) +(N :+ (N :* N)) +((N :+ N) :+ N) +((N :+ N) :+ N) +((N :+ N) :+ N) +((N :+ N) :+ N) +((N :+ N) :+ N) +((N :+ N) :+ N) +(N :+ (N :* N)) +((N :+ N) :* N) +(N :+ (N :+ N)) +((N :+ N) :+ N) +(((N :+ N) :* N) :+ N) +(N :+ (N :* (N :+ N))) +((N :+ N) :* (N :+ N)) +((N :+ N) :* (N :+ N)) +((N :+ (N :* N)) :+ (N :* N)) +((N :+ N) :* (N :+ N)) +((N :+ (N :* N)) :+ N) +((N :+ N) :+ N) +(N :+ (N :+ N)) +(N :* (N :+ N)) +True +True +True +True +True +True +True +True +True +True +True +True +True +True +True +True +InfixE (Just (InfixE (Just (ConE TH_unresolvedInfix_Lib.N)) (ConE TH_unresolvedInfix_Lib.:*) (Just (ConE TH_unresolvedInfix_Lib.N)))) (ConE TH_unresolvedInfix_Lib.:+) (Just (ConE TH_unresolvedInfix_Lib.N)) +InfixE (Just (InfixE (Just (ConE TH_unresolvedInfix_Lib.N)) (ConE TH_unresolvedInfix_Lib.:*) (Just (ConE TH_unresolvedInfix_Lib.N)))) (ConE TH_unresolvedInfix_Lib.:+) (Just (ConE TH_unresolvedInfix_Lib.N)) +InfixP (InfixP (ConP TH_unresolvedInfix_Lib.N []) TH_unresolvedInfix_Lib.:* (ConP TH_unresolvedInfix_Lib.N [])) TH_unresolvedInfix_Lib.:+ (ConP TH_unresolvedInfix_Lib.N []) +InfixP (InfixP (ConP TH_unresolvedInfix_Lib.N []) TH_unresolvedInfix_Lib.:* (ConP TH_unresolvedInfix_Lib.N [])) TH_unresolvedInfix_Lib.:+ (ConP TH_unresolvedInfix_Lib.N []) +N :+ (N :+ N :+ N) +(N) +N :+ (N :+ N :+ N) +(N) diff --git a/testsuite/tests/th/TH_unresolvedInfix2.hs b/testsuite/tests/th/TH_unresolvedInfix2.hs new file mode 100644 index 0000000000..eeba6e3a50 --- /dev/null +++ b/testsuite/tests/th/TH_unresolvedInfix2.hs @@ -0,0 +1,16 @@ +module TH_unresolvedInfix2 where + +import Language.Haskell.TH + +infixl 6 :+ + +data Tree = N + | Tree :+ Tree + | Tree :* Tree + +$(return []) + +-- Should fail +expr = $( let plus = conE '(:+) + n = conE 'N + in infixE Nothing plus (Just $ uInfixE n plus n) ) diff --git a/testsuite/tests/th/TH_unresolvedInfix2.stderr b/testsuite/tests/th/TH_unresolvedInfix2.stderr new file mode 100644 index 0000000000..4baa35a351 --- /dev/null +++ b/testsuite/tests/th/TH_unresolvedInfix2.stderr @@ -0,0 +1,11 @@ + +TH_unresolvedInfix2.hs:14:11: + The operator ‛:+’ [infixl 6] of a section + must have lower precedence than that of the operand, + namely ‛:+’ [infixl 6] + in the section: ‛:+ N :+ N’ + In the splice: + $(let + plus = conE ... + n = conE ... + in infixE Nothing plus (Just $ uInfixE n plus n)) diff --git a/testsuite/tests/th/TH_unresolvedInfix_Lib.hs b/testsuite/tests/th/TH_unresolvedInfix_Lib.hs new file mode 100644 index 0000000000..aa734ab9d4 --- /dev/null +++ b/testsuite/tests/th/TH_unresolvedInfix_Lib.hs @@ -0,0 +1,74 @@ +module TH_unresolvedInfix_Lib where + +import Language.Haskell.TH +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Quote + +infixl 6 :+ +infixl 7 :* + +data Tree = N + | Tree :+ Tree + | Tree :* Tree + +-- custom instance, including redundant parentheses +instance Show Tree where + show N = "N" + show (a :+ b) = "(" ++ show a ++ " :+ " ++ show b ++ ")" + show (a :* b) = "(" ++ show a ++ " :* " ++ show b ++ ")" + +-- VarE versions +infixl 6 +: +infixl 7 *: +(+:) = (:+) +(*:) = (:*) + +n = conE (mkName "N") +plus = conE (mkName ":+") +times = conE (mkName ":*") + +a +? b = uInfixE a plus b +a *? b = uInfixE a times b +a +! b = infixApp a plus b +a *! b = infixApp a times b + +plus2 = varE (mkName "+:") +times2 = varE (mkName "*:") +plus3 = conE ('(:+)) + + +-------------------------------------------------------------------------------- +-- Patterns -- +-------------------------------------------------------------------------------- +-- The only way to test pattern splices is using QuasiQuotation +mkQQ pat = QuasiQuoter undefined (const pat) undefined undefined +p = conP (mkName "N") [] +plus' = mkName ":+" +times' = mkName ":*" + +a ^+? b = uInfixP a plus' b +a ^*? b = uInfixP a times' b +a ^+! b = infixP a plus' b +a ^*! b = infixP a times' b + +-------------- Completely-unresolved patterns +p1 = mkQQ ( p ^+? (p ^*? p) ) +p2 = mkQQ ( (p ^+? p) ^*? p ) +p3 = mkQQ ( p ^+? (p ^+? p) ) +p4 = mkQQ ( (p ^+? p) ^+? p ) +-------------- Completely-resolved patterns +p5 = mkQQ ( p ^+! (p ^*! p) ) +p6 = mkQQ ( (p ^+! p) ^*! p ) +p7 = mkQQ ( p ^+! (p ^+! p) ) +p8 = mkQQ ( (p ^+! p) ^+! p ) +-------------- Mixed resolved/unresolved +p9 = mkQQ ( (p ^+! p) ^*? (p ^+? p) ) +p10 = mkQQ ( (p ^+? p) ^*? (p ^+! p) ) +p11 = mkQQ ( (p ^+? p) ^*! (p ^+! p) ) +p12 = mkQQ ( (p ^+? p) ^*! (p ^+? p) ) +-------------- Parens +p13 = mkQQ ( ((parensP ((p ^+? p) ^*? p)) ^+? p) ^*? p ) +p14 = mkQQ ( (parensP (p ^+? p)) ^*? (parensP (p ^+? p)) ) +p15 = mkQQ ( parensP ((p ^+? p) ^*? (p ^+? p)) ) +-------------- Dropping constructors +p16 = mkQQ ( p ^*? (tupP [p ^+? p]) ) diff --git a/testsuite/tests/th/TH_viewPatPrint.hs b/testsuite/tests/th/TH_viewPatPrint.hs new file mode 100644 index 0000000000..f0ef779691 --- /dev/null +++ b/testsuite/tests/th/TH_viewPatPrint.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ViewPatterns, QuasiQuotes #-} + +module Main where + +import Language.Haskell.TH + +main = do + p <- runQ [p|(id -> x)|] + print p + putStrLn (pprint p) diff --git a/testsuite/tests/th/TH_viewPatPrint.stdout b/testsuite/tests/th/TH_viewPatPrint.stdout new file mode 100644 index 0000000000..a995dae563 --- /dev/null +++ b/testsuite/tests/th/TH_viewPatPrint.stdout @@ -0,0 +1,2 @@ +ViewP (VarE GHC.Base.id) (VarP x_0)
+(GHC.Base.id -> x_0)
diff --git a/testsuite/tests/th/TH_where.hs b/testsuite/tests/th/TH_where.hs new file mode 100644 index 0000000000..94d8db76d4 --- /dev/null +++ b/testsuite/tests/th/TH_where.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Main where + +import Language.Haskell.TH + + +main = do {d <- runQ $ [| let { foo = bar where bar = 3 } in foo |]; print d} diff --git a/testsuite/tests/th/TH_where.stdout b/testsuite/tests/th/TH_where.stdout new file mode 100644 index 0000000000..14c7c1a864 --- /dev/null +++ b/testsuite/tests/th/TH_where.stdout @@ -0,0 +1 @@ +LetE [ValD (VarP foo_0) (NormalB (VarE bar_1)) [ValD (VarP bar_1) (NormalB (LitE (IntegerL 3))) []]] (VarE foo_0) diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T new file mode 100644 index 0000000000..5b064ba2ea --- /dev/null +++ b/testsuite/tests/th/all.T @@ -0,0 +1,319 @@ + +# This test needs to come before the setTestOpts calls below, as we want +# to run it if !compiler_profiled +test('T4255', unless(compiler_profiled(), skip), compile_fail, ['-v0']) + +def f(name, opts): + opts.extra_hc_opts = '-XTemplateHaskell -package template-haskell' + if (ghc_with_interpreter == 0): + opts.skip = 1 + +setTestOpts(f) +setTestOpts(only_compiler_types(['ghc'])) +setTestOpts(only_ways(['normal','ghci'])) +setTestOpts(when(compiler_profiled(), skip)) + +test('TH_mkName', normal, compile, ['-v0']) +test('TH_1tuple', normal, compile_fail, ['-v0']) + +test('TH_repE1', normal, compile, ['']) +test('TH_repE2', normal, compile_and_run, ['']) +test('TH_repE3', normal, compile, ['']) +test('TH_repPrim', normal, compile, ['-v0']) +test('TH_repPrim2', normal, compile, ['-v0']) +test('TH_repUnboxedTuples', normal, compile, ['-v0']) +test('TH_spliceGuard', normal, compile, ['-v0']) +test('TH_repPrimOutput', normal, compile_and_run, ['']) +test('TH_repPrimOutput2', normal, compile_and_run, ['']) +test('TH_repGuard', normal, compile, ['-v0']) +test('TH_repGuardOutput', normal, compile_and_run, ['']) +test('TH_repPatSig', normal, compile_fail, ['']) + +test('TH_spliceE5', + extra_clean(['TH_spliceE5_Lib.hi', 'TH_spliceE5_Lib.o']), + multimod_compile_and_run, + ['TH_spliceE5.hs', '-v0 ' + config.ghc_th_way_flags]) + +test('TH_spliceE6', normal, compile, ['-v0']) + +test('TH_NestedSplices', + extra_clean(['TH_NestedSplices_Lib.hi', 'TH_NestedSplices_Lib.o']), + multimod_compile, + ['TH_NestedSplices.hs', '-v0 ' + config.ghc_th_way_flags]) + +# Testing profiling with TH is a bit tricky; we've already disabled +# the prof way above, and also we want to add options specifically for +# profiling (-osuf p.o) because this is necessary when mixing +# profiling w/ TH. Furthermore we must have built the program the +# normal way first, which is why the work is done by a Makefile rule. +test('TH_spliceE5_prof', + [req_profiling, + omit_ways(['ghci']), + extra_clean(['TH_spliceE5_prof_Lib.p.o', 'TH_spliceE5_prof_Lib.hi', + 'TH_spliceE5_prof_Lib.o','TH_spliceE5_prof.p.o'])], + run_command, + ['$MAKE -s --no-print-directory TH_spliceE5_prof']) + +test('TH_spliceD1', + extra_clean(['TH_spliceD1_Lib.hi', 'TH_spliceD1_Lib.o']), + multimod_compile_fail, + ['TH_spliceD1', '-v0 ' + config.ghc_th_way_flags]) + +test('TH_spliceD2', + extra_clean(['TH_spliceD2_Lib.hi', 'TH_spliceD2_Lib.o']), + multimod_compile, + ['TH_spliceD2', '-v0']) + +test('TH_reifyDecl1', normal, compile, ['-v0']) +test('TH_reifyDecl2', normal, compile, ['-v0']) + +test('TH_reifyType1', normal, compile, ['']) +test('TH_reifyType2', normal, compile, ['']) +test('TH_reifyMkName', normal, compile, ['-v0']) + +test('TH_reifyInstances', normal, compile, ['-v0']) + +test('TH_spliceDecl1', normal, compile, ['-v0']) +test('TH_spliceDecl2', normal, compile, ['-v0']) +test('TH_spliceDecl3', + extra_clean(['TH_spliceDecl3_Lib.hi', 'TH_spliceDecl3_Lib.o']), + multimod_compile, + ['TH_spliceDecl3', '-v0 ' + config.ghc_th_way_flags]) +test('TH_spliceDecl4', + extra_clean(['TH_spliceDecl4_Lib.hi', 'TH_spliceDecl4_Lib.o']), + multimod_compile, + ['TH_spliceDecl4', '-v0 ' + config.ghc_th_way_flags]) + +test('T2597a', + extra_clean(['T2597a_Lib.hi', 'T2597a_Lib.o']), + multimod_compile, + ['T2597a', '-v0 ' + config.ghc_th_way_flags]) + +test('T2597b', + extra_clean(['T2597b_Lib.hi', 'T2597b_Lib.o']), + multimod_compile_fail, + ['T2597b', '-v0 ' + config.ghc_th_way_flags]) + +test('TH_spliceE1', normal, compile_and_run, ['']) +test('TH_spliceExpr1', normal, compile, ['-v0']) +test('TH_spliceE3', normal, compile, ['-v0']) +test('TH_spliceE4', normal, compile_and_run, ['']) + +test('TH_bracket1', normal, compile, ['']) +test('TH_bracket2', normal, compile, ['']) +test('TH_bracket3', normal, compile, ['']) + +test('TH_class1', normal, compile, ['-v0']) +test('TH_tuple1', normal, compile, ['-v0']) +test('TH_genEx', + extra_clean(['TH_genExLib.hi', 'TH_genExLib.o']), + multimod_compile, + ['TH_genEx', '-v0 ' + config.ghc_th_way_flags]) + +test('TH_where', normal, compile_and_run, ['']) + +test('TH_spliceInst', normal, compile, ['-v0']) + +test('TH_exn1', normal, compile_fail, ['-v0']) + +test('TH_dupdecl', normal, compile_fail, ['-v0']) +test('TH_exn2', normal, compile_fail, ['-v0']) + +test('TH_recover', normal, compile_and_run, ['']) +test('TH_dataD1', normal, compile, ['-v0']) + +test('TH_ppr1', normal, compile_and_run, ['']) + +test('TH_fail', normal, compile_fail, ['-v0']) +test('TH_scopedTvs', normal, compile, ['-v0']) + +test('TH_runIO', normal, compile_fail, ['-v0']) + +test('TH_ghci1', normal, ghci_script, ['TH_ghci1.script']) + +test('TH_scope', normal, compile, ['']) +test('T2632', normal, compile, ['']) +test('T2700', normal, compile, ['-v0']) +test('T2817', normal, compile, ['-v0']) +test('T2713', normal, compile_fail, ['-v0']) +test('T2674', normal, compile_fail, ['-v0']) +test('T2931', normal, compile, ['-v0']) +test('TH_emptycase', normal, compile, ['-v0']) + +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']), + multimod_compile, ['T2685', '-v0 ' + config.ghc_th_way_flags]) + +test('TH_sections', normal, compile, ['-v0']) + +test('TH_tf1', normal, compile, ['-v0']) +test('TH_tf2', normal, compile, ['-v0']) +test('TH_tf3', normal, compile, ['-v0']) + +test('TH_pragma', normal, compile, ['-v0 -dsuppress-uniques']) +test('T3177', normal, compile, ['-v0']) +test('T3177a', normal, compile_fail, ['-v0']) + +test('T3319', normal, compile, ['-ddump-splices -v0']) +test('TH_foreignInterruptible', normal, compile, ['-ddump-splices -v0']) + +test('T3395', normal, compile_fail, ['-v0']) +test('T3467', normal, compile, ['']) +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']), + multimod_compile, ['T3600', '-v0 ' + config.ghc_th_way_flags]) +test('T3845', normal, compile, ['-v0']) +test('T3899', extra_clean(['T3899a.hi','T3899a.o']), + multimod_compile, + ['T3899','-v0 -ddump-splices -dsuppress-uniques ' + config.ghc_th_way_flags]) +test('T4056', normal, compile, ['-v0']) +test('T4188', normal, compile, ['-v0']) +test('T4233', normal, compile, ['-v0']) +test('T4169', normal, compile, ['-v0']) +test('T1835', normal, compile_and_run, ['-v0']) + +test('TH_viewPatPrint', normal, compile_and_run, ['']) +test('T4436', normal, compile, ['-v0 -ddump-splices']) +test('T4949', normal, compile, ['-v0']) +test('T5126', normal, compile, ['-v0']) +test('T5217', normal, compile, ['-v0 -dsuppress-uniques -ddump-splices']) +test('T5037', normal, compile, ['-v0']) +test('TH_unboxedSingleton', normal, compile, ['-v0']) +test('T5290', normal, compile, ['-v0 -ddump-splices']) +test('T5362', normal, compile, ['-v0']) + +test('TH_unresolvedInfix', + extra_clean(['TH_unresolvedInfix_Lib.hi', 'TH_unresolvedInfix_Lib.o']), + multimod_compile_and_run, + ['TH_unresolvedInfix.hs', '-v0 ' + config.ghc_th_way_flags]) +test('TH_unresolvedInfix2', + normal, + compile_fail, + ['-v0']) + +test('T5358', normal, compile_fail, [' -v0']) +test('T5379', normal, compile_and_run, ['']) +test('T5404', normal, compile, ['-v0']) +test('T5410', normal, compile_and_run, ['-v0']) +test('TH_lookupName', + extra_clean(['TH_lookupName_Lib.hi', 'TH_lookupName_Lib.o']), + multimod_compile_and_run, + ['TH_lookupName.hs', config.ghc_th_way_flags]) +test('T5452', normal, compile, ['-v0']) +test('T5434', extra_clean(['T5434a.hi','T5434a.o']), + multimod_compile, + ['T5434','-v0 -Wall ' + config.ghc_th_way_flags]) +test('T5508', normal, compile, ['-v0 -ddump-splices']) +test('TH_Depends', + [extra_clean(['TH_Depends_External.o', 'TH_Depends_External.hi', + 'TH_Depends_external.txt'])], + run_command, + ['$MAKE -s --no-print-directory TH_Depends']) +test('T5597', extra_clean(['T5597a.hi','T5597a.o']), + multimod_compile, ['T5597', '-v0 ' + config.ghc_th_way_flags]) +test('T5665', extra_clean(['T5665a.hi','T5665a.o']), + multimod_compile, ['T5665', '-v0 ' + config.ghc_th_way_flags]) +test('T5700', extra_clean(['T5700a.hi','T5700a.o']), + multimod_compile, + ['T5700','-v0 -ddump-splices ' + config.ghc_th_way_flags]) +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']), + multimod_compile, ['T5886','-v0 ' + config.ghc_th_way_flags]) +test('T4135', normal, compile, ['-v0']) +test('T4135a', normal, compile, ['-v0']) +test('T5971', normal, compile_fail, ['-v0 -dsuppress-uniques']) +test('T5968', normal, compile, ['-v0']) +test('T5984', extra_clean(['T5984_Lib.hi', 'T5984_Lib.o']), + multimod_compile, + ['T5984', '-v0 -ddump-splices ' + config.ghc_th_way_flags]) +test('T5555', extra_clean(['T5555_Lib.hi', 'T5555_Lib.o']), + multimod_compile, ['T5555', '-v0 ' + config.ghc_th_way_flags]) +test('T5976', normal, compile_fail, ['-v0']) +test('T5795', normal, compile_fail, ['-v0']) +test('T6005', normal, compile, ['-v0']) +test('T6005a', normal, compile, ['-v0']) +test('T5737', normal, compile, ['-v0']) +test('T6114', normal, compile_fail, ['-v0 -dsuppress-uniques']) +test('TH_StringPrimL', normal, compile_and_run, ['']) +test('T7064', + extra_clean(['T7064a.hi', 'T7064a.o']), + multimod_compile_and_run, + ['T7064.hs', '-v0 ' + config.ghc_th_way_flags]) +test('T7092', extra_clean(['T7092a.hi','T7092a.o']), + multimod_compile, ['T7092', '-v0 ' + config.ghc_th_way_flags]) +test('T7276', normal, compile_fail, ['-v0']) +test('T7276a', combined_output, ghci_script, ['T7276a.script']) + +test('TH_TyInstWhere1', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques']) +test('TH_TyInstWhere2', normal, compile, ['-v0']) + +test('T7445', extra_clean(['T7445a.hi', 'T7445a.o']), + run_command, + ['$MAKE -s --no-print-directory T7445'] ) +test('T7532', + extra_clean(['T7532a.hi', 'T7532a.o']), + multimod_compile, + ['T7532', '-v0 ' + config.ghc_th_way_flags]) +test('T2222', normal, compile, ['-v0']) +test('T1849', normal, ghci_script, ['T1849.script']) +test('T7681', normal, compile, ['-v0']) +test('T7910', normal, compile_and_run, ['-v0']) + +test('ClosedFam1TH', normal, compile, ['-dsuppress-uniques -v0']) +test('ClosedFam2TH', normal, compile, ['-v0']) + +test('T8028', + extra_clean(['T8028a.hi', 'T8028a.o']), + multimod_compile_fail, + ['T8028', '-v0 ' + config.ghc_th_way_flags]) + +test('TH_Roles1', normal, compile_fail, ['-v0']) +test('TH_Roles2', normal, compile, ['-v0 -ddump-tc']) +test('TH_Roles3', normal, compile, ['-v0 -dsuppress-uniques']) +test('TH_Roles4', normal, compile, ['-v0']) + +test('T8186', normal, compile_and_run, ['-v0']) + +test('T8333', + normal, + run_command, + ['$MAKE -s --no-print-directory T8333']) + +test('T4170', normal, compile, ['-v0']) +test('T4124', normal, compile, ['-v0']) +test('T4128', normal, compile, ['-v0']) +test('T6062', normal, compile, ['-v0']) +test('T4364', normal, compile, ['-v0']) +test('T8412', normal, compile_fail, ['-v0']) +test('T7667', normal, compile, ['-v0']) +test('T7667a', normal, compile_fail, ['-v0']) +test('T8455', normal, compile, ['-v0']) +test('T8499', normal, compile, ['-v0']) +test('T7477', normal, compile, ['-v0']) +test('T8507', normal, compile, ['-v0']) +test('T8540', + extra_clean(['T8540a.hi', 'T8540a.o']), + multimod_compile, + ['T8540', '-v0 ' + config.ghc_th_way_flags]) +test('T8577', + extra_clean(['T8577a.hi', 'T8577a.o']), + multimod_compile_fail, + ['T8577', '-v0 ' + config.ghc_th_way_flags]) +test('T8633', normal, compile_and_run, ['']) +test('T8625', normal, ghci_script, ['T8625.script']) |