diff options
Diffstat (limited to 'testsuite')
46 files changed, 231 insertions, 25 deletions
diff --git a/testsuite/tests/cabal/cabal04/TH.hs b/testsuite/tests/cabal/cabal04/TH.hs index 8719c7d550..d37efa1acc 100644 --- a/testsuite/tests/cabal/cabal04/TH.hs +++ b/testsuite/tests/cabal/cabal04/TH.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-} module TH where import Language.Haskell.TH diff --git a/testsuite/tests/driver/recomp009/Sub1.hs b/testsuite/tests/driver/recomp009/Sub1.hs index 25ea7552e4..9420c7a3f9 100644 --- a/testsuite/tests/driver/recomp009/Sub1.hs +++ b/testsuite/tests/driver/recomp009/Sub1.hs @@ -1,3 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-} module Sub where x = [| 1 |] diff --git a/testsuite/tests/driver/recomp009/Sub2.hs b/testsuite/tests/driver/recomp009/Sub2.hs index 7ca8b12c33..78bd05fc18 100644 --- a/testsuite/tests/driver/recomp009/Sub2.hs +++ b/testsuite/tests/driver/recomp009/Sub2.hs @@ -1,3 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-} module Sub where x = [| 2 |] diff --git a/testsuite/tests/ghci/T16670/TH.hs b/testsuite/tests/ghci/T16670/TH.hs index f288c784f0..36f705e2bd 100644 --- a/testsuite/tests/ghci/T16670/TH.hs +++ b/testsuite/tests/ghci/T16670/TH.hs @@ -1,3 +1,4 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module TH where th = [|909|] diff --git a/testsuite/tests/ghci/scripts/T8831.hs b/testsuite/tests/ghci/scripts/T8831.hs index b0a3cc5bdf..4bf9f6d870 100644 --- a/testsuite/tests/ghci/scripts/T8831.hs +++ b/testsuite/tests/ghci/scripts/T8831.hs @@ -1,3 +1,3 @@ -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TemplateHaskell, NoMonomorphismRestriction #-} module T8831 where foo = [| 3 |] diff --git a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs index 40d82bb7a2..0f8198d22d 100644 --- a/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs +++ b/testsuite/tests/overloadedrecflds/should_fail/overloadedrecfldsfail09.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DuplicateRecordFields, TemplateHaskell #-} +{-# LANGUAGE DuplicateRecordFields, TemplateHaskell, NoMonomorphismRestriction #-} data S = MkS { x :: Int } data T = MkT { x :: Int } diff --git a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs index 89464451ee..3867404d2c 100644 --- a/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs +++ b/testsuite/tests/plugins/simple-plugin/Simple/RemovePlugin.hs @@ -17,6 +17,7 @@ import OccName import RdrName import Name import Avail +import GHC.Hs.Dump plugin :: Plugin plugin = defaultPlugin { parsedResultAction = parsedPlugin @@ -52,11 +53,13 @@ typecheckPlugin [name, "typecheck"] _ tc typecheckPlugin _ _ tc = return tc metaPlugin' :: [CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) -metaPlugin' opts (L l (HsPar x e)) = (\e' -> L l (HsPar x e')) <$> metaPlugin' opts e -metaPlugin' [name, "meta"] (L _ (HsApp noExt (L l (HsVar _ (L _ id))) e)) +metaPlugin' [name, "meta"] (L l (HsWrap ne w (HsPar x (L _ (HsApp noExt (L _ (HsVar _ (L _ id))) e))))) | occNameString (getOccName id) == name - = return e -metaPlugin' _ meta = return meta + = return (L l (HsWrap ne w (unLoc e))) +-- The test should always match this first case. If the desugaring changes +-- again in the future then the panic is more useful than the previous +-- inscrutable failure. +metaPlugin' _ meta = pprPanic "meta" (showAstData BlankSrcSpan meta) interfaceLoadPlugin' :: [CommandLineOption] -> ModIface -> IfM lcl ModIface interfaceLoadPlugin' [name, "interface"] iface diff --git a/testsuite/tests/quotes/T6062.hs b/testsuite/tests/quotes/T6062.hs index 342850e853..efce7b2752 100644 --- a/testsuite/tests/quotes/T6062.hs +++ b/testsuite/tests/quotes/T6062.hs @@ -1,2 +1,3 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} module T6062 where x = [| False True |] diff --git a/testsuite/tests/quotes/T8455.hs b/testsuite/tests/quotes/T8455.hs index 69d1271b40..c55c5272f9 100644 --- a/testsuite/tests/quotes/T8455.hs +++ b/testsuite/tests/quotes/T8455.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module T8455 where diff --git a/testsuite/tests/quotes/T8759a.hs b/testsuite/tests/quotes/T8759a.hs index 37b65d6fcc..c56a363e7a 100644 --- a/testsuite/tests/quotes/T8759a.hs +++ b/testsuite/tests/quotes/T8759a.hs @@ -1,4 +1,5 @@ {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module T8759a where diff --git a/testsuite/tests/quotes/T9824.hs b/testsuite/tests/quotes/T9824.hs index 9a2d6fdfef..d8e2098c07 100644 --- a/testsuite/tests/quotes/T9824.hs +++ b/testsuite/tests/quotes/T9824.hs @@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fwarn-unused-matches #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module T9824 where diff --git a/testsuite/tests/quotes/TH_bracket1.hs b/testsuite/tests/quotes/TH_bracket1.hs index 7dee21ba01..bc0126a91d 100644 --- a/testsuite/tests/quotes/TH_bracket1.hs +++ b/testsuite/tests/quotes/TH_bracket1.hs @@ -1,6 +1,6 @@ -- Check that declarations in a bracket shadow the top-level -- declarations, rather than clashing with them. - +{-# LANGUAGE NoMonomorphismRestriction #-} module TH_bracket1 where foo = 1 diff --git a/testsuite/tests/quotes/TH_bracket2.hs b/testsuite/tests/quotes/TH_bracket2.hs index 2b06b9eecb..e903b673db 100644 --- a/testsuite/tests/quotes/TH_bracket2.hs +++ b/testsuite/tests/quotes/TH_bracket2.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} module TH_bracket2 where d_show = [d| data A = A diff --git a/testsuite/tests/quotes/TH_bracket3.hs b/testsuite/tests/quotes/TH_bracket3.hs index c746d61cd3..281b8cb081 100644 --- a/testsuite/tests/quotes/TH_bracket3.hs +++ b/testsuite/tests/quotes/TH_bracket3.hs @@ -1,4 +1,5 @@ {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NoMonomorphismRestriction #-} module TH_bracket3 where diff --git a/testsuite/tests/quotes/TH_localname.stderr b/testsuite/tests/quotes/TH_localname.stderr index d872a622b3..6d0ccc91ec 100644 --- a/testsuite/tests/quotes/TH_localname.stderr +++ b/testsuite/tests/quotes/TH_localname.stderr @@ -1,21 +1,23 @@ TH_localname.hs:3:11: error: - • Ambiguous type variable ‘t0’ arising from a use of ‘Language.Haskell.TH.Syntax.lift’ - prevents the constraint ‘(Language.Haskell.TH.Syntax.Lift - t0)’ from being solved. + • Ambiguous type variable ‘m0’ arising from a quotation bracket + prevents the constraint ‘(Language.Haskell.TH.Syntax.Quote + m0)’ from being solved. Relevant bindings include - y :: t0 (bound at TH_localname.hs:3:6) - x :: t0 -> Language.Haskell.TH.Lib.Internal.ExpQ + x :: t0 -> m0 Language.Haskell.TH.Syntax.Exp (bound at TH_localname.hs:3:1) - Probable fix: use a type annotation to specify what ‘t0’ should be. - These potential instances exist: - 29 instances involving out-of-scope types + Probable fix: use a type annotation to specify what ‘m0’ should be. + These potential instance exist: + one instance involving out-of-scope types (use -fprint-potential-instances to see them all) - • In the expression: Language.Haskell.TH.Syntax.lift y - In the expression: + • In the expression: [| y |] pending(rn) [<y, Language.Haskell.TH.Syntax.lift y>] In the expression: \ y -> [| y |] pending(rn) [<y, Language.Haskell.TH.Syntax.lift y>] + In an equation for ‘x’: + x = \ y + -> [| y |] + pending(rn) [<y, Language.Haskell.TH.Syntax.lift y>] diff --git a/testsuite/tests/quotes/TH_typed_csp.hs b/testsuite/tests/quotes/TH_typed_csp.hs new file mode 100644 index 0000000000..4660fffd7f --- /dev/null +++ b/testsuite/tests/quotes/TH_typed_csp.hs @@ -0,0 +1,6 @@ +-- Check that CSP works for typed quotations.. there was no test for this +-- before apart from the deriving tests. +{-# LANGUAGE NoMonomorphismRestriction #-} +module TH_typed_csp where + +bar = (\x -> [|| x ||]) () diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T index feefc41433..a10da1046f 100644 --- a/testsuite/tests/quotes/all.T +++ b/testsuite/tests/quotes/all.T @@ -29,3 +29,4 @@ test('TH_repE1', normal, compile, ['']) test('TH_repE3', normal, compile, ['']) test('TH_abstractFamily', normal, compile_fail, ['']) test('TH_localname', normal, compile_fail, ['']) +test('TH_typed_csp', normal, compile, ['']) 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|] |