diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -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! diff --git a/data/candy-hasklig.lkshc b/data/candy-hasklig.lkshc new file mode 100644 --- /dev/null +++ b/data/candy-hasklig.lkshc @@ -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 + + diff --git a/data/candy.lkshc b/data/candy.lkshc --- a/data/candy.lkshc +++ b/data/candy.lkshc @@ -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 diff --git a/data/leksah.menu b/data/leksah.menu --- a/data/leksah.menu +++ b/data/leksah.menu @@ -65,11 +65,19 @@ + + + + + + + + @@ -81,6 +89,7 @@ + @@ -183,6 +192,7 @@ + diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -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) diff --git a/osx/makedmg.sh b/osx/makedmg.sh --- a/osx/makedmg.sh +++ b/osx/makedmg.sh @@ -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 diff --git a/pics/ide_js.png b/pics/ide_js.png new file mode 100644 Binary files /dev/null and b/pics/ide_js.png differ diff --git a/scripts/stage.sh b/scripts/stage.sh --- a/scripts/stage.sh +++ b/scripts/stage.sh @@ -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 diff --git a/src/Distribution/PackageDescription/ParseCopied.hs b/src/Distribution/PackageDescription/ParseCopied.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/ParseCopied.hs +++ /dev/null @@ -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." ---} - diff --git a/src/Distribution/PackageDescription/PrettyPrintCopied.hs b/src/Distribution/PackageDescription/PrettyPrintCopied.hs deleted file mode 100644 --- a/src/Distribution/PackageDescription/PrettyPrintCopied.hs +++ /dev/null @@ -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 - - - diff --git a/src/IDE/BufferMode.hs b/src/IDE/BufferMode.hs --- a/src/IDE/BufferMode.hs +++ b/src/IDE/BufferMode.hs @@ -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 diff --git a/src/IDE/Build.hs b/src/IDE/Build.hs --- a/src/IDE/Build.hs +++ b/src/IDE/Build.hs @@ -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 diff --git a/src/IDE/Command.hs b/src/IDE/Command.hs --- a/src/IDE/Command.hs +++ b/src/IDE/Command.hs @@ -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" diff --git a/src/IDE/Command/VCS/Common.hs b/src/IDE/Command/VCS/Common.hs --- a/src/IDE/Command/VCS/Common.hs +++ b/src/IDE/Command/VCS/Common.hs @@ -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. diff --git a/src/IDE/Command/VCS/Common/Helper.hs b/src/IDE/Command/VCS/Common/Helper.hs --- a/src/IDE/Command/VCS/Common/Helper.hs +++ b/src/IDE/Command/VCS/Common/Helper.hs @@ -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) diff --git a/src/IDE/Command/VCS/Common/Workspaces.hs b/src/IDE/Command/VCS/Common/Workspaces.hs --- a/src/IDE/Command/VCS/Common/Workspaces.hs +++ b/src/IDE/Command/VCS/Common/Workspaces.hs @@ -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) diff --git a/src/IDE/Command/VCS/Mercurial.hs b/src/IDE/Command/VCS/Mercurial.hs --- a/src/IDE/Command/VCS/Mercurial.hs +++ b/src/IDE/Command/VCS/Mercurial.hs @@ -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 = [ diff --git a/src/IDE/Command/VCS/SVN.hs b/src/IDE/Command/VCS/SVN.hs --- a/src/IDE/Command/VCS/SVN.hs +++ b/src/IDE/Command/VCS/SVN.hs @@ -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,()) diff --git a/src/IDE/Command/VCS/Types.hs b/src/IDE/Command/VCS/Types.hs --- a/src/IDE/Command/VCS/Types.hs +++ b/src/IDE/Command/VCS/Types.hs @@ -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 diff --git a/src/IDE/Core/State.hs b/src/IDE/Core/State.hs --- a/src/IDE/Core/State.hs +++ b/src/IDE/Core/State.hs @@ -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 diff --git a/src/IDE/Core/Types.hs b/src/IDE/Core/Types.hs --- a/src/IDE/Core/Types.hs +++ b/src/IDE/Core/Types.hs @@ -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 diff --git a/src/IDE/Debug.hs b/src/IDE/Debug.hs --- a/src/IDE/Debug.hs +++ b/src/IDE/Debug.hs @@ -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 diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs --- a/src/IDE/Find.hs +++ b/src/IDE/Find.hs @@ -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" diff --git a/src/IDE/GUIHistory.hs b/src/IDE/GUIHistory.hs --- a/src/IDE/GUIHistory.hs +++ b/src/IDE/GUIHistory.hs @@ -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 diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs --- a/src/IDE/ImportTool.hs +++ b/src/IDE/ImportTool.hs @@ -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" diff --git a/src/IDE/Keymap.hs b/src/IDE/Keymap.hs --- a/src/IDE/Keymap.hs +++ b/src/IDE/Keymap.hs @@ -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 [] diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -334,6 +334,7 @@ , vcsData = (Map.empty, Nothing) , logLaunches = Map.empty , autoCommand = return () + , autoURI = Nothing } ideR <- newIORef ide menuDescription' <- menuDescription diff --git a/src/IDE/LogRef.hs b/src/IDE/LogRef.hs --- a/src/IDE/LogRef.hs +++ b/src/IDE/LogRef.hs @@ -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 diff --git a/src/IDE/Metainfo/Provider.hs b/src/IDE/Metainfo/Provider.hs --- a/src/IDE/Metainfo/Provider.hs +++ b/src/IDE/Metainfo/Provider.hs @@ -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 -> diff --git a/src/IDE/NotebookFlipper.hs b/src/IDE/NotebookFlipper.hs --- a/src/IDE/NotebookFlipper.hs +++ b/src/IDE/NotebookFlipper.hs @@ -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 diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -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 diff --git a/src/IDE/Pane/Breakpoints.hs b/src/IDE/Pane/Breakpoints.hs --- a/src/IDE/Pane/Breakpoints.hs +++ b/src/IDE/Pane/Breakpoints.hs @@ -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") diff --git a/src/IDE/Pane/Errors.hs b/src/IDE/Pane/Errors.hs --- a/src/IDE/Pane/Errors.hs +++ b/src/IDE/Pane/Errors.hs @@ -1,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 diff --git a/src/IDE/Pane/Files.hs b/src/IDE/Pane/Files.hs --- a/src/IDE/Pane/Files.hs +++ b/src/IDE/Pane/Files.hs @@ -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 diff --git a/src/IDE/Pane/Grep.hs b/src/IDE/Pane/Grep.hs --- a/src/IDE/Pane/Grep.hs +++ b/src/IDE/Pane/Grep.hs @@ -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 diff --git a/src/IDE/Pane/HLint.hs b/src/IDE/Pane/HLint.hs --- a/src/IDE/Pane/HLint.hs +++ b/src/IDE/Pane/HLint.hs @@ -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 diff --git a/src/IDE/Pane/Info.hs b/src/IDE/Pane/Info.hs --- a/src/IDE/Pane/Info.hs +++ b/src/IDE/Pane/Info.hs @@ -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 diff --git a/src/IDE/Pane/Log.hs b/src/IDE/Pane/Log.hs --- a/src/IDE/Pane/Log.hs +++ b/src/IDE/Pane/Log.hs @@ -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 diff --git a/src/IDE/Pane/Modules.hs b/src/IDE/Pane/Modules.hs --- a/src/IDE/Pane/Modules.hs +++ b/src/IDE/Pane/Modules.hs @@ -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 diff --git a/src/IDE/Pane/PackageEditor.hs b/src/IDE/Pane/PackageEditor.hs --- a/src/IDE/Pane/PackageEditor.hs +++ b/src/IDE/Pane/PackageEditor.hs @@ -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 diff --git a/src/IDE/Pane/PackageFlags.hs b/src/IDE/Pane/PackageFlags.hs --- a/src/IDE/Pane/PackageFlags.hs +++ b/src/IDE/Pane/PackageFlags.hs @@ -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 diff --git a/src/IDE/Pane/Preferences.hs b/src/IDE/Pane/Preferences.hs --- a/src/IDE/Pane/Preferences.hs +++ b/src/IDE/Pane/Preferences.hs @@ -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") diff --git a/src/IDE/Pane/Search.hs b/src/IDE/Pane/Search.hs --- a/src/IDE/Pane/Search.hs +++ b/src/IDE/Pane/Search.hs @@ -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") diff --git a/src/IDE/Pane/SourceBuffer.hs b/src/IDE/Pane/SourceBuffer.hs --- a/src/IDE/Pane/SourceBuffer.hs +++ b/src/IDE/Pane/SourceBuffer.hs @@ -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) diff --git a/src/IDE/Pane/Trace.hs b/src/IDE/Pane/Trace.hs --- a/src/IDE/Pane/Trace.hs +++ b/src/IDE/Pane/Trace.hs @@ -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 diff --git a/src/IDE/Pane/Variables.hs b/src/IDE/Pane/Variables.hs --- a/src/IDE/Pane/Variables.hs +++ b/src/IDE/Pane/Variables.hs @@ -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 diff --git a/src/IDE/Pane/WebKit/Documentation.hs b/src/IDE/Pane/WebKit/Documentation.hs --- a/src/IDE/Pane/WebKit/Documentation.hs +++ b/src/IDE/Pane/WebKit/Documentation.hs @@ -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 diff --git a/src/IDE/Pane/WebKit/Output.hs b/src/IDE/Pane/WebKit/Output.hs --- a/src/IDE/Pane/WebKit/Output.hs +++ b/src/IDE/Pane/WebKit/Output.hs @@ -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 diff --git a/src/IDE/Pane/Workspace.hs b/src/IDE/Pane/Workspace.hs --- a/src/IDE/Pane/Workspace.hs +++ b/src/IDE/Pane/Workspace.hs @@ -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 diff --git a/src/IDE/PaneGroups.hs b/src/IDE/PaneGroups.hs --- a/src/IDE/PaneGroups.hs +++ b/src/IDE/PaneGroups.hs @@ -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 () diff --git a/src/IDE/Sandbox.hs b/src/IDE/Sandbox.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Sandbox.hs @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Sandbox +-- Copyright : 2007-2014 Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GPL +-- +-- Maintainer : Juergen Nicklisch-Franken +-- 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) + diff --git a/src/IDE/TextEditor/Class.hs b/src/IDE/TextEditor/Class.hs --- a/src/IDE/TextEditor/Class.hs +++ b/src/IDE/TextEditor/Class.hs @@ -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 diff --git a/src/IDE/TextEditor/CodeMirror.hs b/src/IDE/TextEditor/CodeMirror.hs --- a/src/IDE/TextEditor/CodeMirror.hs +++ b/src/IDE/TextEditor/CodeMirror.hs @@ -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 diff --git a/src/IDE/TextEditor/Yi.hs b/src/IDE/TextEditor/Yi.hs --- a/src/IDE/TextEditor/Yi.hs +++ b/src/IDE/TextEditor/Yi.hs @@ -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 diff --git a/src/IDE/Utils/ExternalTool.hs b/src/IDE/Utils/ExternalTool.hs --- a/src/IDE/Utils/ExternalTool.hs +++ b/src/IDE/Utils/ExternalTool.hs @@ -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 diff --git a/src/IDE/Utils/ServerConnection.hs b/src/IDE/Utils/ServerConnection.hs --- a/src/IDE/Utils/ServerConnection.hs +++ b/src/IDE/Utils/ServerConnection.hs @@ -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 diff --git a/src/IDE/Workspaces.hs b/src/IDE/Workspaces.hs --- a/src/IDE/Workspaces.hs +++ b/src/IDE/Workspaces.hs @@ -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) diff --git a/src/IDE/Workspaces/Writer.hs b/src/IDE/Workspaces/Writer.hs --- a/src/IDE/Workspaces/Writer.hs +++ b/src/IDE/Workspaces/Writer.hs @@ -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] diff --git a/src/IDE/YiConfig.hs b/src/IDE/YiConfig.hs --- a/src/IDE/YiConfig.hs +++ b/src/IDE/YiConfig.hs @@ -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 diff --git a/tests/IDE/TextEditor/Tests.hs b/tests/IDE/TextEditor/Tests.hs --- a/tests/IDE/TextEditor/Tests.hs +++ b/tests/IDE/TextEditor/Tests.hs @@ -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