Overloaded Quotation Brackets (#246)

This patch implements overloaded quotation brackets which generalise the
desugaring of all quotation forms in terms of a new minimal interface.

The main change is that a quotation, for example, [e| 5 |], will now
have type `Quote m => m Exp` rather than `Q Exp`. The `Quote` typeclass
contains a single method for generating new names which is used when
desugaring binding structures.

The return type of functions from the `Lift` type class, `lift` and `liftTyped` have
been restricted to `forall m . Quote m => m Exp` rather than returning a
result in a Q monad.

More details about the feature can be read in the GHC proposal.

https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0246-overloaded-bracket.rst

29 files changed, 192 insertions, 5 deletions

diff --git a/testsuite/tests/th/T10047.stdout b/testsuite/tests/th/T10047.stdout
index ea22d78254..6855b00bdf 100644
--- a/testsuite/tests/th/T10047.stdout
+++ b/testsuite/tests/th/T10047.stdout
@@ -1,2 +1,2 @@
-[| $(dyn "foo") |] :: ExpQ
-[| [n|foo|] |] :: ExpQ
+[| $(dyn "foo") |] :: Quote m => m Exp
+[| [n|foo|] |] :: Q Exp
diff --git a/testsuite/tests/th/T12993_Lib.hs b/testsuite/tests/th/T12993_Lib.hs
index 441b783812..344cd034d0 100644
--- a/testsuite/tests/th/T12993_Lib.hs
+++ b/testsuite/tests/th/T12993_Lib.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 module T12993_Lib (q) where
 data X = X { x :: Int }
 q = [|x|]
diff --git a/testsuite/tests/th/T1476.hs b/testsuite/tests/th/T1476.hs
index 7e3a192ba0..be08f59082 100644
--- a/testsuite/tests/th/T1476.hs
+++ b/testsuite/tests/th/T1476.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 
 module T1476 where
 
diff --git a/testsuite/tests/th/T1476b.hs b/testsuite/tests/th/T1476b.hs
index 7d62850904..8481be1ce2 100644
--- a/testsuite/tests/th/T1476b.hs
+++ b/testsuite/tests/th/T1476b.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 
 module T1476b where
 
diff --git a/testsuite/tests/th/T15783B.hs b/testsuite/tests/th/T15783B.hs
index 818f57d52e..b58b2baa51 100644
--- a/testsuite/tests/th/T15783B.hs
+++ b/testsuite/tests/th/T15783B.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 module T15783B(f) where
 
 d = 0
diff --git a/testsuite/tests/th/T15843a.hs b/testsuite/tests/th/T15843a.hs
index 2f413fd2c1..e0fb69ce0f 100644
--- a/testsuite/tests/th/T15843a.hs
+++ b/testsuite/tests/th/T15843a.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 module T15843a where
 
 import Language.Haskell.TH
diff --git a/testsuite/tests/th/T2386_Lib.hs b/testsuite/tests/th/T2386_Lib.hs
index 4322cc9584..96fa324ef1 100644
--- a/testsuite/tests/th/T2386_Lib.hs
+++ b/testsuite/tests/th/T2386_Lib.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 
 module T2386_Lib(ExportedAbstract, makeOne) where
 
diff --git a/testsuite/tests/th/T4949.hs b/testsuite/tests/th/T4949.hs
index a1cb8b4d99..b3c37eea57 100644
--- a/testsuite/tests/th/T4949.hs
+++ b/testsuite/tests/th/T4949.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 module Foo where
 
 import Language.Haskell.TH
diff --git a/testsuite/tests/th/T7276.stderr b/testsuite/tests/th/T7276.stderr
index 4fa2a3c4c9..10a592f4a5 100644
--- a/testsuite/tests/th/T7276.stderr
+++ b/testsuite/tests/th/T7276.stderr
@@ -3,6 +3,7 @@ T7276.hs:6:8: error:
     • Couldn't match type ‘[Language.Haskell.TH.Syntax.Dec]’
                      with ‘Language.Haskell.TH.Syntax.Exp’
       Expected type: Language.Haskell.TH.Lib.Internal.ExpQ
-        Actual type: Language.Haskell.TH.Lib.Internal.DecsQ
+        Actual type: Language.Haskell.TH.Syntax.Q
+                       Language.Haskell.TH.Lib.Internal.Decs
     • In the expression: [d| y = 3 |]
       In the untyped splice: $([d| y = 3 |])
diff --git a/testsuite/tests/th/T7276a.stdout b/testsuite/tests/th/T7276a.stdout
index ebcf5be338..048d305562 100644
--- a/testsuite/tests/th/T7276a.stdout
+++ b/testsuite/tests/th/T7276a.stdout
@@ -2,7 +2,7 @@
 <interactive>:3:9: warning: [-Wdeferred-type-errors (in -Wdefault)]
     • Couldn't match type ‘[Dec]’ with ‘Exp’
       Expected type: Q Exp
-        Actual type: DecsQ
+        Actual type: Q Language.Haskell.TH.Lib.Internal.Decs
     • In the expression: [d| a = () |] :: Q Exp
       In an equation for ‘x’: x = [d| a = () |] :: Q Exp
 
@@ -11,7 +11,7 @@
         <interactive>:3:9: error:
     • Couldn't match type ‘[Dec]’ with ‘Exp’
       Expected type: Q Exp
-        Actual type: DecsQ
+        Actual type: Q Language.Haskell.TH.Lib.Internal.Decs
     • In the expression: [d| a = () |] :: Q Exp
       In an equation for ‘x’: x = [d| a = () |] :: Q Exp
 (deferred type error)
diff --git a/testsuite/tests/th/T8028a.hs b/testsuite/tests/th/T8028a.hs
index 5bdff99f4d..b944634ac1 100644
--- a/testsuite/tests/th/T8028a.hs
+++ b/testsuite/tests/th/T8028a.hs
@@ -2,5 +2,6 @@ module T8028a where
 
 import Language.Haskell.TH
 
+x :: Q [Dec]
 x = do n <- newName "F"
        return [ClosedTypeFamilyD (TypeFamilyHead n [] NoSig Nothing) []]
diff --git a/testsuite/tests/th/TH_NestedSplices.hs b/testsuite/tests/th/TH_NestedSplices.hs
index 1af80dbcf9..f5950ef5cb 100644
--- a/testsuite/tests/th/TH_NestedSplices.hs
+++ b/testsuite/tests/th/TH_NestedSplices.hs
@@ -24,8 +24,10 @@ f x = $(spliceExpr "boo" [| x |])
 g x = $(spliceExpr $(litE (stringL "boo")) [| x |])
 
 -- Ordinary splice inside bracket
+h1 :: Q Exp
 h1 = [| $(litE (integerL 3)) |]
 
 -- Splice inside splice inside bracket
+h2 :: Q Exp
 h2 = [| $(litE ($(varE 'integerL) 3)) |]
 
diff --git a/testsuite/tests/th/TH_StringLift.hs b/testsuite/tests/th/TH_StringLift.hs
new file mode 100644
index 0000000000..334ba14353
--- /dev/null
+++ b/testsuite/tests/th/TH_StringLift.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+module TH_StringLift where
+
+import Language.Haskell.TH.Syntax
+
+foo :: Quote m => String -> m (TExp String)
+foo x = [|| x ||]
+
+foo2 :: Quote m => String -> m Exp
+foo2 x = [| x |]
diff --git a/testsuite/tests/th/TH_tuple1a.hs b/testsuite/tests/th/TH_tuple1a.hs
index 2b4bb5014b..c6894b6817 100644
--- a/testsuite/tests/th/TH_tuple1a.hs
+++ b/testsuite/tests/th/TH_tuple1a.hs
@@ -4,6 +4,7 @@ module TH_tuple1a where
 
 import Language.Haskell.TH
 
+tp2, tp1, tp2u, tp1u :: Q Exp
 tp2 = sigE (appsE [conE (tupleDataName 2),
                   litE (integerL 1),
                   litE (integerL 2)])
diff --git a/testsuite/tests/th/TH_unresolvedInfix.hs b/testsuite/tests/th/TH_unresolvedInfix.hs
index 49a6b03871..3c34b976a3 100644
--- a/testsuite/tests/th/TH_unresolvedInfix.hs
+++ b/testsuite/tests/th/TH_unresolvedInfix.hs
@@ -1,6 +1,7 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE NoStarIsType #-}
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 
 module Main where
 
diff --git a/testsuite/tests/th/TH_unresolvedInfix_Lib.hs b/testsuite/tests/th/TH_unresolvedInfix_Lib.hs
index 56930be3b7..04dead18ae 100644
--- a/testsuite/tests/th/TH_unresolvedInfix_Lib.hs
+++ b/testsuite/tests/th/TH_unresolvedInfix_Lib.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE NoStarIsType #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 
 module TH_unresolvedInfix_Lib where
 
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 3d73107231..bcaf5fbd1b 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -496,3 +496,4 @@ test('T17379b', normal, compile_fail, [''])
 test('T17461', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T17511', normal, compile, [''])
 test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques'])
+test('TH_StringLift', normal, compile, [''])
diff --git a/testsuite/tests/th/overloaded/Makefile b/testsuite/tests/th/overloaded/Makefile
new file mode 100644
index 0000000000..4a268530f1
--- /dev/null
+++ b/testsuite/tests/th/overloaded/Makefile
@@ -0,0 +1,4 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs b/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs
new file mode 100644
index 0000000000..565ef41c1d
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_constraints.hs
@@ -0,0 +1,32 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TH_overloaded_constraints where
+-- Test that constraints are collected properly from nested splices
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Data.Functor.Identity
+
+class C m where
+  cid :: m a -> m a
+
+class D m where
+  did :: m a -> m a
+
+cq :: (C m, Quote m) => m Exp
+cq = [| 5 |]
+
+dq :: (D m, Quote m) => m Exp
+dq = [| 5 |]
+
+top_level :: (C m, D m, Quote m) => m Exp
+top_level = [| $cq + $dq |]
+
+cqt :: (C m, Quote m) => m (TExp Int)
+cqt = [|| 5 ||]
+
+dqt :: (D m, Quote m) => m (TExp Int)
+dqt = [|| 5 ||]
+
+top_level_t :: (C m, D m, Quote m) => m (TExp Int)
+top_level_t = [|| $$cqt + $$dqt ||]
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.hs b/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.hs
new file mode 100644
index 0000000000..07c2163bbc
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.hs
@@ -0,0 +1,20 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TH_overloaded_constraints_fail where
+-- Test the error message when there are conflicting nested splices
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Data.Functor.Identity
+
+instance Quote Identity where
+  -- Not the correct implementation, just for testing
+  newName s = Identity (Name (mkOccName s) NameS)
+
+idQ :: Identity Exp
+idQ = [| 5 |]
+
+qq :: Q Exp
+qq = [| 5 |]
+
+quote = [| $(idQ) $(qq) |]
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.stderr b/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.stderr
new file mode 100644
index 0000000000..d76db558c6
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_constraints_fail.stderr
@@ -0,0 +1,13 @@
+
+TH_overloaded_constraints_fail.hs:20:14: error:
+    • Couldn't match type ‘Identity’ with ‘Q’
+      Expected type: Q Exp
+        Actual type: Identity Exp
+    • In the expression: idQ
+      In the expression:
+        [| $(idQ) $(qq) |]
+        pending(rn) [<splice, qq>, <splice, idQ>]
+      In an equation for ‘quote’:
+          quote
+            = [| $(idQ) $(qq) |]
+              pending(rn) [<splice, qq>, <splice, idQ>]
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_csp.hs b/testsuite/tests/th/overloaded/TH_overloaded_csp.hs
new file mode 100644
index 0000000000..c87707c01e
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_csp.hs
@@ -0,0 +1,18 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+-- A test to check that CSP works with overloaded quotes
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Data.Functor.Identity
+
+
+instance Quote Identity where
+  -- Not the correct implementation, just for testing
+  newName s = Identity (Name (mkOccName s) NameS)
+
+main = do
+  print $ runIdentity ((\x -> [| x |]) ())
+  print $ unType $ runIdentity ((\x -> [|| x ||]) ())
+
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_csp.stdout b/testsuite/tests/th/overloaded/TH_overloaded_csp.stdout
new file mode 100644
index 0000000000..5a64654110
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_csp.stdout
@@ -0,0 +1,2 @@
+ConE GHC.Tuple.()
+ConE GHC.Tuple.()
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_extract.hs b/testsuite/tests/th/overloaded/TH_overloaded_extract.hs
new file mode 100644
index 0000000000..23c5ac5257
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_extract.hs
@@ -0,0 +1,23 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+-- A simple test to check that defining a custom instance is easily
+-- possible and extraction works as expected.
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+import Data.Functor.Identity
+
+
+instance Quote Identity where
+  -- Not the correct implementation, just for testing
+  newName s = Identity (Name (mkOccName s) NameS)
+
+main = do
+  print $ runIdentity [| 1 + 2 |]
+  print $ runIdentity [| \x -> 1 + 2 |]
+  print $ runIdentity [d| data Foo = Foo |]
+  print $ runIdentity [p| () |]
+  print $ runIdentity [t| [Int] |]
+  print $ unType $ runIdentity [|| (+1) ||]
+
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_extract.stdout b/testsuite/tests/th/overloaded/TH_overloaded_extract.stdout
new file mode 100644
index 0000000000..e636c0c4f1
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_extract.stdout
@@ -0,0 +1,6 @@
+InfixE (Just (LitE (IntegerL 1))) (VarE GHC.Num.+) (Just (LitE (IntegerL 2)))
+LamE [VarP x] (InfixE (Just (LitE (IntegerL 1))) (VarE GHC.Num.+) (Just (LitE (IntegerL 2))))
+[DataD [] Foo [] Nothing [NormalC Foo []] []]
+ConP GHC.Tuple.() []
+AppT ListT (ConT GHC.Types.Int)
+InfixE Nothing (VarE GHC.Num.+) (Just (LitE (IntegerL 1)))
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_no_instance.hs b/testsuite/tests/th/overloaded/TH_overloaded_no_instance.hs
new file mode 100644
index 0000000000..18dd9e7a3e
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_no_instance.hs
@@ -0,0 +1,14 @@
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE TemplateHaskell #-}
+module TH_overloaded_constraints_no_instance where
+-- Test the error message when there is no instance
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+data NewType a
+
+-- No instance for Quote NewType
+quote2 :: NewType Exp
+quote2 = [| 5 |]
+
diff --git a/testsuite/tests/th/overloaded/TH_overloaded_no_instance.stderr b/testsuite/tests/th/overloaded/TH_overloaded_no_instance.stderr
new file mode 100644
index 0000000000..78f70c4d85
--- /dev/null
+++ b/testsuite/tests/th/overloaded/TH_overloaded_no_instance.stderr
@@ -0,0 +1,5 @@
+
+TH_overloaded_no_instance.hs:13:10: error:
+    • No instance for (Quote NewType) arising from a quotation bracket
+    • In the expression: [| 5 |]
+      In an equation for ‘quote2’: quote2 = [| 5 |]
diff --git a/testsuite/tests/th/overloaded/all.T b/testsuite/tests/th/overloaded/all.T
new file mode 100644
index 0000000000..e5c9194ee2
--- /dev/null
+++ b/testsuite/tests/th/overloaded/all.T
@@ -0,0 +1,23 @@
+# NOTICE TO DEVELOPERS
+# ~~~~~~~~~~~~~~~~~~~~
+# Adding a TemplateHaskell test?  If it only contains (non-quasi) quotes
+# and no splices, consider adding it to the quotes/ directory instead
+# of the th/ directory; this way, we can test it on the stage 1 compiler too!
+
+def f(name, opts):
+    opts.extra_hc_opts = '-XTemplateHaskell -package template-haskell'
+setTestOpts(f)
+setTestOpts(req_interp)
+# TH should work with -fexternal-interpreter too
+if config.have_ext_interp :
+     setTestOpts(extra_ways(['ext-interp']))
+     setTestOpts(only_ways(['normal','ghci','ext-interp']))
+
+     if llvm_build():
+         setTestOpts(fragile_for(16087, ['ext-interp']))
+
+test('TH_overloaded_extract', normal, compile_and_run, [''])
+test('TH_overloaded_constraints', normal, compile, ['-v0'])
+test('TH_overloaded_constraints_fail', normal, compile_fail, ['-v0'])
+test('TH_overloaded_no_instance', normal, compile_fail, ['-v0'])
+test('TH_overloaded_csp', normal, compile_and_run, ['-v0'])
diff --git a/testsuite/tests/th/should_compile/T8025/A.hs b/testsuite/tests/th/should_compile/T8025/A.hs
index c0e3083a01..f02a57a7c5 100644
--- a/testsuite/tests/th/should_compile/T8025/A.hs
+++ b/testsuite/tests/th/should_compile/T8025/A.hs
@@ -1,3 +1,5 @@
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
 module A where
+
 a = [|3|]