leksah 0.13.4.2 → 0.13.4.3
raw patch · 60 files changed
+1756/−2821 lines, 60 filesdep ~Cabaldep ~binary-shareddep ~leksahbinary-added
Dependency ranges changed: Cabal, binary-shared, leksah, vcsgui, vcswrapper, yi
Files
- Readme.md +5/−3
- data/candy-hasklig.lkshc +89/−0
- data/candy.lkshc +80/−27
- data/leksah.menu +10/−0
- leksah.cabal +32/−45
- osx/makedmg.sh +1/−1
- pics/ide_js.png binary
- scripts/stage.sh +0/−2
- src/Distribution/PackageDescription/ParseCopied.hs +0/−1206
- src/Distribution/PackageDescription/PrettyPrintCopied.hs +0/−238
- src/IDE/BufferMode.hs +5/−5
- src/IDE/Build.hs +12/−13
- src/IDE/Command.hs +60/−47
- src/IDE/Command/VCS/Common.hs +16/−16
- src/IDE/Command/VCS/Common/Helper.hs +6/−6
- src/IDE/Command/VCS/Common/Workspaces.hs +32/−31
- src/IDE/Command/VCS/Mercurial.hs +2/−2
- src/IDE/Command/VCS/SVN.hs +2/−2
- src/IDE/Command/VCS/Types.hs +2/−2
- src/IDE/Core/State.hs +52/−62
- src/IDE/Core/Types.hs +30/−6
- src/IDE/Debug.hs +46/−55
- src/IDE/Find.hs +64/−71
- src/IDE/GUIHistory.hs +13/−14
- src/IDE/ImportTool.hs +14/−32
- src/IDE/Keymap.hs +2/−3
- src/IDE/Leksah.hs +1/−0
- src/IDE/LogRef.hs +4/−3
- src/IDE/Metainfo/Provider.hs +2/−2
- src/IDE/NotebookFlipper.hs +1/−1
- src/IDE/Package.hs +342/−305
- src/IDE/Pane/Breakpoints.hs +6/−6
- src/IDE/Pane/Errors.hs +7/−8
- src/IDE/Pane/Files.hs +54/−44
- src/IDE/Pane/Grep.hs +4/−3
- src/IDE/Pane/HLint.hs +13/−16
- src/IDE/Pane/Info.hs +11/−14
- src/IDE/Pane/Log.hs +30/−41
- src/IDE/Pane/Modules.hs +75/−41
- src/IDE/Pane/PackageEditor.hs +115/−93
- src/IDE/Pane/PackageFlags.hs +27/−22
- src/IDE/Pane/Preferences.hs +56/−51
- src/IDE/Pane/Search.hs +33/−30
- src/IDE/Pane/SourceBuffer.hs +44/−48
- src/IDE/Pane/Trace.hs +13/−11
- src/IDE/Pane/Variables.hs +20/−22
- src/IDE/Pane/WebKit/Documentation.hs +5/−3
- src/IDE/Pane/WebKit/Output.hs +73/−17
- src/IDE/Pane/Workspace.hs +38/−38
- src/IDE/PaneGroups.hs +20/−28
- src/IDE/Sandbox.hs +103/−0
- src/IDE/TextEditor/Class.hs +1/−2
- src/IDE/TextEditor/CodeMirror.hs +3/−0
- src/IDE/TextEditor/Yi.hs +3/−2
- src/IDE/Utils/ExternalTool.hs +15/−12
- src/IDE/Utils/ServerConnection.hs +5/−4
- src/IDE/Workspaces.hs +47/−53
- src/IDE/Workspaces/Writer.hs +6/−6
- src/IDE/YiConfig.hs +2/−6
- tests/IDE/TextEditor/Tests.hs +2/−0
Readme.md view
@@ -4,9 +4,9 @@ This is [Leksah](http://leksah.org/), a hopefully practical tool to support the Haskell development process. -Leksah uses GTK+ as GUI Toolkit with the gtk2hs binding. It is plattform independend+Leksah uses GTK+ as GUI Toolkit with the gtk2hs binding. It is plattform independent and should run on any plattform where GTK+, gtk2hs and ghc can be installed.-It is currently been tested on Linux, Mac OS X and Windows. It uses the Cabal package management+It has currently been tested on Linux, Mac OS X and Windows. It uses the Cabal package management and build system for Package Management. It currently only supports the Glasgow Haskell Compiler (ghc). Documentation can be found on [leksah.org](http://leksah.org/).@@ -22,10 +22,12 @@ To build the latest development version of Leksah follow the steps in the [.travis.yml](.travis.yml) file. -If you are a user or just test Leksah, we would appreciate to hear from you.+If you are a user and would simply like to test Leksah, we would highley appreciate your feedback. Please send questions and suggestions to the [Leksah group](https://groups.google.com/forum/#!forum/leksah)++Thank you!
+ data/candy-hasklig.lkshc view
@@ -0,0 +1,89 @@+-- Candy file+-- reworked accordind to package: base-unicode-symbols++-- Control.Applicative.Unicode+"<*>" 0x229B -- CIRCLED ASTERISK OPERATOR+"empty" 0x2205 -- EMPTY SET++-- Control.Arrow.Unicode+--hasklig ">>>" 0x22D9 -- VERY MUCH GREATER-THAN+--hasklig "<<<" 0x22D8 -- VERY MUCH LESS-THAN+"***" 0x2042 -- ASTERISM+--hasklig "+++" 0x29FB -- TRIPLE PLUS+"|||" 0x2AF4 -- TRIPLE VERTICAL BAR BINARY RELATION++-- Control.Category.Unicode+-- "." 0x2218 -- RING OPERATOR+" . " 0x2218 --RING OPERATOR . -++-- Control.Monad.Unicode+--hasklig ">>=" 0x226B -- MUCH GREATER-THAN) + (U+3D, EQUALS SIGN)+--hasklig ">>" 0x226B -- MUCH GREATER-THAN+--hasklig "=<<" (0x3D, EQUALS SIGN) + (0x226A, MUCH LESS-THAN)++-- Data.Bool.Unicode+"&&" 0x2227 --LOGICAL AND +"||" 0x2228 --LOGICAL OR +"not" 0x00ac --NOT SIGN++-- Data.Eq.Unicode+--hasklig "==" 0x2261 --IDENTICAL TO +--hasklig "/=" 0x2262 --NOT IDENTICAL TO++-- Data.Foldable.Unicode+"elem" 0x2208 -- ELEMENT OF+"notElem" 0x2209 -- NOT AN ELEMENT OF++-- "flip elem" 0x220B -- CONTAINS AS MEMBER+-- flip (not elem) 0x220C -- DOES NOT CONTAIN AS MEMBER++-- Data.Function.Unicode+-- repeated "." 0x2218 -- RING OPERATOR++-- Data.List.Unicode+--hasklig "++" 0x29FA -- DOUBLE PLUS+"union" 0x222A -- UNION+"\\" 0x2216 -- SET MINUS+"intersect" 0x2229 -- INTERSECTION++-- Data.Monoid.Unicode+"mempty" 0x2205 -- EMPTY SET+"mappend" 0x2295 -- CIRCLED PLUS++-- Data.Ord.Unicode+">=" 0x2265 --GREATER-THAN OR EQUAL TO >= -+"<=" 0x2264 --LESS-THAN OR EQUAL TO <= -++-- Prelude.Unicode+"pi" 0x03C0 -- GREEK SMALL LETTER PI+"/" 0x00F7 -- DIVISION SIGN+"*" 0x22C5 -- DOT OPERATOR+"undefined" 0x22A5 -- UP TACK+"Integer" 0x2124 -- DOUBLE-STRUCK CAPITAL Z+"Ratio Integer" 0x2124 -- DOUBLE-STRUCK CAPITAL Q++-- Leksah specific?+--hasklig "->" 0x2192 --RIGHTWARDS ARROW +--hasklig "<-" 0x2190 Trimming --LEFTWARDS ARROW +--hasklig "=>" 0x21d2 --RIGHTWARDS DOUBLE ARROW +--hasklig "::" 0x2237 Trimming --PROPORTION +--hasklig ".." 0x2025 --TWO DOT LEADER +"^" 0x2191 --UPWARDS ARROW +"\" 0x03bb --GREEK SMALL LETTER LAMBDA +"forall" 0x2200 --FOR ALL+"exist" 0x2203 --THERE EXISTS++--hasklig "=<<" 0x291e -- =<< -+--hasklig ">>=" 0x21a0 -- >>= -++-- Some greek Letter+"alpha" 0x03b1 --GREEK SMALL LETTER ALPHA+"beta" 0x03b2 --GREEK SMALL LETTER BETA+"gamma" 0x03b3 --GREEK SMALL LETTER GAMMA+"delta" 0x03b4 --GREEK SMALL LETTER DELTA+"epsilon" 0x03b5 --GREEK SMALL LETTER EPSILON+"zeta" 0x03b6 --GREEK SMALL LETTER ZETA+"eta" 0x03b7 --GREEK SMALL LETTER ETA+"theta" 0x03b8 --GREEK SMALL LETTER THETA++
data/candy.lkshc view
@@ -1,36 +1,89 @@ -- Candy file+-- reworked accordind to package: base-unicode-symbols -"->" 0x2192 --RIGHTWARDS ARROW -> --"<-" 0x2190 Trimming --LEFTWARDS ARROW <- --"=>" 0x21d2 --RIGHTWARDS DOUBLE ARROW => -+-- Control.Applicative.Unicode+"<*>" 0x229B -- CIRCLED ASTERISK OPERATOR+"empty" 0x2205 -- EMPTY SET++-- Control.Arrow.Unicode+">>>" 0x22D9 -- VERY MUCH GREATER-THAN+"<<<" 0x22D8 -- VERY MUCH LESS-THAN+"***" 0x2042 -- ASTERISM+"+++" 0x29FB -- TRIPLE PLUS+"|||" 0x2AF4 -- TRIPLE VERTICAL BAR BINARY RELATION++-- Control.Category.Unicode+-- "." 0x2218 -- RING OPERATOR+" . " 0x2218 --RING OPERATOR . -++-- Control.Monad.Unicode+-- doesn't work yet? ">>=" 0x226B -- MUCH GREATER-THAN) + (U+3D, EQUALS SIGN)+">>" 0x226B -- MUCH GREATER-THAN+-- doesn't work yet? "=<<" (0x3D, EQUALS SIGN) + (0x226A, MUCH LESS-THAN)++-- Data.Bool.Unicode+"&&" 0x2227 --LOGICAL AND +"||" 0x2228 --LOGICAL OR +"not" 0x00ac --NOT SIGN++-- Data.Eq.Unicode+"==" 0x2261 --IDENTICAL TO +"/=" 0x2262 --NOT IDENTICAL TO++-- Data.Foldable.Unicode+"elem" 0x2208 -- ELEMENT OF+"notElem" 0x2209 -- NOT AN ELEMENT OF++-- "flip elem" 0x220B -- CONTAINS AS MEMBER+-- flip (not elem) 0x220C -- DOES NOT CONTAIN AS MEMBER++-- Data.Function.Unicode+-- repeated "." 0x2218 -- RING OPERATOR++-- Data.List.Unicode+"++" 0x29FA -- DOUBLE PLUS+"union" 0x222A -- UNION+"\\" 0x2216 -- SET MINUS+"intersect" 0x2229 -- INTERSECTION++-- Data.Monoid.Unicode+"mempty" 0x2205 -- EMPTY SET+"mappend" 0x2295 -- CIRCLED PLUS++-- Data.Ord.Unicode ">=" 0x2265 --GREATER-THAN OR EQUAL TO >= - "<=" 0x2264 --LESS-THAN OR EQUAL TO <= --"/=" 0x2260 --NOT EQUAL TO /= --"&&" 0x2227 --LOGICAL AND && --"||" 0x2228 --LOGICAL OR || --"++" 0x2295 --CIRCLED PLUS ++ --"::" 0x2237 Trimming --PROPORTION :: --".." 0x2025 --TWO DOT LEADER .. --"^" 0x2191 --UPWARDS ARROW ^ --"==" 0x2261 --IDENTICAL TO == ---- " . " 0x2218 --RING OPERATOR . --"\" 0x03bb --GREEK SMALL LETTER LAMBDA \ -++-- Prelude.Unicode+"pi" 0x03C0 -- GREEK SMALL LETTER PI+"/" 0x00F7 -- DIVISION SIGN+"*" 0x22C5 -- DOT OPERATOR+"undefined" 0x22A5 -- UP TACK+"Integer" 0x2124 -- DOUBLE-STRUCK CAPITAL Z+"Ratio Integer" 0x2124 -- DOUBLE-STRUCK CAPITAL Q++-- Leksah specific?+"->" 0x2192 --RIGHTWARDS ARROW +"<-" 0x2190 Trimming --LEFTWARDS ARROW +"=>" 0x21d2 --RIGHTWARDS DOUBLE ARROW +"::" 0x2237 Trimming --PROPORTION +".." 0x2025 --TWO DOT LEADER +"^" 0x2191 --UPWARDS ARROW +"\" 0x03bb --GREEK SMALL LETTER LAMBDA +"forall" 0x2200 --FOR ALL+"exist" 0x2203 --THERE EXISTS+ -- "=<<" 0x291e -- =<< - ">>=" 0x21a0 -- >>= ---- "$" 0x25ca -- $ ---- ">>" 0x226b -- MUCH GREATER THEN >> - --- "forall" 0x2200 --FOR ALL--- "exist" 0x2203 --THERE EXISTS-"not" 0x00ac --NOT SIGN--"alpha" 0x03b1 --ALPHA-"beta" 0x03b2 --BETA-"gamma" 0x03b3 --GAMMA-"delta" 0x03b4 --DELTA-"epsilon" 0x03b5 --EPSILON-"zeta" 0x03b6 --ZETA-"eta" 0x03b7 --ETA-"theta" 0x03b8 --THETA+-- Some greek Letter+"alpha" 0x03b1 --GREEK SMALL LETTER ALPHA+"beta" 0x03b2 --GREEK SMALL LETTER BETA+"gamma" 0x03b3 --GREEK SMALL LETTER GAMMA+"delta" 0x03b4 --GREEK SMALL LETTER DELTA+"epsilon" 0x03b5 --GREEK SMALL LETTER EPSILON+"zeta" 0x03b6 --GREEK SMALL LETTER ZETA+"eta" 0x03b7 --GREEK SMALL LETTER ETA+"theta" 0x03b8 --GREEK SMALL LETTER THETA
@@ -65,11 +65,19 @@ <menuitem name="With _Text Editor" action="EditPackageText" /> <menuitem name="Package _Flags" action="PackageFlags" /> </menu>+ <menu name="_Sandbox" action="PackageSandbox">+ <menuitem name="_Init" action="SandboxInit" />+ <menuitem name="Init _Shared" action="SandboxInitShared" />+ <menuitem name="_Delete" action="SandboxDelete" />+ <menuitem name="_Add Source..." action="SandboxAddSource" />+ <menuitem name="Add Source S_napshot..." action="SandboxAddSourceSnapshot" />+ </menu> <separator/> <menuitem name="Clea_n" action="CleanPackage" /> <menuitem name="_Configure" action="ConfigPackage" /> <menuitem name="_Build" action="BuildPackage" /> <menuitem name="_Run" action="RunPackage" />+ <menuitem name="Run _JavaScript" action="RunJavaScript" /> <separator/> <menuitem name="_Install Dependencies" action="InstallDependenciesPackage" /> <menuitem name="C_opy" action="CopyPackage" />@@ -81,6 +89,7 @@ <menuitem name="Open Documentation" action="OpenDocPackage" /> </menu> <menu name="_Debug" action="Debug">+ <menuitem name="GHCi" action="DebugToggled" /> <menuitem name="Continue" action="DebugContinue" /> <menuitem name="Abandon" action="DebugAbandon" /> <menuitem name="Stop" action="DebugStop" />@@ -183,6 +192,7 @@ <toolitem name="Configure" action="ConfigPackage"/> <toolitem name="Build" action="BuildPackage"/> <toolitem name="Run" action="RunPackage"/>+ <toolitem name="RunJavaScript" action="RunJavaScript"/> <toolitem name="Next Error" action="NextError"/> <toolitem name="Previous Error" action="PreviousError"/> <separator/>
leksah.cabal view
@@ -1,5 +1,5 @@ name: leksah-version: 0.13.4.2+version: 0.13.4.3 cabal-version: >=1.10 build-type: Simple license: GPL@@ -20,6 +20,7 @@ data/current.lkshs data/candy.lkshc+ data/candy-hasklig.lkshc data/keymap.lkshk data/leksah.menu data/svn.menu@@ -78,6 +79,7 @@ pics/ide_link.png pics/ide_rebuild_meta.png pics/ide_empty.png+ pics/ide_js.png doc/Keybindings.svg doc/leksah_manual.lyx@@ -210,7 +212,7 @@ build-depends: gtk-mac-integration >= 0.2.0.0 && <0.3 if flag(yi)- build-depends: yi >=0.6.6.1 && <0.7+ build-depends: yi >=0.8.1 && <0.9 cpp-options: -DLEKSAH_WITH_YI if flag(yi) && flag(dyre)@@ -242,7 +244,7 @@ hs-source-dirs: src default-language: Haskell98 - build-depends: Cabal >=1.6.0.1 && <1.20, base >=4.0.0.0 && <4.8, binary >=0.5.0.0 && <0.8,+ build-depends: Cabal >=1.10.2.0 && <1.22, base >=4.0.0.0 && <4.8, 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.4, glib >=0.10 && <0.13, mtl >=1.1.0.2 && <2.2, old-time >=1.0.0.1 && <1.2,@@ -253,47 +255,32 @@ ghc >=6.10.1 && <7.9, strict >= 0.3.2 && <0.4, conduit >= 1.0.8 && <1.1, text >= 0.11.1.5 && < 1.2, gio >=0.12.2 && <0.13, transformers >=0.2.2.0 && <0.4, executable-path >=0.0.3 && <0.1,- vcsgui >=0.0.1 && < 0.1, vcswrapper >=0.0.1 && < 0.1,+ vcsgui >=0.0.4 && < 0.1, vcswrapper >=0.0.4 && < 0.1, QuickCheck >=2.4.2 && <2.7, haskell-src-exts >=1.13.5 && <1.15,- hlint >=1.8.59 && <1.9, vado >=0.0.1 && <0.1, shakespeare >=2.0.0.1 && <2.1 - exposed-modules:- IDE.Leksah IDE.Completion IDE.ImportTool- IDE.Find 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.Output- IDE.TextEditor.Class- IDE.TextEditor.CodeMirror- IDE.TextEditor.Yi- IDE.TextEditor.GtkSourceView- IDE.Utils.ExternalTool-- other-modules:- Distribution.PackageDescription.PrettyPrintCopied- Distribution.PackageDescription.ParseCopied+ hlint >=1.8.59 && <1.9, vado >=0.0.1 && <0.1, shakespeare >=2.0.0.1 && <2.1+ 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.Output IDE.TextEditor.Class+ IDE.TextEditor.CodeMirror IDE.TextEditor.Yi+ IDE.TextEditor.GtkSourceView IDE.Utils.ExternalTool if (impl(ghc >= 7.2))- binary-shared >=0.8.2+ build-depends: binary-shared >=0.8.2 other-modules: Paths_leksah @@ -316,7 +303,7 @@ ghc-options: -threaded hs-source-dirs: main- build-depends: leksah == 0.13.4.2, base >= 4.0.0.0 && <=4.8, gtk3 -any+ build-depends: leksah == 0.13.4.3, base >= 4.0.0.0 && <=4.8, gtk3 -any if os(linux) && flag(loc) cpp-options: -DLOCALIZATION build-depends: hgettext, setlocale@@ -335,7 +322,7 @@ if !flag(webkit) buildable: False else- build-depends: leksah ==0.13.4.2, base >=4.0.0.0 && <=4.8,+ build-depends: leksah ==0.13.4.3, base >=4.0.0.0 && <=4.8, jsaddle -any, ghcjs-dom -any if flag(gtk3) build-depends: gtk3 >=0.12.4 && <0.13, gtksourceview3 >=0.10.0 && <0.13,@@ -351,8 +338,8 @@ hs-source-dirs: bew test-suite tests- build-depends: base >=4.0.0.0 && <4.8, Cabal >=1.6.0.1 && <1.19,- QuickCheck >=2.4.2 && <2.7, leksah ==0.13.4.2,+ build-depends: base >=4.0.0.0 && <4.8, Cabal >=1.10.2.0 && <1.22,+ QuickCheck >=2.4.2 && <2.7, leksah ==0.13.4.3, containers, ltk, leksah-server, hslogger, transformers, glib, monad-loops if flag(gtk3)
osx/makedmg.sh view
@@ -58,5 +58,5 @@ if test -e "$LEKSAH_DMG"; then rm "$LEKSAH_DMG" fi-hdiutil create -size 300m -srcfolder "Leksah" "$LEKSAH_DMG" || exit+hdiutil create -size 400m -srcfolder "Leksah" "$LEKSAH_DMG" || exit
+ pics/ide_js.png view
binary file changed (absent → 2799 bytes)
scripts/stage.sh view
@@ -28,8 +28,6 @@ echo https://github.com/leksah/ltk > sources.txt echo https://github.com/leksah/leksah-server >> sources.txt-echo https://github.com/leksah/haskellVCSWrapper.git >> sources.txt-echo https://github.com/leksah/haskellVCSGUI.git >> sources.txt # echo ./vendor/gtk2hs >> sources.txt echo ./ >> sources.txt
− src/Distribution/PackageDescription/ParseCopied.hs
@@ -1,1206 +0,0 @@--------------------------------------------------------------------------------- |--- Module : Distribution.PackageDescription.ParseCopied--- Copyright : Isaac Jones 2003-2005------ Maintainer : cabal-devel@haskell.org--- Portability : portable------ This defined parsers and partial pretty printers for the @.cabal@ format.--- Some of the complexity in this module is due to the fact that we have to be--- backwards compatible with old @.cabal@ files, so there's code to translate--- into the newer structure.--{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Isaac Jones nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.PackageDescription.ParseCopied (- -- * Package descriptions--- readPackageDescription,--- writePackageDescription,--- parsePackageDescription,--- showPackageDescription,-- -- ** Parsing- ParseResult(..),- FieldDescr(..),- LineNo,-- -- ** Supplementary build information--- readHookedBuildInfo,--- parseHookedBuildInfo,--- writeHookedBuildInfo,--- showHookedBuildInfo,-- pkgDescrFieldDescrs,- libFieldDescrs,- executableFieldDescrs,- binfoFieldDescrs,- sourceRepoFieldDescrs,- testSuiteFieldDescrs,- flagFieldDescrs- ) where--import Data.Char (isSpace)-import Data.Maybe (listToMaybe, isJust)-import Data.Monoid ( Monoid(..) )-import Data.List (nub, unfoldr, partition, (\\))-import Control.Monad (liftM, foldM, when, unless)-import System.Directory (doesFileExist)--import Distribution.Text- ( Text(disp, parse), display, simpleParse )-import Distribution.Compat.ReadP- ((+++), option)-import Text.PrettyPrint--import Distribution.ParseUtils hiding (parseFields)-import Distribution.PackageDescription-import Distribution.Package- ( PackageIdentifier(..), Dependency(..), packageName, packageVersion )-import Distribution.ModuleName ( ModuleName )-import Distribution.Version- ( Version(Version), orLaterVersion- , LowerBound(..), asVersionIntervals )-import Distribution.Verbosity (Verbosity)-import Distribution.Compiler (CompilerFlavor(..))-import Distribution.PackageDescription.Configuration (parseCondition, freeVars)-import Distribution.Simple.Utils- ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion- , withFileContents, withUTF8FileContents- , writeFileAtomic, writeUTF8File )----- -------------------------------------------------------------------------------- The PackageDescription type--pkgDescrFieldDescrs :: [FieldDescr PackageDescription]-pkgDescrFieldDescrs =- [ simpleField "name"- disp parse- packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}})- , simpleField "version"- disp parse- packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})- , simpleField "cabal-version"- (either disp disp) (liftM Left parse +++ liftM Right parse)- specVersionRaw (\v pkg -> pkg{specVersionRaw=v})- , simpleField "build-type"- (maybe empty disp) (fmap Just parse)- buildType (\t pkg -> pkg{buildType=t})- , simpleField "license"- disp parseLicenseQ- license (\l pkg -> pkg{license=l})- , simpleField "license-file"- showFilePath parseFilePathQ- licenseFile (\l pkg -> pkg{licenseFile=l})- , simpleField "copyright"- showFreeText parseFreeText- copyright (\val pkg -> pkg{copyright=val})- , simpleField "maintainer"- showFreeText parseFreeText- maintainer (\val pkg -> pkg{maintainer=val})- , commaListField "build-depends"- disp parse- buildDepends (\xs pkg -> pkg{buildDepends=xs})- , simpleField "stability"- showFreeText parseFreeText- stability (\val pkg -> pkg{stability=val})- , simpleField "homepage"- showFreeText parseFreeText- homepage (\val pkg -> pkg{homepage=val})- , simpleField "package-url"- showFreeText parseFreeText- pkgUrl (\val pkg -> pkg{pkgUrl=val})- , simpleField "bug-reports"- showFreeText parseFreeText- bugReports (\val pkg -> pkg{bugReports=val})- , simpleField "synopsis"- showFreeText parseFreeText- synopsis (\val pkg -> pkg{synopsis=val})- , simpleField "description"- showFreeText parseFreeText- description (\val pkg -> pkg{description=val})- , simpleField "category"- showFreeText parseFreeText- category (\val pkg -> pkg{category=val})- , simpleField "author"- showFreeText parseFreeText- author (\val pkg -> pkg{author=val})- , listField "tested-with"- showTestedWith parseTestedWithQ- testedWith (\val pkg -> pkg{testedWith=val})- , listField "data-files"- showFilePath parseFilePathQ- dataFiles (\val pkg -> pkg{dataFiles=val})- , simpleField "data-dir"- showFilePath parseFilePathQ- dataDir (\val pkg -> pkg{dataDir=val})- , listField "extra-source-files"- showFilePath parseFilePathQ- extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val})- , listField "extra-tmp-files"- showFilePath parseFilePathQ- extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val})- ]---- | Store any fields beginning with "x-" in the customFields field of--- a PackageDescription. All other fields will generate a warning.-storeXFieldsPD :: UnrecFieldParser PackageDescription-storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD =- (customFieldsPD pkg) ++ [(f,val)]}-storeXFieldsPD _ _ = Nothing---- ------------------------------------------------------------------------------ The Library type--libFieldDescrs :: [FieldDescr Library]-libFieldDescrs =- [ listField "exposed-modules" disp parseModuleNameQ- exposedModules (\mods lib -> lib{exposedModules=mods})-- , boolField "exposed"- libExposed (\val lib -> lib{libExposed=val})- ] ++ map biToLib binfoFieldDescrs- where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi})--storeXFieldsLib :: UnrecFieldParser Library-storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =- Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}}-storeXFieldsLib _ _ = Nothing---- ------------------------------------------------------------------------------ The Executable type---executableFieldDescrs :: [FieldDescr Executable]-executableFieldDescrs =- [ -- note ordering: configuration must come first, for- -- showPackageDescription.- simpleField "executable"- showToken parseTokenQ- exeName (\xs exe -> exe{exeName=xs})- , simpleField "main-is"- showFilePath parseFilePathQ- modulePath (\xs exe -> exe{modulePath=xs})- ]- ++ map biToExe binfoFieldDescrs- where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi})--storeXFieldsExe :: UnrecFieldParser Executable-storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) =- Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}-storeXFieldsExe _ _ = Nothing---- ------------------------------------------------------------------------------ The TestSuite type---- | An intermediate type just used for parsing the test-suite stanza.--- After validation it is converted into the proper 'TestSuite' type.-data TestSuiteStanza = TestSuiteStanza {- testStanzaTestType :: Maybe TestType,- testStanzaMainIs :: Maybe FilePath,- testStanzaTestModule :: Maybe ModuleName,- testStanzaBuildInfo :: BuildInfo- }--emptyTestStanza :: TestSuiteStanza-emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty--testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza]-testSuiteFieldDescrs =- [ simpleField "type"- (maybe empty disp) (fmap Just parse)- testStanzaTestType (\x suite -> suite { testStanzaTestType = x })- , simpleField "main-is"- (maybe empty showFilePath) (fmap Just parseFilePathQ)- testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x })- , simpleField "test-module"- (maybe empty disp) (fmap Just parseModuleNameQ)- testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x })- ]- ++ map biToTest binfoFieldDescrs- where- biToTest = liftField testStanzaBuildInfo- (\bi suite -> suite { testStanzaBuildInfo = bi })--storeXFieldsTest :: UnrecFieldParser TestSuiteStanza-storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) =- Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}-storeXFieldsTest _ _ = Nothing--validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite-validateTestSuite line stanza =- case testStanzaTestType stanza of- Nothing -> return $- emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza }-- Just tt@(TestTypeUnknown _ _) ->- return emptyTestSuite {- testInterface = TestSuiteUnsupported tt,- testBuildInfo = testStanzaBuildInfo stanza- }-- Just tt | tt `notElem` knownTestTypes ->- return emptyTestSuite {- testInterface = TestSuiteUnsupported tt,- testBuildInfo = testStanzaBuildInfo stanza- }-- Just tt@(TestTypeExe ver) ->- case testStanzaMainIs stanza of- Nothing -> syntaxError line (missingField "main-is" tt)- Just file -> do- when (isJust (testStanzaTestModule stanza)) $- warning (extraField "test-module" tt)- return emptyTestSuite {- testInterface = TestSuiteExeV10 ver file,- testBuildInfo = testStanzaBuildInfo stanza- }-- Just tt@(TestTypeLib ver) ->- case testStanzaTestModule stanza of- Nothing -> syntaxError line (missingField "test-module" tt)- Just module_ -> do- when (isJust (testStanzaMainIs stanza)) $- warning (extraField "main-is" tt)- return emptyTestSuite {- testInterface = TestSuiteLibV09 ver module_,- testBuildInfo = testStanzaBuildInfo stanza- }-- where- missingField name tt = "The '" ++ name ++ "' field is required for the "- ++ display tt ++ " test suite type."-- extraField name tt = "The '" ++ name ++ "' field is not used for the '"- ++ display tt ++ "' test suite type."----- ------------------------------------------------------------------------------ The Benchmark type-{----- | An intermediate type just used for parsing the benchmark stanza.--- After validation it is converted into the proper 'Benchmark' type.-data BenchmarkStanza = BenchmarkStanza {- benchmarkStanzaBenchmarkType :: Maybe BenchmarkType,- benchmarkStanzaMainIs :: Maybe FilePath,- benchmarkStanzaBenchmarkModule :: Maybe ModuleName,- benchmarkStanzaBuildInfo :: BuildInfo- }--emptyBenchmarkStanza :: BenchmarkStanza-emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty--benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza]-benchmarkFieldDescrs =- [ simpleField "type"- (maybe empty disp) (fmap Just parse)- benchmarkStanzaBenchmarkType- (\x suite -> suite { benchmarkStanzaBenchmarkType = x })- , simpleField "main-is"- (maybe empty showFilePath) (fmap Just parseFilePathQ)- benchmarkStanzaMainIs- (\x suite -> suite { benchmarkStanzaMainIs = x })- ]- ++ map biToBenchmark binfoFieldDescrs- where- biToBenchmark = liftField benchmarkStanzaBuildInfo- (\bi suite -> suite { benchmarkStanzaBuildInfo = bi })--storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza-storeXFieldsBenchmark (f@('x':'-':_), val)- t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) =- Just $ t {benchmarkStanzaBuildInfo =- bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}-storeXFieldsBenchmark _ _ = Nothing--validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark-validateBenchmark line stanza =- case benchmarkStanzaBenchmarkType stanza of- Nothing -> return $- emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza }-- Just tt@(BenchmarkTypeUnknown _ _) ->- return emptyBenchmark {- benchmarkInterface = BenchmarkUnsupported tt,- benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza- }-- Just tt | tt `notElem` knownBenchmarkTypes ->- return emptyBenchmark {- benchmarkInterface = BenchmarkUnsupported tt,- benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza- }-- Just tt@(BenchmarkTypeExe ver) ->- case benchmarkStanzaMainIs stanza of- Nothing -> syntaxError line (missingField "main-is" tt)- Just file -> do- when (isJust (benchmarkStanzaBenchmarkModule stanza)) $- warning (extraField "benchmark-module" tt)- return emptyBenchmark {- benchmarkInterface = BenchmarkExeV10 ver file,- benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza- }-- where- missingField name tt = "The '" ++ name ++ "' field is required for the "- ++ display tt ++ " benchmark type."-- extraField name tt = "The '" ++ name ++ "' field is not used for the '"- ++ display tt ++ "' benchmark type."---}--- ------------------------------------------------------------------------------ The BuildInfo type---binfoFieldDescrs :: [FieldDescr BuildInfo]-binfoFieldDescrs =- [ boolField "buildable"- buildable (\val binfo -> binfo{buildable=val})- , commaListField "build-tools"- disp parseBuildTool- buildTools (\xs binfo -> binfo{buildTools=xs})- , spaceListField "cpp-options"- showToken parseTokenQ'- cppOptions (\val binfo -> binfo{cppOptions=val})- , spaceListField "cc-options"- showToken parseTokenQ'- ccOptions (\val binfo -> binfo{ccOptions=val})- , spaceListField "ld-options"- showToken parseTokenQ'- ldOptions (\val binfo -> binfo{ldOptions=val})- , commaListField "pkgconfig-depends"- disp parsePkgconfigDependency- pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs})- , listField "frameworks"- showToken parseTokenQ- frameworks (\val binfo -> binfo{frameworks=val})- , listField "c-sources"- showFilePath parseFilePathQ- cSources (\paths binfo -> binfo{cSources=paths})-- , simpleField "default-language"- (maybe empty disp) (option Nothing (fmap Just parseLanguageQ))- defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang})- , listField "other-languages"- disp parseLanguageQ- otherLanguages (\langs binfo -> binfo{otherLanguages=langs})- , listField "default-extensions"- disp parseExtensionQ- defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts})- , listField "other-extensions"- disp parseExtensionQ- otherExtensions (\exts binfo -> binfo{otherExtensions=exts})- , listField "extensions"- disp parseExtensionQ- oldExtensions (\exts binfo -> binfo{oldExtensions=exts})-- , listField "extra-libraries"- showToken parseTokenQ- extraLibs (\xs binfo -> binfo{extraLibs=xs})- , listField "extra-lib-dirs"- showFilePath parseFilePathQ- extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs})- , listField "includes"- showFilePath parseFilePathQ- includes (\paths binfo -> binfo{includes=paths})- , listField "install-includes"- showFilePath parseFilePathQ- installIncludes (\paths binfo -> binfo{installIncludes=paths})- , listField "include-dirs"- showFilePath parseFilePathQ- includeDirs (\paths binfo -> binfo{includeDirs=paths})- , listField "hs-source-dirs"- showFilePath parseFilePathQ- hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths})- , listField "other-modules"- disp parseModuleNameQ- otherModules (\val binfo -> binfo{otherModules=val})- , listField "ghc-prof-options"- text parseTokenQ- ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val})- , listField "ghc-shared-options"- text parseTokenQ- ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=val})- , optsField "ghc-options" GHC- options (\path binfo -> binfo{options=path})- , optsField "hugs-options" Hugs- options (\path binfo -> binfo{options=path})- , optsField "nhc98-options" NHC- options (\path binfo -> binfo{options=path})- , optsField "jhc-options" JHC- options (\path binfo -> binfo{options=path})- ]--storeXFieldsBI :: UnrecFieldParser BuildInfo-storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) }-storeXFieldsBI _ _ = Nothing----------------------------------------------------------------------------------flagFieldDescrs :: [FieldDescr Flag]-flagFieldDescrs =- [ simpleField "description"- showFreeText parseFreeText- flagDescription (\val fl -> fl{ flagDescription = val })- , boolField "default"- flagDefault (\val fl -> fl{ flagDefault = val })- , boolField "manual"- flagManual (\val fl -> fl{ flagManual = val })- ]----------------------------------------------------------------------------------sourceRepoFieldDescrs :: [FieldDescr SourceRepo]-sourceRepoFieldDescrs =- [ simpleField "type"- (maybe empty disp) (fmap Just parse)- repoType (\val repo -> repo { repoType = val })- , simpleField "location"- (maybe empty showFreeText) (fmap Just parseFreeText)- repoLocation (\val repo -> repo { repoLocation = val })- , simpleField "module"- (maybe empty showToken) (fmap Just parseTokenQ)- repoModule (\val repo -> repo { repoModule = val })- , simpleField "branch"- (maybe empty showToken) (fmap Just parseTokenQ)- repoBranch (\val repo -> repo { repoBranch = val })- , simpleField "tag"- (maybe empty showToken) (fmap Just parseTokenQ)- repoTag (\val repo -> repo { repoTag = val })- , simpleField "subdir"- (maybe empty showFilePath) (fmap Just parseFilePathQ)- repoSubdir (\val repo -> repo { repoSubdir = val })- ]---- ------------------------------------------------------------------ Parsing---- | Given a parser and a filename, return the parse of the file,--- after checking if the file exists.-readAndParseFile :: (FilePath -> (String -> IO a) -> IO a)- -> (String -> ParseResult a)- -> Verbosity- -> FilePath -> IO a-readAndParseFile withFileContents' parser verbosity fpath = do- exists <- doesFileExist fpath- when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")- withFileContents' fpath $ \str -> case parser str of- ParseFailed e -> do- let (line, message) = locatedErrorMsg e- dieWithLocation fpath line message- ParseOk warnings x -> do- mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings- return x-{---readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo-readHookedBuildInfo =- readAndParseFile withFileContents parseHookedBuildInfo---- |Parse the given package file.-readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription-readPackageDescription =- readAndParseFile withUTF8FileContents parsePackageDescription---}-stanzas :: [Field] -> [[Field]]-stanzas [] = []-stanzas (f:fields) = (f:this) : stanzas rest- where- (this, rest) = break isStanzaHeader fields--isStanzaHeader :: Field -> Bool-isStanzaHeader (F _ f _) = f == "executable"-isStanzaHeader _ = False-----------------------------------------------------------------------------------mapSimpleFields :: (Field -> ParseResult Field) -> [Field]- -> ParseResult [Field]-mapSimpleFields f fs = mapM walk fs- where- walk fld@(F _ _ _) = f fld- walk (IfBlock l c fs1 fs2) = do- fs1' <- mapM walk fs1- fs2' <- mapM walk fs2- return (IfBlock l c fs1' fs2')- walk (Section ln n l fs1) = do- fs1' <- mapM walk fs1- return (Section ln n l fs1')---- prop_isMapM fs = mapSimpleFields return fs == return fs----- names of fields that represents dependencies, thus consrca-constraintFieldNames :: [String]-constraintFieldNames = ["build-depends"]-{----- Possible refactoring would be to have modifiers be explicit about what--- they add and define an accessor that specifies what the dependencies--- are. This way we would completely reuse the parsing knowledge from the--- field descriptor.-parseConstraint :: Field -> ParseResult [Dependency]-parseConstraint (F l n v)- | n == "build-depends" = runP l n (parseCommaList parse) v-parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")"---}-{--headerFieldNames :: [String]-headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames))- . map fieldName $ pkgDescrFieldDescrs--}-{--libFieldNames :: [String]-libFieldNames = map fieldName libFieldDescrs- ++ buildInfoNames ++ constraintFieldNames--}--- exeFieldNames :: [String]--- exeFieldNames = map fieldName executableFieldDescrs--- ++ buildInfoNames-{---buildInfoNames :: [String]-buildInfoNames = map fieldName binfoFieldDescrs- ++ map fst deprecatedFieldsBuildInfo---}--- A minimal implementation of the StateT monad transformer to avoid depending--- on the 'mtl' package.-newtype StT s m a = StT { runStT :: s -> m (a,s) }--instance Monad m => Monad (StT s m) where- return a = StT (\s -> return (a,s))- StT f >>= g = StT $ \s -> do- (a,s') <- f s- runStT (g a) s'--get :: Monad m => StT s m s-get = StT $ \s -> return (s, s)--modify :: Monad m => (s -> s) -> StT s m ()-modify f = StT $ \s -> return ((),f s)--lift :: Monad m => m a -> StT s m a-lift m = StT $ \s -> m >>= \a -> return (a,s)--evalStT :: Monad m => StT s m a -> s -> m a-evalStT st s = runStT st s >>= return . fst---- Our monad for parsing a list/tree of fields.------ The state represents the remaining fields to be processed.-type PM a = StT [Field] ParseResult a------ return look-ahead field or nothing if we're at the end of the file-peekField :: PM (Maybe Field)-peekField = get >>= return . listToMaybe---- Unconditionally discard the first field in our state. Will error when it--- reaches end of file. (Yes, that's evil.)-skipField :: PM ()-skipField = modify tail----FIXME: this should take a ByteString, not a String. We have to be able to--- decode UTF8 and handle the BOM.--{----- | Parses the given file into a 'GenericPackageDescription'.------ In Cabal 1.2 the syntax for package descriptions was changed to a format--- with sections and possibly indented property descriptions.-parsePackageDescription :: String -> ParseResult GenericPackageDescription-parsePackageDescription file = do-- -- This function is quite complex because it needs to be able to parse- -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains- -- a lot of parser-related noise since we do not want to depend on Parsec.- --- -- If we detect an pre-1.2 file we implicitly convert it to post-1.2- -- style. See 'sectionizeFields' below for details about the conversion.-- fields0 <- readFields file `catchParseError` \err ->- let tabs = findIndentTabs file in- case err of- -- In case of a TabsError report them all at once.- TabsError tabLineNo -> reportTabsError- -- but only report the ones including and following- -- the one that caused the actual error- [ t | t@(lineNo',_) <- tabs- , lineNo' >= tabLineNo ]- _ -> parseFail err-- let cabalVersionNeeded =- head $ [ minVersionBound versionRange- | Just versionRange <- [ simpleParse v- | F _ "cabal-version" v <- fields0 ] ]- ++ [Version [0] []]- minVersionBound versionRange =- case asVersionIntervals versionRange of- [] -> Version [0] []- ((LowerBound version _, _):_) -> version-- handleFutureVersionParseFailure cabalVersionNeeded $ do-- let sf = sectionizeFields fields0 -- ensure 1.2 format-- -- figure out and warn about deprecated stuff (warnings are collected- -- inside our parsing monad)- fields <- mapSimpleFields deprecField sf-- -- Our parsing monad takes the not-yet-parsed fields as its state.- -- After each successful parse we remove the field from the state- -- ('skipField') and move on to the next one.- --- -- Things are complicated a bit, because fields take a tree-like- -- structure -- they can be sections or "if"/"else" conditionals.-- flip evalStT fields $ do-- -- The header consists of all simple fields up to the first section- -- (flag, library, executable).- header_fields <- getHeader []-- -- Parses just the header fields and stores them in a- -- 'PackageDescription'. Note that our final result is a- -- 'GenericPackageDescription'; for pragmatic reasons we just store- -- the partially filled-out 'PackageDescription' inside the- -- 'GenericPackageDescription'.- pkg <- lift $ parseFields pkgDescrFieldDescrs- storeXFieldsPD- emptyPackageDescription- header_fields-- -- 'getBody' assumes that the remaining fields only consist of- -- flags, lib and exe sections.- (repos, flags, mlib, exes, tests, bms) <- getBody- warnIfRest -- warn if getBody did not parse up to the last field.- -- warn about using old/new syntax with wrong cabal-version:- maybeWarnCabalVersion (not $ oldSyntax fields0) pkg- checkForUndefinedFlags flags mlib exes tests- return $ GenericPackageDescription- pkg { sourceRepos = repos }- flags mlib exes tests bms-- where- oldSyntax flds = all isSimpleField flds- reportTabsError tabs =- syntaxError (fst (head tabs)) $- "Do not use tabs for indentation (use spaces instead)\n"- ++ " Tabs were used at (line,column): " ++ show tabs-- maybeWarnCabalVersion newsyntax pkg- | newsyntax && specVersion pkg < Version [1,2] []- = lift $ warning $- "A package using section syntax must specify at least\n"- ++ "'cabal-version: >= 1.2'."-- maybeWarnCabalVersion newsyntax pkg- | not newsyntax && specVersion pkg >= Version [1,2] []- = lift $ warning $- "A package using 'cabal-version: "- ++ displaySpecVersion (specVersionRaw pkg)- ++ "' must use section syntax. See the Cabal user guide for details."- where- displaySpecVersion (Left version) = display version- displaySpecVersion (Right versionRange) =- case asVersionIntervals versionRange of- [] {- impossible -} -> display versionRange- ((LowerBound version _, _):_) -> display (orLaterVersion version)-- maybeWarnCabalVersion _ _ = return ()--- handleFutureVersionParseFailure cabalVersionNeeded parseBody =- (unless versionOk (warning message) >> parseBody)- `catchParseError` \parseError -> case parseError of- TabsError _ -> parseFail parseError- _ | versionOk -> parseFail parseError- | otherwise -> fail message- where versionOk = cabalVersionNeeded <= cabalVersion- message = "This package requires at least Cabal version "- ++ display cabalVersionNeeded-- -- "Sectionize" an old-style Cabal file. A sectionized file has:- --- -- * all global fields at the beginning, followed by- --- -- * all flag declarations, followed by- --- -- * an optional library section, and an arbitrary number of executable- -- sections (in any order).- --- -- The current implementatition just gathers all library-specific fields- -- in a library section and wraps all executable stanzas in an executable- -- section.- sectionizeFields :: [Field] -> [Field]- sectionizeFields fs- | oldSyntax fs =- let- -- "build-depends" is a local field now. To be backwards- -- compatible, we still allow it as a global field in old-style- -- package description files and translate it to a local field by- -- adding it to every non-empty section- (hdr0, exes0) = break ((=="executable") . fName) fs- (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0-- (deps, libfs) = partition ((== "build-depends") . fName)- libfs0-- exes = unfoldr toExe exes0- toExe [] = Nothing- toExe (F l e n : r)- | e == "executable" =- let (efs, r') = break ((=="executable") . fName) r- in Just (Section l "executable" n (deps ++ efs), r')- toExe _ = bug "unexpeced input to 'toExe'"- in- hdr ++- (if null libfs then []- else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)])- ++ exes- | otherwise = fs-- isSimpleField (F _ _ _) = True- isSimpleField _ = False-- -- warn if there's something at the end of the file- warnIfRest :: PM ()- warnIfRest = do- s <- get- case s of- [] -> return ()- _ -> lift $ warning "Ignoring trailing declarations." -- add line no.-- -- all simple fields at the beginning of the file are (considered) header- -- fields- getHeader :: [Field] -> PM [Field]- getHeader acc = peekField >>= \mf -> case mf of- Just f@(F _ _ _) -> skipField >> getHeader (f:acc)- _ -> return (reverse acc)-- --- -- body ::= { repo | flag | library | executable | test }+ -- at most one lib- --- -- The body consists of an optional sequence of declarations of flags and- -- an arbitrary number of executables and at most one library.- getBody :: PM ([SourceRepo], [Flag]- ,Maybe (CondTree ConfVar [Dependency] Library)- ,[(String, CondTree ConfVar [Dependency] Executable)]- ,[(String, CondTree ConfVar [Dependency] TestSuite)])--- ,[(String, CondTree ConfVar [Dependency] Benchmark)])- getBody = peekField >>= \mf -> case mf of- Just (Section line_no sec_type sec_label sec_fields)- | sec_type == "executable" -> do- when (null sec_label) $ lift $ syntaxError line_no- "'executable' needs one argument (the executable's name)"- exename <- lift $ runP line_no "executable" parseTokenQ sec_label- flds <- collectFields parseExeFields sec_fields- skipField- (repos, flags, lib, exes, tests, bms) <- getBody- return (repos, flags, lib, (exename, flds): exes, tests, bms)-- | sec_type == "test-suite" -> do- when (null sec_label) $ lift $ syntaxError line_no- "'test-suite' needs one argument (the test suite's name)"- testname <- lift $ runP line_no "test" parseTokenQ sec_label- flds <- collectFields (parseTestFields line_no) sec_fields-- -- Check that a valid test suite type has been chosen. A type- -- field may be given inside a conditional block, so we must- -- check for that before complaining that a type field has not- -- been given. The test suite must always have a valid type, so- -- we need to check both the 'then' and 'else' blocks, though- -- the blocks need not have the same type.- let checkTestType ts ct =- let ts' = mappend ts $ condTreeData ct- -- If a conditional has only a 'then' block and no- -- 'else' block, then it cannot have a valid type- -- in every branch, unless the type is specified at- -- a higher level in the tree.- checkComponent (_, _, Nothing) = False- -- If a conditional has a 'then' block and an 'else'- -- block, both must specify a test type, unless the- -- type is specified higher in the tree.- checkComponent (_, t, Just e) =- checkTestType ts' t && checkTestType ts' e- -- Does the current node specify a test type?- hasTestType = testInterface ts'- /= testInterface emptyTestSuite- components = condTreeComponents ct- -- If the current level of the tree specifies a type,- -- then we are done. If not, then one of the conditional- -- branches below the current node must specify a type.- -- Each node may have multiple immediate children; we- -- only one need one to specify a type because the- -- configure step uses 'mappend' to join together the- -- results of flag resolution.- in hasTestType || (any checkComponent components)- if checkTestType emptyTestSuite flds- then do- skipField- (repos, flags, lib, exes, tests, bms) <- getBody- return (repos, flags, lib, exes, (testname, flds) : tests, bms)- else lift $ syntaxError line_no $- "Test suite \"" ++ testname- ++ "\" is missing required field \"type\" or the field "- ++ "is not present in all conditional branches. The "- ++ "available test types are: "- ++ intercalate ", " (map display knownTestTypes)-- | sec_type == "benchmark" -> do- when (null sec_label) $ lift $ syntaxError line_no- "'benchmark' needs one argument (the benchmark's name)"- benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label- flds <- collectFields (parseBenchmarkFields line_no) sec_fields-- -- Check that a valid benchmark type has been chosen. A type- -- field may be given inside a conditional block, so we must- -- check for that before complaining that a type field has not- -- been given. The benchmark must always have a valid type, so- -- we need to check both the 'then' and 'else' blocks, though- -- the blocks need not have the same type.- let checkBenchmarkType ts ct =- let ts' = mappend ts $ condTreeData ct- -- If a conditional has only a 'then' block and no- -- 'else' block, then it cannot have a valid type- -- in every branch, unless the type is specified at- -- a higher level in the tree.- checkComponent (_, _, Nothing) = False- -- If a conditional has a 'then' block and an 'else'- -- block, both must specify a benchmark type, unless the- -- type is specified higher in the tree.- checkComponent (_, t, Just e) =- checkBenchmarkType ts' t && checkBenchmarkType ts' e- -- Does the current node specify a benchmark type?- hasBenchmarkType = benchmarkInterface ts'- /= benchmarkInterface emptyBenchmark- components = condTreeComponents ct- -- If the current level of the tree specifies a type,- -- then we are done. If not, then one of the conditional- -- branches below the current node must specify a type.- -- Each node may have multiple immediate children; we- -- only one need one to specify a type because the- -- configure step uses 'mappend' to join together the- -- results of flag resolution.- in hasBenchmarkType || (any checkComponent components)- if checkBenchmarkType emptyBenchmark flds- then do- skipField- (repos, flags, lib, exes, tests, bms) <- getBody- return (repos, flags, lib, exes, tests, (benchname, flds) : bms)- else lift $ syntaxError line_no $- "Benchmark \"" ++ benchname- ++ "\" is missing required field \"type\" or the field "- ++ "is not present in all conditional branches. The "- ++ "available benchmark types are: "- ++ intercalate ", " (map display knownBenchmarkTypes)-- | sec_type == "library" -> do- when (not (null sec_label)) $ lift $- syntaxError line_no "'library' expects no argument"- flds <- collectFields parseLibFields sec_fields- skipField- (repos, flags, lib, exes, tests, bms) <- getBody- when (isJust lib) $ lift $ syntaxError line_no- "There can only be one library section in a package description."- return (repos, flags, Just flds, exes, tests, bms)-- | sec_type == "flag" -> do- when (null sec_label) $ lift $- syntaxError line_no "'flag' needs one argument (the flag's name)"- flag <- lift $ parseFields- flagFieldDescrs- warnUnrec- (MkFlag (FlagName (lowercase sec_label)) "" True False)- sec_fields- skipField- (repos, flags, lib, exes, tests, bms) <- getBody- return (repos, flag:flags, lib, exes, tests, bms)-- | sec_type == "source-repository" -> do- when (null sec_label) $ lift $ syntaxError line_no $- "'source-repository' needs one argument, "- ++ "the repo kind which is usually 'head' or 'this'"- kind <- case simpleParse sec_label of- Just kind -> return kind- Nothing -> lift $ syntaxError line_no $- "could not parse repo kind: " ++ sec_label- repo <- lift $ parseFields- sourceRepoFieldDescrs- warnUnrec- (SourceRepo {- repoKind = kind,- repoType = Nothing,- repoLocation = Nothing,- repoModule = Nothing,- repoBranch = Nothing,- repoTag = Nothing,- repoSubdir = Nothing- })- sec_fields- skipField- (repos, flags, lib, exes, tests, bms) <- getBody- return (repo:repos, flags, lib, exes, tests, bms)-- | otherwise -> do- lift $ warning $ "Ignoring unknown section type: " ++ sec_type- skipField- getBody- Just f -> do- _ <- lift $ syntaxError (lineNo f) $- "Construct not supported at this position: " ++ show f- skipField- getBody- Nothing -> return ([], [], Nothing, [], [], [])-- -- Extracts all fields in a block and returns a 'CondTree'.- --- -- We have to recurse down into conditionals and we treat fields that- -- describe dependencies specially.- collectFields :: ([Field] -> PM a) -> [Field]- -> PM (CondTree ConfVar [Dependency] a)- collectFields parser allflds = do-- let simplFlds = [ F l n v | F l n v <- allflds ]- condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ]-- let (depFlds, dataFlds) = partition isConstraint simplFlds-- a <- parser dataFlds- deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds-- ifs <- mapM processIfs condFlds-- return (CondNode a deps ifs)- where- isConstraint (F _ n _) = n `elem` constraintFieldNames- isConstraint _ = False-- processIfs (IfBlock l c t e) = do- cnd <- lift $ runP l "if" parseCondition c- t' <- collectFields parser t- e' <- case e of- [] -> return Nothing- es -> do fs <- collectFields parser es- return (Just fs)- return (cnd, t', e')- processIfs _ = bug "processIfs called with wrong field type"-- parseLibFields :: [Field] -> PM Library- parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary-- -- Note: we don't parse the "executable" field here, hence the tail hack.- parseExeFields :: [Field] -> PM Executable- parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable-- parseTestFields :: LineNo -> [Field] -> PM TestSuite- parseTestFields line fields = do- x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest- emptyTestStanza fields- lift $ validateTestSuite line x-- parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark- parseBenchmarkFields line fields = do- x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark- emptyBenchmarkStanza fields- lift $ validateBenchmark line x-- checkForUndefinedFlags ::- [Flag] ->- Maybe (CondTree ConfVar [Dependency] Library) ->- [(String, CondTree ConfVar [Dependency] Executable)] ->- [(String, CondTree ConfVar [Dependency] TestSuite)] ->- PM ()- checkForUndefinedFlags flags mlib exes tests = do- let definedFlags = map flagName flags- maybe (return ()) (checkCondTreeFlags definedFlags) mlib- mapM_ (checkCondTreeFlags definedFlags . snd) exes- mapM_ (checkCondTreeFlags definedFlags . snd) tests-- checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()- checkCondTreeFlags definedFlags ct = do- let fv = nub $ freeVars ct- when (not . all (`elem` definedFlags) $ fv) $- fail $ "These flags are used without having been defined: "- ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]----- | Parse a list of fields, given a list of field descriptions,--- a structure to accumulate the parsed fields, and a function--- that can decide what to do with fields which don't match any--- of the field descriptions.-parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to- -- parse- -> UnrecFieldParser a -- ^ possibly do something with- -- unrecognized fields- -> a -- ^ accumulator- -> [Field] -- ^ fields to be parsed- -> ParseResult a-parseFields descrs unrec ini fields =- do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields- when (not (null unknowns)) $ do- warning $ render $- text "Unknown fields:" <+>- commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")")- (reverse unknowns))- $+$- text "Fields allowed in this section:" $$- nest 4 (commaSep $ map fieldName descrs)- return a- where- commaSep = fsep . punctuate comma . map text--parseField :: [FieldDescr a] -- ^ list of parseable fields- -> UnrecFieldParser a -- ^ possibly do something with- -- unrecognized fields- -> (a,[(Int,String)]) -- ^ accumulated result and warnings- -> Field -- ^ the field to be parsed- -> ParseResult (a, [(Int,String)])-parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val)- | name == f = parser line val a >>= \a' -> return (a',us)- | otherwise = parseField fields unrec (a,us) (F line f val)-parseField [] unrec (a,us) (F l f val) = return $- case unrec (f,val) a of -- no fields matched, see if the 'unrec'- Just a' -> (a',us) -- function wants to do anything with it- Nothing -> (a, ((l,f):us))-parseField _ _ _ _ = bug "'parseField' called on a non-field"--deprecatedFields :: [(String,String)]-deprecatedFields =- deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo--deprecatedFieldsPkgDescr :: [(String,String)]-deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ]--deprecatedFieldsBuildInfo :: [(String,String)]-deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ]---- Handle deprecated fields-deprecField :: Field -> ParseResult Field-deprecField (F line fld val) = do- fld' <- case lookup fld deprecatedFields of- Nothing -> return fld- Just newName -> do- warning $ "The field \"" ++ fld- ++ "\" is deprecated, please use \"" ++ newName ++ "\""- return newName- return (F line fld' val)-deprecField _ = bug "'deprecField' called on a non-field"---parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo-parseHookedBuildInfo inp = do- fields <- readFields inp- let ss@(mLibFields:exes) = stanzas fields- mLib <- parseLib mLibFields- biExes <- mapM parseExe (maybe ss (const exes) mLib)- return (mLib, biExes)- where- parseLib :: [Field] -> ParseResult (Maybe BuildInfo)- parseLib (bi@((F _ inFieldName _):_))- | lowercase inFieldName /= "executable" = liftM Just (parseBI bi)- parseLib _ = return Nothing-- parseExe :: [Field] -> ParseResult (String, BuildInfo)- parseExe ((F line inFieldName mName):bi)- | lowercase inFieldName == "executable"- = do bis <- parseBI bi- return (mName, bis)- | otherwise = syntaxError line "expecting 'executable' at top of stanza"- parseExe (_:_) = bug "`parseExe' called on a non-field"- parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"-- parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st---- ------------------------------------------------------------------------------ Pretty printing--writePackageDescription :: FilePath -> PackageDescription -> IO ()-writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)----TODO: make this use section syntax--- add equivalent for GenericPackageDescription-showPackageDescription :: PackageDescription -> String-showPackageDescription pkg = render $- ppPackage pkg- $$ ppCustomFields (customFieldsPD pkg)- $$ (case library pkg of- Nothing -> empty- Just lib -> ppLibrary lib)- $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ]- where- ppPackage = ppFields pkgDescrFieldDescrs- ppLibrary = ppFields libFieldDescrs- ppExecutable = ppFields executableFieldDescrs--ppCustomFields :: [(String,String)] -> Doc-ppCustomFields flds = vcat (map ppCustomField flds)--ppCustomField :: (String,String) -> Doc-ppCustomField (name,val) = text name <> colon <+> showFreeText val--writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()-writeHookedBuildInfo fpath = writeFileAtomic fpath . showHookedBuildInfo--showHookedBuildInfo :: HookedBuildInfo -> String-showHookedBuildInfo (mb_lib_bi, ex_bis) = render $- (case mb_lib_bi of- Nothing -> empty- Just bi -> ppBuildInfo bi)- $$ vcat [ space- $$ text "executable:" <+> text name- $$ ppBuildInfo bi- | (name, bi) <- ex_bis ]- where- ppBuildInfo bi = ppFields binfoFieldDescrs bi- $$ ppCustomFields (customFieldsBI bi)---- replace all tabs used as indentation with whitespace, also return where--- tabs were found-findIndentTabs :: String -> [(Int,Int)]-findIndentTabs = concatMap checkLine- . zip [1..]- . lines- where- checkLine (lineno, l) =- let (indent, _content) = span isSpace l- tabCols = map fst . filter ((== '\t') . snd) . zip [0..]- addLineNo = map (\col -> (lineno,col))- in addLineNo (tabCols indent)----test_findIndentTabs = findIndentTabs $ unlines $--- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ]--bug :: String -> a-bug msg = error $ msg ++ ". Consider this a bug."---}-
− src/Distribution/PackageDescription/PrettyPrintCopied.hs
@@ -1,238 +0,0 @@------------------------------------------------------------------------------------ Module : Distribution.PackageDescription.PrettyPrintCopied--- Copyright : Jürgen Nicklisch-Franken 2010--- License : AllRightsReserved------ Maintainer : cabal-devel@haskell.org--- Stability : provisional--- Portability : portable------ | Pretty printing for cabal files----------------------------------------------------------------------------------{- All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are-met:-- * Redistributions of source code must retain the above copyright- notice, this list of conditions and the following disclaimer.-- * Redistributions in binary form must reproduce the above- copyright notice, this list of conditions and the following- disclaimer in the documentation and/or other materials provided- with the distribution.-- * Neither the name of Isaac Jones nor the names of other- contributors may be used to endorse or promote products derived- from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}--module Distribution.PackageDescription.PrettyPrintCopied (- writeGenericPackageDescription,- showGenericPackageDescription,-) where--import Distribution.PackageDescription- ( TestSuite(..), TestSuiteInterface(..), testType- , SourceRepo(..),- customFieldsBI, CondTree(..), Condition(..),- FlagName(..), ConfVar(..), Executable(..), Library(..),- Flag(..), PackageDescription(..),- GenericPackageDescription(..))-import Text.PrettyPrint- (hsep, comma, punctuate, fsep, parens, char, nest, empty,- isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)-import Distribution.Simple.Utils (writeUTF8File)-import Distribution.ParseUtils (showFreeText, FieldDescr(..))-import Distribution.PackageDescription.ParseCopied (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,- sourceRepoFieldDescrs)-import Distribution.Package (Dependency(..))-import Distribution.Text (Text(..))-import Data.Maybe (isJust, fromJust, isNothing)--indentWith :: Int-indentWith = 4---- | Recompile with false for regression testing-simplifiedPrinting :: Bool-simplifiedPrinting = False---- | Writes a .cabal file from a generic package description-writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()-writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)---- | Writes a generic package description to a string-showGenericPackageDescription :: GenericPackageDescription -> String-showGenericPackageDescription = render . ppGenericPackageDescription--ppGenericPackageDescription :: GenericPackageDescription -> Doc-ppGenericPackageDescription gpd =- ppPackageDescription (packageDescription gpd)- $+$ ppGenPackageFlags (genPackageFlags gpd)- $+$ ppLibrary (condLibrary gpd)- $+$ ppExecutables (condExecutables gpd)- $+$ ppTestSuites (condTestSuites gpd)--ppPackageDescription :: PackageDescription -> Doc-ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd- $+$ ppCustomFields (customFieldsPD pd)- $+$ ppSourceRepos (sourceRepos pd)--ppSourceRepos :: [SourceRepo] -> Doc-ppSourceRepos [] = empty-ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl--ppSourceRepo :: SourceRepo -> Doc-ppSourceRepo repo =- emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$- (nest indentWith (ppFields sourceRepoFieldDescrs' repo))- where- sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"]--ppFields :: [FieldDescr a] -> a -> Doc-ppFields fields x =- vcat [ ppField name (getter x)- | FieldDescr name getter _ <- fields]--ppField :: String -> Doc -> Doc-ppField name fielddoc | isEmpty fielddoc = empty- | otherwise = text name <> colon <+> fielddoc--ppDiffFields :: [FieldDescr a] -> a -> a -> Doc-ppDiffFields fields x y =- vcat [ ppField name (getter x)- | FieldDescr name getter _ <- fields,- render (getter x) /= render (getter y)]--ppCustomFields :: [(String,String)] -> Doc-ppCustomFields flds = vcat [ppCustomField f | f <- flds]--ppCustomField :: (String,String) -> Doc-ppCustomField (name,val) = text name <> colon <+> showFreeText val--ppGenPackageFlags :: [Flag] -> Doc-ppGenPackageFlags flds = vcat [ppFlag f | f <- flds]--ppFlag :: Flag -> Doc-ppFlag (MkFlag name desc dflt manual) =- emptyLine $ text "flag" <+> ppFlagName name $+$- (nest indentWith ((if null desc- then empty- else text "Description: " <+> showFreeText desc) $+$- (if dflt then empty else text "Default: False") $+$- (if manual then text "Manual: True" else empty)))--ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc-ppLibrary Nothing = empty-ppLibrary (Just condTree) =- emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)- where- ppLib lib Nothing = ppFields libFieldDescrs lib- $$ ppCustomFields (customFieldsBI (libBuildInfo lib))- ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib- $$ ppCustomFields (customFieldsBI (libBuildInfo lib))--ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc-ppExecutables exes =- vcat [emptyLine $ text ("executable " ++ n)- $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes]- where- ppExe (Executable _ modulePath' buildInfo') Nothing =- (if modulePath' == "" then empty else text "main-is:" <+> text modulePath')- $+$ ppFields binfoFieldDescrs buildInfo'- $+$ ppCustomFields (customFieldsBI buildInfo')- ppExe (Executable _ modulePath' buildInfo')- (Just (Executable _ modulePath2 buildInfo2)) =- (if modulePath' == "" || modulePath' == modulePath2- then empty else text "main-is:" <+> text modulePath')- $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2- $+$ ppCustomFields (customFieldsBI buildInfo')--ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc-ppTestSuites suites =- emptyLine $ vcat [ text ("test-suite " ++ n)- $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)- | (n,condTree) <- suites]- where- ppTestSuite testsuite Nothing =- text "type:" <+> disp (testType testsuite)- $+$ maybe empty (\f -> text "main-is:" <+> text f)- (testSuiteMainIs testsuite)- $+$ maybe empty (\m -> text "test-module:" <+> disp m)- (testSuiteModule testsuite)- $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)- $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))-- ppTestSuite (TestSuite _ _ buildInfo' _)- (Just (TestSuite _ _ buildInfo2 _)) =- ppDiffFields binfoFieldDescrs buildInfo' buildInfo2- $+$ ppCustomFields (customFieldsBI buildInfo')-- testSuiteMainIs test = case testInterface test of- TestSuiteExeV10 _ f -> Just f- _ -> Nothing-- testSuiteModule test = case testInterface test of- TestSuiteLibV09 _ m -> Just m- _ -> Nothing--ppCondition :: Condition ConfVar -> Doc-ppCondition (Var x) = ppConfVar x-ppCondition (Lit b) = text (show b)-ppCondition (CNot c) = char '!' <> (ppCondition c)-ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||"- <+> ppCondition c2])-ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&"- <+> ppCondition c2])-ppConfVar :: ConfVar -> Doc-ppConfVar (OS os) = text "os" <> parens (disp os)-ppConfVar (Arch arch) = text "arch" <> parens (disp arch)-ppConfVar (Flag name) = text "flag" <> parens (ppFlagName name)-ppConfVar (Impl c v) = text "impl" <> parens (disp c <+> disp v)--ppFlagName :: FlagName -> Doc-ppFlagName (FlagName name) = text name--ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc-ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =- let res = ppDeps deps- $+$ (vcat $ map ppIf ifs)- $+$ ppIt it mbIt- in if isJust mbIt && isEmpty res- then ppCondTree ct Nothing ppIt- else res- where- ppIf (c,thenTree,mElseTree) =- ((emptyLine $ text "if" <+> ppCondition c) $$- nest indentWith (ppCondTree thenTree- (if simplifiedPrinting then (Just it) else Nothing) ppIt))- $+$ (if isNothing mElseTree- then empty- else text "else"- $$ nest indentWith (ppCondTree (fromJust mElseTree)- (if simplifiedPrinting then (Just it) else Nothing) ppIt))--ppDeps :: [Dependency] -> Doc-ppDeps [] = empty-ppDeps deps =- text "build-depends:" <+> fsep (punctuate comma (map disp deps))--emptyLine :: Doc -> Doc-emptyLine d = text " " $+$ d---
src/IDE/BufferMode.hs view
@@ -111,17 +111,17 @@ let endLineReal = if b && endLine /= startLine then endLine' - 1 else endLine' return (startLine',endLineReal) -inBufContext :: alpha -> IDEBuffer -> (forall editor. TextEditor editor => Notebook -> EditorView editor -> EditorBuffer editor -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha+inBufContext :: MonadIDE m => alpha -> IDEBuffer -> (forall editor. TextEditor editor => Notebook -> EditorView editor -> EditorBuffer editor -> IDEBuffer -> Int -> m alpha) -> m alpha inBufContext def (ideBuf@IDEBuffer{sourceView = v}) f = do- (pane,_) <- guiPropertiesFromName (paneName ideBuf)- nb <- getNotebook pane- mbI <- liftIO $notebookPageNum nb (scrolledWindow ideBuf)+ (pane,_) <- liftIDE $ guiPropertiesFromName (paneName ideBuf)+ nb <- liftIDE $ getNotebook pane+ mbI <- liftIO $ notebookPageNum nb (scrolledWindow ideBuf) case mbI of Nothing -> liftIO $ do sysMessage Normal $ bufferName ideBuf ++ " notebook page not found: unexpected" return def Just i -> do- ebuf <- getBuffer v+ ebuf <- liftIDE $ getBuffer v f nb v ebuf ideBuf i inActiveBufContext :: alpha -> (forall editor. TextEditor editor => Notebook -> EditorView editor -> EditorBuffer editor -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha
src/IDE/Build.hs view
@@ -34,7 +34,7 @@ import Distribution.Package (pkgVersion, pkgName, Dependency(..)) import Data.List (delete, nub, (\\), find) import Distribution.Version (withinRange)-import Data.Maybe (mapMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import IDE.Package (packageClean', packageCopy', packageRegister', buildPackage, packageConfig', packageTest', packageDoc')@@ -44,6 +44,8 @@ import Control.Event (EventSource(..)) import Control.Monad.Trans.Reader (ask) import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad (void)+import Control.Arrow ((***)) -- import Debug.Trace (trace) trace a b = b@@ -74,7 +76,6 @@ data MakeOp = MoConfigure | MoBuild- | MoTest | MoCopy | MoRegister | MoClean@@ -163,12 +164,12 @@ -- finished traversing the topsorted deps or no targets | null currentTargets || null tops = EmptyChain -- operations have to be applied to current- | elem (head tops) currentTargets && not (elem (head tops) noBuilds) =+ | elem (head tops) currentTargets && notElem (head tops) noBuilds = let current = head tops- dependents = case Map.lookup current depGraph of- Nothing -> trace ("Build>>constrMakeChain: unknown package"- ++ show current) []- Just deps -> deps+ dependents = fromMaybe+ (trace ("Build>>constrMakeChain: unknown package" ++ show current)+ [])+ (Map.lookup current depGraph) withoutInstall = msDontInstallLast ms && null (delete current dependents) filteredOps = case firstOp of MoComposed l -> MoComposed (filter (\e -> e /= MoCopy && e /= MoRegister) l)@@ -195,12 +196,10 @@ doBuildChain ms chain@Chain{mcAction = MoConfigure} = packageConfig' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain)) doBuildChain ms chain@Chain{mcAction = MoBuild} =- buildPackage (msBackgroundBuild ms) (msJumpToWarnings ms) (not (msMakeMode ms) && msSingleBuildWithoutLinking ms)+ buildPackage (msBackgroundBuild ms) (msRunUnitTests ms) (msJumpToWarnings ms) (not (msMakeMode ms) && msSingleBuildWithoutLinking ms) (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain)) doBuildChain ms chain@Chain{mcAction = MoDocu} = packageDoc' (msBackgroundBuild ms) (msJumpToWarnings ms) (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain))-doBuildChain ms chain@Chain{mcAction = MoTest} =- packageTest' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain)) doBuildChain ms chain@Chain{mcAction = MoCopy} = packageCopy' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain)) doBuildChain ms chain@Chain{mcAction = MoRegister} =@@ -208,7 +207,7 @@ doBuildChain ms chain@Chain{mcAction = MoClean} = packageClean' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain)) doBuildChain ms chain@Chain{mcAction = MoMetaInfo} =- postSyncIDE (triggerEventIDE UpdateWorkspaceInfo) >> return ()+ void (postSyncIDE (triggerEventIDE UpdateWorkspaceInfo)) doBuildChain ms chain = doBuildChain ms (mcPos chain) constrCont ms pos (Just neg) False = doBuildChain ms neg@@ -232,7 +231,7 @@ showGraph :: MakeGraph -> String showGraph mg = show- $ map (\(k,v) -> (disp (ipdPackageId k), (map (disp . ipdPackageId) v)))+ $ map (\(k,v) -> (disp (ipdPackageId k), map (disp . ipdPackageId) v)) $ Map.toList mg showTopSorted :: [IDEPackage] -> String@@ -277,7 +276,7 @@ constr (from,to) map = case Map.lookup from map of Nothing -> Map.insert from [to] map Just l -> Map.insert from (to : l) map- myEdges = map (\(a,b) -> (lookItUp a, lookItUp b)) $ edges graph+ myEdges = map (lookItUp *** lookItUp) $ edges graph lookItUp = (\(_,e,_)-> e) . lookup
src/IDE/Command.hs view
@@ -66,14 +66,9 @@ import IDE.Pane.PackageFlags import IDE.Pane.PackageEditor import IDE.Pane.Errors-import IDE.Pane.Search-import IDE.Pane.Info-import IDE.Pane.Breakpoints-import IDE.Pane.Trace-import IDE.Pane.Variables import IDE.Package+import IDE.Sandbox import IDE.Pane.Log-import IDE.Session import IDE.Pane.Modules import IDE.Find import IDE.Pane.Info@@ -93,12 +88,12 @@ import Data.List (sort) import Control.Event (registerEvent) import IDE.Pane.Breakpoints- (fillBreakpointList, selectBreak)+ (showBreakpoints, fillBreakpointList, selectBreak) import IDE.Workspaces import IDE.Statusbar import IDE.Pane.Workspace-import IDE.Pane.Variables (fillVariablesListQuiet)-import IDE.Pane.Trace (fillTraceList)+import IDE.Pane.Variables (showVariables, fillVariablesListQuiet)+import IDE.Pane.Trace (showTrace, fillTraceList) import IDE.PaneGroups import IDE.Pane.Search (getSearch, IDESearch(..)) import IDE.Pane.Grep (getGrep)@@ -115,7 +110,9 @@ import Foreign.Ptr (Ptr(..)) import Foreign.ForeignPtr (withForeignPtr) import Graphics.UI.GtkInternals (unToolbar)-import IDE.Session (viewFullScreen, viewDark)+import IDE.Session+ (saveSessionAs, loadSession, saveSession, sessionClosePane,+ loadSessionPrompt, saveSessionAsPrompt, viewFullScreen, viewDark) import qualified Data.Text as T (pack) foreign import ccall safe "gtk_toolbar_set_icon_size"@@ -133,7 +130,7 @@ mkActions = [ AD "vcs" (__ "Version Con_trol") Nothing Nothing (return ()) [] False- ,AD "FilePrint" (__ "_Print File") Nothing Nothing (filePrint) [] False+ ,AD "FilePrint" (__ "_Print File") Nothing Nothing filePrint [] False ,AD "File" (__ "_File") Nothing Nothing (return ()) [] False ,AD "FileNew" (__ "_New Module...") Nothing (Just "gtk-new") (packageTry $ addModule []) [] False@@ -237,9 +234,21 @@ (packageTry packageEditText) [] False -- ,AD "RemovePackage" "_Close Package" Nothing Nothing -- removePackage [] False- ,AD "PackageFlags" (__ "Package Flags") (Just (__ "Edit the package flags used")) Nothing (getFlags Nothing >>= \ p -> displayPane p False) [] False++ ,AD "PackageSandbox" (__ "_Sandbox") Nothing Nothing (return ()) [] False+ ,AD "SandboxInit" (__ "_Init") (Just (__ "Initialise a cabal sandbox for the package")) Nothing+ (packageTry sandboxInit) [] False+ ,AD "SandboxInitShared" (__ "Init _Shared...") (Just (__ "Initialise or use a cabal sandbox in a selected directory")) Nothing+ (packageTry sandboxInitShared) [] False+ ,AD "SandboxDelete" (__ "_Delete") (Just (__ "Delete the cabal sandbox")) Nothing+ (packageTry sandboxDelete) [] False+ ,AD "SandboxAddSource" (__ "_Add Source...") (Just (__ "Add a source package into the sandbox")) Nothing+ (packageTry (sandboxAddSource False)) [] False+ ,AD "SandboxAddSourceSnapshot" (__ "Add Source S_napshot...") (Just (__ "Add a snapshot of a source package into the sandbox")) Nothing+ (packageTry (sandboxAddSource True)) [] False+ ,AD "CleanPackage" (__ "Cl_ean") (Just (__ "Cleans the package")) (Just "ide_clean") (packageTry packageClean) [] False ,AD "ConfigPackage" (__ "_Configure") (Just (__ "Configures the package")) (Just "ide_configure")@@ -252,6 +261,8 @@ (packageTry packageCopy) [] False ,AD "RunPackage" (__ "_Run") (Just (__ "Runs the package")) (Just "ide_run") (packageTry packageRun) [] False+ ,AD "RunJavaScript" (__ "_Run JavaScript") (Just (__ "Run jsexe created by GHCJS")) (Just "ide_js")+ (packageTry packageRunJavaScript) [] False ,AD "ResolveErrors" (__ "Resol_ve Errors") (Just (__ "Resolve 'Hidden package' and 'Not in scope' errors by adding the necessary dependancies or imports")) Nothing resolveErrors [] False @@ -405,7 +416,7 @@ ,AD "ViewCollapse" (__ "_Collapse") Nothing Nothing viewCollapse [] False ,AD "ViewNest" (__ "_Group") Nothing Nothing- (viewNewGroup) [] False+ viewNewGroup [] False ,AD "ViewDetach" (__ "_Detach") Nothing Nothing viewDetachInstrumented [] False ,AD "ViewFullScreen" (__ "_Full Screen") Nothing Nothing@@ -466,7 +477,7 @@ runUnitTestsToggled [] True ,AD "MakeModeToggled" (__ "_MakeMode") (Just (__ "Make dependent packages")) (Just "ide_make") makeModeToggled [] True- ,AD "DebugToggled" (__ "_Debug") (Just (__ "Use GHCi debugger to build and run")) (Just "ide_debug")+ ,AD "DebugToggled" "_GHCi" (Just (__ "Use GHCi debugger to build and run")) (Just "ide_debug") debugToggled [] True ,AD "OpenDocu" (__ "_OpenDocu") (Just (__ "Opens a browser for a search of the selected data")) Nothing openDocu [] True@@ -479,10 +490,7 @@ menuDescription = do dataDir <- getDataDir prefsPath <- getConfigFilePathForLoad "leksah.menu" Nothing dataDir- res <- readFile prefsPath- return res--+ readFile prefsPath updateRecentEntries :: IDEAction updateRecentEntries = do@@ -532,8 +540,8 @@ where actm ideR ag (AD name label tooltip stockId ideAction accs isToggle) = do let (acc,accString) = if null accs- then (Just "","=" ++ name)- else (Just (head accs),(head accs) ++ "=" ++ name)+ then (Just "", "=" ++ name)+ else (Just (head accs), head accs ++ "=" ++ name) if isToggle then do act <- toggleActionNew name label tooltip stockId@@ -544,10 +552,10 @@ on act actionActivated $ doAction ideAction ideR accString actionGroupAddActionWithAccel ag act acc doAction ideAction ideR accStr =- (reflectIDE (do+ reflectIDE (do ideAction triggerEventIDE (StatusbarChanged [CompartmentCommand accStr])- return ()) ideR)+ return ()) ideR -- getMenuAndToolbars :: UIManager -> IO (AccelGroup, MenuBar, Toolbar) getMenuAndToolbars uiManager = do@@ -573,7 +581,8 @@ mi1 `on` menuItemActivate $ reflectIDE_ debugExecuteSelection menuShellAppend menu mi1 mi11 <- menuItemNewWithLabel (__ "Eval & Insert")- mi11 `on` menuItemActivate $ reflectIDE_ debugExecuteAndShowSelection+ mi11 `on` menuItemActivate $+ reflectIDE_ debugExecuteAndShowSelection menuShellAppend menu mi11 mi12 <- menuItemNewWithLabel (__ "Step") mi12 `on` menuItemActivate $ reflectIDE_ debugStepExpression@@ -601,27 +610,31 @@ mi2 `on` menuItemActivate $ reflectIDE_ (editFindInc Initial) menuShellAppend menu mi2 mi3 <- menuItemNewWithLabel (__ "Search (metadata)")- mi3 `on` menuItemActivate $ (reflectIDE_ $- getSearch Nothing >>= (\search -> do- mbtext <- selectedText- case mbtext of- Just t -> searchMetaGUI search t- Nothing -> ideMessage Normal (__ "Select a text first")))+ mi3 `on` menuItemActivate $+ reflectIDE_ $+ getSearch Nothing >>=+ (\ search ->+ do mbtext <- selectedText+ case mbtext of+ Just t -> searchMetaGUI search t+ Nothing -> ideMessage Normal (__ "Select a text first")) menuShellAppend menu mi3 let interpretingEntries = [castToWidget mi16]- let interpretingSelEntries = [castToWidget mi1, castToWidget mi11, castToWidget mi12,- castToWidget mi13, castToWidget mi14, castToWidget mi141,- castToWidget mi15]+ let interpretingSelEntries+ = [castToWidget mi1, castToWidget mi11, castToWidget mi12,+ castToWidget mi13, castToWidget mi14, castToWidget mi141,+ castToWidget mi15] let otherEntries = [castToWidget mi2, castToWidget mi3] -- isInterpreting' <- (reflectIDE isInterpreting ideR)- selected <- (reflectIDE selectedText ideR)+ selected <- reflectIDE selectedText ideR -- unless isInterpreting' -- $ mapM_ (\w -> widgetSetSensitive w False) (interpretingEntries ++ interpretingSelEntries) -- unless (isJust selected) -- $ mapM_ (\w -> widgetSetSensitive w False) (otherEntries ++ interpretingSelEntries) mapM_ widgetShow interpretingEntries mapM_ widgetShow interpretingSelEntries- mapM_ widgetShow (castToWidget sep1 : castToWidget sep2 : otherEntries)+ mapM_ widgetShow+ (castToWidget sep1 : castToWidget sep2 : otherEntries) mapM_ widgetHide $ take 2 (reverse items) canQuit :: IDEM Bool@@ -645,12 +658,12 @@ aboutDialog = do d <- aboutDialogNew dd <- getDataDir- license <- catch (readFile $ dd </> (__ "LICENSE")) (\ (_ :: SomeException) -> return "")+ license <- catch (readFile $ dd </> __ "LICENSE") (\ (_ :: SomeException) -> return "") set d [ aboutDialogName := "Leksah" , aboutDialogVersion := showVersion version- , aboutDialogCopyright := (__ "Copyright 2007-2011 Jürgen Nicklisch-Franken, Hamish Mackenzie")- , aboutDialogComments := (__ "An integrated development environement (IDE) for the ") ++- (__ "programming language Haskell and the Glasgow Haskell Compiler")+ , aboutDialogCopyright := __ "Copyright 2007-2011 Jürgen Nicklisch-Franken, Hamish Mackenzie"+ , aboutDialogComments := __ "An integrated development environement (IDE) for the " +++ __ "programming language Haskell and the Glasgow Haskell Compiler" , aboutDialogLicense := Just license , aboutDialogWebsite := "http://leksah.org/" , aboutDialogAuthors := ["Jürgen Nicklisch-Franken","Hamish Mackenzie"] ]@@ -668,7 +681,7 @@ "ide_method","ide_newtype","ide_other","ide_rule","ide_run","ide_slot", "ide_source","ide_type","leksah", "ide_reexported", "ide_clean", "ide_link", "ide_build", "ide_debug", "ide_step", "ide_local", "ide_module", "ide_continue", "ide_rebuild_meta",- "ide_empty","ide_source_local"]+ "ide_empty","ide_source_local", "ide_js"] iconFactoryAddDefault iconFactory) (\(e :: SomeException) -> getDataDir >>= \dataDir -> throwIDE (printf (__ "Can't load icons from %s %s") dataDir (show e))) where@@ -678,10 +691,10 @@ iconFactoryAdd iconFactory name icon setSensitivity :: [(SensitivityMask, Bool)] -> IDEAction-setSensitivity l = mapM_ setSensitivitySingle l+setSensitivity = mapM_ setSensitivitySingle where setSensitivitySingle (sens,bool) = do actions <- getActionsFor sens- liftIO $ mapM_ (\a -> actionSetSensitive a bool) actions+ liftIO $ mapM_ (`actionSetSensitive` bool) actions let additionalActions = getAdditionalActionsFor sens mapM_ (\a -> a bool) additionalActions @@ -711,7 +724,7 @@ uiManager' <- getUiManager actionGroups <- liftIO $ uiManagerGetActionGroups uiManager' res <- liftIO $ actionGroupGetAction (head actionGroups) string- when (isNothing res) $ ideMessage Normal $ (printf (__ "Can't find UI Action %s") string)+ when (isNothing res) $ ideMessage Normal $ printf (__ "Can't find UI Action %s") string return res getAdditionalActionsFor :: SensitivityMask -> [Bool -> IDEAction]@@ -826,8 +839,7 @@ return True where printMods :: [Modifier] -> String- printMods [] = ""- printMods (m:r) = show m ++ printMods r+ printMods = concatMap show setSymbol :: String -> Bool -> IDEAction setSymbol symbol openSource = do@@ -835,7 +847,8 @@ search <- getSearch Nothing case currentInfo' of Nothing -> return ()- Just ((GenScopeC (PackScope _ symbolTable1)),(GenScopeC (PackScope _ symbolTable2))) ->+ Just (GenScopeC (PackScope _ symbolTable1),+ GenScopeC (PackScope _ symbolTable2)) -> case filter (not . isReexported) (getIdentifierDescr symbol symbolTable1 symbolTable2) of [] -> return () a:[] -> selectIdentifier a openSource@@ -880,9 +893,9 @@ registerEvent stRef "Sensitivity" (\ s@(Sensitivity h) -> setSensitivity h >> return s) registerEvent stRef "SearchMeta"- (\ e@(SearchMeta string) -> getSearch Nothing >>= (flip searchMetaGUI) string >> return e)+ (\ e@(SearchMeta string) -> getSearch Nothing >>= flip searchMetaGUI string >> return e) registerEvent stRef "StartFindInitial"- (\ e@(StartFindInitial) -> editFindInc Initial >> return e)+ (\ e@StartFindInitial -> editFindInc Initial >> return e) registerEvent stRef "LoadSession" (\ e@(LoadSession fp) -> loadSession fp >> return e) registerEvent stRef "SaveSession"
src/IDE/Command/VCS/Common.hs view
@@ -46,14 +46,14 @@ -- create or get packageItem and set it to ide to be able to get it later again (oldMenuItems,pw) <- readIDE vcsData- packageItem <- do- case (Map.lookup cabalFp oldMenuItems) of- Nothing -> liftIO $ Gtk.menuItemNewWithLabel cabalFp- Just menuItem -> return menuItem+ packageItem <-+ case Map.lookup cabalFp oldMenuItems of+ Nothing -> liftIO $ Gtk.menuItemNewWithLabel cabalFp+ Just menuItem -> return menuItem let newMenuItems = Map.insert cabalFp packageItem oldMenuItems modifyIDE_ (\ide -> ide {vcsData = (newMenuItems,pw)}) - packageMenu <- liftIO $ Gtk.menuNew+ packageMenu <- liftIO Gtk.menuNew -- build and set set-up repo action setupActionItem <- liftIO $ Gtk.menuItemNewWithMnemonic "_Setup Repo"@@ -76,13 +76,13 @@ liftIO $ Gtk.widgetShowAll vcsMenu return () where- addActions cabalFp packageMenu ideR actions = mapM_ (\(name,action) -> do- -- for each operation add it to menu and connect action- actionItem <- Gtk.menuItemNewWithMnemonic name- actionItem `Gtk.on` Gtk.menuItemActivate $- reflectIDE (runActionWithContext action cabalFp) ideR- Gtk.menuShellAppend packageMenu actionItem- ) actions+ addActions cabalFp packageMenu ideR+ = mapM_+ (\ (name, action) ->+ do actionItem <- Gtk.menuItemNewWithMnemonic name+ actionItem `Gtk.on` Gtk.menuItemActivate $+ reflectIDE (runActionWithContext action cabalFp) ideR+ Gtk.menuShellAppend packageMenu actionItem) mkVCSActions :: VCS.VCSType -> [(String, Types.VCSAction ())] mkVCSActions VCS.SVN = SVN.mkSVNActions mkVCSActions VCS.GIT = GIT.mkGITActions@@ -100,7 +100,7 @@ -> IDEAction runActionWithContext vcsAction packageFp = do config <- getVCSConf'' packageFp- runVcs config packageFp $ vcsAction+ runVcs config packageFp vcsAction where runVcs :: VCSConf -> FilePath -> Types.VCSAction t -> IDEM t runVcs config cabalFp (Types.VCSAction a) = runReaderT a (config,cabalFp)@@ -119,7 +119,7 @@ liftIO $ VCSGUI.showSetupConfigGUI mbConfig (callback ide packageFp) where callback :: IDERef -> FilePath -> Maybe (VCS.VCSType, VCS.Config, Maybe VCSGUI.MergeTool) -> IO()- callback ideRef packageFp mbConfig = do+ callback ideRef packageFp mbConfig = -- set config in workspace runReaderT (workspaceSetVCSConfig packageFp mbConfig) ideRef @@ -156,7 +156,7 @@ getVCSConf pathToPackage = do mbWorkspace <- readIDE workspace case mbWorkspace of- Nothing -> return $ Left $ "No open workspace. Open Workspace first."+ Nothing -> return $ Left "No open workspace. Open Workspace first." Just workspace -> getVCSConf' workspace pathToPackage -- | vcs conf for given package in given workspace.@@ -165,7 +165,7 @@ let mbConfig = Map.lookup pathToPackage $ packageVcsConf workspace case mbConfig of --Left $ "Could not find version-control-system configuration for package "++pathToPackage- Nothing -> return $ Right $ Nothing+ Nothing -> return $ Right Nothing Just conf -> return $ Right $ Just conf -- | vcs conf for given package in current workspace. Workspae and VCS conf must be set before.
src/IDE/Command/VCS/Common/Helper.hs view
@@ -40,7 +40,7 @@ -> Types.VCSAction () createActionFromContext vcsAction = do ((_,conf,_),_) <- ask- liftIO $ VCSGUI.defaultVCSExceptionHandler $ VCS.runVcs conf $ vcsAction+ liftIO $ VCSGUI.defaultVCSExceptionHandler $ VCS.runVcs conf vcsAction {- | Creates an 'eMergeToolSetter' (Either MergeTool or MT-Setter) from given parameters.@@ -49,16 +49,16 @@ -> FilePath -> Maybe VCSGUI.MergeTool -> Either VCSGUI.MergeTool (VCSGUI.MergeTool -> IO())-eMergeToolSetter ideRef cabalFp mbMergeTool = do+eMergeToolSetter ideRef cabalFp mbMergeTool = case mbMergeTool of- Nothing -> Right $ mergeToolSetter ideRef cabalFp- Just mergeTool -> Left $ mergeTool+ Nothing -> Right $ mergeToolSetter ideRef cabalFp+ Just mergeTool -> Left mergeTool {- | Facility to set a mergetool for a given package. -} mergeToolSetter :: IDERef -> FilePath -> VCSGUI.MergeTool -> IO()-mergeToolSetter ideRef cabalFp mergeTool = do+mergeToolSetter ideRef cabalFp mergeTool = runReaderT (workspaceSetMergeTool cabalFp mergeTool) ideRef {- |@@ -69,7 +69,7 @@ modifyIDE_ (\ide -> do let oldWs = fromJust (workspace ide) let oldMap = packageVcsConf oldWs- case (Map.lookup pathToPackage oldMap) of+ case Map.lookup pathToPackage oldMap of Nothing -> ide --TODO error Just (vcsType,config,_) -> do let vcsConf = (vcsType,config,Just mergeTool)
src/IDE/Command/VCS/Common/Workspaces.hs view
@@ -44,42 +44,43 @@ onWorkspaceClose :: IDEAction onWorkspaceClose = do- vcsItem <- GUIUtils.getVCS- liftIO $ menuItemRemoveSubmenu vcsItem+ vcsItem <- GUIUtils.getVCS+ liftIO $ menuItemRemoveSubmenu vcsItem onWorkspaceOpen :: Workspace -> IDEAction onWorkspaceOpen ws = do- liftIO $ debugM "leksah" "onWorkspaceOpen"- let mbPackages = wsPackages ws- packages <- mapM (mapper ws)- mbPackages- vcsItem <- GUIUtils.getVCS- vcsMenu <- liftIO $ menuNew+ liftIO $ debugM "leksah" "onWorkspaceOpen"+ let mbPackages = wsAllPackages ws+ packages <- mapM (mapper ws)+ mbPackages+ vcsItem <- GUIUtils.getVCS+ vcsMenu <- liftIO menuNew - ideR <- ask+ ideR <- ask - --for each package add an extra menu containing vcs specific menuitems- mapM_ (\(p,mbVcsConf) -> do- Common.setMenuForPackage vcsMenu (ipdCabalFile p) mbVcsConf- liftIO $ menuItemSetSubmenu vcsItem vcsMenu- )- packages+ --for each package add an extra menu containing vcs specific menuitems+ mapM_ (\(p,mbVcsConf) -> do+ Common.setMenuForPackage vcsMenu (ipdCabalFile p) mbVcsConf+ liftIO $ menuItemSetSubmenu vcsItem vcsMenu+ )+ packages - liftIO $ widgetShowAll vcsItem- return ()- where- mapper :: Workspace -> IDEPackage -> IDEM (IDEPackage, Maybe VCSConf)- mapper workspace p = do- let fp = ipdCabalFile p- eErrConf <- Common.getVCSConf' workspace fp- case eErrConf of- Left error -> do- liftIO $ putStrLn $ "Could not retrieve vcs-conf due to '"++error++"'."- return (p, Nothing)- Right mbConf -> case mbConf of- Nothing -> do- liftIO $ putStrLn $ "Could not retrieve vcs-conf for active package. No vcs-conf set up."- return (p, Nothing)- Just vcsConf -> return $ (p, Just vcsConf)+ liftIO $ widgetShowAll vcsItem+ return ()+ where+ mapper :: Workspace -> IDEPackage -> IDEM (IDEPackage, Maybe VCSConf)+ mapper workspace p = do+ let fp = ipdCabalFile p+ eErrConf <- Common.getVCSConf' workspace fp+ case eErrConf of+ Left error -> do+ liftIO $ putStrLn $ "Could not retrieve vcs-conf due to '"++error++"'."+ return (p, Nothing)+ Right mbConf -> case mbConf of+ Nothing -> do+ liftIO $ putStrLn+ "Could not retrieve vcs-conf for active package. No vcs-conf set up."+ return (p, Nothing)+ Just vcsConf -> return (p, Just vcsConf)
src/IDE/Command/VCS/Mercurial.hs view
@@ -32,10 +32,10 @@ viewLogAction = Helper.createActionFromContext MercurialGUI.showLogGUI pushAction :: Types.VCSAction ()-pushAction = Helper.createActionFromContext $ Mercurial.push+pushAction = Helper.createActionFromContext Mercurial.push pullAction :: Types.VCSAction ()-pullAction = Helper.createActionFromContext $ Mercurial.pull+pullAction = Helper.createActionFromContext Mercurial.pull mkMercurialActions :: [(String, Types.VCSAction ())] mkMercurialActions = [
src/IDE/Command/VCS/SVN.hs view
@@ -72,11 +72,11 @@ Just mb -> Helper.createActionFromContext $ action $ Right mb where -- passwordHandler :: IORef IDE-> Maybe MergeId -> ((Maybe (Bool, Maybe String)) -> Wrapper.Ctx ())- passwordHandler ide mbMergeInfo result = liftIO $ do+ passwordHandler ide mbMergeInfo result = liftIO $ case result of Just (True, pw) -> modifyIDE_' ide (\ide -> ide {vcsData = (mbMergeInfo, Just pw) }) _ -> return ()- modifyIDE_' ide f = do+ modifyIDE_' ide f = liftIO (atomicModifyIORef ide f') where f' a = (f a,())
src/IDE/Command/VCS/Types.hs view
@@ -28,7 +28,7 @@ deriving (Functor, Applicative, Monad, MonadIO, MonadReader (VCSConf,FilePath)) askIDERef :: VCSAction IDERef-askIDERef = VCSAction $ lift $ ask+askIDERef = VCSAction $ lift ask --liftIDE :: ReaderT (VCSConf,FilePath) IDEM a --liftIDE = VCSAction $ lift@@ -37,4 +37,4 @@ readIDE' f = VCSAction $ lift $ readIDE f reflectIDE' :: IDEM a -> IDERef -> IO a-reflectIDE' c ideR = reflectIDE c ideR+reflectIDE' = reflectIDE
src/IDE/Core/State.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeSynonymInstances, MultiParamTypeClasses, ScopedTypeVariables, CPP, DeriveDataTypeable #-}@@ -62,7 +63,6 @@ --, deactivatePane --, deactivatePaneIfActive --, closePane-, activeProjectDir , changePackage , liftYiControl@@ -73,11 +73,7 @@ , getDataDir , P.version -, module IDE.Core.Types-, module IDE.Core.CTypes-, module IDE.Utils.Utils-, module Graphics.UI.Frame.Panes-, module Graphics.UI.Frame.ViewFrame+, module Reexported ) where @@ -88,17 +84,17 @@ import Control.Exception import Prelude hiding (catch) import Control.Monad.IO.Class (MonadIO, liftIO)-import IDE.Core.Types-import Graphics.UI.Frame.Panes-import Graphics.UI.Frame.ViewFrame --hiding (notebookInsertOrdered)+import IDE.Core.Types as Reexported+import Graphics.UI.Frame.Panes as Reexported+import Graphics.UI.Frame.ViewFrame as Reexported --hiding (notebookInsertOrdered) import Control.Event import System.IO import Data.Maybe (isJust) import System.FilePath (dropFileName, takeDirectory, (</>), takeFileName)-import IDE.Core.CTypes+import IDE.Core.CTypes as Reexported import Control.Concurrent (forkIO)-import IDE.Utils.Utils+import IDE.Utils.Utils as Reexported import qualified Data.Map as Map (empty, lookup) import Data.Typeable(Typeable) import qualified IDE.YiConfig as Yi@@ -107,7 +103,7 @@ (transPipe, Sink, awaitForever, yield, leftover, ($$)) import qualified Data.Conduit.List as CL (sourceList)-import Control.Monad (liftM, when)+import Control.Monad (void, liftM, when) import Control.Monad.Trans.Reader (ask, ReaderT(..)) import qualified Paths_leksah as P import System.Environment.Executable (getExecutablePath)@@ -119,8 +115,8 @@ runInIO f = reifyIDE (\ideRef -> return (\v -> reflectIDE (f v) ideRef)) panePathForGroup id = do prefs <- readIDE prefs- case id `lookup` (categoryForPane prefs) of- Just group -> case group `lookup` (pathForCategory prefs) of+ case id `lookup` categoryForPane prefs of+ Just group -> case group `lookup` pathForCategory prefs of Nothing -> return (defaultPath prefs) Just p -> return p Nothing -> return (defaultPath prefs)@@ -194,7 +190,7 @@ updateRecent ide = ide{recentPanes = paneName pane : filter (/= paneName pane) (recentPanes ide)} trigger :: Maybe String -> Maybe String -> IDEAction trigger s1 s2 = do- triggerEventIDE (RecordHistory ((PaneSelected s1), PaneSelected s2))+ triggerEventIDE (RecordHistory (PaneSelected s1, PaneSelected s2)) triggerEventIDE (Sensitivity [(SensitivityEditor, False)]) return () --closeThisPane :: forall alpha beta . RecoverablePane alpha beta delta => alpha -> delta Bool@@ -225,13 +221,13 @@ putStrLn str hFlush stdout -ideMessage :: MessageLevel -> String -> IDEAction+ideMessage :: MonadIDE m => MessageLevel -> String -> m () ideMessage level str = do liftIO $ sysMessage level str triggerEventIDE (LogMessage (str ++ "\n") LogTag) return () -logMessage :: String -> LogTag -> IDEAction+logMessage :: MonadIDE m => String -> LogTag -> m () logMessage str tag = do triggerEventIDE (LogMessage (str ++ "\n") tag) return ()@@ -255,21 +251,15 @@ -- Main window is always the first one in the list window = head . windows -activeProjectDir :: IDEM FilePath-activeProjectDir = do- activePack' <- readIDE activePack- case activePack' of- Nothing -> return "."- Just pack -> return (dropFileName (ipdCabalFile pack))- errorRefs :: IDE -> [LogRef]-errorRefs = (filter ((\t -> t == ErrorRef || t == WarningRef) . logRefType)) . allLogRefs+errorRefs = filter ((\ t -> t == ErrorRef || t == WarningRef) . logRefType) .+ allLogRefs breakpointRefs :: IDE -> [LogRef]-breakpointRefs = (filter ((== BreakpointRef) . logRefType)) . allLogRefs+breakpointRefs = filter ((== BreakpointRef) . logRefType) . allLogRefs contextRefs :: IDE -> [LogRef]-contextRefs = (filter ((== ContextRef) . logRefType)) . allLogRefs+contextRefs = filter ((== ContextRef) . logRefType) . allLogRefs currentError = (\(e,_,_)-> e) . currentEBC currentBreak = (\(_,b,_)-> b) . currentEBC@@ -277,10 +267,10 @@ setCurrentError e = do modifyIDE_ (\ide -> ide{currentEBC = (e, currentBreak ide, currentContext ide)})- triggerEventIDE (CurrentErrorChanged e) >> return ()+ triggerEventIDE_ (CurrentErrorChanged e) setCurrentBreak b = do modifyIDE_ (\ide -> ide{currentEBC = (currentError ide, b, currentContext ide)})- triggerEventIDE (CurrentBreakChanged b) >> return ()+ triggerEventIDE_ (CurrentBreakChanged b) setCurrentContext c = modifyIDE_ (\ide -> ide{currentEBC = (currentError ide, currentBreak ide, c)}) isStartingOrClosing :: IDEState -> Bool@@ -288,22 +278,25 @@ isStartingOrClosing IsShuttingDown = True isStartingOrClosing _ = False -isInterpreting :: IDEM Bool-isInterpreting = do+isInterpreting :: MonadIDE m => m Bool+isInterpreting = readIDE debugState >>= \mb -> return (isJust mb) -triggerEventIDE :: IDEEvent -> IDEM IDEEvent-triggerEventIDE e = ask >>= \ideR -> triggerEvent ideR e+triggerEventIDE :: MonadIDE m => IDEEvent -> m IDEEvent+triggerEventIDE e = liftIDE $ ask >>= \ideR -> triggerEvent ideR e +triggerEventIDE_ :: MonadIDE m => IDEEvent -> m ()+triggerEventIDE_ = void . triggerEventIDE+ -- -- | A reader monad for a mutable reference to the IDE state -- -reifyIDE :: (IDERef -> IO a) -> IDEM a-reifyIDE = ReaderT+reifyIDE :: MonadIDE m => (IDERef -> IO a) -> m a+reifyIDE = liftIDE . ReaderT reflectIDE :: IDEM a -> IDERef -> IO a-reflectIDE c ideR = runReaderT c ideR+reflectIDE = runReaderT reflectIDEI :: C.Sink a IDEM () -> IDERef -> C.Sink a IO () reflectIDEI c ideR = C.transPipe (`reflectIDE` ideR) c@@ -320,50 +313,47 @@ catchIDE block handler = reifyIDE (\ideR -> catch (reflectIDE block ideR) handler) forkIDE :: IDEAction -> IDEAction-forkIDE block = reifyIDE (\ideR -> forkIO (reflectIDE block ideR) >> return ())+forkIDE block = reifyIDE (void . forkIO . reflectIDE block) postSyncIDE :: IDEM a -> IDEM a-postSyncIDE f = reifyIDE (\ideR -> postGUISync (reflectIDE f ideR))+postSyncIDE f = reifyIDE (postGUISync . reflectIDE f) postAsyncIDE :: IDEM () -> IDEM ()-postAsyncIDE f = reifyIDE (\ideR -> postGUIAsync (reflectIDE f ideR))+postAsyncIDE f = reifyIDE (postGUIAsync . reflectIDE f) onIDE obj signal callback = do ideRef <- ask- liftIO $ obj `on` signal $ runReaderT callback ideRef+ liftIO (obj `on` signal $ runReaderT callback ideRef) -- --------------------------------------------------------------------- -- Convenience methods for accesing the IDE State -- -- | Read an attribute of the contents-readIDE :: (IDE -> beta) -> IDEM beta+readIDE :: MonadIDE m => (IDE -> beta) -> m beta readIDE f = do- e <- ask+ e <- liftIDE ask liftIO $ liftM f (readIORef e) -- | Modify the contents, without returning a value-modifyIDE_ :: (IDE -> IDE) -> IDEM ()+modifyIDE_ :: MonadIDE m => (IDE -> IDE) -> m () modifyIDE_ f = let f' a = (f a,()) in do- e <- ask+ e <- liftIDE ask liftIO (atomicModifyIORef e f') -- | Variation on modifyIDE_ that lets you return a value-modifyIDE :: (IDE -> (IDE,beta)) -> IDEM beta+modifyIDE :: MonadIDE m => (IDE -> (IDE,beta)) -> m beta modifyIDE f = do- e <- ask+ e <- liftIDE ask liftIO (atomicModifyIORef e f) -withIDE :: (IDE -> IO alpha) -> IDEM alpha+withIDE :: MonadIDE m => (IDE -> IO alpha) -> m alpha withIDE f = do- e <- ask+ e <- liftIDE ask liftIO $ f =<< readIORef e -getIDE :: IDEM(IDE)-getIDE = do- e <- ask- st <- liftIO $ readIORef e- return st+getIDE :: MonadIDE m => m IDE+getIDE = liftIDE ask >>= (liftIO . readIORef) withoutRecordingDo :: IDEAction -> IDEAction withoutRecordingDo act = do@@ -408,12 +398,10 @@ mbActive <- getActivePane case mbActive of Nothing -> return ()- Just (n,_) -> if n == paneName pane- then deactivatePane- else return ()+ Just (n,_) -> when (n == paneName pane) deactivatePane changePackage :: IDEPackage -> IDEAction-changePackage ideP@IDEPackage{ipdCabalFile = file} = do+changePackage ideP = do oldWorkspace <- readIDE workspace case oldWorkspace of Nothing -> return ()@@ -423,12 +411,14 @@ bufferProjCache = Map.empty}) mbActivePack <- readIDE activePack case mbActivePack of- Just activePack | ipdCabalFile ideP == ipdCabalFile activePack ->+ Just activePack | key ideP == key activePack -> modifyIDE_ (\ide -> ide{activePack = Just ideP}) _ -> return () where- exchange p | ipdCabalFile p == file = ideP- | otherwise = p+ key = ipdBuildDir+ idePKey = key ideP+ exchange p | key p == idePKey = ideP+ | otherwise = p -- | Find a directory relative to the leksah install directory leksahSubDir :: FilePath -- ^ Sub directory to look for@@ -437,9 +427,9 @@ exePath <- getExecutablePath if takeFileName exePath == "leksah.exe" then do- let dataDir = (takeDirectory $ takeDirectory exePath) </> subDir+ let dataDir = takeDirectory (takeDirectory exePath) </> subDir exists <- doesDirectoryExist dataDir- if exists then return (Just dataDir) else return Nothing+ return (if exists then Just dataDir else Nothing) else return Nothing -- | Get the leksah data dir based on the executable name or if that fails
src/IDE/Core/Types.hs view
@@ -34,6 +34,7 @@ , IDEEventM , IDEAction , IDEEvent(..)+, MonadIDE , liftIDE , (?>>=) @@ -50,7 +51,10 @@ , runDebug , IDEPackage(..)+, ipdBuildDir+, ipdAllDirs , Workspace(..)+, wsAllPackages , VCSConf , ActionDescr(..)@@ -102,6 +106,7 @@ import Distribution.PackageDescription (BuildInfo) import Data.Map (Map(..)) import Data.Set (Set(..))+import Data.List (nubBy) import Distribution.ModuleName (ModuleName(..)) import Graphics.UI.Gtk.Gdk.EventM (Modifier(..)) import Graphics.UI.Gtk.ActionMenuToolbar.UIManager(MergeId)@@ -119,7 +124,7 @@ import Distribution.Text(disp) import Text.PrettyPrint (render) import Control.Monad.Trans.Class (lift)-import Control.Monad.IO.Class (liftIO)+import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Trans.Reader (ReaderT(..)) #if MIN_VERSION_directory(1,2,0) import Data.Time (UTCTime(..))@@ -151,7 +156,7 @@ , workspace :: Maybe Workspace -- ^ may be a workspace (set of packages) , activePack :: Maybe IDEPackage , activeExe :: Maybe String-, bufferProjCache :: Map FilePath (Maybe IDEPackage)+, bufferProjCache :: Map FilePath [IDEPackage] , allLogRefs :: [LogRef] , currentEBC :: (Maybe LogRef, Maybe LogRef, Maybe LogRef) , currentHist :: Int@@ -174,6 +179,7 @@ , vcsData :: (Map FilePath MenuItem, Maybe (Maybe String)) -- menus for packages, password , logLaunches :: Map.Map String LogLaunchData , autoCommand :: IDEAction+, autoURI :: Maybe String } --deriving Show --@@ -206,9 +212,12 @@ | IsCompleting Connections -class MonadIDE m where+class (Functor m, Monad m, MonadIO m) => MonadIDE m where liftIDE :: IDEM a -> m a +instance MonadIDE IDEM where+ liftIDE = id+ instance MonadIDE WorkspaceM where liftIDE = lift @@ -241,10 +250,13 @@ -- --------------------------------------------------------------------- -- Monad for functions that need an active package ---type PackageM = ReaderT IDEPackage IDEM+type PackageM = ReaderT IDEPackage WorkspaceM type PackageAction = PackageM () -runPackage :: PackageM a -> IDEPackage -> IDEM a+instance MonadIDE PackageM where+ liftIDE = lift . lift++runPackage :: PackageM a -> IDEPackage -> WorkspaceM a runPackage = runReaderT -- ---------------------------------------------------------------------@@ -356,6 +368,7 @@ , ipdHasLibs :: Bool , ipdExes :: [String] , ipdTests :: [String]+, ipdBenchmarks :: [String] , ipdMain :: [(FilePath, BuildInfo, Bool)] , ipdExtraSrcs :: Set FilePath , ipdSrcDirs :: [FilePath]@@ -369,6 +382,7 @@ , ipdRegisterFlags :: [String] , ipdUnregisterFlags :: [String] , ipdSdistFlags :: [String]+, ipdSandboxSources :: [IDEPackage] } deriving (Eq) @@ -378,6 +392,12 @@ instance Ord IDEPackage where compare x y = compare (ipdPackageId x) (ipdPackageId y) +ipdBuildDir :: IDEPackage -> FilePath+ipdBuildDir = dropFileName . ipdCabalFile++ipdAllDirs :: IDEPackage -> [FilePath]+ipdAllDirs p = ipdBuildDir p : (ipdSandboxSources p >>= ipdAllDirs)+ -- --------------------------------------------------------------------- -- Workspace --@@ -394,6 +414,10 @@ , packageVcsConf :: Map FilePath VCSConf -- ^ (FilePath to package, Version-Control-System Configuration) } deriving Show +-- | Includes sandbox sources+wsAllPackages :: Workspace -> [IDEPackage]+wsAllPackages w = nubBy (\ a b -> ipdCabalFile a == ipdCabalFile b) $ wsPackages w ++ (wsPackages w >>= ipdSandboxSources)+ -- --------------------------------------------------------------------- -- Other data structures which are used in the state --@@ -521,7 +545,7 @@ show (srcSpanStartColumn s) ++ "-" ++ show (srcSpanEndColumn s) logRefRootPath :: LogRef -> FilePath-logRefRootPath = dropFileName . ipdCabalFile . logRefPackage+logRefRootPath = ipdBuildDir . logRefPackage logRefFilePath :: LogRef -> FilePath logRefFilePath = srcSpanFilename . logRefSrcSpan
src/IDE/Debug.hs view
@@ -91,7 +91,12 @@ import Data.Monoid ((<>), Monoid(..)) import Data.Text (Text) import qualified Data.Text as T (isSuffixOf, unpack)+import System.Exit (ExitCode(..))+import IDE.Pane.WebKit.Output (loadOutputUri) +-- | Get the last item+sinkLast = CL.fold (\_ a -> Just a) Nothing+ debugCommand :: String -> C.Sink ToolOutput IDEM () -> DebugAction debugCommand command handler = do debugCommand' command handler@@ -102,14 +107,14 @@ debugCommand' command handler = do ghci <- ask lift $ catchIDE (runDebug (executeDebugCommand command handler) ghci)- (\(e :: SomeException) -> putStrLn (show e))+ (\(e :: SomeException) -> (print e)) debugToggled :: IDEAction debugToggled = do toggled <- getDebugToggled maybeDebug <- readIDE debugState case (toggled, maybeDebug) of- (True, Nothing) -> packageTry $ debugStart+ (True, Nothing) -> packageTry debugStart (False, Just _) -> debugQuit _ -> return () @@ -130,8 +135,8 @@ -- > stripComments "-- This is still a comment" stripComments :: String -> String stripComments t = maybe t unlines $- sequence (map (stripPrefix "-- >>>") lines')- <|> sequence (map (stripPrefix "-- >") lines')+ mapM (stripPrefix "-- >>>") lines'+ <|> mapM (stripPrefix "-- >") lines' where lines' = lines t @@ -143,8 +148,13 @@ let command = packageTry $ tryDebug $ do debugSetLiberalScope buffer <- liftIO $ newIORef mempty- debugCommand (stripComments text) $ logOutputPane buffer- modifyIDE_ $ \ide -> ide {autoCommand = command}+ debugCommand (stripComments text) $ do+ (_, _) <- CU.zipSinks sinkLast (logOutputPane text buffer)+ mbURI <- lift $ readIDE autoURI+ case mbURI of+ Just uri -> lift . postSyncIDE $ loadOutputUri uri+ Nothing -> return ()+ modifyIDE_ $ \ide -> ide {autoCommand = command, autoURI = Nothing} command Nothing -> ideMessage Normal "Please select some text in the editor to execute" @@ -168,7 +178,7 @@ debugSetLiberalScope = do maybeModuleName <- lift selectedModuleName case maybeModuleName of- Just moduleName -> do+ Just moduleName -> debugCommand (":module *" ++ moduleName) CL.sinkNull Nothing -> do mbPackage <- lift getActivePackageDescr@@ -179,15 +189,13 @@ CL.sinkNull debugAbandon :: IDEAction-debugAbandon = do-+debugAbandon = packageTry $ tryDebug $ debugCommand ":abandon" logOutputDefault debugBack :: IDEAction debugBack = packageTry $ do currentHist' <- lift $ readIDE currentHist- rootPath <- lift activeProjectDir- lift $ modifyIDE_ (\ide -> ide{currentHist = min (currentHist' - 1) 0})+ liftIDE $ modifyIDE_ (\ide -> ide{currentHist = min (currentHist' - 1) 0}) tryDebug $ do (debugPackage, _) <- ask debugCommand ":back" (logOutputForHistoricContextDefault debugPackage)@@ -195,8 +203,7 @@ debugForward :: IDEAction debugForward = packageTry $ do currentHist' <- lift $ readIDE currentHist- rootPath <- lift activeProjectDir- lift $ modifyIDE_ (\ide -> ide{currentHist = currentHist' + 1})+ liftIDE $ modifyIDE_ (\ide -> ide{currentHist = currentHist' + 1}) tryDebug $ do (debugPackage, _) <- ask debugCommand ":forward" (logOutputForHistoricContextDefault debugPackage)@@ -209,11 +216,9 @@ Nothing -> return () debugContinue :: IDEAction-debugContinue = packageTry $ do- rootPath <- lift $ activeProjectDir- tryDebug $ do- (debugPackage, _) <- ask- debugCommand ":continue" (logOutputForHistoricContextDefault debugPackage)+debugContinue = packageTry $ tryDebug $ do+ (debugPackage, _) <- ask+ debugCommand ":continue" (logOutputForHistoricContextDefault debugPackage) debugDeleteAllBreakpoints :: IDEAction debugDeleteAllBreakpoints = do@@ -253,12 +258,10 @@ Nothing -> ideMessage Normal "Please select an name in the editor" debugStep :: IDEAction-debugStep = packageTry $ do- rootPath <- lift $ activeProjectDir- tryDebug $ do- (debugPackage, _) <- ask- debugSetLiberalScope- debugCommand ":step" (logOutputForHistoricContextDefault debugPackage)+debugStep = packageTry $ tryDebug $ do+ (debugPackage, _) <- ask+ debugSetLiberalScope+ debugCommand ":step" (logOutputForHistoricContextDefault debugPackage) debugStepExpression :: IDEAction debugStepExpression = do@@ -270,24 +273,19 @@ debugStepExpr :: Maybe String -> DebugAction debugStepExpr maybeText = do (debugPackage, _) <- ask- rootPath <- lift $ activeProjectDir case maybeText of Just text -> debugCommand (":step " ++ stripComments text) (logOutputForHistoricContextDefault debugPackage) Nothing -> lift $ ideMessage Normal "Please select an expression in the editor" debugStepLocal :: IDEAction-debugStepLocal = packageTry $ do- rootPath <- lift $ activeProjectDir- tryDebug $ do- (debugPackage, _) <- ask- debugCommand ":steplocal" (logOutputForHistoricContextDefault debugPackage)+debugStepLocal = packageTry $ tryDebug $ do+ (debugPackage, _) <- ask+ debugCommand ":steplocal" (logOutputForHistoricContextDefault debugPackage) debugStepModule :: IDEAction-debugStepModule = packageTry $ do- rootPath <- lift $ activeProjectDir- tryDebug $ do- (debugPackage, _) <- ask- debugCommand ":stepmodule" (logOutputForHistoricContextDefault debugPackage)+debugStepModule = packageTry $ tryDebug $ do+ (debugPackage, _) <- ask+ debugCommand ":stepmodule" (logOutputForHistoricContextDefault debugPackage) logTraceOutput debugPackage = do@@ -296,11 +294,9 @@ return () debugTrace :: IDEAction-debugTrace = packageTry $ do- rootPath <- lift $ activeProjectDir- tryDebug $ do- (debugPackage, _) <- ask- debugCommand ":trace" $ logTraceOutput debugPackage+debugTrace = packageTry $ tryDebug $ do+ (debugPackage, _) <- ask+ debugCommand ":trace" $ logTraceOutput debugPackage debugTraceExpression :: IDEAction debugTraceExpression = do@@ -321,18 +317,14 @@ debugShowBindings = packageTry $ tryDebug $ debugCommand ":show bindings" logOutputDefault debugShowBreakpoints :: IDEAction-debugShowBreakpoints = packageTry $ do- rootPath <- lift activeProjectDir- tryDebug $ do- (debugPackage, _) <- ask- debugCommand ":show breaks" (logOutputForSetBreakpointDefault debugPackage)+debugShowBreakpoints = packageTry $ tryDebug $ do+ (debugPackage, _) <- ask+ debugCommand ":show breaks" (logOutputForSetBreakpointDefault debugPackage) debugShowContext :: IDEAction-debugShowContext = packageTry $ do- rootPath <- lift activeProjectDir- tryDebug $ do- (debugPackage, _) <- ask- debugCommand ":show context" (logOutputForHistoricContextDefault debugPackage)+debugShowContext = packageTry $ tryDebug $ do+ (debugPackage, _) <- ask+ debugCommand ":show context" (logOutputForHistoricContextDefault debugPackage) debugShowModules :: IDEAction debugShowModules = packageTry $ tryDebug $ debugCommand ":show modules" $@@ -382,7 +374,6 @@ debugSetBreakpoint :: IDEAction debugSetBreakpoint = do- rootPath <- activeProjectDir maybeModuleName <- selectedModuleName case maybeModuleName of Just moduleName -> do@@ -398,16 +389,16 @@ case maybeLocation of Just (line, lineOffset) -> packageTry $ tryDebug $ do (debugPackage, _) <- ask- debugCommand (":break " ++ moduleName ++ " " ++ (show (line+1)) ++ " " ++- (show lineOffset)) (logOutputForSetBreakpointDefault debugPackage)+ debugCommand (":break " ++ moduleName ++ " " ++ show (line + 1) ++ " " ++ show lineOffset)+ (logOutputForSetBreakpointDefault debugPackage) Nothing -> ideMessage Normal "Unknown error setting breakpoint" ref <- ask return () Nothing -> ideMessage Normal "Please select module file in the editor" debugSet :: (Bool -> String) -> Bool -> IDEAction-debugSet flag value = do- packageTry $ tryDebug $ debugCommand (":set "++(flag value)) logOutputDefault+debugSet flag value =+ packageTry $ tryDebug $ debugCommand (":set " ++ flag value) logOutputDefault debugSetPrintEvldWithShow :: Bool -> IDEAction debugSetPrintEvldWithShow = debugSet printEvldWithShowFlag
src/IDE/Find.hs view
@@ -75,7 +75,7 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Reader (ask) import Control.Monad.Trans.Class (MonadTrans(..))-import Control.Monad (liftM, filterM, when)+import Control.Monad (liftM, filterM, when, unless) import Foreign.C.Types (CInt(..)) import Foreign.Ptr (Ptr(..)) import Foreign.ForeignPtr (withForeignPtr)@@ -105,9 +105,9 @@ getFindState = do (fb,ls) <- needFindbar liftIO $ do- lineNr <- getLineEntry fb >>= (\e -> spinButtonGetValueAsInt (castToSpinButton e))- replaceStr <- getReplaceEntry fb >>= (\e -> entryGetText (castToEntry e))- entryStr <- getFindEntry fb >>= (\e -> entryGetText (castToEntry e))+ lineNr <- getLineEntry fb >>= (spinButtonGetValueAsInt . castToSpinButton)+ replaceStr <- getReplaceEntry fb >>= (entryGetText . castToEntry)+ entryStr <- getFindEntry fb >>= (entryGetText . castToEntry) entryHist <- listStoreToList ls entireWord <- getEntireWord fb wrapAround <- getWrapAround fb@@ -132,7 +132,7 @@ getReplaceEntry fb >>= (\e -> entrySetText (castToEntry e) (replaceStr fs)) getFindEntry fb >>= (\e -> entrySetText (castToEntry e) (entryStr fs)) listStoreClear ls- mapM_ (\s -> listStoreAppend ls s) (entryHist fs)+ mapM_ (listStoreAppend ls) (entryHist fs) setEntireWord fb (entireWord fs) setWrapAround fb (wrapAround fs) setCaseSensitive fb (caseSensitive fs)@@ -216,7 +216,7 @@ sep1 <- separatorToolItemNew toolbarInsert toolbar sep1 0 - let performGrep = (reflectIDE (packageTry $ doGrep toolbar) ideR)+ let performGrep = reflectIDE (packageTry $ doGrep toolbar) ideR grepButton <- toolButtonNew (Nothing :: Maybe Widget) (Just "Grep") toolbarInsert toolbar grepButton 0 grepButton `onToolButtonClicked` performGrep@@ -249,7 +249,7 @@ nextButton <- toolButtonNewFromStock "gtk-go-forward" toolbarInsert toolbar nextButton 0 set nextButton [widgetTooltipText := Just "Search for the next match in the current file"]- nextButton `onToolButtonClicked` (doSearch toolbar Forward ideR )+ nextButton `onToolButtonClicked` doSearch toolbar Forward ideR wrapAroundButton <- toggleToolButtonNew toolButtonSetLabel wrapAroundButton (Just "Wrap")@@ -260,7 +260,7 @@ previousButton <- toolButtonNewFromStock "gtk-go-back" toolbarInsert toolbar previousButton 0 set previousButton [widgetTooltipText := Just "Search for the previous match in the current file"]- previousButton `onToolButtonClicked` (doSearch toolbar Backward ideR )+ previousButton `onToolButtonClicked` doSearch toolbar Backward ideR entryTool <- toolItemNew entry <- entryNew@@ -280,7 +280,7 @@ cell <- cellRendererTextNew cellLayoutPackStart completion cell True cellLayoutSetAttributes completion cell store- (\cd -> [cellText := cd])+ (\ cd -> [cellText := cd]) entryCompletionSetMatchFunc completion (matchFunc store) on completion matchSelected $ \ model iter -> do txt <- treeModelGetValue model iter (makeColumnIdString 0)@@ -292,21 +292,22 @@ toolButtonSetLabel regexButton (Just "Regex") widgetSetName regexButton "regexButton" toolbarInsert toolbar regexButton 0- regexButton `onToolButtonClicked` (doSearch toolbar Insert ideR)+ regexButton `onToolButtonClicked` doSearch toolbar Insert ideR set regexButton [widgetTooltipText := Just "When selected the search string is used as a regular expression"] entireWordButton <- toggleToolButtonNew toolButtonSetLabel entireWordButton (Just "Words") widgetSetName entireWordButton "entireWordButton" toolbarInsert toolbar entireWordButton 0- entireWordButton `onToolButtonClicked` (doSearch toolbar Insert ideR)+ entireWordButton `onToolButtonClicked` doSearch toolbar Insert ideR set entireWordButton [widgetTooltipText := Just "When selected only entire words are matched"] caseSensitiveButton <- toggleToolButtonNew toolButtonSetLabel caseSensitiveButton (Just "Case") widgetSetName caseSensitiveButton "caseSensitiveButton" toolbarInsert toolbar caseSensitiveButton 0- caseSensitiveButton `onToolButtonClicked` (doSearch toolbar Insert ideR)+ caseSensitiveButton `onToolButtonClicked`+ doSearch toolbar Insert ideR set caseSensitiveButton [widgetTooltipText := Just "When selected the search is case sensitive"] labelTool <- toolItemNew@@ -314,12 +315,10 @@ containerAdd labelTool label toolbarInsert toolbar labelTool 0 - after entry insertText (\t i -> do+ after entry insertText (\ t i -> do doSearch toolbar Insert ideR return i)- after entry deleteText (\ _ _ -> doSearch toolbar Delete ideR )--+ after entry deleteText (\ _ _ -> doSearch toolbar Delete ideR) on entry entryActivate $ doSearch toolbar Forward ideR on entry focusInEvent $ do@@ -327,11 +326,10 @@ return False replaceButton `onToolButtonClicked` replace toolbar Forward ideR- let performReplaceAll = replaceAll toolbar Forward ideR+ let performReplaceAll = replaceAll toolbar Forward ideR replaceAllButton `onToolButtonClicked` performReplaceAll - let- ctrl "c" = toggleToolButton caseSensitiveButton >> return True+ let ctrl "c" = toggleToolButton caseSensitiveButton >> return True ctrl "e" = toggleToolButton regexButton >> return True ctrl "w" = toggleToolButton entireWordButton >> return True ctrl "p" = toggleToolButton wrapAroundButton >> return True@@ -354,24 +352,22 @@ widgetGrabFocus re --- widgetAc return True- _ | (mapControlCommand Control) `elem` mods -> liftIO . ctrl $ map toLower name- _ -> return False-+ _ | mapControlCommand Control `elem` mods -> liftIO . ctrl $ map toLower name+ _ -> return False rentry `on` keyPressEvent $ do name <- eventKeyName mods <- eventModifier case () of- _- | name == "Tab" || name == "ISO_Left_Tab" -> liftIO $ do+ _ | name == "Tab" || name == "ISO_Left_Tab" -> liftIO $ do fe <- getFindEntry toolbar widgetGrabFocus fe return True- | (mapControlCommand Control) `elem` mods ->+ | mapControlCommand Control `elem` mods -> liftIO . ctrl $ map toLower name- | otherwise -> return False+ | otherwise -> return False - after spinL focusInEvent . liftIO $ reflectIDE (inActiveBufContext True $ \_ _ ebuf _ _ -> do+ after spinL focusInEvent . liftIO $ reflectIDE (inActiveBufContext True $ \ _ _ ebuf _ _ -> do max <- getLineCount ebuf liftIO $ spinButtonSetRange spinL 1.0 (fromIntegral max) return True) ideR@@ -385,36 +381,35 @@ re <- getFindEntry toolbar widgetGrabFocus re return True- _ | (mapControlCommand Control) `elem` mods -> liftIO . ctrl $ map toLower name- _ -> return False-+ _ | mapControlCommand Control `elem` mods -> liftIO . ctrl $ map toLower name+ _ -> return False - after spinL entryActivate $ reflectIDE (inActiveBufContext () $ \_ sv ebuf _ _ -> do- line <- liftIO $ spinButtonGetValueAsInt spinL- iter <- getIterAtLine ebuf (line - 1)+ after spinL entryActivate $ reflectIDE (inActiveBufContext () $ \ _ sv ebuf _ _ -> do+ line <- liftIO $ spinButtonGetValueAsInt spinL+ iter <- getIterAtLine ebuf (line - 1) placeCursor ebuf iter scrollToIter sv iter 0.2 Nothing liftIO $ getOut ideR return ()) ideR - closeButton `onToolButtonClicked` do- reflectIDE hideFindbar ideR+ closeButton `onToolButtonClicked` reflectIDE hideFindbar ideR - set toolbar [ toolbarChildHomogeneous spinTool := False ]- set toolbar [ toolbarChildHomogeneous wrapAroundButton := False ]- set toolbar [ toolbarChildHomogeneous entireWordButton := False ]- set toolbar [ toolbarChildHomogeneous caseSensitiveButton := False ]- set toolbar [ toolbarChildHomogeneous regexButton := False ]- set toolbar [ toolbarChildHomogeneous replaceAllButton := False ]- set toolbar [ toolbarChildHomogeneous labelTool := False ]- set toolbar [ toolbarChildHomogeneous labelTool2 := False ]- set toolbar [ toolbarChildHomogeneous labelTool3 := False ]+ set toolbar [toolbarChildHomogeneous spinTool := False]+ set toolbar [toolbarChildHomogeneous wrapAroundButton := False]+ set toolbar [toolbarChildHomogeneous entireWordButton := False]+ set toolbar [toolbarChildHomogeneous caseSensitiveButton := False]+ set toolbar [toolbarChildHomogeneous regexButton := False]+ set toolbar [toolbarChildHomogeneous replaceAllButton := False]+ set toolbar [toolbarChildHomogeneous labelTool := False]+ set toolbar [toolbarChildHomogeneous labelTool2 := False]+ set toolbar [toolbarChildHomogeneous labelTool3 := False] - reflectIDE (modifyIDE_ (\ide -> ide{findbar = (False,Just (toolbar,store))})) ideR+ reflectIDE (modifyIDE_ (\ ide -> ide{findbar = (False, Just (toolbar, store))})) ideR return toolbar- where getOut = reflectIDE $ do- hideFindbar- maybeActiveBuf ?>>= makeActive+ where+ getOut = reflectIDE $ do+ hideFindbar+ maybeActiveBuf ?>>= makeActive doSearch :: Toolbar -> SearchHint -> IDERef -> IO ()@@ -436,7 +431,7 @@ else do widgetModifyBase entry StateNormal red widgetModifyText entry StateNormal white- Nothing -> do+ Nothing -> if null search then do widgetModifyBase entry StateNormal white@@ -450,7 +445,7 @@ doGrep :: Toolbar -> PackageAction doGrep fb = do package <- ask- ideR <- lift $ ask+ ideR <- lift ask entry <- liftIO $ getFindEntry fb search <- liftIO $ entryGetText (castToEntry entry) entireWord <- liftIO $ getEntireWord fb@@ -458,30 +453,28 @@ wrapAround <- liftIO $ getWrapAround fb regex <- liftIO $ getRegex fb let (regexString, _) = regexStringAndMatchIndex entireWord regex search- lift $ workspaceTry $ grepWorkspace regexString caseSensitive+ liftIDE $ workspaceTry $ grepWorkspace regexString caseSensitive matchFunc :: ListStore String -> String -> TreeIter -> IO Bool matchFunc model str iter = do tp <- treeModelGetPath model iter- r <- case tp of+ case tp of (i:_) -> do row <- listStoreGetValue model i return (isPrefixOf (map toLower str) (map toLower row) && length str < length row) otherwise -> return False- return r addToHist :: String -> IDEAction addToHist str =- if null str- then return ()- else do- (_,ls) <- needFindbar- liftIO $ do- entryHist <- listStoreToList ls- when (null (filter (\e -> (str `isPrefixOf` e)) entryHist)) $ do- let newList = take 12 (str : filter (\e -> not (e `isPrefixOf` str)) entryHist)+ unless (null str) $+ do (_, ls) <- needFindbar+ liftIO $+ do entryHist <- listStoreToList ls+ unless (any (str `isPrefixOf`) entryHist) $+ do let newList+ = take 12+ (str : filter (\ e -> not (e `isPrefixOf` str)) entryHist) listStoreClear ls- mapM_ (\s -> listStoreAppend ls s) newList-+ mapM_ (listStoreAppend ls) newList replace :: Toolbar -> SearchHint -> IDERef -> IO () replace fb hint ideR = do@@ -528,7 +521,7 @@ removeTagByName ebuf "found" startMark <- getInsertMark ebuf st1 <- getIterAtMark ebuf startMark- mbsr2 <- do+ mbsr2 <- if hint == Backward then do st2 <- backwardCharC st1@@ -537,7 +530,7 @@ case mbsr of Nothing -> if wrapAround- then do backSearch exp matchIndex ebuf text i2+ then backSearch exp matchIndex ebuf text i2 else return Nothing m -> return m else do@@ -548,7 +541,7 @@ case mbsr of Nothing -> if wrapAround- then do forwardSearch exp matchIndex ebuf text i1+ then forwardSearch exp matchIndex ebuf text i1 else return Nothing m -> return m case mbsr2 of@@ -569,7 +562,7 @@ findMatch exp matchIndex ebuf text (>= offset) False regexAndMatchIndex :: Bool -> Bool -> Bool -> String -> IO (Maybe (Regex, Int))-regexAndMatchIndex caseSensitive entireWord regex string = do+regexAndMatchIndex caseSensitive entireWord regex string = if null string then return Nothing else do@@ -640,7 +633,7 @@ Nothing -> return False where replacementText False _ _ _ replace = return $ Just replace- replacementText True text matchIndex matches replace = do+ replacementText True text matchIndex matches replace = case compileRegex caseSensitive search of Left err -> do sysMessage Normal err@@ -725,7 +718,7 @@ getWidget :: String -> Toolbar -> IO Widget getWidget str tb = do widgets <- containerGetChildren tb- entryL <- filterM (\w -> liftM (== str) (widgetGetName w) ) widgets+ entryL <- filterM (liftM (== str) . widgetGetName) widgets case entryL of [w] -> do mbw <- binGetChild (castToBin w)@@ -743,7 +736,7 @@ getSelection :: String -> Toolbar -> IO Bool getSelection str tb = do widgets <- containerGetChildren tb- entryL <- filterM (\w -> liftM (== str) (widgetGetName w) ) widgets+ entryL <- filterM (liftM (== str) . widgetGetName) widgets case entryL of [w] -> toggleToolButtonGetActive (castToToggleToolButton w) _ -> throwIDE "Find>>getIt widget not found"@@ -757,7 +750,7 @@ setSelection :: String -> Toolbar -> Bool -> IO () setSelection str tb bool = do widgets <- containerGetChildren tb- entryL <- filterM (\w -> liftM (== str) (widgetGetName w) ) widgets+ entryL <- filterM (liftM (== str) . widgetGetName ) widgets case entryL of [w] -> toggleToolButtonSetActive (castToToggleToolButton w) bool _ -> throwIDE "Find>>getIt widget not found"
src/IDE/GUIHistory.hs view
@@ -25,18 +25,17 @@ import IDE.Core.State import IDE.Pane.Modules import IDE.Pane.Info+import Control.Monad (unless) recordHistory :: GUIHistory -> IDEAction recordHistory entry = do (b,l,n) <- readIDE guiHistory- if b || (n >= 0 && fst entry == fst (l !! n))- then return ()- else do- modifyIDE_ (\ide -> ide{guiHistory = (b,entry:(drop n l),0)})- triggerEventIDE (Sensitivity- [(SensitivityForwardHist,False),(SensitivityBackwardHist,0 < length (drop n l) - 1)])- return ()- -- liftIO $ putStrLn $ "record n : " ++ show 0 -- ++ " hist: " ++ show (entry:(drop n l))+ unless (b || (n >= 0 && fst entry == fst (l !! n))) $ do+ modifyIDE_ (\ide -> ide{guiHistory = (b,entry : drop n l,0)})+ triggerEventIDE (Sensitivity+ [(SensitivityForwardHist,False),(SensitivityBackwardHist,0 < length (drop n l) - 1)])+ return ()+ -- liftIO $ putStrLn $ "record n : " ++ show 0 -- ++ " hist: " ++ show (entry:(drop n l)) historyBack :: IDEAction historyBack = do@@ -48,7 +47,7 @@ withoutRecordingDo (activateHistory (snd (l !! n))) modifyIDE_ (\ide -> ide{guiHistory = (b,l, n + 1)}) triggerEventIDE (Sensitivity- [(SensitivityForwardHist,(n + 1) > 0),(SensitivityBackwardHist,(n + 1) < (length l) - 1)])+ [(SensitivityForwardHist,(n + 1) > 0),(SensitivityBackwardHist,(n + 1) < length l - 1)]) return () -- liftIO $ putStrLn $ "back n : " ++ show (n + 1) -- ++ " hist: " ++ show l @@ -62,21 +61,21 @@ withoutRecordingDo (activateHistory (fst (l !! n))) modifyIDE_ (\ide -> ide{guiHistory = (b,l, n - 1)}) triggerEventIDE (Sensitivity- [(SensitivityForwardHist,(n - 1) > 0),(SensitivityBackwardHist,(n - 1) < (length l) - 1)])+ [(SensitivityForwardHist,(n - 1) > 0),(SensitivityBackwardHist,(n - 1) < length l - 1)]) return () -- liftIO $ putStrLn $ "forward n : " ++ show (n - 1) -- ++ " hist: " ++ show l activateHistory :: GUIHistory' -> IDEAction-activateHistory ms@(ModuleSelected s1 s2) = do+activateHistory ms@(ModuleSelected s1 s2) = -- liftIO $ putStrLn $ "activate with module selected " ++ show s1 ++ " " ++ show s2 replaySelHistory s1 s2-activateHistory ms@(ScopeSelected bl sc) = do+activateHistory ms@(ScopeSelected bl sc) = -- liftIO $ putStrLn $ "activate with scope selected " ++ show ms replayScopeHistory bl sc-activateHistory ms@(InfoElementSelected descr) = do+activateHistory ms@(InfoElementSelected descr) = -- liftIO $ putStrLn $ "activate with " ++ show ms replayInfoHistory descr-activateHistory ms@(PaneSelected mbPaneName) = do+activateHistory ms@(PaneSelected mbPaneName) = -- liftIO $ putStrLn $ "activate with " ++ show ms case mbPaneName of Nothing -> withoutRecordingDo deactivatePane
src/IDE/ImportTool.hs view
@@ -64,19 +64,16 @@ (flattenPackageDescription) import IDE.BufferMode (editInsertCode) import Control.Monad.IO.Class (MonadIO(..))-#if MIN_VERSION_Cabal(1,10,0)-import Distribution.PackageDescription.PrettyPrintCopied+import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription)-#else-import Distribution.PackageDescription.Parse- (writePackageDescription)-import Distribution.PackageDescription- (CondTree(..))-#endif import qualified Data.Text as T (unpack) import Language.Haskell.Exts (KnownExtension)-import Text.Read (readMaybe) +readMaybe :: Read a => String -> Maybe a+readMaybe s = case reads s of+ [(x, "")] -> Just x+ _ -> Nothing+ -- | Add all imports which gave error messages ... resolveErrors :: IDEAction resolveErrors = do@@ -179,21 +176,11 @@ let idePackage = logRefPackage error gpd <- liftIO $ readPackageDescription normal (ipdCabalFile $ idePackage) ideMessage Normal $ "addPackage " ++ (display $ pkgName pack)-#if MIN_VERSION_Cabal(1,10,0) liftIO $ writeGenericPackageDescription (ipdCabalFile $ idePackage) gpd { condLibrary = addDepToLib pack (condLibrary gpd), condExecutables = map (addDepToExe pack) (condExecutables gpd)} return True-#else- if hasConfigs gpd- then return False- else do- let flat = flattenPackageDescription gpd- liftIO $ writePackageDescription (ipdCabalFile $ idePackage)- flat { buildDepends = dep pack : buildDepends flat}- return True-#endif where addDepToLib _ Nothing = Nothing addDepToLib p (Just cn@CondNode{condTreeConstraints = deps}) =@@ -217,10 +204,10 @@ case mbActiveBuf of Nothing -> return Nothing Just buf -> do- mbPackage <- belongsToPackage buf- case mbPackage of- Nothing -> return Nothing- Just pack -> getPackageImportInfo pack+ packages <- belongsToPackages buf+ case packages of+ [] -> return Nothing+ pack:_ -> getPackageImportInfo pack addImport' :: NotInScopeParseResult -> FilePath -> Descr -> [Descr] -> ((Bool,[Descr]) -> IDEAction) -> IDEAction addImport' nis filePath descr descrList continuation = do@@ -353,26 +340,21 @@ isSub <- optionMaybe (try (choice [symbol "type constructor or class" , symbol "data constructor"])) ( (do- choice [char '`',char '‘']+ char '`' mbQual <- optionMaybe (try (do q <- lexeme conid dot return q)) id <- optionMaybe (try identifier) case id of-#if MIN_VERSION_ghc(7,8,0) Just id -> return (NotInScopeParseResult mbQual- id (isJust isSub) False)-#else- Just id -> return (NotInScopeParseResult mbQual (take (length id - 1) id) (isJust isSub) False)-#endif Nothing -> do op <- operator char '\'' return (NotInScopeParseResult mbQual op (isJust isSub) True)) <|> (do- choice [char '`',char '‘']+ choice [char '‛', char '‘'] mbQual <- optionMaybe (try (do q <- lexeme conid dot@@ -473,13 +455,13 @@ hiddenModuleParser = do whiteSpace symbol "Could not find module "- (char '`' <|> char '‛')+ (char '`' <|> char '‛' <|> char '‘') mod <- many (noneOf "'’") many (noneOf "\n") symbol "\n" whiteSpace symbol "It is a member of the hidden package "- (char '`' <|> char '‛')+ (char '`' <|> char '‛' <|> char '‘') pack <- many (noneOf "'’") (char '\'' <|> char '’') symbol ".\n"
src/IDE/Keymap.hs view
@@ -47,7 +47,7 @@ -- | Sets the accelerators is the action descriptions from the keymap -- setKeymap' :: KeymapI -> [ActionDescr IDERef] -> [ActionDescr IDERef]-setKeymap' (KM keymap) actions = map setAccel actions+setKeymap' (KM keymap) = map setAccel where setAccel act = case Map.lookup (name act) keymap of Nothing -> act Just [] -> act@@ -68,8 +68,7 @@ let map1 = Map.fromListWith (++) $concat pseudoTriples return (Map.map Map.fromList map1) where- build :: ActionDescr IDERef -> IO [((KeyVal,[Modifier]),[((KeyVal,[Modifier]),- (ActionDescr IDERef))])]+ build :: ActionDescr IDERef -> IO [((KeyVal,[Modifier]),[((KeyVal, [Modifier]), ActionDescr IDERef)])] build act = case Map.lookup (name act) keymap of Nothing -> return []
src/IDE/Leksah.hs view
@@ -334,6 +334,7 @@ , vcsData = (Map.empty, Nothing) , logLaunches = Map.empty , autoCommand = return ()+ , autoURI = Nothing } ideR <- newIORef ide menuDescription' <- menuDescription
src/IDE/LogRef.hs view
@@ -455,13 +455,14 @@ defaultLogLaunch <- lift $ getDefaultLogLaunch logOutput defaultLogLaunch -logOutputPane :: IORef [Text] -> C.Sink ToolOutput IDEM ()-logOutputPane buffer = do+logOutputPane :: String -> IORef [Text] -> C.Sink ToolOutput IDEM ()+logOutputPane command buffer = do defaultLogLaunch <- lift $ getDefaultLogLaunch result <- catMaybes <$> logOutputLines defaultLogLaunch paneLineLogger when (not $ null result) $ do new <- liftIO . atomicModifyIORef buffer $ \x -> let new = x ++ result in (new, new)- lift . postSyncIDE . setOutput $ T.unpack $ T.unlines new+ mbURI <- lift $ readIDE autoURI+ unless (isJust mbURI) . lift . postSyncIDE . setOutput command $ T.unpack $ T.unlines new logOutputForBuild :: IDEPackage -> Bool
src/IDE/Metainfo/Provider.hs view
@@ -204,7 +204,7 @@ trace "no workspace" $ modifyIDE_ (\ide -> ide{workspaceInfo = Nothing, packageInfo = Nothing}) continuation False Just ws -> do- updatePackageInfos rebuild (wsPackages ws) $ \ _ packDescrs -> do+ updatePackageInfos rebuild (wsAllPackages ws) $ \ _ packDescrs -> do let dependPackIds = (nub $ concatMap pdBuildDepends packDescrs) \\ map pdPackage packDescrs let packDescrsI = case systemInfo' of@@ -231,7 +231,7 @@ catMaybes $ map (\ pid -> pid `Map.lookup` pdmap) (pdBuildDepends pd) -- The imported from the workspace should be treated different- workspacePackageIds = map ipdPackageId (wsPackages ws)+ workspacePackageIds = map ipdPackageId (wsAllPackages ws) impPackDescrs' = filter (\pd -> not (elem (pdPackage pd) workspacePackageIds)) impPackDescrs impPackDescrs'' = catMaybes $ map (\pd ->
src/IDE/NotebookFlipper.hs view
@@ -161,7 +161,7 @@ -- This is done after currentState is set so we know not to update the -- previous panes list n <- treeModelIterNChildren store' Nothing- treeViewSetCursor tree' [if direction then min 1 (n-1) else (n-1)] Nothing+ treeViewSetCursor tree' [if direction then min 1 (n - 1) else n - 1] Nothing return () handleKeyRelease :: TreeViewClass alpha => alpha -> IDERef -> EventM EKey Bool
src/IDE/Package.hs view
@@ -1,5 +1,7 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Package@@ -27,6 +29,7 @@ , packageCopy , packageCopy' , packageRun+, packageRunJavaScript , activatePackage , deactivatePackage @@ -41,6 +44,7 @@ , getPackageDescriptionAndPath , getEmptyModuleTemplate , getModuleTemplate+, ModuleLocation(..) , addModuleToPackageDescr , delModuleFromPackageDescr @@ -61,6 +65,7 @@ , choosePackageFile , idePackageFromPath+, refreshPackage ) where @@ -72,9 +77,10 @@ import Distribution.Verbosity import System.FilePath import Control.Concurrent-import System.Directory (setCurrentDirectory, doesFileExist)+import System.Directory (setCurrentDirectory, doesFileExist, getDirectoryContents) import Prelude hiding (catch)-import Data.Maybe (isNothing, isJust, fromJust)+import Data.Maybe+ (listToMaybe, fromMaybe, isNothing, isJust, fromJust, catMaybes) import Control.Exception (SomeException(..), catch) import IDE.Core.State@@ -82,7 +88,7 @@ import IDE.Pane.Log import IDE.Pane.PackageEditor import IDE.Pane.SourceBuffer-import IDE.Pane.PackageFlags (readFlags)+import IDE.Pane.PackageFlags (writeFlags, readFlags) import Distribution.Text (display) import IDE.Utils.FileUtils(getConfigFilePathForLoad) import IDE.LogRef@@ -90,7 +96,7 @@ import Distribution.ModuleName (ModuleName(..)) import Data.List (isInfixOf, nub, foldl', delete) import qualified System.IO.UTF8 as UTF8 (readFile)-import IDE.Utils.Tool (ToolOutput(..), runTool, newGhci, ToolState(..))+import IDE.Utils.Tool (ToolOutput(..), runTool, newGhci, ToolState(..), toolline) import qualified Data.Set as Set (fromList) import qualified Data.Map as Map (empty, fromList) import System.Exit (ExitCode(..))@@ -98,25 +104,25 @@ import IDE.Utils.Tool (executeGhciCommand, getProcessExitCode, interruptProcessGroupOf, ProcessHandle) import qualified Data.Conduit as C (Sink)-import qualified Data.Conduit.List as CL (foldM, fold)+import qualified Data.Conduit.List as CL (foldM, fold, consume) import qualified Data.Conduit.Util as CU (zipSinks) import Data.Conduit (($$)) import Control.Monad.Trans.Reader (ask) import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift)-import Control.Monad (when, unless, liftM)-#if MIN_VERSION_Cabal(1,10,0)-import Distribution.PackageDescription.PrettyPrintCopied+import Control.Monad (when, unless, liftM, forM, forM_)+import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription)-#endif import Debug.Trace (trace) import IDE.Pane.WebKit.Documentation (getDocumentation, loadDoc, reloadDoc)+import IDE.Pane.WebKit.Output (loadOutputUri, getOutputPane) import Text.Printf (printf) import System.Log.Logger (debugM) import System.Process.Vado (getMountPoint, vado, readSettings)-import qualified Data.Text as T (pack, isInfixOf)+import qualified Data.Text as T (pack, unpack, isInfixOf) import IDE.Utils.ExternalTool (runExternalTool', runExternalTool, isRunning, interruptBuild)+import Text.PrinterParser (writeFields) -- | Get the last item sinkLast = CL.fold (\_ a -> Just a) Nothing@@ -125,59 +131,47 @@ moduleInfo bi mods a = map (\m -> (m, buildInfo)) $ mods a where buildInfo = bi a -#if MIN_VERSION_Cabal(1,8,0) myLibModules pd = case library pd of Nothing -> [] Just l -> moduleInfo libBuildInfo libModules l myExeModules pd = concatMap (moduleInfo buildInfo exeModules) (executables pd)-#else-myLibModules pd = moduleInfo libModules libBuildInfo pd-myExeModules pd = moduleInfo exeModules buildInfo pd-#endif-#if MIN_VERSION_Cabal(1,10,0) myTestModules pd = concatMap (moduleInfo testBuildInfo (otherModules . testBuildInfo)) (testSuites pd)-#endif--activatePackage :: Maybe (IDEPackage, Maybe String) -> IDEM ()-activatePackage (Just (pack, mbExe)) = do- liftIO $ debugM "leksah" "activatePackage"- modifyIDE_ (\ide -> ide{activePack = Just pack, activeExe = mbExe})- liftIO $ setCurrentDirectory (dropFileName (ipdCabalFile pack))- triggerEventIDE (Sensitivity [(SensitivityProjectActive,True)])- mbWs <- readIDE workspace- let wsStr = case mbWs of- Nothing -> ""- Just ws -> wsName ws- let txt = wsStr ++ " > " ++ packageIdentifierToString (ipdPackageId pack)- triggerEventIDE (StatusbarChanged [CompartmentPackage txt])- return ()-activatePackage Nothing = return ()+myBenchmarkModules pd = concatMap (moduleInfo benchmarkBuildInfo (otherModules . benchmarkBuildInfo)) (benchmarks pd) -deactivatePackage :: IDEAction-deactivatePackage = do- liftIO $ debugM "leksah" "deactivatePackage"+activatePackage :: Maybe FilePath -> Maybe IDEPackage -> Maybe String -> IDEM ()+activatePackage mbPath mbPack mbExe = do+ liftIO $ debugM "leksah" "activatePackage" oldActivePack <- readIDE activePack- modifyIDE_ (\ide -> ide{activePack = Nothing, activeExe = Nothing})- when (isJust oldActivePack) $ do- triggerEventIDE (Sensitivity [(SensitivityProjectActive,False)])+ modifyIDE_ (\ide -> ide{activePack = mbPack, activeExe = mbExe})+ case mbPath of+ Just p -> liftIO $ setCurrentDirectory (dropFileName p)+ Nothing -> return ()+ when (isJust mbPack || isJust oldActivePack) $ do+ triggerEventIDE (Sensitivity [(SensitivityProjectActive,isJust mbPack)]) return () mbWs <- readIDE workspace let wsStr = case mbWs of Nothing -> "" Just ws -> wsName ws- let txt = wsStr ++ ":"+ txt = case (mbPath, mbPack) of+ (_, Just pack) -> wsStr ++ " > " ++ packageIdentifierToString (ipdPackageId pack)+ (Just path, _) -> wsStr ++ " > " ++ takeFileName path+ _ -> wsStr ++ ":" triggerEventIDE (StatusbarChanged [CompartmentPackage txt]) return () +deactivatePackage :: IDEAction+deactivatePackage = activatePackage Nothing Nothing Nothing+ packageConfig :: PackageAction packageConfig = do package <- ask- lift $ packageConfig' package (\ _ -> return ())+ liftIDE $ packageConfig' package (\ _ -> return ()) packageConfig' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction packageConfig' package continuation = do prefs <- readIDE prefs- let dir = dropFileName (ipdCabalFile package)+ let dir = ipdBuildDir package logLaunch <- getDefaultLogLaunch showDefaultLogLaunch' @@ -187,7 +181,7 @@ dir $ do (mbLastOutput, _) <- CU.zipSinks sinkLast (logOutput logLaunch) lift $ do- mbPack <- idePackageFromPath (ipdCabalFile package)+ mbPack <- idePackageFromPath (logOutput logLaunch) (ipdCabalFile package) case mbPack of Just pack -> do changePackage pack@@ -199,15 +193,16 @@ continuation False return() -runCabalBuild :: Bool -> Bool -> Bool -> IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction-runCabalBuild backgroundBuild jumpToWarnings withoutLinking package shallConfigure continuation = do+runCabalBuild :: Bool -> Bool -> Bool -> Bool -> IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction+runCabalBuild backgroundBuild runTests jumpToWarnings withoutLinking package shallConfigure continuation = do prefs <- readIDE prefs- let dir = dropFileName (ipdCabalFile package)- let args = (["build"] ++- if backgroundBuild && withoutLinking+ let dir = ipdBuildDir package+ let args = ([if runTests then "test" else "build"]+ ++ (if backgroundBuild && withoutLinking then ["--with-ld=false"]- else []- ++ ipdBuildFlags package)+ else [])+ ++ ipdBuildFlags package+ ++ (if runTests then ipdTestFlags package else [])) runExternalTool' (__ "Building") (cabalCommand prefs) args dir $ do (mbLastOutput, (isConfigErr, _)) <- CU.zipSinks sinkLast $ CU.zipSinks isConfigError $ logOutputForBuild package backgroundBuild jumpToWarnings@@ -216,7 +211,7 @@ if shallConfigure && isConfigErr then packageConfig' package (\ b ->- when b $ runCabalBuild backgroundBuild jumpToWarnings withoutLinking package False continuation)+ when b $ runCabalBuild backgroundBuild runTests jumpToWarnings withoutLinking package False continuation) else do continuation (mbLastOutput == Just (ToolExit ExitSuccess)) return ()@@ -230,8 +225,8 @@ str2 = T.pack (__ "please re-configure") str3 = T.pack (__ "cannot satisfy -package-id") -buildPackage :: Bool -> Bool -> Bool -> IDEPackage -> (Bool -> IDEAction) -> IDEAction-buildPackage backgroundBuild jumpToWarnings withoutLinking package continuation = catchIDE (do+buildPackage :: Bool -> Bool -> Bool -> Bool -> IDEPackage -> (Bool -> IDEAction) -> IDEAction+buildPackage backgroundBuild runTests jumpToWarnings withoutLinking package continuation = catchIDE (do ideR <- ask prefs <- readIDE prefs maybeDebug <- readIDE debugState@@ -244,17 +239,23 @@ when (not backgroundBuild) $ liftIO $ do timeoutAddFull (do reflectIDE (do- buildPackage backgroundBuild jumpToWarnings withoutLinking+ buildPackage backgroundBuild runTests jumpToWarnings withoutLinking package continuation return False) ideR return False) priorityDefaultIdle 1000 return ()- else runCabalBuild backgroundBuild jumpToWarnings withoutLinking package True continuation+ else runCabalBuild backgroundBuild runTests jumpToWarnings withoutLinking package True $ \f -> do+ when f $ do+ mbURI <- readIDE autoURI+ case mbURI of+ Just uri -> postSyncIDE $ loadOutputUri uri+ Nothing -> return ()+ continuation f Just debug@(_, ghci) -> do -- TODO check debug package matches active package ready <- liftIO $ isEmptyMVar (currentToolCommand ghci) when ready $ do- let dir = dropFileName (ipdCabalFile package)+ let dir = ipdBuildDir package when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace; return ()) (`runDebug` debug) . executeDebugCommand ":reload" $ do errs <- logOutputForBuild package backgroundBuild jumpToWarnings@@ -268,13 +269,13 @@ packageDoc :: PackageAction packageDoc = do package <- ask- lift $ packageDoc' False True package (\ _ -> return ())+ liftIDE $ packageDoc' False True package (\ _ -> return ()) packageDoc' :: Bool -> Bool -> IDEPackage -> (Bool -> IDEAction) -> IDEAction packageDoc' backgroundBuild jumpToWarnings package continuation = do prefs <- readIDE prefs catchIDE (do- let dir = dropFileName (ipdCabalFile package)+ let dir = ipdBuildDir package runExternalTool' (__ "Documenting") (cabalCommand prefs) (["haddock"] ++ (ipdHaddockFlags package)) dir $ do (mbLastOutput, _) <- CU.zipSinks sinkLast $@@ -286,7 +287,7 @@ packageClean :: PackageAction packageClean = do package <- ask- lift $ packageClean' package (\ _ -> return ())+ liftIDE $ packageClean' package (\ _ -> return ()) packageClean' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction packageClean' package continuation = do@@ -294,7 +295,7 @@ logLaunch <- getDefaultLogLaunch showDefaultLogLaunch' - let dir = dropFileName (ipdCabalFile package)+ let dir = ipdBuildDir package runExternalTool' (__ "Cleaning") (cabalCommand prefs) ["clean"]@@ -305,40 +306,42 @@ packageCopy :: PackageAction packageCopy = do package <- ask- logLaunch <- lift $ getDefaultLogLaunch- lift $ showDefaultLogLaunch'+ liftIDE $ do+ logLaunch <- getDefaultLogLaunch+ showDefaultLogLaunch' - lift $ catchIDE (do- prefs <- readIDE prefs- window <- getMainWindow- mbDir <- liftIO $ chooseDir window (__ "Select the target directory") Nothing- case mbDir of- Nothing -> return ()- Just fp -> do- let dir = dropFileName (ipdCabalFile package)- runExternalTool' (__ "Copying")- (cabalCommand prefs)- (["copy"] ++ ["--destdir=" ++ fp])- dir- (logOutput logLaunch))- (\(e :: SomeException) -> putStrLn (show e))+ catchIDE (do+ prefs <- readIDE prefs+ window <- getMainWindow+ mbDir <- liftIO $ chooseDir window (__ "Select the target directory") Nothing+ case mbDir of+ Nothing -> return ()+ Just fp -> do+ let dir = ipdBuildDir package+ runExternalTool' (__ "Copying")+ (cabalCommand prefs)+ (["copy"] ++ ["--destdir=" ++ fp])+ dir+ (logOutput logLaunch))+ (\(e :: SomeException) -> putStrLn (show e)) packageInstallDependencies :: PackageAction packageInstallDependencies = do package <- ask- logLaunch <- lift $ getDefaultLogLaunch- lift $ showDefaultLogLaunch'+ liftIDE $ do+ logLaunch <- getDefaultLogLaunch+ showDefaultLogLaunch' - lift $ catchIDE (do- prefs <- readIDE prefs- let dir = dropFileName (ipdCabalFile package)- runExternalTool' (__ "Installing") (cabalCommand prefs) (- (if useCabalDev prefs- then ["install-deps"]- else ["install","--only-dependencies"])- ++ (ipdConfigFlags package)- ++ (ipdInstallFlags package)) dir (logOutput logLaunch))- (\(e :: SomeException) -> putStrLn (show e))+ catchIDE (do+ prefs <- readIDE prefs+ let dir = ipdBuildDir package+ runExternalTool' (__ "Installing") (cabalCommand prefs) (+ (if useCabalDev prefs+ then ["install-deps"]+ else ["install","--only-dependencies"])+ ++ (ipdConfigFlags package)+ ++ (ipdInstallFlags package)) dir (logOutput logLaunch))+ (\(e :: SomeException) -> putStrLn (show e)) packageCopy' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction packageCopy' package continuation = do@@ -347,7 +350,7 @@ showDefaultLogLaunch' catchIDE (do- let dir = dropFileName (ipdCabalFile package)+ let dir = ipdBuildDir package runExternalTool' (__ "Copying") (cabalCommand prefs) (["copy"] ++ (ipdInstallFlags package)) dir $ do (mbLastOutput, _) <- CU.zipSinks sinkLast (logOutput logLaunch)@@ -355,54 +358,123 @@ (\(e :: SomeException) -> putStrLn (show e)) packageRun :: PackageAction-packageRun = do- package <- ask- lift $ catchIDE (do- ideR <- ask- maybeDebug <- readIDE debugState- pd <- liftIO $ readPackageDescription normal (ipdCabalFile package) >>= return . flattenPackageDescription- mbExe <- readIDE activeExe- let exes = filter (isActiveExe mbExe) $ executables pd- case maybeDebug of- Nothing -> do- case exes of- (Executable name _ _):_ -> do- (logLaunch,logName) <- buildLogLaunchByName name- let path = "dist/build" </> name </> name- let dir = dropFileName (ipdCabalFile package)- IDE.Package.runPackage (addLogLaunchData logName logLaunch)- (printf (__ "Running %s") name)- path- (ipdExeFlags package)- dir- (logOutput logLaunch)+packageRun = ask >>= (liftIDE . packageRun' True) +packageRun' :: Bool -> IDEPackage -> IDEAction+packageRun' addFlagIfMissing package = do+ if addFlagIfMissing && "--ghcjs" `elem` ipdConfigFlags package && not ("--ghcjs-option=--native-executables" `elem` ipdConfigFlags package)+ then do+ window <- liftIDE $ getMainWindow+ resp <- liftIO $ do+ md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel+ (__ "Package is configured to use GHCJS. Would you like to add --ghcjs-option=--native-executables to the configure flags and rebuild?")+ dialogAddButton md (__ "Add _GHCJS Native Executables") (ResponseUser 1)+ dialogSetDefaultResponse md (ResponseUser 1)+ set md [ windowWindowPosition := WinPosCenterOnParent ]+ resp <- dialogRun md+ widgetDestroy md+ return resp+ case resp of+ ResponseUser 1 -> do+ let packWithNewFlags = package { ipdConfigFlags = ["--ghcjs-option=--native-executables"] ++ ipdConfigFlags package }+ changePackage packWithNewFlags+ liftIO $ writeFlags (dropExtension (ipdCabalFile packWithNewFlags) ++ leksahFlagFileExtension) packWithNewFlags+ packageConfig' packWithNewFlags $ \ ok -> when ok $ do+ packageRun' False packWithNewFlags+ _ -> return ()+ else liftIDE $ catchIDE (do+ ideR <- ask+ maybeDebug <- readIDE debugState+ pd <- liftIO $ readPackageDescription normal (ipdCabalFile package) >>= return . flattenPackageDescription+ mbExe <- readIDE activeExe+ let exe = take 1 . filter (isActiveExe mbExe) $ executables pd+ let defaultLogName = display . pkgName $ ipdPackageId package+ logName = fromMaybe defaultLogName . listToMaybe $ map exeName exe+ (logLaunch,logName) <- buildLogLaunchByName logName+ case maybeDebug of+ Nothing -> do+ let dir = ipdBuildDir package+ IDE.Package.runPackage (addLogLaunchData logName logLaunch)+ (printf (__ "Running %s") logName)+ "cabal"+ (concat [["run"]+ , ipdBuildFlags package+ , map exeName exe+ , ["--"]+ , ipdExeFlags package])+ dir+ (logOutput logLaunch)+ Just debug -> do+ -- TODO check debug package matches active package+ runDebug (do+ case exe of+ [Executable name mainFilePath _] -> do+ executeDebugCommand (":module *" ++ (map (\c -> if c == '/' then '.' else c) (takeWhile (/= '.') mainFilePath))) (logOutput logLaunch)+ _ -> return ()+ executeDebugCommand (":main " ++ (unwords (ipdExeFlags package))) (logOutput logLaunch))+ debug)+ (\(e :: SomeException) -> putStrLn (show e))+ where+ isActiveExe selected (Executable name _ _) = selected == Just name - otherwise -> do- sysMessage Normal (__ "no executable in selected package")- return ()- Just debug -> do- -- TODO check debug package matches active package- case exes of- (Executable name mainFilePath _):_ -> do- (logLaunch,logName) <- buildLogLaunchByName name- runDebug (do- executeDebugCommand (":module *" ++ (map (\c -> if c == '/' then '.' else c) (takeWhile (/= '.') mainFilePath))) (logOutput logLaunch)- executeDebugCommand (":main " ++ (unwords (ipdExeFlags package))) (logOutput logLaunch))- debug- otherwise -> do- sysMessage Normal (__ "no executable in selected package")- return ())- (\(e :: SomeException) -> putStrLn (show e))+packageRunJavaScript :: PackageAction+packageRunJavaScript = ask >>= (liftIDE . packageRunJavaScript' True)++packageRunJavaScript' :: Bool -> IDEPackage -> IDEAction+packageRunJavaScript' addFlagIfMissing package = do+ if addFlagIfMissing && not ("--ghcjs" `elem` ipdConfigFlags package)+ then do+ window <- liftIDE $ getMainWindow+ resp <- liftIO $ do+ md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel+ (__ "Package is not configured to use GHCJS. Would you like to add --ghcjs to the configure flags and rebuild?")+ dialogAddButton md (__ "Use _GHCJS") (ResponseUser 1)+ dialogSetDefaultResponse md (ResponseUser 1)+ set md [ windowWindowPosition := WinPosCenterOnParent ]+ resp <- dialogRun md+ widgetDestroy md+ return resp+ case resp of+ ResponseUser 1 -> do+ let packWithNewFlags = package { ipdConfigFlags = ["--ghcjs"] ++ ipdConfigFlags package }+ changePackage packWithNewFlags+ liftIO $ writeFlags (dropExtension (ipdCabalFile packWithNewFlags) ++ leksahFlagFileExtension) packWithNewFlags+ packageConfig' packWithNewFlags $ \ ok -> when ok $ do+ packageRunJavaScript' False packWithNewFlags+ _ -> return ()+ else liftIDE $ buildPackage False False True False package $ \ ok -> when ok $ liftIDE $ catchIDE (do+ ideR <- ask+ maybeDebug <- readIDE debugState+ pd <- liftIO $ readPackageDescription normal (ipdCabalFile package) >>= return . flattenPackageDescription+ mbExe <- readIDE activeExe+ let exe = take 1 . filter (isActiveExe mbExe) $ executables pd+ let defaultLogName = display . pkgName $ ipdPackageId package+ logName = fromMaybe defaultLogName . listToMaybe $ map exeName exe+ (logLaunch,logName) <- buildLogLaunchByName logName+ let dir = ipdBuildDir package+ prefs <- readIDE prefs+ case exe ++ executables pd of+ (Executable name _ _ : _) -> liftIDE $ do+ let path = "dist/build" </> name </> name <.> "jsexe" </> "index.html"+ dir = ipdBuildDir package+#ifdef WEBKITGTK+ loadOutputUri ("file:///" ++ dir </> path)+ getOutputPane Nothing >>= \ p -> displayPane p False+#else+ openBrowser path+#endif+ `catchIDE`+ (\(e :: SomeException) -> putStrLn (show e))++ _ -> return ())+ (\(e :: SomeException) -> putStrLn (show e)) where- isActiveExe Nothing _ = True- isActiveExe (Just selected) (Executable name _ _) = selected == name- isActiveExe _ _ = False+ isActiveExe selected (Executable name _ _) = selected == Just name packageRegister :: PackageAction packageRegister = do package <- ask- lift $ packageRegister' package (\ _ -> return ())+ liftIDE $ packageRegister' package (\ _ -> return ()) packageRegister' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction packageRegister' package continuation =@@ -412,7 +484,7 @@ showDefaultLogLaunch' catchIDE (do prefs <- readIDE prefs- let dir = dropFileName (ipdCabalFile package)+ let dir = ipdBuildDir package runExternalTool' (__ "Registering") (cabalCommand prefs) (["register"] ++ (ipdRegisterFlags package)) dir $ do (mbLastOutput, _) <- CU.zipSinks sinkLast (logOutput logLaunch)@@ -423,51 +495,59 @@ packageTest :: PackageAction packageTest = do package <- ask- lift $ packageTest' package (\ _ -> return ())+ liftIDE $ packageTest' package True (\ _ -> return ()) -packageTest' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction-packageTest' package continuation =+packageTest' :: IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction+packageTest' package shallConfigure continuation = if "--enable-tests" `elem` ipdConfigFlags package then do logLaunch <- getDefaultLogLaunch showDefaultLogLaunch' catchIDE (do prefs <- readIDE prefs- let dir = dropFileName (ipdCabalFile package)+ let dir = ipdBuildDir package runExternalTool' (__ "Testing") (cabalCommand prefs) (["test"]- ++ (ipdTestFlags package)) dir $ do- (mbLastOutput, _) <- CU.zipSinks sinkLast (logOutput logLaunch)- lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))+ ++ ipdBuildFlags package ++ ipdTestFlags package) dir $ do+ (mbLastOutput, (isConfigErr, _)) <- CU.zipSinks sinkLast $ CU.zipSinks isConfigError $+ logOutputForBuild package False True+ lift $ do+ errs <- readIDE errorRefs+ if shallConfigure && isConfigErr+ then+ packageConfig' package (\ b ->+ when b $ packageTest' package shallConfigure continuation)+ else do+ continuation (mbLastOutput == Just (ToolExit ExitSuccess))+ return ()) (\(e :: SomeException) -> putStrLn (show e)) else continuation True packageSdist :: PackageAction packageSdist = do package <- ask- logLaunch <- lift $ getDefaultLogLaunch- lift $ showDefaultLogLaunch'+ liftIDE $ do+ logLaunch <- getDefaultLogLaunch+ showDefaultLogLaunch' - lift $ catchIDE (do- prefs <- readIDE prefs- let dir = dropFileName (ipdCabalFile package)- runExternalTool' (__ "Source Dist") (cabalCommand prefs) (["sdist"]- ++ (ipdSdistFlags package)) dir (logOutput logLaunch))- (\(e :: SomeException) -> putStrLn (show e))+ catchIDE (do+ prefs <- readIDE prefs+ let dir = ipdBuildDir package+ runExternalTool' (__ "Source Dist") (cabalCommand prefs) (["sdist"]+ ++ (ipdSdistFlags package)) dir (logOutput logLaunch))+ (\(e :: SomeException) -> putStrLn (show e)) packageOpenDoc :: PackageAction packageOpenDoc = do package <- ask- logLaunch <- lift $ getDefaultLogLaunch- lift $ showDefaultLogLaunch' - lift $ do+ liftIDE $ do prefs <- readIDE prefs- let path = dropFileName (ipdCabalFile package)+ let path = ipdBuildDir package </> "dist/doc/html" </> display (pkgName (ipdPackageId package)) </> "index.html"- dir = dropFileName (ipdCabalFile package)+ dir = ipdBuildDir package #ifdef WEBKITGTK loadDoc ("file:///" ++ dir </> path) getDocumentation Nothing >>= \ p -> displayPane p False@@ -527,52 +607,62 @@ , ("@ModuleBody@" , body)])) (\ (e :: SomeException) -> sysMessage Normal (printf (__ "Couldn't read template file: %s") (show e)) >> return "") -#if MIN_VERSION_Cabal(1,10,0)-addModuleToPackageDescr :: ModuleName -> Bool -> PackageAction-addModuleToPackageDescr moduleName isExposed = do+data ModuleLocation = LibExposedMod | LibOtherMod | ExeOrTestMod String++addModuleToPackageDescr :: ModuleName -> [ModuleLocation] -> PackageAction+addModuleToPackageDescr moduleName locations = do p <- ask- lift $ reifyIDE (\ideR -> catch (do+ liftIDE $ reifyIDE (\ideR -> catch (do gpd <- readPackageDescription normal (ipdCabalFile p)- let npd = if isExposed && isJust (condLibrary gpd)- then gpd{- condLibrary = Just (addModToLib moduleName- (fromJust (condLibrary gpd))),- condExecutables = map (addModToBuildInfoExe moduleName)- (condExecutables gpd)}- else gpd{- condLibrary = case condLibrary gpd of- Nothing -> Nothing- Just lib -> Just (addModToBuildInfoLib moduleName- (fromJust (condLibrary gpd))),- condExecutables = map (addModToBuildInfoExe moduleName)- (condExecutables gpd)}+ let npd = trace (show gpd) foldr addModule gpd locations writeGenericPackageDescription (ipdCabalFile p) npd) (\(e :: SomeException) -> do reflectIDE (ideMessage Normal ((__ "Can't update package ") ++ show e)) ideR return ()))+ where+ addModule LibExposedMod gpd@GenericPackageDescription{condLibrary = Just lib} =+ gpd {condLibrary = Just (addModToLib moduleName lib)}+ addModule LibOtherMod gpd@GenericPackageDescription{condLibrary = Just lib} =+ gpd {condLibrary = Just (addModToBuildInfoLib moduleName lib)}+ addModule (ExeOrTestMod name) gpd = gpd {+ condExecutables = map (addModToBuildInfoExe name moduleName) (condExecutables gpd)+ , condTestSuites = map (addModToBuildInfoTest name moduleName) (condTestSuites gpd)+ }+ addModule _ x = x addModToLib :: ModuleName -> CondTree ConfVar [Dependency] Library -> CondTree ConfVar [Dependency] Library addModToLib modName ct@CondNode{condTreeData = lib} =- ct{condTreeData = lib{exposedModules = modName : exposedModules lib}}+ ct{condTreeData = lib{exposedModules = modName `inOrderAdd` exposedModules lib}} addModToBuildInfoLib :: ModuleName -> CondTree ConfVar [Dependency] Library -> CondTree ConfVar [Dependency] Library addModToBuildInfoLib modName ct@CondNode{condTreeData = lib} = ct{condTreeData = lib{libBuildInfo = (libBuildInfo lib){otherModules = modName- : otherModules (libBuildInfo lib)}}}+ `inOrderAdd` otherModules (libBuildInfo lib)}}} -addModToBuildInfoExe :: ModuleName -> (String, CondTree ConfVar [Dependency] Executable) ->+addModToBuildInfoExe :: String -> ModuleName -> (String, CondTree ConfVar [Dependency] Executable) -> (String, CondTree ConfVar [Dependency] Executable)-addModToBuildInfoExe modName (str,ct@CondNode{condTreeData = exe}) =+addModToBuildInfoExe name modName (str,ct@CondNode{condTreeData = exe}) | str == name = (str, ct{condTreeData = exe{buildInfo = (buildInfo exe){otherModules = modName- : otherModules (buildInfo exe)}}})+ `inOrderAdd` otherModules (buildInfo exe)}}})+addModToBuildInfoExe name _ x = x +addModToBuildInfoTest :: String -> ModuleName -> (String, CondTree ConfVar [Dependency] TestSuite) ->+ (String, CondTree ConfVar [Dependency] TestSuite)+addModToBuildInfoTest name modName (str,ct@CondNode{condTreeData = test}) | str == name =+ (str, ct{condTreeData = test{testBuildInfo = (testBuildInfo test){otherModules = modName+ `inOrderAdd` otherModules (testBuildInfo test)}}})+addModToBuildInfoTest _ _ x = x++inOrderAdd :: Ord a => a -> [a] -> [a]+inOrderAdd a list = let (before, after) = span (< a) list in before ++ [a] ++ after+ -------------------------------------------------------------------------- delModuleFromPackageDescr :: ModuleName -> PackageAction-delModuleFromPackageDescr moduleName = trace ("addModule " ++ show moduleName) $ do+delModuleFromPackageDescr moduleName = do p <- ask- lift $ reifyIDE (\ideR -> catch (do+ liftIDE $ reifyIDE (\ideR -> catch (do gpd <- readPackageDescription normal (ipdCabalFile p) let isExposedAndJust = isExposedModule moduleName (condLibrary gpd) let npd = if isExposedAndJust@@ -614,76 +704,6 @@ isExposedModule mn Nothing = False isExposedModule mn (Just CondNode{condTreeData = lib}) = elem mn (exposedModules lib) -#else--- Old version to support older Cabal-addModuleToPackageDescr :: ModuleName -> Bool -> PackageAction-addModuleToPackageDescr moduleName isExposed = do- p <- ask- lift $ reifyIDE (\ideR -> catch (do- gpd <- readPackageDescription normal (ipdCabalFile p)- if hasConfigs gpd- then do- reflectIDE (ideMessage High- (__ "Cabal file with configurations can't be automatically updated with the current version of Leksah")) ideR- else- let pd = flattenPackageDescription gpd- npd = if isExposed && isJust (library pd)- then pd{library = Just ((fromJust (library pd)){exposedModules =- moduleName : exposedModules (fromJust $ library pd)})}- else let npd1 = case library pd of- Nothing -> pd- Just lib -> pd{library = Just (lib{libBuildInfo =- addModToBuildInfo (libBuildInfo lib) moduleName})}- in npd1{executables = map- (\exe -> exe{buildInfo = addModToBuildInfo (buildInfo exe) moduleName})- (executables npd1)}- in writePackageDescription (ipdCabalFile p) npd)- (\(e :: SomeException) -> do- reflectIDE (ideMessage Normal ((__ "Can't upade package ") ++ show e)) ideR- return ()))- where- addModToBuildInfo :: BuildInfo -> ModuleName -> BuildInfo- addModToBuildInfo bi mn = bi {otherModules = mn : otherModules bi}---- Old version to support older Cabal-delModuleFromPackageDescr :: ModuleName -> PackageAction-delModuleFromPackageDescr moduleName = do- p <- ask- lift $ reifyIDE (\ideR -> catch (do- gpd <- readPackageDescription normal (ipdCabalFile p)- if hasConfigs gpd- then do- reflectIDE (ideMessage High- (__ "Cabal file with configurations can't be automatically updated with the current version of Leksah")) ideR- else- let pd = flattenPackageDescription gpd- isExposedAndJust = isExposedModule pd moduleName- npd = if isExposedAndJust- then pd{library = Just ((fromJust (library pd)){exposedModules =- delete moduleName (exposedModules (fromJust $ library pd))})}- else let npd1 = case library pd of- Nothing -> pd- Just lib -> pd{library = Just (lib{libBuildInfo =- delModFromBuildInfo (libBuildInfo lib) moduleName})}- in npd1{executables = map- (\exe -> exe{buildInfo = delModFromBuildInfo (buildInfo exe) moduleName})- (executables npd1)}- in writePackageDescription (ipdCabalFile p) npd)- (\(e :: SomeException) -> do- reflectIDE (ideMessage Normal ((__ "Can't update package ") ++ show e)) ideR- return ()))- where- delModFromBuildInfo :: BuildInfo -> ModuleName -> BuildInfo- delModFromBuildInfo bi mn = bi {otherModules = delete mn (otherModules bi)}---- Old version to support older Cabal-isExposedModule :: PackageDescription -> ModuleName -> Bool-isExposedModule pd mn = do- if isJust (library pd)- then elem mn (exposedModules (fromJust $ library pd))- else False-#endif- backgroundBuildToggled :: IDEAction backgroundBuildToggled = do toggled <- getBackgroundBuildToggled@@ -728,13 +748,13 @@ debugStart :: PackageAction debugStart = do package <- ask- lift $ catchIDE (do+ liftIDE $ catchIDE (do ideRef <- ask prefs' <- readIDE prefs maybeDebug <- readIDE debugState case maybeDebug of Nothing -> do- let dir = dropFileName (ipdCabalFile package)+ let dir = ipdBuildDir package mbExe <- readIDE activeExe ghci <- reifyIDE $ \ideR -> newGhci dir mbExe (interactiveFlags prefs') $ reflectIDEI (logOutputForBuild package True False >> return ()) ideR@@ -749,7 +769,7 @@ modifyIDE_ (\ide -> ide {debugState = Nothing, autoCommand = return ()}) triggerEventIDE (Sensitivity [(SensitivityInterpreting, False)]) -- Kick of a build if one is not already due- modifiedPacks <- fileCheckAll belongsToPackage+ modifiedPacks <- fileCheckAll belongsToPackages let modified = not (null modifiedPacks) prefs <- readIDE prefs when ((not modified) && (backgroundBuild prefs)) $ do@@ -758,7 +778,7 @@ -- Lets build to make sure the binaries are up to date mbPackage <- readIDE activePack case mbPackage of- Just package -> runCabalBuild True False False package True (\ _ -> return ())+ Just package -> runCabalBuild True False False False package True (\ _ -> return ()) Nothing -> return () return () _ -> do@@ -768,13 +788,13 @@ tryDebug :: DebugAction -> PackageAction tryDebug f = do- maybeDebug <- lift $ readIDE debugState+ maybeDebug <- liftIDE $ readIDE debugState case maybeDebug of Just debug -> do -- TODO check debug package matches active package- lift $ runDebug f debug+ liftIDE $ runDebug f debug _ -> do- window <- lift $ getMainWindow+ window <- liftIDE $ getMainWindow resp <- liftIO $ do md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel (__ "GHCi debugger is not running.")@@ -787,19 +807,19 @@ case resp of ResponseUser 1 -> do debugStart- maybeDebug <- lift $ readIDE debugState+ maybeDebug <- liftIDE $ readIDE debugState case maybeDebug of- Just debug -> lift $ postAsyncIDE $ runDebug f debug+ Just debug -> liftIDE $ postAsyncIDE $ runDebug f debug _ -> return () _ -> return () tryDebugQuiet :: DebugAction -> PackageAction tryDebugQuiet f = do- maybeDebug <- lift $ readIDE debugState+ maybeDebug <- liftIDE $ readIDE debugState case maybeDebug of Just debug -> do -- TODO check debug package matches active package- lift $ runDebug f debug+ liftIDE $ runDebug f debug _ -> do return () @@ -819,20 +839,16 @@ return () allBuildInfo' :: PackageDescription -> [BuildInfo]-#if MIN_VERSION_Cabal(1,10,0) allBuildInfo' pkg_descr = [ libBuildInfo lib | Just lib <- [library pkg_descr] ] ++ [ buildInfo exe | exe <- executables pkg_descr ] ++ [ testBuildInfo tst | tst <- testSuites pkg_descr ] testMainPath (TestSuiteExeV10 _ f) = [f] testMainPath _ = []-#else-allBuildInfo' = allBuildInfo-#endif -idePackageFromPath :: FilePath -> IDEM (Maybe IDEPackage)-idePackageFromPath filePath = do+idePackageFromPath' :: FilePath -> IDEM (Maybe IDEPackage)+idePackageFromPath' ipdCabalFile = do mbPackageD <- reifyIDE (\ideR -> catch (do- pd <- readPackageDescription normal filePath+ pd <- readPackageDescription normal ipdCabalFile return (Just (flattenPackageDescription pd))) (\ (e :: SomeException) -> do reflectIDE (ideMessage Normal ((__ "Can't activate package ") ++(show e))) ideR@@ -840,55 +856,76 @@ case mbPackageD of Nothing -> return Nothing Just packageD -> do- let modules = Map.fromList $ myLibModules packageD ++ myExeModules packageD-#if MIN_VERSION_Cabal(1,10,0)- ++ myTestModules packageD-#endif- let mainFiles = [ (modulePath exe, buildInfo exe, False) | exe <- executables packageD ]-#if MIN_VERSION_Cabal(1,10,0)- ++ [ (f, bi, True) | TestSuite _ (TestSuiteExeV10 _ f) bi _ <- testSuites packageD ]-#endif- let files = Set.fromList $ extraSrcFiles packageD- let srcDirs = case (nub $ concatMap hsSourceDirs (allBuildInfo' packageD)) of- [] -> [".","src"]- l -> l- let exes = [ exeName e | e <- executables packageD++ let ipdModules = Map.fromList $ myLibModules packageD ++ myExeModules packageD+ ++ myTestModules packageD ++ myBenchmarkModules packageD+ ipdMain = [ (modulePath exe, buildInfo exe, False) | exe <- executables packageD ]+ ++ [ (f, bi, True) | TestSuite _ (TestSuiteExeV10 _ f) bi _ <- testSuites packageD ]+ ++ [ (f, bi, True) | Benchmark _ (BenchmarkExeV10 _ f) bi _ <- benchmarks packageD ]+ ipdExtraSrcs = Set.fromList $ extraSrcFiles packageD+ ipdSrcDirs = case (nub $ concatMap hsSourceDirs (allBuildInfo' packageD)) of+ [] -> [".","src"]+ l -> l+ ipdExes = [ exeName e | e <- executables packageD , buildable (buildInfo e) ]-#if MIN_VERSION_Cabal(1,10,0)- let exts = nub $ concatMap oldExtensions (allBuildInfo' packageD)- let tests = [ testName t | t <- testSuites packageD+ ipdExtensions = nub $ concatMap oldExtensions (allBuildInfo' packageD)+ ipdTests = [ testName t | t <- testSuites packageD , buildable (testBuildInfo t) ]-#else- let exts = nub $ concatMap extensions (allBuildInfo' packageD)- let tests = []-#endif-- let packp = IDEPackage {- ipdPackageId = package packageD,- ipdCabalFile = filePath,- ipdDepends = buildDepends packageD,- ipdModules = modules,- ipdHasLibs = hasLibs packageD,- ipdExes = exes,- ipdTests = tests,- ipdMain = mainFiles,- ipdExtraSrcs = files,- ipdSrcDirs = srcDirs,- ipdExtensions = exts,- ipdConfigFlags = ["--user", "--enable-tests"],- ipdBuildFlags = [],- ipdTestFlags = [],- ipdHaddockFlags = [],- ipdExeFlags = [],- ipdInstallFlags = [],- ipdRegisterFlags = [],- ipdUnregisterFlags = [],- ipdSdistFlags = []}- let pfile = dropExtension filePath+ ipdBenchmarks = [ benchmarkName b | b <- benchmarks packageD+ , buildable (benchmarkBuildInfo b) ]+ ipdPackageId = package packageD+ ipdDepends = buildDepends packageD+ ipdHasLibs = hasLibs packageD+ ipdConfigFlags = ["--user", "--enable-tests"]+ ipdBuildFlags = []+ ipdTestFlags = []+ ipdHaddockFlags = []+ ipdExeFlags = []+ ipdInstallFlags = []+ ipdRegisterFlags = []+ ipdUnregisterFlags = []+ ipdSdistFlags = []+ ipdSandboxSources = []+ packp = IDEPackage {..}+ pfile = dropExtension ipdCabalFile pack <- (do flagFileExists <- liftIO $ doesFileExist (pfile ++ leksahFlagFileExtension) if flagFileExists then liftIO $ readFlags (pfile ++ leksahFlagFileExtension) packp else return packp) return (Just pack)++idePackageFromPath :: C.Sink ToolOutput IDEM () -> FilePath -> IDEM (Maybe IDEPackage)+idePackageFromPath log filePath = do+ mbRootPackage <- idePackageFromPath' filePath+ case mbRootPackage of+ Nothing -> return Nothing+ Just rootPackage -> do+ mvar <- liftIO newEmptyMVar+ runExternalTool' "" "cabal" ["sandbox", "list-sources"] (takeDirectory filePath) $ do+ output <- CL.consume+ liftIO . putMVar mvar $ case take 1 $ reverse output of+ [ToolExit ExitSuccess] ->+ map (T.unpack . toolline) . takeWhile (/= ToolOutput "") . drop 1 $ dropWhile (/= ToolOutput "") output+ _ -> []+ paths <- liftIO $ takeMVar mvar+ sandboxSources <- concat <$> (forM paths $ \ path -> do+ contents <- liftIO $ getDirectoryContents path+ return . take 1 . map (path </>) $ filter ((== ".cabal") . takeExtension) contents)+ s <- liftM catMaybes . mapM idePackageFromPath' $ nub sandboxSources+ return . Just $ rootPackage {ipdSandboxSources = s}++refreshPackage :: C.Sink ToolOutput IDEM () -> PackageM (Maybe IDEPackage)+refreshPackage log = do+ package <- ask+ liftIDE $ do+ mbUpdatedPack <- idePackageFromPath log (ipdCabalFile package)+ case mbUpdatedPack of+ Just updatedPack -> do+ changePackage updatedPack+ triggerEventIDE $ WorkspaceChanged False True+ return mbUpdatedPack+ Nothing -> do+ postAsyncIDE $ ideMessage Normal (__ "Can't read package file")+ return Nothing
src/IDE/Pane/Breakpoints.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleInstances, RecordWildCards, TypeSynonymInstances,- MultiParamTypeClasses, DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances,+ MultiParamTypeClasses, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Breakpoints@@ -53,14 +53,13 @@ instance Pane IDEBreakpoints IDEM where- primPaneName _ = (__ "Breakpoints")+ primPaneName _ = __ "Breakpoints" getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledView paneId b = "*Breakpoints" instance RecoverablePane IDEBreakpoints BreakpointsState IDEM where- saveState p = do- return (Just BreakpointsState)+ saveState p = return (Just BreakpointsState) recoverState pp BreakpointsState = do nb <- getNotebook pp buildPane pp nb builder@@ -95,6 +94,7 @@ selB <- treeViewGetSelection treeView treeSelectionSetMode selB SelectionSingle scrolledView <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scrolledView ShadowIn containerAdd scrolledView treeView scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic let pane = IDEBreakpoints scrolledView treeView breakpoints@@ -183,7 +183,7 @@ deleteBreakpoint :: LogRef -> IDEAction deleteBreakpoint logRef = case logRefType logRef of- BreakpointRef -> debugDeleteBreakpoint ((words (T.unpack $ refDescription logRef)) !! 1) logRef+ BreakpointRef -> debugDeleteBreakpoint (words (T.unpack $ refDescription logRef) !! 1) logRef _ -> sysMessage Normal (__ "Debugger>>deleteBreakpoint: Not a breakpoint")
src/IDE/Pane/Errors.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleInstances, RecordWildCards, TypeSynonymInstances,- MultiParamTypeClasses, DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances,+ MultiParamTypeClasses, DeriveDataTypeable, OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Errors@@ -54,13 +54,12 @@ instance Pane IDEErrors IDEM where- primPaneName _ = (__ "Errors")+ primPaneName _ = __ "Errors" getTopWidget = castToWidget . scrolledView paneId b = "*Errors" instance RecoverablePane IDEErrors ErrorsState IDEM where- saveState p = do- return (Just ErrorsState)+ saveState p = return (Just ErrorsState) recoverState pp ErrorsState = do nb <- getNotebook pp p <- buildPane pp nb builder@@ -87,7 +86,7 @@ cellLayoutPackStart colA rendererA False cellLayoutSetAttributes colA rendererA errorStore $ \row -> [cellText := if index row == 0 then showSourceSpan (logRef row) else "",- cellTextForeground := if (logRefType (logRef row)) == WarningRef+ cellTextForeground := if logRefType (logRef row) == WarningRef then "green" else "red" ] rendererB <- cellRendererTextNew@@ -105,6 +104,7 @@ selB <- treeViewGetSelection treeView treeSelectionSetMode selB SelectionSingle scrolledView <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scrolledView ShadowIn containerAdd scrolledView treeView scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic let pane = IDEErrors scrolledView treeView errorStore@@ -171,8 +171,7 @@ errorsContextMenu ideR store treeView theMenu = do mbSel <- getSelectedError treeView store item0 <- menuItemNewWithLabel (__ "Resolve Errors")- item0 `on` menuItemActivate $ do- reflectIDE resolveErrors ideR+ item0 `on` menuItemActivate $ reflectIDE resolveErrors ideR menuShellAppend theMenu item0 case mbSel of Just sel -> addResolveMenuItems ideR theMenu sel
src/IDE/Pane/Files.hs view
@@ -23,11 +23,12 @@ import Prelude hiding (catch) import Graphics.UI.Gtk- (treeSelectionSelectionChanged, treeStoreRemove, treeModelIterNext,- treeModelGetRow, treeStoreInsert, treeModelIterNthChild,- treeModelGetPath, TreeIter, treeModelGetIter, TreePath,- treeSelectionGetSelectedRows, rowActivated, treeStoreGetValue,- rowExpanded, on, after, focusInEvent, scrolledWindowSetPolicy, containerAdd,+ (scrolledWindowSetShadowType, treeSelectionSelectionChanged,+ treeStoreRemove, treeModelIterNext, treeModelGetRow,+ treeStoreInsert, treeModelIterNthChild, treeModelGetPath, TreeIter,+ treeModelGetIter, TreePath, treeSelectionGetSelectedRows,+ rowActivated, treeStoreGetValue, rowExpanded, on, after,+ focusInEvent, scrolledWindowSetPolicy, containerAdd, scrolledWindowNew, treeSelectionSetMode, treeViewGetSelection, treeViewSetHeadersVisible, cellText, cellLayoutSetAttributes, cellLayoutPackStart, treeViewAppendColumn,@@ -37,12 +38,12 @@ treeViewNew, treeStoreNew, castToWidget, TreeStore, TreeView, ScrolledWindow) import Data.Maybe (isJust)-import Control.Monad (forM_, when)+import Control.Monad (void, forM_, when) import Data.Typeable (Typeable) import IDE.Core.State- (MessageLevel(..), ipdCabalFile, ipdPackageId, wsPackages,+ (MessageLevel(..), ipdBuildDir, ipdPackageId, wsPackages, workspace, readIDE, IDEAction, ideMessage, reflectIDE, reifyIDE,- IDEM)+ IDEM, IDEPackage, ipdSandboxSources) import IDE.Pane.SourceBuffer (goToSourceDefinition) import Control.Applicative ((<$>))@@ -56,7 +57,8 @@ import Graphics.UI.Frame.ViewFrame (getNotebook) import Graphics.UI.Editor.Basics (Connection(..)) import Graphics.UI.Gtk.General.Enums- (PolicyType(..), SelectionMode(..), TreeViewColumnSizing(..))+ (ShadowType(..), PolicyType(..), SelectionMode(..),+ TreeViewColumnSizing(..)) import System.Glib.Attributes (AttrOp(..)) import Control.Monad.IO.Class (MonadIO(..)) import IDE.Utils.GUIUtils (__)@@ -65,13 +67,13 @@ data FileRecord = FileRecord FilePath | DirRecord FilePath- | PackageRecord PackageIdentifier FilePath+ | PackageRecord IDEPackage | PlaceHolder deriving(Eq) file :: FileRecord -> String file (FileRecord f) = takeFileName f file (DirRecord f) = takeFileName f-file (PackageRecord pid f) = packageIdentifierToString pid ++ " " ++ f+file (PackageRecord p) = packageIdentifierToString (ipdPackageId p) ++ " " ++ ipdBuildDir p file PlaceHolder = "" -- | A files pane description@@ -88,14 +90,13 @@ instance Pane IDEFiles IDEM where- primPaneName _ = (__ "Files")+ primPaneName _ = __ "Files" getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledView paneId b = "*Files" instance RecoverablePane IDEFiles FilesState IDEM where- saveState p = do- return (Just FilesState)+ saveState p = return (Just FilesState) recoverState pp FilesState = do nb <- getNotebook pp buildPane pp nb builder@@ -122,6 +123,7 @@ treeSelectionSetMode sel SelectionSingle scrolledView <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scrolledView ShadowIn containerAdd scrolledView treeView scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic @@ -132,29 +134,29 @@ return True cid2 <- on treeView rowExpanded $ \ iter path -> do record <- treeStoreGetValue fileStore path- reflectIDE (do+ reflectIDE ( case record of- DirRecord f -> liftIO $ refreshDir fileStore path f- PackageRecord _ f -> liftIO $ refreshDir fileStore path f- _ -> ideMessage Normal (__ "Unexpected Expansion in Files Pane")) ideR+ DirRecord f -> liftIO $ refreshDir fileStore path f+ PackageRecord p -> liftIO $ refreshPackage fileStore path p+ _ -> ideMessage Normal (__ "Unexpected Expansion in Files Pane")) ideR on treeView rowActivated $ \ path col -> do record <- treeStoreGetValue fileStore path- reflectIDE (do+ reflectIDE ( case record of- FileRecord f -> (goToSourceDefinition f $ Just $ Location 1 0 1 0) >> return ()- DirRecord f -> liftIO $ refreshDir fileStore path f- PackageRecord _ f -> liftIO $ refreshDir fileStore path f- _ -> ideMessage Normal (__ "Unexpected Activation in Files Pane")) ideR+ FileRecord f -> void (goToSourceDefinition f (Just $ Location 1 0 1 0))+ DirRecord f -> liftIO $ refreshDir fileStore path f+ PackageRecord p -> liftIO $ refreshPackage fileStore path p+ _ -> ideMessage Normal (__ "Unexpected Activation in Files Pane")) ideR on sel treeSelectionSelectionChanged $ do paths <- treeSelectionGetSelectedRows sel forM_ paths $ \ path -> do record <- treeStoreGetValue fileStore path- reflectIDE (do+ reflectIDE ( case record of- FileRecord _ -> return ()- DirRecord f -> liftIO $ refreshDir fileStore path f- PackageRecord _ f -> liftIO $ refreshDir fileStore path f- _ -> ideMessage Normal (__ "Unexpected Selection in Files Pane")) ideR+ FileRecord _ -> return ()+ DirRecord f -> liftIO $ refreshDir fileStore path f+ PackageRecord p -> liftIO $ refreshPackage fileStore path p+ _ -> ideMessage Normal (__ "Unexpected Selection in Files Pane")) ideR return (Just files,[ConnectC cid1]) @@ -177,23 +179,31 @@ files <- getFiles Nothing let store = fileStore files mbWS <- readIDE workspace- liftIO $ setDirectories store Nothing $ map packageRecord $ maybe [] wsPackages mbWS- where- packageRecord package = PackageRecord- (ipdPackageId package)- (dropFileName $ ipdCabalFile package)+ liftIO $ setDirectories store Nothing $ map PackageRecord $ maybe [] wsPackages mbWS +dirContents :: FilePath -> IO [FileRecord]+dirContents dir =+ (filter ((/= '.') . head) <$> getDirectoryContents dir >>=+ mapM+ (\ f ->+ do let full = dir </> f+ isDir <- doesDirectoryExist full+ return $ if isDir then DirRecord full else FileRecord full))+ `catch` \ (e :: IOError) -> return []++refreshPackage :: TreeStore FileRecord -> TreePath -> IDEPackage -> IO ()+refreshPackage store path p = do+ let dir = ipdBuildDir p+ mbIter <- treeModelGetIter store path+ when (isJust mbIter) $ do+ contents <- dirContents dir+ setDirectories store mbIter $ map PackageRecord (ipdSandboxSources p) ++ contents+ refreshDir :: TreeStore FileRecord -> TreePath -> FilePath -> IO () refreshDir store path dir = do mbIter <- treeModelGetIter store path when (isJust mbIter) $ do- contents <- do- filter ((/= '.').head) <$>- getDirectoryContents dir >>= mapM (\f -> do- let full = dir </> f- isDir <- doesDirectoryExist full- return $ if isDir then DirRecord full else FileRecord full)- `catch` \ (e :: IOError) -> return []+ contents <- dirContents dir setDirectories store mbIter contents setDirectories :: TreeStore FileRecord -> Maybe TreeIter -> [FileRecord] -> IO ()@@ -210,11 +220,11 @@ path <- treeModelGetPath store iter removeUntil record store path _ -> do- treeStoreInsert store parentPath n $ record+ treeStoreInsert store parentPath n record case record of- DirRecord _ -> treeStoreInsert store (parentPath++[n]) 0 PlaceHolder- PackageRecord _ _ -> treeStoreInsert store (parentPath++[n]) 0 PlaceHolder- _ -> return ()+ DirRecord _ -> treeStoreInsert store (parentPath++[n]) 0 PlaceHolder+ PackageRecord _ -> treeStoreInsert store (parentPath++[n]) 0 PlaceHolder+ _ -> return () removeRemaining store (parentPath++[length records]) data FindResult = WhereExpected TreeIter | Found TreeIter | NotFound
src/IDE/Pane/Grep.hs view
@@ -137,7 +137,7 @@ treeViewAppendColumn treeView col3 cellLayoutPackStart col3 renderer3 True cellLayoutSetAttributes col3 renderer3 grepStore- $ \row -> [ cellText := context row]+ $ \row -> [ cellText := take 2048 $ context row] treeViewSetHeadersVisible treeView True@@ -145,6 +145,7 @@ treeSelectionSetMode sel SelectionSingle scrolledView <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scrolledView ShadowIn containerAdd scrolledView treeView scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic @@ -227,8 +228,8 @@ ws <- ask maybeActive <- lift $ readIDE activePack let packages = case maybeActive of- Just active -> active : (filter (/= active) $ wsPackages ws)- Nothing -> wsPackages ws+ Just active -> active : (filter (/= active) $ wsAllPackages ws)+ Nothing -> wsAllPackages ws lift $ grepDirectories regexString caseSensitive $ map (\p -> (dropFileName $ ipdCabalFile p)) $ packages
src/IDE/Pane/HLint.hs view
@@ -40,7 +40,7 @@ import System.FilePath ((</>), dropFileName) import System.Exit (ExitCode(..)) import IDE.Pane.Log (getLog)-import Control.Monad (forM_, foldM, when)+import Control.Monad (void, forM_, foldM, when) import Control.Monad.Trans.Reader (ask) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.IO.Class (MonadIO(..))@@ -88,8 +88,7 @@ paneId b = "*HLint" instance RecoverablePane IDEHLint HLintState IDEM where- saveState p = do- return (Just HLintState)+ saveState p = return (Just HLintState) recoverState pp HLintState = do nb <- getNotebook pp buildPane pp nb builder@@ -116,6 +115,7 @@ treeSelectionSetMode sel SelectionSingle scrolledView <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scrolledView ShadowIn containerAdd scrolledView treeView scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic @@ -152,8 +152,7 @@ _ -> return False treeViewContextMenu treeView $ hlintContextMenu ideR hlintStore treeView- on sel treeSelectionSelectionChanged (reflectIDE (gotoSource False treeView hlintStore- >> return ()) ideR)+ on sel treeSelectionSelectionChanged (reflectIDE (void $ gotoSource False treeView hlintStore) ideR) return (Just hlint,map ConnectC [cid1]) @@ -207,8 +206,8 @@ ws <- ask maybeActive <- lift $ readIDE activePack let packages = case maybeActive of- Just active -> active : (filter (/= active) $ wsPackages ws)- Nothing -> wsPackages ws+ Just active -> active : filter (/= active) (wsAllPackages ws)+ Nothing -> wsAllPackages ws lift $ hlintDirectories2 packages @@ -216,14 +215,14 @@ gotoSource focus treeView hlintStore = do sel <- liftIO $ getSelectionHLintRecord treeView hlintStore case sel of- Just record -> do+ Just record -> case record of HLintRecord {condIdea = Just idea} ->- (goToSourceDefinition (srcSpanFilename (H.ideaSpan idea))+ goToSourceDefinition (srcSpanFilename (H.ideaSpan idea)) (Just $ Location (srcSpanStartLine (H.ideaSpan idea)) (srcSpanStartColumn (H.ideaSpan idea)) (srcSpanEndLine (H.ideaSpan idea))- (srcSpanEndColumn (H.ideaSpan idea))))+ (srcSpanEndColumn (H.ideaSpan idea))) ?>>= (\(IDEBuffer {sourceView = sv}) -> when focus $ grabFocus sv) _ -> return () Nothing -> return ()@@ -247,7 +246,7 @@ let datadirOpt = case mbHlintDir of Just d -> "--datadir":[d] Nothing -> []- (flags, classify, hint) <- liftIO $ H.autoSettings+ (flags, classify, hint) <- liftIO H.autoSettings let modules = Map.keys (ipdModules package) pathes <- getSourcePathes (ipdPackageId package) modules resL <- liftIO $ mapM (\dir -> H.parseModuleEx flags dir Nothing) pathes@@ -295,8 +294,7 @@ (Just iter, Found _) -> do path <- treeModelGetPath store iter removeUntil record store path- _ -> do- treeStoreInsert store parentPath n $ record+ _ -> treeStoreInsert store parentPath n record removeRemaining store (parentPath++[nRecords]) return nRecords where@@ -311,8 +309,7 @@ hlintContextMenu ideR store treeView theMenu = do mbSel <- getSelectionHLintRecord treeView store item0 <- menuItemNewWithLabel (__ "Replace")- item0 `on` menuItemActivate $ do- reflectIDE (replaceHlint store treeView mbSel) ideR+ item0 `on` menuItemActivate $ reflectIDE (replaceHlint store treeView mbSel) ideR menuShellAppend theMenu item0 where replaceableSelection Nothing = False@@ -326,7 +323,7 @@ startColumn = srcSpanStartColumn (H.ideaSpan idea) source = init $ unlines (head lined : map (\ s -> replicate startColumn ' ' ++ s) (tail lined))- in do+ in replaceHLintSource (srcSpanFilename (H.ideaSpan idea)) (srcSpanStartLine (H.ideaSpan idea)) startColumn
src/IDE/Pane/Info.hs view
@@ -25,7 +25,6 @@ , openDocu ) where -import Control.Monad import Data.IORef import Data.Typeable import Data.Char (isAlphaNum)@@ -44,6 +43,8 @@ scrolledWindowSetPolicy, castToWidget, ScrolledWindow) import Graphics.UI.Gtk.General.Enums (PolicyType(..)) import System.Glib.Signals (on)+import Control.Monad (void, when)+import Data.Foldable (forM_) -- | An info pane description --@@ -58,7 +59,7 @@ instance Pane IDEInfo IDEM where- primPaneName _ = (__ "Info")+ primPaneName _ = __ "Info" getAddedIndex _ = 0 getTopWidget = castToWidget . sw paneId b = "*Info"@@ -86,7 +87,7 @@ createHyperLinkSupport descriptionView sw (\_ _ iter -> do (beg, en) <- getIdentifierUnderCursorFromIter (iter, iter)- return (beg, en)) (\_ shift' slice -> do+ return (beg, en)) (\_ shift' slice -> when (slice /= []) $ do -- liftIO$ print ("slice",slice) triggerEventIDE (SelectInfo slice shift')@@ -103,7 +104,7 @@ let info = IDEInfo sw currentDescr' descriptionView -- ids5 <- sv `onLookupInfo` selectInfo descriptionView -- obsolete by hyperlinks cids2 <- descriptionView `afterFocusIn` makeActive info- return (Just info, concat [cids1, cids2])+ return (Just info, cids1 ++ cids2) getInfo :: IDEM IDEInfo getInfo = forceGetPane (Right "*Info")@@ -119,14 +120,14 @@ case mbInfo of Nothing -> do ideMessage Normal "gotoSource:noDefinition" return ()- Just info -> goToDefinition info >> return ()+ Just info -> void (goToDefinition info) gotoModule' :: IDEAction gotoModule' = do mbInfo <- getInfoCont case mbInfo of Nothing -> return ()- Just info -> triggerEventIDE (SelectIdent info) >> return ()+ Just info -> void (triggerEventIDE (SelectIdent info)) setInfo :: Descr -> IDEAction@@ -155,7 +156,7 @@ (True,v) -> Just v -getInfoCont :: IDEM (Maybe (Descr))+getInfoCont :: IDEM (Maybe Descr) getInfoCont = do mbPane <- getPane case mbPane of@@ -168,15 +169,11 @@ recordInfoHistory :: Maybe Descr -> Maybe Descr -> IDEAction recordInfoHistory descr oldDescr = do triggerEventIDE (RecordHistory- ((InfoElementSelected descr),- (InfoElementSelected oldDescr)))+ (InfoElementSelected descr, InfoElementSelected oldDescr)) return () replayInfoHistory :: Maybe Descr -> IDEAction-replayInfoHistory mbDescr = do- case mbDescr of- Nothing -> return ()- Just descr -> setInfo descr+replayInfoHistory mbDescr = forM_ mbDescr setInfo openDocu :: IDEAction openDocu = do@@ -185,7 +182,7 @@ Nothing -> return () Just descr -> do prefs' <- readIDE prefs- openBrowser $ docuSearchURL prefs' ++ (escapeURIString isAlphaNum $ dscName descr)+ openBrowser $ docuSearchURL prefs' ++ escapeURIString isAlphaNum (dscName descr) populatePopupMenu :: IDERef -> IORef (Maybe Descr) -> Menu -> IO () populatePopupMenu ideR currentDescr' menu = do
src/IDE/Pane/Log.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, DeriveDataTypeable,- MultiParamTypeClasses, TypeSynonymInstances, ParallelListComp #-}+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables,+ DeriveDataTypeable, MultiParamTypeClasses, TypeSynonymInstances #-} -- -- Module : IDE.Pane.Log -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie@@ -38,7 +38,7 @@ import IDE.Core.State import IDE.Core.Types(LogLaunch) import Control.Monad.Trans (liftIO)-import Control.Monad.Reader+import Control.Monad.Reader (ask, unless) import IDE.Pane.SourceBuffer (markRefInSourceBuf,selectSourceBuf) import System.IO import Prelude hiding (catch)@@ -81,7 +81,8 @@ import Data.Text (Text) import qualified Data.Text as T (length, unpack) import Data.Monoid ((<>))-import Data.List (isPrefixOf, isSuffixOf, findIndex)+import Data.List (elemIndex, isPrefixOf, isSuffixOf, findIndex)+import Data.Foldable (forM_) ------------------------------------------------------------------------------- --@@ -110,7 +111,7 @@ Nothing -> getDefaultLogLaunch Just key -> return $ logLaunch $ launches Map.! key -getDefaultLogLaunch :: IDEM LogLaunch+getDefaultLogLaunch :: MonadIDE m => m LogLaunch getDefaultLogLaunch = do launches <- readIDE logLaunches return $ logLaunch $ launches Map.! defaultLogName@@ -134,26 +135,24 @@ launches <- readIDE logLaunches let mbLogLaunch = Map.lookup logName launches let name = getNextFreeName logName launches- newLogLaunch <- liftIO $ createNewLogLaunch+ newLogLaunch <- liftIO createNewLogLaunch return (newLogLaunch, name) where- getNextFreeName prevName launches = case (Map.lookup prevName launches) of+ getNextFreeName prevName launches = case Map.lookup prevName launches of Nothing -> prevName Just _ -> getNextFreeName (incrementName prevName) launches- incrementName name = case (parseName name) of+ incrementName name = case parseName name of Nothing -> createNewName name 0 Just (number,name) -> createNewName name number createNewName name number = concat [name, " (", show (number+1), ")"]- parseName name = if surroundedByParenth $ getLaunchString name- then- if isNumberAndNotEmpty $ init $ tail $ getLaunchString name- then -- check if- Just $ (read $ init $ tail $ getLaunchString name,- reverse $ drop 4 $ reverse name)- else Nothing- else Nothing- surroundedByParenth string = ("(" `isPrefixOf` string ) && (")" `isSuffixOf` string) && (isNotBlank string)- isNumberAndNotEmpty string = (foldr ((&&) . isNumber) True $ string) && (isNotBlank string) -- check if+ parseName name = if surroundedByParenth (getLaunchString name) &&+ isNumberAndNotEmpty (init $ tail $ getLaunchString name)+ then Just+ (read $ init $ tail $ getLaunchString name,+ reverse $ drop 4 $ reverse name)+ else Nothing+ surroundedByParenth string = ("(" `isPrefixOf` string ) && (")" `isSuffixOf` string) && isNotBlank string+ isNumberAndNotEmpty string = all isNumber string && isNotBlank string -- check if getLaunchString name = reverse $ take 3 $ reverse name isNotBlank [] = False isNotBlank _ = True@@ -223,21 +222,21 @@ model <- liftIO $ comboBoxGetModelText comboBox list <- liftIO $ listStoreToList model- let mbIndex = findIndex (==name) list+ let mbIndex = elemIndex name list liftIO $ putStrLn $ "showLogLaunch: mbIndex = " ++ show mbIndex case mbIndex of Nothing -> return() -- TODO errorCalls Just index -> liftIO $ comboBoxSetActive comboBox index- liftIO $ putStrLn $ "switched to loglaunch"+ liftIO $ putStrLn "switched to loglaunch" data LogState = LogState deriving(Eq,Ord,Read,Show,Typeable) instance Pane IDELog IDEM where- primPaneName _ = (__ "Log")+ primPaneName _ = __ "Log" getAddedIndex _ = 0 getTopWidget = castToWidget . logMainContainer paneId b = "*Log"@@ -294,7 +293,7 @@ IDEM (Maybe IDELog,Connections) builder' pp nb windows = do prefs <- readIDE prefs- newLogLaunch <- liftIO $ createNewLogLaunch+ newLogLaunch <- liftIO createNewLogLaunch let emptyMap = Map.empty :: Map.Map String LogLaunchData let map = Map.insert defaultLogName (LogLaunchData newLogLaunch Nothing) emptyMap modifyIDE_ $ \ide -> ide { logLaunches = map}@@ -318,8 +317,7 @@ tv <- textViewNew textViewSetEditable tv False fd <- case logviewFont prefs of- Just str -> do- fontDescriptionFromString str+ Just str -> fontDescriptionFromString str Nothing -> do f <- fontDescriptionNew fontDescriptionSetFamily f "Sans"@@ -368,18 +366,12 @@ mbTitle <- comboBoxGetActiveText comboBox case mbTitle of Nothing -> return()- Just title -> if not $ title == defaultLogName then- reflectIDE (- do- launches <- readIDE logLaunches- removeActiveLogLaunchData- terminateLogLaunch title launches--- )- ideR- else- return ()+ Just title -> unless (title == defaultLogName) $+ reflectIDE+ (do launches <- readIDE logLaunches+ removeActiveLogLaunchData+ terminateLogLaunch title launches)+ ideR let buf = IDELog mainContainer tv hBox comboBox@@ -431,8 +423,7 @@ populatePopupMenu log ideR menu = do items <- containerGetChildren menu item0 <- menuItemNewWithLabel (__ "Resolve Errors")- item0 `on` menuItemActivate $ do- reflectIDE resolveErrors ideR+ item0 `on` menuItemActivate $ reflectIDE resolveErrors ideR menuShellAppend menu item0 res <- reflectIDE (do log <- getLog@@ -495,9 +486,7 @@ textBufferMoveMarkByName buf "end" iter2 mbMark <- textBufferGetMark buf "end" line <- textIterGetLine iter2- case mbMark of- Nothing -> return ()- Just mark -> textViewScrollMarkOnscreen tv mark+ forM_ mbMark (textViewScrollMarkOnscreen tv) return line markErrorInLog :: IDELog -> (Int,Int) -> IDEAction
src/IDE/Pane/Modules.hs view
@@ -32,6 +32,8 @@ import Data.Maybe import qualified Data.Map as Map import Data.Map (Map)+import qualified Data.Set as Set+import Data.Set (Set) import Data.Tree import Data.List import Distribution.Package@@ -46,8 +48,10 @@ import Distribution.Text (simpleParse,display) import Data.Typeable (Typeable(..)) import Control.Exception (SomeException(..),catch)-import IDE.Package (packageConfig,addModuleToPackageDescr,delModuleFromPackageDescr,getEmptyModuleTemplate,getPackageDescriptionAndPath)-import Distribution.PackageDescription (allBuildInfo,hsSourceDirs)+import IDE.Package (packageConfig,addModuleToPackageDescr,delModuleFromPackageDescr,getEmptyModuleTemplate,getPackageDescriptionAndPath, ModuleLocation(..))+import Distribution.PackageDescription+ (allBuildInfo, hsSourceDirs, hasLibs, executables, testSuites, exeName, testName,+ benchmarks, benchmarkName) import System.FilePath (takeBaseName, (</>),dropFileName) import System.Directory (doesFileExist,createDirectoryIfMissing, removeFile) import Graphics.UI.Editor.MakeEditor (buildEditor,FieldDescription(..),mkField)@@ -55,6 +59,7 @@ (paraMinSize, paraMultiSel, Parameter(..), emptyParams, (<<<-), paraName) import Graphics.UI.Editor.Simple (boolEditor,staticListEditor,stringEditor)+import Graphics.UI.Editor.Composite (maybeEditor) import qualified System.IO.UTF8 as UTF8 (writeFile) import IDE.Utils.GUIUtils (stockIdFromType, __) import IDE.Metainfo.Provider@@ -249,16 +254,20 @@ treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore)) pane' <- hPanedNew sw <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType sw ShadowIn containerAdd sw treeView scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic sw2 <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType sw2 ShadowIn containerAdd sw2 descrView scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic panedAdd1 pane' sw panedAdd2 pane' sw2 (Rectangle _ _ x y) <- liftIO $ widgetGetAllocation nb panedSetPosition pane' (max 200 (x `quot` 2))- box <- hBoxNew True 2+ box <- hButtonBoxNew+ boxSetSpacing box 2+ buttonBoxSetLayout box ButtonboxSpread rb1 <- radioButtonNewWithLabel (__ "Package") rb2 <- radioButtonNewWithLabelFromWidget rb1 (__ "Workspace") rb3 <- radioButtonNewWithLabelFromWidget rb1 (__ "System")@@ -266,16 +275,16 @@ cb2 <- checkButtonNewWithLabel (__ "Imports") cb <- checkButtonNewWithLabel (__ "Blacklist") - boxPackStart box rb1 PackGrow 2- boxPackStart box rb2 PackGrow 2- boxPackStart box rb3 PackGrow 2- boxPackEnd box cb PackNatural 2- boxPackEnd box cb2 PackNatural 2+ boxPackStart box rb1 PackGrow 0+ boxPackStart box rb2 PackGrow 0+ boxPackStart box rb3 PackGrow 0+ boxPackEnd box cb PackNatural 0+ boxPackEnd box cb2 PackNatural 0 - boxOuter <- vBoxNew False 2+ boxOuter <- vBoxNew False 0 boxPackStart boxOuter box PackNatural 2- boxPackStart boxOuter pane' PackGrow 2+ boxPackStart boxOuter pane' PackGrow 0 oldState <- liftIO $ newIORef $ SelectionState Nothing Nothing SystemScope False expanderState <- liftIO $ newIORef emptyExpansion scopeRef <- newIORef (SystemScope,True)@@ -1049,7 +1058,7 @@ delModule :: TreeView -> TreeStore (String, Maybe (ModuleDescr,PackageDescr)) -> PackageAction delModule treeview store = do liftIO $ debugM "leksah" "delModule"- window <- lift $ getMainWindow+ window <- liftIDE $ getMainWindow sel <- liftIO $ treeViewGetSelection treeview paths <- liftIO $ treeSelectionGetSelectedRows sel categories <- case paths of@@ -1057,14 +1066,14 @@ (treePath:_) -> liftIO $ mapM (treeStoreGetValue store) $ map (\n -> take n treePath) [1 .. length treePath] - lift $ ideMessage Normal (printf (__ "categories: %s") (show categories))+ liftIDE $ ideMessage Normal (printf (__ "categories: %s") (show categories)) let modPacDescr = snd(last categories) case modPacDescr of- Nothing -> lift $ ideMessage Normal (__ "This should never be shown!")+ Nothing -> liftIDE $ ideMessage Normal (__ "This should never be shown!") Just(md,_) -> do let modName = modu.mdModuleId $ md- lift $ ideMessage Normal ("modName: " ++ (show modName))+ liftIDE $ ideMessage Normal ("modName: " ++ (show modName)) delModuleFromPackageDescr modName respDelModDialog :: IDEM (Bool)@@ -1094,44 +1103,57 @@ addModule categories = do liftIO $ debugM "leksah" "selectIdentifier"- mbPD <- lift $ getPackageDescriptionAndPath+ mbPD <- liftIDE $ getPackageDescriptionAndPath case mbPD of- Nothing -> lift $ ideMessage Normal (__ "No package description")+ Nothing -> liftIDE $ ideMessage Normal (__ "No package description") Just (pd,cabalPath) -> let srcPaths = nub $ concatMap hsSourceDirs $ allBuildInfo pd rootPath = dropFileName cabalPath modPath = foldr (\a b -> a ++ "." ++ b) "" (map fst categories) in do- window' <- lift getMainWindow- mbResp <- liftIO $ addModuleDialog window' modPath srcPaths+ window' <- liftIDE getMainWindow+ mbResp <- liftIO $ addModuleDialog window' modPath srcPaths (hasLibs pd) $+ map exeName (executables pd) ++ map testName (testSuites pd) ++ map benchmarkName (benchmarks pd) case mbResp of Nothing -> return ()- Just (AddModule modPath srcPath isExposed) ->+ Just addMod@(AddModule modPath srcPath libExposed exesAndTests) -> case simpleParse modPath of- Nothing -> lift $ ideMessage Normal (printf (__ "Not a valid module name : %s") modPath)+ Nothing -> liftIDE $ ideMessage Normal (printf (__ "Not a valid module name : %s") modPath) Just moduleName -> do let target = srcPath </> toFilePath moduleName ++ ".hs" liftIO $ createDirectoryIfMissing True (dropFileName target) alreadyExists <- liftIO $ doesFileExist target if alreadyExists then do- lift $ ideMessage Normal (printf (__ "File already exists! Importing existing file %s.hs") (takeBaseName target))- addModuleToPackageDescr moduleName isExposed+ liftIDE $ ideMessage Normal (printf (__ "File already exists! Importing existing file %s.hs") (takeBaseName target))+ addModuleToPackageDescr moduleName $ addModuleLocations addMod packageConfig else do template <- liftIO $ getEmptyModuleTemplate pd modPath liftIO $ UTF8.writeFile target template- addModuleToPackageDescr moduleName isExposed+ addModuleToPackageDescr moduleName $ addModuleLocations addMod packageConfig- lift $ fileOpenThis target+ liftIDE $ fileOpenThis target -- Yet another stupid little dialog -data AddModule = AddModule {moduleName :: String, sourceRoot :: FilePath, isExposed :: Bool}+data AddModule = AddModule {+ moduleName :: String,+ sourceRoot :: FilePath,+ libExposed :: Maybe Bool,+ exesAndTests :: Set String} -addModuleDialog :: Window -> String -> [String] -> IO (Maybe AddModule)-addModuleDialog parent modString sourceRoots = do+addModuleLocations :: AddModule -> [ModuleLocation]+addModuleLocations addMod = lib (libExposed addMod)+ ++ map ExeOrTestMod (Set.toList $ exesAndTests addMod)+ where+ lib (Just True) = [LibExposedMod]+ lib (Just False) = [LibOtherMod]+ lib Nothing = []++addModuleDialog :: Window -> String -> [String] -> Bool -> [String] -> IO (Maybe AddModule)+addModuleDialog parent modString sourceRoots hasLib exesTests = do liftIO $ debugM "leksah" "addModuleDialog" dia <- dialogNew set dia [ windowTransientFor := parent@@ -1142,30 +1164,32 @@ upper <- dialogGetUpper dia #endif lower <- dialogGetActionArea dia- (widget,inj,ext,_) <- buildEditor (moduleFields sourceRoots)- (AddModule modString (head sourceRoots) False)+ (widget,inj,ext,_) <- buildEditor (moduleFields sourceRoots hasLib exesTests)+ (AddModule modString (head sourceRoots) (Just False) Set.empty) bb <- hButtonBoxNew+ boxSetSpacing bb 6+ buttonBoxSetLayout bb ButtonboxSpread closeB <- buttonNewFromStock "gtk-cancel" save <- buttonNewFromStock "gtk-ok" boxPackEnd bb closeB PackNatural 0 boxPackEnd bb save PackNatural 0 on save buttonActivated (dialogResponse dia ResponseOk) on closeB buttonActivated (dialogResponse dia ResponseCancel)- boxPackStart (castToBox upper) widget PackGrow 7- boxPackStart (castToBox lower) bb PackNatural 7+ boxPackStart (castToBox upper) widget PackGrow 0+ boxPackStart (castToBox lower) bb PackNatural 5 set save [widgetCanDefault := True] widgetGrabDefault save widgetShowAll dia resp <- dialogRun dia- value <- ext (AddModule modString (head sourceRoots) False)+ value <- ext (AddModule modString (head sourceRoots) (Just False) Set.empty) widgetDestroy dia --find case resp of ResponseOk -> return value _ -> return Nothing -moduleFields :: [FilePath] -> FieldDescription AddModule-moduleFields list = VFD emptyParams [+moduleFields :: [FilePath] -> Bool -> [String] -> FieldDescription AddModule+moduleFields list hasLibs exesTests = VFD emptyParams $ [ mkField (paraName <<<- ParaName ((__ "New module ")) $ emptyParams)@@ -1179,13 +1203,23 @@ $ emptyParams) (\a -> sourceRoot a) (\ a b -> b{sourceRoot = a})- (staticListEditor list id),- mkField- (paraName <<<- ParaName ((__ "Is this an exposed library module"))- $ emptyParams)- isExposed- (\ a b -> b{isExposed = a})- boolEditor]+ (staticListEditor list id)]+ ++ (if hasLibs+ then [+ mkField+ (paraName <<<- ParaName ((__ "Is this an exposed library module"))+ $ emptyParams)+ libExposed+ (\ a b -> b{libExposed = a})+ (maybeEditor (boolEditor, emptyParams) True (__ "Expose module"))]+ else [])+ ++ map (\ name ->+ mkField+ (paraName <<<- ParaName ((__ "Include in ") ++ name)+ $ emptyParams)+ (Set.member name . exesAndTests)+ (\ a b -> b{exesAndTests = (if a then Set.insert else Set.delete) name (exesAndTests b)})+ boolEditor) exesTests -- * Expander State
src/IDE/Pane/PackageEditor.hs view
@@ -89,9 +89,6 @@ import IDE.Utils.GUIUtils import IDE.Pane.SourceBuffer (fileOpenThis) import Control.Event (EventSource(..))-#if !MIN_VERSION_Cabal(1,8,0)-import Distribution.License-#endif import qualified Graphics.UI.Gtk.Gdk.Events as GTK (Event(..)) import Data.List (isPrefixOf, sort, nub)@@ -99,13 +96,8 @@ import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.Class (lift) import Control.Monad (when)-#if MIN_VERSION_Cabal(1,10,0)-import Distribution.PackageDescription.PrettyPrintCopied+import Distribution.PackageDescription.PrettyPrint (writeGenericPackageDescription)-#else-import Distribution.PackageDescription.Parse- (writePackageDescription)-#endif import Distribution.Version (Version(..), orLaterVersion) import Text.Printf (printf)@@ -125,7 +117,6 @@ -------------------------------------------------------------------------- -- Handling of Generic Package Descriptions -#if MIN_VERSION_Cabal(1,10,0) toGenericPackageDescription :: PackageDescription -> GenericPackageDescription toGenericPackageDescription pd = GenericPackageDescription {@@ -133,13 +124,15 @@ library = Nothing, executables = [], testSuites = [],+ benchmarks = [], buildDepends = []}, genPackageFlags = [], condLibrary = case library pd of Nothing -> Nothing Just lib -> Just (buildCondTreeLibrary lib), condExecutables = map buildCondTreeExe (executables pd),- condTestSuites = map buildCondTreeTest (testSuites pd)}+ condTestSuites = map buildCondTreeTest (testSuites pd),+ condBenchmarks = map buildCondTreeBenchmark (benchmarks pd)} where buildCondTreeLibrary lib = CondNode {@@ -156,7 +149,11 @@ condTreeData = test, condTreeConstraints = buildDepends pd, condTreeComponents = []})-#endif+ buildCondTreeBenchmark bm =+ (benchmarkName bm, CondNode {+ condTreeData = bm,+ condTreeConstraints = buildDepends pd,+ condTreeComponents = []}) -- --------------------------------------------------------------------- -- The exported stuff goes here@@ -176,31 +173,26 @@ package <- liftIO $ readPackageDescription normal (ipdCabalFile idePackage) if hasConfigs package then do- lift $ ideMessage High+ liftIDE $ ideMessage High (__ "Cabal file with configurations can't be edited with the current version of the editor")- lift $ fileOpenThis $ ipdCabalFile idePackage+ liftIDE $ fileOpenThis $ ipdCabalFile idePackage return () else do let flat = flattenPackageDescription package-#if MIN_VERSION_Cabal(1,10,0)- if hasUnknownTestTypes flat+ if hasUnknownTestTypes flat || hasUnknownBenchmarkTypes flat then do- lift $ ideMessage High- (__ "Cabal file with tests of this type can't be edited with the current version of the editor")- lift $ fileOpenThis $ ipdCabalFile idePackage+ liftIDE $ ideMessage High+ (__ "Cabal file with tests or benchmarks of this type can't be edited with the current version of the editor")+ liftIDE $ fileOpenThis $ ipdCabalFile idePackage return () else do- lift $ editPackage flat dirName modules (\ _ -> return ())+ liftIDE $ editPackage flat dirName modules (\ _ -> return ()) return ()-#else- lift $ editPackage flat dirName modules (\ _ -> return ())- return ()-#endif packageEditText :: PackageAction packageEditText = do idePackage <- ask- lift $ fileOpenThis $ ipdCabalFile idePackage+ liftIDE $ fileOpenThis $ ipdCabalFile idePackage return () hasConfigs :: GenericPackageDescription -> Bool@@ -213,26 +205,27 @@ then True else not (null (condTreeComponents condTree))) False (condExecutables gpd)-#if MIN_VERSION_Cabal(1,10,0) testConds = foldr (\ (_,condTree) hasConfigs -> if hasConfigs then True else not (null (condTreeComponents condTree))) False (condTestSuites gpd) in libConds || exeConds || testConds-#else- in libConds || exeConds-#endif -#if MIN_VERSION_Cabal(1,10,0) hasUnknownTestTypes :: PackageDescription -> Bool hasUnknownTestTypes pd = not . null . filter unknown $ testSuites pd where unknown (TestSuite _ (TestSuiteExeV10 _ _) _ _) = False unknown _ = True-#endif +hasUnknownBenchmarkTypes :: PackageDescription -> Bool+hasUnknownBenchmarkTypes pd =+ not . null . filter unknown $ benchmarks pd+ where+ unknown (Benchmark _ (BenchmarkExeV10 _ _) _ _) = False+ unknown _ = True+ data NewPackage = NewPackage { newPackageName :: String, newPackageParentDir :: FilePath,@@ -260,7 +253,10 @@ (\ a b -> b{templatePackage = a}) (comboEntryEditor examplePackages)] -examplePackages = ["hello", "gtk2hs-hello"]+examplePackages = [ "hello"+ , "gtk2hs-hello"+ , "ghcjs-dom-hello"+ , "jsaddle-hello"] newPackageDialog :: Window -> FilePath -> IO (Maybe NewPackage) newPackageDialog parent workspaceDir = do@@ -332,30 +328,27 @@ when make $ do modules <- liftIO $ allModules dirName let Just initialVersion = simpleParse "0.0.1"- editPackage emptyPackageDescription{+ editPackage emptyPackageDescription { package = PackageIdentifier (PackageName newPackageName)- initialVersion,- buildType = Just Simple,-#if MIN_VERSION_Cabal(1,10,0)- specVersionRaw = Right (orLaterVersion (Version [1,2] [])),-#endif- buildDepends = [+ initialVersion+ , buildType = Just Simple+ , specVersionRaw = Right (orLaterVersion (Version [1,2] []))+ , buildDepends = [ Dependency (PackageName "base") anyVersion- , Dependency (PackageName "QuickCheck") anyVersion],- executables = [emptyExecutable {+ , Dependency (PackageName "QuickCheck") anyVersion]+ , executables = [emptyExecutable { exeName = newPackageName , modulePath = "Main.hs" , buildInfo = emptyBuildInfo { hsSourceDirs = ["src"]}}]-#if MIN_VERSION_Cabal(1,10,0)- , testSuites = [emptyTestSuite {+ , testSuites = [emptyTestSuite { testName = "test-" ++ newPackageName , testInterface = (TestSuiteExeV10 (Version [1,0] []) "Main.hs") , testBuildInfo = emptyBuildInfo { hsSourceDirs = ["src"] , cppOptions = ["-DMAIN_FUNCTION=testMain"]}}]-#endif- } dirName modules (activateAction True)+ , benchmarks = []+ } dirName modules (activateAction True) return () Just NewPackage{..} -> cabalUnpack newPackageParentDir templatePackage False (Just newPackageName) log (activateAction False) @@ -492,9 +485,8 @@ data PackageDescriptionEd = PDE { pd :: PackageDescription, exes :: [Executable'],-#if MIN_VERSION_Cabal(1,10,0) tests :: [Test'],-#endif+ bms :: [Benchmark'], mbLib :: Maybe Library', bis :: [BuildInfo]} deriving Eq@@ -502,26 +494,24 @@ comparePDE a b = do when (pd a /= pd b) $ putStrLn "pd" when (exes a /= exes b) $ putStrLn "exes"-#if MIN_VERSION_Cabal(1,10,0) when (tests a /= tests b) $ putStrLn "tests"-#endif when (mbLib a /= mbLib b) $ putStrLn "mbLib" when (bis a /= bis b) $ putStrLn "bis" fromEditor :: PackageDescriptionEd -> PackageDescription fromEditor (PDE pd exes'-#if MIN_VERSION_Cabal(1,10,0) tests'-#endif+ benchmarks' mbLib' buildInfos) = let exes = map (\ (Executable' s fb bii) -> if bii + 1 > length buildInfos then Executable s fb (buildInfos !! (length buildInfos - 1)) else Executable s fb (buildInfos !! bii)) exes'-#if MIN_VERSION_Cabal(1,10,0) tests = map (\ (Test' s fb bii) -> if bii + 1 > length buildInfos then TestSuite s fb (buildInfos !! (length buildInfos - 1)) False else TestSuite s fb (buildInfos !! bii) False) tests'-#endif+ bms = map (\ (Benchmark' s fb bii) -> if bii + 1 > length buildInfos+ then Benchmark s fb (buildInfos !! (length buildInfos - 1)) False+ else Benchmark s fb (buildInfos !! bii) False) benchmarks' mbLib = case mbLib' of Nothing -> Nothing Just (Library' mn b bii) -> if bii + 1 > length buildInfos@@ -530,22 +520,19 @@ in pd { library = mbLib , executables = exes-#if MIN_VERSION_Cabal(1,10,0) , testSuites = tests-#endif+ , benchmarks = bms } toEditor :: PackageDescription -> PackageDescriptionEd toEditor pd = let (exes,exeBis) = unzip $ map (\((Executable s fb bi), i) -> ((Executable' s fb i), bi)) (zip (executables pd) [0..])-#if MIN_VERSION_Cabal(1,10,0) (tests,testBis) = unzip $ map (\((TestSuite s fb bi _), i) -> ((Test' s fb i), bi)) (zip (testSuites pd) [length exeBis..])- bis = exeBis++testBis-#else- bis = exeBis-#endif+ (bms,benchmarkBis) = unzip $ map (\((Benchmark s fb bi _), i) -> ((Benchmark' s fb i), bi))+ (zip (benchmarks pd) [length testBis..])+ bis = exeBis ++ testBis ++ benchmarkBis (mbLib,bis2) = case library pd of Nothing -> (Nothing,bis) Just (Library mn b bi) -> (Just (Library' (sort mn) b (length bis)), bis ++ [bi])@@ -554,9 +541,8 @@ else bis2 in PDE (pd {library = Nothing , executables = []}) exes-#if MIN_VERSION_Cabal(1,10,0) tests-#endif+ bms mbLib bis3 @@ -724,11 +710,7 @@ Just newPackage' -> let newPackage = fromEditor newPackage' in do let packagePath = packageDir </> (display . pkgName . package . pd) newPackage' ++ ".cabal"-#if MIN_VERSION_Cabal(1,10,0) writeGenericPackageDescription packagePath (toGenericPackageDescription newPackage)-#else- writePackageDescription packagePath newPackage-#endif reflectIDE (do afterSaveAction packagePath closePane packagePane@@ -804,15 +786,12 @@ (stability . pd) (\ a b -> b{pd = (pd b){stability = a}}) (stringEditor (const True) True)-#if MIN_VERSION_Cabal(1,8,0)- -- TODO-#else- , mkField- (paraName <<<- ParaName (__ "License") $ emptyParams)- (license . pd)- (\ a b -> b{pd = (pd b){license = a}})- (comboSelectionEditor [GPL, LGPL, BSD3, BSD4, PublicDomain, AllRightsReserved, OtherLicense] show)-#endif+ -- TODO Fix this up to work with current Cabal+-- , mkField+-- (paraName <<<- ParaName (__ "License") $ emptyParams)+-- (license . pd)+-- (\ a b -> b{pd = (pd b){license = a}})+-- (comboSelectionEditor [GPL, LGPL, BSD3, BSD4, PublicDomain, AllRightsReserved, OtherLicense] show) , mkField (paraName <<<- ParaName (__ "License File") $ emptyParams) (licenseFile . pd)@@ -863,11 +842,7 @@ (__ "Does this package depends on a specific version of Cabal?") $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) (descCabalVersion . pd)-#if MIN_VERSION_Cabal(1,10,0) (\ a b -> b{pd = (pd b){specVersionRaw = Right a}})-#else- (\ a b -> b{pd = (pd b){descCabalVersion = a}})-#endif versionRangeEditor , mkField (paraName <<<- ParaName (__ "Tested with compiler")@@ -957,7 +932,6 @@ (\ a b -> b{exes = a}) (executablesEditor (Just fp) modules numBuildInfos) ]),-#if MIN_VERSION_Cabal(1,10,0) ((__ "Tests"),VFD emptyParams [ mkField (paraName <<<- ParaName (__ "Tests")@@ -968,7 +942,16 @@ (\ a b -> b{tests = a}) (testsEditor (Just fp) modules numBuildInfos) ]),-#endif+ ((__ "Benchmarks"),VFD emptyParams [+ mkField+ (paraName <<<- ParaName (__ "Benchmarks")+ $ paraSynopsis <<<- ParaSynopsis+ (__ "Describe tests contained in the package")+ $ paraDirection <<<- ParaDirection Vertical $ emptyParams)+ bms+ (\ a b -> b{bms = a})+ (benchmarksEditor (Just fp) modules numBuildInfos)+ ]), ((__ "Library"), VFD emptyParams [ mkField (paraName <<<- ParaName (__ "Library")@@ -1066,13 +1049,8 @@ $ paraMinSize <<<- ParaMinSize (-1,400) $ paraPack <<<- ParaPack PackGrow $ emptyParams)-#if MIN_VERSION_Cabal(1,10,0) (oldExtensions . (\a -> a !! i) . bis) (\ a b -> b{bis = update (bis b) i (\bi -> bi{oldExtensions = a})})-#else- (extensions . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{extensions = a})})-#endif extensionsEditor ]), ((printf (__ "%s Build Tools ") (show (i + 1))), VFD emptyParams [@@ -1409,25 +1387,30 @@ , buildInfoIdx :: Int} deriving (Show, Eq) -#if MIN_VERSION_Cabal(1,10,0) data Test' = Test'{ testName' :: String , testInterface' :: TestSuiteInterface , testBuildInfoIdx :: Int} deriving (Show, Eq)-#endif +data Benchmark' = Benchmark'{+ benchmarkName' :: String+, benchmarkInterface' :: BenchmarkInterface+, benchmarkBuildInfoIdx :: Int}+ deriving (Show, Eq)+ instance Default Library' where getDefault = Library' [] getDefault getDefault instance Default Executable' where getDefault = Executable' getDefault getDefault getDefault -#if MIN_VERSION_Cabal(1,10,0) instance Default Test' where getDefault = Test' getDefault (TestSuiteExeV10 (Version [1,0] []) getDefault) getDefault-#endif +instance Default Benchmark'+ where getDefault = Benchmark' getDefault (BenchmarkExeV10 (Version [1,0] []) getDefault) getDefault+ libraryEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Library' libraryEditor fp modules numBuildInfos para noti = do (wid,inj,ext) <-@@ -1500,13 +1483,11 @@ Just (s,f,bi) -> return (Just $Executable' s f bi) return (wid,pinj,pext) -#if MIN_VERSION_Cabal(1,10,0) testsEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor [Test'] testsEditor fp modules countBuildInfo p = multisetEditor (ColumnDescr True [( (__ "Test Name"),\(Test' testName _ _) -> [cellText := testName]) ,( (__ "Interface"),\(Test' _ i _) -> [cellText := interfaceName i])- ,( (__ "Build info index"),\(Test' _ _ bii) -> [cellText := show (bii + 1)])]) (testEditor fp modules countBuildInfo,emptyParams) Nothing@@ -1543,7 +1524,48 @@ Nothing -> return Nothing Just (s,f,bi) -> return (Just $Test' s (TestSuiteExeV10 (Version [1,0] []) f) bi) return (wid,pinj,pext)-#endif++benchmarksEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor [Benchmark']+benchmarksEditor fp modules countBuildInfo p =+ multisetEditor+ (ColumnDescr True [( (__ "Benchmark Name"),\(Benchmark' benchmarkName _ _) -> [cellText := benchmarkName])+ ,( (__ "Interface"),\(Benchmark' _ i _) -> [cellText := interfaceName i])+ ,( (__ "Build info index"),\(Benchmark' _ _ bii) -> [cellText := show (bii + 1)])])+ (benchmarkEditor fp modules countBuildInfo,emptyParams)+ Nothing+ Nothing+ (paraShadow <<<- ParaShadow ShadowIn+ $ paraMinSize <<<- ParaMinSize (-1,200) $ p)+ where+ interfaceName (BenchmarkExeV10 _ f) = f+ interfaceName i = show i++benchmarkEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Benchmark'+benchmarkEditor fp modules countBuildInfo para noti = do+ (wid,inj,ext) <- tupel3Editor+ (stringEditor (\s -> not (null s)) True,+ paraName <<<- ParaName (__ "Benchmark Name")+ $ emptyParams)+ (stringEditor (\s -> not (null s)) True,+ paraDirection <<<- ParaDirection Vertical+ $ paraName <<<- ParaName (__ "File with main function")+ $ emptyParams)+ (buildInfoEditorP countBuildInfo, paraName <<<- ParaName (__ "Build Info")+ $ paraOuterAlignment <<<- ParaOuterAlignment (0.0, 0.0, 0.0, 0.0)+ $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0)+ $ paraInnerAlignment <<<- ParaInnerAlignment (0.0, 0.0, 0.0, 0.0)+ $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0)+ $ emptyParams)+ (paraDirection <<<- ParaDirection Vertical $ para)+ noti+ let pinj (Benchmark' s (BenchmarkExeV10 (Version [1,0] []) f) bi) = inj (s,f,bi)+ pinj _ = error "Unexpected Benchmark Interface"+ let pext = do+ mbp <- ext+ case mbp of+ Nothing -> return Nothing+ Just (s,f,bi) -> return (Just $Benchmark' s (BenchmarkExeV10 (Version [1,0] []) f) bi)+ return (wid,pinj,pext) buildInfoEditorP :: Int -> Editor Int buildInfoEditorP numberOfBuildInfos para noti = do
src/IDE/Pane/PackageFlags.hs view
@@ -43,6 +43,7 @@ import Text.ParserCombinators.Parsec hiding(Parser) import Debug.Trace (trace) import IDE.Utils.GUIUtils (__)+import Control.Monad (void) data IDEFlags = IDEFlags { flagsBox :: VBox@@ -53,7 +54,7 @@ instance Pane IDEFlags IDEM where- primPaneName _ = (__ "Package Flags")+ primPaneName _ = __ "Package Flags" getAddedIndex _ = 0 getTopWidget = castToWidget . flagsBox paneId b = "*Flags"@@ -87,14 +88,17 @@ vb <- vBoxNew False 0 let flagsPane = IDEFlags vb bb <- hButtonBoxNew+ boxSetSpacing bb 6+ buttonBoxSetLayout bb ButtonboxSpread saveB <- buttonNewFromStock "gtk-save" widgetSetSensitive saveB False cancelB <- buttonNewFromStock "gtk-cancel"- boxPackStart bb cancelB PackGrow 0- boxPackStart bb saveB PackGrow 0+ boxPackStart bb cancelB PackNatural 0+ boxPackStart bb saveB PackNatural 0 (widget,injb,ext,notifier) <- buildEditor flagsDesc idePackage sw <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType sw ShadowIn scrolledWindowAddWithViewport sw widget scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic on saveB buttonActivated (do@@ -105,9 +109,10 @@ reflectIDE (do changePackage packWithNewFlags closePane flagsPane) ideR- writeFields ((dropExtension (ipdCabalFile packWithNewFlags)) ++ leksahFlagFileExtension)+ writeFields (dropExtension (ipdCabalFile packWithNewFlags) +++ leksahFlagFileExtension) packWithNewFlags flatFlagsDescription)- on cancelB buttonActivated (reflectIDE (closePane flagsPane >> return ()) ideR)+ on cancelB buttonActivated (reflectIDE (void (closePane flagsPane)) ideR) registerEvent notifier FocusIn (\e -> do reflectIDE (makeActive flagsPane) ideR return (e{gtkReturn=False}))@@ -120,8 +125,8 @@ widgetSetSensitive saveB hasChanged return (e{gtkReturn=False})) - boxPackStart vb sw PackGrow 7- boxPackEnd vb bb PackNatural 7+ boxPackStart vb sw PackGrow 0+ boxPackEnd vb bb PackNatural 6 return (Just flagsPane,[]) getFlags :: Maybe PanePath -> IDEM IDEFlags@@ -129,7 +134,7 @@ getFlags (Just pp) = forceGetPane (Left pp) quoteArg :: String -> String-quoteArg s | ' ' `elem` s = "\"" ++ (escapeQuotes s) ++ "\""+quoteArg s | ' ' `elem` s = "\"" ++ escapeQuotes s ++ "\"" quoteArg s = s escapeQuotes = foldr (\c s -> if c == '"' then '\\':c:s else c:s) ""@@ -138,7 +143,7 @@ quotedArgCharParser = try (do char '\\' anyChar)- <|> try (do+ <|> try ( noneOf "\"") <?> "argsParser" @@ -148,19 +153,19 @@ s <- many quotedArgCharParser char '"' return s)- <|> try (do+ <|> try ( many1 (noneOf " ")) <?> "argParser" argsParser :: CharParser () [String]-argsParser = try (do+argsParser = try ( many (do many (char ' ') argParser)) <?> "argsParser" unargs :: [String] -> String-unargs = unwords . (map quoteArg)+unargs = unwords . map quoteArg args :: String -> [String] args s = case parse argsParser "" s of@@ -176,7 +181,7 @@ (paraName <<<- ParaName (__ "Config flags") $ emptyParams) (PP.text . show) readParser- (\p -> unargs (ipdConfigFlags p))+ (unargs . ipdConfigFlags) (\ b a -> a{ipdConfigFlags = args b}) (stringEditor (const True) True) (\ _ -> return ())@@ -184,7 +189,7 @@ (paraName <<<- ParaName (__ "Build flags") $ emptyParams) (PP.text . show) readParser- (\p -> unargs (ipdBuildFlags p))+ (unargs . ipdBuildFlags) (\ b a -> a{ipdBuildFlags = args b}) (stringEditor (const True) True) (\ _ -> return ())@@ -192,7 +197,7 @@ (paraName <<<- ParaName (__ "Test flags") $ emptyParams) (PP.text . show) readParser- (\p -> unargs (ipdTestFlags p))+ (unargs . ipdTestFlags) (\ b a -> a{ipdTestFlags = args b}) (stringEditor (const True) True) (\ _ -> return ())@@ -200,7 +205,7 @@ (paraName <<<- ParaName (__ "Haddock flags") $ emptyParams) (PP.text . show) readParser- (\p -> unargs (ipdHaddockFlags p))+ (unargs . ipdHaddockFlags) (\ b a -> a{ipdHaddockFlags = args b}) (stringEditor (const True) True) (\ _ -> return ())@@ -208,7 +213,7 @@ (paraName <<<- ParaName (__ "Executable flags") $ emptyParams) (PP.text . show) readParser- (\p -> unargs (ipdExeFlags p))+ (unargs . ipdExeFlags) (\ b a -> a{ipdExeFlags = args b}) (stringEditor (const True) True) (\ _ -> return ())@@ -216,7 +221,7 @@ (paraName <<<- ParaName (__ "Install flags") $ emptyParams) (PP.text . show) readParser- (\p -> unargs (ipdInstallFlags p))+ (unargs . ipdInstallFlags) (\ b a -> a{ipdInstallFlags = args b}) (stringEditor (const True) True) (\ _ -> return ())@@ -224,7 +229,7 @@ (paraName <<<- ParaName (__ "Register flags") $ emptyParams) (PP.text . show) readParser- (\p -> unargs (ipdRegisterFlags p))+ (unargs . ipdRegisterFlags) (\ b a -> a{ipdRegisterFlags = args b}) (stringEditor (const True) True) (\ _ -> return ())@@ -232,7 +237,7 @@ (paraName <<<- ParaName (__ "Unregister flags") $ emptyParams) (PP.text . show) readParser- (\p -> unargs (ipdUnregisterFlags p))+ (unargs . ipdUnregisterFlags) (\ b a -> a{ipdUnregisterFlags = args b}) (stringEditor (const True) True) (\ _ -> return ())@@ -240,7 +245,7 @@ (paraName <<<- ParaName (__ "Source Distribution flags") $ emptyParams) (PP.text . show) readParser- (\p -> unargs (ipdSdistFlags p))+ (unargs . ipdSdistFlags) (\ b a -> a{ipdSdistFlags = args b}) (stringEditor (const True) True) (\ _ -> return ())]@@ -250,7 +255,7 @@ -- ------------------------------------------------------------ readFlags :: FilePath -> IDEPackage -> IO IDEPackage-readFlags fn pack = readFields fn flatFlagsDescription pack+readFlags fn = readFields fn flatFlagsDescription -- ------------------------------------------------------------ -- * Printing
src/IDE/Pane/Preferences.hs view
@@ -27,9 +27,10 @@ ) where import Graphics.UI.Gtk- (widgetDestroy, dialogRun, windowWindowPosition, dialogAddButton,- messageDialogNew, labelSetMarkup, labelNew, widgetSetSensitive,- cellText, widgetModifyFont, on, buttonActivated, boxPackEnd, boxPackStart,+ (buttonBoxSetLayout, boxSetSpacing, widgetDestroy, dialogRun,+ windowWindowPosition, dialogAddButton, messageDialogNew,+ labelSetMarkup, labelNew, widgetSetSensitive, cellText,+ widgetModifyFont, on, buttonActivated, boxPackEnd, boxPackStart, buttonNewFromStock, hButtonBoxNew, vBoxNew, castToWidget, VBox, ShadowType(..), Packing(..), fontDescriptionFromString, AttrOp(..), FileChooserAction(..), Color(..), ResponseId(..))@@ -66,13 +67,14 @@ import Control.Exception(SomeException,catch) import Prelude hiding(catch) import Data.List (isSuffixOf, sortBy)-import Data.Maybe (isJust)+import Data.Maybe (fromMaybe, isJust) import Graphics.UI.Gtk.Windows.MessageDialog (ButtonsType(..), MessageType(..)) import System.Glib.Attributes (set)-import Graphics.UI.Gtk.General.Enums (WindowPosition(..))+import Graphics.UI.Gtk.General.Enums+ (ButtonBoxStyle(..), WindowPosition(..)) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad (forM_, when)+import Control.Monad (void, forM_, when) import System.FilePath ((</>)) -- ---------------------------------------------------------------------@@ -94,7 +96,7 @@ instance Pane IDEPrefs IDEM where- primPaneName _ = (__ "Prefs")+ primPaneName _ = __ "Prefs" getAddedIndex _ = 0 getTopWidget = castToWidget . prefsBox paneId b = "*Prefs"@@ -106,11 +108,13 @@ prefs <- readIDE prefs configDir <- liftIO getConfigDir lastAppliedPrefsRef <- liftIO $ newIORef prefs- packageInfos <- liftIO $ getInstalledPackageIds+ packageInfos <- liftIO getInstalledPackageIds let flatPrefsDesc = flattenFieldDescriptionPP (prefsDescription configDir packageInfos) reifyIDE $ \ ideR -> do vb <- vBoxNew False 0 bb <- hButtonBoxNew+ boxSetSpacing bb 6+ buttonBoxSetLayout bb ButtonboxSpread apply <- buttonNewFromStock "gtk-apply" restore <- buttonNewFromStock "Restore" closeB <- buttonNewFromStock "gtk-cancel"@@ -122,10 +126,10 @@ boxPackEnd bb save PackNatural 0 (widget,injb,ext,notifier) <- buildEditor (extractFieldDescription $ prefsDescription configDir packageInfos) prefs- boxPackStart vb widget PackGrow 7+ boxPackStart vb widget PackGrow 0 label <- labelNew Nothing boxPackStart vb label PackNatural 0- boxPackEnd vb bb PackNatural 7+ boxPackEnd vb bb PackNatural 5 let prefsPane = IDEPrefs vb on apply buttonActivated $ do mbNewPrefs <- extract prefs [ext]@@ -154,14 +158,14 @@ writePrefs fp newPrefs fp2 <- getConfigFilePathForSave strippedPreferencesFilename SP.writeStrippedPrefs fp2- (SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs,+ SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs, SP.unpackDirectory = unpackDirectory newPrefs, SP.retrieveURL = retrieveURL newPrefs, SP.retrieveStrategy = retrieveStrategy newPrefs, SP.serverPort = serverPort newPrefs,- SP.endWithLastConn = endWithLastConn newPrefs})+ SP.endWithLastConn = endWithLastConn newPrefs} reflectIDE (modifyIDE_ (\ide -> ide{prefs = newPrefs})) ideR- reflectIDE (closePane prefsPane >> return ()) ideR+ reflectIDE (void (closePane prefsPane)) ideR on closeB buttonActivated $ do mbP <- extract prefs [ext] let hasChanged = case mbP of@@ -169,7 +173,7 @@ Just p -> p{prefsFormat = 0, prefsSaveTime = ""} /= prefs{prefsFormat = 0, prefsSaveTime = ""} if not hasChanged- then reflectIDE (closePane prefsPane >> return ()) ideR+ then reflectIDE (void (closePane prefsPane)) ideR else do md <- messageDialogNew (Just windows) [] MessageQuestion@@ -179,8 +183,7 @@ resp <- dialogRun md widgetDestroy md case resp of- ResponseYes -> do- reflectIDE (closePane prefsPane >> return ()) ideR+ ResponseYes -> reflectIDE (void (closePane prefsPane)) ideR _ -> return () registerEvent notifier FocusIn (\e -> do reflectIDE (makeActive prefsPane) ideR@@ -211,7 +214,7 @@ prefsDescription :: FilePath -> [PackageIdentifier] -> FieldDescriptionPP Prefs IDEM prefsDescription configDir packages = NFDPP [- ((__ "Editor"), VFDPP emptyParams [+ (__ "Editor", VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName (__ "Version number of preferences file format") $ paraSynopsis <<<- ParaSynopsis (__ "Integer")@@ -247,7 +250,7 @@ (paraName <<<- ParaName (__ "TextView Font") $ emptyParams) (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s)) (do str <- stringParser- return (if null str then Nothing else Just (str)))+ return (if null str then Nothing else Just str)) textviewFont (\ b a -> a{textviewFont = b}) fontEditor@@ -315,7 +318,7 @@ (PP.text . show) readParser sourceCandy (\b a -> a{sourceCandy = b})- (disableEditor (stringEditor (\s -> not (null s)) True,+ (disableEditor (stringEditor (not . null) True, paraName <<<- ParaName (__ "Candy specification") $ emptyParams) True (__ "Use it ?"))@@ -330,7 +333,7 @@ (paraName <<<- ParaName (__ "Editor Style") $ emptyParams) (\a -> PP.text (case a of (False,_) -> show ""; (True, s) -> show s)) (do str <- stringParser- return (if null str then (False,(__ "classic")) else (True,str)))+ return (if null str then (False, __ "classic") else (True,str))) sourceStyle (\b a -> a{sourceStyle = b}) styleEditor@@ -420,18 +423,18 @@ (comboSelectionEditor ["GtkSourceView", "Yi", "CodeMirror"] id) (\i -> return ()) ]),- ((__ "GUI Options"), VFDPP emptyParams [+ (__ "GUI Options", VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName (__ "LogView Font") $ emptyParams) (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s)) (do str <- stringParser- return (if null str then Nothing else Just (str)))+ return (if null str then Nothing else Just str)) logviewFont (\ b a -> a{logviewFont = b}) fontEditor (\mbs -> do log <- getLog- fdesc <- liftIO $fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "")+ fdesc <- liftIO $fontDescriptionFromString (fromMaybe "" mbs) liftIO $widgetModifyFont (castToWidget $ logLaunchTextView log) (Just fdesc)) , mkFieldPP (paraName <<<- ParaName (__ "Window default size")@@ -441,9 +444,9 @@ (PP.text.show) (pairParser intParser) defaultSize (\(c,d) a -> a{defaultSize = (c,d)})- (pairEditor ((intEditor (0.0, 3000.0, 25.0)),+ (pairEditor (intEditor (0.0, 3000.0, 25.0), paraName <<<- ParaName "X" $ emptyParams)- ((intEditor (0.0, 3000.0, 25.0)),+ (intEditor (0.0, 3000.0, 25.0), paraName <<<- ParaName "Y" $ emptyParams)) (\a -> return ()) , mkFieldPP@@ -471,10 +474,10 @@ identifier keymapName (\b a -> a{keymapName = b})- (stringEditor (\s -> not (null s)) True)+ (stringEditor (not . null) True) (\ a -> return ()) ]),- ((__ "Initial Pane positions"), VFDPP emptyParams [+ (__ "Initial Pane positions", VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName (__ "Categories for panes")@@ -487,11 +490,11 @@ categoryForPane (\b a -> a{categoryForPane = b}) (multisetEditor- (ColumnDescr True [((__ "Pane Id"),\(n,_) -> [cellText := n])- ,((__ "Pane Category"),\(_,v) -> [cellText := v])])- ((pairEditor- (stringEditor (\s -> not (null s)) True,emptyParams)- (stringEditor (\s -> not (null s)) True,emptyParams)),emptyParams)+ (ColumnDescr True [(__ "Pane Id", \ (n, _) -> [cellText := n])+ ,(__ "Pane Category", \ (_, v) -> [cellText := v])])+ (pairEditor+ (stringEditor (not . null) True, emptyParams)+ (stringEditor (not . null) True, emptyParams), emptyParams) (Just (sortBy (\(a,_) (a2,_) -> compare a a2))) (Just (\(a,_) (a2,_) -> a == a2))) (\i -> return ())@@ -507,11 +510,11 @@ pathForCategory (\b a -> a{pathForCategory = b}) (multisetEditor- (ColumnDescr True [((__ "Pane category"),\(n,_) -> [cellText := n])- ,((__ "Pane path"),\(_,v) -> [cellText := show v])])- ((pairEditor- (stringEditor (\s -> not (null s)) True,emptyParams)- (genericEditor,emptyParams)),emptyParams)+ (ColumnDescr True [(__ "Pane category", \ (n, _) -> [cellText := n])+ ,(__ "Pane path", \ (_, v) -> [cellText := show v])])+ (pairEditor (stringEditor (not . null) True, emptyParams)+ (genericEditor, emptyParams),+ emptyParams) (Just (sortBy (\(a,_) (a2,_) -> compare a a2))) (Just (\(a,_) (a2,_) -> a == a2))) (\i -> return ())@@ -524,7 +527,7 @@ genericEditor (\i -> return ()) ]),- ((__ "Metadata"), VFDPP emptyParams [+ (__ "Metadata", VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName (__ "Paths under which haskell sources for packages may be found")@@ -542,7 +545,7 @@ readParser unpackDirectory (\b a -> a{unpackDirectory = b})- (maybeEditor (stringEditor (\ _ -> True) True,emptyParams) True "")+ (maybeEditor (stringEditor (const True) True,emptyParams) True "") (\i -> return ()) , mkFieldPP (paraName <<<- ParaName (__ "URL from which to download prebuilt metadata") $ emptyParams)@@ -558,7 +561,9 @@ readParser retrieveStrategy (\b a -> a{retrieveStrategy = b})- (enumEditor [(__ "Try to download and then build locally if that fails"),(__ "Try to build locally and then download if that fails"),(__ "Never download (just try to build locally)")])+ (enumEditor [__ "Try to download and then build locally if that fails",+ __ "Try to build locally and then download if that fails",+ __ "Never download (just try to build locally)"]) (\i -> return ()) , mkFieldPP (paraName <<<- ParaName (__ "Update metadata at startup") $ emptyParams)@@ -582,7 +587,7 @@ stringParser serverIP (\b a -> a{serverIP = b})- (stringEditor (\ s -> not $ null s) True)+ (stringEditor (not . null) True) (\i -> return ()) , mkFieldPP (paraName <<<- ParaName (__ "Stop the leksah-server process when leksah disconnects") $ emptyParams)@@ -593,7 +598,7 @@ boolEditor (\i -> return ()) ]),- ((__ "Blacklist"), VFDPP emptyParams [+ (__ "Blacklist", VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName (__ "Packages which are excluded from the modules pane")@@ -606,7 +611,7 @@ (dependenciesEditor packages) (\i -> return ()) ]),- ((__ "Build"), VFDPP emptyParams [+ (__ "Build", VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName (__ "Automatically save all files before building") $ emptyParams) (PP.text . show)@@ -683,7 +688,7 @@ boolEditor (\i -> return ()) ]),- ((__ "Debug"), VFDPP emptyParams [+ (__ "Debug", VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName (__ "Enable usage of Show instances in :print") $ emptyParams) (PP.text . show)@@ -717,14 +722,14 @@ boolEditor debugSetPrintBindResult ]),- ((__ "Help"), VFDPP emptyParams [+ (__ "Help", VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName (__ "Browser") $ emptyParams) (PP.text . show) stringParser browser (\b a -> a{browser = b})- (stringEditor (\s -> not (null s)) True)+ (stringEditor (not . null) True) (\i -> return ()) , mkFieldPP (paraName <<<- ParaName (__ "URL for searching documentation") $@@ -736,7 +741,7 @@ stringParser docuSearchURL (\b a -> a{docuSearchURL = b})- (stringEditor (\s -> not (null s)) True)+ (stringEditor (not . null) True) (\i -> return ()) ])] @@ -775,11 +780,11 @@ , browser = "firefox" , sourceDirectories = [] , packageBlacklist = []- , pathForCategory = [ ("EditorCategory",[SplitP (LeftP)])- , ("LogCategory",[SplitP (RightP), SplitP (BottomP)])- , ("ToolCategory",[SplitP (RightP),SplitP (TopP)])+ , pathForCategory = [ ("EditorCategory",[SplitP LeftP])+ , ("LogCategory",[SplitP RightP, SplitP BottomP])+ , ("ToolCategory",[SplitP RightP, SplitP TopP]) ]- , defaultPath = [SplitP (LeftP)]+ , defaultPath = [SplitP LeftP] , categoryForPane = [ ("*ClassHierarchy","ToolCategory") , ("*Breakpoints","LogCategory") , ("*Browser","ToolCategory")
src/IDE/Pane/Search.hs view
@@ -23,12 +23,13 @@ ) where import Graphics.UI.Gtk- (rowActivated, Menu, menuAttachToWidget, cellTextScaleSet,- cellTextScale, listStoreGetValue, treeSelectionGetSelectedRows,- widgetShowAll, menuPopup, menuShellAppend, menuItemActivate,- menuItemNewWithLabel, menuNew, listStoreAppend, listStoreClear,- entrySetText, toggleButtonGetActive, widgetSetSensitivity, vBoxNew,- entryNew, scrolledWindowSetPolicy, containerAdd, scrolledWindowNew,+ (scrolledWindowSetShadowType, rowActivated, Menu,+ menuAttachToWidget, cellTextScaleSet, cellTextScale,+ listStoreGetValue, treeSelectionGetSelectedRows, widgetShowAll,+ menuPopup, menuShellAppend, menuItemActivate, menuItemNewWithLabel,+ menuNew, listStoreAppend, listStoreClear, entrySetText,+ toggleButtonGetActive, widgetSetSensitivity, vBoxNew, entryNew,+ scrolledWindowSetPolicy, containerAdd, scrolledWindowNew, treeSelectionSetMode, treeViewGetSelection, treeViewSetHeadersVisible, cellPixbufStockId, cellText, cellLayoutSetAttributes, cellLayoutPackStart, treeViewAppendColumn,@@ -39,17 +40,16 @@ checkButtonNewWithLabel, toggleButtonSetActive, ResponseId(..), dialogRun, radioButtonNewWithLabelFromWidget, radioButtonNewWithLabel, buttonNewFromStock, windowTransientFor,- hButtonBoxNew, dialogGetActionArea,- widgetGrabDefault, set, get, dialogNew, dialogResponse,- widgetHide, buttonSetLabel, widgetCanDefault, hBoxNew,- entryGetText, castToWidget, Entry, VBox, ListStore, TreeView,- ScrolledWindow, PolicyType(..), SelectionMode(..),- TreeViewColumnSizing(..), AttrOp(..), Packing(..), focusInEvent,- toggled, buttonPressEvent, keyPressEvent, keyReleaseEvent)+ hButtonBoxNew, dialogGetActionArea, widgetGrabDefault, set, get,+ dialogNew, dialogResponse, widgetHide, buttonSetLabel,+ widgetCanDefault, hBoxNew, entryGetText, castToWidget, Entry, VBox,+ ListStore, TreeView, ScrolledWindow, PolicyType(..),+ SelectionMode(..), TreeViewColumnSizing(..), AttrOp(..),+ Packing(..), focusInEvent, toggled, buttonPressEvent,+ keyPressEvent, keyReleaseEvent) import Graphics.UI.Gtk.Gdk.EventM import System.Glib.Signals (on, after)-import Data.IORef (newIORef)-import Data.IORef (writeIORef,readIORef,IORef(..))+import Data.IORef (newIORef, writeIORef, readIORef, IORef(..)) -- import IDE.Pane.SourceBuffer (goToDefinition) import IDE.Metainfo.Provider (searchMeta) import Data.Maybe@@ -61,6 +61,8 @@ import Control.Monad.IO.Class (MonadIO(..)) import qualified Data.ByteString.Char8 as BS (empty, unpack) import System.Glib.Properties (newAttrFromMaybeStringProperty)+import Control.Monad (void)+import Graphics.UI.Gtk.General.Enums (ShadowType(..)) -- | A search pane description --@@ -87,7 +89,7 @@ instance Pane IDESearch IDEM where- primPaneName _ = (__ "Search")+ primPaneName _ = __ "Search" getAddedIndex _ = 0 getTopWidget = castToWidget . topBox paneId b = "*Search"@@ -101,9 +103,9 @@ recoverState pp (SearchState str scope mode) = do nb <- getNotebook pp mbP@(Just search) <- buildPane pp nb builder- (scopeSelection search) scope- (modeSelection search) mode- (searchMetaGUI search) str+ scopeSelection search scope+ modeSelection search mode+ searchMetaGUI search str return mbP builder pp nb windows = buildSearchPane @@ -216,6 +218,7 @@ treeSelectionSetMode sel SelectionSingle sw <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType sw ShadowIn containerAdd sw treeView scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic @@ -261,7 +264,7 @@ text <- liftIO $ entryGetText entry searchMetaGUI_ text setChoices_ :: [Descr] -> IDEAction- setChoices_ descrs = do+ setChoices_ descrs = liftIO $ do listStoreClear (searchStore search) mapM_ (listStoreAppend (searchStore search)) descrs@@ -276,11 +279,11 @@ s1 <- toggleButtonGetActive rb1 s2 <- toggleButtonGetActive rb2 s3 <- toggleButtonGetActive rb3- if s1- then return (PackageScope withImports)- else if s2- then return (WorkspaceScope withImports)- else return (SystemScope)+ return $ if s1+ then PackageScope withImports+ else if s2+ then WorkspaceScope withImports+ else SystemScope scopeSelection_ scope cid1 <- treeView `after` focusInEvent $ liftIO $ do@@ -293,18 +296,18 @@ mb1 `on` toggled $ liftIO $ do widgetSetSensitivity mb4 False active <- toggleButtonGetActive mb4- (reflectIDE (modeSelection_ (Exact active)) ideR )+ reflectIDE (modeSelection_ (Exact active)) ideR mb2 `on` toggled $ liftIO $ do widgetSetSensitivity mb4 True active <- toggleButtonGetActive mb4- (reflectIDE (modeSelection_ (Prefix active)) ideR )+ reflectIDE (modeSelection_ (Prefix active)) ideR mb3 `on` toggled $ liftIO $ do widgetSetSensitivity mb4 True active <- toggleButtonGetActive mb4- (reflectIDE (modeSelection_ (Regex active)) ideR )+ reflectIDE (modeSelection_ (Regex active)) ideR mb4 `on` toggled $ liftIO $ do active <- toggleButtonGetActive mb4- (reflectIDE (modeSelectionCase active) ideR )+ reflectIDE (modeSelectionCase active) ideR (cid2, cid3) <- treeViewContextMenu treeView $ searchContextMenu ideR listStore treeView cid4 <- treeView `on` rowActivated $ selectDescr ideR listStore -- sel `onSelectionChanged` do@@ -339,7 +342,7 @@ goToDef ideR store descrView = do sel <- getSelectionDescr descrView store case sel of- Just descr -> reflectIDE (triggerEvent ideR (GotoDefinition descr)) ideR >> return ()+ Just descr -> void (reflectIDE (triggerEvent ideR (GotoDefinition descr)) ideR) -- (goToDefinition descr) ideR otherwise -> sysMessage Normal (__ "Search >> listViewPopup: no selection")
src/IDE/Pane/SourceBuffer.hs view
@@ -72,7 +72,7 @@ , selectedLocation , recentSourceBuffers , newTextBuffer-, belongsToPackage+, belongsToPackages , belongsToWorkspace , getIdentifierUnderCursorFromIter @@ -127,15 +127,15 @@ import IDE.BufferMode import Control.Monad.Trans.Reader (ask) import Control.Monad.IO.Class (MonadIO(..))-import Control.Monad (foldM, forM, filterM, unless, when)+import Control.Monad (forM, filterM, unless, when, liftM) import Control.Exception as E (catch, SomeException) import qualified IDE.Command.Print as Print import Control.Monad.Trans.Class (MonadTrans(..)) import System.Log.Logger (debugM) -allBuffers :: IDEM [IDEBuffer]-allBuffers = getPanes+allBuffers :: MonadIDE m => m [IDEBuffer]+allBuffers = liftIDE getPanes instance RecoverablePane IDEBuffer BufferState IDEM where saveState (p@IDEBuffer {sourceView=v}) = do@@ -693,7 +693,7 @@ _ -> return endSel return (start, end) -checkModTime :: IDEBuffer -> IDEM (Bool, Bool)+checkModTime :: MonadIDE m => IDEBuffer -> m (Bool, Bool) checkModTime buf = do currentState' <- readIDE currentState case currentState' of@@ -724,7 +724,7 @@ revert buf return (False, True) else do- window <- getMainWindow+ window <- liftIDE getMainWindow resp <- liftIO $ do md <- messageDialogNew (Just window) []@@ -773,14 +773,14 @@ fileRevert = inActiveBufContext () $ \ _ _ _ currentBuffer _ -> do revert currentBuffer -revert :: IDEBuffer -> IDEAction+revert :: MonadIDE m => IDEBuffer -> m () revert (buf@IDEBuffer{sourceView = sv}) = do useCandy <- useCandyFor buf ct <- readIDE candy let name = paneName buf case fileName buf of Nothing -> return ()- Just fn -> do+ Just fn -> liftIDE $ do buffer <- getBuffer sv fc <- liftIO $ UTF8.readFile fn mt <- liftIO $ getModificationTime fn@@ -838,8 +838,8 @@ modified <- getModified ebuf liftIO $ markLabel nb (getTopWidget buf) modified -fileSaveBuffer :: TextEditor editor => Bool -> Notebook -> EditorView editor -> EditorBuffer editor -> IDEBuffer -> Int -> IDEM Bool-fileSaveBuffer query nb _ ebuf (ideBuf@IDEBuffer{sourceView = sv}) i = do+fileSaveBuffer :: MonadIDE m => TextEditor editor => Bool -> Notebook -> EditorView editor -> EditorBuffer editor -> IDEBuffer -> Int -> m Bool+fileSaveBuffer query nb _ ebuf (ideBuf@IDEBuffer{sourceView = sv}) i = liftIDE $ do ideR <- ask window <- getMainWindow prefs <- readIDE prefs@@ -928,34 +928,34 @@ fileSave :: Bool -> IDEM Bool fileSave query = inActiveBufContext False $ fileSaveBuffer query -fileSaveAll :: (IDEBuffer -> IDEM Bool) -> IDEM Bool+fileSaveAll :: MonadIDE m => (IDEBuffer -> m Bool) -> m Bool fileSaveAll filterFunc = do bufs <- allBuffers filtered <- filterM filterFunc bufs results <- forM filtered (\buf -> inBufContext False buf (fileSaveBuffer False)) return $ True `elem` results -fileCheckBuffer :: TextEditor editor => Notebook -> EditorView editor -> EditorBuffer editor -> IDEBuffer -> Int -> IDEM Bool+fileCheckBuffer :: (MonadIDE m, TextEditor editor) => Notebook -> EditorView editor -> EditorBuffer editor -> IDEBuffer -> Int -> m Bool fileCheckBuffer nb _ ebuf ideBuf i = do let mbfn = fileName ideBuf if isJust mbfn then do (_, modifiedOnDisk) <- checkModTime ideBuf -- The user is given option to reload- modifiedInBuffer <- getModified ebuf+ modifiedInBuffer <- liftIDE $ getModified ebuf return (modifiedOnDisk || modifiedInBuffer) else return False -fileCheckAll :: (IDEBuffer -> IDEM (Maybe alpha)) -> IDEM [alpha]+fileCheckAll :: MonadIDE m => (IDEBuffer -> m [alpha]) -> m [alpha] fileCheckAll filterFunc = do bufs <- allBuffers- foldM (\ packs buf -> do- mbFilt <- filterFunc buf- case mbFilt of- Nothing -> return packs- Just p -> do+ liftM concat . forM bufs $ \ buf -> do+ ps <- filterFunc buf+ case ps of+ [] -> return []+ _ -> do modified <- inBufContext False buf fileCheckBuffer if modified- then return (p : packs)- else return packs) [] bufs+ then return ps+ else return [] fileNew :: IDEAction fileNew = do@@ -1016,12 +1016,13 @@ fileCloseAllButPackage :: IDEAction fileCloseAllButPackage = do- mbActivePack <- readIDE activePack+ mbActivePath <- (fmap ipdBuildDir) <$> readIDE activePack bufs <- allBuffers- when (not (null bufs) && isJust mbActivePack) $ do- mapM_ (close' (fromJust mbActivePack)) bufs+ case mbActivePath of+ Just p -> mapM_ (close' p) bufs+ Nothing -> return () where- close' activePack (buf@IDEBuffer {sourceView = sv}) = do+ close' dir (buf@IDEBuffer {sourceView = sv}) = do (pane,_) <- guiPropertiesFromName (paneName buf) nb <- getNotebook pane mbI <- liftIO $notebookPageNum nb (scrolledWindow buf)@@ -1029,7 +1030,6 @@ Nothing -> throwIDE (__ "notebook page not found: unexpected") Just i -> do ebuf <- getBuffer sv- let dir = dropFileName $ ipdCabalFile activePack when (isJust (fileName buf)) $ do modified <- getModified ebuf when (not modified && not (isSubPath dir (fromJust (fileName buf))))@@ -1055,8 +1055,8 @@ when (not modified && not (isSubPathOfAny workspace (fromJust (fileName buf)))) $ do fileClose' nb sv ebuf buf i; return () isSubPathOfAny workspace fileName =- let pathes = map (dropFileName . ipdCabalFile) (wsPackages workspace)- in or (map (\dir -> isSubPath dir fileName) pathes)+ let paths = wsPackages workspace >>= ipdAllDirs+ in or (map (\dir -> isSubPath dir fileName) paths) fileOpen :: IDEAction@@ -1376,41 +1376,37 @@ selectRange ebuf i1 i2 -- | Returns the package, to which this buffer belongs, if possible-belongsToPackage :: IDEBuffer -> IDEM(Maybe IDEPackage)-belongsToPackage IDEBuffer{fileName = Just fp}= do+belongsToPackages :: MonadIDE m => IDEBuffer -> m [IDEPackage]+belongsToPackages IDEBuffer{fileName = Just fp}= do bufferToProject' <- readIDE bufferProjCache ws <- readIDE workspace case Map.lookup fp bufferToProject' of Just p -> return p Nothing -> case ws of- Nothing -> return Nothing+ Nothing -> return [] Just workspace -> do- mbMn <- liftIO $ moduleNameFromFilePath fp- let mbMn2 = case mbMn of- Nothing -> Nothing- Just mn -> simpleParse mn- let res = foldl (belongsToPackage' fp mbMn2) Nothing (wsPackages workspace)+-- mbMn <- liftIO $ moduleNameFromFilePath fp+-- let mbMn2 = case mbMn of+-- Nothing -> Nothing+-- Just mn -> simpleParse mn+ let res = filter (belongsToPackage fp) (wsPackages workspace) modifyIDE_ (\ide -> ide{bufferProjCache = Map.insert fp res bufferToProject'}) return res-belongsToPackage _ = return Nothing+belongsToPackages _ = return [] -belongsToPackage' :: FilePath -> Maybe ModuleName -> Maybe IDEPackage -> IDEPackage -> Maybe IDEPackage-belongsToPackage' _ _ r@(Just pack) _ = r-belongsToPackage' fp mbModuleName Nothing pack =- let basePath = dropFileName $ ipdCabalFile pack- in if isSubPath basePath fp- then Just pack- else Nothing+-- | Including files in sandbox source dirs+belongsToPackage :: FilePath -> IDEPackage -> Bool+belongsToPackage f = any (`isSubPath` f) . ipdAllDirs -belongsToWorkspace b = belongsToPackage b >>= return . isJust+belongsToWorkspace b = belongsToPackages b >>= return . (not . null) -useCandyFor :: IDEBuffer -> IDEM Bool+useCandyFor :: MonadIDE m => IDEBuffer -> m Bool useCandyFor aBuffer = do- use <- getCandyState+ use <- liftIDE getCandyState return (use && isHaskellMode (mode aBuffer)) editCandy = do- use <- getCandyState+ use <- liftIDE getCandyState buffers <- allBuffers if use then mapM_ (\b -> modeEditToCandy (mode b)
src/IDE/Pane/Trace.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleInstances, RecordWildCards, TypeSynonymInstances,- MultiParamTypeClasses, DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances,+ MultiParamTypeClasses, DeriveDataTypeable, OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Trace@@ -49,6 +49,7 @@ import System.Log.Logger (debugM) import IDE.Workspaces (packageTry) import qualified Data.Conduit.List as CL (consume)+import Control.Applicative ((<$>)) import Control.Monad.Trans.Class (MonadTrans(..)) import Control.Monad.IO.Class (MonadIO(..)) import IDE.Utils.GUIUtils (treeViewContextMenu, __)@@ -77,14 +78,13 @@ instance Pane IDETrace IDEM where- primPaneName _ = (__ "Trace")+ primPaneName _ = __ "Trace" getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledView paneId b = "*Trace" instance RecoverablePane IDETrace TraceState IDEM where- saveState p = do- return (Just TraceState)+ saveState p = return (Just TraceState) recoverState pp TraceState = do nb <- getNotebook pp buildPane pp nb builder@@ -156,6 +156,7 @@ treeSelectionSetMode sel SelectionSingle scrolledView <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scrolledView ShadowIn containerAdd scrolledView treeView scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic @@ -174,8 +175,8 @@ fillTraceList :: IDEAction fillTraceList = packageTry $ do- currentHist' <- lift $ readIDE currentHist- mbTraces <- lift getPane+ currentHist' <- readIDE currentHist+ mbTraces <- liftIDE getPane case mbTraces of Nothing -> return () Just tracePane -> tryDebug $ debugCommand' ":history" $ do@@ -184,7 +185,8 @@ let parseRes = parse tracesParser "" . T.unpack $ selectString to r <- case parseRes of Left err -> do- debugM "leksah" ((printf (__ "trace parse error %s\ninput: %s") (show err) (T.unpack $ selectString to)))+ debugM "leksah" (printf (__ "trace parse error %s\ninput: %s") (show err)+ (T.unpack $ selectString to)) return [] Right traces -> return traces treeStoreClear (tracepoints tracePane)@@ -254,7 +256,7 @@ eof return [] <?>- (__ "traces parser")+ __ "traces parser" traceParser :: CharParser () TraceHist traceParser = do@@ -268,13 +270,13 @@ span <- srcSpanParser symbol ")" return (TraceHist False index function span)- <?> (__ "trace parser")+ <?> __ "trace parser" lexer = P.makeTokenParser emptyDef colon = P.colon lexer symbol = P.symbol lexer whiteSpace = P.whiteSpace lexer-int = fmap fromInteger $ P.integer lexer+int = fromInteger <$> P.integer lexer
src/IDE/Pane/Variables.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleInstances, RecordWildCards, TypeSynonymInstances,- MultiParamTypeClasses, DeriveDataTypeable, OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances, TypeSynonymInstances,+ MultiParamTypeClasses, DeriveDataTypeable, OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Variables@@ -73,14 +73,13 @@ instance Pane IDEVariables IDEM where- primPaneName _ = (__ "Variables")+ primPaneName _ = __ "Variables" getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledView paneId b = "*Variables" instance RecoverablePane IDEVariables VariablesState IDEM where- saveState p = do- return (Just VariablesState)+ saveState p = return (Just VariablesState) recoverState pp VariablesState = do nb <- getNotebook pp buildPane pp nb builder@@ -141,6 +140,7 @@ treeSelectionSetMode sel SelectionSingle scrolledView <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scrolledView ShadowIn containerAdd scrolledView treeView scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic @@ -155,12 +155,12 @@ fillVariablesListQuiet :: IDEAction fillVariablesListQuiet = packageTryQuiet $ do- mbVariables <- lift getPane+ mbVariables <- liftIDE getPane case mbVariables of Nothing -> return () Just var -> tryDebugQuiet $ debugCommand' ":show bindings" $ do to <- CL.consume- liftIO $ postGUIAsync $ do+ liftIO $ postGUIAsync $ case parse variablesParser "" . T.unpack $ selectString to of Left e -> sysMessage Normal (show e) Right triples -> do@@ -172,12 +172,12 @@ fillVariablesList :: IDEAction fillVariablesList = packageTry $ do- mbVariables <- lift getPane+ mbVariables <- liftIDE getPane case mbVariables of Nothing -> return () Just var -> tryDebug $ debugCommand' ":show bindings" $ do to <- CL.consume- liftIO $ postGUIAsync $ do+ liftIO $ postGUIAsync $ case parse variablesParser "" . T.unpack $ selectString to of Left e -> sysMessage Normal (show e) Right triples -> do@@ -218,7 +218,7 @@ symbol "::" typeStr <- many (noneOf "=") char '='- value <- many (do+ value <- many ( noneOf "\n" <|> try (do r <- char '\n'@@ -233,8 +233,7 @@ whiteSpace many (noneOf "=") char '='- value <- many anyChar- return (value)+ many anyChar <?> "valueParser" typeParser :: CharParser () String@@ -242,8 +241,7 @@ whiteSpace many (noneOf ":") symbol "::"- typeStr <- many anyChar- return typeStr+ many anyChar <?> "typeParser" @@ -287,17 +285,17 @@ forceVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction forceVariable varDescr path treeStore = packageTry $ tryDebug $ do- debugCommand' (":force " ++ (varName varDescr)) $ do+ debugCommand' (":force " ++ varName varDescr) $ do to <- CL.consume- liftIO $ postGUIAsync $ do+ liftIO $ postGUIAsync $ case parse valueParser "" . T.unpack $ selectString to of Left e -> sysMessage Normal (show e) Right value -> do var <- treeStoreGetValue treeStore path treeStoreSetValue treeStore path var{varValue = value}- debugCommand' (":type " ++ (varName varDescr)) $ do+ debugCommand' (":type " ++ varName varDescr) $ do to <- CL.consume- liftIO $ postGUIAsync $ do+ liftIO $ postGUIAsync $ case parse typeParser "" . T.unpack $ selectString to of Left e -> sysMessage Normal (show e) Right typ -> do@@ -306,17 +304,17 @@ printVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction printVariable varDescr path treeStore = packageTry $ tryDebug $ do- debugCommand' (":print " ++ (varName varDescr)) $ do+ debugCommand' (":print " ++ varName varDescr) $ do to <- CL.consume- liftIO $ postGUIAsync $ do+ liftIO $ postGUIAsync $ case parse valueParser "" . T.unpack $ selectString to of Left e -> sysMessage Normal (show e) Right value -> do var <- treeStoreGetValue treeStore path treeStoreSetValue treeStore path var{varValue = value}- debugCommand' (":type " ++ (varName varDescr)) $ do+ debugCommand' (":type " ++ varName varDescr) $ do to <- CL.consume- liftIO $ postGUIAsync $ do+ liftIO $ postGUIAsync $ case parse typeParser "" . T.unpack $ selectString to of Left e -> sysMessage Normal (show e) Right typ -> do
src/IDE/Pane/WebKit/Documentation.hs view
@@ -29,14 +29,15 @@ import Graphics.UI.Frame.Panes (RecoverablePane(..), PanePath, RecoverablePane, Pane(..)) import Graphics.UI.Gtk- (scrolledWindowSetPolicy, scrolledWindowNew, castToWidget,- ScrolledWindow)+ (scrolledWindowSetShadowType, scrolledWindowSetPolicy,+ scrolledWindowNew, castToWidget, ScrolledWindow) import Data.Typeable (Typeable) import IDE.Core.Types (IDEAction, IDEM) import Control.Monad.IO.Class (MonadIO(..)) import Graphics.UI.Frame.ViewFrame (getNotebook) import IDE.Core.State (reifyIDE)-import Graphics.UI.Gtk.General.Enums (PolicyType(..))+import Graphics.UI.Gtk.General.Enums+ (ShadowType(..), PolicyType(..)) #ifdef WEBKITGTK import Graphics.UI.Gtk@@ -100,6 +101,7 @@ return mbPane builder pp nb windows = reifyIDE $ \ ideR -> do scrolledView <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scrolledView ShadowIn #ifdef WEBKITGTK webView <- webViewNew
src/IDE/Pane/WebKit/Output.hs view
@@ -23,19 +23,24 @@ , OutputState(..) , getOutputPane , setOutput+ , loadOutputUri ) where import Graphics.UI.Frame.Panes (RecoverablePane(..), PanePath, RecoverablePane, Pane(..)) import Graphics.UI.Gtk- (postGUISync, scrolledWindowSetPolicy, scrolledWindowNew,+ (scrolledWindowSetShadowType, entryGetText, entryActivated,+ boxPackStart, entrySetText, Entry, VBox, entryNew, vBoxNew,+ postGUISync, scrolledWindowSetPolicy, scrolledWindowNew, castToWidget, ScrolledWindow) import Data.Typeable (Typeable)-import IDE.Core.Types (IDEAction, IDEM)+import IDE.Core.Types (IDEAction, IDEM, IDE(..)) import Control.Monad.IO.Class (MonadIO(..)) import Graphics.UI.Frame.ViewFrame (getNotebook)-import IDE.Core.State (postSyncIDE, reifyIDE, leksahOrPackageDir)-import Graphics.UI.Gtk.General.Enums (PolicyType(..))+import IDE.Core.State+ (modifyIDE_, postSyncIDE, reifyIDE, leksahOrPackageDir)+import Graphics.UI.Gtk.General.Enums+ (ShadowType(..), Packing(..), PolicyType(..)) #ifdef WEBKITGTK import Graphics.UI.Gtk@@ -60,9 +65,13 @@ import Data.IORef (writeIORef, newIORef, readIORef, IORef) import Control.Applicative ((<$>)) import System.Log.Logger (debugM)+import Graphics.UI.Gtk.WebKit.WebView+ (loadCommitted, webViewGetUri)+import Graphics.UI.Gtk.WebKit.WebFrame (webFrameGetUri) data IDEOutput = IDEOutput {- scrolledView :: ScrolledWindow+ vbox :: VBox+ , uriEntry :: Entry #ifdef WEBKITGTK , webView :: WebView , alwaysHtmlRef :: IORef Bool@@ -80,7 +89,7 @@ where primPaneName _ = "Out" getAddedIndex _ = 0- getTopWidget = castToWidget . scrolledView+ getTopWidget = castToWidget . vbox paneId b = "*Out" instance RecoverablePane IDEOutput OutputState IDEM where@@ -106,7 +115,13 @@ #endif return mbPane builder pp nb windows = reifyIDE $ \ ideR -> do+ vbox <- vBoxNew False 0+ uriEntry <- entryNew+ entrySetText uriEntry "http://" scrolledView <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scrolledView ShadowIn+ boxPackStart vbox uriEntry PackNatural 0+ boxPackStart vbox scrolledView PackGrow 0 #ifdef WEBKITGTK webView <- webViewNew@@ -125,7 +140,7 @@ return True webView `set` [webViewZoomLevel := 2.0]- cid2 <- webView `on` keyPressEvent $ do+ cid2 <- on webView keyPressEvent $ do key <- eventKeyName mod <- eventModifier liftIO $ case (key, mod) of@@ -134,7 +149,7 @@ ("BackSpace", []) -> webViewGoBack webView >> return True _ -> return False - cid3 <- webView `on` populatePopup $ \ menu -> do+ cid3 <- on webView populatePopup $ \ menu -> do alwaysHtml <- readIORef alwaysHtmlRef action <- toggleActionNew "AlwaysHTML" "Always HTML" Nothing Nothing item <- castToMenuItem <$> actionCreateMenuItem action@@ -143,7 +158,27 @@ menuShellAppend menu item return () - return (Just out, map ConnectC [cid1, cid2, cid3])+ cid4 <- on uriEntry entryActivated $ do+ uri <- entryGetText uriEntry+ webViewLoadUri webView uri+ (`reflectIDE` ideR) $ modifyIDE_ (\ide -> ide {autoURI = Just uri})++ cid5 <- on webView loadCommitted $ \ frame -> do+ mbUri <- webFrameGetUri frame+ valueUri <- getValueUri+ case mbUri of+ Just uri | uri /= valueUri -> do+ entrySetText uriEntry uri+ (`reflectIDE` ideR) $ modifyIDE_ (\ide -> ide {autoURI = Just uri})+ Just _ -> do+ (`reflectIDE` ideR) $ modifyIDE_ (\ide -> ide {autoURI = Nothing})+ Nothing -> return ()++ cid6 <- uriEntry `after` focusInEvent $ do+ liftIO $ reflectIDE (makeActive out) ideR+ return True++ return (Just out, [ConnectC cid1, ConnectC cid2, ConnectC cid3, ConnectC cid4, ConnectC cid5, ConnectC cid6]) #else return (Just out, []) #endif@@ -153,22 +188,43 @@ getOutputPane Nothing = forceGetPane (Right "*Out") getOutputPane (Just pp) = forceGetPane (Left pp) -setOutput :: String -> IDEAction-setOutput str = do+getValueUri :: IO String+getValueUri = do+ dataDir <- leksahOrPackageDir "pretty-show" getDataDir+ return $ "file://"+ ++ (case dataDir of+ ('/':_) -> dataDir+ _ -> '/':dataDir)+ ++ "/value.html"++setOutput :: String -> String -> IDEAction+setOutput command str = do #ifdef WEBKITGTK out <- getOutputPane Nothing liftIO $ do- dataDir <- leksahOrPackageDir "pretty-show" getDataDir+ entrySetText (uriEntry out) (show command)+ uri <- getValueUri alwaysHtml <- readIORef $ alwaysHtmlRef out let view = webView out html = case (alwaysHtml, parseValue str) of (False, Just value) -> valToHtmlPage defaultHtmlOpts value _ -> str- webViewLoadString view html Nothing Nothing ("file://"- ++ (case dataDir of- ('/':_) -> dataDir- _ -> '/':dataDir)- ++ "/value.html")+ webViewLoadString view html Nothing Nothing uri+#else+ return ()+#endif++loadOutputUri :: FilePath -> IDEAction+loadOutputUri uri = do+#ifdef WEBKITGTK+ out <- getOutputPane Nothing+ let view = webView out+ liftIO $ do+ entrySetText (uriEntry out) uri+ currentUri <- webViewGetUri view+ if Just uri == currentUri+ then webViewReload view+ else webViewLoadUri view uri #else return () #endif
src/IDE/Pane/Workspace.hs view
@@ -38,20 +38,24 @@ import System.Glib.Properties (newAttrFromMaybeStringProperty) import Data.Tree (Tree(..)) import System.Log.Logger (debugM)+import qualified Data.Function as F (on)+import System.FilePath (takeDirectory, takeBaseName, takeFileName) -- | Workspace pane state -- +type WorkspaceRecord = (IDEPackage, Maybe String)+ data IDEWorkspace = IDEWorkspace { scrolledView :: ScrolledWindow , treeViewC :: TreeView-, workspaceStore :: TreeStore (Bool,IDEPackage,Maybe String)+, workspaceStore :: TreeStore (Bool, WorkspaceRecord) , topBox :: VBox } deriving Typeable instance Pane IDEWorkspace IDEM where- primPaneName _ = (__ "Workspace")+ primPaneName _ = __ "Workspace" getAddedIndex _ = 0 getTopWidget = castToWidget . topBox paneId b = "*Workspace"@@ -61,8 +65,7 @@ deriving(Eq,Ord,Read,Show,Typeable) instance RecoverablePane IDEWorkspace WorkspaceState IDEM where- saveState p = do- return (Just WorkspaceState)+ saveState p = return (Just WorkspaceState) recoverState pp WorkspaceState = do nb <- getNotebook pp buildPane pp nb builder@@ -76,18 +79,7 @@ treeViewSetModel treeView treeStore renderer0 <- cellRendererPixbufNew- col0 <- treeViewColumnNew- treeViewColumnSetTitle col0 (__ "Active")- treeViewColumnSetSizing col0 TreeViewColumnAutosize- treeViewColumnSetResizable col0 True- treeViewColumnSetReorderable col0 True- treeViewAppendColumn treeView col0- cellLayoutPackStart col0 renderer0 True- cellLayoutSetAttributes col0 renderer0 treeStore- $ \row -> [newAttrFromMaybeStringProperty "stock-id" :=- if (\(b,_,_)-> b) row- then Just stockYes- else Nothing]+ set renderer0 [ newAttrFromMaybeStringProperty "stock-id" := Nothing ] renderer1 <- cellRendererTextNew col1 <- treeViewColumnNew@@ -96,7 +88,13 @@ treeViewColumnSetResizable col1 True treeViewColumnSetReorderable col1 True treeViewAppendColumn treeView col1+ cellLayoutPackStart col1 renderer0 False cellLayoutPackStart col1 renderer1 True+ cellLayoutSetAttributes col1 renderer0 treeStore+ $ \row -> [newAttrFromMaybeStringProperty "stock-id" :=+ if fst row+ then Just stockYes+ else Nothing] cellLayoutSetAttributes col1 renderer1 treeStore $ \row -> [ cellText := name row ] @@ -116,6 +114,7 @@ treeSelectionSetMode sel SelectionSingle sw <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType sw ShadowIn containerAdd sw treeView scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic box <- vBoxNew False 2@@ -129,10 +128,11 @@ cid4 <- treeView `on` rowActivated $ workspaceSelect ideR workspacePane return (Just workspacePane, map ConnectC [cid1, cid2, cid3, cid4]) where- name (_, _, Just exe) = exe- name (_, pack, _) = packageIdentifierToString $ ipdPackageId pack- file (_, _, Just _) = ""- file (_, pack, _) = ipdCabalFile pack+ name (_, (_, Just exe)) = exe+ name (_, (pack, Nothing)) = packageIdentifierToString $ ipdPackageId pack+ file (_, (_, Just _)) = ""+ file (_, (pack, _)) = ipdCabalFile pack+ getWorkspace :: Maybe PanePath -> IDEM IDEWorkspace getWorkspace Nothing = forceGetPane (Right "*Workspace") getWorkspace (Just pp) = forceGetPane (Left pp)@@ -143,7 +143,7 @@ displayPane l False getSelectionTree :: TreeView- -> TreeStore (Bool, IDEPackage, Maybe String)+ -> TreeStore (Bool, WorkspaceRecord) -> IO (Maybe (Bool, IDEPackage, Maybe String)) getSelectionTree treeView treeStore = do liftIO $ debugM "leksah" "getSelectionTree"@@ -152,7 +152,8 @@ case rows of [path] -> do val <- treeStoreGetValue treeStore path- return (Just val)+ case val of+ (active, (p, exe)) -> return $ Just (active, p, exe) _ -> return Nothing workspaceContextMenu :: IDERef@@ -167,10 +168,9 @@ sel <- getSelectionTree (treeViewC workspacePane) (workspaceStore workspacePane) case sel of- Just (_,ideP,mbExe) -> reflectIDE (workspaceTry $ workspaceActivatePackage ideP mbExe) ideR-+ Just (_, ideP,mbExe) -> reflectIDE (workspaceTry $ workspaceActivatePackage ideP mbExe) ideR otherwise -> return ()- item2 `on` menuItemActivate $ reflectIDE (workspaceTry $ workspaceAddPackage) ideR+ item2 `on` menuItemActivate $ reflectIDE (workspaceTry workspaceAddPackage) ideR item3 `on` menuItemActivate $ do sel <- getSelectionTree (treeViewC workspacePane) (workspaceStore workspacePane)@@ -188,37 +188,37 @@ -> IO () workspaceSelect ideR workspacePane path _ = do liftIO $ debugM "leksah" "workspaceSelect"- (_,ideP,mbExe) <- treeStoreGetValue (workspaceStore workspacePane) path+ (_,(ideP,mbExe)) <- treeStoreGetValue (workspaceStore workspacePane) path reflectIDE (workspaceTry $ workspaceActivatePackage ideP mbExe) ideR updateWorkspace :: Bool -> Bool -> IDEAction updateWorkspace showPane updateFileCache = do liftIO $ debugM "leksah" "updateWorkspace" mbWs <- readIDE workspace+ when updateFileCache $ modifyIDE_ (\ide -> ide{bufferProjCache = Map.empty})+ mbMod <- getPane case mbWs of Nothing -> do- when updateFileCache $ modifyIDE_ (\ide -> ide{bufferProjCache = Map.empty})- mbMod <- getPane case mbMod of Nothing -> return ()- Just (p :: IDEWorkspace) -> do+ Just (p :: IDEWorkspace) -> do liftIO $ treeStoreClear (workspaceStore p) when showPane $ displayPane p False refreshFiles Just ws -> do- when updateFileCache $ modifyIDE_ (\ide -> ide{bufferProjCache = Map.empty})- mbMod <- getPane case mbMod of Nothing -> return ()- Just (p :: IDEWorkspace) -> do+ Just (p :: IDEWorkspace) -> do liftIO $ treeStoreClear (workspaceStore p)- let sorted = sortBy (\ f s -> compare (ipdPackageId f) (ipdPackageId s)) $ wsPackages ws- forest = map (\ ideP ->- Node (Just (ipdCabalFile ideP) == wsActivePackFile ws, ideP, Nothing)- (map (\ test -> Node (+ let sorted = sortBy (compare `F.on` ipdPackageId) $ wsPackages ws+ forest = map (\ ideP -> Node (+ Just (ipdCabalFile ideP) == wsActivePackFile ws,+ (ideP, Nothing))+ (map (\ pack -> Node (False, (pack, Nothing)) []) (ipdSandboxSources ideP) +++ map (\ test -> Node ( Just (ipdCabalFile ideP) == wsActivePackFile ws &&- Just test == wsActiveExe ws, ideP, Just test) []) $- ipdExes ideP ++ ipdTests ideP))+ Just test == wsActiveExe ws, (ideP, Just test)) [])+ (ipdExes ideP ++ ipdTests ideP ++ ipdBenchmarks ideP))) sorted liftIO $ treeStoreInsertForest (workspaceStore p) [] 0 forest when showPane $ displayPane p False
src/IDE/PaneGroups.hs view
@@ -32,7 +32,7 @@ panePathForGroup) import Graphics.UI.Frame.ViewFrame (getBestPanePath, getNotebook, viewSplit', newGroupOrBringToFront)-import Control.Monad (when, liftM)+import Control.Monad (void, unless, when, liftM) import IDE.Core.Types (frameState) import Graphics.UI.Editor.Parameters (Direction(..)) import Graphics.UI.Gtk@@ -71,26 +71,25 @@ notebookSetShowTabs upper False notebookSetShowTabs lower False notebookSetShowTabs top False- getOrBuildPane (Left upperP) :: IDEM (Maybe IDEModules)- getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEInfo)- getOrBuildPane (Left topP) :: IDEM (Maybe IDEWorkspace)- return ()+ getOrBuildBrowserPanes upperP lowerP topP (Just rpp, False) -> do let lowerP = getBestPanePath (rpp ++ [SplitP BottomP, SplitP BottomP]) layout' let upperP = getBestPanePath (rpp ++ [SplitP BottomP, SplitP TopP]) layout' let topP = getBestPanePath (rpp ++ [SplitP TopP]) layout'- getOrBuildPane (Left upperP) :: IDEM (Maybe IDEModules)- getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEInfo)- getOrBuildPane (Left topP) :: IDEM (Maybe IDEWorkspace)- return ()+ getOrBuildBrowserPanes upperP lowerP topP _ -> return ()+ where+ getOrBuildBrowserPanes upperP lowerP topP = do+ getOrBuildPane (Left upperP) :: IDEM (Maybe IDEModules)+ getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEInfo)+ getOrBuildPane (Left topP) :: IDEM (Maybe IDEWorkspace)+ return () setSensitivityDebugger :: Bool -> IDEAction setSensitivityDebugger sens = do mbBreakpoints :: Maybe IDEBreakpoints <- getPane mbVariables :: Maybe IDEVariables <- getPane mbTrace :: Maybe IDETrace <- getPane- mbOutput :: Maybe IDEOutput <- getPane liftIO $ do case mbBreakpoints of Nothing -> return ()@@ -101,9 +100,6 @@ case mbTrace of Nothing -> return () Just idePane -> widgetSetSensitive (getTopWidget idePane) sens- case mbOutput of- Nothing -> return ()- Just idePane -> widgetSetSensitive (getTopWidget idePane) sens showDebugger :: IDEAction showDebugger = do@@ -122,23 +118,19 @@ notebookSetTabPos lower PosTop notebookSetTabPos upper PosTop notebookSetShowTabs upper False- getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEBreakpoints)- getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEVariables)- getOrBuildPane (Left lowerP) :: IDEM (Maybe IDETrace)- getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEOutput)- when (null $ filter (\b -> bufferName b == "_Eval.hs") bufs) $- newTextBuffer upperP "_Eval.hs" Nothing >> return ()- return ()+ getOrBuildDebugPanes upperP lowerP bufs (Just rpp, False) -> do let lowerP = getBestPanePath (rpp ++ [SplitP BottomP]) layout' let upperP = getBestPanePath (rpp ++ [SplitP TopP]) layout'- getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEBreakpoints)- getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEVariables)- getOrBuildPane (Left lowerP) :: IDEM (Maybe IDETrace)- getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEOutput)- when (null $ filter (\b -> bufferName b == "_Eval.hs") bufs) $- newTextBuffer upperP "_Eval.hs" Nothing >> return ()- return ()+ getOrBuildDebugPanes upperP lowerP bufs _ -> return ()-+ where+ getOrBuildDebugPanes upperP lowerP bufs = do+ getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEBreakpoints)+ getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEVariables)+ getOrBuildPane (Left lowerP) :: IDEM (Maybe IDETrace)+ getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEOutput)+ unless (any (\ b -> bufferName b == "_Eval.hs") bufs) $+ void (newTextBuffer upperP "_Eval.hs" Nothing)+ return ()
+ src/IDE/Sandbox.hs view
@@ -0,0 +1,103 @@+-----------------------------------------------------------------------------+--+-- Module : IDE.Sandbox+-- Copyright : 2007-2014 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org>+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Sandbox (+ sandboxInit+, sandboxInitShared+, sandboxDelete+, sandboxAddSource+) where++import Graphics.UI.Gtk (Window)+import Control.Monad (when, void)+import Control.Monad.Trans.Class (lift)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask)+import System.Exit (ExitCode(..))+import System.FilePath (dropFileName)+import qualified Data.Conduit as C (Sink)+import qualified Data.Conduit.List as CL (fold)+import qualified Data.Conduit.Util as CU (zipSinks)+import IDE.Utils.Tool (ToolOutput(..))+import IDE.Utils.GUIUtils (__, chooseDir)+import IDE.Core.State (PackageAction, readIDE, prefs, ipdBuildDir, getMainWindow,+ Workspace, wsFile, liftIDE, IDEPackage, IDEM, runPackage, LogLaunch)+import IDE.Pane.Log (getDefaultLogLaunch)+import IDE.Utils.ExternalTool (runExternalTool')+import IDE.LogRef (logOutput)+import IDE.Pane.PackageEditor (choosePackageFile)+import IDE.Workspaces (workspaceTryQuiet)+import IDE.Package (refreshPackage)++-- | Get the last item+sinkLast = CL.fold (\_ a -> Just a) Nothing++logSandbox :: IDEPackage -> LogLaunch -> C.Sink ToolOutput IDEM ()+logSandbox package logLaunch = do+ let log = logOutput logLaunch+ (mbLastOutput, _) <- CU.zipSinks sinkLast log+ when (mbLastOutput == Just (ToolExit ExitSuccess)) .+ lift $ workspaceTryQuiet (runPackage (void $ refreshPackage log) package)++sandboxInit :: PackageAction+sandboxInit = do+ package <- ask+ logLaunch <- getDefaultLogLaunch+ runExternalTool' (__ "Sandbox Init")+ "cabal" ["sandbox", "init"]+ (ipdBuildDir package) (logSandbox package logLaunch)++chooseSandboxDir :: Window -> Maybe FilePath -> IO (Maybe FilePath)+chooseSandboxDir window = chooseDir window (__ "Select sandbox folder")++sandboxInitShared :: PackageAction+sandboxInitShared = do+ package <- ask+ ws <- lift ask+ window <- liftIDE getMainWindow+ mbDir <- liftIO $ chooseSandboxDir window Nothing+ case mbDir of+ Nothing -> return ()+ Just dir -> do+ logLaunch <- getDefaultLogLaunch+ runExternalTool' (__ "Sandbox Init")+ "cabal" ["sandbox", "init", "--sandbox=" ++ dir]+ (ipdBuildDir package) (logSandbox package logLaunch)++sandboxDelete :: PackageAction+sandboxDelete = do+ package <- ask+ logLaunch <- getDefaultLogLaunch+ runExternalTool' (__ "Sandbox Delete")+ "cabal" ["sandbox", "delete"]+ (ipdBuildDir package) (logSandbox package logLaunch)++chooseSandboxSourceDir :: Window -> Maybe FilePath -> IO (Maybe FilePath)+chooseSandboxSourceDir window = chooseDir window (__ "Select source folder")++sandboxAddSource :: Bool -> PackageAction+sandboxAddSource snapshot = do+ package <- ask+ ws <- lift ask+ let path = dropFileName (wsFile ws)+ window <- liftIDE getMainWindow+ mbFilePath <- liftIO $ chooseSandboxSourceDir window (Just path)+ case mbFilePath of+ Nothing -> return ()+ Just fp -> do+ logLaunch <- getDefaultLogLaunch+ runExternalTool' (__ "Sandbox Add Source")+ "cabal" (["sandbox", "add-source", fp] ++ ["--snapshot" | snapshot])+ (ipdBuildDir package) (logSandbox package logLaunch)+
src/IDE/TextEditor/Class.hs view
@@ -17,7 +17,7 @@ TextEditor(..) ) where -import IDE.Core.Types (IDERef, IDEM)+import IDE.Core.Types (IDERef, IDEM, IDEEventM) import Graphics.UI.Editor.Basics (Connection) import Control.Monad.Reader (ReaderT(..)) import Graphics.UI.Gtk@@ -28,7 +28,6 @@ import Control.Monad.Reader.Class (MonadReader(..)) import Control.Monad.IO.Class (MonadIO(..)) import System.Glib.Signals (on)-import IDE.Core.Types (IDEEventM) class TextEditor editor where data EditorBuffer editor
src/IDE/TextEditor/CodeMirror.hs view
@@ -33,6 +33,8 @@ ) where import Data.Typeable (Typeable)+import Graphics.UI.Gtk (scrolledWindowSetShadowType)+import Graphics.UI.Gtk.General.Enums (ShadowType(..)) #ifdef LEKSAH_WITH_CODE_MIRROR import Control.Monad (unless)@@ -181,6 +183,7 @@ liftIO $ do debugM "leksah" "newCMBuffer" scrolledWindow <- scrolledWindowNew Nothing Nothing+ scrolledWindowSetShadowType scrolledWindow ShadowIn cmWebView <- webViewNew containerAdd scrolledWindow cmWebView dataDir <- liftIO $ leksahOrPackageDir "ghcjs-codemirror" CM.getDataDir
src/IDE/TextEditor/Yi.hs view
@@ -47,7 +47,7 @@ (moveToColB, gotoLn, atSol, atEof, atSof, curCol, curLn, readLnB, readCharB, nextWordB, moveToEol, rightB, rightN, nextPointB, unitWord, atBoundaryB, moveToSol, prevWordB, leftB, readB,- doUntilB_, prevPointB, Mode, modifyMode, insertingA, getA, undoB,+ doUntilB_, prevPointB, Mode, modifyMode, insertingA, undoB, markSavedB, setSelectRegionB, redoB, setMarkPointB, insertNAt, regionIsEmpty, regionEnd, regionStart, selMark, isUnchangedBuffer, Point(..), MarkValue(..), lineOf, getMarkPointB, pointOfLineColB,@@ -80,6 +80,7 @@ import Graphics.UI.Editor.Basics (Connection(..)) import Control.Monad.Trans.Class (MonadTrans(..)) import System.Glib.Signals (on, after)+import Control.Lens (use) #endif data Yi = Yi deriving( Typeable, Show )@@ -210,7 +211,7 @@ #endif getIterAtLocation (YiView View{viewFBufRef = b}) x y = return $ mkYiIter' b $ Point 0 -- TODO getIterLocation (YiView v) (YiIter i) = return $ Rectangle 0 0 0 0 -- TODO- getOverwrite (YiView View{viewFBufRef = b}) = withYiBuffer' b $ not <$> getA insertingA+ getOverwrite (YiView View{viewFBufRef = b}) = withYiBuffer' b $ not <$> use insertingA getScrolledWindow (YiView v) = return $ scrollWin v getEditorWidget (YiView v) = return $ castToWidget $ drawArea v grabFocus (YiView View{drawArea = da}) = liftIO $ widgetGrabFocus da
src/IDE/Utils/ExternalTool.hs view
@@ -26,8 +26,8 @@ import IDE.Core.State (runningTool, modifyIDE_, reflectIDE, useVado, reifyIDE, triggerEventIDE, saveAllBeforeBuild, prefs, readIDE, IDEAction,- IDEM)-import Control.Monad (when)+ IDEM, MonadIDE(..))+import Control.Monad (void, unless, when) import IDE.Pane.SourceBuffer (belongsToWorkspace, fileSaveAll) import IDE.Core.Types (StatusbarCompartment(..), IDEEvent(..)) import Control.Concurrent (forkIO)@@ -37,12 +37,13 @@ import Data.Maybe (isNothing) import Control.Applicative ((<$>)) -runExternalTool' :: String+runExternalTool' :: MonadIDE m+ => String -> FilePath -> [String] -> FilePath -> C.Sink ToolOutput IDEM ()- -> IDEAction+ -> m () runExternalTool' description executable args dir handleOutput = do runExternalTool (do run <- isRunning@@ -55,20 +56,22 @@ handleOutput return() -runExternalTool :: IDEM Bool- -> (ProcessHandle -> IDEAction)+runExternalTool :: MonadIDE m+ => m Bool+ -> (ProcessHandle -> IDEM ()) -> String -> FilePath -> [String] -> FilePath -> C.Sink ToolOutput IDEM ()- -> IDEAction+ -> m () runExternalTool runGuard pidHandler description executable args dir handleOutput = do prefs <- readIDE prefs run <- runGuard when run $ do when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace; return ())- triggerEventIDE (StatusbarChanged [CompartmentState description, CompartmentBuild True])+ unless (null description) . void $+ triggerEventIDE (StatusbarChanged [CompartmentState description, CompartmentBuild True]) reifyIDE $ \ideR -> forkIO $ do -- If vado is enabled then look up the mount point and transform -- the execuatble to "ssh" and the arguments@@ -90,16 +93,16 @@ -- --------------------------------------------------------------------- -- | Handling of Compiler errors ---isRunning :: IDEM Bool+isRunning :: MonadIDE m => m Bool isRunning = do maybeProcess <- readIDE runningTool- liftIO $ do+ liftIO $ case maybeProcess of- Just process -> do+ Just process -> isNothing <$> getProcessExitCode process Nothing -> return False -interruptBuild :: IDEAction+interruptBuild :: MonadIDE m => m () interruptBuild = do maybeProcess <- readIDE runningTool liftIO $ case maybeProcess of
src/IDE/Utils/ServerConnection.hs view
@@ -30,6 +30,7 @@ import Control.Event(triggerEvent) import Control.Monad.IO.Class (MonadIO(..)) import System.Log.Logger (getLevel, getRootLogger)+import Control.Monad (void) doServerCommand :: ServerCommand -> (ServerAnswer -> IDEM alpha) -> IDEAction doServerCommand command cont = do@@ -38,13 +39,13 @@ Just handle -> do isOpen <- liftIO $ hIsOpen handle if isOpen- then doCommand handle >> return ()+ then void (doCommand handle) else do modifyIDE_ (\ ide -> ide{server = Nothing}) doServerCommand command cont Nothing -> do prefs' <- readIDE prefs- handle <- reifyIDE $ \ideR -> do+ handle <- reifyIDE $ \ideR -> catch (connectTo (serverIP prefs') (PortNumber(PortNum (fromIntegral $ serverPort prefs')))) (\(exc :: SomeException) -> do catch (startServer (serverPort prefs'))@@ -52,7 +53,7 @@ mbHandle <- waitForServer prefs' 100 case mbHandle of Just handle -> return handle- Nothing -> throwIDE ("Can't connect to leksah-server"))+ Nothing -> throwIDE "Can't connect to leksah-server") modifyIDE_ (\ ide -> ide{server = Just handle}) doCommand handle return ()@@ -60,7 +61,7 @@ doCommand handle = do triggerEventIDE (StatusbarChanged [CompartmentCollect True]) reifyIDE $ \ideR -> forkIO $ do- hPutStrLn handle (show command)+ hPrint handle command hFlush handle resp <- hGetLine handle postGUIAsync (reflectIDE (do
src/IDE/Workspaces.hs view
@@ -12,7 +12,6 @@ -- | Represents a workspace, a work unit, which can be composed of multiple packages -- ------------------------------------------------------------------------------{-# LANGUAGE DeriveDataTypeable #-} module IDE.Workspaces ( workspaceNew , workspaceOpen@@ -39,8 +38,8 @@ import IDE.Core.State import Graphics.UI.Editor.Parameters (Parameter(..), (<<<-), paraName, emptyParams)-import Control.Monad (forM_, unless, when, liftM)-import Data.Maybe (isJust,fromJust )+import Control.Monad (void, unless, when, liftM)+import Data.Maybe (isJust, fromJust, catMaybes) import IDE.Utils.GUIUtils (chooseFile, chooseSaveFile, __) import System.FilePath@@ -64,7 +63,7 @@ import Data.List (delete) import IDE.Package (getModuleTemplate, getPackageDescriptionAndPath, activatePackage,- deactivatePackage, idePackageFromPath)+ deactivatePackage, idePackageFromPath, idePackageFromPath) import System.Directory (getHomeDirectory, createDirectoryIfMissing, doesFileExist) import System.Time (getClockTime)@@ -73,7 +72,7 @@ import Graphics.UI.Gtk.Windows.Dialog (ResponseId(..)) import qualified Control.Exception as Exc (SomeException(..), throw, Exception) import qualified Data.Map as Map (empty)-import IDE.Pane.SourceBuffer (fileOpenThis, fileCheckAll, belongsToPackage)+import IDE.Pane.SourceBuffer (fileOpenThis, fileCheckAll, belongsToPackages) import qualified System.IO.UTF8 as UTF8 (writeFile) import System.Glib.Attributes (AttrOp(..), set) import Graphics.UI.Gtk.General.Enums (WindowPosition(..))@@ -91,19 +90,16 @@ import qualified IDE.Workspaces.Writer as Writer import Text.Printf (printf) import System.Log.Logger (debugM)-import Data.Maybe (catMaybes) import IDE.Pane.Log (showDefaultLogLaunch', getLog) import IDE.LogRef (logOutputDefault)+import Data.Foldable (forM_) -- | Constructs a new workspace and makes it the current workspace workspaceNew :: IDEAction workspaceNew = do window <- getMainWindow- mbFile <- liftIO $ do- chooseSaveFile window (__ "New file for workspace") Nothing- case mbFile of- Nothing -> return ()- Just filePath -> workspaceNewHere filePath+ mbFile <- liftIO $ chooseSaveFile window (__ "New file for workspace") Nothing+ forM_ mbFile workspaceNewHere workspaceNewHere :: FilePath -> IDEAction workspaceNewHere filePath =@@ -145,9 +141,9 @@ resp <- liftIO $ do defaultExists <- doesFileExist defaultWorkspace md <- messageDialogNew (Just mainWindow) [DialogModal] MessageQuestion ButtonsCancel (- (__ "You need to have a workspace open for this to work. ")- ++ (__ "Choose ~/leksah.lkshw to ")- ++ (if defaultExists then (__ "open workspace ") else (__ "create a workspace "))+ __ "You need to have a workspace open for this to work. "+ ++ __ "Choose ~/leksah.lkshw to "+ ++ __ (if defaultExists then "open workspace " else "create a workspace ") ++ defaultWorkspace) dialogAddButton md (__ "_New Workspace") (ResponseUser 1) dialogAddButton md (__ "_Open Workspace") (ResponseUser 2)@@ -190,7 +186,7 @@ window <- getMainWindow liftIO $ do md <- messageDialogNew (Just window) [] MessageQuestion ButtonsNone- $ (__ "There are session settings stored with this workspace.")+ $ __ "There are session settings stored with this workspace." dialogAddButton md (__ "_Ignore Session") ResponseCancel dialogAddButton md (__ "_Load Session") ResponseYes dialogSetDefaultResponse md ResponseYes@@ -202,7 +198,7 @@ otherwise -> return False else return False if wantToLoadSession- then triggerEventIDE (LoadSession spath) >> return ()+ then void (triggerEventIDE (LoadSession spath)) else do ideR <- ask catchIDE (do@@ -223,8 +219,7 @@ Just ws -> do VCSWS.onWorkspaceClose let oldActivePackFile = wsActivePackFile ws- triggerEventIDE (SaveSession ((dropExtension (wsFile ws))- ++ leksahSessionFileExtension))+ triggerEventIDE (SaveSession (dropExtension (wsFile ws) ++ leksahSessionFileExtension)) addRecentlyUsedWorkspace (wsFile ws) Writer.setWorkspace Nothing when (isJust oldActivePackFile) $ do@@ -241,11 +236,11 @@ let path = dropFileName (wsFile ws) lift $ packageNew' path logOutputDefault (\isNew fp -> do window <- getMainWindow- workspaceTry $ workspaceAddPackage' fp >> return ()+ workspaceTry $ void (workspaceAddPackage' fp) when isNew $ do- mbPack <- idePackageFromPath fp+ mbPack <- idePackageFromPath logOutputDefault fp constructAndOpenMainModule mbPack- triggerEventIDE UpdateWorkspaceInfo >> return ())+ void (triggerEventIDE UpdateWorkspaceInfo)) workspacePackageClone :: WorkspaceAction workspacePackageClone = do@@ -253,8 +248,8 @@ let path = dropFileName (wsFile ws) lift $ packageClone path logOutputDefault (\fp -> do window <- getMainWindow- workspaceTry $ workspaceAddPackage' fp >> return ()- triggerEventIDE UpdateWorkspaceInfo >> return ())+ workspaceTry $ void (workspaceAddPackage' fp)+ void (triggerEventIDE UpdateWorkspaceInfo)) constructAndOpenMainModule :: Maybe IDEPackage -> IDEAction constructAndOpenMainModule Nothing = return ()@@ -262,7 +257,7 @@ forM_ (ipdMain idePackage) $ \(target, bi, isTest) -> do mbPD <- getPackageDescriptionAndPath case mbPD of- Just (pd,_) -> do+ Just (pd,_) -> case hsSourceDirs bi of path:_ -> do liftIO $ createDirectoryIfMissing True path@@ -283,17 +278,17 @@ case mbFilePath of Nothing -> return () Just fp -> do- workspaceAddPackage' fp >> return ()- lift $ triggerEventIDE UpdateWorkspaceInfo >> return ()+ void (workspaceAddPackage' fp)+ lift $ void (triggerEventIDE UpdateWorkspaceInfo) workspaceAddPackage' :: FilePath -> WorkspaceM (Maybe IDEPackage) workspaceAddPackage' fp = do ws <- ask cfp <- liftIO $ myCanonicalizePath fp- mbPack <- lift $ idePackageFromPath cfp+ mbPack <- lift $ idePackageFromPath logOutputDefault cfp case mbPack of Just pack -> do- unless (elem cfp (map ipdCabalFile (wsPackages ws))) $ lift $+ unless (cfp `elem` map ipdCabalFile (wsPackages ws)) $ lift $ Writer.writeWorkspace $ ws {wsPackages = pack : wsPackages ws, wsActivePackFile = Just (ipdCabalFile pack), wsActiveExe = Nothing}@@ -304,16 +299,16 @@ packageTryQuiet f = do maybePackage <- readIDE activePack case maybePackage of- Just p -> runPackage f p+ Just p -> workspaceTryQuiet $ runPackage f p Nothing -> ideMessage Normal (__ "No active package") packageTry :: PackageAction -> IDEAction packageTry f = workspaceTry $ do maybePackage <- lift $ readIDE activePack case maybePackage of- Just p -> lift $ runPackage f p+ Just p -> runPackage f p Nothing -> do- window <- lift $ getMainWindow+ window <- lift getMainWindow resp <- liftIO $ do md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel (__ "You need to have an active package for this to work.")@@ -336,15 +331,16 @@ workspaceRemovePackage :: IDEPackage -> WorkspaceAction workspaceRemovePackage pack = do ws <- ask- when (elem pack (wsPackages ws)) $ lift $+ when (pack `elem` wsPackages ws) $ lift $ Writer.writeWorkspace ws {wsPackages = delete pack (wsPackages ws)} return () workspaceActivatePackage :: IDEPackage -> Maybe String -> WorkspaceAction workspaceActivatePackage pack exe = do ws <- ask- lift $ activatePackage (Just (pack, exe))- when (elem pack (wsPackages ws)) $ lift $ do+ let activePath = takeDirectory $ ipdCabalFile pack+ lift $ activatePackage (Just activePath) (Just pack) exe+ when (pack `elem` wsPackages ws) $ lift $ do Writer.writeWorkspace ws {wsActivePackFile = Just (ipdCabalFile pack) ,wsActiveExe = exe} return ()@@ -357,7 +353,7 @@ liftIO $ debugM "leksah" "readWorkspace" ws <- liftIO $ readFields fp Writer.workspaceDescr emptyWorkspace ws' <- liftIO $ makePathsAbsolute ws fp- packages <- mapM idePackageFromPath (wsPackagesFiles ws')+ packages <- mapM (idePackageFromPath logOutputDefault) (wsPackagesFiles ws') --TODO set package vcs here return ws'{ wsPackages = catMaybes packages} @@ -376,9 +372,10 @@ return ws {wsActivePackFile = wsActivePackFile', wsFile = wsFile', wsPackagesFiles = wsPackagesFiles'} where makeAbsolute basePath relativePath =- if isAbsolute relativePath- then myCanonicalizePath relativePath- else myCanonicalizePath (basePath </> relativePath)+ myCanonicalizePath+ (if isAbsolute relativePath+ then relativePath+ else basePath </> relativePath) emptyWorkspace = Workspace { wsVersion = Writer.workspaceVersion@@ -398,9 +395,9 @@ addRecentlyUsedWorkspace :: FilePath -> IDEAction addRecentlyUsedWorkspace fp = do state <- readIDE currentState- when (not $ isStartingOrClosing state) $ do+ unless (isStartingOrClosing state) $ do recentWorkspaces' <- readIDE recentWorkspaces- unless (elem fp recentWorkspaces') $+ unless (fp `elem` recentWorkspaces') $ modifyIDE_ (\ide -> ide{recentWorkspaces = take 12 (fp : recentWorkspaces')}) triggerEventIDE UpdateRecent return ()@@ -408,10 +405,10 @@ removeRecentlyUsedWorkspace :: FilePath -> IDEAction removeRecentlyUsedWorkspace fp = do state <- readIDE currentState- when (not $ isStartingOrClosing state) $ do+ unless (isStartingOrClosing state) $ do recentWorkspaces' <- readIDE recentWorkspaces- when (elem fp recentWorkspaces') $- modifyIDE_ (\ide -> ide{recentWorkspaces = filter (\e -> e /= fp) recentWorkspaces'})+ when (fp `elem` recentWorkspaces') $+ modifyIDE_ (\ide -> ide{recentWorkspaces = filter (/= fp) recentWorkspaces'}) triggerEventIDE UpdateRecent return () @@ -431,7 +428,7 @@ debug <- isJust <$> readIDE debugState return $ case (runTests, debug) of (True, True) -> [MoBuild,MoDocu]- (True, False) -> [MoBuild,MoDocu,MoTest,MoCopy,MoRegister]+ (True, False) -> [MoBuild,MoDocu,MoCopy,MoRegister] (False, True) -> [MoBuild] (False, False) -> [MoBuild,MoCopy,MoRegister] @@ -457,18 +454,15 @@ Nothing -> return () Just package -> do modifiedPacks <- if saveAllBeforeBuild prefs- then fileCheckAll belongsToPackage+ then fileCheckAll belongsToPackages else return [] let isModified = not (null modifiedPacks) when isModified $ do let settings = defaultMakeSettings prefs steps <- buildSteps $ msRunUnitTests settings- if debug || msSingleBuildWithoutLinking settings && not (msMakeMode settings)- then workspaceTryQuiet $- makePackages settings modifiedPacks (MoComposed steps) (MoComposed []) moNoOp- else do- workspaceTryQuiet $- makePackages settings modifiedPacks (MoComposed steps)+ workspaceTryQuiet $ if debug || msSingleBuildWithoutLinking settings && not (msMakeMode settings)+ then makePackages settings modifiedPacks (MoComposed steps) (MoComposed []) moNoOp+ else makePackages settings modifiedPacks (MoComposed steps) (MoComposed (MoConfigure:steps)) MoMetaInfo ) (\(e :: Exc.SomeException) -> sysMessage Normal (show e))@@ -476,7 +470,7 @@ makePackage :: PackageAction makePackage = do p <- ask- lift $ do+ liftIDE $ do getLog >>= liftIO . bringPaneToFront showDefaultLogLaunch' prefs' <- readIDE prefs@@ -490,7 +484,7 @@ if debug || msSingleBuildWithoutLinking settings && not (msMakeMode settings) then runWorkspace (makePackages settings [p] (MoComposed steps) (MoComposed []) moNoOp) ws- else do+ else runWorkspace (makePackages settings [p] (MoComposed steps)
src/IDE/Workspaces/Writer.hs view
@@ -27,7 +27,7 @@ import IDE.Utils.FileUtils(myCanonicalizePath) import Data.Maybe-import Control.Monad (when)+import Control.Monad (void, when) import Control.Monad.Trans (liftIO) import System.Time (getClockTime) import Text.PrinterParser@@ -57,10 +57,10 @@ newWs' <- liftIO $ makePathsRelative newWs liftIO $ writeFields (wsFile newWs') (newWs' {wsFile = ""}) workspaceDescr -getPackage :: FilePath -> Maybe String -> [IDEPackage] -> Maybe (IDEPackage, Maybe String)-getPackage fp mbExe packages =+getPackage :: FilePath -> [IDEPackage] -> Maybe IDEPackage+getPackage fp packages = case filter (\ p -> ipdCabalFile p == fp) packages of- [p] -> Just (p, mbExe)+ [p] -> Just p l -> Nothing -- ---------------------------------------------------------------------@@ -85,7 +85,7 @@ Just ws -> Just (wsPackages ws) when (packFileAndExe /= oldPackFileAndExe) $ case packFileAndExe of- (Just (Just p, mbExe)) -> activatePackage (getPackage p mbExe (fromJust mbPackages)) >> return ()+ (Just (Just p, mbExe)) -> void (activatePackage (Just p) (getPackage p (fromJust mbPackages)) mbExe) _ -> deactivatePackage mbPack <- readIDE activePack mbExe <- readIDE activeExe@@ -113,7 +113,7 @@ nfp <- liftIO $ myCanonicalizePath fp return (Just (makeRelative (dropFileName wsFile') nfp)) wsPackagesFiles' <- mapM myCanonicalizePath (wsPackagesFiles ws)- let relativePathes = map (\p -> makeRelative (dropFileName wsFile') p) wsPackagesFiles'+ let relativePathes = map (makeRelative (dropFileName wsFile')) wsPackagesFiles' return ws {wsActivePackFile = wsActivePackFile', wsFile = wsFile', wsPackagesFiles = relativePathes} workspaceDescr :: [FieldDescriptionS Workspace]
src/IDE/YiConfig.hs view
@@ -20,8 +20,6 @@ #ifdef LEKSAH_WITH_YI import Data.List (reverse, isPrefixOf)-import Yi.Prelude-import Prelude () import Yi import Yi.Keymap.Vim@@ -30,6 +28,7 @@ import Yi.UI.Pango.Control import Control.Monad (replicateM_)+import Control.Applicative (Alternative(..)) start yiConfig f = startControl yiConfig $ do@@ -56,10 +55,7 @@ startFrontEnd = Yi.UI.Pango.start, defaultKm = mkKeymap extendedVimKeymap, modeTable = fmap (onMode $ noHaskellAnnots . prefIndent) (modeTable defaultConfig),- configUI = (configUI defaultConfig)- {- configTheme = defaultLightTheme- }+ configUI = configUI defaultConfig } extendedVimKeymap = defKeymap `override` \super self -> super
tests/IDE/TextEditor/Tests.hs view
@@ -137,7 +137,9 @@ -> IO Bool allEditors test = allM id [ doTest GtkSourceView+#ifdef MIN_VERSION_yi , doTest Yi+#endif , doTest CodeMirror] where doTest :: forall editor. (TextEditor editor, Show editor) => editor -> IO Bool