diff options
| -rw-r--r-- | compiler/basicTypes/BasicTypes.lhs | 61 | ||||
| -rw-r--r-- | compiler/iface/BinIface.hs | 13 | ||||
| -rw-r--r-- | compiler/iface/LoadIface.lhs | 2 | ||||
| -rw-r--r-- | compiler/iface/TcIface.lhs | 9 | ||||
| -rw-r--r-- | compiler/iface/TcIface.lhs-boot | 2 | ||||
| -rw-r--r-- | compiler/typecheck/Inst.lhs | 24 | ||||
| -rw-r--r-- | compiler/typecheck/TcDeriv.lhs | 26 | ||||
| -rw-r--r-- | compiler/typecheck/TcInstDcls.lhs | 3 | ||||
| -rw-r--r-- | compiler/types/InstEnv.lhs | 25 |
9 files changed, 80 insertions, 85 deletions
diff --git a/compiler/basicTypes/BasicTypes.lhs b/compiler/basicTypes/BasicTypes.lhs index 7ea66e1db2..5c931d9d3a 100644 --- a/compiler/basicTypes/BasicTypes.lhs +++ b/compiler/basicTypes/BasicTypes.lhs @@ -324,38 +324,43 @@ instance Outputable RecFlag where \begin{code} data OverlapFlag - = NoOverlap -- This instance must not overlap another - - | 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]) - -- 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) - - | Incoherent -- Like OverlapOk, but also ignore this instance - -- if it doesn't match the constraint you are - -- trying to resolve, but could match if the type variables - -- in the constraint were instantiated - -- - -- Example: constraint (Foo [b]) - -- instances (Foo [Int]) Incoherent - -- (Foo [a]) - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen + -- | This instance must not overlap another + = NoOverlap { isSafeOverlap :: Bool } + + -- | 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 { isSafeOverlap :: Bool } + + -- | Like OverlapOk, but also ignore this instance + -- if it doesn't match the constraint you are + -- trying to resolve, but could match if the type variables + -- in the constraint were instantiated + -- + -- Example: constraint (Foo [b]) + -- instances (Foo [Int]) Incoherent + -- (Foo [a]) + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen + | Incoherent { isSafeOverlap :: Bool } deriving( Eq ) instance Outputable OverlapFlag where - ppr NoOverlap = empty - ppr OverlapOk = ptext (sLit "[overlap ok]") - ppr Incoherent = ptext (sLit "[incoherent]") + ppr (NoOverlap b) = empty <+> pprSafeOverlap b + ppr (OverlapOk b) = ptext (sLit "[overlap ok]") <+> pprSafeOverlap b + ppr (Incoherent b) = ptext (sLit "[incoherent]") <+> pprSafeOverlap b +pprSafeOverlap :: Bool -> SDoc +pprSafeOverlap True = ptext $ sLit "[safe]" +pprSafeOverlap False = empty \end{code} %************************************************************************ diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs index 904d5a6877..0fab2d28c8 100644 --- a/compiler/iface/BinIface.hs +++ b/compiler/iface/BinIface.hs @@ -1407,14 +1407,15 @@ instance Binary IfaceFamInst where return (IfaceFamInst fam tys tycon) instance Binary OverlapFlag where - put_ bh NoOverlap = putByte bh 0 - put_ bh OverlapOk = putByte bh 1 - put_ bh Incoherent = putByte bh 2 + 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 get bh = do h <- getByte bh + b <- get bh case h of - 0 -> return NoOverlap - 1 -> return OverlapOk - 2 -> return Incoherent + 0 -> return $ NoOverlap b + 1 -> return $ OverlapOk b + 2 -> return $ Incoherent b _ -> panic ("get OverlapFlag " ++ show h) instance Binary IfaceConDecls where diff --git a/compiler/iface/LoadIface.lhs b/compiler/iface/LoadIface.lhs index b73c186dd0..219ab6a917 100644 --- a/compiler/iface/LoadIface.lhs +++ b/compiler/iface/LoadIface.lhs @@ -240,7 +240,7 @@ loadInterface doc_str mod from ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) - ; new_eps_insts <- mapM (tcIfaceInst $ mi_trust iface) (mi_insts iface) + ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) ; new_eps_fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; new_eps_rules <- tcIfaceRules ignore_prags (mi_rules iface) ; new_eps_anns <- tcIfaceAnnotations (mi_anns iface) diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs index ac5794a53f..ab28615c80 100644 --- a/compiler/iface/TcIface.lhs +++ b/compiler/iface/TcIface.lhs @@ -265,7 +265,7 @@ typecheckIface iface ; writeMutVar tc_env_var type_env -- Now do those rules, instances and annotations - ; insts <- mapM (tcIfaceInst $ mi_trust iface) (mi_insts iface) + ; insts <- mapM tcIfaceInst (mi_insts iface) ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; rules <- tcIfaceRules ignore_prags (mi_rules iface) ; anns <- tcIfaceAnnotations (mi_anns iface) @@ -588,14 +588,13 @@ look at it. %************************************************************************ \begin{code} -tcIfaceInst :: IfaceTrustInfo -> IfaceInst -> IfL Instance -tcIfaceInst safe (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, +tcIfaceInst :: IfaceInst -> IfL Instance +tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, ifInstCls = cls, ifInstTys = mb_tcs }) = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ tcIfaceExtId dfun_occ ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; let safe' = getSafeMode safe - ; return (mkImportedInstance cls mb_tcs' dfun oflag safe') } + ; return (mkImportedInstance cls mb_tcs' dfun oflag) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, diff --git a/compiler/iface/TcIface.lhs-boot b/compiler/iface/TcIface.lhs-boot index e6f3b7b0c4..d78253e034 100644 --- a/compiler/iface/TcIface.lhs-boot +++ b/compiler/iface/TcIface.lhs-boot @@ -14,7 +14,7 @@ import Annotations ( Annotation ) tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo -tcIfaceInst :: IfaceTrustInfo -> IfaceInst -> IfL Instance +tcIfaceInst :: IfaceInst -> IfL Instance tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] \end{code} diff --git a/compiler/typecheck/Inst.lhs b/compiler/typecheck/Inst.lhs index a3caea6e8e..028f339c88 100644 --- a/compiler/typecheck/Inst.lhs +++ b/compiler/typecheck/Inst.lhs @@ -13,7 +13,7 @@ module Inst ( newOverloadedLit, mkOverLit, - tcGetInstEnvs, getOverlapFlag, getSafeHaskellFlag, + tcGetInstEnvs, getOverlapFlag, tcExtendLocalInstEnv, instCallConstraints, newMethodFromName, tcSyntaxName, @@ -368,19 +368,15 @@ syntaxNameCtxt name orig ty tidy_env = do \begin{code} getOverlapFlag :: TcM OverlapFlag getOverlapFlag - = do { dflags <- getDOpts - ; let overlap_ok = xopt Opt_OverlappingInstances dflags - incoherent_ok = xopt Opt_IncoherentInstances dflags - overlap_flag | incoherent_ok = Incoherent - | overlap_ok = OverlapOk - | otherwise = NoOverlap - - ; return overlap_flag } - -getSafeHaskellFlag :: TcM SafeHaskellMode -getSafeHaskellFlag - = do { dflags <- getDOpts - ; return $ safeHaskell dflags } + = do { dflags <- getDOpts + ; 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 + + ; return overlap_flag } tcGetInstEnvs :: TcM (InstEnv, InstEnv) -- Gets both the external-package inst-env diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 7499cd9ac6..08810978e7 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/compiler/typecheck/TcDeriv.lhs @@ -315,14 +315,13 @@ tcDeriving tycl_decls inst_decls deriv_decls ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras ; overlap_flag <- getOverlapFlag - ; safe <- getSafeHaskellFlag ; let (infer_specs, given_specs) = splitEithers early_specs - ; insts1 <- mapM (genInst True safe overlap_flag) given_specs + ; insts1 <- mapM (genInst True overlap_flag) given_specs ; final_specs <- extendLocalInstEnv (map (iSpec . fst) insts1) $ - inferInstanceContexts safe overlap_flag infer_specs + inferInstanceContexts overlap_flag infer_specs - ; insts2 <- mapM (genInst False safe overlap_flag) final_specs + ; insts2 <- mapM (genInst False overlap_flag) final_specs -- We no longer generate the old generic to/from functions -- from each type declaration, so this is emptyBag @@ -1325,11 +1324,11 @@ ordered by sorting on type varible, tv, (major key) and then class, k, \end{itemize} \begin{code} -inferInstanceContexts :: SafeHaskellMode -> OverlapFlag -> [DerivSpec] -> TcM [DerivSpec] +inferInstanceContexts :: OverlapFlag -> [DerivSpec] -> TcM [DerivSpec] -inferInstanceContexts _ _ [] = return [] +inferInstanceContexts _ [] = return [] -inferInstanceContexts safe oflag infer_specs +inferInstanceContexts oflag infer_specs = do { traceTc "inferInstanceContexts" $ vcat (map pprDerivSpec infer_specs) ; iterate_deriv 1 initial_solutions } where @@ -1355,7 +1354,7 @@ inferInstanceContexts safe oflag infer_specs | otherwise = do { -- Extend the inst info from the explicit instance decls -- with the current set of solutions, and simplify each RHS - let inst_specs = zipWithEqual "add_solns" (mkInstance safe oflag) + let inst_specs = zipWithEqual "add_solns" (mkInstance oflag) current_solns infer_specs ; new_solns <- checkNoErrs $ extendLocalInstEnv inst_specs $ @@ -1401,11 +1400,11 @@ inferInstanceContexts safe oflag infer_specs the_pred = mkClassPred clas inst_tys ------------------------------------------------------------------ -mkInstance :: SafeHaskellMode -> OverlapFlag -> ThetaType -> DerivSpec -> Instance -mkInstance safe overlap_flag theta +mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance +mkInstance overlap_flag theta (DS { ds_name = dfun_name , ds_tvs = tyvars, ds_cls = clas, ds_tys = tys }) - = mkLocalInstance dfun overlap_flag safe + = mkLocalInstance dfun overlap_flag where dfun = mkDictFunId dfun_name tyvars theta clas tys @@ -1492,10 +1491,9 @@ the renamer. What a great hack! -- case of instances for indexed families. -- genInst :: Bool -- True <=> standalone deriving - -> SafeHaskellMode -> OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds) -genInst standalone_deriv safe oflag +genInst standalone_deriv oflag spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args , ds_theta = theta, ds_newtype = is_newtype , ds_name = name, ds_cls = clas }) @@ -1514,7 +1512,7 @@ genInst standalone_deriv safe oflag , iBinds = VanillaInst meth_binds [] standalone_deriv } , aux_binds) } where - inst_spec = mkInstance safe oflag theta spec + inst_spec = mkInstance oflag theta spec co1 = case tyConFamilyCoercion_maybe rep_tycon of Just co_con -> mkAxInstCo co_con rep_tc_args Nothing -> id_co diff --git a/compiler/typecheck/TcInstDcls.lhs b/compiler/typecheck/TcInstDcls.lhs index 7ca7a327ad..d4d8d2fbc5 100644 --- a/compiler/typecheck/TcInstDcls.lhs +++ b/compiler/typecheck/TcInstDcls.lhs @@ -450,11 +450,10 @@ tcLocalInstDecl1 (L loc (InstDecl poly_ty binds uprags ats)) ; dfun_name <- newDFunName clas inst_tys (getLoc poly_ty) -- Dfun location is that of instance *header* ; overlap_flag <- getOverlapFlag - ; safe <- getSafeHaskellFlag ; let (eq_theta,dict_theta) = partition isEqPred theta theta' = eq_theta ++ dict_theta dfun = mkDictFunId dfun_name tyvars theta' clas inst_tys - ispec = mkLocalInstance dfun overlap_flag safe + ispec = mkLocalInstance dfun overlap_flag ; return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags False }, idx_tycons) diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs index 4fb64fb473..eb7a5216f3 100644 --- a/compiler/types/InstEnv.lhs +++ b/compiler/types/InstEnv.lhs @@ -62,8 +62,6 @@ data Instance , is_dfun :: DFunId -- See Note [Haddock assumptions] , is_flag :: OverlapFlag -- See detailed comments with -- the decl of BasicTypes.OverlapFlag - , is_safe :: SafeHaskellMode -- SafeHaskell mode of module the - -- instance came from } \end{code} @@ -180,22 +178,21 @@ instanceHead ispec mkLocalInstance :: DFunId -> OverlapFlag - -> SafeHaskellMode -> Instance -- Used for local instances, where we can safely pull on the DFunId -mkLocalInstance dfun oflag sflag - = Instance { is_flag = oflag, is_safe = sflag, is_dfun = dfun, +mkLocalInstance dfun oflag + = Instance { is_flag = oflag, is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys, is_cls = className cls, is_tcs = roughMatchTcs tys } where (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) mkImportedInstance :: Name -> [Maybe Name] - -> DFunId -> OverlapFlag -> SafeHaskellMode -> Instance + -> DFunId -> OverlapFlag -> Instance -- Used for imported instances, where we get the rough-match stuff -- from the interface file -mkImportedInstance cls mb_tcs dfun oflag sflag - = Instance { is_flag = oflag, is_safe = sflag, is_dfun = dfun, +mkImportedInstance cls mb_tcs dfun oflag + = Instance { is_flag = oflag, is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys, is_cls = cls, is_tcs = mb_tcs } where @@ -482,12 +479,12 @@ lookupInstEnv (pkg_ie, home_ie) cls tys -- overlap instances from the same module. A same instance origin -- policy for safe compiled instances. check_safe match@(inst,_) others - = case is_safe inst of + = case isSafeOverlap (is_flag inst) of -- most specific isn't from a Safe module so OK - sf | sf /= Sf_Safe && sf /= Sf_SafeLanguage -> ([match], True) + False -> ([match], True) -- otherwise we make sure it only overlaps instances from -- the same module - _other -> (go [] others, True) + True -> (go [] others, True) where go bad [] = match:bad go bad (i@(x,_):unchecked) = @@ -538,7 +535,7 @@ lookupInstEnv (pkg_ie, home_ie) cls tys -- Does not match, so next check whether the things unify -- See Note [Overlapping instances] above - | Incoherent <- oflag + | Incoherent _ <- oflag = find ms us rest | otherwise @@ -581,8 +578,8 @@ insert_overlapping new_item (item:items) -- 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 + (NoOverlap _, NoOverlap _) -> False + _ -> True \end{code} |