Implement OVERLAPPING and OVERLAPPABLE pragmas (see #9242)

This also removes the short-lived NO_OVERLAP pragama, and renames
OVERLAP to OVERLAPS.

An instance may be annotated with one of 4 pragams, to control its
interaction with other overlapping instances:

  * OVERLAPPABLE:
    this instance is ignored if a more specific candidate exists

  * OVERLAPPING:
    this instance is preferred over more general candidates

  * OVERLAPS:
    both OVERLAPPING and OVERLAPPABLE (i.e., the previous GHC behavior).
    When compiling with -XOverlappingInstances, all instance are OVERLAPS.

  * INCOHERENT:
    same as before (see manual for details).
    When compiling with -XIncoherentInstances, all instances are INCOHERENT.

7 files changed, 104 insertions, 52 deletions

diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs
index f4a7aaf335..0ae47377d7 100644
--- a/compiler/basicTypes/BasicTypes.lhs
+++ b/compiler/basicTypes/BasicTypes.lhs
@@ -42,6 +42,7 @@ module BasicTypes(
         TopLevelFlag(..), isTopLevel, isNotTopLevel,
 
         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
+        hasOverlappingFlag, hasOverlappableFlag,
 
         Boxity(..), isBoxed,
 
@@ -456,43 +457,81 @@ setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag
 setOverlapModeMaybe f Nothing  = f
 setOverlapModeMaybe f (Just m) = f { overlapMode = m }
 
+hasOverlappableFlag :: OverlapMode -> Bool
+hasOverlappableFlag mode =
+  case mode of
+    Overlappable -> True
+    Overlaps     -> True
+    _            -> False
+
+hasOverlappingFlag :: OverlapMode -> Bool
+hasOverlappingFlag mode =
+  case mode of
+    Overlapping  -> True
+    Overlaps     -> True
+    _            -> False
 
 data OverlapMode
-  -- | This instance must not overlap another
+
+  {- | This instance must not overlap another `NoOverlap` instance.
+  However, it may be overlapped by `Overlapping` instances,
+  and it may overlap `Overlappable` instances. -}
   = NoOverlap
 
-  -- | Silently ignore this instance if you find a
-  -- more specific one that matches the constraint
-  -- you are trying to resolve
-  --
-  -- Example: constraint (Foo [Int])
-  --        instances  (Foo [Int])
-  --                   (Foo [a])        OverlapOk
-  -- Since the second instance has the OverlapOk flag,
-  -- the first instance will be chosen (otherwise
-  -- its ambiguous which to choose)
-  | OverlapOk
+
+  {- | Silently ignore this instance if you find a
+  more specific one that matches the constraint
+  you are trying to resolve
+
+  Example: constraint (Foo [Int])
+    instance                      Foo [Int]
+    instance {-# OVERLAPPABLE #-} Foo [a]
+
+  Since the second instance has the Overlappable flag,
+  the first instance will be chosen (otherwise
+  its ambiguous which to choose) -}
+  | Overlappable
+
+
+  {- | Silently ignore any more general instances that may be
+       used to solve the constraint.
+
+  Example: constraint (Foo [Int])
+    instance {-# OVERLAPPING #-} Foo [Int]
+    instance                     Foo [a]
+
+  Since the first instance has the Overlapping flag,
+  the second---more general---instance will be ignored (otherwise
+  its ambiguous which to choose) -}
+  | Overlapping
+
+
+  -- | Equiavalent to having both `Overlapping` and `Overlappable` flags.
+  | Overlaps
 
   -- | Silently ignore this instance if you find any other that matches the
   -- constraing you are trying to resolve, including when checking if there are
   -- instances that do not match, but unify.
   --
   -- Example: constraint (Foo [b])
-  --        instances  (Foo [Int])      Incoherent
-  --                   (Foo [a])
+  -- instance {-# INCOHERENT -} Foo [Int]
+  -- instance                   Foo [a]
   -- Without the Incoherent flag, we'd complain that
   -- instantiating 'b' would change which instance
   -- was chosen. See also note [Incoherent instances]
   | Incoherent
   deriving (Eq, Data, Typeable)
 
+
 instance Outputable OverlapFlag where
    ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag)
 
 instance Outputable OverlapMode where
-   ppr NoOverlap  = empty
-   ppr OverlapOk  = ptext (sLit "[overlap ok]")
-   ppr Incoherent = ptext (sLit "[incoherent]")
+   ppr NoOverlap    = empty
+   ppr Overlappable = ptext (sLit "[overlappable]")
+   ppr Overlapping  = ptext (sLit "[overlapping]")
+   ppr Overlaps     = ptext (sLit "[overlap ok]")
+   ppr Incoherent   = ptext (sLit "[incoherent]")
 
 pprSafeOverlap :: Bool -> SDoc
 pprSafeOverlap True  = ptext $ sLit "[safe]"
diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index 845c05296c..313dccccd5 100644
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -1055,16 +1055,18 @@ instance (OutputableBndr name) => Outputable (ClsInstDecl name) where
                map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++
                pprLHsBindsForUser binds sigs ]
       where
-        top_matter = ptext (sLit "instance") <+> ppOveralapPragma mbOverlap
+        top_matter = ptext (sLit "instance") <+> ppOverlapPragma mbOverlap
                                              <+> ppr inst_ty
 
-ppOveralapPragma :: Maybe OverlapMode -> SDoc
-ppOveralapPragma mb =
+ppOverlapPragma :: Maybe OverlapMode -> SDoc
+ppOverlapPragma mb =
   case mb of
-    Nothing          -> empty
-    Just NoOverlap   -> ptext (sLit "{-# NO_OVERLAP #-}")
-    Just OverlapOk   -> ptext (sLit "{-# OVERLAP #-}")
-    Just Incoherent  -> ptext (sLit "{-# INCOHERENT #-}")
+    Nothing           -> empty
+    Just NoOverlap    -> ptext (sLit "{-# NO_OVERLAP #-}")
+    Just Overlappable -> ptext (sLit "{-# OVERLAPPABLE #-}")
+    Just Overlapping  -> ptext (sLit "{-# OVERLAPPING #-}")
+    Just Overlaps     -> ptext (sLit "{-# OVERLAPS #-}")
+    Just Incoherent   -> ptext (sLit "{-# INCOHERENT #-}")
 
 
 
@@ -1102,7 +1104,7 @@ data DerivDecl name = DerivDecl { deriv_type :: LHsType name
 
 instance (OutputableBndr name) => Outputable (DerivDecl name) where
     ppr (DerivDecl ty o)
-        = hsep [ptext (sLit "deriving instance"), ppOveralapPragma o, ppr ty]
+        = hsep [ptext (sLit "deriving instance"), ppOverlapPragma o, ppr ty]
 \end{code}
 
 %************************************************************************
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index 3917dcfcfc..88a0f07d90 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -527,8 +527,9 @@ data Token
   | ITvect_scalar_prag
   | ITnovect_prag
   | ITminimal_prag
-  | ITno_overlap_prag           -- instance overlap mode
-  | IToverlap_prag              -- instance overlap mode
+  | IToverlappable_prag         -- instance overlap mode
+  | IToverlapping_prag          -- instance overlap mode
+  | IToverlaps_prag             -- instance overlap mode
   | ITincoherent_prag           -- instance overlap mode
   | ITctype
 
@@ -2431,8 +2432,9 @@ oneWordPrags = Map.fromList([("rules", rulePrag),
                            ("vectorize", token ITvect_prag),
                            ("novectorize", token ITnovect_prag),
                            ("minimal", token ITminimal_prag),
-                           ("no_overlap", token ITno_overlap_prag),
-                           ("overlap", token IToverlap_prag),
+                           ("overlaps", token IToverlaps_prag),
+                           ("overlappable", token IToverlappable_prag),
+                           ("overlapping", token IToverlapping_prag),
                            ("incoherent", token ITincoherent_prag),
                            ("ctype", token ITctype)])
 
diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index d592510aa6..3fff097d25 100644
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -286,8 +286,9 @@ incorrect.
  '{-# NOVECTORISE'        { L _ ITnovect_prag }
  '{-# MINIMAL'            { L _ ITminimal_prag }
  '{-# CTYPE'              { L _ ITctype }
- '{-# NO_OVERLAP'         { L _ ITno_overlap_prag }
- '{-# OVERLAP'            { L _ IToverlap_prag }
+ '{-# OVERLAPPING'        { L _ IToverlapping_prag }
+ '{-# OVERLAPPABLE'       { L _ IToverlappable_prag }
+ '{-# OVERLAPS'           { L _ IToverlaps_prag }
  '{-# INCOHERENT'         { L _ ITincoherent_prag }
  '#-}'                                          { L _ ITclose_prag }
 
@@ -707,10 +708,11 @@ inst_decl :: { LInstDecl RdrName }
                                      (unLoc $5) (unLoc $6) (unLoc $7) }
 
 overlap_pragma :: { Maybe OverlapMode }
-  : '{-# OVERLAP'    '#-}'    { Just OverlapOk  }
-  | '{-# INCOHERENT' '#-}'    { Just Incoherent }
-  | '{-# NO_OVERLAP' '#-}'    { Just NoOverlap  }
-  | {- empty -}               { Nothing }
+  : '{-# OVERLAPPABLE'    '#-}' { Just Overlappable }
+  | '{-# OVERLAPPING'     '#-}' { Just Overlapping }
+  | '{-# OVERLAPS'        '#-}' { Just Overlaps }
+  | '{-# INCOHERENT'      '#-}' { Just Incoherent }
+  | {- empty -}                 { Nothing }
 
 
 -- Closed type families
diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs
index dac522803f..723ce0671e 100644
--- a/compiler/typecheck/Inst.lhs
+++ b/compiler/typecheck/Inst.lhs
@@ -390,7 +390,7 @@ getOverlapFlag
               use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
                                   , overlapMode   = x }
               overlap_flag | incoherent_ok = use Incoherent
-                           | overlap_ok    = use OverlapOk
+                           | overlap_ok    = use Overlaps
                            | otherwise     = use NoOverlap
 
         ; return overlap_flag }
diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index be1cdb1e44..e1ab8da5c7 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -638,20 +638,23 @@ insert_overlapping new_item (item:items)
 
     incoherent (inst, _) = overlapMode (is_flag inst) == Incoherent
 
+    -- `instB` can be instantiated to match `instA`
+    instA `moreSpecificThan` instB =
+      isJust (tcMatchTys (mkVarSet (is_tvs instB))
+             (is_tys instB) (is_tys instA))
+
     (instA, _) `beats` (instB, _)
-          = overlap_ok &&
-            isJust (tcMatchTys (mkVarSet (is_tvs instB)) (is_tys instB) (is_tys instA))
-                    -- A beats B if A is more specific than B,
-                    -- (ie. if B can be instantiated to match A)
-                    -- and overlap is permitted
+          = overlap_ok && (instA `moreSpecificThan` instB)
           where
-            -- Overlap permitted if *either* instance permits overlap
-            -- This is a change (Trac #3877, Dec 10). It used to
-            -- require that instB (the less specific one) permitted overlap.
-            overlap_ok = case (overlapMode (is_flag instA),
-                               overlapMode (is_flag instB)) of
-                              (NoOverlap, NoOverlap) -> False
-                              _                      -> True
+            {- Overlap permitted if either the more specific instance
+            is marked as overlapping, or the more general one is
+            marked as overlappable.
+            Latest change described in: Trac #9242.
+            Previous change: Trac #3877, Dec 10.  -}
+            overlap_ok = hasOverlappingFlag  (overlapMode (is_flag instA))
+                      || hasOverlappableFlag (overlapMode (is_flag instB))
+
+
 \end{code}
 
 Note [Incoherent instances]
diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs
index 82d1497ee6..0aa8c648b8 100644
--- a/compiler/utils/Binary.hs
+++ b/compiler/utils/Binary.hs
@@ -834,15 +834,19 @@ instance Binary RecFlag where
               _ -> do return NonRecursive
 
 instance Binary OverlapMode where
-    put_ bh NoOverlap   = putByte bh 0
-    put_ bh OverlapOk   = putByte bh 1
-    put_ bh Incoherent  = putByte bh 2
+    put_ bh NoOverlap     = putByte bh 0
+    put_ bh Overlaps      = putByte bh 1
+    put_ bh Incoherent    = putByte bh 2
+    put_ bh Overlapping   = putByte bh 3
+    put_ bh Overlappable  = putByte bh 4
     get bh = do
         h <- getByte bh
         case h of
             0 -> return NoOverlap
-            1 -> return OverlapOk
+            1 -> return Overlaps
             2 -> return Incoherent
+            3 -> return Overlapping
+            4 -> return Overlappable
             _ -> panic ("get OverlapMode" ++ show h)