Refactor Safe Haskell check to provide hscCheckSafe GHC API
authorDavid Terei <davidterei@gmail.com>
Fri, 16 Dec 2011 21:45:53 +0000 (13:45 -0800)
committerDavid Terei <davidterei@gmail.com>
Tue, 20 Dec 2011 03:13:09 +0000 (19:13 -0800)
compiler/main/HscMain.hs

index f3df384..c705526 100644 (file)
@@ -60,6 +60,7 @@ module HscMain
     , hscParseIdentifier
     , hscTcRcLookupName
     , hscTcRnGetInfo
+    , hscCheckSafe
 #ifdef GHCI
     , hscGetModuleInterface
     , hscRnImportDecls
@@ -886,9 +887,8 @@ hscFileFrontEnd mod_summary = do
 -- inference mode.
 hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
 hscCheckSafeImports tcg_env = do
-    hsc_env  <- getHscEnv
     dflags   <- getDynFlags
-    tcg_env' <- checkSafeImports dflags hsc_env tcg_env
+    tcg_env' <- checkSafeImports dflags tcg_env
     case safeLanguageOn dflags of
         True -> do
             -- we nuke user written RULES in -XSafe
@@ -925,8 +925,8 @@ hscCheckSafeImports tcg_env = do
 -- dependencies for a module are collected and unioned.
 -- Specifically see the Note [RnNames . Tracking Trust Transitively]
 -- and the Note [RnNames . Trust Own Package].
-checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv
-checkSafeImports dflags hsc_env tcg_env
+checkSafeImports :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
+checkSafeImports dflags tcg_env
     = do
         -- We want to use the warning state specifically for detecting if safe
         -- inference has failed, so store and clear any existing warnings.
@@ -981,40 +981,48 @@ checkSafeImports dflags hsc_env tcg_env
               (text $ "is imported both as a safe and unsafe import!"))
         | otherwise
         = return v1
+    
+    -- easier interface to work with
+    checkSafe (_, _, False) = return Nothing
+    checkSafe (m, l, True ) = hscCheckSafe' dflags m l
 
-    lookup' :: Module -> Hsc (Maybe ModIface)
-    lookup' m = do
-        hsc_eps <- liftIO $ hscEPS hsc_env
-        let pkgIfaceT = eps_PIT hsc_eps
-            homePkgT = hsc_HPT hsc_env
-            iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m
-        return iface
-
-    isHomePkg :: Module -> Bool
-    isHomePkg m
-        | thisPackage dflags == modulePackageId m = True
-        | otherwise                               = False
-
-    -- | Check the package a module resides in is trusted.
-    -- Safe compiled modules are trusted without requiring
-    -- that their package is trusted. For trustworthy modules,
-    -- modules in the home package are trusted but otherwise
-    -- we check the package trust flag.
-    packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
-    packageTrusted _ _ _
-        | not (packageTrustOn dflags)     = True
-    packageTrusted Sf_Safe        False _ = True
-    packageTrusted Sf_SafeInfered False _ = True
-    packageTrusted _ _ m
-        | isHomePkg m = True
-        | otherwise   = trusted $ getPackageDetails (pkgState dflags)
-                                                    (modulePackageId m)
+    -- Here we check the transitive package trust requirements are OK still.
+    checkPkgTrust :: [PackageId] -> Hsc ()
+    checkPkgTrust pkgs =
+        case errors of
+            [] -> return ()
+            _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
+        where
+            errors = catMaybes $ map go pkgs
+            go pkg
+                | trusted $ getPackageDetails (pkgState dflags) pkg
+                = Nothing
+                | otherwise
+                = Just $ mkPlainErrMsg noSrcSpan
+                       $ text "The package (" <> ppr pkg <> text ") is required"
+                      <> text " to be trusted but it isn't!"
 
-    -- Is a module trusted? Return Nothing if True, or a String
-    -- if it isn't, containing the reason it isn't. Also return
-    -- if the module trustworthy (true) or safe (false) so we know
-    -- if we should check if the package itself is trusted in the
-    -- future.
+-- | Check that a module is safe to import.
+--
+-- We return a package id if the safe import is OK and a Nothing otherwise
+-- with the reason for the failure printed out.
+hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO (Maybe PackageId)
+hscCheckSafe hsc_env m l = runHsc hsc_env $ do
+    dflags <- getDynFlags
+    hscCheckSafe' dflags m l
+
+hscCheckSafe' :: DynFlags -> Module -> SrcSpan -> Hsc (Maybe PackageId)
+hscCheckSafe' dflags m l = do
+    tw <- isModSafe m l
+    case tw of
+        False              -> return Nothing
+        True | isHomePkg m -> return Nothing
+             | otherwise   -> return $ Just $ modulePackageId m
+  where
+    -- Is a module trusted? Return Nothing if True, or a String if it isn't,
+    -- containing the reason it isn't. Also return if the module trustworthy
+    -- (true) or safe (false) so we know if we should check if the package
+    -- itself is trusted in the future.
     isModSafe :: Module -> SrcSpan -> Hsc (Bool)
     isModSafe m l = do
         iface <- lookup' m
@@ -1047,30 +1055,34 @@ checkSafeImports dflags hsc_env tcg_env
                         <+> text "can't be safely imported!"
                         <+> text "The module itself isn't safe."
 
-    -- Here we check the transitive package trust requirements are OK still.
-    checkPkgTrust :: [PackageId] -> Hsc ()
-    checkPkgTrust pkgs =
-        case errors of
-            [] -> return ()
-            _  -> (liftIO . throwIO . mkSrcErr . listToBag) errors
-        where
-            errors = catMaybes $ map go pkgs
-            go pkg
-                | trusted $ getPackageDetails (pkgState dflags) pkg
-                = Nothing
-                | otherwise
-                = Just $ mkPlainErrMsg noSrcSpan
-                       $ text "The package (" <> ppr pkg <> text ") is required"
-                      <> text " to be trusted but it isn't!"
+    -- | Check the package a module resides in is trusted.
+    -- Safe compiled modules are trusted without requiring
+    -- that their package is trusted. For trustworthy modules,
+    -- modules in the home package are trusted but otherwise
+    -- we check the package trust flag.
+    packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool
+    packageTrusted _ _ _
+        | not (packageTrustOn dflags)     = True
+    packageTrusted Sf_Safe        False _ = True
+    packageTrusted Sf_SafeInfered False _ = True
+    packageTrusted _ _ m
+        | isHomePkg m = True
+        | otherwise   = trusted $ getPackageDetails (pkgState dflags)
+                                                    (modulePackageId m)
 
-    checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId)
-    checkSafe (_, _, False) = return Nothing
-    checkSafe (m, l, True ) = do
-        tw <- isModSafe m l
-        return $ pkg tw
-        where pkg False = Nothing
-              pkg True | isHomePkg m = Nothing
-                           | otherwise   = Just (modulePackageId m)
+    lookup' :: Module -> Hsc (Maybe ModIface)
+    lookup' m = do
+        hsc_env <- getHscEnv
+        hsc_eps <- liftIO $ hscEPS hsc_env
+        let pkgIfaceT = eps_PIT hsc_eps
+            homePkgT  = hsc_HPT hsc_env
+            iface     = lookupIfaceByModule dflags homePkgT pkgIfaceT m
+        return iface
+
+    isHomePkg :: Module -> Bool
+    isHomePkg m
+        | thisPackage dflags == modulePackageId m = True
+        | otherwise                               = False
 
 -- | Set module to unsafe and wipe trust information.
 --