SafeHaskell: Move safe haskell flag into Overlap flag
authorDavid Terei <davidterei@gmail.com>
Tue, 24 May 2011 00:31:10 +0000 (17:31 -0700)
committerDavid Terei <davidterei@gmail.com>
Sat, 18 Jun 2011 03:40:17 +0000 (20:40 -0700)
For instance decls we no longer store the SafeHaskell mode
in this data structure but instead store it as a bool field
in the overlap flag structure.

compiler/basicTypes/BasicTypes.lhs
compiler/iface/BinIface.hs
compiler/iface/LoadIface.lhs
compiler/iface/TcIface.lhs
compiler/iface/TcIface.lhs-boot
compiler/typecheck/Inst.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/types/InstEnv.lhs

index 7ea66e1..5c931d9 100644 (file)
@@ -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}
 
 %************************************************************************
index 904d5a6..0fab2d2 100644 (file)
@@ -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
index b73c186..219ab6a 100644 (file)
@@ -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)
index ac5794a..ab28615 100644 (file)
@@ -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, 
index e6f3b7b..d78253e 100644 (file)
@@ -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}
index a3caea6..028f339 100644 (file)
@@ -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
index 7499cd9..0881097 100644 (file)
@@ -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
index 7ca7a32..d4d8d2f 100644 (file)
@@ -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)
index 4fb64fb..eb7a521 100644 (file)
@@ -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}