diff options
Diffstat (limited to 'testsuite/tests/quotes')
35 files changed, 388 insertions, 0 deletions
diff --git a/testsuite/tests/quotes/.gitignore b/testsuite/tests/quotes/.gitignore new file mode 100644 index 0000000000..1c8a416fcd --- /dev/null +++ b/testsuite/tests/quotes/.gitignore @@ -0,0 +1,4 @@ +T3572 +T8633 +TH_ppr1 +TH_spliceViewPat/TH_spliceViewPat diff --git a/testsuite/tests/quotes/Makefile b/testsuite/tests/quotes/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/quotes/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/quotes/T2632.hs b/testsuite/tests/quotes/T2632.hs new file mode 100644 index 0000000000..71f6350cc2 --- /dev/null +++ b/testsuite/tests/quotes/T2632.hs @@ -0,0 +1,14 @@ +-- 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/quotes/T2931.hs b/testsuite/tests/quotes/T2931.hs new file mode 100644 index 0000000000..43aeda0ece --- /dev/null +++ b/testsuite/tests/quotes/T2931.hs @@ -0,0 +1,7 @@ +-- Trac #2931 + +module Foo where +a = 1 + +-- NB: no newline after the 'a'! +b = 'a diff --git a/testsuite/tests/quotes/T3572.hs b/testsuite/tests/quotes/T3572.hs new file mode 100644 index 0000000000..4717fd2735 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/T3572.stdout b/testsuite/tests/quotes/T3572.stdout new file mode 100644 index 0000000000..9df7a449ff --- /dev/null +++ b/testsuite/tests/quotes/T3572.stdout @@ -0,0 +1 @@ +data Void_0
diff --git a/testsuite/tests/quotes/T4056.hs b/testsuite/tests/quotes/T4056.hs new file mode 100644 index 0000000000..a9b936987c --- /dev/null +++ b/testsuite/tests/quotes/T4056.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE 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/quotes/T4169.hs b/testsuite/tests/quotes/T4169.hs new file mode 100644 index 0000000000..cdef4a2e3a --- /dev/null +++ b/testsuite/tests/quotes/T4169.hs @@ -0,0 +1,13 @@ +-- 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/quotes/T4170.hs b/testsuite/tests/quotes/T4170.hs new file mode 100644 index 0000000000..46319abaf0 --- /dev/null +++ b/testsuite/tests/quotes/T4170.hs @@ -0,0 +1,12 @@ +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/quotes/T5721.hs b/testsuite/tests/quotes/T5721.hs new file mode 100644 index 0000000000..ed5e7e380b --- /dev/null +++ b/testsuite/tests/quotes/T5721.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module T5371 where +import Language.Haskell.TH + +f :: a -> Name +f (x :: a) = ''a diff --git a/testsuite/tests/quotes/T6062.hs b/testsuite/tests/quotes/T6062.hs new file mode 100644 index 0000000000..342850e853 --- /dev/null +++ b/testsuite/tests/quotes/T6062.hs @@ -0,0 +1,2 @@ +module T6062 where +x = [| False True |] diff --git a/testsuite/tests/quotes/T8455.hs b/testsuite/tests/quotes/T8455.hs new file mode 100644 index 0000000000..69d1271b40 --- /dev/null +++ b/testsuite/tests/quotes/T8455.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE DataKinds #-} + +module T8455 where + +ty = [t| 5 |] diff --git a/testsuite/tests/quotes/T8633.hs b/testsuite/tests/quotes/T8633.hs new file mode 100644 index 0000000000..eb2b3f3a3b --- /dev/null +++ b/testsuite/tests/quotes/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 diff --git a/testsuite/tests/quotes/T8759a.hs b/testsuite/tests/quotes/T8759a.hs new file mode 100644 index 0000000000..37b65d6fcc --- /dev/null +++ b/testsuite/tests/quotes/T8759a.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE PatternSynonyms #-} + +module T8759a where + +foo = [d| pattern Q = False |] diff --git a/testsuite/tests/quotes/T8759a.stderr b/testsuite/tests/quotes/T8759a.stderr new file mode 100644 index 0000000000..ff0fd495df --- /dev/null +++ b/testsuite/tests/quotes/T8759a.stderr @@ -0,0 +1,4 @@ + +T8759a.hs:5:7: + pattern synonyms not (yet) handled by Template Haskell + pattern Q = False diff --git a/testsuite/tests/quotes/T9824.hs b/testsuite/tests/quotes/T9824.hs new file mode 100644 index 0000000000..9a2d6fdfef --- /dev/null +++ b/testsuite/tests/quotes/T9824.hs @@ -0,0 +1,5 @@ +{-# OPTIONS_GHC -fwarn-unused-matches #-} + +module T9824 where + +foo = [p| (x, y) |] diff --git a/testsuite/tests/quotes/TH_abstractFamily.hs b/testsuite/tests/quotes/TH_abstractFamily.hs new file mode 100644 index 0000000000..78d7e43931 --- /dev/null +++ b/testsuite/tests/quotes/TH_abstractFamily.hs @@ -0,0 +1,11 @@ +module TH_abstractFamily where + +import Language.Haskell.TH + +-- Empty closed type families are okay... +ds1 :: Q [Dec] +ds1 = [d| type family F a where |] + +-- ...but abstract ones should result in a type error +ds2 :: Q [Dec] +ds2 = [d| type family G a where .. |] diff --git a/testsuite/tests/quotes/TH_abstractFamily.stderr b/testsuite/tests/quotes/TH_abstractFamily.stderr new file mode 100644 index 0000000000..c0aa8d274b --- /dev/null +++ b/testsuite/tests/quotes/TH_abstractFamily.stderr @@ -0,0 +1,5 @@ + +TH_abstractFamily.hs:11:7: + abstract closed type family not (yet) handled by Template Haskell + type family G a where + .. diff --git a/testsuite/tests/quotes/TH_bracket1.hs b/testsuite/tests/quotes/TH_bracket1.hs new file mode 100644 index 0000000000..7dee21ba01 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_bracket2.hs b/testsuite/tests/quotes/TH_bracket2.hs new file mode 100644 index 0000000000..2b06b9eecb --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_bracket3.hs b/testsuite/tests/quotes/TH_bracket3.hs new file mode 100644 index 0000000000..c746d61cd3 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_ppr1.hs b/testsuite/tests/quotes/TH_ppr1.hs new file mode 100644 index 0000000000..763d7682e0 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_ppr1.stdout b/testsuite/tests/quotes/TH_ppr1.stdout new file mode 100644 index 0000000000..e969c176c3 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_reifyType1.hs b/testsuite/tests/quotes/TH_reifyType1.hs new file mode 100644 index 0000000000..d8b45db271 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_reifyType2.hs b/testsuite/tests/quotes/TH_reifyType2.hs new file mode 100644 index 0000000000..85615b5382 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_repE1.hs b/testsuite/tests/quotes/TH_repE1.hs new file mode 100644 index 0000000000..1938a9bdc3 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_repE3.hs b/testsuite/tests/quotes/TH_repE3.hs new file mode 100644 index 0000000000..5f0453c1a7 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_scope.hs b/testsuite/tests/quotes/TH_scope.hs new file mode 100644 index 0000000000..7674a5d1c0 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_spliceViewPat/A.hs b/testsuite/tests/quotes/TH_spliceViewPat/A.hs new file mode 100644 index 0000000000..0147d2eca2 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_spliceViewPat/Main.hs b/testsuite/tests/quotes/TH_spliceViewPat/Main.hs new file mode 100644 index 0000000000..675ae99bf9 --- /dev/null +++ b/testsuite/tests/quotes/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/quotes/TH_spliceViewPat/Makefile b/testsuite/tests/quotes/TH_spliceViewPat/Makefile new file mode 100644 index 0000000000..4a268530f1 --- /dev/null +++ b/testsuite/tests/quotes/TH_spliceViewPat/Makefile @@ -0,0 +1,4 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + diff --git a/testsuite/tests/quotes/TH_spliceViewPat/TH_spliceViewPat.stdout b/testsuite/tests/quotes/TH_spliceViewPat/TH_spliceViewPat.stdout new file mode 100644 index 0000000000..4792e70f33 --- /dev/null +++ b/testsuite/tests/quotes/TH_spliceViewPat/TH_spliceViewPat.stdout @@ -0,0 +1,2 @@ +2 +3 diff --git a/testsuite/tests/quotes/TH_spliceViewPat/test.T b/testsuite/tests/quotes/TH_spliceViewPat/test.T new file mode 100644 index 0000000000..3075ef4b1f --- /dev/null +++ b/testsuite/tests/quotes/TH_spliceViewPat/test.T @@ -0,0 +1,9 @@ +def f(name, opts): + opts.extra_hc_opts = '-XTemplateHaskell -package template-haskell' + +setTestOpts(f) + +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/quotes/TH_tf2.hs b/testsuite/tests/quotes/TH_tf2.hs new file mode 100644 index 0000000000..9f313d4a3e --- /dev/null +++ b/testsuite/tests/quotes/TH_tf2.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE AllowAmbiguousTypes #-} -- 'bar' is ambiguous + +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/quotes/all.T b/testsuite/tests/quotes/all.T new file mode 100644 index 0000000000..2688391f15 --- /dev/null +++ b/testsuite/tests/quotes/all.T @@ -0,0 +1,29 @@ +def f(name, opts): + opts.extra_hc_opts = '-XTemplateHaskell -package template-haskell' + +setTestOpts(f) + +test('T2632', normal, compile, ['']) +test('T2931', normal, compile, ['-v0']) +test('T3572', normal, compile_and_run, ['']) +test('T4056', normal, compile, ['-v0']) +test('T4169', normal, compile, ['-v0']) +test('T4170', normal, compile, ['-v0']) +test('T5721', normal, compile, ['-v0']) +test('T6062', normal, compile, ['-v0']) +test('T8455', normal, compile, ['-v0']) +test('T8633', normal, compile_and_run, ['']) +test('T8759a', normal, compile_fail, ['-v0']) +test('T9824', normal, compile, ['-v0']) + +test('TH_tf2', normal, compile, ['-v0']) +test('TH_ppr1', normal, compile_and_run, ['']) +test('TH_bracket1', normal, compile, ['']) +test('TH_bracket2', normal, compile, ['']) +test('TH_bracket3', normal, compile, ['']) +test('TH_scope', normal, compile, ['']) +test('TH_reifyType1', normal, compile, ['']) +test('TH_reifyType2', normal, compile, ['']) +test('TH_repE1', normal, compile, ['']) +test('TH_repE3', normal, compile, ['']) +test('TH_abstractFamily', normal, compile_fail, ['']) |