Commit 48a0d6ce authored by Edward Z. Yang's avatar Edward Z. Yang
Browse files

Provide useful call-stacks over all IO code.



The key idea is that we define:

    type IO a = HasCallStack => Prelude.IO a

and voila, call stacks are maintained across all IO!  You can
look at the stacks using -v"debug +callstack".

There are a number of IO functions for which the call stack is
never used.  They are explicitly annotated using NoCallStackIO.
Maybe some day they will use call stacks and we can change their
types.  Similarly, there are a number of functions which do
have type IO, but then suppress the redundant constraint error
using "_ = callStack". Maybe some day we will attach call
stacks to the exceptions we throw.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>
parent 83c93c10
......@@ -429,6 +429,7 @@ library
Distribution.Compat.Binary.Generic
default-language: Haskell98
default-extensions: Rank2Types, FlexibleContexts
-- Small, fast running tests.
test-suite unit-tests
......
......@@ -42,16 +42,16 @@ import Foreign.C
( throwErrnoPathIfMinus1_ )
#endif /* mingw32_HOST_OS */
copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()
copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> NoCallStackIO ()
copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest
copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest
setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO ()
setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> NoCallStackIO ()
#ifndef mingw32_HOST_OS
setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r--
setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x
setFileMode :: FilePath -> FileMode -> IO ()
setFileMode :: FilePath -> FileMode -> NoCallStackIO ()
setFileMode name m =
withFilePath name $ \s -> do
throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)
......@@ -64,7 +64,7 @@ setDirOrdinary = setFileExecutable
-- | Copies a file to a new destination.
-- Often you should use `copyFileChanged` instead.
copyFile :: FilePath -> FilePath -> IO ()
copyFile :: FilePath -> FilePath -> NoCallStackIO ()
copyFile fromFPath toFPath =
copy
`catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))
......@@ -88,14 +88,14 @@ copyFile fromFPath toFPath =
-- | Like `copyFile`, but does not touch the target if source and destination
-- are already byte-identical. This is recommended as it is useful for
-- time-stamp based recompilation avoidance.
copyFileChanged :: FilePath -> FilePath -> IO ()
copyFileChanged :: FilePath -> FilePath -> NoCallStackIO ()
copyFileChanged src dest = do
equal <- filesEqual src dest
unless equal $ copyFile src dest
-- | Checks if two files are byte-identical.
-- Returns False if either of the files do not exist.
filesEqual :: FilePath -> FilePath -> IO Bool
filesEqual :: FilePath -> FilePath -> NoCallStackIO Bool
filesEqual f1 f2 = do
ex1 <- doesFileExist f1
ex2 <- doesFileExist f2
......
......@@ -5,9 +5,11 @@ import System.IO (Handle, hSetEncoding, localeEncoding)
import Prelude ()
import Distribution.Compat.Prelude
import Distribution.Compat.Stack
-- The mingw32_HOST_OS CPP macro is GHC-specific
#if mingw32_HOST_OS
import qualified Prelude
import Control.Exception (onException)
import Foreign.C.Error (throwErrnoIfMinus1_)
import Foreign.C.Types (CInt(..), CUInt(..))
......@@ -39,21 +41,26 @@ createPipe = do
hSetEncoding writeh localeEncoding
return (readh, writeh)) `onException` (close readfd >> close writefd)
where
fdToHandle :: CInt -> IOMode -> IO Handle
fdToHandle :: CInt -> IOMode -> NoCallStackIO Handle
fdToHandle fd mode = do
(fd', deviceType) <- mkFD fd mode (Just (Stream, 0, 0)) False False
mkHandleFromFD fd' deviceType "" mode False Nothing
close :: CInt -> IO ()
close = throwErrnoIfMinus1_ "_close" . c__close
where _ = callStack -- TODO: attach call stack to exception
_ = callStack -- TODO: attach call stack to exceptions
foreign import ccall "io.h _pipe" c__pipe ::
Ptr CInt -> CUInt -> CInt -> IO CInt
Ptr CInt -> CUInt -> CInt -> Prelude.IO CInt
foreign import ccall "io.h _close" c__close ::
CInt -> IO CInt
CInt -> Prelude.IO CInt
#elif ghcjs_HOST_OS
createPipe = error "createPipe"
where
_ = callStack
#else
createPipe = do
(readfd, writefd) <- Posix.createPipe
......@@ -62,4 +69,6 @@ createPipe = do
hSetEncoding readh localeEncoding
hSetEncoding writeh localeEncoding
return (readh, writeh)
where
_ = callStack
#endif
......@@ -7,6 +7,7 @@ module Distribution.Compat.Environment
where
import Prelude ()
import qualified Prelude
import Distribution.Compat.Prelude
#ifndef mingw32_HOST_OS
......@@ -25,6 +26,8 @@ import System.Environment (unsetEnv)
import Distribution.Compat.Exception (catchIO)
#endif
import Distribution.Compat.Stack
#ifdef mingw32_HOST_OS
import Foreign.C
import GHC.Windows
......@@ -35,7 +38,7 @@ import Foreign.C.Error (throwErrnoIfMinus1_)
import System.Posix.Internals ( withFilePath )
#endif /* mingw32_HOST_OS */
getEnvironment :: IO [(String, String)]
getEnvironment :: NoCallStackIO [(String, String)]
#ifdef mingw32_HOST_OS
-- On Windows, the names of environment variables are case-insensitive, but are
-- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise
......@@ -74,6 +77,8 @@ setEnv_ :: String -> String -> IO ()
setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
success <- c_SetEnvironmentVariable k v
unless success (throwGetLastError "setEnv")
where
_ = callStack -- TODO: attach CallStack to exception
# if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
......@@ -84,16 +89,18 @@ setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do
# endif /* i386_HOST_ARCH */
foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"
c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool
c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> Prelude.IO Bool
#else
setEnv_ key value = do
withFilePath key $ \ keyP ->
withFilePath value $ \ valueP ->
throwErrnoIfMinus1_ "setenv" $
c_setenv keyP valueP (fromIntegral (fromEnum True))
where
_ = callStack -- TODO: attach CallStack to exception
foreign import ccall unsafe "setenv"
c_setenv :: CString -> CString -> CInt -> IO CInt
c_setenv :: CString -> CString -> CInt -> Prelude.IO CInt
#endif /* mingw32_HOST_OS */
#if __GLASGOW_HASKELL__ < 708
......@@ -118,10 +125,10 @@ unsetEnv key = withCWString key $ \k -> do
#else
unsetEnv key = withFilePath key (throwErrnoIf_ (/= 0) "unsetEnv" . c_unsetenv)
#if __GLASGOW_HASKELL__ > 706
foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> IO CInt
foreign import ccall unsafe "__hsbase_unsetenv" c_unsetenv :: CString -> Prelude.IO CInt
#else
-- HACK: We hope very hard that !UNSETENV_RETURNS_VOID
foreign import ccall unsafe "unsetenv" c_unsetenv :: CString -> IO CInt
foreign import ccall unsafe "unsetenv" c_unsetenv :: CString -> Prelude.IO CInt
#endif
#endif
......
......@@ -17,6 +17,7 @@ import Distribution.Compat.Prelude
#ifdef mingw32_HOST_OS
import qualified Prelude
import qualified System.Win32 as Win32
import System.Win32 (LPCTSTR, LPTSTR, DWORD)
import Foreign.Marshal.Array (allocaArray)
......@@ -28,7 +29,7 @@ import Foreign.Marshal.Array (allocaArray)
#endif
foreign import WINAPI unsafe "windows.h GetShortPathNameW"
c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> IO DWORD
c_GetShortPathName :: LPCTSTR -> LPTSTR -> DWORD -> Prelude.IO DWORD
-- | On Windows, retrieves the short path form of the specified path. On
-- non-Windows, does nothing. See https://github.com/haskell/cabal/issues/3185.
......@@ -39,7 +40,7 @@ foreign import WINAPI unsafe "windows.h GetShortPathNameW"
-- will always return the required buffer size for a
-- specified lpszLongPath.
--
getShortPathName :: FilePath -> IO FilePath
getShortPathName :: FilePath -> NoCallStackIO FilePath
getShortPathName path =
Win32.withTString path $ \c_path -> do
c_len <- Win32.failIfZero "GetShortPathName #1 failed!" $
......@@ -52,7 +53,7 @@ getShortPathName path =
#else
getShortPathName :: FilePath -> IO FilePath
getShortPathName :: FilePath -> NoCallStackIO FilePath
getShortPathName path = return path
#endif
......@@ -25,7 +25,7 @@ instance MonadFail Maybe where
instance MonadFail [] where
fail _ = []
instance MonadFail IO where
instance MonadFail P.IO where
fail = P.fail
instance MonadFail ReadPrec where
......
......@@ -18,7 +18,7 @@
module Distribution.Compat.Prelude (
-- * Prelude
--
-- Prelude is re-exported, following is hided:
-- Prelude is re-exported, following is hidden:
module BasePrelude,
#if !MINVER_base_48
......@@ -39,6 +39,7 @@ module Distribution.Compat.Prelude (
MonadPlus (..),
-- * Some types
IO, NoCallStackIO,
Map,
-- * Data.Maybe
......@@ -84,7 +85,7 @@ module Distribution.Compat.Prelude (
-- We also could hide few partial function
import Prelude as BasePrelude hiding
( mapM, mapM_, sequence, null, length, foldr
( IO, mapM, mapM_, sequence, null, length, foldr
#if MINVER_base_48
-- We hide them, as we import only some members
, Traversable, traverse, sequenceA
......@@ -122,6 +123,12 @@ import Data.Maybe
import qualified Text.PrettyPrint as Disp
import qualified Prelude as OrigPrelude
import Distribution.Compat.Stack
type IO a = WithCallStack (OrigPrelude.IO a)
type NoCallStackIO a = OrigPrelude.IO a
-- | New name for 'Text.PrettyPrint.<>'
(<<>>) :: Disp.Doc -> Disp.Doc -> Disp.Doc
(<<>>) = (Disp.<>)
......
......@@ -5,6 +5,7 @@ module Distribution.Compat.Stack (
WithCallStack,
CallStack,
withFrozenCallStack,
withLexicalCallStack,
callStack,
prettyCallStack,
parentSrcLocPrefix
......@@ -25,7 +26,7 @@ import GHC.Stack
#if MIN_VERSION_base(4,9,0)
type WithCallStack a = HasCallStack => a
#elif MIN_VERSION_base(4,8,1)
type WithCallStack a = (?loc :: CallStack) => a
type WithCallStack a = (?callStack :: CallStack) => a
#endif
#if !MIN_VERSION_base(4,9,0)
......@@ -37,8 +38,8 @@ type WithCallStack a = (?loc :: CallStack) => a
withFrozenCallStack :: WithCallStack (a -> a)
withFrozenCallStack x = x
callStack :: (?loc :: CallStack) => CallStack
callStack = ?loc
callStack :: (?callStack :: CallStack) => CallStack
callStack = ?callStack
prettyCallStack :: CallStack -> String
prettyCallStack = showCallStack
......@@ -64,6 +65,12 @@ parentSrcLocPrefix =
parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "
#endif
-- Yeah, this uses skivvy implementation details.
withLexicalCallStack :: (a -> WithCallStack (IO b)) -> WithCallStack (a -> IO b)
withLexicalCallStack f =
let stk = ?callStack
in \x -> let ?callStack = stk in f x
#else
data CallStack = CallStack
......@@ -83,4 +90,7 @@ prettyCallStack _ = "Call stacks not available with base < 4.8.1.0 (GHC 7.10)"
parentSrcLocPrefix :: String
parentSrcLocPrefix = "Call sites not available with base < 4.9.0.0 (GHC 8.0): "
withLexicalCallStack :: (a -> IO b) -> a -> IO b
withLexicalCallStack f = f
#endif
......@@ -29,6 +29,7 @@ import System.Time ( getClockTime, diffClockTimes
#if defined mingw32_HOST_OS
import qualified Prelude
import Data.Bits ((.|.), unsafeShiftL)
#if MIN_VERSION_base(4,7,0)
import Data.Bits (finiteBitSize)
......@@ -69,7 +70,7 @@ instance Read ModTime where
--
-- This is a modified version of the code originally written for Shake by Neil
-- Mitchell. See module Development.Shake.FileInfo.
getModTime :: FilePath -> IO ModTime
getModTime :: FilePath -> NoCallStackIO ModTime
#if defined mingw32_HOST_OS
......@@ -105,9 +106,9 @@ getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do
#endif
foreign import CALLCONV "windows.h GetFileAttributesExW"
c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> IO BOOL
c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> Prelude.IO BOOL
getFileAttributesEx :: String -> LPVOID -> IO BOOL
getFileAttributesEx :: String -> LPVOID -> NoCallStackIO BOOL
getFileAttributesEx path lpFileInformation =
withTString path $ \c_path ->
c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation
......@@ -156,7 +157,7 @@ posixTimeToModTime p = ModTime $ (ceiling $ p * 1e7) -- 100 ns precision
+ (secToUnixEpoch * windowsTick)
-- | Return age of given file in days.
getFileAge :: FilePath -> IO Double
getFileAge :: FilePath -> NoCallStackIO Double
getFileAge file = do
t0 <- getModificationTime file
#if MIN_VERSION_directory(1,2,0)
......@@ -169,7 +170,7 @@ getFileAge file = do
#endif
-- | Return the current time as 'ModTime'.
getCurTime :: IO ModTime
getCurTime :: NoCallStackIO ModTime
getCurTime = posixTimeToModTime `fmap` getPOSIXTime -- Uses 'gettimeofday'.
-- | Based on code written by Neil Mitchell for Shake. See
......
......@@ -1614,7 +1614,7 @@ checkDevelopmentOnlyFlags pkg =
-- | Sanity check things that requires IO. It looks at the files in the
-- package and expects to find the package unpacked in at the given file path.
--
checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck]
checkPackageFiles :: PackageDescription -> FilePath -> NoCallStackIO [PackageCheck]
checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg
where
checkFilesIO = CheckPackageContentOps {
......
......@@ -48,7 +48,7 @@ simplifiedPrinting :: Bool
simplifiedPrinting = False
-- | Writes a .cabal file from a generic package description
writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()
writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> NoCallStackIO ()
writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)
-- | Writes a generic package description to a string
......@@ -272,7 +272,7 @@ emptyLine :: Doc -> Doc
emptyLine d = text "" $+$ d
-- | @since 1.26.0.0@
writePackageDescription :: FilePath -> PackageDescription -> IO ()
writePackageDescription :: FilePath -> PackageDescription -> NoCallStackIO ()
writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)
--TODO: make this use section syntax
......@@ -357,7 +357,7 @@ benchmarkInterfaceToMaybeMainIs BenchmarkUnsupported{} = Nothing
-- | @since 1.26.0.0@
writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()
writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> NoCallStackIO ()
writeHookedBuildInfo fpath = writeFileAtomic fpath . BS.Char8.pack
. showHookedBuildInfo
......
......@@ -515,7 +515,7 @@ clean pkg_descr flags = do
traverse_ (writePersistBuildConfig distPref) maybeConfig
where
removeFileOrDirectory :: FilePath -> IO ()
removeFileOrDirectory :: FilePath -> NoCallStackIO ()
removeFileOrDirectory fname = do
isDir <- doesDirectoryExist fname
isFile <- doesFileExist fname
......
......@@ -147,7 +147,7 @@ readBuildTargets pkg targetStrs = do
return btargets
checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)
checkTargetExistsAsFile :: UserBuildTarget -> NoCallStackIO (UserBuildTarget, Bool)
checkTargetExistsAsFile t = do
fexists <- existsAsFile (fileComponentOfTarget t)
return (t, fexists)
......
......@@ -196,10 +196,10 @@ registrationPackageDB dbs = last dbs
-- | Make package paths absolute
absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack
absolutePackageDBPaths :: PackageDBStack -> NoCallStackIO PackageDBStack
absolutePackageDBPaths = traverse absolutePackageDBPath
absolutePackageDBPath :: PackageDB -> IO PackageDB
absolutePackageDBPath :: PackageDB -> NoCallStackIO PackageDB
absolutePackageDBPath GlobalPackageDB = return GlobalPackageDB
absolutePackageDBPath UserPackageDB = return UserPackageDB
absolutePackageDBPath (SpecificPackageDB db) =
......
......@@ -87,6 +87,7 @@ import Distribution.Version
import Distribution.Verbosity
import qualified Distribution.Compat.Graph as Graph
import Distribution.Compat.Graph (Node(..))
import Distribution.Compat.Stack
import qualified Distribution.Simple.GHC as GHC
import qualified Distribution.Simple.GHCJS as GHCJS
......@@ -198,6 +199,8 @@ getConfigStateFile filename = do
throw $ ConfigStateFileBadVersion cabalId compId eResult
| otherwise = act
deferErrorIfBadVersion getStoredValue
where
_ = callStack -- TODO: attach call stack to exception
-- | Read the 'localBuildInfoFile', returning either an error or the local build
-- info.
......@@ -227,7 +230,7 @@ maybeGetPersistBuildConfig =
-- 'localBuildInfoFile'.
writePersistBuildConfig :: FilePath -- ^ The @dist@ directory path.
-> LocalBuildInfo -- ^ The 'LocalBuildInfo' to write.
-> IO ()
-> NoCallStackIO ()
writePersistBuildConfig distPref lbi = do
createDirectoryIfMissing False distPref
writeFileAtomic (localBuildInfoFile distPref) $
......@@ -272,7 +275,7 @@ showHeader pkgId = BLC8.unwords
-- | Check that localBuildInfoFile is up-to-date with respect to the
-- .cabal file.
checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool
checkPersistBuildConfigOutdated :: FilePath -> FilePath -> NoCallStackIO Bool
checkPersistBuildConfigOutdated distPref pkg_descr_file = do
pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref)
......@@ -290,7 +293,7 @@ localBuildInfoFile distPref = distPref </> "setup-config"
-- \"CABAL_BUILDDIR\" environment variable, or the default prefix.
findDistPref :: FilePath -- ^ default \"dist\" prefix
-> Setup.Flag FilePath -- ^ override \"dist\" prefix
-> IO FilePath
-> NoCallStackIO FilePath
findDistPref defDistPref overrideDistPref = do
envDistPref <- liftM parseEnvDistPref (lookupEnv "CABAL_BUILDDIR")
return $ fromFlagOrDefault defDistPref (mappend envDistPref overrideDistPref)
......@@ -307,7 +310,7 @@ findDistPref defDistPref overrideDistPref = do
-- set. (The @*DistPref@ flags are always set to a definite value before
-- invoking 'UserHooks'.)
findDistPrefOrDefault :: Setup.Flag FilePath -- ^ override \"dist\" prefix
-> IO FilePath
-> NoCallStackIO FilePath
findDistPrefOrDefault = findDistPref defaultDistPref
-- |Perform the \"@.\/setup configure@\" action.
......@@ -1486,7 +1489,7 @@ configurePkgconfigPackages verbosity pkg_descr progdb
addPkgConfigBIBench = addPkgConfigBI benchmarkBuildInfo $
\bench bi -> bench { benchmarkBuildInfo = bi }
pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo
pkgconfigBuildInfo :: [Dependency] -> NoCallStackIO BuildInfo
pkgconfigBuildInfo [] = return mempty
pkgconfigBuildInfo pkgdeps = do
let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ]
......
......@@ -338,7 +338,7 @@ getGlobalPackageDB verbosity ghcProg =
getProgramOutput verbosity ghcProg ["--print-global-package-db"]
-- | Return the 'FilePath' to the per-user GHC package database.
getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> IO FilePath
getUserPackageDB :: Verbosity -> ConfiguredProgram -> Platform -> NoCallStackIO FilePath
getUserPackageDB _verbosity ghcProg (Platform arch os) = do
-- It's rather annoying that we have to reconstruct this, because ghc
-- hides this information from us otherwise. But for certain use cases
......@@ -962,7 +962,7 @@ buildOrReplExe forRepl verbosity numJobs _pkg_descr lbi
-- | Returns True if the modification date of the given source file is newer than
-- the object file we last compiled for it, or if no object file exists yet.
checkNeedsRecompilation :: FilePath -> GhcOptions -> IO Bool
checkNeedsRecompilation :: FilePath -> GhcOptions -> NoCallStackIO Bool
checkNeedsRecompilation filename opts = filename `moreRecentFile` oname
where oname = getObjectFileName filename opts
......@@ -978,7 +978,7 @@ getObjectFileName filename opts = oname
-- Calculates relative RPATHs when 'relocatable' is set.
getRPaths :: LocalBuildInfo
-> ComponentLocalBuildInfo -- ^ Component we are building
-> IO (NubListR FilePath)
-> NoCallStackIO (NubListR FilePath)
getRPaths lbi clbi | supportRPaths hostOS = do
libraryPaths <- depLibraryPaths False (relocatable lbi) lbi clbi
let hostPref = case hostOS of
......
......@@ -54,6 +54,7 @@ import Distribution.System
import Distribution.Text ( display, simpleParse )
import Distribution.Utils.NubList ( toNubListR )
import Distribution.Verbosity
import Distribution.Compat.Stack
import Language.Haskell.Extension
import qualified Data.Map as Map
......@@ -155,7 +156,7 @@ configureToolchain _implInfo ghcProg ghcInfo =
| (flags', ""):_ <- reads flags -> flags'
| otherwise -> tokenizeQuotedWords flags
configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureGcc :: Verbosity -> ConfiguredProgram -> NoCallStackIO ConfiguredProgram
configureGcc _v gccProg = do
return gccProg {
programDefaultArgs = programDefaultArgs gccProg
......@@ -192,7 +193,7 @@ configureToolchain _implInfo ghcProg ghcInfo =
else return ldProg
getLanguages :: Verbosity -> GhcImplInfo -> ConfiguredProgram
-> IO [(Language, String)]
-> NoCallStackIO [(Language, String)]
getLanguages _ implInfo _
-- TODO: should be using --supported-languages rather than hard coding
| supportsHaskell2010 implInfo = return [(Haskell98, "-XHaskell98")
......@@ -353,7 +354,7 @@ ghcLookupProperty prop comp =
-- when using -split-objs, we need to search for object files in the
-- Module_split directory for each module.
getHaskellObjects :: GhcImplInfo -> Library -> LocalBuildInfo
-> FilePath -> String -> Bool -> IO [FilePath]
-> FilePath -> String -> Bool -> NoCallStackIO [FilePath]
getHaskellObjects _implInfo lib lbi pref wanted_obj_ext allow_split_objs
| splitObjs lbi && allow_split_objs = do
let splitSuffix = "_" ++ wanted_obj_ext ++ "_split"
......@@ -409,7 +410,7 @@ checkPackageDbEnvVar compilerName packagePathEnvVar = do
mcsPP <- lookupEnv "CABAL_SANDBOX_PACKAGE_PATH"
unless (mPP == mcsPP) abort
where
lookupEnv :: String -> IO (Maybe String)
lookupEnv :: String -> NoCallStackIO (Maybe String)
lookupEnv name = (Just `fmap` getEnv name)
`catchIO` const (return Nothing)
abort =
......@@ -418,6 +419,8 @@ checkPackageDbEnvVar compilerName packagePathEnvVar = do
++ "flag --package-db to specify a package database (it can be "
++ "used multiple times)."
_ = callStack -- TODO: output stack when erroring
profDetailLevelFlag :: Bool -> ProfDetailLevel -> Flag GhcProfAuto
profDetailLevelFlag forLib mpl =
case mpl of
......
......@@ -567,7 +567,7 @@ renderPureArgs version comp platform args = concat
-- HTML paths, and an optional warning for packages with missing documentation.
haddockPackagePaths :: [InstalledPackageInfo]
-> Maybe (InstalledPackageInfo -> FilePath)
-> IO ([(FilePath, Maybe FilePath)], Maybe String)
-> NoCallStackIO ([(FilePath, Maybe FilePath)], Maybe String)
haddockPackagePaths ipkgs mkHtmlPath = do
interfaces <- sequenceA
[ case interfaceAndHtmlPath ipkg of
......
......@@ -59,6 +59,7 @@ import System.FilePath ((</>), isPathSeparator, pathSeparator)
import System.FilePath (dropDrive)
#if mingw32_HOST_OS
import qualified Prelude
import Foreign
import Foreign.C
#endif
......@@ -539,7 +540,7 @@ instance Read PathTemplate where
-- ---------------------------------------------------------------------------
-- Internal utilities
getWindowsProgramFilesDir :: IO FilePath
getWindowsProgramFilesDir :: NoCallStackIO FilePath
getWindowsProgramFilesDir = do
#if mingw32_HOST_OS
m <- shGetFolderPath csidl_PROGRAM_FILES
......@@ -549,7 +550,7 @@ getWindowsProgramFilesDir = do
return (fromMaybe "C:\\Program Files" m)
#if mingw32_HOST_OS
shGetFolderPath :: CInt -> IO (Maybe FilePath)
shGetFolderPath :: CInt -> NoCallStackIO (Maybe FilePath)
shGetFolderPath n =
allocaArray long_path_size $ \pPath -> do
r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath
......@@ -576,5 +577,5 @@ foreign import CALLCONV unsafe "shlobj.h SHGetFolderPathW"
-> Ptr ()
-> CInt
-> CWString
-> IO CInt
-> Prelude.IO CInt
#endif
......@@ -139,7 +139,7 @@ configureToolchain lhcProg =
programFindLocation prog verbosity searchpath
| otherwise = programFindLocation prog
configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram
configureGcc :: Verbosity -> ConfiguredProgram -> NoCallStackIO ConfiguredProgram
configureGcc
| isWindows = \_ gccProg -> case programLocation gccProg of
-- if it's found on system then it means we're using the result
......@@ -175,7 +175,7 @@ configureToolchain lhcProg =
then return ldProg { programDefaultArgs = ["-x"] }
else return ldProg
getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]
getLanguages :: Verbosity -> ConfiguredProgram -> NoCallStackIO [(Language, Flag)]