leksah 0.15.1.4 → 0.15.2.0

raw patch · 56 files changed

+3139/−2226 lines, 56 filesdep +base-compatdep ~haskell-src-extsdep ~jsaddledep ~leksahbinary-addedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base-compat

Dependency ranges changed: haskell-src-exts, jsaddle, leksah, leksah-server, webkitgtk3-javascriptcore

API changes (from Hackage documentation)

Files

• Readme.md +3/−2
• data/keymap.lkshk +1/−1
• data/leksah-welcome/src/Main.hs +2/−2
• data/leksah.menu +39/−32
• leksah.cabal +21/−10
• osx/launcher.sh +0/−1
• osx/leksah.bundle +0/−8
• osx/makedmg.sh +0/−3
• osx/makedmgs.sh +6/−6
• pics/ide_cabal_file.png binary
• pics/ide_component.png binary
• pics/ide_error.png binary
• pics/ide_folder.png binary
• pics/ide_package.png binary
• pics/ide_source.png binary
• pics/ide_source_dependency.png binary
• pics/ide_source_folder.png binary
• pics/ide_suggestion.png binary
• pics/ide_warning.png binary
• src/IDE/BufferMode.hs +9/−1
• src/IDE/Command.hs +118/−84
• src/IDE/Completion.hs +0/−1
• src/IDE/Core/State.hs +1/−1
• src/IDE/Core/Types.hs +31/−10
• src/IDE/Find.hs +64/−60
• src/IDE/HLint.hs +7/−7
• src/IDE/ImportTool.hs +9/−0
• src/IDE/Leksah.hs +1/−2
• src/IDE/LogRef.hs +5/−5
• src/IDE/Metainfo/Provider.hs +72/−49
• src/IDE/OSX.hs +1/−1
• src/IDE/Package.hs +121/−67
• src/IDE/Pane/Errors.hs +309/−151
• src/IDE/Pane/Files.hs +50/−287
• src/IDE/Pane/Grep.hs +1/−1
• src/IDE/Pane/Info.hs +1/−1
• src/IDE/Pane/Modules.hs +31/−11
• src/IDE/Pane/PackageEditor.hs +15/−12
• src/IDE/Pane/Preferences.hs +0/−936
• src/IDE/Pane/SourceBuffer.hs +100/−26
• src/IDE/Pane/WebKit/Documentation.hs +0/−1
• src/IDE/Pane/WebKit/Output.hs +1/−1
• src/IDE/Pane/Workspace.hs +648/−194
• src/IDE/PaneGroups.hs +2/−2
• src/IDE/Preferences.hs +965/−0
• src/IDE/Sandbox.hs +45/−9
• src/IDE/Session.hs +46/−92
• src/IDE/TextEditor/Class.hs +16/−9
• src/IDE/TextEditor/CodeMirror.hs +99/−94
• src/IDE/TextEditor/GtkSourceView.hs +3/−3
• src/IDE/Utils/DirectoryUtils.hs +75/−0
• src/IDE/Utils/GUIUtils.hs +158/−27
• src/IDE/Utils/GtkBindings.hs +32/−0
• src/IDE/Workspaces.hs +10/−6
• tests/IDE/TextEditor/Tests.hs +18/−10
• tests/Tests.hs +3/−0

@@ -10,6 +10,8 @@  ## Installation +Requirements: ghc >= 7.8.3 cabal >= 1.18+ You can get Leksah up and running quickly on Windows and OS X using the [official binaries](https://github.com/leksah/leksah/wiki/download). @@ -34,7 +36,7 @@     cabal install leksah     leksah -### Buildling on OS X+### Building on OS X  [Install MacPorts](https://www.macports.org/install.php). @@ -95,7 +97,6 @@      cabal update     cabal install Cabal-    cabal install regex-tdfa-text --ghc-options=-XFlexibleContexts     cabal install alex happy     cabal install gtk2hs-buildtools     cabal install leksah

@@ -8,7 +8,7 @@ --<compose> is often labelled Alt Gr. -- --The defined values for the keys can can be found at--- http://gitweb.freedesktop.org/?p=xorg/proto/x11proto.git;a=blob_plain;f=keysymdef.h.+-- http://www.cl.cam.ac.uk/%7Emgk25/ucs/keysymdef.h -- The names of the keys are the names of the macros without the prefix.  

@@ -16,12 +16,12 @@ --   * Package -> New  -- Next we are importing some things from other modules.--- Leksah can normally addd these imports for you, just+-- Leksah can normally add these imports for you, just -- press Ctrl+R (OS X Command+R)  import Data.Monoid ((<>)) --- This strang looking comment adds code only needed when running the+-- This strange looking comment adds code only needed when running the -- doctest tests embedded in the comments -- $setup -- >>> import Data.List (stripPrefix)

@@ -1,17 +1,31 @@    <ui>     <menubar>       <menu name="_File" action="File">-       <menuitem name="_New Module..." action="FileNew" />-       <menuitem name="New _Text File" action="FileNewTextFile" />-       <menuitem name="_Open..." action="FileOpen" />-       <menuitem name="Open _Recent" action="RecentFiles"/>+       <menu name="_New" action="FileNew">+           <menuitem name="_Package..." action="FileNewPackage" />+           <menuitem name="_Module..." action="FileNewModule" />+           <menuitem name="_Text File..." action="FileNewTextFile" />+           <separator />+           <menuitem name="_Workspace..." action="FileNewWorkspace" />+       </menu>+       <menu name="_Open" action="FileOpen">+           <menuitem name="_Workspace..." action="FileOpenWorkspace" />+           <menuitem name="_Package..." action="FileOpenPackage" />+           <menuitem name="_File..." action="FileOpenFile" />+       </menu>+       <separator />        <menuitem name="_Save" action="FileSave" />        <menuitem name="Save _As..." action="FileSaveAs" />        <menuitem name="Save _All" action="FileSaveAll" />-       <menuitem name="_Revert" action="FileRevert" />        <menuitem name="_Close" action="FileClose" />        <menuitem name="_Print File" action="FilePrint" />        <separator/>+       <menu name="Recent Files" action="FileRecentFiles">+       </menu>+       <menu name="Recent Workspaces" action="FileRecentWorkspaces">+       </menu>+       <separator/>+       <menuitem name="Close Workspace" action="FileCloseWorkspace" />        <menuitem name="Close All" action="FileCloseAll" />        <menuitem name="Close All but Package" action="FileCloseAllButPackage" />        <menuitem name="Close All but Workspace" action="FileCloseAllButWorkspace" />@@ -44,22 +58,17 @@        <menuitem name="Align ::" action="EditAlignTypeSig" />      </menu>     <menu name="_Workspace" action="Workspace">-       <menuitem name="_New..." action="NewWorkspace" />-       <menuitem name="_Open..." action="OpenWorkspace" />-       <menuitem name="Open _Recent" action="RecentWorkspaces"/>-       <menuitem name="_Close" action="CloseWorkspace" />-       <separator/>-       <menuitem name="_Clean" action="CleanWorkspace" />-       <menuitem name="_Make" action="MakeWorkspace" />+       <menuitem name="_Add Package..." action="WorkspaceAddPackage" />+       <menuitem name="_Add Copy Of Installed Package..." action="WorkspaceAddPackageCopy" />+       <separator />+       <menuitem name="Cl_ean All packages" action="CleanWorkspace" />+       <menuitem name="_Build All packages" action="MakeWorkspace" />        <separator/>        <menuitem name="_Next Error" action="NextError" />        <menuitem name="_Previous Error" action="PreviousError" />        <menuitem name="Resol_ve Errors" action="ResolveErrors" />      </menu>     <menu name="_Package" action="Package">-       <menuitem name="_New..." action="NewPackage" />-       <menuitem name="_Add..." action="AddPackage" />-       <menuitem name="_Add From Source Repository..." action="ClonePackage" />        <menu name="_Edit" action="PackageEdit">           <menuitem name="With _Package Editor" action="EditPackage" />           <menuitem name="With _Text Editor" action="EditPackageText" />@@ -87,10 +96,10 @@        <menuitem name="SDist" action="SdistPackage" />        <menuitem name="_Build Documentation" action="DocPackage" />        <separator/>-       <menuitem name="Open Documentation" action="OpenDocPackage" />+       <menuitem name="_Open Documentation" action="OpenDocPackage" />      </menu>     <menu name="_Debug" action="Debug">-       <menuitem name="GHCi" action="DebugToggled" />+       <menuitem name="_Enable GHCi" action="DebugToggled" />        <menuitem name="Continue" action="DebugContinue" />        <menuitem name="Abandon" action="DebugAbandon" />        <menuitem name="Stop" action="DebugStop" />@@ -108,7 +117,7 @@     <menu name="_Panes" action="Panes">        <menuitem name="_Browser" action="ShowBrowser" />        <menuitem name="_Modules" action="ShowModules" />-       <menuitem name="_Info" action="ShowInfo" />+       <menuitem name="Symbol _Info" action="ShowInfo" />        <separator/>        <menuitem name="_Debugger" action="ShowDebugger" />        <menuitem name="_Breakpoints" action="ShowBreakpointsPane" />@@ -118,7 +127,6 @@        <menuitem name="_Web Inspector" action="ShowInspect" />        <separator/>        <menuitem name="_Errors" action="ShowErrors" />-       <menuitem name="_Files" action="ShowFiles" />        <menuitem name="_Grep" action="ShowGrep" />        <menuitem name="_Documentation" action="ShowDocumentation" />        <menuitem name="_Log" action="ShowLog" />@@ -134,7 +142,7 @@        <menuitem name="_Group" action="ViewNest" />        <menuitem name="_Detach" action="ViewDetach" />        <menuitem name="_Full Screen" action="ViewFullScreen" />-       <menuitem name="Dark" action="ViewDark" />+       <menuitem name="_Use Dark Interface" action="UseDarkInterface" />        <separator/>        <menuitem name="Move _Left" action="ViewMoveLeft" />        <menuitem name="Move _Right" action="ViewMoveRight" />@@ -150,18 +158,17 @@        <menuitem name="Clear Log" action="ClearLog" />        <menuitem name="Toggle Toolbar" action="ToggleToolbar" />      </menu>-    <menu name="_Configuration" action="Configuration">-       <menuitem name="Source Candy" action="EditCandy" />-       <menuitem name="Edit general Preferences" action="PrefsEdit" />-       <separator/>-       <menuitem name="Update workspace data" action="UpdateMetadataCurrent" />-       <menuitem name="Rebuild workspace data" action="RebuildMetadataCurrent" />-       <menuitem name="Update system data" action="UpdateMetadataLib" />-       <menuitem name="Rebuild system data" action="RebuildMetadataLib" />+    <menu name="_Tools" action="Tools">+       <menuitem name="Update Workspace Data" action="UpdateMetadataCurrent" />+       <menuitem name="Rebuild Workspace Data" action="RebuildMetadataCurrent" />+       <menuitem name="Update System Data" action="UpdateMetadataLib" />+       <menuitem name="Rebuild System Data" action="RebuildMetadataLib" />        <separator/>-       <menuitem name="Save Session" action="SaveSession" />+       <menuitem name="Save Session As..." action="SaveSession" />        <menuitem name="Load Session" action="LoadSession" />-       <menuitem name="Forget Session" action="ForgetSession" />+       <separator/>+       <menuitem name="_Preferences" action="PrefsEdit" />+       <separator/>     </menu>     <menu name="Version Con_trol" action="vcs">     </menu>@@ -174,8 +181,8 @@     <toolbar name="toolbar">      <placeholder name="FileToolItems">        <separator/>-       <toolitem name="New" action="FileNew"/>-       <toolitem name="Open" action="FileOpen"/>+       <toolitem name="New Module" action="FileNewModule"/>+       <toolitem name="Open" action="FileOpenFile"/>        <toolitem name="Save" action="FileSave"/>        <toolitem name="Close" action="ViewClosePane"/>        <separator/>

@@ -1,5 +1,5 @@ name: leksah-version: 0.15.1.4+version: 0.15.2.0 cabal-version: >=1.18 build-type: Simple license: GPL@@ -51,6 +51,12 @@     language-specs/lucius.lang     language-specs/julius.lang     language-specs/jmacro.lang+    pics/ide_folder.png+    pics/ide_source_folder.png+    pics/ide_component.png+    pics/ide_source_dependency.png+    pics/ide_package.png+    pics/ide_cabal_file.png     pics/ide_class.png     pics/ide_configure.png     pics/ide_data.png@@ -82,6 +88,9 @@     pics/ide_rebuild_meta.png     pics/ide_empty.png     pics/ide_js.png+    pics/ide_error.png+    pics/ide_warning.png+    pics/ide_suggestion.png     doc/Keybindings.svg     doc/leksah_manual.lyx     doc/screenshots2/screenshot_buffer_menu.png@@ -249,6 +258,7 @@         IDE.Session         IDE.Command         IDE.Keymap+        IDE.Utils.DirectoryUtils         IDE.Utils.GUIUtils         IDE.SymbolNavigation         IDE.Package@@ -260,7 +270,6 @@         IDE.Core.Types         IDE.Core.State         IDE.Metainfo.Provider-        IDE.Pane.Preferences         IDE.Pane.PackageEditor         IDE.Pane.HLint         IDE.Pane.Info@@ -277,6 +286,7 @@         IDE.Pane.Trace         IDE.Pane.Variables         IDE.Pane.Errors+        IDE.Preferences         IDE.TextEditor         IDE.Workspaces         IDE.Workspaces.Writer@@ -304,12 +314,14 @@         IDE.TextEditor.Yi         IDE.TextEditor.GtkSourceView         IDE.Utils.ExternalTool+        IDE.Utils.GtkBindings     build-depends:+        base-compat >=0.9.0 && <0.10,         gtk3 >=0.14.1 && <0.15,         gtksourceview3 >=0.13.1.5 && <0.14,         webkitgtk3 >=0.13 && <0.15,         webkitgtk3-javascriptcore -any,-        jsaddle >=0.2.1.0 && <0.3,+        jsaddle >=0.3.0.0 && <0.4,         ghcjs-codemirror -any,         blaze-html -any,         lens -any,@@ -336,7 +348,7 @@         binary-shared >=0.8 && <0.9,         deepseq >=1.1.0.0 && <1.5,         hslogger >=1.0.7 && <1.3,-        leksah-server >=0.15.0.8 && <0.16,+        leksah-server >=0.15.2.0 && <0.16,         ghc >=6.10.1 && <7.11,         strict >=0.3.2 && <0.4,         conduit >=1.0.8 && <1.3,@@ -347,14 +359,13 @@         vcsgui >=0.1.0 && <0.2,         vcswrapper >=0.1.0 && <0.2,         QuickCheck >=2.4.2 && <2.9,-        haskell-src-exts >=1.13.5 && <1.17,+        haskell-src-exts >=1.13.5 && <1.18,         hlint >=1.9.21 && <1.10,         vado >=0.0.1 && <0.1,         shakespeare >=2.0.0.1 && <2.1,         cpphs >=1.19 && <1.20,         stm >=2.4.4 && <2.5-    cpp-options: -DWEBKITGTK-                 -DLEKSAH_WITH_CODE_MIRROR+    cpp-options: -DWEBKITGTK -DLEKSAH_WITH_CODE_MIRROR     default-language: Haskell2010     default-extensions: ViewPatterns     hs-source-dirs: src@@ -389,7 +400,7 @@         ghc-options: -optl-headerpad_max_install_names     main-is: Main.hs     build-depends:-        leksah ==0.15.1.4,+        leksah ==0.15.2.0,         base >=4.0.0.0 && <=4.9,         gtk3 >=0.14.1 && <0.15,         stm >=2.4.4 && <2.5@@ -400,7 +411,7 @@ executable bewleksah     main-is: Main.hs     build-depends:-        leksah ==0.15.1.4,+        leksah ==0.15.2.0,         base >=4.0.0.0 && <=4.9,         jsaddle -any,         ghcjs-dom >=0.2.1.0 && <0.3,@@ -423,7 +434,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.4,+        leksah ==0.15.2.0,         containers -any,         ltk -any,         leksah-server -any,

@@ -36,7 +36,6 @@ export PATH="$bundle_bin":$PATH  export GTK2_RC_FILES="$bundle_etc/gtk-3.0/gtkrc"-export GTK_IM_MODULE_FILE="$bundle_etc/gtk-3.0/gtk.immodules" export GDK_PIXBUF_MODULE_FILE="$bundle_etc/gtk-3.0/gdk-pixbuf.loaders" export FONTCONFIG_PATH="$bundle_etc/fonts" export PANGO_RC_FILE="$bundle_etc/pango/pangorc"

@@ -83,10 +83,6 @@   </binary>    <binary>-    ${prefix}/lib/pango/${pkg:pango:pango_module_version}/modules/-  </binary>--  <binary>     ${prefix}/lib/gio/modules/   </binary> @@ -104,10 +100,6 @@    <data>     ${prefix}/etc/fonts/-  </data>--  <data>-    ${prefix}/etc/pango/   </data>    <!-- Translation filenames, one for each program or library that you

@@ -62,9 +62,6 @@ echo Fixing pixbuf loader paths sed -i "" -e "s|@executable_path/../Resources/|@executable_path/../|" Leksah/Leksah.app/Contents/Resources/etc/gtk-3.0/gdk-pixbuf.loaders || exit -echo Fixing pango module paths-sed -i "" -e "s|@executable_path/../Resources/|@executable_path/../|" Leksah/Leksah.app/Contents/Resources/etc/pango/pango.modules || exit- LEKSAH_DMG="$LEKSAH_X_X_X_X_GHC_X_X_X.dmg" if test -e "$LEKSAH_DMG"; then    rm "$LEKSAH_DMG"

@@ -1,12 +1,12 @@ #!/bin/sh -ex -export GHCVERSION=-7.8.3-scripts/clean.sh-osx/makedmg.sh-export GHCVERSION=-7.10.1-scripts/clean.sh+#export GHCVERSION=-7.8.3+#scripts/clean.sh+#osx/makedmg.sh+export GHCVERSION=-7.10.2+#scripts/clean.sh osx/makedmg.sh export GHCVERSION=-scripts/clean.sh+#scripts/clean.sh osx/makedmg.sh 

binary file changed (absent → 276 bytes)

binary file changed (absent → 508 bytes)

binary file changed (absent → 375 bytes)

binary file changed (absent → 202 bytes)

binary file changed (absent → 398 bytes)

binary file changed (469 → 456 bytes)

binary file changed (absent → 554 bytes)

binary file changed (absent → 260 bytes)

binary file changed (absent → 478 bytes)

binary file changed (absent → 379 bytes)

@@ -36,7 +36,6 @@ import IDE.SourceCandy        (getCandylessText, keystrokeCandy, transformFromCandy,         transformToCandy)-import IDE.Utils.GUIUtils (getCandyState) import Control.Monad (when) import Data.Maybe (mapMaybe, catMaybes) import IDE.Utils.FileUtils@@ -152,6 +151,7 @@     modeSelectedModuleName :: IDEM (Maybe Text),     modeEditToCandy        :: (Text -> Bool) -> IDEAction,     modeTransformToCandy   :: forall editor . TextEditor editor => (Text -> Bool) -> EditorBuffer editor -> IDEAction,+    modeTransformFromCandy   :: forall editor . TextEditor editor => EditorBuffer editor -> IDEAction,     modeEditFromCandy      :: IDEAction,     modeEditKeystrokeCandy :: Maybe Char -> (Text -> Bool) -> IDEAction,     modeEditInsertCode     :: forall editor . TextEditor editor => Text -> EditorIter editor -> EditorBuffer editor -> IDEAction,@@ -189,6 +189,9 @@     modeTransformToCandy = \ inCommentOrString ebuf -> do         ct <- readIDE candy         transformToCandy ct ebuf inCommentOrString,+    modeTransformFromCandy = \buf -> do+        ct <- readIDE candy+        transformFromCandy ct buf,     modeEditToCandy = \ inCommentOrString -> do         ct <- readIDE candy         inActiveBufContext () $ \_ _ ebuf _ _ ->@@ -234,6 +237,9 @@     modeTransformToCandy = \ inCommentOrString ebuf -> do         ct <- readIDE candy         transformToCandy ct ebuf inCommentOrString,+    modeTransformFromCandy = \buf -> do+        ct <- readIDE candy+        transformFromCandy ct buf,     modeEditToCandy = \ inCommentOrString -> do         ct <- readIDE candy         inActiveBufContext () $ \_ _ ebuf _ _ ->@@ -268,6 +274,7 @@         return (),     modeSelectedModuleName   = return Nothing,     modeTransformToCandy     = \ _ _ -> return (),+    modeTransformFromCandy   = \_ -> return (),     modeEditToCandy          = \ _ -> return (),     modeEditFromCandy        = return (),     modeEditKeystrokeCandy   = \ _ _ -> return (),@@ -282,6 +289,7 @@     modeEditUncomment        = return (),     modeSelectedModuleName   = return Nothing,     modeTransformToCandy     = \ _ _ -> return (),+    modeTransformFromCandy   = \_ -> return (),     modeEditToCandy          = \ _ -> return (),     modeEditFromCandy        = return (),     modeEditKeystrokeCandy   = \_ _ -> return (),

@@ -36,7 +36,8 @@ ) where  import Graphics.UI.Gtk-       (toToolbar, ToolbarClass, Toolbar(..), keyToChar, eventKeyVal,+       (iconThemeAddBuiltinIcon, iconThemeLoadIcon, iconThemeGetDefault,+        toToolbar, ToolbarClass, Toolbar(..), keyToChar, eventKeyVal,         eventModifier, eventKeyName, EKey, containerAdd,         windowAddAccelGroup, keyPressEvent, boxPackEnd, boxPackStart,         widgetSetName, vBoxNew, windowSetIconFromFile, Widget, Window,@@ -55,7 +56,8 @@         actionGroupNew, UIManager, widgetShowAll, menuItemSetSubmenu,         widgetDestroy, menuItemGetSubmenu, menuShellAppend,         menuItemActivate, menuItemNewWithLabel, menuNew, Packing(..),-        ToolbarStyle(..), PositionType(..), on, IconSize(..), Modifier(..))+        ToolbarStyle(..), PositionType(..), on, IconSize(..), Modifier(..),+        widgetSetSensitive) import System.FilePath import Data.Version import Prelude hiding (catch)@@ -64,11 +66,11 @@  import IDE.Core.State import IDE.Pane.SourceBuffer-import IDE.Pane.Preferences import IDE.Pane.PackageFlags import IDE.Pane.PackageEditor import IDE.Pane.Errors import IDE.Package+import IDE.Preferences (runPreferencesDialog, applyInterfaceTheme) import IDE.HLint import IDE.Sandbox import IDE.Pane.Log@@ -87,7 +89,7 @@ import IDE.Debug import System.Directory (doesFileExist) import Graphics.UI.Gtk.Gdk.EventM (EventM)-import qualified Data.Map as  Map (lookup)+import qualified Data.Map as  Map (lookup, empty) import Data.List (sort) import Control.Event (registerEvent) import IDE.Pane.Breakpoints@@ -103,9 +105,8 @@ import IDE.Pane.WebKit.Documentation (getDocumentation) import IDE.Pane.WebKit.Output (getOutputPane) import IDE.Pane.WebKit.Inspect (getInspectPane)-import IDE.Pane.Files (refreshFiles, getFiles) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad (unless, when)+import Control.Monad (unless, when, forM_, filterM, liftM) import Control.Monad.Trans.Reader (ask) import System.Log.Logger (debugM) import Foreign.C.Types (CInt(..))@@ -114,13 +115,16 @@ import Graphics.UI.GtkInternals (unToolbar) import IDE.Session        (saveSessionAs, loadSession, saveSession, sessionClosePane,-        loadSessionPrompt, saveSessionAsPrompt, viewFullScreen, viewDark)+        loadSessionPrompt, saveSessionAsPrompt, viewFullScreen) import qualified Data.Text as T (unpack, pack)+import Data.Time.Clock (getCurrentTime, utctDay)+import Data.Time.Calendar (toGregorian) import Data.Text (Text) import qualified Data.Text.IO as T (readFile) import Data.Monoid (Monoid(..), (<>)) import qualified Text.Printf as S (printf) import Text.Printf (PrintfType)+import Graphics.UI.Gtk.General.IconTheme (IconLookupFlags(..))  printf :: PrintfType r => Text -> r printf = S.printf . T.unpack@@ -142,15 +146,24 @@     AD "vcs" (__ "Version Con_trol") Nothing Nothing (return ()) [] False     ,AD "FilePrint" (__ "_Print File") Nothing Nothing filePrint [] False     ,AD "File" (__ "_File") Nothing Nothing (return ()) [] False-    ,AD "FileNew" (__ "_New Module...") Nothing (Just "gtk-new")+    ,AD "FileNew" (__ "_New") Nothing Nothing (return ()) [] False+    ,AD "FileNewWorkspace" (__ "_Workspace...") Nothing Nothing+        (workspaceNew >> showWorkspacePane) [] False+    ,AD "FileNewPackage" (__ "_Package...") Nothing Nothing+        (showWorkspacePane >> workspaceTry workspacePackageNew) [] False+    ,AD "FileNewModule" (__ "_Module...") Nothing (Just "gtk-new")         (packageTry $ addModule []) [] False-    ,AD "FileNewTextFile" (__ "_New Text File") Nothing Nothing+    ,AD "FileNewTextFile" (__ "_Text File...") Nothing Nothing         fileNew [] False-    ,AD "FileOpen" (__ "_Open...") Nothing (Just "gtk-open")+    ,AD "FileOpen" (__ "_Open") Nothing Nothing (return ()) [] False+    ,AD "FileOpenWorkspace" (__ "_Workspace...") Nothing Nothing+        (workspaceOpen >> showWorkspacePane) [] False+    ,AD "FileOpenPackage" (__ "_Package...") Nothing Nothing+        (showWorkspacePane >> workspaceTry workspaceAddPackage) [] False+    ,AD "FileOpenFile" (__ "_File...") Nothing (Just "gtk-open")         fileOpen [] False-    ,AD "RecentFiles" (__ "Open _Recent") Nothing Nothing (return ()) [] False-    ,AD "FileRevert" (__ "_Revert") Nothing Nothing-        fileRevert [] False+    ,AD "FileRecentFiles" (__ "Recent Files") Nothing Nothing (return ()) [] False+    ,AD "FileRecentWorkspaces" (__ "Recent Workspaces") Nothing Nothing (return ()) [] False     ,AD "FileSave" (__ "_Save") Nothing (Just "gtk-save")         (do fileSave False; return ()) [] False     ,AD "FileSaveAs" (__ "Save _As...") Nothing (Just "gtk-save-as")@@ -159,6 +172,8 @@         (do fileSaveAll (\ b -> return (bufferName b /= "_Eval.hs")); return ()) [] False     ,AD "FileClose" (__ "_Close") Nothing (Just "gtk-close")         (do fileClose; return ()) [] False+    ,AD "FileCloseWorkspace" (__ "Close Workspace") Nothing Nothing+        workspaceClose [] False     ,AD "FileCloseAll" (__ "Close All") Nothing Nothing         (do fileCloseAll (\ b -> return (bufferName b /= "_Eval.hs")); return ()) [] False     ,AD "FileCloseAllButPackage" (__ "Close All But Package") Nothing Nothing@@ -212,17 +227,13 @@         (align ':') [] False      ,AD "Workspace" (__ "_Workspace") Nothing Nothing (return ()) [] False-    ,AD "NewWorkspace" (__ "_New...") Nothing Nothing-        (workspaceNew >> showWorkspace) [] False-    ,AD "OpenWorkspace" (__ "_Open...") Nothing Nothing-        (workspaceOpen >> showWorkspace) [] False-    ,AD "RecentWorkspaces" (__ "Open _Recent") Nothing Nothing (return ()) [] False-    ,AD "CloseWorkspace" (__ "_Close") Nothing Nothing-        workspaceClose [] False--    ,AD "CleanWorkspace" (__ "Cl_ean") (Just (__ "Cleans all packages")) (Just "ide_clean")+    ,AD "WorkspaceAddPackage" (__ "_Add Package...") Nothing Nothing+        (showWorkspacePane >> workspaceTry workspaceAddPackage) [] False+    ,AD "WorkspaceAddPackageCopy" (__ "_Add Copy Of Installed Package...") Nothing Nothing+    (showWorkspacePane >> workspaceTry workspacePackageClone) [] False+    ,AD "CleanWorkspace" (__ "Cl_ean All packages") (Just (__ "Cleans all packages in the workspace")) (Just "ide_clean")         (workspaceTry workspaceClean) [] False-    ,AD "MakeWorkspace" (__ "_Make") (Just (__ "Makes all of this workspace")) (Just "ide_configure")+    ,AD "MakeWorkspace" (__ "_Build All packages") (Just (__ "Builds all of the packages in the workspace")) (Just "ide_configure")         (workspaceTry workspaceMake) [] False     ,AD "NextError" (__ "_Next Error") (Just (__ "Go to the next error")) (Just "ide_error_next")         nextError [] False@@ -230,12 +241,6 @@         previousError [] False      ,AD "Package" (__ "_Package") Nothing Nothing (return ()) [] False-    ,AD "NewPackage" (__ "_New...") Nothing Nothing-        (showWorkspace >> workspaceTry workspacePackageNew) [] False-    ,AD "AddPackage" (__ "_Add...") Nothing Nothing-        (showWorkspace >> workspaceTry workspaceAddPackage) [] False-    ,AD "ClonePackage" (__ "Add From Source _Repository...") Nothing Nothing-        (showWorkspace >> workspaceTry workspacePackageClone) [] False --    ,AD "RecentPackages" "_Recent Packages" Nothing Nothing (return ()) [] False     ,AD "PackageEdit" (__ "_Edit") Nothing Nothing (return ()) [] False     ,AD "EditPackage" (__ "With _Package Editor") Nothing Nothing@@ -286,7 +291,7 @@         (packageTry packageTest) [] False     ,AD "SdistPackage" (__ "Source Dist") Nothing Nothing         (packageTry packageSdist) [] False-    ,AD "OpenDocPackage" (__ "_Open Doc") Nothing Nothing+    ,AD "OpenDocPackage" (__ "_Open Documentation") Nothing Nothing         (packageTry packageOpenDoc) [] False      ,AD "Debug" (__ "_Debug") Nothing Nothing (return ()) [] False@@ -361,29 +366,27 @@         debugType [] False      ,AD "Metadata" (__ "_Metadata") Nothing Nothing (return ()) [] False-    ,AD "UpdateMetadataCurrent" (__ "_Update workspace data") (Just (__ "Updates data for the current workspace"))+    ,AD "UpdateMetadataCurrent" (__ "_Update Workspace Data") (Just (__ "Updates data for the current workspace"))             (Just "ide_rebuild_meta") updateWorkspaceInfo [] False-    ,AD "RebuildMetadataCurrent" (__ "_Rebuild workspace data") (Just (__ "Rebuilds data for the current workspace"))+    ,AD "RebuildMetadataCurrent" (__ "_Rebuild Workspace Data") (Just (__ "Rebuilds data for the current workspace"))             Nothing rebuildWorkspaceInfo [] False-    ,AD "UpdateMetadataLib" (__ "U_pdate system data") Nothing Nothing+    ,AD "UpdateMetadataLib" (__ "U_pdate System Data") Nothing Nothing         updateSystemInfo [] False-    ,AD "RebuildMetadataLib" (__ "R_ebuild system data") Nothing Nothing+    ,AD "RebuildMetadataLib" (__ "R_ebuild System Data") Nothing Nothing         rebuildSystemInfo [] False      ,AD "Session" (__ "_Session") Nothing Nothing (return ()) [] False-    ,AD "SaveSession" (__ "_Save Session") Nothing Nothing+    ,AD "SaveSession" (__ "_Save Session As...") Nothing Nothing         saveSessionAsPrompt [] False     ,AD "LoadSession" (__ "_Load Session") Nothing Nothing         loadSessionPrompt [] False-    ,AD "ForgetSession" (__ "_Forget Session") Nothing Nothing-        (return ()) [] True      ,AD "Panes" (__ "_Panes") Nothing Nothing (return ()) [] False     ,AD "ShowBrowser" (__ "Browser") Nothing Nothing         showBrowser [] False     ,AD "ShowModules" (__ "Modules") Nothing Nothing         showModules [] False-    ,AD "ShowInfo" (__ "Info") Nothing Nothing+    ,AD "ShowInfo" (__ "Symbol _Info") Nothing Nothing         showInfo [] False     ,AD "ShowDebugger" (__ "Debugger") Nothing Nothing         showDebugger [] False@@ -395,8 +398,6 @@         showVariables [] False     ,AD "ShowSearch" (__ "Search") Nothing Nothing         (getSearch Nothing  >>= \ p -> displayPane p False) [] False-    ,AD "ShowFiles" (__ "Files") Nothing Nothing-        (getFiles Nothing  >>= \ p -> displayPane p False >> refreshFiles) [] False     ,AD "ShowGrep" (__ "Grep") Nothing Nothing         (getGrep Nothing  >>= \ p -> displayPane p False) [] False     ,AD "ShowDocumentation" (__ "Documentation") Nothing Nothing@@ -410,7 +411,7 @@     ,AD "ShowLog" (__ "Log") Nothing Nothing         showLog [] False     ,AD "ShowWorkspace" (__ "Workspace") Nothing Nothing-        showWorkspace [] False+        showWorkspacePane [] False      ,AD "View" (__ "_View") Nothing Nothing (return ()) [] False     ,AD "ViewMoveLeft" (__ "Move _Left") Nothing Nothing@@ -433,9 +434,8 @@         viewDetachInstrumented [] False     ,AD "ViewFullScreen" (__ "_Full Screen") Nothing Nothing         viewFullScreen [] True-    ,AD "ViewDark" (__ "Dark") Nothing Nothing-        viewDark [] True-+    ,AD "UseDarkInterface" (__ "_Use Dark Interface") Nothing Nothing+        viewUseDarkInterface [] True     ,AD "ViewTabsLeft" (__ "Tabs Left") Nothing Nothing         (viewTabsPos PosLeft) [] False     ,AD "ViewTabsRight" (__ "Tabs Right") Nothing Nothing@@ -468,11 +468,9 @@     ,AD "ToggleToolbar" (__ "Toggle Toolbar") Nothing Nothing         toggleToolbar [] False -    ,AD "Configuration" (__ "_Configuration") Nothing Nothing (return ()) [] False-    ,AD "EditCandy" (__ "_To Candy") Nothing Nothing-        editCandy [] True-    ,AD "PrefsEdit" (__ "_Edit Prefs") Nothing Nothing-        (getPrefs Nothing >>= \ p -> displayPane p False) [] False+    ,AD "Tools" (__ "_Tools") Nothing Nothing (return ()) [] False+    ,AD "PrefsEdit" (__ "_Preferences") Nothing Nothing+        runPreferencesDialog [] False      ,AD "Help" (__ "_Help") Nothing Nothing (return ()) [] False     ,AD "HelpDebug" (__ "Debug") Nothing Nothing (do@@ -489,7 +487,7 @@         runUnitTestsToggled [] True     ,AD "MakeModeToggled" (__ "_MakeMode") (Just (__ "Make dependent packages")) (Just "ide_make")         makeModeToggled [] True-    ,AD "DebugToggled" "_GHCi" (Just (__ "Use GHCi debugger to build and run")) (Just "ide_debug")+    ,AD "DebugToggled" "_Enable GHCi" (Just (__ "Use GHCi debugger to build and run")) (Just "ide_debug")         debugToggled [] True     ,AD "OpenDocu" (__ "_OpenDocu") (Just (__ "Opens a browser for a search of the selected data")) Nothing         openDocu [] True@@ -509,28 +507,40 @@     recentFiles'       <-  readIDE recentFiles     recentWorkspaces'  <-  readIDE recentWorkspaces     recentFilesItem    <-  getRecentFiles-    recentWorkspacesItem <-  getRecentWorkspaces+    recentWorkspacesItem <- getRecentWorkspaces     reifyIDE (\ ideR -> do         recentFilesMenu    <-  menuNew-        mapM_ (\s -> do-            fe <- doesFileExist s-            when fe $ do-                mi <- menuItemNewWithLabel $ T.pack s-                mi `on` menuItemActivate $ reflectIDE (fileOpen' s) ideR-                menuShellAppend recentFilesMenu mi) recentFiles'+        existingRecentFiles <- filterM doesFileExist recentFiles'+        if null existingRecentFiles+            then do+                mi <- menuItemNewWithLabel (T.pack "No recently opened files")+                widgetSetSensitive mi False+                menuShellAppend recentFilesMenu mi+            else+                forM_ recentFiles' $ \s -> do+                    mi <- menuItemNewWithLabel $ T.pack s+                    mi `on` menuItemActivate $ reflectIDE (fileOpen' s) ideR+                    menuShellAppend recentFilesMenu mi         oldSubmenu <- menuItemGetSubmenu recentFilesItem         when (isJust oldSubmenu) $ do             widgetHide (fromJust oldSubmenu)             widgetDestroy (fromJust oldSubmenu)         menuItemSetSubmenu recentFilesItem recentFilesMenu         widgetShowAll recentFilesMenu+         recentWorkspacesMenu    <-  menuNew-        mapM_ (\s -> do-            fe <- doesFileExist s-            when fe $ do-                mi <- menuItemNewWithLabel $ T.pack s-                mi `on` menuItemActivate $ reflectIDE (workspaceOpenThis True (Just s) >> showWorkspace) ideR-                menuShellAppend recentWorkspacesMenu mi) recentWorkspaces'+        existingRecentWorkspaces <- filterM doesFileExist recentWorkspaces'+        if null existingRecentWorkspaces+            then do+                mi <- menuItemNewWithLabel (T.pack "No recently opened workspaces")+                widgetSetSensitive mi False+                menuShellAppend recentWorkspacesMenu mi+            else+                forM_ existingRecentWorkspaces $ \s -> do+                    mi <- menuItemNewWithLabel $ T.pack s+                    mi `on` menuItemActivate $ reflectIDE (workspaceOpenThis True (Just s) >> showWorkspacePane) ideR+                    menuShellAppend recentWorkspacesMenu mi+         oldSubmenu <- menuItemGetSubmenu recentWorkspacesItem         when (isJust oldSubmenu) $ do             widgetHide (fromJust oldSubmenu)@@ -623,13 +633,12 @@     menuShellAppend menu mi2     mi3 <- menuItemNewWithLabel (__ "Search (metadata)")     mi3 `on` menuItemActivate $-      reflectIDE_ $-         getSearch Nothing >>=-           (\ search ->-              do mbtext <- selectedText-                 case mbtext of-                     Just t -> searchMetaGUI search t-                     Nothing -> ideMessage Normal (__ "Select a text first"))+      reflectIDE_ $ do+         mbtext <- selectedTextOrCurrentIdentifier -- if no text selected, search for current identifier+         searchPane <- getSearch Nothing+         case mbtext of+              Just t  -> searchMetaGUI searchPane t+              Nothing -> ideMessage Normal (__ "No identifier selected")     menuShellAppend menu mi3     let interpretingEntries = [castToWidget mi16]     let interpretingSelEntries@@ -652,7 +661,9 @@ canQuit :: IDEM Bool canQuit = do     modifyIDE_ (\ide -> ide{currentState = IsShuttingDown})-    saveSession :: IDEAction+    prefs <- readIDE prefs+    when (saveSessionOnClose prefs) $+        saveSession     can <- fileCloseAll (\_ -> return True)     unless can $ modifyIDE_ (\ide -> ide{currentState = IsRunning})     return can@@ -670,10 +681,11 @@ aboutDialog = do     d <- aboutDialogNew     dd <- getDataDir+    (year, _, _) <- liftM (toGregorian . utctDay) getCurrentTime     license <- catch (T.readFile $ dd </> T.unpack (__ "LICENSE")) (\ (_ :: SomeException) -> return "")     set d [ aboutDialogName := ("Leksah" :: Text)           , aboutDialogVersion := T.pack $ showVersion version-          , aboutDialogCopyright := __ "Copyright 2007-2011 Jürgen Nicklisch-Franken, Hamish Mackenzie"+          , aboutDialogCopyright := __ "Copyright 2007-" <> T.pack (show year) <> " Jürgen Nicklisch-Franken, Hamish Mackenzie"           , aboutDialogComments := __ "An integrated development environement (IDE) for the " <>                                __ "programming language Haskell and the Glasgow Haskell Compiler"           , aboutDialogLicense := Just license@@ -688,12 +700,16 @@ newIcons = catch (do         iconFactory <- iconFactoryNew         dataDir <- getDataDir-        mapM_ (loadIcon dataDir iconFactory) ["ide_class","ide_configure","ide_data","ide_error_next",++        mapM_ (loadIcon dataDir iconFactory)+            ["ide_class","ide_configure","ide_data","ide_error_next",             "ide_error_prev","ide_function","ide_instance", "ide_konstructor","ide_make",             "ide_method","ide_newtype","ide_other","ide_rule","ide_run","ide_slot",             "ide_source","ide_type","leksah", "ide_reexported", "ide_clean", "ide_link", "ide_build",             "ide_debug", "ide_step", "ide_local", "ide_module", "ide_continue", "ide_rebuild_meta",-            "ide_empty","ide_source_local", "ide_js"]+            "ide_empty","ide_source_local", "ide_js", "ide_folder", "ide_source_folder",+            "ide_cabal_file", "ide_package", "ide_component", "ide_source_dependency", "ide_error",+            "ide_warning", "ide_suggestion"  ]         iconFactoryAddDefault iconFactory)     (\(e :: SomeException) -> getDataDir >>= \dataDir -> throwIDE (T.pack $ printf (__ "Can't load icons from %s %s") dataDir (show e)))     where@@ -701,6 +717,7 @@         pb      <-  pixbufNewFromFile $ dataDir </> "pics" </> (name <> ".png")         icon    <-  iconSetNewFromPixbuf pb         iconFactoryAdd iconFactory (T.pack name) icon+        iconThemeAddBuiltinIcon name 16 pb  setSensitivity :: [(SensitivityMask, Bool)] -> IDEAction setSensitivity = mapM_ setSensitivitySingle@@ -720,7 +737,7 @@     ,"OpenDocPackage","FileCloseAll"] getActionsFor SensitivityError = getActionsFor' ["NextError", "PreviousError"] getActionsFor SensitivityEditor = getActionsFor' ["EditUndo", "EditRedo",-        "EditGotoLine","EditComment", "EditUncomment",+        "EditGotoLine","EditComment", "EditUncomment", "EditSelectAll",         "EditShiftLeft", "EditShiftRight","FileClose",         "OpenDocu"         ]@@ -752,6 +769,16 @@             instrumentSecWindow win             liftIO $ widgetShowAll win +viewUseDarkInterface :: IDEAction+viewUseDarkInterface = do+    useDark <- getDarkState+    prefs <- readIDE prefs+    when (useDark /= darkUserInterface prefs) $ do+        let prefs' = prefs {darkUserInterface = useDark}+        modifyIDE_ (\ide -> ide {prefs = prefs'})+        applyInterfaceTheme++ instrumentWindow :: Window -> Prefs -> Widget -> IDEAction instrumentWindow win prefs topWidget = do     -- sets the icon@@ -779,7 +806,6 @@         windowAddAccelGroup win acc         containerAdd win vb         reflectIDE (do-            setCandyState (fst (sourceCandy prefs))             setBackgroundBuildToggled (backgroundBuild prefs)             setRunUnitTests (runUnitTests prefs)             setMakeModeToggled (makeMode prefs)) ideR@@ -822,8 +848,7 @@             flipUp             return True         _                                                            -> do-                bs <- getCandyState-                when bs (editKeystrokeCandy mbChar)+                when (candyState prefs') (editKeystrokeCandy mbChar)                 sk  <- readIDE specialKey                 sks <- readIDE specialKeys                 case sk of@@ -899,8 +924,14 @@     registerEvent stRef "UpdateWorkspaceInfo"         (\ e@UpdateWorkspaceInfo  -> updateWorkspaceInfo >> return e)     registerEvent stRef "WorkspaceChanged"-        (\ e@(WorkspaceChanged showPane updateFileCache)-                                  -> postAsyncIDE (updateWorkspace showPane updateFileCache) >> return e)+        (\ e@(WorkspaceChanged showPane updateFileCache) -> do+                                     postAsyncIDE $ do+                                         refreshWorkspacePane+                                         when showPane+                                            showWorkspacePane+                                         when updateFileCache $+                                            modifyIDE_ (\ide -> ide{bufferProjCache = Map.empty})+                                     return e)     registerEvent stRef "RecordHistory"         (\ rh@(RecordHistory h)   -> recordHistory h >> return rh)     registerEvent stRef "Sensitivity"@@ -922,9 +953,7 @@     registerEvent stRef "ErrorAdded"         (\ e@(ErrorAdded show' i ref) -> postAsyncIDE (addErrorToList show' i ref) >> return e)     registerEvent stRef "CurrentErrorChanged"-        (\ e@(CurrentErrorChanged mbLogRef) -> postAsyncIDE (do-            selectRef mbLogRef-            selectError mbLogRef)  >> return e)+        (\ e@(CurrentErrorChanged mbLogRef) -> postAsyncIDE (selectRef mbLogRef)  >> return e)     registerEvent stRef "BreakpointChanged"         (\ e@BreakpointChanged    -> postAsyncIDE fillBreakpointList >> return e)     registerEvent stRef "CurrentBreakChanged"@@ -942,7 +971,12 @@     registerEvent stRef "SelectSrcSpan"         (\ e@(SelectSrcSpan mbSpan) -> selectMatchingErrors mbSpan >> return e)     registerEvent stRef "SavedFile"-        (\ e@(SavedFile file) -> scheduleHLint (Right file) >> return e)+        (\ e@(SavedFile file) -> do+              prefs <- readIDE prefs+              when (hlintOnSave prefs && takeExtension file `elem` [".hs", ".lhs"]) $+                  scheduleHLint (Right file)+              return e)+     return ()  

@@ -31,7 +31,6 @@ import qualified Control.Monad.Reader as Gtk (liftIO) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Applicative ((<$>))-import IDE.Utils.GUIUtils (getDarkState) import Data.Text (Text) import qualified Data.Text as T        (empty, commonPrefixes, pack, unpack, null, stripPrefix,

@@ -445,7 +445,7 @@             modifyIDE_ (\ide -> ide{activePack = Just ideP})         _ -> return ()     where-        key = ipdBuildDir+        key = ipdPackageDir         idePKey = key ideP         exchange p | key p == idePKey = ideP                    | otherwise        = p

@@ -45,8 +45,10 @@ ,   runDebug  ,   IDEPackage(..)-,   ipdBuildDir+,   ipdPackageDir ,   ipdAllDirs+,   ipdLib+,   ipdPackageName ,   Workspace(..) ,   wsAllPackages ,   VCSConf@@ -56,6 +58,7 @@ ,   KeyString  ,   Prefs(..)+,   candyState ,   cabalCommand ,   EditorStyle(..) ,   editorStyle@@ -99,7 +102,7 @@ import Data.Unique (newUnique, Unique(..)) import Graphics.UI.Frame.Panes import Distribution.Package-    (PackageIdentifier(..), Dependency(..))+       (PackageName(..), PackageIdentifier(..), Dependency(..)) import Distribution.PackageDescription (BuildInfo) import Data.Map (Map(..)) import Data.Set (Set(..))@@ -119,7 +122,7 @@ import IDE.Core.CTypes import IDE.StrippedPrefs(RetrieveStrategy) import System.IO (Handle)-import Distribution.Text(disp)+import Distribution.Text (display, disp) import Text.PrettyPrint (render) import Control.Monad.Trans.Class (lift) import Control.Monad.IO.Class (liftIO, MonadIO)@@ -133,11 +136,12 @@ import Foreign (Ptr) import Control.Monad.Reader.Class (MonadReader(..)) import Data.Text (Text)-import qualified Data.Text as T (unpack)+import qualified Data.Text as T (pack, unpack) import Language.Haskell.HLint3 (Idea(..)) import Data.Function (on) import Control.Concurrent.STM.TVar (TVar) import Data.Sequence (Seq)+import Data.Maybe (maybeToList)  -- --------------------------------------------------------------------- -- IDE State@@ -382,7 +386,7 @@ ,   ipdBenchmarks      ::   [Text] ,   ipdMain            ::   [(FilePath, BuildInfo, Bool)] ,   ipdExtraSrcs       ::   Set FilePath-,   ipdSrcDirs         ::   [FilePath]+,   ipdSrcDirs         ::   [FilePath] -- ^ Relative paths to the source directories ,   ipdExtensions      ::   [Extension] ,   ipdConfigFlags     ::   [Text] ,   ipdBuildFlags      ::   [Text]@@ -403,11 +407,21 @@ instance Ord IDEPackage where     compare x y     =   compare (ipdPackageId x) (ipdPackageId y) -ipdBuildDir :: IDEPackage -> FilePath-ipdBuildDir = dropFileName . ipdCabalFile+-- | The directory of the cabal file+ipdPackageDir :: IDEPackage -> FilePath+ipdPackageDir = dropFileName . ipdCabalFile +-- | Gets the package name+ipdPackageName :: IDEPackage -> Text+ipdPackageName = T.pack . (\(PackageName s) -> s) . pkgName . ipdPackageId++-- | Gets the library name if the package has a library component+ipdLib :: IDEPackage -> Maybe Text+ipdLib pkg = if ipdHasLibs pkg then Just (ipdPackageName pkg) else Nothing++-- | All directory of the package and those of all its source dependencies ipdAllDirs :: IDEPackage -> [FilePath]-ipdAllDirs p = ipdBuildDir p : (ipdSandboxSources p >>= ipdAllDirs)+ipdAllDirs p = ipdPackageDir p : (ipdSandboxSources p >>= ipdAllDirs)  -- --------------------------------------------------------------------- -- Workspace@@ -461,6 +475,8 @@     ,   tabWidth            ::   Int     ,   wrapLines           ::   Bool     ,   sourceCandy         ::   (Bool,Text)+    ,   darkUserInterface   ::   Bool+    ,   saveSessionOnClose  ::   Bool     ,   keymapName          ::   Text     ,   forceLineEnds       ::   Bool     ,   removeTBlanks       ::   Bool@@ -504,6 +520,8 @@     ,   printBindResult     ::   Bool     ,   serverIP            ::   Text     ,   showHiddenFiles     ::   Bool+    ,   showWorkspaceIcons  ::   Bool+    ,   hlintOnSave         ::   Bool             -- As well used by server     ,   serverPort          ::   Int     ,   sourceDirectories   ::   [FilePath]@@ -516,6 +534,9 @@ cabalCommand :: Prefs -> FilePath cabalCommand p = if useCabalDev p then "cabal-dev" else "cabal" +candyState :: Prefs -> Bool+candyState = fst . sourceCandy+ data EditorStyle = EditorStyle { styleName    :: Maybe Text                                , preferDark   :: Bool                                , foundBG      :: (Color, Color)@@ -590,7 +611,7 @@             show (srcSpanStartColumn s) ++ "-" ++ show (srcSpanEndColumn s)  logRefRootPath :: LogRef -> FilePath-logRefRootPath = ipdBuildDir . logRefPackage+logRefRootPath = ipdPackageDir . logRefPackage  logRefFilePath :: LogRef -> FilePath logRefFilePath = srcSpanFilename . logRefSrcSpan@@ -677,4 +698,4 @@     |   CompartmentCollect Bool  type PackageDescrCache = Map PackageIdentifier ModuleDescrCache-type ModuleDescrCache = Map ModuleName (UTCTime, Maybe FilePath, ModuleDescr)+type ModuleDescrCache = Map ModuleKey (UTCTime, Maybe FilePath, ModuleDescr)

@@ -9,7 +9,7 @@ -- -- Maintainer  :  <maintainer at leksah.org> -- Stability   :  provisional--- Portability :  portablea+-- Portability :  portable -- -- | The toolbar for searching and replacing in a text buffer --@@ -27,12 +27,9 @@ ,   getFindState ,   setFindState ,   editFind- ,   showToolbar ,   hideToolbar ,   toggleToolbar-- ) where  import Graphics.UI.Gtk@@ -326,7 +323,7 @@         return False      replaceButton `onToolButtonClicked` replace toolbar Forward ideR-    let performReplaceAll = replaceAll toolbar Forward ideR+    let performReplaceAll = replaceAll toolbar Initial ideR     replaceAllButton `onToolButtonClicked` performReplaceAll      let ctrl "c" = toggleToolButton caseSensitiveButton >> return True@@ -488,7 +485,6 @@                 ideR     return () - replaceAll :: Toolbar -> SearchHint -> IDERef -> IO () replaceAll fb hint ideR   =  do     entry          <- getFindEntry fb@@ -499,7 +495,7 @@     caseSensitive  <- getCaseSensitive fb     wrapAround     <- getWrapAround fb     regex          <- getRegex fb-    found <- reflectIDE (editReplaceAll entireWord caseSensitive wrapAround regex search replace hint)+    found <- reflectIDE (editReplaceAll entireWord caseSensitive regex search replace hint)                 ideR     return () @@ -513,43 +509,45 @@ editFind' :: Regex -> Int -> Bool -> Text -> SearchHint -> IDEM Bool editFind' exp matchIndex wrapAround dummy hint =     inActiveBufContext False $ \_ sv ebuf _ _ -> do-    i1 <- getStartIter ebuf-    i2 <- getEndIter ebuf-    text <- getText ebuf i1 i2 True-    removeTagByName ebuf "found"-    startMark <- getInsertMark ebuf-    st1 <- getIterAtMark ebuf startMark-    mbsr2 <--        if hint == Backward-            then do-                st2 <- backwardCharC st1-                st3 <- backwardCharC st2-                mbsr <- backSearch exp matchIndex ebuf text st3-                case mbsr of-                    Nothing ->-                        if wrapAround-                            then backSearch exp matchIndex ebuf text i2-                            else return Nothing-                    m -> return m-            else do-                st2 <- if hint == Forward-                    then forwardCharC st1-                    else return st1-                mbsr <- forwardSearch exp matchIndex ebuf text st2-                case mbsr of-                    Nothing ->-                        if wrapAround-                            then forwardSearch exp matchIndex ebuf text i1-                            else return Nothing-                    m -> return m-    case mbsr2 of-        Just (start,end,_) -> do --found-            --widgetGrabFocus sourceView-            scrollToIter sv start 0.2 Nothing-            applyTagByName ebuf "found" start end-            placeCursor ebuf start-            return True-        Nothing -> return False+        i1 <- getStartIter ebuf+        i2 <- getEndIter ebuf+        text <- getText ebuf i1 i2 True+        removeTagByName ebuf "found"+        startMark <- getInsertMark ebuf+        st1 <- getIterAtMark ebuf startMark+        mbsr2 <-+            if hint == Backward+                then do+                    st2 <- backwardCharC st1+                    st3 <- backwardCharC st2+                    mbsr <- backSearch exp matchIndex ebuf text st3+                    case mbsr of+                        Nothing ->+                            if wrapAround+                                then backSearch exp matchIndex ebuf text i2+                                else return Nothing+                        m -> return m+                else do+                    st2 <- if hint == Forward+                        then forwardCharC st1+                        else return st1+                    mbsr <- if hint == Initial+                            then initialSearch exp matchIndex ebuf text st2+                            else forwardSearch exp matchIndex ebuf text st2+                    case mbsr of+                        Nothing ->+                            if wrapAround+                                then forwardSearch exp matchIndex ebuf text i1+                                else return Nothing+                        m -> return m+        case mbsr2 of+            Just (start,end,_) -> do --found+                --widgetGrabFocus sourceView+                scrollToIter sv start 0.2 Nothing+                applyTagByName ebuf "found" start end+                placeCursor ebuf start+                return True+            Nothing -> return False     where         backSearch exp matchIndex ebuf text iter = do             offset <- getOffset iter@@ -559,6 +557,8 @@             offset <- getOffset iter             findMatch exp matchIndex ebuf text (>= offset) False +        initialSearch exp matchIndex ebuf text iter = findMatch exp matchIndex ebuf text (>= 0) False+ regexAndMatchIndex :: Bool -> Bool -> Bool -> Text -> IO (Maybe (Regex, Int)) regexAndMatchIndex caseSensitive entireWord regex string =     if T.null string@@ -595,21 +595,22 @@  editReplace :: Bool -> Bool -> Bool -> Bool -> Text -> Text -> SearchHint -> IDEM Bool editReplace entireWord caseSensitive wrapAround regex search replace hint =-    editReplace' entireWord caseSensitive wrapAround regex search replace hint True+    editReplace' entireWord caseSensitive wrapAround regex search replace hint False  editReplace' :: Bool -> Bool -> Bool -> Bool -> Text -> Text -> SearchHint -> Bool -> IDEM Bool-editReplace' entireWord caseSensitive wrapAround regex search replace hint mayRepeat =+editReplace' entireWord caseSensitive wrapAround regex search replace hint fromStart =     inActiveBufContext False $ \_ _ ebuf _ _ -> do         insertMark <- getInsertMark ebuf         iter       <- getIterAtMark ebuf insertMark-        offset     <- getOffset iter+        offset   <- getOffset iter+        let offset' = if fromStart then 0 else offset         mbExpAndMatchIndex <- liftIO $ regexAndMatchIndex caseSensitive entireWord regex search         case mbExpAndMatchIndex of             Just (exp, matchIndex) -> do                 iStart <- getStartIter ebuf                 iEnd   <- getEndIter ebuf                 text   <- getText ebuf iStart iEnd True-                match  <- findMatch exp matchIndex ebuf text (== offset) False+                match  <- findMatch exp matchIndex ebuf text (== offset') False                 case match of                     Just (iterStart, iterEnd, matches) -> do                         mbText <- liftIO $ replacementText regex text matchIndex matches $ T.unpack replace@@ -654,11 +655,14 @@  regexReplacement text matchIndex matches (x : xs) = x : regexReplacement text matchIndex matches xs -editReplaceAll :: Bool -> Bool -> Bool -> Bool -> Text -> Text -> SearchHint -> IDEM Bool-editReplaceAll entireWord caseSensitive wrapAround regex search replace hint = do-    res <- editReplace' entireWord caseSensitive False regex search replace hint True+editReplaceAll :: Bool -> Bool -> Bool -> Text -> Text -> SearchHint -> IDEM Bool+editReplaceAll = editReplaceAll' True++editReplaceAll' :: Bool -> Bool -> Bool -> Bool -> Text -> Text -> SearchHint -> IDEM Bool+editReplaceAll' fromStart entireWord caseSensitive regex search replace hint = do+    res <- editReplace' entireWord caseSensitive False regex search replace hint fromStart     if res-        then editReplaceAll entireWord caseSensitive False regex search replace hint+        then editReplaceAll' False entireWord caseSensitive regex search replace hint         else return False  compileRegex :: Bool -> Text -> Either String Regex@@ -680,19 +684,19 @@         Nothing -> throwIDE "Find>>needFindbar: Findbar not initialized"         Just p  -> return p +-- | Find action. If SearchHint==Initial then we'll use the selected text or current identifier to populate the find text box editFindInc :: SearchHint -> IDEAction editFindInc hint = do     ideR <- ask     (fb,_) <- needFindbar     case hint of-        Initial -> inActiveBufContext () $ \_ _ ebuf _ _ -> do-            hasSelection <- hasSelection ebuf-            when hasSelection $ do-                (i1,i2)   <- getSelectionBounds ebuf-                text      <- getText ebuf i1 i2 False-                findEntry <- liftIO $ getFindEntry fb-                liftIO $ entrySetText (castToEntry findEntry) text-                return ()+        Initial -> do+               mbtext <- selectedTextOrCurrentIdentifier -- if no text selected, search for current identifier+               case mbtext of+                 Just text -> do+                     findEntry <- liftIO $ getFindEntry fb+                     liftIO $ entrySetText (castToEntry findEntry) text+                 Nothing -> return ()         _ -> return ()     showFindbar     reifyIDE $ \ideR   -> do

@@ -26,7 +26,7 @@ import Prelude hiding(getChar, getLine) import IDE.Core.Types        (logRefFullFilePath, Prefs(..), LogRef(..), LogRefType(..),-        wsAllPackages, ipdBuildDir, IDEM, IDEAction, IDE(..),+        wsAllPackages, ipdPackageDir, IDEM, IDEAction, IDE(..),         IDEPackage(..), PackageAction) import Control.Monad.Reader (asks, MonadReader(..)) import IDE.Core.State@@ -111,7 +111,7 @@ runHLint (Right sourceFile) = do     liftIO . debugM "leksah" $ "runHLint"     packages <- maybe [] wsAllPackages <$> readIDE workspace-    case sortBy (flip (comparing (length . ipdBuildDir))) $ filter (belongsToPackage sourceFile) packages of+    case sortBy (flip (comparing (length . ipdPackageDir))) $ filter (belongsToPackage sourceFile) packages of         (package:_) -> runHLint' package (Just sourceFile)         _ -> liftIO . debugM "leksah" $ "runHLint package not found for " <> sourceFile runHLint (Left cabalFile) = do@@ -131,8 +131,8 @@                     Just f  -> return [f]                     Nothing -> getSourcePaths (ipdPackageId package) modules     res <- forM paths $ \ full -> do-        let file = makeRelative (ipdBuildDir package) full-        postSyncIDE $ removeLintLogRefs (ipdBuildDir package) file+        let file = makeRelative (ipdPackageDir package) full+        postSyncIDE $ removeLintLogRefs (ipdPackageDir package) file         text <- liftIO $ T.readFile full         liftIO . debugM "leksah" $ "runHLint parsing " <> full         do result <- liftIO $ parseModuleEx flags full (Just (T.unpack text))@@ -172,7 +172,7 @@ hlintSettings :: IDEPackage -> IDEM (ParseFlags, [Classify], Hint) hlintSettings package = do     mbHlintDir <- liftIO $ leksahSubDir "hlint"-    let cabalMacros = ipdBuildDir package </> "dist/build/autogen/cabal_macros.h"+    let cabalMacros = ipdPackageDir package </> "dist/build/autogen/cabal_macros.h"     cabalMacrosExist <- liftIO $ doesFileExist cabalMacros     defines <- liftIO $ if cabalMacrosExist                             then do@@ -192,7 +192,7 @@     forM_ ideas $ \ idea@Idea{..} -> do         let text = getText (HSE.srcSpanFilename ideaSpan)             fixColumn c = max 0 (c - 1)-            srcSpan = SrcSpan (makeRelative (ipdBuildDir package) $ HSE.srcSpanFilename ideaSpan)+            srcSpan = SrcSpan (makeRelative (ipdPackageDir package) $ HSE.srcSpanFilename ideaSpan)                               (HSE.srcSpanStartLine ideaSpan)                               (HSE.srcSpanStartColumn ideaSpan - 1)                               (HSE.srcSpanEndLine ideaSpan)@@ -213,7 +213,7 @@ logHLintError :: Bool -> IDEPackage -> ParseError -> IDEAction logHLintError fileScope package error = do     let loc = parseErrorLocation error-        srcSpan = SrcSpan (makeRelative (ipdBuildDir package) $ HSE.srcFilename loc)+        srcSpan = SrcSpan (makeRelative (ipdPackageDir package) $ HSE.srcFilename loc)                           (HSE.srcLine loc)                           (HSE.srcColumn loc - 1)                           (HSE.srcLine loc)

@@ -17,6 +17,7 @@     resolveErrors ,   addOneImport ,   addResolveMenuItems+,   resolveMenuItems ,   parseHiddenModule ,   HiddenModuleResult(..) ) where@@ -546,6 +547,14 @@                 setModified gtkbuf True                 continuation True         _  -> return ()++resolveMenuItems :: LogRef -> [(Text, IDEAction)]+resolveMenuItems logRef+    | isJust (parseNotInScope msg)   = [("Add Import", addImport logRef [] (\ _ -> return ()))]+    | isJust (parseHiddenModule msg) = [("Add Package", void $ addPackages [logRef])]+    | length (parsePerhapsYouIntendedToUse msg) == 1 = [("Add Extension", addExtension logRef (\ _ -> return ()))]+    | otherwise = []+    where msg = refDescription logRef  addResolveMenuItems ideR theMenu logRef = do     let msg = refDescription logRef

@@ -46,7 +46,7 @@ import Graphics.UI.Editor.MakeEditor import Graphics.UI.Editor.Parameters import IDE.Command-import IDE.Pane.Preferences+import IDE.Preferences import IDE.Keymap import IDE.Pane.SourceBuffer import IDE.Find@@ -410,7 +410,6 @@     on win deleteEvent . liftIO $ reflectIDE quit ideR >> return True     reflectIDE (instrumentWindow win startupPrefs (castToWidget nb)) ideR     reflectIDE (do-        setCandyState (fst (sourceCandy startupPrefs))         setBackgroundBuildToggled (backgroundBuild startupPrefs)         setRunUnitTests (runUnitTests startupPrefs)         setMakeModeToggled (makeMode startupPrefs)) ideR

@@ -383,7 +383,7 @@ logOutputLines logLaunch lineLogger = do     log :: Log.IDELog <- lift $ postSyncIDE Log.getLog     results <- CL.mapM (postSyncIDE . lineLogger log logLaunch) =$ CL.consume-    lift $ triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])+    lift . postSyncIDE $ triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])     return results  logOutputLines_ :: LogLaunch@@ -514,7 +514,7 @@                         logLn <- Log.appendLog log logLaunch (line <> "\n") LogTag                         reflectIDE (triggerEventIDE (StatusbarChanged [CompartmentState                             (T.pack $ "Compiling " ++ show n ++ " of " ++ show total), CompartmentBuild False])) ideR-                        let root = ipdBuildDir package+                        let root = ipdPackageDir package                             fullFilePath = root </> file                         reflectIDE (removeBuildLogRefs root file) ideR                         when inDocTest $ logPrevious testFails@@ -574,7 +574,7 @@                         -> LogLaunch           -- ^ loglaunch                         -> C.Sink ToolOutput IDEM () logOutputForBreakpoints package logLaunch = do-    breaks <- logOutputLines logLaunch (\log logLaunch out ->+    breaks <- logOutputLines logLaunch (\log logLaunch out -> postSyncIDE $         case out of             ToolOutput line -> do                 logLineNumber <- liftIO $ Log.appendLog log logLaunch (line <> "\n") LogTag@@ -602,7 +602,7 @@             _ -> do                 defaultLineLogger log logLaunch out                 return Nothing)-    lift . addLogRefs . Seq.fromList $ catMaybes breaks+    lift . postSyncIDE . addLogRefs . Seq.fromList $ catMaybes breaks  logOutputForSetBreakpointDefault :: IDEPackage                                  -> C.Sink ToolOutput IDEM ()@@ -626,7 +626,7 @@             _ -> do                 defaultLineLogger log logLaunch out                 return Nothing)-    lift $ unless (null refs) $ do+    lift . unless (null refs) . postSyncIDE $ do         addLogRefs . Seq.singleton $ last refs         lastContext 

@@ -1,3 +1,4 @@+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} -----------------------------------------------------------------------------@@ -33,16 +34,20 @@ ,   getSystemInfo  ,   getPackageImportInfo -- Scope for the import tool+,   getAllPackageIds+,   getAllPackageIds' ) where +import Prelude ()+import Prelude.Compat hiding(catch, readFile) import System.IO (hClose, openBinaryFile, IOMode(..)) import System.IO.Strict (readFile) import qualified Data.Map as Map-import Control.Monad+import Control.Monad (void, filterM, foldM, liftM, when) import System.FilePath import System.Directory-import Data.List-import Data.Maybe+import Data.List (nub, (\\), find, partition, maximumBy, foldl')+import Data.Maybe (catMaybes, fromJust, isJust, mapMaybe, fromMaybe) import Distribution.Package hiding (depends,packageId) import qualified Data.Set as Set import qualified Data.ByteString.Char8 as BS@@ -64,7 +69,6 @@ import IDE.Core.Serializable () import Data.Map (Map(..)) import Control.Exception (SomeException(..), catch)-import Prelude hiding(catch, readFile) import IDE.Utils.ServerConnection(doServerCommand) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (MonadTrans(..))@@ -75,6 +79,7 @@ import Data.Monoid ((<>)) import qualified Control.Arrow as A (Arrow(..)) import Data.Function (on)+import Distribution.Package (PackageIdentifier)  -- --------------------------------------------------------------------- -- Updating metadata@@ -131,6 +136,19 @@     updateWorkspaceInfo' True $ \ _ ->         void (triggerEventIDE (InfoChanged False)) +getAllPackageIds :: IDEM [PackageIdentifier]+getAllPackageIds = either (const []) id <$> getAllPackageIds'++getAllPackageIds' :: IDEM (Either Text [PackageIdentifier])+getAllPackageIds' = do+    mbWorkspace <- readIDE workspace+    liftIO . getInstalledPackageIds' $ map ipdPackageDir (maybe [] wsAllPackages mbWorkspace)++getAllPackageDBs :: IDEM [[FilePath]]+getAllPackageDBs = do+    mbWorkspace <- readIDE workspace+    liftIO . getPackageDBs $ map ipdPackageDir (maybe [] wsAllPackages mbWorkspace)+ -- -- | Load all infos for all installed and exposed packages --   (see shell command: ghc-pkg list)@@ -138,7 +156,7 @@ loadSystemInfo :: IDEAction loadSystemInfo = do     collectorPath   <-  liftIO getCollectorPath-    mbPackageIds    <-  liftIO getInstalledPackageIds'+    mbPackageIds    <-  getAllPackageIds'     case mbPackageIds of         Left e -> logMessage ("Please check that ghc-pkg is in your PATH and restart leksah:\n    " <> e) ErrorTag         Right packageIds -> do@@ -161,7 +179,7 @@     case wi of         Nothing -> loadSystemInfo         Just (GenScopeC (PackScope psmap psst)) -> do-            mbPackageIds    <-  liftIO getInstalledPackageIds'+            mbPackageIds    <-  getAllPackageIds'             case mbPackageIds of                 Left e -> logMessage ("Please check that ghc-pkg is in your PATH and restart leksah:\n    " <> e) ErrorTag                 Right packageIds -> do@@ -255,35 +273,39 @@                 continuation True     postAsyncIDE $ ideMessage Normal "Finished updating workspace metadata" +-- | Update the metadata on several packages updatePackageInfos :: Bool -> [IDEPackage] -> (Bool -> [PackageDescr] -> IDEAction) -> IDEAction-updatePackageInfos = updatePackageInfos' []+updatePackageInfos rebuild pkgs continuation = do+    -- calculate list of known packages once+    knownPackages   <- getAllPackageIds+    updatePackageInfos' [] knownPackages rebuild pkgs continuation     where-        updatePackageInfos' collector _ [] continuation =  continuation True collector-        updatePackageInfos' collector rebuild (hd:tail) continuation =-            updatePackageInfo rebuild hd $ \ _ packDescr ->-                updatePackageInfos' (packDescr : collector) rebuild tail continuation+        updatePackageInfos' collector _ _ [] continuation =  continuation True collector+        updatePackageInfos' collector knownPackages rebuild (hd:tail) continuation =+            updatePackageInfo knownPackages rebuild hd $ \ _ packDescr ->+                updatePackageInfos' (packDescr : collector) knownPackages rebuild tail continuation -updatePackageInfo :: Bool -> IDEPackage -> (Bool -> PackageDescr -> IDEAction) -> IDEAction-updatePackageInfo rebuild idePack continuation = do+-- | Update the metadata on one package+updatePackageInfo :: [PackageIdentifier] -> Bool -> IDEPackage -> (Bool -> PackageDescr -> IDEAction) -> IDEAction+updatePackageInfo knownPackages rebuild idePack continuation = do     liftIO $ infoM "leksah" ("updatePackageInfo " ++ show rebuild ++ " " ++ show (ipdPackageId idePack))     workspInfoCache'     <- readIDE workspInfoCache     let (packageMap, ic) =  case pi  `Map.lookup` workspInfoCache' of                                 Nothing -> (Map.empty,True)                                 Just m  -> (m,False)     modPairsMb <- liftIO $ mapM (\(modName, bi) -> do-            sf <- case  modName `Map.lookup` packageMap of+            sf <- case  LibModule modName `Map.lookup` packageMap of                         Nothing            -> findSourceFile (srcDirs' bi) haskellSrcExts modName                         Just (_,Nothing,_) -> findSourceFile (srcDirs' bi) haskellSrcExts modName                         Just (_,Just fp,_) -> return (Just fp)-            return (modName, sf))+            return (LibModule modName, sf))                 $ Map.toList $ ipdModules idePack     mainModules <- liftIO $ mapM (\(fn, bi, isTest) -> do                                     mbFn <- findSourceFile' (srcDirs' bi) fn-                                    return (main,mbFn))+                                    return (MainModule (fromMaybe fn mbFn), mbFn))                             (ipdMain idePack)-    let modPairsMb' = case mainModules of-                        [] -> modPairsMb-                        hd:_ -> hd : modPairsMb+    -- we want all Main modules since they may be several with different files+    let modPairsMb' = mainModules ++ modPairsMb     let (modWith,modWithout) = partition (\(x,y) -> isJust y) modPairsMb'     let modWithSources       = map (A.second fromJust) modWith     let modWithoutSources    = map fst modWithout@@ -291,14 +313,14 @@     modToUpdate <- if rebuild                             then return modWithSources                             else liftIO $ figureOutRealSources idePack modWithSources-    liftIO . infoM "leksah" $ "updatePackageInfo modToUpdate " ++ show (map (display.fst) modToUpdate)+    liftIO . infoM "leksah" $ "updatePackageInfo modToUpdate " ++ show (map (displayModuleKey.fst) modToUpdate)     callCollectorWorkspace         rebuild-        (dropFileName (ipdCabalFile idePack))+        (ipdPackageDir idePack)         (ipdPackageId idePack)-        (map (\(x,y) -> (T.pack $ display x,y)) modToUpdate)+        (map (\(x,y) -> (T.pack $ display (moduleKeyToName x),y)) modToUpdate)         (\ b -> do-            buildDepends         <- liftIO $ findFittingPackages (ipdDepends idePack)+            let buildDepends         = findFittingPackages knownPackages (ipdDepends idePack)             collectorPath        <- liftIO getCollectorPath             let packageCollectorPath = collectorPath </> T.unpack (packageIdentifierToString pi)             (moduleDescrs,packageMap, changed, modWithout)@@ -318,29 +340,28 @@         srcDirs' bi =  map (basePath </>) ("dist/build":hsSourceDirs bi)         pi = ipdPackageId idePack -figureOutRealSources :: IDEPackage -> [(ModuleName,FilePath)] -> IO [(ModuleName,FilePath)]+figureOutRealSources :: IDEPackage -> [(ModuleKey,FilePath)] -> IO [(ModuleKey,FilePath)] figureOutRealSources idePack modWithSources = do     collectorPath <- getCollectorPath     let packageCollectorPath = collectorPath </> T.unpack (packageIdentifierToString $ ipdPackageId idePack)     filterM (ff packageCollectorPath) modWithSources     where         ff packageCollectorPath (md ,fp) =  do-                let modId = display md-                let collectorModulePath = packageCollectorPath </> modId <.> leksahMetadataWorkspaceFileExtension-                existCollectorFile <- doesFileExist collectorModulePath-                existSourceFile    <- doesFileExist fp-                if not existSourceFile || not existCollectorFile-                    then return True -- Maybe with preprocessing-                    else do-                        sourceModTime <-  getModificationTime fp-                        collModTime   <-  getModificationTime collectorModulePath-                        return (sourceModTime > collModTime)+            let collectorModulePath = packageCollectorPath </> moduleCollectorFileName md <.> leksahMetadataWorkspaceFileExtension+            existCollectorFile <- doesFileExist collectorModulePath+            existSourceFile    <- doesFileExist fp+            if not existSourceFile || not existCollectorFile+                then return True -- Maybe with preprocessing+                else do+                    sourceModTime <-  getModificationTime fp+                    collModTime   <-  getModificationTime collectorModulePath+                    return (sourceModTime > collModTime)   getModuleDescr :: FilePath-    -> ([ModuleDescr],ModuleDescrCache,Bool,[ModuleName])-    -> (ModuleName, Maybe FilePath)-    -> IO ([ModuleDescr],ModuleDescrCache,Bool,[ModuleName])+    -> ([ModuleDescr],ModuleDescrCache,Bool,[ModuleKey])+    -> (ModuleKey, Maybe FilePath)+    -> IO ([ModuleDescr],ModuleDescrCache,Bool,[ModuleKey]) getModuleDescr packageCollectorPath (modDescrs,packageMap,changed,problemMods) (modName,mbFilePath) =     case modName `Map.lookup` packageMap of         Just (eTime,mbFp,mdescr) -> do@@ -351,7 +372,7 @@                     if modificationTime == eTime                         then return (mdescr:modDescrs,packageMap,changed,problemMods)                         else do-                            liftIO . infoM "leksah" $ "getModuleDescr loadInfo: " ++ display modName+                            liftIO . infoM "leksah" $ "getModuleDescr loadInfo: " ++ displayModuleKey modName                             mbNewDescr <- loadInfosForModule moduleCollectorPath                             case mbNewDescr of                                 Just newDescr -> return (newDescr:modDescrs,@@ -374,7 +395,7 @@                                         modName : problemMods)                 else return (modDescrs,packageMap,changed, modName : problemMods)     where-        moduleCollectorPath = packageCollectorPath </> display modName <.>  leksahMetadataWorkspaceFileExtension+        moduleCollectorPath = packageCollectorPath </> moduleCollectorFileName modName <.>  leksahMetadataWorkspaceFileExtension  -- --------------------------------------------------------------------- -- Low level helpers for loading metadata@@ -454,15 +475,20 @@             sysMessage Normal $ "moduleInfo not found for " <> T.pack filePath             return Nothing -findFittingPackages :: [Dependency] -> IO [PackageIdentifier]-findFittingPackages dependencyList = do-    knownPackages   <-  getInstalledPackageIds-    return (concatMap (fittingKnown knownPackages) dependencyList)+-- | Find the packages fitting the dependencies+findFittingPackages+    :: [PackageIdentifier] -- ^ the list of known packages+    -> [Dependency]  -- ^ the dependencies+    -> [PackageIdentifier] -- ^ the known packages matching the dependencies+findFittingPackages knownPackages =+    concatMap (fittingKnown knownPackages)     where     fittingKnown packages (Dependency dname versionRange) =+        -- find matching packages         let filtered =  filter (\ (PackageIdentifier name version) ->                                     name == dname && withinRange version versionRange)                         packages+        -- take latest version if several versions match         in  if length filtered > 1                 then [maximumBy (compare `on` pkgVersion) filtered]                 else filtered@@ -747,9 +773,10 @@ --  callCollector :: Bool -> Bool -> Bool -> (Bool -> IDEAction) -> IDEAction-callCollector rebuild sources extract cont = do+callCollector scRebuild scSources scExtract cont = do     liftIO $ infoM "leksah" "callCollector"-    doServerCommand command $ \ res ->+    scPackageDBs <- getAllPackageDBs+    doServerCommand SystemCommand {..} $ \ res ->         case res of             ServerOK         -> do                 liftIO $ infoM "leksah" "callCollector finished"@@ -760,10 +787,6 @@             _                -> do                 liftIO $ infoM "leksah" "impossible server answer"                 cont False-    where command = SystemCommand {-            scRebuild = rebuild,-            scSources = sources,-            scExtract = extract}  callCollectorWorkspace :: Bool -> FilePath -> PackageIdentifier -> [(Text,FilePath)] ->     (Bool -> IDEAction) -> IDEAction

@@ -57,7 +57,7 @@                 applicationInsertAppMenuItem app sep 1             Nothing   -> return () -        mbPrefs   <- uiManagerGetWidget uiManager ("/ui/menubar/_Configuration/Edit general Preferences" :: Text)+        mbPrefs   <- uiManagerGetWidget uiManager ("/ui/menubar/_Tools/_Preferences" :: Text)         case mbPrefs of             Just prefs -> do                 applicationInsertAppMenuItem app (castToMenuItem prefs) 2

@@ -77,10 +77,13 @@ import Distribution.Verbosity import System.FilePath import Control.Concurrent-import System.Directory (setCurrentDirectory, doesFileExist, getDirectoryContents)+import System.Directory+       (canonicalizePath, setCurrentDirectory, doesFileExist,+        getDirectoryContents, doesDirectoryExist) import Prelude hiding (catch) import Data.Maybe-       (listToMaybe, fromMaybe, isNothing, isJust, fromJust, catMaybes)+       (mapMaybe, listToMaybe, fromMaybe, isNothing, isJust, fromJust,+        catMaybes) import Control.Exception (SomeException(..), catch)  import IDE.Core.State@@ -93,7 +96,7 @@ import IDE.Utils.FileUtils(getConfigFilePathForLoad) import IDE.LogRef import Distribution.ModuleName (ModuleName(..))-import Data.List (isInfixOf, nub, foldl', delete)+import Data.List (isInfixOf, nub, foldl', delete, find) import IDE.Utils.Tool (ToolOutput(..), runTool, newGhci, ToolState(..), toolline, ProcessHandle, executeGhciCommand) import qualified Data.Set as  Set (fromList) import qualified Data.Map as  Map (empty, fromList)@@ -115,7 +118,8 @@ import System.Log.Logger (debugM) import System.Process.Vado (getMountPoint, vado, readSettings) import qualified Data.Text as T-       (replace, unwords, takeWhile, pack, unpack, isInfixOf)+       (lines, isPrefixOf, stripPrefix, replace, unwords, takeWhile, pack,+        unpack, isInfixOf) import IDE.Utils.ExternalTool (runExternalTool', runExternalTool, isRunning, interruptBuild) import Text.PrinterParser (writeFields) import Data.Text (Text)@@ -195,36 +199,42 @@ packageConfig'  :: IDEPackage -> (Bool -> IDEAction) -> IDEAction packageConfig' package continuation = do     prefs     <- readIDE prefs-    let dir = ipdBuildDir package-    logLaunch <- getDefaultLogLaunch-    showDefaultLogLaunch'+    let dir = ipdPackageDir package+    useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"+    if useStack+        then ideMessage Normal (__ "Leksah is not running \"cabal configure\" because a stack.yaml file was found.")+        else do+            logLaunch <- getDefaultLogLaunch+            showDefaultLogLaunch' -    runExternalTool'        (__ "Configuring")-                            (cabalCommand prefs)-                            ("configure" : ipdConfigFlags package)-                            dir $ do-        mbLastOutput <- C.getZipSink $ const <$> C.ZipSink sinkLast <*> C.ZipSink (logOutput logLaunch)-        lift $ do-            mbPack <- idePackageFromPath (logOutput logLaunch) (ipdCabalFile package)-            case mbPack of-                Just pack -> do-                    changePackage pack-                    triggerEventIDE $ WorkspaceChanged False True-                    continuation (mbLastOutput == Just (ToolExit ExitSuccess))-                    return ()-                Nothing -> do-                    postAsyncIDE $ ideMessage Normal (__ "Can't read package file")-                    continuation False-                    return()+            runExternalTool'        (__ "Configuring")+                                    (cabalCommand prefs)+                                    ("configure" : ipdConfigFlags package)+                                    dir $ do+                mbLastOutput <- C.getZipSink $ const <$> C.ZipSink sinkLast <*> C.ZipSink (logOutput logLaunch)+                lift $ do+                    mbPack <- idePackageFromPath (logOutput logLaunch) (ipdCabalFile package)+                    case mbPack of+                        Just pack -> do+                            changePackage pack+                            triggerEventIDE $ WorkspaceChanged False True+                            continuation (mbLastOutput == Just (ToolExit ExitSuccess))+                            return ()+                        Nothing -> do+                            postAsyncIDE $ ideMessage Normal (__ "Can't read package file")+                            continuation False+                            return()  runCabalBuild :: Bool -> Bool -> Bool -> IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction runCabalBuild backgroundBuild jumpToWarnings withoutLinking package shallConfigure continuation = do     prefs <- readIDE prefs-    let dir =  ipdBuildDir package+    let dir =  ipdPackageDir package+    useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"     let args = ["build"]-                ++ ["--with-ld=false" | backgroundBuild && withoutLinking]+                ++ ["--with-ld=false" | not useStack && backgroundBuild && withoutLinking]+                ++ (if useStack && runUnitTests prefs then ["--test", "--haddock"] else [])                 ++ ipdBuildFlags package-    runExternalTool' (__ "Building") (cabalCommand prefs) args dir $ do+    runExternalTool' (__ "Building") (if useStack then "stack" else cabalCommand prefs) args dir $ do         (mbLastOutput, isConfigErr, _) <- C.getZipSink $ (,,)             <$> C.ZipSink sinkLast             <*> C.ZipSink isConfigError@@ -281,7 +291,7 @@             -- TODO check debug package matches active package             ready <- liftIO $ isEmptyMVar (currentToolCommand ghci)             when ready $ do-                let dir = ipdBuildDir package+                let dir = ipdPackageDir package                 when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace'; return ())                 (`runDebug` debug) . executeDebugCommand ":reload" $ do                     errs <- logOutputForBuild package backgroundBuild jumpToWarnings@@ -301,12 +311,16 @@ packageDoc' backgroundBuild jumpToWarnings package continuation = do     prefs     <- readIDE prefs     catchIDE (do-        let dir = ipdBuildDir package-        runExternalTool' (__ "Documenting") (cabalCommand prefs) ("haddock" : ipdHaddockFlags package) dir $ do-                mbLastOutput <- C.getZipSink $ const <$> C.ZipSink sinkLast <*> (C.ZipSink $-                    logOutputForBuild package backgroundBuild jumpToWarnings)-                lift $ postAsyncIDE reloadDoc-                lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))+        let dir = ipdPackageDir package+        useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"+        if useStack+            then continuation True+            else+                runExternalTool' (__ "Documenting") (cabalCommand prefs) ("haddock" : ipdHaddockFlags package) dir $ do+                    mbLastOutput <- C.getZipSink $ const <$> C.ZipSink sinkLast <*> (C.ZipSink $+                        logOutputForBuild package backgroundBuild jumpToWarnings)+                    lift $ postAsyncIDE reloadDoc+                    lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))         (\(e :: SomeException) -> print e)  packageClean :: PackageAction@@ -320,9 +334,10 @@     logLaunch <- getDefaultLogLaunch     showDefaultLogLaunch' -    let dir = ipdBuildDir package+    let dir = ipdPackageDir package+    useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"     runExternalTool' (__ "Cleaning")-                    (cabalCommand prefs)+                    (if useStack then "stack" else cabalCommand prefs)                     ["clean"]                     dir $ do         mbLastOutput <- C.getZipSink $ const <$> C.ZipSink sinkLast <*> C.ZipSink (logOutput logLaunch)@@ -342,10 +357,10 @@             case mbDir of                 Nothing -> return ()                 Just fp -> do-                    let dir = ipdBuildDir package+                    let dir = ipdPackageDir package                     runExternalTool' (__ "Copying")                                     (cabalCommand prefs)-                                    ("copy" : ["--destdir=" <> T.pack fp])+                                    ["copy", "--destdir=" <> T.pack fp]                                     dir                                     (logOutput logLaunch))             (\(e :: SomeException) -> print e)@@ -359,7 +374,7 @@          catchIDE (do             prefs <- readIDE prefs-            let dir = ipdBuildDir package+            let dir = ipdPackageDir package             runExternalTool' (__ "Installing") (cabalCommand prefs) (                    (if useCabalDev prefs                         then ["install-deps"]@@ -375,8 +390,12 @@     showDefaultLogLaunch'      catchIDE (do-        let dir = ipdBuildDir package-        runExternalTool' (__ "Copying") (cabalCommand prefs) ("copy" : ipdInstallFlags package) dir $ do+        let dir = ipdPackageDir package+        useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"+        runExternalTool' (__ "Copying")+                         (if useStack then "stack" else cabalCommand prefs)+                         ((if useStack then ("install" : ipdBuildFlags package) else ["copy"]) ++ ipdInstallFlags package)+                         dir $ do                 mbLastOutput <- C.getZipSink $ (const <$> C.ZipSink sinkLast) <*> C.ZipSink (logOutput logLaunch)                 lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))         (\(e :: SomeException) -> print e)@@ -419,11 +438,12 @@             showLog             case maybeDebug of                 Nothing -> do-                    let dir = ipdBuildDir package+                    let dir = ipdPackageDir package+                    useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"                     IDE.Package.runPackage (addLogLaunchData logName logLaunch)                                            (T.pack $ printf (__ "Running %s") (T.unpack logName))-                                           "cabal"-                                           (concat [["run"]+                                           (if useStack then "stack" else "cabal")+                                           (concat [[if useStack then "exec" else "run"]                                                 , ipdBuildFlags package                                                 , map (T.pack . exeName) exe                                                 , ["--"]@@ -479,12 +499,12 @@                 let defaultLogName = T.pack . display . pkgName $ ipdPackageId package                     logName = fromMaybe defaultLogName . listToMaybe $ map (T.pack . exeName) exe                 (logLaunch,logName) <- buildLogLaunchByName logName-                let dir = ipdBuildDir package+                let dir = ipdPackageDir package                 prefs <- readIDE prefs                 case exe ++ executables pd of                     (Executable name _ _ : _) -> liftIDE $ do                         let path = "dist/build" </> name </> name <.> "jsexe" </> "index.html"-                            dir = ipdBuildDir package+                            dir = ipdPackageDir package #ifdef WEBKITGTK                         postAsyncIDE $ do                             loadOutputUri ("file:///" ++ dir </> path)@@ -513,10 +533,13 @@           showDefaultLogLaunch'           catchIDE (do             prefs <- readIDE prefs-            let dir = ipdBuildDir package-            runExternalTool' (__ "Registering") (cabalCommand prefs) ("register" : ipdRegisterFlags package) dir $ do-                    mbLastOutput <- C.getZipSink $ (const <$> C.ZipSink sinkLast) <*> C.ZipSink (logOutput logLaunch)-                    lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))+            let dir = ipdPackageDir package+            useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"+            if useStack+                then continuation True+                else runExternalTool' (__ "Registering") (cabalCommand prefs) ("register" : ipdRegisterFlags package) dir $ do+                        mbLastOutput <- C.getZipSink $ (const <$> C.ZipSink sinkLast) <*> C.ZipSink (logOutput logLaunch)+                        lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))             (\(e :: SomeException) -> print e)         else continuation True @@ -526,14 +549,15 @@     interruptSaveAndRun $ packageTest' False True package True (\ _ -> return ())  packageTest' :: Bool -> Bool -> IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction-packageTest' backgroundBuild jumpToWarnings package shallConfigure continuation =-    if "--enable-tests" `elem` ipdConfigFlags package+packageTest' backgroundBuild jumpToWarnings package shallConfigure continuation = do+    let dir = ipdPackageDir package+    useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"+    if not useStack && "--enable-tests" `elem` ipdConfigFlags package         then do           logLaunch <- getDefaultLogLaunch           showDefaultLogLaunch'           catchIDE (do             prefs <- readIDE prefs-            let dir = ipdBuildDir package             removeTestLogRefs dir             runExternalTool' (__ "Testing") (cabalCommand prefs) (["test", "--with-ghc=leksahtrue"]                 ++ ipdBuildFlags package ++ ipdTestFlags package) dir $ do@@ -562,7 +586,7 @@          catchIDE (do             prefs <- readIDE prefs-            let dir = ipdBuildDir package+            let dir = ipdPackageDir package             runExternalTool' (__ "Source Dist") (cabalCommand prefs) ("sdist" : ipdSdistFlags package) dir (logOutput logLaunch))             (\(e :: SomeException) -> print e) @@ -573,11 +597,11 @@      liftIDE $ do         prefs   <- readIDE prefs-        let path = ipdBuildDir package+        let path = ipdPackageDir package                         </> "dist/doc/html"                         </> display (pkgName (ipdPackageId package))                         </> "index.html"-            dir = ipdBuildDir package+            dir = ipdPackageDir package #ifdef WEBKITGTK         loadDoc . T.pack $ "file:///" ++ dir </> path         getDocumentation Nothing  >>= \ p -> displayPane p False@@ -786,7 +810,7 @@         maybeDebug <- readIDE debugState         case maybeDebug of             Nothing -> do-                let dir = ipdBuildDir package+                let dir = ipdPackageDir package                 mbExe <- readIDE activeExe                 ghci <- reifyIDE $ \ideR -> newGhci dir mbExe (interactiveFlags prefs')                     $ reflectIDEI (void (logOutputForBuild package True False)) ideR@@ -929,6 +953,19 @@                     else return packp             return (Just pack) +extractStackPackageList :: Text -> [String]+extractStackPackageList = filter (/= ".") .+                          map (stripQuotes . T.unpack . (\x -> fromMaybe x $ T.stripPrefix "location: " x)) .+                          mapMaybe (T.stripPrefix "- ") .+                          takeWhile ("- " `T.isPrefixOf`) .+                          drop 1 .+                          dropWhile (/= "packages:") .+                          T.lines+  where+    stripQuotes ('\'':rest) | take 1 (reverse rest) == "\'" = init rest+    stripQuotes x = x++ idePackageFromPath :: C.Sink ToolOutput IDEM () -> FilePath -> IDEM (Maybe IDEPackage) idePackageFromPath log filePath = do     mbRootPackage <- idePackageFromPath' filePath@@ -936,16 +973,33 @@         Nothing -> return Nothing         Just rootPackage -> do             mvar <- liftIO newEmptyMVar-            runExternalTool' "" "cabal" ["sandbox", "list-sources"] (takeDirectory filePath) $ do-                output <- CL.consume-                liftIO . putMVar mvar $ case take 1 $ reverse output of-                    [ToolExit ExitSuccess] ->-                        map (T.unpack . toolline) . takeWhile (/= ToolOutput "") . drop 1 $ dropWhile (/= ToolOutput "") output-                    _ -> []-            paths <- liftIO $ takeMVar mvar-            sandboxSources <- concat <$> forM paths (\ path -> do-                contents <- liftIO $ getDirectoryContents path-                return . take 1 . map (path </>) $ filter ((== ".cabal") . takeExtension) contents)+            let dir = takeDirectory filePath+            useStack <- liftIO . doesFileExist $ dir </> "stack.yaml"+            paths <-+                if useStack+                    then liftIO $ map (dir </>) . extractStackPackageList <$> T.readFile (dir </> "stack.yaml")+                    else do+                        runExternalTool' "" "cabal" ["sandbox", "list-sources"] dir $ do+                            output <- CL.consume+                            liftIO . putMVar mvar $ case take 1 $ reverse output of+                                [ToolExit ExitSuccess] ->+                                    map (T.unpack . toolline) . takeWhile (/= ToolOutput "") . drop 1 $ dropWhile (/= ToolOutput "") output+                                _ -> []+                        liftIO $ takeMVar mvar++            sandboxSources <- catMaybes <$> forM paths (\path -> do+                exists <- liftIO (doesDirectoryExist path)+                if exists+                    then do+                        cpath <- liftIO $ canonicalizePath path+                        contents <- liftIO $ getDirectoryContents cpath+                        let mbCabalFile = find ((== ".cabal") . takeExtension) contents+                        when (isNothing mbCabalFile) $+                            ideMessage Normal ("Could not find cabal file of the add-source dependency at " <> T.pack cpath)+                        return (fmap (path </>) mbCabalFile)+                    else do+                        ideMessage Normal ("Path of add-source dependency does not exist: " <> T.pack path)+                        return Nothing)             s <- liftM catMaybes . mapM idePackageFromPath' $ nub sandboxSources             return . Just $ rootPackage {ipdSandboxSources = s} 

@@ -17,118 +17,227 @@ -----------------------------------------------------------------------------  module IDE.Pane.Errors (-    IDEErrors+    ErrorsPane ,   ErrorsState ,   fillErrorList-,   addErrorToList-,   selectError ,   getErrors+,   addErrorToList ,   selectMatchingErrors ) where +import Prelude ()+import Prelude.Compat import Graphics.UI.Gtk import Data.Typeable (Typeable) import IDE.Core.State import IDE.ImportTool-       (addResolveMenuItems, resolveErrors)-import Data.List (elemIndex)+       (resolveErrors, resolveMenuItems)+import Data.List (groupBy, sortBy, elemIndex) import IDE.LogRef (showSourceSpan) import Control.Monad.IO.Class (MonadIO(..))-import IDE.Utils.GUIUtils (getDarkState, treeViewContextMenu, __)-import Data.Text (Text)-import Control.Monad (foldM_, unless, void, when, forM_)+import IDE.Utils.GUIUtils+       (treeViewContextMenu', treeViewContextMenu, __, treeViewToggleRow,+        treeStoreGetForest)+import Data.Text (dropWhileEnd, Text)+import Control.Applicative (Alternative(..))+import Control.Monad (filterM, foldM_, unless, void, when) import qualified Data.Text as T-       (intercalate, lines, takeWhile, length, drop)+       (unlines, dropWhileEnd, unpack, pack, intercalate, lines,+        takeWhile, length, drop) import Data.IORef (writeIORef, readIORef, newIORef, IORef)-import Data.Maybe (isNothing)+import Data.Maybe (isJust, isNothing) import qualified Data.Foldable as F (toList) import qualified Data.Sequence as Seq (null, elemIndexL)+import Data.Monoid ((<>))+import Data.Ord (comparing)+import System.Glib.Properties (newAttrFromMaybeStringProperty)+import Data.Char (isSpace)+import Data.Tree (Forest, Tree(..), Tree)+import Data.Function.Compat ((&))+import System.Log.Logger (debugM)+import Data.Foldable (forM_)   -- | 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+data ErrorsPane      =   ErrorsPane {+    vbox              :: VBox+,   scrolledView      :: ScrolledWindow+,   treeView          :: TreeView+,   errorStore        :: TreeStore ErrorRecord+,   autoClose         :: IORef Bool -- ^ If the pane was only displayed to show current error+,   errorsButton      :: ToggleButton+,   warningsButton    :: ToggleButton+,   suggestionsButton :: ToggleButton+,   testFailsButton   :: ToggleButton } deriving Typeable   -- | The data for a single row in the Errors pane-data ErrColumn = ErrColumn {-    logRef     :: LogRef,-    background :: Text}-+data ErrorRecord = ERLogRef LogRef+                 | ERPackage IDEPackage Text+                 | ERIDE Text+                 | ERFullMessage Text (Maybe LogRef)+    deriving (Eq)  -- | The additional state used when recovering the pane-data ErrorsState    =   ErrorsState+data ErrorsState = ErrorsState+    {+      showErrors :: Bool+    , showWarnings :: Bool+    , showSuggestions :: Bool+    , showTestFails :: Bool+    }    deriving (Eq,Ord,Read,Show,Typeable)  -instance Pane IDEErrors IDEM+instance Pane ErrorsPane IDEM     where     primPaneName _  =   __ "Errors"-    getTopWidget    =   castToWidget . scrolledView+    getTopWidget    =   castToWidget . vbox     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+instance RecoverablePane ErrorsPane ErrorsState IDEM where+    saveState ErrorsPane{..} = liftIO $ do+        showErrors      <- get errorsButton toggleButtonActive+        showWarnings    <- get warningsButton toggleButtonActive+        showSuggestions <- get suggestionsButton toggleButtonActive+        showTestFails   <- get testFailsButton toggleButtonActive+        return (Just ErrorsState{..})++    recoverState pp ErrorsState{..} = do+        nb <- getNotebook pp+        mbErrors <- buildPane pp nb builder+        forM_ mbErrors $ \ErrorsPane{..} -> liftIO $ do+            set errorsButton [toggleButtonActive := showErrors]+            set warningsButton [toggleButtonActive := showWarnings]+            set suggestionsButton [toggleButtonActive := showSuggestions]+            set testFailsButton [toggleButtonActive := showTestFails]+        return mbErrors++     builder = builder' --- | Builds an 'IDEErrors' pane together with a list of+-- | Builds an 'ErrorsPane' pane together with a list of --   event 'Connections' builder' :: PanePath ->     Notebook ->     Window ->-    IDEM (Maybe IDEErrors, Connections)+    IDEM (Maybe ErrorsPane, Connections) builder' _pp _nb _windows = reifyIDE $ \ ideR -> do-    errorStore   <- listStoreNew []+    errorStore   <- treeStoreNew []++    vbox         <- vBoxNew False 0++    -- Top box with buttons+    hbox <- hBoxNew False 0+    boxPackStart vbox hbox PackNatural 0+++    errorsButton <- toggleButtonNewWithLabel (__ "Errors")+    warningsButton <- toggleButtonNewWithLabel (__ "Warnings")+    suggestionsButton <- toggleButtonNewWithLabel (__ "Suggestions")+    testFailsButton <- toggleButtonNewWithLabel (__ "Test Failures")+    set suggestionsButton [toggleButtonActive := False]++    forM_ [errorsButton, warningsButton, suggestionsButton, testFailsButton] $ \b -> do+        set b [toggleButtonActive := True]+        boxPackStart hbox b PackNatural 3+        b `on` toggled $ reflectIDE (fillErrorList False) ideR+++    boxPackStart vbox hbox PackNatural 0+++    -- TreeView for bottom part of vbox+     treeView     <- treeViewNew     treeViewSetModel treeView errorStore+    set treeView+        [ treeViewLevelIndentation := 20+        , treeViewRulesHint := True+        , treeViewHeadersVisible := False] -    rendererA    <- cellRendererTextNew-    colA         <- treeViewColumnNew-    treeViewColumnSetTitle colA (__ "Description")-    treeViewColumnSetSizing colA TreeViewColumnAutosize-    treeViewColumnSetResizable colA True-    treeViewColumnSetReorderable colA True-    treeViewAppendColumn treeView colA-    cellLayoutPackStart colA rendererA False-    cellLayoutSetAttributes colA rendererA errorStore-        $ \row -> [cellText := removeIndentation (refDescription (logRef row)),-                   cellTextBackground := background row ]-    rendererB    <- cellRendererTextNew-    colB         <- treeViewColumnNew-    treeViewColumnSetTitle colB (__ "Location")-    treeViewColumnSetSizing colB TreeViewColumnAutosize-    treeViewColumnSetResizable colB True-    treeViewColumnSetReorderable colB True-    treeViewAppendColumn treeView colB-    cellLayoutPackStart colB rendererB False-    cellLayoutSetAttributes colB rendererB errorStore-        $ \row -> [ cellText := showSourceSpan (logRef row),-                   cellTextBackground := background row ]-    treeViewSetHeadersVisible treeView False+    column       <- treeViewColumnNew+    iconRenderer <- cellRendererPixbufNew++    cellLayoutPackStart column iconRenderer False+    cellLayoutSetAttributes column iconRenderer errorStore+                $ \row -> [ newAttrFromMaybeStringProperty "icon-name" := toIcon row]+++    treeViewColumnSetSizing column TreeViewColumnAutosize++    renderer <- cellRendererTextNew+    cellLayoutPackStart column renderer False++    cellLayoutSetAttributeFunc column renderer errorStore $ \iter -> do+        path <- treeModelGetPath errorStore iter+        row <- treeModelGetRow errorStore iter+        expanded <- treeViewRowExpanded treeView path+        set renderer [cellText := toDescription expanded row]++    treeViewAppendColumn treeView column++     selB <- treeViewGetSelection treeView     treeSelectionSetMode selB SelectionMultiple     scrolledView <- scrolledWindowNew Nothing Nothing     scrolledWindowSetShadowType scrolledView ShadowIn     containerAdd scrolledView treeView     scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic+    boxPackStart vbox scrolledView PackGrow 0+     autoClose <- newIORef False-    let pane = IDEErrors {..}++    let pane = ErrorsPane {..}     cid1 <- after treeView focusInEvent $ do         liftIO $ reflectIDE (makeActive pane) ideR         return True-    (cid2, cid3) <- treeViewContextMenu treeView $ errorsContextMenu ideR errorStore treeView-    cid4 <- treeView `on` rowActivated $ errorsSelect ideR errorStore+    (cid2, cid3) <- flip reflectIDE ideR $+        treeViewContextMenu' treeView errorStore contextMenuItems+    cid4 <- treeView `on` rowActivated $ \path col -> do+        record <- treeStoreGetValue errorStore path+        case record of+            ERLogRef logRef -> errorsSelect ideR errorStore path col+            ERFullMessage _ ref -> errorsSelect ideR errorStore path col+            _        -> return ()+     reflectIDE (fillErrorList' pane) ideR     return (Just pane, map ConnectC [cid1, cid2, cid3, cid4])  +toIcon :: ErrorRecord -> Maybe Text+toIcon (ERLogRef logRef) =+    case logRefType logRef of+        ErrorRef       -> Just "ide_error"+        WarningRef     -> Just "ide_warning"+        LintRef        -> Just "ide_suggestion"+        TestFailureRef -> Just "software-update-urgent"+        _              -> Nothing+toIcon (ERPackage _ _) = Just "dialog-error"+toIcon (ERIDE _) = Just "dialog-error"+toIcon (ERFullMessage _ _) = Nothing+++toDescription :: Bool -> ErrorRecord -> Text+toDescription expanded errorRec =+    case errorRec of+        (ERLogRef logRef)   -> formatExpandableMessage (T.pack $ logRefFilePath logRef) (refDescription logRef)+        (ERIDE msg)         -> formatExpandableMessage "" msg+        (ERPackage pkg msg) -> formatExpandableMessage (packageIdentifierToString (ipdPackageId pkg))+                                   (packageIdentifierToString (ipdPackageId pkg) <> ": \n" <> msg)+        (ERFullMessage msg _) -> removeIndentation msg++    where+        formatExpandableMessage location msg+            | expanded  = location+            | otherwise = location <> ": " <> msg & removeIndentation+                                                  & T.lines+                                                  & map removeTrailingWhiteSpace+                                                  & T.intercalate " "++ -- | Removes the unnecessary indentation removeIndentation :: Text -> Text removeIndentation t = T.intercalate "\n" $ map (T.drop minIndent) l@@ -136,9 +245,15 @@     l = T.lines t     minIndent = minimum $ map (T.length . T.takeWhile (== ' ')) l +removeTrailingWhiteSpace :: Text -> Text+removeTrailingWhiteSpace = T.dropWhileEnd isSpace +cutOffAt :: Int -> Text -> Text+cutOffAt n t | T.length t < n = t+             | otherwise      = T.pack (take n (T.unpack t)) <> "..."+ -- | Get the Errors pane-getErrors :: Maybe PanePath -> IDEM IDEErrors+getErrors :: Maybe PanePath -> IDEM ErrorsPane getErrors Nothing    = forceGetPane (Right "*Errors") getErrors (Just pp)  = forceGetPane (Left pp) @@ -151,152 +266,195 @@   -- | Fills the pane with the error list from the IDE state-fillErrorList' :: IDEErrors -> IDEAction+fillErrorList' :: ErrorsPane -> IDEAction fillErrorList' pane = do-    refs <- readIDE errorRefs+    liftIO $ debugM "leksah" "fillErrorList'"+    refs <- F.toList <$> readIDE errorRefs+    visibleRefs <- liftIO $ filterM (isRefVisible pane) refs+     ac   <- liftIO $ readIORef (autoClose pane)-    when (Seq.null refs && ac) . void $ closePane pane-    isDark <- getDarkState+    when (null refs && ac) . void $ closePane pane++    updateFilterButtons pane     liftIO $ do         let store = errorStore pane-        listStoreClear store-        forM_ (zip (F.toList refs) [0..]) $ \ (lr, index) ->-            listStoreInsert store index $ ErrColumn lr (-                (if even index then fst else snd) $-                (if isDark then fst else snd) $-                    case logRefType lr of-                        WarningRef -> (("#282000", "#201900"), ("#FFF1DE", "#FFF5E8"))-                        LintRef    -> (("#003000", "#002800"), ("#DBFFDB", "#EDFFED"))-                        _          -> (("#380000", "#280000"), ("#FFDEDE", "#FFEBEB")))+        let view  = treeView pane+        treeStoreClear store+        forM_ (zip visibleRefs [0..]) $ \(ref, n) -> do+            treeStoreInsert store [] n (ERLogRef ref)+            when (length (T.lines (refDescription ref)) > 1) $ do+                treeStoreInsert store [n] 0 (ERFullMessage (refDescription ref) (Just ref))+                treeViewExpandToPath view [n,0] +-- | Returns whether the `LogRef` should be visible in the errors pane+isRefVisible :: ErrorsPane -> LogRef -> IO Bool+isRefVisible pane ref =+    case logRefType ref of+        ErrorRef       -> toggleButtonGetActive (errorsButton pane)+        WarningRef     -> toggleButtonGetActive (warningsButton pane)+        LintRef        -> toggleButtonGetActive (suggestionsButton pane)+        TestFailureRef -> toggleButtonGetActive (testFailsButton pane)+        _              -> return False  -- | 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 +               -> 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-    ac   <- liftIO $ readIORef (autoClose pane)---    when (null refs && ac) . void $ closePane pane-    isDark <- getDarkState+addErrorToList' :: Int -> LogRef -> ErrorsPane -> IDEAction+addErrorToList' unfilteredIndex ref pane = do+    liftIO $ debugM "leksah" "addErrorToList'"+    visible <- liftIO $ isRefVisible pane ref+    updateFilterButtons pane+    when visible $ do+        refs <- F.toList <$> readIDE errorRefs+        index <- liftIO $ length <$> filterM (isRefVisible pane) (take unfilteredIndex refs)+        ac   <- liftIO $ readIORef (autoClose pane)+        liftIO $ do+            let store = errorStore pane+            let view  = treeView pane+            treeStoreInsert store [] index (ERLogRef ref)+            when (length (T.lines (refDescription ref)) > 1) $ do+                treeStoreInsert store [index] 0 (ERFullMessage (refDescription ref) (Just ref))+                treeViewExpandToPath view [index,0]++-- | Updates the filter buttons in the Error Pane+updateFilterButtons :: ErrorsPane -> IDEAction+updateFilterButtons pane = do+    liftIO $ debugM "leksah" "updateFilterButtons"+    let numRefs refType = length . filter ((== refType) . logRefType) . F.toList <$> readIDE errorRefs+    let setLabel name amount button = buttonSetLabel button (name <> " (" <> T.pack (show amount) <> ")" )++    numErrors      <- numRefs ErrorRef+    numWarnings    <- numRefs WarningRef+    numSuggestions <- numRefs LintRef+    numTestFails   <- numRefs TestFailureRef+     liftIO $ do-        let store = errorStore pane---        listStoreClear store---        forM_ (zip (toList refs) [0..]) $ \ (lr, index) ->-        listStoreInsert store index $ ErrColumn lr (-                (if even index then fst else snd) $-                (if isDark then fst else snd) $-                    case logRefType lr of-                        WarningRef -> (("#282000", "#201900"), ("#FFF1DE", "#FFF5E8"))-                        LintRef    -> (("#003000", "#002800"), ("#DBFFDB", "#EDFFED"))-                        _          -> (("#380000", "#280000"), ("#FFDEDE", "#FFEBEB")))+        setLabel "Errors"        numErrors      (errorsButton      pane)+        setLabel "Warnings"      numWarnings    (warningsButton    pane)+        setLabel "Suggestions"   numSuggestions (suggestionsButton pane)+        setLabel "Test Failures" numTestFails   (testFailsButton   pane)+        widgetShowAll (vbox pane)   -- | Get the currently selected error getSelectedError ::  TreeView-    -> ListStore ErrColumn+    -> TreeStore ErrorRecord     -> IO (Maybe LogRef) getSelectedError treeView store = do+    liftIO $ debugM "leksah" "getSelectedError"     treeSelection   <-  treeViewGetSelection treeView     paths           <-  treeSelectionGetSelectedRows treeSelection     case paths of-        [a]:r ->  do-            val     <-  listStoreGetValue store a-            return (Just (logRef val))+        path:_ ->  do+            val     <-  treeStoreGetValue store path+            case val of+                ERLogRef logRef -> return (Just logRef)+                _ -> return Nothing         _  ->  return Nothing --- | Select an error in the Errors pane-selectError :: Maybe LogRef -- ^ When @Nothing@, the first error in the list is selected+-- | Select a 'LogRef' in the Errors pane if it is visible+selectError :: Maybe LogRef -- ^ When @Nothing@, the first row in the list is selected             -> IDEAction selectError mbLogRef = do-    (mbPane :: Maybe IDEErrors) <- getPane-    errorRefs' <- readIDE errorRefs+    liftIO $ debugM "leksah" "selectError"+    (mbPane :: Maybe ErrorsPane) <- getPane     errors     <- getErrors Nothing     when (isNothing mbPane) $ do         liftIO $ writeIORef (autoClose errors) True         displayPane errors False-    liftIO $ do+    reifyIDE $ \ideR -> do         selection <- treeViewGetSelection (treeView errors)         case mbLogRef of             Nothing -> do-                size <- listStoreGetSize (errorStore errors)-                unless (size == 0) $+                empty <- null <$> treeStoreGetTree (errorStore errors) []+                unless empty $                     treeViewScrollToCell (treeView errors) (Just [0]) Nothing Nothing                 treeSelectionUnselectAll selection-            Just lr -> case lr `Seq.elemIndexL` errorRefs' of-                        Nothing  -> return ()-                        Just ind -> do-                            treeViewScrollToCell (treeView errors) (Just [ind]) Nothing Nothing-                            treeSelectionSelectPath selection [ind]+            Just lr -> do+                let store = errorStore errors+                empty <- isNothing <$> treeModelGetIterFirst store+                unless empty $ do+                    forest <- treeStoreGetForest store+                    let mbPath = forestFind forest (ERLogRef lr)+                    forM_ mbPath $ \path -> do+                        treeViewScrollToCell (treeView errors) (Just path) Nothing Nothing+                        treeSelectionSelectPath selection path +    where+        forestFind :: Eq a => Forest a -> a -> Maybe TreePath+        forestFind = forestFind' [0]+            where+                forestFind' path [] _ = Nothing+                forestFind' path (Node x trees : forest) y+                    | x == y    = Just path+                    | otherwise = forestFind' (path ++ [0]) trees y+                                      <|> forestFind' (sibling path) forest y --- | Constructs the context menu for the Errors pane-errorsContextMenu :: IDERef-                  -> ListStore ErrColumn-                  -> TreeView-                  -> Menu-                  -> IO ()-errorsContextMenu ideR store treeView theMenu = do-    mbSel           <-  getSelectedError treeView store-    item0           <-  menuItemNewWithLabel (__ "Resolve Errors")-    item0 `on` menuItemActivate $ reflectIDE resolveErrors ideR-    menuShellAppend theMenu item0-    case mbSel of-        Just sel -> addResolveMenuItems ideR theMenu sel-        Nothing -> return ()+                sibling [n] = [n+1]+                sibling (x:xs) = x:sibling xs+                sibling [] = error "Error in selectError sibling function" +contextMenuItems :: ErrorRecord -> TreePath -> TreeStore ErrorRecord -> IDEM [[(Text, IDEAction)]]+contextMenuItems record path store = return+    [("Resolve Errors", resolveErrors) :+        case record of+               ERLogRef logRef -> resolveMenuItems logRef ++ [clipboardItem (refDescription logRef)]+               ERIDE msg       -> [clipboardItem msg]+               ERPackage _ msg -> [clipboardItem msg]+               _               -> []+    ] ++    where clipboardItem str = ("Copy message to clipboard", liftIO $ clipboardGet selectionClipboard >>= flip clipboardSetText str)++ -- | Highlight an error refered to by the 'TreePath' in the given 'TreeViewColumn' errorsSelect :: IDERef-                -> ListStore ErrColumn+                -> TreeStore ErrorRecord                 -> TreePath                 -> TreeViewColumn                 -> IO ()-errorsSelect ideR store [index] _ = do-    ref <- listStoreGetValue store index-    reflectIDE (setCurrentError (Just (logRef ref))) ideR-errorsSelect _ _ _ _ = return ()+errorsSelect ideR store path _ = do+    liftIO $ debugM "leksah" "errorsSelect"+    record <- treeStoreGetValue store path+    case record of+        ERLogRef logRef -> reflectIDE (setCurrentError (Just logRef)) ideR+        ERFullMessage _ (Just ref) -> reflectIDE (setCurrentError (Just ref)) ideR+        _ -> return ()  --- | Select the matching errors for a 'SrcSpan' in the Errors +-- | 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 :: Maybe SrcSpan -- ^ When @Nothing@, unselects any errors in the pane+                     -> IDEAction selectMatchingErrors mbSpan = do+    liftIO $ debugM "leksah" "selectMatchingErrors"     mbErrors <- getPane-    case mbErrors of-        Nothing -> return ()-        Just pane  ->-            liftIO $ do-                treeSel <- treeViewGetSelection (treeView pane)-                case mbSpan of-                    Nothing -> treeSelectionUnselectAll treeSel-                    Just (SrcSpan file lStart cStart lEnd cEnd) -> do-                        size <- listStoreGetSize (errorStore pane)-                        foldM_ (\ haveScrolled n -> do-                            mbIter <- treeModelGetIter (errorStore pane) [n]-                            case mbIter of-                                Nothing -> return False-                                Just iter -> do-                                    ErrColumn {logRef = ref@LogRef{..}} <- listStoreGetValue (errorStore pane) n-                                    isSelected <- treeSelectionIterIsSelected treeSel iter-                                    let shouldBeSel = file == logRefFullFilePath ref-                                                     && (lStart, cStart) <= (srcSpanEndLine     logRefSrcSpan,-                                                                               srcSpanEndColumn   logRefSrcSpan)-                                                     && (lEnd, cEnd)     >= (srcSpanStartLine   logRefSrcSpan,-                                                                               srcSpanStartColumn logRefSrcSpan)-                                    when (isSelected && not shouldBeSel) $ treeSelectionUnselectIter treeSel iter-                                    when (not isSelected && shouldBeSel) $ do-                                        unless haveScrolled $ treeViewScrollToCell (treeView pane) (Just [n]) Nothing Nothing-                                        treeSelectionSelectIter treeSel iter-                                    return $ haveScrolled || shouldBeSel)-                            False (take size [0..])+    forM_ mbErrors $ \pane -> do+        treeSel <- liftIO $ treeViewGetSelection (treeView pane)+        liftIO $ treeSelectionUnselectAll treeSel+        forM_ mbSpan $ \span -> do+            spans <- map logRefSrcSpan . F.toList <$> readIDE errorRefs+            matches <- matchingRefs span . F.toList <$> readIDE errorRefs+            forM_ matches $ \ref ->+                selectError (Just ref) +matchingRefs :: SrcSpan -> [LogRef] -> [LogRef]+matchingRefs span refs =+    -- the path of the SrcSpan in the LogRef absolute, so comparison with the given SrcSpan goes right+    let toAbsolute ref =  ref {logRefSrcSpan = (logRefSrcSpan ref) {srcSpanFilename = logRefFullFilePath ref}}+    in filter (\ref -> filesMatch (logRefSrcSpan (toAbsolute ref)) span && span `insideOf` logRefSrcSpan (toAbsolute ref)) refs+    where+        filesMatch span span' = srcSpanFilename span == srcSpanFilename span' +        -- Test whether the first span is inside of the second+        insideOf (SrcSpan _ lStart cStart lEnd cEnd) (SrcSpan _ lStart' cStart' lEnd' cEnd')+            =  (lStart, cStart) <= (lEnd', cEnd')+            && (lEnd, cEnd)     >= (lStart', cStart')

@@ -6,7 +6,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------+--f -- Module      :  IDE.Pane.Files -- Copyright   :  (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License     :  GNU-GPL@@ -22,101 +22,81 @@ module IDE.Pane.Files (     IDEFiles(..) ,   FilesState(..)-,   getFiles-,   refreshFiles ) where  import Prelude hiding (catch) import Graphics.UI.Gtk-       (scrolledWindowSetShadowType, treeSelectionSelectionChanged,-        treeStoreRemove, treeModelIterNext, treeModelGetRow,-        treeStoreInsert, treeModelIterNthChild, treeModelGetPath, TreeIter,-        treeModelGetIter, TreePath, treeSelectionGetSelectedRows,-        rowActivated, treeStoreGetValue, rowExpanded, on, after,-        focusInEvent, scrolledWindowSetPolicy, containerAdd,-        scrolledWindowNew, treeSelectionSetMode, treeViewGetSelection,-        treeViewSetHeadersVisible, cellText, cellLayoutSetAttributes,-        cellLayoutPackStart, treeViewAppendColumn,-        treeViewColumnSetReorderable, treeViewColumnSetResizable,-        treeViewColumnSetSizing, treeViewColumnSetTitle, treeViewColumnNew,-        cellRendererPixbufNew, cellRendererTextNew, treeViewSetModel,-        treeViewNew, treeStoreNew, castToWidget, TreeStore, TreeView,-        ScrolledWindow, treeViewRowExpanded, treeStoreGetTree)-import Data.Maybe (isJust)+import Data.Maybe (fromMaybe, maybeToList, listToMaybe, isJust) import Control.Monad (forM, void, forM_, when) import Data.Typeable (Typeable) import IDE.Core.State-       (MessageLevel(..), ipdBuildDir, ipdPackageId, wsPackages,-        workspace, readIDE, IDEAction, ideMessage, reflectIDE, reifyIDE,-        IDEM, IDEPackage, ipdSandboxSources)-import IDE.Pane.SourceBuffer-    (goToSourceDefinition')+       (catchIDE, window, getIDE, MessageLevel(..), ipdPackageId,+        wsPackages, workspace, readIDE, IDEAction, ideMessage, reflectIDE,+        reifyIDE, IDEM, IDEPackage, ipdSandboxSources)+import IDE.Pane.SourceBuffer (fileNew, goToSourceDefinition')+import IDE.Sandbox import Control.Applicative ((<$>)) import System.FilePath ((</>), takeFileName, dropFileName) import Distribution.Package (PackageIdentifier(..))-import System.Directory (doesDirectoryExist, getDirectoryContents, getPermissions, readable)+import System.Directory+       (removeDirectoryRecursive, removeDirectory, createDirectory,+        doesFileExist, removeFile, doesDirectoryExist,+        getDirectoryContents, getPermissions, readable) import IDE.Core.CTypes        (Location(..), packageIdentifierToString) import Graphics.UI.Frame.Panes        (RecoverablePane(..), PanePath, RecoverablePane, Pane(..))-import Graphics.UI.Frame.ViewFrame (getNotebook)+import Graphics.UI.Frame.ViewFrame (getMainWindow, getNotebook) import Graphics.UI.Editor.Basics (Connection(..)) import Graphics.UI.Gtk.General.Enums        (ShadowType(..), PolicyType(..), SelectionMode(..),         TreeViewColumnSizing(..))-import System.Glib.Attributes (AttrOp(..))+import System.Glib.Attributes (set, AttrOp(..)) import Control.Monad.IO.Class (MonadIO(..))-import IDE.Utils.GUIUtils (__)-import Control.Exception (catch)+import IDE.Utils.GUIUtils+       (showErrorDialog, showInputDialog, treeViewContextMenu', __,+        showDialogOptions)+import Control.Exception (SomeException(..), catch) import Data.Text (Text)-import qualified Data.Text as T (pack)+import qualified Data.Text as T+       (isPrefixOf, words, isSuffixOf, unpack, pack) import Data.Monoid ((<>))-import Data.List (sortBy, sort)+import IDE.Core.Types+       (ipdLib, WorkspaceAction, Workspace(..), wsAllPackages, WorkspaceM,+        runPackage, runWorkspace, PackageAction, PackageM, IDEPackage(..),+        IDE(..), Prefs(..), MonadIDE(..), ipdPackageDir)+import System.Glib.Properties (newAttrFromMaybeStringProperty)+import System.FilePath+       (addTrailingPathSeparator, takeDirectory, takeExtension,+       makeRelative, splitDirectories)+import Control.Monad.Reader.Class (MonadReader(..))+import IDE.Workspaces+       (makePackage, workspaceAddPackage', workspaceRemovePackage,+        workspaceActivatePackage, workspaceTry, workspaceTryQuiet,+        packageTry)+import Data.List+       (isSuffixOf, find, stripPrefix, isPrefixOf, sortBy, sort) import Data.Ord (comparing)-import Data.Char (toLower)-import IDE.Core.Types (IDEPackage(..), IDE(..), Prefs(..))-import Data.Tree (Tree(..))+import Data.Char (toUpper, toLower) 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 -- ^ 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-    compare (FileRecord _) (DirRecord _) = GT-    compare (FileRecord p1) (FileRecord p2) = comparing (map toLower) p1 p2-    compare (DirRecord p1) (DirRecord p2) = comparing (map toLower) p1 p2-    compare _ _ = LT---- | 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 = ""--+import Data.Tree (Forest, Tree(..))+import Graphics.UI.Gtk.MenuComboToolbar.MenuItem+       (menuItemActivate, menuItemNewWithLabel)+import IDE.Pane.Modules (addModule)+import Graphics.UI.Gtk.Windows.MessageDialog+       (ButtonsType(..), MessageType(..), messageDialogNew)+import Graphics.UI.Gtk.ModelView.CellRenderer+       (CellRendererMode(..), cellMode)+import IDE.Pane.PackageEditor (packageEditText)+import IDE.Utils.GtkBindings (treeViewSetActiveOnSingleClick)+import IDE.Package (packageTest, packageRun, packageClean)   -- * The Files pane  -- | The representation of the Files pane data IDEFiles        =   IDEFiles {-    scrolledView    ::   ScrolledWindow-,   treeView        ::   TreeView-,   fileStore       ::   TreeStore FileRecord+    deprecatedLabel :: Label } deriving Typeable  @@ -128,7 +108,7 @@ instance Pane IDEFiles IDEM where     primPaneName _  =   __ "Files"     getAddedIndex _ =   0-    getTopWidget    =   castToWidget . scrolledView+    getTopWidget    =   castToWidget . deprecatedLabel     paneId b        =   "*Files"  instance RecoverablePane IDEFiles FilesState IDEM where@@ -137,222 +117,5 @@         nb      <-  getNotebook pp         buildPane pp nb builder     builder pp nb windows = reifyIDE $ \ ideR -> do-        fileStore   <-  treeStoreNew []-        treeView    <-  treeViewNew-        treeViewSetModel treeView fileStore--        renderer1    <- cellRendererTextNew-        renderer10   <- cellRendererPixbufNew-        col1         <- treeViewColumnNew-        treeViewColumnSetTitle col1 (__ "File")-        treeViewColumnSetSizing col1 TreeViewColumnAutosize-        treeViewColumnSetResizable col1 True-        treeViewColumnSetReorderable col1 True-        treeViewAppendColumn treeView col1-        cellLayoutPackStart col1 renderer10 False-        cellLayoutPackStart col1 renderer1 True-        cellLayoutSetAttributes col1 renderer1 fileStore-            $ \row -> [ cellText := displayText row]--        treeViewSetHeadersVisible treeView False-        sel <- treeViewGetSelection treeView-        treeSelectionSetMode sel SelectionSingle--        scrolledView <- scrolledWindowNew Nothing Nothing-        scrolledWindowSetShadowType scrolledView ShadowIn-        containerAdd scrolledView treeView-        scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic--        let files = IDEFiles {..}--        cid1 <- after treeView focusInEvent $ do-            liftIO $ reflectIDE (makeActive files) ideR-            return True-        cid2 <- on treeView rowExpanded $ \ iter path -> do-            record <- treeStoreGetValue fileStore path-            reflectIDE (-                case record of-                    DirRecord f     -> refreshDir fileStore path f-                    PackageRecord p -> refreshPackage fileStore path p-                    _               -> ideMessage Normal (__ "Unexpected Expansion in Files Pane")) ideR-        on treeView rowActivated $ \ path col -> do-            record <- treeStoreGetValue fileStore path-            reflectIDE (-                case record of-                    FileRecord f    -> void (goToSourceDefinition' f (Location "" 1 0 1 0))-                    DirRecord f     -> refreshDir fileStore path f-                    PackageRecord p -> refreshPackage fileStore path p-                    _               -> ideMessage Normal (__ "Unexpected Activation in Files Pane")) ideR-        on sel treeSelectionSelectionChanged $ do-            paths <- treeSelectionGetSelectedRows sel-            forM_ paths $ \ path -> do-                record <- treeStoreGetValue fileStore path-                reflectIDE (-                    case record of-                        FileRecord _    -> return ()-                        DirRecord f     -> refreshDir fileStore path f-                        PackageRecord p -> refreshPackage fileStore path p-                        _               -> ideMessage Normal (__ "Unexpected Selection in Files Pane")) ideR--        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)----- | Refreshes the Files pane, lists all package directories and synchronizes the expanded--- folders with the file system-refreshFiles :: IDEAction-refreshFiles = do-    files <- getFiles Nothing-    let store = fileStore files-    let view  = treeView files-    mbWS <- readIDE workspace-    let packages = maybe [] wsPackages mbWS-    setDirectories store Nothing $ map PackageRecord packages--    forM_ (zip [0..] packages) $ \(n, package) ->-         refreshRecursively store [n] view---- | Returns the 'FileRecord's at the given 'FilePath'.-dirContents :: FilePath -> IDEM [FileRecord]-dirContents dir = do-   prefs <- readIDE prefs-   contents <- liftIO $ getDirectoryContents dir-                            `catch` \ (e :: IOError) -> return []-   let filtered = if showHiddenFiles prefs-                      then filter (`notElem` [".", ".."]) contents-                      else filter ((/= '.') . head) contents-   records <- forM filtered $ \f -> do-                  let full = dir </> f-                  isDir <- liftIO $ doesDirectoryExist full-                  return $ if isDir then DirRecord full else FileRecord full-   return (sort records)----- | Recursively refreshes the file tree with the given TreePath as root. Only refreshes contents--- of expanded folders.-refreshRecursively :: TreeStore FileRecord -> TreePath -> TreeView -> IDEAction-refreshRecursively store path view = do-    isExpanded <- liftIO $ treeViewRowExpanded view path-    record     <- liftIO $ treeStoreGetValue store path--    when isExpanded $-        case record of-            DirRecord dir -> do-                refreshDir store path dir-                nChildren  <- length . subForest <$> liftIO (treeStoreGetTree store path)-                forM_ [0..nChildren-1] (\n -> refreshRecursively store (path ++ [n]) view)--            PackageRecord package -> do-                refreshPackage store path package-                nChildren  <- length . subForest <$> liftIO (treeStoreGetTree store path)-                forM_ [0..nChildren-1] (\n -> refreshRecursively store (path ++ [n]) view)--            _ -> return ()---- | Refreshes the child nodes of the package node at the given 'TreePath'. Also adds sandbox--- add-source dependencies as a 'PackageRecord'.-refreshPackage :: TreeStore FileRecord -> TreePath -> IDEPackage -> IDEAction-refreshPackage store path p = do-    liftIO $ debugM "leksah" $ "refreshPackage " <> ipdCabalFile p-    let dir = ipdBuildDir p-    mbIter <- liftIO $ treeModelGetIter store path-    when (isJust mbIter) $ do-        contents <- dirContents dir-        setDirectories store mbIter $ map PackageRecord (ipdSandboxSources p) ++ contents----- | Refreshes the child nodes of the node at the given 'TreePath'.-refreshDir :: TreeStore FileRecord -> TreePath -> FilePath -> IDEAction-refreshDir store path dir =  do-    liftIO $ debugM "leksah" $ "refreshPackage " <> dir-    mbIter <- liftIO $ treeModelGetIter store path-    when (isJust mbIter) $ do-        contents <- dirContents dir-        setDirectories store mbIter contents---- | Sets the child nodes of the given 'TreeIter' to the provided list of 'FileRecord's. If a record--- is already present, it is kept in the same (expanded) state.-setDirectories :: TreeStore FileRecord -> Maybe TreeIter -> [FileRecord] -> IDEAction-setDirectories store parent records = liftIO $ do-    parentPath <- case parent of-                Just i -> treeModelGetPath store i-                _      -> return []-    forM_ (zip [0..] records) $ \(n, record) -> do-        mbChild <- treeModelIterNthChild store parent n-        findResult <- find record store mbChild-        case (mbChild, findResult) of-            (_, WhereExpected _) -> return ()-            (Just iter, Found _) -> do-                path <- treeModelGetPath store iter-                removeUntil record store path-            _ -> do-                treeStoreInsert store parentPath n record--                -- Insert placeholder children for dirs and packages so they can-                -- be expanded on clicking, and have the contents loaded "lazily".-                case record of-                    DirRecord _     -> treeStoreInsert store (parentPath++[n]) 0 PlaceHolder-                    PackageRecord _ -> treeStoreInsert store (parentPath++[n]) 0 PlaceHolder-                    _               -> return ()-    removeRemaining store (parentPath++[length records])--data FindResult = WhereExpected TreeIter | Found TreeIter | NotFound---- | Tries to find the given value in the 'TreeStore'. Only looks at the given 'TreeIter' and its--- sibling nodes to the right.--- Returns @WhereExpected iter@ if the records is found at the provided 'TreeIter'--- Returns @Found iter@ if the record is found at a sibling iter--- Returns @NotFound@ otherwise-find :: Eq a => a -> TreeStore a -> Maybe TreeIter -> IO FindResult-find _ _ Nothing = return NotFound-find a store (Just iter) = do-    row <- treeModelGetRow store iter-    if row == a-        then return $ WhereExpected iter-        else treeModelIterNext store iter >>= find'-  where-    find' :: Maybe TreeIter -> IO FindResult-    find' Nothing = return NotFound-    find' (Just iter) = do-        row <- treeModelGetRow store iter-        if row == a-            then return $ Found iter-            else treeModelIterNext store iter >>= find'----- | Starting at the node at the given 'TreePath', removes all sibling nodes to the right---   until the given value is found.-removeUntil :: Eq a => a -> TreeStore a -> TreePath -> IO ()-removeUntil a store path = do-    row <- treeStoreGetValue store path-    when (row /= a) $ do-        found <- treeStoreRemove store path-        when found $ removeUntil a store path----- | Starting at the node at the given 'TreePath', removes all sibling nodes to the right-removeRemaining :: TreeStore a -> TreePath -> IO ()-removeRemaining store path = do-    found <- treeStoreRemove store path-    when found $ removeRemaining store path-----------------+        deprecatedLabel <- labelNew $ Just ("The Files pane is deprecated and has been combined with the Workspace pane"::Text)+        return (Just IDEFiles {..}, [])

@@ -247,7 +247,7 @@             Just active -> active : filter (/= active) (wsAllPackages ws)
             Nothing     -> wsAllPackages ws
     lift $ grepDirectories regexString caseSensitive $
-            map (dropFileName . ipdCabalFile) packages
+            map ipdPackageDir packages
 
 
 -- | Greps a list of directories

@@ -69,7 +69,7 @@  instance Pane IDEInfo IDEM     where-    primPaneName _  =   __ "Info"+    primPaneName _  =   __ "Symbol Info"     getAddedIndex _ =   0     getTopWidget    =   castToWidget . sw     paneId b        =   "*Info"

@@ -59,7 +59,7 @@         hasLibs, executables, testSuites, exeName, testName, benchmarks,         benchmarkName, libBuildInfo, library, buildInfo, testBuildInfo,         benchmarkBuildInfo)-import System.FilePath (takeBaseName, (</>),dropFileName)+import System.FilePath (takeBaseName, (</>),dropFileName,makeRelative,takeDirectory) import System.Directory (doesFileExist,createDirectoryIfMissing, removeFile) import Graphics.UI.Editor.MakeEditor (buildEditor,FieldDescription(..),mkField) import Graphics.UI.Editor.Parameters@@ -782,13 +782,26 @@         resultTree        =   foldl' insertPairsInTree defaultRoot modDescrPackDescr         in sortTree resultTree +-- | Insert module and package info into the tre insertPairsInTree :: ModTree -> (ModuleDescr,PackageDescr) -> ModTree insertPairsInTree tree pair =-    let nameArray           =   map T.pack . components . modu . mdModuleId $ fst pair+    let nameArray           =   modTreeName $ fst pair         (startArray,last)   =   splitAt (length nameArray - 1) nameArray         pairedWith          =   map (\ n -> (n, Nothing)) startArray ++ [(head last, Just pair)]     in  insertNodesInTree pairedWith tree-+    where modTreeName modDescr = let+                    modId = mdModuleId modDescr+                    modName = modu modId+                    mFilePath = mdMbSourcePath modDescr+                    -- show relative file path for Main modules+                    -- since we can have several+                    in case (components modName,mFilePath) of+                        (["Main"],Just fp) ->+                            let sfp = case (pdMbSourcePath (snd pair)) of+                                        Nothing -> fp+                                        Just pfp -> makeRelative (takeDirectory pfp) fp+                            in  [T.pack $ "Main ("++sfp++")"]+                        (cmps,_) -> map T.pack cmps  insertNodesInTree :: [ModuleRecord] -> ModTree -> ModTree insertNodesInTree  [p1@(str1,Just pair)] (Node p2@(str2,mbPair) forest2) =@@ -1151,7 +1164,7 @@         []     -> return []         (treePath:_) -> liftIO $ mapM (treeStoreGetValue store . (`take` treePath))                                    [1 .. length treePath]-    addModule categories+    addModule (map fst categories)  -- Includes non buildable allBuildInfo' :: PackageDescription -> [BuildInfo]@@ -1160,15 +1173,16 @@                        ++ [ testBuildInfo tst      | tst <- testSuites pkg_descr ]                        ++ [ benchmarkBuildInfo tst | tst <- benchmarks pkg_descr ] -addModule :: [ModuleRecord] -> PackageAction-addModule categories = do+addModule :: [Text] -> PackageAction+addModule modulePrefix = do     liftIO $ debugM "leksah" "selectIdentifier"     mbPD <- liftIDE getPackageDescriptionAndPath     case mbPD of         Nothing             -> liftIDE $ ideMessage Normal (__ "No package description")         Just (pd,cabalPath) -> let srcPaths = nub $ concatMap hsSourceDirs $ allBuildInfo' pd                                    rootPath = dropFileName cabalPath-                                   modPath  = foldr ((\ a b -> a <> "." <> b) . fst) "" categories+                                   modPath  = foldr (\a b -> a <> "." <> b) ""+                                                    modulePrefix                                in do             window' <- liftIDE getMainWindow             mbResp <- liftIO $ addModuleDialog window' modPath srcPaths (hasLibs pd) $@@ -1181,7 +1195,8 @@                     case simpleParse $ T.unpack modPath of                         Nothing         -> liftIDE $ ideMessage Normal (T.pack $ printf (__ "Not a valid module name : %s") (T.unpack modPath))                         Just moduleName -> do-                            let  target = srcPath </> toFilePath moduleName ++ ".hs"+                            package <- ask+                            let  target = ipdPackageDir package </> srcPath </> toFilePath moduleName ++ ".hs"                             liftIO $ createDirectoryIfMissing True (dropFileName target)                             alreadyExists <- liftIO $ doesFileExist target                             if alreadyExists@@ -1197,8 +1212,7 @@                                     liftIDE $ fileOpenThis target  ---  Yet another stupid little dialog-+-- | The dialog for adding a new module data AddModule = AddModule {     moduleName   :: Text,     sourceRoot   :: FilePath,@@ -1213,7 +1227,13 @@     lib (Just False) = [LibOtherMod]     lib Nothing = [] -addModuleDialog :: Window -> Text -> [FilePath] -> Bool -> [Text] -> IO (Maybe AddModule)+-- | Creates and runs a "new module" dialog+addModuleDialog :: Window -- ^ The parent window+                -> Text   -- ^ Will be set as default value for the module name+                -> [FilePath] -- ^ Possible source directories to add it to+                -> Bool       -- ^ Whether the active package has a library+                -> [Text]     -- ^ The components of the active package+                -> IO (Maybe AddModule) addModuleDialog parent modString sourceRoots hasLib exesTests = do     liftIO $ debugM "leksah" "addModuleDialog"     dia                        <-   dialogNew

@@ -113,6 +113,8 @@ import MyMissing (forceJust) import Language.Haskell.Extension (Language(..)) import Distribution.License (License(..))+import Control.Exception (SomeException(..))+import IDE.Metainfo.Provider (getAllPackageIds)  printf :: PrintfType r => Text -> r printf = S.printf . T.unpack@@ -170,13 +172,13 @@   = chooseDir window (__ "Select root folder for package")  choosePackageFile :: Window -> Maybe FilePath -> IO (Maybe FilePath)-choosePackageFile window-  = chooseFile window (__ "Select cabal package file (.cabal)")+choosePackageFile window mbfp+  = chooseFile window (__ "Select cabal package file (.cabal)") mbfp [("Cabal Package Files", ["*.cabal"])]  packageEdit :: PackageAction packageEdit = do     idePackage <- ask-    let dirName = dropFileName (ipdCabalFile idePackage)+    let dirName = ipdPackageDir idePackage     modules <- liftIO $ allModules dirName     package <- liftIO $ readPackageDescription normal (ipdCabalFile idePackage)     if hasConfigs package@@ -376,7 +378,7 @@ cloneFields :: [PackageId] -> FilePath -> FieldDescription ClonePackageSourceRepo cloneFields packages workspaceDir = VFD emptyParams [         mkField-            (paraName <<<- ParaName (__ "Existing package to clone source repository")+            (paraName <<<- ParaName (__ "Existing package to copy source repository")                     $ emptyParams)             packageToClone             (\ a b -> b{packageToClone = a})@@ -389,17 +391,18 @@             (\ a b -> b{cloneParentDir = a})             (fileEditor (Just workspaceDir) FileChooserActionSelectFolder "Select")] -clonePackageSourceDialog :: Window -> FilePath -> IO (Maybe ClonePackageSourceRepo)+clonePackageSourceDialog :: Window -> FilePath -> IDEM (Maybe ClonePackageSourceRepo) clonePackageSourceDialog parent workspaceDir = do-    packages                   <- getInstalledPackageIds+  packages <- getAllPackageIds+  liftIO $ do     dia                        <-   dialogNew     set dia [ windowTransientFor := parent-            , windowTitle := __ "Clone Package" ]+            , windowTitle := __ "Copy Installed Package" ]     upper                      <-   dialogGetContentArea dia     lower                      <-   dialogGetActionArea dia     (widget,inj,ext,_)         <-   buildEditor (cloneFields packages workspaceDir)                                         (ClonePackageSourceRepo "" workspaceDir)-    okButton <- dialogAddButton dia (__"Clone Package") ResponseOk+    okButton <- dialogAddButton dia (__"Copy Package") ResponseOk     dialogAddButton dia (__"Cancel") ResponseCancel     boxPackStart (castToBox upper) widget PackGrow 7     set okButton [widgetCanDefault := True]@@ -414,9 +417,9 @@         _             -> return Nothing  packageClone :: FilePath -> C.Sink ToolOutput IDEM () -> (FilePath -> IDEAction) -> IDEAction-packageClone workspaceDir log activateAction = do+packageClone workspaceDir log activateAction = flip catchIDE (\(e :: SomeException) -> print e) $ do     windows  <- getWindows-    mbResult <- liftIO $ clonePackageSourceDialog (head windows) workspaceDir+    mbResult <- clonePackageSourceDialog (head windows) workspaceDir     case mbResult of         Nothing -> return ()         Just ClonePackageSourceRepo{..} -> cabalUnpack cloneParentDir packageToClone True Nothing log activateAction@@ -597,7 +600,7 @@         Nothing -> do             pp  <- getBestPathForId "*Package"             nb  <- getNotebook pp-            packageInfos <- liftIO getInstalledPackageIds+            packageInfos <- getAllPackageIds             let packageEd = toEditor packageD             initPackage packagePath packageEd                 (packageDD@@ -622,7 +625,7 @@ initPackage packageDir packageD packageDescr panePath nb modules afterSaveAction origPackageD = do     let fields =  flattenFieldDescription packageDescr     let initialPackagePath = packageDir </> (display . pkgName . package . pd) packageD ++ ".cabal"-    packageInfos <- liftIO getInstalledPackageIds+    packageInfos <- getAllPackageIds     mbP <- buildThisPane panePath nb         (builder' packageDir packageD packageDescr afterSaveAction             initialPackagePath modules packageInfos fields origPackageD)

@@ -1,936 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}------------------------------------------------------------------------------------ Module      :  IDE.Pane.Preferences--- Copyright   :  (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License     :  GNU-GPL------ Maintainer  :  <maintainer at leksah.org>--- Stability   :  provisional--- Portability :  portable--------- | Module for saving, restoring and editing preferences----------------------------------------------------------------------------------------module IDE.Pane.Preferences (-    IDEPrefs(..)-,   PrefsState-,   readPrefs-,   writePrefs-,   defaultPrefs-,   prefsDescription-,   getPrefs-) where--import Graphics.UI.Gtk-       (buttonBoxSetLayout, boxSetSpacing, widgetDestroy, dialogRun,-        windowWindowPosition, dialogAddButton, messageDialogNew,-        labelSetMarkup, labelNew, widgetSetSensitive, cellText,-        widgetModifyFont, on, buttonActivated, boxPackEnd, boxPackStart,-        buttonNewFromStock, hButtonBoxNew, vBoxNew, castToWidget, VBox,-        ShadowType(..), Packing(..), fontDescriptionFromString, AttrOp(..),-        FileChooserAction(..), Color(..), ResponseId(..))-import qualified Text.PrettyPrint.HughesPJ as PP-import Distribution.Package-import Data.IORef-import Data.Typeable--import Control.Event-import Graphics.UI.Editor.Basics-import IDE.Core.State-import Graphics.UI.Editor.Simple-import Graphics.UI.Editor.Composite-import Graphics.UI.Editor.Parameters-import Graphics.UI.Editor.MakeEditor hiding (parameters)-import Graphics.UI.Editor.DescriptionPP-import Text.PrinterParser hiding (fieldParser,parameters)-import IDE.TextEditor-import IDE.Pane.SourceBuffer-import IDE.Pane.Log-import IDE.Pane.Info (setInfoStyle)-import IDE.Utils.FileUtils-import IDE.Utils.GUIUtils-import IDE.Debug-    (debugSetPrintBindResult,-     debugSetBreakOnError,-     debugSetBreakOnException,-     debugSetPrintEvldWithShow)-import Graphics.UI.Gtk.SourceView-       (sourceStyleSchemeManagerAppendSearchPath,-        sourceStyleSchemeManagerGetSchemeIds, sourceStyleSchemeManagerNew)-import System.Time (getClockTime)-import qualified IDE.StrippedPrefs as SP-import Control.Exception(SomeException,catch)-import Prelude hiding(catch)-import Data.List (isSuffixOf, sortBy)-import Data.Maybe (mapMaybe, catMaybes, fromMaybe, isJust)-import Graphics.UI.Gtk.Windows.MessageDialog-       (ButtonsType(..), MessageType(..))-import System.Glib.Attributes (set)-import Graphics.UI.Gtk.General.Enums-       (ButtonBoxStyle(..), WindowPosition(..))-import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad (void, when)-import System.FilePath ((</>))-import Data.Text (Text)-import qualified Data.Text as T (isSuffixOf, unpack, pack, null)-import Data.Monoid ((<>))-import Control.Applicative ((<$>))-import Distribution.Text (display, simpleParse)-import IDE.Pane.Files (refreshFiles)-import Data.Foldable (forM_)---- ------------------------------------------------------------------------ This needs to be incremented, when the preferences format changes----prefsVersion :: Int-prefsVersion = 3----- | 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"-    getAddedIndex _ =   0-    getTopWidget    =   castToWidget . prefsBox-    paneId b        =   "*Prefs"---instance RecoverablePane IDEPrefs PrefsState IDEM where-    saveState p     =   return Nothing-    recoverState pp st  =  return Nothing-    builder pp nb windows = do-        initialPrefs <- readIDE prefs-        configDir <- liftIO getConfigDir-        lastAppliedPrefsRef <- liftIO $ newIORef initialPrefs-        packageInfos <- liftIO getInstalledPackageIds-        let flatPrefsDesc = flattenFieldDescriptionPP (prefsDescription configDir packageInfos)-        reifyIDE $  \ ideR -> do-            vb      <-  vBoxNew False 0-            bb      <-  hButtonBoxNew-            boxSetSpacing bb 6-            buttonBoxSetLayout bb ButtonboxSpread-            preview   <-  buttonNewFromStock "Preview"-            restore <-  buttonNewFromStock "Restore"-            closeB  <-  buttonNewFromStock "gtk-cancel"-            save    <-  buttonNewFromStock "gtk-save"-            widgetSetSensitive save False-            boxPackStart bb preview PackNatural 0-            boxPackStart bb restore PackNatural 0-            boxPackEnd bb closeB PackNatural 0-            boxPackEnd bb save PackNatural 0-            (widget,injb,ext,notifier) <-  buildEditor-                                (extractFieldDescription $ prefsDescription configDir packageInfos) initialPrefs-            boxPackStart vb widget PackGrow 0-            label   <-  labelNew (Nothing :: Maybe Text)-            boxPackStart vb label PackNatural 0-            boxPackEnd vb bb PackNatural 5-            let prefsPane = IDEPrefs vb--            let applyPrefs newPrefs = do-                    lastAppliedPrefs    <- readIORef lastAppliedPrefsRef-                    reflectIDE (modifyIDE_ (\ide -> ide{prefs = newPrefs})) ideR-                    mapM_ (\f -> reflectIDE (applicator f newPrefs lastAppliedPrefs) ideR) flatPrefsDesc-                    writeIORef lastAppliedPrefsRef newPrefs--            on preview buttonActivated $ do-                mbNewPrefs <- extract initialPrefs [ext]-                forM_ mbNewPrefs applyPrefs--            on restore buttonActivated $ do-                applyPrefs initialPrefs--                -- update the UI-                injb initialPrefs-                markLabel nb (getTopWidget prefsPane) False-                widgetSetSensitive save False---            on save buttonActivated $ do-                mbNewPrefs <- extract initialPrefs [ext]-                case mbNewPrefs of-                    Nothing -> return ()-                    Just newPrefs -> do-                        applyPrefs newPrefs--                        -- save preferences to disk-                        fp   <- getConfigFilePathForSave standardPreferencesFilename-                        writePrefs fp newPrefs-                        fp2  <-  getConfigFilePathForSave strippedPreferencesFilename-                        SP.writeStrippedPrefs fp2-                            SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs,-                                       SP.unpackDirectory   = unpackDirectory newPrefs,-                                       SP.retrieveURL       = retrieveURL newPrefs,-                                       SP.retrieveStrategy  = retrieveStrategy newPrefs,-                                       SP.serverPort        = serverPort newPrefs,-                                       SP.endWithLastConn   = endWithLastConn newPrefs}--                        -- close the UI-                        reflectIDE (void (closePane prefsPane)) ideR--            on closeB buttonActivated $ do-                mbP <- extract initialPrefs [ext]-                let hasChanged = case mbP of-                                        Nothing -> False-                                        Just p -> p{prefsFormat = 0, prefsSaveTime = ""} /=-                                                  initialPrefs{prefsFormat = 0, prefsSaveTime = ""}-                if not hasChanged-                    then reflectIDE (void (closePane prefsPane)) ideR-                    else do-                        md <- messageDialogNew (Just windows) []-                            MessageQuestion-                            ButtonsYesNo-                            (__ "Unsaved changes. Close anyway?")-                        set md [ windowWindowPosition := WinPosCenterOnParent ]-                        resp <- dialogRun md-                        widgetDestroy md-                        case resp of-                            ResponseYes -> do-                                applyPrefs initialPrefs-                                reflectIDE (void (closePane prefsPane)) ideR-                            _  ->   return ()-            registerEvent notifier FocusIn (\e -> do-                reflectIDE (makeActive prefsPane) ideR-                return (e{gtkReturn=False}))-            registerEvent notifier MayHaveChanged (\ e -> do-                mbP <- extract initialPrefs [ext]-                let hasChanged = case mbP of-                                        Nothing -> False-                                        Just p -> p{prefsFormat = 0, prefsSaveTime = ""} /=-                                                  initialPrefs{prefsFormat = 0, prefsSaveTime = ""}-                when (isJust mbP) $ labelSetMarkup label ("" :: Text)-                markLabel nb (getTopWidget prefsPane) hasChanged-                widgetSetSensitive save hasChanged-                return (e{gtkReturn=False}))-            registerEvent notifier ValidationError (\e -> do-                labelSetMarkup label $ "<span foreground=\"red\" size=\"x-large\">The following fields have invalid values: "-                    <> eventText e <> "</span>"-                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 [-        mkFieldPP-            (paraName <<<- ParaName (__ "Version number of preferences file format")-                $ paraSynopsis <<<- ParaSynopsis (__ "Integer")-                    $ paraShowLabel <<<- ParaShowLabel False $ emptyParams)-            (PP.text . show)-            intParser-            prefsFormat-            (\ b a -> a{prefsFormat = b})-            (noEditor 0)-            (\b -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Time of last storage")-                $ paraShowLabel <<<- ParaShowLabel False $ emptyParams)-            (PP.text . show)-            stringParser-            prefsSaveTime-            (\ b a -> a{prefsSaveTime = b})-            (noEditor "")-            (\b -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Show line numbers")-                $ paraSynopsis <<<- ParaSynopsis (__ "(True/False)")-                    $ emptyParams)-            (PP.text . show)-            boolParser-            showLineNumbers-            (\ b a -> a{showLineNumbers = b})-            boolEditor-            (\b -> do-                buffers <- allBuffers-                mapM_ (\(IDEBuffer {sourceView = sv}) -> setShowLineNumbers sv b) buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "TextView Font") $ emptyParams)-            (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))-            (do str <- stringParser-                return (if T.null str then Nothing else Just str))-            textviewFont-            (\ b a -> a{textviewFont = b})-            fontEditor-            (\mbs -> do-                buffers <- allBuffers-                mapM_ (\(IDEBuffer {sourceView = sv}) -> setFont sv mbs) buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Right margin")-                $ paraSynopsis <<<- ParaSynopsis (__ "Size or 0 for no right margin")-                    $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)-            (PP.text . show)-            readParser-            rightMargin-            (\b a -> a{rightMargin = b})-            (disableEditor (intEditor (1.0, 200.0, 5.0), paraName <<<- ParaName (__ "Position")-                    $ emptyParams)-                    True (__ "Show it ?"))-            (\b -> do-                buffers <- allBuffers-                mapM_ (\(IDEBuffer {sourceView = sv}) -> setRightMargin sv-                                (case b of-                                    (True,v) -> Just v-                                    (False,_) -> Nothing)) buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Tab width") $ emptyParams)-            (PP.text . show)-            intParser-            tabWidth-            (\b a -> a{tabWidth = b})-            (intEditor (1.0, 20.0, 1.0))-            (\i -> do-                buffers <- allBuffers-                mapM_ (\(IDEBuffer {sourceView = sv}) -> setIndentWidth sv i) buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Wrap lines") $ emptyParams)-            (PP.text . show)-            boolParser-            wrapLines-            (\b a -> a{wrapLines = b})-            boolEditor-            (\b -> do-                buffers <- allBuffers-                mapM_ (\(IDEBuffer {sourceView = sv}) -> setWrapMode sv b) buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Use standard line ends even on windows") $ emptyParams)-            (PP.text . show)-            boolParser-            forceLineEnds-            (\b a -> a{forceLineEnds = b})-            boolEditor-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Remove trailing blanks when saving a file") $ emptyParams)-            (PP.text . show)-            boolParser-            removeTBlanks-            (\b a -> a{removeTBlanks = b})-            boolEditor-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Source candy")-                $ paraSynopsis <<<- ParaSynopsis-                    (__ "Empty for do not use or the name of a candy file in a config dir")-                    $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)-            (PP.text . show)-            readParser-            sourceCandy (\b a -> a{sourceCandy = b})-            (disableEditor (textEditor (not . T.null) True,-                paraName <<<- ParaName (__ "Candy specification")-                                    $ emptyParams)-                    True (__ "Use it ?"))-            (\cs -> case cs of-                        (False,_) -> do-                            setCandyState False-                            editCandy-                        (True,name) -> do-                            setCandyState True-                            editCandy)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Editor Style") $ emptyParams)-            (\a -> PP.text (case a of (False,_) -> show ""; (True, s) -> show s))-            (do str <- stringParser-                return (if T.null str then (False, __ "classic") else (True,str)))-            sourceStyle-            (\b a -> a{sourceStyle = b})-            styleEditor-            (\mbs -> do-                setInfoStyle-                buffers <- allBuffers-                mapM_ updateStyle' buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Found Text Background") $ emptyParams)-            (PP.text . show)-            colorParser-            foundBackgroundLight-            (\ b a -> a{foundBackgroundLight = b})-            colorEditor-            (\c -> do-                buffers <- allBuffers-                mapM_ updateStyle' buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Selection Match Text Background") $ emptyParams)-            (PP.text . show)-            colorParser-            matchBackgroundLight-            (\ b a -> a{matchBackgroundLight = b})-            colorEditor-            (\c -> do-                buffers <- allBuffers-                mapM_ updateStyle' buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Execution Context Text Background") $ emptyParams)-            (PP.text . show)-            colorParser-            contextBackgroundLight-            (\ b a -> a{contextBackgroundLight = b})-            colorEditor-            (\c -> do-                buffers <- allBuffers-                mapM_ updateStyle' buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Breakpoint Text Background") $ emptyParams)-            (PP.text . show)-            colorParser-            breakpointBackgroundLight-            (\ b a -> a{breakpointBackgroundLight = b})-            colorEditor-            (\c -> do-                buffers <- allBuffers-                mapM_ updateStyle' buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Lint Text Background") $ emptyParams)-            (PP.text . show)-            colorParser-            lintBackgroundLight-            (\ b a -> a{lintBackgroundLight = b})-            colorEditor-            (\c -> do-                buffers <- allBuffers-                mapM_ updateStyle' buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Found Text Dark Background") $ emptyParams)-            (PP.text . show)-            colorParser-            foundBackgroundDark-            (\ b a -> a{foundBackgroundDark = b})-            colorEditor-            (\c -> do-                buffers <- allBuffers-                mapM_ updateStyle' buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Selection Match Text Dark Background") $ emptyParams)-            (PP.text . show)-            colorParser-            matchBackgroundDark-            (\ b a -> a{matchBackgroundDark = b})-            colorEditor-            (\c -> do-                buffers <- allBuffers-                mapM_ updateStyle' buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Execution Context Text Dark Background") $ emptyParams)-            (PP.text . show)-            colorParser-            contextBackgroundDark-            (\ b a -> a{contextBackgroundDark = b})-            colorEditor-            (\c -> do-                buffers <- allBuffers-                mapM_ updateStyle' buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Breakpoint Text Dark Background") $ emptyParams)-            (PP.text . show)-            colorParser-            breakpointBackgroundDark-            (\ b a -> a{breakpointBackgroundDark = b})-            colorEditor-            (\c -> do-                buffers <- allBuffers-                mapM_ updateStyle' buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Lint Text Dark Background") $ emptyParams)-            (PP.text . show)-            colorParser-            lintBackgroundDark-            (\ b a -> a{lintBackgroundDark = b})-            colorEditor-            (\c -> do-                buffers <- allBuffers-                mapM_ updateStyle' buffers)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Automatically load modified files modified outside of Leksah") $ emptyParams)-            (PP.text . show)-            boolParser-            autoLoad-            (\b a -> a{autoLoad = b})-            boolEditor-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Text Editor") $ emptyParams)-            (PP.text . show)-            stringParser-            textEditorType-            (\b a -> a{textEditorType = b})-            (comboSelectionEditor ["GtkSourceView", "Yi", "CodeMirror"] id)-            (\i -> return ())-    ]),-    (__ "GUI Options", VFDPP emptyParams [-        mkFieldPP-            (paraName <<<- ParaName (__ "LogView Font") $ emptyParams)-            (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))-            (do str <- stringParser-                return (if T.null str then Nothing else Just str))-            logviewFont-            (\ b a -> a{logviewFont = b})-            fontEditor-            (\mbs -> do-                log <- getLog-                fdesc <- liftIO $fontDescriptionFromString (fromMaybe "" mbs)-                liftIO $widgetModifyFont (castToWidget $ logLaunchTextView log) (Just fdesc))-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Window default size")-                $ paraSynopsis <<<- ParaSynopsis-                    (__ "Default size of the main ide window specified as pair (int,int)")-                    $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)-            (PP.text.show)-            (pairParser intParser)-            defaultSize (\(c,d) a -> a{defaultSize = (c,d)})-            (pairEditor (intEditor (0.0, 3000.0, 25.0),-                            paraName <<<- ParaName "X" $ emptyParams)-                        (intEditor (0.0, 3000.0, 25.0),-                            paraName <<<- ParaName "Y" $ emptyParams))-            (\a -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Show hidden files in file tree") $ emptyParams)-            (PP.text . show)-            boolParser-            showHiddenFiles-            (\b a -> a {showHiddenFiles = b})-            boolEditor-            (const refreshFiles)-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Use ctrl Tab for Notebook flipper") $ emptyParams)-            (PP.text . show)-            boolParser-            useCtrlTabFlipping-            (\b a -> a{useCtrlTabFlipping = b})-            boolEditor-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Complete only on Hotkey") $ emptyParams)-            (PP.text . show)-            boolParser-            completeRestricted-            (\b a -> a{completeRestricted = b})-            boolEditor-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Name of the keymap")-                $ paraSynopsis <<<- ParaSynopsis-                    (__ "The name of a keymap file in a config dir")-                    $ paraDirection <<<- ParaDirection Horizontal $ emptyParams)-            (PP.text . T.unpack)-            identifier-            keymapName-            (\b a -> a{keymapName = b})-            (textEditor (not . T.null) True)-            (\ a -> return ())-    ]),-    (__ "Initial Pane positions", VFDPP emptyParams [-        mkFieldPP-            (paraName <<<- ParaName-                (__ "Categories for panes")-                $ paraShadow <<<- ParaShadow ShadowIn-                     $ paraDirection <<<- ParaDirection Vertical-                        $ paraMinSize <<<- ParaMinSize (-1,130)-                            $ emptyParams)-            (PP.text . show)-            readParser-            categoryForPane-            (\b a -> a{categoryForPane = b})-            (multisetEditor-                (ColumnDescr True [(__ "Pane Id", \ (n, _) -> [cellText := n])-                                   ,(__ "Pane Category", \ (_, v) -> [cellText := v])])-                (pairEditor-                    (textEditor (not . T.null) True, emptyParams)-                    (textEditor (not . T.null) True, emptyParams), emptyParams)-                (Just (sortBy (\(a,_) (a2,_) -> compare a a2)))-                (Just (\(a,_) (a2,_) -> a == a2)))-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName-                (__ "Pane path for category")-                $ paraShadow <<<- ParaShadow ShadowIn-                     $ paraDirection <<<- ParaDirection Vertical-                        $ paraMinSize <<<- ParaMinSize (-1,130)-                            $ emptyParams)-            (PP.text . show)-            readParser-            pathForCategory-            (\b a -> a{pathForCategory = b})-            (multisetEditor-                (ColumnDescr True [(__ "Pane category", \ (n, _) -> [cellText := n])-                                   ,(__ "Pane path", \ (_, v) -> [cellText := T.pack $ show v])])-                (pairEditor (textEditor (not . T.null) True, emptyParams)-                    (genericEditor, emptyParams),-                  emptyParams)-                (Just (sortBy (\(a,_) (a2,_) -> compare a a2)))-                (Just (\(a,_) (a2,_) -> a == a2)))-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Default pane path") $ emptyParams)-            (PP.text . show)-            readParser-            defaultPath-            (\b a -> a{defaultPath = b})-            genericEditor-            (\i -> return ())-    ]),-    (__ "Metadata", VFDPP emptyParams [-        mkFieldPP-            (paraName <<<- ParaName-                (__ "Paths under which haskell sources for packages may be found")-                        $ paraMinSize <<<- ParaMinSize (-1,100)-                            $ emptyParams)-            (PP.text . show)-            readParser-            sourceDirectories-            (\b a -> a{sourceDirectories = b})-            (filesEditor Nothing FileChooserActionSelectFolder (__ "Select folder"))-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Unpack source for cabal packages to") $ emptyParams)-            (PP.text . show)-            readParser-            unpackDirectory-            (\b a -> a{unpackDirectory = b})-            (maybeEditor (stringEditor (const True) True,emptyParams) True "")-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "URL from which to download prebuilt metadata") $ emptyParams)-            (PP.text . show)-            stringParser-            retrieveURL-            (\b a -> a{retrieveURL = b})-            (textEditor (const True) True)-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Strategy for downloading prebuilt metadata") $ emptyParams)-            (PP.text . show)-            readParser-            retrieveStrategy-            (\b a -> a{retrieveStrategy = b})-            (enumEditor [__ "Try to download and then build locally if that fails",-                         __ "Try to build locally and then download if that fails",-                         __ "Never download (just try to build locally)"])-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Update metadata at startup") $ emptyParams)-            (PP.text . show)-            boolParser-            collectAtStart-            (\b a -> a{collectAtStart = b})-            boolEditor-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Port number for leksah to comunicate with leksah-server") $ emptyParams)-            (PP.text . show)-            intParser-            serverPort-            (\b a -> a{serverPort = b})-            (intEditor (1.0, 65535.0, 1.0))-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "IP address for leksah to comunicate with leksah-server") $ emptyParams)-            (PP.text . show)-            stringParser-            serverIP-            (\b a -> a{serverIP = b})-            (textEditor (not . T.null) True)-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "Stop the leksah-server process when leksah disconnects") $ emptyParams)-            (PP.text . show)-            boolParser-            endWithLastConn-            (\b a -> a{endWithLastConn = b})-            boolEditor-            (\i -> return ())-    ]),-    (__ "Blacklist", VFDPP emptyParams [-        mkFieldPP-            (paraName <<<- ParaName-                (__ "Packages which are excluded from the modules pane")-                        $ paraMinSize <<<- ParaMinSize (-1,200)-                            $ emptyParams)-            (PP.text . show . map display)-            (fmap (mapMaybe simpleParse) readParser)-            packageBlacklist-            (\b a -> a{packageBlacklist = b})-            (dependenciesEditor packages)-            (\i -> return ())-    ]),-    (__ "Build", VFDPP emptyParams [-         mkFieldPP-            (paraName <<<- ParaName (__ "Automatically save all files before building") $ emptyParams)-            (PP.text . show)-            boolParser-            saveAllBeforeBuild-            (\b a -> a{saveAllBeforeBuild = b})-            boolEditor-            (\i -> return ())-         , mkFieldPP-            (paraName <<<- ParaName (__ "Select first warning if built without errors") $ emptyParams)-            (PP.text . show)-            boolParser-            jumpToWarnings-            (\b a -> a{jumpToWarnings = b})-            boolEditor-            (\i -> return ())-         , mkFieldPP-            (paraName <<<- ParaName (__ "Background build") $ emptyParams)-            (PP.text . show)-            boolParser-            backgroundBuild-            (\b a -> a{backgroundBuild = b})-            boolEditor-            (\i -> return ())-         , mkFieldPP-            (paraName <<<- ParaName (__ "Run unit tests when building") $ emptyParams)-            (PP.text . show)-            boolParser-            runUnitTests-            (\b a -> a{runUnitTests = b})-            boolEditor-            (\i -> return ())-         , mkFieldPP-            (paraName <<<- ParaName (__ "Make mode") $ emptyParams)-            (PP.text . show)-            boolParser-            makeMode-            (\b a -> a{makeMode = b})-            (boolEditor2 (__ "Single mode"))-            (\i -> return ())--         , mkFieldPP-            (paraName <<<- ParaName (__ "Single build without linking") $ emptyParams)-            (PP.text . show)-            boolParser-            singleBuildWithoutLinking-            (\b a -> a{singleBuildWithoutLinking = b})-            boolEditor-            (\i -> return ())-         , mkFieldPP-            (paraName <<<- ParaName (__ "Don't install last package") $ emptyParams)-            (PP.text . show)-            boolParser-            dontInstallLast-            (\b a -> a{dontInstallLast = b})-            boolEditor-            (\i -> return ())--        , mkFieldPP-            (paraName <<<- ParaName (__ "Use vado to run commands on the remote machine") $ emptyParams)-            (PP.text . show)-            boolParser-            useVado-            (\b a -> a{useVado = b})-            boolEditor-            (\i -> return ())--        , mkFieldPP-            (paraName <<<- ParaName (__ "Use cabal-dev") $ emptyParams)-            (PP.text . show)-            boolParser-            useCabalDev-            (\b a -> a{useCabalDev = b})-            boolEditor-            (\i -> return ())-    ]),-    (__ "Debug", VFDPP emptyParams [-           mkFieldPP-            (paraName <<<- ParaName (__ "Enable usage of Show instances in :print") $ emptyParams)-            (PP.text . show)-            boolParser-            printEvldWithShow-            (\b a -> a{printEvldWithShow = b})-            boolEditor-            debugSetPrintEvldWithShow-         , mkFieldPP-            (paraName <<<- ParaName (__ "Break on any exception thrown") $ emptyParams)-            (PP.text . show)-            boolParser-            breakOnException-            (\b a -> a{breakOnException = b})-            boolEditor-            debugSetBreakOnException-         , mkFieldPP-            (paraName <<<- ParaName (__ "Break on uncaught exceptions and errors") $ emptyParams)-            (PP.text . show)-            boolParser-            breakOnError-            (\b a -> a{breakOnError = b})-            boolEditor-            debugSetBreakOnError-         , mkFieldPP-            (paraName <<<- ParaName (__ "Turn on printing of binding results in GHCi") $ emptyParams)-            (PP.text . show)-            boolParser-            printBindResult-            (\b a -> a{printBindResult = b})-            boolEditor-            debugSetPrintBindResult-    ]),-    (__ "Help", VFDPP emptyParams [-        mkFieldPP-            (paraName <<<- ParaName (__ "Browser") $ emptyParams)-            (PP.text . show)-            stringParser-            browser-            (\b a -> a{browser = b})-            (textEditor (not . T.null) True)-            (\i -> return ())-    ,   mkFieldPP-            (paraName <<<- ParaName (__ "URL for searching documentation") $-                paraSynopsis <<<- ParaSynopsis-                    ("e.g https://www.haskell.org/hoogle/?q= or " <>-                        "Hayoo: http://hayoo.fh-wedel.de/?query=")-                        $ emptyParams)-            (PP.text . show)-            stringParser-            docuSearchURL-            (\b a -> a{docuSearchURL = b})-            (textEditor (not . T.null) True)-            (\i -> return ())-    ])]---- | Editor for enabling a different syntax stylesheet-styleEditor :: Editor (Bool, Text)-styleEditor p n = do-    styleManager <- sourceStyleSchemeManagerNew-    dataDir <- getDataDir-    sourceStyleSchemeManagerAppendSearchPath styleManager $ dataDir </> "data/styles"-    ids          <- sourceStyleSchemeManagerGetSchemeIds styleManager-    let notDarkIds = filter (not . T.isSuffixOf "-dark") ids-    disableEditor (comboSelectionEditor notDarkIds id, p) True (__ "Select a special style?") p n----- | The default preferences-defaultPrefs = Prefs {-        prefsFormat         =   prefsVersion-    ,   prefsSaveTime       =   ""-    ,   showLineNumbers     =   True-    ,   rightMargin         =   (True,100)-    ,   tabWidth            =   4-    ,   wrapLines           =   False-    ,   sourceCandy         =   (False,"candy")-    ,   keymapName          =   "keymap"-    ,   forceLineEnds       =   True-    ,   removeTBlanks       =   True-    ,   textviewFont        =   Nothing-    ,   sourceStyle         =   (True,"leksah")-    ,   foundBackgroundLight      = Color 65535 65535 32768-    ,   matchBackgroundLight      = Color 42064 55923 28520-    ,   contextBackgroundLight    = Color 65535 46529 46529-    ,   breakpointBackgroundLight = Color 64879 51921 28114-    ,   lintBackgroundLight       = Color 60000 65535 60000-    ,   foundBackgroundDark       = Color 30364 29149     0-    ,   matchBackgroundDark       = Color 18021 29927  6384-    ,   contextBackgroundDark     = Color 20000 16000 16000-    ,   breakpointBackgroundDark  = Color 15000  5000  5000-    ,   lintBackgroundDark        = Color     0 15000     0-    ,   textEditorType      =   "GtkSourceView"-    ,   autoLoad            =   False-    ,   logviewFont         =   Nothing-    ,   defaultSize         =   (1024,800)-    ,   browser             =   "firefox"-    ,   sourceDirectories   =   []-    ,   packageBlacklist    =   []-    ,   pathForCategory     =   [   ("EditorCategory",[SplitP LeftP])-                                ,   ("LogCategory",[SplitP RightP, SplitP BottomP])-                                ,   ("ToolCategory",[SplitP RightP, SplitP TopP])-                                ]-    ,   defaultPath         =   [SplitP LeftP]-    ,   categoryForPane     =   [   ("*ClassHierarchy","ToolCategory")-                                ,   ("*Breakpoints","LogCategory")-                                ,   ("*Browser","ToolCategory")-                                ,   ("*Debug","ToolCategory")-                                ,   ("*Errors","ToolCategory")-                                ,   ("*Files","ToolCategory")-                                ,   ("*Flags","ToolCategory")-                                ,   ("*Grep","ToolCategory")-                                ,   ("*HLint","ToolCategory")-                                ,   ("*Doc","ToolCategory")-                                ,   ("*Info","LogCategory")-                                ,   ("*Log","LogCategory")-                                ,   ("*Inspect","LogCategory")-                                ,   ("*Modules","ToolCategory")-                                ,   ("*Out","ToolCategory")-                                ,   ("*Package","EditorCategory")-                                ,   ("*Prefs","EditorCategory")-                                ,   ("*Search","ToolCategory")-                                ,   ("*Trace","LogCategory")-                                ,   ("*Variables","LogCategory")-                                ,   ("*Workspace","LogCategory")]-    ,   collectAtStart      =   True-    ,   unpackDirectory     =   Just ("~" </> configDirName </> "packageSources")-    ,   retrieveURL         =   "http://www.leksah.org"-    ,   retrieveStrategy    =   SP.RetrieveThenBuild-    ,   useCtrlTabFlipping  =   True-    ,   docuSearchURL       =   "https://www.haskell.org/hoogle/?q="-    ,   completeRestricted  =   False-    ,   saveAllBeforeBuild  =   True-    ,   jumpToWarnings      =   True-    ,   useVado             =   False-    ,   useCabalDev         =   False-    ,   backgroundBuild     =   True-    ,   runUnitTests        =   False-    ,   makeMode            =   True-    ,   singleBuildWithoutLinking  = False-    ,   dontInstallLast     =   False-    ,   printEvldWithShow   =   True-    ,   breakOnException    =   True-    ,   breakOnError        =   True-    ,   printBindResult     =   False-    ,   serverPort          =   11111-    ,   serverIP            =   "127.0.0.1"-    ,   endWithLastConn     =   True-    ,   showHiddenFiles     =   False-    }---- --------------------------------------------------------------- * Parsing--- ---------------------------------------------------------------- | Read the preference file-readPrefs :: FilePath -> IO Prefs-readPrefs fn = catch (do-    configDir <- getConfigDir-    readFields fn (flattenFieldDescriptionPPToS (prefsDescription configDir [])) defaultPrefs)-        (\ (e :: SomeException) -> do-            sysMessage Normal (T.pack $ show e)-            return defaultPrefs)--- --------------------------------------------------------------- * Printing--- ---------------------------------------------------------------- | Write the preference file-writePrefs :: FilePath -> Prefs -> IO ()-writePrefs fpath prefs = do-    timeNow         <- liftIO getClockTime-    configDir <- getConfigDir-    let newPrefs    =   prefs {prefsSaveTime = T.pack $ show timeNow, prefsFormat = prefsVersion}-    writeFields fpath newPrefs (flattenFieldDescriptionPPToS (prefsDescription configDir []))--

@@ -6,6 +6,7 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fwarn-unused-imports #-} ----------------------------------------------------------------------------- --@@ -61,7 +62,7 @@ ,   editToCandy ,   editFromCandy ,   editKeystrokeCandy-,   editCandy+,   switchBuffersCandy  ,   updateStyle ,   updateStyle'@@ -79,6 +80,7 @@  ,   selectedText ,   selectedTextOrCurrentLine+,   selectedTextOrCurrentIdentifier ,   insertTextAfterSelection ,   selectedModuleName ,   selectedLocation@@ -108,6 +110,7 @@ import IDE.Core.State import IDE.Utils.GUIUtils import IDE.Utils.FileUtils+import IDE.Utils.DirectoryUtils import IDE.SourceCandy import IDE.SymbolNavigation import IDE.Completion as Completion (complete,cancel)@@ -137,12 +140,12 @@ import IDE.BufferMode import Control.Monad.Trans.Reader (ask) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad (filterM, void, unless, when, liftM)+import Control.Monad (filterM, void, unless, when, liftM, forM_) import Control.Exception as E (catch, SomeException)  import qualified IDE.Command.Print as Print import Control.Monad.Trans.Class (MonadTrans(..))-import System.Log.Logger (debugM)+import System.Log.Logger (errorM, warningM, debugM) import Data.Text (Text) import qualified Data.Text as T        (length, findIndex, replicate, lines,@@ -158,6 +161,7 @@ -- import Data.Time.Clock.POSIX (getPOSIXTime) import qualified Data.Sequence as Seq import Data.Sequence (ViewR(..), (|>))+import Data.Time.Clock (addUTCTime, diffUTCTime)  --time :: MonadIO m => String -> m a -> m a --time name action = do@@ -193,7 +197,7 @@                     iter    <- getIterAtOffset gtkBuf i                     placeCursor gtkBuf iter                     mark    <- getInsertMark gtkBuf-                    scrollToMark v mark 0.0 (Just (0.3,0.3))+                    scrollToMark v mark 0.0 (Just (1.0,0.3))                     liftIO $ debugM "leksah" "SourceBuffer recoverState done"                 return mbbuf             Nothing -> return Nothing@@ -211,7 +215,7 @@                     iter     <-  getIterAtOffset gtkBuf i                     placeCursor gtkBuf iter                     mark     <-  getInsertMark gtkBuf-                    scrollToMark v mark 0.0 (Just (0.3,0.3))+                    scrollToMark v mark 0.0 (Just (1.0,0.3))                     liftIO $ debugM "leksah" "SourceBuffer recoverState done"                 return (Just buf)             Nothing -> return Nothing@@ -328,7 +332,7 @@                     liftIO $ debugM "lekash" "goToSourceDefinition triggered selectRange"                     selectRange ebuf iter iter2                     liftIO $ debugM "lekash" "goToSourceDefinition triggered scrollToIter"-                    scrollToIter sv iter 0.0 (Just (0.3,0.3))+                    scrollToIter sv iter 0.0 (Just (1.0,0.3))                 return ()         Nothing -> return ()     return mbBuf@@ -491,7 +495,7 @@             lineStart <- backwardToLineStartC iter             createMark sv (logRefType logRef) lineStart $ refDescription logRef             applyTagByName ebuf tagName iter iter2-        when scrollTo . postAsyncIDE $ do+        when scrollTo $ do             liftIO $ debugM "lekash" "markRefInSourceBuf triggered placeCursor"             placeCursor ebuf iter             mark <- getInsertMark ebuf@@ -520,7 +524,7 @@     where buildPane contents mModTime = do             nb      <-  getNotebook panePath             prefs   <-  readIDE prefs-            bs      <-  getCandyState+            let bs = candyState prefs             ct      <-  readIDE candy             (ind,rbn) <- figureOutPaneName bn 0             buildThisPane panePath nb (builder' bs mbfn ind bn rbn ct prefs contents mModTime)@@ -627,6 +631,7 @@                 case mbfn of                     Just fn -> Just (SrcSpan fn lStart cStart lEnd cEnd)                     Nothing -> Nothing+             let tagName = "match"             hasSelection <- hasSelection buffer             m <- liftIO $ readIORef hasMatch@@ -737,11 +742,13 @@     mbPrevCharCat <- getCharacterCategory <$> (backwardCharC sel >>= getChar)     return $ isNothing currentChar || currentChar == Just '\n' || mbStartCharCat /= mbPrevCharCat && (mbStartCharCat == SyntaxCharacter || mbStartCharCat == IdentifierCharacter) +-- | Get an iterator pair (start,end) delimiting the identifier currently under the cursor getIdentifierUnderCursor :: forall editor. TextEditor editor => EditorBuffer editor -> IDEM (EditorIter editor, EditorIter editor) getIdentifierUnderCursor buffer = do     (startSel, endSel) <- getSelectionBounds buffer     getIdentifierUnderCursorFromIter (startSel, endSel) +-- | Get an iterator pair (start,end) delimiting the identifier currently contained inside the provided iterator pair getIdentifierUnderCursorFromIter :: TextEditor editor => (EditorIter editor, EditorIter editor) -> IDEM (EditorIter editor, EditorIter editor) getIdentifierUnderCursorFromIter (startSel, endSel) = do     let isIdent a = isAlphaNum a || a == '\'' || a == '_'@@ -987,14 +994,58 @@             let text' = if removeTBlanks                             then T.unlines $ map (T.dropWhileEnd $ \c -> c == ' ') $ T.lines text                             else text+            alreadyExists <- liftIO $ doesFileExist fn+            mbModTimeBefore <- if alreadyExists+                then liftIO $ Just <$> getModificationTime fn+                else return Nothing             succ <- liftIO $ E.catch (do T.writeFile fn text'; return True)                 (\(e :: SomeException) -> do                     sysMessage Normal . T.pack $ show e                     return False)-            setModified buf (not succ)-            markLabelAsChanged nb ideBuf-            triggerEventIDE_ $ SavedFile fn +            -- Truely horrible hack to work around HFS+ only having 1sec resolution+            -- and ghc ignoring files unless the modifiction time has moved forward.+            -- The limitation means we can do at most 1 reload a second, but+            -- this hack allows us to take an advance of up to 30 reloads (by+            -- moving the modidification time up to 30s into the future).+            modTimeChanged <- liftIO $ case mbModTimeBefore of+                Nothing -> return True+                Just modTime -> do+                    newModTime <- getModificationTime fn+                    let diff = diffUTCTime modTime newModTime+                    if+                        | (newModTime > modTime) -> return True -- All good mode time has moved on+                        | diff < 30 -> do+                             setModificationTimeOnOSX fn (addUTCTime 1 modTime)+                             updatedModTime <- getModificationTime fn+                             return (updatedModTime > modTime)+                        | diff < 32 -> do+                             -- Reached our limit of how far in the future we want to set the modifiction time.+                             -- Using 32 instead of 31 in case NTP or something is adjusting the clock back.+                             warningM "leksah" $ "Modification time for " <> fn+                                <> " was already " <> show (diffUTCTime modTime newModTime)+                                <> " in the future"+                             -- We still want to keep the modification time the same though.+                             -- If it went back the future date ghc has might cause it to+                             -- continue to ignore the file.+                             setModificationTimeOnOSX fn modTime+                             return False+                        | otherwise -> do+                             -- This should never happen unless something else is messing+                             -- with the modification time or the clock.+                             -- If it does happen we will leave the modifiction time alone.+                             errorM "leksah" $ "Modification time for " <> fn+                                <> " was already " <> show (diffUTCTime modTime newModTime)+                                <> " in the future"+                             return True++            -- Only consider the file saved if the modification time changed+            -- otherwise another save is really needed to trigger ghc.+            when modTimeChanged $ do+                setModified buf (not succ)+                markLabelAsChanged nb ideBuf+                triggerEventIDE_ $ SavedFile fn+ fileSave :: Bool -> IDEM Bool fileSave query = inActiveBufContext False $ fileSaveBuffer query @@ -1085,7 +1136,7 @@  fileCloseAllButPackage :: IDEAction fileCloseAllButPackage = do-    mbActivePath    <-  fmap ipdBuildDir <$> readIDE activePack+    mbActivePath    <-  fmap ipdPackageDir <$> readIDE activePack     bufs            <-  allBuffers     case mbActivePath of         Just p -> mapM_ (close' p) bufs@@ -1225,19 +1276,22 @@                 Nothing   -> return ()  editUndo :: IDEAction-editUndo = inActiveBufContext () $ \_ _ buf _ _ -> do+editUndo = inActiveBufContext () $ \_ view buf _ _ -> do     can <- canUndo buf-    when can $ undo buf+    when can $ do+        undo buf+        scrollToCursor view  editRedo :: IDEAction-editRedo = inActiveBufContext () $ \_ _ buf _ _ -> do+editRedo = inActiveBufContext () $ \_ view buf _ _ -> do     can <- canRedo buf     when can $ redo buf+    scrollToCursor view  editDelete :: IDEAction-editDelete = inActiveBufContext ()  $ \_ _ ebuf _ _ ->  do+editDelete = inActiveBufContext ()  $ \_ view ebuf _ _ ->  do     deleteSelection ebuf-    return ()+    scrollToCursor view  editSelectAll :: IDEAction editSelectAll = inActiveBufContext () $ \_ _ ebuf _ _ -> do@@ -1251,9 +1305,10 @@     cutClipboard ebuf clip True  editCopy :: IDEAction-editCopy = inActiveBufContext () $ \_ _ ebuf _ _ -> do+editCopy = inActiveBufContext () $ \_ view ebuf _ _ -> do     clip <- liftIO $ clipboardGet selectionClipboard     copyClipboard ebuf clip+    scrollToCursor view  editPaste :: IDEAction editPaste = inActiveBufContext () $ \_ _ ebuf _ _ -> do@@ -1344,6 +1399,7 @@         triggerEventIDE UpdateRecent         return () +-- | Get the currently selected text or Nothing is no text is selected selectedText :: IDEM (Maybe Text) selectedText = do     candy' <- readIDE candy@@ -1356,6 +1412,7 @@                 return $ Just text             else return Nothing +-- | Get the currently selected text, or, if none, the current line text selectedTextOrCurrentLine :: IDEM (Maybe Text) selectedTextOrCurrentLine = do     candy' <- readIDE candy@@ -1371,6 +1428,21 @@                 return (iStart, iEnd)         Just <$> getCandylessPart candy' ebuf i1 i2 +-- | Get the currently selected text, or, if none, tries to selected the current identifier (the one under the cursor)+selectedTextOrCurrentIdentifier :: IDEM (Maybe Text)+selectedTextOrCurrentIdentifier = do+    st <- selectedText+    case st of+        Just t -> return $ Just t+        Nothing -> do+            candy' <- readIDE candy+            inActiveBufContext Nothing $ \_ _ ebuf currentBuffer _ -> do+                        (l,r)   <- getIdentifierUnderCursor ebuf+                        t <- getCandylessPart candy' ebuf l r+                        return $ if T.null t+                                                then Nothing+                                                else Just t+ selectedLocation :: IDEM (Maybe (Int, Int)) selectedLocation = do     candy'      <- readIDE candy@@ -1433,15 +1505,17 @@  useCandyFor :: MonadIDE m => IDEBuffer -> m Bool useCandyFor aBuffer = do-    use <- liftIDE getCandyState-    return (use && isHaskellMode (mode aBuffer))+    prefs <- readIDE prefs+    return (candyState prefs && isHaskellMode (mode aBuffer)) -editCandy = do-    use <- liftIDE getCandyState+switchBuffersCandy :: IDEAction+switchBuffersCandy = do+    prefs <- readIDE prefs     buffers <- allBuffers-    if use-        then mapM_ (\b -> modeEditToCandy (mode b)-            (modeEditInCommentOrString (mode b))) buffers-        else mapM_ (modeEditFromCandy . mode) buffers+    forM_ buffers $ \b@IDEBuffer{sourceView=sv} -> do+        buf <- getBuffer sv+        if candyState prefs+            then modeTransformToCandy (mode b) (modeEditInCommentOrString (mode b)) buf+            else modeTransformFromCandy (mode b) buf  

@@ -120,7 +120,6 @@             liftIO $ reflectIDE (makeActive docs) ideR             return True -        webView `set` [webViewZoomLevel := 2.0]         cid2 <- webView `on` keyPressEvent $ do             key <- eventKeyName             mod <- eventModifier

@@ -148,7 +148,7 @@             liftIO $ reflectIDE (makeActive out) ideR             return True -        webView `set` [webViewZoomLevel := 2.0]+--        webView `set` [webViewZoomLevel := 2.0]         cid2 <- on webView keyPressEvent $ do             key <- eventKeyName             mod <- eventModifier

@@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- --@@ -15,247 +16,700 @@ -- Portability : -- -- | The pane of the IDE that shows the cabal packages in the workspace---   and their build targets+--   and their components, source dependencies and files -- -----------------------------------------------------------------------------  module IDE.Pane.Workspace (     WorkspaceState(..)-,   IDEWorkspace-,   updateWorkspace-,   getWorkspace-,   showWorkspace+,   WorkspacePane+,   getWorkspacePane+,   showWorkspacePane+,   refreshWorkspacePane+,   rebuildWorkspacePane ) where -import Graphics.UI.Gtk hiding (get)-import Graphics.UI.Gtk.Gdk.EventM+import Prelude hiding (catch)+import Graphics.UI.Gtk+       (treeSelectionSelectIter, treeStoreLookup,+        cellLayoutSetAttributeFunc, treeViewRowActivated, treeStoreClear,+        treeModelGetIterFirst, treeViewLevelIndentation,+        treeViewShowExpanders, treeViewCollapseRow, treeViewExpandRow,+        treeSelectionUnselectAll, cellLayoutPackEnd, cellTextMarkup,+        cellPixbufStockId, scrolledWindowSetShadowType,+        treeSelectionSelectionChanged, treeStoreRemove, treeModelIterNext,+        treeModelGetRow, treeStoreInsert, treeModelIterNthChild,+        treeModelGetPath, TreeIter, treeModelGetIter, TreePath,+        treeSelectionGetSelectedRows, rowActivated, treeStoreGetValue,+        rowExpanded, on, after, focusInEvent, scrolledWindowSetPolicy,+        containerAdd, scrolledWindowNew, treeSelectionSetMode,+        treeViewGetSelection, treeViewSetHeadersVisible, cellText,+        cellLayoutSetAttributes, cellLayoutPackStart, treeViewAppendColumn,+        treeViewColumnSetReorderable, treeViewColumnSetResizable,+        treeViewColumnSetSizing, treeViewColumnSetTitle, treeViewColumnNew,+        cellRendererPixbufNew, cellRendererTextNew, treeViewSetModel,+        treeViewNew, treeStoreNew, castToWidget, TreeStore, TreeView,+        ScrolledWindow, treeViewRowExpanded, treeStoreGetTree, Menu(..),+        MenuItem(..), treeStoreSetValue) import Data.Maybe-import Data.Typeable+       (fromJust, fromMaybe, maybeToList, listToMaybe, isJust)+import Control.Monad (forM, void, when)+import Data.Foldable (forM_)+import Data.Typeable (Typeable) import IDE.Core.State-import IDE.Workspaces-import qualified Data.Map as Map (empty)-import Data.List (sortBy)-import IDE.Pane.Files (refreshFiles)-import Control.Monad (when)+       (catchIDE, window, getIDE, MessageLevel(..), ipdPackageId,+        wsPackages, workspace, readIDE, IDEAction, ideMessage, reflectIDE,+        reifyIDE, IDEM, IDEPackage, ipdSandboxSources)+import IDE.Pane.SourceBuffer (fileNew, goToSourceDefinition')+import IDE.Sandbox+import Control.Applicative ((<$>))+import System.FilePath ((</>), takeFileName, dropFileName)+import Distribution.Package (PackageIdentifier(..))+import System.Directory+       (removeDirectoryRecursive, removeDirectory, createDirectory,+        doesFileExist, removeFile, doesDirectoryExist,+        getDirectoryContents, getPermissions, readable)+import IDE.Core.CTypes+       (Location(..), packageIdentifierToString)+import Graphics.UI.Frame.Panes+       (RecoverablePane(..), PanePath, RecoverablePane, Pane(..))+import Graphics.UI.Frame.ViewFrame (getMainWindow, getNotebook)+import Graphics.UI.Editor.Basics (Connection(..))+import Graphics.UI.Gtk.General.Enums+       (ShadowType(..), PolicyType(..), SelectionMode(..),+        TreeViewColumnSizing(..))+import System.Glib.Attributes (set, AttrOp(..)) import Control.Monad.IO.Class (MonadIO(..))-import IDE.Utils.GUIUtils (treeViewContextMenu, __)+import IDE.Utils.GUIUtils+       (showErrorDialog, showInputDialog, treeViewContextMenu', __,+        showDialogOptions, treeViewToggleRow)+import Control.Exception (SomeException(..), catch)+import Data.Text (Text)+import qualified Data.Text as T+       (isPrefixOf, words, isSuffixOf, unpack, pack)+import Data.Monoid ((<>))+import IDE.Core.Types+       (ipdLib, WorkspaceAction, Workspace(..), wsAllPackages, WorkspaceM,+        runPackage, runWorkspace, PackageAction, PackageM, IDEPackage(..),+        IDE(..), Prefs(..), MonadIDE(..), ipdPackageDir) import System.Glib.Properties (newAttrFromMaybeStringProperty)-import Data.Tree (Tree(..))+import System.FilePath+       (addTrailingPathSeparator, takeDirectory, takeExtension,+       makeRelative, splitDirectories)+import Control.Monad.Reader.Class (MonadReader(..))+import IDE.Workspaces+       (makePackage, workspaceAddPackage', workspaceRemovePackage,+        workspaceActivatePackage, workspaceTry, workspaceTryQuiet,+        packageTry)+import Data.List+       (isSuffixOf, find, stripPrefix, isPrefixOf, sortBy, sort)+import Data.Ord (comparing)+import Data.Char (toUpper, toLower) import System.Log.Logger (debugM)-import qualified Data.Function as F (on)-import System.FilePath (takeDirectory, takeBaseName, takeFileName)-import Data.Text (Text)-import qualified Data.Text as T (pack)+import Data.Tree (Forest, Tree(..))+import Graphics.UI.Gtk.MenuComboToolbar.MenuItem+       (menuItemActivate, menuItemNewWithLabel)+import IDE.Pane.Modules (addModule)+import Graphics.UI.Gtk.Windows.MessageDialog+       (ButtonsType(..), MessageType(..), messageDialogNew)+import Graphics.UI.Gtk.ModelView.CellRenderer+       (CellRendererMode(..), cellMode)+import IDE.Pane.PackageEditor (packageEditText)+import IDE.Utils.GtkBindings (treeViewSetActiveOnSingleClick)+import IDE.Package (packageTest, packageRun, packageClean)+import Control.Monad.Trans.Class (MonadTrans(..)) --- | 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 data for a single record in the Workspace Pane+data WorkspaceRecord =+    FileRecord FilePath+  | DirRecord FilePath+              Bool -- Whether it is a source directory+  | PackageRecord IDEPackage+  | AddSourcesRecord+  | AddSourceRecord IDEPackage+  | ComponentsRecord+  | ComponentRecord Text+  deriving (Eq) +instance Ord WorkspaceRecord where+    -- | The ordering used for displaying the records+    compare (DirRecord _ _) (FileRecord _) = LT+    compare (FileRecord _) (DirRecord _ _) = GT+    compare (FileRecord p1) (FileRecord p2) = comparing (map toLower) p1 p2+    compare (DirRecord p1 _) (DirRecord p2 _) = comparing (map toLower) p1 p2+    compare (PackageRecord p1) (PackageRecord p2) = comparing (map toLower . ipdPackageDir) p1 p2+    compare (AddSourceRecord p1) (AddSourceRecord p2) = comparing (map toLower . ipdPackageDir) p1 p2+    compare (ComponentRecord t1) (ComponentRecord t2) = comparing (map toLower . T.unpack) t1 t2+    compare _ _ = LT --- | The representation of the workspace pane-data IDEWorkspace   =   IDEWorkspace {-    scrolledView        ::   ScrolledWindow-,   treeViewC           ::   TreeView-,   workspaceStore      ::   TreeStore (Bool, WorkspaceRecord)-,   topBox              ::   VBox-} deriving Typeable -instance Pane IDEWorkspace IDEM+-- | The markup to show for a record+toMarkup :: WorkspaceRecord+         -> IDEPackage+         -> IDEM Text+toMarkup record pkg = do+    mbActivePackage   <- readIDE activePack+    mbActiveComponent <- readIDE activeExe++    return . size $ case record of+     (PackageRecord p) ->+        let active = Just pkg == mbActivePackage+            pkgText = (if active then bold else id)+                          (packageIdentifierToString (ipdPackageId p))+            mbLib   = ipdLib p+            componentText = if active+                                then maybe (if isJust mbLib then "(library)" else "")+                                           (\comp -> "(" <> comp <> ")") mbActiveComponent+                                else ""+            pkgDir = gray . T.pack $ ipdPackageDir p+        in (pkgText <> " " <> componentText <> " " <> pkgDir)+     (FileRecord f) -> T.pack $ takeFileName f+     (DirRecord f _) | ipdPackageDir pkg == f -> "Files"+                     | otherwise -> T.pack $ last (splitDirectories f)+     AddSourcesRecord -> "Source Dependencies"+     (AddSourceRecord p) -> do+        let pkgText = packageIdentifierToString (ipdPackageId p)+            dirText = gray (T.pack (ipdPackageDir p))+        pkgText <> " " <> dirText+     ComponentsRecord -> "Components"+     (ComponentRecord comp) -> do+        let active = Just pkg == mbActivePackage &&+                         (mbActiveComponent == Nothing && comp == "library"+                             ||+                          Just comp == mbActiveComponent)+        (if active then bold else id) comp     where-    primPaneName _  =   __ "Workspace"-    getAddedIndex _ =   0-    getTopWidget    =   castToWidget . topBox-    paneId b        =   "*Workspace"+        bold str = "<b>" <> str <> "</b>"+        italic str = "<i>" <> str <> "</i>"+        gray str = "<span foreground=\"#999999\">" <> str <> "</span>"+        size str = "<span font=\"9\">" <> str <> "</span>" ++-- | The icon to show for a record+toIcon :: WorkspaceRecord -> Maybe Text+toIcon record = case record of+    FileRecord path+        | takeExtension path == ".hs"    -> Just "ide_source"+        | takeExtension path == ".cabal" -> Just "ide_cabal_file"+    DirRecord p isSrc+        | isSrc     -> Just "ide_source_folder"+        | otherwise -> Just "ide_folder"+    PackageRecord _ -> Just "ide_package"+    ComponentsRecord -> Just "ide_component"+    AddSourcesRecord -> Just "ide_source_dependency"+    AddSourceRecord _ -> Just "ide_package"+    _ -> Nothing+++-- | Gets the package to which a node in the tree belongs+iterToPackage :: TreeStore WorkspaceRecord -> TreeIter -> IDEM (Maybe IDEPackage)+iterToPackage store iter = do+    path <- liftIO $ treeModelGetPath store iter+    treePathToPackage store path++-- | Gets the package to which a node in the tree belongs+treePathToPackage :: TreeStore WorkspaceRecord -> TreePath -> IDEM (Maybe IDEPackage)+treePathToPackage store (n:_) = do+    record <- liftIO $ treeStoreGetValue store [n]+    case record of+        (PackageRecord pkg) -> return (Just pkg)+        _                     -> do+            liftIO $ debugM "leksah" "treePathToPackage: Unexpected entry at root forest"+            return Nothing+treePathToPackage _ _ = do+    liftIO $ debugM "leksah" "treePathToPackage is called with empty path"+    return Nothing+++-- | Determines whether the 'WorkspaceRecord' can expand, i.e. whether+-- it should get an expander.+canExpand :: WorkspaceRecord -> IDEPackage -> IDEM Bool+canExpand record pkg = case record of+    (PackageRecord _) -> return True+    (DirRecord fp _)     -> do+        mbWs <- readIDE workspace+        case mbWs of+            Just ws -> not . null <$> (flip runWorkspace ws . flip runPackage pkg $ dirRecords fp)+            Nothing -> return False+    ComponentsRecord    -> return . not . null $ components+    AddSourcesRecord    -> return . not . null $ ipdSandboxSources pkg+    (AddSourceRecord _) -> return True+    _                   -> return False++    where components = maybeToList (ipdLib pkg) ++ ipdExes pkg ++ ipdTests pkg ++ ipdBenchmarks pkg++-- * The Workspace pane++-- | The representation of the Workspace pane+data WorkspacePane        =   WorkspacePane {+    scrolledView    ::   ScrolledWindow+,   treeView        ::   TreeView+,   recordStore     ::   TreeStore WorkspaceRecord+} deriving Typeable++ -- | The additional state used when recovering the pane---   (none, the packages and their targets come from the IDE state)-data WorkspaceState           =   WorkspaceState+--   (none)+data WorkspaceState = WorkspaceState     deriving(Eq,Ord,Read,Show,Typeable) -instance RecoverablePane IDEWorkspace WorkspaceState IDEM where+instance Pane WorkspacePane IDEM where+    primPaneName _  =   __ "Workspace"+    getAddedIndex _ =   0+    getTopWidget    =   castToWidget . scrolledView+    paneId b        =   "*Workspace"++instance RecoverablePane WorkspacePane WorkspaceState IDEM where     saveState p     =   return (Just WorkspaceState)     recoverState pp WorkspaceState =   do         nb      <-  getNotebook pp         buildPane pp nb builder-    buildPane pp nb builder  =   do-        res <- buildThisPane pp nb builder-        when (isJust res) $ updateWorkspace True False-        return res-    builder pp nb windows = reifyIDE $ \ideR -> do-        treeStore   <-  treeStoreNew []+    builder pp nb windows = reifyIDE $ \ ideR -> do+        recordStore   <-  treeStoreNew []         treeView    <-  treeViewNew-        treeViewSetModel treeView treeStore+        treeViewSetModel treeView recordStore -        renderer0    <- cellRendererPixbufNew-        set renderer0 [ newAttrFromMaybeStringProperty "stock-id"  := (Nothing :: Maybe Text) ] -        renderer1   <- cellRendererTextNew-        col1        <- treeViewColumnNew-        treeViewColumnSetTitle col1 (__ "Package")++        col1         <- treeViewColumnNew         treeViewColumnSetSizing col1 TreeViewColumnAutosize         treeViewColumnSetResizable col1 True         treeViewColumnSetReorderable col1 True         treeViewAppendColumn treeView col1-        cellLayoutPackStart col1 renderer0 False-        cellLayoutPackStart col1 renderer1 True-        cellLayoutSetAttributes col1 renderer0 treeStore-            $ \row -> [newAttrFromMaybeStringProperty "stock-id" :=-                        if fst row-                            then Just stockYes-                            else Nothing]-        cellLayoutSetAttributes col1 renderer1 treeStore-            $ \row -> [ cellText := name row ] -        renderer2   <- cellRendererTextNew-        col2        <- treeViewColumnNew-        treeViewColumnSetTitle col2 (__ "File path")-        treeViewColumnSetSizing col2 TreeViewColumnAutosize-        treeViewColumnSetResizable col2 True-        treeViewColumnSetReorderable col2 True-        treeViewAppendColumn treeView col2-        cellLayoutPackStart col2 renderer2 True-        cellLayoutSetAttributes col2 renderer2 treeStore-            $ \row -> [ cellText := T.pack $ file row ] -        treeViewSetHeadersVisible treeView True+        prefs <- reflectIDE (readIDE prefs) ideR+        when (showWorkspaceIcons prefs) $ do+            renderer2    <- cellRendererPixbufNew+            cellLayoutPackStart col1 renderer2 False+            set renderer2 [ newAttrFromMaybeStringProperty "stock-id"  := (Nothing :: Maybe Text) ]+            cellLayoutSetAttributes col1 renderer2 recordStore+                $ \record -> [ newAttrFromMaybeStringProperty "stock-id" := toIcon record]++        renderer1    <- cellRendererTextNew+        cellLayoutPackStart col1 renderer1 True+        cellLayoutSetAttributeFunc col1 renderer1 recordStore $ \iter -> do+            record <- treeModelGetRow recordStore iter+            mbPkg  <- flip reflectIDE ideR $ iterToPackage recordStore iter+            forM_ mbPkg $ \pkg -> do+                -- The cellrenderer is stateful, so it knows which cell this markup will be for (the cell at iter)+                markup <- flip reflectIDE ideR $ toMarkup record pkg+                forM_ mbPkg $ \pkg -> set renderer1 [ cellTextMarkup := Just markup]++        -- treeViewSetActiveOnSingleClick treeView True+        treeViewSetHeadersVisible treeView False         sel <- treeViewGetSelection treeView-        treeSelectionSetMode sel SelectionSingle+        -- treeSelectionSetMode sel SelectionSingle -        sw <- scrolledWindowNew Nothing Nothing-        scrolledWindowSetShadowType sw ShadowIn-        containerAdd sw treeView-        scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic-        box             <-  vBoxNew False 2-        boxPackEnd box sw PackGrow 0-        let workspacePane = IDEWorkspace sw treeView treeStore box-        widgetShowAll box-        cid1 <- treeView `after` focusInEvent $ do-            liftIO $ reflectIDE (makeActive workspacePane) ideR+        scrolledView <- scrolledWindowNew Nothing Nothing+        scrolledWindowSetShadowType scrolledView ShadowIn+        containerAdd scrolledView treeView+        scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic++        let wsPane = WorkspacePane {..}++        cid1 <- after treeView focusInEvent $ do+            liftIO $ reflectIDE (makeActive wsPane) ideR             return True-        (cid2, cid3) <- treeViewContextMenu treeView $ workspaceContextMenu ideR workspacePane-        cid4 <- treeView `on` rowActivated $ workspaceSelect ideR workspacePane-        return (Just workspacePane, map ConnectC [cid1, cid2, cid3, cid4])-      where-        name (_, (_, Just exe)) = exe-        name (_, (pack, Nothing)) = packageIdentifierToString $ ipdPackageId pack-        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)+        on treeView rowExpanded $ \iter path -> do+            record <- treeStoreGetValue recordStore path+            mbPkg  <- flip reflectIDE ideR $ iterToPackage recordStore iter+            forM_ mbPkg $ \pkg -> do+                flip reflectIDE ideR $ do+                    workspaceTryQuiet $ do+                        runPackage (refreshPackageTreeFrom recordStore treeView path) pkg --- | Show the workspace pane-showWorkspace :: IDEAction-showWorkspace = do-    l <- getWorkspace Nothing+        on treeView rowActivated $ \path col -> do+            record <- treeStoreGetValue recordStore path+            mbPkg    <- flip reflectIDE ideR $ treePathToPackage recordStore path+            forM_ mbPkg $ \pkg -> do+                expandable <- flip reflectIDE ideR $ canExpand record pkg+                case record of+                        FileRecord f  -> void . flip reflectIDE ideR $+                                             goToSourceDefinition' f (Location "" 1 0 1 0)+                        ComponentRecord name -> flip reflectIDE ideR $ workspaceTryQuiet $+                                                          workspaceActivatePackage pkg (Just name)+                        _ -> when expandable $ do+                                 void $ treeViewToggleRow treeView path++        (cid3, cid4) <- reflectIDE (treeViewContextMenu' treeView recordStore contextMenuItems) ideR+        reflectIDE (refresh wsPane) ideR++        return (Just wsPane, map ConnectC [cid1, cid3, cid4])++-- | Get the Workspace pane+getWorkspacePane :: IDEM WorkspacePane+getWorkspacePane = forceGetPane (Right "*Workspace")+++-- | Show the Workspace pane+showWorkspacePane :: IDEAction+showWorkspacePane = do+    l <- getWorkspacePane     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))-getSelectionTree treeView treeStore = do-    liftIO $ debugM "leksah" "getSelectionTree"-    treeSelection <- treeViewGetSelection treeView-    rows          <- treeSelectionGetSelectedRows treeSelection-    case rows of-        [path]  ->  do-            val     <-  treeStoreGetValue treeStore path-            case val of-                (active, (p, exe)) -> return $ Just (active, p, exe)-        _       ->  return Nothing +-- | Deletes the Workspace pane and rebuilds it (used when enabling/disabling+-- icons, since it requires extra/fewer cellrenderers)+rebuildWorkspacePane :: IDEAction+rebuildWorkspacePane = do+    mbWsPane <- getPane :: IDEM (Maybe WorkspacePane)+    forM_ mbWsPane closePane+    getOrBuildPane (Right "*Workspace") :: IDEM (Maybe WorkspacePane)+    return () --- | Construct the context menu for the pane-workspaceContextMenu :: IDERef-                     -> IDEWorkspace-                     -> Menu-                     -> IO ()-workspaceContextMenu ideR workspacePane theMenu = do-    item1 <- menuItemNewWithLabel (__ "Activate Package")-    item2 <- menuItemNewWithLabel (__ "Add Package")-    item3 <- menuItemNewWithLabel (__ "Remove Package")-    item1 `on` menuItemActivate $ do-        sel <- getSelectionTree (treeViewC workspacePane)-                                (workspaceStore workspacePane)-        case sel of-            Just (_, ideP,mbExe) -> reflectIDE (workspaceTry $ workspaceActivatePackage ideP mbExe) ideR-            otherwise     -> return ()-    item2 `on` menuItemActivate $ reflectIDE (workspaceTry workspaceAddPackage) ideR-    item3 `on` menuItemActivate $ do-        sel <- getSelectionTree (treeViewC workspacePane)-                                (workspaceStore workspacePane)-        case sel of-            Just (_,ideP,_) -> reflectIDE (workspaceTry $ workspaceRemovePackage ideP) ideR-            otherwise     -> return ()-    menuShellAppend theMenu item1-    menuShellAppend theMenu item2-    menuShellAppend theMenu item3 +-- | Searches the workspace packages if it is part of any of them+fileGetPackage :: FilePath -> WorkspaceM (Maybe IDEPackage)+fileGetPackage path = do+    packages <- wsAllPackages <$> ask+    let dirs     = [p | p <- packages, takeDirectory (ipdCabalFile p) `isPrefixOf` path]+    return (listToMaybe dirs) --- | Try to activate the package pointed to by the given 'TreePath'---   by modifying the given IDE state-workspaceSelect :: IDERef-                -> IDEWorkspace-                -> TreePath-                -> TreeViewColumn-                -> IO ()-workspaceSelect ideR workspacePane path _ = do-    liftIO $ debugM "leksah" "workspaceSelect"-    (_,(ideP,mbExe)) <- treeStoreGetValue (workspaceStore workspacePane) path-    reflectIDE (workspaceTry $ workspaceActivatePackage ideP mbExe) ideR  --- | 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-    when updateFileCache $ modifyIDE_ (\ide -> ide{bufferProjCache = Map.empty})-    mbMod <- getPane-    case mbWs of-        Nothing -> do-            case mbMod of-                Nothing -> return ()-                Just (p :: IDEWorkspace) -> do-                    liftIO $ treeStoreClear (workspaceStore p)-                    when showPane $ displayPane p False-            refreshFiles-        Just ws -> do-            case mbMod of-                Nothing -> return ()-                Just (p :: IDEWorkspace) -> do-                    liftIO $ do-                        treeStoreClear (workspaceStore p)-                        treeStoreInsertForest (workspaceStore p) [] 0 (buildForest ws)-                    when showPane $ displayPane p False-            refreshFiles+-- * Actions for refreshing the Workspace pane++++-- | Refreshes the Workspace pane, lists all packages and synchronizes the expanded+-- nodes with the file system and workspace+refreshWorkspacePane :: IDEAction+refreshWorkspacePane = do+    liftIO $ debugM "leksah" "refreshWorkspacePane"+    workspace <- getWorkspacePane+    refresh workspace++-- | Needed when building the pane, since getWorkspacePane does not+-- work before the building is finished+refresh :: WorkspacePane -> IDEAction+refresh pane = do+    let store = recordStore pane+    let view  = treeView pane++    workspaceTryQuiet $ do+        packages <- sort . wsPackages <$> ask+        setChildren Nothing store view [] (map PackageRecord packages)+++-- | Mutates the 'TreeStore' with the given TreePath as root to attach new+-- entries to. Walks the directory tree recursively when refreshing directories.+refreshPackageTreeFrom :: TreeStore WorkspaceRecord -> TreeView -> TreePath -> PackageAction+refreshPackageTreeFrom store view path = do+    record     <- liftIO $ treeStoreGetValue store path+    Just pkg   <- liftIDE $ treePathToPackage store path+    expandable <- liftIDE $ canExpand record pkg++    kids     <- children record+    lift $ setChildren (Just pkg) store view path kids++-- | Returns the children of the 'WorkspaceRecord'.+children :: WorkspaceRecord -> PackageM [WorkspaceRecord]+children record = case record of+    DirRecord dir _     -> dirRecords dir+    ComponentsRecord    -> componentsRecords+    AddSourcesRecord    -> addSourcesRecords+    AddSourceRecord pkg -> return []+    PackageRecord pkg   -> do+        p <- ask+        return [ ComponentsRecord+               , AddSourcesRecord+               , DirRecord (ipdPackageDir p) False]+    _                   -> return []+++-- | Gets the direct children, the add source dependencies+addSourcesRecords :: PackageM [WorkspaceRecord]+addSourcesRecords = do+    pkg <- ask+    return $ sort $ map AddSourceRecord (ipdSandboxSources pkg)+++-- | Returns the contents at the given 'FilePath' as 'WorkspaceRecord's.+-- Runs in the PackageM monad to determine if directories are+-- source directories (as specified in the cabal file)+dirRecords :: FilePath -> PackageM [WorkspaceRecord]+dirRecords dir = do+   prefs    <- readIDE prefs+   contents <- liftIO $ getDirectoryContents dir+                            `catch` \(e :: IOError) -> return []+   let filtered = if showHiddenFiles prefs+                      then filter (`notElem` [".", ".."]) contents+                      else filter ((/= '.') . head) contents+   records <- forM filtered $ \f -> do+                  let full = dir </> f+                  isDir <- liftIO $ doesDirectoryExist full+                  if isDir+                      then do+                          -- find out if it is a source directory of the project+                          pkgDir <- (addTrailingPathSeparator . takeDirectory . ipdCabalFile) <$> ask+                          case stripPrefix pkgDir full of+                              Just relativeToPackage -> do+                                  srcDirs <- ipdSrcDirs <$> ask+                                  return $ DirRecord full (relativeToPackage `elem` srcDirs)+                              Nothing -> do+                                  -- It's not a descendant of the package directory (e.g. in a source dependency)+                                  return $ DirRecord full False+                      else return $ FileRecord full+   return (sort records)+++-- | Get the components for a specific package+componentsRecords :: PackageM [WorkspaceRecord]+componentsRecords = do+    package         <- ask+    mbActivePackage <- readIDE activePack+    activeComponent <- readIDE activeExe++    return $ sort $ map (\comp -> ComponentRecord comp) (components package)+     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+        components package = maybeToList (ipdLib package)+                          ++ ipdExes package+                          ++ ipdTests package+                          ++ ipdBenchmarks package -        -- | 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)++-- | Recursively sets the children of the given 'TreePath' to the provided tree of 'WorkspaceRecord's. If a record+-- is already present, it is kept in the same (expanded) state.+-- If a the parent record is not expanded just makes sure at least one of+-- the chldren is added.+setChildren :: Maybe IDEPackage -> TreeStore WorkspaceRecord -> TreeView -> TreePath -> [WorkspaceRecord] -> WorkspaceAction+setChildren _ store _ [] [] = liftIO $ treeStoreClear store+setChildren mbPkg store view parentPath kids = do+    -- We only need to get all the children right when they are visible+    expanded <- if null parentPath+                    then return True+                    else liftIO $ treeViewRowExpanded view parentPath++    let kidsToAdd = (if expanded+                            then id+                            else take 1) kids++    forM_ (zip [0..] kidsToAdd) $ \(n, record) -> do+      liftIO $ do+        mbParentIter <- treeModelGetIter store parentPath+        mbChildIter <- treeModelIterNthChild store mbParentIter n+        let compare rec1 rec2 = case (rec1, rec2) of+                (PackageRecord p1, PackageRecord p2) -> ipdCabalFile p1 == ipdCabalFile p2+                _ -> rec1 == rec2+        findResult <- searchToRight compare record store mbChildIter+        case (mbChildIter, findResult) of+            (_, WhereExpected iter) -> do -- it's already there+                path <- treeModelGetPath store iter+                treeStoreSetValue store path record+            (Just iter, Found _) -> do -- it's already there at a later sibling+                path <- treeModelGetPath store iter+                removeUntil record store path+            _ -> do+                treeStoreInsert store parentPath n record++      let pkg = case record of+                        PackageRecord p -> p+                        _               -> fromJust mbPkg+      -- Only update the grand kids if they are visible+      when expanded $ do+          grandKids <- (`runPackage` pkg) $ children record+          setChildren (Just pkg) store view (parentPath ++ [n]) grandKids++    liftIO $ if null kids+        then treeStoreRemoveChildren store parentPath+        else when expanded . void $ removeRemaining store (parentPath++[length kids])+++-- * Context menu++contextMenuItems :: WorkspaceRecord -> TreePath -> TreeStore WorkspaceRecord -> IDEM [[(Text, IDEAction)]]+contextMenuItems record path store = do+    case record of+        (FileRecord fp) -> do+            let onDeleteFile = flip catchIDE (\(e :: SomeException) -> print e) $ reifyIDE $ \ideRef -> do+                    showDialogOptions+                        ("Are you sure you want to delete " <> T.pack (takeFileName fp) <> "?")+                        MessageQuestion+                        [ ("Delete File", removeFile fp >> reflectIDE refreshWorkspacePane ideRef)+                        , ("Cancel", return ())+                        ]+                        (Just 0)+            return [[("Open File...", void $ goToSourceDefinition' fp (Location "" 1 0 1 0))]+                   ,[("Delete File...", onDeleteFile)]]++        DirRecord fp _ -> do++            let onNewModule = flip catchIDE (\(e :: SomeException) -> print e) $ do+                    mbPkg <- treePathToPackage store path+                    forM_ mbPkg $ \pkg -> do+                        mbWs <- readIDE workspace+                        forM_ mbWs $ \ws -> do+                            mbModulePath <- flip runWorkspace ws $ runPackage (dirToModulePath fp) pkg+                            let modulePrefix = fromMaybe [] mbModulePath+                            packageTry $ addModule modulePrefix+                            refreshWorkspacePane++            let onNewTextFile = flip catchIDE (\(e :: SomeException) -> print e) $ reifyIDE $ \ideRef -> do+                    mbText <- showInputDialog "File name:" ""+                    case mbText of+                        Just t  -> do+                            let path = fp </> T.unpack t+                            exists <- doesFileExist path+                            if exists+                                then showErrorDialog "File already exists"+                                else do+                                    writeFile path ""+                                    void $ reflectIDE (refreshWorkspacePane >> goToSourceDefinition' path (Location "" 1 0 1 0)) ideRef+                        Nothing -> return ()++            let onNewDir = flip catchIDE (\(e :: SomeException) -> print e) $ reifyIDE $ \ideRef -> do+                    mbText <- showInputDialog "Directory name:" ""+                    case mbText of+                        Just t  -> do+                            let path = fp </> T.unpack t+                            exists <- doesDirectoryExist path+                            if exists+                                then showErrorDialog "Directory already exists"+                                else do+                                    createDirectory path+                                    void $ reflectIDE refreshWorkspacePane ideRef+                        Nothing -> return ()++            let onDeleteDir = flip catchIDE (\(e :: SomeException) -> print e) $ reifyIDE $ \ideRef -> do+                    showDialogOptions+                        ("Are you sure you want to delete " <> T.pack (takeFileName fp) <> "?")+                        MessageQuestion+                        [ ("Delete directory", removeDirectoryRecursive fp >> reflectIDE refreshWorkspacePane ideRef)+                        , ("Cancel", return ())+                        ]+                        (Just 0)++            return [ [ ("New Module...", onNewModule)+                     , ("New Text File...", onNewTextFile)+                     , ("New Directory...", onNewDir)+                     ]+                   , [ ("Delete Directory...", onDeleteDir)+                     ]+                   ]++        PackageRecord p -> do++            let onSetActive = workspaceTryQuiet $ workspaceActivatePackage p Nothing+                onAddModule = workspaceTryQuiet $ runPackage (addModule []) p+                onOpenCabalFile = workspaceTryQuiet $ runPackage packageEditText p+                onRemoveFromWs = workspaceTryQuiet $ do+                    workspaceRemovePackage p+                    liftIDE refreshWorkspacePane++            return [ [ ("New Module...", onAddModule)+                     , ("Set As Active Package", onSetActive)++                     ]+                   , [ ("Build", workspaceTryQuiet $ runPackage makePackage p)+                     , ("Run", workspaceTryQuiet $ runPackage packageRun p)+                     , ("Test", workspaceTryQuiet $ runPackage packageTest p)+                     , ("Clean", workspaceTryQuiet $ runPackage packageClean p)+                     , ("Open Package File", onOpenCabalFile)+                     ]+                   , [+                     ("Remove From Workspace", onRemoveFromWs)+                     ]+                   ]++        ComponentRecord comp -> do+            Just pkg <- treePathToPackage store path+            let onSetActive = workspaceTryQuiet $+                                  workspaceActivatePackage pkg (Just comp)+            return [[ ("Activate component", onSetActive) ]]++        AddSourcesRecord -> do+            Just pkg <- treePathToPackage store path+            let onAddSource snapshot = workspaceTryQuiet $ flip runPackage pkg (sandboxAddSource snapshot)+            return [ [ ("Add Source Dependency...", onAddSource False >> refreshWorkspacePane)+                     , ("Add Source Dependency Snapshot...", onAddSource True >> refreshWorkspacePane)+                     ]+                   ]+++        AddSourceRecord p -> do+            Just pkg <- treePathToPackage store path+            let onRemoveSourceDependency  = do+                    workspaceTryQuiet $ flip runPackage pkg (sandboxDeleteSource (ipdPackageDir p))+                onAddSourceDependencyToWs = workspaceTryQuiet . void $+                    workspaceAddPackage' (ipdCabalFile p)++            return [ [ ("Add Package To Workspace", onAddSourceDependencyToWs >> refreshWorkspacePane)+                     ]+                   , [ ("Delete Source Dependency", onRemoveSourceDependency >> refreshWorkspacePane)+                     ]+                   ]+        _ -> return []+++-- | Searches the source folders to determine what the corresponding+--   module path is+dirToModulePath :: FilePath -> PackageM (Maybe [Text])+dirToModulePath fp = do+    pkgDir <- ipdPackageDir <$> ask+    srcDirs <- map (pkgDir <>) . ipdSrcDirs <$> ask+    return $ do+        srcDir <- find (`isPrefixOf` fp) srcDirs+        let suffix = if srcDir == fp then "" else makeRelative srcDir fp+        let dirs   = map (T.pack . capitalize) (splitDirectories suffix)+        return dirs+    where+        capitalize (x:xs) = toUpper x : xs+        capitalize [] = []+++-- * Utility functions for operating on 'TreeStore'++++leaf :: a -> Tree a+leaf x = Node x []++treeStoreRemoveChildren :: TreeStore a -> TreePath -> IO ()+treeStoreRemoveChildren store path = do+    Node record children <- treeStoreGetTree store path+    forM_ (zip [0..] children) $ \_ -> do+        treeStoreRemove store (path ++ [0]) -- this works because mutation ...++data FindResult = WhereExpected TreeIter | Found TreeIter | NotFound++-- | Tries to find the given value in the 'TreeStore'. Only looks at the given 'TreeIter' and its+-- sibling nodes to the right.+-- Returns @WhereExpected iter@ if the records is found at the provided 'TreeIter'+-- Returns @Found iter@ if the record is found at a sibling iter+-- Returns @NotFound@ otherwise+searchToRight :: (a -> a -> Bool) -> a -> TreeStore a -> Maybe TreeIter -> IO FindResult+searchToRight compare _ _ Nothing = return NotFound+searchToRight compare a store (Just iter) = do+    row <- treeModelGetRow store iter+    if compare row a+        then return $ WhereExpected iter+        else treeModelIterNext store iter >>= find'+  where+    find' :: Maybe TreeIter -> IO FindResult+    find' Nothing = return NotFound+    find' (Just iter) = do+        row <- treeModelGetRow store iter+        if compare row a+            then return $ Found iter+            else treeModelIterNext store iter >>= find'+++-- | Starting at the node at the given 'TreePath', removes all sibling nodes to the right+--   until the given value is found.+removeUntil :: Eq a => a -> TreeStore a -> TreePath -> IO ()+removeUntil a store path = do+    row <- treeStoreGetValue store path+    when (row /= a) $ do+        found <- treeStoreRemove store path+        when found $ removeUntil a store path+++-- | Starting at the node at the given 'TreePath', removes all sibling nodes to the right+removeRemaining :: TreeStore a -> TreePath -> IO ()+removeRemaining store path = do+    found <- treeStoreRemove store path+    when found $ removeRemaining store path

@@ -43,7 +43,7 @@ import IDE.Pane.Breakpoints (IDEBreakpoints(..)) import IDE.Pane.Variables (IDEVariables(..)) import IDE.Pane.Trace (IDETrace(..))-import IDE.Pane.Workspace (IDEWorkspace(..))+import IDE.Pane.Workspace (WorkspacePane(..)) import Control.Monad.IO.Class (MonadIO(..)) import IDE.Pane.WebKit.Output (IDEOutput(..)) @@ -88,7 +88,7 @@     getOrBuildBrowserPanes upperP lowerP topP = do         moveOrBuildPane upperP :: IDEM (Maybe IDEModules)         moveOrBuildPane lowerP :: IDEM (Maybe IDEInfo)-        moveOrBuildPane topP :: IDEM (Maybe IDEWorkspace)+        moveOrBuildPane topP :: IDEM (Maybe WorkspacePane)         return ()  setSensitivityDebugger :: Bool -> IDEAction

@@ -0,0 +1,965 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+-----------------------------------------------------------------------------+--+-- Module      :  IDE.Preferences+-- Copyright   :  2007-2014 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License     :  GPL+--+-- Maintainer  :  maintainer@leksah.org+-- Stability   :  provisional+-- Portability :  Definition of the Preferences dialog+--+-- |+--+-----------------------------------------------------------------------------+++module IDE.Preferences (+  runPreferencesDialog+, applyInterfaceTheme+, readPrefs+, writePrefs+, defaultPrefs+) where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.General.Settings+import qualified Text.PrettyPrint.HughesPJ as PP+import Distribution.Package+import Data.IORef+import Data.Typeable++import Control.Event+import Graphics.UI.Editor.Basics+import IDE.Core.State+import Graphics.UI.Editor.Simple+import Graphics.UI.Editor.Composite+import Graphics.UI.Editor.Parameters+import Graphics.UI.Editor.MakeEditor hiding (parameters)+import Graphics.UI.Editor.DescriptionPP+import Text.PrinterParser hiding (fieldParser,parameters)+import IDE.TextEditor+import IDE.Pane.SourceBuffer+import IDE.Pane.Log+import IDE.Pane.Info (setInfoStyle)+import IDE.Utils.FileUtils+import IDE.Utils.GUIUtils+import IDE.Pane.Workspace+import IDE.Debug+    (debugSetPrintBindResult,+     debugSetBreakOnError,+     debugSetBreakOnException,+     debugSetPrintEvldWithShow)+import Graphics.UI.Gtk.SourceView+       (sourceStyleSchemeManagerAppendSearchPath,+        sourceStyleSchemeManagerGetSchemeIds, sourceStyleSchemeManagerNew)+import System.Time (getClockTime)+import qualified IDE.StrippedPrefs as SP+import Control.Exception(SomeException,catch)+import Prelude hiding(catch)+import Data.List (isSuffixOf, sortBy)+import Data.Maybe (mapMaybe, catMaybes, fromMaybe, isJust)+import Graphics.UI.Gtk.Windows.MessageDialog+       (ButtonsType(..), MessageType(..))+import System.Glib.Attributes (set)+import Graphics.UI.Gtk.General.Enums+       (ButtonBoxStyle(..), WindowPosition(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (void, when)+import System.FilePath ((</>))+import Data.Text (Text)+import qualified Data.Text as T (isSuffixOf, unpack, pack, null)+import Data.Monoid ((<>))+import Control.Applicative ((<$>))+import Distribution.Text (display, simpleParse)+import Data.Foldable (forM_)+import IDE.Pane.Errors (fillErrorList)+import GHC.IO (evaluate)+import IDE.Metainfo.Provider (getAllPackageIds)+++-- | This needs to be incremented when the preferences format changes+prefsVersion :: Int+prefsVersion = 7++runPreferencesDialog :: IDEAction+runPreferencesDialog = do+  packageInfos <- getAllPackageIds+  initialPrefs <- readIDE prefs+  parent <- getMainWindow+  reifyIDE $ \ideR -> do+    dialog <-   dialogNew+    set dialog [ windowTransientFor := parent+            , windowTitle := __ "Preferences" ]+    windowSetDefaultSize dialog 800 500++    configDir    <- getConfigDir+    (widget, inj, ext, notifier) <- buildEditor (extractFieldDescription $ prefsDescription configDir packageInfos) initialPrefs++    bb      <-  hButtonBoxNew+    boxSetSpacing bb 6+    buttonBoxSetLayout bb ButtonboxSpread+    load    <-  buttonNewWithLabel (__ "Load")+    save    <-  buttonNewWithLabel (__ "Save")+    preview <-  buttonNewWithLabel (__ "Preview")+    cancel  <-  buttonNewFromStock "gtk-cancel"+    apply      <-  buttonNewFromStock "gtk-apply"+    forM_ [preview, cancel, apply] $ \but ->+        boxPackEnd bb but PackNatural 0++++    upper <-   dialogGetContentArea dialog+    boxPackStart (castToBox upper) widget PackGrow 0+    errorLabel <-  labelNew (Nothing :: Maybe Text)+    boxPackStart (castToBox upper) errorLabel PackNatural 0+    lower <-   dialogGetActionArea dialog+    boxPackEnd (castToBox lower) bb PackNatural 5++    -- Keep an IO ref to the last applied preferences+    -- so it can be restored+    lastAppliedPrefsRef <- liftIO $ newIORef initialPrefs+    let flatPrefsDesc = flattenFieldDescriptionPP (prefsDescription configDir packageInfos)+    let applyPrefs newPrefs = do+            lastAppliedPrefs <- readIORef lastAppliedPrefsRef+            reflectIDE (modifyIDE_ (\ide -> ide{prefs = newPrefs})) ideR+            mapM_ (\f -> reflectIDE (applicator f newPrefs lastAppliedPrefs) ideR) flatPrefsDesc+            writeIORef lastAppliedPrefsRef newPrefs+++    on preview buttonActivated $ do+            mbNewPrefs <- extract initialPrefs [ext]+            forM_ mbNewPrefs applyPrefs+++    on apply buttonActivated $ do+        mbNewPrefs <- extract initialPrefs [ext]+        forM_ mbNewPrefs $ \newPrefs -> do+            applyPrefs newPrefs++            -- save preferences to disk+            fp   <- getConfigFilePathForSave standardPreferencesFilename+            writePrefs fp newPrefs+            fp2  <-  getConfigFilePathForSave strippedPreferencesFilename+            SP.writeStrippedPrefs fp2+                SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs,+                           SP.unpackDirectory   = unpackDirectory newPrefs,+                           SP.retrieveURL       = retrieveURL newPrefs,+                           SP.retrieveStrategy  = retrieveStrategy newPrefs,+                           SP.serverPort        = serverPort newPrefs,+                           SP.endWithLastConn   = endWithLastConn newPrefs}++        dialogResponse dialog ResponseOk++    let onClose = do+            mbP <- extract initialPrefs [ext]+            let hasChanged = case mbP of+                                    Nothing -> False+                                    Just p -> p{prefsFormat = 0, prefsSaveTime = ""} /=+                                              initialPrefs{prefsFormat = 0, prefsSaveTime = ""}+            when hasChanged (applyPrefs initialPrefs)+            dialogResponse dialog ResponseCancel++    on cancel buttonActivated onClose+    on dialog response $ \resp -> do+        case resp of+            ResponseDeleteEvent -> onClose+            _ -> return ()++    registerEvent notifier MayHaveChanged (\ e -> do+        mbP <- extract initialPrefs [ext]+        let hasChanged = case mbP of+                                Nothing -> False+                                Just p -> p{prefsFormat = 0, prefsSaveTime = ""} /=+                                          initialPrefs{prefsFormat = 0, prefsSaveTime = ""}+        when (isJust mbP) $ labelSetMarkup errorLabel ("" :: Text)+        return (e{gtkReturn=False}))++    registerEvent notifier ValidationError $ \e -> do+        labelSetMarkup errorLabel $ "<span foreground=\"red\" size=\"x-large\">The following fields have invalid values: "+            <> eventText e <> "</span>"+        widgetSetSensitive apply False+        return e+++    set apply [widgetCanDefault := True]+    widgetGrabDefault apply+    widgetShowAll dialog+    resp  <- dialogRun dialog+    widgetDestroy dialog+    return ()+++-- | Represents the Preferences dialog+data PreferencesDialog = PreferencesDialog {+    editorsBox ::   VBox+} deriving Typeable+++-- ------------------------------------------------------------+-- * Dialog definition+-- ------------------------------------------------------------++-- | Description of the preference options+prefsDescription :: FilePath -> [PackageIdentifier] -> FieldDescriptionPP Prefs IDEM+prefsDescription configDir packages = NFDPP [+    (__ "Editor", VFDPP emptyParams [+        mkFieldPP+            (paraName <<<- ParaName (__ "Version number of preferences file format")+                $ paraSynopsis <<<- ParaSynopsis (__ "Integer")+                    $ paraShowLabel <<<- ParaShowLabel False $ emptyParams)+            (PP.text . show)+            intParser+            prefsFormat+            (\ b a -> a{prefsFormat = b})+            (noEditor 0)+            (\b -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Time of last storage")+                $ paraShowLabel <<<- ParaShowLabel False $ emptyParams)+            (PP.text . show)+            stringParser+            prefsSaveTime+            (\ b a -> a{prefsSaveTime = b})+            (noEditor "")+            (\b -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Show line numbers")+                $ paraSynopsis <<<- ParaSynopsis (__ "(True/False)")+                    $ emptyParams)+            (PP.text . show)+            boolParser+            showLineNumbers+            (\ b a -> a{showLineNumbers = b})+            boolEditor+            (\b -> do+                buffers <- allBuffers+                mapM_ (\(IDEBuffer {sourceView = sv}) -> setShowLineNumbers sv b) buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "TextView Font") $ emptyParams)+            (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))+            (do str <- stringParser+                return (if T.null str then Nothing else Just str))+            textviewFont+            (\ b a -> a{textviewFont = b})+            fontEditor+            (\mbs -> do+                buffers <- allBuffers+                mapM_ (\(IDEBuffer {sourceView = sv}) -> setFont sv mbs) buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Right margin")+                $ paraSynopsis <<<- ParaSynopsis (__ "Size or 0 for no right margin")+                    $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)+            (PP.text . show)+            readParser+            rightMargin+            (\b a -> a{rightMargin = b})+            (disableEditor (intEditor (1.0, 200.0, 5.0), paraName <<<- ParaName (__ "Position")+                    $ emptyParams)+                    True (__ "Show it ?"))+            (\b -> do+                buffers <- allBuffers+                mapM_ (\(IDEBuffer {sourceView = sv}) -> setRightMargin sv+                                (case b of+                                    (True,v) -> Just v+                                    (False,_) -> Nothing)) buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Tab width") $ emptyParams)+            (PP.text . show)+            intParser+            tabWidth+            (\b a -> a{tabWidth = b})+            (intEditor (1.0, 20.0, 1.0))+            (\i -> do+                buffers <- allBuffers+                mapM_ (\(IDEBuffer {sourceView = sv}) -> setIndentWidth sv i) buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Wrap lines") $ emptyParams)+            (PP.text . show)+            boolParser+            wrapLines+            (\b a -> a{wrapLines = b})+            boolEditor+            (\b -> do+                buffers <- allBuffers+                mapM_ (\(IDEBuffer {sourceView = sv}) -> setWrapMode sv b) buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Use standard line ends even on windows") $ emptyParams)+            (PP.text . show)+            boolParser+            forceLineEnds+            (\b a -> a{forceLineEnds = b})+            boolEditor+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Remove trailing blanks when saving a file") $ emptyParams)+            (PP.text . show)+            boolParser+            removeTBlanks+            (\b a -> a{removeTBlanks = b})+            boolEditor+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Source candy")+                $ paraSynopsis <<<- ParaSynopsis+                    (__ "Empty for do not use or the name of a candy file in a config dir")+                    $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)+            (PP.text . show)+            readParser+            sourceCandy (\b a -> a{sourceCandy = b})+            (disableEditor (textEditor (not . T.null) True,+                paraName <<<- ParaName (__ "Candy specification")+                                    $ emptyParams)+                    True (__ "Use it ?"))+            (\_ -> switchBuffersCandy)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Editor Style") $ emptyParams)+            (\a -> PP.text (case a of (False,_) -> show ""; (True, s) -> show s))+            (do str <- stringParser+                return (if T.null str then (False, __ "classic") else (True,str)))+            sourceStyle+            (\b a -> a{sourceStyle = b})+            styleEditor+            (\mbs -> do+                setInfoStyle+                buffers <- allBuffers+                mapM_ updateStyle' buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Found Text Background") $ emptyParams)+            (PP.text . show)+            colorParser+            foundBackgroundLight+            (\ b a -> a{foundBackgroundLight = b})+            colorEditor+            (\c -> do+                buffers <- allBuffers+                mapM_ updateStyle' buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Selection Match Text Background") $ emptyParams)+            (PP.text . show)+            colorParser+            matchBackgroundLight+            (\ b a -> a{matchBackgroundLight = b})+            colorEditor+            (\c -> do+                buffers <- allBuffers+                mapM_ updateStyle' buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Execution Context Text Background") $ emptyParams)+            (PP.text . show)+            colorParser+            contextBackgroundLight+            (\ b a -> a{contextBackgroundLight = b})+            colorEditor+            (\c -> do+                buffers <- allBuffers+                mapM_ updateStyle' buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Breakpoint Text Background") $ emptyParams)+            (PP.text . show)+            colorParser+            breakpointBackgroundLight+            (\ b a -> a{breakpointBackgroundLight = b})+            colorEditor+            (\c -> do+                buffers <- allBuffers+                mapM_ updateStyle' buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Lint Text Background") $ emptyParams)+            (PP.text . show)+            colorParser+            lintBackgroundLight+            (\ b a -> a{lintBackgroundLight = b})+            colorEditor+            (\c -> do+                buffers <- allBuffers+                mapM_ updateStyle' buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Found Text Dark Background") $ emptyParams)+            (PP.text . show)+            colorParser+            foundBackgroundDark+            (\ b a -> a{foundBackgroundDark = b})+            colorEditor+            (\c -> do+                buffers <- allBuffers+                mapM_ updateStyle' buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Selection Match Text Dark Background") $ emptyParams)+            (PP.text . show)+            colorParser+            matchBackgroundDark+            (\ b a -> a{matchBackgroundDark = b})+            colorEditor+            (\c -> do+                buffers <- allBuffers+                mapM_ updateStyle' buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Execution Context Text Dark Background") $ emptyParams)+            (PP.text . show)+            colorParser+            contextBackgroundDark+            (\ b a -> a{contextBackgroundDark = b})+            colorEditor+            (\c -> do+                buffers <- allBuffers+                mapM_ updateStyle' buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Breakpoint Text Dark Background") $ emptyParams)+            (PP.text . show)+            colorParser+            breakpointBackgroundDark+            (\ b a -> a{breakpointBackgroundDark = b})+            colorEditor+            (\c -> do+                buffers <- allBuffers+                mapM_ updateStyle' buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Lint Text Dark Background") $ emptyParams)+            (PP.text . show)+            colorParser+            lintBackgroundDark+            (\ b a -> a{lintBackgroundDark = b})+            colorEditor+            (\c -> do+                buffers <- allBuffers+                mapM_ updateStyle' buffers)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Automatically load modified files modified outside of Leksah") $ emptyParams)+            (PP.text . show)+            boolParser+            autoLoad+            (\b a -> a{autoLoad = b})+            boolEditor+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Text Editor") $ emptyParams)+            (PP.text . show)+            stringParser+            textEditorType+            (\b a -> a{textEditorType = b})+            (comboSelectionEditor ["GtkSourceView", "Yi", "CodeMirror"] id)+            (\i -> return ())+    ]),+    (__ "User Interface", VFDPP emptyParams [+        mkFieldPP+            -- TODO: be able to load different gtk themes+            (paraName <<<- ParaName (__ "User interface theme") $ emptyParams)+            (PP.text . show)+            stringParser+            (\prefs -> if darkUserInterface prefs then "Dark" else "Light")+            (\str a -> a {darkUserInterface = str == "Dark"})+            (comboSelectionEditor ["Dark", "Light"] id)+            (\_ -> applyInterfaceTheme)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "LogView Font") $ emptyParams)+            (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))+            (do str <- stringParser+                return (if T.null str then Nothing else Just str))+            logviewFont+            (\ b a -> a{logviewFont = b})+            fontEditor+            (\mbs -> do+                log <- getLog+                fdesc <- liftIO $fontDescriptionFromString (fromMaybe "" mbs)+                liftIO $widgetModifyFont (castToWidget $ logLaunchTextView log) (Just fdesc))+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Window default size")+                $ paraSynopsis <<<- ParaSynopsis+                    (__ "Default size of the main ide window specified as pair")+                $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)+            (PP.text.show)+            (pairParser intParser)+            defaultSize (\(c,d) a -> a{defaultSize = (c,d)})+            (pairEditor (intEditor (0.0, 3000.0, 25.0),+                            paraName <<<- ParaName "X" $ emptyParams)+                        (intEditor (0.0, 3000.0, 25.0),+                            paraName <<<- ParaName "Y" $ emptyParams))+            (\a -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Show hidden files in workspace") $ emptyParams)+            (PP.text . show)+            boolParser+            showHiddenFiles+            (\b a -> a {showHiddenFiles = b})+            boolEditor+            (\_ -> refreshWorkspacePane)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Show icons in the Workspace pane") $ emptyParams)+            (PP.text . show)+            boolParser+            showWorkspaceIcons+            (\b a -> a {showWorkspaceIcons = b})+            boolEditor+            (\_ -> rebuildWorkspacePane)+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Use ctrl Tab for Notebook flipper") $ emptyParams)+            (PP.text . show)+            boolParser+            useCtrlTabFlipping+            (\b a -> a{useCtrlTabFlipping = b})+            boolEditor+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Complete only on Hotkey") $ emptyParams)+            (PP.text . show)+            boolParser+            completeRestricted+            (\b a -> a{completeRestricted = b})+            boolEditor+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Name of the keymap")+                $ paraSynopsis <<<- ParaSynopsis+                    (__ "The name of a keymap file in a config dir")+                    $ paraDirection <<<- ParaDirection Horizontal $ emptyParams)+            (PP.text . T.unpack)+            identifier+            keymapName+            (\b a -> a{keymapName = b})+            (textEditor (not . T.null) True)+            (\ a -> return ())+    ]),+    (__ "Sessions", VFDPP emptyParams [+         mkFieldPP+            (paraName <<<- ParaName (__ "Save the session (open files, pane positioning and sizing, etc) before closing a workspace") $+                paraSynopsis <<<- ParaSynopsis+                    (__ "Save the session (open files, pane positioning and sizing, etc) before closing a workspace")+                    $ paraShadow <<<- ParaShadow ShadowIn  $ emptyParams)+            (PP.text . show)+            boolParser+            saveSessionOnClose+            (\b a -> a{saveSessionOnClose = b})+            boolEditor+            (\_ -> return ())+    ]),+    (__ "Initial Pane positions", VFDPP emptyParams [+        mkFieldPP+            (paraName <<<- ParaName+                (__ "Categories for panes")+                $ paraShadow <<<- ParaShadow ShadowIn+                     $ paraDirection <<<- ParaDirection Vertical+                        $ paraMinSize <<<- ParaMinSize (-1,130)+                            $ emptyParams)+            (PP.text . show)+            readParser+            categoryForPane+            (\b a -> a{categoryForPane = b})+            (multisetEditor+                (ColumnDescr True [(__ "Pane Id", \ (n, _) -> [cellText := n])+                                   ,(__ "Pane Category", \ (_, v) -> [cellText := v])])+                (pairEditor+                    (textEditor (not . T.null) True, emptyParams)+                    (textEditor (not . T.null) True, emptyParams), emptyParams)+                (Just (sortBy (\(a,_) (a2,_) -> compare a a2)))+                (Just (\(a,_) (a2,_) -> a == a2)))+            (\i -> return ())+       ,mkFieldPP+            (paraName <<<- ParaName+                (__ "Pane path for category")+                $ paraShadow <<<- ParaShadow ShadowIn+                     $ paraDirection <<<- ParaDirection Vertical+                        $ paraMinSize <<<- ParaMinSize (-1,130)+                            $ emptyParams)+            (PP.text . show)+            readParser+            pathForCategory+            (\b a -> a{pathForCategory = b})+            (multisetEditor+                (ColumnDescr True [(__ "Pane category", \ (n, _) -> [cellText := n])+                                   ,(__ "Pane path", \ (_, v) -> [cellText := T.pack $ show v])])+                (pairEditor (textEditor (not . T.null) True, emptyParams)+                    (genericEditor, emptyParams),+                  emptyParams)+                (Just (sortBy (\(a,_) (a2,_) -> compare a a2)))+                (Just (\(a,_) (a2,_) -> a == a2)))+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Default pane path") $ emptyParams)+            (PP.text . show)+            readParser+            defaultPath+            (\b a -> a{defaultPath = b})+            genericEditor+            (\i -> return ())+    ]),+    (__ "Metadata", VFDPP emptyParams [+        mkFieldPP+            (paraName <<<- ParaName+                (__ "Paths under which haskell sources for packages may be found")+                        $ paraMinSize <<<- ParaMinSize (-1,100)+                            $ emptyParams)+            (PP.text . show)+            readParser+            sourceDirectories+            (\b a -> a{sourceDirectories = b})+            (filesEditor Nothing FileChooserActionSelectFolder (__ "Select folder"))+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Unpack source for cabal packages to") $ emptyParams)+            (PP.text . show)+            readParser+            unpackDirectory+            (\b a -> a{unpackDirectory = b})+            (maybeEditor (stringEditor (const True) True,emptyParams) True "")+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "URL from which to download prebuilt metadata") $ emptyParams)+            (PP.text . show)+            stringParser+            retrieveURL+            (\b a -> a{retrieveURL = b})+            (textEditor (const True) True)+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Strategy for downloading prebuilt metadata") $ emptyParams)+            (PP.text . show)+            readParser+            retrieveStrategy+            (\b a -> a{retrieveStrategy = b})+            (enumEditor [__ "Try to download and then build locally if that fails",+                         __ "Try to build locally and then download if that fails",+                         __ "Never download (just try to build locally)"])+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Update metadata at startup") $ emptyParams)+            (PP.text . show)+            boolParser+            collectAtStart+            (\b a -> a{collectAtStart = b})+            boolEditor+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Port number for leksah to comunicate with leksah-server") $ emptyParams)+            (PP.text . show)+            intParser+            serverPort+            (\b a -> a{serverPort = b})+            (intEditor (1.0, 65535.0, 1.0))+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "IP address for leksah to comunicate with leksah-server") $ emptyParams)+            (PP.text . show)+            stringParser+            serverIP+            (\b a -> a{serverIP = b})+            (textEditor (not . T.null) True)+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "Stop the leksah-server process when leksah disconnects") $ emptyParams)+            (PP.text . show)+            boolParser+            endWithLastConn+            (\b a -> a{endWithLastConn = b})+            boolEditor+            (\i -> return ())+    ]),+    (__ "Blacklist", VFDPP emptyParams [+        mkFieldPP+            (paraName <<<- ParaName+                (__ "Packages which are excluded from the modules pane")+                        $ paraMinSize <<<- ParaMinSize (-1,200)+                            $ emptyParams)+            (PP.text . show . map display)+            (fmap (mapMaybe simpleParse) readParser)+            packageBlacklist+            (\b a -> a{packageBlacklist = b})+            (dependenciesEditor packages)+            (\i -> return ())+    ]),+    (__ "Build", VFDPP emptyParams [+         mkFieldPP+            (paraName <<<- ParaName (__ "Automatically save all files before building") $ emptyParams)+            (PP.text . show)+            boolParser+            saveAllBeforeBuild+            (\b a -> a{saveAllBeforeBuild = b})+            boolEditor+            (\i -> return ())+         , mkFieldPP+               (paraName <<<- ParaName (__ "Run HLint when saving a source file") $ emptyParams)+               (PP.text . show)+               boolParser+               hlintOnSave+               (\b a -> a{hlintOnSave = b})+               boolEditor+               (\i -> return ())+         , mkFieldPP+            (paraName <<<- ParaName (__ "Select first warning if built without errors") $ emptyParams)+            (PP.text . show)+            boolParser+            jumpToWarnings+            (\b a -> a{jumpToWarnings = b})+            boolEditor+            (\i -> return ())+         , mkFieldPP+            (paraName <<<- ParaName (__ "Background build") $ emptyParams)+            (PP.text . show)+            boolParser+            backgroundBuild+            (\b a -> a{backgroundBuild = b})+            boolEditor+            (\i -> return ())+         , mkFieldPP+            (paraName <<<- ParaName (__ "Run unit tests when building") $ emptyParams)+            (PP.text . show)+            boolParser+            runUnitTests+            (\b a -> a{runUnitTests = b})+            boolEditor+            (\i -> return ())+         , mkFieldPP+            (paraName <<<- ParaName (__ "Make mode") $ emptyParams)+            (PP.text . show)+            boolParser+            makeMode+            (\b a -> a{makeMode = b})+            (boolEditor2 (__ "Single mode"))+            (\i -> return ())++         , mkFieldPP+            (paraName <<<- ParaName (__ "Single build without linking") $ emptyParams)+            (PP.text . show)+            boolParser+            singleBuildWithoutLinking+            (\b a -> a{singleBuildWithoutLinking = b})+            boolEditor+            (\i -> return ())+         , mkFieldPP+            (paraName <<<- ParaName (__ "Don't install last package") $ emptyParams)+            (PP.text . show)+            boolParser+            dontInstallLast+            (\b a -> a{dontInstallLast = b})+            boolEditor+            (\i -> return ())++        , mkFieldPP+            (paraName <<<- ParaName (__ "Use vado to run commands on the remote machine") $ emptyParams)+            (PP.text . show)+            boolParser+            useVado+            (\b a -> a{useVado = b})+            boolEditor+            (\i -> return ())++        , mkFieldPP+            (paraName <<<- ParaName (__ "Use cabal-dev") $ emptyParams)+            (PP.text . show)+            boolParser+            useCabalDev+            (\b a -> a{useCabalDev = b})+            boolEditor+            (\i -> return ())+    ]),+    (__ "Debug", VFDPP emptyParams [+           mkFieldPP+            (paraName <<<- ParaName (__ "Enable usage of Show instances in :print") $ emptyParams)+            (PP.text . show)+            boolParser+            printEvldWithShow+            (\b a -> a{printEvldWithShow = b})+            boolEditor+            debugSetPrintEvldWithShow+         , mkFieldPP+            (paraName <<<- ParaName (__ "Break on any exception thrown") $ emptyParams)+            (PP.text . show)+            boolParser+            breakOnException+            (\b a -> a{breakOnException = b})+            boolEditor+            debugSetBreakOnException+         , mkFieldPP+            (paraName <<<- ParaName (__ "Break on uncaught exceptions and errors") $ emptyParams)+            (PP.text . show)+            boolParser+            breakOnError+            (\b a -> a{breakOnError = b})+            boolEditor+            debugSetBreakOnError+         , mkFieldPP+            (paraName <<<- ParaName (__ "Turn on printing of binding results in GHCi") $ emptyParams)+            (PP.text . show)+            boolParser+            printBindResult+            (\b a -> a{printBindResult = b})+            boolEditor+            debugSetPrintBindResult+    ]),+    (__ "Help", VFDPP emptyParams [+        mkFieldPP+            (paraName <<<- ParaName (__ "Browser") $ emptyParams)+            (PP.text . show)+            stringParser+            browser+            (\b a -> a{browser = b})+            (textEditor (not . T.null) True)+            (\i -> return ())+    ,   mkFieldPP+            (paraName <<<- ParaName (__ "URL for searching documentation") $+                paraSynopsis <<<- ParaSynopsis+                    ("e.g https://www.haskell.org/hoogle/?q= or " <>+                        "Hayoo: http://hayoo.fh-wedel.de/?query=")+                        $ emptyParams)+            (PP.text . show)+            stringParser+            docuSearchURL+            (\b a -> a{docuSearchURL = b})+            (textEditor (not . T.null) True)+            (\i -> return ())+    ])]++getActiveSettings :: PaneMonad alpha => alpha (Maybe Settings)+getActiveSettings = do+    mbScreen <- getActiveScreen+    case mbScreen of+        Nothing -> return Nothing+        Just screen -> liftIO $ Just <$> settingsGetForScreen screen++applyInterfaceTheme :: IDEAction+applyInterfaceTheme = do+    setInfoStyle+    fillErrorList False+    prefs <- readIDE prefs+    buffers <- allBuffers+    mapM_ updateStyle' buffers+    mbSettings <- getActiveSettings+    case mbSettings of+        Just settings -> liftIO $ settingsSetLongProperty+                            settings+                            ("gtk-application-prefer-dark-theme" :: Text)+                            (if darkUserInterface prefs then 1 else 0)+                            "Leksah"+        Nothing -> return ()+    menuDarkState <- getDarkState+    when (menuDarkState /= darkUserInterface prefs) $+        setDarkState (darkUserInterface prefs)++-- | Editor for enabling a different syntax stylesheet+styleEditor :: Editor (Bool, Text)+styleEditor p n = do+    styleManager <- sourceStyleSchemeManagerNew+    dataDir <- getDataDir+    sourceStyleSchemeManagerAppendSearchPath styleManager $ dataDir </> "data/styles"+    ids          <- sourceStyleSchemeManagerGetSchemeIds styleManager+    let notDarkIds = filter (not . T.isSuffixOf "-dark") ids+    disableEditor (comboSelectionEditor notDarkIds id, p) True (__ "Select a special style?") p n+++-- | The default preferences+defaultPrefs = Prefs {+        prefsFormat         =   prefsVersion+    ,   prefsSaveTime       =   ""+    ,   showLineNumbers     =   True+    ,   rightMargin         =   (True,100)+    ,   tabWidth            =   4+    ,   wrapLines           =   False+    ,   sourceCandy         =   (False,"candy")+    ,   darkUserInterface   = False+    ,   saveSessionOnClose  = True+    ,   keymapName          =   "keymap"+    ,   forceLineEnds       =   True+    ,   removeTBlanks       =   True+    ,   textviewFont        =   Nothing+    ,   sourceStyle         =   (True,"leksah")+    ,   foundBackgroundLight      = Color 65535 65535 32768+    ,   matchBackgroundLight      = Color 42064 55923 28520+    ,   contextBackgroundLight    = Color 65535 46529 46529+    ,   breakpointBackgroundLight = Color 64879 51921 28114+    ,   lintBackgroundLight       = Color 60000 65535 60000+    ,   foundBackgroundDark       = Color 30364 29149     0+    ,   matchBackgroundDark       = Color 18021 29927  6384+    ,   contextBackgroundDark     = Color 20000 16000 16000+    ,   breakpointBackgroundDark  = Color 15000  5000  5000+    ,   lintBackgroundDark        = Color     0 15000     0+    ,   textEditorType      =   "GtkSourceView"+    ,   autoLoad            =   False+    ,   logviewFont         =   Nothing+    ,   defaultSize         =   (1024,800)+    ,   browser             =   "firefox"+    ,   sourceDirectories   =   []+    ,   packageBlacklist    =   []+    ,   pathForCategory     =   [   ("EditorCategory",[SplitP LeftP])+                                ,   ("LogCategory",[SplitP RightP, SplitP BottomP])+                                ,   ("ToolCategory",[SplitP RightP, SplitP TopP])+                                ]+    ,   defaultPath         =   [SplitP LeftP]+    ,   categoryForPane     =   [   ("*ClassHierarchy","ToolCategory")+                                ,   ("*Breakpoints","LogCategory")+                                ,   ("*Browser","ToolCategory")+                                ,   ("*Debug","ToolCategory")+                                ,   ("*Errors","ToolCategory")+                                ,   ("*Files","ToolCategory")+                                ,   ("*Flags","ToolCategory")+                                ,   ("*Grep","ToolCategory")+                                ,   ("*HLint","ToolCategory")+                                ,   ("*Doc","ToolCategory")+                                ,   ("*Info","LogCategory")+                                ,   ("*Log","LogCategory")+                                ,   ("*Inspect","LogCategory")+                                ,   ("*Modules","ToolCategory")+                                ,   ("*Out","ToolCategory")+                                ,   ("*Package","EditorCategory")+                                ,   ("*Prefs","EditorCategory")+                                ,   ("*Search","ToolCategory")+                                ,   ("*Trace","LogCategory")+                                ,   ("*Variables","LogCategory")+                                ,   ("*Workspace","LogCategory")]+    ,   collectAtStart      =   True+    ,   unpackDirectory     =   Just ("~" </> configDirName </> "packageSources")+    ,   retrieveURL         =   "http://www.leksah.org"+    ,   retrieveStrategy    =   SP.RetrieveThenBuild+    ,   useCtrlTabFlipping  =   True+    ,   docuSearchURL       =   "https://www.haskell.org/hoogle/?q="+    ,   completeRestricted  =   False+    ,   saveAllBeforeBuild  =   True+    ,   jumpToWarnings      =   True+    ,   useVado             =   False+    ,   useCabalDev         =   False+    ,   backgroundBuild     =   True+    ,   runUnitTests        =   False+    ,   makeMode            =   True+    ,   singleBuildWithoutLinking  = False+    ,   dontInstallLast     =   False+    ,   printEvldWithShow   =   True+    ,   breakOnException    =   True+    ,   breakOnError        =   True+    ,   printBindResult     =   False+    ,   serverPort          =   11111+    ,   serverIP            =   "127.0.0.1"+    ,   endWithLastConn     =   True+    ,   showHiddenFiles     =   False+    ,   showWorkspaceIcons       =   True+    ,   hlintOnSave = True+    }++-- ------------------------------------------------------------+-- * Parsing+-- ------------------------------------------------------------++-- | Read the preference file+readPrefs :: FilePath -> IO Prefs+readPrefs fn = catch (do+    configDir <- getConfigDir+    readFields fn (flattenFieldDescriptionPPToS (prefsDescription configDir [])) defaultPrefs)+        (\ (e :: SomeException) -> do+            sysMessage Normal (T.pack $ show e)+            return defaultPrefs)+-- ------------------------------------------------------------+-- * Printing+-- ------------------------------------------------------------++-- | Write the preference file+writePrefs :: FilePath -> Prefs -> IO ()+writePrefs fpath prefs = do+    timeNow         <- liftIO getClockTime+    configDir <- getConfigDir+    let newPrefs    =   prefs {prefsSaveTime = T.pack $ show timeNow, prefsFormat = prefsVersion}+    writeFields fpath newPrefs (flattenFieldDescriptionPPToS (prefsDescription configDir []))++

@@ -18,6 +18,7 @@ , sandboxInitShared , sandboxDelete , sandboxAddSource+, sandboxDeleteSource ) where  import Graphics.UI.Gtk (Window)@@ -31,9 +32,11 @@ import qualified Data.Conduit as C (Sink, ZipSink(..), getZipSink) import qualified Data.Conduit.List as CL (fold) import IDE.Utils.Tool (ToolOutput(..))-import IDE.Utils.GUIUtils (__, chooseDir)-import IDE.Core.State (PackageAction, readIDE, prefs, ipdBuildDir, getMainWindow,-            Workspace, wsFile, liftIDE, IDEPackage, IDEM, runPackage, LogLaunch)+import IDE.Utils.GUIUtils (showDialogOptions, __, chooseDir)+import IDE.Core.State+       (reflectIDE, reifyIDE, PackageAction, readIDE, prefs,+        ipdPackageDir, getMainWindow, Workspace, wsFile, liftIDE,+        IDEPackage, IDEM, runPackage, LogLaunch) import IDE.Pane.Log (getDefaultLogLaunch) import IDE.Utils.ExternalTool (runExternalTool') import IDE.LogRef (logOutput)@@ -42,10 +45,35 @@ import IDE.Package (refreshPackage) import Data.Monoid ((<>)) import qualified Data.Text as T (pack)+import IDE.Core.Types (runWorkspace, IDE(..), PackageM)+import System.Directory (doesFileExist)+import System.FilePath.Windows ((</>))+import Graphics.UI.Gtk.Windows.MessageDialog (MessageType(..))  -- | Get the last item sinkLast = CL.fold (\_ a -> Just a) Nothing +sandboxTry :: PackageAction -> PackageAction+sandboxTry action = do+    sandbox <- hasSandbox+    pkg <- ask+    if sandbox then action else do+        reifyIDE $ \ideRef -> do+            Just ws <- reflectIDE (readIDE workspace) ideRef+            let packageToIO = flip reflectIDE ideRef . flip runWorkspace ws . flip runPackage pkg+            showDialogOptions+                "This action requires a sandboxed package database. Would you like to initialize a sandbox for this package?"+                MessageQuestion+                [ ("Initialize New Sandbox", packageToIO $ sandboxInit >> action)+                , ("Use Existing Sandbox", packageToIO $ sandboxInitShared >> action)+                , ("Cancel", return ())]+                (Just 0)++hasSandbox :: PackageM Bool+hasSandbox = do+    pkg <- ask+    liftIO $ doesFileExist (ipdPackageDir pkg </> "cabal.sandbox.config")+ logSandbox :: IDEPackage -> LogLaunch -> C.Sink ToolOutput IDEM () logSandbox package logLaunch = do     let log = logOutput logLaunch@@ -59,7 +87,7 @@     logLaunch <- getDefaultLogLaunch     runExternalTool' (__ "Sandbox Init")         "cabal" ["sandbox", "init"]-        (ipdBuildDir package) (logSandbox package logLaunch)+        (ipdPackageDir package) (logSandbox package logLaunch)  chooseSandboxDir :: Window -> Maybe FilePath -> IO (Maybe FilePath) chooseSandboxDir window = chooseDir window (__ "Select sandbox folder")@@ -76,21 +104,21 @@             logLaunch <- getDefaultLogLaunch             runExternalTool' (__ "Sandbox Init")                 "cabal" ["sandbox", "init", "--sandbox=" <> T.pack dir]-                (ipdBuildDir package) (logSandbox package logLaunch)+                (ipdPackageDir package) (logSandbox package logLaunch)  sandboxDelete :: PackageAction-sandboxDelete = do+sandboxDelete = sandboxTry $  do     package <- ask     logLaunch <- getDefaultLogLaunch     runExternalTool' (__ "Sandbox Delete")         "cabal" ["sandbox", "delete"]-        (ipdBuildDir package) (logSandbox package logLaunch)+        (ipdPackageDir package) (logSandbox package logLaunch)  chooseSandboxSourceDir :: Window -> Maybe FilePath -> IO (Maybe FilePath) chooseSandboxSourceDir window = chooseDir window (__ "Select source folder")  sandboxAddSource :: Bool -> PackageAction-sandboxAddSource snapshot = do+sandboxAddSource snapshot = sandboxTry $ do     package <- ask     ws <- lift ask     let path = dropFileName (wsFile ws)@@ -102,5 +130,13 @@             logLaunch <- getDefaultLogLaunch             runExternalTool' (__ "Sandbox Add Source")                 "cabal" (["sandbox", "add-source", T.pack fp] ++ ["--snapshot" | snapshot])-                (ipdBuildDir package) (logSandbox package logLaunch)+                (ipdPackageDir package) (logSandbox package logLaunch)++sandboxDeleteSource :: FilePath -> PackageAction+sandboxDeleteSource dir = sandboxTry $ do+    package <- ask+    logLaunch <- getDefaultLogLaunch+    runExternalTool' (__ "Sandbox Delete Source")+        "cabal" ["sandbox", "delete-source", T.pack dir]+        (ipdPackageDir package) (logSandbox package logLaunch) 

@@ -24,7 +24,6 @@ ,   loadSession ,   loadSessionPrompt ,   viewFullScreen-,   viewDark ) where  import Prelude hiding (catch)@@ -49,7 +48,6 @@ import IDE.Pane.SourceBuffer import IDE.Pane.Info (InfoState(..), setInfoStyle) import IDE.Pane.Log (LogState(..))-import IDE.Pane.Preferences import IDE.Pane.PackageFlags import IDE.Pane.Search import IDE.Pane.Grep@@ -76,12 +74,13 @@ import qualified Data.Text as T (pack) import Data.Traversable (forM) import Data.Foldable (forM_)+import IDE.Preferences (applyInterfaceTheme)  -- --------------------------------------------------------------------- -- This needs to be incremented, when the session format changes -- theSessionVersion :: Int-theSessionVersion = 1+theSessionVersion = 2  -- --------------------------------------------------------------------- -- All pane types must be in here !@@ -91,7 +90,6 @@                     |   LogSt LogState                     |   InfoSt InfoState                     |   ModulesSt ModulesState-                    |   PrefsSt PrefsState                     |   FlagsSt FlagsState                     |   SearchSt SearchState                     |   FilesSt FilesState@@ -112,7 +110,6 @@ asPaneState s | isJust (cast s :: Maybe LogState)         =   LogSt (fromJust $ cast s) asPaneState s | isJust (cast s :: Maybe InfoState)        =   InfoSt (fromJust $ cast s) asPaneState s | isJust (cast s :: Maybe ModulesState)     =   ModulesSt (fromJust $ cast s)-asPaneState s | isJust (cast s :: Maybe PrefsState)       =   PrefsSt (fromJust $ cast s) asPaneState s | isJust (cast s :: Maybe FlagsState)       =   FlagsSt (fromJust $ cast s) asPaneState s | isJust (cast s :: Maybe SearchState)      =   SearchSt (fromJust $ cast s) asPaneState s | isJust (cast s :: Maybe FilesState)       =   FilesSt (fromJust $ cast s)@@ -133,7 +130,6 @@ recover pp (LogSt p)            =   void (recoverState pp p) recover pp (InfoSt p)           =   void (recoverState pp p) recover pp (ModulesSt p)        =   void (recoverState pp p)-recover pp (PrefsSt p)          =   void (recoverState pp p) recover pp (FlagsSt p)          =   void (recoverState pp p) recover pp (SearchSt p)         =   void (recoverState pp p) recover pp (FilesSt p)          =   void (recoverState pp p)@@ -171,7 +167,6 @@     ,   population          ::   [(Maybe PaneState,PanePath)]     ,   windowSize          ::   (Int,Int)     ,   fullScreen          ::   Bool-    ,   dark                ::   Bool     ,   completionSize      ::   (Int,Int)     ,   workspacePath       ::   Maybe FilePath     ,   activePaneN         ::   Maybe Text@@ -235,7 +230,6 @@                                 , (Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP BottomP])]     ,   windowSize          =   (1024,768)     ,   fullScreen          =   False-    ,   dark                =   False     ,   completionSize      =   (750,400)     ,   workspacePath       =   Nothing     ,   activePaneN         =   Nothing@@ -293,12 +287,6 @@             fullScreen             (\b a -> a{fullScreen = b})     ,   mkFieldS-            (paraName <<<- ParaName "Dark" $ emptyParams)-            (PP.text . show)-            readParser-            dark-            (\b a -> a{dark = b})-    ,   mkFieldS             (paraName <<<- ParaName "Completion size" $ emptyParams)             (PP.text . show)             (pairParser intParser)@@ -357,55 +345,49 @@  saveSessionAs :: FilePath -> Maybe FilePath ->  IDEAction saveSessionAs sessionPath mbSecondPath = do-    forget          <- getForgetSession-    if forget-        then ideMessage Normal (__ "Forget this session")-        else do-            sysMessage Normal (__ "Now saving session")-            bufs <- allBuffers-            case filter (\b -> bufferName b == "_Eval.hs") bufs of-                [IDEBuffer{sourceView = sv}] -> do-                    ebuf <- getBuffer sv-                    setModified ebuf False-                _     -> return ()-            wdw             <-  getMainWindow-            layout          <-  mkLayout-            population      <-  getPopulation-            size            <-  liftIO $ windowGetSize wdw-            fullScreen      <-  getFullScreenState-            dark            <-  getDarkState-            (completionSize,_) <- readIDE completion-            mbWs            <-  readIDE workspace-            activePane'     <-  getActivePane-            let activeP =   case activePane' of-                                Nothing -> Nothing-                                Just (s,_) -> Just s-            (toolbarVisible,_)  <- readIDE toolbar-            findState       <- getFindState-            (findbarVisible,_)  <- readIDE findbar-            timeNow         <- liftIO getClockTime-            recentFiles'      <- readIDE recentFiles-            recentWorkspaces' <- readIDE recentWorkspaces-            let state = SessionState {-                sessionVersion      =   theSessionVersion-            ,   saveTime            =   T.pack $ show timeNow-            ,   layoutS             =   layout-            ,   population          =   population-            ,   windowSize          =   size-            ,   fullScreen          =   fullScreen-            ,   dark                =   dark-            ,   completionSize      =   completionSize-            ,   workspacePath       =   case mbWs of-                                            Nothing -> Nothing-                                            Just ws -> Just (wsFile ws)-            ,   activePaneN         =   activeP-            ,   toolbarVisibleS     =   toolbarVisible-            ,   findbarState        =   (findbarVisible,findState)-            ,   recentOpenedFiles   =   recentFiles'-            ,   recentOpenedWorksp  =   recentWorkspaces'}-            liftIO $ writeFields sessionPath state sessionDescr-            when (isJust mbSecondPath) $-                liftIO $ writeFields (fromJust mbSecondPath) state sessionDescr+    sysMessage Normal (__ "Now saving session")+    bufs <- allBuffers+    case filter (\b -> bufferName b == "_Eval.hs") bufs of+        [IDEBuffer{sourceView = sv}] -> do+            ebuf <- getBuffer sv+            setModified ebuf False+        _     -> return ()+    wdw             <-  getMainWindow+    layout          <-  mkLayout+    population      <-  getPopulation+    size            <-  liftIO $ windowGetSize wdw+    fullScreen      <-  getFullScreenState+    (completionSize,_) <- readIDE completion+    mbWs            <-  readIDE workspace+    activePane'     <-  getActivePane+    let activeP =   case activePane' of+                        Nothing -> Nothing+                        Just (s,_) -> Just s+    (toolbarVisible,_)  <- readIDE toolbar+    findState       <- getFindState+    (findbarVisible,_)  <- readIDE findbar+    timeNow         <- liftIO getClockTime+    recentFiles'      <- readIDE recentFiles+    recentWorkspaces' <- readIDE recentWorkspaces+    let state = SessionState {+        sessionVersion      =   theSessionVersion+    ,   saveTime            =   T.pack $ show timeNow+    ,   layoutS             =   layout+    ,   population          =   population+    ,   windowSize          =   size+    ,   fullScreen          =   fullScreen+    ,   completionSize      =   completionSize+    ,   workspacePath       =   case mbWs of+                                    Nothing -> Nothing+                                    Just ws -> Just (wsFile ws)+    ,   activePaneN         =   activeP+    ,   toolbarVisibleS     =   toolbarVisible+    ,   findbarState        =   (findbarVisible,findState)+    ,   recentOpenedFiles   =   recentFiles'+    ,   recentOpenedWorksp  =   recentWorkspaces'}+    liftIO $ writeFields sessionPath state sessionDescr+    when (isJust mbSecondPath) $+        liftIO $ writeFields (fromJust mbSecondPath) state sessionDescr  saveSessionAsPrompt :: IDEAction saveSessionAsPrompt = do@@ -583,8 +565,7 @@                                         recentWorkspaces = recentOpenedWorksp sessionSt})         setFullScreenState (fullScreen sessionSt)         viewFullScreen-        setDarkState (dark sessionSt)-        viewDark+        applyInterfaceTheme         liftIO $ debugM "leksah" "recoverSession done"         return (toolbarVisibleS sessionSt, (fst . findbarState) sessionSt))         (\ (e :: SomeException) -> do@@ -654,31 +635,4 @@         (Nothing, _)         -> return ()         (Just window, True)  -> liftIO $ windowFullscreen window         (Just window, False) -> liftIO $ windowUnfullscreen window--viewDark :: IDEAction-viewDark = getDarkState >>= setDark--getActiveSettings :: PaneMonad alpha => alpha (Maybe Settings)-getActiveSettings = do-    mbScreen <- getActiveScreen-    case mbScreen of-        Nothing -> return Nothing-        Just screen -> liftIO $ Just <$> settingsGetForScreen screen--setDark :: Bool -> IDEM ()-setDark dark = do-    setInfoStyle-    fillErrorList False-    prefs <- readIDE prefs-    buffers <- allBuffers-    mapM_ updateStyle' buffers-    mbSettings <- getActiveSettings-    case mbSettings of-        Just settings -> liftIO $ settingsSetLongProperty-                            settings-                            ("gtk-application-prefer-dark-theme" :: Text)-                            (if dark then 1 else 0)-                            "Leksah"-        Nothing -> return ()-