diff options
| author | David Terei <davidterei@gmail.com> | 2011-07-20 11:09:03 -0700 |
|---|---|---|
| committer | David Terei <davidterei@gmail.com> | 2011-07-20 11:26:35 -0700 |
| commit | 16514f272fb42af6e9c7674a9bd6c9dce369231f (patch) | |
| tree | e4f332b45fe65e2a7a2451be5674f887b42bf199 /testsuite/tests/th | |
| parent | ebd422aed41048476aa61dd4c520d43becd78682 (diff) | |
| download | haskell-16514f272fb42af6e9c7674a9bd6c9dce369231f.tar.gz | |
Move tests from tests/ghc-regress/* to just tests/*
Diffstat (limited to 'testsuite/tests/th')
185 files changed, 2216 insertions, 0 deletions
diff --git a/testsuite/tests/th/2014/A.hs b/testsuite/tests/th/2014/A.hs new file mode 100644 index 0000000000..d843c00b78 --- /dev/null +++ b/testsuite/tests/th/2014/A.hs @@ -0,0 +1 @@ +module A where diff --git a/testsuite/tests/th/2014/A.hs-boot b/testsuite/tests/th/2014/A.hs-boot new file mode 100644 index 0000000000..d843c00b78 --- /dev/null +++ b/testsuite/tests/th/2014/A.hs-boot @@ -0,0 +1 @@ +module A where diff --git a/testsuite/tests/th/2014/B.hs b/testsuite/tests/th/2014/B.hs new file mode 100644 index 0000000000..0233a40209 --- /dev/null +++ b/testsuite/tests/th/2014/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/2014/C.hs b/testsuite/tests/th/2014/C.hs new file mode 100644 index 0000000000..5ddff11497 --- /dev/null +++ b/testsuite/tests/th/2014/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/2014/Makefile b/testsuite/tests/th/2014/Makefile new file mode 100644 index 0000000000..eafbcfb7e0 --- /dev/null +++ b/testsuite/tests/th/2014/Makefile @@ -0,0 +1,9 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +2014 : + '$(TEST_HC)' $(TEST_HC_OPTS) -fforce-recomp -c A.hs-boot + '$(TEST_HC)' $(TEST_HC_OPTS) -fforce-recomp -c A.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -fforce-recomp -c B.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -fforce-recomp -c C.hs -v0 diff --git a/testsuite/tests/th/2014/all.T b/testsuite/tests/th/2014/all.T new file mode 100644 index 0000000000..c6792677d9 --- /dev/null +++ b/testsuite/tests/th/2014/all.T @@ -0,0 +1,8 @@ +setTestOpts(if_compiler_profiled(skip)) + +test('2014', + [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 2014']) diff --git a/testsuite/tests/th/Makefile b/testsuite/tests/th/Makefile new file mode 100644 index 0000000000..dc60d5b6b9 --- /dev/null +++ b/testsuite/tests/th/Makefile @@ -0,0 +1,19 @@ +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) -v0 -c T2386_Lib.hs -fforce-recomp + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 -c T2386.hs -fforce-recomp + + +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 $@ + ./$@ + diff --git a/testsuite/tests/th/T1835.hs b/testsuite/tests/th/T1835.hs new file mode 100644 index 0000000000..296bf907ab --- /dev/null +++ b/testsuite/tests/th/T1835.hs @@ -0,0 +1,37 @@ +{-# 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 Num a => MyClass (Quux2 a) + +class MyClass2 a b +instance MyClass2 Int Bool + +main = do + putStrLn $(do { info <- reify ''MyClass; lift (pprint info) }) + print $(isClassInstance ''Eq [ConT ''Foo] >>= lift) + print $(isClassInstance ''MyClass [ConT ''Foo] >>= lift) + print $ not $(isClassInstance ''Show [ConT ''Foo] >>= lift) + print $(isClassInstance ''MyClass [ConT ''Bar] >>= lift) -- this one + print $(isClassInstance ''MyClass [ConT ''Baz] >>= lift) + print $(isClassInstance ''MyClass [AppT (ConT ''Quux) (ConT ''Int)] >>= lift) --this one + print $(isClassInstance ''MyClass [AppT (ConT ''Quux2) (ConT ''Int)] >>= lift) -- this one + print $(isClassInstance ''MyClass2 [ConT ''Int, ConT ''Bool] >>= lift) + print $(isClassInstance ''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..dcb42a2b19 --- /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.Num.Num a_2 => Main.MyClass (Main.Quux2 a_2) +True +True +True +True +True +True +True +True +False 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..8881b81044 --- /dev/null +++ b/testsuite/tests/th/T2597b.stderr @@ -0,0 +1,6 @@ + +T2597b.hs:8:8: + Empty stmt list in do-block + When splicing a TH expression: do + In the expression: $mkBug2 + In an equation for `bug2': bug2 = $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..a69781dfe4 --- /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..77eb704b1c --- /dev/null +++ b/testsuite/tests/th/T2713.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE TemplateHaskell #-}
+module Fixity where
+
+class MyClass a where
+ (.*.) :: a -> a -> a
+
+$( [d| x = undefined |] )
+
+infixr 3 .*.
diff --git a/testsuite/tests/th/T2713.stderr b/testsuite/tests/th/T2713.stderr new file mode 100644 index 0000000000..a2528885ee --- /dev/null +++ b/testsuite/tests/th/T2713.stderr @@ -0,0 +1,4 @@ + +T2713.hs:9:10: + The fixity signature for `.*.' lacks an accompanying binding + (The fixity signature must be given where `.*.' 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..00b0c0d92c --- /dev/null +++ b/testsuite/tests/th/T3177a.stderr @@ -0,0 +1,11 @@ + +T3177a.hs:8:15: + `Int' is applied to too many type arguments + In the Template Haskell quotation [t| Int Int |] + In the first argument of `id', namely `[t| Int Int |]' + In the expression: id [t| 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..7947ce0ef1 --- /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.Unit.() 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..f85f7cc1da --- /dev/null +++ b/testsuite/tests/th/T3395.stderr @@ -0,0 +1,16 @@ + +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 expression: + $(return + $ CompE + [NoBindS (VarE $ mkName "undefined"), + BindS (VarP $ mkName "r1") (VarE $ mkName "undefined")]) + In an equation for `foo': + foo = $(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..8dd47a4c5a --- /dev/null +++ b/testsuite/tests/th/T3572.stdout @@ -0,0 +1 @@ +data Void 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..8ab357db1a --- /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..8a8ac0b7d3 --- /dev/null +++ b/testsuite/tests/th/T3920.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE EmptyDataDecls, TypeFamilies, TemplateHaskell #-} +module Main where + +import Language.Haskell.TH + +type family S :: (* -> (* -> * -> *)) -> (* -> *) -> * + +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..224efdfda9 --- /dev/null +++ b/testsuite/tests/th/T3920.stdout @@ -0,0 +1,2 @@ +type family T :: (* -> * -> * -> *) -> (* -> *) -> * +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/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/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..469a2d3840 --- /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/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..d66582ec1e --- /dev/null +++ b/testsuite/tests/th/T4436.stderr @@ -0,0 +1,11 @@ +T4436.hs:5:7-56: Splicing expression + return + (LitE + (StringL + "hello\ + \goodbye\ + \and then")) + ======> + "hello\ + \goodbye\ + \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..987d7fd852 --- /dev/null +++ b/testsuite/tests/th/T5037.stderr @@ -0,0 +1,3 @@ +f :: Data.Maybe.Maybe GHC.Types.Int -> GHC.Types.Int
+f (Data.Maybe.Nothing) = 3
+f (Data.Maybe.Just x_0) = 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/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..cb8889e4ca --- /dev/null +++ b/testsuite/tests/th/TH_1tuple.stderr @@ -0,0 +1,6 @@ + +TH_1tuple.hs:11:7: + Illegal 1-tuple type constructor + When splicing a TH expression: 1 :: () + In the expression: $(sigE [| 1 |] (tupleT 1)) + In an equation for `y': y = $(sigE [| 1 |] (tupleT 1)) 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_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..60d8e018ad --- /dev/null +++ b/testsuite/tests/th/TH_dataD1.hs @@ -0,0 +1,10 @@ + +module TH_dataD1 where + +import Language.Haskell.TH + +ds :: Q [Dec] +ds = [d| + $(dataD [] (mkName "D") [] [normalC "K" []] []) + |] + diff --git a/testsuite/tests/th/TH_dataD1.stderr b/testsuite/tests/th/TH_dataD1.stderr new file mode 100644 index 0000000000..ddabee742a --- /dev/null +++ b/testsuite/tests/th/TH_dataD1.stderr @@ -0,0 +1,3 @@ + +TH_dataD1.hs:8:13: + Declaration splices are not permitted inside declaration brackets 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..a8628a3de7 --- /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..d68ca9a8ee --- /dev/null +++ b/testsuite/tests/th/TH_emptycase.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE TemplateHaskell #-} +-- Trac #2431: empty case expression +-- currently rejected + +module Main where + +import Language.Haskell.TH + +f :: Int +f = $(caseE (litE $ CharL 'a') []) + +main = print f diff --git a/testsuite/tests/th/TH_emptycase.stderr b/testsuite/tests/th/TH_emptycase.stderr new file mode 100644 index 0000000000..2de068769b --- /dev/null +++ b/testsuite/tests/th/TH_emptycase.stderr @@ -0,0 +1,6 @@ + +TH_emptycase.hs:10:7: + Case expression with no alternatives + When splicing a TH expression: case 'a' of + In the expression: $(caseE (litE $ CharL 'a') []) + In an equation for `f': f = $(caseE (litE $ CharL 'a') []) 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..f544485245 --- /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 (GHC.Types.[]) } 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..b9aab05755 --- /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.Unit.() 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..88eeca7d5c --- /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..ebb8a427a7 --- /dev/null +++ b/testsuite/tests/th/TH_import_loop/TH_import_loop.T @@ -0,0 +1,5 @@ + +setTestOpts(if_compiler_profiled(skip)) + +test('TH_import_loop', expect_broken(1012), multimod_compile_and_run, ['Main', '-v0']) + 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..291d0bf748 --- /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 a_0 b_1 + where foo :: a_0 -> b_1 +\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_recompile/Main.hs b/testsuite/tests/th/TH_recompile/Main.hs new file mode 100644 index 0000000000..c4ce4a680f --- /dev/null +++ b/testsuite/tests/th/TH_recompile/Main.hs @@ -0,0 +1,7 @@ + +module Main where + +import Sub + +main = print $x + diff --git a/testsuite/tests/th/TH_recompile/Makefile b/testsuite/tests/th/TH_recompile/Makefile new file mode 100644 index 0000000000..87fab6348a --- /dev/null +++ b/testsuite/tests/th/TH_recompile/Makefile @@ -0,0 +1,22 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +# Test for trac #481. GHC should notice that the code that generates +# the splice has changed, and thus re-run it. + +clean: + rm -f *.o + rm -f hi + rm -f test test2 + rm -f Sub.hs + +TH_recompile: + $(MAKE) clean + cp Sub1.hs Sub.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make -XTemplateHaskell Main.hs -o test + cp Sub2.hs Sub.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make -XTemplateHaskell Main.hs -o test2 + ./test + ./test2 + diff --git a/testsuite/tests/th/TH_recompile/Sub1.hs b/testsuite/tests/th/TH_recompile/Sub1.hs new file mode 100644 index 0000000000..f52a654e44 --- /dev/null +++ b/testsuite/tests/th/TH_recompile/Sub1.hs @@ -0,0 +1,5 @@ + +module Sub where + +x = [| 1 |] + diff --git a/testsuite/tests/th/TH_recompile/Sub2.hs b/testsuite/tests/th/TH_recompile/Sub2.hs new file mode 100644 index 0000000000..3698ec5064 --- /dev/null +++ b/testsuite/tests/th/TH_recompile/Sub2.hs @@ -0,0 +1,5 @@ + +module Sub where + +x = [| 2 |] + diff --git a/testsuite/tests/th/TH_recompile/TH_recompile.stdout b/testsuite/tests/th/TH_recompile/TH_recompile.stdout new file mode 100644 index 0000000000..1191247b6d --- /dev/null +++ b/testsuite/tests/th/TH_recompile/TH_recompile.stdout @@ -0,0 +1,2 @@ +1 +2 diff --git a/testsuite/tests/th/TH_recompile/all.T b/testsuite/tests/th/TH_recompile/all.T new file mode 100644 index 0000000000..ecdba11c05 --- /dev/null +++ b/testsuite/tests/th/TH_recompile/all.T @@ -0,0 +1,16 @@ +def f(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'])); +setTestOpts(if_compiler_profiled(skip)) + +test('TH_recompile', + [expect_broken(481), + clean_cmd('$MAKE -s clean')], + run_command, + ['$MAKE -s TH_recompile']) + 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..dfd05187ba --- /dev/null +++ b/testsuite/tests/th/TH_reifyDecl1.hs @@ -0,0 +1,46 @@ +-- test reification of data declarations + +module TH_reifyDecl1 where + +import Language.Haskell.TH +import Text.PrettyPrint.HughesPJ + +infixl 3 `m` + +-- 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 C a where + m :: a -> Int + +test :: () +test = $(let + display :: Name -> Q () + display q = do { i <- reify q; report False (pprint i) } + in do { display ''T + ; display ''R + ; display ''List + ; display ''Tree + ; display ''IntList + ; display ''Length + ; display 'Leaf + ; display 'm + ; [| () |] }) + + diff --git a/testsuite/tests/th/TH_reifyDecl1.stderr b/testsuite/tests/th/TH_reifyDecl1.stderr new file mode 100644 index 0000000000..cf4b92d33b --- /dev/null +++ b/testsuite/tests/th/TH_reifyDecl1.stderr @@ -0,0 +1,30 @@ + +TH_reifyDecl1.hs:33:10: + data TH_reifyDecl1.T = TH_reifyDecl1.A | TH_reifyDecl1.B + +TH_reifyDecl1.hs:33:10: + data TH_reifyDecl1.R a_0 = TH_reifyDecl1.C a_0 | TH_reifyDecl1.D + +TH_reifyDecl1.hs:33:10: + data TH_reifyDecl1.List a_0 + = TH_reifyDecl1.Nil + | TH_reifyDecl1.Cons a_0 (TH_reifyDecl1.List a_0) + +TH_reifyDecl1.hs:33:10: + data TH_reifyDecl1.Tree a_0 + = TH_reifyDecl1.Leaf + | (TH_reifyDecl1.Tree a_0) TH_reifyDecl1.:+: (TH_reifyDecl1.Tree a_0) + +TH_reifyDecl1.hs:33:10: + type TH_reifyDecl1.IntList = [GHC.Types.Int] + +TH_reifyDecl1.hs:33:10: + newtype TH_reifyDecl1.Length = TH_reifyDecl1.Length GHC.Types.Int + +TH_reifyDecl1.hs:33:10: + Constructor from TH_reifyDecl1.Tree: TH_reifyDecl1.Leaf :: forall a_0 . TH_reifyDecl1.Tree a_0 + +TH_reifyDecl1.hs:33:10: + Class op from TH_reifyDecl1.C: TH_reifyDecl1.m :: forall a_0 . TH_reifyDecl1.C a_0 => + a_0 -> GHC.Types.Int + infixl 3 TH_reifyDecl1.m 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..1beab4d9c3 --- /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_reifyMkName.hs b/testsuite/tests/th/TH_reifyMkName.hs new file mode 100644 index 0000000000..c5d5ebeea9 --- /dev/null +++ b/testsuite/tests/th/TH_reifyMkName.hs @@ -0,0 +1,13 @@ +-- Trac #2339 + +module Foo where + +import Language.Haskell.TH + +type C = Int + +$(do + a <- reify $ mkName "C" + report False $ 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..0537f1ddcf --- /dev/null +++ b/testsuite/tests/th/TH_reifyMkName.stderr @@ -0,0 +1,3 @@ + +TH_reifyMkName.hs:9:3: + 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..896793a113 --- /dev/null +++ b/testsuite/tests/th/TH_repGuard.stderr @@ -0,0 +1,7 @@ +foo :: GHC.Types.Int -> GHC.Types.Int +foo x_0 | x_0 GHC.Classes.== 5 = 6 +foo x_1 = 7 +bar :: Data.Maybe.Maybe GHC.Types.Int -> GHC.Types.Int +bar x_0 | Data.Maybe.Just y_1 <- x_0 + = y_1 +bar _ = 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..64df06518c --- /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.Word.W#) (LitE (WordPrimL 32)) +GHC.Word.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..f7a536a95a --- /dev/null +++ b/testsuite/tests/th/TH_runIO.stderr @@ -0,0 +1,7 @@ + +TH_runIO.hs:12:9: + Exception when trying to run compile-time code: + user error (hi) + Code: runIO (fail "hi") + In the expression: $(runIO (fail "hi")) + In an equation for `foo': foo = $(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_scopedTvs.stderr b/testsuite/tests/th/TH_scopedTvs.stderr new file mode 100644 index 0000000000..f8263fc28f --- /dev/null +++ b/testsuite/tests/th/TH_scopedTvs.stderr @@ -0,0 +1,4 @@ + +TH_scopedTvs.hs:6:13: + Illegal lexically-scoped type variable `a' + Lexically scoped type variables are not supported by Template Haskell 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..d54ef19b88 --- /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/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..fa50658a6b --- /dev/null +++ b/testsuite/tests/th/TH_spliceViewPat/test.T @@ -0,0 +1,11 @@ +def f(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(if_compiler_profiled(skip)) + +test('TH_spliceViewPat', normal, multimod_compile_and_run, [ 'Main', '' ]) 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_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..f520b23008 --- /dev/null +++ b/testsuite/tests/th/TH_viewPatPrint.stdout @@ -0,0 +1,2 @@ +ViewP (VarE GHC.Base.id) (VarP x) +(GHC.Base.id -> x) 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..7ca7f09223 --- /dev/null +++ b/testsuite/tests/th/all.T @@ -0,0 +1,185 @@ + +# 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(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(if_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']) + +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']) + +# 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']) + +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_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']) +test('TH_spliceDecl4', + extra_clean(['TH_spliceDecl4_Lib.hi', 'TH_spliceDecl4_Lib.o']), + multimod_compile, + ['TH_spliceDecl4', '-v0']) + +test('T2597a', + extra_clean(['T2597a_Lib.hi', 'T2597a_Lib.o']), + multimod_compile, + ['T2597a', '-v0']) + +test('T2597b', + extra_clean(['T2597b_Lib.hi', 'T2597b_Lib.o']), + multimod_compile_fail, + ['T2597b', '-v0']) + +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']) + +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_fail, ['-v0']) + +test('TH_ppr1', normal, compile_and_run, ['']) + +test('TH_fail', normal, compile_fail, ['-v0']) +test('TH_scopedTvs', normal, compile_fail, ['-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_fail, ['-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']) + +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']) +test('T3845', normal, compile, ['-v0']) +test('T3899', extra_clean(['T3899a.hi','T3899a.o']), + multimod_compile, ['T3899','-v0 -ddump-splices -dsuppress-uniques']) +test('T4056', normal, compile, ['-v0']) +test('T4188', normal, compile, ['-v0']) +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']) + |