module Scion.Session where
import Prelude hiding ( mod )
import GHC hiding ( flags, load )
import HscTypes ( srcErrorMessages, SourceError, isBootSummary )
import Exception
import Scion.Types
import Scion.Types.Notes
import Scion.Utils
import Scion.Inspect.DefinitionSite
import qualified Data.MultiSet as MS
import Control.Monad
import Data.Data
import Data.IORef
import Data.List ( intercalate, nubBy )
import Data.Maybe ( isJust, fromMaybe, fromJust )
import Data.Monoid
import Data.Time.Clock ( getCurrentTime, diffUTCTime )
import System.Directory ( setCurrentDirectory, getCurrentDirectory,
doesFileExist, getDirectoryContents )
import System.FilePath ( (</>), isRelative, makeRelative, normalise,
dropFileName, takeDirectory, takeFileName )
import Control.Exception
import System.Exit ( ExitCode(..) )
import qualified Distribution.ModuleName as PD ( ModuleName, components )
import Distribution.Simple.Configure
import Distribution.Simple.GHC ( ghcOptions )
import Distribution.Simple.LocalBuildInfo hiding ( libdir )
import Distribution.Simple.Build ( initialBuildSteps )
import Distribution.Simple.PreProcess ( knownSuffixHandlers )
import qualified Distribution.Verbosity as V
import qualified Distribution.PackageDescription as PD
import qualified Distribution.PackageDescription.Parse as PD
import qualified Distribution.PackageDescription.Configuration as PD
data CannotOpenCabalProject = CannotOpenCabalProject String
deriving (Show, Typeable)
instance Exception CannotOpenCabalProject where
toException = scionToException
fromException = scionFromException
data NoCurrentCabalProject = NoCurrentCabalProject deriving (Show, Typeable)
instance Exception NoCurrentCabalProject where
toException = scionToException
fromException = scionFromException
data ComponentDoesNotExist = ComponentDoesNotExist Component
deriving (Show, Typeable)
instance Exception ComponentDoesNotExist where
toException = scionToException
fromException = scionFromException
initialScionDynFlags :: DynFlags -> DynFlags
initialScionDynFlags dflags =
dflags {
#ifdef RECOMPILE_BUG_FIXED
hscTarget = HscNothing
, ghcLink = NoLink
#else
hscTarget = HscInterpreted
, ghcLink = LinkInMemory
#endif
}
resetSessionState :: ScionM ()
resetSessionState = do
unload
dflags0 <- gets initialDynFlags
setSessionDynFlags (initialScionDynFlags dflags0)
return ()
setWorkingDir :: FilePath -> ScionM ()
setWorkingDir home = do
cwd <- liftIO $ getCurrentDirectory
message deafening $ "Setting working directory: " ++ home ++ " (old: " ++ cwd ++ ")"
liftIO $ setCurrentDirectory home
cwd' <- liftIO $ getCurrentDirectory
when (cwd /= cwd') $ do
message deafening $ "(Working directory changed.)"
workingDirectoryChanged
openCabalProject :: FilePath
-> FilePath
-> ScionM ()
openCabalProject root_dir dist_rel_dir = do
let dist_dir = root_dir </> dist_rel_dir
mb_lbi <- liftIO $ tryGetConfigStateFile (localBuildInfoFile dist_dir)
case mb_lbi of
Left e ->
liftIO $ throwIO $ CannotOpenCabalProject $ "reason :" ++ show e
Right lbi -> do
setWorkingDir root_dir
resetSessionState
modifySessionState $ \st -> st { localBuildInfo = Just lbi }
currentCabalPackage :: ScionM PD.PackageDescription
currentCabalPackage = do
lbi <- getLocalBuildInfo
return (localPkgDescr lbi)
currentCabalFile :: ScionM FilePath
currentCabalFile = do
lbi <- getLocalBuildInfo
case pkgDescrFile lbi of
Just f -> return f
Nothing -> liftIO $ throwIO $ NoCurrentCabalProject
cabalProjectComponents :: FilePath
-> ScionM [Component]
cabalProjectComponents cabal_file = do
ghandle (\(_ :: ExitCode) ->
liftIO $ throwIO $ CannotOpenCabalProject cabal_file) $ do
gpd <- liftIO $ PD.readPackageDescription V.silent cabal_file
let pd = PD.flattenPackageDescription gpd
return $
(if isJust (PD.library pd) then [Library] else []) ++
[ Executable (PD.exeName e) | e <- PD.executables pd ]
cabalConfigurations :: FilePath
-> String
-> Bool
-> ScionM [CabalConfiguration]
cabalConfigurations cabal type' scionDefaultOnly = do
let allowed = ["dist", "config", "all", "uniq"]
when (not $ elem type' allowed) $ scionError $ "invalid value for type, expected: one of " ++ (show allowed)
let dir = takeDirectory cabal
existingDists <- liftIO $ filterM (doesFileExist . (\c -> dir </> c </> "setup-config"))
=<< liftM (filter (not . (`elem` [".", ".."]))) (getDirectoryContents dir)
config <- parseScionProjectConfig $ projectConfigFileFromDir dir
let list = (if type' `elem` ["all", "config", "uniq"] then buildConfigurations config else [])
++ (if type' `elem` ["all", "dist", "uniq"] then map (\ a-> CabalConfiguration a []) existingDists else [])
let f = if type' == "uniq" then nubBy (\a b -> distDir a == distDir b) else id
let list' = f list
let d = scionDefaultCabalConfig config
let scionDefault = filter ( ((fromJust d) ==) . distDir) list'
return $ if isJust d && scionDefaultOnly && (not . null) scionDefault
then scionDefault
else list'
preprocessPackage :: FilePath
-> ScionM ()
preprocessPackage dist_dir = do
lbi <- getLocalBuildInfo
let pd = localPkgDescr lbi
liftIO $ initialBuildSteps dist_dir pd lbi V.normal knownSuffixHandlers
return ()
getLocalBuildInfo :: ScionM LocalBuildInfo
getLocalBuildInfo =
gets localBuildInfo >>= \mb_lbi ->
case mb_lbi of
Nothing -> liftIO $ throwIO NoCurrentCabalProject
Just lbi -> return lbi
projectRootDir :: ScionM FilePath
projectRootDir = do
liftIO $ getCurrentDirectory
setComponentDynFlags ::
Component
-> ScionM [PackageId]
setComponentDynFlags (File f) = do
cfg <- liftM projectConfigFileFromDir $ liftIO getCurrentDirectory
config <- parseScionProjectConfig cfg
addCmdLineFlags $ fromMaybe [] $ lookup (takeFileName f) (fileComponentExtraFlags config)
setComponentDynFlags component = do
lbi <- getLocalBuildInfo
bi <- component_build_info component (localPkgDescr lbi)
let odir = buildDir lbi
let flags = ghcOptions lbi bi odir
addCmdLineFlags flags
where
component_build_info Library pd
| Just lib <- PD.library pd = return (PD.libBuildInfo lib)
| otherwise = noLibError
component_build_info (Executable n) pd =
case [ exe | exe <- PD.executables pd, PD.exeName exe == n ] of
[ exe ] -> return (PD.buildInfo exe)
[] -> noExeError n
_ -> error $ "Multiple executables, named \"" ++ n ++
"\" found. This is weird..."
component_build_info _ _ =
dieHard "component_build_info: impossible case"
setComponentTargets :: Component -> ScionM ()
setComponentTargets Library = do
pd <- currentCabalPackage
unless (isJust (PD.library pd))
noLibError
let modnames = PD.libModules pd
setTargets (map cabalModuleNameToTarget modnames)
setComponentTargets (Executable n) = do
pd <- currentCabalPackage
let ex0 = filter ((n==) . PD.exeName) (PD.executables pd)
case ex0 of
[] -> noExeError n
(_:_:_) -> error $ "Multiple executables with name: " ++ n
[exe] -> do
proj_root <- cabalProjectRoot
let others = PD.otherModules (PD.buildInfo exe)
let main_mods = [ proj_root </> search_path </> PD.modulePath exe
| search_path <- PD.hsSourceDirs (PD.buildInfo exe)]
(main_mod:_) <- filterM (liftIO . doesFileExist) main_mods
let targets = Target (TargetFile main_mod Nothing) True Nothing :
map cabalModuleNameToTarget others
setTargets targets
return ()
setComponentTargets (File f) = do
setTargets [ Target (TargetFile f Nothing)
True
Nothing ]
cabalModuleNameToTarget :: PD.ModuleName -> Target
cabalModuleNameToTarget name =
Target { targetId = TargetModule (mkModuleName
(cabal_mod_to_string name))
, targetAllowObjCode = True
, targetContents = Nothing }
where
cabal_mod_to_string m =
intercalate "." (PD.components m)
loadComponent :: Component
-> ScionM CompilationResult
loadComponent comp = do
resetSessionState
setActiveComponent comp
maybe_set_working_dir comp
setComponentDynFlags comp
setComponentTargets comp
rslt <- load LoadAllTargets
mg <- getModuleGraph
base_dir <- projectRootDir
db <- moduleGraphDefSiteDB base_dir mg
liftIO $ evaluate db
modifySessionState $ \s -> s { lastCompResult = rslt
, defSiteDB = db }
return rslt
where
maybe_set_working_dir (File f) = do
wd <- liftIO $ getCurrentDirectory
let dir = normalise $ wd </> dropFileName f
setWorkingDir dir
maybe_set_working_dir _ = do
dir <- cabalProjectRoot
setWorkingDir dir
cabalProjectRoot :: ScionM FilePath
cabalProjectRoot = do
lbi <- getLocalBuildInfo
let mb_pkg_dir = dropFileName `fmap` pkgDescrFile lbi
case mb_pkg_dir of
Just dir -> return dir
Nothing -> liftIO $ getCurrentDirectory
setActiveComponent :: Component -> ScionM ()
setActiveComponent comp = do
curr_comp <- gets activeComponent
when (needs_unloading curr_comp)
unload
setComponentDynFlags comp
modifySessionState (\sess -> sess { activeComponent = Just comp })
where
needs_unloading (Just c) | c /= comp = True
needs_unloading _ = False
getActiveComponent :: ScionM (Maybe Component)
getActiveComponent = gets activeComponent
noLibError :: ScionM a
noLibError = liftIO $ throwIO $ ComponentDoesNotExist Library
noExeError :: String -> ScionM a
noExeError = liftIO . throwIO . ComponentDoesNotExist . Executable
load :: LoadHowMuch -> ScionM CompilationResult
load how_much = do
start_time <- liftIO $ getCurrentTime
ref <- liftIO $ newIORef (mempty, mempty)
res <- loadWithLogger (logWarnErr ref) how_much
`gcatch` (\(e :: SourceError) -> handle_error ref e)
end_time <- liftIO $ getCurrentTime
let time_diff = diffUTCTime end_time start_time
(warns, errs) <- liftIO $ readIORef ref
base_dir <- projectRootDir
let notes = ghcMessagesToNotes base_dir (warns, errs)
let comp_rslt = case res of
Succeeded -> CompilationResult True notes time_diff
Failed -> CompilationResult False notes time_diff
modifySessionState $ \s -> s { lastCompResult = comp_rslt }
return comp_rslt
where
logWarnErr ref err = do
let errs = case err of
Nothing -> mempty
Just exc -> srcErrorMessages exc
warns <- getWarnings
clearWarnings
add_warn_err ref warns errs
add_warn_err ref warns errs =
liftIO $ modifyIORef ref $
\(warns', errs') -> ( warns `mappend` warns'
, errs `mappend` errs')
handle_error ref e = do
let errs = srcErrorMessages e
warns <- getWarnings
add_warn_err ref warns errs
clearWarnings
return Failed
unload :: ScionM ()
unload = do
setTargets []
load LoadAllTargets
modifySessionState $ \st -> st { lastCompResult = mempty
, defSiteDB = mempty }
return ()
addCmdLineFlags :: [String] -> ScionM [PackageId]
addCmdLineFlags flags = do
message deafening $ "Setting Flags: " ++ show flags
dflags <- getSessionDynFlags
res <- gtry $ parseDynamicFlags dflags (map noLoc flags)
case res of
Left (UsageError msg) -> do
liftIO $ putStrLn $ "Dynflags parse error: " ++ msg
return []
Left e -> liftIO $ throwIO e
Right (dflags', unknown, warnings) -> do
unless (null unknown) $
liftIO $ putStrLn $ "Unrecognised flags:\n" ++ show (map unLoc unknown)
liftIO $ mapM_ putStrLn $ map unLoc warnings
setSessionDynFlags dflags'
availableComponents :: ScionM [Component]
availableComponents = do
pd <- currentCabalPackage
return $ (case PD.library pd of
Just _ -> [Library]
_ -> []) ++
[ Executable n
| PD.Executable {PD.exeName = n} <- PD.executables pd ]
setGHCVerbosity :: Int -> ScionM ()
setGHCVerbosity lvl = do
dflags <- getSessionDynFlags
setSessionDynFlags $! dflags { verbosity = lvl }
return ()
backgroundTypecheckFile ::
FilePath
-> ScionM (Either String CompilationResult)
backgroundTypecheckFile fname = do
root_dir <- projectRootDir
ifM (not `fmap` isRelativeToProjectRoot fname)
(return (Left ("file " ++ fname ++ " is not relative to project root " ++ root_dir)))
prepareContext
where
prepareContext :: ScionM (Either String CompilationResult)
prepareContext = do
message verbose $ "Preparing context for " ++ fname
mb_focusmod <- gets focusedModule
case mb_focusmod of
Just ms | Just f <- ml_hs_file (ms_location ms), f == fname ->
backgroundTypecheckFile' mempty
_otherwise -> do
mb_modsum <- filePathToProjectModule fname
case mb_modsum of
Nothing -> do
return $ Left "Could not find file in module graph."
Just modsum -> do
(_, rslt) <- setContextForBGTC modsum
if compilationSucceeded rslt
then backgroundTypecheckFile' rslt
else return $ Right rslt
backgroundTypecheckFile' comp_rslt = do
message verbose $ "Background type checking: " ++ fname
clearWarnings
start_time <- liftIO $ getCurrentTime
modsum <- preprocessModule
let finish_up tc_res errs = do
base_dir <- projectRootDir
warns <- getWarnings
clearWarnings
let notes = ghcMessagesToNotes base_dir (warns, errs)
end_time <- liftIO $ getCurrentTime
let ok = isJust tc_res
let res = CompilationResult ok notes
(diffUTCTime end_time start_time)
let abs_fname = mkAbsFilePath base_dir fname
full_comp_rslt <- removeMessagesForFile abs_fname =<< gets lastCompResult
let comp_rslt' = full_comp_rslt `mappend` comp_rslt `mappend` res
modifySessionState (\s -> s { bgTcCache = tc_res
, lastCompResult = comp_rslt' })
return $ Right comp_rslt'
ghandle (\(e :: SourceError) -> finish_up Nothing (srcErrorMessages e)) $
do
parsed_mod <- parseModule modsum
tcd_mod <- typecheckModule parsed_mod
ds_mod <- desugarModule tcd_mod
loadModule ds_mod
finish_up (Just (Typechecked tcd_mod)) mempty
preprocessModule = do
depanal [] True
mb_modsum <- filePathToProjectModule fname
case mb_modsum of
Nothing -> error "Huh? No modsummary after preprocessing?"
Just ms -> return ms
isRelativeToProjectRoot :: FilePath -> ScionM Bool
isRelativeToProjectRoot fname = do
root_dir <- projectRootDir
return (isRelative (makeRelative root_dir fname))
`gcatch` \(_ :: NoCurrentCabalProject) -> return False
filePathToProjectModule :: FilePath -> ScionM (Maybe ModSummary)
filePathToProjectModule fname = do
root_dir <- projectRootDir
let rel_fname = normalise (makeRelative root_dir fname)
mod_graph <- getModuleGraph
case [ m | m <- mod_graph
, not (isBootSummary m)
, Just src <- [ml_hs_file (ms_location m)]
, src == fname || src == rel_fname || normalise src == normalise rel_fname ]
of [ m ] -> do return (Just m)
l -> do message verbose $ "No module found for " ++ fname ++ (if null l then "" else " reason: ambiguity")
return Nothing
`gcatch` \(_ :: NoCurrentCabalProject) -> return Nothing
isPartOfProject :: FilePath -> ScionM Bool
isPartOfProject fname = fmap isJust (filePathToProjectModule fname)
setContextForBGTC :: ModSummary -> ScionM (Maybe ModuleName, CompilationResult)
setContextForBGTC modsum = do
message deafening $ "Setting context for: " ++
moduleNameString (moduleName (ms_mod modsum))
let mod_name = ms_mod_name modsum
start_time <- liftIO $ getCurrentTime
r <- load (LoadDependenciesOf mod_name)
`gcatch` \(e :: SourceError) ->
srcErrToCompilationResult start_time e
modifySessionState $ \sess ->
sess { focusedModule = if compilationSucceeded r
then Just modsum
else Nothing
}
return (Nothing, r)
where
srcErrToCompilationResult start_time err = do
end_time <- liftIO $ getCurrentTime
warns <- getWarnings
clearWarnings
base_dir <- projectRootDir
let notes = ghcMessagesToNotes base_dir (warns, srcErrorMessages err)
return (CompilationResult False notes
(diffUTCTime end_time start_time))
modSummaryForFile :: FilePath -> ModuleGraph -> ModSummary
modSummaryForFile fname mod_graph =
case [ m | m <- mod_graph
, Just src <- [ml_hs_file (ms_location m)]
, src == fname ]
of [ m ] -> m
[] -> dieHard $ "modSummaryForFile: No ModSummary found for " ++ fname
_ -> dieHard $ "modSummaryForFile: Too many ModSummaries found for "
++ fname
removeMessagesForFile :: AbsFilePath -> CompilationResult -> ScionM CompilationResult
removeMessagesForFile fname res = return res'
where
notes = compilationNotes res
res' = res { compilationNotes = notes' }
notes' = MS.filter f notes
f note
| isValidLoc l, FileSrc fn <- locSource l = fname /= fn
| otherwise = True
where l = noteLoc note