Factor-out the `OverlapMode` from `OverlapFlag`.
authorIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 29 Jun 2014 23:34:30 +0000 (16:34 -0700)
committerIavor S. Diatchki <iavor.diatchki@gmail.com>
Sun, 29 Jun 2014 23:34:30 +0000 (16:34 -0700)
This seems a bit cleaner conceptually because the overlap mode and running
in safety mode are quite orthogonal.

More pragmatically, it also makes it possible to use `OverlapMode` to let
programmers pick the overlap mode for individual instances.

compiler/basicTypes/BasicTypes.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcGenGenerics.lhs
compiler/types/InstEnv.lhs
compiler/utils/Binary.hs

index 9a92b00..f4a7aaf 100644 (file)
@@ -41,7 +41,7 @@ module BasicTypes(
 
         TopLevelFlag(..), isTopLevel, isNotTopLevel,
 
-        OverlapFlag(..),
+        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
 
         Boxity(..), isBoxed,
 
@@ -447,9 +447,19 @@ instance Outputable Origin where
 -- | The semantics allowed for overlapping instances for a particular
 -- instance. See Note [Safe Haskell isSafeOverlap] (in `InstEnv.lhs`) for a
 -- explanation of the `isSafeOverlap` field.
-data OverlapFlag
+data OverlapFlag = OverlapFlag
+  { overlapMode   :: OverlapMode
+  , isSafeOverlap :: Bool
+  } deriving (Eq, Data, Typeable)
+
+setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag
+setOverlapModeMaybe f Nothing  = f
+setOverlapModeMaybe f (Just m) = f { overlapMode = m }
+
+
+data OverlapMode
   -- | This instance must not overlap another
-  = NoOverlap { isSafeOverlap :: Bool }
+  = NoOverlap
 
   -- | Silently ignore this instance if you find a
   -- more specific one that matches the constraint
@@ -461,7 +471,7 @@ data OverlapFlag
   -- Since the second instance has the OverlapOk flag,
   -- the first instance will be chosen (otherwise
   -- its ambiguous which to choose)
-  | OverlapOk { isSafeOverlap :: Bool }
+  | OverlapOk
 
   -- | Silently ignore this instance if you find any other that matches the
   -- constraing you are trying to resolve, including when checking if there are
@@ -473,13 +483,16 @@ data OverlapFlag
   -- Without the Incoherent flag, we'd complain that
   -- instantiating 'b' would change which instance
   -- was chosen. See also note [Incoherent instances]
-  | Incoherent { isSafeOverlap :: Bool }
+  | Incoherent
   deriving (Eq, Data, Typeable)
 
 instance Outputable OverlapFlag where
-   ppr (NoOverlap  b) = empty <+> pprSafeOverlap b
-   ppr (OverlapOk  b) = ptext (sLit "[overlap ok]") <+> pprSafeOverlap b
-   ppr (Incoherent b) = ptext (sLit "[incoherent]") <+> pprSafeOverlap b
+   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]")
 
 pprSafeOverlap :: Bool -> SDoc
 pprSafeOverlap True  = ptext $ sLit "[safe]"
index 2bcf981..dac5228 100644 (file)
@@ -383,14 +383,15 @@ syntaxNameCtxt name orig ty tidy_env
 
 \begin{code}
 getOverlapFlag :: TcM OverlapFlag
-getOverlapFlag 
+getOverlapFlag
   = do  { dflags <- getDynFlags
         ; let overlap_ok    = xopt Opt_OverlappingInstances dflags
               incoherent_ok = xopt Opt_IncoherentInstances  dflags
-              safeOverlap   = safeLanguageOn dflags
-              overlap_flag | incoherent_ok = Incoherent safeOverlap
-                           | overlap_ok    = OverlapOk safeOverlap
-                           | otherwise     = NoOverlap safeOverlap
+              use x = OverlapFlag { isSafeOverlap = safeLanguageOn dflags
+                                  , overlapMode   = x }
+              overlap_flag | incoherent_ok = use Incoherent
+                           | overlap_ok    = use OverlapOk
+                           | otherwise     = use NoOverlap
 
         ; return overlap_flag }
 
@@ -462,10 +463,10 @@ addLocalInst home_ie ispec
              False -> case dup_ispecs of
                  dup : _ -> dupInstErr ispec dup >> return (extendInstEnv home_ie ispec)
                  []      -> return (extendInstEnv home_ie ispec)
-             True  -> case (dup_ispecs, home_ie_matches, unifs, overlapFlag) of
+             True  -> case (dup_ispecs, home_ie_matches, unifs, overlapMode overlapFlag) of
                  (_, _:_, _, _)      -> return (overwriteInstEnv home_ie ispec)
                  (dup:_, [], _, _)   -> dupInstErr ispec dup >> return (extendInstEnv home_ie ispec)
-                 ([], _, u:_, NoOverlap _)    -> overlappingInstErr ispec u >> return (extendInstEnv home_ie ispec)
+                 ([], _, u:_, NoOverlap)    -> overlappingInstErr ispec u >> return (extendInstEnv home_ie ispec)
                  _                   -> return (extendInstEnv home_ie ispec)
                where (homematches, _) = lookupInstEnv' home_ie cls tys
                      home_ie_matches = [ dup_ispec 
index 044d058..385fc37 100644 (file)
@@ -121,11 +121,11 @@ metaTyConsToDerivStuff tc metaDts =
       fix_env <- getFixityEnv
 
       let
-        safeOverlap = safeLanguageOn dflags
         (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc
         mk_inst clas tc dfun_name
           = mkLocalInstance (mkDictFunId dfun_name [] [] clas tys)
-                            (NoOverlap safeOverlap)
+                            OverlapFlag { overlapMode   = NoOverlap
+                                        , isSafeOverlap = safeLanguageOn dflags }
                             [] clas tys
           where
             tys = [mkTyConTy tc]
index 176f189..be1cdb1 100644 (file)
@@ -10,12 +10,13 @@ The bits common to TcInstDcls and TcDeriv.
 {-# LANGUAGE CPP, DeriveDataTypeable #-}
 
 module InstEnv (
-        DFunId, OverlapFlag(..), InstMatch, ClsInstLookupResult,
-        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances, 
+        DFunId, InstMatch, ClsInstLookupResult,
+        OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,
+        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,
         instanceHead, instanceSig, mkLocalInstance, mkImportedInstance,
         instanceDFunId, tidyClsInstDFun, instanceRoughTcs,
 
-        InstEnv, emptyInstEnv, extendInstEnv, overwriteInstEnv, 
+        InstEnv, emptyInstEnv, extendInstEnv, overwriteInstEnv,
         extendInstEnvList, lookupUniqueInstEnv, lookupInstEnv', lookupInstEnv, instEnvElts,
         classInstances, orphNamesOfClsInst, instanceBindFun,
         instanceCantMatch, roughMatchTcs
@@ -536,7 +537,7 @@ lookupInstEnv' ie cls tys
 
         -- Does not match, so next check whether the things unify
         -- See Note [Overlapping instances] and Note [Incoherent Instances]
-      | Incoherent _ <- oflag
+      | Incoherent <- overlapMode oflag
       = find ms us rest
 
       | otherwise
@@ -635,11 +636,10 @@ insert_overlapping new_item (item:items)
     new_beats_old = new_item `beats` item
     old_beats_new = item `beats` new_item
 
-    incoherent (inst, _) = case is_flag inst of Incoherent _ -> True
-                                                _            -> False
+    incoherent (inst, _) = overlapMode (is_flag inst) == Incoherent
 
     (instA, _) `beats` (instB, _)
-          = overlap_ok && 
+          = 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)
@@ -648,9 +648,10 @@ insert_overlapping new_item (item:items)
             -- 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 (is_flag instA, is_flag instB) of
-                              (NoOverlap _, NoOverlap _) -> False
-                              _                          -> True
+            overlap_ok = case (overlapMode (is_flag instA),
+                               overlapMode (is_flag instB)) of
+                              (NoOverlap, NoOverlap) -> False
+                              _                      -> True
 \end{code}
 
 Note [Incoherent instances]
index 166a948..82d1497 100644 (file)
@@ -833,18 +833,26 @@ instance Binary RecFlag where
               0 -> do return Recursive
               _ -> do return NonRecursive
 
-instance Binary OverlapFlag where
-    put_ bh (NoOverlap  b) = putByte bh 0 >> put_ bh b
-    put_ bh (OverlapOk  b) = putByte bh 1 >> put_ bh b
-    put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b
+instance Binary OverlapMode where
+    put_ bh NoOverlap   = putByte bh 0
+    put_ bh OverlapOk   = putByte bh 1
+    put_ bh Incoherent  = putByte bh 2
     get bh = do
         h <- getByte bh
-        b <- get bh
         case h of
-            0 -> return $ NoOverlap b
-            1 -> return $ OverlapOk b
-            2 -> return $ Incoherent b
-            _ -> panic ("get OverlapFlag " ++ show h)
+            0 -> return NoOverlap
+            1 -> return OverlapOk
+            2 -> return Incoherent
+            _ -> panic ("get OverlapMode" ++ show h)
+
+
+instance Binary OverlapFlag where
+    put_ bh flag = do put_ bh (overlapMode flag)
+                      put_ bh (isSafeOverlap flag)
+    get bh = do
+        h <- get bh
+        b <- get bh
+        return OverlapFlag { overlapMode = h, isSafeOverlap = b }
 
 instance Binary FixityDirection where
     put_ bh InfixL = do