{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Workspace -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | Represents a workspace, a work unit, which can be composed of multiple packages -- ----------------------------------------------------------------------------- module IDE.Workspaces ( workspaceNew , projectNew , workspaceOpen , projectOpen , workspaceTry , workspaceOpenThis , projectOpenThis , workspaceClose , workspaceClean , workspaceMake , workspaceActivatePackage , projectAddPackage , projectAddPackage' , workspaceRemoveProject , projectRemovePackage , workspacePackageNew , projectPackageClone , workspaceTryQuiet , workspaceNewHere , projectNewHere , projectTry , projectTryQuiet , packageTry , packageTryQuiet , backgroundMake , makePackage , fileOpen , fileOpen' ) where import Prelude () import Prelude.Compat import IDE.Core.State import Graphics.UI.Editor.Parameters (dialogRun', dialogSetDefaultResponse', dialogAddButton', Parameter(..), (<<<-), paraName, emptyParams) import Control.Monad (filterM, void, unless, when, liftM) import Data.Maybe (listToMaybe, isJust, fromJust, catMaybes) import IDE.Utils.GUIUtils (showDialog, showDialogOptions, chooseFile, chooseSaveFile, __) import System.FilePath (takeFileName, (), isAbsolute, dropFileName, makeRelative, dropExtension, takeBaseName, addExtension, takeExtension, takeDirectory, (<.>)) import Text.PrinterParser (readFields, writeFields, readParser, stringParser, intParser, mkFieldS, FieldDescriptionS(..)) import qualified Text.PrettyPrint as PP (text) import IDE.Pane.PackageEditor (packageNew', packageClone, choosePackageFile, standardSetup) import Data.List (delete) import IDE.Package (getModuleTemplate, idePackageFromPath', getPackageDescriptionAndPath, activatePackage, deactivatePackage, ideProjectFromPath) import System.Directory (doesDirectoryExist, getDirectoryContents, getHomeDirectory, createDirectoryIfMissing, doesFileExist) import System.Time (getClockTime) import qualified Control.Exception as Exc (SomeException(..), throw, Exception) import qualified Data.Map as Map (empty) import IDE.Pane.SourceBuffer (belongsToWorkspace, IDEBuffer(..), maybeActiveBuf, fileOpenThis, fileCheckAll, belongsToPackages', belongsToPackage) import Control.Applicative ((<$>)) import IDE.Build import IDE.Utils.FileUtils(myCanonicalizePath) import Control.Monad.Trans.Reader (ask, asks) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift) import qualified Data.Set as Set (toList) import Distribution.PackageDescription (hsSourceDirs) import IDE.Command.VCS.Common.Workspaces as VCSWS import qualified VCSWrapper.Common as VCS import qualified VCSGui.Common as VCSGUI import qualified IDE.Workspaces.Writer as Writer import System.Log.Logger (debugM) import IDE.Pane.Log (showDefaultLogLaunch', getLog) import IDE.LogRef (logOutputDefault) import Data.Foldable (forM_) import Data.Text (Text) import qualified Data.Text as T (unlines, isPrefixOf, lines, unpack, pack) import Data.Monoid ((<>)) import qualified Text.Printf as S (printf) import Text.Printf (PrintfType) import qualified Data.Text.IO as T (readFile, writeFile) import Control.Exception (SomeException(..), catch) import GI.Gtk.Objects.MessageDialog (setMessageDialogText, constructMessageDialogButtons, setMessageDialogMessageType, MessageDialog(..)) import GI.Gtk.Objects.Dialog (constructDialogUseHeaderBar) import GI.Gtk.Objects.Window (windowSetTransientFor, setWindowTitle, Window(..), setWindowWindowPosition, setWindowModal) import GI.Gtk.Enums (FileChooserAction(..), ResponseType(..), ButtonsType(..), WindowPosition(..), MessageType(..)) import Data.GI.Base (set, new') import GI.Gtk.Objects.Widget (widgetShow, widgetDestroy, widgetHide) import GI.Gtk.Objects.FileChooserDialog (FileChooserDialog(..)) import GI.Gtk.Interfaces.FileChooser (fileChooserGetFilename, fileChooserSetCurrentFolder, fileChooserSetAction) import IDE.Workspaces.Writer (WorkspaceFile(..)) import qualified Data.Map as M (member, delete, adjust, insert) printf :: PrintfType r => Text -> r printf = S.printf . T.unpack -- | Constructs a new workspace and makes it the current workspace workspaceNew :: IDEAction workspaceNew = do window <- getMainWindow mbFile <- liftIO $ chooseSaveFile window (__ "New file for workspace") Nothing forM_ mbFile workspaceNewHere projectNew :: WorkspaceAction projectNew = do window <- liftIDE getMainWindow mbFile <- liftIO $ chooseSaveFile window (__ "New cabal.project or stack.yaml") Nothing forM_ mbFile projectNewHere workspaceNewHere :: FilePath -> IDEAction workspaceNewHere filePath = let realPath = if takeExtension filePath == leksahWorkspaceFileExtension then filePath else addExtension filePath leksahWorkspaceFileExtension in do dir <- liftIO $ myCanonicalizePath $ dropFileName realPath let cPath = dir takeFileName realPath newWorkspace = Writer.emptyWorkspaceFile { wsfName = T.pack $ takeBaseName cPath } liftIO $ writeFields cPath newWorkspace Writer.workspaceDescr workspaceOpenThis False cPath return () projectNewHere :: FilePath -> WorkspaceAction projectNewHere filePath = let realPath | takeExtension filePath == ".project" || takeExtension filePath == ".yaml" = filePath | takeBaseName filePath == "cabal" = filePath <.> "project" | otherwise = filePath <.> "yaml" in do dir <- liftIO $ myCanonicalizePath $ dropFileName realPath let cPath = dir takeFileName realPath liftIO (doesFileExist cPath) >>= \case True -> ideMessage Normal $ __ "Project already exists : " <> T.pack cPath False -> do liftIO $ T.writeFile cPath "packages:\n" projectOpenThis cPath workspaceOpen :: IDEAction workspaceOpen = do window <- getMainWindow liftIO (chooseWorkspaceFile window) >>= mapM_ (workspaceOpenThis True) projectOpen :: WorkspaceAction projectOpen = do window <- liftIDE getMainWindow liftIO (chooseProjectFile window) >>= mapM_ projectOpenThis workspaceTryQuiet :: WorkspaceAction -> IDEAction workspaceTryQuiet f = readIDE workspace >>= \case Just ws -> runWorkspace f ws Nothing -> ideMessage Normal (__ "No workspace open") projectTryQuiet :: ProjectAction -> IDEAction projectTryQuiet f = workspaceTryQuiet $ readIDE activeProject >>= \case Just project -> runProject f project Nothing -> ideMessage Normal (__ "No project active") workspaceTry :: WorkspaceAction -> IDEAction workspaceTry f = readIDE workspace >>= \case Just ws -> runWorkspace f ws Nothing -> do mainWindow <- getMainWindow defaultWorkspace <- liftIO $ ( "leksah.lkshw") <$> getHomeDirectory defaultExists <- liftIO $ doesFileExist defaultWorkspace md <- new' MessageDialog [ constructDialogUseHeaderBar 0, constructMessageDialogButtons ButtonsTypeCancel] setWindowModal md True setMessageDialogMessageType md MessageTypeQuestion setMessageDialogText md ( __ "You need to have a workspace open for this to work. " <> __ "Choose ~/leksah.lkshw to " <> __ (if defaultExists then "open workspace " else "create a workspace ") <> T.pack defaultWorkspace) windowSetTransientFor md (Just mainWindow) dialogAddButton' md (__ "_New Workspace") (AnotherResponseType 1) dialogAddButton' md (__ "_Open Workspace") (AnotherResponseType 2) dialogAddButton' md "~/leksah.lkshw" (AnotherResponseType 3) dialogSetDefaultResponse' md (AnotherResponseType 3) setWindowWindowPosition md WindowPositionCenterOnParent resp <- dialogRun' md widgetHide md case resp of AnotherResponseType 1 -> do workspaceNew postAsyncIDE $ workspaceTryQuiet f AnotherResponseType 2 -> do workspaceOpen postAsyncIDE $ workspaceTryQuiet f AnotherResponseType 3 -> do defaultExists <- liftIO $ doesFileExist defaultWorkspace if defaultExists then workspaceOpenThis True defaultWorkspace else workspaceNewHere defaultWorkspace postAsyncIDE $ workspaceTryQuiet f _ -> return () projectTry :: ProjectAction -> IDEAction projectTry f = workspaceTry $ readIDE activeProject >>= \case Just project -> runProject f project Nothing -> do mainWindow <- liftIDE getMainWindow defaultCabal <- ( "cabal.project") . takeDirectory <$> asks wsFile defaultStack <- ( "stack.yaml") . takeDirectory <$> asks wsFile defaultCabalExists <- liftIO $ doesFileExist defaultCabal md <- new' MessageDialog [ constructDialogUseHeaderBar 0, constructMessageDialogButtons ButtonsTypeCancel] setWindowModal md True setMessageDialogMessageType md MessageTypeQuestion setMessageDialogText md ( __ "You need to have a project open for this to work. " <> __ "Choose cabal.project to " <> __ (if defaultCabalExists then "open project " else "create a workspace ") <> T.pack defaultCabal) windowSetTransientFor md (Just mainWindow) dialogAddButton' md (__ "_New Project") (AnotherResponseType 1) dialogAddButton' md (__ "_Open Project") (AnotherResponseType 2) dialogAddButton' md "cabal.project" (AnotherResponseType 3) dialogAddButton' md "stack.yaml" (AnotherResponseType 4) dialogSetDefaultResponse' md (AnotherResponseType 3) setWindowWindowPosition md WindowPositionCenterOnParent resp <- dialogRun' md widgetHide md case resp of AnotherResponseType 1 -> do projectNew postAsyncIDE $ projectTryQuiet f AnotherResponseType 2 -> do projectOpen postAsyncIDE $ projectTryQuiet f AnotherResponseType 3 -> do defaultExists <- liftIO $ doesFileExist defaultCabal if defaultExists then projectOpenThis defaultCabal else projectNewHere defaultCabal postAsyncIDE $ projectTryQuiet f _ -> return () chooseWorkspaceFile :: Window -> IO (Maybe FilePath) chooseWorkspaceFile window = chooseFile window (__ "Select leksah workspace file (.lkshw)") Nothing [("Leksah Workspace Files", ["*.lkshw"])] chooseProjectFile :: Window -> IO (Maybe FilePath) chooseProjectFile window = chooseFile window (__ "Select cabal.project or stack.yaml file") Nothing [("Haskell Project", ["*.project", "*.yaml"])] workspaceOpenThis :: Bool -> FilePath -> IDEAction workspaceOpenThis askForSession filePath = do liftIO . debugM "leksah" $ "workspaceOpenThis " ++ show askForSession ++ " " ++ filePath getMainWindow >>= open where open mainWindow = do exists <- liftIO $ doesFileExist filePath sessionExists <- liftIO $ doesFileExist sessionPath if exists then workspaceClose >> if askForSession && sessionExists then sessionDialog else openWithoutSession else showDialog (Just mainWindow) ("Could not find workspace file at " <> T.pack filePath) MessageTypeError where sessionPath = dropExtension filePath ++ leksahSessionFileExtension openWithoutSession :: IDEAction openWithoutSession = do ideR <- ask catchIDE ( Writer.readWorkspace filePath >>= \case Left errorMsg -> showDialog (Just mainWindow) (T.pack $ "Could not open " <> filePath <> ". " <> errorMsg) MessageTypeError Right workspace -> do Writer.setWorkspace (Just workspace {wsFile = filePath}) VCSWS.onWorkspaceOpen workspace) (\ (e :: Exc.SomeException) -> reflectIDE (ideMessage Normal (T.pack $ printf (__ "Can't load workspace file %s\n%s") filePath (show e))) ideR) sessionDialog :: IDEAction sessionDialog = showDialogOptions (Just mainWindow) "There are session settings stored with this workspace." MessageTypeQuestion [ ("_Ignore Session", openWithoutSession) , ("_Load Session" , void (triggerEventIDE (LoadSession sessionPath))) -- Also loads the workspace from that session ] Nothing projectOpenThis :: FilePath -> WorkspaceAction projectOpenThis filePath = do liftIO . debugM "leksah" $ "projectOpenThis " ++ filePath dir <- liftIO $ myCanonicalizePath $ dropFileName filePath let cPath = dir takeFileName filePath liftIO (doesFileExist cPath) >>= \case False -> ideMessage Normal $ __ "Project does not exists : " <> T.pack cPath True -> do ws <- ask liftIDE (ideProjectFromPath filePath) >>= \case Nothing -> ideMessage Normal $ __ "Unable to load project : " <> T.pack cPath Just project -> lift $ Writer.writeWorkspace $ ws { wsProjects = project : wsProjects ws , wsActiveProjectFile = Just cPath , wsActivePackFile = ipdCabalFile <$> listToMaybe (pjPackages project) , wsActiveComponent = Nothing } -- | Closes a workspace workspaceClose :: IDEAction workspaceClose = do liftIO $ debugM "leksah" "workspaceClose" oldWorkspace <- readIDE workspace case oldWorkspace of Nothing -> return () Just ws -> do VCSWS.onWorkspaceClose let oldActivePackFile = wsActivePackFile ws prefs <- readIDE prefs when (saveSessionOnClose prefs) $ triggerEventIDE_ (SaveSession (dropExtension (wsFile ws) ++ leksahSessionFileExtension)) addRecentlyUsedWorkspace (wsFile ws) Writer.setWorkspace Nothing when (isJust oldActivePackFile) $ do triggerEventIDE (Sensitivity [(SensitivityProjectActive, False), (SensitivityWorkspaceOpen, False)]) return () return () return () workspacePackageNew :: WorkspaceAction workspacePackageNew = do ws <- ask let path = dropFileName (wsFile ws) liftIDE . packageNew' path (wsProjects ws) logOutputDefault $ \isNew mbProject fp -> do liftIO $ debugM "leksah" $ "workspacePackageNew " <> show (isNew, pjFile <$> mbProject, fp) case mbProject of Just project -> workspaceTryQuiet . (`runProject` project) . void $ projectAddPackage' fp Nothing -> postAsyncIDE . workspaceTryQuiet $ do let packageDir = dropFileName fp liftIO (doesFileExist $ packageDir "cabal.project") >>= \case True -> projectOpenThis (packageDir "cabal.project") False -> liftIO (doesFileExist $ packageDir "stack.yaml") >>= \case True -> projectOpenThis (packageDir "stack.yaml") False -> do liftIO $ debugM "leksah" $ "workspacePackageNew show project creation dialog" window <- liftIDE getMainWindow md <- new' MessageDialog [ constructDialogUseHeaderBar 0, constructMessageDialogButtons ButtonsTypeCancel] setMessageDialogMessageType md MessageTypeQuestion setMessageDialogText md $ __ "No project file found for this package would you like to add one?" windowSetTransientFor md (Just window) dialogAddButton' md (__ "Add cabal.project") (AnotherResponseType 1) dialogAddButton' md (__ "Add stack.yaml") (AnotherResponseType 2) dialogSetDefaultResponse' md (AnotherResponseType 2) setWindowWindowPosition md WindowPositionCenterOnParent resp <- dialogRun' md widgetHide md case resp of AnotherResponseType 1 -> do liftIO $ T.writeFile (packageDir "cabal.project") "packages:\n ./\n" projectOpenThis (packageDir "cabal.project") AnotherResponseType 2 -> do liftIO $ T.writeFile (packageDir "stack.yaml") "packages:\n- '.'\n" projectOpenThis (packageDir "stack.yaml") _ -> return () when isNew $ do mbPack <- liftIDE $ idePackageFromPath' fp liftIDE $ constructAndOpenMainModules mbPack liftIDE $ triggerEventIDE_ UpdateWorkspaceInfo projectPackageClone :: ProjectAction projectPackageClone = do project <- ask let path = dropFileName (pjFile project) liftIDE . packageClone path logOutputDefault $ \fp -> projectTry $ do projectAddPackage' fp triggerEventIDE_ UpdateWorkspaceInfo constructAndOpenMainModules :: Maybe IDEPackage -> IDEAction constructAndOpenMainModules Nothing = return () constructAndOpenMainModules (Just idePackage) = forM_ (ipdMain idePackage) $ \(target, bi, isTest) -> do mbPD <- getPackageDescriptionAndPath case mbPD of Just (pd,_) -> case hsSourceDirs bi of path:_ -> do liftIO $ createDirectoryIfMissing True path alreadyExists <- liftIO $ doesFileExist (path target) unless alreadyExists $ do template <- liftIO $ getModuleTemplate (if isTest then "testmain" else "main") pd "Main" "" "" liftIO $ T.writeFile (path target) template fileOpenThis (path target) _ -> return () Nothing -> ideMessage Normal (__ "No package description") projectAddPackage :: ProjectAction projectAddPackage = do project <- ask let path = dropFileName (pjFile project) window <- liftIDE getMainWindow liftIO (choosePackageFile window (Just path)) >>= \case Nothing -> return () Just fp -> do void (projectAddPackage' fp) liftIDE $ triggerEventIDE_ UpdateWorkspaceInfo projectAddPackage' :: FilePath -> ProjectM (Maybe IDEPackage) projectAddPackage' fp = do project <- ask ws <- lift ask let projectFile = pjFile project cfp <- liftIO $ myCanonicalizePath fp liftIDE (idePackageFromPath' cfp) >>= \case Just pack -> do let indent = case pjTool project of StackTool -> "- " CabalTool -> " " projectText <- liftIO $ T.readFile projectFile let projectLines = T.lines projectText relativePath = makeRelative (dropFileName projectFile) (dropFileName cfp) case span (/= "packages:") projectLines of (before, _:rest) -> case span (indent `T.isPrefixOf`) rest of (packs, rest') -> liftIO $ T.writeFile projectFile . T.unlines $ before <> ("packages:":packs) <> [indent <> T.pack relativePath] <> rest' _ -> return () unless (cfp `elem` map ipdCabalFile (pjPackages project)) $ liftIDE $ Writer.writeWorkspace $ ws { wsProjects = map (\p -> if pjFile p == projectFile then p { pjPackageMap = M.insert (ipdCabalFile pack) pack $ pjPackageMap p } else p) (wsProjects ws) , wsActivePackFile = Just (ipdCabalFile pack) , wsActiveComponent = Nothing} return (Just pack) Nothing -> return Nothing packageTryQuiet :: PackageAction -> IDEAction packageTryQuiet f = do maybePackage <- readIDE activePack case maybePackage of Just p -> projectTryQuiet $ runPackage f p Nothing -> ideMessage Normal (__ "No active package") packageTry :: PackageAction -> IDEAction packageTry f = workspaceTry $ do maybeProject <- lift $ readIDE activeProject maybePackage <- lift $ readIDE activePack case (maybeProject, maybePackage) of (Just project, Just package) -> runProject (runPackage f package) project _ -> do window <- liftIDE getMainWindow md <- new' MessageDialog [ constructDialogUseHeaderBar 0, constructMessageDialogButtons ButtonsTypeCancel] setMessageDialogMessageType md MessageTypeQuestion setMessageDialogText md $ __ "You need to have an active package for this to work." windowSetTransientFor md (Just window) dialogAddButton' md (__ "_New Package") (AnotherResponseType 1) dialogAddButton' md (__ "_Add Package") (AnotherResponseType 2) dialogSetDefaultResponse' md (AnotherResponseType 2) setWindowWindowPosition md WindowPositionCenterOnParent resp <- dialogRun' md widgetHide md case resp of AnotherResponseType 1 -> do workspacePackageNew lift $ postAsyncIDE $ packageTryQuiet f AnotherResponseType 2 -> do workspacePackageNew lift $ postAsyncIDE $ packageTryQuiet f _ -> return () workspaceRemoveProject :: FilePath -> WorkspaceAction workspaceRemoveProject projectFile = do ws <- ask when (any ((/= projectFile) . pjFile) $ wsProjects ws) . lift $ Writer.writeWorkspace ws {wsProjects = filter ((/= projectFile) . pjFile) $ wsProjects ws} projectRemovePackage :: IDEPackage -> ProjectAction projectRemovePackage pack = do -- ws <- ask -- when (pack `elem` wsPackages ws) $ lift $ -- Writer.writeWorkspace ws {wsProjects = delete pack (wsPackages ws)} ideMessage Normal "projectRemovePackage not implemented" workspaceActivatePackage :: Project -> Maybe IDEPackage -> Maybe Text -> WorkspaceAction workspaceActivatePackage project mbPack exe = do (mbPackFile, mbExe) <- liftIDE $ case mbPack of Just pack | ipdCabalFile pack `elem` map ipdCabalFile (pjPackages project) -> do activatePackage (Just (ipdCabalFile pack)) (Just project) (Just pack) exe return (Just (ipdCabalFile pack), exe) _ -> do activatePackage Nothing (Just project) Nothing Nothing return (Nothing, Nothing) ws <- ask let projects = project : filter ((/= pjFile project) . pjFile) (wsProjects ws) liftIDE $ Writer.writeWorkspace ws {wsProjects = projects ,wsActiveProjectFile = Just (pjFile project) ,wsActivePackFile = mbPackFile ,wsActiveComponent = mbExe} addRecentlyUsedWorkspace :: FilePath -> IDEAction addRecentlyUsedWorkspace fp = do state <- readIDE currentState unless (isStartingOrClosing state) $ do recentWorkspaces' <- readIDE recentWorkspaces unless (fp `elem` recentWorkspaces') $ modifyIDE_ (\ide -> ide{recentWorkspaces = take 12 (fp : recentWorkspaces')}) triggerEventIDE UpdateRecent return () removeRecentlyUsedWorkspace :: FilePath -> IDEAction removeRecentlyUsedWorkspace fp = do state <- readIDE currentState unless (isStartingOrClosing state) $ do recentWorkspaces' <- readIDE recentWorkspaces when (fp `elem` recentWorkspaces') $ modifyIDE_ (\ide -> ide{recentWorkspaces = filter (/= fp) recentWorkspaces'}) triggerEventIDE UpdateRecent return () ------------------------ -- Workspace make workspaceClean :: WorkspaceAction workspaceClean = do ws <- ask settings <- lift $ do prefs' <- readIDE prefs return (defaultMakeSettings prefs') lift $ makePackages settings (map (\p -> (p, pjPackages p)) $ wsProjects ws) MoClean MoClean moNoOp buildSteps :: MakeSettings -> IDEM [MakeOp] buildSteps settings = do debug <- isJust <$> readIDE debugState return $ MoBuild : [MoDocu | msMakeDocs settings] ++ [MoTest | not debug && msRunUnitTests settings] ++ [MoInstall | not debug] ++ [MoBench | not debug && msRunBenchmarks settings] workspaceMake :: WorkspaceAction workspaceMake = do ws <- ask settings <- lift $ do prefs' <- readIDE prefs return ((defaultMakeSettings prefs'){ msMakeMode = True, msBackgroundBuild = False}) build <- lift . buildSteps $ settings lift $ makePackages settings (map (\p -> (p, pjPackages p)) $ wsProjects ws) (MoComposed build) (MoComposed build) MoMetaInfo backgroundMake :: IDEAction backgroundMake = catchIDE (do ideR <- ask prefs <- readIDE prefs debug <- isJust <$> readIDE debugState modifiedFiles <- catMaybes <$> if saveAllBeforeBuild prefs then fileCheckAll (return . return . fileName) else return [] workspaceTryQuiet $ do ws <- ask liftIDE $ do let modifiedPacks = filter (not . null . snd) $ map (\project -> (project, filter (\pack -> any (`belongsToPackage` pack) modifiedFiles) (pjPackages project))) (wsProjects ws) settings = defaultMakeSettings prefs steps <- buildSteps settings if debug || msSingleBuildWithoutLinking settings && not (msMakeMode settings) then makePackages settings modifiedPacks (MoComposed steps) (MoComposed []) moNoOp else makePackages settings modifiedPacks (MoComposed steps) (MoComposed steps) MoMetaInfo ) (\(e :: Exc.SomeException) -> sysMessage Normal (T.pack $ show e)) makePackage :: PackageAction makePackage = do liftIO $ debugM "leksah" "makePackage" p <- ask project <- lift ask liftIDE $ do getLog >>= bringPaneToFront showDefaultLogLaunch' prefs' <- readIDE prefs mbWs <- readIDE workspace let settings = (defaultMakeSettings prefs'){msBackgroundBuild = False} debug <- isJust <$> readIDE debugState steps <- buildSteps settings if debug || msSingleBuildWithoutLinking settings && not (msMakeMode settings) then makePackages settings [(project, [p])] (MoComposed steps) (MoComposed []) moNoOp else makePackages settings [(project, [p])] (MoComposed steps) (MoComposed steps) MoMetaInfo fileOpen :: IDEAction fileOpen = do window <- getMainWindow prefs <- readIDE prefs mbBuf <- maybeActiveBuf dialog <- new' FileChooserDialog [constructDialogUseHeaderBar 1] setWindowTitle dialog $ __ "Open File" windowSetTransientFor dialog $ Just window fileChooserSetAction dialog FileChooserActionOpen dialogAddButton' dialog "gtk-cancel" ResponseTypeCancel dialogAddButton' dialog "gtk-open" ResponseTypeAccept case mbBuf >>= fileName of Just fn -> void (fileChooserSetCurrentFolder dialog (dropFileName fn)) Nothing -> return () widgetShow dialog response <- dialogRun' dialog when (response == ResponseTypeAccept) $ fileChooserGetFilename dialog >>= mapM_ fileOpen' widgetDestroy dialog fileOpen' :: FilePath -> IDEAction fileOpen' fp = do window <- getMainWindow knownFile <- belongsToWorkspace fp unless knownFile $ if takeExtension fp == ".cabal" then do md <- new' MessageDialog [ constructDialogUseHeaderBar 0, constructMessageDialogButtons ButtonsTypeNone] setMessageDialogMessageType md MessageTypeQuestion setMessageDialogText md (__ "Would you like to add the package " <> T.pack fp <> __ " to the active project so that it can be built by Leksah?") windowSetTransientFor md (Just window) dialogAddButton' md (__ "_Add " <> T.pack (takeFileName fp)) (AnotherResponseType 1) dialogAddButton' md (__ "Just _open " <> T.pack (takeFileName fp)) (AnotherResponseType 2) dialogSetDefaultResponse' md (AnotherResponseType 1) resp <- dialogRun' md widgetDestroy md case resp of AnotherResponseType 1 -> projectTry $ do projectAddPackage' fp return () _ -> return () else liftIO (findCabalFile fp) >>= \case Nothing -> return () Just cabalFile -> do md <- new' MessageDialog [ constructDialogUseHeaderBar 0, constructMessageDialogButtons ButtonsTypeNone] setMessageDialogMessageType md MessageTypeQuestion setMessageDialogText md (__ "The file " <> T.pack fp <> __ " seems to belong to the package " <> T.pack cabalFile <> __ " would you like to add " <> T.pack (takeFileName cabalFile) <> __ " to your active project?") windowSetTransientFor md (Just window) dialogAddButton' md (__ "_Add " <> T.pack (takeFileName cabalFile)) (AnotherResponseType 1) dialogAddButton' md (__ "Just _open " <> T.pack (takeFileName fp)) (AnotherResponseType 2) dialogSetDefaultResponse' md (AnotherResponseType 1) resp <- dialogRun' md widgetDestroy md case resp of AnotherResponseType 1 -> projectTry $ do projectAddPackage' cabalFile return () _ -> return () fileOpenThis fp where findCabalFile :: FilePath -> IO (Maybe FilePath) findCabalFile fp = (do let dir = takeDirectory fp contents <- getDirectoryContents dir files <- filterM (\f -> not <$> doesDirectoryExist (dir f)) contents let cabal = filter ((== ".cabal") . takeExtension) files case cabal of (c:_) -> return . Just $ dir c _ | fp == dir -> return Nothing | otherwise -> findCabalFile dir ) `catch` (\(_ :: SomeException) -> return Nothing)