diff --git a/data/leksah.menu b/data/leksah.menu --- a/data/leksah.menu +++ b/data/leksah.menu @@ -82,6 +82,7 @@ + @@ -119,7 +120,6 @@ - diff --git a/data/prefs.lkshp b/data/prefs.lkshp --- a/data/prefs.lkshp +++ b/data/prefs.lkshp @@ -18,13 +18,25 @@ --Pair with True or False for use and name of a candy file in a config dir Editor Style: "leksah" Found Text Background: - Color 50372 41120 0 + Color 65535 65535 32768 Selection Match Text Background: - Color 32768 32768 32768 + Color 42064 55923 28520 Execution Context Text Background: - Color 31675 10875 10875 + Color 65535 46529 46529 Breakpoint Text Background: - Color 20752 15778 6640 + Color 64879 51921 28114 +Lint Text Background: + Color 60000 65535 60000 +Found Text Dark Background: + Color 30364 29149 0 +Selection Match Text Dark Background: + Color 18021 29927 6384 +Execution Context Text Dark Background: + Color 20000 16000 16000 +Breakpoint Text Dark Background: + Color 15000 5000 5000 +Lint Text Dark Background: + Color 0 15000 0 Text Editor: "GtkSourceView" LogView Font: "Sans 12" Window default size: diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -1,5 +1,5 @@ name: leksah -version: 0.15.0.6 +version: 0.15.1.0 cabal-version: >=1.18 build-type: Simple license: GPL @@ -11,346 +11,435 @@ package-url: http://code.haskell.org/leksah bug-reports: http://code.google.com/p/leksah/issues/list synopsis: Haskell IDE written in Haskell -description: An Integrated Development Environment for Haskell written in Haskell. +description: + An Integrated Development Environment for Haskell written in Haskell. category: Development, IDE, Editor author: Juergen Nicklisch-Franken, Hamish Mackenzie -tested-with: GHC == 7.2.2 -data-files: LICENSE - Readme.md - - data/current.lkshs - data/candy.lkshc - data/candy-hasklig.lkshc - data/keymap.lkshk - data/leksah.menu - data/svn.menu - data/git.menu - data/prefs.lkshp - data/prefscoll.lkshp - data/emacs.lkshk - data/LICENSE - data/main.lksht - data/testmain.lksht - data/module.lksht - data/welcome.txt - data/leksah-welcome/Setup.lhs - data/leksah-welcome/leksah-welcome.cabal - data/leksah-welcome/LICENSE - data/leksah-welcome/src/Main.hs - data/leksah-welcome/test/Main.hs - data/empty.lkshs - data/.gtkrc-2.0 - data/styles/leksah.xml - data/styles/leksah-dark.xml - - language-specs/cabal.lang - language-specs/haskell.lang - language-specs/haskell-literate.lang - language-specs/hamlet.lang - language-specs/cassius.lang - language-specs/lucius.lang - language-specs/julius.lang - language-specs/jmacro.lang - - pics/ide_class.png - pics/ide_configure.png - pics/ide_data.png - pics/ide_error_next.png - pics/ide_error_prev.png - pics/ide_function.png - pics/ide_instance.png - pics/ide_konstructor.png - pics/ide_make.png - pics/ide_method.png - pics/ide_newtype.png - pics/ide_other.png - pics/ide_reexported.png - pics/ide_rule.png - pics/ide_run.png - pics/ide_slot.png - pics/ide_source.png - pics/ide_source_local.png - pics/ide_type.png - pics/leksah.png - pics/ide_step.png - pics/ide_local.png - pics/ide_module.png - pics/ide_continue.png - pics/ide_debug.png - pics/ide_clean.png - pics/ide_build.png - pics/ide_link.png - pics/ide_rebuild_meta.png - pics/ide_empty.png - pics/ide_js.png - - doc/Keybindings.svg - doc/leksah_manual.lyx - doc/screenshots2/screenshot_buffer_menu.png - doc/screenshots2/screenshot_completion.png - doc/screenshots2/screenshot_config_menu.png - doc/screenshots2/screenshot_construct_module.png - doc/screenshots2/screenshot_debug_menu.png - doc/screenshots2/screenshot_debug_pane.png - doc/screenshots2/screenshot_edit_menu.png - doc/screenshots2/screenshot_error_pane.png - doc/screenshots2/screenshot_file_menu.png - doc/screenshots2/screenshot_findbar.png - doc/screenshots2/screenshot_first_start.png - doc/screenshots2/screenshot_grep.png - doc/screenshots2/screenshot_help_menu.png - doc/screenshots2/screenshot_metadata_prefs.png - doc/screenshots2/screenshot_module_browser.png - doc/screenshots2/screenshot_package_editor_1.png - doc/screenshots2/screenshot_package_flags.png - doc/screenshots2/screenshot_package_menu.png - doc/screenshots2/screenshot_panes_menu.png - doc/screenshots2/screenshot_prefs_editor.png - doc/screenshots2/screenshot_serach_pane.png - doc/screenshots2/screenshot_source_candy.png - doc/screenshots2/screenshot_view_menu.png - doc/screenshots2/screenshot_welcome.png - doc/screenshots2/screenshot_workspace_menu.png - - scripts/clean.sh - scripts/stage.sh - osx/bundle.sh - osx/gtk2.sh - osx/gtk.sh - osx/Info.plist - osx/launcher.sh - osx/leksah.bundle - osx/leksah.icns - osx/makedmg.sh - osx/makedmgs.sh - osx/osxkeymap.lkshk - osx/settings.ini - win32/gtk2hsall.sh - win32/gtkrc - win32/leksah.bat - win32/leksah.ico - win32/leksah.nsi - win32/leksah-rebuild-metadata.bat - win32/leksah-server.bat - win32/makeinstaller.sh - win32/makeinstallers.sh - win32/recache.sh - linux/applications/leksah.desktop - linux/applications/leksah.xml - linux/icons/hicolor/48x48/apps/leksah_48x48.png - linux/specfiles/fedora/12/ghc-binary-shared.spec - linux/specfiles/fedora/12/ghc-deepseq.spec - linux/specfiles/fedora/12/ghc-hslogger.spec - linux/specfiles/fedora/12/ghc-ltk.spec - linux/specfiles/fedora/12/ghc-process-leksah.spec - linux/specfiles/fedora/12/ghc-regex-base.spec - linux/specfiles/fedora/12/ghc-regex-tdfa.spec - linux/specfiles/fedora/12/leksah_server.spec - linux/specfiles/fedora/12/leksah.spec - linux/specfiles/fedora/13/ghc-binary-shared.spec - linux/specfiles/fedora/13/ghc-hslogger.spec - linux/specfiles/fedora/13/ghc-ltk.spec - linux/specfiles/fedora/13/ghc-process-leksah.spec - linux/specfiles/fedora/13/ghc-regex-tdfa.spec - linux/specfiles/fedora/13/haddock.spec - linux/specfiles/fedora/13/leksah-server.spec - linux/specfiles/fedora/13/leksah.spec - linux/specfiles/fedora/14/ghc-binary-shared.spec - linux/specfiles/fedora/14/ghc-haddock.spec - linux/specfiles/fedora/14/ghc-ltk.spec - linux/specfiles/fedora/14/ghc-process-leksah.spec - linux/specfiles/fedora/14/ghc-regex-tdfa.spec - linux/specfiles/fedora/14/leksah-server.spec - linux/specfiles/fedora/14/leksah.spec - linux/specfiles/fedora/14/leksah.spec-darcs-backup0 - linux/specfiles/fedora/14/leksah.spec-darcs-backup1 - -data-dir: "" -extra-source-files: Setup.lhs SetupLocale.lhs po/*.pot po/*.po - -x-gettext-po-files: po/*.po -x-gettext-domain-name: leksah - -extra-tmp-files: +tested-with: GHC ==7.2.2 +data-files: + LICENSE + Readme.md + data/current.lkshs + data/candy.lkshc + data/candy-hasklig.lkshc + data/keymap.lkshk + data/leksah.menu + data/svn.menu + data/git.menu + data/prefs.lkshp + data/prefscoll.lkshp + data/emacs.lkshk + data/LICENSE + data/main.lksht + data/testmain.lksht + data/module.lksht + data/welcome.txt + data/leksah-welcome/Setup.lhs + data/leksah-welcome/leksah-welcome.cabal + data/leksah-welcome/LICENSE + data/leksah-welcome/src/Main.hs + data/leksah-welcome/test/Main.hs + data/empty.lkshs + data/.gtkrc-2.0 + data/styles/leksah.xml + data/styles/leksah-dark.xml + language-specs/cabal.lang + language-specs/haskell.lang + language-specs/haskell-literate.lang + language-specs/hamlet.lang + language-specs/cassius.lang + language-specs/lucius.lang + language-specs/julius.lang + language-specs/jmacro.lang + pics/ide_class.png + pics/ide_configure.png + pics/ide_data.png + pics/ide_error_next.png + pics/ide_error_prev.png + pics/ide_function.png + pics/ide_instance.png + pics/ide_konstructor.png + pics/ide_make.png + pics/ide_method.png + pics/ide_newtype.png + pics/ide_other.png + pics/ide_reexported.png + pics/ide_rule.png + pics/ide_run.png + pics/ide_slot.png + pics/ide_source.png + pics/ide_source_local.png + pics/ide_type.png + pics/leksah.png + pics/ide_step.png + pics/ide_local.png + pics/ide_module.png + pics/ide_continue.png + pics/ide_debug.png + pics/ide_clean.png + pics/ide_build.png + pics/ide_link.png + pics/ide_rebuild_meta.png + pics/ide_empty.png + pics/ide_js.png + doc/Keybindings.svg + doc/leksah_manual.lyx + doc/screenshots2/screenshot_buffer_menu.png + doc/screenshots2/screenshot_completion.png + doc/screenshots2/screenshot_config_menu.png + doc/screenshots2/screenshot_construct_module.png + doc/screenshots2/screenshot_debug_menu.png + doc/screenshots2/screenshot_debug_pane.png + doc/screenshots2/screenshot_edit_menu.png + doc/screenshots2/screenshot_error_pane.png + doc/screenshots2/screenshot_file_menu.png + doc/screenshots2/screenshot_findbar.png + doc/screenshots2/screenshot_first_start.png + doc/screenshots2/screenshot_grep.png + doc/screenshots2/screenshot_help_menu.png + doc/screenshots2/screenshot_metadata_prefs.png + doc/screenshots2/screenshot_module_browser.png + doc/screenshots2/screenshot_package_editor_1.png + doc/screenshots2/screenshot_package_flags.png + doc/screenshots2/screenshot_package_menu.png + doc/screenshots2/screenshot_panes_menu.png + doc/screenshots2/screenshot_prefs_editor.png + doc/screenshots2/screenshot_serach_pane.png + doc/screenshots2/screenshot_source_candy.png + doc/screenshots2/screenshot_view_menu.png + doc/screenshots2/screenshot_welcome.png + doc/screenshots2/screenshot_workspace_menu.png + scripts/clean.sh + scripts/stage.sh + osx/bundle.sh + osx/gtk2.sh + osx/gtk.sh + osx/Info.plist + osx/launcher.sh + osx/leksah.bundle + osx/leksah.icns + osx/makedmg.sh + osx/makedmgs.sh + osx/osxkeymap.lkshk + osx/settings.ini + win32/gtk2hsall.sh + win32/gtkrc + win32/leksah.bat + win32/leksah.ico + win32/leksah.nsi + win32/leksah-rebuild-metadata.bat + win32/leksah-server.bat + win32/makeinstaller.sh + win32/makeinstallers.sh + win32/recache.sh + linux/applications/leksah.desktop + linux/applications/leksah.xml + linux/icons/hicolor/48x48/apps/leksah_48x48.png + linux/specfiles/fedora/12/ghc-binary-shared.spec + linux/specfiles/fedora/12/ghc-deepseq.spec + linux/specfiles/fedora/12/ghc-hslogger.spec + linux/specfiles/fedora/12/ghc-ltk.spec + linux/specfiles/fedora/12/ghc-process-leksah.spec + linux/specfiles/fedora/12/ghc-regex-base.spec + linux/specfiles/fedora/12/ghc-regex-tdfa.spec + linux/specfiles/fedora/12/leksah_server.spec + linux/specfiles/fedora/12/leksah.spec + linux/specfiles/fedora/13/ghc-binary-shared.spec + linux/specfiles/fedora/13/ghc-hslogger.spec + linux/specfiles/fedora/13/ghc-ltk.spec + linux/specfiles/fedora/13/ghc-process-leksah.spec + linux/specfiles/fedora/13/ghc-regex-tdfa.spec + linux/specfiles/fedora/13/haddock.spec + linux/specfiles/fedora/13/leksah-server.spec + linux/specfiles/fedora/13/leksah.spec + linux/specfiles/fedora/14/ghc-binary-shared.spec + linux/specfiles/fedora/14/ghc-haddock.spec + linux/specfiles/fedora/14/ghc-ltk.spec + linux/specfiles/fedora/14/ghc-process-leksah.spec + linux/specfiles/fedora/14/ghc-regex-tdfa.spec + linux/specfiles/fedora/14/leksah-server.spec + linux/specfiles/fedora/14/leksah.spec + linux/specfiles/fedora/14/leksah.spec-darcs-backup0 + linux/specfiles/fedora/14/leksah.spec-darcs-backup1 +extra-source-files: + Setup.lhs + SetupLocale.lhs + po/*.pot + po/*.po +x-gettext-po-files: po/*.po +x-gettext-domain-name: leksah source-repository head - type: git - location: https://github.com/leksah/leksah + type: git + location: https://github.com/leksah/leksah flag yi - Description: Experimental Yi support - Default: False + description: + Experimental Yi support + default: False flag dyre - Description: Experimental Yi support - Default: True + description: + Experimental Yi support flag threaded - description: Build with support for multithreaded execution - default: False + description: + Build with support for multithreaded execution flag loc - Description: Experimental localization support - Default: False + description: + Experimental localization support + default: False flag network-uri - description: Get Network.URI from the network-uri package - default: True + description: + Get Network.URI from the network-uri package library + if os(windows) - build-depends: Win32 >=2.2.0.0 && <2.4 - extra-libraries: kernel32 + build-depends: + Win32 >=2.2.0.0 && <2.4 + extra-libraries: + kernel32 else - build-depends: unix >=2.3.1.0 && <2.8 + build-depends: + unix >=2.3.1.0 && <2.8 if os(osx) - build-depends: gtk3-mac-integration >= 0.3.0.0 && <0.4 + build-depends: + gtk3-mac-integration >=0.3.0.0 && <0.4 if flag(yi) - build-depends: yi >=0.11.2 && <0.12, - yi-language >=0.1.0.8 && <0.2, - yi-rope >=0.7.0.0 && <0.8 + build-depends: + yi >=0.11.2 && <0.12, + yi-language >=0.1.0.8 && <0.2, + yi-rope >=0.7.0.0 && <0.8 cpp-options: -DLEKSAH_WITH_YI - if flag(yi) && flag(dyre) - build-depends: dyre >= 0.8.3 && <0.9 + if (flag(yi) && flag(dyre)) + build-depends: + dyre >=0.8.3 && <0.9 cpp-options: -DLEKSAH_WITH_YI_DYRE - build-depends: gtk3 >=0.13.8 && <0.14, - gtksourceview3 >=0.13.1.5 && <0.14, - webkitgtk3 >=0.13 && <0.14, - webkitgtk3-javascriptcore -any - cpp-options: -DMIN_VERSION_gtk=MIN_VERSION_gtk3 - - build-depends: jsaddle -any, ghcjs-codemirror -any, hamlet -any, blaze-html -any, - lens -any, pretty-show >=1.6.3 && <1.7 - cpp-options: -DWEBKITGTK -DLEKSAH_WITH_CODE_MIRROR - - if flag(loc) && os(linux) + if (flag(loc) && os(linux)) + build-depends: + hgettext -any, + setlocale -any cpp-options: -DLOCALIZATION - build-depends: hgettext, setlocale if flag(network-uri) - build-depends: network-uri >=2.6 && <2.7, network >= 2.6 && <2.7 + build-depends: + network-uri >=2.6 && <2.7, + network >=2.6 && <2.7 else - build-depends: network >=2.2 && <2.6 + build-depends: + network >=2.2 && <2.6 - hs-source-dirs: src + if impl(ghc >=7.2) + build-depends: + binary-shared >=0.8.2 + exposed-modules: + IDE.HLint + IDE.Leksah + IDE.Completion + IDE.ImportTool + IDE.Find + IDE.Sandbox + IDE.Session + IDE.Command + IDE.Keymap + IDE.Utils.GUIUtils + IDE.SymbolNavigation + IDE.Package + IDE.YiConfig + IDE.OSX + IDE.GUIHistory + IDE.SourceCandy + IDE.NotebookFlipper + IDE.Core.Types + IDE.Core.State + IDE.Metainfo.Provider + IDE.Pane.Preferences + IDE.Pane.PackageEditor + IDE.Pane.HLint + IDE.Pane.Info + IDE.Pane.Log + IDE.Pane.SourceBuffer + IDE.Pane.Modules + IDE.Pane.Search + IDE.Pane.PackageFlags + IDE.LogRef + IDE.Debug + IDE.Pane.Grep + IDE.Pane.Files + IDE.Pane.Breakpoints + IDE.Pane.Trace + IDE.Pane.Variables + IDE.Pane.Errors + IDE.TextEditor + IDE.Workspaces + IDE.Workspaces.Writer + IDE.Statusbar + IDE.Pane.Workspace + IDE.PaneGroups + IDE.Utils.ServerConnection + IDE.BufferMode + IDE.Build + IDE.Command.VCS + IDE.Command.VCS.Common + IDE.Command.VCS.SVN + IDE.Command.VCS.GIT + IDE.Command.VCS.Mercurial + IDE.Command.VCS.Common.Workspaces + IDE.Command.VCS.Common.GUI + IDE.Command.VCS.Common.Helper + IDE.Command.VCS.Types + IDE.Command.Print + IDE.Pane.WebKit.Documentation + IDE.Pane.WebKit.Inspect + IDE.Pane.WebKit.Output + IDE.TextEditor.Class + IDE.TextEditor.CodeMirror + IDE.TextEditor.Yi + IDE.TextEditor.GtkSourceView + IDE.Utils.ExternalTool + build-depends: + gtk3 >=0.13.9 && <0.14, + gtksourceview3 >=0.13.1.5 && <0.14, + webkitgtk3 >=0.13 && <0.14, + webkitgtk3-javascriptcore -any, + jsaddle -any, + ghcjs-codemirror -any, + hamlet -any, + blaze-html -any, + lens -any, + pretty-show >=1.6.3 && <1.7, + Cabal >=1.10.2.0 && <1.23, + base >=4.0.0.0 && <4.9, + binary >=0.5.0.0 && <0.8, + bytestring >=0.9.0.1 && <0.11, + containers >=0.2.0.0 && <0.6, + directory >=1.0.0.2 && <3.1, + filepath >=1.1.0.1 && <1.5, + glib >=0.13.0.0 && <0.14, + mtl >=1.1.0.2 && <2.3, + old-time >=1.0.0.1 && <1.2, + parsec >=2.1.0.1 && <3.2, + pretty >=1.0.1.0 && <1.2, + regex-tdfa >=1.1 && <1.3, + regex-tdfa-text -any, + regex-base ==0.93.*, + utf8-string >=0.3.1.1 && <1.1, + array >=0.2.0.0 && <0.6, + time >=0.1 && <1.6, + ltk >=0.15.0.1 && <0.16, + binary-shared >=0.8 && <0.9, + deepseq >=1.1.0.0 && <1.5, + hslogger >=1.0.7 && <1.3, + leksah-server >=0.15.0.4 && <0.16, + ghc >=6.10.1 && <7.11, + strict >=0.3.2 && <0.4, + conduit >=1.0.8 && <1.3, + text >=0.11.1.5 && <1.3, + gio >=0.13.0.0 && <0.14, + transformers >=0.2.2.0 && <0.5, + executable-path >=0.0.3 && <0.1, + 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, + 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: -DMIN_VERSION_gtk=MIN_VERSION_gtk3 -DWEBKITGTK + -DLEKSAH_WITH_CODE_MIRROR default-language: Haskell98 - - build-depends: Cabal >=1.10.2.0 && <1.23, base >=4.0.0.0 && <4.9, binary >=0.5.0.0 && <0.8, - bytestring >=0.9.0.1 && <0.11, containers >=0.2.0.0 && <0.6, directory >=1.0.0.2 && <3.1, - filepath >=1.1.0.1 && <1.5, glib >=0.13.0.0 && <0.14, - mtl >=1.1.0.2 && <2.3, old-time >=1.0.0.1 && <1.2, - parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2, - regex-tdfa >=1.1 && <1.3, regex-tdfa-text, regex-base ==0.93.*, utf8-string >=0.3.1.1 && <1.1, array >=0.2.0.0 && <0.6, - time >=0.1 && <1.6, ltk >= 0.15.0.1 && <0.16, binary-shared >= 0.8 && <0.9, deepseq >= 1.1.0.0 && <1.5, - hslogger >= 1.0.7 && <1.3, leksah-server >=0.15.0.4 && <0.16, - ghc >=6.10.1 && <7.11, strict >= 0.3.2 && <0.4, conduit >= 1.0.8 && <1.3, text >= 0.11.1.5 && < 1.3, - gio >=0.13.0.0 && <0.14, transformers >=0.2.2.0 && <0.5, - executable-path >=0.0.3 && <0.1, - 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, - hlint >=1.9.21 && <1.10, vado >=0.0.1 && <0.1, shakespeare >=2.0.0.1 && <2.1, - cpphs >=1.19 && <1.20 - exposed-modules: IDE.Leksah IDE.Completion IDE.ImportTool IDE.Find - IDE.Sandbox IDE.Session IDE.Command IDE.Keymap IDE.Utils.GUIUtils - IDE.SymbolNavigation IDE.Package IDE.YiConfig IDE.OSX - IDE.GUIHistory IDE.SourceCandy IDE.NotebookFlipper IDE.Core.Types - IDE.Core.State IDE.Metainfo.Provider IDE.Pane.Preferences - IDE.Pane.PackageEditor IDE.Pane.Info IDE.Pane.Log - IDE.Pane.SourceBuffer IDE.Pane.Modules IDE.Pane.Search - IDE.Pane.PackageFlags IDE.LogRef IDE.Debug IDE.Pane.Grep - IDE.Pane.Files IDE.Pane.HLint IDE.Pane.Breakpoints IDE.Pane.Trace - IDE.Pane.Variables IDE.Pane.Errors IDE.TextEditor IDE.Workspaces - IDE.Workspaces.Writer IDE.Statusbar IDE.Pane.Workspace - IDE.PaneGroups IDE.Utils.ServerConnection IDE.BufferMode IDE.Build - IDE.Command.VCS IDE.Command.VCS.Common IDE.Command.VCS.SVN - IDE.Command.VCS.GIT IDE.Command.VCS.Mercurial - IDE.Command.VCS.Common.Workspaces IDE.Command.VCS.Common.GUI - IDE.Command.VCS.Common.Helper IDE.Command.VCS.Types - IDE.Command.Print IDE.Pane.WebKit.Documentation - IDE.Pane.WebKit.Inspect - IDE.Pane.WebKit.Output IDE.TextEditor.Class - IDE.TextEditor.CodeMirror IDE.TextEditor.Yi - IDE.TextEditor.GtkSourceView IDE.Utils.ExternalTool - - if (impl(ghc >= 7.2)) - build-depends: binary-shared >=0.8.2 - - other-modules: Paths_leksah + hs-source-dirs: src + other-modules: + Paths_leksah ghc-options: -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans -Executable leksah +executable leksah + if os(windows) - build-depends: Win32 >=2.2.0.0 && <2.4 - extra-libraries: kernel32 + build-depends: + Win32 >=2.2.0.0 && <2.4 + extra-libraries: + kernel32 if flag(yi) cpp-options: -DLEKSAH_WITH_YI - if flag(yi) && flag(dyre) + if (flag(yi) && flag(dyre)) cpp-options: -DLEKSAH_WITH_DYRE if flag(threaded) ghc-options: -threaded - hs-source-dirs: main - build-depends: leksah == 0.15.0.6, - base >= 4.0.0.0 && <=4.9, - gtk3 >=0.13.2 && <0.14 - if os(linux) && flag(loc) + if (os(linux) && flag(loc)) + build-depends: + hgettext -any, + setlocale -any cpp-options: -DLOCALIZATION - build-depends: hgettext, setlocale if os(osx) ghc-options: -optl-headerpad_max_install_names - - default-language: Haskell98 main-is: Main.hs - buildable: True + build-depends: + leksah ==0.15.1.0, + base >=4.0.0.0 && <=4.9, + gtk3 >=0.13.9 && <0.14, + stm >=2.4.4 && <2.5 + default-language: Haskell98 + hs-source-dirs: main ghc-options: -rtsopts -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans executable bewleksah - build-depends: leksah ==0.15.0.6, - base >=4.0.0.0 && <=4.9, - jsaddle -any, - ghcjs-dom -any, - gtk3 >=0.13.8 && <0.14, - gtksourceview3 >=0.13.1.5 && <0.14, - webkitgtk3 >=0.13 && <0.14, - webkitgtk3-javascriptcore -any - cpp-options: -DMIN_VERSION_gtk=MIN_VERSION_gtk3 - main-is: Main.hs - buildable: True + build-depends: + leksah ==0.15.1.0, + base >=4.0.0.0 && <=4.9, + jsaddle -any, + ghcjs-dom -any, + gtk3 >=0.13.9 && <0.14, + gtksourceview3 >=0.13.1.5 && <0.14, + webkitgtk3 >=0.13 && <0.14, + webkitgtk3-javascriptcore -any, + stm >=2.4.4 && <2.5 + cpp-options: -DMIN_VERSION_gtk=MIN_VERSION_gtk3 default-language: Haskell2010 hs-source-dirs: bew test-suite tests - build-depends: base >=4.0.0.0 && <4.9, - Cabal >=1.10.2.0 && <1.23, - QuickCheck >=2.4.2 && <2.9, - leksah ==0.15.0.6, - containers, - ltk, - leksah-server, - hslogger, - transformers, - glib, - monad-loops, - text, - gtk3 >=0.13.8 && <0.14, - gtksourceview3 >=0.13.1.5 && <0.14, - webkitgtk3 -any - cpp-options: -DMIN_VERSION_gtk=MIN_VERSION_gtk3 + if flag(yi) - build-depends: yi + build-depends: + yi -any type: exitcode-stdio-1.0 main-is: Tests.hs - other-modules: IDE.TextEditor.Tests - buildable: True + build-depends: + base >=4.0.0.0 && <4.9, + Cabal >=1.10.2.0 && <1.23, + QuickCheck >=2.4.2 && <2.9, + leksah ==0.15.1.0, + containers -any, + ltk -any, + leksah-server -any, + hslogger -any, + transformers -any, + glib -any, + monad-loops -any, + text -any, + gtk3 >=0.13.9 && <0.14, + gtksourceview3 >=0.13.1.5 && <0.14, + webkitgtk3 -any, + stm >=2.4.4 && <2.5 + cpp-options: -DMIN_VERSION_gtk=MIN_VERSION_gtk3 default-language: Haskell2010 hs-source-dirs: tests + other-modules: + IDE.TextEditor.Tests ghc-options: -threaded diff --git a/src/IDE/BufferMode.hs b/src/IDE/BufferMode.hs --- a/src/IDE/BufferMode.hs +++ b/src/IDE/BufferMode.hs @@ -138,7 +138,10 @@ doForSelectedLines :: [a] -> (forall editor. TextEditor editor => EditorBuffer editor -> Int -> IDEM a) -> IDEM [a] doForSelectedLines d f = inActiveBufContext d $ \_ _ ebuf currentBuffer _ -> do (start,end) <- getStartAndEndLineOfSelection ebuf - mapM (f ebuf) [start .. end] + beginUserAction ebuf + result <- mapM (f ebuf) [start .. end] + endUserAction ebuf + return result -- * Buffer Modes diff --git a/src/IDE/Command.hs b/src/IDE/Command.hs --- a/src/IDE/Command.hs +++ b/src/IDE/Command.hs @@ -69,6 +69,7 @@ import IDE.Pane.PackageEditor import IDE.Pane.Errors import IDE.Package +import IDE.HLint import IDE.Sandbox import IDE.Pane.Log import IDE.Pane.Modules @@ -99,7 +100,6 @@ import IDE.PaneGroups import IDE.Pane.Search (getSearch, IDESearch(..)) import IDE.Pane.Grep (getGrep) -import IDE.Pane.HLint (refreshHLint, getHLint) import IDE.Pane.WebKit.Documentation (getDocumentation) import IDE.Pane.WebKit.Output (getOutputPane) import IDE.Pane.WebKit.Inspect (getInspectPane) @@ -280,6 +280,8 @@ (packageTry packageInstallDependencies) [] False ,AD "RegisterPackage" (__ "_Register") Nothing Nothing (packageTry packageRegister) [] False + ,AD "HLintPackage" (__ "_HLint") Nothing Nothing + (packageTry packageHLint) [] False ,AD "TestPackage" (__ "Test") Nothing Nothing (packageTry packageTest) [] False ,AD "SdistPackage" (__ "Source Dist") Nothing Nothing @@ -397,8 +399,6 @@ (getFiles Nothing >>= \ p -> displayPane p False >> refreshFiles) [] False ,AD "ShowGrep" (__ "Grep") Nothing Nothing (getGrep Nothing >>= \ p -> displayPane p False) [] False - ,AD "ShowHLint" (__ "HLint") Nothing Nothing - (getHLint Nothing >>= \ p -> displayPane p False >> workspaceTry refreshHLint) [] False ,AD "ShowDocumentation" (__ "Documentation") Nothing Nothing (getDocumentation Nothing >>= \ p -> displayPane p False) [] False ,AD "ShowOutput" (__ "Output") Nothing Nothing @@ -937,6 +937,10 @@ (\ e@(GetTextPopup _) -> return (GetTextPopup (Just textPopupMenu))) registerEvent stRef "StatusbarChanged" (\ e@(StatusbarChanged args) -> changeStatusbar args >> return e) + registerEvent stRef "SelectSrcSpan" + (\ e@(SelectSrcSpan mbSpan) -> selectMatchingErrors mbSpan >> return e) + registerEvent stRef "SavedFile" + (\ e@(SavedFile file) -> scheduleHLint (Right file) >> return e) return () diff --git a/src/IDE/Core/State.hs b/src/IDE/Core/State.hs --- a/src/IDE/Core/State.hs +++ b/src/IDE/Core/State.hs @@ -34,6 +34,7 @@ , isStartingOrClosing , triggerEventIDE +, triggerEventIDE_ , deactivatePane @@ -255,7 +256,7 @@ window = head . windows errorRefs :: IDE -> [LogRef] -errorRefs = filter ((\ t -> t == ErrorRef || t == WarningRef || t == LintRef || t == TestFailureRef) . logRefType) . +errorRefs = filter ((`elem` [ErrorRef, WarningRef, LintRef, TestFailureRef]) . logRefType) . allLogRefs breakpointRefs :: IDE -> [LogRef] diff --git a/src/IDE/Core/Types.hs b/src/IDE/Core/Types.hs --- a/src/IDE/Core/Types.hs +++ b/src/IDE/Core/Types.hs @@ -136,6 +136,7 @@ import qualified Data.Text as T (unpack) import Language.Haskell.HLint3 (Idea(..)) import Data.Function (on) +import Control.Concurrent.STM.TVar (TVar) -- --------------------------------------------------------------------- -- IDE State @@ -175,6 +176,7 @@ , yiControl :: Yi.Control , serverQueue :: Maybe (MVar (ServerCommand, ServerAnswer -> IDEM ())) , server :: Maybe Handle +, hlintQueue :: Maybe (TVar [Either FilePath FilePath]) , vcsData :: (Map FilePath MenuItem, Maybe (Maybe Text)) -- menus for packages, password , logLaunches :: Map.Map Text LogLaunchData , autoCommand :: IDEAction @@ -294,6 +296,8 @@ | GetTextPopup (Maybe (IDERef -> Menu -> IO ())) | StatusbarChanged [StatusbarCompartment] | WorkspaceChanged Bool Bool -- ^ showPane updateFileCache + | SelectSrcSpan (Maybe SrcSpan) + | SavedFile FilePath instance Event IDEEvent Text where getSelector (InfoChanged _) = "InfoChanged" @@ -318,6 +322,8 @@ getSelector (GetTextPopup _) = "GetTextPopup" getSelector (StatusbarChanged _) = "StatusbarChanged" getSelector (WorkspaceChanged _ _) = "WorkspaceChanged" + getSelector (SelectSrcSpan _) = "SelectSrcSpan" + getSelector (SavedFile _) = "SavedFile" instance EventSource IDERef IDEEvent IDEM Text where canTriggerEvent _ "InfoChanged" = True @@ -344,6 +350,8 @@ canTriggerEvent _ "GetTextPopup" = True canTriggerEvent _ "StatusbarChanged" = True canTriggerEvent _ "WorkspaceChanged" = True + canTriggerEvent _ "SelectSrcSpan" = True + canTriggerEvent _ "SavedFile" = True canTriggerEvent _ _ = False getHandlers ideRef = do ide <- liftIO $ readIORef ideRef @@ -454,10 +462,16 @@ , removeTBlanks :: Bool , textviewFont :: Maybe Text , sourceStyle :: (Bool, Text) - , foundBackground :: Color - , matchBackground :: Color - , contextBackground :: Color - , breakpointBackground :: Color + , foundBackgroundLight :: Color + , matchBackgroundLight :: Color + , contextBackgroundLight :: Color + , breakpointBackgroundLight :: Color + , lintBackgroundLight :: Color + , foundBackgroundDark :: Color + , matchBackgroundDark :: Color + , contextBackgroundDark :: Color + , breakpointBackgroundDark :: Color + , lintBackgroundDark :: Color , autoLoad :: Bool , textEditorType :: Text , logviewFont :: Maybe Text @@ -500,8 +514,11 @@ data EditorStyle = EditorStyle { styleName :: Maybe Text , preferDark :: Bool - , breakpointBG :: Color - , contextBG :: Color + , foundBG :: (Color, Color) + , matchBG :: (Color, Color) + , contextBG :: (Color, Color) + , breakpointBG :: (Color, Color) + , lintBG :: (Color, Color) } editorStyle :: Bool -> Prefs -> EditorStyle @@ -509,8 +526,11 @@ (False,_) -> Nothing (True,v) -> Just v , preferDark = preferDark - , breakpointBG = breakpointBackground prefs - , contextBG = contextBackground prefs + , foundBG = (foundBackgroundDark prefs, foundBackgroundLight prefs) + , matchBG = (matchBackgroundDark prefs, matchBackgroundLight prefs) + , contextBG = (contextBackgroundDark prefs, contextBackgroundLight prefs) + , breakpointBG = (breakpointBackgroundDark prefs, breakpointBackgroundLight prefs) + , lintBG = (lintBackgroundDark prefs, lintBackgroundLight prefs) } data SearchHint = Forward | Backward | Insert | Delete | Initial @@ -539,14 +559,14 @@ -- Order determines priority of the icons in the gutter data LogRefType = ContextRef | BreakpointRef | ErrorRef | TestFailureRef | WarningRef | LintRef - deriving (Eq, Show, Enum, Bounded) + deriving (Eq, Ord, Show, Enum, Bounded) data LogRef = LogRef { logRefSrcSpan :: SrcSpan , logRefPackage :: IDEPackage , refDescription :: Text , logRefIdea :: Maybe (Text, Idea) -, logLines :: (Int,Int) +, logLines :: Maybe (Int, Int) , logRefType :: LogRefType } deriving (Eq) diff --git a/src/IDE/HLint.hs b/src/IDE/HLint.hs new file mode 100644 --- /dev/null +++ b/src/IDE/HLint.hs @@ -0,0 +1,306 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.HLint +-- Copyright : 2007-2015 Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module IDE.HLint ( + hlintSettings + , scheduleHLint + , packageHLint + , resolveActiveHLint +) where + +import Control.Applicative +import Prelude hiding(getChar, getLine) +import IDE.Core.Types + (Prefs(..), LogRef(..), LogRefType(..), wsAllPackages, ipdBuildDir, + IDEM, IDEAction, IDE(..), IDEPackage(..), PackageAction) +import Control.Monad.Reader (asks, MonadReader(..)) +import IDE.Core.State + (postSyncIDE, catchIDE, MessageLevel(..), ideMessage, + leksahSubDir, reflectIDE, modifyIDE_, readIDE) +import Control.Concurrent.STM.TVar + (newTVarIO, writeTVar, readTVar) +import Control.Concurrent (forkIO) +import Control.Monad + (void, when, foldM, forM_, forM, unless, forever) +import Control.Monad.STM (retry, atomically) +import Control.Monad.Trans.Class (MonadTrans(..)) +import Control.Monad.IO.Class (MonadIO(..)) +import Language.Haskell.HLint3 + (Note(..), Idea(..), Severity(..), applyHints, ParseError(..), + parseModuleEx, CppFlags(..), defaultParseFlags, + parseFlagsAddFixities, resolveHints, readSettingsFile, + findSettings, Hint(..), Classify(..), ParseFlags(..)) +import System.FilePath.Windows (makeRelative, equalFilePath, ()) +import System.Directory (doesFileExist) +import qualified System.IO.Strict as S (readFile) +import Language.Preprocessor.Cpphs + (defaultCpphsOptions, runCpphsReturningSymTab, CpphsOptions(..)) +import System.Log.Logger (debugM) +import Data.Monoid ((<>)) +import Data.List (intercalate, find) +import qualified Data.Map as M (keys, lookup) +import qualified Data.Text as T + (replicate, init, unlines, reverse, take, drop, lines, unpack, + pack) +import Control.Exception (SomeException(..)) +import Data.Maybe (mapMaybe, catMaybes) +import Distribution.Package (PackageIdentifier(..)) +import Distribution.ModuleName (ModuleName) +import IDE.Core.CTypes + (SrcSpan(..), mdMbSourcePath, pdModules, mdModuleId, modu, + PackScope(..), GenScope(..), GenScope) +import IDE.Metainfo.Provider (getWorkspaceInfo) +import qualified Language.Haskell.Exts.SrcLoc as HSE + (SrcLoc(..), SrcSpan(..)) +import IDE.Pane.SourceBuffer + (useCandyFor, selectSourceBuf, fileSave, inActiveBufContext, + addLogRef, belongsToPackage, removeLogRefs) +import qualified Data.Text.IO as T (readFile) +import Data.Text (Text) +import IDE.TextEditor (TextEditor(..)) +import IDE.SourceCandy + (getCandylessPart, positionToCandy, stringToCandy) +import IDE.BufferMode (editInsertCode) + +packageHLint :: PackageAction +packageHLint = asks ipdCabalFile >>= (lift . lift . scheduleHLint . Left) + +scheduleHLint :: Either FilePath FilePath -> IDEAction +scheduleHLint what = do + liftIO $ debugM "leksah" "scheduleHLint" + mbQueue <- readIDE hlintQueue + queue <- case mbQueue of + Nothing -> do + ideR <- ask + queue <- liftIO $ newTVarIO [] + modifyIDE_ $ \ide -> ide { hlintQueue = Just queue } + liftIO . forkIO . forever $ do + x <- atomically $ do + schedule <- readTVar queue + case schedule of + (x:xs) -> do + writeTVar queue xs + return x + [] -> retry + reflectIDE (runHLint x) ideR + return queue + Just queue -> return queue + liftIO . atomically $ do + scheduled <- readTVar queue + unless (what `elem` scheduled) $ + writeTVar queue $ scheduled ++ [what] + +runHLint :: Either FilePath FilePath -> IDEAction +runHLint (Right sourceFile) = do + liftIO . debugM "leksah" $ "runHLint" + packages <- maybe [] wsAllPackages <$> readIDE workspace + case find (belongsToPackage sourceFile) packages of + Just package -> runHLint' package (Just sourceFile) + _ -> liftIO . debugM "leksah" $ "runHLint package not found for " <> sourceFile +runHLint (Left cabalFile) = do + liftIO . debugM "leksah" $ "runHLint" + packages <- maybe [] wsAllPackages <$> readIDE workspace + case find ((== cabalFile) . ipdCabalFile) packages of + Just package -> runHLint' package Nothing + _ -> liftIO . debugM "leksah" $ "runHLint package not found for " <> cabalFile + +runHLint' :: IDEPackage -> Maybe FilePath -> IDEAction +runHLint' package mbSourceFile = do + liftIO . debugM "leksah" $ "runHLint'" + ideR <- ask + (flags, classify, hint) <- hlintSettings package + let modules = M.keys (ipdModules package) + paths <- case mbSourceFile of + Just f -> return [f] + Nothing -> getSourcePaths (ipdPackageId package) modules + res <- forM paths $ \ full -> do + let file = makeRelative (ipdBuildDir package) full + postSyncIDE $ removeLogRefs [LintRef] (ipdBuildDir package) file + text <- liftIO $ T.readFile full + liftIO . debugM "leksah" $ "runHLint parsing " <> full + do result <- liftIO $ parseModuleEx flags full (Just (T.unpack text)) + case result of + Left e -> logHLintError package e >> return Nothing + Right r -> do + liftIO . debugM "leksah" $ "runHLint parsed " <> full + return $ Just (r, (full, text)) + `catchIDE` (\(e :: SomeException) -> do + reflectIDE (ideMessage Normal . T.pack $ "HLint Exception : " <> show e) ideR + return Nothing) + liftIO $ debugM "leksah" "runHLint parse complete" + let results = catMaybes res + ideas = map fst results + texts = map snd results + getText f = maybe "" snd $ find (equalFilePath f . fst) texts + logHLintResult package (applyHints classify hint ideas) getText + + +getSourcePaths :: PackageIdentifier -> [ModuleName] -> IDEM [FilePath] +getSourcePaths packId names = do + mbWorkspaceInfo <- getWorkspaceInfo + case mbWorkspaceInfo of + Nothing -> return [] + Just (sc, _) -> return (mapMaybe (sourcePathFromScope sc) names) + where + sourcePathFromScope :: GenScope -> ModuleName -> Maybe FilePath + sourcePathFromScope (GenScopeC (PackScope l _)) mn = + case packId `M.lookup` l of + Just pack -> + case filter (\md -> modu (mdModuleId md) == mn) + (pdModules pack) of + (mod : tl) -> mdMbSourcePath mod + [] -> Nothing + Nothing -> Nothing + +hlintSettings :: IDEPackage -> IDEM (ParseFlags, [Classify], Hint) +hlintSettings package = do + mbHlintDir <- liftIO $ leksahSubDir "hlint" + let cabalMacros = ipdBuildDir package "dist/build/autogen/cabal_macros.h" + cabalMacrosExist <- liftIO $ doesFileExist cabalMacros + defines <- liftIO $ if cabalMacrosExist + then do + raw <- S.readFile cabalMacros + map (\(a, b) -> (a, concat (lines b))) . snd <$> runCpphsReturningSymTab defaultCpphsOptions cabalMacros raw + else return [] + (fixities, classify, hints) <- liftIO $ findSettings (readSettingsFile mbHlintDir) Nothing + let hint = resolveHints hints + flags = parseFlagsAddFixities fixities defaultParseFlags{ cppFlags = Cpphs defaultCpphsOptions + { defines = defines } } + liftIO . debugM "leksah" $ "hlintSettings defines = " <> show defines + return (flags, classify, hint) + +logHLintResult :: IDEPackage -> [Idea] -> (FilePath -> Text) -> IDEAction +logHLintResult package allIdeas getText = do + let ideas = filter (\Idea{..} -> ideaSeverity /= Ignore) allIdeas + 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) + (HSE.srcSpanStartLine ideaSpan) + (HSE.srcSpanStartColumn ideaSpan - 1) + (HSE.srcSpanEndLine ideaSpan) + (HSE.srcSpanEndColumn ideaSpan - 1) + fromLines = drop (HSE.srcSpanStartLine ideaSpan - 1) + . take (HSE.srcSpanEndLine ideaSpan) $ T.lines text + fixHead [] = [] + fixHead (x:xs) = T.drop (HSE.srcSpanStartColumn ideaSpan - 1) x : xs + fixTail [] = [] + fixTail (x:xs) = T.take (HSE.srcSpanEndColumn ideaSpan - 1) x : xs + from = T.reverse . T.drop 1 . T.reverse + . T.unlines . fixHead . reverse . fixTail $ reverse fromLines + ref = LogRef srcSpan package (T.pack $ showHLint idea) + (Just (from, idea)) Nothing LintRef + postSyncIDE $ addLogRef ref + return () + +logHLintError :: IDEPackage -> ParseError -> IDEAction +logHLintError package error = do + let loc = parseErrorLocation error + srcSpan = SrcSpan (makeRelative (ipdBuildDir package) $ HSE.srcFilename loc) + (HSE.srcLine loc) + (HSE.srcColumn loc - 1) + (HSE.srcLine loc) + (HSE.srcColumn loc - 1) + ref = LogRef srcSpan package ("Hlint Parse Error: " <> T.pack (parseErrorMessage error)) Nothing Nothing LintRef + postSyncIDE $ addLogRef ref + +-- Cut down version of showEx from HLint +showHLint :: Idea -> String +showHLint Idea{..} = intercalate "\n" $ + [if ideaHint == "" then "" else show ideaSeverity ++ ": " ++ ideaHint] ++ + f "Found" (if ideaHint == "Reduce duplication" then Just ideaFrom else Nothing) ++ + f "Why not" ideaTo ++ + ["Note: " ++ n | let n = showNotes ideaNote, n /= ""] + where + f msg Nothing = [] + f msg (Just x) | null x = [msg ++ " remove it."] + | otherwise = (msg ++ ":") : map (" "++) (lines x) + showNotes :: [Note] -> String + showNotes = intercalate ", " . map show . filter use + where use ValidInstance{} = False -- Not important enough to tell an end user + use _ = True + +resolveActiveHLint :: IDEM Bool +resolveActiveHLint = inActiveBufContext False $ \_ _ ebuf _ _ -> do + allLogRefs <- readIDE allLogRefs + (iStart, iEnd) <- getSelectionBounds ebuf + lStart <- getLine iStart + cStart <- getLineOffset iStart + lEnd <- getLine iEnd + cEnd <- getLineOffset iEnd + let selectedRefs = [ref | ref@LogRef{..} <- allLogRefs, + logRefType == LintRef + && maybe "" (ideaHint . snd) logRefIdea /= "Reduce duplication" + && (lStart+1, cStart) <= (srcSpanEndLine logRefSrcSpan, + srcSpanEndColumn logRefSrcSpan) + && (lEnd+1, cEnd) >= (srcSpanStartLine logRefSrcSpan, + srcSpanStartColumn logRefSrcSpan)] + safeRefs = takeWhileNotOverlapping selectedRefs + (changed, _) <- foldM replaceHLintSource (False, 0) . catMaybes $ map logRefIdea safeRefs + prefs <- readIDE prefs + when changed $ if backgroundBuild prefs + then setModified ebuf True + else void $ fileSave False + return changed + where + takeWhileNotOverlapping = takeWhileNotOverlapping' (-1) + takeWhileNotOverlapping' _ [] = [] + takeWhileNotOverlapping' line (ref:refs) + | srcSpanEndLine (logRefSrcSpan ref) > line = ref : takeWhileNotOverlapping' (srcSpanEndLine $ logRefSrcSpan ref) refs + | otherwise = takeWhileNotOverlapping' line refs + +indentHLintText :: Int -> Text -> Text +indentHLintText startColumn text = + T.init $ T.unlines (take 1 lines <> drop 1 (map (indent <>) lines)) + where + lines = T.lines text + indent = T.replicate startColumn " " + +replaceHLintSource :: (Bool, Int) -> (Text, Idea) -> IDEM (Bool, Int) +replaceHLintSource (changed, delta) (from, Idea{ideaSpan = ideaSpan, ideaTo = Just ideaTo}) = do + let HSE.SrcSpan{..} = ideaSpan + to = indentHLintText (srcSpanStartColumn-1) (T.pack ideaTo) + liftIO . debugM "leksah" $ "replaceHLintSource From: " <> show from <> "\nreplaceHLintSource To: " <> show to + mbBuf <- selectSourceBuf srcSpanFilename + case mbBuf of + Just buf -> inActiveBufContext (changed, delta) $ \_ sv ebuf _ _ -> do + useCandy <- useCandyFor buf + candy' <- readIDE candy + realString <- if useCandy then stringToCandy candy' to else return to + (lineS', columnS', lineE', columnE') <- if useCandy + then do + (_,e1) <- positionToCandy candy' ebuf (srcSpanStartLine + delta, srcSpanStartColumn - 1) + (_,e2) <- positionToCandy candy' ebuf (srcSpanEndLine + delta, srcSpanEndColumn - 1) + return (srcSpanStartLine-1 + delta,e1,srcSpanEndLine-1 + delta,e2) + else return (srcSpanStartLine-1 + delta,srcSpanStartColumn-1,srcSpanEndLine-1 + delta,srcSpanEndColumn-1) + i1 <- getIterAtLine ebuf lineS' + i1' <- forwardCharsC i1 columnS' + i2 <- getIterAtLine ebuf lineE' + i2' <- forwardCharsC i2 columnE' + candy <- readIDE candy + check <- getCandylessPart candy ebuf i1' i2' + if check == from + then do + beginUserAction ebuf + delete ebuf i1' i2' + editInsertCode ebuf i1' realString + endUserAction ebuf + return (True, delta + length (T.lines to) - length (T.lines from)) + else return (changed, delta) + _ -> return (changed, delta) +replaceHLintSource x _ = return x + diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs --- a/src/IDE/ImportTool.hs +++ b/src/IDE/ImportTool.hs @@ -30,6 +30,7 @@ import Text.PrettyPrint (render) import Distribution.Text (simpleParse, display, disp) import IDE.Pane.SourceBuffer +import IDE.HLint (resolveActiveHLint) import Graphics.UI.Gtk import IDE.Utils.GUIUtils import Text.ParserCombinators.Parsec.Language (haskellStyle) diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -215,8 +215,9 @@ startGUI yiConfig sessionFP mbWorkspaceFP sourceFPs iprefs isFirstStart = Yi.start yiConfig $ \yiControl -> do st <- unsafeInitGUIForThreadedRTS - when rtsSupportsBoundThreads - (sysMessage Normal "Linked with -threaded") + when rtsSupportsBoundThreads $ do + setNumCapabilities 2 + sysMessage Normal "Linked with -threaded" timeout <- timeoutAddFull (yield >> return True) priorityLow 10 mbScreen <- screenGetDefault case mbScreen of @@ -390,6 +391,7 @@ , yiControl = yiControl , serverQueue = Nothing , server = Nothing + , hlintQueue = Nothing , vcsData = (Map.empty, Nothing) , logLaunches = Map.empty , autoCommand = return () diff --git a/src/IDE/LogRef.hs b/src/IDE/LogRef.hs --- a/src/IDE/LogRef.hs +++ b/src/IDE/LogRef.hs @@ -72,7 +72,7 @@ import qualified Data.Text as T (length, stripPrefix, isPrefixOf, unpack, unlines, pack, null) import Data.Monoid ((<>)) -import qualified Data.Set as S (member, insert, empty) +import qualified Data.Set as S (notMember, member, insert, empty) import Data.Set (Set) import System.FilePath.Windows (()) @@ -81,16 +81,12 @@ selectRef :: Maybe LogRef -> IDEAction selectRef (Just ref) = do - logRefs <- readIDE allLogRefs - case elemIndex ref logRefs of - Nothing -> liftIO . void $ debugM "leksah" "no index" - Just index -> do - mbBuf <- selectSourceBuf (logRefFullFilePath ref) - case mbBuf of - Just buf -> markRefInSourceBuf buf ref True - Nothing -> liftIO . void $ debugM "leksah" "no buf" - log :: Log.IDELog <- Log.getLog - Log.markErrorInLog log (logLines ref) + mbBuf <- selectSourceBuf (logRefFullFilePath ref) + case mbBuf of + Just buf -> markRefInSourceBuf buf ref True + Nothing -> liftIO . void $ debugM "leksah" "no buf" + log :: Log.IDELog <- Log.getLog + maybe (return ()) (Log.markErrorInLog log) (logLines ref) selectRef Nothing = return () forOpenLogRefs :: (LogRef -> IDEBuffer -> IDEAction) -> IDEAction @@ -114,17 +110,6 @@ buf <- getBuffer sv removeTagByName buf (T.pack $ show (logRefType logRef)) -setErrorList :: [LogRef] -> IDEAction -setErrorList errs = do - unmarkLogRefs - breaks <- readIDE breakpointRefs - contexts <- readIDE contextRefs - modifyIDE_ (\ide -> ide{allLogRefs = errs ++ breaks ++ contexts}) - setCurrentError Nothing - markLogRefs - triggerEventIDE ErrorChanged - return () - setBreakpointList :: [LogRef] -> IDEAction setBreakpointList breaks = do ideR <- ask @@ -149,104 +134,47 @@ triggerEventIDE TraceChanged return () +next :: (IDE -> [LogRef]) + -> (IDE -> Maybe LogRef) + -> (Maybe LogRef -> IDEAction) + -> IDEAction +next all current set = do + all <- readIDE all + current <- readIDE current + let isCurrent = (== current) . Just + case dropWhile isCurrent (dropWhile (not . isCurrent) all) <> all of + (n:_) -> do + set (Just n) + selectRef (Just n) + _ -> return () + nextError :: IDEAction -nextError = do - errs <- readIDE errorRefs - currentError <- readIDE currentError - unless (null errs) $ - do let new - = case currentError of - Nothing -> 0 - Just ref -> case elemIndex ref errs of - Nothing -> 0 - Just n | (n + 1) < length errs -> n + 1 - Just n -> n - setCurrentError (Just $ errs !! new) - selectRef $ Just (errs !! new) +nextError = next errorRefs currentError setCurrentError previousError :: IDEAction -previousError = do - errs <- readIDE errorRefs - currentError <- readIDE currentError - unless (null errs) $ - do let new - = case currentError of - Nothing -> length errs - 1 - Just ref -> case elemIndex ref errs of - Nothing -> length errs - 1 - Just n | n > 0 -> n - 1 - Just n -> 0 - setCurrentError (Just $ errs !! new) - selectRef $ Just (errs !! new) +previousError = next (reverse . errorRefs) currentError setCurrentError nextBreakpoint :: IDEAction -nextBreakpoint = do - breaks <- readIDE breakpointRefs - currentBreak <- readIDE currentBreak - unless (null breaks) $ - do let new - = case currentBreak of - Nothing -> 0 - Just ref -> case elemIndex ref breaks of - Nothing -> 0 - Just n | (n + 1) < length breaks -> n + 1 - Just n -> n - setCurrentBreak (Just $ breaks !! new) - selectRef $ Just (breaks !! new) +nextBreakpoint = next breakpointRefs currentBreak setCurrentBreak previousBreakpoint :: IDEAction -previousBreakpoint = do - breaks <- readIDE breakpointRefs - currentBreak <- readIDE currentBreak - unless (null breaks) $ - do let new - = case currentBreak of - Nothing -> length breaks - 1 - Just ref -> case elemIndex ref breaks of - Nothing -> length breaks - 1 - Just n | n > 0 -> n - 1 - Just n -> 0 - setCurrentBreak (Just $ breaks !! new) - selectRef $ Just (breaks !! new) +previousBreakpoint = next (reverse . breakpointRefs) currentBreak setCurrentBreak nextContext :: IDEAction -nextContext = do - contexts <- readIDE contextRefs - currentContext <- readIDE currentContext - unless (null contexts) $ - do let new - = case currentContext of - Nothing -> 0 - Just ref -> case elemIndex ref contexts of - Nothing -> 0 - Just n | (n + 1) < length contexts -> n + 1 - Just n -> n - setCurrentContext (Just $ contexts !! new) - selectRef $ Just (contexts !! new) +nextContext = next contextRefs currentContext setCurrentContext previousContext :: IDEAction -previousContext = do - contexts <- readIDE contextRefs - currentContext <- readIDE currentContext - unless (null contexts) $ - do let new - = case currentContext of - Nothing -> length contexts - 1 - Just ref -> case elemIndex ref contexts of - Nothing -> length contexts - 1 - Just n | n > 0 -> n - 1 - Just n -> 0 - setCurrentContext (Just $ contexts !! new) - selectRef $ Just (contexts !! new) +previousContext = next (reverse . contextRefs) currentContext setCurrentContext lastContext :: IDEAction lastContext = do contexts <- readIDE contextRefs currentContext <- readIDE currentContext - unless (null contexts) $ do - let new = last contexts - setCurrentContext (Just new) - selectRef $ Just new + case reverse contexts of + (l:_) -> do + setCurrentContext $ Just l + selectRef $ Just l + _ -> return () fixColumn c = max 0 (c - 1) @@ -503,7 +431,7 @@ -> Bool -> C.Sink ToolOutput IDEM [LogRef] logOutputForBuild package backgroundBuild jumpToWarnings = do - liftIO $ putStrLn "logOutputForBuild" + liftIO $ debugM "leksah" "logOutputForBuild" log <- lift getLog logLaunch <- lift Log.getDefaultLogLaunch BuildOutputState {..} <- CL.foldM (readAndShow logLaunch) $ initialState log @@ -541,7 +469,7 @@ sysMessage Normal . T.pack $ show e return state { inError = False } (Right ne@(ErrorLine span refType str),_) -> do - let ref = LogRef span package str Nothing (lineNr,lineNr) refType + let ref = LogRef span package str Nothing (Just (lineNr,lineNr)) refType root = logRefRootPath ref file = logRefFilePath ref fullFilePath = logRefFullFilePath ref @@ -552,22 +480,22 @@ , errs = ref:errs , filesCompiled = S.insert fullFilePath filesCompiled } - (Right (OtherLine str1), ref@(LogRef span rootPath str Nothing (l1,l2) refType):tl) -> + (Right (OtherLine str1), ref@(LogRef span rootPath str Nothing (Just (l1,l2)) refType):tl) -> if inError then return state { errs = LogRef span rootPath (if T.null str then line else str <> "\n" <> line) Nothing - (l1, lineNr) + (Just (l1, lineNr)) refType : tl } else return state - (Right (WarningLine str1),LogRef span rootPath str Nothing (l1, l2) isError : tl) -> + (Right (WarningLine str1),LogRef span rootPath str Nothing (Just (l1, l2)) isError : tl) -> if inError then return state { errs = LogRef span rootPath (if T.null str then line else str <> "\n" <> line) Nothing - (l1, lineNr) + (Just (l1, lineNr)) WarningRef : tl } @@ -594,14 +522,14 @@ , testFails = LogRef span package exp - Nothing (logLn,logLn) TestFailureRef : testFails + Nothing (Just (logLn,logLn)) TestFailureRef : testFails } - (_, True, LogRef span rootPath str Nothing (l1, l2) refType : tl) -> do + (_, True, LogRef span rootPath str Nothing (Just (l1, l2)) refType : tl) -> do logLn <- Log.appendLog log logLaunch (line <> "\n") ErrorTag return state { testFails = LogRef span rootPath (str <> "\n" <> line) - Nothing (l1,logLn) TestFailureRef : tl + Nothing (Just (l1,logLn)) TestFailureRef : tl } _ -> do Log.appendLog log logLaunch (line <> "\n") LogTag @@ -648,7 +576,7 @@ logLineNumber <- liftIO $ Log.appendLog log logLaunch (line <> "\n") LogTag case parse breaksLineParser "" $ T.unpack line of Right (BreakpointDescription n span) -> - return $ Just $ LogRef span package line Nothing (logLineNumber, logLineNumber) BreakpointRef + return $ Just $ LogRef span package line Nothing (Just (logLineNumber, logLineNumber)) BreakpointRef _ -> return Nothing _ -> do defaultLineLogger log logLaunch out @@ -665,7 +593,7 @@ logLineNumber <- liftIO $ Log.appendLog log logLaunch (line <> "\n") LogTag case parse setBreakpointLineParser "" $ T.unpack line of Right (BreakpointDescription n span) -> - return $ Just $ LogRef span package line Nothing (logLineNumber, logLineNumber) BreakpointRef + return $ Just $ LogRef span package line Nothing (Just (logLineNumber, logLineNumber)) BreakpointRef _ -> return Nothing _ -> do defaultLineLogger log logLaunch out @@ -690,7 +618,7 @@ let contexts = getContexts line if null contexts then return Nothing - else return $ Just $ LogRef (last contexts) package line Nothing (logLineNumber, logLineNumber) ContextRef + else return $ Just $ LogRef (last contexts) package line Nothing (Just (logLineNumber, logLineNumber)) ContextRef _ -> do defaultLineLogger log logLaunch out return Nothing) diff --git a/src/IDE/Pane/Errors.hs b/src/IDE/Pane/Errors.hs --- a/src/IDE/Pane/Errors.hs +++ b/src/IDE/Pane/Errors.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses, DeriveDataTypeable, OverloadedStrings #-} ----------------------------------------------------------------------------- @@ -20,34 +22,37 @@ , fillErrorList , selectError , getErrors +, selectMatchingErrors ) where import Graphics.UI.Gtk -import Data.Typeable (Typeable(..)) +import Data.Typeable (Typeable) import IDE.Core.State -import Graphics.UI.Gtk.General.Enums - (Click(..), MouseButton(..)) -import Graphics.UI.Gtk.Gdk.Events (Event(..)) import IDE.ImportTool (addResolveMenuItems, resolveErrors) import Data.List (elemIndex) import IDE.LogRef (showSourceSpan) import Control.Monad.IO.Class (MonadIO(..)) -import IDE.Utils.GUIUtils (treeViewContextMenu, __) -import Data.Maybe (isJust) -import Control.Monad (when) +import IDE.Utils.GUIUtils (getDarkState, treeViewContextMenu, __) import Data.Text (Text) -import qualified Data.Text as T (unpack) +import Control.Monad (void, when, forM_) +import qualified Data.Text as T + (intercalate, lines, takeWhile, length, drop) +import Data.IORef (writeIORef, readIORef, newIORef, IORef) +import Data.Maybe (isNothing) -- | A breakpoints pane description -- data IDEErrors = IDEErrors { scrolledView :: ScrolledWindow , treeView :: TreeView -, errorStore :: TreeStore ErrColumn +, errorStore :: ListStore ErrColumn +, autoClose :: IORef Bool -- If the pane was only displayed to show current error } deriving Typeable -data ErrColumn = ErrColumn {logRef :: LogRef, text :: Text, index :: Int} +data ErrColumn = ErrColumn { + logRef :: LogRef, + background :: Text} data ErrorsState = ErrorsState { } deriving(Eq,Ord,Read,Show,Typeable) @@ -56,106 +61,112 @@ where primPaneName _ = __ "Errors" getTopWidget = castToWidget . scrolledView - paneId b = "*Errors" + paneId _b = "*Errors" instance RecoverablePane IDEErrors ErrorsState IDEM where - saveState p = return (Just ErrorsState) - recoverState pp ErrorsState = do - nb <- getNotebook pp - p <- buildPane pp nb builder - fillErrorList - return p + saveState _p = return (Just ErrorsState) + recoverState pp ErrorsState = do nb <- getNotebook pp + buildPane pp nb builder builder = builder' builder' :: PanePath -> Notebook -> Window -> IDEM (Maybe IDEErrors, Connections) -builder' pp nb windows = reifyIDE $ \ ideR -> do - errorStore <- treeStoreNew [] - treeView <- treeViewNew +builder' _pp _nb _windows = reifyIDE $ \ ideR -> do + errorStore <- listStoreNew [] + treeView <- treeViewNew treeViewSetModel treeView errorStore rendererA <- cellRendererTextNew colA <- treeViewColumnNew - treeViewColumnSetTitle colA (__ "Location") + 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 := if index row == 0 then showSourceSpan (logRef row) else "", - cellTextForeground := case logRefType (logRef row) of - WarningRef -> "orange" :: Text - LintRef -> "green" - _ -> "red" ] + $ \row -> [cellText := removeIndentation (refDescription (logRef row)), + cellTextBackground := background row ] rendererB <- cellRendererTextNew colB <- treeViewColumnNew - treeViewColumnSetTitle colB (__ "Description") + 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 := text row] - - treeViewSetHeadersVisible treeView True + $ \row -> [ cellText := showSourceSpan (logRef row), + cellTextBackground := background row ] + treeViewSetHeadersVisible treeView False selB <- treeViewGetSelection treeView - treeSelectionSetMode selB SelectionSingle + treeSelectionSetMode selB SelectionMultiple scrolledView <- scrolledWindowNew Nothing Nothing scrolledWindowSetShadowType scrolledView ShadowIn containerAdd scrolledView treeView scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic - let pane = IDEErrors scrolledView treeView errorStore + autoClose <- newIORef False + let pane = IDEErrors {..} 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 + reflectIDE (fillErrorList' pane) ideR return (Just pane, map ConnectC [cid1, cid2, cid3, cid4]) +removeIndentation t = T.intercalate "\n" $ map (T.drop minIndent) l + where + l = T.lines t + minIndent = minimum $ map (T.length . T.takeWhile (== ' ')) l + getErrors :: Maybe PanePath -> IDEM IDEErrors getErrors Nothing = forceGetPane (Right "*Errors") getErrors (Just pp) = forceGetPane (Left pp) fillErrorList :: IDEAction -fillErrorList = do - mbErrors <- getPane - case mbErrors of - Nothing -> return () - Just pane -> do - refs <- readIDE errorRefs - liftIO $ do - treeStoreClear (errorStore pane) - mapM_ (insertError (errorStore pane)) (zip refs [0..length refs]) - where - insertError treeStore (lr,index) = - case {--lines--} [refDescription lr] of - [] -> treeStoreInsert treeStore [] index (ErrColumn lr "" 0) - h:t -> do - treeStoreInsert treeStore [] index (ErrColumn lr h 0) - mapM_ (\(line,subind) -> - treeStoreInsert treeStore [index] subind (ErrColumn lr line (subind + 1))) - (zip t [0..length t]) +fillErrorList = getPane >>= maybe (return ()) fillErrorList' +fillErrorList' :: IDEErrors -> IDEAction +fillErrorList' pane = do + refs <- readIDE errorRefs + ac <- liftIO $ readIORef (autoClose pane) + when (null refs && ac) . void $ closePane pane + isDark <- getDarkState + liftIO $ do + let store = errorStore pane + listStoreClear store + forM_ (zip 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"))) + getSelectedError :: TreeView - -> TreeStore ErrColumn + -> ListStore ErrColumn -> IO (Maybe LogRef) -getSelectedError treeView treeStore = do +getSelectedError treeView store = do treeSelection <- treeViewGetSelection treeView paths <- treeSelectionGetSelectedRows treeSelection case paths of - a:r -> do - val <- treeStoreGetValue treeStore a + [a]:r -> do + val <- listStoreGetValue store a return (Just (logRef val)) _ -> return Nothing selectError :: Maybe LogRef -> IDEAction selectError mbLogRef = do + (mbPane :: Maybe IDEErrors) <- getPane errorRefs' <- readIDE errorRefs errors <- getErrors Nothing + when (isNothing mbPane) $ do + liftIO $ writeIORef (autoClose errors) True + displayPane errors False liftIO $ do selection <- treeViewGetSelection (treeView errors) case mbLogRef of @@ -165,7 +176,7 @@ Just ind -> treeSelectionSelectPath selection [ind] errorsContextMenu :: IDERef - -> TreeStore ErrColumn + -> ListStore ErrColumn -> TreeView -> Menu -> IO () @@ -179,15 +190,40 @@ Nothing -> return () errorsSelect :: IDERef - -> TreeStore ErrColumn + -> ListStore ErrColumn -> TreePath -> TreeViewColumn -> IO () -errorsSelect ideR store path _ = do - ref <- treeStoreGetValue store path +errorsSelect ideR store [index] _ = do + ref <- listStoreGetValue store index reflectIDE (setCurrentError (Just (logRef ref))) ideR - - +errorsSelect _ _ _ _ = return () +selectMatchingErrors :: Maybe SrcSpan -> IDEM () +selectMatchingErrors mbSpan = do + 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) + forM_ (take size [0..]) $ \ n -> do + mbIter <- treeModelGetIter (errorStore pane) [n] + case mbIter of + Nothing -> return () + 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) $ treeSelectionSelectIter treeSel iter diff --git a/src/IDE/Pane/HLint.hs b/src/IDE/Pane/HLint.hs --- a/src/IDE/Pane/HLint.hs +++ b/src/IDE/Pane/HLint.hs @@ -16,84 +16,26 @@ -- Stability : provisional -- Portability : portable -- --- | The pane of ide where HLint results are displayed +-- | Deprecated. Kept in to make old session (.lkshs) files work. -- ----------------------------------------------------------------------------- module IDE.Pane.HLint ( - IDEHLint(..) -, refreshHLint -, HLintState(..) -, getHLint + HLintState(..) ) where - -import Graphics.UI.Gtk hiding (get) -import qualified Graphics.UI.Gtk.Gdk.Events as Gdk -import Text.ParserCombinators.Parsec.Language -import Text.ParserCombinators.Parsec hiding(Parser) -import qualified Text.ParserCombinators.Parsec.Token as P -import Data.Maybe -import Data.Typeable -import IDE.Core.State hiding (SrcSpan(..)) -import IDE.BufferMode -import IDE.LogRef (logOutput, defaultLineLogger) -import IDE.Pane.SourceBuffer - (hlintSettings, hlintBuffer, fileSave, goToSourceDefinition', - maybeActiveBuf, IDEBuffer(..), replaceHLintSource) -import IDE.TextEditor (TextEditor(..), grabFocus) -import Control.Applicative ((<$>)) -import System.FilePath ((), dropFileName) -import System.Exit (ExitCode(..)) -import IDE.Pane.Log (getLog) -import Control.Monad (forM, unless, void, forM_, foldM, when) -import Control.Monad.Trans.Reader (ask) -import Control.Monad.Trans.Class (MonadTrans(..)) -import Control.Monad.IO.Class (MonadIO(..)) -import Language.Haskell.Exts (SrcLoc(..)) -import Language.Haskell.Exts.SrcLoc (SrcSpan(..)) - -import qualified Language.Haskell.HLint3 as H -import IDE.Utils.GUIUtils (__, treeViewContextMenu) -import Data.List (isPrefixOf, findIndex) -import Debug.Trace (trace) -import Control.Exception (SomeException, catch) -import Distribution.ModuleName (ModuleName) -import IDE.Metainfo.Provider (getWorkspaceInfo) -import qualified Data.Map as Map (keys, lookup) -import Distribution.Package (PackageIdentifier(..)) +import Graphics.UI.Frame.Panes + (RecoverablePane(..), RecoverablePane, Pane(..)) +import Graphics.UI.Gtk.Display.Label (labelNew, Label) +import Data.Typeable (Typeable) +import IDE.Core.Types (IDEM) +import Graphics.UI.Gtk.Abstract.Widget (castToWidget) +import Graphics.UI.Frame.ViewFrame (getNotebook) +import IDE.Core.State (reifyIDE) import Data.Text (Text) -import qualified Data.Text as T - (replicate, unlines, init, lines, pack, unpack) -import Data.Monoid ((<>)) -import qualified System.IO.Strict as S (readFile) -import Language.Haskell.HLint3 - (CppFlags(..), defaultParseFlags, parseFlagsAddFixities, - resolveHints, readSettingsFile, findSettings, ParseFlags(..)) -import Language.Preprocessor.Cpphs - (runCpphsReturningSymTab, defaultCpphsOptions, CpphsOptions(..)) -import System.Log.Logger (debugM) -import System.Directory (doesFileExist) -import qualified System.IO as S (writeFile) -import System.Glib.GTypeConstants (flags) -data HLintRecord = HLintRecord { - condPackage :: Maybe IDEPackage - , context :: Text - , condIdea :: Maybe H.Idea - , parDir :: Maybe FilePath - } deriving (Eq) - -isDir HLintRecord{parDir = Nothing} = True -isDir otherwies = False - --- | A HLint pane description --- - data IDEHLint = IDEHLint { - scrolledView :: ScrolledWindow -, treeView :: TreeView -, hlintStore :: TreeStore HLintRecord + deprecatedLabel :: Label } deriving Typeable data HLintState = HLintState @@ -103,7 +45,7 @@ where primPaneName _ = "HLint" getAddedIndex _ = 0 - getTopWidget = castToWidget . scrolledView + getTopWidget = castToWidget . deprecatedLabel paneId b = "*HLint" instance RecoverablePane IDEHLint HLintState IDEM where @@ -112,221 +54,5 @@ nb <- getNotebook pp buildPane pp nb builder builder pp nb windows = reifyIDE $ \ ideR -> do - hlintStore <- treeStoreNew [] - treeView <- treeViewNew - treeViewSetModel treeView hlintStore - - renderer1 <- cellRendererTextNew - renderer10 <- cellRendererPixbufNew - col1 <- treeViewColumnNew - treeViewColumnSetTitle col1 (__ "Context") - treeViewColumnSetSizing col1 TreeViewColumnAutosize - treeViewColumnSetResizable col1 True - treeViewColumnSetReorderable col1 True - treeViewAppendColumn treeView col1 - cellLayoutPackStart col1 renderer10 False - cellLayoutPackStart col1 renderer1 True - cellLayoutSetAttributes col1 renderer1 hlintStore - $ \row -> [ cellText := context 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 hlint = IDEHLint {..} - cid1 <- after treeView focusInEvent $ do - liftIO $ reflectIDE (makeActive hlint) ideR - return True - cid2 <- on treeView rowExpanded $ \ iter path -> do - record <- treeStoreGetValue hlintStore path - case record of - HLintRecord { condPackage = Just p, parDir = Nothing } -> - reflectIDE (refreshDir hlintStore iter p) ideR - _ -> reflectIDE (ideMessage Normal (__ "Unexpected Expansion in HLint Pane")) ideR - cid3 <- on treeView rowActivated $ \ path col -> do - record <- treeStoreGetValue hlintStore path - mbIter <- treeModelGetIter hlintStore path - case (mbIter, record) of - (Just iter, HLintRecord { condPackage = Just p, parDir = Nothing }) -> - reflectIDE (refreshDir hlintStore iter p) ideR - _ -> return () - cid4 <- on treeView keyPressEvent $ do - name <- eventKeyName - liftIO $ case name of - "Return" -> reflectIDE (gotoSource True treeView hlintStore) ideR - "Escape" -> do - reflectIDE (do - lastActiveBufferPane ?>>= \paneName -> do - (PaneC pane) <- paneFromName paneName - makeActive pane - return () - triggerEventIDE StartFindInitial) ideR - return True - -- gotoSource True - _ -> return False - on sel treeSelectionSelectionChanged (reflectIDE (void $ gotoSource False treeView hlintStore) ideR) - - return (Just hlint,map ConnectC [cid1]) - -getHLint :: Maybe PanePath -> IDEM IDEHLint -getHLint Nothing = forceGetPane (Right "*HLint") -getHLint (Just pp) = forceGetPane (Left pp) - -data FindResult = WhereExpected TreeIter | Found TreeIter | NotFound - -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' - -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 - -removeRemaining :: TreeStore a -> TreePath -> IO () -removeRemaining store path = do - found <- treeStoreRemove store path - when found $ removeRemaining store path - - -getSelectionHLintRecord :: TreeView - -> TreeStore HLintRecord - -> IO (Maybe HLintRecord) -getSelectionHLintRecord treeView hlintStore = do - treeSelection <- treeViewGetSelection treeView - paths <- treeSelectionGetSelectedRows treeSelection - case paths of - p:_ -> Just <$> treeStoreGetValue hlintStore p - _ -> return Nothing - -refreshHLint :: WorkspaceAction -refreshHLint = do - ws <- ask - maybeActive <- lift $ readIDE activePack - let packages = case maybeActive of - Just active -> active : filter (/= active) (wsAllPackages ws) - Nothing -> wsAllPackages ws - lift $ hlintDirectories2 packages - - ---gotoSource :: Bool -> IDEM Bool -gotoSource focus treeView hlintStore = do - sel <- liftIO $ getSelectionHLintRecord treeView hlintStore - case sel of - Just record -> - case record of - HLintRecord {condIdea = Just idea} -> - goToSourceDefinition' (srcSpanFilename (H.ideaSpan idea)) - (Location "" (srcSpanStartLine (H.ideaSpan idea)) - (srcSpanStartColumn (H.ideaSpan idea)) - (srcSpanEndLine (H.ideaSpan idea)) - (srcSpanEndColumn (H.ideaSpan idea))) - ?>>= (\buf@IDEBuffer {sourceView = sv} -> do - hlintBuffer buf - when focus $ grabFocus sv) - _ -> return () - Nothing -> return () - return True - - -hlintDirectories2 :: [IDEPackage] -> IDEAction -hlintDirectories2 packages = do - hlint <- getHLint Nothing - let store = hlintStore hlint - liftIO $ do - treeStoreClear store - forM_ packages $ \ p -> do - nDir <- treeModelIterNChildren store Nothing - treeStoreInsert store [] nDir $ HLintRecord (Just p) (packageIdentifierToString (ipdPackageId p)) Nothing Nothing - treeStoreInsert store [nDir] 0 $ HLintRecord (Just p) (packageIdentifierToString (ipdPackageId p)) Nothing Nothing - -refreshDir :: TreeStore HLintRecord -> TreeIter -> IDEPackage -> IDEM () -refreshDir store iter package = do - ideR <- ask - (flags, classify, hint) <- hlintSettings package - let modules = Map.keys (ipdModules package) - paths <- getSourcePaths (ipdPackageId package) modules - res <- forM paths $ \ file -> do - str <- liftIO $ S.readFile file - liftIO . debugM "leksah" $ "refreshDir hlint parsing " <> file - do result <- liftIO $ H.parseModuleEx flags file (Just str) - case result of - Left e -> do ideMessage Normal . T.pack $ - "can't parse: " <> H.parseErrorContents e <> " location " <> - show (H.parseErrorLocation e) - return Nothing - Right r -> do liftIO . debugM "leksah" $ - "refreshDir hlint parsed " <> file - return $ Just r - `catchIDE` (\(e :: SomeException) -> do - reflectIDE (ideMessage Normal . T.pack $ show e) ideR - return Nothing) - liftIO $ debugM "leksah" "refreshDir hlint parse complete" - let ideas = H.applyHints classify hint (catMaybes res) - liftIO $ setHLint2Results store iter (T.unpack $ packageIdentifierToString (ipdPackageId package)) ideas - return () - - -getSourcePaths :: PackageIdentifier -> [ModuleName] -> IDEM [FilePath] -getSourcePaths packId names = do - mbWorkspaceInfo <- getWorkspaceInfo - case mbWorkspaceInfo of - Nothing -> return [] - Just (sc, _) -> return (mapMaybe (sourcePathFromScope sc) names) - where - sourcePathFromScope :: GenScope -> ModuleName -> Maybe FilePath - sourcePathFromScope (GenScopeC (PackScope l _)) mn = - case packId `Map.lookup` l of - Just pack -> - case filter (\md -> modu (mdModuleId md) == mn) - (pdModules pack) of - (mod : tl) -> mdMbSourcePath mod - [] -> Nothing - Nothing -> Nothing - - -hlint2Record dir idea = HLintRecord { - condPackage = Nothing, - context = T.pack $ show idea, - condIdea = Just idea, - parDir = Just dir} - -setHLint2Results :: TreeStore HLintRecord -> TreeIter -> FilePath -> [H.Idea] -> IO Int -setHLint2Results store parent dir ideas = do - liftIO $ debugM "leksah" "setHLint2Results" - parentPath <- treeModelGetPath store parent - forM_ (zip [0..] records) $ \(n, record) -> do - mbChild <- treeModelIterNthChild store (Just 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 - _ -> treeStoreInsert store parentPath n record - liftIO $ debugM "leksah" "setHLint2Results removing remaining records" - removeRemaining store (parentPath++[nRecords]) - return nRecords - where - records = map (hlint2Record dir) ideas - nRecords = length records - + deprecatedLabel <- labelNew $ Just ("HLint has moved to the Errors pane and Package -> HLint menu item"::Text) + return (Just IDEHLint {..}, []) diff --git a/src/IDE/Pane/Log.hs b/src/IDE/Pane/Log.hs --- a/src/IDE/Pane/Log.hs +++ b/src/IDE/Pane/Log.hs @@ -408,18 +408,18 @@ (_,y') <- textViewWindowToBufferCoords tv TextWindowWidget (x,y) (iter,_) <- textViewGetLineAtY tv y' textIterGetLine iter - case filter (\es -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1)) logRefs' of - [thisRef] -> do + case [(s,e,es) | es@LogRef{logLines = Just (s, e)} <- logRefs', s <= (line'+1) && e >= (line'+1)] of + [(s,e,thisRef)] -> do mbBuf <- selectSourceBuf (logRefFullFilePath thisRef) case mbBuf of Just buf -> markRefInSourceBuf buf thisRef True Nothing -> return () log :: IDELog <- getLog - markErrorInLog log (logLines thisRef) + markErrorInLog log (s, e) case logRefType thisRef of BreakpointRef -> setCurrentBreak (Just thisRef) _ -> setCurrentError (Just thisRef) - otherwise -> return () + _ -> return () clicked _ _ _ _ _ = return () populatePopupMenu :: IDELog -> IDERef -> Menu -> IO () @@ -438,10 +438,9 @@ (_,y') <- textViewWindowToBufferCoords tv TextWindowWidget (x,y) (iter,_) <- textViewGetLineAtY tv y' textIterGetLine iter - return $ filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1)) - (zip logRefs' [0..(length logRefs')])) ideR + return [es | es@LogRef{logLines = Just (s, e)} <- logRefs', s <= (line'+1) && e >= (line'+1)]) ideR case res of - [(thisRef,n)] -> do + [thisRef] -> do addResolveMenuItems ideR menu thisRef widgetShowAll menu return () @@ -516,7 +515,8 @@ log <- getLog buf <- liftIO $ textViewGetBuffer $ logLaunchTextView log liftIO $ textBufferSetText buf ("" :: Text) --- modifyIDE_ (\ide -> ide{allLogRefs = []}) --- setCurrentError Nothing --- setCurrentBreak Nothing TODO: Check with Hamish + modifyIDE_ (\ide -> ide{allLogRefs = []}) + setCurrentError Nothing + setCurrentBreak Nothing + diff --git a/src/IDE/Pane/Preferences.hs b/src/IDE/Pane/Preferences.hs --- a/src/IDE/Pane/Preferences.hs +++ b/src/IDE/Pane/Preferences.hs @@ -365,63 +365,103 @@ (paraName <<<- ParaName (__ "Found Text Background") $ emptyParams) (PP.text . show) colorParser - foundBackground - (\ b a -> a{foundBackground = b}) + foundBackgroundLight + (\ b a -> a{foundBackgroundLight = b}) colorEditor (\c -> do buffers <- allBuffers - forM_ buffers $ \(IDEBuffer {sourceView = sv}) -> do - ebuf <- getBuffer sv - tagTable <- getTagTable ebuf - mbTag <- lookupTag tagTable "found" - case mbTag of - Just tag -> background tag c - Nothing -> return ()) + mapM_ updateStyle' buffers) , mkFieldPP (paraName <<<- ParaName (__ "Selection Match Text Background") $ emptyParams) (PP.text . show) colorParser - matchBackground - (\ b a -> a{matchBackground = b}) + matchBackgroundLight + (\ b a -> a{matchBackgroundLight = b}) colorEditor (\c -> do buffers <- allBuffers - forM_ buffers $ \(IDEBuffer {sourceView = sv}) -> do - ebuf <- getBuffer sv - tagTable <- getTagTable ebuf - mbTag <- lookupTag tagTable "match" - case mbTag of - Just tag -> background tag c - Nothing -> return ()) + mapM_ updateStyle' buffers) , mkFieldPP (paraName <<<- ParaName (__ "Execution Context Text Background") $ emptyParams) (PP.text . show) colorParser - contextBackground - (\ b a -> a{contextBackground = b}) + contextBackgroundLight + (\ b a -> a{contextBackgroundLight = b}) colorEditor (\c -> do buffers <- allBuffers - forM_ buffers $ \(IDEBuffer {sourceView = sv}) -> do - ebuf <- getBuffer sv - tagTable <- getTagTable ebuf - -- TODO find and set the tag background - return ()) + mapM_ updateStyle' buffers) , mkFieldPP (paraName <<<- ParaName (__ "Breakpoint Text Background") $ emptyParams) (PP.text . show) colorParser - breakpointBackground - (\ b a -> a{breakpointBackground = b}) + breakpointBackgroundLight + (\ b a -> a{breakpointBackgroundLight = b}) colorEditor (\c -> do buffers <- allBuffers - forM_ buffers $ \(IDEBuffer {sourceView = sv}) -> do - ebuf <- getBuffer sv - tagTable <- getTagTable ebuf - -- TODO find and set the tag background - return ()) + 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 @@ -792,10 +832,16 @@ , removeTBlanks = True , textviewFont = Nothing , sourceStyle = (True,"leksah") - , foundBackground = Color 65535 65535 32768 - , matchBackground = Color 32768 32768 32768 - , contextBackground = Color 65535 49152 49152 - , breakpointBackground = Color 65535 49152 32768 + , 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 diff --git a/src/IDE/Pane/SourceBuffer.hs b/src/IDE/Pane/SourceBuffer.hs --- a/src/IDE/Pane/SourceBuffer.hs +++ b/src/IDE/Pane/SourceBuffer.hs @@ -32,7 +32,6 @@ , goToSourceDefinition' , goToDefinition , insertInBuffer -, replaceHLintSource , fileNew , fileOpenThis @@ -68,10 +67,8 @@ , updateStyle , updateStyle' , addLogRef +, removeLogRefs , removeBuildLogRefs -, resolveActiveHLint -, hlintSettings -, hlintBuffer , markRefInSourceBuf , inBufContext , inActiveBufContext @@ -87,8 +84,10 @@ , recentSourceBuffers , newTextBuffer , belongsToPackages +, belongsToPackage , belongsToWorkspace , getIdentifierUnderCursorFromIter +, useCandyFor ) where @@ -136,7 +135,7 @@ import IDE.BufferMode import Control.Monad.Trans.Reader (ask) import Control.Monad.IO.Class (MonadIO(..)) -import Control.Monad (filterM, foldM, void, unless, when, liftM) +import Control.Monad (filterM, void, unless, when, liftM) import Control.Exception as E (catch, SomeException) import qualified IDE.Command.Print as Print @@ -144,22 +143,11 @@ import System.Log.Logger (debugM) import Data.Text (Text) import qualified Data.Text as T - (reverse, take, drop, init, length, findIndex, replicate, lines, + (length, findIndex, replicate, lines, dropWhileEnd, unlines, strip, null, pack, unpack) import Data.Monoid ((<>)) import qualified Data.Text.IO as T (writeFile, readFile) import Data.Time (UTCTime(..)) -import Control.Concurrent (forkIO) -import Language.Haskell.HLint3 - (Hint(..), Classify(..), ParseError(..), Idea(..), Severity(..), - parseFlagsAddFixities, resolveHints, readSettingsFile, - findSettings, applyHints, defaultParseFlags, parseModuleEx, - ParseFlags(..), CppFlags(..)) -import qualified Language.Haskell.Exts.SrcLoc as HSE - (SrcLoc(..), SrcSpan(..)) -import Language.Preprocessor.Cpphs as Cpphs - (runCpphsReturningSymTab, defaultCpphsOptions, CpphsOptions(..)) -import qualified System.IO.Strict as S (readFile) import Graphics.UI.Gtk.Gdk.EventM (eventModifier, eventKeyName, eventKeyVal) import Data.Foldable (forM_) @@ -235,7 +223,7 @@ buildPane panePath notebook builder = return Nothing builder pp nb w = return (Nothing,[]) -startComplete :: IDEAction +-- startComplete :: IDEAction startComplete = do mbBuf <- maybeActiveBuf currentState' <- readIDE currentState @@ -243,7 +231,7 @@ Nothing -> return () Just (IDEBuffer {sourceView=v}) -> complete v True -selectSourceBuf :: FilePath -> IDEM (Maybe IDEBuffer) +-- selectSourceBuf :: FilePath -> IDEM (Maybe IDEBuffer) selectSourceBuf fp = do fpc <- liftIO $ myCanonicalizePath fp buffers <- allBuffers @@ -336,47 +324,6 @@ Nothing -> return () return mbBuf -indentHLintText :: Int -> Text -> Text -indentHLintText startColumn text = - T.init $ T.unlines (take 1 lines <> drop 1 (map (indent <>) lines)) - where - lines = T.lines text - indent = T.replicate startColumn " " - -replaceHLintSource :: (Bool, Int) -> (Text, Idea) -> IDEM (Bool, Int) -replaceHLintSource (changed, delta) (from, Idea{ideaSpan = ideaSpan, ideaTo = Just ideaTo}) = do - let HSE.SrcSpan{..} = ideaSpan - to = indentHLintText (srcSpanStartColumn-1) (T.pack ideaTo) - liftIO . debugM "leksah" $ "replaceHLintSource From: " <> show from <> "\nreplaceHLintSource To: " <> show to - mbBuf <- selectSourceBuf srcSpanFilename - case mbBuf of - Just buf -> inActiveBufContext (changed, delta) $ \_ sv ebuf _ _ -> do - useCandy <- useCandyFor buf - candy' <- readIDE candy - realString <- if useCandy then stringToCandy candy' to else return to - (lineS', columnS', lineE', columnE') <- if useCandy - then do - (_,e1) <- positionToCandy candy' ebuf (srcSpanStartLine + delta, srcSpanStartColumn - 1) - (_,e2) <- positionToCandy candy' ebuf (srcSpanEndLine + delta, srcSpanEndColumn - 1) - return (srcSpanStartLine-1 + delta,e1,srcSpanEndLine-1 + delta,e2) - else return (srcSpanStartLine-1 + delta,srcSpanStartColumn-1,srcSpanEndLine-1 + delta,srcSpanEndColumn-1) - i1 <- getIterAtLine ebuf lineS' - i1' <- forwardCharsC i1 columnS' - i2 <- getIterAtLine ebuf lineE' - i2' <- forwardCharsC i2 columnE' - candy <- readIDE candy - check <- getCandylessPart candy ebuf i1' i2' - if check == from - then do - beginUserAction ebuf - delete ebuf i1' i2' - editInsertCode ebuf i1' realString - endUserAction ebuf - return (True, delta + length (T.lines to) - length (T.lines from)) - else return (changed, delta) - _ -> return (changed, delta) -replaceHLintSource x _ = return x - insertInBuffer :: Descr -> IDEAction insertInBuffer idDescr = do mbPaneName <- lastActiveBufferPane @@ -416,9 +363,28 @@ removeBuildLogRefs :: FilePath -> FilePath -> IDEAction removeBuildLogRefs = removeLogRefs [ErrorRef, WarningRef, TestFailureRef] +-- | Test failures have the same imporance as errors so should be +-- sorted the same +importance :: LogRef -> LogRefType +importance LogRef{ logRefType = TestFailureRef } = ErrorRef +importance ref = logRefType ref + addLogRef :: LogRef -> IDEAction addLogRef ref = do - modifyIDE_ (\ide -> ide{allLogRefs = allLogRefs ide <> [ref]}) + -- Put most important errors first. + -- If the importance of two errors is the same then + -- then the older one might be stale (unless it is in the same file) + modifyIDE_ $ \ ide -> + let (moreImportant, rest) = + partition (\old -> importance old < importance ref -- Note: a low LogRefType is more important + || (importance old == importance ref + && logRefFullFilePath old == logRefFullFilePath ref)) (allLogRefs ide) + currErr = if currentError ide `elem` map Just moreImportant + then currentError ide + else Nothing in + ide{ allLogRefs = moreImportant <> [ref] <> rest + , currentEBC = (currErr, currentBreak ide, currentContext ide) + } buffers <- allBuffers let matchingBufs = filter (maybe False (equalFilePath (logRefFullFilePath ref)) . fileName) buffers @@ -543,13 +509,10 @@ _ -> newDefaultBuffer mbfn fileContents >>= makeBuffer modTime where + makeBuffer :: TextEditor editor => Maybe UTCTime -> EditorBuffer editor -> IDEM (Maybe IDEBuffer,Connections) makeBuffer modTime buffer = do ideR <- ask - tagTable <- getTagTable buffer - foundTag <- newTag tagTable "found" - background foundTag $ foundBackground prefs - beginNotUndoableAction buffer let mod = modFromFileName mbfn when (bs && isHaskellMode mod) $ modeTransformToCandy mod @@ -606,32 +569,37 @@ sysMessage Normal "SourceBuffer>> no text popup" return [] - --TODO refactor this - ids5 <- onMotionNotifyEvent sv $ do - liftIDE $ do - candy' <- readIDE candy - inActiveBufContext () $ \_ _ ebuf currentBuffer _ -> do - let tagName = "match" - tagTable <- getTagTable ebuf - mbTag <- lookupTag tagTable tagName - case mbTag of - Just existingTag -> removeTagByName ebuf tagName - Nothing -> do - tag <- newTag tagTable tagName - background tag $ matchBackground prefs - - hasSelection <- hasSelection ebuf - when hasSelection $ do - (si1,si2) <- getSelectionBounds ebuf - - sTxt <- getCandylessPart candy' ebuf si1 si2 - let strippedSTxt = T.strip sTxt - unless (T.null strippedSTxt) $ - do bi1 <- getStartIter ebuf - bi2 <- getEndIter ebuf - forwardApplying bi1 strippedSTxt (Just si1) tagName ebuf - forwardApplying si2 strippedSTxt (Just bi2) tagName ebuf - return False + hasMatch <- liftIO $ newIORef False + ids5 <- onSelectionChanged buffer $ do + (iStart, iEnd) <- getSelectionBounds buffer + lStart <- (+1) <$> getLine iStart + cStart <- getLineOffset iStart + lEnd <- (+1) <$> getLine iEnd + cEnd <- getLineOffset iEnd + triggerEventIDE_ . SelectSrcSpan $ + case mbfn of + Just fn -> Just (SrcSpan fn lStart cStart lEnd cEnd) + Nothing -> Nothing + let tagName = "match" + hasSelection <- hasSelection buffer + m <- liftIO $ readIORef hasMatch + when m $ removeTagByName buffer tagName + r <- if hasSelection + then do + candy' <- readIDE candy + sTxt <- getCandylessPart candy' buffer iStart iEnd + let strippedSTxt = T.strip sTxt + if T.null strippedSTxt + then return False + else do + bi1 <- getStartIter buffer + bi2 <- getEndIter buffer + r1 <- forwardApplying bi1 strippedSTxt (Just iStart) tagName buffer + r2 <- forwardApplying iEnd strippedSTxt (Just bi2) tagName buffer + return (r1 || r2) + else return False + liftIO $ writeIORef hasMatch r + return () ids6 <- onKeyPress sv $ do keyval <- lift eventKeyVal @@ -702,7 +670,7 @@ -> Maybe (EditorIter editor) -> Text -- tagname -> EditorBuffer editor - -> IDEM () + -> IDEM Bool forwardApplying tI txt mbTi tagName ebuf = do mbFTxt <- forwardSearch tI txt [TextSearchVisibleOnly, TextSearchTextOnly] mbTi case mbFTxt of @@ -711,8 +679,8 @@ endsWord <- endsWord end when (startsWord && endsWord) $ applyTagByName ebuf tagName start end - forwardApplying end txt mbTi tagName ebuf - Nothing -> return() + (|| (startsWord && endsWord)) <$> forwardApplying end txt mbTi tagName ebuf + Nothing -> return False isIdent a = isAlphaNum a || a == '\'' || a == '_' -- parts of haskell identifiers @@ -982,102 +950,7 @@ return False) setModified buf (not succ) markLabelAsChanged nb ideBuf - hlintBuffer' ideBuf text' fn - -hlintSettings :: IDEPackage -> IDEM (ParseFlags, [Classify], Hint) -hlintSettings package = do - mbHlintDir <- liftIO $ leksahSubDir "hlint" - let cabalMacros = ipdBuildDir package "dist/build/autogen/cabal_macros.h" - cabalMacrosExist <- liftIO $ doesFileExist cabalMacros - defines <- liftIO $ if cabalMacrosExist - then do - raw <- S.readFile cabalMacros - map (\(a, b) -> (a, concat (lines b))) . snd <$> runCpphsReturningSymTab defaultCpphsOptions cabalMacros raw - else return [] - (fixities, classify, hints) <- liftIO $ findSettings (readSettingsFile mbHlintDir) Nothing - let hint = resolveHints hints - flags = parseFlagsAddFixities fixities defaultParseFlags{ cppFlags = Cpphs defaultCpphsOptions - { defines = defines } } - liftIO . debugM "leksah" $ "hlintSettings defines = " <> show defines - return (flags, classify, hint) - -hlintBuffer :: IDEBuffer -> IDEAction -hlintBuffer ideBuf@IDEBuffer{..} = do - buf <- getBuffer sourceView - candy <- readIDE candy - text <- getCandylessText candy buf - maybe (return ()) (hlintBuffer' ideBuf text) fileName - -hlintBuffer' :: IDEBuffer -> Text -> FilePath -> IDEAction -hlintBuffer' ideBuf text fn = do - packs <- belongsToPackages ideBuf - ideR <- ask - case packs of - (package:_) -> do - let file = makeRelative (ipdBuildDir package) fn - removeLogRefs [LintRef] (ipdBuildDir package) file - liftIO . void . forkIO $ do - (flags, classify, hint) <- reflectIDE (hlintSettings package) ideR - parseResult <- parseModuleEx flags fn (Just $ T.unpack text) - case parseResult of - (Right m) -> do - let allIdeas = applyHints classify hint [m] - ideas = filter (\Idea{..} -> ideaSeverity /= Ignore - && equalFilePath (HSE.srcSpanFilename ideaSpan) fn) allIdeas - forM_ ideas $ \ idea@Idea{..} -> do - let fixColumn c = max 0 (c - 1) - srcSpan = SrcSpan file - (HSE.srcSpanStartLine ideaSpan) - (HSE.srcSpanStartColumn ideaSpan - 1) - (HSE.srcSpanEndLine ideaSpan) - (HSE.srcSpanEndColumn ideaSpan - 1) - fromLines = drop (HSE.srcSpanStartLine ideaSpan - 1) - . take (HSE.srcSpanEndLine ideaSpan) $ T.lines text - fixHead [] = [] - fixHead (x:xs) = T.drop (HSE.srcSpanStartColumn ideaSpan - 1) x : xs - fixTail [] = [] - fixTail (x:xs) = T.take (HSE.srcSpanEndColumn ideaSpan - 1) x : xs - from = T.reverse . T.drop 1 . T.reverse - . T.unlines . fixHead . reverse . fixTail $ reverse fromLines - reflectIDE (postAsyncIDE $ addLogRef - (LogRef srcSpan package (T.pack ideaHint <> maybe "" (("\n" <>) . T.pack) ideaTo) - (Just (from, idea)) (0, 0) LintRef)) ideR - Left error -> do - let loc = parseErrorLocation error - srcSpan = SrcSpan file - (HSE.srcLine loc) - (HSE.srcColumn loc - 1) - (HSE.srcLine loc) - (HSE.srcColumn loc - 1) - reflectIDE (postAsyncIDE $ addLogRef - (LogRef srcSpan package ("Hlint Parse Error: " <> T.pack (parseErrorMessage error)) - Nothing (0, 0) LintRef)) ideR - _ -> liftIO . debugM "leksah" $ "hlintBuffer package not found for " <> fn - -resolveActiveHLint :: IDEM Bool -resolveActiveHLint = inActiveBufContext False $ \_ _ ebuf _ _ -> do - allLogRefs <- readIDE allLogRefs - (iStart, iEnd) <- getSelectionBounds ebuf - lStart <- getLine iStart - cStart <- getLineOffset iStart - lEnd <- getLine iEnd - cEnd <- getLineOffset iEnd - let selectedRefs = filter (\ LogRef{..} -> logRefType == LintRef - && (lStart+1, cStart) <= (srcSpanEndLine logRefSrcSpan, srcSpanEndColumn logRefSrcSpan) - && (lEnd+1, cEnd) >= (srcSpanStartLine logRefSrcSpan, srcSpanStartColumn logRefSrcSpan)) allLogRefs - safeRefs = takeWhileNotOverlapping selectedRefs - (changed, _) <- foldM replaceHLintSource (False, 0) . catMaybes $ map logRefIdea safeRefs - prefs <- readIDE prefs - when changed $ if backgroundBuild prefs - then setModified ebuf True - else void $ fileSave False - return changed - where - takeWhileNotOverlapping = takeWhileNotOverlapping' (-1) - takeWhileNotOverlapping' _ [] = [] - takeWhileNotOverlapping' line (ref:refs) - | srcSpanEndLine (logRefSrcSpan ref) > line = ref : takeWhileNotOverlapping' (srcSpanEndLine $ logRefSrcSpan ref) refs - | otherwise = takeWhileNotOverlapping' line refs + triggerEventIDE_ $ SavedFile fn fileSave :: Bool -> IDEM Bool fileSave query = inActiveBufContext False $ fileSaveBuffer query diff --git a/src/IDE/Pane/Workspace.hs b/src/IDE/Pane/Workspace.hs --- a/src/IDE/Pane/Workspace.hs +++ b/src/IDE/Pane/Workspace.hs @@ -35,7 +35,6 @@ import qualified Data.Map as Map (empty) import Data.List (sortBy) import IDE.Pane.Files (refreshFiles) -import IDE.Pane.HLint (refreshHLint) import Control.Monad (when) import Control.Monad.IO.Class (MonadIO(..)) import IDE.Utils.GUIUtils (treeViewContextMenu, __) @@ -229,5 +228,4 @@ liftIO $ treeStoreInsertForest (workspaceStore p) [] 0 forest when showPane $ displayPane p False refreshFiles - workspaceTry refreshHLint diff --git a/src/IDE/Session.hs b/src/IDE/Session.hs --- a/src/IDE/Session.hs +++ b/src/IDE/Session.hs @@ -67,7 +67,7 @@ import IDE.Find import System.Time (getClockTime) import IDE.Package (deactivatePackage) -import IDE.Pane.Errors (ErrorsState(..)) +import IDE.Pane.Errors (fillErrorList, ErrorsState(..)) import Control.Exception (catch, SomeException(..)) import IDE.Pane.Workspace (WorkspaceState(..)) import IDE.Workspaces (workspaceOpenThis) @@ -673,6 +673,7 @@ setDark :: Bool -> IDEM () setDark dark = do setInfoStyle + fillErrorList prefs <- readIDE prefs buffers <- allBuffers mapM_ updateStyle' buffers diff --git a/src/IDE/SymbolNavigation.hs b/src/IDE/SymbolNavigation.hs --- a/src/IDE/SymbolNavigation.hs +++ b/src/IDE/SymbolNavigation.hs @@ -120,7 +120,8 @@ let hasNoControlModifier = mapControlCommand Control `notElem` mods lnbf <- readIORef lineNumberBugFix -- print ("ishint?, adjusted, event.x, ptr.x, adjustment,hasControl?",isHint,ptrx - fromMaybe (-1000) lnbf , eventX, ptrx, lnbf, hasNoControlModifier) - when (isHint && hasNoControlModifier) $ + -- when (isHint && hasNoControlModifier) $ + when (abs (ptrx - eventX) > 1) $ -- get difference between event X and pointer x -- event X is in coordinates of sourceView text -- pointer X is in coordinates of window (remember "show line numbers" ?) diff --git a/src/IDE/TextEditor/Class.hs b/src/IDE/TextEditor/Class.hs --- a/src/IDE/TextEditor/Class.hs +++ b/src/IDE/TextEditor/Class.hs @@ -169,6 +169,7 @@ onLookupInfo :: EditorView editor -> IDEEventM EButton Bool -> IDEM [Connection] onMotionNotifyEvent :: EditorView editor -> IDEEventM EMotion Bool -> IDEM [Connection] onPopulatePopup :: EditorView editor -> (Menu -> IDEM ()) -> IDEM [Connection] + onSelectionChanged :: EditorBuffer editor -> IDEM () -> IDEM [Connection] -- Iter backwardCharC :: EditorIter editor -> IDEM (EditorIter editor) diff --git a/src/IDE/TextEditor/CodeMirror.hs b/src/IDE/TextEditor/CodeMirror.hs --- a/src/IDE/TextEditor/CodeMirror.hs +++ b/src/IDE/TextEditor/CodeMirror.hs @@ -540,5 +540,6 @@ menuPopup menu Nothing return True return [ConnectC id1] + onSelectionChanged (CMBuffer cm) f = return [] -- TODO #endif diff --git a/src/IDE/TextEditor/GtkSourceView.hs b/src/IDE/TextEditor/GtkSourceView.hs --- a/src/IDE/TextEditor/GtkSourceView.hs +++ b/src/IDE/TextEditor/GtkSourceView.hs @@ -129,7 +129,7 @@ (drop, dropWhile, all, length, pack) import Data.Monoid ((<>)) import Graphics.UI.Gtk.Multiline.TextBuffer - (textBufferDeleteMarkByName, textBufferDeleteMark, + (markSet, textBufferDeleteMarkByName, textBufferDeleteMark, textBufferGetMark) import Graphics.UI.Gtk.SourceView.SourceMarkAttributes (queryTooltipText, sourceMarkAttributesSetIconName, @@ -139,6 +139,7 @@ import Graphics.UI.Gtk.Multiline.TextMark (textMarkGetName, toTextMark) import Control.Arrow (Arrow(..)) +import System.Log.Logger (debugM) transformGtkIter :: EditorIter GtkSourceView -> (TextIter -> IO a) -> IDEM (EditorIter GtkSourceView) transformGtkIter (GtkIter i) f = do @@ -181,6 +182,10 @@ textBufferSetText buffer contents sourceBufferEndNotUndoableAction buffer tagTable <- textBufferGetTagTable buffer + textTagNew (Just "found") >>= textTagTableAdd tagTable + textTagNew (Just "match") >>= textTagTableAdd tagTable + textTagNew (Just "context") >>= textTagTableAdd tagTable + textTagNew (Just "breakpoint") >>= textTagTableAdd tagTable forM_ [minBound .. maxBound :: LogRefType] $ \ refType -> textTagNew (Just . T.pack $ show refType) >>= textTagTableAdd tagTable return $ GtkBuffer buffer @@ -291,19 +296,17 @@ sourceBufferSetStyleScheme sb (Just scheme) tagTable <- getTagTable (GtkBuffer sb) let isDark = name `elem` ["leksah-dark", "oblivion", "cobalt"] - forM_ [minBound .. maxBound] $ \ refType -> do - mbTag <- lookupTag tagTable (T.pack $ show refType) - case mbTag of - Nothing -> return () - Just tag -> - case refType of - ErrorRef -> underline tag UnderlineError - WarningRef -> underline tag UnderlineError - TestFailureRef -> underline tag UnderlineError - LintRef | isDark -> background tag $ Color 0 15000 0 - | otherwise -> background tag $ Color 60000 65535 60000 - BreakpointRef -> background tag breakpointBG - ContextRef -> background tag contextBG + setBG (dark, light) (Just tag) = background tag (if isDark then dark else light) + setBG _ Nothing = return () + setUnderline = maybe (return ()) (`underline` UnderlineError) + lookupTag tagTable "match" >>= setBG matchBG + lookupTag tagTable "found" >>= setBG foundBG + lookupTag tagTable (T.pack $ show ErrorRef ) >>= setUnderline + lookupTag tagTable (T.pack $ show WarningRef ) >>= setUnderline + lookupTag tagTable (T.pack $ show TestFailureRef) >>= setUnderline + lookupTag tagTable (T.pack $ show LintRef ) >>= setBG lintBG + lookupTag tagTable (T.pack $ show BreakpointRef ) >>= setBG breakpointBG + lookupTag tagTable (T.pack $ show ContextRef ) >>= setBG contextBG setText (GtkBuffer sb) text = liftIO $ textBufferSetText sb text undo (GtkBuffer sb) = liftIO $ sourceBufferUndo sb @@ -388,8 +391,11 @@ -- Paste operation is example of such sequential events (each word!). lastHandler <- newIORef Nothing id1 <- after sb bufferInsertText $ \iter text -> do - mapM_ idleRemove =<< maybeToList <$> readIORef lastHandler + lh <- readIORef lastHandler + debugM "leksah" $ "Removing " <> show lh + mapM_ idleRemove $ maybeToList lh h <- flip idleAdd priorityDefault $ do + writeIORef lastHandler Nothing let isIdent a = isAlphaNum a || a == '\'' || a == '_' || a == '.' let isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-' || a == '!' || a == '@' || a == '%' || a == '&' || a == '?' @@ -443,6 +449,13 @@ ideR <- ask liftIO $ do id1 <- sv `on` populatePopup $ \menu -> reflectIDE (f menu) ideR + return [ConnectC id1] + onSelectionChanged (GtkBuffer sb) handler = do + ideR <- ask + liftIO $ do + id1 <- sb `on` markSet $ \ _ mark -> do + name <- textMarkGetName mark + when (name == Just "insert") $ reflectIDE handler ideR return [ConnectC id1] -- Iter