diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/basicTypes/BasicTypes.lhs | 29 | ||||
| -rw-r--r-- | compiler/typecheck/Inst.lhs | 15 | ||||
| -rw-r--r-- | compiler/typecheck/TcGenGenerics.lhs | 4 | ||||
| -rw-r--r-- | compiler/types/InstEnv.lhs | 21 | ||||
| -rw-r--r-- | compiler/utils/Binary.hs | 26 |
5 files changed, 59 insertions, 36 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 9a92b003bc..f4a7aaf335 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -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]" diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index 2bcf981e06..dac522803f 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -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 diff --git a/compiler/typecheck/TcGenGenerics.lhs b/compiler/typecheck/TcGenGenerics.lhs index 044d058a4d..385fc37306 100644 --- a/compiler/typecheck/TcGenGenerics.lhs +++ b/compiler/typecheck/TcGenGenerics.lhs @@ -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] diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 176f189922..be1cdb1e44 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -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] diff --git a/compiler/utils/Binary.hs b/compiler/utils/Binary.hs index 166a94850b..82d1497ee6 100644 --- a/compiler/utils/Binary.hs +++ b/compiler/utils/Binary.hs @@ -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 |