Add TemplateHaskell support for Overlapping pragmas

Reviewers: hvr, goldfire, austin, RyanGlScott, bgamari

Reviewed By: RyanGlScott, bgamari

Subscribers: RyanGlScott, thomie

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

7 files changed, 37 insertions, 6 deletions

diff --git a/testsuite/tests/th/T5452.hs b/testsuite/tests/th/T5452.hs
index b727df5a47..de6a1771f7 100644
--- a/testsuite/tests/th/T5452.hs
+++ b/testsuite/tests/th/T5452.hs
@@ -9,8 +9,8 @@ class D (f :: * -> *)
 instance C ((,) Int)
 
 $(do { ClassI _ [inst_dec] <- reify ''C
-     ; let InstanceD cxt (AppT _ ty) _ = inst_dec
-     ; return [InstanceD cxt
+     ; let InstanceD o cxt (AppT _ ty) _ = inst_dec
+     ; return [InstanceD o cxt
                          (foldl AppT (ConT ''D) [ty]) 
                          []
               ] })
diff --git a/testsuite/tests/th/T5700a.hs b/testsuite/tests/th/T5700a.hs
index 31dbfa9120..39d39b16a1 100644
--- a/testsuite/tests/th/T5700a.hs
+++ b/testsuite/tests/th/T5700a.hs
@@ -8,7 +8,7 @@ class C a where
 
 mkC :: Name -> Q [Dec]
 mkC n = return
-  [InstanceD [] (AppT (ConT ''C) (ConT n))
+  [InstanceD Nothing [] (AppT (ConT ''C) (ConT n))
     [ FunD 'inlinable [Clause [WildP] (NormalB (ConE '())) []],
       PragmaD (InlineP 'inlinable Inline FunLike AllPhases)    
     ] 
diff --git a/testsuite/tests/th/T5886a.hs b/testsuite/tests/th/T5886a.hs
index 4d2cec6207..95aefc2792 100644
--- a/testsuite/tests/th/T5886a.hs
+++ b/testsuite/tests/th/T5886a.hs
@@ -10,5 +10,5 @@ class C α where
   type AT α ∷ ★
 
 bang ∷ DecsQ
-bang = return [InstanceD [] (AppT (ConT ''C) (ConT ''Int))
+bang = return [InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int))
                 [TySynInstD ''AT (TySynEqn [ConT ''Int] (ConT ''Int))]]
diff --git a/testsuite/tests/th/T7532a.hs b/testsuite/tests/th/T7532a.hs
index 901e27a1bf..84fa23e69f 100644
--- a/testsuite/tests/th/T7532a.hs
+++ b/testsuite/tests/th/T7532a.hs
@@ -10,6 +10,6 @@ class C a where
 
 bang' :: DecsQ
 bang' = return [
-     InstanceD [] (AppT (ConT ''C) (ConT ''Int)) [
+     InstanceD Nothing [] (AppT (ConT ''C) (ConT ''Int)) [
          DataInstD [] ''D [ConT ''Int] Nothing [
              NormalC (mkName "T") []] []]]
diff --git a/testsuite/tests/th/T8625.stdout b/testsuite/tests/th/T8625.stdout
index 8308c5b67d..8547e53fd6 100644
--- a/testsuite/tests/th/T8625.stdout
+++ b/testsuite/tests/th/T8625.stdout
@@ -1,2 +1,2 @@
-[InstanceD [AppT (AppT EqualityT (VarT y_0)) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.Member) (ConT GHC.Types.Bool)) []]
+[InstanceD Nothing [AppT (AppT EqualityT (VarT y_0)) (AppT (AppT ArrowT (VarT t_1)) (VarT t_1))] (AppT (ConT Ghci1.Member) (ConT GHC.Types.Bool)) []]
 [SigD f_4 (ForallT [PlainTV y_2,PlainTV t_3] [AppT (AppT EqualityT (VarT y_2)) (AppT (AppT ArrowT (VarT t_3)) (VarT t_3))] (AppT (AppT ArrowT (VarT y_2)) (VarT t_3))),FunD f_4 [Clause [VarP x_5] (NormalB (VarE x_5)) []]]
diff --git a/testsuite/tests/th/TH_overlaps.hs b/testsuite/tests/th/TH_overlaps.hs
new file mode 100644
index 0000000000..9fd2180dcb
--- /dev/null
+++ b/testsuite/tests/th/TH_overlaps.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE TemplateHaskell, FlexibleInstances #-}
+module TH_overlaps where
+
+import Language.Haskell.TH
+
+class C1 a where c1 :: a
+class C2 a where c2 :: a
+class C3 a where c3 :: a
+
+[d|
+  instance {-# OVERLAPPABLE #-} C1 [a]      where c1 = []
+  instance                      C1 [Int]    where c1 = [1]
+
+  instance                      C2 [a]      where c2 = []
+  instance {-# OVERLAPPING #-}  C2 [Int]    where c2 = [1]
+
+  instance                      C3 [a]      where c3 = []
+  instance {-# OVERLAPS #-}     C3 [[a]]    where c3 = [[]]
+  instance                      C3 [[Int]]  where c3 = [[1]]
+  |]
+
+test1 :: ([Char],[Int])
+test1 = (c1,c1)
+
+test2 :: ([Char],[Int])
+test2 = (c2,c2)
+
+test3 :: ([Char],[[Char]],[[Int]])
+test3 = (c3,c3,c3)
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index d562836ebd..648f7c932f 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -26,6 +26,8 @@ test('TH_repGuard', normal, compile, ['-v0'])
 test('TH_repGuardOutput', normal, compile_and_run, [''])
 test('TH_repPatSig', normal, compile_fail, [''])
 
+test('TH_overlaps', normal, compile, ['-v0'])
+
 test('TH_spliceE5',
      extra_clean(['TH_spliceE5_Lib.hi', 'TH_spliceE5_Lib.o']),
      multimod_compile_and_run,