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

6 files changed, 36 insertions, 6 deletions

diff --git a/libraries/ghci/GHCi/TH/Binary.hs b/libraries/ghci/GHCi/TH/Binary.hs
index 6183a3d26f..ab9b35525a 100644
--- a/libraries/ghci/GHCi/TH/Binary.hs
+++ b/libraries/ghci/GHCi/TH/Binary.hs
@@ -29,6 +29,7 @@ instance Binary TH.Stmt
 instance Binary TH.Pat
 instance Binary TH.Exp
 instance Binary TH.Dec
+instance Binary TH.Overlap
 instance Binary TH.Guard
 instance Binary TH.Body
 instance Binary TH.Match
diff --git a/libraries/template-haskell/Language/Haskell/TH.hs b/libraries/template-haskell/Language/Haskell/TH.hs
index 2f750e32a7..3bca8eaeef 100644
--- a/libraries/template-haskell/Language/Haskell/TH.hs
+++ b/libraries/template-haskell/Language/Haskell/TH.hs
@@ -142,7 +142,9 @@ module Language.Haskell.TH(
     -- **** Data
     valD, funD, tySynD, dataD, newtypeD,
     -- **** Class
-    classD, instanceD, sigD, standaloneDerivD, defaultSigD,
+    classD, instanceD, instanceWithOverlapD, Overlap(..),
+    sigD, standaloneDerivD, defaultSigD,
+
     -- **** Role annotations
     roleAnnotD,
     -- **** Type Family / Data Family
diff --git a/libraries/template-haskell/Language/Haskell/TH/Lib.hs b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
index 81ef1fcbb6..6971970524 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Lib.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Lib.hs
@@ -369,12 +369,17 @@ classD ctxt cls tvs fds decs =
     return $ ClassD ctxt1 cls tvs fds decs1
 
 instanceD :: CxtQ -> TypeQ -> [DecQ] -> DecQ
-instanceD ctxt ty decs =
+instanceD = instanceWithOverlapD Nothing
+
+instanceWithOverlapD :: Maybe Overlap -> CxtQ -> TypeQ -> [DecQ] -> DecQ
+instanceWithOverlapD o ctxt ty decs =
   do
     ctxt1 <- ctxt
     decs1 <- sequence decs
     ty1   <- ty
-    return $ InstanceD ctxt1 ty1 decs1
+    return $ InstanceD o ctxt1 ty1 decs1
+
+
 
 sigD :: Name -> TypeQ -> DecQ
 sigD fun ty = liftM (SigD fun) $ ty
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 3f79920a0b..2a56620684 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -290,7 +290,8 @@ ppr_dec _ (NewtypeD ctxt t xs ksig c decs)
 ppr_dec _  (ClassD ctxt c xs fds ds)
   = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
     $$ where_clause ds
-ppr_dec _ (InstanceD ctxt i ds) = text "instance" <+> pprCxt ctxt <+> ppr i
+ppr_dec _ (InstanceD o ctxt i ds) =
+        text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i
                                   $$ where_clause ds
 ppr_dec _ (SigD f t)    = pprPrefixOcc f <+> dcolon <+> ppr t
 ppr_dec _ (ForeignD f)  = ppr f
@@ -339,6 +340,15 @@ ppr_dec _ (StandaloneDerivD cxt ty)
 ppr_dec _ (DefaultSigD n ty)
   = hsep [ text "default", pprPrefixOcc n, dcolon, ppr ty ]
 
+
+ppr_overlap :: Overlap -> Doc
+ppr_overlap o = text $
+  case o of
+    Overlaps      -> "{-# OVERLAPS #-}"
+    Overlappable  -> "{-# OVERLAPPABLE #-}"
+    Overlapping   -> "{-# OVERLAPPING #-}"
+    Incoherent    -> "{-# INCOHERENT #-}"
+
 ppr_data :: Doc -> Cxt -> Name -> Doc -> Maybe Kind -> [Con] -> Cxt -> Doc
 ppr_data maybeInst ctxt t argsDoc ksig cs decs
   = sep [text "data" <+> maybeInst
diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index ce3c9083b2..c8d9d75b4b 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1510,8 +1510,9 @@ data Dec
   | TySynD Name [TyVarBndr] Type  -- ^ @{ type T x = (x,x) }@
   | ClassD Cxt Name [TyVarBndr]
          [FunDep] [Dec]           -- ^ @{ class Eq a => Ord a where ds }@
-  | InstanceD Cxt Type [Dec]      -- ^ @{ instance Show w => Show [w]
-                                  --       where ds }@
+  | InstanceD (Maybe Overlap) Cxt Type [Dec]
+                                  -- ^ @{ instance {\-\# OVERLAPS \#-\}
+                                  --        Show w => Show [w] where ds }@
   | SigD Name Type                -- ^ @{ length :: [a] -> Int }@
   | ForeignD Foreign              -- ^ @{ foreign import ... }
                                   --{ foreign export ... }@
@@ -1549,6 +1550,15 @@ data Dec
   | DefaultSigD Name Type         -- ^ @{ default size :: Data a => a -> Int }@
   deriving( Show, Eq, Ord, Data, Typeable, Generic )
 
+-- | Properties for overlapping instances.
+data Overlap = Overlappable   -- ^ May be overlapped by more specific instances
+             | Overlapping    -- ^ May overlap a more general instance
+             | Overlaps       -- ^ Both 'Overlapping' and 'Overlappable'
+             | Incoherent     -- ^ Both 'Overlappable' and 'Overlappable', and
+                              -- pick an arbitrary one if multiple choices are
+                              -- avaialble.
+  deriving( Show, Eq, Ord, Data, Typeable, Generic )
+
 -- | Common elements of 'OpenTypeFamilyD' and 'ClosedTypeFamilyD'.
 -- By analogy with with "head" for type classes and type class instances as
 -- defined in /Type classes: an exploration of the design space/, the
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index c313c62d14..e746cb54fc 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -47,6 +47,8 @@
 
   * TODO: document API changes and important bugfixes
 
+  * Add support for OVERLAP(S/PED/PING) pragmas on instances
+
 
 ## 2.10.0.0  *Mar 2015*