diff --git a/data/main.lksht b/data/main.lksht --- a/data/main.lksht +++ b/data/main.lksht @@ -16,12 +16,16 @@ main ) where -import Data.List (stripPrefix) +-- This strang looking comment adds code only needed when running the +-- doctest tests embedded in the comments +-- $setup +-- >>> import Data.List (stripPrefix) -- | Simple function to create a hello message. -- prop> stripPrefix "Hello " (hello s) == Just s +hello :: String -> String hello s = "Hello " ++ s -main = do - putStrLn (hello "World") +main :: IO () +main = putStrLn (hello "World") diff --git a/data/testmain.lksht b/data/testmain.lksht --- a/data/testmain.lksht +++ b/data/testmain.lksht @@ -18,6 +18,7 @@ import Test.DocTest +main :: IO () main = doctest ["-isrc", "src/Main.hs"] diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -1,5 +1,5 @@ name: leksah -version: 0.15.1.3 +version: 0.15.1.4 cabal-version: >=1.18 build-type: Simple license: GPL @@ -305,11 +305,11 @@ IDE.TextEditor.GtkSourceView IDE.Utils.ExternalTool build-depends: - gtk3 >=0.13.9 && <0.15, + gtk3 >=0.14.1 && <0.15, gtksourceview3 >=0.13.1.5 && <0.14, webkitgtk3 >=0.13 && <0.15, webkitgtk3-javascriptcore -any, - jsaddle -any, + jsaddle >=0.2.1.0 && <0.3, ghcjs-codemirror -any, blaze-html -any, lens -any, @@ -332,11 +332,11 @@ utf8-string >=0.3.1.1 && <1.1, array >=0.2.0.0 && <0.6, time >=0.1 && <1.6, - ltk >=0.15.0.2 && <0.16, + ltk >=0.15.0.4 && <0.16, binary-shared >=0.8 && <0.9, deepseq >=1.1.0.0 && <1.5, hslogger >=1.0.7 && <1.3, - leksah-server >=0.15.0.6 && <0.16, + leksah-server >=0.15.0.8 && <0.16, ghc >=6.10.1 && <7.11, strict >=0.3.2 && <0.4, conduit >=1.0.8 && <1.3, @@ -389,9 +389,9 @@ ghc-options: -optl-headerpad_max_install_names main-is: Main.hs build-depends: - leksah ==0.15.1.3, + leksah ==0.15.1.4, base >=4.0.0.0 && <=4.9, - gtk3 >=0.13.9 && <0.15, + gtk3 >=0.14.1 && <0.15, stm >=2.4.4 && <2.5 default-language: Haskell2010 hs-source-dirs: main @@ -400,11 +400,11 @@ executable bewleksah main-is: Main.hs build-depends: - leksah ==0.15.1.3, + leksah ==0.15.1.4, base >=4.0.0.0 && <=4.9, jsaddle -any, - ghcjs-dom -any, - gtk3 >=0.13.9 && <0.15, + ghcjs-dom >=0.2.1.0 && <0.3, + gtk3 >=0.14.1 && <0.15, gtksourceview3 >=0.13.1.5 && <0.14, webkitgtk3 >=0.13 && <0.15, webkitgtk3-javascriptcore -any, @@ -423,7 +423,7 @@ base >=4.0.0.0 && <4.9, Cabal >=1.10.2.0 && <1.23, QuickCheck >=2.4.2 && <2.9, - leksah ==0.15.1.3, + leksah ==0.15.1.4, containers -any, ltk -any, leksah-server -any, @@ -432,7 +432,7 @@ glib -any, monad-loops -any, text -any, - gtk3 >=0.13.9 && <0.15, + gtk3 >=0.14.1 && <0.15, gtksourceview3 >=0.13.1.5 && <0.14, webkitgtk3 -any, stm >=2.4.4 && <2.5 diff --git a/osx/launcher.sh b/osx/launcher.sh --- a/osx/launcher.sh +++ b/osx/launcher.sh @@ -1,4 +1,4 @@ -#!/bin/sh +#!/bin/bash if test -e ~/.bash_profile; then . ~/.bash_profile diff --git a/osx/makedmg.sh b/osx/makedmg.sh --- a/osx/makedmg.sh +++ b/osx/makedmg.sh @@ -27,9 +27,7 @@ sed -e 's|\|\|' \ -e 's|\|\|' \ - -e 's|^--\x |\x |' \ - -e 's|^--\c |\c |' \ - -e 's|^--\v |\v |' \ + -e 's|^\q |--\q |' \ osx/keymap.lkshk cat osx/osxkeymap.lkshk >>osx/keymap.lkshk diff --git a/osx/makedmgs.sh b/osx/makedmgs.sh --- a/osx/makedmgs.sh +++ b/osx/makedmgs.sh @@ -1,8 +1,8 @@ #!/bin/sh -ex -#export GHCVERSION=-7.8.3 -#scripts/clean.sh -#osx/makedmg.sh +export GHCVERSION=-7.8.3 +scripts/clean.sh +osx/makedmg.sh export GHCVERSION=-7.10.1 scripts/clean.sh osx/makedmg.sh diff --git a/scripts/clean.sh b/scripts/clean.sh --- a/scripts/clean.sh +++ b/scripts/clean.sh @@ -10,8 +10,18 @@ ghc-pkg$GHCVERSION unregister --force jsaddle || true ghc-pkg$GHCVERSION unregister --force gtksourceview2 || true ghc-pkg$GHCVERSION unregister --force gtksourceview3 || true +ghc-pkg$GHCVERSION unregister --force webkit-javascriptcore || true +ghc-pkg$GHCVERSION unregister --force webkitgtk3-javascriptcore || true +ghc-pkg$GHCVERSION unregister --force webkit || true +ghc-pkg$GHCVERSION unregister --force webkitgtk3 || true ghc-pkg$GHCVERSION unregister --force gtk-mac-integration || true ghc-pkg$GHCVERSION unregister --force gtk3-mac-integration || true +ghc-pkg$GHCVERSION unregister --force gtk || true +ghc-pkg$GHCVERSION unregister --force gtk3 || true +ghc-pkg$GHCVERSION unregister --force pango || true +ghc-pkg$GHCVERSION unregister --force cairo || true +ghc-pkg$GHCVERSION unregister --force gio || true +ghc-pkg$GHCVERSION unregister --force glib || true ghc-pkg$GHCVERSION unregister --force hlint || true rm -rf vendor/*/dist \ diff --git a/src/IDE/Command.hs b/src/IDE/Command.hs --- a/src/IDE/Command.hs +++ b/src/IDE/Command.hs @@ -516,7 +516,7 @@ fe <- doesFileExist s when fe $ do mi <- menuItemNewWithLabel $ T.pack s - mi `on` menuItemActivate $ reflectIDE (fileOpenThis s) ideR + mi `on` menuItemActivate $ reflectIDE (fileOpen' s) ideR menuShellAppend recentFilesMenu mi) recentFiles' oldSubmenu <- menuItemGetSubmenu recentFilesItem when (isJust oldSubmenu) $ do @@ -721,7 +721,7 @@ getActionsFor SensitivityError = getActionsFor' ["NextError", "PreviousError"] getActionsFor SensitivityEditor = getActionsFor' ["EditUndo", "EditRedo", "EditGotoLine","EditComment", "EditUncomment", - "EditShiftLeft", "EditShiftRight","FileClose","ResolveErrors", + "EditShiftLeft", "EditShiftRight","FileClose", "OpenDocu" ] getActionsFor SensitivityInterpreting = getActionsFor' ["QuitDebugger"] diff --git a/src/IDE/Completion.hs b/src/IDE/Completion.hs --- a/src/IDE/Completion.hs +++ b/src/IDE/Completion.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables, OverloadedStrings, LambdaCase #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Completion @@ -36,6 +36,7 @@ import qualified Data.Text as T (empty, commonPrefixes, pack, unpack, null, stripPrefix, isPrefixOf) +import System.Log.Logger (debugM) complete :: TextEditor editor => EditorView editor -> Bool -> IDEAction complete sourceView always = do @@ -181,47 +182,47 @@ selection <- liftIO $ treeViewGetSelection tree count <- liftIO $ treeModelIterNChildren model Nothing Just column <- liftIO $ treeViewGetColumn tree 0 + let whenVisible f = liftIO (get tree widgetVisible) >>= \case + True -> f + False -> return False + down = whenVisible $ do + maybeRow <- liftIO $ getRow tree + let newRow = maybe 0 (+ 1) maybeRow + when (newRow < count) . liftIO $ do + treeSelectionSelectPath selection [newRow] + treeViewScrollToCell tree (Just [newRow]) Nothing Nothing + return True + up = whenVisible $ do + maybeRow <- liftIO $ getRow tree + let newRow = maybe 0 (\ row -> row - 1) maybeRow + when (newRow >= 0) . liftIO $ do + treeSelectionSelectPath selection [newRow] + treeViewScrollToCell tree (Just [newRow]) Nothing Nothing + return True case (name, modifier, char) of - ("Tab", _, _) -> do visible <- liftIO $ get tree widgetVisible - if visible then - (do liftIDE $ - tryToUpdateOptions window tree store sourceView True isWordChar - always - return True) - else return False - ("Return", _, _) -> do visible <- liftIO $ get tree widgetVisible - if visible then - (do maybeRow <- liftIO $ getRow tree - case maybeRow of - Just row -> do liftIO $ treeViewRowActivated tree [row] column - return True - Nothing -> do liftIDE cancel - return False) - else return False - ("Down", _, _) -> do visible <- liftIO $ get tree widgetVisible - if visible then - (do maybeRow <- liftIO $ getRow tree - let newRow = maybe 0 (+ 1) maybeRow - when (newRow < count) $ - liftIO $ - do treeSelectionSelectPath selection [newRow] - treeViewScrollToCell tree (Just [newRow]) Nothing Nothing - return True) - else return False - ("Up", _, _) -> do visible <- liftIO $ get tree widgetVisible - if visible then - (do maybeRow <- liftIO $ getRow tree - let newRow = maybe 0 (\ row -> row - 1) maybeRow - when (newRow >= 0) $ - liftIO $ - do treeSelectionSelectPath selection [newRow] - treeViewScrollToCell tree (Just [newRow]) Nothing Nothing - return True) - else return False + ("Tab", _, _) -> whenVisible . liftIDE $ do + tryToUpdateOptions window tree store sourceView True isWordChar always + return True + ("Return", _, _) -> whenVisible $ do + maybeRow <- liftIO $ getRow tree + case maybeRow of + Just row -> do + liftIO $ treeViewRowActivated tree [row] column + return True + Nothing -> do + liftIDE cancel + return False + ("Down", _, _) -> down + ("Up", _, _) -> up + (super, _, Just 'a') | super `elem` ["Super_L", "Super_R"] -> do + liftIO $ debugM "leksah" "Completion - Super 'a' key press" + down + (super, _, Just 'l') | super `elem` ["Super_L", "Super_R"] -> do + liftIO $ debugM "leksah" "Completion - Super 'l' key press" + up (_, _, Just c) | isWordChar c -> return False ("BackSpace", _, _) -> return False - (shift, _, _) | (shift == "Shift_L") || (shift == "Shift_R") -> - return False + (key, _, _) | key `elem` ["Shift_L", "Shift_R", "Super_L", "Super_R"] -> return False _ -> do liftIDE cancel return False diff --git a/src/IDE/Core/State.hs b/src/IDE/Core/State.hs --- a/src/IDE/Core/State.hs +++ b/src/IDE/Core/State.hs @@ -427,6 +427,9 @@ Nothing -> return () Just (n,_) -> when (n == paneName pane) deactivatePane +-- | Replaces an 'IDEPackage' in the workspace by the given 'IDEPackage' and +-- replaces the current package if it matches. +-- Comparison is done based on the package's build directory. changePackage :: IDEPackage -> IDEAction changePackage ideP = do oldWorkspace <- readIDE workspace diff --git a/src/IDE/Core/Types.hs b/src/IDE/Core/Types.hs --- a/src/IDE/Core/Types.hs +++ b/src/IDE/Core/Types.hs @@ -156,7 +156,7 @@ , workspace :: Maybe Workspace -- ^ may be a workspace (set of packages) , activePack :: Maybe IDEPackage , activeExe :: Maybe Text -, bufferProjCache :: Map FilePath [IDEPackage] +, bufferProjCache :: Map FilePath [IDEPackage] -- ^ cache the associated packages for a file , allLogRefs :: Seq LogRef , currentEBC :: (Maybe LogRef, Maybe LogRef, Maybe LogRef) , currentHist :: Int @@ -561,10 +561,13 @@ logBuffer :: TextBuffer } deriving Typeable + -- Order determines priority of the icons in the gutter data LogRefType = ContextRef | BreakpointRef | ErrorRef | TestFailureRef | WarningRef | LintRef deriving (Eq, Ord, Show, Enum, Bounded) + +-- | Represents a message about a part of the source code data LogRef = LogRef { logRefSrcSpan :: SrcSpan , logRefPackage :: IDEPackage diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs --- a/src/IDE/Find.hs +++ b/src/IDE/Find.hs @@ -86,6 +86,7 @@ import qualified Data.Text as T (pack, unpack, singleton, isPrefixOf, length, null, toLower) import Data.Monoid ((<>)) +import Graphics.UI.Gtk.Entry.Entry (entrySetPlaceholderText) foreign import ccall safe "gtk_toolbar_set_icon_size" gtk_toolbar_set_icon_size :: Ptr Toolbar -> CInt -> IO () @@ -240,15 +241,11 @@ replaceTool <- toolItemNew rentry <- entryNew widgetSetName rentry ("replaceEntry" :: Text) + entrySetPlaceholderText rentry $ Just ("Replace with" :: Text) containerAdd replaceTool rentry widgetSetName replaceTool ("replaceTool" :: Text) toolbarInsert toolbar replaceTool 0 - labelTool2 <- toolItemNew - label2 <- labelNew (Just (__"Replace: ")) - containerAdd labelTool2 label2 - toolbarInsert toolbar labelTool2 0 - sep2 <- separatorToolItemNew toolbarInsert toolbar sep2 0 @@ -271,6 +268,7 @@ entryTool <- toolItemNew entry <- entryNew widgetSetName entry ("searchEntry" :: Text) + entrySetPlaceholderText entry $ Just ("Find" :: Text) containerAdd entryTool entry widgetSetName entryTool ("searchEntryTool" :: Text) toolItemSetExpand entryTool True @@ -317,11 +315,6 @@ doSearch toolbar Insert ideR set caseSensitiveButton [widgetTooltipText := Just (__"When selected the search is case sensitive")] - labelTool <- toolItemNew - label <- labelNew (Just (__"Find: ")) - containerAdd labelTool label - toolbarInsert toolbar labelTool 0 - after entry insertText (\ (t::Text) i -> do doSearch toolbar Insert ideR return i) @@ -407,8 +400,6 @@ set toolbar [toolbarChildHomogeneous caseSensitiveButton := False] set toolbar [toolbarChildHomogeneous regexButton := False] set toolbar [toolbarChildHomogeneous replaceAllButton := False] - set toolbar [toolbarChildHomogeneous labelTool := False] - set toolbar [toolbarChildHomogeneous labelTool2 := False] set toolbar [toolbarChildHomogeneous labelTool3 := False] reflectIDE (modifyIDE_ (\ ide -> ide{findbar = (False, Just (toolbar, store))})) ideR diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs --- a/src/IDE/ImportTool.hs +++ b/src/IDE/ImportTool.hs @@ -41,7 +41,8 @@ import Text.ParserCombinators.Parsec hiding (parse) import qualified Text.ParserCombinators.Parsec as Parsec (parse) import Graphics.UI.Editor.Simple (staticListEditor) -import Control.Monad (void, MonadPlus(..), unless, forM, when) +import Control.Monad + (forM_, void, MonadPlus(..), unless, forM, when) import Control.Applicative ((<$>)) import Data.List (stripPrefix, sort, nub, nubBy) import IDE.Utils.ServerConnection @@ -92,19 +93,19 @@ let buildInBackground = backgroundBuild prefs' when buildInBackground $ modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = False}}) - errors <- readIDE errorRefs - addPackageResults <- Tr.forM errors addPackage + errors <- F.toList <$> readIDE errorRefs + addPackageResult <- addPackages errors let notInScopes = [ y | (x,y) <- nubBy (\ (p1,_) (p2,_) -> p1 == p2) - [(x,y) | (x,y) <- [((parseNotInScope . refDescription) e, e) | e <- F.toList errors]], + [(x,y) | (x,y) <- [((parseNotInScope . refDescription) e, e) | e <- errors]], isJust x] let extensions = [ y | (x,y) <- nubBy (\ (p1,_) (p2,_) -> p1 == p2) - [(x,y) | (x,y) <- [((parsePerhapsYouIntendedToUse . refDescription) e, e) | e <- F.toList errors]], + [(x,y) | (x,y) <- [((parsePerhapsYouIntendedToUse . refDescription) e, e) | e <- errors]], length x == 1] - addAll addPackageResults buildInBackground notInScopes extensions + addAll addPackageResult buildInBackground notInScopes extensions where - addAll addPackageResults buildInBackground notInScopes extensions = addAllImports notInScopes (True,[]) + addAll addPackageResult buildInBackground notInScopes extensions = addAllImports notInScopes (True,[]) where addAllImports :: [LogRef] -> (Bool,[Descr]) -> IDEM () addAllImports (errorSpec:rest) (True,descrList) = addImport errorSpec descrList (addAllImports rest) @@ -118,7 +119,7 @@ when buildInBackground $ do prefs' <- readIDE prefs modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = True}}) - when (not (F.or addPackageResults) && null notInScopes && null extensions) $ do + when (not addPackageResult && null notInScopes && null extensions) $ do hlintResolved <- resolveActiveHLint unless hlintResolved $ ideMessage Normal "No errors, warnings or selected hlints that can be auto resolved" @@ -182,45 +183,49 @@ else addImport' nis (logRefFullFilePath error) descr descrList continuation -addPackage :: LogRef -> IDEM Bool -addPackage error = - case parseHiddenModule $ refDescription error of - Nothing -> return False - Just (HiddenModuleResult mod pack) -> do - let idePackage = logRefPackage error - gpd <- liftIO $ readPackageDescription normal (ipdCabalFile idePackage) - ideMessage Normal $ "addPackage " <> (T.pack . display $ pkgName pack) - liftIO $ writeGenericPackageDescription (ipdCabalFile idePackage) - gpd { condLibrary = addDepToLib pack (condLibrary gpd), - condExecutables = map (addDepToExe pack) - (condExecutables gpd), - condTestSuites = map (addDepToTest pack) - (condTestSuites gpd), - condBenchmarks = map (addDepToBenchmark pack) - (condBenchmarks gpd)} - return True +addPackages :: [LogRef] -> IDEM Bool +addPackages errors = do + let packs = nub $ mapMaybe (\error -> + case parseHiddenModule $ refDescription error of + Nothing -> Nothing + Just (HiddenModuleResult _ pack) -> Just (ipdCabalFile (logRefPackage error), dep pack)) errors + + forM_ packs $ \(cabalFile, d) -> do + gpd <- liftIO $ readPackageDescription normal cabalFile + ideMessage Normal $ "Adding build-depends " <> T.pack (display d <> " to " <> cabalFile) + liftIO $ writeGenericPackageDescription cabalFile + gpd { condLibrary = addDepToLib d (condLibrary gpd), + condExecutables = map (addDepToExe d) + (condExecutables gpd), + condTestSuites = map (addDepToTest d) + (condTestSuites gpd), + condBenchmarks = map (addDepToBenchmark d) + (condBenchmarks gpd)} + return True + + return . not $ null packs where addDepToLib _ Nothing = Nothing - addDepToLib p (Just cn@CondNode{ + addDepToLib d (Just cn@CondNode{ condTreeConstraints = deps, condTreeData = lib@Library{libBuildInfo = bi}}) = Just (cn{ - condTreeConstraints = deps <> [dep p], - condTreeData = lib {libBuildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [dep p]}}}) - addDepToExe p (str,cn@CondNode{ + condTreeConstraints = deps <> [d], + condTreeData = lib {libBuildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [d]}}}) + addDepToExe d (str,cn@CondNode{ condTreeConstraints = deps, condTreeData = exe@Executable{buildInfo = bi}}) = (str,cn{ - condTreeConstraints = deps <> [dep p], - condTreeData = exe { buildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [dep p]}}}) - addDepToTest p (str,cn@CondNode{ + condTreeConstraints = deps <> [d], + condTreeData = exe { buildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [d]}}}) + addDepToTest d (str,cn@CondNode{ condTreeConstraints = deps, condTreeData = test@TestSuite{testBuildInfo = bi}}) = (str,cn{ - condTreeConstraints = deps <> [dep p], - condTreeData = test { testBuildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [dep p]}}}) - addDepToBenchmark p (str,cn@CondNode{ + condTreeConstraints = deps <> [d], + condTreeData = test { testBuildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [d]}}}) + addDepToBenchmark d (str,cn@CondNode{ condTreeConstraints = deps, condTreeData = bm@Benchmark{benchmarkBuildInfo = bi}}) = (str,cn{ - condTreeConstraints = deps <> [dep p], - condTreeData = bm { benchmarkBuildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [dep p]}}}) + condTreeConstraints = deps <> [d], + condTreeData = bm { benchmarkBuildInfo = bi {targetBuildDepends = targetBuildDepends bi <> [d]}}}) -- Empty version is probably only going to happen for ghc-prim dep p | null . versionBranch $ packageVersion p = Dependency (packageName p) anyVersion dep p = Dependency (packageName p) ( @@ -238,7 +243,7 @@ case mbActiveBuf of Nothing -> return Nothing Just buf -> do - packages <- belongsToPackages buf + packages <- belongsToPackages' buf case packages of [] -> return Nothing pack:_ -> getPackageImportInfo pack @@ -547,7 +552,7 @@ when (isJust $ parseNotInScope msg) $ addFixMenuItem (__"Add Import") $ addImport logRef [] (\ _ -> return ()) when (isJust $ parseHiddenModule msg) $ - addFixMenuItem (__"Add Package") $ addPackage logRef + addFixMenuItem (__"Add Package") $ addPackages [logRef] when (length (parsePerhapsYouIntendedToUse msg) == 1) $ addFixMenuItem (__"Add Extension") $ addExtension logRef (\ _ -> return ()) where diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -184,7 +184,7 @@ where run = do prefs <- readIDE prefs - when (saveAllBeforeBuild prefs) . liftIDE . void $ fileSaveAll belongsToWorkspace + when (saveAllBeforeBuild prefs) . liftIDE . void $ fileSaveAll belongsToWorkspace' action packageConfig :: PackageAction @@ -269,7 +269,7 @@ return False) priorityDefault 100 return () else do - when (saveAllBeforeBuild prefs) . liftIDE . void $ fileSaveAll belongsToWorkspace + when (saveAllBeforeBuild prefs) . liftIDE . void $ fileSaveAll belongsToWorkspace' runCabalBuild backgroundBuild jumpToWarnings withoutLinking package True $ \f -> do when f $ do mbURI <- readIDE autoURI @@ -282,7 +282,7 @@ ready <- liftIO $ isEmptyMVar (currentToolCommand ghci) when ready $ do let dir = ipdBuildDir package - when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace; return ()) + when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace'; return ()) (`runDebug` debug) . executeDebugCommand ":reload" $ do errs <- logOutputForBuild package backgroundBuild jumpToWarnings unless (any isError errs) $ do @@ -416,6 +416,7 @@ let defaultLogName = T.pack . display . pkgName $ ipdPackageId package logName = fromMaybe defaultLogName . listToMaybe $ map (T.pack . exeName) exe (logLaunch,logName) <- buildLogLaunchByName logName + showLog case maybeDebug of Nothing -> do let dir = ipdBuildDir package @@ -800,7 +801,7 @@ modifyIDE_ (\ide -> ide {debugState = Nothing, autoCommand = return ()}) triggerEventIDE (Sensitivity [(SensitivityInterpreting, False)]) -- Kick of a build if one is not already due - modifiedPacks <- fileCheckAll belongsToPackages + modifiedPacks <- fileCheckAll belongsToPackages' let modified = not (null modifiedPacks) prefs <- readIDE prefs when (not modified && backgroundBuild prefs) $ do diff --git a/src/IDE/Pane/Breakpoints.hs b/src/IDE/Pane/Breakpoints.hs --- a/src/IDE/Pane/Breakpoints.hs +++ b/src/IDE/Pane/Breakpoints.hs @@ -13,7 +13,7 @@ -- Stability : provisional -- Portability : -- --- | +-- | A pane to display the set breakpoints -- ----------------------------------------------------------------------------- @@ -44,18 +44,19 @@ import qualified Data.Sequence as Seq (elemIndexL) --- | A breakpoints pane description --- +-- | Represents the Breakpoints pane data IDEBreakpoints = IDEBreakpoints { scrolledView :: ScrolledWindow , treeView :: TreeView , breakpoints :: TreeStore LogRef } deriving Typeable -data BreakpointsState = BreakpointsState { -} deriving(Eq,Ord,Read,Show,Typeable) +-- | The additional state used when recovering the pane +data BreakpointsState = BreakpointsState + deriving(Eq,Ord,Read,Show,Typeable) + instance Pane IDEBreakpoints IDEM where primPaneName _ = __ "Breakpoints" @@ -63,6 +64,7 @@ getTopWidget = castToWidget . scrolledView paneId b = "*Breakpoints" + instance RecoverablePane IDEBreakpoints BreakpointsState IDEM where saveState p = return (Just BreakpointsState) recoverState pp BreakpointsState = do @@ -110,14 +112,20 @@ cid4 <- treeView `on` rowActivated $ breakpointsSelect ideR breakpoints return (Just pane, map ConnectC [cid1, cid2, cid3, cid4]) + +-- | Get the Breakpoints pane getBreakpoints :: IDEM IDEBreakpoints getBreakpoints = forceGetPane (Right "*Breakpoints") + +-- | Display the Breakpoints pane showBreakpoints :: IDEAction showBreakpoints = do pane <- getBreakpoints displayPane pane False + +-- | Fill the pane with the breakpoint 'LogRef's from the IDE state fillBreakpointList :: IDEAction fillBreakpointList = do mbBreakpoints <- getPane @@ -130,6 +138,8 @@ mapM_ (\ (lr,index) -> treeStoreInsert (breakpoints b) [] index lr) (zip (F.toList refs) [0..]) + +-- | Try to get the currently selected breakpoint getSelectedBreakpoint :: TreeView -> TreeStore LogRef -> IO (Maybe LogRef) @@ -142,7 +152,10 @@ return (Just val) _ -> return Nothing -selectBreak :: Maybe LogRef -> IDEAction + +-- | Select a specific 'LogRef' or none at all +selectBreak :: Maybe LogRef -- If @Nothing@, no breakpoints are selected + -> IDEAction selectBreak mbLogRef = do breakRefs' <- readIDE breakpointRefs breaks <- forceGetPane (Right "*Breakpoints") @@ -154,6 +167,8 @@ Nothing -> return () Just ind -> treeSelectionSelectPath selection [ind] + +-- | Constructs the context menu for the breakpoint breakpointsContextMenu :: IDERef -> TreeStore LogRef -> TreeView @@ -175,6 +190,8 @@ castToMenuItem item2, castToMenuItem item3] +-- | Set the current breakpoint to a specific entry +-- pointed to by the supplied 'TreePath' breakpointsSelect :: IDERef -> TreeStore LogRef -> TreePath @@ -185,6 +202,7 @@ reflectIDE (setCurrentBreak (Just ref)) ideR +-- | Remove a breakpoint from the pane deleteBreakpoint :: LogRef -> IDEAction deleteBreakpoint logRef = case logRefType logRef of diff --git a/src/IDE/Pane/Errors.hs b/src/IDE/Pane/Errors.hs --- a/src/IDE/Pane/Errors.hs +++ b/src/IDE/Pane/Errors.hs @@ -44,34 +44,42 @@ import qualified Data.Foldable as F (toList) import qualified Data.Sequence as Seq (null, elemIndexL) --- | A breakpoints pane description --- + +-- | The representation of the Errors pane data IDEErrors = IDEErrors { scrolledView :: ScrolledWindow , treeView :: TreeView , errorStore :: ListStore ErrColumn -, autoClose :: IORef Bool -- If the pane was only displayed to show current error +, autoClose :: IORef Bool -- ^ If the pane was only displayed to show current error } deriving Typeable + +-- | The data for a single row in the Errors pane data ErrColumn = ErrColumn { logRef :: LogRef, background :: Text} -data ErrorsState = ErrorsState { -} deriving(Eq,Ord,Read,Show,Typeable) +-- | The additional state used when recovering the pane +data ErrorsState = ErrorsState + deriving (Eq,Ord,Read,Show,Typeable) + + instance Pane IDEErrors IDEM where primPaneName _ = __ "Errors" getTopWidget = castToWidget . scrolledView paneId _b = "*Errors" + instance RecoverablePane IDEErrors ErrorsState IDEM where saveState _p = return (Just ErrorsState) recoverState pp ErrorsState = do nb <- getNotebook pp buildPane pp nb builder builder = builder' +-- | Builds an 'IDEErrors' pane together with a list of +-- event 'Connections' builder' :: PanePath -> Notebook -> Window -> @@ -120,19 +128,29 @@ reflectIDE (fillErrorList' pane) ideR return (Just pane, map ConnectC [cid1, cid2, cid3, cid4]) + +-- | Removes the unnecessary indentation +removeIndentation :: Text -> Text removeIndentation t = T.intercalate "\n" $ map (T.drop minIndent) l where l = T.lines t minIndent = minimum $ map (T.length . T.takeWhile (== ' ')) l + +-- | Get the Errors pane getErrors :: Maybe PanePath -> IDEM IDEErrors getErrors Nothing = forceGetPane (Right "*Errors") getErrors (Just pp) = forceGetPane (Left pp) -fillErrorList :: Bool -> IDEAction + +-- | Repopulates the Errors pane +fillErrorList :: Bool -- ^ Whether to display the Errors pane + -> IDEAction fillErrorList False = getPane >>= maybe (return ()) fillErrorList' fillErrorList True = getErrors Nothing >>= \ p -> fillErrorList' p >> displayPane p False + +-- | Fills the pane with the error list from the IDE state fillErrorList' :: IDEErrors -> IDEAction fillErrorList' pane = do refs <- readIDE errorRefs @@ -151,10 +169,17 @@ LintRef -> (("#003000", "#002800"), ("#DBFFDB", "#EDFFED")) _ -> (("#380000", "#280000"), ("#FFDEDE", "#FFEBEB"))) -addErrorToList :: Bool -> Int -> LogRef -> IDEAction + +-- | Add any LogRef to the Errors pane at a given index +addErrorToList :: Bool -- ^ Whether to display the pane + -> Int -- ^ The index to insert at + -> LogRef + -> IDEAction addErrorToList False index lr = getPane >>= maybe (return ()) (addErrorToList' index lr) addErrorToList True index lr = getErrors Nothing >>= \ p -> addErrorToList' index lr p >> displayPane p False + +-- | Add a 'LogRef' at a specific index to the Errors pane addErrorToList' :: Int -> LogRef -> IDEErrors -> IDEAction addErrorToList' index lr pane = do -- refs <- readIDE errorRefs @@ -173,6 +198,8 @@ LintRef -> (("#003000", "#002800"), ("#DBFFDB", "#EDFFED")) _ -> (("#380000", "#280000"), ("#FFDEDE", "#FFEBEB"))) + +-- | Get the currently selected error getSelectedError :: TreeView -> ListStore ErrColumn -> IO (Maybe LogRef) @@ -185,7 +212,9 @@ return (Just (logRef val)) _ -> return Nothing -selectError :: Maybe LogRef -> IDEAction +-- | Select an error in the Errors pane +selectError :: Maybe LogRef -- ^ When @Nothing@, the first error in the list is selected + -> IDEAction selectError mbLogRef = do (mbPane :: Maybe IDEErrors) <- getPane errorRefs' <- readIDE errorRefs @@ -207,6 +236,8 @@ treeViewScrollToCell (treeView errors) (Just [ind]) Nothing Nothing treeSelectionSelectPath selection [ind] + +-- | Constructs the context menu for the Errors pane errorsContextMenu :: IDERef -> ListStore ErrColumn -> TreeView @@ -221,6 +252,8 @@ Just sel -> addResolveMenuItems ideR theMenu sel Nothing -> return () + +-- | Highlight an error refered to by the 'TreePath' in the given 'TreeViewColumn' errorsSelect :: IDERef -> ListStore ErrColumn -> TreePath @@ -231,7 +264,11 @@ reflectIDE (setCurrentError (Just (logRef ref))) ideR errorsSelect _ _ _ _ = return () -selectMatchingErrors :: Maybe SrcSpan -> IDEM () + +-- | Select the matching errors for a 'SrcSpan' in the Errors +-- pane, or none at all +selectMatchingErrors :: Maybe SrcSpan -- ^ When @Nothing@, unselects any errors in the pane + -> IDEM () selectMatchingErrors mbSpan = do mbErrors <- getPane case mbErrors of diff --git a/src/IDE/Pane/Files.hs b/src/IDE/Pane/Files.hs --- a/src/IDE/Pane/Files.hs +++ b/src/IDE/Pane/Files.hs @@ -78,12 +78,20 @@ import Data.Tree (Tree(..)) import System.Log.Logger (debugM) + + +-- * A record in the Files Pane + +-- | The data for a single cell in the file tree data FileRecord = FileRecord FilePath | DirRecord FilePath | PackageRecord IDEPackage - | PlaceHolder deriving(Eq) + | PlaceHolder -- ^ Used as child node of directories that are not yet expanded, + -- so that the expansion arrow becomes visible + deriving (Eq) + instance Ord FileRecord where -- | The ordering used for displaying the records in the filetree compare (DirRecord _) (FileRecord _) = LT @@ -92,26 +100,32 @@ compare (DirRecord p1) (DirRecord p2) = comparing (map toLower) p1 p2 compare _ _ = LT -file :: FileRecord -> Text -file (FileRecord f) = T.pack $ takeFileName f -file (DirRecord f) = T.pack $ takeFileName f -file (PackageRecord p) = packageIdentifierToString (ipdPackageId p) <> " " <> T.pack (ipdBuildDir p) -file PlaceHolder = "" +-- | The text to show in the file tree for a file record +displayText :: FileRecord -> Text +displayText (FileRecord f) = T.pack $ takeFileName f +displayText (DirRecord f) = T.pack $ takeFileName f +displayText (PackageRecord p) = packageIdentifierToString (ipdPackageId p) <> " " <> T.pack (ipdBuildDir p) +displayText PlaceHolder = "" --- | A files pane description --- + + +-- * The Files pane + +-- | The representation of the Files pane data IDEFiles = IDEFiles { scrolledView :: ScrolledWindow , treeView :: TreeView , fileStore :: TreeStore FileRecord } deriving Typeable + +-- | The additional state used when recovering the pane +-- (none, the package directories come from the IDE state) data FilesState = FilesState deriving(Eq,Ord,Read,Show,Typeable) -instance Pane IDEFiles IDEM - where +instance Pane IDEFiles IDEM where primPaneName _ = __ "Files" getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledView @@ -138,7 +152,7 @@ cellLayoutPackStart col1 renderer10 False cellLayoutPackStart col1 renderer1 True cellLayoutSetAttributes col1 renderer1 fileStore - $ \row -> [ cellText := file row] + $ \row -> [ cellText := displayText row] treeViewSetHeadersVisible treeView False sel <- treeViewGetSelection treeView @@ -182,20 +196,10 @@ return (Just files,[ConnectC cid1]) +-- | Get the Files pane getFiles :: Maybe PanePath -> IDEM IDEFiles getFiles Nothing = forceGetPane (Right "*Files") getFiles (Just pp) = forceGetPane (Left pp) - --- | Tries to get the 'FileRecord' of the selected node in the 'TreeView' -getSelectionFileRecord :: TreeView - -> TreeStore FileRecord - -> IO (Maybe FileRecord) -getSelectionFileRecord treeView fileStore = do - treeSelection <- treeViewGetSelection treeView - paths <- treeSelectionGetSelectedRows treeSelection - case paths of - p:_ -> Just <$> treeStoreGetValue fileStore p - _ -> return Nothing -- | Refreshes the Files pane, lists all package directories and synchronizes the expanded diff --git a/src/IDE/Pane/Grep.hs b/src/IDE/Pane/Grep.hs --- a/src/IDE/Pane/Grep.hs +++ b/src/IDE/Pane/Grep.hs @@ -15,7 +15,7 @@ -- Stability : provisional -- Portability : portable -- --- | The pane of ide where grep results are displayed +-- | The pane of the ide where grep results are displayed -- ------------------------------------------------------------------------------- @@ -65,6 +65,7 @@ import Control.Exception (SomeException, catch) import Data.Text (Text) +-- | Represents a single search result data GrepRecord = GrepRecord { file :: FilePath , line :: Int @@ -72,12 +73,14 @@ , parDir :: Maybe FilePath } + +-- | Determines whether a 'GrepRecord' is a directory +isDir :: GrepRecord -> Bool isDir GrepRecord{parDir = Nothing} = True isDir otherwies = False --- | A grep pane description --- +-- | The representation of the Grep result pane data IDEGrep = IDEGrep { scrolledView :: ScrolledWindow , treeView :: TreeView @@ -86,9 +89,12 @@ , activeGrep :: MVar Bool } deriving Typeable + +-- | The additional state used when recovering the pane data GrepState = GrepState deriving(Eq,Ord,Read,Show,Typeable) + instance Pane IDEGrep IDEM where primPaneName _ = __ "Grep" @@ -96,6 +102,7 @@ getTopWidget = castToWidget . scrolledView paneId b = "*Grep" + instance RecoverablePane IDEGrep GrepState IDEM where saveState p = return (Just GrepState) recoverState pp GrepState = do @@ -187,10 +194,13 @@ return (Just grep,[ConnectC cid1]) +-- | Get the Grep panel getGrep :: Maybe PanePath -> IDEM IDEGrep getGrep Nothing = forceGetPane (Right "*Grep") getGrep (Just pp) = forceGetPane (Left pp) + +-- | Parses a result line of grep output into a 'GrepRecord' grepLineParser :: CharParser () GrepRecord grepLineParser = try (do file <- many (noneOf ":") @@ -211,6 +221,8 @@ colon = P.colon lexer int = fromInteger <$> P.integer lexer + +-- | Tries to get the currently selected record in the pane getSelectionGrepRecord :: TreeView -> TreeStore GrepRecord -> IO (Maybe GrepRecord) @@ -221,8 +233,12 @@ p:_ -> Just <$> treeStoreGetValue grepStore p _ -> return Nothing + --TODO srp use default loglaunch probably -grepWorkspace :: Text -> Bool -> WorkspaceAction +-- | Greps the current workspace +grepWorkspace :: Text -- ^ The regex string + -> Bool -- ^ Case sensitive + -> WorkspaceAction grepWorkspace "" caseSensitive = return () grepWorkspace regexString caseSensitive = do ws <- ask @@ -233,7 +249,12 @@ lift $ grepDirectories regexString caseSensitive $ map (dropFileName . ipdCabalFile) packages -grepDirectories :: Text -> Bool -> [FilePath] -> IDEAction + +-- | Greps a list of directories +grepDirectories :: Text -- ^ The regex string + -> Bool -- ^ Case sensitive + -> [FilePath] + -> IDEAction grepDirectories regexString caseSensitive dirs = do grep <- getGrep Nothing let store = grepStore grep @@ -287,6 +308,8 @@ void $ takeMVar (activeGrep grep) return () + +-- | A Sink for processing lines of grep output and counting them setGrepResults :: FilePath -> C.Sink ToolOutput IDEM Int setGrepResults dir = do ideRef <- lift ask diff --git a/src/IDE/Pane/Info.hs b/src/IDE/Pane/Info.hs --- a/src/IDE/Pane/Info.hs +++ b/src/IDE/Pane/Info.hs @@ -16,7 +16,7 @@ -- Stability : provisional -- Portability : portable -- --- | The GUI stuff for infos +-- | The info Pane to show symbol information -- ------------------------------------------------------------------------------- @@ -53,17 +53,20 @@ import qualified Data.Text as T (unpack, pack, null) import Data.Monoid ((<>)) --- | An info pane description --- + +-- | Represents the Info pane data IDEInfo = forall editor. TextEditor editor => IDEInfo { sw :: ScrolledWindow , currentDescr :: IORef (Maybe Descr) , descriptionView :: EditorView editor } deriving Typeable + +-- | The additional state used when recovering the pane data InfoState = InfoState (Maybe Descr) deriving(Eq,Ord,Read,Show,Typeable) + instance Pane IDEInfo IDEM where primPaneName _ = __ "Info" @@ -71,6 +74,7 @@ getTopWidget = castToWidget . sw paneId b = "*Info" + instance RecoverablePane IDEInfo InfoState IDEM where saveState p = do currentDescr' <- liftIO $ readIORef (currentDescr p) @@ -110,14 +114,20 @@ cids2 <- descriptionView `afterFocusIn` makeActive info return (Just info, cids1 ++ cids2) + +-- | Get the Info pane getInfo :: IDEM IDEInfo getInfo = forceGetPane (Right "*Info") + +-- | Display the Info pane showInfo :: IDEAction showInfo = do pane <- getInfo displayPane pane False + +-- | Open the source of the current symbol description gotoSource :: IDEAction gotoSource = do mbInfo <- getInfoCont @@ -126,6 +136,8 @@ return () Just info -> void (goToDefinition info) + +-- | Select the symbol description in the module pane gotoModule' :: IDEAction gotoModule' = do mbInfo <- getInfoCont @@ -134,6 +146,7 @@ Just info -> void (triggerEventIDE (SelectIdent info)) +-- | Replaces the symbol description and displays the info pane setInfo :: Descr -> IDEAction setInfo identifierDescr = do info <- getInfo @@ -147,12 +160,16 @@ setText tb (T.pack $ show (Present identifierDescr) ++ "\n") -- EOL for text iters to work recordInfoHistory (Just identifierDescr) oldDescr + +-- | Updates the style of the text buffer if it is opened setInfoStyle :: IDEAction setInfoStyle = getPane >>= setInfoStyle' where setInfoStyle' Nothing = return () setInfoStyle' (Just IDEInfo{..}) = getBuffer descriptionView >>= updateStyle + +-- | Try to get the symbol description of the Info pane getInfoCont :: IDEM (Maybe Descr) getInfoCont = do mbPane <- getPane @@ -163,15 +180,24 @@ -- * GUI History -recordInfoHistory :: Maybe Descr -> Maybe Descr -> IDEAction + +-- | Record the transition to the new description from the old +recordInfoHistory :: Maybe Descr -- ^ The new description + -> Maybe Descr -- ^ The old description + -> IDEAction recordInfoHistory descr oldDescr = do triggerEventIDE (RecordHistory (InfoElementSelected descr, InfoElementSelected oldDescr)) return () -replayInfoHistory :: Maybe Descr -> IDEAction + +-- | Replace the symbol description +replayInfoHistory :: Maybe Descr -- ^ If @Nothing@, the description is not replaced + -> IDEAction replayInfoHistory mbDescr = forM_ mbDescr setInfo + +-- | Open the documentation for the current symbol description openDocu :: IDEAction openDocu = do mbDescr <- getInfoCont @@ -181,6 +207,8 @@ prefs' <- readIDE prefs openBrowser $ docuSearchURL prefs' <> T.pack (escapeURIString isAlphaNum (T.unpack $ dscName descr)) + +-- | Builds the context menu of the Info pane populatePopupMenu :: IDERef -> IORef (Maybe Descr) -> Menu -> IO () populatePopupMenu ideR currentDescr' menu = do items <- containerGetChildren menu diff --git a/src/IDE/Pane/PackageEditor.hs b/src/IDE/Pane/PackageEditor.hs --- a/src/IDE/Pane/PackageEditor.hs +++ b/src/IDE/Pane/PackageEditor.hs @@ -334,13 +334,18 @@ , buildType = Just Simple , specVersionRaw = Right (orLaterVersion (Version [1,12] [])) , license = AllRightsReserved + , buildDepends = [ + Dependency (PackageName "base") anyVersion + , Dependency (PackageName "QuickCheck") anyVersion + , Dependency (PackageName "doctest") anyVersion] , executables = [emptyExecutable { exeName = T.unpack newPackageName , modulePath = "Main.hs" , buildInfo = emptyBuildInfo { - hsSourceDirs = ["src"] + hsSourceDirs = ["src"] , targetBuildDepends = [Dependency (PackageName "base") anyVersion] - , defaultLanguage = Just Haskell2010}}] + , options = [(GHC, ["-ferror-spans"])] + , defaultLanguage = Just Haskell2010}}] , testSuites = [emptyTestSuite { testName = "test-" ++ T.unpack newPackageName , testInterface = TestSuiteExeV10 (Version [1,0] []) "Main.hs" @@ -350,6 +355,7 @@ Dependency (PackageName "base") anyVersion , Dependency (PackageName "QuickCheck") anyVersion , Dependency (PackageName "doctest") anyVersion] + , options = [(GHC, ["-ferror-spans"])] , defaultLanguage = Just Haskell2010}}] , benchmarks = [] } dirName modules (activateAction True) diff --git a/src/IDE/Pane/PackageFlags.hs b/src/IDE/Pane/PackageFlags.hs --- a/src/IDE/Pane/PackageFlags.hs +++ b/src/IDE/Pane/PackageFlags.hs @@ -15,7 +15,8 @@ -- Portability : portable -- -- --- | Module for saving, restoring and editing projectFlags +-- | Pane for saving, restoring and editing flags for specific cabal +-- commands. -- --------------------------------------------------------------------------------- @@ -91,6 +92,8 @@ Nothing -> return (Nothing,[]) Just p -> reifyIDE $ \ideR -> builder' p flagsDesc flatflagsDesc pp nb window ideR + +-- | Builds the Flags pane builder' idePackage flagsDesc flatflagsDesc pp nb window ideR = do vb <- vBoxNew False 0 let flagsPane = IDEFlags vb @@ -136,16 +139,23 @@ boxPackEnd vb bb PackNatural 6 return (Just flagsPane,[]) + +-- | Gets the Flags pane getFlags :: Maybe PanePath -> IDEM IDEFlags getFlags Nothing = forceGetPane (Right "*Flags") getFlags (Just pp) = forceGetPane (Left pp) + +-- | Quote the string if it contains spaces and escape +-- any other quotes. quoteArg :: String -> String quoteArg s | ' ' `elem` s = "\"" <> escapeQuotes s <> "\"" quoteArg s = s escapeQuotes = foldr (\c s -> if c == '"' then '\\':c:s else c:s) "" + +-- | Parse any (escaped) character (ignoring a prefixed @\@) quotedArgCharParser :: CharParser () Char quotedArgCharParser = try (do char '\\' @@ -154,6 +164,9 @@ noneOf "\"") "argsParser" + +-- | Parse an argument that is either quoted or does not +-- contain spaces argParser :: CharParser () Text argParser = try (do char '"' @@ -164,6 +177,8 @@ T.pack <$> many1 (noneOf " ")) "argParser" + +-- | Parse many arguments, possibly seperated by spaces argsParser :: CharParser () [Text] argsParser = try ( many (do @@ -171,17 +186,25 @@ argParser)) "argsParser" + +-- | Quote all arguments and concatenate them unargs :: [Text] -> Text unargs = T.unwords . map (T.pack . quoteArg . T.unpack) + +-- | Parse a list of arguments from a given string args :: Text -> [Text] args s = case parse argsParser "" $ T.unpack s of Right result -> result _ -> [s] + +-- | The flattened description of the fields in the pane flatFlagsDescription :: [FieldDescriptionS IDEPackage] flatFlagsDescription = flattenFieldDescriptionPPToS flagsDescription + +-- | The description of the fields in the pane flagsDescription :: FieldDescriptionPP IDEPackage IDEM flagsDescription = VFDPP emptyParams [ mkFieldPP @@ -261,6 +284,7 @@ -- * Parsing -- ------------------------------------------------------------ +-- | Read all the field values from the given 'FilePath' readFlags :: FilePath -> IDEPackage -> IO IDEPackage readFlags fn = readFields fn flatFlagsDescription @@ -268,6 +292,7 @@ -- * Printing -- ------------------------------------------------------------ +-- | Write all field values to the given 'FilePath' writeFlags :: FilePath -> IDEPackage -> IO () writeFlags fpath flags = writeFields fpath flags flatFlagsDescription diff --git a/src/IDE/Pane/Preferences.hs b/src/IDE/Pane/Preferences.hs --- a/src/IDE/Pane/Preferences.hs +++ b/src/IDE/Pane/Preferences.hs @@ -94,17 +94,18 @@ prefsVersion :: Int prefsVersion = 3 --- --- | The Preferences Pane --- +-- | Represents the Preferences pane data IDEPrefs = IDEPrefs { prefsBox :: VBox } deriving Typeable + +-- | The additional state used when recovering the pane data PrefsState = PrefsState deriving(Eq,Ord,Read,Show,Typeable) + instance Pane IDEPrefs IDEM where primPaneName _ = __ "Prefs" @@ -112,6 +113,7 @@ getTopWidget = castToWidget . prefsBox paneId b = "*Prefs" + instance RecoverablePane IDEPrefs PrefsState IDEM where saveState p = return Nothing recoverState pp st = return Nothing @@ -224,14 +226,19 @@ return e) return (Just prefsPane,[]) + +-- | Get the Preferences pane getPrefs :: Maybe PanePath -> IDEM IDEPrefs getPrefs Nothing = forceGetPane (Right "*Prefs") getPrefs (Just pp) = forceGetPane (Left pp) + + -- ------------------------------------------------------------ -- * Dialog definition -- ------------------------------------------------------------ +-- | Description of the preference options prefsDescription :: FilePath -> [PackageIdentifier] -> FieldDescriptionPP Prefs IDEM prefsDescription configDir packages = NFDPP [ (__ "Editor", VFDPP emptyParams [ @@ -808,7 +815,7 @@ (\i -> return ()) ])] - +-- | Editor for enabling a different syntax stylesheet styleEditor :: Editor (Bool, Text) styleEditor p n = do styleManager <- sourceStyleSchemeManagerNew @@ -819,6 +826,7 @@ disableEditor (comboSelectionEditor notDarkIds id, p) True (__ "Select a special style?") p n +-- | The default preferences defaultPrefs = Prefs { prefsFormat = prefsVersion , prefsSaveTime = "" @@ -905,6 +913,7 @@ -- * Parsing -- ------------------------------------------------------------ +-- | Read the preference file readPrefs :: FilePath -> IO Prefs readPrefs fn = catch (do configDir <- getConfigDir @@ -916,6 +925,7 @@ -- * Printing -- ------------------------------------------------------------ +-- | Write the preference file writePrefs :: FilePath -> Prefs -> IO () writePrefs fpath prefs = do timeNow <- liftIO getClockTime diff --git a/src/IDE/Pane/SourceBuffer.hs b/src/IDE/Pane/SourceBuffer.hs --- a/src/IDE/Pane/SourceBuffer.hs +++ b/src/IDE/Pane/SourceBuffer.hs @@ -35,7 +35,6 @@ , fileNew , fileOpenThis -, fileOpen , filePrint , fileRevert , fileClose @@ -86,8 +85,10 @@ , recentSourceBuffers , newTextBuffer , belongsToPackages +, belongsToPackages' , belongsToPackage , belongsToWorkspace +, belongsToWorkspace' , getIdentifierUnderCursorFromIter , useCandyFor @@ -120,7 +121,7 @@ notebookGetNthPage, notebookPageNum, widgetHide, dialogRun, messageDialogNew, scrolledWindowSetShadowType, scrolledWindowSetPolicy, dialogSetDefaultResponse, - fileChooserSetCurrentFolder, fileChooserSelectFilename, + fileChooserSelectFilename, TextSearchFlags(..)) import qualified Graphics.UI.Gtk as Gtk hiding (eventKeyName) import Graphics.UI.Gtk.Windows.Window @@ -1127,40 +1128,6 @@ in any (`isSubPath` fileName) paths -fileOpen :: IDEAction -fileOpen = do - window <- getMainWindow - prefs <- readIDE prefs - mbBuf <- maybeActiveBuf - mbFileName <- liftIO $ do - dialog <- fileChooserDialogNew - (Just $ __ "Open File") - (Just window) - FileChooserActionOpen - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-open" - ,ResponseAccept)] - case mbBuf >>= fileName of - Just fn -> void (fileChooserSetCurrentFolder dialog (dropFileName fn)) - Nothing -> return () - widgetShow dialog - response <- dialogRun dialog - case response of - ResponseAccept -> do - f <- fileChooserGetFilename dialog - widgetDestroy dialog - return f - ResponseCancel -> do - widgetDestroy dialog - return Nothing - ResponseDeleteEvent-> do - widgetDestroy dialog - return Nothing - _ -> return Nothing - F.forM_ mbFileName fileOpenThis - - fileOpenThis :: FilePath -> IDEAction fileOpenThis fp = do liftIO . debugM "leksah" $ "fileOpenThis " ++ fp @@ -1431,9 +1398,10 @@ i2 <- forwardCharsC i1 (T.length realString) selectRange ebuf i1 i2 --- | Returns the package, to which this buffer belongs, if possible -belongsToPackages :: MonadIDE m => IDEBuffer -> m [IDEPackage] -belongsToPackages IDEBuffer{fileName = Just fp}= do +-- | Returns the packages to which this file belongs +-- uses the 'bufferProjCache' and might extend it +belongsToPackages :: MonadIDE m => FilePath -> m [IDEPackage] +belongsToPackages fp = do bufferToProject' <- readIDE bufferProjCache ws <- readIDE workspace case Map.lookup fp bufferToProject' of @@ -1441,20 +1409,27 @@ Nothing -> case ws of Nothing -> return [] Just workspace -> do --- mbMn <- liftIO $ moduleNameFromFilePath fp --- let mbMn2 = case mbMn of --- Nothing -> Nothing --- Just mn -> simpleParse mn let res = filter (belongsToPackage fp) (wsPackages workspace) modifyIDE_ (\ide -> ide{bufferProjCache = Map.insert fp res bufferToProject'}) return res -belongsToPackages _ = return [] --- | Including files in sandbox source dirs +-- | Returns the packages to which this buffer belongs +-- uses the 'bufferProjCache' and might extend it +belongsToPackages' :: MonadIDE m => IDEBuffer -> m [IDEPackage] +belongsToPackages' = maybe (return []) belongsToPackages . fileName + +-- | Checks whether a file belongs to a package (includes files in +-- sandbox source dirs) belongsToPackage :: FilePath -> IDEPackage -> Bool belongsToPackage f = any (`isSubPath` f) . ipdAllDirs -belongsToWorkspace b = liftM (not . null) (belongsToPackages b) +-- | Checks whether a file belongs to the workspace +belongsToWorkspace :: MonadIDE m => FilePath -> m Bool +belongsToWorkspace fp = liftM (not . null) (belongsToPackages fp) + +-- | Checks whether a file belongs to the workspace +belongsToWorkspace' :: MonadIDE m => IDEBuffer -> m Bool +belongsToWorkspace' = maybe (return False) belongsToWorkspace . fileName useCandyFor :: MonadIDE m => IDEBuffer -> m Bool useCandyFor aBuffer = do diff --git a/src/IDE/Pane/Variables.hs b/src/IDE/Pane/Variables.hs --- a/src/IDE/Pane/Variables.hs +++ b/src/IDE/Pane/Variables.hs @@ -56,22 +56,26 @@ import qualified Data.Text as T (pack, unpack) import Control.Applicative ((<$>)) --- | A variables pane description --- +-- | Represents the Variables pane data IDEVariables = IDEVariables { scrolledView :: ScrolledWindow , treeView :: TreeView , variables :: TreeStore VarDescription } deriving Typeable + +-- | The data for a single entry in the pane data VarDescription = VarDescription { varName :: Text , varType :: Text , varValue :: Text} -data VariablesState = VariablesState { -} deriving(Eq,Ord,Read,Show,Typeable) +-- | The additional state used when recovering the pane +data VariablesState = VariablesState + deriving(Eq,Ord,Read,Show,Typeable) + + instance Pane IDEVariables IDEM where primPaneName _ = __ "Variables" @@ -79,6 +83,7 @@ getTopWidget = castToWidget . scrolledView paneId b = "*Variables" + instance RecoverablePane IDEVariables VariablesState IDEM where saveState p = return (Just VariablesState) recoverState pp VariablesState = do @@ -86,14 +91,21 @@ buildPane pp nb builder builder = builder' + +-- | Get the Variables pane getVariables :: IDEM IDEVariables getVariables = forceGetPane (Right "*Variables") + +-- | Display the Variables pane showVariables :: IDEAction showVariables = do pane <- getVariables displayPane pane False + +-- | Builds the Variables pane, together with a list +-- of connections of events builder' :: PanePath -> Notebook -> Window -> @@ -154,6 +166,7 @@ return (Just pane, map ConnectC [cid1, cid2, cid3, cid4]) +-- | Quietly list the variable bindings of the current debug session fillVariablesListQuiet :: IDEAction fillVariablesListQuiet = packageTryQuiet $ do mbVariables <- liftIDE getPane @@ -171,6 +184,8 @@ where insertBreak treeStore (v,index) = treeStoreInsert treeStore [] index v + +-- | List the variable bindings of the current debug session fillVariablesList :: IDEAction fillVariablesList = packageTry $ do mbVariables <- liftIDE getPane @@ -188,11 +203,16 @@ where insertBreak treeStore (v,index) = treeStoreInsert treeStore [] index v + +-- | Concatenates the tool output lines with newlines selectString :: [ToolOutput] -> Text selectString (ToolOutput str:r) = "\n" <> str <> selectString r selectString (_:r) = selectString r selectString [] = "" + +-- | Tries to get the selected variable in the Pane, +-- together with the 'TreePath' getSelectedVariable :: TreeView -> TreeStore VarDescription -> IO (Maybe (VarDescription,TreePath)) @@ -205,6 +225,8 @@ return (Just (val,a)) _ -> return Nothing + +-- | Parses multiple 'VarDescription's variablesParser :: CharParser () [VarDescription] variablesParser = do whiteSpace @@ -212,6 +234,8 @@ eof return r + +-- | Parses a 'VarDescription' from a line of ghci output variableParser :: CharParser () VarDescription variableParser = do whiteSpace @@ -229,6 +253,9 @@ return (VarDescription varName typeStr value) "variableParser" + +-- | Parses only the value of a variable binding from a line of +-- ghci output valueParser :: CharParser () Text valueParser = do whiteSpace @@ -237,6 +264,8 @@ T.pack <$> many anyChar "valueParser" +-- | Parses only the type of a variable binding from a line of +-- ghci output typeParser :: CharParser () Text typeParser = do whiteSpace @@ -251,6 +280,7 @@ whiteSpace = P.whiteSpace lexer +-- | Constructs the context menu of the Variables pane variablesContextMenu :: IDERef -> TreeStore VarDescription -> TreeView @@ -275,6 +305,9 @@ mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem item2, castToMenuItem sep1, castToMenuItem item3] + +-- | Called when a variable is selected in the Variables pane. +-- Forces the variable and updates the entry in the pane, variablesSelect :: IDERef -> TreeStore VarDescription -> TreePath @@ -284,6 +317,9 @@ varDescr <- treeStoreGetValue store path reflectIDE (forceVariable varDescr path store) ideR + +-- | Force the value of the given 'VarDescription', retrieve its type +-- and update the appropriate entry in the Variables pane forceVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction forceVariable varDescr path treeStore = packageTry $ tryDebug $ do debugCommand' (":force " <> varName varDescr) $ do @@ -303,6 +339,9 @@ var <- treeStoreGetValue treeStore path treeStoreSetValue treeStore path var{varType = typ} + +-- | Print the value of the given 'VarDescription', retrieve its type +-- and update the appropriate entry in the Variables pane printVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction printVariable varDescr path treeStore = packageTry $ tryDebug $ do debugCommand' (":print " <> varName varDescr) $ do diff --git a/src/IDE/Pane/Workspace.hs b/src/IDE/Pane/Workspace.hs --- a/src/IDE/Pane/Workspace.hs +++ b/src/IDE/Pane/Workspace.hs @@ -14,7 +14,8 @@ -- Stability : provisional -- Portability : -- --- | +-- | The pane of the IDE that shows the cabal packages in the workspace +-- and their build targets -- ----------------------------------------------------------------------------- @@ -49,8 +50,13 @@ -- | Workspace pane state -- +-- | The data in a row displays a package or an +-- executable of that package (in the first case +-- the path to the package is also stored) type WorkspaceRecord = (IDEPackage, Maybe Text) + +-- | The representation of the workspace pane data IDEWorkspace = IDEWorkspace { scrolledView :: ScrolledWindow , treeViewC :: TreeView @@ -65,7 +71,8 @@ getTopWidget = castToWidget . topBox paneId b = "*Workspace" --- | Nothing to remember here, everything comes from the IDE state +-- | The additional state used when recovering the pane +-- (none, the packages and their targets come from the IDE state) data WorkspaceState = WorkspaceState deriving(Eq,Ord,Read,Show,Typeable) @@ -138,15 +145,19 @@ file (_, (_, Just _)) = "" file (_, (pack, _)) = ipdCabalFile pack +-- | Get the workspace pane getWorkspace :: Maybe PanePath -> IDEM IDEWorkspace getWorkspace Nothing = forceGetPane (Right "*Workspace") getWorkspace (Just pp) = forceGetPane (Left pp) +-- | Show the workspace pane showWorkspace :: IDEAction showWorkspace = do l <- getWorkspace Nothing displayPane l False +-- | Try to get the current selected record and whether +-- it is selected getSelectionTree :: TreeView -> TreeStore (Bool, WorkspaceRecord) -> IO (Maybe (Bool, IDEPackage, Maybe Text)) @@ -161,6 +172,8 @@ (active, (p, exe)) -> return $ Just (active, p, exe) _ -> return Nothing + +-- | Construct the context menu for the pane workspaceContextMenu :: IDERef -> IDEWorkspace -> Menu @@ -186,6 +199,9 @@ menuShellAppend theMenu item2 menuShellAppend theMenu item3 + +-- | Try to activate the package pointed to by the given 'TreePath' +-- by modifying the given IDE state workspaceSelect :: IDERef -> IDEWorkspace -> TreePath @@ -196,7 +212,12 @@ (_,(ideP,mbExe)) <- treeStoreGetValue (workspaceStore workspacePane) path reflectIDE (workspaceTry $ workspaceActivatePackage ideP mbExe) ideR -updateWorkspace :: Bool -> Bool -> IDEAction + +-- | Repopulates the workspace pane with the current packages +-- (if the pane is open) +updateWorkspace :: Bool -- ^ Show the pane if it is open and a workspace is loaded + -> Bool -- ^ Empty the 'bufferProjCache' + -> IDEAction updateWorkspace showPane updateFileCache = do liftIO $ debugM "leksah" "updateWorkspace" mbWs <- readIDE workspace @@ -214,18 +235,27 @@ case mbMod of Nothing -> return () Just (p :: IDEWorkspace) -> do - liftIO $ treeStoreClear (workspaceStore p) - let sorted = sortBy (compare `F.on` ipdPackageId) $ wsPackages ws - forest = map (\ ideP -> Node ( - Just (ipdCabalFile ideP) == wsActivePackFile ws, - (ideP, Nothing)) - (map (\ pack -> Node (False, (pack, Nothing)) []) (ipdSandboxSources ideP) ++ - map (\ test -> Node ( - Just (ipdCabalFile ideP) == wsActivePackFile ws && - Just test == wsActiveExe ws, (ideP, Just test)) []) - (ipdExes ideP ++ ipdTests ideP ++ ipdBenchmarks ideP))) - sorted - liftIO $ treeStoreInsertForest (workspaceStore p) [] 0 forest + liftIO $ do + treeStoreClear (workspaceStore p) + treeStoreInsertForest (workspaceStore p) [] 0 (buildForest ws) when showPane $ displayPane p False refreshFiles + where + -- | Given a workspace, constructs the forest of + -- packages and their targets + buildForest ws = + let sorted = sortBy (compare `F.on` ipdPackageId) $ wsPackages ws + in map (buildPackageTree ws) sorted + -- | Given an ide package, constructs the tree with the + -- package as root node, and its targets as children + buildPackageTree ws ideP = + let isActive = Just (ipdCabalFile ideP) == wsActivePackFile ws + sandboxChildren = map (\pack -> Node (False, (pack, Nothing)) []) + (ipdSandboxSources ideP) + targetsChildren = map (\test -> Node ( + Just (ipdCabalFile ideP) == wsActivePackFile ws && + Just test == wsActiveExe ws, (ideP, Just test)) []) + (ipdExes ideP ++ ipdTests ideP ++ ipdBenchmarks ideP) + in Node (isActive, (ideP, Nothing)) + (sandboxChildren ++ targetsChildren) diff --git a/src/IDE/PaneGroups.hs b/src/IDE/PaneGroups.hs --- a/src/IDE/PaneGroups.hs +++ b/src/IDE/PaneGroups.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- -- Module : IDE.PaneGroups @@ -24,15 +25,11 @@ import IDE.Core.State (IDEM(..), readIDE, IDEAction(..)) import Graphics.UI.Frame.Panes - (getTopWidget, - getPane, - getOrBuildPane, - PaneDirection(..), - PanePathElement(..), - layout, - panePathForGroup) + (RecoverablePane, PanePath, getTopWidget, getPane, getOrBuildPane, + PaneDirection(..), PanePathElement(..), layout, panePathForGroup) import Graphics.UI.Frame.ViewFrame - (getBestPanePath, getNotebook, viewSplit', newGroupOrBringToFront) + (viewMoveTo, getBestPanePath, getNotebook, viewSplit', + newGroupOrBringToFront) import Control.Monad (void, unless, when, liftM) import IDE.Core.Types (frameState) import Graphics.UI.Editor.Parameters (Direction(..)) @@ -50,6 +47,14 @@ import Control.Monad.IO.Class (MonadIO(..)) import IDE.Pane.WebKit.Output (IDEOutput(..)) +moveOrBuildPane :: RecoverablePane alpha beta delta => PanePath -> delta (Maybe alpha) +moveOrBuildPane path = do + mbPane <- getOrBuildPane (Left path) + case mbPane of + Just pane -> viewMoveTo path pane + Nothing -> return () + return mbPane + showBrowser :: IDEAction showBrowser = do pp <- panePathForGroup "*Browser" @@ -81,9 +86,9 @@ _ -> return () where getOrBuildBrowserPanes upperP lowerP topP = do - getOrBuildPane (Left upperP) :: IDEM (Maybe IDEModules) - getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEInfo) - getOrBuildPane (Left topP) :: IDEM (Maybe IDEWorkspace) + moveOrBuildPane upperP :: IDEM (Maybe IDEModules) + moveOrBuildPane lowerP :: IDEM (Maybe IDEInfo) + moveOrBuildPane topP :: IDEM (Maybe IDEWorkspace) return () setSensitivityDebugger :: Bool -> IDEAction @@ -127,11 +132,13 @@ _ -> return () where getOrBuildDebugPanes upperP lowerP bufs = do - getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEBreakpoints) - getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEVariables) - getOrBuildPane (Left lowerP) :: IDEM (Maybe IDETrace) - getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEOutput) + moveOrBuildPane lowerP :: IDEM (Maybe IDEBreakpoints) + moveOrBuildPane lowerP :: IDEM (Maybe IDEVariables) + moveOrBuildPane lowerP :: IDEM (Maybe IDETrace) + moveOrBuildPane lowerP :: IDEM (Maybe IDEOutput) unless (any (\ b -> bufferName b == "_Eval.hs") bufs) $ - void (newTextBuffer upperP "_Eval.hs" Nothing) + newTextBuffer upperP "_Eval.hs" Nothing >>= \case + Nothing -> return () + Just pane -> viewMoveTo upperP pane return () diff --git a/src/IDE/Workspaces.hs b/src/IDE/Workspaces.hs --- a/src/IDE/Workspaces.hs +++ b/src/IDE/Workspaces.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Workspace @@ -34,6 +35,8 @@ , backgroundMake , makePackage +, fileOpen +, fileOpen' ) where import IDE.Core.State @@ -66,14 +69,17 @@ (getModuleTemplate, getPackageDescriptionAndPath, activatePackage, deactivatePackage, idePackageFromPath, idePackageFromPath) import System.Directory - (getHomeDirectory, createDirectoryIfMissing, doesFileExist) + (getDirectoryContents, getHomeDirectory, createDirectoryIfMissing, + doesFileExist) import System.Time (getClockTime) import Graphics.UI.Gtk.Windows.MessageDialog (ButtonsType(..), MessageType(..)) import Graphics.UI.Gtk.Windows.Dialog (ResponseId(..)) import qualified Control.Exception as Exc (SomeException(..), throw, Exception) import qualified Data.Map as Map (empty) -import IDE.Pane.SourceBuffer (fileOpenThis, fileCheckAll, belongsToPackages) +import IDE.Pane.SourceBuffer + (belongsToWorkspace, IDEBuffer(..), maybeActiveBuf, fileOpenThis, + fileCheckAll, belongsToPackages') import System.Glib.Attributes (AttrOp(..), set) import Graphics.UI.Gtk.General.Enums (WindowPosition(..)) import Control.Applicative ((<$>)) @@ -98,6 +104,13 @@ import qualified Text.Printf as S (printf) import Text.Printf (PrintfType) import qualified Data.Text.IO as T (writeFile) +import Graphics.UI.Gtk.Selectors.FileChooserDialog + (fileChooserDialogNew) +import Graphics.UI.Gtk.Selectors.FileChooser + (fileChooserGetFilename, fileChooserSetCurrentFolder, + FileChooserAction(..)) +import Graphics.UI.Gtk.Abstract.Widget (widgetShow) +import Control.Exception (SomeException(..), catch) printf :: PrintfType r => Text -> r printf = S.printf . T.unpack @@ -456,22 +469,18 @@ backgroundMake = catchIDE (do ideR <- ask prefs <- readIDE prefs - mbPackage <- readIDE activePack debug <- isJust <$> readIDE debugState - case mbPackage of - Nothing -> return () - Just package -> do - modifiedPacks <- if saveAllBeforeBuild prefs - then fileCheckAll belongsToPackages - else return [] - let isModified = not (null modifiedPacks) - when isModified $ do - let settings = defaultMakeSettings prefs - steps <- buildSteps $ msRunUnitTests settings - workspaceTryQuiet $ if debug || msSingleBuildWithoutLinking settings && not (msMakeMode settings) - then makePackages settings modifiedPacks (MoComposed steps) (MoComposed []) moNoOp - else makePackages settings modifiedPacks (MoComposed steps) - (MoComposed (MoConfigure:steps)) MoMetaInfo + modifiedPacks <- if saveAllBeforeBuild prefs + then fileCheckAll belongsToPackages' + else return [] + let isModified = not (null modifiedPacks) + when isModified $ do + let settings = defaultMakeSettings prefs + steps <- buildSteps $ msRunUnitTests settings + workspaceTryQuiet $ if debug || msSingleBuildWithoutLinking settings && not (msMakeMode settings) + then makePackages settings modifiedPacks (MoComposed steps) (MoComposed []) moNoOp + else makePackages settings modifiedPacks (MoComposed steps) + (MoComposed (MoConfigure:steps)) MoMetaInfo ) (\(e :: Exc.SomeException) -> sysMessage Normal (T.pack $ show e)) @@ -498,3 +507,96 @@ (MoComposed steps) (MoComposed (MoConfigure:steps)) MoMetaInfo) ws + +fileOpen :: IDEAction +fileOpen = do + window <- getMainWindow + prefs <- readIDE prefs + mbBuf <- maybeActiveBuf + mbFileName <- liftIO $ do + dialog <- fileChooserDialogNew + (Just $ __ "Open File") + (Just window) + FileChooserActionOpen + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-open" + ,ResponseAccept)] + case mbBuf >>= fileName of + Just fn -> void (fileChooserSetCurrentFolder dialog (dropFileName fn)) + Nothing -> return () + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do + f <- fileChooserGetFilename dialog + widgetDestroy dialog + return f + ResponseCancel -> do + widgetDestroy dialog + return Nothing + ResponseDeleteEvent-> do + widgetDestroy dialog + return Nothing + _ -> return Nothing + forM_ mbFileName fileOpen' + +fileOpen' :: FilePath -> IDEAction +fileOpen' fp = do + window <- getMainWindow + knownFile <- belongsToWorkspace fp + unless knownFile $ + if takeExtension fp == ".cabal" + then do + resp <- liftIO $ do + md <- messageDialogNew + (Just window) [] + MessageQuestion + ButtonsNone + (__ "Would you like to add the package " <> T.pack fp + <> __ " to the workspace so that it can be built by Leksah?") + dialogAddButton md (__ "_Add " <> T.pack (takeFileName fp)) (ResponseUser 1) + dialogAddButton md (__ "Just _open " <> T.pack (takeFileName fp)) (ResponseUser 2) + dialogSetDefaultResponse md (ResponseUser 1) + resp <- dialogRun md + widgetDestroy md + return resp + case resp of + ResponseUser 1 -> workspaceTry $ do + workspaceAddPackage' fp + return () + _ -> return () + else liftIO (findCabalFile fp) >>= \case + Nothing -> return () + Just cabalFile -> do + resp <- liftIO $ do + md <- messageDialogNew + (Just window) [] + MessageQuestion + ButtonsNone + (__ "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 workspace?") + dialogAddButton md (__ "_Add " <> T.pack (takeFileName cabalFile)) (ResponseUser 1) + dialogAddButton md (__ "Just _open " <> T.pack (takeFileName fp)) (ResponseUser 2) + dialogSetDefaultResponse md (ResponseUser 1) + resp <- dialogRun md + widgetDestroy md + return resp + case resp of + ResponseUser 1 -> workspaceTry $ do + workspaceAddPackage' cabalFile + return () + _ -> return () + fileOpenThis fp + where + findCabalFile :: FilePath -> IO (Maybe FilePath) + findCabalFile fp = (do + let dir = takeDirectory fp + cabal <- filter ((== ".cabal") . takeExtension) <$> getDirectoryContents dir + case cabal of + (c:_) -> return . Just $ dir c + _ | fp == dir -> return Nothing + | otherwise -> findCabalFile dir + ) `catch` (\(_ :: SomeException) -> return Nothing) diff --git a/win32/makeinstaller.sh b/win32/makeinstaller.sh --- a/win32/makeinstaller.sh +++ b/win32/makeinstaller.sh @@ -83,7 +83,7 @@ $LN "$GTK_PREFIX_U"/bin/libglib-2.0-0.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libgmodule-2.0-0.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libgmp-10.dll SourceDir/bin -$LN "$GTK_PREFIX_U"/bin/libgnutls-28.dll SourceDir/bin +$LN "$GTK_PREFIX_U"/bin/libgnutls-*.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libgobject-2.0-0.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libgst*-1.0-0.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libgthread-2.0-0.dll SourceDir/bin @@ -91,11 +91,11 @@ $LN "$GTK_PREFIX_U"/bin/libgtksourceview-3.0-1.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libharfbuzz-0.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libharfbuzz-icu-0.dll SourceDir/bin -$LN "$GTK_PREFIX_U"/bin/libhogweed-2-5.dll SourceDir/bin +$LN "$GTK_PREFIX_U"/bin/libhogweed-*.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libintl-8.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libjavascriptcoregtk-3.0-0.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libjpeg-62.dll SourceDir/bin -$LN "$GTK_PREFIX_U"/bin/libnettle-4-7.dll SourceDir/bin +$LN "$GTK_PREFIX_U"/bin/libnettle-*.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libp11-kit-0.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libpango-1.0-0.dll SourceDir/bin $LN "$GTK_PREFIX_U"/bin/libpangocairo-1.0-0.dll SourceDir/bin