module HscMain
(
newHscEnv
, Messager, batchMsg
, HscStatus (..)
, hscIncrementalCompile
, hscCompileCmmFile
, hscGenHardCode
, hscInteractive
, hscParse
, hscTypecheckRename
, hscDesugar
, makeSimpleDetails
, hscSimplify
, hscCheckSafe
, hscGetSafe
, hscParseIdentifier
, hscTcRcLookupName
, hscTcRnGetInfo
, hscIsGHCiMonad
, hscGetModuleInterface
, hscRnImportDecls
, hscTcRnLookupRdrName
, hscStmt, hscStmtWithLocation, hscParsedStmt
, hscDecls, hscDeclsWithLocation
, hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
, hscParseExpr
, hscCompileCoreExpr
, hscCompileCoreExpr'
, hscParse', hscSimplify', hscDesugar', tcRnModule'
, getHscEnv
, hscSimpleIface', hscNormalIface'
, oneShotMsg
, hscFileFrontEnd, genericHscFrontend, dumpIfaceStats
, ioMsgMaybe
, showModuleIndex
, hscAddSptEntries
) where
import GhcPrelude
import Data.Data hiding (Fixity, TyCon)
import DynFlags (addPluginModuleName)
import Id
import GHCi ( addSptEntry )
import GHCi.RemoteTypes ( ForeignHValue )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker
import CoreTidy ( tidyExpr )
import Type ( Type )
import Type ( Kind )
import CoreLint ( lintInteractiveExpr )
import VarEnv ( emptyTidyEnv )
import Panic
import ConLike
import Control.Concurrent
import Module
import Packages
import RdrName
import HsSyn
import HsDumpAst
import CoreSyn
import StringBuffer
import Parser
import Lexer
import SrcLoc
import TcRnDriver
import TcIface ( typecheckIface )
import TcRnMonad
import NameCache ( initNameCache )
import LoadIface ( ifaceStats, initExternalPackageState )
import PrelInfo
import MkIface
import Desugar
import SimplCore
import TidyPgm
import CorePrep
import CoreToStg ( coreToStg )
import qualified StgCmm ( codeGen )
import StgSyn
import CostCentre
import ProfInit
import TyCon
import Name
import SimplStg ( stg2stg )
import Cmm
import CmmParse ( parseCmmFile )
import CmmBuildInfoTables
import CmmPipeline
import CmmInfo
import CodeOutput
import InstEnv
import FamInstEnv
import Fingerprint ( Fingerprint )
import Hooks
import TcEnv
import PrelNames
import Plugins
import DynamicLoading ( initializePlugins )
import DynFlags
import ErrUtils
import Platform ( platformOS, osSubsectionsViaSymbols )
import Outputable
import NameEnv
import HscStats ( ppSourceStats )
import HscTypes
import FastString
import UniqSupply
import Bag
import Exception
import qualified Stream
import Stream (Stream)
import Util
import Data.List
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
import System.Directory
import System.IO (fixIO)
import qualified Data.Map as Map
import qualified Data.Set as S
import Data.Set (Set)
#include "HsVersions.h"
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv dflags = do
eps_var <- newIORef initExternalPackageState
us <- mkSplitUniqSupply 'r'
nc_var <- newIORef (initNameCache us knownKeyNames)
fc_var <- newIORef emptyInstalledModuleEnv
iserv_mvar <- newMVar Nothing
return HscEnv { hsc_dflags = dflags
, hsc_targets = []
, hsc_mod_graph = emptyMG
, hsc_IC = emptyInteractiveContext dflags
, hsc_HPT = emptyHomePackageTable
, hsc_EPS = eps_var
, hsc_NC = nc_var
, hsc_FC = fc_var
, hsc_type_env_var = Nothing
, hsc_iserv = iserv_mvar
}
getWarnings :: Hsc WarningMessages
getWarnings = Hsc $ \_ w -> return (w, w)
clearWarnings :: Hsc ()
clearWarnings = Hsc $ \_ _ -> return ((), emptyBag)
logWarnings :: WarningMessages -> Hsc ()
logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w)
getHscEnv :: Hsc HscEnv
getHscEnv = Hsc $ \e w -> return (e, w)
handleWarnings :: Hsc ()
handleWarnings = do
dflags <- getDynFlags
w <- getWarnings
liftIO $ printOrThrowWarnings dflags w
clearWarnings
logWarningsReportErrors :: Messages -> Hsc ()
logWarningsReportErrors (warns,errs) = do
logWarnings warns
when (not $ isEmptyBag errs) $ throwErrors errs
throwErrors :: ErrorMessages -> Hsc a
throwErrors = liftIO . throwIO . mkSrcErr
ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a
ioMsgMaybe ioA = do
((warns,errs), mb_r) <- liftIO ioA
logWarnings warns
case mb_r of
Nothing -> throwErrors errs
Just r -> ASSERT( isEmptyBag errs ) return r
ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' ioA = do
((warns,_errs), mb_r) <- liftIO $ ioA
logWarnings warns
return mb_r
hscTcRnLookupRdrName :: HscEnv -> Located RdrName -> IO [Name]
hscTcRnLookupRdrName hsc_env0 rdr_name
= runInteractiveHsc hsc_env0 $
do { hsc_env <- getHscEnv
; ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name }
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ioMsgMaybe' $ tcRnLookupName hsc_env name
hscTcRnGetInfo :: HscEnv -> Name
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo hsc_env0 name
= runInteractiveHsc hsc_env0 $
do { hsc_env <- getHscEnv
; ioMsgMaybe' $ tcRnGetInfo hsc_env name }
hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad hsc_env name
= runHsc hsc_env $ ioMsgMaybe $ isGHCiMonad hsc_env name
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ioMsgMaybe $ getModuleInterface hsc_env mod
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ioMsgMaybe $ tcRnImportDecls hsc_env import_decls
hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' mod_summary
| Just r <- ms_parsed_mod mod_summary = return r
| otherwise =
withTiming getDynFlags
(text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
(const ()) $ do
dflags <- getDynFlags
let src_filename = ms_hspp_file mod_summary
maybe_src_buf = ms_hspp_buf mod_summary
buf <- case maybe_src_buf of
Just b -> return b
Nothing -> liftIO $ hGetStringBuffer src_filename
let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
let parseMod | HsigFile == ms_hsc_src mod_summary
= parseSignature
| otherwise = parseModule
case unP parseMod (mkPState dflags buf loc) of
PFailed warnFn span err -> do
logWarningsReportErrors (warnFn dflags)
handleWarnings
liftIO $ throwOneError (mkPlainErrMsg dflags span err)
POk pst rdr_module -> do
logWarningsReportErrors (getMessages pst dflags)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $
ppr rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
showAstData NoBlankSrcSpan rdr_module
liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $
ppSourceStats False rdr_module
let n_hspp = FilePath.normalise src_filename
srcs0 = nub $ filter (not . (tmpDir dflags `isPrefixOf`))
$ filter (not . (== n_hspp))
$ map FilePath.normalise
$ filter (not . isPrefixOf "<")
$ map unpackFS
$ srcfiles pst
srcs1 = case ml_hs_file (ms_location mod_summary) of
Just f -> filter (/= FilePath.normalise f) srcs0
Nothing -> srcs0
srcs2 <- liftIO $ filterM doesFileExist srcs1
let res = HsParsedModule {
hpm_module = rdr_module,
hpm_src_files = srcs2,
hpm_annotations
= (Map.fromListWith (++) $ annotations pst,
Map.fromList $ ((noSrcSpan,comment_q pst)
:(annotations_comments pst)))
}
let applyPluginAction p opts
= parsedResultAction p opts mod_summary
withPlugins dflags applyPluginAction res
extract_renamed_stuff :: TcGblEnv -> Hsc (TcGblEnv, RenamedStuff)
extract_renamed_stuff tc_result = do
let rn_info = getRenamedStuff tc_result
dflags <- getDynFlags
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_rn_ast "Renamer" $
showAstData NoBlankSrcSpan rn_info
return (tc_result, rn_info)
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $ do
tc_result <- hscTypecheck True mod_summary (Just rdr_module)
extract_renamed_stuff tc_result
hscTypecheck :: Bool
-> ModSummary -> Maybe HsParsedModule
-> Hsc TcGblEnv
hscTypecheck keep_rn mod_summary mb_rdr_module = do
tc_result <- hscTypecheck' keep_rn mod_summary mb_rdr_module
_ <- extract_renamed_stuff tc_result
return tc_result
hscTypecheck' :: Bool
-> ModSummary -> Maybe HsParsedModule
-> Hsc TcGblEnv
hscTypecheck' keep_rn mod_summary mb_rdr_module = do
hsc_env <- getHscEnv
let hsc_src = ms_hsc_src mod_summary
dflags = hsc_dflags hsc_env
outer_mod = ms_mod mod_summary
mod_name = moduleName outer_mod
outer_mod' = mkModule (thisPackage dflags) mod_name
inner_mod = canonicalizeHomeModule dflags mod_name
src_filename = ms_hspp_file mod_summary
real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
MASSERT( moduleUnitId outer_mod == thisPackage dflags )
if hsc_src == HsigFile && not (isHoleModule inner_mod)
then ioMsgMaybe $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
else
do hpm <- case mb_rdr_module of
Just hpm -> return hpm
Nothing -> hscParse' mod_summary
tc_result0 <- tcRnModule' mod_summary keep_rn hpm
if hsc_src == HsigFile
then do (iface, _, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 Nothing
ioMsgMaybe $
tcRnMergeSignatures hsc_env hpm tc_result0 iface
else return tc_result0
tcRnModule' :: ModSummary -> Bool -> HsParsedModule
-> Hsc TcGblEnv
tcRnModule' sum save_rn_syntax mod = do
hsc_env <- getHscEnv
dflags <- getDynFlags
tcg_res <-
ioMsgMaybe $
tcRnModule hsc_env sum
save_rn_syntax mod
(tcSafeOK, whyUnsafe) <- liftIO $ readIORef (tcg_safeInfer tcg_res)
let allSafeOK = safeInferred dflags && tcSafeOK
res <- if not (safeHaskellOn dflags)
|| (safeInferOn dflags && not allSafeOK)
then markUnsafeInfer tcg_res whyUnsafe
else do
tcg_res' <- hscCheckSafeImports tcg_res
safe <- liftIO $ fst <$> readIORef (tcg_safeInfer tcg_res')
when safe $ do
case wopt Opt_WarnSafe dflags of
True -> (logWarnings $ unitBag $
makeIntoWarning (Reason Opt_WarnSafe) $
mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $
errSafe tcg_res')
False | safeHaskell dflags == Sf_Trustworthy &&
wopt Opt_WarnTrustworthySafe dflags ->
(logWarnings $ unitBag $
makeIntoWarning (Reason Opt_WarnTrustworthySafe) $
mkPlainWarnMsg dflags (trustworthyOnLoc dflags) $
errTwthySafe tcg_res')
False -> return ()
return tcg_res'
return res
where
pprMod t = ppr $ moduleName $ tcg_mod t
errSafe t = quotes (pprMod t) <+> text "has been inferred as safe!"
errTwthySafe t = quotes (pprMod t)
<+> text "is marked as Trustworthy but has been inferred as safe!"
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar hsc_env mod_summary tc_result =
runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' mod_location tc_result = do
hsc_env <- getHscEnv
r <- ioMsgMaybe $
deSugar hsc_env mod_location tc_result
handleWarnings
return r
makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result
type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModSummary -> IO ()
hscIncrementalFrontend :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
hscIncrementalFrontend
always_do_basic_recompilation_check m_tc_result
mHscMessage mod_summary source_modified mb_old_iface mod_index
= do
hsc_env <- getHscEnv
let msg what = case mHscMessage of
Just hscMessage -> hscMessage hsc_env mod_index what mod_summary
Nothing -> return ()
skip iface = do
liftIO $ msg UpToDate
return $ Left iface
compile mb_old_hash reason = do
liftIO $ msg reason
result <- genericHscFrontend mod_summary
return $ Right (result, mb_old_hash)
stable = case source_modified of
SourceUnmodifiedAndStable -> True
_ -> False
case m_tc_result of
Just tc_result
| not always_do_basic_recompilation_check ->
return $ Right (FrontendTypecheck tc_result, Nothing)
_ -> do
(recomp_reqd, mb_checked_iface)
<-
liftIO $ checkOldIface hsc_env mod_summary
source_modified mb_old_iface
let mb_old_hash = fmap mi_iface_hash mb_checked_iface
case mb_checked_iface of
Just iface | not (recompileRequired recomp_reqd) ->
case m_tc_result of
Nothing
| mi_used_th iface && not stable ->
compile mb_old_hash (RecompBecause "TH")
_ ->
skip iface
_ ->
case m_tc_result of
Nothing -> compile mb_old_hash recomp_reqd
Just tc_result ->
return $ Right (FrontendTypecheck tc_result, mb_old_hash)
genericHscFrontend :: ModSummary -> Hsc FrontendResult
genericHscFrontend mod_summary =
getHooked hscFrontendHook genericHscFrontend' >>= ($ mod_summary)
genericHscFrontend' :: ModSummary -> Hsc FrontendResult
genericHscFrontend' mod_summary
= FrontendTypecheck `fmap` hscFileFrontEnd mod_summary
hscIncrementalCompile :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
-> IO (HscStatus, HomeModInfo)
hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
= do
dflags <- initializePlugins hsc_env' (hsc_dflags hsc_env')
let hsc_env'' = hsc_env' { hsc_dflags = dflags }
type_env_var <- newIORef emptyNameEnv
let mod = ms_mod mod_summary
hsc_env | isOneShot (ghcMode (hsc_dflags hsc_env''))
= hsc_env'' { hsc_type_env_var = Just (mod, type_env_var) }
| otherwise
= hsc_env''
runHsc hsc_env $ do
e <- hscIncrementalFrontend always_do_basic_recompilation_check m_tc_result mHscMessage
mod_summary source_modified mb_old_iface mod_index
case e of
Left iface -> do
hmi <- liftIO . fixIO $ \hmi' -> do
let hsc_env' =
hsc_env {
hsc_HPT = addToHpt (hsc_HPT hsc_env)
(ms_mod_name mod_summary) hmi'
}
details <- genModDetails hsc_env' iface
return HomeModInfo{
hm_details = details,
hm_iface = iface,
hm_linkable = Nothing }
return (HscUpToDate, hmi)
Right (FrontendTypecheck tc_result, mb_old_hash) ->
finish mod_summary tc_result mb_old_hash
finish :: ModSummary
-> TcGblEnv
-> Maybe Fingerprint
-> Hsc (HscStatus, HomeModInfo)
finish summary tc_result mb_old_hash = do
hsc_env <- getHscEnv
let dflags = hsc_dflags hsc_env
target = hscTarget dflags
hsc_src = ms_hsc_src summary
should_desugar =
ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile
mk_simple_iface = do
let hsc_status =
case (target, hsc_src) of
(HscNothing, _) -> HscNotGeneratingCode
(_, HsBootFile) -> HscUpdateBoot
(_, HsigFile) -> HscUpdateSig
_ -> panic "finish"
(iface, changed, details) <- liftIO $
hscSimpleIface hsc_env tc_result mb_old_hash
return (iface, changed, details, hsc_status)
(iface, changed, details, hsc_status) <-
if should_desugar
then do
desugared_guts0 <- hscDesugar' (ms_location summary) tc_result
if target == HscNothing
then mk_simple_iface
else do
plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
desugared_guts <- hscSimplify' plugins desugared_guts0
(iface, changed, details, cgguts) <-
liftIO $ hscNormalIface hsc_env desugared_guts mb_old_hash
return (iface, changed, details, HscRecomp cgguts summary)
else mk_simple_iface
liftIO $ hscMaybeWriteIface dflags iface changed summary
return
( hsc_status
, HomeModInfo
{hm_details = details, hm_iface = iface, hm_linkable = Nothing})
hscMaybeWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscMaybeWriteIface dflags iface changed summary =
let force_write_interface = gopt Opt_WriteInterface dflags
write_interface = case hscTarget dflags of
HscNothing -> False
HscInterpreted -> False
_ -> True
in when (write_interface || force_write_interface) $
hscWriteIface dflags iface changed summary
genModDetails :: HscEnv -> ModIface -> IO ModDetails
genModDetails hsc_env old_iface
= do
new_details <-
initIfaceLoad hsc_env (typecheckIface old_iface)
dumpIfaceStats hsc_env
return new_details
oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
oneShotMsg hsc_env recomp =
case recomp of
UpToDate ->
compilationProgressMsg (hsc_dflags hsc_env) $
"compilation IS NOT required"
_ ->
return ()
batchMsg :: Messager
batchMsg hsc_env mod_index recomp mod_summary =
case recomp of
MustCompile -> showMsg "Compiling " ""
UpToDate
| verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " ""
| otherwise -> return ()
RecompBecause reason -> showMsg "Compiling " (" [" ++ reason ++ "]")
where
dflags = hsc_dflags hsc_env
showMsg msg reason =
compilationProgressMsg dflags $
(showModuleIndex mod_index ++
msg ++ showModMsg dflags (hscTarget dflags)
(recompileRequired recomp) mod_summary)
++ reason
hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv
hscFileFrontEnd mod_summary = hscTypecheck False mod_summary Nothing
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports tcg_env = do
dflags <- getDynFlags
tcg_env' <- checkSafeImports tcg_env
checkRULES dflags tcg_env'
where
checkRULES dflags tcg_env' = do
case safeLanguageOn dflags of
True -> do
logWarnings $ warns dflags (tcg_rules tcg_env')
return tcg_env' { tcg_rules = [] }
False
| safeInferOn dflags && not (null $ tcg_rules tcg_env')
-> markUnsafeInfer tcg_env' $ warns dflags (tcg_rules tcg_env')
| otherwise
-> return tcg_env'
warns dflags rules = listToBag $ map (warnRules dflags) rules
warnRules dflags (L loc (HsRule _ n _ _ _ _)) =
mkPlainWarnMsg dflags loc $
text "Rule \"" <> ftext (snd $ unLoc n) <> text "\" ignored" $+$
text "User defined rules are disabled under Safe Haskell"
warnRules _ (L _ (XRuleDecl _)) = panic "hscCheckSafeImports"
checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
checkSafeImports tcg_env
= do
dflags <- getDynFlags
imps <- mapM condense imports'
let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
oldErrs <- getWarnings
clearWarnings
safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps
safeErrs <- getWarnings
clearWarnings
(infErrs, infPkgs) <- case (safeInferOn dflags) of
False -> return (emptyBag, S.empty)
True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps
infErrs <- getWarnings
clearWarnings
return (infErrs, infPkgs)
logWarnings oldErrs
case (isEmptyBag safeErrs) of
False -> liftIO . throwIO . mkSrcErr $ safeErrs
True -> do
let infPassed = isEmptyBag infErrs
tcg_env' <- case (not infPassed) of
True -> markUnsafeInfer tcg_env infErrs
False -> return tcg_env
when (packageTrustOn dflags) $ checkPkgTrust pkgReqs
let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed
return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
where
impInfo = tcg_imports tcg_env
imports = imp_mods impInfo
imports1 = moduleEnvToList imports
imports' = map (fmap importedByUser) imports1
pkgReqs = imp_trust_pkgs impInfo
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense (_, []) = panic "HscMain.condense: Pattern match failure!"
condense (m, x:xs) = do imv <- foldlM cond' x xs
return (m, imv_span imv, imv_is_safe imv)
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' v1 v2
| imv_is_safe v1 /= imv_is_safe v2
= do
dflags <- getDynFlags
throwErrors $ unitBag $ mkPlainErrMsg dflags (imv_span v1)
(text "Module" <+> ppr (imv_name v1) <+>
(text $ "is imported both as a safe and unsafe import!"))
| otherwise
= return v1
checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe InstalledUnitId)
checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l
pkgTrustReqs :: DynFlags -> Set InstalledUnitId -> Set InstalledUnitId ->
Bool -> ImportAvails
pkgTrustReqs dflags req inf infPassed | safeInferOn dflags
&& safeHaskell dflags == Sf_None && infPassed
= emptyImportAvails {
imp_trust_pkgs = req `S.union` inf
}
pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe
= emptyImportAvails
pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
pkgs <- snd `fmap` hscCheckSafe' m l
when (packageTrustOn dflags) $ checkPkgTrust pkgs
errs <- getWarnings
return $ isEmptyBag errs
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set InstalledUnitId)
hscGetSafe hsc_env m l = runHsc hsc_env $ do
(self, pkgs) <- hscCheckSafe' m l
good <- isEmptyBag `fmap` getWarnings
clearWarnings
let pkgs' | Just p <- self = S.insert p pkgs
| otherwise = pkgs
return (good, pkgs')
hscCheckSafe' :: Module -> SrcSpan
-> Hsc (Maybe InstalledUnitId, Set InstalledUnitId)
hscCheckSafe' m l = do
dflags <- getDynFlags
(tw, pkgs) <- isModSafe m l
case tw of
False -> return (Nothing, pkgs)
True | isHomePkg dflags m -> return (Nothing, pkgs)
| otherwise -> return (Just $ toInstalledUnitId (moduleUnitId m), pkgs)
where
isModSafe :: Module -> SrcSpan -> Hsc (Bool, Set InstalledUnitId)
isModSafe m l = do
dflags <- getDynFlags
iface <- lookup' m
case iface of
Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
$ text "Can't load the interface file for" <+> ppr m
<> text ", to check that it can be safely imported"
Just iface' ->
let trust = getSafeMode $ mi_trust iface'
trust_own_pkg = mi_trust_pkg iface'
safeM = trust `elem` [Sf_Safe, Sf_Trustworthy]
safeP = packageTrusted dflags trust trust_own_pkg m
pkgRs = S.fromList . map fst $ filter snd $ dep_pkgs $ mi_deps iface'
errs = case (safeM, safeP) of
(True, True ) -> emptyBag
(True, False) -> pkgTrustErr
(False, _ ) -> modTrustErr
in do
logWarnings errs
return (trust == Sf_Trustworthy, pkgRs)
where
pkgTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The package (" <> ppr (moduleUnitId m)
<> text ") the module resides in isn't trusted."
]
modTrustErr = unitBag $ mkErrMsg dflags l (pkgQual dflags) $
sep [ ppr (moduleName m)
<> text ": Can't be safely imported!"
, text "The module itself isn't safe." ]
packageTrusted :: DynFlags -> SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted _ Sf_None _ _ = False
packageTrusted _ Sf_Unsafe _ _ = False
packageTrusted dflags _ _ _
| not (packageTrustOn dflags) = True
packageTrusted _ Sf_Safe False _ = True
packageTrusted dflags _ _ m
| isHomePkg dflags m = True
| otherwise = trusted $ getPackageDetails dflags (moduleUnitId m)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' m = do
dflags <- getDynFlags
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
iface' <- case iface of
Just _ -> return iface
Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
return iface'
isHomePkg :: DynFlags -> Module -> Bool
isHomePkg dflags m
| thisPackage dflags == moduleUnitId m = True
| otherwise = False
checkPkgTrust :: Set InstalledUnitId -> Hsc ()
checkPkgTrust pkgs = do
dflags <- getDynFlags
let errors = S.foldr go [] pkgs
go pkg acc
| trusted $ getInstalledPackageDetails dflags pkg
= acc
| otherwise
= (:acc) $ mkErrMsg dflags noSrcSpan (pkgQual dflags)
$ text "The package (" <> ppr pkg <> text ") is required" <>
text " to be trusted but it isn't!"
case errors of
[] -> return ()
_ -> (liftIO . throwIO . mkSrcErr . listToBag) errors
markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer tcg_env whyUnsafe = do
dflags <- getDynFlags
when (wopt Opt_WarnUnsafe dflags)
(logWarnings $ unitBag $ makeIntoWarning (Reason Opt_WarnUnsafe) $
mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
liftIO $ writeIORef (tcg_safeInfer tcg_env) (False, whyUnsafe)
case safeHaskell dflags == Sf_None of
True -> return $ tcg_env { tcg_imports = wiped_trust }
False -> return tcg_env
where
wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }
pprMod = ppr $ moduleName $ tcg_mod tcg_env
whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
, text "Reason:"
, nest 4 $ (vcat $ badFlags df) $+$
(vcat $ pprErrMsgBagWithLoc whyUnsafe) $+$
(vcat $ badInsts $ tcg_insts tcg_env)
]
badFlags df = concat $ map (badFlag df) unsafeFlagsForInfer
badFlag df (str,loc,on,_)
| on df = [mkLocMessage SevOutput (loc df) $
text str <+> text "is not allowed in Safe Haskell"]
| otherwise = []
badInsts insts = concat $ map badInst insts
checkOverlap (NoOverlap _) = False
checkOverlap _ = True
badInst ins | checkOverlap (overlapMode (is_flag ins))
= [mkLocMessage SevOutput (nameSrcSpan $ getName $ is_dfun ins) $
ppr (overlapMode $ is_flag ins) <+>
text "overlap mode isn't allowed in Safe Haskell"]
| otherwise = []
hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode tcg_env = do
dflags <- getDynFlags
liftIO $ finalSafeMode dflags tcg_env
hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify hsc_env plugins modguts =
runHsc hsc_env $ hscSimplify' plugins modguts
hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
hscSimplify' plugins ds_result = do
hsc_env <- getHscEnv
let hsc_env_with_plugins = hsc_env
{ hsc_dflags = foldr addPluginModuleName (hsc_dflags hsc_env) plugins
}
liftIO $ core2core hsc_env_with_plugins ds_result
hscSimpleIface :: HscEnv
-> TcGblEnv
-> Maybe Fingerprint
-> IO (ModIface, Bool, ModDetails)
hscSimpleIface hsc_env tc_result mb_old_iface
= runHsc hsc_env $ hscSimpleIface' tc_result mb_old_iface
hscSimpleIface' :: TcGblEnv
-> Maybe Fingerprint
-> Hsc (ModIface, Bool, ModDetails)
hscSimpleIface' tc_result mb_old_iface = do
hsc_env <- getHscEnv
details <- liftIO $ mkBootModDetailsTc hsc_env tc_result
safe_mode <- hscGetSafeMode tc_result
(new_iface, no_change)
<-
liftIO $
mkIfaceTc hsc_env mb_old_iface safe_mode details tc_result
liftIO $ dumpIfaceStats hsc_env
return (new_iface, no_change, details)
hscNormalIface :: HscEnv
-> ModGuts
-> Maybe Fingerprint
-> IO (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface hsc_env simpl_result mb_old_iface =
runHsc hsc_env $ hscNormalIface' simpl_result mb_old_iface
hscNormalIface' :: ModGuts
-> Maybe Fingerprint
-> Hsc (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface' simpl_result mb_old_iface = do
hsc_env <- getHscEnv
(cg_guts, details) <-
liftIO $ tidyProgram hsc_env simpl_result
(new_iface, no_change)
<-
liftIO $
mkIface hsc_env mb_old_iface details simpl_result
liftIO $ dumpIfaceStats hsc_env
return (new_iface, no_change, details, cg_guts)
hscWriteIface :: DynFlags -> ModIface -> Bool -> ModSummary -> IO ()
hscWriteIface dflags iface no_change mod_summary = do
let ifaceFile = ml_hi_file (ms_location mod_summary)
unless no_change $
writeIfaceFile dflags ifaceFile iface
whenGeneratingDynamicToo dflags $ do
let dynIfaceFile = replaceExtension ifaceFile (dynHiSuf dflags)
dynIfaceFile' = addBootSuffix_maybe (mi_boot iface) dynIfaceFile
dynDflags = dynamicTooMkDynamicDynFlags dflags
writeIfaceFile dynDflags dynIfaceFile' iface
hscGenHardCode :: HscEnv -> CgGuts -> ModSummary -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)])
hscGenHardCode hsc_env cgguts mod_summary output_filename = do
let CgGuts{
cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_foreign = foreign_stubs0,
cg_foreign_files = foreign_files,
cg_dep_pkgs = dependencies,
cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env
location = ms_location mod_summary
data_tycons = filter isDataTyCon tycons
(prepd_binds, local_ccs) <-
corePrepPgm hsc_env this_mod location
core_binds data_tycons
(stg_binds, (caf_ccs, caf_cc_stacks))
<-
myCoreToStg dflags this_mod prepd_binds
let cost_centre_info =
(S.toList local_ccs ++ caf_ccs, caf_cc_stacks)
prof_init = profilingInitCode this_mod cost_centre_info
foreign_stubs = foreign_stubs0 `appendStubC` prof_init
withTiming (pure dflags)
(text "CodeGen"<+>brackets (ppr this_mod))
(const ()) $ do
cmms <-
doCodeGen hsc_env this_mod data_tycons
cost_centre_info
stg_binds hpc_info
rawcmms0 <-
cmmToRawCmm dflags cmms
let dump a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_raw "Raw Cmm"
(ppr a)
return a
rawcmms1 = Stream.mapM dump rawcmms0
(output_filename, (_stub_h_exists, stub_c_exists), foreign_fps)
<-
codeOutput dflags this_mod output_filename location
foreign_stubs foreign_files dependencies rawcmms1
return (output_filename, stub_c_exists, foreign_fps)
hscInteractive :: HscEnv
-> CgGuts
-> ModSummary
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive hsc_env cgguts mod_summary = do
let dflags = hsc_dflags hsc_env
let CgGuts{
cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_foreign = foreign_stubs,
cg_modBreaks = mod_breaks,
cg_spt_entries = spt_entries } = cgguts
location = ms_location mod_summary
data_tycons = filter isDataTyCon tycons
(prepd_binds, _) <-
corePrepPgm hsc_env this_mod location core_binds data_tycons
comp_bc <- byteCodeGen hsc_env this_mod prepd_binds data_tycons mod_breaks
(_istub_h_exists, istub_c_exists)
<- outputForeignStubs dflags this_mod location foreign_stubs
return (istub_c_exists, comp_bc, spt_entries)
hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO ()
hscCompileCmmFile hsc_env filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
cmm <- ioMsgMaybe $ parseCmmFile dflags filename
liftIO $ do
dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose "Parsed Cmm" (ppr cmm)
let
mod_name = mkModuleName $ "Cmm$" ++ FilePath.takeFileName filename
cmm_mod = mkModule (thisPackage dflags) mod_name
(_, cmmgroup) <- cmmPipeline hsc_env (emptySRT cmm_mod) cmm
rawCmms <- cmmToRawCmm dflags (Stream.yield cmmgroup)
_ <- codeOutput dflags cmm_mod output_filename no_loc NoStubs [] []
rawCmms
return ()
where
no_loc = ModLocation{ ml_hs_file = Just filename,
ml_hi_file = panic "hscCompileCmmFile: no hi file",
ml_obj_file = panic "hscCompileCmmFile: no obj file" }
doCodeGen :: HscEnv -> Module -> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroup ())
doCodeGen hsc_env this_mod data_tycons
cost_centre_info stg_binds hpc_info = do
let dflags = hsc_dflags hsc_env
let cmm_stream :: Stream IO CmmGroup ()
cmm_stream =
StgCmm.codeGen dflags this_mod data_tycons
cost_centre_info stg_binds hpc_info
let dump1 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm_from_stg
"Cmm produced by codegen" (ppr a)
return a
ppr_stream1 = Stream.mapM dump1 cmm_stream
us <- mkSplitUniqSupply 'S'
let
pipeline_stream
| gopt Opt_SplitObjs dflags || gopt Opt_SplitSections dflags ||
osSubsectionsViaSymbols (platformOS (targetPlatform dflags))
=
let run_pipeline us cmmgroup = do
(_topSRT, cmmgroup) <-
cmmPipeline hsc_env (emptySRT this_mod) cmmgroup
return (us, cmmgroup)
in do _ <- Stream.mapAccumL run_pipeline us ppr_stream1
return ()
| otherwise
=
let run_pipeline = cmmPipeline hsc_env
in void $ Stream.mapAccumL run_pipeline (emptySRT this_mod) ppr_stream1
let
dump2 a = do dumpIfSet_dyn dflags Opt_D_dump_cmm
"Output Cmm" (ppr a)
return a
ppr_stream2 = Stream.mapM dump2 pipeline_stream
return ppr_stream2
myCoreToStg :: DynFlags -> Module -> CoreProgram
-> IO ( [StgTopBinding]
, CollectedCCs )
myCoreToStg dflags this_mod prepd_binds = do
let (stg_binds, cost_centre_info)
=
coreToStg dflags this_mod prepd_binds
stg_binds2
<-
stg2stg dflags stg_binds
return (stg_binds2, cost_centre_info)
hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
hscStmtWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO ( Maybe ([Id]
, ForeignHValue
, FixityEnv))
hscStmtWithLocation hsc_env0 stmt source linenumber =
runInteractiveHsc hsc_env0 $ do
maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
case maybe_stmt of
Nothing -> return Nothing
Just parsed_stmt -> do
hsc_env <- getHscEnv
liftIO $ hscParsedStmt hsc_env parsed_stmt
hscParsedStmt :: HscEnv
-> GhciLStmt GhcPs
-> IO ( Maybe ([Id]
, ForeignHValue
, FixityEnv))
hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
(ids, tc_expr, fix_env) <- ioMsgMaybe $ tcRnStmt hsc_env stmt
ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env tc_expr
liftIO (lintInteractiveExpr "desugar expression" hsc_env ds_expr)
handleWarnings
let src_span = srcLocSpan interactiveSrcLoc
hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
return $ Just (ids, hval, fix_env)
hscDecls :: HscEnv
-> String
-> IO ([TyThing], InteractiveContext)
hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
hscDeclsWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation hsc_env0 str source linenumber =
runInteractiveHsc hsc_env0 $ do
L _ (HsModule{ hsmodDecls = decls }) <-
hscParseThingWithLocation source linenumber parseModule str
hsc_env <- getHscEnv
tc_gblenv <- ioMsgMaybe $ tcRnDeclsi hsc_env decls
let defaults = tcg_default tc_gblenv
let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
ml_obj_file = panic "hsDeclsWithLocation:ml_hi_file"}
ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
simpl_mg <- liftIO $ do
plugins <- readIORef (tcg_th_coreplugins tc_gblenv)
hscSimplify hsc_env plugins ds_result
(tidy_cg, mod_details) <- liftIO $ tidyProgram hsc_env simpl_mg
let !CgGuts{ cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_modBreaks = mod_breaks } = tidy_cg
!ModDetails { md_insts = cls_insts
, md_fam_insts = fam_insts } = mod_details
data_tycons = filter isDataTyCon tycons
(prepd_binds, _) <-
liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
cbc <- liftIO $ byteCodeGen hsc_env this_mod
prepd_binds data_tycons mod_breaks
let src_span = srcLocSpan interactiveSrcLoc
liftIO $ linkDecls hsc_env src_span cbc
liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
patsyns = mg_patsyns simpl_mg
ext_ids = [ id | id <- bindersOfBinds core_binds
, isExternalName (idName id)
, not (isDFunId id || isImplicitId id) ]
new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
ictxt = hsc_IC hsc_env
fix_env = tcg_fix_env tc_gblenv
new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts
fam_insts defaults fix_env
return (new_tythings, new_ictxt)
hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries hsc_env entries = do
let add_spt_entry :: SptEntry -> IO ()
add_spt_entry (SptEntry i fpr) = do
val <- getHValue hsc_env (idName i)
addSptEntry hsc_env fpr val
mapM_ add_spt_entry entries
hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
hscImport hsc_env str = runInteractiveHsc hsc_env $ do
(L _ (HsModule{hsmodImports=is})) <-
hscParseThing parseModule str
case is of
[L _ i] -> return i
_ -> liftIO $ throwOneError $
mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
text "parse error in import declaration"
hscTcExpr :: HscEnv
-> TcRnExprMode
-> String
-> IO Type
hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
parsed_expr <- hscParseExpr expr
ioMsgMaybe $ tcRnExpr hsc_env mode parsed_expr
hscKcType
:: HscEnv
-> Bool
-> String
-> IO (Type, Kind)
hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ty <- hscParseType str
ioMsgMaybe $ tcRnType hsc_env normalise ty
hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr expr = do
hsc_env <- getHscEnv
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
Just (L _ (BodyStmt _ expr _ _)) -> return expr
_ -> throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
(text "not an expression:" <+> quotes (text expr))
hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt = hscParseThing parseStmt
hscParseStmtWithLocation :: String -> Int -> String
-> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation source linenumber stmt =
hscParseThingWithLocation source linenumber parseStmt stmt
hscParseType :: String -> Hsc (LHsType GhcPs)
hscParseType = hscParseThing parseType
hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName)
hscParseIdentifier hsc_env str =
runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
hscParseThing :: (Outputable thing, Data thing)
=> Lexer.P thing -> String -> Hsc thing
hscParseThing = hscParseThingWithLocation "<interactive>" 1
hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
-> Lexer.P thing -> String -> Hsc thing
hscParseThingWithLocation source linenumber parser str
= withTiming getDynFlags
(text "Parser [source]")
(const ()) $ do
dflags <- getDynFlags
let buf = stringToStringBuffer str
loc = mkRealSrcLoc (fsLit source) linenumber 1
case unP parser (mkPState dflags buf loc) of
PFailed warnFn span err -> do
logWarningsReportErrors (warnFn dflags)
handleWarnings
let msg = mkPlainErrMsg dflags span err
throwErrors $ unitBag msg
POk pst thing -> do
logWarningsReportErrors (getMessages pst dflags)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing)
liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed_ast "Parser AST" $
showAstData NoBlankSrcSpan thing
return thing
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr hsc_env =
lookupHook hscCompileCoreExprHook hscCompileCoreExpr' (hsc_dflags hsc_env) hsc_env
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' hsc_env srcspan ds_expr
= do { let dflags = hsc_dflags hsc_env
; simpl_expr <- simplifyExpr dflags ds_expr
; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
; prepd_expr <- corePrepExpr dflags hsc_env tidy_expr
; lintInteractiveExpr "hscCompileExpr" hsc_env prepd_expr
; bcos <- coreExprToBCOs hsc_env
(icInteractiveModule (hsc_IC hsc_env)) prepd_expr
; hval <- linkExpr hsc_env srcspan bcos
; return hval }
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env = do
eps <- readIORef (hsc_EPS hsc_env)
dumpIfSet dflags (dump_if_trace || dump_rn_stats)
"Interface statistics"
(ifaceStats eps)
where
dflags = hsc_dflags hsc_env
dump_rn_stats = dopt Opt_D_dump_rn_stats dflags
dump_if_trace = dopt Opt_D_dump_if_trace dflags
showModuleIndex :: (Int, Int) -> String
showModuleIndex (i,n) = "[" ++ padded ++ " of " ++ n_str ++ "] "
where
n_str = show n
i_str = show i
padded = replicate (length n_str length i_str) ' ' ++ i_str