Overlapable pragmas for individual instances (#9242)

Programmers may provide a pragma immediately after the `instance` keyword
to control the overlap/incoherence behavior for individual instances.
For example:

    instance {-# OVERLAP #-} C a where ...

I chose this notation, rather than the other two outlined in the ticket
for these reasons:

   1. Having the pragma after the type looks odd, I think.
   2. Having the pragma after there `where` does not work for
       stand-alone derived instances

I have implemented 3 pragams:

   1. NO_OVERLAP
   2. OVERLAP
   3. INCOHERENT

These correspond directly to the internal modes currently supported by
GHC.  If a pragma is specified, it will be used no matter what flags are
turned on.   For example, putting `NO_OVERLAP` on an instance will mark
it as non-overlapping, even if `OVERLAPPIN_INSTANCES` is turned on for the
module.

2 files changed, 21 insertions, 5 deletions

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 6862901437..122be81972 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -216,7 +216,7 @@ cvtDec (InstanceD ctxt ty decs)
         ; ctxt' <- cvtContext ctxt
         ; L loc ty' <- cvtType ty
         ; let inst_ty' = L loc $ mkImplicitHsForAllTy ctxt' $ L loc ty'
-        ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts')) }
+        ; returnL $ InstD (ClsInstD (ClsInstDecl inst_ty' binds' sigs' ats' adts' Nothing)) }
 
 cvtDec (ForeignD ford)
   = do { ford' <- cvtForD ford
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index c4174db776..d35a7e5c5e 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -941,6 +941,7 @@ data ClsInstDecl name
       , cid_sigs  :: [LSig name]                -- User-supplied pragmatic info
       , cid_tyfam_insts :: [LTyFamInstDecl name]  -- type family instances
       , cid_datafam_insts :: [LDataFamInstDecl name] -- data family instances
+      , cid_overlap_mode :: Maybe OverlapMode
       }
   deriving (Data, Typeable)
 
@@ -1013,6 +1014,7 @@ pprDataFamInstFlavour (DataFamInstDecl { dfid_defn = (HsDataDefn { dd_ND = nd })
 instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
     ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds
                      , cid_sigs = sigs, cid_tyfam_insts = ats
+                     , cid_overlap_mode = mbOverlap
                      , cid_datafam_insts = adts })
       | null sigs, null ats, null adts, isEmptyBag binds  -- No "where" part
       = top_matter
@@ -1024,7 +1026,19 @@ instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
                map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
                pprLHsBindsForUser binds sigs ]
       where
-        top_matter = ptext (sLit "instance") <+> ppr inst_ty
+        top_matter = ptext (sLit "instance") <+> ppOveralapPragma mbOverlap
+                                             <+> ppr inst_ty
+
+ppOveralapPragma :: Maybe OverlapMode -> SDoc
+ppOveralapPragma mb =
+  case mb of
+    Nothing          -> empty
+    Just NoOverlap   -> ptext (sLit "{-# NO_OVERLAP #-}")
+    Just OverlapOk   -> ptext (sLit "{-# OVERLAP #-}")
+    Just Incoherent  -> ptext (sLit "{-# INCOHERENT #-}")
+
+
+
 
 instance (OutputableBndr name) => Outputable (InstDecl name) where
     ppr (ClsInstD     { cid_inst  = decl }) = ppr decl
@@ -1052,12 +1066,14 @@ instDeclDataFamInsts inst_decls
 \begin{code}
 type LDerivDecl name = Located (DerivDecl name)
 
-data DerivDecl name = DerivDecl { deriv_type :: LHsType name }
+data DerivDecl name = DerivDecl { deriv_type :: LHsType name
+                                , deriv_overlap_mode :: Maybe OverlapMode
+                                }
   deriving (Data, Typeable)
 
 instance (OutputableBndr name) => Outputable (DerivDecl name) where
-    ppr (DerivDecl ty) 
-        = hsep [ptext (sLit "deriving instance"), ppr ty]
+    ppr (DerivDecl ty o)
+        = hsep [ptext (sLit "deriving instance"), ppOveralapPragma o, ppr ty]
 \end{code}
 
 %************************************************************************