Split off quotes/ from th/ for tests that can be done on stage1 compiler.

Signed-off-by: Edward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: run these tests with stage1

Reviewers: simonpj, austin

Subscribers: bgamari, thomie

Differential Revision: https://phabricator.haskell.org/D877

GHC Trac Issues: #10382

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, [''])