SafeHaskell: Add safe import flag (not functional)
authorDavid Terei <davidterei@gmail.com>
Mon, 25 Apr 2011 19:14:21 +0000 (12:14 -0700)
committerDavid Terei <davidterei@gmail.com>
Sat, 18 Jun 2011 01:19:48 +0000 (18:19 -0700)
13 files changed:
compiler/hsSyn/HsImpExp.lhs
compiler/iface/BinIface.hs
compiler/iface/LoadIface.lhs
compiler/iface/MkIface.lhs
compiler/main/DynFlags.hs
compiler/main/HeaderInfo.hs
compiler/main/HscStats.lhs
compiler/main/HscTypes.lhs
compiler/parser/Lexer.x
compiler/parser/Parser.y.pp
compiler/rename/RnNames.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs

index 7b4c904..58bc4b0 100644 (file)
@@ -36,6 +36,7 @@ data ImportDecl name
       ideclName      :: Located ModuleName, -- ^ Module name.
       ideclPkgQual   :: Maybe FastString,   -- ^ Package qualifier.
       ideclSource    :: Bool,               -- ^ True <=> {-# SOURCE #-} import
+      ideclSafe      :: Bool,               -- ^ True => safe import
       ideclQualified :: Bool,               -- ^ True => qualified
       ideclAs        :: Maybe ModuleName,   -- ^ as Module
       ideclHiding    :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names)
@@ -54,9 +55,9 @@ simpleImportDecl mn = ImportDecl {
 
 \begin{code}
 instance (Outputable name) => Outputable (ImportDecl name) where
-    ppr (ImportDecl mod pkg from qual as spec)
-      = hang (hsep [ptext (sLit "import"), ppr_imp from, 
-                    pp_qual qual, pp_pkg pkg, ppr mod, pp_as as])
+    ppr (ImportDecl mod' pkg from safe qual as spec)
+      = hang (hsep [ptext (sLit "import"), ppr_imp from, pp_safe safe,
+                    pp_qual qual, pp_pkg pkg, ppr mod', pp_as as])
             4 (pp_spec spec)
       where
         pp_pkg Nothing  = empty
@@ -65,6 +66,9 @@ instance (Outputable name) => Outputable (ImportDecl name) where
        pp_qual False   = empty
        pp_qual True    = ptext (sLit "qualified")
 
+       pp_safe False   = empty
+       pp_safe True    = ptext (sLit "safe")
+
        pp_as Nothing   = empty
        pp_as (Just a)  = ptext (sLit "as") <+> ppr a
 
index 211417d..904d5a6 100644 (file)
@@ -511,12 +511,14 @@ instance Binary Usage where
         putByte bh 0
        put_ bh (usg_mod usg)
        put_ bh (usg_mod_hash usg)
+       put_ bh (usg_safe     usg)
     put_ bh usg@UsageHomeModule{} = do 
         putByte bh 1
        put_ bh (usg_mod_name usg)
        put_ bh (usg_mod_hash usg)
        put_ bh (usg_exports  usg)
        put_ bh (usg_entities usg)
+       put_ bh (usg_safe     usg)
 
     get bh = do
         h <- getByte bh
@@ -524,14 +526,16 @@ instance Binary Usage where
           0 -> do
             nm    <- get bh
             mod   <- get bh
-            return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod }
+            safe  <- get bh
+            return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe }
           _ -> do
             nm    <- get bh
             mod   <- get bh
             exps  <- get bh
             ents  <- get bh
+            safe  <- get bh
             return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod,
-                            usg_exports = exps, usg_entities = ents }
+                     usg_exports = exps, usg_entities = ents, usg_safe = safe }
 
 instance Binary Warnings where
     put_ bh NoWarnings     = putByte bh 0
index ccaaf69..219ab6a 100644 (file)
@@ -697,16 +697,22 @@ pprExport (mod, items)
 
 pprUsage :: Usage -> SDoc
 pprUsage usage@UsagePackageModule{}
-  = hsep [ptext (sLit "import"), ppr (usg_mod usage), 
-         ppr (usg_mod_hash usage)]
+  = pprUsageImport usage usg_mod
 pprUsage usage@UsageHomeModule{}
-  = hsep [ptext (sLit "import"), ppr (usg_mod_name usage), 
-         ppr (usg_mod_hash usage)] $$
+  = pprUsageImport usage usg_mod_name $$
     nest 2 (
        maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$
         vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ]
         )
 
+pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc
+pprUsageImport usage usg_mod'
+  = hsep [ptext (sLit "import"), safe, ppr (usg_mod' usage),
+                       ppr (usg_mod_hash usage)]
+    where
+        safe | usg_safe usage = ptext $ sLit "safe"
+             | otherwise      = ptext $ sLit " -/ "
+
 pprDeps :: Dependencies -> SDoc
 pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs,
                dep_finsts = finsts })
index 9deceb5..6ff9191 100644 (file)
@@ -873,7 +873,8 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
 
       | modulePackageId mod /= this_pkg
       = Just UsagePackageModule{ usg_mod      = mod,
-                                 usg_mod_hash = mod_hash }
+                                 usg_mod_hash = mod_hash,
+                                 usg_safe     = imp_safe }
         -- for package modules, we record the module hash only
 
       | (null used_occs
@@ -888,22 +889,27 @@ mk_usage_info pit hsc_env this_mod direct_imports used_names
       | otherwise      
       = Just UsageHomeModule { 
                       usg_mod_name = moduleName mod,
-                     usg_mod_hash = mod_hash,
-                     usg_exports  = export_hash,
-                     usg_entities = Map.toList ent_hashs }
+                      usg_mod_hash = mod_hash,
+                      usg_exports  = export_hash,
+                      usg_entities = Map.toList ent_hashs,
+                      usg_safe     = imp_safe }
       where
-       maybe_iface  = lookupIfaceByModule dflags hpt pit mod
-               -- In one-shot mode, the interfaces for home-package 
-               -- modules accumulate in the PIT not HPT.  Sigh.
-
-        is_direct_import = mod `elemModuleEnv` direct_imports
+        maybe_iface  = lookupIfaceByModule dflags hpt pit mod
+                -- In one-shot mode, the interfaces for home-package
+                -- modules accumulate in the PIT not HPT.  Sigh.
 
         Just iface   = maybe_iface
        finsts_mod   = mi_finsts    iface
         hash_env     = mi_hash_fn   iface
         mod_hash     = mi_mod_hash  iface
         export_hash | depend_on_exports = Just (mi_exp_hash iface)
-                   | otherwise         = Nothing
+                    | otherwise         = Nothing
+
+        (is_direct_import, imp_safe)
+            = case lookupModuleEnv direct_imports mod of
+                Just ((_,_,_,safe):xs) -> (True, safe)
+                Just _                 -> pprPanic "mkUsage: empty direct import" empty
+                Nothing                -> (False, False)
     
         used_occs = lookupModuleEnv ent_map mod `orElse` []
 
@@ -1158,7 +1164,7 @@ checkDependencies hsc_env summary iface
    orM = foldr f (return False)
     where f m rest = do b <- m; if b then return True else rest
 
-   dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do
+   dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _ _)) = do
      find_res <- liftIO $ findImportedModule hsc_env mod pkg
      case find_res of
         Found _ mod
index f25df2d..bb91170 100644 (file)
@@ -32,6 +32,7 @@ module DynFlags (
         DPHBackend(..), dphPackageMaybe,
         wayNames,
         SafeHaskellMode(..),
+        safeHaskellOn,
 
         Settings(..),
         ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings,
@@ -962,6 +963,7 @@ xopt_unset dfs f
       in dfs { extensions = onoffs,
                extensionFlags = flattenExtensionFlags (language dfs) onoffs }
 
+-- | Set the Haskell language standard to use
 setLanguage :: Language -> DynP ()
 setLanguage l = upd f
     where f dfs = let mLang = Just l
@@ -971,6 +973,10 @@ setLanguage l = upd f
                          extensionFlags = flattenExtensionFlags mLang oneoffs
                      }
 
+-- | Test if SafeHaskell is on in some form
+safeHaskellOn :: DynFlags -> Bool
+safeHaskellOn dflags = safeHaskell dflags /= Sf_None
+
 -- | Set a 'SafeHaskell' flag
 setSafeHaskell :: SafeHaskellMode -> DynP ()
 setSafeHaskell s = upd f
index 93ce824..3fd9916 100644 (file)
@@ -98,7 +98,7 @@ mkPrelImports this_mod implicit_prelude import_decls
   | otherwise = [preludeImportDecl]
   where
       explicit_prelude_import
-       = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _) <- import_decls,
+       = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _ _) <- import_decls,
                   unLoc mod == pRELUDE_NAME ]
 
       preludeImportDecl :: LImportDecl RdrName
@@ -107,6 +107,7 @@ mkPrelImports this_mod implicit_prelude import_decls
          ImportDecl (L loc pRELUDE_NAME)
                Nothing {- no specific package -}
               False {- Not a boot interface -}
+              False {- Not a safe interface -}
               False    {- Not qualified -}
               Nothing  {- No "as" -}
               Nothing  {- No import list -}
index d902626..76699a5 100644 (file)
@@ -32,12 +32,13 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
               [("ExportAll        ", export_all), -- 1 if no export list
                ("ExportDecls      ", export_ds),
                ("ExportModules    ", export_ms),
-               ("Imports          ", import_no),
-               ("  ImpQual        ", import_qual),
-               ("  ImpAs          ", import_as),
-               ("  ImpAll         ", import_all),
-               ("  ImpPartial     ", import_partial),
-               ("  ImpHiding      ", import_hiding),
+               ("Imports          ", imp_no),
+               ("  ImpSafe        ", imp_safe),
+               ("  ImpQual        ", imp_qual),
+               ("  ImpAs          ", imp_as),
+               ("  ImpAll         ", imp_all),
+               ("  ImpPartial     ", imp_partial),
+               ("  ImpHiding      ", imp_hiding),
                ("FixityDecls      ", fixity_sigs),
                ("DefaultDecls     ", default_ds),
                ("TypeDecls        ", type_ds),
@@ -99,8 +100,8 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     (val_bind_ds, fn_bind_ds)
        = foldr add2 (0,0) (map count_bind val_decls)
 
-    (import_no, import_qual, import_as, import_all, import_partial, import_hiding)
-       = foldr add6 (0,0,0,0,0,0) (map import_info imports)
+    (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding)
+       = foldr add7 (0,0,0,0,0,0,0) (map import_info imports)
     (data_constrs, data_derivs)
        = foldr add2 (0,0) (map data_info tycl_decls)
     (class_method_ds, default_method_ds)
@@ -122,15 +123,16 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     sig_info (GenericSig _ _)   = (0,0,0,0,1)
     sig_info _                  = (0,0,0,0,0)
 
-    import_info (L _ (ImportDecl _ _ _ qual as spec))
-       = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec)
+    import_info (L _ (ImportDecl _ _ _ safe qual as spec))
+       = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
+    safe_info = qual_info
     qual_info False  = 0
     qual_info True   = 1
     as_info Nothing  = 0
     as_info (Just _) = 1
-    spec_info Nothing          = (0,0,0,1,0,0)
-    spec_info (Just (False, _)) = (0,0,0,0,1,0)
-    spec_info (Just (True, _))  = (0,0,0,0,0,1)
+    spec_info Nothing          = (0,0,0,0,1,0,0)
+    spec_info (Just (False, _)) = (0,0,0,0,0,1,0)
+    spec_info (Just (True, _))  = (0,0,0,0,0,0,1)
 
     data_info (TyData {tcdCons = cs, tcdDerivs = derivs})
        = (length cs, case derivs of Nothing -> 0
@@ -160,12 +162,12 @@ ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
     addpr :: (Int,Int) -> Int
     add2  :: (Int,Int) -> (Int,Int) -> (Int, Int)
     add5  :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int)
-    add6  :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int)
+    add7  :: (Int,Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int, Int)
 
     addpr (x,y) = x+y
     add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2)
     add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5)
-    add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6)
+    add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7)
 \end{code}
 
 
index d39e1da..9988d1d 100644 (file)
@@ -93,7 +93,7 @@ module HscTypes (
 
         -- * Safe Haskell information
         IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo,
-        trustInfoToNum, numToTrustInfo,
+        trustInfoToNum, numToTrustInfo, IsSafeImport,
 
         -- * Compilation errors and warnings
         SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
@@ -718,7 +718,7 @@ emptyModDetails = ModDetails { md_types = emptyTypeEnv,
                              } 
 
 -- | Records the modules directly imported by a module for extracting e.g. usage information
-type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)]
+type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan, IsSafeImport)]
 -- TODO: we are not actually using the codomain of this type at all, so it can be
 -- replaced with ModuleEnv ()
 
@@ -1456,7 +1456,10 @@ data Usage
   = UsagePackageModule {
         usg_mod      :: Module,
            -- ^ External package module depended on
-        usg_mod_hash :: Fingerprint
+        usg_mod_hash :: Fingerprint,
+           -- ^ Cached module fingerprint
+        usg_safe :: IsSafeImport
+            -- ^ Was this module imported as a safe import
     }                                           -- ^ Module from another package
   | UsageHomeModule {
         usg_mod_name :: ModuleName,
@@ -1467,9 +1470,11 @@ data Usage
             -- ^ Entities we depend on, sorted by occurrence name and fingerprinted.
             -- NB: usages are for parent names only, e.g. type constructors 
             -- but not the associated data constructors.
-       usg_exports  :: Maybe Fingerprint
+       usg_exports  :: Maybe Fingerprint,
             -- ^ Fingerprint for the export list we used to depend on this module,
             -- if we depend on the export list
+        usg_safe :: IsSafeImport
+            -- ^ Was this module imported as a safe import
     }                                           -- ^ Module from the current package
     deriving( Eq )
        -- The export list field is (Just v) if we depend on the export list:
@@ -1810,6 +1815,9 @@ This stuff here is related to supporting the Safe Haskell extension,
 primarily about storing under what trust type a module has been compiled.
 
 \begin{code}
+-- | Is an import a safe import?
+type IsSafeImport = Bool
+
 -- | Safe Haskell information for 'ModIface'
 -- Simply a wrapper around SafeHaskellMode to sepperate iface and flags
 newtype IfaceTrustInfo = TrustInfo SafeHaskellMode
index 43a4004..736ab09 100644 (file)
@@ -661,7 +661,7 @@ reservedWordsFM = listToUFM $
        ( "export",     ITexport,        bit ffiBit),
        ( "label",      ITlabel,         bit ffiBit),
        ( "dynamic",    ITdynamic,       bit ffiBit),
-       ( "safe",       ITsafe,          bit ffiBit),
+       ( "safe",       ITsafe,          bit ffiBit .|. bit safeHaskellBit),
        ( "threadsafe", ITthreadsafe,    bit ffiBit),  -- ToDo: remove
        ( "interruptible", ITinterruptible, bit ffiBit),
        ( "unsafe",     ITunsafe,        bit ffiBit),
@@ -1807,6 +1807,8 @@ relaxedLayoutBit :: Int
 relaxedLayoutBit = 24
 nondecreasingIndentationBit :: Int
 nondecreasingIndentationBit = 25
+safeHaskellBit :: Int
+safeHaskellBit = 26
 
 always :: Int -> Bool
 always           _     = True
@@ -1902,6 +1904,7 @@ mkPState flags buf loc =
                .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags
                .|. relaxedLayoutBit  `setBitIf` xopt Opt_RelaxedLayout flags
                .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags
+               .|. safeHaskellBit    `setBitIf` safeHaskellOn flags
       --
       setBitIf :: Int -> Bool -> Int
       b `setBitIf` cond | cond      = bit b
index 1ad519b..bb82aaa 100644 (file)
@@ -500,13 +500,17 @@ importdecls :: { [LImportDecl RdrName] }
        | {- empty -}                           { [] }
 
 importdecl :: { LImportDecl RdrName }
-       : 'import' maybe_src optqualified maybe_pkg modid maybeas maybeimpspec 
-               { L (comb4 $1 $5 $6 $7) (ImportDecl $5 $4 $2 $3 (unLoc $6) (unLoc $7)) }
+       : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec 
+               { L (comb4 $1 $6 $7 $8) (ImportDecl $6 $5 $2 $3 $4 (unLoc $7) (unLoc $8)) }
 
 maybe_src :: { IsBootInterface }
        : '{-# SOURCE' '#-}'                    { True }
        | {- empty -}                           { False }
 
+maybe_safe :: { Bool }
+       : 'safe'                                { True }
+       | {- empty -}                           { False }
+
 maybe_pkg :: { Maybe FastString }
         : STRING                                { Just (getSTRING $1) }
         | {- empty -}                           { Nothing }
index 46258a6..57166f4 100644 (file)
@@ -65,7 +65,7 @@ rnImports imports
          implicit_prelude <- xoptM Opt_ImplicitPrelude
          let prel_imports       = mkPrelImports (moduleName this_mod) implicit_prelude imports
              (source, ordinary) = partition is_source_import imports
-             is_source_import (L _ (ImportDecl _ _ is_boot _ _ _)) = is_boot
+             is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot
 
          ifDOptM Opt_WarnImplicitPrelude (
             when (notNull prel_imports) $ addWarn (implicitPreludeWarn)
@@ -94,7 +94,8 @@ rnImportDecl  :: Module -> Bool
 
 rnImportDecl this_mod implicit_prelude
              (L loc (ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg
-                                , ideclSource = want_boot, ideclQualified = qual_only
+                                , ideclSource = want_boot, ideclSafe = mod_safe
+                                , ideclQualified = qual_only
                                 , ideclAs = as_mod, ideclHiding = imp_details }))
   = setSrcSpan loc $ do
 
@@ -219,7 +220,7 @@ rnImportDecl this_mod implicit_prelude
                         _                    -> False
 
         imports   = ImportAvails {
-                        imp_mods     = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc)],
+                        imp_mods     = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc, mod_safe)],
                         imp_orphs    = orphans,
                         imp_finsts   = finsts,
                         imp_dep_mods = mkModDeps dependent_mods,
@@ -233,7 +234,7 @@ rnImportDecl this_mod implicit_prelude
           _           -> return ()
      )
 
-    let new_imp_decl = L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot
+    let new_imp_decl = L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot mod_safe
                                          qual_only as_mod new_imp_details)
 
     return (new_imp_decl, gbl_env, imports, mi_hpc iface)
@@ -908,7 +909,7 @@ exports_from_avail (Just rdr_items) rdr_env imports this_mod
 
     imported_modules = [ qual_name
                        | xs <- moduleEnvElts $ imp_mods imports,
-                         (qual_name, _, _) <- xs ]
+                         (qual_name, _, _, _) <- xs ]
 
     exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum
     exports_from_item acc@(ie_names, occs, exports)
index ce84178..bd5cf8d 100644 (file)
@@ -84,8 +84,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
              maybe_rn_syntax :: forall a. a -> Maybe a ;
              maybe_rn_syntax empty_val
                | keep_rn_syntax = Just empty_val
-               | otherwise      = Nothing ;
-                       
+               | otherwise      = Nothing ;
+
             gbl_env = TcGblEnv {
                tcg_mod       = mod,
                tcg_src       = hsc_src,
index 17e5dcb..78b2f32 100644 (file)
@@ -571,7 +571,8 @@ type ErrCtxt = (Bool, TidyEnv -> TcM (TidyEnv, Message))
 --
 data ImportAvails 
    = ImportAvails {
-       imp_mods :: ModuleEnv [(ModuleName, Bool, SrcSpan)],
+       imp_mods :: ImportedMods,
+         --      = ModuleEnv [(ModuleName, Bool, SrcSpan, Bool)],
           -- ^ Domain is all directly-imported modules
           -- The 'ModuleName' is what the module was imported as, e.g. in
           -- @