leksah 0.10.0.4 → 0.12.0.3
raw patch · 56 files changed
+7801/−2568 lines, 56 filesdep +QuickCheckdep +enumeratordep +giodep −ige-mac-integrationdep −process-leksahdep ~Cabaldep ~arraydep ~base
Dependencies added: QuickCheck, enumerator, gio, gtk-mac-integration, text, transformers
Dependencies removed: ige-mac-integration, process-leksah
Dependency ranges changed: Cabal, array, base, deepseq, filepath, ghc, leksah, leksah-server, ltk, old-time, pretty, time, unix
Files
- data/leksah-welcome/Setup.lhs +6/−0
- data/leksah-welcome/leksah-welcome.cabal +26/−0
- data/leksah-welcome/src/Main.hs +75/−0
- data/leksah.menu +3/−1
- data/main.lksht +49/−0
- data/prefs.lkshp +4/−2
- data/prefscoll.lkshp +1/−1
- language-specs/cassius.lang +529/−0
- language-specs/hamlet.lang +201/−0
- language-specs/haskell-literate.lang +58/−0
- language-specs/haskell.lang +270/−0
- language-specs/julius.lang +350/−0
- language-specs/lucius.lang +528/−0
- leksah.cabal +61/−31
- src/Distribution/PackageDescription/ParseCopied.hs +1206/−0
- src/Distribution/PackageDescription/PrettyPrintCopied.hs +238/−0
- src/IDE/BufferMode.hs +66/−24
- src/IDE/Build.hs +143/−103
- src/IDE/Command.hs +54/−33
- src/IDE/Completion.hs +14/−13
- src/IDE/Core/State.hs +39/−5
- src/IDE/Core/Types.hs +31/−7
- src/IDE/Debug.hs +36/−36
- src/IDE/Find.hs +84/−23
- src/IDE/ImportTool.hs +425/−399
- src/IDE/Keymap.hs +1/−1
- src/IDE/Leksah.hs +55/−26
- src/IDE/LogRef.hs +77/−66
- src/IDE/Metainfo/Provider.hs +11/−9
- src/IDE/NotebookFlipper.hs +1/−1
- src/IDE/OSX.hs +4/−4
- src/IDE/Package.hs +258/−121
- src/IDE/Pane/Breakpoints.hs +3/−3
- src/IDE/Pane/Errors.hs +3/−3
- src/IDE/Pane/Files.hs +262/−0
- src/IDE/Pane/Grep.hs +110/−50
- src/IDE/Pane/Info.hs +20/−6
- src/IDE/Pane/Log.hs +4/−4
- src/IDE/Pane/Modules.hs +9/−5
- src/IDE/Pane/PackageEditor.hs +1388/−1168
- src/IDE/Pane/PackageFlags.hs +20/−13
- src/IDE/Pane/Preferences.hs +26/−7
- src/IDE/Pane/Search.hs +256/−205
- src/IDE/Pane/SourceBuffer.hs +171/−64
- src/IDE/Pane/Trace.hs +10/−6
- src/IDE/Pane/Variables.hs +67/−38
- src/IDE/Pane/Workspace.hs +6/−3
- src/IDE/PaneGroups.hs +1/−1
- src/IDE/Session.hs +6/−2
- src/IDE/SourceCandy.hs +12/−23
- src/IDE/Statusbar.hs +1/−1
- src/IDE/SymbolNavigation.hs +334/−0
- src/IDE/TextEditor.hs +113/−23
- src/IDE/Utils/GUIUtils.hs +22/−2
- src/IDE/Utils/ServerConnection.hs +9/−3
- src/IDE/Workspaces.hs +44/−32
+ data/leksah-welcome/Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ data/leksah-welcome/leksah-welcome.cabal view
@@ -0,0 +1,26 @@+name: leksah-welcome+version: 0.12.0.3+cabal-version: >=1.2+build-type: Simple+license: AllRightsReserved+license-file: ""+description:+ .+ .+ .+ .+data-dir: ""++executable leksah-welcome+ build-depends: QuickCheck -any, base -any+ main-is: Main.hs+ buildable: True+ hs-source-dirs: src++test-suite test-leksah-welcome+ build-depends: QuickCheck -any, base -any+ type: exitcode-stdio-1.0+ main-is: Main.hs+ buildable: True+ cpp-options: -DMAIN_FUNCTION=testMain+ hs-source-dirs: src
+ data/leksah-welcome/src/Main.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE CPP, TemplateHaskell #-}+-- Welcome to Leksah. This is a quick sample package for you to+-- try things out with. We hope it will be useful for those new+-- to Haskell or just new to Leksah.++-- If you are new to haskell then here are some great sites to visit+-- http://learnyouahaskell.com/+-- http://tryhaskell.org/+-- http://book.realworldhaskell.org/++-- To build this package use+-- * Just make a change while background build is activated+-- * Ctrl+B (OS X Command+B)+-- * Package -> Build++-- When you are ready to create your own workspace and package.+-- * Package -> New+-- * When asked for a root folder for your package select a new folder+-- with the desired name of your package++-- This is the "Main" module and it exports a "main" function+module Main (+ main+) where++-- Next we are importing some things from other modules.+-- Leksah can normally addd these imports for you, just+-- press Ctrl+R (OS X Command+R)+import Control.Monad (unless)+import Data.List (stripPrefix)+import System.Exit (exitFailure)+import Test.QuickCheck.All (quickCheckAll)++-- Simple function to create a hello message.+hello s = "Hello " ++ s++-- QuickCheck is a great tool for writing tests.+-- The following tells QuickCheck that if you strip "Hello "+-- from the start of hello s you will be left with s (for any s).+-- QuickCheck will create the test data needed to run this test.+prop_hello s = stripPrefix "Hello " (hello s) == Just s++-- exeMain : Executable Entry Point+-- --------------------------------+-- Here is the entry point for the leksah-welcome executable+--+-- To run it+-- * Select Leksah menu item Package -> Run (or the cogs on the toolbar)+-- * Select "exeMain" and press Ctrl+Enter to run them in ghci+-- * Run "leksah-wellcome" from the command line+exeMain = do+ putStrLn (hello "World")++-- testMain : Unit Testing Entry Point+-- -----------------------------------+-- This is the main function uses by the cabal test+--+-- To run these tests+-- * Select Leksah menu item Package -> Test+-- * Select the tick icon on the Leksa toolbar (to enable "cabal test" during builds)+-- * Select "testMain" and press Ctrl+Enter to run them in ghci+-- * Run "cabal test" from the command line in the package directory+testMain = do+ allPass <- $quickCheckAll -- Run QuickCheck on all prop_ functions+ unless allPass exitFailure++-- This is a clunky, but portable, way to use the same Main module file+-- for both an application and for unit tests.+-- MAIN_FUNCTION is preprocessor macro set to exeMain or testMain.+-- That way we can use the same file for both an application and for tests.+#ifndef MAIN_FUNCTION+#define MAIN_FUNCTION exeMain+#endif+main = MAIN_FUNCTION+
@@ -66,8 +66,8 @@ <menuitem name="_Build" action="BuildPackage" /> <menuitem name="_Run" action="RunPackage" /> <separator/>+ <menuitem name="_Install Dependencies" action="InstallDependenciesPackage" /> <menuitem name="C_opy" action="CopyPackage" />- <menuitem name="_Install" action="InstallPackage" /> <menuitem name="Re_gister" action="RegisterPackage" /> <menuitem name="Test" action="TestPackage" /> <menuitem name="SDist" action="SdistPackage" />@@ -94,6 +94,7 @@ <menuitem name="_Browser" action="ShowBrowser" /> <menuitem name="_Debugger" action="ShowDebugger" /> <menuitem name="_Errors" action="ShowErrors" />+ <menuitem name="_Files" action="ShowFiles" /> <menuitem name="_Grep" action="ShowGrep" /> <menuitem name="_Log" action="ShowLog" /> <menuitem name="_Search" action="ShowSearch" />@@ -170,6 +171,7 @@ <toolitem name="Forward" action="ViewHistoryForth"/> <separator/> <toolitem name="BackgroundBuild" action="BackgroundBuildToggled"/>+ <toolitem name="RunUnitTests" action="RunUnitTestsToggled"/> <toolitem name="MakeMode" action="MakeModeToggled"/> <separator/> <toolitem name="Update Project" action="UpdateMetadataCurrent" />
+ data/main.lksht view
@@ -0,0 +1,49 @@+{-# LANGUAGE CPP, TemplateHaskell #-}+-----------------------------------------------------------------------------+--+-- Module : @ModuleName@+-- Copyright : @Copyright@+-- License : @License@+--+-- Maintainer : @Maintainer@+-- Stability : @Stability@+-- Portability : @Portability@+--+-- |+--+-----------------------------------------------------------------------------++module @ModuleName@ (+ main+) where++import Control.Monad (unless)+import Data.List (stripPrefix)+import System.Exit (exitFailure)+import Test.QuickCheck.All (quickCheckAll)++-- Simple function to create a hello message.+hello s = "Hello " ++ s++-- Tell QuickCheck that if you strip "Hello " from the start of+-- hello s you will be left with s (for any s).+prop_hello s = stripPrefix "Hello " (hello s) == Just s++-- Hello World+exeMain = do+ putStrLn (hello "World")++-- Entry point for unit tests.+testMain = do+ allPass <- $quickCheckAll -- Run QuickCheck on all prop_ functions+ unless allPass exitFailure++-- This is a clunky, but portable, way to use the same Main module file+-- for both an application and for unit tests.+-- MAIN_FUNCTION is preprocessor macro set to exeMain or testMain.+-- That way we can use the same file for both an application and for tests.+#ifndef MAIN_FUNCTION+#define MAIN_FUNCTION exeMain+#endif+main = MAIN_FUNCTION+
data/prefs.lkshp view
@@ -37,7 +37,7 @@ keymap --The name of a keymap file in a config dir Categories for panes:- [("*Debug","ToolCategory"),("*Grep","ToolCategory"),("*Log","LogCategory"),("*Search","ToolCategory"),("*Browser","ToolCategory"),("*Package","EditorCategory"),("*Flags","EditorCategory"),("*References","LogCategory"),("*Workspace","LogCategory"),("*Errors","ToolCategory")]+ [("*Debug","ToolCategory"),("*Files","ToolCategory"),("*Grep","ToolCategory"),("*Log","LogCategory"),("*Search","ToolCategory"),("*Browser","ToolCategory"),("*Package","EditorCategory"),("*Flags","EditorCategory"),("*References","LogCategory"),("*Workspace","LogCategory"),("*Errors","ToolCategory")] Pane path for category: [("EditorCategory",[SplitP LeftP]),("ToolCategory",[SplitP RightP,SplitP TopP]),("LogCategory",[SplitP RightP,SplitP BottomP])] Default pane path:@@ -45,7 +45,7 @@ Paths under which haskell sources for packages may be found: [] Unpack source for cabal packages to:- Just "~/.leksah-0.10/packageSources"+ Just "~/.leksah-0.12/packageSources" URL from which to download prebuilt metadata: "http://www.leksah.org" Strategy for downloading prebuilt metadata:@@ -64,6 +64,8 @@ True Background build: True+Run unit tests when building:+ False Make mode: True Single build without linking:
data/prefscoll.lkshp view
@@ -1,7 +1,7 @@ Paths under which haskell sources for packages may be found: [] Unpack source for cabal packages to:- Just "~/.leksah-0.10/packageSources"+ Just "~/.leksah-0.12/packageSources" URL from which to download prebuilt metadata: "http://www.leksah.org" Strategy for downloading prebuilt metadata:
+ language-specs/cassius.lang view
@@ -0,0 +1,529 @@+<?xml version="1.0" encoding="UTF-8"?>+<!--++ Author: Scott Martin <scott@coffeeblack.org>+ Copyright (C) 2004 Scott Martin <scott@coffeeblack.org>++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Library General Public+ License as published by the Free Software Foundation; either+ version 2 of the License, or (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+ Library General Public License for more details.++ You should have received a copy of the GNU Library General Public+ License along with this library; if not, write to the+ Free Software Foundation, Inc., 59 Temple Place - Suite 330,+ Boston, MA 02111-1307, USA.++-->+<!--+ Proposed language specification for CSS (Cascading Style Sheet) files.++ Reference used:+ http://www.w3.org/TR/CSS2/++ Tested with:+ http://www.simplebits.com/css/simple.css++ Submitted by++ Converted to new format with convert.py+-->+<language id="cassius" _name="Cassius" version="2.0" _section="Others">+ <metadata>+ <property name="mimetypes">text/css</property>+ <property name="globs">*.cassius</property>+ <property name="block-comment-start">/*</property>+ <property name="block-comment-end">*/</property>+ </metadata>++ <styles>+ <style id="haskell-embed" _name="Haskell" map-to="def:preprocessor"/>+ <style id="comment" _name="Comment" map-to="def:comment"/>+ <style id="error" _name="Error" map-to="def:error"/>+ <style id="others-2" _name="Others 2"/>+ <style id="string" _name="String" map-to="def:string"/>+ <style id="color" _name="Color" map-to="def:base-n-integer"/>+ <style id="others-3" _name="Others 3"/>+ <style id="function" _name="Function" map-to="def:function"/>+ <style id="decimal" _name="Decimal" map-to="def:decimal"/>+ <style id="dimension" _name="Dimension" map-to="def:floating-point"/>+ <style id="known-property-values" _name="Known Property Value" map-to="def:type"/>+ <style id="at-rules" _name="at-rules" map-to="def:keyword"/>+ <style id="keyword" _name="Keyword" map-to="def:keyword"/>+ </styles>++ <definitions>++ <context id="comment" style-ref="comment" class="comment" class-disabled="no-spell-check">+ <start>/\*</start>+ <end>\*/</end>+ <include>+ <context style-ref="error" extend-parent="false">+ <match>/\*</match>+ </context>+ <context ref="def:in-comment"/>+ <context ref="haskell-embed"/>+ </include>+ </context>++ <context id="close-comment-outside-comment" style-ref="error">+ <match>\*/(?!\*)</match>+ </context>++ <context id="unicode-character-reference" style-ref="others-2">+ <match>\\([a-fA-F0-9]{1,5}[ \t]|[a-fA-F0-9]{6})</match>+ </context>++ <context id="selector-pseudo-elements" style-ref="function">+ <keyword>first-line</keyword>+ <keyword>first-letter</keyword>+ <keyword>before</keyword>+ <keyword>after</keyword>+ </context>++ <context id="selector-pseudo-classes" style-ref="function">+ <keyword>first-child</keyword>+ <keyword>link</keyword>+ <keyword>visited</keyword>+ <keyword>hover</keyword>+ <keyword>active</keyword>+ <keyword>focus</keyword>+ <keyword>lang</keyword>+ </context>++ <context id="at-rules" style-ref="at-rules">+ <prefix>^[ \t]*@</prefix>+ <keyword>charset</keyword>+ <keyword>font-face</keyword>+ <keyword>media</keyword>+ <keyword>page</keyword>+ <keyword>import</keyword>+ </context>++ <context id="hexadecimal-color" style-ref="color">+ <match>#([a-fA-F0-9]{6}|[a-fA-F0-9]{3})\b</match>+ </context>++ <context id="named-color" style-ref="color">+ <keyword>aqua</keyword>+ <keyword>black</keyword>+ <keyword>blue</keyword>+ <keyword>fuchsia</keyword>+ <keyword>gray</keyword>+ <keyword>green</keyword>+ <keyword>lime</keyword>+ <keyword>maroon</keyword>+ <keyword>navy</keyword>+ <keyword>olive</keyword>+ <keyword>orange</keyword>+ <keyword>purple</keyword>+ <keyword>red</keyword>+ <keyword>silver</keyword>+ <keyword>teal</keyword>+ <keyword>white</keyword>+ <keyword>yellow</keyword>+ </context>++ <context id="function" style-ref="function">+ <start>[a-zA-Z][a-z0-9-]+\(</start>+ <end>\)</end>+ <include>+ <context ref="def:escape"/>+ <context ref="def:line-continue"/>+ </include>+ </context>++ <context id="dimension" style-ref="dimension">+ <match>[\+-]?([0-9]+|[0-9]*\.[0-9]+)(%|e(m|x)|p(x|t|c)|in|ft|(m|c)m|k?Hz|deg|g?rad|m?s)</match>+ </context>++ <context id="number" style-ref="decimal">+ <match>\b(0|[\+-]?[1-9][0-9]*)</match>+ </context>++ <context id="unicode-range" style-ref="others-2">+ <match>[uU]\+[a-fA-F0-9]{1,6}(-[a-fA-F0-9]{1,6})?</match>+ </context>++ <context id="importance-modifier" style-ref="keyword">+ <match>\![ \t]*important</match>+ </context>++ <context id="property-names" style-ref="keyword">+ <suffix>(?=\s*:)</suffix>+ <keyword>azimuth</keyword>+ <keyword>background-attachment</keyword>+ <keyword>background-color</keyword>+ <keyword>background-image</keyword>+ <keyword>background-position</keyword>+ <keyword>background-repeat</keyword>+ <keyword>background</keyword>+ <keyword>border-bottom-color</keyword>+ <keyword>border-bottom-style</keyword>+ <keyword>border-bottom-width</keyword>+ <keyword>border-bottom</keyword>+ <keyword>border-collapse</keyword>+ <keyword>border-color</keyword>+ <keyword>border-left-color</keyword>+ <keyword>border-left-style</keyword>+ <keyword>border-left-width</keyword>+ <keyword>border-left</keyword>+ <keyword>border-right-color</keyword>+ <keyword>border-right-style</keyword>+ <keyword>border-right-width</keyword>+ <keyword>border-right</keyword>+ <keyword>border-spacing</keyword>+ <keyword>border-style</keyword>+ <keyword>border-top-color</keyword>+ <keyword>border-top-style</keyword>+ <keyword>border-top-width</keyword>+ <keyword>border-top</keyword>+ <keyword>border-width</keyword>+ <keyword>border</keyword>+ <keyword>bottom</keyword>+ <keyword>caption-side</keyword>+ <keyword>clear</keyword>+ <keyword>clip</keyword>+ <keyword>color</keyword>+ <keyword>content</keyword>+ <keyword>counter-increment</keyword>+ <keyword>counter-reset</keyword>+ <keyword>cue-after</keyword>+ <keyword>cue-before</keyword>+ <keyword>cue</keyword>+ <keyword>cursor</keyword>+ <keyword>direction</keyword>+ <keyword>display</keyword>+ <keyword>elevation</keyword>+ <keyword>empty-cells</keyword>+ <keyword>float</keyword>+ <keyword>font-family</keyword>+ <keyword>font-size-adjust</keyword>+ <keyword>font-size</keyword>+ <keyword>font-style</keyword>+ <keyword>font-variant</keyword>+ <keyword>font-weight</keyword>+ <keyword>font</keyword>+ <keyword>height</keyword>+ <keyword>left</keyword>+ <keyword>letter-spacing</keyword>+ <keyword>line-height</keyword>+ <keyword>list-style-image</keyword>+ <keyword>list-style-position</keyword>+ <keyword>list-style-type</keyword>+ <keyword>list-style</keyword>+ <keyword>margin-bottom</keyword>+ <keyword>margin-left</keyword>+ <keyword>margin-right</keyword>+ <keyword>margin-top</keyword>+ <keyword>margin</keyword>+ <keyword>marker-offset</keyword>+ <keyword>marks</keyword>+ <keyword>max-height</keyword>+ <keyword>max-width</keyword>+ <keyword>min-height</keyword>+ <keyword>min-width</keyword>+ <keyword>orphans</keyword>+ <keyword>outline-color</keyword>+ <keyword>outline-style</keyword>+ <keyword>outline-width</keyword>+ <keyword>outline</keyword>+ <keyword>overflow</keyword>+ <keyword>padding-bottom</keyword>+ <keyword>padding-left</keyword>+ <keyword>padding-right</keyword>+ <keyword>padding-top</keyword>+ <keyword>padding</keyword>+ <keyword>page-break-after</keyword>+ <keyword>page-break-before</keyword>+ <keyword>page-break-inside</keyword>+ <keyword>page</keyword>+ <keyword>pause-after</keyword>+ <keyword>pause-before</keyword>+ <keyword>pause</keyword>+ <keyword>pitch-range</keyword>+ <keyword>pitch</keyword>+ <keyword>play-during</keyword>+ <keyword>position</keyword>+ <keyword>quotes</keyword>+ <keyword>richness</keyword>+ <keyword>right</keyword>+ <keyword>size</keyword>+ <keyword>speak-header</keyword>+ <keyword>speak-numerical</keyword>+ <keyword>speak-punctuation</keyword>+ <keyword>speak</keyword>+ <keyword>speech-rate</keyword>+ <keyword>stress</keyword>+ <keyword>table-layout</keyword>+ <keyword>text-align</keyword>+ <keyword>text-decoration</keyword>+ <keyword>text-indent</keyword>+ <keyword>text-shadow</keyword>+ <keyword>text-transform</keyword>+ <keyword>top</keyword>+ <keyword>unicode-bidi</keyword>+ <keyword>vertical-align</keyword>+ <keyword>visibility</keyword>+ <keyword>voice-family</keyword>+ <keyword>volume</keyword>+ <keyword>white-space</keyword>+ <keyword>widows</keyword>+ <keyword>width</keyword>+ <keyword>word-spacing</keyword>+ <keyword>z-index</keyword>+ </context>++ <context id="known-property-values" style-ref="known-property-values">+ <keyword>above</keyword>+ <keyword>absolute</keyword>+ <keyword>always</keyword>+ <keyword>armenian</keyword>+ <keyword>auto</keyword>+ <keyword>avoid</keyword>+ <keyword>baseline</keyword>+ <keyword>behind</keyword>+ <keyword>below</keyword>+ <keyword>bidi-override</keyword>+ <keyword>blink</keyword>+ <keyword>block</keyword>+ <keyword>bolder</keyword>+ <keyword>bold</keyword>+ <keyword>bottom</keyword>+ <keyword>capitalize</keyword>+ <keyword>center-left</keyword>+ <keyword>center-right</keyword>+ <keyword>center</keyword>+ <keyword>circle</keyword>+ <keyword>cjk-ideographic</keyword>+ <keyword>close-quote</keyword>+ <keyword>code</keyword>+ <keyword>collapse</keyword>+ <keyword>compact</keyword>+ <keyword>condensed</keyword>+ <keyword>continuous</keyword>+ <keyword>crop</keyword>+ <keyword>crosshair</keyword>+ <keyword>cross</keyword>+ <keyword>cue-after</keyword>+ <keyword>cue-before</keyword>+ <keyword>cursive</keyword>+ <keyword>dashed</keyword>+ <keyword>decimal</keyword>+ <keyword>decimal-leading-zero</keyword>+ <keyword>default</keyword>+ <keyword>digits</keyword>+ <keyword>disc</keyword>+ <keyword>dotted</keyword>+ <keyword>double</keyword>+ <keyword>embed</keyword>+ <keyword>e-resize</keyword>+ <keyword>expanded</keyword>+ <keyword>extra-condensed</keyword>+ <keyword>extra-expanded</keyword>+ <keyword>fantasy</keyword>+ <keyword>far-left</keyword>+ <keyword>far-right</keyword>+ <keyword>faster</keyword>+ <keyword>fast</keyword>+ <keyword>fixed</keyword>+ <keyword>fixed</keyword>+ <keyword>georgian</keyword>+ <keyword>groove</keyword>+ <keyword>hebrew</keyword>+ <keyword>help</keyword>+ <keyword>hidden</keyword>+ <keyword>hide</keyword>+ <keyword>higher</keyword>+ <keyword>high</keyword>+ <keyword>hiragana-iroha</keyword>+ <keyword>hiragana</keyword>+ <keyword>inherit</keyword>+ <keyword>inline</keyword>+ <keyword>inline-table</keyword>+ <keyword>inset</keyword>+ <keyword>inside</keyword>+ <keyword>invert</keyword>+ <keyword>italic</keyword>+ <keyword>justify</keyword>+ <keyword>katakana-iroha</keyword>+ <keyword>katakana</keyword>+ <keyword>landscape</keyword>+ <keyword>large</keyword>+ <keyword>larger</keyword>+ <keyword>left</keyword>+ <keyword>left-side</keyword>+ <keyword>leftwards</keyword>+ <keyword>level</keyword>+ <keyword>lighter</keyword>+ <keyword>line-through</keyword>+ <keyword>list-item</keyword>+ <keyword>loud</keyword>+ <keyword>lower-alpha</keyword>+ <keyword>lowercase</keyword>+ <keyword>lower-greek</keyword>+ <keyword>lower-latin</keyword>+ <keyword>lower-roman</keyword>+ <keyword>lower</keyword>+ <keyword>low</keyword>+ <keyword>ltr</keyword>+ <keyword>marker</keyword>+ <keyword>medium</keyword>+ <keyword>medium</keyword>+ <keyword>middle</keyword>+ <keyword>mix</keyword>+ <keyword>monospace</keyword>+ <keyword>move</keyword>+ <keyword>narrower</keyword>+ <keyword>ne-resize</keyword>+ <keyword>no-close-quote</keyword>+ <keyword>none</keyword>+ <keyword>no-open-quote</keyword>+ <keyword>no-repeat</keyword>+ <keyword>normal</keyword>+ <keyword>nowrap</keyword>+ <keyword>n-resize</keyword>+ <keyword>nw-resize</keyword>+ <keyword>oblique</keyword>+ <keyword>once</keyword>+ <keyword>open-quote</keyword>+ <keyword>outset</keyword>+ <keyword>outside</keyword>+ <keyword>overline</keyword>+ <keyword>pointer</keyword>+ <keyword>portait</keyword>+ <keyword>pre</keyword>+ <keyword>relative</keyword>+ <keyword>repeat-x</keyword>+ <keyword>repeat-y</keyword>+ <keyword>repeat</keyword>+ <keyword>ridge</keyword>+ <keyword>right-side</keyword>+ <keyword>right</keyword>+ <keyword>rightwards</keyword>+ <keyword>rlt</keyword>+ <keyword>run-in</keyword>+ <keyword>sans-serif</keyword>+ <keyword>scroll</keyword>+ <keyword>scroll</keyword>+ <keyword>semi-condensed</keyword>+ <keyword>semi-expanded</keyword>+ <keyword>separate</keyword>+ <keyword>se-resize</keyword>+ <keyword>serif</keyword>+ <keyword>show</keyword>+ <keyword>silent</keyword>+ <keyword>slower</keyword>+ <keyword>slow</keyword>+ <keyword>small-caps</keyword>+ <keyword>smaller</keyword>+ <keyword>small</keyword>+ <keyword>soft</keyword>+ <keyword>solid</keyword>+ <keyword>spell-out</keyword>+ <keyword>square</keyword>+ <keyword>s-resize</keyword>+ <keyword>static</keyword>+ <keyword>sub</keyword>+ <keyword>super</keyword>+ <keyword>sw-resize</keyword>+ <keyword>table-caption</keyword>+ <keyword>table-cell</keyword>+ <keyword>table-column-group</keyword>+ <keyword>table-column</keyword>+ <keyword>table-footer-group</keyword>+ <keyword>table-header-group</keyword>+ <keyword>table-row-group</keyword>+ <keyword>table-row</keyword>+ <keyword>table</keyword>+ <keyword>text-bottom</keyword>+ <keyword>text</keyword>+ <keyword>text-top</keyword>+ <keyword>thick</keyword>+ <keyword>thin</keyword>+ <keyword>top</keyword>+ <keyword>top</keyword>+ <keyword>transparent</keyword>+ <keyword>ultra-condensed</keyword>+ <keyword>ultra-expanded</keyword>+ <keyword>underline</keyword>+ <keyword>upper-alpha</keyword>+ <keyword>uppercase</keyword>+ <keyword>upper-latin</keyword>+ <keyword>upper-roman</keyword>+ <keyword>visible</keyword>+ <keyword>wait</keyword>+ <keyword>wider</keyword>+ <keyword>w-resize</keyword>+ <keyword>x-fast</keyword>+ <keyword>x-high</keyword>+ <keyword>x-large</keyword>+ <keyword>x-loud</keyword>+ <keyword>x-low</keyword>+ <keyword>x-slow</keyword>+ <keyword>x-small</keyword>+ <keyword>x-soft</keyword>+ <keyword>xx-large</keyword>+ <keyword>xx-small</keyword>+ </context>++ <context id="punctuators" style-ref="others-3">+ <match>[();,]</match>+ </context>++ <context id="attribute-value-delimiters" style-ref="others-2" extend-parent="false">+ <match>(\[|\])</match>+ </context>++ <context id="operators" style-ref="function" extend-parent="false">+ <match>[@%~|!=]</match>+ </context>++ <context id="selector-grammar" style-ref="others-3">+ <match>[*#.>+]</match>+ </context>++ <context id="haskell-embed">+ <start>[#@^]\{</start>+ <end>\}</end>+ <include>+ <context sub-pattern="0" where="start" style-ref="haskell-embed"/>+ <context sub-pattern="0" where="end" style-ref="haskell-embed"/>+ <context ref="haskell:body"/>+ </include>+ </context>++ <context id="cassius" class="no-spell-check">+ <include>+ <context ref="haskell-embed"/>+ <context ref="def:string"/>+ <context ref="def:single-quoted-string"/>+ <context ref="comment"/>+ <context ref="close-comment-outside-comment"/>+ <context ref="unicode-character-reference"/>+ <context ref="selector-pseudo-elements"/>+ <context ref="selector-pseudo-classes"/>+ <context ref="at-rules"/>+ <context ref="hexadecimal-color"/>+ <context ref="named-color"/>+ <context ref="function"/>+ <context ref="dimension"/>+ <context ref="number"/>+ <context ref="unicode-range"/>+ <context ref="importance-modifier"/>+ <context ref="property-names"/>+ <context ref="known-property-values"/>+ <context ref="punctuators"/>+ <context ref="attribute-value-delimiters"/>+ <context ref="operators"/>+ <context ref="selector-grammar"/>+ </include>+ </context>++ </definitions>+</language>
+ language-specs/hamlet.lang view
@@ -0,0 +1,201 @@+<?xml version="1.0" encoding="UTF-8"?>+<!--++ Authors: Marco Barisione, Emanuele Aina+ Copyright (C) 2005-2007 Marco Barisione <barisione@gmail.com>+ Copyright (C) 2005-2007 Emanuele Aina++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Library General Public+ License as published by the Free Software Foundation; either+ version 2 of the License, or (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+ Library General Public License for more details.++ You should have received a copy of the GNU Library General Public+ License along with this library; if not, write to the+ Free Software Foundation, Inc., 59 Temple Place - Suite 330,+ Boston, MA 02111-1307, USA.++-->+<language id="hamlet" _name="Hamlet" version="2.0" _section="Markup">+ <metadata>+ <property name="mimetypes">text/x-hamlet</property>+ <property name="globs">*.hamlet</property>+ <property name="block-comment-start"><!--</property>+ <property name="block-comment-end">--></property>+ </metadata>++ <styles>+ <style id="haskell-embed" _name="Haskell" map-to="def:preprocessor"/>+ <style id="comment" _name="Comment" map-to="xml:comment"/>+ <style id="tag" _name="Tag" map-to="xml:element-name"/>+ <style id="attrib-name" _name="Attribute Name" map-to="xml:attribute-name"/>+ <style id="attrib-value" _name="Attribute Value" map-to="xml:attribute-value"/>+ <style id="dtd" _name="DTD" map-to="xml:doctype"/>+ <style id="error" _name="Error" map-to="xml:error"/>+ </styles>++ <default-regex-options case-sensitive="false"/>++ <definitions>+ <!-- Html comments are more permissive than xml comments -->+ <context id="comment" style-ref="comment" class="comment">+ <start><!--</start>+ <end>--\s*></end>+ <include>+ <context ref="def:in-comment"/>+ </include>+ </context>++ <context id="dtd" style-ref="dtd" class="no-spell-check">+ <start><!</start>+ <end>></end>+ </context>++ <!-- This is a placeholder context intended to be <replace>d+ in languages like php that need to embedd contexts inside+ html tags and attributes.+ -->+ <context id="embedded-lang-hook">+ <start>\%{def:never-match}</start>+ <end></end>+ </context>++ <context id="generic-tag">+ <include>++ <!-- Attribute in the form: name="value" -->+ <context id="attrib-quoted" style-ref="attrib-name" class="no-spell-check">+ <start extended="true">+ [A-Za-z0-9:_-]+ # attribute name+ \s*=\s* # "="+ (\") # string beginning+ </start>+ <end>\"</end>+ <include>+ <context sub-pattern="1" where="start" style-ref="attrib-value"/>+ <context sub-pattern="0" where="end" style-ref="attrib-value"/>+ <context id="string" extend-parent="false" end-at-line-end="true" style-ref="attrib-value" class="string" class-disabled="no-spell-check">+ <start>\%{def:always-match}</start>+ <include>+ <context ref="xml:entity"/>+ <context ref="xml:character-reference"/>+ <context ref="embedded-lang-hook"/>+ <context ref="haskell-embed"/>+ </include>+ </context>+ </include>+ </context>++ <!-- Attribute in the form: name=value -->+ <context id="attrib-unquoted" style-ref="attrib-value" class="no-spell-check">+ <start extended="true">+ [a-z0-9:_-]+ # attribute name+ \s*=\s* # "="+ </start>+ <end>(?=>|\s)</end>+ <include>+ <context sub-pattern="0" where="start" style-ref="attrib-name"/>+ <context ref="xml:entity"/>+ <context ref="xml:character-reference"/>+ <context ref="haskell-embed"/>+ </include>+ </context>++ <!-- Attribute in the form: name -->+ <context id="attrib-no-value" style-ref="attrib-name" class="no-spell-check">+ <match extended="true">+ [a-z0-9:_-]+ # attribute name+ </match>+ </context>++ <context id="attrib-id" style-ref="attrib-value" class="no-spell-check">+ <start extended="true">+ \#+ </start>+ <end>(?=>|\s)</end>+ <include>+ <context sub-pattern="0" where="start" style-ref="attrib-name"/>+ <context ref="xml:entity"/>+ <context ref="xml:character-reference"/>+ <context ref="haskell-embed"/>+ </include>+ </context>++ <context id="attrib-class" style-ref="attrib-value" class="no-spell-check">+ <start extended="true">+ \.+ </start>+ <end>(?=>|\s)</end>+ <include>+ <context sub-pattern="0" where="start" style-ref="attrib-name"/>+ <context ref="xml:entity"/>+ <context ref="xml:character-reference"/>+ <context ref="haskell-embed"/>+ </include>+ </context>++ <context ref="embedded-lang-hook"/>++ </include>+ </context>++ <context id="haskell-line" end-at-line-end="true">+ <start>^\s*\$[a-zA-Z0-9]+</start>+ <include>+ <context sub-pattern="0" where="start" style-ref="haskell-embed"/>+ <context ref="haskell:body"/>+ </include>+ </context>++ <context id="haskell-embed">+ <start>[#@^]\{</start>+ <end>\}</end>+ <include>+ <context sub-pattern="0" where="start" style-ref="haskell-embed"/>+ <context sub-pattern="0" where="end" style-ref="haskell-embed"/>+ <context ref="haskell:body"/>+ </include>+ </context>++ <context id="start-of-line" style-ref="tag" class="no-spell-check">+ <match extended="true">^\s*\\</match>+ </context>++ <context id="end-of-line" style-ref="tag" class="no-spell-check">+ <match extended="true">\#$</match>+ </context>++ <context id="tag" class="no-spell-check" end-at-line-end="true">+ <start><\s*/?\s*[a-z0-9_-]+</start>+ <end>/?\s*></end>+ <include>+ <context sub-pattern="0" where="start" style-ref="tag"/>+ <context sub-pattern="0" where="end" style-ref="tag"/>+ <context ref="generic-tag"/>+ </include>+ </context>++ <context id="hamlet">+ <include>+ <context ref="xml:doctype"/>+ <context ref="xml:entity"/>+ <context ref="xml:character-reference"/>+ <context ref="xml:cdata"/>+ <context ref="comment"/>+ <context ref="dtd"/>+ <!-- <context ref="script"/> -->+ <context ref="haskell-line"/>+ <context ref="haskell-embed"/>+ <context ref="tag"/>+ <context ref="start-of-line"/>+ <context ref="end-of-line"/>+ </include>+ </context>++ </definitions>+</language>
+ language-specs/haskell-literate.lang view
@@ -0,0 +1,58 @@+<?xml version="1.0" encoding="UTF-8"?>+<!--++ Authors: Duncan Coutts+ Copyright (C) 2007 Duncan Coutts <duncan@haskell.org>++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Library General Public+ License as published by the Free Software Foundation; either+ version 2 of the License, or (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+ Library General Public License for more details.++ You should have received a copy of the GNU Library General Public+ License along with this library; if not, write to the+ Free Software Foundation, Inc., 59 Temple Place - Suite 330,+ Boston, MA 02111-1307, USA.++-->+<language id="haskell-literate" _name="Literate Haskell" version="2.0" _section="Sources">+ <metadata>+ <property name="mimetypes">text/x-literate-haskell</property>+ <property name="globs">*.lhs</property>+ </metadata>++ <definitions>+ <context id="haskell-literate">+ <include>++ <context ref="def:shebang"/>+ <context ref="c:if0-comment"/>+ <context ref="c:include"/>+ <context ref="c:preprocessor"/>+ <context ref="def:in-comment"/>++ <context id="line-code" end-at-line-end="true">+ <start>^></start>+ <include>+ <context ref="haskell:body"/>+ </include>+ </context>++ <context id="block-code">+ <start>^\\begin\{code\}</start>+ <end>^\\end\{code\}</end>+ <include>+ <context ref="haskell:body" />+ </include>+ </context>++ </include>+ </context>++ </definitions>+</language>
+ language-specs/haskell.lang view
@@ -0,0 +1,270 @@+<?xml version="1.0" encoding="UTF-8"?>+<!--++ Authors: Duncan Coutts, Anders Carlsson+ Copyright (C) 2004, 2007 Duncan Coutts <duncan@haskell.org>+ Copyright (C) 2004 Anders Carlsson <andersca@gnome.org>++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Library General Public+ License as published by the Free Software Foundation; either+ version 2 of the License, or (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+ Library General Public License for more details.++ You should have received a copy of the GNU Library General Public+ License along with this library; if not, write to the+ Free Software Foundation, Inc., 59 Temple Place - Suite 330,+ Boston, MA 02111-1307, USA.++-->+<language id="haskell" _name="Haskell" version="2.0" _section="Sources">+ <metadata>+ <property name="mimetypes">text/x-haskell</property>+ <property name="globs">*.hs</property>+ </metadata>++ <styles>+ <style id="preprocessor" _name="Preprocessor" map-to="def:preprocessor"/>+ <style id="comment" _name="Comment" map-to="def:comment"/>+ <style id="variable" _name="Variable" />+ <style id="symbol" _name="Symbol" />+ <style id="keyword" _name="Keyword" map-to="def:keyword"/>+ <style id="type" _name="Data Type" map-to="def:type"/>+ <style id="string" _name="String" map-to="def:string"/>+ <style id="character" _name="Character" map-to="def:character"/>+ <style id="char-escape" _name="Escaped Character" map-to="def:special-char"/>+ <style id="float" _name="Float" map-to="def:floating-point"/>+ <style id="decimal" _name="Decimal" map-to="def:decimal"/>+ <style id="octal" _name="Octal" map-to="def:base-n-integer"/>+ <style id="hexadecimal" _name="Hex" map-to="def:base-n-integer"/>+ </styles>++ <definitions>+ <!-- Spec: http://haskell.org/onlinereport/lexemes.html -->++ <define-regex id="symbolchar">[!#$%&*+./>=<?@:\\^|~-]</define-regex>++ <context id="line-comment" style-ref="comment" end-at-line-end="true" class="comment" class-disabled="no-spell-check">+ <start>(?<!\%{symbolchar})--+(?!\%{symbolchar})</start>+ <include>+ <context ref="def:in-comment"/>+ <context ref="haddock:line-paragraph"/>+ <context ref="haddock:directive"/>+ </include>+ </context>++ <context id="block-comment" style-ref="comment" class="comment" class-disabled="no-spell-check">+ <start>\{-</start>+ <end>-\}</end>+ <include>+ <context ref="def:in-comment"/>+ <context ref="haddock:block-paragraph"/>+ <context ref="haddock:directive"/>+ <context ref="block-comment"/>+ </include>+ </context>++ <context id="pragma" style-ref="preprocessor">+ <start>\{-#</start>+ <end>#-\}</end>+ </context>++ <context id="haskell" class="no-spell-check">+ <include>+ <context ref="def:shebang"/>+ <context ref="c:if0-comment"/>+ <context ref="c:include"/>+ <context ref="c:preprocessor"/>+ <context ref="body"/>+ </include>+ </context>++ <context id="hamlet">+ <start>\[\$?(s|i|w|)hamlet\|</start>+ <end>\|\]</end>+ <include>+ <context sub-pattern="0" where="start" style-ref="preprocessor"/>+ <context sub-pattern="0" where="end" style-ref="preprocessor"/>+ <context ref="hamlet:hamlet"/>+ </include>+ </context>++ <context id="cassius">+ <start>\[\$?cassius\|</start>+ <end>\|\]</end>+ <include>+ <context sub-pattern="0" where="start" style-ref="preprocessor"/>+ <context sub-pattern="0" where="end" style-ref="preprocessor"/>+ <context ref="cassius:cassius"/>+ </include>+ </context>++ <context id="lucius">+ <start>\[\$?lucius\|</start>+ <end>\|\]</end>+ <include>+ <context sub-pattern="0" where="start" style-ref="preprocessor"/>+ <context sub-pattern="0" where="end" style-ref="preprocessor"/>+ <context ref="lucius:lucius"/>+ </include>+ </context>++ <context id="julius">+ <start>\[\$?julius\|</start>+ <end>\|\]</end>+ <include>+ <context sub-pattern="0" where="start" style-ref="preprocessor"/>+ <context sub-pattern="0" where="end" style-ref="preprocessor"/>+ <context ref="julius:julius"/>+ </include>+ </context>++ <context id="variable" style-ref="variable">+ <match>\b[a-z_][0-9a-zA-Z_'#]*</match>+ </context>++ <context id="type-or-constructor" style-ref="type">+ <match>\b[A-Z][0-9a-zA-Z_'#]*</match>+ </context>++ <!-- Must not extend parent context, or we end up matching+ "\end{code}" as part of the Haskell context, but when in+ literate haskell mode it should be terminating a code block. -->+ <context id="symbol" style-ref="symbol" extend-parent="false">+ <match>\%{symbolchar}+</match>+ </context>++ <context id="keysymbol" style-ref="keyword">+ <prefix>(?<!\%{symbolchar})</prefix>+ <suffix>(?!\%{symbolchar})</suffix>+ <keyword>\.\.</keyword>+ <keyword>::</keyword>+ <keyword>=</keyword>+ <keyword>\|</keyword>+ <keyword>\</keyword>+ <keyword>-></keyword>+ <keyword><-</keyword>+ <keyword>@</keyword>+ <keyword>~</keyword>+ <keyword>=></keyword>+ </context>++ <define-regex id="escaped-character" extended="true">+ \\( # leading backslash+ [abfnrtv\\"\'&] | # escaped character+ [0-9]+ | # decimal digits+ o[0-7]+ | # 'o' followed by octal digits+ x[0-9A-Fa-f]+ | # 'x' followed by hex digits+ \^[A-Z@\[\\\]^_] | # control character codes+ NUL | SOH | STX | ETX | EOT | ENQ | ACK |+ BEL | BS | HT | LF | VT | FF | CR | SO |+ SI | DLE | DC1 | DC2 | DC3 | DC4 | NAK |+ SYN | ETB | CAN | EM | SUB | ESC | FS | GS |+ RS | US | SP | DEL # control char names+ )+ </define-regex>++ <context id="string" style-ref="string" end-at-line-end="true" class="string" class-disabled="no-spell-check">+ <start>"</start>+ <end>"</end>+ <include>+ <context ref="def:line-continue"/>+ <context style-ref="char-escape">+ <match>\%{escaped-character}</match>+ </context>+ </include>+ </context>++ <context id="char" style-ref="character" end-at-line-end="true">+ <start>'</start>+ <end>'</end>+ <include>+ <context style-ref="char-escape" once-only="true">+ <match>\%{escaped-character}</match>+ </context>+ <context once-only="true" extend-parent="false">+ <match>.</match>+ </context>+ <context style-ref="def:error" extend-parent="false">+ <match>.</match>+ </context>+ </include>+ </context>++ <context id="float" style-ref="float">+ <match extended="true">+ [0-9]+ \. [0-9]+ ([eE][+-]?[0-9]+)?+ | [0-9]+ [eE][+-]?[0-9]++ </match>+ </context>++ <context id="hexadecimal" style-ref="hexadecimal">+ <match>0[xX][0-9a-fA-F]+</match>+ </context>++ <context id="octal" style-ref="octal">+ <match>0[oO][0-7]+</match>+ </context>++ <context id="decimal" style-ref="decimal">+ <match>[0-9]+</match>+ </context>++ <context id="keyword" style-ref="keyword">+ <keyword>case</keyword>+ <keyword>class</keyword>+ <keyword>data</keyword>+ <keyword>default</keyword>+ <keyword>deriving</keyword>+ <keyword>do</keyword>+ <keyword>mdo</keyword>+ <keyword>else</keyword>+ <keyword>forall</keyword>+ <keyword>foreign</keyword>+ <keyword>hiding</keyword>+ <keyword>if</keyword>+ <keyword>import</keyword>+ <keyword>in</keyword>+ <keyword>infix</keyword>+ <keyword>infixl</keyword>+ <keyword>infixr</keyword>+ <keyword>instance</keyword>+ <keyword>let</keyword>+ <keyword>module</keyword>+ <keyword>newtype</keyword>+ <keyword>of</keyword>+ <keyword>qualified</keyword>+ <keyword>then</keyword>+ <keyword>where</keyword>+ <keyword>type</keyword>+ </context>++ <context id="body">+ <include>+ <context ref="line-comment"/>+ <context ref="pragma"/>+ <context ref="block-comment"/>+ <context ref="keyword"/>+ <context ref="variable"/>+ <context ref="type-or-constructor"/>+ <context ref="keysymbol"/>+ <context ref="symbol"/>+ <context ref="string"/>+ <context ref="char"/>+ <context ref="float"/>+ <context ref="hexadecimal"/>+ <context ref="octal"/>+ <context ref="decimal"/>+ <context ref="hamlet"/>+ <context ref="cassius"/>+ <context ref="lucius"/>+ <context ref="julius"/>+ </include>+ </context>++ </definitions>+</language>
+ language-specs/julius.lang view
@@ -0,0 +1,350 @@+<?xml version="1.0" encoding="UTF-8"?>+<!--++ Author: Scott Martin <scott@coffeeblack.org>+ Copyright (C) 2004 Scott Martin <scott@coffeeblack.org>+ Copyright (C) 2005 Stef Walter (formerly Nate Nielsen) <stef@memberwebs.com>+ Copyright (C) 2005-2007 Marco Barisione <barisione@gmail.com>+ Copyright (C) 2005-2007 Emanuele Aina++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Library General Public+ License as published by the Free Software Foundation; either+ version 2 of the License, or (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+ Library General Public License for more details.++ You should have received a copy of the GNU Library General Public+ License along with this library; if not, write to the+ Free Software Foundation, Inc., 59 Temple Place - Suite 330,+ Boston, MA 02111-1307, USA.++-->+<language id="julius" _name="Julius" version="2.0" _section="Scripts">+ <metadata>+ <property name="mimetypes">application/x-julius;text/x-julius</property>+ <property name="globs">*.julius</property>+ <property name="line-comment-start">//</property>+ <property name="block-comment-start">/*</property>+ <property name="block-comment-end">*/</property>+ </metadata>++ <styles>+ <style id="haskell-embed" _name="Haskell" map-to="def:preprocessor"/>+ <style id="comment" _name="Comment" map-to="def:comment"/>+ <style id="error" _name="Error" map-to="def:error"/>+ <style id="string" _name="String" map-to="def:string"/>+ <style id="null-value" _name="Null Value" map-to="def:special-constant"/>+ <style id="undefined-value" _name="Undefined Value" map-to="def:special-constant"/>+ <style id="boolean" _name="Boolean value" map-to="def:boolean"/>+ <style id="keyword" _name="Keyword" map-to="def:keyword"/>+ <style id="object" _name="Object"/> <!--map-to="def:others"-->+ <style id="type" _name="Data Type" map-to="def:type"/>+ <style id="function" _name="Function" map-to="def:function"/>+ <style id="properties" _name="Properties" map-to="def:statement"/>+ <style id="constructors" _name="Constructors" map-to="def:type"/>+ <style id="future-words" _name="Future Reserved Keywords" map-to="def:error"/>+ </styles>++ <definitions>+ <context id="haskell-embed">+ <start>[#@^]\{</start>+ <end>\}</end>+ <include>+ <context sub-pattern="0" where="start" style-ref="haskell-embed"/>+ <context sub-pattern="0" where="end" style-ref="haskell-embed"/>+ <context ref="haskell:body"/>+ </include>+ </context>++ <context id="julius" class="no-spell-check">+ <include>+ <context ref="haskell-embed"/>++ <!-- Comments -->+ <context id="line-comment" style-ref="comment" class="comment" class-disabled="no-spell-check">+ <start>//</start>+ <end>$</end>+ <include>+ <context ref="def:line-continue"/>+ <context ref="def:in-comment"/>+ <context ref="haskell-embed"/>+ </include>+ </context>++ <context id="block-comment" style-ref="comment" class="comment" class-disabled="no-spell-check">+ <start>/\*</start>+ <end>\*/</end>+ <include>+ <context ref="def:in-comment"/>+ <context ref="haskell-embed"/>+ </include>+ </context>++ <context id="close-comment-outside-comment" style-ref="error">+ <match>\*/(?!\*)</match>+ </context>++ <!-- Strings -->+ <context id="string-double" end-at-line-end="true" style-ref="string" class="string" class-disabled="no-spell-check">+ <start>"</start>+ <end>"</end>+ <include>+ <context ref="def:line-continue"/>+ <context ref="def:escape"/>+ <context ref="haskell-embed"/>+ </include>+ </context>++ <context id="string-single" end-at-line-end="true" style-ref="string" class="string" class-disabled="no-spell-check">+ <start>'</start>+ <end>'</end>+ <include>+ <context ref="def:line-continue"/>+ <context ref="def:escape"/>+ <context ref="haskell-embed"/>+ </include>+ </context>++ <!-- Numbers -->+ <context ref="def:float"/>+ <context ref="def:decimal"/>+ <context ref="def:octal"/>+ <context ref="def:hexadecimal"/>++ <!-- Constants -->+ <context id="null-value" style-ref="null-value">+ <keyword>null</keyword>+ </context>+ <context id="undefined-value" style-ref="undefined-value">+ <keyword>undefined</keyword>+ </context>+ <context id="boolean" style-ref="boolean">+ <keyword>false</keyword>+ <keyword>true</keyword>+ </context>++ <!-- Keywords -->+ <context id="keywords" style-ref="keyword">+ <keyword>break</keyword>+ <keyword>case</keyword>+ <keyword>catch</keyword>+ <keyword>const</keyword>+ <keyword>continue</keyword>+ <keyword>default</keyword>+ <keyword>delete</keyword>+ <keyword>do</keyword>+ <keyword>else</keyword>+ <keyword>export</keyword>+ <keyword>finally</keyword>+ <keyword>for</keyword>+ <keyword>function</keyword>+ <keyword>if</keyword>+ <keyword>import</keyword>+ <keyword>instanceof</keyword>+ <keyword>in</keyword>+ <keyword>let</keyword>+ <keyword>new</keyword>+ <keyword>return</keyword>+ <keyword>switch</keyword>+ <keyword>this</keyword>+ <keyword>throw</keyword>+ <keyword>try</keyword>+ <keyword>typeof</keyword>+ <keyword>while</keyword>+ <keyword>with</keyword>+ <keyword>var</keyword>+ <keyword>void</keyword>+ </context>++ <context id="objects" style-ref="object">+ <keyword>constructor</keyword>+ <keyword>prototype</keyword>+ </context>++ <context id="types" style-ref="type">+ <keyword>Infinity</keyword>+ <keyword>Math</keyword>+ <keyword>NaN</keyword>+ <keyword>NEGATIVE_INFINITY</keyword>+ <keyword>POSITIVE_INFINITY</keyword>+ </context>++ <context id="functions" style-ref="function">+ <keyword>abs</keyword>+ <keyword>acos</keyword>+ <keyword>apply</keyword>+ <keyword>asin</keyword>+ <keyword>atan2</keyword>+ <keyword>atan</keyword>+ <keyword>call</keyword>+ <keyword>ceil</keyword>+ <keyword>charAt</keyword>+ <keyword>charCodeAt</keyword>+ <keyword>concat</keyword>+ <keyword>cos</keyword>+ <keyword>decodeURIComponent</keyword>+ <keyword>decodeURI</keyword>+ <keyword>encodeURIComponent</keyword>+ <keyword>encodeURI</keyword>+ <keyword>escape</keyword>+ <keyword>eval</keyword>+ <keyword>exec</keyword>+ <keyword>exp</keyword>+ <keyword>floor</keyword>+ <keyword>fromCharCode</keyword>+ <keyword>getDate</keyword>+ <keyword>getDay</keyword>+ <keyword>getFullYear</keyword>+ <keyword>getHours</keyword>+ <keyword>getMilliseconds</keyword>+ <keyword>getMinutes</keyword>+ <keyword>getMonth</keyword>+ <keyword>getSeconds</keyword>+ <keyword>getTime</keyword>+ <keyword>getTimezoneOffset</keyword>+ <keyword>getUTCDate</keyword>+ <keyword>getUTCDay</keyword>+ <keyword>getUTCFullYear</keyword>+ <keyword>getUTCHours</keyword>+ <keyword>getUTCMilliseconds</keyword>+ <keyword>getUTCMinutes</keyword>+ <keyword>getUTCMonth</keyword>+ <keyword>getUTCSeconds</keyword>+ <keyword>getYear</keyword>+ <keyword>hasOwnProperty</keyword>+ <keyword>indexOf</keyword>+ <keyword>isFinite</keyword>+ <keyword>isNaN</keyword>+ <keyword>isPrototypeOf</keyword>+ <keyword>join</keyword>+ <keyword>lastIndexOf</keyword>+ <keyword>localeCompare</keyword>+ <keyword>log</keyword>+ <keyword>match</keyword>+ <keyword>max</keyword>+ <keyword>min</keyword>+ <keyword>parseFloat</keyword>+ <keyword>parseInt</keyword>+ <keyword>parse</keyword>+ <keyword>pop</keyword>+ <keyword>pow</keyword>+ <keyword>propertyIsEnumerable</keyword>+ <keyword>push</keyword>+ <keyword>random</keyword>+ <keyword>replace</keyword>+ <keyword>reverse</keyword>+ <keyword>round</keyword>+ <keyword>search</keyword>+ <keyword>setDate</keyword>+ <keyword>setFullYear</keyword>+ <keyword>setHours</keyword>+ <keyword>setMilliseconds</keyword>+ <keyword>setMinutes</keyword>+ <keyword>setMonth</keyword>+ <keyword>setSeconds</keyword>+ <keyword>setTime</keyword>+ <keyword>setUTCDate</keyword>+ <keyword>setUTCFullYear</keyword>+ <keyword>setUTCHours</keyword>+ <keyword>setUTCMilliseconds</keyword>+ <keyword>setUTCMinutes</keyword>+ <keyword>setUTCMonth</keyword>+ <keyword>setUTCSeconds</keyword>+ <keyword>setYear</keyword>+ <keyword>shift</keyword>+ <keyword>sin</keyword>+ <keyword>slice</keyword>+ <keyword>sort</keyword>+ <keyword>split</keyword>+ <keyword>sqrt</keyword>+ <keyword>substring</keyword>+ <keyword>substr</keyword>+ <keyword>tan</keyword>+ <keyword>toDateString</keyword>+ <keyword>toExponential</keyword>+ <keyword>toFixed</keyword>+ <keyword>toGMTString</keyword>+ <keyword>toLocaleDateString</keyword>+ <keyword>toLocaleLowerCase</keyword>+ <keyword>toLocaleString</keyword>+ <keyword>toLocaleTimeString</keyword>+ <keyword>toLocaleUpperCase</keyword>+ <keyword>toLowerCase</keyword>+ <keyword>toPrecision</keyword>+ <keyword>toString</keyword>+ <keyword>toTimeString</keyword>+ <keyword>toUpperCase</keyword>+ <keyword>toUTCString</keyword>+ <keyword>unescape</keyword>+ <keyword>unshift</keyword>+ <keyword>UTC</keyword>+ <keyword>valueOf</keyword>+ </context>++ <context id="properties" style-ref="properties">+ <keyword>global</keyword>+ <keyword>ignoreCase</keyword>+ <keyword>lastIndex</keyword>+ <keyword>length</keyword>+ <keyword>message</keyword>+ <keyword>multiline</keyword>+ <keyword>name</keyword>+ <keyword>source</keyword>+ </context>++ <context id="constructors" style-ref="constructors">+ <keyword>Array</keyword>+ <keyword>Boolean</keyword>+ <keyword>Date</keyword>+ <keyword>Error</keyword>+ <keyword>EvalError</keyword>+ <keyword>Function</keyword>+ <keyword>Number</keyword>+ <keyword>Object</keyword>+ <keyword>RangeError</keyword>+ <keyword>RegExp</keyword>+ <keyword>String</keyword>+ <keyword>SyntaxError</keyword>+ <keyword>TypeError</keyword>+ <keyword>URIError</keyword>+ </context>++ <context id="future-words" style-ref="future-words">+ <keyword>abstract</keyword>+ <keyword>boolean</keyword>+ <keyword>byte</keyword>+ <keyword>char</keyword>+ <keyword>class</keyword>+ <keyword>debugger</keyword>+ <keyword>double</keyword>+ <keyword>enum</keyword>+ <keyword>extends</keyword>+ <keyword>final</keyword>+ <keyword>float</keyword>+ <keyword>goto</keyword>+ <keyword>implements</keyword>+ <keyword>interface</keyword>+ <keyword>int</keyword>+ <keyword>long</keyword>+ <keyword>native</keyword>+ <keyword>package</keyword>+ <keyword>private</keyword>+ <keyword>protected</keyword>+ <keyword>public</keyword>+ <keyword>short</keyword>+ <keyword>static</keyword>+ <keyword>super</keyword>+ <keyword>synchronized</keyword>+ <keyword>throws</keyword>+ <keyword>transient</keyword>+ <keyword>volatile</keyword>+ </context>++ </include>+ </context>+ </definitions>+</language>
+ language-specs/lucius.lang view
@@ -0,0 +1,528 @@+<?xml version="1.0" encoding="UTF-8"?>+<!--++ Author: Scott Martin <scott@coffeeblack.org>+ Copyright (C) 2004 Scott Martin <scott@coffeeblack.org>++ This library is free software; you can redistribute it and/or+ modify it under the terms of the GNU Library General Public+ License as published by the Free Software Foundation; either+ version 2 of the License, or (at your option) any later version.++ This library is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+ Library General Public License for more details.++ You should have received a copy of the GNU Library General Public+ License along with this library; if not, write to the+ Free Software Foundation, Inc., 59 Temple Place - Suite 330,+ Boston, MA 02111-1307, USA.++-->+<!--+ Proposed language specification for CSS (Cascading Style Sheet) files.++ Reference used:+ http://www.w3.org/TR/CSS2/++ Tested with:+ http://www.simplebits.com/css/simple.css++ Submitted by++ Converted to new format with convert.py+-->+<language id="lucius" _name="Lucius" version="2.0" _section="Others">+ <metadata>+ <property name="mimetypes">text/css</property>+ <property name="globs">*.lucius</property>+ <property name="block-comment-start">/*</property>+ <property name="block-comment-end">*/</property>+ </metadata>++ <styles>+ <style id="haskell-embed" _name="Haskell" map-to="def:preprocessor"/>+ <style id="comment" _name="Comment" map-to="def:comment"/>+ <style id="error" _name="Error" map-to="def:error"/>+ <style id="others-2" _name="Others 2"/>+ <style id="string" _name="String" map-to="def:string"/>+ <style id="color" _name="Color" map-to="def:base-n-integer"/>+ <style id="others-3" _name="Others 3"/>+ <style id="function" _name="Function" map-to="def:function"/>+ <style id="decimal" _name="Decimal" map-to="def:decimal"/>+ <style id="dimension" _name="Dimension" map-to="def:floating-point"/>+ <style id="known-property-values" _name="Known Property Value" map-to="def:type"/>+ <style id="at-rules" _name="at-rules" map-to="def:keyword"/>+ <style id="keyword" _name="Keyword" map-to="def:keyword"/>+ </styles>++ <definitions>++ <context id="comment" style-ref="comment" class="comment" class-disabled="no-spell-check">+ <start>/\*</start>+ <end>\*/</end>+ <include>+ <context style-ref="error" extend-parent="false">+ <match>/\*</match>+ </context>+ <context ref="def:in-comment"/>+ </include>+ </context>++ <context id="close-comment-outside-comment" style-ref="error">+ <match>\*/(?!\*)</match>+ </context>++ <context id="unicode-character-reference" style-ref="others-2">+ <match>\\([a-fA-F0-9]{1,5}[ \t]|[a-fA-F0-9]{6})</match>+ </context>++ <context id="selector-pseudo-elements" style-ref="function">+ <keyword>first-line</keyword>+ <keyword>first-letter</keyword>+ <keyword>before</keyword>+ <keyword>after</keyword>+ </context>++ <context id="selector-pseudo-classes" style-ref="function">+ <keyword>first-child</keyword>+ <keyword>link</keyword>+ <keyword>visited</keyword>+ <keyword>hover</keyword>+ <keyword>active</keyword>+ <keyword>focus</keyword>+ <keyword>lang</keyword>+ </context>++ <context id="at-rules" style-ref="at-rules">+ <prefix>^[ \t]*@</prefix>+ <keyword>charset</keyword>+ <keyword>font-face</keyword>+ <keyword>media</keyword>+ <keyword>page</keyword>+ <keyword>import</keyword>+ </context>++ <context id="hexadecimal-color" style-ref="color">+ <match>#([a-fA-F0-9]{6}|[a-fA-F0-9]{3})\b</match>+ </context>++ <context id="named-color" style-ref="color">+ <keyword>aqua</keyword>+ <keyword>black</keyword>+ <keyword>blue</keyword>+ <keyword>fuchsia</keyword>+ <keyword>gray</keyword>+ <keyword>green</keyword>+ <keyword>lime</keyword>+ <keyword>maroon</keyword>+ <keyword>navy</keyword>+ <keyword>olive</keyword>+ <keyword>orange</keyword>+ <keyword>purple</keyword>+ <keyword>red</keyword>+ <keyword>silver</keyword>+ <keyword>teal</keyword>+ <keyword>white</keyword>+ <keyword>yellow</keyword>+ </context>++ <context id="function" style-ref="function">+ <start>[a-zA-Z][a-z0-9-]+\(</start>+ <end>\)</end>+ <include>+ <context ref="def:escape"/>+ <context ref="def:line-continue"/>+ </include>+ </context>++ <context id="dimension" style-ref="dimension">+ <match>[\+-]?([0-9]+|[0-9]*\.[0-9]+)(%|e(m|x)|p(x|t|c)|in|ft|(m|c)m|k?Hz|deg|g?rad|m?s)</match>+ </context>++ <context id="number" style-ref="decimal">+ <match>\b(0|[\+-]?[1-9][0-9]*)</match>+ </context>++ <context id="unicode-range" style-ref="others-2">+ <match>[uU]\+[a-fA-F0-9]{1,6}(-[a-fA-F0-9]{1,6})?</match>+ </context>++ <context id="importance-modifier" style-ref="keyword">+ <match>\![ \t]*important</match>+ </context>++ <context id="property-names" style-ref="keyword">+ <suffix>(?=\s*:)</suffix>+ <keyword>azimuth</keyword>+ <keyword>background-attachment</keyword>+ <keyword>background-color</keyword>+ <keyword>background-image</keyword>+ <keyword>background-position</keyword>+ <keyword>background-repeat</keyword>+ <keyword>background</keyword>+ <keyword>border-bottom-color</keyword>+ <keyword>border-bottom-style</keyword>+ <keyword>border-bottom-width</keyword>+ <keyword>border-bottom</keyword>+ <keyword>border-collapse</keyword>+ <keyword>border-color</keyword>+ <keyword>border-left-color</keyword>+ <keyword>border-left-style</keyword>+ <keyword>border-left-width</keyword>+ <keyword>border-left</keyword>+ <keyword>border-right-color</keyword>+ <keyword>border-right-style</keyword>+ <keyword>border-right-width</keyword>+ <keyword>border-right</keyword>+ <keyword>border-spacing</keyword>+ <keyword>border-style</keyword>+ <keyword>border-top-color</keyword>+ <keyword>border-top-style</keyword>+ <keyword>border-top-width</keyword>+ <keyword>border-top</keyword>+ <keyword>border-width</keyword>+ <keyword>border</keyword>+ <keyword>bottom</keyword>+ <keyword>caption-side</keyword>+ <keyword>clear</keyword>+ <keyword>clip</keyword>+ <keyword>color</keyword>+ <keyword>content</keyword>+ <keyword>counter-increment</keyword>+ <keyword>counter-reset</keyword>+ <keyword>cue-after</keyword>+ <keyword>cue-before</keyword>+ <keyword>cue</keyword>+ <keyword>cursor</keyword>+ <keyword>direction</keyword>+ <keyword>display</keyword>+ <keyword>elevation</keyword>+ <keyword>empty-cells</keyword>+ <keyword>float</keyword>+ <keyword>font-family</keyword>+ <keyword>font-size-adjust</keyword>+ <keyword>font-size</keyword>+ <keyword>font-style</keyword>+ <keyword>font-variant</keyword>+ <keyword>font-weight</keyword>+ <keyword>font</keyword>+ <keyword>height</keyword>+ <keyword>left</keyword>+ <keyword>letter-spacing</keyword>+ <keyword>line-height</keyword>+ <keyword>list-style-image</keyword>+ <keyword>list-style-position</keyword>+ <keyword>list-style-type</keyword>+ <keyword>list-style</keyword>+ <keyword>margin-bottom</keyword>+ <keyword>margin-left</keyword>+ <keyword>margin-right</keyword>+ <keyword>margin-top</keyword>+ <keyword>margin</keyword>+ <keyword>marker-offset</keyword>+ <keyword>marks</keyword>+ <keyword>max-height</keyword>+ <keyword>max-width</keyword>+ <keyword>min-height</keyword>+ <keyword>min-width</keyword>+ <keyword>orphans</keyword>+ <keyword>outline-color</keyword>+ <keyword>outline-style</keyword>+ <keyword>outline-width</keyword>+ <keyword>outline</keyword>+ <keyword>overflow</keyword>+ <keyword>padding-bottom</keyword>+ <keyword>padding-left</keyword>+ <keyword>padding-right</keyword>+ <keyword>padding-top</keyword>+ <keyword>padding</keyword>+ <keyword>page-break-after</keyword>+ <keyword>page-break-before</keyword>+ <keyword>page-break-inside</keyword>+ <keyword>page</keyword>+ <keyword>pause-after</keyword>+ <keyword>pause-before</keyword>+ <keyword>pause</keyword>+ <keyword>pitch-range</keyword>+ <keyword>pitch</keyword>+ <keyword>play-during</keyword>+ <keyword>position</keyword>+ <keyword>quotes</keyword>+ <keyword>richness</keyword>+ <keyword>right</keyword>+ <keyword>size</keyword>+ <keyword>speak-header</keyword>+ <keyword>speak-numerical</keyword>+ <keyword>speak-punctuation</keyword>+ <keyword>speak</keyword>+ <keyword>speech-rate</keyword>+ <keyword>stress</keyword>+ <keyword>table-layout</keyword>+ <keyword>text-align</keyword>+ <keyword>text-decoration</keyword>+ <keyword>text-indent</keyword>+ <keyword>text-shadow</keyword>+ <keyword>text-transform</keyword>+ <keyword>top</keyword>+ <keyword>unicode-bidi</keyword>+ <keyword>vertical-align</keyword>+ <keyword>visibility</keyword>+ <keyword>voice-family</keyword>+ <keyword>volume</keyword>+ <keyword>white-space</keyword>+ <keyword>widows</keyword>+ <keyword>width</keyword>+ <keyword>word-spacing</keyword>+ <keyword>z-index</keyword>+ </context>++ <context id="known-property-values" style-ref="known-property-values">+ <keyword>above</keyword>+ <keyword>absolute</keyword>+ <keyword>always</keyword>+ <keyword>armenian</keyword>+ <keyword>auto</keyword>+ <keyword>avoid</keyword>+ <keyword>baseline</keyword>+ <keyword>behind</keyword>+ <keyword>below</keyword>+ <keyword>bidi-override</keyword>+ <keyword>blink</keyword>+ <keyword>block</keyword>+ <keyword>bolder</keyword>+ <keyword>bold</keyword>+ <keyword>bottom</keyword>+ <keyword>capitalize</keyword>+ <keyword>center-left</keyword>+ <keyword>center-right</keyword>+ <keyword>center</keyword>+ <keyword>circle</keyword>+ <keyword>cjk-ideographic</keyword>+ <keyword>close-quote</keyword>+ <keyword>code</keyword>+ <keyword>collapse</keyword>+ <keyword>compact</keyword>+ <keyword>condensed</keyword>+ <keyword>continuous</keyword>+ <keyword>crop</keyword>+ <keyword>crosshair</keyword>+ <keyword>cross</keyword>+ <keyword>cue-after</keyword>+ <keyword>cue-before</keyword>+ <keyword>cursive</keyword>+ <keyword>dashed</keyword>+ <keyword>decimal</keyword>+ <keyword>decimal-leading-zero</keyword>+ <keyword>default</keyword>+ <keyword>digits</keyword>+ <keyword>disc</keyword>+ <keyword>dotted</keyword>+ <keyword>double</keyword>+ <keyword>embed</keyword>+ <keyword>e-resize</keyword>+ <keyword>expanded</keyword>+ <keyword>extra-condensed</keyword>+ <keyword>extra-expanded</keyword>+ <keyword>fantasy</keyword>+ <keyword>far-left</keyword>+ <keyword>far-right</keyword>+ <keyword>faster</keyword>+ <keyword>fast</keyword>+ <keyword>fixed</keyword>+ <keyword>fixed</keyword>+ <keyword>georgian</keyword>+ <keyword>groove</keyword>+ <keyword>hebrew</keyword>+ <keyword>help</keyword>+ <keyword>hidden</keyword>+ <keyword>hide</keyword>+ <keyword>higher</keyword>+ <keyword>high</keyword>+ <keyword>hiragana-iroha</keyword>+ <keyword>hiragana</keyword>+ <keyword>inherit</keyword>+ <keyword>inline</keyword>+ <keyword>inline-table</keyword>+ <keyword>inset</keyword>+ <keyword>inside</keyword>+ <keyword>invert</keyword>+ <keyword>italic</keyword>+ <keyword>justify</keyword>+ <keyword>katakana-iroha</keyword>+ <keyword>katakana</keyword>+ <keyword>landscape</keyword>+ <keyword>large</keyword>+ <keyword>larger</keyword>+ <keyword>left</keyword>+ <keyword>left-side</keyword>+ <keyword>leftwards</keyword>+ <keyword>level</keyword>+ <keyword>lighter</keyword>+ <keyword>line-through</keyword>+ <keyword>list-item</keyword>+ <keyword>loud</keyword>+ <keyword>lower-alpha</keyword>+ <keyword>lowercase</keyword>+ <keyword>lower-greek</keyword>+ <keyword>lower-latin</keyword>+ <keyword>lower-roman</keyword>+ <keyword>lower</keyword>+ <keyword>low</keyword>+ <keyword>ltr</keyword>+ <keyword>marker</keyword>+ <keyword>medium</keyword>+ <keyword>medium</keyword>+ <keyword>middle</keyword>+ <keyword>mix</keyword>+ <keyword>monospace</keyword>+ <keyword>move</keyword>+ <keyword>narrower</keyword>+ <keyword>ne-resize</keyword>+ <keyword>no-close-quote</keyword>+ <keyword>none</keyword>+ <keyword>no-open-quote</keyword>+ <keyword>no-repeat</keyword>+ <keyword>normal</keyword>+ <keyword>nowrap</keyword>+ <keyword>n-resize</keyword>+ <keyword>nw-resize</keyword>+ <keyword>oblique</keyword>+ <keyword>once</keyword>+ <keyword>open-quote</keyword>+ <keyword>outset</keyword>+ <keyword>outside</keyword>+ <keyword>overline</keyword>+ <keyword>pointer</keyword>+ <keyword>portait</keyword>+ <keyword>pre</keyword>+ <keyword>relative</keyword>+ <keyword>repeat-x</keyword>+ <keyword>repeat-y</keyword>+ <keyword>repeat</keyword>+ <keyword>ridge</keyword>+ <keyword>right-side</keyword>+ <keyword>right</keyword>+ <keyword>rightwards</keyword>+ <keyword>rlt</keyword>+ <keyword>run-in</keyword>+ <keyword>sans-serif</keyword>+ <keyword>scroll</keyword>+ <keyword>scroll</keyword>+ <keyword>semi-condensed</keyword>+ <keyword>semi-expanded</keyword>+ <keyword>separate</keyword>+ <keyword>se-resize</keyword>+ <keyword>serif</keyword>+ <keyword>show</keyword>+ <keyword>silent</keyword>+ <keyword>slower</keyword>+ <keyword>slow</keyword>+ <keyword>small-caps</keyword>+ <keyword>smaller</keyword>+ <keyword>small</keyword>+ <keyword>soft</keyword>+ <keyword>solid</keyword>+ <keyword>spell-out</keyword>+ <keyword>square</keyword>+ <keyword>s-resize</keyword>+ <keyword>static</keyword>+ <keyword>sub</keyword>+ <keyword>super</keyword>+ <keyword>sw-resize</keyword>+ <keyword>table-caption</keyword>+ <keyword>table-cell</keyword>+ <keyword>table-column-group</keyword>+ <keyword>table-column</keyword>+ <keyword>table-footer-group</keyword>+ <keyword>table-header-group</keyword>+ <keyword>table-row-group</keyword>+ <keyword>table-row</keyword>+ <keyword>table</keyword>+ <keyword>text-bottom</keyword>+ <keyword>text</keyword>+ <keyword>text-top</keyword>+ <keyword>thick</keyword>+ <keyword>thin</keyword>+ <keyword>top</keyword>+ <keyword>top</keyword>+ <keyword>transparent</keyword>+ <keyword>ultra-condensed</keyword>+ <keyword>ultra-expanded</keyword>+ <keyword>underline</keyword>+ <keyword>upper-alpha</keyword>+ <keyword>uppercase</keyword>+ <keyword>upper-latin</keyword>+ <keyword>upper-roman</keyword>+ <keyword>visible</keyword>+ <keyword>wait</keyword>+ <keyword>wider</keyword>+ <keyword>w-resize</keyword>+ <keyword>x-fast</keyword>+ <keyword>x-high</keyword>+ <keyword>x-large</keyword>+ <keyword>x-loud</keyword>+ <keyword>x-low</keyword>+ <keyword>x-slow</keyword>+ <keyword>x-small</keyword>+ <keyword>x-soft</keyword>+ <keyword>xx-large</keyword>+ <keyword>xx-small</keyword>+ </context>++ <context id="punctuators" style-ref="others-3">+ <match>[{}();,]</match>+ </context>++ <context id="attribute-value-delimiters" style-ref="others-2">+ <match>(\[|\])</match>+ </context>++ <context id="operators" style-ref="function">+ <match>[@%~|!=]</match>+ </context>++ <context id="selector-grammar" style-ref="others-3">+ <match>[*#.>+]</match>+ </context>++ <context id="haskell-embed">+ <start>[#@^]\{</start>+ <end>\}</end>+ <include>+ <context sub-pattern="0" where="start" style-ref="haskell-embed"/>+ <context sub-pattern="0" where="end" style-ref="haskell-embed"/>+ <context ref="haskell:body"/>+ </include>+ </context>++ <context id="lucius" class="no-spell-check">+ <include>+ <context ref="def:string"/>+ <context ref="def:single-quoted-string"/>+ <context ref="comment"/>+ <context ref="close-comment-outside-comment"/>+ <context ref="unicode-character-reference"/>+ <context ref="selector-pseudo-elements"/>+ <context ref="selector-pseudo-classes"/>+ <context ref="at-rules"/>+ <context ref="hexadecimal-color"/>+ <context ref="named-color"/>+ <context ref="function"/>+ <context ref="dimension"/>+ <context ref="number"/>+ <context ref="unicode-range"/>+ <context ref="importance-modifier"/>+ <context ref="property-names"/>+ <context ref="known-property-values"/>+ <context ref="punctuators"/>+ <context ref="attribute-value-delimiters"/>+ <context ref="operators"/>+ <context ref="selector-grammar"/>+ <context ref="haskell-embed"/>+ </include>+ </context>++ </definitions>+</language>
leksah.cabal view
@@ -1,5 +1,5 @@ name: leksah-version: 0.10.0.4+version: 0.12.0.3 cabal-version: >=1.8 build-type: Simple license: GPL@@ -14,7 +14,7 @@ description: An Integrated Development Environment for Haskell written in Haskell. category: Development, IDE, Editor author: Juergen Nicklisch-Franken, Hamish Mackenzie-tested-with: GHC ==6.10 || ==6.12 || ==7.0+tested-with: GHC == 7.2.2 data-files: LICENSE Readme @@ -26,9 +26,20 @@ data/prefscoll.lkshp data/emacs.lkshk data/LICENSE+ data/main.lksht data/module.lksht data/welcome.txt+ data/leksah-welcome/Setup.lhs+ data/leksah-welcome/leksah-welcome.cabal+ data/leksah-welcome/src/Main.hs + language-specs/haskell.lang+ language-specs/haskell-literate.lang+ language-specs/hamlet.lang+ language-specs/cassius.lang+ language-specs/lucius.lang+ language-specs/julius.lang+ pics/ide_class.png pics/ide_configure.png pics/ide_data.png@@ -71,6 +82,10 @@ Default: True Description: Experimental Yi support +flag threaded+ default: False+ description: Build with support for multithreaded execution+ library if os(windows) build-depends: Win32 >=2.2.0.0 && <2.3@@ -79,10 +94,10 @@ includes: windows.h -- include-dirs: C:/cygwin/usr/include/w32api else- build-depends: unix >=2.3.1.0 && <2.5+ build-depends: unix >=2.3.1.0 && <2.6 if os(osx)- build-depends: ige-mac-integration >= 0.0.0.2 && <0.2+ build-depends: gtk-mac-integration >= 0.0.0.2 && <0.2 if flag(yi) build-depends: yi >=0.6.1 && <0.7@@ -92,22 +107,27 @@ build-depends: dyre >= 0.8.3 && <0.9 cpp-options: -DLEKSAH_WITH_YI_DYRE + if flag(threaded)+ ghc-options: -threaded+ hs-source-dirs: src extensions: CPP - build-depends: Cabal >=1.6.0.1 && <1.11, base >=4.0.0.0 && <4.4, binary >=0.5.0.0 && <0.6,- bytestring >=0.9.0.1 && <0.10, containers >=0.2.0.0 && <0.5, directory >=1.0.0.2 && <3.1,- filepath >=1.1.0.1 && <1.3, glib >=0.10 && <0.13, gtk >=0.10 && <0.13,- gtksourceview2 >=0.10.0 && <0.13, mtl >=1.1.0.2 && <2.1, old-time >=1.0.0.1 && <1.1,- parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.1, process-leksah >=1.0.1.3 && <1.1,- regex-tdfa ==1.1.*, regex-base ==0.93.*, utf8-string >=0.3.1.1 && <0.4, array >=0.2.0.0 && <0.4,- time >=0.1 && <1.3, ltk >= 0.10 && <0.11, binary-shared >= 0.8 && <0.9, deepseq >= 1.1.0.0 && <1.2,- hslogger >= 1.0.7 && <1.2, leksah-server >= 0.10 && <0.11, network >= 2.2 && <3.0,- ghc >=6.10.1 && <7.1, strict >= 0.3.2 && <0.4+ build-depends: Cabal >=1.6.0.1 && <1.15, base >=4.0.0.0 && <4.6, binary >=0.5.0.0 && <0.6,+ bytestring >=0.9.0.1 && <0.10, containers >=0.2.0.0 && <0.5, directory >=1.0.0.2 && <3.1,+ filepath >=1.1.0.1 && <1.4, glib >=0.10 && <0.13, gtk >=0.10 && <0.13,+ gtksourceview2 >=0.10.0 && <0.13, mtl >=1.1.0.2 && <2.1, old-time >=1.0.0.1 && <1.2,+ parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2,+ regex-tdfa ==1.1.*, regex-base ==0.93.*, utf8-string >=0.3.1.1 && <0.4, array >=0.2.0.0 && <0.5,+ time >=0.1 && <1.5, ltk >= 0.12 && <0.13, binary-shared >= 0.8 && <0.9, deepseq >= 1.1.0.0 && <1.4,+ hslogger >= 1.0.7 && <1.2, leksah-server >=0.12.0.3 && <0.13, network >= 2.2 && <3.0,+ ghc >=6.10.1 && <7.5, strict >= 0.3.2 && <0.4, enumerator >=0.4.14 && <0.5, text >= 0.11.1.5 && < 0.12,+ gio >=0.12.2 && <0.13, transformers >=0.2.2.0 && <0.3,+ QuickCheck >=2.4.2 && <2.5 exposed-modules: IDE.Leksah IDE.Completion IDE.ImportTool- IDE.Find IDE.Session IDE.Command IDE.Keymap IDE.Utils.GUIUtils+ 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@@ -115,7 +135,7 @@ 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.LogRef IDE.Debug IDE.Pane.Grep IDE.Pane.Files IDE.Pane.Breakpoints IDE.Pane.Trace IDE.Pane.Variables IDE.Pane.Errors IDE.TextEditor IDE.Workspaces IDE.Statusbar IDE.Pane.Workspace IDE.PaneGroups@@ -123,10 +143,15 @@ IDE.BufferMode IDE.Build + if (impl(ghc > 7))+ other-modules:+ Distribution.PackageDescription.PrettyPrintCopied+ Distribution.PackageDescription.ParseCopied+ other-modules: Paths_leksah ghc-prof-options: -auto-all -prof- ghc-shared-options: -auto-all -prof+ ghc-shared-options: -auto-all ghc-options: -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans Executable leksah@@ -137,10 +162,10 @@ includes: windows.h -- include-dirs: C:/cygwin/usr/include/w32api else- build-depends: unix >=2.3.1.0 && <2.5+ build-depends: unix >=2.3.1.0 && <2.6 if os(osx)- build-depends: ige-mac-integration >= 0.0.0.2 && <0.2+ build-depends: gtk-mac-integration >= 0.0.0.2 && <0.2 if flag(yi) cpp-options: -DLEKSAH_WITH_YI@@ -148,32 +173,37 @@ if flag(yi) && flag(dyre) cpp-options: -DLEKSAH_WITH_DYRE - if impl(ghc < 6.12.3) && flag(yi)+ if impl(ghc < 7.0) && flag(yi) build-depends: yi >=0.6.1 && <0.7 - if impl(ghc < 6.12.3) && flag(yi) && flag(dyre)+ if impl(ghc < 7.0) && flag(yi) && flag(dyre) build-depends: dyre >= 0.8.3 && <0.9 - if impl(ghc < 6.12.3)+ if flag(threaded)+ ghc-options: -threaded++ if impl(ghc < 7.0) hs-source-dirs: src, main- build-depends: Cabal >=1.6.0.1 && <1.11, base >=4.0.0.0 && <4.4, binary >=0.5.0.0 && <0.6,+ build-depends: Cabal >=1.6.0.1 && <1.15, base >=4.0.0.0 && <4.6, binary >=0.5.0.0 && <0.6, bytestring >=0.9.0.1 && <0.10, containers >=0.2.0.0 && <0.5, directory >=1.0.0.2 && <3.1,- filepath >=1.1.0.1 && <1.3, glib >=0.10 && <0.13, gtk >=0.10 && <0.13,- gtksourceview2 >=0.10.0 && <0.13, mtl >=1.1.0.2 && <2.1, old-time >=1.0.0.1 && <1.1,- parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.1, process-leksah >=1.0.1.3 && <1.1,- regex-tdfa ==1.1.*, regex-base ==0.93.*, utf8-string >=0.3.1.1 && <0.4, array >=0.2.0.0 && <0.4,- time >=0.1 && <1.3, ltk >= 0.10 && <0.11, binary-shared >= 0.8 && <0.9, deepseq >= 1.1.0.0 && <1.2,- hslogger >= 1.0.7 && <1.2, leksah-server >= 0.10 && <0.11, network >= 2.2 && <3.0,- ghc >=6.10.1 && <7.1, strict >= 0.3.2 && <0.4+ filepath >=1.1.0.1 && <1.4, glib >=0.10 && <0.13, gtk >=0.10 && <0.13,+ gtksourceview2 >=0.10.0 && <0.13, mtl >=1.1.0.2 && <2.1, old-time >=1.0.0.1 && <1.2,+ parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2,+ regex-tdfa ==1.1.*, regex-base ==0.93.*, utf8-string >=0.3.1.1 && <0.4, array >=0.2.0.0 && <0.5,+ time >=0.1 && <1.5, ltk >=0.12 && <0.13, binary-shared >= 0.8 && <0.9, deepseq >= 1.1.0.0 && <1.4,+ hslogger >= 1.0.7 && <1.2, leksah-server >=0.12.0.3 && <0.13, network >= 2.2 && <3.0,+ ghc >=6.10.1 && <7.5, strict >= 0.3.2 && <0.4, enumerator >=0.4.14 && <0.5, text >= 0.11.1.5 && < 0.12,+ gio >=0.12.2 && <0.13, transformers >=0.2.2.0 && <0.3,+ QuickCheck >=2.4.2 && <2.5 else hs-source-dirs: main- build-depends: leksah ==0.10.0.4, base >=4.0.0.0 && <= 5+ build-depends: leksah ==0.12.0.3, base >=4.0.0.0 && <= 5 main-is: Main.hs buildable: True extensions: CPP ghc-prof-options: -auto-all -prof- ghc-shared-options: -auto-all -prof+ ghc-shared-options: -auto-all ghc-options: -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans
+ src/Distribution/PackageDescription/ParseCopied.hs view
@@ -0,0 +1,1206 @@+-----------------------------------------------------------------------------+-- |+-- Module : Distribution.PackageDescription.ParseCopied+-- Copyright : Isaac Jones 2003-2005+--+-- Maintainer : cabal-devel@haskell.org+-- Portability : portable+--+-- This defined parsers and partial pretty printers for the @.cabal@ format.+-- Some of the complexity in this module is due to the fact that we have to be+-- backwards compatible with old @.cabal@ files, so there's code to translate+-- into the newer structure.++{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.PackageDescription.ParseCopied (+ -- * Package descriptions+-- readPackageDescription,+-- writePackageDescription,+-- parsePackageDescription,+-- showPackageDescription,++ -- ** Parsing+ ParseResult(..),+ FieldDescr(..),+ LineNo,++ -- ** Supplementary build information+-- readHookedBuildInfo,+-- parseHookedBuildInfo,+-- writeHookedBuildInfo,+-- showHookedBuildInfo,++ pkgDescrFieldDescrs,+ libFieldDescrs,+ executableFieldDescrs,+ binfoFieldDescrs,+ sourceRepoFieldDescrs,+ testSuiteFieldDescrs,+ flagFieldDescrs+ ) where++import Data.Char (isSpace)+import Data.Maybe (listToMaybe, isJust)+import Data.Monoid ( Monoid(..) )+import Data.List (nub, unfoldr, partition, (\\))+import Control.Monad (liftM, foldM, when, unless)+import System.Directory (doesFileExist)++import Distribution.Text+ ( Text(disp, parse), display, simpleParse )+import Distribution.Compat.ReadP+ ((+++), option)+import Text.PrettyPrint++import Distribution.ParseUtils hiding (parseFields)+import Distribution.PackageDescription+import Distribution.Package+ ( PackageIdentifier(..), Dependency(..), packageName, packageVersion )+import Distribution.ModuleName ( ModuleName )+import Distribution.Version+ ( Version(Version), orLaterVersion+ , LowerBound(..), asVersionIntervals )+import Distribution.Verbosity (Verbosity)+import Distribution.Compiler (CompilerFlavor(..))+import Distribution.PackageDescription.Configuration (parseCondition, freeVars)+import Distribution.Simple.Utils+ ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion+ , withFileContents, withUTF8FileContents+ , writeFileAtomic, writeUTF8File )+++-- -----------------------------------------------------------------------------+-- The PackageDescription type++pkgDescrFieldDescrs :: [FieldDescr PackageDescription]+pkgDescrFieldDescrs =+ [ simpleField "name"+ disp parse+ packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}})+ , simpleField "version"+ disp parse+ packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}})+ , simpleField "cabal-version"+ (either disp disp) (liftM Left parse +++ liftM Right parse)+ specVersionRaw (\v pkg -> pkg{specVersionRaw=v})+ , simpleField "build-type"+ (maybe empty disp) (fmap Just parse)+ buildType (\t pkg -> pkg{buildType=t})+ , simpleField "license"+ disp parseLicenseQ+ license (\l pkg -> pkg{license=l})+ , simpleField "license-file"+ showFilePath parseFilePathQ+ licenseFile (\l pkg -> pkg{licenseFile=l})+ , simpleField "copyright"+ showFreeText parseFreeText+ copyright (\val pkg -> pkg{copyright=val})+ , simpleField "maintainer"+ showFreeText parseFreeText+ maintainer (\val pkg -> pkg{maintainer=val})+ , commaListField "build-depends"+ disp parse+ buildDepends (\xs pkg -> pkg{buildDepends=xs})+ , simpleField "stability"+ showFreeText parseFreeText+ stability (\val pkg -> pkg{stability=val})+ , simpleField "homepage"+ showFreeText parseFreeText+ homepage (\val pkg -> pkg{homepage=val})+ , simpleField "package-url"+ showFreeText parseFreeText+ pkgUrl (\val pkg -> pkg{pkgUrl=val})+ , simpleField "bug-reports"+ showFreeText parseFreeText+ bugReports (\val pkg -> pkg{bugReports=val})+ , simpleField "synopsis"+ showFreeText parseFreeText+ synopsis (\val pkg -> pkg{synopsis=val})+ , simpleField "description"+ showFreeText parseFreeText+ description (\val pkg -> pkg{description=val})+ , simpleField "category"+ showFreeText parseFreeText+ category (\val pkg -> pkg{category=val})+ , simpleField "author"+ showFreeText parseFreeText+ author (\val pkg -> pkg{author=val})+ , listField "tested-with"+ showTestedWith parseTestedWithQ+ testedWith (\val pkg -> pkg{testedWith=val})+ , listField "data-files"+ showFilePath parseFilePathQ+ dataFiles (\val pkg -> pkg{dataFiles=val})+ , simpleField "data-dir"+ showFilePath parseFilePathQ+ dataDir (\val pkg -> pkg{dataDir=val})+ , listField "extra-source-files"+ showFilePath parseFilePathQ+ extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val})+ , listField "extra-tmp-files"+ showFilePath parseFilePathQ+ extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val})+ ]++-- | Store any fields beginning with "x-" in the customFields field of+-- a PackageDescription. All other fields will generate a warning.+storeXFieldsPD :: UnrecFieldParser PackageDescription+storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD =+ (customFieldsPD pkg) ++ [(f,val)]}+storeXFieldsPD _ _ = Nothing++-- ---------------------------------------------------------------------------+-- The Library type++libFieldDescrs :: [FieldDescr Library]+libFieldDescrs =+ [ listField "exposed-modules" disp parseModuleNameQ+ exposedModules (\mods lib -> lib{exposedModules=mods})++ , boolField "exposed"+ libExposed (\val lib -> lib{libExposed=val})+ ] ++ map biToLib binfoFieldDescrs+ where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi})++storeXFieldsLib :: UnrecFieldParser Library+storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =+ Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}}+storeXFieldsLib _ _ = Nothing++-- ---------------------------------------------------------------------------+-- The Executable type+++executableFieldDescrs :: [FieldDescr Executable]+executableFieldDescrs =+ [ -- note ordering: configuration must come first, for+ -- showPackageDescription.+ simpleField "executable"+ showToken parseTokenQ+ exeName (\xs exe -> exe{exeName=xs})+ , simpleField "main-is"+ showFilePath parseFilePathQ+ modulePath (\xs exe -> exe{modulePath=xs})+ ]+ ++ map biToExe binfoFieldDescrs+ where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi})++storeXFieldsExe :: UnrecFieldParser Executable+storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) =+ Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}+storeXFieldsExe _ _ = Nothing++-- ---------------------------------------------------------------------------+-- The TestSuite type++-- | An intermediate type just used for parsing the test-suite stanza.+-- After validation it is converted into the proper 'TestSuite' type.+data TestSuiteStanza = TestSuiteStanza {+ testStanzaTestType :: Maybe TestType,+ testStanzaMainIs :: Maybe FilePath,+ testStanzaTestModule :: Maybe ModuleName,+ testStanzaBuildInfo :: BuildInfo+ }++emptyTestStanza :: TestSuiteStanza+emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty++testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza]+testSuiteFieldDescrs =+ [ simpleField "type"+ (maybe empty disp) (fmap Just parse)+ testStanzaTestType (\x suite -> suite { testStanzaTestType = x })+ , simpleField "main-is"+ (maybe empty showFilePath) (fmap Just parseFilePathQ)+ testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x })+ , simpleField "test-module"+ (maybe empty disp) (fmap Just parseModuleNameQ)+ testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x })+ ]+ ++ map biToTest binfoFieldDescrs+ where+ biToTest = liftField testStanzaBuildInfo+ (\bi suite -> suite { testStanzaBuildInfo = bi })++storeXFieldsTest :: UnrecFieldParser TestSuiteStanza+storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) =+ Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}+storeXFieldsTest _ _ = Nothing++validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite+validateTestSuite line stanza =+ case testStanzaTestType stanza of+ Nothing -> return $+ emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza }++ Just tt@(TestTypeUnknown _ _) ->+ return emptyTestSuite {+ testInterface = TestSuiteUnsupported tt,+ testBuildInfo = testStanzaBuildInfo stanza+ }++ Just tt | tt `notElem` knownTestTypes ->+ return emptyTestSuite {+ testInterface = TestSuiteUnsupported tt,+ testBuildInfo = testStanzaBuildInfo stanza+ }++ Just tt@(TestTypeExe ver) ->+ case testStanzaMainIs stanza of+ Nothing -> syntaxError line (missingField "main-is" tt)+ Just file -> do+ when (isJust (testStanzaTestModule stanza)) $+ warning (extraField "test-module" tt)+ return emptyTestSuite {+ testInterface = TestSuiteExeV10 ver file,+ testBuildInfo = testStanzaBuildInfo stanza+ }++ Just tt@(TestTypeLib ver) ->+ case testStanzaTestModule stanza of+ Nothing -> syntaxError line (missingField "test-module" tt)+ Just module_ -> do+ when (isJust (testStanzaMainIs stanza)) $+ warning (extraField "main-is" tt)+ return emptyTestSuite {+ testInterface = TestSuiteLibV09 ver module_,+ testBuildInfo = testStanzaBuildInfo stanza+ }++ where+ missingField name tt = "The '" ++ name ++ "' field is required for the "+ ++ display tt ++ " test suite type."++ extraField name tt = "The '" ++ name ++ "' field is not used for the '"+ ++ display tt ++ "' test suite type."+++-- ---------------------------------------------------------------------------+-- The Benchmark type+{--+-- | An intermediate type just used for parsing the benchmark stanza.+-- After validation it is converted into the proper 'Benchmark' type.+data BenchmarkStanza = BenchmarkStanza {+ benchmarkStanzaBenchmarkType :: Maybe BenchmarkType,+ benchmarkStanzaMainIs :: Maybe FilePath,+ benchmarkStanzaBenchmarkModule :: Maybe ModuleName,+ benchmarkStanzaBuildInfo :: BuildInfo+ }++emptyBenchmarkStanza :: BenchmarkStanza+emptyBenchmarkStanza = BenchmarkStanza Nothing Nothing Nothing mempty++benchmarkFieldDescrs :: [FieldDescr BenchmarkStanza]+benchmarkFieldDescrs =+ [ simpleField "type"+ (maybe empty disp) (fmap Just parse)+ benchmarkStanzaBenchmarkType+ (\x suite -> suite { benchmarkStanzaBenchmarkType = x })+ , simpleField "main-is"+ (maybe empty showFilePath) (fmap Just parseFilePathQ)+ benchmarkStanzaMainIs+ (\x suite -> suite { benchmarkStanzaMainIs = x })+ ]+ ++ map biToBenchmark binfoFieldDescrs+ where+ biToBenchmark = liftField benchmarkStanzaBuildInfo+ (\bi suite -> suite { benchmarkStanzaBuildInfo = bi })++storeXFieldsBenchmark :: UnrecFieldParser BenchmarkStanza+storeXFieldsBenchmark (f@('x':'-':_), val)+ t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) =+ Just $ t {benchmarkStanzaBuildInfo =+ bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}+storeXFieldsBenchmark _ _ = Nothing++validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark+validateBenchmark line stanza =+ case benchmarkStanzaBenchmarkType stanza of+ Nothing -> return $+ emptyBenchmark { benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza }++ Just tt@(BenchmarkTypeUnknown _ _) ->+ return emptyBenchmark {+ benchmarkInterface = BenchmarkUnsupported tt,+ benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza+ }++ Just tt | tt `notElem` knownBenchmarkTypes ->+ return emptyBenchmark {+ benchmarkInterface = BenchmarkUnsupported tt,+ benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza+ }++ Just tt@(BenchmarkTypeExe ver) ->+ case benchmarkStanzaMainIs stanza of+ Nothing -> syntaxError line (missingField "main-is" tt)+ Just file -> do+ when (isJust (benchmarkStanzaBenchmarkModule stanza)) $+ warning (extraField "benchmark-module" tt)+ return emptyBenchmark {+ benchmarkInterface = BenchmarkExeV10 ver file,+ benchmarkBuildInfo = benchmarkStanzaBuildInfo stanza+ }++ where+ missingField name tt = "The '" ++ name ++ "' field is required for the "+ ++ display tt ++ " benchmark type."++ extraField name tt = "The '" ++ name ++ "' field is not used for the '"+ ++ display tt ++ "' benchmark type."+--}+-- ---------------------------------------------------------------------------+-- The BuildInfo type+++binfoFieldDescrs :: [FieldDescr BuildInfo]+binfoFieldDescrs =+ [ boolField "buildable"+ buildable (\val binfo -> binfo{buildable=val})+ , commaListField "build-tools"+ disp parseBuildTool+ buildTools (\xs binfo -> binfo{buildTools=xs})+ , spaceListField "cpp-options"+ showToken parseTokenQ'+ cppOptions (\val binfo -> binfo{cppOptions=val})+ , spaceListField "cc-options"+ showToken parseTokenQ'+ ccOptions (\val binfo -> binfo{ccOptions=val})+ , spaceListField "ld-options"+ showToken parseTokenQ'+ ldOptions (\val binfo -> binfo{ldOptions=val})+ , commaListField "pkgconfig-depends"+ disp parsePkgconfigDependency+ pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs})+ , listField "frameworks"+ showToken parseTokenQ+ frameworks (\val binfo -> binfo{frameworks=val})+ , listField "c-sources"+ showFilePath parseFilePathQ+ cSources (\paths binfo -> binfo{cSources=paths})++ , simpleField "default-language"+ (maybe empty disp) (option Nothing (fmap Just parseLanguageQ))+ defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang})+ , listField "other-languages"+ disp parseLanguageQ+ otherLanguages (\langs binfo -> binfo{otherLanguages=langs})+ , listField "default-extensions"+ disp parseExtensionQ+ defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts})+ , listField "other-extensions"+ disp parseExtensionQ+ otherExtensions (\exts binfo -> binfo{otherExtensions=exts})+ , listField "extensions"+ disp parseExtensionQ+ oldExtensions (\exts binfo -> binfo{oldExtensions=exts})++ , listField "extra-libraries"+ showToken parseTokenQ+ extraLibs (\xs binfo -> binfo{extraLibs=xs})+ , listField "extra-lib-dirs"+ showFilePath parseFilePathQ+ extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs})+ , listField "includes"+ showFilePath parseFilePathQ+ includes (\paths binfo -> binfo{includes=paths})+ , listField "install-includes"+ showFilePath parseFilePathQ+ installIncludes (\paths binfo -> binfo{installIncludes=paths})+ , listField "include-dirs"+ showFilePath parseFilePathQ+ includeDirs (\paths binfo -> binfo{includeDirs=paths})+ , listField "hs-source-dirs"+ showFilePath parseFilePathQ+ hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths})+ , listField "other-modules"+ disp parseModuleNameQ+ otherModules (\val binfo -> binfo{otherModules=val})+ , listField "ghc-prof-options"+ text parseTokenQ+ ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val})+ , listField "ghc-shared-options"+ text parseTokenQ+ ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=val})+ , optsField "ghc-options" GHC+ options (\path binfo -> binfo{options=path})+ , optsField "hugs-options" Hugs+ options (\path binfo -> binfo{options=path})+ , optsField "nhc98-options" NHC+ options (\path binfo -> binfo{options=path})+ , optsField "jhc-options" JHC+ options (\path binfo -> binfo{options=path})+ ]++storeXFieldsBI :: UnrecFieldParser BuildInfo+storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) }+storeXFieldsBI _ _ = Nothing++------------------------------------------------------------------------------++flagFieldDescrs :: [FieldDescr Flag]+flagFieldDescrs =+ [ simpleField "description"+ showFreeText parseFreeText+ flagDescription (\val fl -> fl{ flagDescription = val })+ , boolField "default"+ flagDefault (\val fl -> fl{ flagDefault = val })+ , boolField "manual"+ flagManual (\val fl -> fl{ flagManual = val })+ ]++------------------------------------------------------------------------------++sourceRepoFieldDescrs :: [FieldDescr SourceRepo]+sourceRepoFieldDescrs =+ [ simpleField "type"+ (maybe empty disp) (fmap Just parse)+ repoType (\val repo -> repo { repoType = val })+ , simpleField "location"+ (maybe empty showFreeText) (fmap Just parseFreeText)+ repoLocation (\val repo -> repo { repoLocation = val })+ , simpleField "module"+ (maybe empty showToken) (fmap Just parseTokenQ)+ repoModule (\val repo -> repo { repoModule = val })+ , simpleField "branch"+ (maybe empty showToken) (fmap Just parseTokenQ)+ repoBranch (\val repo -> repo { repoBranch = val })+ , simpleField "tag"+ (maybe empty showToken) (fmap Just parseTokenQ)+ repoTag (\val repo -> repo { repoTag = val })+ , simpleField "subdir"+ (maybe empty showFilePath) (fmap Just parseFilePathQ)+ repoSubdir (\val repo -> repo { repoSubdir = val })+ ]++-- ---------------------------------------------------------------+-- Parsing++-- | Given a parser and a filename, return the parse of the file,+-- after checking if the file exists.+readAndParseFile :: (FilePath -> (String -> IO a) -> IO a)+ -> (String -> ParseResult a)+ -> Verbosity+ -> FilePath -> IO a+readAndParseFile withFileContents' parser verbosity fpath = do+ exists <- doesFileExist fpath+ when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")+ withFileContents' fpath $ \str -> case parser str of+ ParseFailed e -> do+ let (line, message) = locatedErrorMsg e+ dieWithLocation fpath line message+ ParseOk warnings x -> do+ mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings+ return x+{--+readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo+readHookedBuildInfo =+ readAndParseFile withFileContents parseHookedBuildInfo++-- |Parse the given package file.+readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription+readPackageDescription =+ readAndParseFile withUTF8FileContents parsePackageDescription+--}+stanzas :: [Field] -> [[Field]]+stanzas [] = []+stanzas (f:fields) = (f:this) : stanzas rest+ where+ (this, rest) = break isStanzaHeader fields++isStanzaHeader :: Field -> Bool+isStanzaHeader (F _ f _) = f == "executable"+isStanzaHeader _ = False++------------------------------------------------------------------------------+++mapSimpleFields :: (Field -> ParseResult Field) -> [Field]+ -> ParseResult [Field]+mapSimpleFields f fs = mapM walk fs+ where+ walk fld@(F _ _ _) = f fld+ walk (IfBlock l c fs1 fs2) = do+ fs1' <- mapM walk fs1+ fs2' <- mapM walk fs2+ return (IfBlock l c fs1' fs2')+ walk (Section ln n l fs1) = do+ fs1' <- mapM walk fs1+ return (Section ln n l fs1')++-- prop_isMapM fs = mapSimpleFields return fs == return fs+++-- names of fields that represents dependencies, thus consrca+constraintFieldNames :: [String]+constraintFieldNames = ["build-depends"]+{--+-- Possible refactoring would be to have modifiers be explicit about what+-- they add and define an accessor that specifies what the dependencies+-- are. This way we would completely reuse the parsing knowledge from the+-- field descriptor.+parseConstraint :: Field -> ParseResult [Dependency]+parseConstraint (F l n v)+ | n == "build-depends" = runP l n (parseCommaList parse) v+parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")"+--}+{-+headerFieldNames :: [String]+headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames))+ . map fieldName $ pkgDescrFieldDescrs+-}+{-+libFieldNames :: [String]+libFieldNames = map fieldName libFieldDescrs+ ++ buildInfoNames ++ constraintFieldNames+-}+-- exeFieldNames :: [String]+-- exeFieldNames = map fieldName executableFieldDescrs+-- ++ buildInfoNames+{--+buildInfoNames :: [String]+buildInfoNames = map fieldName binfoFieldDescrs+ ++ map fst deprecatedFieldsBuildInfo+--}+-- A minimal implementation of the StateT monad transformer to avoid depending+-- on the 'mtl' package.+newtype StT s m a = StT { runStT :: s -> m (a,s) }++instance Monad m => Monad (StT s m) where+ return a = StT (\s -> return (a,s))+ StT f >>= g = StT $ \s -> do+ (a,s') <- f s+ runStT (g a) s'++get :: Monad m => StT s m s+get = StT $ \s -> return (s, s)++modify :: Monad m => (s -> s) -> StT s m ()+modify f = StT $ \s -> return ((),f s)++lift :: Monad m => m a -> StT s m a+lift m = StT $ \s -> m >>= \a -> return (a,s)++evalStT :: Monad m => StT s m a -> s -> m a+evalStT st s = runStT st s >>= return . fst++-- Our monad for parsing a list/tree of fields.+--+-- The state represents the remaining fields to be processed.+type PM a = StT [Field] ParseResult a++++-- return look-ahead field or nothing if we're at the end of the file+peekField :: PM (Maybe Field)+peekField = get >>= return . listToMaybe++-- Unconditionally discard the first field in our state. Will error when it+-- reaches end of file. (Yes, that's evil.)+skipField :: PM ()+skipField = modify tail++--FIXME: this should take a ByteString, not a String. We have to be able to+-- decode UTF8 and handle the BOM.++{--+-- | Parses the given file into a 'GenericPackageDescription'.+--+-- In Cabal 1.2 the syntax for package descriptions was changed to a format+-- with sections and possibly indented property descriptions.+parsePackageDescription :: String -> ParseResult GenericPackageDescription+parsePackageDescription file = do++ -- This function is quite complex because it needs to be able to parse+ -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains+ -- a lot of parser-related noise since we do not want to depend on Parsec.+ --+ -- If we detect an pre-1.2 file we implicitly convert it to post-1.2+ -- style. See 'sectionizeFields' below for details about the conversion.++ fields0 <- readFields file `catchParseError` \err ->+ let tabs = findIndentTabs file in+ case err of+ -- In case of a TabsError report them all at once.+ TabsError tabLineNo -> reportTabsError+ -- but only report the ones including and following+ -- the one that caused the actual error+ [ t | t@(lineNo',_) <- tabs+ , lineNo' >= tabLineNo ]+ _ -> parseFail err++ let cabalVersionNeeded =+ head $ [ minVersionBound versionRange+ | Just versionRange <- [ simpleParse v+ | F _ "cabal-version" v <- fields0 ] ]+ ++ [Version [0] []]+ minVersionBound versionRange =+ case asVersionIntervals versionRange of+ [] -> Version [0] []+ ((LowerBound version _, _):_) -> version++ handleFutureVersionParseFailure cabalVersionNeeded $ do++ let sf = sectionizeFields fields0 -- ensure 1.2 format++ -- figure out and warn about deprecated stuff (warnings are collected+ -- inside our parsing monad)+ fields <- mapSimpleFields deprecField sf++ -- Our parsing monad takes the not-yet-parsed fields as its state.+ -- After each successful parse we remove the field from the state+ -- ('skipField') and move on to the next one.+ --+ -- Things are complicated a bit, because fields take a tree-like+ -- structure -- they can be sections or "if"/"else" conditionals.++ flip evalStT fields $ do++ -- The header consists of all simple fields up to the first section+ -- (flag, library, executable).+ header_fields <- getHeader []++ -- Parses just the header fields and stores them in a+ -- 'PackageDescription'. Note that our final result is a+ -- 'GenericPackageDescription'; for pragmatic reasons we just store+ -- the partially filled-out 'PackageDescription' inside the+ -- 'GenericPackageDescription'.+ pkg <- lift $ parseFields pkgDescrFieldDescrs+ storeXFieldsPD+ emptyPackageDescription+ header_fields++ -- 'getBody' assumes that the remaining fields only consist of+ -- flags, lib and exe sections.+ (repos, flags, mlib, exes, tests, bms) <- getBody+ warnIfRest -- warn if getBody did not parse up to the last field.+ -- warn about using old/new syntax with wrong cabal-version:+ maybeWarnCabalVersion (not $ oldSyntax fields0) pkg+ checkForUndefinedFlags flags mlib exes tests+ return $ GenericPackageDescription+ pkg { sourceRepos = repos }+ flags mlib exes tests bms++ where+ oldSyntax flds = all isSimpleField flds+ reportTabsError tabs =+ syntaxError (fst (head tabs)) $+ "Do not use tabs for indentation (use spaces instead)\n"+ ++ " Tabs were used at (line,column): " ++ show tabs++ maybeWarnCabalVersion newsyntax pkg+ | newsyntax && specVersion pkg < Version [1,2] []+ = lift $ warning $+ "A package using section syntax must specify at least\n"+ ++ "'cabal-version: >= 1.2'."++ maybeWarnCabalVersion newsyntax pkg+ | not newsyntax && specVersion pkg >= Version [1,2] []+ = lift $ warning $+ "A package using 'cabal-version: "+ ++ displaySpecVersion (specVersionRaw pkg)+ ++ "' must use section syntax. See the Cabal user guide for details."+ where+ displaySpecVersion (Left version) = display version+ displaySpecVersion (Right versionRange) =+ case asVersionIntervals versionRange of+ [] {- impossible -} -> display versionRange+ ((LowerBound version _, _):_) -> display (orLaterVersion version)++ maybeWarnCabalVersion _ _ = return ()+++ handleFutureVersionParseFailure cabalVersionNeeded parseBody =+ (unless versionOk (warning message) >> parseBody)+ `catchParseError` \parseError -> case parseError of+ TabsError _ -> parseFail parseError+ _ | versionOk -> parseFail parseError+ | otherwise -> fail message+ where versionOk = cabalVersionNeeded <= cabalVersion+ message = "This package requires at least Cabal version "+ ++ display cabalVersionNeeded++ -- "Sectionize" an old-style Cabal file. A sectionized file has:+ --+ -- * all global fields at the beginning, followed by+ --+ -- * all flag declarations, followed by+ --+ -- * an optional library section, and an arbitrary number of executable+ -- sections (in any order).+ --+ -- The current implementatition just gathers all library-specific fields+ -- in a library section and wraps all executable stanzas in an executable+ -- section.+ sectionizeFields :: [Field] -> [Field]+ sectionizeFields fs+ | oldSyntax fs =+ let+ -- "build-depends" is a local field now. To be backwards+ -- compatible, we still allow it as a global field in old-style+ -- package description files and translate it to a local field by+ -- adding it to every non-empty section+ (hdr0, exes0) = break ((=="executable") . fName) fs+ (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0++ (deps, libfs) = partition ((== "build-depends") . fName)+ libfs0++ exes = unfoldr toExe exes0+ toExe [] = Nothing+ toExe (F l e n : r)+ | e == "executable" =+ let (efs, r') = break ((=="executable") . fName) r+ in Just (Section l "executable" n (deps ++ efs), r')+ toExe _ = bug "unexpeced input to 'toExe'"+ in+ hdr +++ (if null libfs then []+ else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)])+ ++ exes+ | otherwise = fs++ isSimpleField (F _ _ _) = True+ isSimpleField _ = False++ -- warn if there's something at the end of the file+ warnIfRest :: PM ()+ warnIfRest = do+ s <- get+ case s of+ [] -> return ()+ _ -> lift $ warning "Ignoring trailing declarations." -- add line no.++ -- all simple fields at the beginning of the file are (considered) header+ -- fields+ getHeader :: [Field] -> PM [Field]+ getHeader acc = peekField >>= \mf -> case mf of+ Just f@(F _ _ _) -> skipField >> getHeader (f:acc)+ _ -> return (reverse acc)++ --+ -- body ::= { repo | flag | library | executable | test }+ -- at most one lib+ --+ -- The body consists of an optional sequence of declarations of flags and+ -- an arbitrary number of executables and at most one library.+ getBody :: PM ([SourceRepo], [Flag]+ ,Maybe (CondTree ConfVar [Dependency] Library)+ ,[(String, CondTree ConfVar [Dependency] Executable)]+ ,[(String, CondTree ConfVar [Dependency] TestSuite)])+-- ,[(String, CondTree ConfVar [Dependency] Benchmark)])+ getBody = peekField >>= \mf -> case mf of+ Just (Section line_no sec_type sec_label sec_fields)+ | sec_type == "executable" -> do+ when (null sec_label) $ lift $ syntaxError line_no+ "'executable' needs one argument (the executable's name)"+ exename <- lift $ runP line_no "executable" parseTokenQ sec_label+ flds <- collectFields parseExeFields sec_fields+ skipField+ (repos, flags, lib, exes, tests, bms) <- getBody+ return (repos, flags, lib, (exename, flds): exes, tests, bms)++ | sec_type == "test-suite" -> do+ when (null sec_label) $ lift $ syntaxError line_no+ "'test-suite' needs one argument (the test suite's name)"+ testname <- lift $ runP line_no "test" parseTokenQ sec_label+ flds <- collectFields (parseTestFields line_no) sec_fields++ -- Check that a valid test suite type has been chosen. A type+ -- field may be given inside a conditional block, so we must+ -- check for that before complaining that a type field has not+ -- been given. The test suite must always have a valid type, so+ -- we need to check both the 'then' and 'else' blocks, though+ -- the blocks need not have the same type.+ let checkTestType ts ct =+ let ts' = mappend ts $ condTreeData ct+ -- If a conditional has only a 'then' block and no+ -- 'else' block, then it cannot have a valid type+ -- in every branch, unless the type is specified at+ -- a higher level in the tree.+ checkComponent (_, _, Nothing) = False+ -- If a conditional has a 'then' block and an 'else'+ -- block, both must specify a test type, unless the+ -- type is specified higher in the tree.+ checkComponent (_, t, Just e) =+ checkTestType ts' t && checkTestType ts' e+ -- Does the current node specify a test type?+ hasTestType = testInterface ts'+ /= testInterface emptyTestSuite+ components = condTreeComponents ct+ -- If the current level of the tree specifies a type,+ -- then we are done. If not, then one of the conditional+ -- branches below the current node must specify a type.+ -- Each node may have multiple immediate children; we+ -- only one need one to specify a type because the+ -- configure step uses 'mappend' to join together the+ -- results of flag resolution.+ in hasTestType || (any checkComponent components)+ if checkTestType emptyTestSuite flds+ then do+ skipField+ (repos, flags, lib, exes, tests, bms) <- getBody+ return (repos, flags, lib, exes, (testname, flds) : tests, bms)+ else lift $ syntaxError line_no $+ "Test suite \"" ++ testname+ ++ "\" is missing required field \"type\" or the field "+ ++ "is not present in all conditional branches. The "+ ++ "available test types are: "+ ++ intercalate ", " (map display knownTestTypes)++ | sec_type == "benchmark" -> do+ when (null sec_label) $ lift $ syntaxError line_no+ "'benchmark' needs one argument (the benchmark's name)"+ benchname <- lift $ runP line_no "benchmark" parseTokenQ sec_label+ flds <- collectFields (parseBenchmarkFields line_no) sec_fields++ -- Check that a valid benchmark type has been chosen. A type+ -- field may be given inside a conditional block, so we must+ -- check for that before complaining that a type field has not+ -- been given. The benchmark must always have a valid type, so+ -- we need to check both the 'then' and 'else' blocks, though+ -- the blocks need not have the same type.+ let checkBenchmarkType ts ct =+ let ts' = mappend ts $ condTreeData ct+ -- If a conditional has only a 'then' block and no+ -- 'else' block, then it cannot have a valid type+ -- in every branch, unless the type is specified at+ -- a higher level in the tree.+ checkComponent (_, _, Nothing) = False+ -- If a conditional has a 'then' block and an 'else'+ -- block, both must specify a benchmark type, unless the+ -- type is specified higher in the tree.+ checkComponent (_, t, Just e) =+ checkBenchmarkType ts' t && checkBenchmarkType ts' e+ -- Does the current node specify a benchmark type?+ hasBenchmarkType = benchmarkInterface ts'+ /= benchmarkInterface emptyBenchmark+ components = condTreeComponents ct+ -- If the current level of the tree specifies a type,+ -- then we are done. If not, then one of the conditional+ -- branches below the current node must specify a type.+ -- Each node may have multiple immediate children; we+ -- only one need one to specify a type because the+ -- configure step uses 'mappend' to join together the+ -- results of flag resolution.+ in hasBenchmarkType || (any checkComponent components)+ if checkBenchmarkType emptyBenchmark flds+ then do+ skipField+ (repos, flags, lib, exes, tests, bms) <- getBody+ return (repos, flags, lib, exes, tests, (benchname, flds) : bms)+ else lift $ syntaxError line_no $+ "Benchmark \"" ++ benchname+ ++ "\" is missing required field \"type\" or the field "+ ++ "is not present in all conditional branches. The "+ ++ "available benchmark types are: "+ ++ intercalate ", " (map display knownBenchmarkTypes)++ | sec_type == "library" -> do+ when (not (null sec_label)) $ lift $+ syntaxError line_no "'library' expects no argument"+ flds <- collectFields parseLibFields sec_fields+ skipField+ (repos, flags, lib, exes, tests, bms) <- getBody+ when (isJust lib) $ lift $ syntaxError line_no+ "There can only be one library section in a package description."+ return (repos, flags, Just flds, exes, tests, bms)++ | sec_type == "flag" -> do+ when (null sec_label) $ lift $+ syntaxError line_no "'flag' needs one argument (the flag's name)"+ flag <- lift $ parseFields+ flagFieldDescrs+ warnUnrec+ (MkFlag (FlagName (lowercase sec_label)) "" True False)+ sec_fields+ skipField+ (repos, flags, lib, exes, tests, bms) <- getBody+ return (repos, flag:flags, lib, exes, tests, bms)++ | sec_type == "source-repository" -> do+ when (null sec_label) $ lift $ syntaxError line_no $+ "'source-repository' needs one argument, "+ ++ "the repo kind which is usually 'head' or 'this'"+ kind <- case simpleParse sec_label of+ Just kind -> return kind+ Nothing -> lift $ syntaxError line_no $+ "could not parse repo kind: " ++ sec_label+ repo <- lift $ parseFields+ sourceRepoFieldDescrs+ warnUnrec+ (SourceRepo {+ repoKind = kind,+ repoType = Nothing,+ repoLocation = Nothing,+ repoModule = Nothing,+ repoBranch = Nothing,+ repoTag = Nothing,+ repoSubdir = Nothing+ })+ sec_fields+ skipField+ (repos, flags, lib, exes, tests, bms) <- getBody+ return (repo:repos, flags, lib, exes, tests, bms)++ | otherwise -> do+ lift $ warning $ "Ignoring unknown section type: " ++ sec_type+ skipField+ getBody+ Just f -> do+ _ <- lift $ syntaxError (lineNo f) $+ "Construct not supported at this position: " ++ show f+ skipField+ getBody+ Nothing -> return ([], [], Nothing, [], [], [])++ -- Extracts all fields in a block and returns a 'CondTree'.+ --+ -- We have to recurse down into conditionals and we treat fields that+ -- describe dependencies specially.+ collectFields :: ([Field] -> PM a) -> [Field]+ -> PM (CondTree ConfVar [Dependency] a)+ collectFields parser allflds = do++ let simplFlds = [ F l n v | F l n v <- allflds ]+ condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ]++ let (depFlds, dataFlds) = partition isConstraint simplFlds++ a <- parser dataFlds+ deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds++ ifs <- mapM processIfs condFlds++ return (CondNode a deps ifs)+ where+ isConstraint (F _ n _) = n `elem` constraintFieldNames+ isConstraint _ = False++ processIfs (IfBlock l c t e) = do+ cnd <- lift $ runP l "if" parseCondition c+ t' <- collectFields parser t+ e' <- case e of+ [] -> return Nothing+ es -> do fs <- collectFields parser es+ return (Just fs)+ return (cnd, t', e')+ processIfs _ = bug "processIfs called with wrong field type"++ parseLibFields :: [Field] -> PM Library+ parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary++ -- Note: we don't parse the "executable" field here, hence the tail hack.+ parseExeFields :: [Field] -> PM Executable+ parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable++ parseTestFields :: LineNo -> [Field] -> PM TestSuite+ parseTestFields line fields = do+ x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest+ emptyTestStanza fields+ lift $ validateTestSuite line x++ parseBenchmarkFields :: LineNo -> [Field] -> PM Benchmark+ parseBenchmarkFields line fields = do+ x <- lift $ parseFields benchmarkFieldDescrs storeXFieldsBenchmark+ emptyBenchmarkStanza fields+ lift $ validateBenchmark line x++ checkForUndefinedFlags ::+ [Flag] ->+ Maybe (CondTree ConfVar [Dependency] Library) ->+ [(String, CondTree ConfVar [Dependency] Executable)] ->+ [(String, CondTree ConfVar [Dependency] TestSuite)] ->+ PM ()+ checkForUndefinedFlags flags mlib exes tests = do+ let definedFlags = map flagName flags+ maybe (return ()) (checkCondTreeFlags definedFlags) mlib+ mapM_ (checkCondTreeFlags definedFlags . snd) exes+ mapM_ (checkCondTreeFlags definedFlags . snd) tests++ checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()+ checkCondTreeFlags definedFlags ct = do+ let fv = nub $ freeVars ct+ when (not . all (`elem` definedFlags) $ fv) $+ fail $ "These flags are used without having been defined: "+ ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ]+++-- | Parse a list of fields, given a list of field descriptions,+-- a structure to accumulate the parsed fields, and a function+-- that can decide what to do with fields which don't match any+-- of the field descriptions.+parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to+ -- parse+ -> UnrecFieldParser a -- ^ possibly do something with+ -- unrecognized fields+ -> a -- ^ accumulator+ -> [Field] -- ^ fields to be parsed+ -> ParseResult a+parseFields descrs unrec ini fields =+ do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields+ when (not (null unknowns)) $ do+ warning $ render $+ text "Unknown fields:" <+>+ commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")")+ (reverse unknowns))+ $+$+ text "Fields allowed in this section:" $$+ nest 4 (commaSep $ map fieldName descrs)+ return a+ where+ commaSep = fsep . punctuate comma . map text++parseField :: [FieldDescr a] -- ^ list of parseable fields+ -> UnrecFieldParser a -- ^ possibly do something with+ -- unrecognized fields+ -> (a,[(Int,String)]) -- ^ accumulated result and warnings+ -> Field -- ^ the field to be parsed+ -> ParseResult (a, [(Int,String)])+parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val)+ | name == f = parser line val a >>= \a' -> return (a',us)+ | otherwise = parseField fields unrec (a,us) (F line f val)+parseField [] unrec (a,us) (F l f val) = return $+ case unrec (f,val) a of -- no fields matched, see if the 'unrec'+ Just a' -> (a',us) -- function wants to do anything with it+ Nothing -> (a, ((l,f):us))+parseField _ _ _ _ = bug "'parseField' called on a non-field"++deprecatedFields :: [(String,String)]+deprecatedFields =+ deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo++deprecatedFieldsPkgDescr :: [(String,String)]+deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ]++deprecatedFieldsBuildInfo :: [(String,String)]+deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ]++-- Handle deprecated fields+deprecField :: Field -> ParseResult Field+deprecField (F line fld val) = do+ fld' <- case lookup fld deprecatedFields of+ Nothing -> return fld+ Just newName -> do+ warning $ "The field \"" ++ fld+ ++ "\" is deprecated, please use \"" ++ newName ++ "\""+ return newName+ return (F line fld' val)+deprecField _ = bug "'deprecField' called on a non-field"+++parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo+parseHookedBuildInfo inp = do+ fields <- readFields inp+ let ss@(mLibFields:exes) = stanzas fields+ mLib <- parseLib mLibFields+ biExes <- mapM parseExe (maybe ss (const exes) mLib)+ return (mLib, biExes)+ where+ parseLib :: [Field] -> ParseResult (Maybe BuildInfo)+ parseLib (bi@((F _ inFieldName _):_))+ | lowercase inFieldName /= "executable" = liftM Just (parseBI bi)+ parseLib _ = return Nothing++ parseExe :: [Field] -> ParseResult (String, BuildInfo)+ parseExe ((F line inFieldName mName):bi)+ | lowercase inFieldName == "executable"+ = do bis <- parseBI bi+ return (mName, bis)+ | otherwise = syntaxError line "expecting 'executable' at top of stanza"+ parseExe (_:_) = bug "`parseExe' called on a non-field"+ parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"++ parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st++-- ---------------------------------------------------------------------------+-- Pretty printing++writePackageDescription :: FilePath -> PackageDescription -> IO ()+writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg)++--TODO: make this use section syntax+-- add equivalent for GenericPackageDescription+showPackageDescription :: PackageDescription -> String+showPackageDescription pkg = render $+ ppPackage pkg+ $$ ppCustomFields (customFieldsPD pkg)+ $$ (case library pkg of+ Nothing -> empty+ Just lib -> ppLibrary lib)+ $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ]+ where+ ppPackage = ppFields pkgDescrFieldDescrs+ ppLibrary = ppFields libFieldDescrs+ ppExecutable = ppFields executableFieldDescrs++ppCustomFields :: [(String,String)] -> Doc+ppCustomFields flds = vcat (map ppCustomField flds)++ppCustomField :: (String,String) -> Doc+ppCustomField (name,val) = text name <> colon <+> showFreeText val++writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO ()+writeHookedBuildInfo fpath = writeFileAtomic fpath . showHookedBuildInfo++showHookedBuildInfo :: HookedBuildInfo -> String+showHookedBuildInfo (mb_lib_bi, ex_bis) = render $+ (case mb_lib_bi of+ Nothing -> empty+ Just bi -> ppBuildInfo bi)+ $$ vcat [ space+ $$ text "executable:" <+> text name+ $$ ppBuildInfo bi+ | (name, bi) <- ex_bis ]+ where+ ppBuildInfo bi = ppFields binfoFieldDescrs bi+ $$ ppCustomFields (customFieldsBI bi)++-- replace all tabs used as indentation with whitespace, also return where+-- tabs were found+findIndentTabs :: String -> [(Int,Int)]+findIndentTabs = concatMap checkLine+ . zip [1..]+ . lines+ where+ checkLine (lineno, l) =+ let (indent, _content) = span isSpace l+ tabCols = map fst . filter ((== '\t') . snd) . zip [0..]+ addLineNo = map (\col -> (lineno,col))+ in addLineNo (tabCols indent)++--test_findIndentTabs = findIndentTabs $ unlines $+-- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ]++bug :: String -> a+bug msg = error $ msg ++ ". Consider this a bug."+--}+
+ src/Distribution/PackageDescription/PrettyPrintCopied.hs view
@@ -0,0 +1,238 @@+-----------------------------------------------------------------------------+--+-- Module : Distribution.PackageDescription.PrettyPrintCopied+-- Copyright : Jürgen Nicklisch-Franken 2010+-- License : AllRightsReserved+--+-- Maintainer : cabal-devel@haskell.org+-- Stability : provisional+-- Portability : portable+--+-- | Pretty printing for cabal files+--+-----------------------------------------------------------------------------+{- All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Isaac Jones nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.PackageDescription.PrettyPrintCopied (+ writeGenericPackageDescription,+ showGenericPackageDescription,+) where++import Distribution.PackageDescription+ ( TestSuite(..), TestSuiteInterface(..), testType+ , SourceRepo(..),+ customFieldsBI, CondTree(..), Condition(..),+ FlagName(..), ConfVar(..), Executable(..), Library(..),+ Flag(..), PackageDescription(..),+ GenericPackageDescription(..))+import Text.PrettyPrint+ (hsep, comma, punctuate, fsep, parens, char, nest, empty,+ isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)+import Distribution.Simple.Utils (writeUTF8File)+import Distribution.ParseUtils (showFreeText, FieldDescr(..))+import Distribution.PackageDescription.ParseCopied (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,+ sourceRepoFieldDescrs)+import Distribution.Package (Dependency(..))+import Distribution.Text (Text(..))+import Data.Maybe (isJust, fromJust, isNothing)++indentWith :: Int+indentWith = 4++-- | Recompile with false for regression testing+simplifiedPrinting :: Bool+simplifiedPrinting = False++-- | Writes a .cabal file from a generic package description+writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO ()+writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg)++-- | Writes a generic package description to a string+showGenericPackageDescription :: GenericPackageDescription -> String+showGenericPackageDescription = render . ppGenericPackageDescription++ppGenericPackageDescription :: GenericPackageDescription -> Doc+ppGenericPackageDescription gpd =+ ppPackageDescription (packageDescription gpd)+ $+$ ppGenPackageFlags (genPackageFlags gpd)+ $+$ ppLibrary (condLibrary gpd)+ $+$ ppExecutables (condExecutables gpd)+ $+$ ppTestSuites (condTestSuites gpd)++ppPackageDescription :: PackageDescription -> Doc+ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd+ $+$ ppCustomFields (customFieldsPD pd)+ $+$ ppSourceRepos (sourceRepos pd)++ppSourceRepos :: [SourceRepo] -> Doc+ppSourceRepos [] = empty+ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl++ppSourceRepo :: SourceRepo -> Doc+ppSourceRepo repo =+ emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$+ (nest indentWith (ppFields sourceRepoFieldDescrs' repo))+ where+ sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"]++ppFields :: [FieldDescr a] -> a -> Doc+ppFields fields x =+ vcat [ ppField name (getter x)+ | FieldDescr name getter _ <- fields]++ppField :: String -> Doc -> Doc+ppField name fielddoc | isEmpty fielddoc = empty+ | otherwise = text name <> colon <+> fielddoc++ppDiffFields :: [FieldDescr a] -> a -> a -> Doc+ppDiffFields fields x y =+ vcat [ ppField name (getter x)+ | FieldDescr name getter _ <- fields,+ render (getter x) /= render (getter y)]++ppCustomFields :: [(String,String)] -> Doc+ppCustomFields flds = vcat [ppCustomField f | f <- flds]++ppCustomField :: (String,String) -> Doc+ppCustomField (name,val) = text name <> colon <+> showFreeText val++ppGenPackageFlags :: [Flag] -> Doc+ppGenPackageFlags flds = vcat [ppFlag f | f <- flds]++ppFlag :: Flag -> Doc+ppFlag (MkFlag name desc dflt manual) =+ emptyLine $ text "flag" <+> ppFlagName name $+$+ (nest indentWith ((if null desc+ then empty+ else text "Description: " <+> showFreeText desc) $+$+ (if dflt then empty else text "Default: False") $+$+ (if manual then text "Manual: True" else empty)))++ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc+ppLibrary Nothing = empty+ppLibrary (Just condTree) =+ emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib)+ where+ ppLib lib Nothing = ppFields libFieldDescrs lib+ $$ ppCustomFields (customFieldsBI (libBuildInfo lib))+ ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib+ $$ ppCustomFields (customFieldsBI (libBuildInfo lib))++ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc+ppExecutables exes =+ vcat [emptyLine $ text ("executable " ++ n)+ $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes]+ where+ ppExe (Executable _ modulePath' buildInfo') Nothing =+ (if modulePath' == "" then empty else text "main-is:" <+> text modulePath')+ $+$ ppFields binfoFieldDescrs buildInfo'+ $+$ ppCustomFields (customFieldsBI buildInfo')+ ppExe (Executable _ modulePath' buildInfo')+ (Just (Executable _ modulePath2 buildInfo2)) =+ (if modulePath' == "" || modulePath' == modulePath2+ then empty else text "main-is:" <+> text modulePath')+ $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2+ $+$ ppCustomFields (customFieldsBI buildInfo')++ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc+ppTestSuites suites =+ emptyLine $ vcat [ text ("test-suite " ++ n)+ $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite)+ | (n,condTree) <- suites]+ where+ ppTestSuite testsuite Nothing =+ text "type:" <+> disp (testType testsuite)+ $+$ maybe empty (\f -> text "main-is:" <+> text f)+ (testSuiteMainIs testsuite)+ $+$ maybe empty (\m -> text "test-module:" <+> disp m)+ (testSuiteModule testsuite)+ $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)+ $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))++ ppTestSuite (TestSuite _ _ buildInfo' _)+ (Just (TestSuite _ _ buildInfo2 _)) =+ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2+ $+$ ppCustomFields (customFieldsBI buildInfo')++ testSuiteMainIs test = case testInterface test of+ TestSuiteExeV10 _ f -> Just f+ _ -> Nothing++ testSuiteModule test = case testInterface test of+ TestSuiteLibV09 _ m -> Just m+ _ -> Nothing++ppCondition :: Condition ConfVar -> Doc+ppCondition (Var x) = ppConfVar x+ppCondition (Lit b) = text (show b)+ppCondition (CNot c) = char '!' <> (ppCondition c)+ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||"+ <+> ppCondition c2])+ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&"+ <+> ppCondition c2])+ppConfVar :: ConfVar -> Doc+ppConfVar (OS os) = text "os" <> parens (disp os)+ppConfVar (Arch arch) = text "arch" <> parens (disp arch)+ppConfVar (Flag name) = text "flag" <> parens (ppFlagName name)+ppConfVar (Impl c v) = text "impl" <> parens (disp c <+> disp v)++ppFlagName :: FlagName -> Doc+ppFlagName (FlagName name) = text name++ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc+ppCondTree ct@(CondNode it deps ifs) mbIt ppIt =+ let res = ppDeps deps+ $+$ (vcat $ map ppIf ifs)+ $+$ ppIt it mbIt+ in if isJust mbIt && isEmpty res+ then ppCondTree ct Nothing ppIt+ else res+ where+ ppIf (c,thenTree,mElseTree) =+ ((emptyLine $ text "if" <+> ppCondition c) $$+ nest indentWith (ppCondTree thenTree+ (if simplifiedPrinting then (Just it) else Nothing) ppIt))+ $+$ (if isNothing mElseTree+ then empty+ else text "else"+ $$ nest indentWith (ppCondTree (fromJust mElseTree)+ (if simplifiedPrinting then (Just it) else Nothing) ppIt))++ppDeps :: [Dependency] -> Doc+ppDeps [] = empty+ppDeps deps =+ text "build-depends:" <+> fsep (punctuate comma (map disp deps))++emptyLine :: Doc -> Doc+emptyLine d = text " " $+$ d+++
src/IDE/BufferMode.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -XDeriveDataTypeable -XTypeSynonymInstances -XMultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, TypeSynonymInstances, MultiParamTypeClasses #-} ----------------------------------------------------------------------------- -- -- Module : IDE.BufferMode@@ -17,11 +17,12 @@ import Prelude hiding(getLine) import IDE.Core.State-import Data.List (isSuffixOf)+import Data.List (isPrefixOf, elemIndices, isInfixOf, isSuffixOf) import IDE.TextEditor- (getOffset, startsLine, getIterAtMark, getSelectionBoundMark,- getInsertMark, EditorBuffer, getBuffer, EditorView, delete,- getText, forwardCharsC, insert, getIterAtLine, getLine)+ (EditorIter, getOffset, startsLine, getIterAtMark,+ getSelectionBoundMark, getInsertMark, EditorBuffer, getBuffer,+ EditorView, delete, getText, forwardCharsC, insert, getIterAtLine,+ getLine) import Data.IORef (IORef) import System.Time (ClockTime) import Data.Typeable (cast, Typeable)@@ -32,9 +33,9 @@ import Control.Monad (when) import Data.Maybe (catMaybes) import IDE.Utils.FileUtils-import Control.Monad.Reader import Graphics.UI.Gtk- (castToWidget, notebookPageNum, Notebook, ScrolledWindow)+ (Notebook, castToWidget, notebookPageNum, ScrolledWindow)+import Control.Monad.IO.Class (MonadIO(..)) -- * Buffer Basics@@ -136,9 +137,12 @@ modeEditComment :: IDEAction, modeEditUncomment :: IDEAction, modeSelectedModuleName :: IDEM (Maybe String),- modeEditToCandy :: IDEAction,+ modeEditToCandy :: (String -> Bool) -> IDEAction,+ modeTransformToCandy :: (String -> Bool) -> EditorBuffer -> IDEAction, modeEditFromCandy :: IDEAction,- modeEditKeystrokeCandy :: Maybe Char -> IDEAction+ modeEditKeystrokeCandy :: Maybe Char -> (String -> Bool) -> IDEAction,+ modeEditInsertCode :: String -> EditorIter -> EditorBuffer -> IDEAction,+ modeEditInCommentOrString :: String -> Bool } @@ -171,18 +175,32 @@ case fileName currentBuffer of Just filePath -> liftIO $ moduleNameFromFilePath filePath Nothing -> return Nothing,- modeEditToCandy = do+ modeTransformToCandy = \ inCommentOrString ebuf -> do ct <- readIDE candy+ transformToCandy ct ebuf inCommentOrString,+ modeEditToCandy = \ inCommentOrString -> do+ ct <- readIDE candy inActiveBufContext () $ \_ ebuf _ _ -> do- transformToCandy ct ebuf,+ transformToCandy ct ebuf inCommentOrString, modeEditFromCandy = do ct <- readIDE candy inActiveBufContext () $ \_ ebuf _ _ -> do transformFromCandy ct ebuf,- modeEditKeystrokeCandy = \c -> do+ modeEditKeystrokeCandy = \c inCommentOrString -> do ct <- readIDE candy inActiveBufContext () $ \_ ebuf _ _ -> do- keystrokeCandy ct c ebuf+ keystrokeCandy ct c ebuf inCommentOrString,+ modeEditInsertCode = \ str iter buf ->+ insert buf iter str,+ modeEditInCommentOrString = \ line ->+ if isInfixOf "--" line+ then True+ else let indices = elemIndices '"' line+ in if length indices == 0+ then False+ else if even (length indices)+ then False+ else True } literalHaskellMode = Mode {@@ -209,19 +227,32 @@ case fileName currentBuffer of Just filePath -> liftIO $ moduleNameFromFilePath filePath Nothing -> return Nothing,- modeEditToCandy = do+ modeTransformToCandy = \ inCommentOrString ebuf -> do ct <- readIDE candy+ transformToCandy ct ebuf inCommentOrString,+ modeEditToCandy = \ inCommentOrString -> do+ ct <- readIDE candy inActiveBufContext () $ \_ ebuf _ _ -> do- transformToCandy ct ebuf,+ transformToCandy ct ebuf inCommentOrString, modeEditFromCandy = do ct <- readIDE candy inActiveBufContext () $ \_ ebuf _ _ -> do transformFromCandy ct ebuf,- modeEditKeystrokeCandy = \c -> do+ modeEditKeystrokeCandy = \c inCommentOrString -> do ct <- readIDE candy inActiveBufContext () $ \_ ebuf _ _ -> do- keystrokeCandy ct c ebuf-}+ keystrokeCandy ct c ebuf inCommentOrString,+ modeEditInsertCode = \ str iter buf ->+ insert buf iter (unlines $ map (\ s -> "> " ++ s) $ lines str),+ modeEditInCommentOrString = \ line ->+ if not (isPrefixOf ">" line)+ then True+ else let indices = elemIndices '"' line+ in if length indices == 0+ then False+ else if even (length indices)+ then False+ else True } cabalMode = Mode { modeName = "Cabal",@@ -240,9 +271,13 @@ else return () return (), modeSelectedModuleName = return Nothing,- modeEditToCandy = return (),+ modeTransformToCandy = \ _ _ -> return (),+ modeEditToCandy = \ _ -> return (), modeEditFromCandy = return (),- modeEditKeystrokeCandy = \c -> return ()+ modeEditKeystrokeCandy = \ _ _ -> return (),+ modeEditInsertCode = \ str iter buf -> insert buf iter str,+ modeEditInCommentOrString = \ str -> isPrefixOf "--" str+ } otherMode = Mode {@@ -250,9 +285,12 @@ modeEditComment = return (), modeEditUncomment = return (), modeSelectedModuleName = return Nothing,- modeEditToCandy = return (),+ modeTransformToCandy = \ _ _ -> return (),+ modeEditToCandy = \ _ -> return (), modeEditFromCandy = return (),- modeEditKeystrokeCandy = \c -> return ()+ modeEditKeystrokeCandy = \_ _ -> return (),+ modeEditInsertCode = \str iter buf -> insert buf iter str,+ modeEditInCommentOrString = \ _ -> False } isHaskellMode mode = modeName mode == "Haskell" || modeName mode == "Literal Haskell"@@ -274,14 +312,18 @@ selectedModuleName = withCurrentMode Nothing modeSelectedModuleName editToCandy :: IDEAction-editToCandy = withCurrentMode () modeEditToCandy+editToCandy = withCurrentMode () (\m -> modeEditToCandy m (modeEditInCommentOrString m)) editFromCandy :: IDEAction editFromCandy = withCurrentMode () modeEditFromCandy editKeystrokeCandy :: Maybe Char -> IDEAction-editKeystrokeCandy c = withCurrentMode () (\m -> modeEditKeystrokeCandy m c)+editKeystrokeCandy c = withCurrentMode () (\m -> modeEditKeystrokeCandy m c+ (modeEditInCommentOrString m)) +editInsertCode :: EditorBuffer -> EditorIter -> String -> IDEAction+editInsertCode buffer iter str = withCurrentMode ()+ (\ m -> modeEditInsertCode m str iter buffer)
src/IDE/Build.hs view
@@ -15,19 +15,17 @@ module IDE.Build (- constrDepGraph, -- :: [IDEPackage] -> MakeGraph- constrMakeChain, -- :: MakeSettings -> MakeGraph -> [IDEPackage] -> BuildChain MakeOp- doBuildChain, -- :: BuildChain MakeOp -> IDE Bool- makePackages, MakeSettings(..), MakeOp(..),+ moNoOp,+ makePackages, defaultMakeSettings ) where import Data.Map (Map) import IDE.Core.State- (readIDE, IDEAction, Workspace(..), ipdPackageId, ipdDepends,- IDEPackage)+ (triggerEventIDE, readIDE, IDEAction, Workspace(..), ipdPackageId,+ ipdDepends, IDEPackage) import qualified Data.Map as Map (insert, empty, lookup, toList, fromList) import Data.Graph@@ -38,33 +36,75 @@ import Distribution.Version (withinRange) import Data.Maybe (mapMaybe) import IDE.Package- (packageClean', packageInstall', buildPackage, packageConfig')+ (packageClean', packageCopy', packageRegister', buildPackage, packageConfig', packageTest') import IDE.Core.Types- (Prefs(..), IDE(..), WorkspaceAction)-import Control.Monad.Reader+ (IDEEvent(..), Prefs(..), IDE(..), WorkspaceAction) import Distribution.Text (Text(..))+import Control.Event (EventSource(..))+import Control.Monad.Trans.Reader (ask)+import Control.Monad.Trans.Class (MonadTrans(..)) -- import Debug.Trace (trace) trace a b = b ---- ** Types+-- * Exported -type MyGraph a = Map a [a]+data MakeSettings = MakeSettings {+ msMakeMode :: Bool,+ msSingleBuildWithoutLinking :: Bool,+ msSaveAllBeforeBuild :: Bool,+ msBackgroundBuild :: Bool,+ msRunUnitTests :: Bool,+ msJumpToWarnings :: Bool,+ msDontInstallLast :: Bool} -type MakeGraph = MyGraph IDEPackage+-- | Take make settings from preferences+defaultMakeSettings :: Prefs -> MakeSettings+defaultMakeSettings prefs = MakeSettings {+ msMakeMode = makeMode prefs,+ msSingleBuildWithoutLinking = singleBuildWithoutLinking prefs,+ msSaveAllBeforeBuild = saveAllBeforeBuild prefs,+ msBackgroundBuild = backgroundBuild prefs,+ msRunUnitTests = runUnitTests prefs,+ msJumpToWarnings = jumpToWarnings prefs,+ msDontInstallLast = dontInstallLast prefs} -- | a make operation data MakeOp = MoConfigure | MoBuild- | MoInstall+ | MoTest+ | MoCopy+ | MoRegister | MoClean | MoDocu | MoOther String+ | MoMetaInfo -- rebuild meta info for workspace | MoComposed [MakeOp] deriving (Eq,Ord,Show) +moNoOp = MoComposed[]++-- | The interface to the build system+-- Consumes settings, a list of targets and a the operation to perform.+-- The firstOp will be applied to the first target+-- The restOp will be applied to all other targets+-- The finishOp will be applied to the last target after any op succeeded,+-- but it is applied after restOp has been tried on the last target+makePackages :: MakeSettings -> [IDEPackage] -> MakeOp -> MakeOp -> MakeOp -> WorkspaceAction+makePackages ms targets firstOp restOp finishOp = trace ("makePackages : " ++ show firstOp ++ " " ++ show restOp) $ do+ ws <- ask+ lift $ do+ prefs' <- readIDE prefs+ let plan = constrMakeChain ms ws targets firstOp restOp finishOp+ trace ("makeChain : " ++ show plan) $ doBuildChain ms plan++-- ** Types++type MyGraph a = Map a [a]++type MakeGraph = MyGraph IDEPackage+ data Chain alpha beta = Chain { mcAction :: alpha,@@ -74,84 +114,29 @@ | EmptyChain deriving Show -data MakeSettings = MakeSettings {- msMakeMode :: Bool,- msSingleBuildWithoutLinking :: Bool,- msSaveAllBeforeBuild :: Bool,- msBackgroundBuild :: Bool,- msDontInstallLast :: Bool}--defaultMakeSettings :: Prefs -> MakeSettings-defaultMakeSettings prefs = MakeSettings {- msMakeMode = makeMode prefs,- msSingleBuildWithoutLinking = singleBuildWithoutLinking prefs,- msSaveAllBeforeBuild = saveAllBeforeBuild prefs,- msBackgroundBuild = backgroundBuild prefs,- msDontInstallLast = dontInstallLast prefs}- -- ** Functions---- | Construct a dependency graph for a package--- pointing to the packages the subject package depends on-constrParentGraph :: [IDEPackage] -> MakeGraph-constrParentGraph targets = trace ("parentGraph : " ++ showGraph parGraph) parGraph- where- parGraph = Map.fromList- $ map (\ p -> (p,nub $ mapMaybe (depToTarget targets)(ipdDepends p))) targets---- | Construct a dependency graph for a package--- pointing to the packages which depend on the subject package-constrDepGraph :: [IDEPackage] -> MakeGraph-constrDepGraph packages = trace ("depGraph : " ++ showGraph depGraph) depGraph- where- depGraph = reverseGraph (constrParentGraph packages)--showGraph :: MakeGraph -> String-showGraph mg =- show- $ map (\(k,v) -> (disp (ipdPackageId k), (map (disp . ipdPackageId) v)))- $ Map.toList mg--showTopSorted :: [IDEPackage] -> String-showTopSorted = show . map (disp .ipdPackageId)- -- | Construct a make chain for a package, -- which is a plan of the build to perform. -- Consumes settings, the workspace and a list of targets.-constrMakeChain :: MakeSettings -> Workspace -> [IDEPackage] -> MakeOp -> MakeOp -> Chain MakeOp IDEPackage-constrMakeChain _ _ [] _ _ = EmptyChain+-- The first op is applied to the first target.++constrMakeChain :: MakeSettings -> Workspace -> [IDEPackage] -> MakeOp ->+ MakeOp -> MakeOp -> Chain MakeOp IDEPackage+-- No more targets+constrMakeChain _ _ [] _ _ _ = EmptyChain+ constrMakeChain ms@MakeSettings{msMakeMode = makeMode} Workspace{wsPackages = packages, wsNobuildPack = noBuilds}- targets@(headTarget:restTargets) op1 op2- | not makeMode = chainFor headTarget ms op1 EmptyChain Nothing- | otherwise = trace ("topsorted: " ++ showTopSorted topsorted)- constrElem targets topsorted depGraph ms noBuilds op1 op2- where- depGraph = constrDepGraph packages- topsorted = reverse $ topSortGraph $ constrParentGraph packages--constrElem :: [IDEPackage] -> [IDEPackage] -> MakeGraph -> MakeSettings -> [IDEPackage]- -> MakeOp -> MakeOp -> Chain MakeOp IDEPackage-constrElem _ [] _ _ _ _ _ = trace ("constrElem: 1") EmptyChain-constrElem [] _ _ _ _ _ _ = trace ("constrElem: 2") EmptyChain-constrElem currentTargets (current:rest) depGraph ms noBuilds op1 op2- | elem current currentTargets && not (elem current noBuilds) =- let dependents = case Map.lookup current depGraph of- Nothing -> trace ("Build>>constrMakeChain: unknown package"- ++ show current) []- Just deps -> deps- withoutInstall = msDontInstallLast ms && null (delete current dependents)- filteredOps = case op1 of- MoComposed l -> MoComposed (filter (\e -> e /= MoInstall) l)- MoInstall -> MoComposed []- other -> other- in trace ("constrElem1 deps: " ++ show dependents ++ " withoutInstall: " ++ show withoutInstall)- $- chainFor current ms (if withoutInstall then filteredOps else op1)- (constrElem (nub $ currentTargets ++ dependents) rest depGraph ms noBuilds op2 op2)- (Just EmptyChain)- | otherwise = trace ("constrElem2 " ++ show op2) $ constrElem currentTargets rest depGraph ms noBuilds op1 op2+ targets firstOp restOp finishOp =+ trace ("topsorted: " ++ showTopSorted topsorted)+ constrElem targets topsorted depGraph ms noBuilds+ firstOp restOp finishOp False+ where+ depGraph | makeMode = constrDepGraph packages+ | otherwise = Map.empty+ topsorted = reverse $ topSortGraph $ constrParentGraph packages +-- Constructs a make chain chainFor :: IDEPackage -> MakeSettings -> MakeOp -> Chain MakeOp IDEPackage -> Maybe (Chain MakeOp IDEPackage) -> Chain MakeOp IDEPackage@@ -166,34 +151,93 @@ mcPos = cont, mcNeg = mbNegCont} +-- Recursive building of a make chain+-- The first list of packages are the targets+-- The second list of packages is the topsorted graph of all deps of all targets+constrElem :: [IDEPackage] -> [IDEPackage] -> MakeGraph -> MakeSettings -> [IDEPackage]+ -> MakeOp -> MakeOp -> MakeOp -> Bool -> Chain MakeOp IDEPackage+constrElem currentTargets tops depGraph ms noBuilds+ firstOp restOp finishOp doneAnything++-- 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) =+ let current = head tops+ dependents = case Map.lookup current depGraph of+ Nothing -> trace ("Build>>constrMakeChain: unknown package"+ ++ show current) []+ Just deps -> deps+ withoutInstall = msDontInstallLast ms && null (delete current dependents)+ filteredOps = case firstOp of+ MoComposed l -> MoComposed (filter (\e -> e /= MoCopy && e /= MoRegister) l)+ MoCopy -> MoComposed []+ MoRegister -> MoComposed []+ other -> other+ in trace ("constrElem1 deps: " ++ show dependents ++ " withoutInstall: " ++ show withoutInstall)+ $+ chainFor current ms (if withoutInstall then filteredOps else firstOp)+ (constrElem (nub $ currentTargets ++ dependents)+ (tail tops) depGraph ms noBuilds restOp restOp finishOp True)+ (Just $ if doneAnything+ then chainFor current ms finishOp EmptyChain Nothing+ else EmptyChain)+-- no operations have to be applied to current, just try the next+ | otherwise = trace ("constrElem2 " ++ show restOp) $+ constrElem currentTargets (tail tops) depGraph ms noBuilds+ firstOp restOp finishOp doneAnything+++-- | Performs the operations of a build chain doBuildChain :: MakeSettings -> Chain MakeOp IDEPackage -> IDEAction doBuildChain _ EmptyChain = return ()-doBuildChain ms chain@Chain{mcAction = MoConfigure} = do+doBuildChain ms chain@Chain{mcAction = MoConfigure} = packageConfig' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain))-doBuildChain ms chain@Chain{mcAction = MoBuild} = do- buildPackage (msBackgroundBuild ms) (not (msMakeMode ms) && msSingleBuildWithoutLinking ms)+doBuildChain ms chain@Chain{mcAction = MoBuild} =+ buildPackage (msBackgroundBuild ms) (msJumpToWarnings ms) (not (msMakeMode ms) && msSingleBuildWithoutLinking ms) (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain))-doBuildChain ms chain@Chain{mcAction = MoInstall} = do- packageInstall' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain))-doBuildChain ms chain@Chain{mcAction = MoClean} = do+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} =+ packageRegister' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain))+doBuildChain ms chain@Chain{mcAction = MoClean} = packageClean' (mcEle chain) (constrCont ms (mcPos chain) (mcNeg chain))+doBuildChain ms chain@Chain{mcAction = MoMetaInfo} =+ triggerEventIDE UpdateWorkspaceInfo >> return () doBuildChain ms chain = doBuildChain ms (mcPos chain) constrCont ms pos (Just neg) False = doBuildChain ms neg constrCont ms pos _ _ = doBuildChain ms pos -makePackages :: MakeSettings -> [IDEPackage] -> MakeOp -> MakeOp -> WorkspaceAction-makePackages ms targets op1 op2 = trace ("makePackages : " ++ show op1 ++ " " ++ show op2) $ do- ws <- ask- lift $ do- prefs' <- readIDE prefs- let plan = constrMakeChain ms ws targets op1 op2- trace ("makeChain : " ++ show plan) $ doBuildChain ms plan+-- | Construct a dependency graph for a package+-- pointing to the packages the subject package depends on+constrParentGraph :: [IDEPackage] -> MakeGraph+constrParentGraph targets = trace ("parentGraph : " ++ showGraph parGraph) parGraph+ where+ parGraph = Map.fromList+ $ map (\ p -> (p,nub $ mapMaybe (depToTarget targets)(ipdDepends p))) targets +-- | Construct a dependency graph for a package+-- pointing to the packages which depend on the subject package+constrDepGraph :: [IDEPackage] -> MakeGraph+constrDepGraph packages = trace ("depGraph : " ++ showGraph depGraph) depGraph+ where+ depGraph = reverseGraph (constrParentGraph packages) +showGraph :: MakeGraph -> String+showGraph mg =+ show+ $ map (\(k,v) -> (disp (ipdPackageId k), (map (disp . ipdPackageId) v)))+ $ Map.toList mg++showTopSorted :: [IDEPackage] -> String+showTopSorted = show . map (disp .ipdPackageId)++ -- | Calculates for every dependency a target (or not) --- TODO depToTarget :: [IDEPackage] -> Dependency -> Maybe IDEPackage depToTarget list dep = find (doesMatch dep) list where@@ -233,10 +277,6 @@ myEdges = map (\(a,b) -> (lookItUp a, lookItUp b)) $ edges graph lookItUp = (\(_,e,_)-> e) . lookup ----calculateReverseDependencies ::--- Workspace -> Map IDEPackage [IDEPackage]---calculateReverseDependencies Workspace{wsPackages = wsPackages} = constrDepGraph wsPackages
src/IDE/Command.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Menu@@ -53,7 +54,6 @@ menuItemGetSubmenu, menuShellAppend, onActivateLeaf, menuItemNewWithLabel, menuNew, Packing(..), ToolbarStyle(..), PositionType(..), on, IconSize(..))-import Control.Monad.Reader import System.FilePath import Data.Version import Prelude hiding (catch)@@ -67,6 +67,7 @@ import IDE.Pane.PackageFlags import IDE.Pane.PackageEditor import IDE.Pane.Errors+import IDE.Pane.Search import IDE.Package import IDE.Pane.Log import IDE.Session@@ -97,11 +98,15 @@ import IDE.Workspaces import IDE.Statusbar import IDE.Pane.Workspace-import IDE.Pane.Variables (fillVariablesList)+import IDE.Pane.Variables (fillVariablesListQuiet) import IDE.Pane.Trace (fillTraceList) import IDE.PaneGroups-import IDE.Pane.Search (getSearch, setChoices, searchMetaGUI)+import IDE.Pane.Search (getSearch, IDESearch(..)) import IDE.Pane.Grep (getGrep)+import IDE.Pane.Files (getFiles)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (unless, when)+import Control.Monad.Trans.Reader (ask) -- -- | The Actions known to the system (they can be activated by keystrokes or menus)@@ -224,8 +229,8 @@ ,AD "ResolveErrors" "Resol_ve Errors" (Just "Resolve 'Hidden package' and 'Not in scope' errors by adding the necessary dependancies or imports") Nothing resolveErrors [] False - ,AD "InstallPackage" "_Install" Nothing Nothing- (packageTry_ packageInstall) [] False+ ,AD "InstallDependenciesPackage" "_Install Dependencies" (Just "Install the package's dependencies from the hackage server") Nothing+ (packageTry_ packageInstallDependencies) [] False ,AD "RegisterPackage" "_Register" Nothing Nothing (packageTry_ packageRegister) [] False ,AD "TestPackage" "Test" Nothing Nothing@@ -331,6 +336,8 @@ showDebugger [] False ,AD "ShowSearch" "Search" Nothing Nothing (getSearch Nothing >>= \ p -> displayPane p False) [] False+ ,AD "ShowFiles" "Files" Nothing Nothing+ (getFiles Nothing >>= \ p -> displayPane p False) [] False ,AD "ShowGrep" "Grep" Nothing Nothing (getGrep Nothing >>= \ p -> displayPane p False) [] False ,AD "ShowErrors" "Errors" Nothing Nothing@@ -409,6 +416,8 @@ ,AD "BackgroundBuildToggled" "_BackgroundBuild" (Just "Build in the background and report errors") (Just "ide_build") backgroundBuildToggled [] True+ ,AD "RunUnitTestsToggled" "_RunUnitTests" (Just "Run unit tests when building") (Just "gtk-apply")+ 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")@@ -510,44 +519,46 @@ textPopupMenu :: IDERef -> Menu -> IO () textPopupMenu ideR menu = do+ let reflectIDE_ x = reflectIDE x ideR items <- containerGetChildren menu mi1 <- menuItemNewWithLabel "Eval"- mi1 `onActivateLeaf` (reflectIDE debugExecuteSelection ideR)+ mi1 `onActivateLeaf` reflectIDE_ debugExecuteSelection menuShellAppend menu mi1 mi11 <- menuItemNewWithLabel "Eval & Insert"- mi11 `onActivateLeaf` (reflectIDE debugExecuteAndShowSelection ideR)+ mi11 `onActivateLeaf` reflectIDE_ debugExecuteAndShowSelection menuShellAppend menu mi11 mi12 <- menuItemNewWithLabel "Step"- mi12 `onActivateLeaf` (reflectIDE debugStepExpression ideR)+ mi12 `onActivateLeaf` reflectIDE_ debugStepExpression menuShellAppend menu mi12 mi13 <- menuItemNewWithLabel "Trace"- mi13 `onActivateLeaf` (reflectIDE debugTraceExpression ideR)+ mi13 `onActivateLeaf` reflectIDE_ debugTraceExpression menuShellAppend menu mi13 mi16 <- menuItemNewWithLabel "Set Breakpoint"- mi16 `onActivateLeaf` (reflectIDE debugSetBreakpoint ideR)+ mi16 `onActivateLeaf` reflectIDE_ debugSetBreakpoint menuShellAppend menu mi16 sep1 <- separatorMenuItemNew menuShellAppend menu sep1 mi14 <- menuItemNewWithLabel "Type"- mi14 `onActivateLeaf` (reflectIDE debugType ideR)+ mi14 `onActivateLeaf` reflectIDE_ debugType menuShellAppend menu mi14 mi141 <- menuItemNewWithLabel "Info"- mi141 `onActivateLeaf` (reflectIDE debugInformation ideR)+ mi141 `onActivateLeaf` reflectIDE_ debugInformation menuShellAppend menu mi141 mi15 <- menuItemNewWithLabel "Kind"- mi15 `onActivateLeaf` (reflectIDE debugKind ideR)+ mi15 `onActivateLeaf` reflectIDE_ debugKind menuShellAppend menu mi15 sep2 <- separatorMenuItemNew menuShellAppend menu sep2 mi2 <- menuItemNewWithLabel "Find (text)"- mi2 `onActivateLeaf` (reflectIDE (editFindInc Initial) ideR)+ mi2 `onActivateLeaf` reflectIDE_ (editFindInc Initial) menuShellAppend menu mi2 mi3 <- menuItemNewWithLabel "Search (metadata)"- mi3 `onActivateLeaf` (reflectIDE (do- mbtext <- selectedText- case mbtext of- Just t -> searchMetaGUI t- Nothing -> ideMessage Normal "Select a text first") ideR)+ mi3 `onActivateLeaf` (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,@@ -631,12 +642,15 @@ getActionsFor SensitivityBackwardHist = getActionsFor' ["ViewHistoryBack"] getActionsFor SensitivityProjectActive = getActionsFor' ["EditPackage", "PackageFlags", "ConfigPackage", "BuildPackage"- ,"DocPackage", "CleanPackage", "CopyPackage", "RunPackage","InstallPackage"+ ,"DocPackage", "CleanPackage", "CopyPackage", "RunPackage","InstallDependenciesPackage" ,"RegisterPackage", "TestPackage","SdistPackage" ,"OpenDocPackage","FileCloseAll"] getActionsFor SensitivityError = getActionsFor' ["NextError", "PreviousError"]-getActionsFor SensitivityEditor = getActionsFor' ["EditUndo", "EditRedo", "EditGotoLine"- ,"EditComment", "EditUncomment", "EditShiftLeft", "EditShiftRight"]+getActionsFor SensitivityEditor = getActionsFor' ["EditUndo", "EditRedo",+ "EditGotoLine","EditComment", "EditUncomment",+ "EditShiftLeft", "EditShiftRight","FileClose","ResolveErrors",+ "OpenDocu"+ ] getActionsFor SensitivityInterpreting = getActionsFor' ["QuitDebugger"] getActionsFor SensitivityWorkspaceOpen = return [] --TODO add here @@ -694,6 +708,7 @@ reflectIDE (do setCandyState (fst (sourceCandy prefs)) setBackgroundBuildToggled (backgroundBuild prefs)+ setRunUnitTests (runUnitTests prefs) setMakeModeToggled (makeMode prefs)) ideR instrumentSecWindow :: Window -> IDEAction@@ -733,7 +748,6 @@ when bs (editKeystrokeCandy mbChar) sk <- readIDE specialKey sks <- readIDE specialKeys- return True case sk of Nothing -> case Map.lookup (keyVal,sort mods) sks of@@ -763,23 +777,25 @@ printMods (m:r) = show m ++ printMods r handleSpecialKeystrokes _ = return True -setSymbol :: String -> IDEAction-setSymbol symbol = do+setSymbol :: String -> Bool -> IDEAction+setSymbol symbol openSource = do currentInfo' <- getWorkspaceInfo+ search <- getSearch Nothing case currentInfo' of Nothing -> return () Just ((GenScopeC (PackScope _ symbolTable1)),(GenScopeC (PackScope _ symbolTable2))) -> case filter (not . isReexported) (getIdentifierDescr symbol symbolTable1 symbolTable2) of [] -> return ()- a:[] -> selectIdentifier a+ a:[] -> selectIdentifier a openSource a:b:[] -> if isJust (dscMbModu a) && dscMbModu a == dscMbModu b && isNear (dscMbLocation a) (dscMbLocation b)- then selectIdentifier a- else setChoices [a,b]- l -> setChoices l+ then selectIdentifier a openSource+ else setChoices search [a,b]+ l -> setChoices search l where isNear (Just a) (Just b) = abs (locationSLine a - locationSLine b) <= 3 isNear _ _ = False+ -- -- | Register handlers for IDE events --@@ -790,9 +806,9 @@ (\e@(LogMessage s t) -> getLog >>= \(log :: IDELog) -> liftIO $ appendLog log s t >> return e) registerEvent stRef "SelectInfo"- (\ e@(SelectInfo str) -> setSymbol str >> return e)+ (\ e@(SelectInfo str gotoSource) -> setSymbol str gotoSource >> return e) registerEvent stRef "SelectIdent"- (\ e@(SelectIdent id) -> selectIdentifier id >> return e)+ (\ e@(SelectIdent id) -> selectIdentifier id False >> return e) registerEvent stRef "InfoChanged" (\ e@(InfoChanged b) -> reloadKeepSelection b >> return e) registerEvent stRef "UpdateWorkspaceInfo"@@ -805,7 +821,9 @@ registerEvent stRef "Sensitivity" (\ s@(Sensitivity h) -> setSensitivity h >> return s) registerEvent stRef "SearchMeta"- (\ e@(SearchMeta string) -> searchMetaGUI string >> return e)+ (\ e@(SearchMeta string) -> getSearch Nothing >>= (flip searchMetaGUI) string >> return e)+ registerEvent stRef "StartFindInitial"+ (\ e@(StartFindInitial) -> editFindInc Initial >> return e) registerEvent stRef "LoadSession" (\ e@(LoadSession fp) -> loadSession fp >> return e) registerEvent stRef "SaveSession"@@ -813,7 +831,7 @@ registerEvent stRef "UpdateRecent" (\ e@UpdateRecent -> updateRecentEntries >> return e) registerEvent stRef "VariablesChanged"- (\ e@VariablesChanged -> fillVariablesList >> return e)+ (\ e@VariablesChanged -> fillVariablesListQuiet >> return e) registerEvent stRef "ErrorChanged" (\ e@ErrorChanged -> postAsyncIDE fillErrorList >> return e) registerEvent stRef "CurrentErrorChanged"@@ -828,10 +846,13 @@ selectBreak mbLogRef) >> return e) registerEvent stRef "TraceChanged" (\ e@TraceChanged -> fillTraceList >> return e)+ registerEvent stRef "GotoDefinition"+ (\ e@(GotoDefinition descr) -> goToDefinition descr >> return e) registerEvent stRef "GetTextPopup" (\ e@(GetTextPopup _) -> return (GetTextPopup (Just textPopupMenu))) registerEvent stRef "StatusbarChanged" (\ e@(StatusbarChanged args) -> changeStatusbar args >> return e) return ()+
src/IDE/Completion.hs view
@@ -21,13 +21,14 @@ import Data.Char import Data.IORef import Control.Monad-import Control.Monad.Trans (liftIO) import Graphics.UI.Gtk as Gtk hiding(onKeyPress, onKeyRelease) import Graphics.UI.Gtk.Gdk.EventM as Gtk import IDE.Core.State import IDE.Metainfo.Provider(getDescription,getCompletionOptions)-import Control.Monad.Reader.Class (ask) import IDE.TextEditor+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Reader (ask)+import qualified Control.Monad.Reader as Gtk (liftIO) complete :: EditorView -> Bool -> IDEAction complete sourceView always = do@@ -47,7 +48,7 @@ currentState' <- readIDE currentState (_, completion') <- readIDE completion case (currentState',completion') of- (IsCompleting conn , Just (CompletionWindow window tv st)) ->+ (IsCompleting conn , Just (CompletionWindow window tv st)) -> do cancelCompletion window tv st conn _ -> return () @@ -255,15 +256,15 @@ (x, y) <- eventCoordinates time <- eventTime - drawWindow <- liftIO $ widgetGetDrawWindow window- status <- liftIO $ pointerGrab+ drawWindow <- Gtk.liftIO $ widgetGetDrawWindow window+ status <- Gtk.liftIO $ pointerGrab drawWindow False [PointerMotionMask, ButtonReleaseMask] (Nothing:: Maybe DrawWindow) Nothing time- when (status == GrabSuccess) $ liftIO $ do+ when (status == GrabSuccess) $ Gtk.liftIO $ do (width, height) <- windowGetSize window writeIORef resizeHandler $ Just $ \(newX, newY) -> do reflectIDE (@@ -272,18 +273,18 @@ return True idMotion <- liftIO $ window `on` motionNotifyEvent $ do- mbResize <- liftIO $ readIORef resizeHandler+ mbResize <- Gtk.liftIO $ readIORef resizeHandler case mbResize of- Just resize -> eventCoordinates >>= (liftIO . resize) >> return True+ Just resize -> eventCoordinates >>= (Gtk.liftIO . resize) >> return True Nothing -> return False idButtonRelease <- liftIO $ window `on` buttonReleaseEvent $ do- mbResize <- liftIO $ readIORef resizeHandler+ mbResize <- Gtk.liftIO $ readIORef resizeHandler case mbResize of Just resize -> do- eventCoordinates >>= (liftIO . resize)- eventTime >>= (liftIO . pointerUngrab)- liftIO $ writeIORef resizeHandler Nothing+ eventCoordinates >>= (Gtk.liftIO . resize)+ eventTime >>= (Gtk.liftIO . pointerUngrab)+ Gtk.liftIO $ writeIORef resizeHandler Nothing return True Nothing -> return False @@ -346,7 +347,7 @@ then return False else do wordStart <- getText buffer start end True- liftIO $ postGUIAsync $ do+ liftIO $ do -- dont use postGUIAsync - it causes bugs related to several repeated tryToUpdateOptions in thread reflectIDE (do options <- getCompletionOptions wordStart processResults window tree store sourceView wordStart options selectLCP isWordChar always) ideR
src/IDE/Core/State.hs view
@@ -1,5 +1,6 @@-{-# OPTIONS_GHC -XFlexibleContexts -XTypeSynonymInstances -XMultiParamTypeClasses- -XScopedTypeVariables -XCPP -XDeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances, FlexibleContexts, TypeSynonymInstances,+ MultiParamTypeClasses, ScopedTypeVariables, CPP,+ DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.State@@ -45,6 +46,7 @@ , reifyIDE , reflectIDE+, reflectIDEI , catchIDE , postSyncIDE , postAsyncIDE@@ -60,6 +62,7 @@ --, deactivatePaneIfActive --, closePane , activeProjectDir+, changePackage , liftYiControl , liftYi@@ -76,10 +79,9 @@ import Graphics.UI.Gtk.SourceView.SourceView () import Data.IORef-import Control.Monad.Reader hiding (liftIO) import Control.Exception import Prelude hiding (catch)-import Control.Monad.State+import Control.Monad.IO.Class (MonadIO, liftIO) import IDE.Core.Types import Graphics.UI.Frame.Panes import Graphics.UI.Frame.ViewFrame --hiding (notebookInsertOrdered)@@ -90,9 +92,14 @@ import IDE.Core.CTypes import Control.Concurrent (forkIO) import IDE.Utils.Utils-import qualified Data.Map as Map (lookup)+import qualified Data.Map as Map (empty, lookup) import Data.Typeable(Typeable) import qualified IDE.YiConfig as Yi+import Data.Enumerator (runIteratee, Iteratee(..))+import qualified Data.Enumerator as E+ (returnI, Step(..), yield, continue)+import Control.Monad (liftM, when)+import Control.Monad.Trans.Reader (ask, ReaderT(..)) instance PaneMonad IDEM where getFrameState = readIDE frameState@@ -284,6 +291,15 @@ reflectIDE :: IDEM a -> IDERef -> IO a reflectIDE c ideR = runReaderT c ideR +reflectIDEI :: Iteratee a IDEM b -> IDERef -> Iteratee a IO b+reflectIDEI c ideR = loop c where+ loop x = do+ s <- liftIO $ reflectIDE (runIteratee x) ideR+ case s of+ E.Continue f -> E.continue $ loop . f+ E.Yield a b -> E.yield a b+ E.Error e -> E.returnI $ E.Error e+ liftYiControl :: Yi.ControlM a -> IDEM a liftYiControl f = do control <- readIDE yiControl@@ -383,6 +399,24 @@ Just (n,_) -> if n == paneName pane then deactivatePane else return ()++changePackage :: IDEPackage -> IDEAction+changePackage ideP@IDEPackage{ipdCabalFile = file} = do+ oldWorkspace <- readIDE workspace+ case oldWorkspace of+ Nothing -> return ()+ Just ws -> do+ let ps = map exchange (wsPackages ws)+ modifyIDE_ (\ide -> ide{workspace = Just ws {wsPackages = ps},+ bufferProjCache = Map.empty})+ mbActivePack <- readIDE activePack+ case mbActivePack of+ Just activePack | ipdCabalFile ideP == ipdCabalFile activePack ->+ modifyIDE_ (\ide -> ide{activePack = Just ideP})+ _ -> return ()+ where+ exchange p | ipdCabalFile p == file = ideP+ | otherwise = p
src/IDE/Core/Types.hs view
@@ -33,6 +33,7 @@ , IDEAction , IDEEvent(..) , liftIDE+, (?>>=) , WorkspaceM , WorkspaceAction@@ -88,11 +89,11 @@ import Graphics.UI.Gtk (Window(..), KeyVal(..), Color(..), Menu(..), TreeView(..), ListStore(..), Toolbar(..))-import Control.Monad.Reader import Data.Unique (newUnique, Unique(..)) import Graphics.UI.Frame.Panes import Distribution.Package (PackageIdentifier(..), Dependency(..))+import Distribution.PackageDescription (BuildInfo) import Data.Map (Map(..)) import Data.Set (Set(..)) import Distribution.ModuleName (ModuleName(..))@@ -103,8 +104,7 @@ #endif import System.Time (ClockTime(..)) import Distribution.Simple (Extension(..))-import IDE.System.Process (ProcessHandle(..))-import IDE.Utils.Tool (ToolState(..))+import IDE.Utils.Tool (ToolState(..), ProcessHandle) import Data.IORef (writeIORef, readIORef, IORef(..)) import Numeric (showHex) import Control.Event@@ -115,6 +115,9 @@ import System.IO (Handle) import Distribution.Text(disp) import Text.PrettyPrint (render)+import Control.Monad.Trans.Class (lift)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ReaderT(..)) -- --------------------------------------------------------------------- -- IDE State@@ -187,6 +190,13 @@ liftIDE :: IDEM a -> WorkspaceM a liftIDE = lift +(?>>=) :: Monad m => (m (Maybe a)) -> (a -> m ()) -> m ()+a ?>>= b = do+ mA <- a+ case mA of+ Just v -> b v+ Nothing -> return ()+ -- --------------------------------------------------------------------- -- Monad for functions that need an open workspace --@@ -221,12 +231,14 @@ data IDEEvent = InfoChanged Bool-- is it the initial = True else False | UpdateWorkspaceInfo- | SelectInfo String+ | SelectInfo String Bool -- navigate to source (== True) | SelectIdent Descr | LogMessage String LogTag | RecordHistory GUIHistory | Sensitivity [(SensitivityMask,Bool)] | SearchMeta String+ | StartFindInitial+ | GotoDefinition Descr | LoadSession FilePath | SaveSession FilePath | UpdateRecent@@ -244,11 +256,13 @@ getSelector (InfoChanged _) = "InfoChanged" getSelector UpdateWorkspaceInfo = "UpdateWorkspaceInfo" getSelector (LogMessage _ _) = "LogMessage"- getSelector (SelectInfo _) = "SelectInfo"+ getSelector (SelectInfo _ _) = "SelectInfo" getSelector (SelectIdent _) = "SelectIdent" getSelector (RecordHistory _) = "RecordHistory" getSelector (Sensitivity _) = "Sensitivity" getSelector (SearchMeta _) = "SearchMeta"+ getSelector (StartFindInitial) = "StartFindInitial"+ getSelector (GotoDefinition _) = "GotoDefinition" getSelector (LoadSession _) = "LoadSession" getSelector (SaveSession _) = "SaveSession" getSelector UpdateRecent = "UpdateRecent"@@ -272,6 +286,9 @@ canTriggerEvent _ "Sensitivity" = True canTriggerEvent _ "DescrChoice" = True canTriggerEvent _ "SearchMeta" = True+ canTriggerEvent _ "StartFindInitial" = True+ canTriggerEvent _ "SearchSymbolDialog" = True+ canTriggerEvent _ "GotoDefinition" = True canTriggerEvent _ "LoadSession" = True canTriggerEvent _ "SaveSession" = True canTriggerEvent _ "UpdateRecent" = True@@ -303,13 +320,16 @@ ipdPackageId :: PackageIdentifier , ipdCabalFile :: FilePath , ipdDepends :: [Dependency]-, ipdModules :: Set ModuleName-, ipdMain :: [FilePath]+, ipdModules :: Map ModuleName BuildInfo+, ipdHasLibs :: Bool+, ipdTests :: [String]+, ipdMain :: [(FilePath, BuildInfo, Bool)] , ipdExtraSrcs :: Set FilePath , ipdSrcDirs :: [FilePath] , ipdExtensions :: [Extension] , ipdConfigFlags :: [String] , ipdBuildFlags :: [String]+, ipdTestFlags :: [String] , ipdHaddockFlags :: [String] , ipdExeFlags :: [String] , ipdInstallFlags :: [String]@@ -393,7 +413,9 @@ , docuSearchURL :: String , completeRestricted :: Bool , saveAllBeforeBuild :: Bool+ , jumpToWarnings :: Bool , backgroundBuild :: Bool+ , runUnitTests :: Bool , makeMode :: Bool , singleBuildWithoutLinking :: Bool , dontInstallLast :: Bool@@ -414,8 +436,10 @@ data SearchHint = Forward | Backward | Insert | Delete | Initial deriving (Eq) +#ifndef LEKSAH_WITH_YI instance Ord Modifier where compare a b = compare (fromEnum a) (fromEnum b)+#endif -- -- | Other types
src/IDE/Debug.hs view
@@ -66,7 +66,6 @@ , debugSetPrintBindResult ) where -import Control.Monad.Reader import IDE.Core.State import IDE.LogRef import Control.Exception (SomeException(..))@@ -77,21 +76,25 @@ import Distribution.Text (display) import IDE.Pane.Log (appendLog) import Data.List (isSuffixOf)-import IDE.System.Process (interruptProcessGroup) import IDE.Utils.GUIUtils (getDebugToggled) import IDE.Package (debugStart, executeDebugCommand, tryDebug_, printBindResultFlag, breakOnErrorFlag, breakOnExceptionFlag, printEvldWithShowFlag)-import IDE.Utils.Tool (ToolOutput(..), toolProcess)+import IDE.Utils.Tool (ToolOutput(..), toolProcess, interruptProcessGroupOf) import IDE.Workspaces (packageTry_)+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Reader (ask)+import Control.Monad.IO.Class (MonadIO(..)) -debugCommand :: String -> ([ToolOutput] -> IDEAction) -> DebugAction-debugCommand command handler = debugCommand' command- (\to -> do- handler to- triggerEventIDE VariablesChanged- return ())+debugCommand :: String -> E.Iteratee ToolOutput IDEM () -> DebugAction+debugCommand command handler = do+ debugCommand' command $ do+ handler+ lift $ triggerEventIDE VariablesChanged+ return () -debugCommand' :: String -> ([ToolOutput] -> IDEAction) -> DebugAction+debugCommand' :: String -> E.Iteratee ToolOutput IDEM () -> DebugAction debugCommand' command handler = do ghci <- ask lift $ catchIDE (runDebug (executeDebugCommand command handler) ghci)@@ -128,30 +131,29 @@ case maybeText of Just text -> packageTry_ $ tryDebug_ $ do debugSetLiberalScope- debugCommand text (\to -> do- insertTextAfterSelection $ " " ++ buildOutputString to- logOutput to)+ debugCommand text $ do+ (out, _) <- EL.zip (EL.fold buildOutputString "") logOutput+ lift $ insertTextAfterSelection $ " " ++ out Nothing -> ideMessage Normal "Please select some text in the editor to execute" where- buildOutputString :: [ToolOutput] -> String- buildOutputString (ToolOutput str:[]) = str- buildOutputString (ToolOutput str:r) = str ++ "\n" ++ (buildOutputString r)- buildOutputString (_:r) = buildOutputString r- buildOutputString [] = ""+ buildOutputString :: String -> ToolOutput -> String+ buildOutputString "" (ToolOutput str) = str+ buildOutputString s (ToolOutput str) = s ++ "\n" ++ str+ buildOutputString s _ = s debugSetLiberalScope :: DebugAction debugSetLiberalScope = do maybeModuleName <- lift selectedModuleName case maybeModuleName of Just moduleName -> do- debugCommand (":module *" ++ moduleName) (\ _ -> return ())+ debugCommand' (":module *" ++ moduleName) logOutput Nothing -> do mbPackage <- lift getActivePackageDescr case mbPackage of Nothing -> return () Just p -> let packageNames = map (display . modu . mdModuleId) (pdModules p) in debugCommand' (foldl (\a b -> a ++ " *" ++ b) ":module + " packageNames)- (\ _ -> return ())+ logOutput debugAbandon :: IDEAction debugAbandon = packageTry_ $ tryDebug_ $ debugCommand ":abandon" logOutput@@ -178,7 +180,7 @@ debugStop = do maybeDebug <- readIDE debugState liftIO $ case maybeDebug of- Just (_, ghci) -> toolProcess ghci >>= interruptProcessGroup+ Just (_, ghci) -> toolProcess ghci >>= interruptProcessGroupOf Nothing -> return () debugContinue :: IDEAction@@ -190,14 +192,12 @@ debugDeleteAllBreakpoints :: IDEAction debugDeleteAllBreakpoints = do- packageTry_ $ tryDebug_ $ debugCommand ":delete *" $ \output -> do- logOutput output+ packageTry_ $ tryDebug_ $ debugCommand ":delete *" logOutput setBreakpointList [] debugDeleteBreakpoint :: String -> LogRef -> IDEAction debugDeleteBreakpoint indexString lr = do- packageTry_ $ tryDebug_ $ debugCommand (":delete " ++ indexString) $ \output -> do- logOutput output+ packageTry_ $ tryDebug_ $ debugCommand (":delete " ++ indexString) logOutput bl <- readIDE breakpointRefs setBreakpointList $ filter (/= lr) bl ideR <- ask@@ -269,10 +269,10 @@ rootPath <- lift $ activeProjectDir tryDebug_ $ do (debugPackage, _) <- ask- debugCommand ":trace" (\to -> do- logOutputForLiveContext debugPackage to- triggerEventIDE TraceChanged- return ())+ debugCommand ":trace" $ do+ logOutputForLiveContext debugPackage+ lift $ triggerEventIDE TraceChanged+ return () debugTraceExpression :: IDEAction debugTraceExpression = do@@ -285,11 +285,11 @@ debugTraceExpr maybeText = do (debugPackage, _) <- ask case maybeText of- Just text -> debugCommand (":trace " ++ text) (\to -> do- rootPath <- activeProjectDir- logOutputForLiveContext debugPackage to- triggerEventIDE TraceChanged- return ())+ Just text -> debugCommand (":trace " ++ text) $ do+-- rootPath <- activeProjectDir+ logOutputForLiveContext debugPackage+ lift $ triggerEventIDE TraceChanged+ return () Nothing -> lift $ ideMessage Normal "Please select an expression in the editor" @@ -319,7 +319,7 @@ -> appendLog log (line ++ "\n") LogTag ToolOutput line -> appendLog log (line ++ "\n") InfoTag ToolError line -> appendLog log (line ++ "\n") ErrorTag- ToolPrompt -> defaultLineLogger' log output+ ToolPrompt _ -> defaultLineLogger' log output ToolExit _ -> appendLog log "X--X--X ghci process exited unexpectedly X--X--X" FrameTag return () @@ -367,7 +367,7 @@ case maybeText of Just text -> packageTry_ $ tryDebug_ $ do (debugPackage, _) <- ask- debugCommand (":module *" ++ moduleName) logOutput+ debugCommand' (":module *" ++ moduleName) logOutput debugCommand (":break " ++ text) (logOutputForSetBreakpoint debugPackage) Nothing -> do maybeLocation <- selectedLocation
src/IDE/Find.hs view
@@ -57,9 +57,12 @@ spinButtonGetValueAsInt, StateType(..), ToolbarStyle(..), IconSize(..), AttrOp(..), set, on, Color(..)) import Graphics.UI.Gtk.Gdk.Events-import Control.Monad.Reader+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk.Buttons.ToggleButton+import Graphics.UI.Gtk.Buttons.CheckButton import IDE.Core.State+import IDE.Utils.GUIUtils import IDE.TextEditor hiding(afterFocusIn) import IDE.Pane.SourceBuffer import Data.Char (digitToInt, isDigit, toLower, isAlphaNum)@@ -70,6 +73,10 @@ import Data.Array (bounds, (!), inRange) import IDE.Pane.Grep (grepWorkspace) import IDE.Workspaces (workspaceTry_, packageTry_)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Reader (ask)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad (liftM, filterM, when) data FindState = FindState { entryStr :: String@@ -199,9 +206,10 @@ sep1 <- separatorToolItemNew toolbarInsert toolbar sep1 0 + let performGrep = (reflectIDE (packageTry_ $ doGrep toolbar) ideR) grepButton <- toolButtonNew (Nothing :: Maybe Widget) (Just "Grep") toolbarInsert toolbar grepButton 0- grepButton `onToolButtonClicked` (reflectIDE (packageTry_ $ doGrep toolbar) ideR)+ grepButton `onToolButtonClicked` performGrep tooltipsSetTip tooltips grepButton "Search in multiple files" "" sep1 <- separatorToolItemNew@@ -300,35 +308,93 @@ doSearch toolbar Insert ideR return i) entry `afterDeleteText` (\ _ _ -> doSearch toolbar Delete ideR )- entry `afterKeyPress` (\ e -> case e of- k@(Key _ _ _ _ _ _ _ _ _ _)- | eventKeyName k == "Down" -> do- doSearch toolbar Forward ideR- return True- | eventKeyName k == "Up" -> do- doSearch toolbar Backward ideR- return True- | eventKeyName k == "Escape" -> do- getOut ideR- return True- | otherwise -> return False- _ -> return False)- entry `onEntryActivate` (doSearch toolbar Forward ideR)++++ entry `onEntryActivate` doSearch toolbar Forward ideR+ entry `Gtk.onFocusIn` \_ -> reflectIDE (triggerEventIDE (Sensitivity [(SensitivityEditor, False)]) >> return False) ideR++ replaceButton `onToolButtonClicked` replace toolbar Forward ideR+ let performReplaceAll = replaceAll toolbar Forward ideR+ replaceAllButton `onToolButtonClicked` performReplaceAll - replaceAllButton `onToolButtonClicked` replaceAll toolbar Forward ideR+ 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+ ctrl "r" = performReplaceAll >> return True+ ctrl "g" = performGrep >> return True+ ctrl _ = return False+ toggleToolButton btn = do+ old <- toggleToolButtonGetActive btn+ toggleToolButtonSetActive btn $ not old + entry `Gtk.onKeyPress` (\ e -> do+ case e of+ k@(Key _ _ _ _ _ _ _ _ _ _)+ | eventKeyName k == "Down" -> do+ doSearch toolbar Forward ideR+ return True+ | eventKeyName k == "Up" -> do+ doSearch toolbar Backward ideR+ return True+ | eventKeyName k == "Escape" -> do+ getOut ideR+ return True+ | eventKeyName k == "Tab" -> do+ re <- getReplaceEntry toolbar+ widgetGrabFocus re+ --- widgetAc+ return True+ | (mapControlCommand Control) `elem` (eventModifier k) ->+ ctrl $ map toLower $ eventKeyName k+ | otherwise -> return False+ _ -> return False) ++ rentry `Gtk.onKeyPress` (\ e -> do+ case e of+ k@(Key _ _ _ _ _ _ _ _ _ _)+ | eventKeyName k == "Tab" || eventKeyName k == "ISO_Left_Tab" -> do+ fe <- getFindEntry toolbar+ widgetGrabFocus fe+ return True+ | (mapControlCommand Control) `elem` (eventModifier k) ->+ ctrl $ map toLower $ eventKeyName k+ | otherwise -> return False+ _ -> return False)+++ spinL `afterFocusIn` (\ _ -> (reflectIDE (inActiveBufContext True $ \_ gtkbuf currentBuffer _ -> do max <- getLineCount gtkbuf liftIO $ spinButtonSetRange spinL 1.0 (fromIntegral max) return True) ideR)) + spinL `Gtk.onKeyPress` (\ e -> do+ case e of+ k@(Key _ _ _ _ _ _ _ _ _ _)+ | eventKeyName k == "Escape" -> do+ getOut ideR+ return True+ | eventKeyName k == "Tab" -> do+ re <- getFindEntry toolbar+ widgetGrabFocus re+ return True+ | (mapControlCommand Control) `elem` (eventModifier k) ->+ ctrl $ map toLower $ eventKeyName k+ | otherwise -> return False+ _ -> return False)++ spinL `afterEntryActivate` (reflectIDE (inActiveBufContext () $ \_ gtkbuf currentBuffer _ -> do line <- liftIO $ spinButtonGetValueAsInt spinL iter <- getIterAtLine gtkbuf (line - 1) placeCursor gtkbuf iter scrollToIter (sourceView currentBuffer) iter 0.2 Nothing+ liftIO $ getOut ideR return ()) ideR ) closeButton `onToolButtonClicked` do@@ -348,12 +414,7 @@ return toolbar where getOut = reflectIDE $ do hideFindbar- mbbuf <- maybeActiveBuf- case mbbuf of- Nothing -> return ()- Just buf -> do- grabFocus (sourceView buf)- return ()+ maybeActiveBuf ?>>= makeActive doSearch :: Toolbar -> SearchHint -> IDERef -> IO ()
src/IDE/ImportTool.hs view
@@ -1,399 +1,425 @@------------------------------------------------------------------------------------ Module : IDE.ImportTool--- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GPL------ Maintainer : Jutaro <jutaro@leksah.org>--- Stability : provisional--- Portability :------ | Help for constructing import statements-----------------------------------------------------------------------------------module IDE.ImportTool (- resolveErrors-, addOneImport-, addImport-, addPackage-, parseNotInScope-, parseHiddenModule-) where--import IDE.Core.State-import Data.Maybe (isNothing,isJust)-import IDE.Metainfo.Provider- (getPackageImportInfo, getIdentifierDescr)-import Text.PrettyPrint (render)-import Distribution.Text (simpleParse, display, disp)-import IDE.Pane.SourceBuffer-import Graphics.UI.Gtk-import Text.ParserCombinators.Parsec.Language (haskellStyle)-import Graphics.UI.Editor.MakeEditor- (getRealWidget, FieldDescription(..), buildEditor, mkField)-import Graphics.UI.Editor.Parameters- ((<<<-), paraMinSize, emptyParams, Parameter(..), paraMultiSel,- paraName)-import Data.Maybe (fromJust)-import Text.ParserCombinators.Parsec hiding (parse)-import qualified Text.ParserCombinators.Parsec as Parsec (parse)-import Graphics.UI.Editor.Simple (staticListEditor)-import Control.Monad (forM, when)-import Data.List (sort, nub, nubBy)-import IDE.Utils.ServerConnection-import Text.PrinterParser (prettyPrint)-import IDE.TextEditor (delete, setModified, insert, getIterAtLine)-import qualified Distribution.ModuleName as D (ModuleName(..))-import qualified Text.ParserCombinators.Parsec.Token as P- (operator, dot, identifier, symbol, lexeme, whiteSpace,- makeTokenParser)-import Control.Monad.Trans (liftIO)-import Distribution.PackageDescription.Parse- (writePackageDescription, readPackageDescription)-import Distribution.Verbosity (normal)-import IDE.Pane.PackageEditor (hasConfigs)-import Distribution.Package-import Distribution.Version (VersionRange(..))-import Distribution.PackageDescription (buildDepends)-import Distribution.PackageDescription.Configuration- (flattenPackageDescription)---- | Add all imports which gave error messages ...-resolveErrors :: IDEAction-resolveErrors = do- prefs' <- readIDE prefs- let buildInBackground = backgroundBuild prefs'- when buildInBackground $- modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = False}})- errors <- readIDE errorRefs- addPackageResults <- forM errors addPackage- let notInScopes = [ y | (x,y) <-- nubBy (\ (p1,_) (p2,_) -> p1 == p2)- $ [(x,y) | (x,y) <- [((parseNotInScope . refDescription) e, e) | e <- errors]],- isJust x]- when (not (or addPackageResults) && null notInScopes) $ ideMessage Normal $ "No errors that can be auto resolved"- addAll buildInBackground notInScopes (True,[])- where- addAll :: Bool -> [LogRef] -> (Bool,[Descr]) -> IDEM ()- addAll bib (errorSpec:rest) (True,descrList) = addImport errorSpec descrList (addAll bib rest)- addAll bib _ _ = finally bib-- finally buildInBackground = when buildInBackground $ do- prefs' <- readIDE prefs- modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = True}})---- | Add import for current error ...-addOneImport :: IDEAction-addOneImport = do- errors' <- readIDE errorRefs- currentErr' <- readIDE currentError- case currentErr' of- Nothing -> do- ideMessage Normal $ "No error selected"- return ()- Just ref -> addImport ref [] (\ _ -> return ())---- | Add one missing import--- Returns a boolean, if the process should be stopped in case of multiple addition--- Returns a list of already added descrs, so that it will not be added two times and can--- be used for default selection-addImport :: LogRef -> [Descr] -> ((Bool,[Descr]) -> IDEAction) -> IDEAction-addImport error descrList continuation =- case parseNotInScope (refDescription error) of- Nothing -> continuation (True,descrList)- Just nis -> do- currentInfo' <- getScopeForActiveBuffer- case currentInfo' of- Nothing -> continuation (True,descrList)- Just (GenScopeC(PackScope _ symbolTable1),GenScopeC(PackScope _ symbolTable2)) ->- let list = getIdentifierDescr (id' nis) symbolTable1 symbolTable2- in case list of- [] -> do- ideMessage Normal $ "Identifier " ++ (id' nis) ++- " not found in imported packages"- continuation (True, descrList)- descr : [] -> addImport' nis (logRefFullFilePath error) descr descrList continuation- list -> do- window' <- getMainWindow- mbDescr <- liftIO $ selectModuleDialog window' list (id' nis) (mbQual' nis)- (if null descrList- then Nothing- else Just (head descrList))- case mbDescr of- Nothing -> continuation (False, [])- Just descr -> if elem descr descrList- then continuation (True,descrList)- else addImport' nis (logRefFullFilePath error)- descr descrList continuation--addPackage :: LogRef -> IDEM Bool-addPackage error = do- case parseHiddenModule (refDescription error) of- Nothing -> return False- Just (HiddenModuleResult mod pack) -> do- let idePackage = logRefPackage error- package <- liftIO $ readPackageDescription normal (ipdCabalFile $ idePackage)- if hasConfigs package- then return False- else do- let flat = flattenPackageDescription package- ideMessage Normal $ "addPackage " ++ (display $ pkgName pack)- liftIO $ writePackageDescription (ipdCabalFile $ idePackage)- flat { buildDepends =- Dependency (pkgName pack) AnyVersion : buildDepends flat}- return True--getScopeForActiveBuffer :: IDEM (Maybe (GenScope, GenScope))-getScopeForActiveBuffer = do- mbActiveBuf <- maybeActiveBuf- case mbActiveBuf of- Nothing -> return Nothing- Just buf -> do- mbPackage <- belongsToPackage buf- case mbPackage of- Nothing -> return Nothing- Just pack -> getPackageImportInfo pack--addImport' :: NotInScopeParseResult -> FilePath -> Descr -> [Descr] -> ((Bool,[Descr]) -> IDEAction) -> IDEAction-addImport' nis filePath descr descrList continuation = do- mbBuf <- selectSourceBuf filePath- let mbMod = case dsMbModu descr of- Nothing -> Nothing- Just pm -> Just (modu pm)- case (mbBuf,mbMod) of- (Just buf,Just mod) -> do- inActiveBufContext () $ \ nb gtkbuf idebuf n -> do- ideMessage Normal $ "addImport " ++ show (dscName descr) ++ " from "- ++ (render $ disp $ mod)- doServerCommand (ParseHeaderCommand filePath) $ \ res ->- case res of- ServerHeader (Left imports) ->- case filter (qualifyAsImportStatement mod) imports of- [] -> let newLine = prettyPrint (newImpDecl mod) ++ "\n"- lastLine = foldr max 0 (map (locationELine . importLoc) imports)- in do- i1 <- getIterAtLine gtkbuf lastLine- insert gtkbuf i1 newLine- fileSave False- setModified gtkbuf True- continuation (True,(descr : descrList))- l@(impDecl:_) ->- let newDecl = addToDecl impDecl- newLine = prettyPrint newDecl ++ "\n"- myLoc = importLoc impDecl- lineStart = locationSLine myLoc- lineEnd = locationELine myLoc- in do- i1 <- getIterAtLine gtkbuf (lineStart - 1)- i2 <- getIterAtLine gtkbuf (lineEnd)- delete gtkbuf i1 i2- insert gtkbuf i1 newLine- fileSave False- setModified gtkbuf True- continuation (True,(descr : descrList))- ServerHeader (Right lastLine) ->- let newLine = prettyPrint (newImpDecl mod) ++ "\n"- in do- i1 <- getIterAtLine gtkbuf lastLine- insert gtkbuf i1 newLine- fileSave False- setModified gtkbuf True- continuation (True,(descr : descrList))- ServerFailed string -> do- ideMessage Normal ("Can't parse module header " ++ filePath ++- " failed with: " ++ string)- continuation (False,[])- _ -> do- ideMessage Normal ("ImportTool>>addImport: Impossible server answer")- continuation (False,[])- _ -> return ()- where- qualifyAsImportStatement :: D.ModuleName -> ImportDecl -> Bool- qualifyAsImportStatement moduleName impDecl =- let importName = importModule impDecl- getHiding (ImportSpecList isHiding _) = isHiding- in importName == display moduleName- && ((isNothing (mbQual' nis) && not (importQualified impDecl)) ||- (isJust (mbQual' nis) && importQualified impDecl- && fromJust (mbQual' nis) == qualString impDecl))- && (isNothing (importSpecs impDecl) || not (getHiding (fromJust (importSpecs impDecl))))- newImpDecl :: D.ModuleName -> ImportDecl- newImpDecl mod = ImportDecl {- importLoc = noLocation,- importModule = display mod,- importQualified = isJust (mbQual' nis),- importSrc = False,- importPkg = Nothing,- importAs = if isJust (mbQual' nis)- then Just (fromJust (mbQual' nis))- else Nothing,- importSpecs = (Just (ImportSpecList False [newImportSpec]))}- newImportSpec :: ImportSpec- newImportSpec = getRealId descr (id' nis)- addToDecl :: ImportDecl -> ImportDecl- addToDecl impDecl = case importSpecs impDecl of- Just (ImportSpecList True listIE) -> throwIDE "ImportTool>>addToDecl: ImpList is hiding"- Just (ImportSpecList False listIE) ->- impDecl{importSpecs = Just (ImportSpecList False (nub (newImportSpec : listIE)))}- Nothing ->- impDecl{importSpecs = Just (ImportSpecList False [newImportSpec])}- noLocation = Location 0 0 0 0--getRealId descr id = case descr of- Reexported rdescr -> getRealId (dsrDescr rdescr) id- Real edescr -> getReal (dscTypeHint' edescr)- where- getReal (FieldDescr d) = IThingAll (dscName d)- getReal (ConstructorDescr d) = IThingAll (dscName d)- getReal (MethodDescr d) = IThingAll (dscName d)- getReal _ = IVar id--qualString :: ImportDecl -> String-qualString impDecl = case importAs impDecl of- Nothing -> ""- Just modName -> modName---- | The import data--data NotInScopeParseResult = NotInScopeParseResult {- mbQual' :: Maybe String- , id' :: String- , isSub' :: Bool- , isOp' :: Bool}- deriving Eq---- |* The error line parser--lexer = P.makeTokenParser haskellStyle-whiteSpace = P.whiteSpace lexer-lexeme = P.lexeme lexer-symbol = P.symbol lexer-identifier = P.identifier lexer-dot = P.dot lexer-operator = P.operator lexer--parseNotInScope :: String -> (Maybe NotInScopeParseResult)-parseNotInScope str =- case Parsec.parse scopeParser "" str of- Left e -> Nothing- Right r -> Just r--scopeParser :: CharParser () NotInScopeParseResult-scopeParser = do- whiteSpace- symbol "Not in scope:"- isSub <- optionMaybe (try (choice [symbol "type constructor or class"- , symbol "data constructor"]))- symbol "`"- mbQual <- optionMaybe (try (do- q <- lexeme conid- dot- return q))- id <- optionMaybe (try identifier)- case id of- Just id -> return (NotInScopeParseResult mbQual- (take (length id - 1) id) (isJust isSub) False)- Nothing -> do- op <- operator- symbol "'"- return (NotInScopeParseResult mbQual op (isJust isSub) True)- <?> "scopeParser"--conid = do- c <- upper- cs <- many (alphaNum <|> oneOf "_'")- return (c:cs)- <?> "conid"----- |* The little dialog to choose between possible modules--moduleFields :: [String] -> String -> FieldDescription String-moduleFields list ident =- mkField- (paraName <<<- ParaName ("From which module is " ++ ident)- $ paraMultiSel <<<- ParaMultiSel False- $ paraMinSize <<<- ParaMinSize (300,400)- $ emptyParams)- (\ a -> a)- (\ a b -> a)- (staticListEditor ( list) id)--selectModuleDialog :: Window -> [Descr] -> String -> Maybe String -> Maybe Descr -> IO (Maybe Descr)-selectModuleDialog parentWindow list id mbQual mbDescr =- let selectionList = (nub . sort) $ map (render . disp . modu . fromJust . dsMbModu) list- in if length selectionList == 1- then return (Just (head list))- else do- let mbSelectedString = case mbDescr of- Nothing -> Nothing- Just descr -> case dsMbModu descr of- Nothing -> Nothing- Just pm -> Just ((render . disp . modu) pm)- let realSelectionString = case mbSelectedString of- Nothing -> head selectionList- Just str -> if elem str selectionList- then str- else head selectionList- let qualId = case mbQual of- Nothing -> id- Just str -> str ++ "." ++ id- dia <- dialogNew- windowSetTransientFor dia parentWindow- upper <- dialogGetUpper dia- okButton <- dialogAddButton dia "Ok" ResponseOk- dialogAddButton dia "Cancel" ResponseCancel- (widget,inj,ext,_) <- buildEditor (moduleFields selectionList qualId) realSelectionString- boxPackStart upper widget PackGrow 7- dialogSetDefaultResponse dia ResponseOk --does not work for the tree view- widgetShowAll dia- rw <- getRealWidget widget- set okButton [widgetCanDefault := True]- widgetGrabDefault okButton- resp <- dialogRun dia- value <- ext ([])- widgetHide dia- widgetDestroy dia- --find- case (resp,value) of- (ResponseOk,Just v) -> return (Just (head- (filter (\e -> case dsMbModu e of- Nothing -> False- Just pm -> (render . disp . modu) pm == v) list)))- _ -> return Nothing----testString = " Could not find module `Graphics.UI.Gtk':\n"--- ++ " It is a member of the hidden package `gtk-0.11.0'.\n"--- ++ " Perhaps you need to add `gtk' to the build-depends in your .cabal file.\n"--- ++ " Use -v to see a list of the files searched for."------test = parseHiddenModule testString == Just (HiddenModuleResult {hiddenModule = "Graphics.UI.Gtk", missingPackage = PackageIdentifier {pkgName = PackageName "gtk", pkgVersion = Version {versionBranch = [0,11,0], versionTags = []}}})--data HiddenModuleResult = HiddenModuleResult {- hiddenModule :: String- , missingPackage :: PackageId}- deriving (Eq, Show)--parseHiddenModule :: String -> (Maybe HiddenModuleResult)-parseHiddenModule str =- case Parsec.parse hiddenModuleParser "" str of- Left e -> Nothing- Right (mod, pack) ->- case simpleParse pack of- Just p -> Just $ HiddenModuleResult mod p- Nothing -> Nothing--hiddenModuleParser :: CharParser () (String, String)-hiddenModuleParser = do- whiteSpace- symbol "Could not find module `"- mod <- many (noneOf "'")- symbol "':\n"- whiteSpace- symbol "It is a member of the hidden package `"- pack <- many (noneOf "'")- symbol "'.\n"- many anyChar- return (mod, pack)- <?> "hiddenModuleParser"+----------------------------------------------------------------------------- +-- +-- Module : IDE.ImportTool +-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GPL +-- +-- Maintainer : Jutaro <jutaro@leksah.org> +-- Stability : provisional +-- Portability : +-- +-- | Help for constructing import statements +-- +----------------------------------------------------------------------------- + +module IDE.ImportTool ( + resolveErrors +, addOneImport +, addImport +, addPackage +, parseNotInScope +, parseHiddenModule +) where + +import IDE.Core.State +import Data.Maybe (isNothing,isJust) +import IDE.Metainfo.Provider + (getPackageImportInfo, getIdentifierDescr) +import Text.PrettyPrint (render) +import Distribution.Text (simpleParse, display, disp) +import IDE.Pane.SourceBuffer +import Graphics.UI.Gtk +import Text.ParserCombinators.Parsec.Language (haskellStyle) +import Graphics.UI.Editor.MakeEditor + (getRealWidget, FieldDescription(..), buildEditor, mkField) +import Graphics.UI.Editor.Parameters + ((<<<-), paraMinSize, emptyParams, Parameter(..), paraMultiSel, + paraName) +import Data.Maybe (fromJust) +import Text.ParserCombinators.Parsec hiding (parse) +import qualified Text.ParserCombinators.Parsec as Parsec (parse) +import Graphics.UI.Editor.Simple (staticListEditor) +import Control.Monad (forM, when) +import Data.List (sort, nub, nubBy) +import IDE.Utils.ServerConnection +import Text.PrinterParser (prettyPrint) +import IDE.TextEditor (delete, setModified, insert, getIterAtLine) +import qualified Distribution.ModuleName as D (ModuleName(..)) +import qualified Text.ParserCombinators.Parsec.Token as P + (operator, dot, identifier, symbol, lexeme, whiteSpace, + makeTokenParser) +import Distribution.PackageDescription.Parse + (readPackageDescription) +import Distribution.Verbosity (normal) +import IDE.Pane.PackageEditor (hasConfigs) +import Distribution.Package +import Distribution.Version (anyVersion) +import Distribution.PackageDescription + (CondTree(..), condExecutables, condLibrary, packageDescription, + buildDepends) +import Distribution.PackageDescription.Configuration + (flattenPackageDescription) +import IDE.BufferMode (editInsertCode) +import Control.Monad.IO.Class (MonadIO(..)) +#if MIN_VERSION_Cabal(1,10,0) +import Distribution.PackageDescription.PrettyPrintCopied + (writeGenericPackageDescription) +#else +import Distribution.PackageDescription.Parse + (writePackageDescription) +import Distribution.PackageDescription + (CondTree(..)) +#endif + +-- | Add all imports which gave error messages ... +resolveErrors :: IDEAction +resolveErrors = do + prefs' <- readIDE prefs + let buildInBackground = backgroundBuild prefs' + when buildInBackground $ + modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = False}}) + errors <- readIDE errorRefs + addPackageResults <- forM errors addPackage + let notInScopes = [ y | (x,y) <- + nubBy (\ (p1,_) (p2,_) -> p1 == p2) + $ [(x,y) | (x,y) <- [((parseNotInScope . refDescription) e, e) | e <- errors]], + isJust x] + when (not (or addPackageResults) && null notInScopes) $ ideMessage Normal $ "No errors that can be auto resolved" + addAll buildInBackground notInScopes (True,[]) + where + addAll :: Bool -> [LogRef] -> (Bool,[Descr]) -> IDEM () + addAll bib (errorSpec:rest) (True,descrList) = addImport errorSpec descrList (addAll bib rest) + addAll bib _ _ = finally bib + + finally buildInBackground = when buildInBackground $ do + prefs' <- readIDE prefs + modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = True}}) + +-- | Add import for current error ... +addOneImport :: IDEAction +addOneImport = do + errors' <- readIDE errorRefs + currentErr' <- readIDE currentError + case currentErr' of + Nothing -> do + ideMessage Normal $ "No error selected" + return () + Just ref -> addImport ref [] (\ _ -> return ()) + +-- | Add one missing import +-- Returns a boolean, if the process should be stopped in case of multiple addition +-- Returns a list of already added descrs, so that it will not be added two times and can +-- be used for default selection +addImport :: LogRef -> [Descr] -> ((Bool,[Descr]) -> IDEAction) -> IDEAction +addImport error descrList continuation = + case parseNotInScope (refDescription error) of + Nothing -> continuation (True,descrList) + Just nis -> do + currentInfo' <- getScopeForActiveBuffer + case currentInfo' of + Nothing -> continuation (True,descrList) + Just (GenScopeC(PackScope _ symbolTable1),GenScopeC(PackScope _ symbolTable2)) -> + let list = getIdentifierDescr (id' nis) symbolTable1 symbolTable2 + in case list of + [] -> do + ideMessage Normal $ "Identifier " ++ (id' nis) ++ + " not found in imported packages" + continuation (True, descrList) + descr : [] -> addImport' nis (logRefFullFilePath error) descr descrList continuation + list -> do + window' <- getMainWindow + mbDescr <- liftIO $ selectModuleDialog window' list (id' nis) (mbQual' nis) + (if null descrList + then Nothing + else Just (head descrList)) + case mbDescr of + Nothing -> continuation (False, []) + Just descr -> if elem descr descrList + then continuation (True,descrList) + else addImport' nis (logRefFullFilePath error) + descr descrList continuation + +addPackage :: LogRef -> IDEM Bool +addPackage error = do + case parseHiddenModule (refDescription error) of + Nothing -> return False + Just (HiddenModuleResult mod pack) -> do + let idePackage = logRefPackage error + gpd <- liftIO $ readPackageDescription normal (ipdCabalFile $ idePackage) + ideMessage Normal $ "addPackage " ++ (display $ pkgName pack) +#if MIN_VERSION_Cabal(1,10,0) + liftIO $ writeGenericPackageDescription (ipdCabalFile $ idePackage) + gpd { condLibrary = addDepToLib (packageName pack) (condLibrary gpd), + condExecutables = map (addDepToExe (packageName pack)) + (condExecutables gpd)} + return True +#else + if hasConfigs gpd + then return False + else do + let flat = flattenPackageDescription gpd + liftIO $ writePackageDescription (ipdCabalFile $ idePackage) + flat { buildDepends = + Dependency (pkgName pack) anyVersion : buildDepends flat} + return True +#endif + where + addDepToLib n Nothing = Nothing + addDepToLib n (Just cn@CondNode{condTreeConstraints = deps}) = + Just (cn{condTreeConstraints = (Dependency n anyVersion) : deps}) + addDepToExe n (str,cn@CondNode{condTreeConstraints = deps}) = + (str,cn{condTreeConstraints = (Dependency n anyVersion) : deps}) + +getScopeForActiveBuffer :: IDEM (Maybe (GenScope, GenScope)) +getScopeForActiveBuffer = do + mbActiveBuf <- maybeActiveBuf + case mbActiveBuf of + Nothing -> return Nothing + Just buf -> do + mbPackage <- belongsToPackage buf + case mbPackage of + Nothing -> return Nothing + Just pack -> getPackageImportInfo pack + +addImport' :: NotInScopeParseResult -> FilePath -> Descr -> [Descr] -> ((Bool,[Descr]) -> IDEAction) -> IDEAction +addImport' nis filePath descr descrList continuation = do + mbBuf <- selectSourceBuf filePath + let mbMod = case dsMbModu descr of + Nothing -> Nothing + Just pm -> Just (modu pm) + case (mbBuf,mbMod) of + (Just buf,Just mod) -> do + inActiveBufContext () $ \ nb gtkbuf idebuf n -> do + ideMessage Normal $ "addImport " ++ show (dscName descr) ++ " from " + ++ (render $ disp $ mod) + doServerCommand (ParseHeaderCommand filePath) $ \ res -> + case res of + ServerHeader (Left imports) -> + case filter (qualifyAsImportStatement mod) imports of + [] -> let newLine = prettyPrint (newImpDecl mod) ++ "\n" + lastLine = foldr max 0 (map (locationELine . importLoc) imports) + in do + i1 <- getIterAtLine gtkbuf lastLine + editInsertCode gtkbuf i1 newLine + fileSave False + setModified gtkbuf True + continuation (True,(descr : descrList)) + l@(impDecl:_) -> + let newDecl = addToDecl impDecl + newLine = prettyPrint newDecl ++ "\n" + myLoc = importLoc impDecl + lineStart = locationSLine myLoc + lineEnd = locationELine myLoc + in do + i1 <- getIterAtLine gtkbuf (lineStart - 1) + i2 <- getIterAtLine gtkbuf (lineEnd) + delete gtkbuf i1 i2 + editInsertCode gtkbuf i1 newLine + fileSave False + setModified gtkbuf True + continuation (True,(descr : descrList)) + ServerHeader (Right lastLine) -> + let newLine = prettyPrint (newImpDecl mod) ++ "\n" + in do + i1 <- getIterAtLine gtkbuf lastLine + editInsertCode gtkbuf i1 newLine + fileSave False + setModified gtkbuf True + continuation (True,(descr : descrList)) + ServerFailed string -> do + ideMessage Normal ("Can't parse module header " ++ filePath ++ + " failed with: " ++ string) + continuation (False,[]) + _ -> do + ideMessage Normal ("ImportTool>>addImport: Impossible server answer") + continuation (False,[]) + _ -> return () + where + qualifyAsImportStatement :: D.ModuleName -> ImportDecl -> Bool + qualifyAsImportStatement moduleName impDecl = + let importName = importModule impDecl + getHiding (ImportSpecList isHiding _) = isHiding + in importName == display moduleName + && ((isNothing (mbQual' nis) && not (importQualified impDecl)) || + (isJust (mbQual' nis) && importQualified impDecl + && fromJust (mbQual' nis) == qualString impDecl)) + && (isNothing (importSpecs impDecl) || not (getHiding (fromJust (importSpecs impDecl)))) + newImpDecl :: D.ModuleName -> ImportDecl + newImpDecl mod = ImportDecl { + importLoc = noLocation, + importModule = display mod, + importQualified = isJust (mbQual' nis), + importSrc = False, + importPkg = Nothing, + importAs = if isJust (mbQual' nis) + then Just (fromJust (mbQual' nis)) + else Nothing, + importSpecs = (Just (ImportSpecList False [newImportSpec]))} + newImportSpec :: ImportSpec + newImportSpec = getRealId descr (id' nis) + addToDecl :: ImportDecl -> ImportDecl + addToDecl impDecl = case importSpecs impDecl of + Just (ImportSpecList True listIE) -> throwIDE "ImportTool>>addToDecl: ImpList is hiding" + Just (ImportSpecList False listIE) -> + impDecl{importSpecs = Just (ImportSpecList False (nub (newImportSpec : listIE)))} + Nothing -> + impDecl{importSpecs = Just (ImportSpecList False [newImportSpec])} + noLocation = Location 0 0 0 0 + +getRealId descr id = case descr of + Reexported rdescr -> getRealId (dsrDescr rdescr) id + Real edescr -> getReal (dscTypeHint' edescr) + where + getReal (FieldDescr d) = IThingAll (dscName d) + getReal (ConstructorDescr d) = IThingAll (dscName d) + getReal (MethodDescr d) = IThingAll (dscName d) + getReal _ = IVar id + +qualString :: ImportDecl -> String +qualString impDecl = case importAs impDecl of + Nothing -> "" + Just modName -> modName + +-- | The import data + +data NotInScopeParseResult = NotInScopeParseResult { + mbQual' :: Maybe String + , id' :: String + , isSub' :: Bool + , isOp' :: Bool} + deriving Eq + +-- |* The error line parser + +lexer = P.makeTokenParser haskellStyle +whiteSpace = P.whiteSpace lexer +lexeme = P.lexeme lexer +symbol = P.symbol lexer +identifier = P.identifier lexer +dot = P.dot lexer +operator = P.operator lexer + +parseNotInScope :: String -> (Maybe NotInScopeParseResult) +parseNotInScope str = + case Parsec.parse scopeParser "" str of + Left e -> Nothing + Right r -> Just r + +scopeParser :: CharParser () NotInScopeParseResult +scopeParser = do + whiteSpace + symbol "Not in scope:" + isSub <- optionMaybe (try (choice [symbol "type constructor or class" + , symbol "data constructor"])) + symbol "`" + mbQual <- optionMaybe (try (do + q <- lexeme conid + dot + return q)) + id <- optionMaybe (try identifier) + case id of + Just id -> return (NotInScopeParseResult mbQual + (take (length id - 1) id) (isJust isSub) False) + Nothing -> do + op <- operator + symbol "'" + return (NotInScopeParseResult mbQual op (isJust isSub) True) + <?> "scopeParser" + +conid = do + c <- upper + cs <- many (alphaNum <|> oneOf "_'") + return (c:cs) + <?> "conid" + + +-- |* The little dialog to choose between possible modules + +moduleFields :: [String] -> String -> FieldDescription String +moduleFields list ident = + mkField + (paraName <<<- ParaName ("From which module is " ++ ident) + $ paraMultiSel <<<- ParaMultiSel False + $ paraMinSize <<<- ParaMinSize (300,400) + $ emptyParams) + (\ a -> a) + (\ a b -> a) + (staticListEditor ( list) id) + +selectModuleDialog :: Window -> [Descr] -> String -> Maybe String -> Maybe Descr -> IO (Maybe Descr) +selectModuleDialog parentWindow list id mbQual mbDescr = + let selectionList = (nub . sort) $ map (render . disp . modu . fromJust . dsMbModu) list + in if length selectionList == 1 + then return (Just (head list)) + else do + let mbSelectedString = case mbDescr of + Nothing -> Nothing + Just descr -> case dsMbModu descr of + Nothing -> Nothing + Just pm -> Just ((render . disp . modu) pm) + let realSelectionString = case mbSelectedString of + Nothing -> head selectionList + Just str -> if elem str selectionList + then str + else head selectionList + let qualId = case mbQual of + Nothing -> id + Just str -> str ++ "." ++ id + dia <- dialogNew + windowSetTransientFor dia parentWindow + upper <- dialogGetUpper dia + okButton <- dialogAddButton dia "Ok" ResponseOk + dialogAddButton dia "Cancel" ResponseCancel + (widget,inj,ext,_) <- buildEditor (moduleFields selectionList qualId) realSelectionString + boxPackStart upper widget PackGrow 7 + dialogSetDefaultResponse dia ResponseOk --does not work for the tree view + widgetShowAll dia + rw <- getRealWidget widget + set okButton [widgetCanDefault := True] + widgetGrabDefault okButton + resp <- dialogRun dia + value <- ext ([]) + widgetHide dia + widgetDestroy dia + --find + case (resp,value) of + (ResponseOk,Just v) -> return (Just (head + (filter (\e -> case dsMbModu e of + Nothing -> False + Just pm -> (render . disp . modu) pm == v) list))) + _ -> return Nothing + +--testString = " Could not find module `Graphics.UI.Gtk':\n" +-- ++ " It is a member of the hidden package `gtk-0.11.0'.\n" +-- ++ " Perhaps you need to add `gtk' to the build-depends in your .cabal file.\n" +-- ++ " Use -v to see a list of the files searched for." +-- +--test = parseHiddenModule testString == Just (HiddenModuleResult {hiddenModule = "Graphics.UI.Gtk", missingPackage = PackageIdentifier {pkgName = PackageName "gtk", pkgVersion = Version {versionBranch = [0,11,0], versionTags = []}}}) + +data HiddenModuleResult = HiddenModuleResult { + hiddenModule :: String + , missingPackage :: PackageId} + deriving (Eq, Show) + +parseHiddenModule :: String -> (Maybe HiddenModuleResult) +parseHiddenModule str = + case Parsec.parse hiddenModuleParser "" str of + Left e -> Nothing + Right (mod, pack) -> + case simpleParse pack of + Just p -> Just $ HiddenModuleResult mod p + Nothing -> Nothing + +hiddenModuleParser :: CharParser () (String, String) +hiddenModuleParser = do + whiteSpace + symbol "Could not find module `" + mod <- many (noneOf "'") + symbol "':\n" + whiteSpace + symbol "It is a member of the hidden package `" + pack <- many (noneOf "'") + symbol "'.\n" + many anyChar + return (mod, pack) + <?> "hiddenModuleParser"
src/IDE/Keymap.hs view
@@ -15,9 +15,9 @@ import Text.ParserCombinators.Parsec.Language(emptyDef) import Data.List (foldl',sort) import Data.Char(toLower)-import Control.Monad.Reader import IDE.Core.State+import Control.Monad (foldM) class Keymap alpha where parseKeymap :: FilePath -> IO alpha
src/IDE/Leksah.hs view
@@ -19,7 +19,6 @@ ) where import Graphics.UI.Gtk-import Control.Monad.Reader import Control.Concurrent import Data.IORef import Data.Maybe@@ -56,19 +55,30 @@ import Graphics.UI.Editor.Simple (enumEditor, stringEditor) import IDE.Metainfo.Provider (initInfo)-import IDE.Workspaces (workspaceOpenThis, backgroundMake)+import IDE.Workspaces+ (workspaceAddPackage', workspaceTryQuiet, workspaceNewHere,+ workspaceOpenThis, backgroundMake) import IDE.Utils.GUIUtils import Network (withSocketsDo) import Control.Exception import System.Exit(exitFailure) import qualified IDE.StrippedPrefs as SP-import IDE.Utils.Tool (runTool,toolline)-import IDE.System.Process(waitForProcess)+import IDE.Utils.Tool (runTool, toolline, waitForProcess) import System.Log-import System.Log.Logger(updateGlobalLogger,rootLoggerName,setLevel)+import System.Log.Logger+ (getLevel, getRootLogger, debugM, updateGlobalLogger,+ rootLoggerName, setLevel) import Data.List (stripPrefix)-import System.Directory (doesFileExist)+import System.Directory+ (doesDirectoryExist, copyFile, createDirectoryIfMissing,+ getHomeDirectory, doesFileExist) import System.FilePath (dropExtension, splitExtension, (</>))+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import Data.Enumerator (($$))+import Control.Monad (when, unless, liftM)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Applicative ((<$>)) -- -------------------------------------------------------------------- -- Command line options@@ -133,9 +143,9 @@ (o,files) <- ideOpts args isFirstStart <- liftM not $ hasSavedConfigFile standardPreferencesFilename- let sessions = filter (\x -> case x of- SessionN _ -> True- _ -> False) o+ let sessions = catMaybes $ map (\x -> case x of+ SessionN s -> Just s+ _ -> Nothing) o let sessionFPs = filter (\f -> snd (splitExtension f) == leksahSessionFileExtension) files let workspaceFPs = filter (\f -> snd (splitExtension f) == leksahWorkspaceFileExtension) files@@ -153,10 +163,9 @@ if exists then return (Just spath,Nothing) else return (Nothing,Just fp)- let ssession = if not (null sessions)- then (head $ map (\ (SessionN x) -> x) sessions) ++- leksahSessionFileExtension- else if null sourceFPs+ let ssession = case sessions of+ (s:_) -> s ++ leksahSessionFileExtension+ _ -> if null sourceFPs then standardSessionFilename else emptySessionFilename @@ -203,7 +212,7 @@ st <- unsafeInitGUIForThreadedRTS when rtsSupportsBoundThreads (sysMessage Normal "Linked with -threaded")- timeoutAddFull (yield >> return True) priorityDefaultIdle 100 -- maybe switch back to priorityHigh/???+ timeoutAddFull (yield >> return True) priorityHigh 10 mapM_ (sysMessage Normal) st initGtkRc dataDir <- getDataDir@@ -292,6 +301,7 @@ reflectIDE (do setCandyState (fst (sourceCandy startupPrefs)) setBackgroundBuildToggled (backgroundBuild startupPrefs)+ setRunUnitTests (runUnitTests startupPrefs) setMakeModeToggled (makeMode startupPrefs)) ideR let (x,y) = defaultSize startupPrefs windowSetDefaultSize win x y@@ -318,9 +328,25 @@ OSX.applicationReady osxApp - when isFirstStart $ do- welcomePath <- getConfigFilePathForLoad "welcome.txt" Nothing dataDir- reflectIDE (fileOpenThis welcomePath) ideR+ configDir <- getConfigDir+ let welcomePath = configDir</>"leksah-welcome"+ welcomeExists <- doesDirectoryExist welcomePath+ unless welcomeExists $ do+ let welcomeSource = dataDir</>"data"</>"leksah-welcome"+ welcomeCabal = welcomePath</>"leksah-welcome.cabal"+ welcomeMain = welcomePath</>"src"</>"Main.hs"+ createDirectoryIfMissing True $ welcomePath</>"src"+ copyFile (welcomeSource</>"Setup.lhs") (welcomePath</>"Setup.lhs")+ copyFile (welcomeSource</>"leksah-welcome.cabal") (welcomeCabal)+ copyFile (welcomeSource</>"src"</>"Main.hs") (welcomeMain)+ defaultWorkspace <- liftIO $ (</> "leksah.lkshw") <$> getHomeDirectory+ defaultExists <- liftIO $ doesFileExist defaultWorkspace+ reflectIDE (do+ if defaultExists+ then workspaceOpenThis False (Just defaultWorkspace)+ else workspaceNewHere defaultWorkspace+ workspaceTryQuiet $ workspaceAddPackage' welcomeCabal+ fileOpenThis welcomeMain) ideR reflectIDE (initInfo (modifyIDE_ (\ide -> ide{currentState = IsRunning}))) ideR timeoutAddFull (do reflectIDE (do@@ -423,15 +449,20 @@ setLeksahIcon dialog set dialog [ windowTitle := "Leksah: Updating Metadata",- windowWindowPosition := WinPosCenter]+ windowWindowPosition := WinPosCenter,+ windowDeletable := False] vb <- dialogGetUpper dialog progressBar <- progressBarNew progressBarSetText progressBar "Please wait while Leksah collects information about Haskell packages on your system" progressBarSetFraction progressBar 0.0 boxPackStart vb progressBar PackGrow 7 forkIO $ do- (output, pid) <- runTool "leksah-server" ["-sbo"] Nothing- mapM_ (update progressBar) output+ logger <- getRootLogger+ let verbosity = case getLevel logger of+ Just level -> ["--verbosity=" ++ show level]+ Nothing -> []+ (output, pid) <- runTool "leksah-server" (["-sbo", "+RTS", "-N2", "-RTS"] ++ verbosity) Nothing+ E.run_ $ output $$ EL.mapM_ (update progressBar) waitForProcess pid postGUIAsync (dialogResponse dialog ResponseOk) widgetShowAll dialog@@ -441,12 +472,10 @@ return () where update pb to = do- when (isJust prog) $ postGUIAsync (progressBarSetFraction pb (fromJust prog))- where- str = toolline to- prog = case stripPrefix "update_toolbar " str of- Just rest -> Just (read rest)- Nothing -> Nothing+ let str = toolline to+ case stripPrefix "update_toolbar " str of+ Just rest -> postGUIAsync $ progressBarSetFraction pb (read rest)+ Nothing -> liftIO $ debugM "leksah" str
src/IDE/LogRef.hs view
@@ -39,7 +39,6 @@ ) where import Graphics.UI.Gtk-import Control.Monad.Reader import Text.ParserCombinators.Parsec.Language import Text.ParserCombinators.Parsec hiding(Parser) import qualified Text.ParserCombinators.Parsec.Token as P@@ -55,6 +54,13 @@ import System.Exit (ExitCode(..)) import System.Log.Logger (debugM) import IDE.Utils.FileUtils(myCanonicalizePath)+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import Data.Enumerator ((=$))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (forM_, unless)+import Control.Monad.Trans.Reader (ask)+import Control.Monad.Trans.Class (lift) showSourceSpan :: LogRef -> String showSourceSpan = displaySrcSpan . logRefSrcSpan@@ -372,58 +378,62 @@ ToolInput line -> appendLog log (line ++ "\n") InputTag ToolOutput line -> appendLog log (line ++ "\n") LogTag ToolError line -> appendLog log (line ++ "\n") ErrorTag- ToolPrompt -> appendLog log (concat (take 20 (repeat "- ")) ++ "-\n") FrameTag+ ToolPrompt line -> do+ unless (null line) $ appendLog log (line ++ "\n") LogTag >> return ()+ appendLog log (concat (take 20 (repeat "- ")) ++ "-\n") FrameTag ToolExit ExitSuccess -> appendLog log (take 41 (repeat '-') ++ "\n") FrameTag ToolExit (ExitFailure 1) -> appendLog log (take 41 (repeat '=') ++ "\n") FrameTag ToolExit (ExitFailure n) -> appendLog log (take 41 ("========== " ++ show n ++ " " ++ repeat '=') ++ "\n") FrameTag -logOutputLines :: (IDELog -> ToolOutput -> IDEM a) -> [ToolOutput] -> IDEM [a]-logOutputLines lineLogger output = do- log :: IDELog <- getLog- liftIO $ bringPaneToFront log- results <- forM output $ lineLogger log- triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])+logOutputLines :: (IDELog -> ToolOutput -> IDEM a) -> E.Iteratee ToolOutput IDEM [a]+logOutputLines lineLogger = do+ ideR <- lift ask+ log <- lift getLog+ liftIO $ postGUISync $ bringPaneToFront log+ results <- (EL.mapM $ liftIO . postGUISync . flip reflectIDE ideR . lineLogger log) =$ EL.consume+ liftIO $ postGUISync $ reflectIDE (do+ triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])+ ) ideR return results -logOutputLines_ :: (IDELog -> ToolOutput -> IDEM a) -> [ToolOutput] -> IDEAction-logOutputLines_ lineLogger output = do- logOutputLines lineLogger output+logOutputLines_ :: (IDELog -> ToolOutput -> IDEM a) -> E.Iteratee ToolOutput IDEM ()+logOutputLines_ lineLogger = do+ logOutputLines lineLogger return () -logOutput :: [ToolOutput] -> IDEM ()-logOutput output = do- logOutputLines defaultLineLogger output+logOutput :: E.Iteratee ToolOutput IDEM ()+logOutput = do+ logOutputLines defaultLineLogger return () -logOutputForBuild :: IDEPackage -> Bool -> [ToolOutput] -> IDEAction-logOutputForBuild package backgroundBuild output = do- ideRef <- ask- log <- getLog- unless backgroundBuild $ liftIO $ bringPaneToFront log- errs <- liftIO $ readAndShow output ideRef log False []- setErrorList $ reverse errs- triggerEventIDE (Sensitivity [(SensitivityError,not (null errs))])- let errorNum = length (filter isError errs)- let warnNum = length errs - errorNum- triggerEventIDE (StatusbarChanged [CompartmentState- (show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings"), CompartmentBuild False])- unless backgroundBuild nextError- return ()- where- readAndShow :: [ToolOutput] -> IDERef -> IDELog -> Bool -> [LogRef] -> IO [LogRef]- readAndShow [] _ log _ errs = do- appendLog log ("----- Leksah Error Please Report -----\n") FrameTag- return errs- readAndShow (output:remainingOutput) ideR log inError errs = do- case output of+logOutputForBuild :: IDEPackage -> Bool -> Bool -> E.Iteratee ToolOutput IDEM ()+logOutputForBuild package backgroundBuild jumpToWarnings = do+ log <- lift getLog+ unless backgroundBuild $ liftIO $ postGUISync $ bringPaneToFront log+ (_, _, errs) <- EL.foldM readAndShow (log, False, [])+ ideR <- lift ask+ liftIO $ postGUISync $ reflectIDE (do+ setErrorList $ reverse errs+ triggerEventIDE (Sensitivity [(SensitivityError,not (null errs))])+ let errorNum = length (filter isError errs)+ let warnNum = length errs - errorNum+ triggerEventIDE (StatusbarChanged [CompartmentState+ (show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings"), CompartmentBuild False])+ unless (backgroundBuild || (not jumpToWarnings && errorNum == 0)) nextError+ return ()) ideR+ where+ readAndShow :: (IDELog, Bool, [LogRef]) -> ToolOutput -> IDEM (IDELog, Bool, [LogRef])+ readAndShow (log, inError, errs) output = do+ ideR <- ask+ liftIO $ postGUISync $ case output of ToolError line -> do let parsed = parse buildLineParser "" line let nonErrorPrefixes = ["Linking ", "ar:", "ld:", "ld warning:"] tag <- case parsed of Right BuildLine -> return InfoTag Right (OtherLine text) | "Linking " `isPrefixOf` text -> do- -- when backgroundBuild $ reflectIDE interruptProcess ideR- postGUIAsync $ reflectIDE (do+ -- when backgroundBuild $ lift interruptProcess+ reflectIDE (do setErrorList $ reverse errs ) ideR return InfoTag@@ -434,42 +444,43 @@ case (parsed, errs) of (Left e,_) -> do sysMessage Normal (show e)- readAndShow remainingOutput ideR log False errs+ return (log, False, errs) (Right ne@(ErrorLine span refType str),_) ->- readAndShow remainingOutput ideR log True ((LogRef span package str (lineNr,lineNr) refType):errs)+ return (log, True, ((LogRef span package str (lineNr,lineNr) refType):errs)) (Right (OtherLine str1),(LogRef span rootPath str (l1,l2) refType):tl) -> if inError- then readAndShow remainingOutput ideR log True ((LogRef span+ then return (log, True, ((LogRef span rootPath (if null str then line else str ++ "\n" ++ line)- (l1,lineNr) refType) : tl)- else readAndShow remainingOutput ideR log False errs+ (l1,lineNr) refType) : tl))+ else return (log, False, errs) (Right (WarningLine str1),(LogRef span rootPath str (l1,l2) isError):tl) -> if inError- then readAndShow remainingOutput ideR log True ((LogRef span+ then return (log, True, ((LogRef span rootPath (if null str then line else str ++ "\n" ++ line)- (l1,lineNr) WarningRef) : tl)- else readAndShow remainingOutput ideR log False errs- otherwise -> readAndShow remainingOutput ideR log False errs+ (l1,lineNr) WarningRef) : tl))+ else return (log, False, errs)+ otherwise -> return (log, False, errs) ToolOutput line -> do appendLog log (line ++ "\n") LogTag- readAndShow remainingOutput ideR log inError errs+ return (log, inError, errs) ToolInput line -> do appendLog log (line ++ "\n") InputTag- readAndShow remainingOutput ideR log inError errs- ToolPrompt -> do+ return (log, inError, errs)+ ToolPrompt line -> do+ unless (null line) $ appendLog log (line ++ "\n") LogTag >> return () let errorNum = length (filter isError errs) let warnNum = length errs - errorNum case errs of [] -> defaultLineLogger' log output _ -> appendLog log ("- - - " ++ show errorNum ++ " errors - " ++ show warnNum ++ " warnings - - -\n") FrameTag- return errs+ return (log, inError, errs) ToolExit _ -> do let errorNum = length (filter isError errs) let warnNum = length errs - errorNum@@ -477,10 +488,10 @@ [] -> defaultLineLogger' log output _ -> appendLog log ("----- " ++ show errorNum ++ " errors -- " ++ show warnNum ++ " warnings -----\n") FrameTag- return errs+ return (log, inError, errs) -logOutputForBreakpoints :: IDEPackage -> [ToolOutput] -> IDEAction-logOutputForBreakpoints package output = do+logOutputForBreakpoints :: IDEPackage -> E.Iteratee ToolOutput IDEM ()+logOutputForBreakpoints package = do breaks <- logOutputLines (\log out -> do case out of ToolOutput line -> do@@ -490,12 +501,12 @@ return $ Just $ LogRef span package line (logLineNumber, logLineNumber) BreakpointRef _ -> return Nothing _ -> do- defaultLineLogger log out- return Nothing) output- setBreakpointList $ catMaybes breaks+ liftIO $ defaultLineLogger' log out+ return Nothing)+ lift $ setBreakpointList $ catMaybes breaks -logOutputForSetBreakpoint :: IDEPackage -> [ToolOutput] -> IDEAction-logOutputForSetBreakpoint package output = do+logOutputForSetBreakpoint :: IDEPackage -> E.Iteratee ToolOutput IDEM ()+logOutputForSetBreakpoint package = do breaks <- logOutputLines (\log out -> do case out of ToolOutput line -> do@@ -506,11 +517,11 @@ _ -> return Nothing _ -> do defaultLineLogger log out- return Nothing) output- addLogRefs $ catMaybes breaks+ return Nothing)+ lift $ addLogRefs $ catMaybes breaks -logOutputForContext :: IDEPackage -> (String -> [SrcSpan]) -> [ToolOutput] -> IDEAction-logOutputForContext package getContexts output = do+logOutputForContext :: IDEPackage -> (String -> [SrcSpan]) -> E.Iteratee ToolOutput IDEM ()+logOutputForContext package getContexts = do refs <- fmap catMaybes $ logOutputLines (\log out -> do case out of ToolOutput line -> do@@ -521,12 +532,12 @@ else return $ Just $ LogRef (last contexts) package line (logLineNumber, logLineNumber) ContextRef _ -> do defaultLineLogger log out- return Nothing) output- unless (null refs) $ do+ return Nothing)+ lift $ unless (null refs) $ do addLogRefs [last refs] lastContext -logOutputForLiveContext :: IDEPackage -> [ToolOutput] -> IDEAction+logOutputForLiveContext :: IDEPackage -> E.Iteratee ToolOutput IDEM () logOutputForLiveContext package = logOutputForContext package getContexts where getContexts [] = []@@ -536,7 +547,7 @@ _ -> getContexts xs _ -> getContexts xs -logOutputForHistoricContext :: IDEPackage -> [ToolOutput] -> IDEAction+logOutputForHistoricContext :: IDEPackage -> E.Iteratee ToolOutput IDEM () logOutputForHistoricContext package = logOutputForContext package getContexts where getContexts line = case stripPrefix "Logged breakpoint at " line of
src/IDE/Metainfo/Provider.hs view
@@ -39,7 +39,6 @@ import System.IO.Strict (readFile) import qualified Data.Map as Map import Control.Monad-import Control.Monad.Trans import System.FilePath import System.Directory import Data.List@@ -67,6 +66,9 @@ import Control.Exception (SomeException(..), catch) import Prelude hiding(catch, readFile) import IDE.Utils.ServerConnection(doServerCommand)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (MonadTrans(..))+import Distribution.PackageDescription (hsSourceDirs) trace a b = b @@ -259,22 +261,22 @@ let (packageMap, ic) = case pi `Map.lookup` workspInfoCache' of Nothing -> (Map.empty,True) Just m -> (m,False)- modPairsMb <- liftIO $ mapM (\ modName -> do+ modPairsMb <- liftIO $ mapM (\(modName, bi) -> do sf <- case modName `Map.lookup` packageMap of- Nothing -> findSourceFile srcDirs' haskellSrcExts modName- Just (_,Nothing,_) -> findSourceFile srcDirs' haskellSrcExts modName+ Nothing -> findSourceFile (srcDirs' bi) haskellSrcExts modName+ Just (_,Nothing,_) -> findSourceFile (srcDirs' bi) haskellSrcExts modName Just (_,Just fp,_) -> return (Just fp) return (modName, sf))- $ Set.toList $ ipdModules idePack- mainModules <- liftIO $ mapM (\fn -> do- mbFn <- findSourceFile' srcDirs' fn+ $ Map.toList $ ipdModules idePack+ mainModules <- liftIO $ mapM (\(fn, bi, isTest) -> do+ mbFn <- findSourceFile' (srcDirs' bi) fn return (main,mbFn)) (ipdMain idePack) let modPairsMb' = case mainModules of [] -> modPairsMb hd:_ -> hd : modPairsMb let (modWith,modWithout) = partition (\(x,y) -> isJust y) modPairsMb'- let modWithSources = map (\(f,Just s) -> (f,s)) modWith+ let modWithSources = map (\(f,s) -> (f,fromJust s)) modWith let modWithoutSources = map fst $ modWithout -- Now see which modules have to be truely updated modToUpdate <- if rebuild@@ -304,7 +306,7 @@ pdBuildDepends = buildDepends})) where basePath = normalise $ (takeDirectory (ipdCabalFile idePack))- srcDirs' = map (basePath </>) (ipdSrcDirs idePack)+ srcDirs' bi = map (basePath </>) (hsSourceDirs bi) pi = ipdPackageId idePack figureOutRealSources :: IDEPackage -> [(ModuleName,FilePath)] -> IO [(ModuleName,FilePath)]
src/IDE/NotebookFlipper.hs view
@@ -29,10 +29,10 @@ windowNewPopup, TreeViewClass, WindowPosition(..), signalDisconnect, AttrOp(..), set) import IDE.Core.State-import Control.Monad.Trans (liftIO) import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Control.Monad (when) import IDE.Pane.SourceBuffer(recentSourceBuffers)+import Control.Monad.IO.Class (MonadIO(..)) flipDown :: IDEAction flipDown = do
src/IDE/OSX.hs view
@@ -48,15 +48,15 @@ mbAbout <- uiManagerGetWidget uiManager "/ui/menubar/_Help/_About" case mbAbout of Just about -> do- group <- applicationAddAppMenuGroup app- applicationAddAppMenuItem app group (castToMenuItem about)+ applicationInsertAppMenuItem app (castToMenuItem about) 0+ sep <- separatorMenuItemNew+ applicationInsertAppMenuItem app sep 1 Nothing -> return () mbPrefs <- uiManagerGetWidget uiManager "/ui/menubar/_Configuration/Edit general Preferences" case mbPrefs of Just prefs -> do- group <- applicationAddAppMenuGroup app- applicationAddAppMenuItem app group (castToMenuItem prefs)+ applicationInsertAppMenuItem app (castToMenuItem prefs) 2 Nothing -> return () app `on` blockTermination $ reflectIDE (fmap not canQuit) ideR
src/IDE/Package.hs view
@@ -15,7 +15,6 @@ -- --------------------------------------------------------------------------------- - module IDE.Package ( packageConfig , packageConfig'@@ -25,14 +24,16 @@ , packageClean , packageClean' , packageCopy+, packageCopy' , packageRun , activatePackage , deactivatePackage -, packageInstall-, packageInstall'+, packageInstallDependencies , packageRegister+, packageRegister' , packageTest+, packageTest' , packageSdist , packageOpenDoc @@ -43,6 +44,7 @@ , delModuleFromPackageDescr , backgroundBuildToggled+, runUnitTestsToggled , makeModeToggled , debugStart@@ -53,15 +55,17 @@ , printEvldWithShowFlag , tryDebug , tryDebug_+, tryDebugQuiet+, tryDebugQuiet_ , executeDebugCommand , choosePackageFile , idePackageFromPath+ ) where import Graphics.UI.Gtk-import Control.Monad.Reader import Distribution.Package hiding (depends,packageId) import Distribution.PackageDescription import Distribution.PackageDescription.Parse@@ -89,20 +93,35 @@ import qualified System.IO.UTF8 as UTF8 (readFile) import IDE.Utils.Tool (ToolOutput(..), runTool, newGhci, ToolState(..)) import qualified Data.Set as Set (fromList)-import qualified Data.Map as Map (empty)+import qualified Data.Map as Map (empty, fromList) import System.Exit (ExitCode(..)) import Control.Applicative ((<$>))-import IDE.System.Process (getProcessExitCode, interruptProcessGroup)-import IDE.Utils.Tool (executeGhciCommand)+import IDE.Utils.Tool (executeGhciCommand, getProcessExitCode, interruptProcessGroupOf)+import qualified Data.Enumerator as E (run_, Iteratee(..), last)+import qualified Data.Enumerator.List as EL (foldM, zip3, zip)+import Data.Enumerator (($$))+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+ (writeGenericPackageDescription)+#endif+import Debug.Trace (trace) +moduleInfo :: (a -> BuildInfo) -> (a -> [ModuleName]) -> a -> [(ModuleName, BuildInfo)]+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 -> libModules l-myExeModules pd = concatMap exeModules (executables pd)+ Just l -> moduleInfo libBuildInfo libModules l+myExeModules pd = concatMap (moduleInfo buildInfo exeModules) (executables pd) #else-myLibModules pd = libModules pd-myExeModules pd = exeModules pd+myLibModules pd = moduleInfo libModules libBuildInfo pd+myExeModules pd = moduleInfo exeModules buildInfo pd #endif @@ -166,69 +185,54 @@ packageConfig' package continuation = do let dir = dropFileName (ipdCabalFile package) runExternalTool "Configuring" "cabal" (["configure"]- ++ (ipdConfigFlags package)) (Just dir) $ \output -> do- logOutput output- mbPack <- idePackageFromPath (ipdCabalFile package)- case mbPack of- Just pack -> do- changeWorkspacePackage pack- modifyIDE_ (\ide -> ide{bufferProjCache = Map.empty})- mbActivePack <- readIDE activePack- case mbActivePack of- Just activePack | ipdCabalFile package == ipdCabalFile activePack ->- modifyIDE_ (\ide -> ide{activePack = Just pack})- _ -> return ()- triggerEventIDE UpdateWorkspaceInfo- triggerEventIDE (WorkspaceChanged False True)- continuation (last output == ToolExit ExitSuccess)- return ()- Nothing -> do- ideMessage Normal "Can't read package file"- continuation False- return()--changeWorkspacePackage :: IDEPackage -> IDEAction-changeWorkspacePackage ideP@IDEPackage{ipdCabalFile = file} = do- oldWorkspace <- readIDE workspace- case oldWorkspace of- Nothing -> return ()- Just ws ->- let ps = map exchange (wsPackages ws)- in modifyIDE_ (\ide -> ide{workspace = Just ws {wsPackages = ps}})- where- exchange p | ipdCabalFile p == file = ideP- | otherwise = p+ ++ (ipdConfigFlags package)) (Just dir) $ do+ (mbLastOutput, _) <- EL.zip E.last logOutput+ lift $ do+ mbPack <- idePackageFromPath (ipdCabalFile package)+ case mbPack of+ Just pack -> do+ changePackage pack+ triggerEventIDE (WorkspaceChanged False True)+ continuation (mbLastOutput == Just (ToolExit ExitSuccess))+ return ()+ Nothing -> do+ ideMessage Normal "Can't read package file"+ continuation False+ return() -runCabalBuild :: Bool -> Bool -> IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction-runCabalBuild backgroundBuild withoutLinking package shallConfigure continuation = do- prefs <- readIDE prefs+runCabalBuild :: Bool -> Bool -> Bool -> IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction+runCabalBuild backgroundBuild jumpToWarnings withoutLinking package shallConfigure continuation = do+ prefs <- readIDE prefs let dir = dropFileName (ipdCabalFile package) let args = (["build"] ++ if backgroundBuild && withoutLinking then ["--with-ld=false"] else [] ++ ipdBuildFlags package)- runExternalTool "Building" "cabal" args (Just dir) $ \output -> do- logOutputForBuild package backgroundBuild output- errs <- readIDE errorRefs- if shallConfigure && isConfigError output- then- packageConfig' package (\ b ->- when b $ runCabalBuild backgroundBuild withoutLinking package False continuation)- else do- continuation (last output == ToolExit ExitSuccess)- return ()+ runExternalTool "Building" "cabal" args (Just dir) $ do+ (mbLastOutput, isConfigErr, _) <- EL.zip3 E.last isConfigError $+ logOutputForBuild package backgroundBuild jumpToWarnings+ lift $ do+ errs <- readIDE errorRefs+ if shallConfigure && isConfigErr+ then+ packageConfig' package (\ b ->+ when b $ runCabalBuild backgroundBuild jumpToWarnings withoutLinking package False continuation)+ else do+ continuation (mbLastOutput == Just (ToolExit ExitSuccess))+ return () -isConfigError :: [ToolOutput] -> Bool-isConfigError = or . (map isCErr)+isConfigError :: Monad m => E.Iteratee ToolOutput m Bool+isConfigError = EL.foldM (\a b -> return $ a || isCErr b) False where- isCErr (ToolError str) = str1 `isInfixOf` str || str2 `isInfixOf` str+ isCErr (ToolError str) = str1 `isInfixOf` str || str2 `isInfixOf` str || str3 `isInfixOf` str isCErr _ = False str1 = "Run the 'configure' command first" str2 = "please re-configure"+ str3 = "cannot satisfy -package-id" -buildPackage :: Bool -> Bool -> IDEPackage -> (Bool -> IDEAction) -> IDEAction-buildPackage backgroundBuild withoutLinking package continuation = catchIDE (do+buildPackage :: Bool -> Bool -> Bool -> IDEPackage -> (Bool -> IDEAction) -> IDEAction+buildPackage backgroundBuild jumpToWarnings withoutLinking package continuation = catchIDE (do ideR <- ask prefs <- readIDE prefs maybeDebug <- readIDE debugState@@ -241,19 +245,19 @@ when (not backgroundBuild) $ liftIO $ do timeoutAddFull (do reflectIDE (do- buildPackage backgroundBuild withoutLinking+ buildPackage backgroundBuild jumpToWarnings withoutLinking package continuation return False) ideR return False) priorityDefaultIdle 1000 return ()- else runCabalBuild backgroundBuild withoutLinking package True continuation+ else runCabalBuild backgroundBuild jumpToWarnings withoutLinking package True continuation Just debug@(_, ghci) -> do -- TODO check debug package matches active package ready <- liftIO $ isEmptyMVar (currentToolCommand ghci) when ready $ do let dir = dropFileName (ipdCabalFile package) when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace; return ())- runDebug (executeDebugCommand ":reload" (logOutputForBuild package backgroundBuild)) debug+ runDebug (executeDebugCommand ":reload" (logOutputForBuild package backgroundBuild jumpToWarnings)) debug ) (\(e :: SomeException) -> sysMessage Normal (show e)) @@ -272,12 +276,11 @@ lift $ packageClean' package (\ _ -> return ()) packageClean' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction-packageClean' package continuation =+packageClean' package continuation = do let dir = dropFileName (ipdCabalFile package)- in runExternalTool "Cleaning" "cabal" ["clean"] (Just dir)- (\ output -> do- logOutput output- continuation (last output == ToolExit ExitSuccess))+ runExternalTool "Cleaning" "cabal" ["clean"] (Just dir) $ do+ (mbLastOutput, _) <- EL.zip E.last logOutput+ lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)) packageCopy :: PackageAction packageCopy = do@@ -293,6 +296,25 @@ ++ ["--destdir=" ++ fp]) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) +packageInstallDependencies :: PackageAction+packageInstallDependencies = do+ package <- ask+ lift $ catchIDE (do+ let dir = dropFileName (ipdCabalFile package)+ runExternalTool "Installing" "cabal" (["install","--only-dependencies"]+ ++ (ipdInstallFlags package)) (Just dir) logOutput)+ (\(e :: SomeException) -> putStrLn (show e))++packageCopy' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction+packageCopy' package continuation = do+ catchIDE (do+ let dir = dropFileName (ipdCabalFile package)+ runExternalTool "Copying" "cabal" (["copy"]+ ++ (ipdInstallFlags package)) (Just dir) $ do+ (mbLastOutput, _) <- EL.zip E.last logOutput+ lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))+ (\(e :: SomeException) -> putStrLn (show e))+ packageRun :: PackageAction packageRun = do package <- ask@@ -322,37 +344,40 @@ return ()) (\(e :: SomeException) -> putStrLn (show e)) -packageInstall :: PackageAction-packageInstall = do- package <- ask- lift $ packageInstall' package (\ _ -> return ())--packageInstall' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction-packageInstall' package continuation = catchIDE (do- let dir = dropFileName (ipdCabalFile package)- runExternalTool "Installing" "runhaskell" (["Setup", "install"]- ++ (ipdInstallFlags package)) (Just dir) (\ output -> do- logOutput output- continuation (last output == ToolExit ExitSuccess)))- (\(e :: SomeException) -> putStrLn (show e))- packageRegister :: PackageAction packageRegister = do package <- ask- lift $ catchIDE (do- let dir = dropFileName (ipdCabalFile package)- runExternalTool "Registering" "cabal" (["register"]- ++ (ipdRegisterFlags package)) (Just dir) logOutput)- (\(e :: SomeException) -> putStrLn (show e))+ lift $ packageRegister' package (\ _ -> return ()) +packageRegister' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction+packageRegister' package continuation =+ if ipdHasLibs package+ then catchIDE (do+ let dir = dropFileName (ipdCabalFile package)+ runExternalTool "Registering" "cabal" (["register"]+ ++ (ipdRegisterFlags package)) (Just dir) $ do+ (mbLastOutput, _) <- EL.zip E.last logOutput+ lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))+ (\(e :: SomeException) -> putStrLn (show e))+ else continuation True+ packageTest :: PackageAction packageTest = do package <- ask- lift $ catchIDE (do- let dir = dropFileName (ipdCabalFile package)- runExternalTool "Testing" "cabal" (["test"]) (Just dir) logOutput)- (\(e :: SomeException) -> putStrLn (show e))+ lift $ packageTest' package (\ _ -> return ()) +packageTest' :: IDEPackage -> (Bool -> IDEAction) -> IDEAction+packageTest' package continuation =+ if "--enable-tests" `elem` ipdConfigFlags package+ then catchIDE (do+ let dir = dropFileName (ipdCabalFile package)+ runExternalTool "Testing" "cabal" (["test"]+ ++ (ipdTestFlags package)) (Just dir) $ do+ (mbLastOutput, _) <- EL.zip E.last logOutput+ lift $ continuation (mbLastOutput == Just (ToolExit ExitSuccess)))+ (\(e :: SomeException) -> putStrLn (show e))+ else continuation True+ packageSdist :: PackageAction packageSdist = do package <- ask@@ -377,18 +402,17 @@ runExternalTool "Opening Documentation" (browser prefs) [path] (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) -runExternalTool :: String -> FilePath -> [String] -> Maybe FilePath -> ([ToolOutput] -> IDEAction) -> IDEAction+runExternalTool :: String -> FilePath -> [String] -> Maybe FilePath -> E.Iteratee ToolOutput IDEM () -> IDEAction runExternalTool description executable args mbDir handleOutput = do prefs <- readIDE prefs alreadyRunning <- isRunning unless alreadyRunning $ do when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace; return ()) triggerEventIDE (StatusbarChanged [CompartmentState description, CompartmentBuild True])- reifyIDE (\ideR -> forkIO $ do+ reifyIDE $ \ideR -> forkIO $ do (output, pid) <- runTool executable args mbDir- reflectIDE (do- modifyIDE_ (\ide -> ide{runningTool = Just pid})- handleOutput output) ideR)+ reflectIDE (modifyIDE_ (\ide -> ide{runningTool = Just pid})) ideR+ E.run_ $ output $$ (reflectIDEI handleOutput ideR) return () @@ -408,7 +432,7 @@ interruptBuild = do maybeProcess <- readIDE runningTool liftIO $ case maybeProcess of- Just h -> interruptProcessGroup h+ Just h -> interruptProcessGroupOf h _ -> return () -- ---------------------------------------------------------------------@@ -432,12 +456,12 @@ return Nothing)) getEmptyModuleTemplate :: PackageDescription -> String -> IO String-getEmptyModuleTemplate pd modName = getModuleTemplate pd modName "" ""+getEmptyModuleTemplate pd modName = getModuleTemplate "module" pd modName "" "" -getModuleTemplate :: PackageDescription -> String -> String -> String -> IO String-getModuleTemplate pd modName exports body = catch (do+getModuleTemplate :: String -> PackageDescription -> String -> String -> String -> IO String+getModuleTemplate template pd modName exports body = catch (do dataDir <- getDataDir- filePath <- getConfigFilePathForLoad standardModuleTemplateFilename Nothing dataDir+ filePath <- getConfigFilePathForLoad (template ++ leksahTemplateFileExtension) Nothing dataDir template <- UTF8.readFile filePath return (foldl' (\ a (from, to) -> replace from to a) template [ ("@License@" , (show . license) pd)@@ -450,11 +474,100 @@ , ("@ModuleBody@" , body)])) (\ (e :: SomeException) -> sysMessage Normal ("Couldn't read template file: " ++ show e) >> return "") +#if MIN_VERSION_Cabal(1,10,0) addModuleToPackageDescr :: ModuleName -> Bool -> PackageAction addModuleToPackageDescr moduleName isExposed = do p <- ask lift $ 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)}+ writeGenericPackageDescription (ipdCabalFile p) npd)+ (\(e :: SomeException) -> do+ reflectIDE (ideMessage Normal ("Can't update package " ++ show e)) ideR+ return ()))++addModToLib :: ModuleName -> CondTree ConfVar [Dependency] Library ->+ CondTree ConfVar [Dependency] Library+addModToLib modName ct@CondNode{condTreeData = lib} =+ ct{condTreeData = lib{exposedModules = modName : 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)}}}++addModToBuildInfoExe :: ModuleName -> (String, CondTree ConfVar [Dependency] Executable) ->+ (String, CondTree ConfVar [Dependency] Executable)+addModToBuildInfoExe modName (str,ct@CondNode{condTreeData = exe}) =+ (str, ct{condTreeData = exe{buildInfo = (buildInfo exe){otherModules = modName+ : otherModules (buildInfo exe)}}})++--------------------------------------------------------------------------+delModuleFromPackageDescr :: ModuleName -> PackageAction+delModuleFromPackageDescr moduleName = trace ("addModule " ++ show moduleName) $ do+ p <- ask+ lift $ reifyIDE (\ideR -> catch (do+ gpd <- readPackageDescription normal (ipdCabalFile p)+ let isExposedAndJust = isExposedModule moduleName (condLibrary gpd)+ let npd = if isExposedAndJust+ then gpd{+ condLibrary = Just (delModFromLib moduleName+ (fromJust (condLibrary gpd))),+ condExecutables = map (delModFromBuildInfoExe moduleName)+ (condExecutables gpd)}+ else gpd{+ condLibrary = case condLibrary gpd of+ Nothing -> Nothing+ Just lib -> Just (delModFromBuildInfoLib moduleName+ (fromJust (condLibrary gpd))),+ condExecutables = map (delModFromBuildInfoExe moduleName)+ (condExecutables gpd)}+ writeGenericPackageDescription (ipdCabalFile p) npd)+ (\(e :: SomeException) -> do+ reflectIDE (ideMessage Normal ("Can't update package " ++ show e)) ideR+ return ()))++delModFromLib :: ModuleName -> CondTree ConfVar [Dependency] Library ->+ CondTree ConfVar [Dependency] Library+delModFromLib modName ct@CondNode{condTreeData = lib} =+ ct{condTreeData = lib{exposedModules = delete modName (exposedModules lib)}}++delModFromBuildInfoLib :: ModuleName -> CondTree ConfVar [Dependency] Library ->+ CondTree ConfVar [Dependency] Library+delModFromBuildInfoLib modName ct@CondNode{condTreeData = lib} =+ ct{condTreeData = lib{libBuildInfo = (libBuildInfo lib){otherModules =+ delete modName (otherModules (libBuildInfo lib))}}}++delModFromBuildInfoExe :: ModuleName -> (String, CondTree ConfVar [Dependency] Executable) ->+ (String, CondTree ConfVar [Dependency] Executable)+delModFromBuildInfoExe modName (str,ct@CondNode{condTreeData = exe}) =+ (str, ct{condTreeData = exe{buildInfo = (buildInfo exe){otherModules =+ delete modName (otherModules (buildInfo exe))}}})++isExposedModule :: ModuleName -> Maybe (CondTree ConfVar [Dependency] Library) -> Bool+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@@ -479,7 +592,7 @@ 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@@ -510,21 +623,24 @@ 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 modifyIDE_ (\ide -> ide{prefs = (prefs ide){backgroundBuild= toggled}}) +runUnitTestsToggled :: IDEAction+runUnitTestsToggled = do+ toggled <- getRunUnitTests+ modifyIDE_ (\ide -> ide{prefs = (prefs ide){runUnitTests= toggled}})+ makeModeToggled :: IDEAction makeModeToggled = do toggled <- getMakeModeToggled@@ -566,14 +682,14 @@ case maybeDebug of Nothing -> do ghci <- reifyIDE $ \ideR -> newGhci (ipdBuildFlags package) (interactiveFlags prefs')- $ \output -> reflectIDE (logOutputForBuild package True output) ideR+ $ reflectIDEI (logOutputForBuild package True False) ideR modifyIDE_ (\ide -> ide {debugState = Just (package, ghci)}) triggerEventIDE (Sensitivity [(SensitivityInterpreting, True)]) setDebugToggled True -- Fork a thread to wait for the output from the process to close liftIO $ forkIO $ do readMVar (outputClosed ghci)- reflectIDE (do+ postGUISync $ reflectIDE (do setDebugToggled False modifyIDE_ (\ide -> ide {debugState = Nothing}) triggerEventIDE (Sensitivity [(SensitivityInterpreting, False)])@@ -587,7 +703,7 @@ -- Lets build to make sure the binaries are up to date mbPackage <- readIDE activePack case mbPackage of- Just package -> runCabalBuild True True package True (\ _ -> return ())+ Just package -> runCabalBuild True False True package True (\ _ -> return ()) Nothing -> return ()) ideRef return () _ -> do@@ -625,18 +741,29 @@ tryDebug_ :: DebugM a -> PackageAction tryDebug_ f = tryDebug f >> return () -executeDebugCommand :: String -> ([ToolOutput] -> IDEAction) -> DebugAction+tryDebugQuiet :: DebugM a -> PackageM (Maybe a)+tryDebugQuiet f = do+ maybeDebug <- lift $ readIDE debugState+ case maybeDebug of+ Just debug -> do+ -- TODO check debug package matches active package+ liftM Just $ lift $ runDebug f debug+ _ -> do+ return Nothing++tryDebugQuiet_ :: DebugM a -> PackageAction+tryDebugQuiet_ f = tryDebugQuiet f >> return ()++executeDebugCommand :: String -> (E.Iteratee ToolOutput IDEM ()) -> DebugAction executeDebugCommand command handler = do (_, ghci) <- ask lift $ do triggerEventIDE (StatusbarChanged [CompartmentState command, CompartmentBuild True]) reifyIDE $ \ideR -> do- executeGhciCommand ghci command $ \output ->- reflectIDE (do- handler output- triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])- return ()- ) ideR+ executeGhciCommand ghci command $ do+ reflectIDEI handler ideR+ liftIO $ postGUISync $ reflectIDE (triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False])) ideR+ return () allBuildInfo' :: PackageDescription -> [BuildInfo] #if MIN_VERSION_Cabal(1,10,0)@@ -658,28 +785,38 @@ case mbPackageD of Nothing -> return Nothing Just packageD -> do- let modules = Set.fromList $ myLibModules packageD ++ myExeModules packageD- let mainFiles = map modulePath (executables packageD)- let files = Set.fromList $ extraSrcFiles packageD ++ map modulePath (executables packageD)+ let modules = Map.fromList $ myLibModules packageD ++ myExeModules packageD+ 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 #if MIN_VERSION_Cabal(1,10,0) let exts = nub $ concatMap oldExtensions (allBuildInfo' packageD)+ let tests = [ 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,+ ipdTests = tests, ipdMain = mainFiles, ipdExtraSrcs = files, ipdSrcDirs = srcDirs, ipdExtensions = exts,- ipdConfigFlags = ["--user"],+ ipdConfigFlags = ["--user", "--enable-tests"], ipdBuildFlags = [],+ ipdTestFlags = [], ipdHaddockFlags = [], ipdExeFlags = [], ipdInstallFlags = [],
src/IDE/Pane/Breakpoints.hs view
@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -XRecordWildCards -XTypeSynonymInstances -XMultiParamTypeClasses- -XDeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances, RecordWildCards, TypeSynonymInstances,+ MultiParamTypeClasses, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Breakpoints@@ -24,7 +24,6 @@ import Graphics.UI.Gtk import Data.Typeable (Typeable(..)) import IDE.Core.State-import Control.Monad.Reader import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Graphics.UI.Gtk.General.Enums (Click(..), MouseButton(..))@@ -34,6 +33,7 @@ debugDeleteAllBreakpoints) import IDE.LogRef (showSourceSpan) import Data.List (elemIndex)+import Control.Monad.IO.Class (MonadIO(..)) -- | A breakpoints pane description
src/IDE/Pane/Errors.hs view
@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -XRecordWildCards -XTypeSynonymInstances -XMultiParamTypeClasses- -XDeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances, RecordWildCards, TypeSynonymInstances,+ MultiParamTypeClasses, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Errors@@ -25,7 +25,6 @@ import Graphics.UI.Gtk import Data.Typeable (Typeable(..)) import IDE.Core.State-import Control.Monad.Reader import Graphics.UI.Gtk.General.Enums (Click(..), MouseButton(..)) import Graphics.UI.Gtk.Gdk.Events (Event(..))@@ -34,6 +33,7 @@ resolveErrors) import Data.List (elemIndex) import IDE.LogRef (showSourceSpan)+import Control.Monad.IO.Class (MonadIO(..)) -- | A breakpoints pane description --
+ src/IDE/Pane/Files.hs view
@@ -0,0 +1,262 @@+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses,+ TypeSynonymInstances, RecordWildCards #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.Files+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | The pane of ide that shows a list of all the files in the workspace+--+-------------------------------------------------------------------------------++module IDE.Pane.Files (+ IDEFiles(..)+, FilesState(..)+, getFiles+, refreshFiles+) where++import Graphics.UI.Gtk+ (onSelectionChanged, treeStoreRemove, treeModelIterNext,+ treeModelGetRow, treeStoreInsert, treeModelIterNthChild,+ treeModelGetPath, TreeIter, treeModelGetIter, TreePath,+ treeSelectionGetSelectedRows, onRowActivated, treeStoreGetValue,+ onRowExpanded, afterFocusIn, scrolledWindowSetPolicy, containerAdd,+ scrolledWindowNew, treeSelectionSetMode, treeViewGetSelection,+ treeViewSetHeadersVisible, cellText, cellLayoutSetAttributes,+ cellLayoutPackStart, treeViewAppendColumn,+ treeViewColumnSetReorderable, treeViewColumnSetResizable,+ treeViewColumnSetSizing, treeViewColumnSetTitle, treeViewColumnNew,+ cellRendererPixbufNew, cellRendererTextNew, treeViewSetModel,+ treeViewNew, treeStoreNew, castToWidget, TreeStore, TreeView,+ ScrolledWindow)+import Data.Maybe (isJust)+import Control.Monad (forM_, when)+import Data.Typeable (Typeable)+import IDE.Core.State+ (MessageLevel(..), ipdCabalFile, ipdPackageId, wsPackages,+ workspace, readIDE, IDEAction, ideMessage, reflectIDE, reifyIDE,+ IDEM)+import IDE.Pane.SourceBuffer+ (goToSourceDefinition)+import Control.Applicative ((<$>))+import System.FilePath ((</>), takeFileName, dropFileName)+import Distribution.Package (PackageIdentifier(..))+import System.Directory (doesDirectoryExist, getDirectoryContents)+import IDE.Core.CTypes+ (Location(..), packageIdentifierToString)+import Graphics.UI.Frame.Panes+ (RecoverablePane(..), PanePath, RecoverablePane, Pane(..))+import Graphics.UI.Frame.ViewFrame (getNotebook)+import Graphics.UI.Editor.Basics (Connection(..))+import Graphics.UI.Gtk.General.Enums+ (PolicyType(..), SelectionMode(..), TreeViewColumnSizing(..))+import System.Glib.Attributes (AttrOp(..))+import Control.Monad.IO.Class (MonadIO(..))++data FileRecord =+ FileRecord FilePath+ | DirRecord FilePath+ | PackageRecord PackageIdentifier FilePath+ | PlaceHolder deriving(Eq)++file :: FileRecord -> String+file (FileRecord f) = takeFileName f+file (DirRecord f) = takeFileName f+file (PackageRecord pid f) = packageIdentifierToString pid ++ " " ++ f+file PlaceHolder = ""++-- | A files pane description+--++data IDEFiles = IDEFiles {+ scrolledView :: ScrolledWindow+, treeView :: TreeView+, fileStore :: TreeStore FileRecord+} deriving Typeable++data FilesState = FilesState+ deriving(Eq,Ord,Read,Show,Typeable)++instance Pane IDEFiles IDEM+ where+ primPaneName _ = "Files"+ getAddedIndex _ = 0+ getTopWidget = castToWidget . scrolledView+ paneId b = "*Files"++instance RecoverablePane IDEFiles FilesState IDEM where+ saveState p = do+ return (Just FilesState)+ recoverState pp FilesState = do+ nb <- getNotebook pp+ buildPane pp nb builder+ builder pp nb windows = reifyIDE $ \ ideR -> do+ fileStore <- treeStoreNew []+ treeView <- treeViewNew+ treeViewSetModel treeView fileStore++ renderer1 <- cellRendererTextNew+ renderer10 <- cellRendererPixbufNew+ col1 <- treeViewColumnNew+ treeViewColumnSetTitle col1 "File"+ treeViewColumnSetSizing col1 TreeViewColumnAutosize+ treeViewColumnSetResizable col1 True+ treeViewColumnSetReorderable col1 True+ treeViewAppendColumn treeView col1+ cellLayoutPackStart col1 renderer10 False+ cellLayoutPackStart col1 renderer1 True+ cellLayoutSetAttributes col1 renderer1 fileStore+ $ \row -> [ cellText := file row]++ treeViewSetHeadersVisible treeView False+ sel <- treeViewGetSelection treeView+ treeSelectionSetMode sel SelectionSingle++ scrolledView <- scrolledWindowNew Nothing Nothing+ containerAdd scrolledView treeView+ scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic++ let files = IDEFiles {..}++ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive files) ideR ; return True)+ cid2 <- treeView `onRowExpanded` \ iter path -> do+ record <- treeStoreGetValue fileStore path+ reflectIDE (do+ 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+ treeView `onRowActivated` \ path col -> do+ record <- treeStoreGetValue fileStore path+ reflectIDE (do+ 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+ sel `onSelectionChanged` do+ paths <- treeSelectionGetSelectedRows sel+ forM_ paths $ \ path -> do+ record <- treeStoreGetValue fileStore path+ reflectIDE (do+ 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++ return (Just files,[ConnectC cid1])++getFiles :: Maybe PanePath -> IDEM IDEFiles+getFiles Nothing = forceGetPane (Right "*Files")+getFiles (Just pp) = forceGetPane (Left pp)++getSelectionFileRecord :: TreeView+ -> TreeStore FileRecord+ -> IO (Maybe FileRecord)+getSelectionFileRecord treeView fileStore = do+ treeSelection <- treeViewGetSelection treeView+ paths <- treeSelectionGetSelectedRows treeSelection+ case paths of+ p:_ -> Just <$> treeStoreGetValue fileStore p+ _ -> return Nothing++refreshFiles :: IDEAction+refreshFiles = do+ 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)++refreshDir :: TreeStore FileRecord -> TreePath -> FilePath -> IO ()+refreshDir store path dir = do+ mbIter <- treeModelGetIter store path+ when (isJust mbIter) $ do+ exists <- doesDirectoryExist dir+ contents <- if exists+ then filter ((/= '.').head) <$>+ getDirectoryContents dir >>= mapM (\f -> do+ let full = dir </> f+ isDir <- doesDirectoryExist full+ return $ if isDir then DirRecord full else FileRecord full)+ else return []+ setDirectories store mbIter contents++setDirectories :: TreeStore FileRecord -> Maybe TreeIter -> [FileRecord] -> IO ()+setDirectories store parent records = do+ parentPath <- case parent of+ Just i -> treeModelGetPath store i+ _ -> return []+ forM_ (zip [0..] records) $ \(n, record) -> do+ mbChild <- treeModelIterNthChild store parent n+ findResult <- find record store mbChild+ case (mbChild, findResult) of+ (_, WhereExpected _) -> return ()+ (Just iter, Found _) -> do+ path <- treeModelGetPath store iter+ removeUntil record store path+ _ -> do+ treeStoreInsert store parentPath n $ record+ case record of+ DirRecord _ -> treeStoreInsert store (parentPath++[n]) 0 PlaceHolder+ PackageRecord _ _ -> treeStoreInsert store (parentPath++[n]) 0 PlaceHolder+ _ -> return ()+ removeRemaining store (parentPath++[length records])++data FindResult = WhereExpected TreeIter | Found TreeIter | NotFound++find :: Eq a => a -> TreeStore a -> Maybe TreeIter -> IO FindResult+find _ _ Nothing = return NotFound+find a store (Just iter) = do+ row <- treeModelGetRow store iter+ if row == a+ then return $ WhereExpected iter+ else treeModelIterNext store iter >>= find'+ where+ find' :: Maybe TreeIter -> IO FindResult+ find' Nothing = return NotFound+ find' (Just iter) = do+ row <- treeModelGetRow store iter+ if row == a+ then return $ Found iter+ else treeModelIterNext store iter >>= find'++removeUntil :: Eq a => a -> TreeStore a -> TreePath -> IO ()+removeUntil a store path = do+ row <- treeStoreGetValue store path+ when (row /= a) $ do+ found <- treeStoreRemove store path+ when found $ removeUntil a store path++removeRemaining :: TreeStore a -> TreePath -> IO ()+removeRemaining store path = do+ found <- treeStoreRemove store path+ when found $ removeRemaining store path+++++++++++++++++
src/IDE/Pane/Grep.hs view
@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances- -XRecordWildCards #-}+{-# LANGUAGE CPP, FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses,+ TypeSynonymInstances, RecordWildCards #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Grep@@ -22,22 +22,37 @@ ) where import Graphics.UI.Gtk hiding (get)+import qualified Graphics.UI.Gtk.Gdk.Events as Gdk import Text.ParserCombinators.Parsec.Language import Text.ParserCombinators.Parsec hiding(Parser) import qualified Text.ParserCombinators.Parsec.Token as P import Data.Maybe-import Control.Monad.Reader import Data.Typeable import IDE.Core.State-import IDE.Utils.Tool (runTool, ToolOutput(..))+import IDE.BufferMode+import IDE.Utils.Tool (runTool, ToolOutput(..), getProcessExitCode, interruptProcessGroupOf) import Control.Concurrent- (newEmptyMVar, isEmptyMVar, takeMVar, putMVar, MVar, forkIO)-import IDE.LogRef (logOutput)+ (forkOS, newEmptyMVar, isEmptyMVar, takeMVar, putMVar, MVar,+ forkIO)+import IDE.LogRef (logOutput, defaultLineLogger) import IDE.Pane.SourceBuffer- (goToSourceDefinition)+ (goToSourceDefinition, maybeActiveBuf, IDEBuffer(..))+import IDE.TextEditor (grabFocus) import Control.Applicative ((<$>)) import System.FilePath ((</>), dropFileName) import System.Exit (ExitCode(..))+import IDE.Pane.Log (getLog)+import Control.DeepSeq+import qualified Data.Enumerator as E+ (Step(..), run_, Iteratee(..), run)+import qualified Data.Enumerator.List as EL+ (foldM, head, dropWhile, isolate)+import Data.Enumerator (($$), (>>==))+import qualified Data.List as L ()+import Control.Monad (foldM, when)+import Control.Monad.Trans.Reader (ask)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.IO.Class (MonadIO(..)) data GrepRecord = GrepRecord { file :: FilePath@@ -130,19 +145,43 @@ waitingGrep <- newEmptyMVar activeGrep <- newEmptyMVar let grep = IDEGrep {..}-+ let+ gotoSource :: Bool -> IO Bool+ gotoSource focus = do+ sel <- getSelectionGrepRecord treeView grepStore+ case sel of+ Just record -> reflectIDE (do+ case record of+ GrepRecord {file=f, line=l, parDir=Just pp} ->+ (goToSourceDefinition (pp </> f) $ Just $ Location l 0 l 0)+ ?>>= (\b -> when focus $ grabFocus (sourceView b))+ _ -> return ()) ideR+ Nothing -> return ()+ return True cid1 <- treeView `afterFocusIn` (\_ -> do reflectIDE (makeActive grep) ideR ; return True)- sel `onSelectionChanged` do- sel <- getSelectionGrepRecord treeView grepStore- case sel of- Just record -> reflectIDE (do- case record of- GrepRecord {file=f, line=l, parDir=Just pp} ->- goToSourceDefinition (pp </> f) $ Just $ Location l 0 l 0- _ -> return ()) ideR- Nothing -> return ()+ cid2 <- treeView `onKeyPress`+ (\e ->+ case e of+ k@(Gdk.Key _ _ _ _ _ _ _ _ _ _)+ | Gdk.eventKeyName k == "Return" -> do+ gotoSource True+ | Gdk.eventKeyName k == "Escape" -> do+ reflectIDE (do+ lastActiveBufferPane ?>>= \paneName -> do+ (PaneC pane) <- paneFromName paneName+ makeActive pane+ return ()+ triggerEventIDE StartFindInitial) ideR+ return True+ -- gotoSource True+ | otherwise -> do+ return False+ _ -> return False+ )+ sel `onSelectionChanged` (gotoSource False >> return ()) + return (Just grep,[ConnectC cid1]) getGrep :: Maybe PanePath -> IDEM IDEGrep@@ -202,55 +241,76 @@ putMVar (activeGrep grep) True takeMVar (waitingGrep grep) - postGUIAsync $ treeStoreClear store+ postGUISync $ treeStoreClear store totalFound <- foldM (\a (dir, subDirs) -> do nooneWaiting <- isEmptyMVar (waitingGrep grep) found <- if nooneWaiting then do (output, pid) <- runTool "grep" ((if caseSensitive then [] else ["-i"])- ++ ["-r", "-E", "-n", "--exclude=*~", regexString] ++ subDirs) (Just dir)- reflectIDE (setGrepResults dir output) ideRef+ ++ ["-r", "-E", "-n", "-I", "--exclude=*~",+#if !defined(darwin_HOST_OS)+ "--exclude-dir=.svn",+ "--exclude-dir=_darcs",+ "--exclude-dir=.git",+#endif+ regexString] ++ subDirs) (Just dir)+ reflectIDE (do+ E.run_ $ output $$ do+ let max = 1000+ step <- EL.isolate (toInteger max) $$ setGrepResults dir+ case step of+ E.Continue _ -> do+ liftIO $ interruptProcessGroupOf pid+ liftIO $ postGUISync $ do+ nDir <- treeModelIterNChildren store Nothing+ liftIO $ treeStoreChange store [nDir-1] (\r -> r{ context = "(Stoped Searching)" })+ return ()+ EL.dropWhile (const True)+ return max+ E.Yield n _ -> return n+ _ -> return 0) ideRef else return 0 return $ a + found) 0 dirs nooneWaiting <- isEmptyMVar (waitingGrep grep)- when nooneWaiting $ do- nDir <- postGUISync $ treeModelIterNChildren store Nothing- postGUIAsync $ treeStoreInsert store [] nDir $- GrepRecord "Search Complete" totalFound "" Nothing+ when nooneWaiting $ postGUISync $ do+ nDir <- treeModelIterNChildren store Nothing+ treeStoreInsert store [] nDir $ GrepRecord "Search Complete" totalFound "" Nothing takeMVar (activeGrep grep) >> return () return () -setGrepResults :: FilePath -> [ToolOutput] -> IDEM Int-setGrepResults dir output = do- grep <- getGrep Nothing+setGrepResults :: FilePath -> E.Iteratee ToolOutput IDEM Int+setGrepResults dir = do+ ideRef <- lift ask+ grep <- lift $ getGrep Nothing+ log <- lift $ getLog let store = grepStore grep view = treeView grep- ideRef <- ask- liftIO $ do- let (displayed, dropped) = splitAt 5000 output- forkIO $ do- let errors = filter isError output- ++ if null dropped- then []- else [ToolError $ "Dropped " ++ show (length dropped) ++ " search results"]- unless (null errors) $ postGUISync $ reflectIDE (logOutput errors) ideRef- return ()- case catMaybes (map (process dir) displayed) of- [] -> return 0- results -> do- nDir <- postGUISync $ treeModelIterNChildren store Nothing- postGUIAsync $ treeStoreInsert store [] nDir $ GrepRecord dir 0 "" Nothing- forM_ (zip results [0..]) $ \(record, n) -> do- nooneWaiting <- isEmptyMVar (waitingGrep grep)- when nooneWaiting $ postGUIAsync $ do- treeStoreInsert store [nDir] n record- treeStoreChange store [nDir] (\r -> r{ line = n+1 }) >> return ()- when (nDir == 0 && n == 0) $- treeViewExpandAll view- return $ length results+ nDir <- liftIO $ postGUISync $ do+ nDir <- treeModelIterNChildren store Nothing+ treeStoreInsert store [] nDir $ GrepRecord dir 0 "" Nothing+ when (nDir == 0) (widgetGrabFocus view >> return())+ return nDir+ EL.foldM (\count line -> do+ if isError line+ then do+ liftIO $ postGUISync $ reflectIDE (defaultLineLogger log line >> return ()) ideRef+ return count+ else do+ case process dir line of+ Nothing -> return count+ Just record -> liftIO $ do+ nooneWaiting <- isEmptyMVar (waitingGrep grep)+ when nooneWaiting $ postGUISync $ do+ parent <- treeModelGetIter store [nDir]+ n <- treeModelIterNChildren store parent+ treeStoreInsert store [nDir] n record+ treeStoreChange store [nDir] (\r -> r{ line = n+1 })+ when (nDir == 0 && n == 0) $+ treeViewExpandAll view+ return (count+1)) 0 where process pp (ToolOutput line) = case parse grepLineParser "" line of
src/IDE/Pane/Info.hs view
@@ -1,5 +1,6 @@-{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses- -XScopedTypeVariables -XTypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses,+ ScopedTypeVariables, TypeSynonymInstances #-}+{-# OPTIONS_GHC -fwarn-unused-imports #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Info@@ -24,16 +25,18 @@ import Graphics.UI.Gtk hiding (afterToggleOverwrite) import Control.Monad-import Control.Monad.Trans import Data.IORef import Data.Typeable import Data.Char (isAlphaNum) import Network.URI (escapeURIString) import IDE.Core.State+import IDE.SymbolNavigation import IDE.Pane.SourceBuffer+import IDE.TextEditor (EditorIter(..)) import IDE.Utils.GUIUtils (openBrowser,controlIsPressed) import Graphics.UI.Gtk.SourceView+import Control.Monad.IO.Class (MonadIO(..)) -- | An info pane description@@ -109,12 +112,23 @@ sw <- scrolledWindowNew Nothing Nothing containerAdd sw descriptionView+++ createHyperLinkSupport descriptionView sw (\_ _ iter -> do+ (GtkEditorIter beg,GtkEditorIter en) <- reflectIDE (getIdentifierUnderCursorFromIter (GtkEditorIter iter, GtkEditorIter iter)) ideR+ return (beg, en)) (\_ shift' slice -> do+ when (slice /= []) $ do+ -- liftIO$ print ("slice",slice)+ reflectIDE (triggerEventIDE+ (SelectInfo slice shift')) ideR+ return ()+ )+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic boxPackStart ibox sw PackGrow 10 - --openType currentDescr' <- newIORef idDescr #if MIN_VERSION_gtk(0,10,5)@@ -131,7 +145,7 @@ symbol <- textBufferGetText buf l r True when (controlIsPressed e) (reflectIDE (do- triggerEventIDE (SelectInfo symbol)+ triggerEventIDE (SelectInfo symbol False) return ()) ideR) return False) return (Just info,[ConnectC cid])@@ -159,7 +173,7 @@ liftIO $ do writeIORef (currentDescr info) (Just identifierDescr) tb <- get (descriptionView info) textViewBuffer- textBufferSetText tb (show (Present identifierDescr))+ textBufferSetText tb (show (Present identifierDescr) ++ "\n") -- EOL for text iters to work recordInfoHistory (Just identifierDescr) oldDescr getInfoCont :: IDEM (Maybe (Descr))
src/IDE/Pane/Log.hs view
@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses- -XTypeSynonymInstances -XParallelListComp #-}+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, DeriveDataTypeable,+ MultiParamTypeClasses, TypeSynonymInstances, ParallelListComp #-} -- -- Module : IDE.Pane.Log -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie@@ -32,7 +32,6 @@ import Data.Typeable (Typeable(..)) import IDE.Core.State import Graphics.UI.Gtk.Gdk.Events-import Control.Monad.Trans (liftIO) import IDE.Pane.SourceBuffer (markRefInSourceBuf,selectSourceBuf) import System.IO import Prelude hiding (catch)@@ -40,7 +39,7 @@ import IDE.ImportTool (addPackage, parseHiddenModule, addImport, parseNotInScope, resolveErrors)-import IDE.System.Process (runInteractiveProcess, ProcessHandle)+import IDE.Utils.Tool (runInteractiveProcess, ProcessHandle) import Graphics.UI.Gtk (textBufferSetText, textViewScrollToMark, textBufferGetIterAtLineOffset, textViewScrollMarkOnscreen,@@ -65,6 +64,7 @@ ScrolledWindow, TextView, Menu, AttrOp(..), set, TextWindowType(..), ShadowType(..), PolicyType(..), priorityDefaultIdle, idleAdd)+import Control.Monad.IO.Class (MonadIO(..)) -------------------------------------------------------------------------------
src/IDE/Pane/Modules.hs view
@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses- -XScopedTypeVariables -XTypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses,+ ScopedTypeVariables, TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Modules@@ -29,7 +29,6 @@ import Graphics.UI.Gtk hiding (get) import Graphics.UI.Gtk.Gdk.Events import Data.Maybe-import Control.Monad.Reader import qualified Data.Map as Map import Data.Map (Map) import Data.Tree@@ -60,6 +59,10 @@ import System.Log.Logger (infoM) import Default (Default(..)) import IDE.Workspaces (packageTry_)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (when)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.Trans.Reader (ask) -- | A modules pane description --@@ -295,8 +298,8 @@ return () return (Just modules,[ConnectC cid1,ConnectC cid2, ConnectC cid3]) -selectIdentifier :: Descr -> IDEAction-selectIdentifier idDescr = do+selectIdentifier :: Descr -> Bool -> IDEAction+selectIdentifier idDescr openSource= do systemScope <- getSystemInfo workspaceScope <- getWorkspaceInfo packageScope <- getPackageInfo@@ -308,6 +311,7 @@ Just sc -> do when (fst currentScope < sc) (setScope (sc,snd currentScope)) selectIdentifier' (modu pm) (dscName idDescr)+ when openSource (goToDefinition idDescr) scopeForDescr :: PackModule -> Maybe (GenScope,GenScope) -> Maybe (GenScope,GenScope) -> Maybe GenScope -> Maybe Scope
src/IDE/Pane/PackageEditor.hs view
@@ -1,1168 +1,1388 @@-{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses- -XTypeSynonymInstances #-}------------------------------------------------------------------------------------ Module : IDE.Pane.PackageEditor--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <info@leksah.org>--- Stability : provisional--- Portability : portable------ | Module for editing of cabal packages and build infos------------------------------------------------------------------------------------------module IDE.Pane.PackageEditor (- packageNew'-, packageEdit-, choosePackageDir-, choosePackageFile--, hasConfigs-, standardSetup-) where--import Graphics.UI.Gtk-import Control.Monad.Reader-import Distribution.Package-import Distribution.PackageDescription-import Distribution.Verbosity-import System.FilePath-import Data.Maybe-import System.Directory--import IDE.Core.State-import IDE.Utils.FileUtils-import Graphics.UI.Editor.MakeEditor-import Distribution.PackageDescription.Parse (readPackageDescription,writePackageDescription)-import Distribution.PackageDescription.Configuration (flattenPackageDescription)-import Distribution.ModuleName(ModuleName)-import Data.Typeable (Typeable(..))-import Graphics.UI.Editor.Composite- (versionEditor,- versionRangeEditor,- dependenciesEditor,- stringsEditor,- filesEditor,- tupel3Editor,- eitherOrEditor,- maybeEditor,- pairEditor,- ColumnDescr(..),- multisetEditor)-import Distribution.Text (simpleParse, display)-import MyMissing-import Graphics.UI.Editor.Parameters- (paraInnerPadding,- paraInnerAlignment,- paraOuterPadding,- paraOuterAlignment,- Parameter(..),- paraPack,- Direction(..),- paraDirection,- paraMinSize,- paraShadow,- paraSynopsis,- (<<<-),- emptyParams,- paraName,- getParameterPrim)-import Graphics.UI.Editor.Simple- (staticListMultiEditor,- intEditor,- boolEditor,- fileEditor,- comboSelectionEditor,- multilineStringEditor,- stringEditor)-import Graphics.UI.Editor.Basics- (Notifier, Editor(..), GUIEventSelector(..), GUIEvent(..))-import Distribution.Compiler- (CompilerFlavor(..))-import Distribution.Simple- (knownExtensions,- Extension(..),- VersionRange(..))-import Default (Default(..))-import IDE.Utils.GUIUtils-import IDE.Pane.SourceBuffer (fileOpenThis)-import Control.Event (EventSource(..))-#if MIN_VERSION_Cabal(1,8,0)-#else-import Distribution.License-#endif--import qualified Graphics.UI.Gtk.Gdk.Events as GTK (Event(..))-import Data.List (sort)----- ------------------------------------------------------------------------ The exported stuff goes here-----choosePackageDir :: Window -> Maybe FilePath -> IO (Maybe FilePath)-choosePackageDir window mbDir = chooseDir window "Select root folder for package" mbDir--choosePackageFile :: Window -> Maybe FilePath -> IO (Maybe FilePath)-choosePackageFile window mbDir = chooseFile window "Select cabal package file (.cabal)" mbDir--packageEdit :: PackageAction-packageEdit = do- idePackage <- ask- let dirName = dropFileName (ipdCabalFile idePackage)- modules <- liftIO $ allModules dirName- package <- liftIO $ readPackageDescription normal (ipdCabalFile idePackage)- if hasConfigs package- then do- lift $ ideMessage High ("Cabal file with configurations can't be edited with the "- ++ "current version of the editor")- lift $ fileOpenThis $ ipdCabalFile idePackage- return ()- else do- lift $ editPackage (flattenPackageDescription package) dirName modules (\ _ -> return ())- return ()--hasConfigs :: GenericPackageDescription -> Bool-hasConfigs gpd =- let libConds = case condLibrary gpd of- Nothing -> False- Just condTree -> not (null (condTreeComponents condTree))- exeConds = foldr (\ (_,condTree) hasConfigs ->- if hasConfigs- then True- else not (null (condTreeComponents condTree)))- False (condExecutables gpd)- in libConds || exeConds---packageNew' :: Maybe FilePath -> (Bool -> FilePath -> IDEAction) -> IDEAction-packageNew' mbDir activateAction = do- windows <- getWindows- mbDirName <- liftIO $ choosePackageDir (head windows) mbDir- case mbDirName of- Nothing -> return ()- Just dirName -> do- mbCabalFile <- liftIO $ cabalFileName dirName- case mbCabalFile of- Just cfn -> do- window <- getMainWindow- add <- liftIO $ do- md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel- $ "There is already file " ++ takeFileName cfn ++ " in this directory. "- ++ "Would you like to add this package to the workspace?"- dialogAddButton md "_Add Package" (ResponseUser 1)- dialogSetDefaultResponse md (ResponseUser 1)- set md [ windowWindowPosition := WinPosCenterOnParent ]- rid <- dialogRun md- widgetDestroy md- return $ rid == ResponseUser 1- when add $ activateAction False cfn- Nothing -> do- modules <- liftIO $ do- b1 <- doesFileExist (dirName </> "Setup.hs")- b2 <- doesFileExist (dirName </> "Setup.lhs")- if not (b1 || b2)- then do- sysMessage Normal "Setup.(l)hs does not exist. Writing Standard"- writeFile (dirName </> "Setup.lhs") standardSetup- else sysMessage Normal "Setup.(l)hs already exist"- allModules dirName- let Just initialVersion = simpleParse "0.0.1"- editPackage emptyPackageDescription{- package = PackageIdentifier (PackageName $ takeBaseName dirName)- initialVersion,- buildType = Just Simple,- buildDepends = [Dependency (PackageName "base") AnyVersion],- executables = [emptyExecutable {- exeName = (takeBaseName dirName),- modulePath = "Main.hs",- buildInfo = emptyBuildInfo {hsSourceDirs = ["src"]}}]- } dirName modules (activateAction True)- return ()--standardSetup = "#!/usr/bin/runhaskell \n"- ++ "> module Main where\n"- ++ "> import Distribution.Simple\n"- ++ "> main :: IO ()\n"- ++ "> main = defaultMain\n\n"---- ------------------------------------------------------------------------ | We do some twist for handling build infos seperately to edit them in one editor together--- with the other stuff. This type show what we really edit here-----data PackageDescriptionEd = PDE {- pd :: PackageDescription,- exes :: [Executable'],- mbLib :: Maybe Library',- bis :: [BuildInfo]}- deriving Eq--comparePDE a b = do- when (pd a /= pd b) $ putStrLn "pd"- when (exes a /= exes b) $ putStrLn "exes"- when (mbLib a /= mbLib b) $ putStrLn "mbLib"- when (bis a /= bis b) $ putStrLn "bis"--fromEditor :: PackageDescriptionEd -> PackageDescription-fromEditor (PDE pd exes' 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'- mbLib = case mbLib' of- Nothing -> Nothing- Just (Library' mn b bii) -> if bii + 1 > length buildInfos- then Just (Library mn b (buildInfos !! (length buildInfos - 1)))- else Just (Library mn b (buildInfos !! bii))- in pd {library = mbLib, executables = exes}--toEditor :: PackageDescription -> PackageDescriptionEd-toEditor pd =- let (exes,bis) = unzip $ map (\ ((Executable s fb bi), i) -> (Executable' s fb i, bi))- (zip (executables pd) [0 .. length (executables pd)])- (mbLib,bis2) = case library pd of- Nothing -> (Nothing,bis)- Just (Library mn b bi) -> (Just (Library' (sort mn) b (length bis)), bis ++ [bi])- bis3 = if null bis2- then [emptyBuildInfo]- else bis2- in PDE (pd {library = Nothing , executables = []}) exes mbLib bis3---- ------------------------------------------------------------------------ The pane stuff-----data PackagePane = PackagePane {- packageBox :: VBox,- packageNotifer :: Notifier-} deriving Typeable---data PackageState = PackageState- deriving (Read, Show, Typeable)--instance Pane PackagePane IDEM- where- primPaneName _ = "Package"- getAddedIndex _ = 0- getTopWidget = castToWidget . packageBox- paneId b = "*Package"--instance RecoverablePane PackagePane PackageState IDEM where- saveState p = return Nothing- recoverState pp st = return Nothing- buildPane panePath notebook builder = return Nothing- builder pp nb w = return (Nothing,[])--editPackage :: PackageDescription -> FilePath -> [ModuleName] -> (FilePath -> IDEAction) -> IDEAction-editPackage packageD packagePath modules afterSaveAction = do- mbPane :: Maybe PackagePane <- getPane- case mbPane of- Nothing -> do- pp <- getBestPathForId "*Package"- nb <- getNotebook pp- packageInfos <- liftIO $ getInstalledPackageIds- let packageEd = toEditor packageD- initPackage packagePath packageEd- (packageDD- packageInfos- (takeDirectory packagePath)- modules- (length (bis packageEd))- (concatMap (buildInfoD (Just (takeDirectory packagePath)) modules)- [0..length (bis packageEd) - 1]))- pp nb modules afterSaveAction packageEd- Just p -> liftIO $ bringPaneToFront p--initPackage :: FilePath- -> PackageDescriptionEd- -> FieldDescription PackageDescriptionEd- -> PanePath- -> Notebook- -> [ModuleName]- -> (FilePath -> IDEAction)- -> PackageDescriptionEd- -> IDEM ()-initPackage packageDir packageD packageDescr panePath nb modules afterSaveAction origPackageD = do- let fields = flattenFieldDescription packageDescr- let initialPackagePath = packageDir </> (display . pkgName . package . pd) packageD ++ ".cabal"- packageInfos <- liftIO $ getInstalledPackageIds- mbP <- buildThisPane panePath nb- (builder' packageDir packageD packageDescr afterSaveAction- initialPackagePath modules packageInfos fields origPackageD)- case mbP of- Nothing -> return ()- Just (PackagePane{packageNotifer = pn}) -> do- liftIO $ triggerEvent pn (GUIEvent {- selector = MayHaveChanged,- gtkEvent = GTK.Event True,- eventText = "",- gtkReturn = True})- return ()--builder' :: FilePath ->- PackageDescriptionEd ->- FieldDescription PackageDescriptionEd ->- (FilePath -> IDEAction) ->- FilePath ->- [ModuleName] ->- [PackageId] ->- [FieldDescription PackageDescriptionEd] ->- PackageDescriptionEd ->- PanePath ->- Notebook ->- Window ->- IDEM (Maybe PackagePane,Connections)-builder' packageDir packageD packageDescr afterSaveAction initialPackagePath modules packageInfos fields- origPackageD panePath nb window = reifyIDE $ \ ideR -> do- vb <- vBoxNew False 0- bb <- hButtonBoxNew- save <- buttonNewFromStock "gtk-save"- widgetSetSensitive save False- closeB <- buttonNewFromStock "gtk-close"- addB <- buttonNewFromStock "Add Build Info"- removeB <- buttonNewFromStock "Remove Build Info"- label <- labelNew Nothing- boxPackStart bb addB PackNatural 0- boxPackStart bb removeB PackNatural 0- boxPackEnd bb closeB PackNatural 0- boxPackEnd bb save PackNatural 0- (widget, setInj, getExt, notifier) <- buildEditor packageDescr packageD- let packagePane = PackagePane vb notifier- boxPackStart vb widget PackGrow 7- boxPackStart vb label PackNatural 0- boxPackEnd vb bb PackNatural 7-- let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of- Just s -> s- Nothing -> "Unnamed") fields- addB `onClicked` (do- mbNewPackage' <- extract packageD [getExt]- case mbNewPackage' of- Nothing -> sysMessage Normal "Content doesn't validate"- Just pde -> reflectIDE (do- closePane packagePane- initPackage packageDir pde {bis = bis pde ++ [bis pde !! 0]}- (packageDD- (packageInfos)- packageDir- modules- (length (bis pde) + 1)- (concatMap (buildInfoD (Just packageDir) modules)- [0..length (bis pde)]))- panePath nb modules afterSaveAction origPackageD) ideR)- removeB `onClicked` (do- mbNewPackage' <- extract packageD [getExt]- case mbNewPackage' of- Nothing -> sysMessage Normal "Content doesn't validate"- Just pde | length (bis pde) == 1 -> sysMessage Normal "Just one Build Info"- | otherwise -> reflectIDE (do- closePane packagePane- initPackage packageDir pde{bis = take (length (bis pde) - 1) (bis pde)}- (packageDD- packageInfos- packageDir- modules- (length (bis pde) - 1)- (concatMap (buildInfoD (Just packageDir) modules)- [0..length (bis pde) - 2]))- panePath nb modules afterSaveAction origPackageD) ideR)- closeB `onClicked` (do- mbP <- extract packageD [getExt]- let hasChanged = case mbP of- Nothing -> False- Just p -> p /= origPackageD- if not hasChanged- then reflectIDE (closePane packagePane >> return ()) ideR- else do- md <- messageDialogNew (Just window) []- MessageQuestion- ButtonsYesNo- "Unsaved changes. Close anyway?"- set md [ windowWindowPosition := WinPosCenterOnParent ]- resp <- dialogRun md- widgetDestroy md- case resp of- ResponseYes -> do- reflectIDE (closePane packagePane >> return ()) ideR- _ -> return ())- save `onClicked` (do- mbNewPackage' <- extract packageD [getExt]- case mbNewPackage' of- Nothing -> return ()- Just newPackage' -> let newPackage = fromEditor newPackage' in do- let packagePath = packageDir </> (display . pkgName . package . pd) newPackage'- ++ ".cabal"- writePackageDescription packagePath newPackage- reflectIDE (do- afterSaveAction packagePath- closePane packagePane- return ()) ideR)- registerEvent notifier MayHaveChanged (\ e -> do- mbP <- extract packageD [getExt]- let hasChanged = case mbP of- Nothing -> False- Just p -> p /= origPackageD- when (isJust mbP) $ labelSetMarkup label ""- when (isJust mbP) $ comparePDE (fromJust mbP) packageD- markLabel nb (getTopWidget packagePane) hasChanged- widgetSetSensitive save hasChanged- return (e{gtkReturn=False}))- registerEvent notifier ValidationError (\e -> do- labelSetMarkup label $ "<span foreground=\"red\" size=\"x-large\">The following fields have invalid values: "- ++ eventText e ++ "</span>"- return e)- return (Just packagePane,[])---- ------------------------------------------------------------------------ The description with some tricks-----packageDD :: [PackageIdentifier]- -> FilePath- -> [ModuleName]- -> Int- -> [(String, FieldDescription PackageDescriptionEd)]- -> FieldDescription PackageDescriptionEd-packageDD packages fp modules numBuildInfos extras = NFD ([- ("Package", VFD emptyParams [- mkField- (paraName <<<- ParaName "Synopsis"- $ paraSynopsis <<<- ParaSynopsis "A one-line summary of this package"- $ emptyParams)- (synopsis . pd)- (\ a b -> b{pd = (pd b){synopsis = a}})- (stringEditor (const True) True)- , mkField- (paraName <<<- ParaName "Package Identifier" $ emptyParams)- (package . pd)- (\ a b -> b{pd = (pd b){package = a}})- packageEditor- , mkField- (paraName <<<- ParaName "Description"- $ paraSynopsis <<<- ParaSynopsis "A more verbose description of this package"- $ paraShadow <<<- ParaShadow ShadowOut- $ paraMinSize <<<- ParaMinSize (-1,210)- $ emptyParams)- (description . pd)- (\ a b -> b{pd = (pd b){description = if null a then " \n\n\n\n\n" else a}})- multilineStringEditor- , mkField- (paraName <<<- ParaName "Homepage" $ emptyParams)- (homepage . pd)- (\ a b -> b{pd = (pd b){homepage = a}})- (stringEditor (const True) True)- , mkField- (paraName <<<- ParaName "Package URL" $ emptyParams)- (pkgUrl . pd)- (\ a b -> b{pd = (pd b){pkgUrl = a}})- (stringEditor (const True) True)- , mkField- (paraName <<<- ParaName "Category" $ emptyParams)- (category . pd)- (\ a b -> b{pd = (pd b){category = a}})- (stringEditor (const True) True)- ]),- ("Description", VFD emptyParams [- mkField- (paraName <<<- ParaName "Stability" $ emptyParams)- (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- , mkField- (paraName <<<- ParaName "License File" $ emptyParams)- (licenseFile . pd)- (\ a b -> b{pd = (pd b){licenseFile = a}})- (fileEditor (Just fp) FileChooserActionOpen "Select file")- , mkField- (paraName <<<- ParaName "Copyright" $ emptyParams)- (copyright . pd)- (\ a b -> b{pd = (pd b){copyright = a}})- (stringEditor (const True) True)- , mkField- (paraName <<<- ParaName "Author" $ emptyParams)- (author . pd)- (\ a b -> b{pd = (pd b){author = a}})- (stringEditor (const True) True)- , mkField- (paraName <<<- ParaName "Maintainer" $ emptyParams)- (maintainer . pd)- (\ a b -> b{pd = (pd b){maintainer = a}})- (stringEditor (const True) True)- , mkField- (paraName <<<- ParaName "Bug Reports" $ emptyParams)- (bugReports . pd)- (\ a b -> b{pd = (pd b){bugReports = a}})- (stringEditor (const True) True)- ]),--- ("Repositories", VFD emptyParams [--- mkField--- (paraName <<<- ParaName "Source Repositories" $ emptyParams)--- (sourceRepos . pd)--- (\ a b -> b{pd = (pd b){sourceRepos = a}})--- reposEditor]),- ("Dependencies ", VFD emptyParams [- mkField- (paraName <<<- ParaName "Build Dependencies"- $ paraSynopsis <<<- ParaSynopsis "Does this package depends on other packages?"- $ paraDirection <<<- ParaDirection Vertical- $ paraMinSize <<<- ParaMinSize (-1,250)- $ emptyParams)- (buildDepends . pd)- (\ a b -> b{pd = (pd b){buildDepends = a}})- (dependenciesEditor packages)- ]),- ("Meta Dep.", VFD emptyParams [- mkField- (paraName <<<- ParaName "Cabal version"- $ paraSynopsis <<<- ParaSynopsis- "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"- $ paraShadow <<<- ParaShadow ShadowIn- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- (\a -> case (testedWith . pd) a of- [] -> []--(GHC,AnyVersion)]- l -> l)- (\ a b -> b{pd = (pd b){testedWith = a}})- testedWithEditor- ]),- ("Data Files", VFD emptyParams [- mkField- (paraName <<<- ParaName "Data Files"- $ paraSynopsis <<<- ParaSynopsis- "A list of files to be installed for run-time use by the package."- $ paraDirection <<<- ParaDirection Vertical- $ paraMinSize <<<- ParaMinSize (-1,250)- $ emptyParams)- (dataFiles . pd)- (\ a b -> b{pd = (pd b){dataFiles = a}})- (filesEditor (Just fp) FileChooserActionOpen "Select File")- , mkField- (paraName <<<- ParaName "Data directory" $ emptyParams)- (dataDir . pd)- (\ a b -> b{pd = (pd b){dataDir = a}})- (fileEditor (Just fp) FileChooserActionSelectFolder "Select file")- ]),- ("Extra Files", VFD emptyParams [- mkField- (paraName <<<- ParaName "Extra Source Files"- $ paraSynopsis <<<- ParaSynopsis- "A list of additional files to be included in source distributions."- $ paraDirection <<<- ParaDirection Vertical- $ paraMinSize <<<- ParaMinSize (-1,120)- $ emptyParams)- (extraSrcFiles . pd)- (\ a b -> b{pd = (pd b){extraSrcFiles = a}})- (filesEditor (Just fp) FileChooserActionOpen "Select File")- , mkField- (paraName <<<- ParaName "Extra Tmp Files"- $ paraSynopsis <<<- ParaSynopsis- "A list of additional files or directories to be removed by setup clean."- $ paraDirection <<<- ParaDirection Vertical- $ paraMinSize <<<- ParaMinSize (-1,120)- $ emptyParams)- (extraTmpFiles . pd)- (\ a b -> b{pd = (pd b){extraTmpFiles = a}})- (filesEditor (Just fp) FileChooserActionOpen "Select File")- ]),- ("Other",VFD emptyParams [- mkField- (paraName <<<- ParaName "Build Type"- $ paraSynopsis <<<- ParaSynopsis- "Describe executable programs contained in the package"- $ paraShadow <<<- ParaShadow ShadowIn- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- (buildType . pd)- (\ a b -> b{pd = (pd b){buildType = a}})- (maybeEditor (buildTypeEditor, emptyParams) True "Specify?")- , mkField- (paraName <<<- ParaName "Custom Fields"- $ paraShadow <<<- ParaShadow ShadowIn- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- (customFieldsPD . pd)- (\ a b -> b{pd = (pd b){customFieldsPD = a}})- (multisetEditor- (ColumnDescr True [("Name",\(n,_) -> [cellText := n])- ,("Value",\(_,v) -> [cellText := v])])- ((pairEditor- (stringxEditor (const True),emptyParams)- (stringEditor (const True) True,emptyParams)),emptyParams)- Nothing- Nothing)- ]),- ("Executables",VFD emptyParams [- mkField- (paraName <<<- ParaName "Executables"- $ paraSynopsis <<<- ParaSynopsis- "Describe executable programs contained in the package"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- exes- (\ a b -> b{exes = a})- (executablesEditor (Just fp) modules numBuildInfos)- ]),- ("Library", VFD emptyParams [- mkField- (paraName <<<- ParaName "Library"- $ paraSynopsis <<<- ParaSynopsis- "If the package contains a library, specify the exported modules here"- $ paraDirection <<<- ParaDirection Vertical- $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)- mbLib- (\ a b -> b{mbLib = a})- (maybeEditor (libraryEditor (Just fp) modules numBuildInfos,- paraName <<<- ParaName "Specify exported modules"- $ emptyParams) True- "Does this package contain a library?")- ])- ] ++ extras)--update :: [BuildInfo] -> Int -> (BuildInfo -> BuildInfo) -> [BuildInfo]-update bis index func =- map (\(bi,ind) -> if ind == index- then func bi- else bi)- (zip bis [0..length bis - 1])--buildInfoD :: Maybe FilePath -> [ModuleName] -> Int -> [(String,FieldDescription PackageDescriptionEd)]-buildInfoD fp modules i = [- (show (i + 1) ++ " Build Info", VFD emptyParams [- mkField- (paraName <<<- ParaName "Component is buildable here" $ emptyParams)- (buildable . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{buildable = a})})- boolEditor- , mkField- (paraName <<<- ParaName- "Where to look for the source hierarchy"- $ paraSynopsis <<<- ParaSynopsis- "Root directories for the source hierarchy."- $ paraShadow <<<- ParaShadow ShadowIn- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- (hsSourceDirs . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{hsSourceDirs = a})})- (filesEditor fp FileChooserActionSelectFolder "Select folder")- , mkField- (paraName <<<- ParaName "Non-exposed or non-main modules"- $ paraSynopsis <<<- ParaSynopsis ("A list of modules used by the component but "- ++ "not exposed to users.")- $ paraShadow <<<- ParaShadow ShadowIn- $ paraDirection <<<- ParaDirection Vertical- $ paraMinSize <<<- ParaMinSize (-1,300)- $ paraPack <<<- ParaPack PackGrow- $ emptyParams)- (map display. otherModules . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi ->- bi{otherModules = (map (\i -> forceJust (simpleParse i)- " PackageEditor >> buildInfoD: no parse for moduile name" ) a)})})- (modulesEditor modules)- ]),- (show (i + 1) ++ " Compiler ", VFD emptyParams [- mkField- (paraName <<<- ParaName "Options for haskell compilers"- $ paraDirection <<<- ParaDirection Vertical- $ paraShadow <<<- ParaShadow ShadowIn- $ paraPack <<<- ParaPack PackGrow $ emptyParams)- (options . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{options = a})})- (multisetEditor- (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [cellText := show cv])- ,("Options",\(_,op) -> [cellText := concatMap (\s -> ' ' : s) op])])- ((pairEditor- (compilerFlavorEditor,emptyParams)- (optsEditor,emptyParams)),- (paraDirection <<<- ParaDirection Vertical- $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams))- Nothing- Nothing)- , mkField- (paraName <<<- ParaName "Additional options for GHC when built with profiling"- $ emptyParams)- (ghcProfOptions . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{ghcProfOptions = a})})- optsEditor- , mkField- (paraName <<<- ParaName "Additional options for GHC when the package is built as shared library"- $ emptyParams)- (ghcSharedOptions . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{ghcSharedOptions = a})})- optsEditor- ]),- (show (i + 1) ++ " Extensions ", VFD emptyParams [- mkField- (paraName <<<- ParaName "Extensions"- $ paraSynopsis <<<- ParaSynopsis- "A list of Haskell extensions used by every module."- $ 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- ]),- (show (i + 1) ++ " Build Tools ", VFD emptyParams [- mkField- (paraName <<<- ParaName "Tools needed for a build"- $ paraDirection <<<- ParaDirection Vertical- $ paraMinSize <<<- ParaMinSize (-1,120)- $ emptyParams)- (buildTools . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{buildTools = a})})- (dependenciesEditor [])- ]),- (show (i + 1) ++ " Pkg Config ", VFD emptyParams [- mkField- (paraName <<<- ParaName "A list of pkg-config packages, needed to build this package"- $ paraDirection <<<- ParaDirection Vertical- $ paraMinSize <<<- ParaMinSize (-1,120)- $ emptyParams)- (pkgconfigDepends . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{pkgconfigDepends = a})})- (dependenciesEditor [])- ]),- (show (i + 1) ++ " Opts C -1-", VFD emptyParams [- mkField- (paraName <<<- ParaName "Options for C compiler"- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- (ccOptions . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{ccOptions = a})})- optsEditor- , mkField- (paraName <<<- ParaName "Options for linker"- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- (ldOptions . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{ldOptions = a})})- optsEditor- , mkField- (paraName <<<- ParaName "A list of header files to use when compiling"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- (includes . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{includes = a})})- (stringsEditor (const True) True)- , mkField- (paraName <<<- ParaName "A list of header files to install"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- (installIncludes . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{installIncludes = a})})- (filesEditor fp FileChooserActionOpen "Select File")- ]),- (show (i + 1) ++ " Opts C -2-", VFD emptyParams [- mkField- (paraName <<<- ParaName "A list of directories to search for header files"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- (includeDirs . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{includeDirs = a})})- (filesEditor fp FileChooserActionSelectFolder "Select Folder")- , mkField- (paraName <<<- ParaName- "A list of C source files to be compiled,linked with the Haskell files."- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- (cSources . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{cSources = a})})- (filesEditor fp FileChooserActionOpen "Select file")- ]),- (show (i + 1) ++ " Opts Libs ", VFD emptyParams [- mkField- (paraName <<<- ParaName "A list of extra libraries to link with"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- (extraLibs . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{extraLibs = a})})- (stringsEditor (const True) True)- , mkField- (paraName <<<- ParaName "A list of directories to search for libraries."- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- (extraLibDirs . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{extraLibDirs = a})})- (filesEditor fp FileChooserActionSelectFolder "Select Folder")- ]),- (show (i + 1) ++ " Other", VFD emptyParams [- mkField- (paraName <<<- ParaName "Support frameworks for Mac OS X"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- (frameworks . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{frameworks = a})})- (stringsEditor (const True) True)- , mkField- (paraName <<<- ParaName "Custom fields build info"- $ paraShadow <<<- ParaShadow ShadowIn- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- (customFieldsBI . (\a -> a !! i) . bis)- (\ a b -> b{bis = update (bis b) i (\bi -> bi{customFieldsBI = a})})- (multisetEditor- (ColumnDescr True [("Name",\(n,_) -> [cellText := n])- ,("Value",\(_,v) -> [cellText := v])])- ((pairEditor- (stringxEditor (const True),emptyParams)- (stringEditor (const True) True,emptyParams)),emptyParams)- Nothing- Nothing)- ])]--stringxEditor :: (String -> Bool) -> Editor String-stringxEditor val para noti = do- (wid,inj,ext) <- stringEditor val True para noti- let- xinj ("") = inj ""- xinj ('x':'-':rest) = inj rest- xinj _ = throwIDE "PackageEditor>>stringxEditor: field without leading x-"- xext = do- res <- ext- case res of- Nothing -> return Nothing- Just str -> return (Just ("x-" ++ str))- return (wid,xinj,xext)--optsEditor :: Editor [String]-optsEditor para noti = do- (wid,inj,ext) <- stringEditor (const True) True para noti- let- oinj = inj . unwords- oext = do- res <- ext- case res of- Nothing -> return Nothing- Just str -> return (Just (words str))- return (wid,oinj,oext)--packageEditor :: Editor PackageIdentifier-packageEditor para noti = do- (wid,inj,ext) <- pairEditor- (stringEditor (\s -> not (null s)) True, paraName <<<- ParaName "Name" $ emptyParams)- (versionEditor, paraName <<<- ParaName "Version" $ emptyParams)- (paraDirection <<<- ParaDirection Horizontal- $ paraShadow <<<- ParaShadow ShadowIn- $ para) noti- let pinj (PackageIdentifier (PackageName n) v) = inj (n,v)- let pext = do- mbp <- ext- case mbp of- Nothing -> return Nothing- Just (n,v) -> do- if null n- then return Nothing- else return (Just $PackageIdentifier (PackageName n) v)- return (wid,pinj,pext)--testedWithEditor :: Editor [(CompilerFlavor, VersionRange)]-testedWithEditor para = do- multisetEditor- (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [cellText := show cv])- ,("Version Range",\(_,vr) -> [cellText := display vr])])- (pairEditor- (compilerFlavorEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams)- (versionRangeEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams),- (paraDirection <<<- (ParaDirection Vertical) $ emptyParams))- Nothing- (Just (==))- para--compilerFlavorEditor :: Editor CompilerFlavor-compilerFlavorEditor para noti = do- (wid,inj,ext) <- eitherOrEditor- (comboSelectionEditor flavors show, paraName <<<- (ParaName "Select compiler") $ emptyParams)- (stringEditor (\s -> not (null s)) True, paraName <<<- (ParaName "Specify compiler") $ emptyParams)- "Other"- (paraName <<<- ParaName "Select" $ para)- noti- let cfinj comp = case comp of- (OtherCompiler str) -> inj (Right str)- other -> inj (Left other)- let cfext = do- mbp <- ext- case mbp of- Nothing -> return Nothing- Just (Right s) -> return (Just $OtherCompiler s)- Just (Left other) -> return (Just other)- return (wid,cfinj,cfext)- where- flavors = [GHC, NHC, Hugs, HBC, Helium, JHC]--buildTypeEditor :: Editor BuildType-buildTypeEditor para noti = do- (wid,inj,ext) <- eitherOrEditor- (comboSelectionEditor flavors show, paraName <<<- (ParaName "Select") $ emptyParams)- (stringEditor (const True) True, paraName <<<- (ParaName "Unknown") $ emptyParams)- "Unknown"- (paraName <<<- ParaName "Select" $ para)- noti- let cfinj comp = case comp of- (UnknownBuildType str) -> inj (Right str)- other -> inj (Left other)- let cfext = do- mbp <- ext- case mbp of- Nothing -> return Nothing- Just (Right s) -> return (Just $ UnknownBuildType s)- Just (Left other) -> return (Just other)- return (wid,cfinj,cfext)- where- flavors = [Simple, Configure, Make, Custom]--extensionsEditor :: Editor [Extension]-extensionsEditor = staticListMultiEditor extensionsL show---extensionsL :: [Extension]-extensionsL = knownExtensions--{---reposEditor :: Editor [SourceRepo]-reposEditor p noti =- multisetEditor- (ColumnDescr False [("",\repo -> [cellText := display repo])])- (repoEditor,- paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0)- $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0)- $ emptyParams)- Nothing- Nothing- (paraShadow <<<- ParaShadow ShadowIn $- paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0)- $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0)- $ paraDirection <<<- ParaDirection Vertical- $ paraPack <<<- ParaPack PackGrow- $ p)- noti--instance Text SourceRepo where- disp (SourceRepo repoKind repoType repoLocation repoModule repoBranch repoTag repoSubdir)- = disp repoKind- <+> case repoType of- Nothing -> empty- Just repoT -> disp repoT- <+> case repoLocation of- Nothing -> empty- Just repoL -> text repoL--repoEditor :: Editor SourceRepo-repoEditor paras noti = do- (widg,inj,ext) <- tupel7Editor- (repoKindEditor,noBorder)- (maybeEditor (repoTypeEditor,noBorder) True "Specify a type", emptyParams)- (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a location", emptyParams)- (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a module", emptyParams)- (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a branch", emptyParams)- (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a tag", emptyParams)- (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a subdir", emptyParams)- (paraDirection <<<- ParaDirection Vertical $ noBorder)- noti- return (widg,- (\ r -> inj (repoKind r,repoType r,repoLocation r,repoModule r,repoBranch r,repoTag r,repoSubdir r)),- (do- mb <- ext- case mb of- Nothing -> return Nothing- Just (a,b,c,d,e,f,g) -> return (Just (SourceRepo a b c d e f g))))- where noBorder = 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--repoKindEditor :: Editor RepoKind-repoKindEditor paras noti = do- (widg,inj,ext) <- pairEditor- (comboSelectionEditor selectionList show, emptyParams)- (stringEditor (const True) True,emptyParams)- paras- noti- return (widg,- (\kind -> case kind of- RepoKindUnknown str -> inj (RepoKindUnknown "",str)- other -> inj (other,"")),- (do- mbRes <- ext- case mbRes of- Nothing -> return Nothing- Just (RepoKindUnknown "",str) -> return (Just (RepoKindUnknown str))- Just (other,_) -> return (Just other)))- where selectionList = [RepoHead, RepoThis, RepoKindUnknown ""]--repoTypeEditor :: Editor RepoType-repoTypeEditor paras noti = do- (widg,inj,ext) <- pairEditor- (comboSelectionEditor selectionList show, emptyParams)- (stringEditor (const True) True,emptyParams)- paras- noti- return (widg,- (\kind -> case kind of- OtherRepoType str -> inj (OtherRepoType "",str)- other -> inj (other,"")),- (do- mbRes <- ext- case mbRes of- Nothing -> return Nothing- Just (OtherRepoType "",str) -> return (Just (OtherRepoType str))- Just (other,_) -> return (Just other)))- where selectionList = [Darcs, Git, SVN, CVS, Mercurial, GnuArch, Bazaar, Monotone, OtherRepoType ""]---}---- --------------------------------------------------------------- * BuildInfos--- --------------------------------------------------------------data Library' = Library'{- exposedModules' :: [ModuleName]-, libExposed' :: Bool-, libBuildInfoIdx :: Int}- deriving (Show, Eq)--data Executable' = Executable'{- exeName' :: String-, modulePath' :: FilePath-, buildInfoIdx :: Int}- deriving (Show, Eq)--instance Default Library'- where getDefault = Library' [] getDefault getDefault--instance Default Executable'- where getDefault = Executable' getDefault getDefault getDefault---libraryEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Library'-libraryEditor fp modules numBuildInfos para noti = do- (wid,inj,ext) <-- tupel3Editor- (boolEditor,- paraName <<<- ParaName "Exposed"- $ paraSynopsis <<<- ParaSynopsis "Is the lib to be exposed by default?"- $ emptyParams)- (modulesEditor (sort modules),- paraName <<<- ParaName "Exposed Modules"- $ paraMinSize <<<- ParaMinSize (-1,300)- $ para)- (buildInfoEditorP numBuildInfos, paraName <<<- ParaName "Build Info"- $ paraPack <<<- ParaPack PackNatural- $ para)- (paraDirection <<<- ParaDirection Vertical- $ emptyParams)- noti- let pinj (Library' em exp bi) = inj (exp, map display em,bi)- let pext = do- mbp <- ext- case mbp of- Nothing -> return Nothing- Just (exp,em,bi) -> return (Just $ Library' (map (\s -> forceJust (simpleParse s)- "SpecialEditor >> libraryEditor: no parse for moduile name") em) exp bi)- return (wid,pinj,pext)----moduleEditor :: [ModuleName] -> Editor String---moduleEditor modules = comboSelectionEditor (map display modules)--modulesEditor :: [ModuleName] -> Editor [String]-modulesEditor modules = staticListMultiEditor (map display modules) id--executablesEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor [Executable']-executablesEditor fp modules countBuildInfo p =- multisetEditor- (ColumnDescr True [("Executable Name",\(Executable' exeName _ _) -> [cellText := exeName])- ,("Module Path",\(Executable' _ mp _) -> [cellText := mp])-- ,("Build info index",\(Executable' _ _ bii) -> [cellText := show (bii + 1)])])- (executableEditor fp modules countBuildInfo,emptyParams)- Nothing- Nothing- (paraShadow <<<- ParaShadow ShadowIn $ p)--executableEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Executable'-executableEditor fp modules countBuildInfo para noti = do- (wid,inj,ext) <- tupel3Editor- (stringEditor (\s -> not (null s)) True,- paraName <<<- ParaName "Executable 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 (Executable' s f bi) = inj (s,f,bi)- let pext = do- mbp <- ext- case mbp of- Nothing -> return Nothing- Just (s,f,bi) -> return (Just $Executable' s f bi)- return (wid,pinj,pext)--buildInfoEditorP :: Int -> Editor Int-buildInfoEditorP numberOfBuildInfos para noti = do- (wid,inj,ext) <- intEditor (1.0,fromIntegral numberOfBuildInfos,1.0)- (paraName <<<- ParaName "Build Info" $para) noti- let pinj i = inj (i + 1)- let pext = do- mbV <- ext- case mbV of- Nothing -> return Nothing- Just i -> return (Just (i - 1))- return (wid,pinj,pext)---- --------------------------------------------------------------- * (Boring) default values--- ---------------------------------------------------------------instance Default CompilerFlavor- where getDefault = GHC--instance Default BuildInfo- where getDefault = emptyBuildInfo--instance Default Library- where getDefault = Library [] getDefault getDefault--instance Default Executable- where getDefault = Executable getDefault getDefault getDefault--instance Default RepoType- where getDefault = Darcs--instance Default RepoKind- where getDefault = RepoThis--instance Default SourceRepo- where getDefault = SourceRepo getDefault getDefault getDefault getDefault getDefault- getDefault getDefault--instance Default BuildType- where getDefault = Simple--+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, DeriveDataTypeable, + MultiParamTypeClasses, TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.PackageEditor +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org> +-- Stability : provisional +-- Portability : portable +-- +-- | Module for editing of cabal packages and build infos +-- +----------------------------------------------------------------------------------- + + +module IDE.Pane.PackageEditor ( + packageNew' +, packageEdit +, choosePackageDir +, choosePackageFile + +, hasConfigs +, standardSetup +) where + +import Graphics.UI.Gtk +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Verbosity +import System.FilePath +import Data.Maybe +import System.Directory + +import IDE.Core.State +import IDE.Utils.FileUtils +import Graphics.UI.Editor.MakeEditor +import Distribution.PackageDescription.Parse (readPackageDescription) +import Distribution.PackageDescription.Configuration (flattenPackageDescription) +import Distribution.ModuleName(ModuleName) +import Data.Typeable (Typeable(..)) +import Graphics.UI.Editor.Composite + (versionEditor, + versionRangeEditor, + dependenciesEditor, + stringsEditor, + filesEditor, + tupel3Editor, + eitherOrEditor, + maybeEditor, + pairEditor, + ColumnDescr(..), + multisetEditor) +import Distribution.Text (simpleParse, display) +import MyMissing +import Graphics.UI.Editor.Parameters + (paraInnerPadding, + paraInnerAlignment, + paraOuterPadding, + paraOuterAlignment, + Parameter(..), + paraPack, + Direction(..), + paraDirection, + paraMinSize, + paraShadow, + paraSynopsis, + (<<<-), + emptyParams, + paraName, + getParameterPrim) +import Graphics.UI.Editor.Simple + (staticListMultiEditor, + intEditor, + boolEditor, + fileEditor, + comboSelectionEditor, + multilineStringEditor, + stringEditor) +import Graphics.UI.Editor.Basics + (Notifier, Editor(..), GUIEventSelector(..), GUIEvent(..)) +import Distribution.Compiler + (CompilerFlavor(..)) +#if !MIN_VERSION_Cabal(1,11,0) +import Distribution.Simple (knownExtensions) +#endif +import Distribution.Simple (Extension(..), VersionRange, anyVersion) +import Default (Default(..)) +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 (sort,nub) +import Control.Monad.Trans.Reader (ask) +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 + (writeGenericPackageDescription) +#else +import Distribution.PackageDescription.Parse + (writePackageDescription) +#endif +import Distribution.Version (Version(..), orLaterVersion)+ +-------------------------------------------------------------------------- +-- Handling of Generic Package Descriptions + +#if MIN_VERSION_Cabal(1,10,0) +toGenericPackageDescription :: PackageDescription -> GenericPackageDescription +toGenericPackageDescription pd = + GenericPackageDescription { + packageDescription = pd{ + library = Nothing, + executables = [], + testSuites = [], + buildDepends = []}, + genPackageFlags = [], + condLibrary = case library pd of + Nothing -> Nothing + Just lib -> Just (buildCondTreeLibrary lib), + condExecutables = map buildCondTreeExe (executables pd), + condTestSuites = map buildCondTreeTest (testSuites pd)} + where + buildCondTreeLibrary lib = + CondNode { + condTreeData = lib, + condTreeConstraints = buildDepends pd, + condTreeComponents = []} + buildCondTreeExe exe = + (exeName exe, CondNode { + condTreeData = exe, + condTreeConstraints = buildDepends pd, + condTreeComponents = []}) + buildCondTreeTest test = + (testName test, CondNode { + condTreeData = test, + condTreeConstraints = buildDepends pd, + condTreeComponents = []}) +#endif + +-- --------------------------------------------------------------------- +-- The exported stuff goes here +-- + +choosePackageDir :: Window -> Maybe FilePath -> IO (Maybe FilePath) +choosePackageDir window mbDir = chooseDir window "Select root folder for package" mbDir + +choosePackageFile :: Window -> Maybe FilePath -> IO (Maybe FilePath) +choosePackageFile window mbDir = chooseFile window "Select cabal package file (.cabal)" mbDir + +packageEdit :: PackageAction +packageEdit = do + idePackage <- ask + let dirName = dropFileName (ipdCabalFile idePackage) + modules <- liftIO $ allModules dirName + package <- liftIO $ readPackageDescription normal (ipdCabalFile idePackage) + if hasConfigs package + then do + lift $ ideMessage High ("Cabal file with configurations can't be edited with the " + ++ "current version of the editor") + lift $ fileOpenThis $ ipdCabalFile idePackage + return () + else do+ let flat = flattenPackageDescription package+#if MIN_VERSION_Cabal(1,10,0) + if hasUnknownTestTypes 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 + return ()+ else do + lift $ editPackage flat dirName modules (\ _ -> return ()) + return () +#else+ lift $ editPackage flat dirName modules (\ _ -> return ()) + return () +#endif+ +hasConfigs :: GenericPackageDescription -> Bool +hasConfigs gpd = + let libConds = case condLibrary gpd of + Nothing -> False + Just condTree -> not (null (condTreeComponents condTree)) + exeConds = foldr (\ (_,condTree) hasConfigs -> + if hasConfigs + 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+ +packageNew' :: Maybe FilePath -> (Bool -> FilePath -> IDEAction) -> IDEAction +packageNew' mbDir activateAction = do + windows <- getWindows + mbDirName <- liftIO $ choosePackageDir (head windows) mbDir + case mbDirName of + Nothing -> return () + Just dirName -> do + mbCabalFile <- liftIO $ cabalFileName dirName+ window <- getMainWindow + case mbCabalFile of + Just cfn -> do + add <- liftIO $ do + md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel + $ "There is already file " ++ takeFileName cfn ++ " in this directory. " + ++ "Would you like to add this package to the workspace?" + dialogAddButton md "_Add Package" (ResponseUser 1) + dialogSetDefaultResponse md (ResponseUser 1) + set md [ windowWindowPosition := WinPosCenterOnParent ] + rid <- dialogRun md + widgetDestroy md + return $ rid == ResponseUser 1 + when add $ activateAction False cfn + Nothing -> do+ isEmptyDir <- liftIO $ isEmptyDirectory dirName+ make <- if isEmptyDir+ then return True+ else liftIO $ do + md <- messageDialogNew (Just window) [] MessageQuestion ButtonsCancel + $ "The path you have choosen " ++ dirName ++ " is not an empty directory. " + ++ "Are you sure you want to make a new package here?" + dialogAddButton md "_Make Package Here" (ResponseUser 1) + dialogSetDefaultResponse md (ResponseUser 1) + set md [ windowWindowPosition := WinPosCenterOnParent ] + rid <- dialogRun md + widgetDestroy md + return $ rid == ResponseUser 1 + when make $ do+ modules <- liftIO $ do + b1 <- doesFileExist (dirName </> "Setup.hs") + b2 <- doesFileExist (dirName </> "Setup.lhs") + if not (b1 || b2) + then do + sysMessage Normal "Setup.(l)hs does not exist. Writing Standard" + writeFile (dirName </> "Setup.lhs") standardSetup + else sysMessage Normal "Setup.(l)hs already exist" + allModules dirName + let Just initialVersion = simpleParse "0.0.1" + editPackage emptyPackageDescription{+ package = PackageIdentifier (PackageName $ takeBaseName dirName) + initialVersion, + buildType = Just Simple, +#if MIN_VERSION_Cabal(1,10,0) + specVersionRaw = Right (orLaterVersion (Version [1,2] [])), +#endif+ buildDepends = [+ Dependency (PackageName "base") anyVersion+ , Dependency (PackageName "QuickCheck") anyVersion], + executables = [emptyExecutable { + exeName = (takeBaseName dirName) + , modulePath = "Main.hs" + , buildInfo = emptyBuildInfo {+ hsSourceDirs = ["src"]}}]+#if MIN_VERSION_Cabal(1,10,0) + , testSuites = [emptyTestSuite {+ testName = "test-" ++ takeBaseName dirName+ , testInterface = (TestSuiteExeV10 (Version [1,0] []) "Main.hs") + , testBuildInfo = emptyBuildInfo {+ hsSourceDirs = ["src"]+ , cppOptions = ["-DMAIN_FUNCTION=testMain"]}}]+#endif+ } dirName modules (activateAction True) + return () + +standardSetup = "#!/usr/bin/runhaskell \n" + ++ "> module Main where\n" + ++ "> import Distribution.Simple\n" + ++ "> main :: IO ()\n" + ++ "> main = defaultMain\n\n" + +-- --------------------------------------------------------------------- +-- | We do some twist for handling build infos seperately to edit them in one editor together +-- with the other stuff. This type show what we really edit here +-- + +data PackageDescriptionEd = PDE { + pd :: PackageDescription, + exes :: [Executable'], +#if MIN_VERSION_Cabal(1,10,0) + tests :: [Test'], +#endif+ mbLib :: Maybe Library', + bis :: [BuildInfo]} + deriving Eq + +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+ 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+ mbLib = case mbLib' of + Nothing -> Nothing + Just (Library' mn b bii) -> if bii + 1 > length buildInfos + then Just (Library mn b (buildInfos !! (length buildInfos - 1))) + else Just (Library mn b (buildInfos !! bii)) + in pd {+ library = mbLib+ , executables = exes+#if MIN_VERSION_Cabal(1,10,0) + , testSuites = tests+#endif+ } + +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+ (mbLib,bis2) = case library pd of + Nothing -> (Nothing,bis) + Just (Library mn b bi) -> (Just (Library' (sort mn) b (length bis)), bis ++ [bi]) + bis3 = if null bis2 + then [emptyBuildInfo] + else bis2 + in PDE (pd {library = Nothing , executables = []})+ exes+#if MIN_VERSION_Cabal(1,10,0) + tests+#endif+ mbLib+ bis3 + +-- --------------------------------------------------------------------- +-- The pane stuff +-- + +data PackagePane = PackagePane { + packageBox :: VBox, + packageNotifer :: Notifier +} deriving Typeable + + +data PackageState = PackageState + deriving (Read, Show, Typeable) + +instance Pane PackagePane IDEM + where + primPaneName _ = "Package" + getAddedIndex _ = 0 + getTopWidget = castToWidget . packageBox + paneId b = "*Package" + +instance RecoverablePane PackagePane PackageState IDEM where + saveState p = return Nothing + recoverState pp st = return Nothing + buildPane panePath notebook builder = return Nothing + builder pp nb w = return (Nothing,[]) + +editPackage :: PackageDescription -> FilePath -> [ModuleName] -> (FilePath -> IDEAction) -> IDEAction +editPackage packageD packagePath modules afterSaveAction = do + mbPane :: Maybe PackagePane <- getPane + case mbPane of + Nothing -> do + pp <- getBestPathForId "*Package" + nb <- getNotebook pp + packageInfos <- liftIO $ getInstalledPackageIds + let packageEd = toEditor packageD + initPackage packagePath packageEd + (packageDD + packageInfos + (takeDirectory packagePath) + modules + (length (bis packageEd)) + (concatMap (buildInfoD (Just (takeDirectory packagePath)) modules) + [0..length (bis packageEd) - 1])) + pp nb modules afterSaveAction packageEd + Just p -> liftIO $ bringPaneToFront p + +initPackage :: FilePath + -> PackageDescriptionEd + -> FieldDescription PackageDescriptionEd + -> PanePath + -> Notebook + -> [ModuleName] + -> (FilePath -> IDEAction) + -> PackageDescriptionEd + -> IDEM () +initPackage packageDir packageD packageDescr panePath nb modules afterSaveAction origPackageD = do + let fields = flattenFieldDescription packageDescr + let initialPackagePath = packageDir </> (display . pkgName . package . pd) packageD ++ ".cabal" + packageInfos <- liftIO $ getInstalledPackageIds + mbP <- buildThisPane panePath nb + (builder' packageDir packageD packageDescr afterSaveAction + initialPackagePath modules packageInfos fields origPackageD) + case mbP of + Nothing -> return () + Just (PackagePane{packageNotifer = pn}) -> do + liftIO $ triggerEvent pn (GUIEvent { + selector = MayHaveChanged, + gtkEvent = GTK.Event True, + eventText = "", + gtkReturn = True}) + return () + +builder' :: FilePath -> + PackageDescriptionEd -> + FieldDescription PackageDescriptionEd -> + (FilePath -> IDEAction) -> + FilePath -> + [ModuleName] -> + [PackageId] -> + [FieldDescription PackageDescriptionEd] -> + PackageDescriptionEd -> + PanePath -> + Notebook -> + Window -> + IDEM (Maybe PackagePane,Connections) +builder' packageDir packageD packageDescr afterSaveAction initialPackagePath modules packageInfos fields + origPackageD panePath nb window = reifyIDE $ \ ideR -> do + vb <- vBoxNew False 0 + bb <- hButtonBoxNew + save <- buttonNewFromStock "gtk-save" + widgetSetSensitive save False + closeB <- buttonNewFromStock "gtk-close" + addB <- buttonNewFromStock "Add Build Info" + removeB <- buttonNewFromStock "Remove Build Info" + label <- labelNew Nothing + boxPackStart bb addB PackNatural 0 + boxPackStart bb removeB PackNatural 0 + boxPackEnd bb closeB PackNatural 0 + boxPackEnd bb save PackNatural 0 + (widget, setInj, getExt, notifier) <- buildEditor packageDescr packageD + let packagePane = PackagePane vb notifier + boxPackStart vb widget PackGrow 7 + boxPackStart vb label PackNatural 0 + boxPackEnd vb bb PackNatural 7 + + let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of + Just s -> s + Nothing -> "Unnamed") fields + addB `onClicked` (do + mbNewPackage' <- extract packageD [getExt] + case mbNewPackage' of + Nothing -> sysMessage Normal "Content doesn't validate" + Just pde -> reflectIDE (do + closePane packagePane + initPackage packageDir pde {bis = bis pde ++ [bis pde !! 0]} + (packageDD + (packageInfos) + packageDir + modules + (length (bis pde) + 1) + (concatMap (buildInfoD (Just packageDir) modules) + [0..length (bis pde)])) + panePath nb modules afterSaveAction origPackageD) ideR) + removeB `onClicked` (do + mbNewPackage' <- extract packageD [getExt] + case mbNewPackage' of + Nothing -> sysMessage Normal "Content doesn't validate" + Just pde | length (bis pde) == 1 -> sysMessage Normal "Just one Build Info" + | otherwise -> reflectIDE (do + closePane packagePane + initPackage packageDir pde{bis = take (length (bis pde) - 1) (bis pde)} + (packageDD + packageInfos + packageDir + modules + (length (bis pde) - 1) + (concatMap (buildInfoD (Just packageDir) modules) + [0..length (bis pde) - 2])) + panePath nb modules afterSaveAction origPackageD) ideR) + closeB `onClicked` (do + mbP <- extract packageD [getExt] + let hasChanged = case mbP of + Nothing -> False + Just p -> p /= origPackageD + if not hasChanged + then reflectIDE (closePane packagePane >> return ()) ideR + else do + md <- messageDialogNew (Just window) [] + MessageQuestion + ButtonsYesNo + "Unsaved changes. Close anyway?" + set md [ windowWindowPosition := WinPosCenterOnParent ] + resp <- dialogRun md + widgetDestroy md + case resp of + ResponseYes -> do + reflectIDE (closePane packagePane >> return ()) ideR + _ -> return ()) + save `onClicked` (do + mbNewPackage' <- extract packageD [getExt] + case mbNewPackage' of + Nothing -> return () + 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 + return ()) ideR) + registerEvent notifier MayHaveChanged (\ e -> do + mbP <- extract packageD [getExt] + let hasChanged = case mbP of + Nothing -> False + Just p -> p /= origPackageD + when (isJust mbP) $ labelSetMarkup label "" + when (isJust mbP) $ comparePDE (fromJust mbP) packageD + markLabel nb (getTopWidget packagePane) hasChanged + widgetSetSensitive save hasChanged + return (e{gtkReturn=False})) + registerEvent notifier ValidationError (\e -> do + labelSetMarkup label $ "<span foreground=\"red\" size=\"x-large\">The following fields have invalid values: " + ++ eventText e ++ "</span>" + return e) + return (Just packagePane,[]) + +-- --------------------------------------------------------------------- +-- The description with some tricks +-- + +packageDD :: [PackageIdentifier] + -> FilePath + -> [ModuleName] + -> Int + -> [(String, FieldDescription PackageDescriptionEd)] + -> FieldDescription PackageDescriptionEd +packageDD packages fp modules numBuildInfos extras = NFD ([ + ("Package", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Synopsis" + $ paraSynopsis <<<- ParaSynopsis "A one-line summary of this package" + $ emptyParams) + (synopsis . pd) + (\ a b -> b{pd = (pd b){synopsis = a}}) + (stringEditor (const True) True) + , mkField + (paraName <<<- ParaName "Package Identifier" $ emptyParams) + (package . pd) + (\ a b -> b{pd = (pd b){package = a}}) + packageEditor + , mkField + (paraName <<<- ParaName "Description" + $ paraSynopsis <<<- ParaSynopsis "A more verbose description of this package" + $ paraShadow <<<- ParaShadow ShadowOut + $ paraMinSize <<<- ParaMinSize (-1,210) + $ emptyParams) + (description . pd) + (\ a b -> b{pd = (pd b){description = if null a then " " else a}}) + multilineStringEditor + , mkField + (paraName <<<- ParaName "Homepage" $ emptyParams) + (homepage . pd) + (\ a b -> b{pd = (pd b){homepage = a}}) + (stringEditor (const True) True) + , mkField + (paraName <<<- ParaName "Package URL" $ emptyParams) + (pkgUrl . pd) + (\ a b -> b{pd = (pd b){pkgUrl = a}}) + (stringEditor (const True) True) + , mkField + (paraName <<<- ParaName "Category" $ emptyParams) + (category . pd) + (\ a b -> b{pd = (pd b){category = a}}) + (stringEditor (const True) True) + ]), + ("Description", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Stability" $ emptyParams) + (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 + , mkField + (paraName <<<- ParaName "License File" $ emptyParams) + (licenseFile . pd) + (\ a b -> b{pd = (pd b){licenseFile = a}}) + (fileEditor (Just fp) FileChooserActionOpen "Select file") + , mkField + (paraName <<<- ParaName "Copyright" $ emptyParams) + (copyright . pd) + (\ a b -> b{pd = (pd b){copyright = a}}) + (stringEditor (const True) True) + , mkField + (paraName <<<- ParaName "Author" $ emptyParams) + (author . pd) + (\ a b -> b{pd = (pd b){author = a}}) + (stringEditor (const True) True) + , mkField + (paraName <<<- ParaName "Maintainer" $ emptyParams) + (maintainer . pd) + (\ a b -> b{pd = (pd b){maintainer = a}}) + (stringEditor (const True) True) + , mkField + (paraName <<<- ParaName "Bug Reports" $ emptyParams) + (bugReports . pd) + (\ a b -> b{pd = (pd b){bugReports = a}}) + (stringEditor (const True) True) + ]), +-- ("Repositories", VFD emptyParams [ +-- mkField +-- (paraName <<<- ParaName "Source Repositories" $ emptyParams) +-- (sourceRepos . pd) +-- (\ a b -> b{pd = (pd b){sourceRepos = a}}) +-- reposEditor]), + ("Dependencies ", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Build Dependencies" + $ paraSynopsis <<<- ParaSynopsis "Does this package depends on other packages?" + $ paraDirection <<<- ParaDirection Vertical + $ paraMinSize <<<- ParaMinSize (-1,250) + $ emptyParams) + (nub . buildDepends . pd) + (\ a b -> b{pd = (pd b){buildDepends = a}}) + (dependenciesEditor packages) + ]), + ("Meta Dep.", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Cabal version" + $ paraSynopsis <<<- ParaSynopsis + "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" + $ paraShadow <<<- ParaShadow ShadowIn + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (\a -> case (testedWith . pd) a of + [] -> []--(GHC,anyVersion)] + l -> l) + (\ a b -> b{pd = (pd b){testedWith = a}}) + testedWithEditor + ]), + ("Data Files", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Data Files" + $ paraSynopsis <<<- ParaSynopsis + "A list of files to be installed for run-time use by the package." + $ paraDirection <<<- ParaDirection Vertical + $ paraMinSize <<<- ParaMinSize (-1,250) + $ emptyParams) + (dataFiles . pd) + (\ a b -> b{pd = (pd b){dataFiles = a}}) + (filesEditor (Just fp) FileChooserActionOpen "Select File") + , mkField + (paraName <<<- ParaName "Data directory" $ emptyParams) + (dataDir . pd) + (\ a b -> b{pd = (pd b){dataDir = a}}) + (fileEditor (Just fp) FileChooserActionSelectFolder "Select file") + ]), + ("Extra Files", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Extra Source Files" + $ paraSynopsis <<<- ParaSynopsis + "A list of additional files to be included in source distributions." + $ paraDirection <<<- ParaDirection Vertical + $ paraMinSize <<<- ParaMinSize (-1,120) + $ emptyParams) + (extraSrcFiles . pd) + (\ a b -> b{pd = (pd b){extraSrcFiles = a}}) + (filesEditor (Just fp) FileChooserActionOpen "Select File") + , mkField + (paraName <<<- ParaName "Extra Tmp Files" + $ paraSynopsis <<<- ParaSynopsis + "A list of additional files or directories to be removed by setup clean." + $ paraDirection <<<- ParaDirection Vertical + $ paraMinSize <<<- ParaMinSize (-1,120) + $ emptyParams) + (extraTmpFiles . pd) + (\ a b -> b{pd = (pd b){extraTmpFiles = a}}) + (filesEditor (Just fp) FileChooserActionOpen "Select File") + ]), + ("Other",VFD emptyParams [ + mkField + (paraName <<<- ParaName "Build Type" + $ paraSynopsis <<<- ParaSynopsis + "Describe executable programs contained in the package" + $ paraShadow <<<- ParaShadow ShadowIn + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (buildType . pd) + (\ a b -> b{pd = (pd b){buildType = a}}) + (maybeEditor (buildTypeEditor, emptyParams) True "Specify?") + , mkField + (paraName <<<- ParaName "Custom Fields" + $ paraShadow <<<- ParaShadow ShadowIn + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (customFieldsPD . pd) + (\ a b -> b{pd = (pd b){customFieldsPD = a}}) + (multisetEditor + (ColumnDescr True [("Name",\(n,_) -> [cellText := n]) + ,("Value",\(_,v) -> [cellText := v])]) + ((pairEditor + (stringxEditor (const True),emptyParams) + (stringEditor (const True) True,emptyParams)),emptyParams) + Nothing + Nothing) + ]), + ("Executables",VFD emptyParams [ + mkField + (paraName <<<- ParaName "Executables" + $ paraSynopsis <<<- ParaSynopsis + "Describe executable programs contained in the package" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + exes + (\ a b -> b{exes = a}) + (executablesEditor (Just fp) modules numBuildInfos) + ]), +#if MIN_VERSION_Cabal(1,10,0) + ("Tests",VFD emptyParams [ + mkField + (paraName <<<- ParaName "Tests" + $ paraSynopsis <<<- ParaSynopsis + "Describe tests contained in the package" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + tests + (\ a b -> b{tests = a}) + (testsEditor (Just fp) modules numBuildInfos) + ]), +#endif+ ("Library", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Library" + $ paraSynopsis <<<- ParaSynopsis + "If the package contains a library, specify the exported modules here" + $ paraDirection <<<- ParaDirection Vertical + $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams) + mbLib + (\ a b -> b{mbLib = a}) + (maybeEditor (libraryEditor (Just fp) modules numBuildInfos, + paraName <<<- ParaName "Specify exported modules" + $ emptyParams) True + "Does this package contain a library?") + ]) + ] ++ extras) + +update :: [BuildInfo] -> Int -> (BuildInfo -> BuildInfo) -> [BuildInfo] +update bis index func = + map (\(bi,ind) -> if ind == index + then func bi + else bi) + (zip bis [0..length bis - 1]) + +buildInfoD :: Maybe FilePath -> [ModuleName] -> Int -> [(String,FieldDescription PackageDescriptionEd)] +buildInfoD fp modules i = [ + (show (i + 1) ++ " Build Info", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Component is buildable here" $ emptyParams) + (buildable . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{buildable = a})}) + boolEditor + , mkField + (paraName <<<- ParaName + "Where to look for the source hierarchy" + $ paraSynopsis <<<- ParaSynopsis + "Root directories for the source hierarchy." + $ paraShadow <<<- ParaShadow ShadowIn + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (hsSourceDirs . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{hsSourceDirs = a})}) + (filesEditor fp FileChooserActionSelectFolder "Select folder") + , mkField + (paraName <<<- ParaName "Non-exposed or non-main modules" + $ paraSynopsis <<<- ParaSynopsis ("A list of modules used by the component but " + ++ "not exposed to users.") + $ paraShadow <<<- ParaShadow ShadowIn + $ paraDirection <<<- ParaDirection Vertical + $ paraMinSize <<<- ParaMinSize (-1,300) + $ paraPack <<<- ParaPack PackGrow + $ emptyParams) + (map display. otherModules . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> + bi{otherModules = (map (\i -> forceJust (simpleParse i) + " PackageEditor >> buildInfoD: no parse for moduile name" ) a)})}) + (modulesEditor modules) + ]), + (show (i + 1) ++ " Compiler ", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Options for haskell compilers" + $ paraDirection <<<- ParaDirection Vertical + $ paraShadow <<<- ParaShadow ShadowIn + $ paraPack <<<- ParaPack PackGrow $ emptyParams) + (options . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{options = a})}) + (multisetEditor + (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [cellText := show cv]) + ,("Options",\(_,op) -> [cellText := concatMap (\s -> ' ' : s) op])]) + ((pairEditor + (compilerFlavorEditor,emptyParams) + (optsEditor,emptyParams)), + (paraDirection <<<- ParaDirection Vertical + $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)) + Nothing + Nothing) + , mkField + (paraName <<<- ParaName "Additional options for GHC when built with profiling" + $ emptyParams) + (ghcProfOptions . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{ghcProfOptions = a})}) + optsEditor + , mkField + (paraName <<<- ParaName "Additional options for GHC when the package is built as shared library" + $ emptyParams) + (ghcSharedOptions . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{ghcSharedOptions = a})}) + optsEditor + ]), + (show (i + 1) ++ " Extensions ", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Extensions" + $ paraSynopsis <<<- ParaSynopsis + "A list of Haskell extensions used by every module." + $ 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 + ]), + (show (i + 1) ++ " Build Tools ", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Tools needed for a build" + $ paraDirection <<<- ParaDirection Vertical + $ paraMinSize <<<- ParaMinSize (-1,120) + $ emptyParams) + (buildTools . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{buildTools = a})}) + (dependenciesEditor []) + ]), + (show (i + 1) ++ " Pkg Config ", VFD emptyParams [ + mkField + (paraName <<<- ParaName "A list of pkg-config packages, needed to build this package" + $ paraDirection <<<- ParaDirection Vertical + $ paraMinSize <<<- ParaMinSize (-1,120) + $ emptyParams) + (pkgconfigDepends . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{pkgconfigDepends = a})}) + (dependenciesEditor []) + ]), + (show (i + 1) ++ " Opts C -1-", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Options for C compiler" + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (ccOptions . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{ccOptions = a})}) + optsEditor + , mkField + (paraName <<<- ParaName "Options for linker" + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (ldOptions . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{ldOptions = a})}) + optsEditor + , mkField + (paraName <<<- ParaName "A list of header files to use when compiling" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (includes . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{includes = a})}) + (stringsEditor (const True) True) + , mkField + (paraName <<<- ParaName "A list of header files to install" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (installIncludes . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{installIncludes = a})}) + (filesEditor fp FileChooserActionOpen "Select File") + ]), + (show (i + 1) ++ " Opts C -2-", VFD emptyParams [ + mkField + (paraName <<<- ParaName "A list of directories to search for header files" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (includeDirs . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{includeDirs = a})}) + (filesEditor fp FileChooserActionSelectFolder "Select Folder") + , mkField + (paraName <<<- ParaName + "A list of C source files to be compiled,linked with the Haskell files." + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (cSources . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{cSources = a})}) + (filesEditor fp FileChooserActionOpen "Select file") + ]), + (show (i + 1) ++ " Opts Libs ", VFD emptyParams [ + mkField + (paraName <<<- ParaName "A list of extra libraries to link with" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (extraLibs . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{extraLibs = a})}) + (stringsEditor (const True) True) + , mkField + (paraName <<<- ParaName "A list of directories to search for libraries." + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (extraLibDirs . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{extraLibDirs = a})}) + (filesEditor fp FileChooserActionSelectFolder "Select Folder") + ]), + (show (i + 1) ++ " Other", VFD emptyParams [ + mkField + (paraName <<<- ParaName "Options for C preprocessor" + $ paraDirection <<<- ParaDirection Vertical + $ emptyParams) + (cppOptions . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{cppOptions = a})}) + optsEditor + , mkField + (paraName <<<- ParaName "Support frameworks for Mac OS X" + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (frameworks . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{frameworks = a})}) + (stringsEditor (const True) True) + , mkField + (paraName <<<- ParaName "Custom fields build info" + $ paraShadow <<<- ParaShadow ShadowIn + $ paraDirection <<<- ParaDirection Vertical $ emptyParams) + (customFieldsBI . (\a -> a !! i) . bis) + (\ a b -> b{bis = update (bis b) i (\bi -> bi{customFieldsBI = a})}) + (multisetEditor + (ColumnDescr True [("Name",\(n,_) -> [cellText := n]) + ,("Value",\(_,v) -> [cellText := v])]) + ((pairEditor + (stringxEditor (const True),emptyParams) + (stringEditor (const True) True,emptyParams)),emptyParams) + Nothing + Nothing) + ])] + +stringxEditor :: (String -> Bool) -> Editor String +stringxEditor val para noti = do + (wid,inj,ext) <- stringEditor val True para noti + let + xinj ("") = inj "" + xinj ('x':'-':rest) = inj rest + xinj _ = throwIDE "PackageEditor>>stringxEditor: field without leading x-" + xext = do + res <- ext + case res of + Nothing -> return Nothing + Just str -> return (Just ("x-" ++ str)) + return (wid,xinj,xext) + +optsEditor :: Editor [String] +optsEditor para noti = do + (wid,inj,ext) <- stringEditor (const True) True para noti + let + oinj = inj . unwords + oext = do + res <- ext + case res of + Nothing -> return Nothing + Just str -> return (Just (words str)) + return (wid,oinj,oext) + +packageEditor :: Editor PackageIdentifier +packageEditor para noti = do + (wid,inj,ext) <- pairEditor + (stringEditor (\s -> not (null s)) True, paraName <<<- ParaName "Name" $ emptyParams) + (versionEditor, paraName <<<- ParaName "Version" $ emptyParams) + (paraDirection <<<- ParaDirection Horizontal + $ paraShadow <<<- ParaShadow ShadowIn + $ para) noti + let pinj (PackageIdentifier (PackageName n) v) = inj (n,v) + let pext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + Just (n,v) -> do + if null n + then return Nothing + else return (Just $PackageIdentifier (PackageName n) v) + return (wid,pinj,pext) + +testedWithEditor :: Editor [(CompilerFlavor, VersionRange)] +testedWithEditor para = do + multisetEditor + (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [cellText := show cv]) + ,("Version Range",\(_,vr) -> [cellText := display vr])]) + (pairEditor + (compilerFlavorEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams) + (versionRangeEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams), + (paraDirection <<<- (ParaDirection Vertical) $ emptyParams)) + Nothing + (Just (==)) + para + +compilerFlavorEditor :: Editor CompilerFlavor +compilerFlavorEditor para noti = do + (wid,inj,ext) <- eitherOrEditor + (comboSelectionEditor flavors show, paraName <<<- (ParaName "Select compiler") $ emptyParams) + (stringEditor (\s -> not (null s)) True, paraName <<<- (ParaName "Specify compiler") $ emptyParams) + "Other" + (paraName <<<- ParaName "Select" $ para) + noti + let cfinj comp = case comp of + (OtherCompiler str) -> inj (Right str) + other -> inj (Left other) + let cfext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + Just (Right s) -> return (Just $OtherCompiler s) + Just (Left other) -> return (Just other) + return (wid,cfinj,cfext) + where + flavors = [GHC, NHC, Hugs, HBC, Helium, JHC] + +buildTypeEditor :: Editor BuildType +buildTypeEditor para noti = do + (wid,inj,ext) <- eitherOrEditor + (comboSelectionEditor flavors show, paraName <<<- (ParaName "Select") $ emptyParams) + (stringEditor (const True) True, paraName <<<- (ParaName "Unknown") $ emptyParams) + "Unknown" + (paraName <<<- ParaName "Select" $ para) + noti + let cfinj comp = case comp of + (UnknownBuildType str) -> inj (Right str) + other -> inj (Left other) + let cfext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + Just (Right s) -> return (Just $ UnknownBuildType s) + Just (Left other) -> return (Just other) + return (wid,cfinj,cfext) + where + flavors = [Simple, Configure, Make, Custom] + +extensionsEditor :: Editor [Extension] +extensionsEditor = staticListMultiEditor extensionsL show + + +extensionsL :: [Extension] +#if MIN_VERSION_Cabal(1,11,0) +extensionsL = map EnableExtension [minBound..maxBound] +#else +extensionsL = knownExtensions +#endif + +{-- +reposEditor :: Editor [SourceRepo] +reposEditor p noti = + multisetEditor + (ColumnDescr False [("",\repo -> [cellText := display repo])]) + (repoEditor, + paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) + $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0) + $ emptyParams) + Nothing + Nothing + (paraShadow <<<- ParaShadow ShadowIn $ + paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) + $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0) + $ paraDirection <<<- ParaDirection Vertical + $ paraPack <<<- ParaPack PackGrow + $ p) + noti + +instance Text SourceRepo where + disp (SourceRepo repoKind repoType repoLocation repoModule repoBranch repoTag repoSubdir) + = disp repoKind + <+> case repoType of + Nothing -> empty + Just repoT -> disp repoT + <+> case repoLocation of + Nothing -> empty + Just repoL -> text repoL + +repoEditor :: Editor SourceRepo +repoEditor paras noti = do + (widg,inj,ext) <- tupel7Editor + (repoKindEditor,noBorder) + (maybeEditor (repoTypeEditor,noBorder) True "Specify a type", emptyParams) + (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a location", emptyParams) + (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a module", emptyParams) + (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a branch", emptyParams) + (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a tag", emptyParams) + (maybeEditor (stringEditor (const True) True,noBorder) True "Specify a subdir", emptyParams) + (paraDirection <<<- ParaDirection Vertical $ noBorder) + noti + return (widg, + (\ r -> inj (repoKind r,repoType r,repoLocation r,repoModule r,repoBranch r,repoTag r,repoSubdir r)), + (do + mb <- ext + case mb of + Nothing -> return Nothing + Just (a,b,c,d,e,f,g) -> return (Just (SourceRepo a b c d e f g)))) + where noBorder = 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 + +repoKindEditor :: Editor RepoKind +repoKindEditor paras noti = do + (widg,inj,ext) <- pairEditor + (comboSelectionEditor selectionList show, emptyParams) + (stringEditor (const True) True,emptyParams) + paras + noti + return (widg, + (\kind -> case kind of + RepoKindUnknown str -> inj (RepoKindUnknown "",str) + other -> inj (other,"")), + (do + mbRes <- ext + case mbRes of + Nothing -> return Nothing + Just (RepoKindUnknown "",str) -> return (Just (RepoKindUnknown str)) + Just (other,_) -> return (Just other))) + where selectionList = [RepoHead, RepoThis, RepoKindUnknown ""] + +repoTypeEditor :: Editor RepoType +repoTypeEditor paras noti = do + (widg,inj,ext) <- pairEditor + (comboSelectionEditor selectionList show, emptyParams) + (stringEditor (const True) True,emptyParams) + paras + noti + return (widg, + (\kind -> case kind of + OtherRepoType str -> inj (OtherRepoType "",str) + other -> inj (other,"")), + (do + mbRes <- ext + case mbRes of + Nothing -> return Nothing + Just (OtherRepoType "",str) -> return (Just (OtherRepoType str)) + Just (other,_) -> return (Just other))) + where selectionList = [Darcs, Git, SVN, CVS, Mercurial, GnuArch, Bazaar, Monotone, OtherRepoType ""] +--} + +-- ------------------------------------------------------------ +-- * BuildInfos +-- ------------------------------------------------------------ + +data Library' = Library'{ + exposedModules' :: [ModuleName] +, libExposed' :: Bool +, libBuildInfoIdx :: Int} + deriving (Show, Eq) + +data Executable' = Executable'{ + exeName' :: String +, modulePath' :: FilePath +, 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+ +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+ +libraryEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Library' +libraryEditor fp modules numBuildInfos para noti = do + (wid,inj,ext) <- + tupel3Editor + (boolEditor, + paraName <<<- ParaName "Exposed" + $ paraSynopsis <<<- ParaSynopsis "Is the lib to be exposed by default?" + $ emptyParams) + (modulesEditor (sort modules), + paraName <<<- ParaName "Exposed Modules" + $ paraMinSize <<<- ParaMinSize (-1,300) + $ para) + (buildInfoEditorP numBuildInfos, paraName <<<- ParaName "Build Info" + $ paraPack <<<- ParaPack PackNatural + $ para) + (paraDirection <<<- ParaDirection Vertical + $ emptyParams) + noti + let pinj (Library' em exp bi) = inj (exp, map display em,bi) + let pext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + Just (exp,em,bi) -> return (Just $ Library' (map (\s -> forceJust (simpleParse s) + "SpecialEditor >> libraryEditor: no parse for moduile name") em) exp bi) + return (wid,pinj,pext) + +--moduleEditor :: [ModuleName] -> Editor String +--moduleEditor modules = comboSelectionEditor (map display modules) + +modulesEditor :: [ModuleName] -> Editor [String] +modulesEditor modules = staticListMultiEditor (map display modules) id + +executablesEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor [Executable'] +executablesEditor fp modules countBuildInfo p = + multisetEditor + (ColumnDescr True [("Executable Name",\(Executable' exeName _ _) -> [cellText := exeName]) + ,("Module Path",\(Executable' _ mp _) -> [cellText := mp]) + + ,("Build info index",\(Executable' _ _ bii) -> [cellText := show (bii + 1)])]) + (executableEditor fp modules countBuildInfo,emptyParams) + Nothing + Nothing + (paraShadow <<<- ParaShadow ShadowIn $ p) + +executableEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Executable' +executableEditor fp modules countBuildInfo para noti = do + (wid,inj,ext) <- tupel3Editor + (stringEditor (\s -> not (null s)) True, + paraName <<<- ParaName "Executable 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 (Executable' s f bi) = inj (s,f,bi) + let pext = do + mbp <- ext + case mbp of + Nothing -> return Nothing + 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 + Nothing + (paraShadow <<<- ParaShadow ShadowIn $ p)+ where+ interfaceName (TestSuiteExeV10 _ f) = f+ interfaceName i = show i + +testEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Test' +testEditor fp modules countBuildInfo para noti = do + (wid,inj,ext) <- tupel3Editor + (stringEditor (\s -> not (null s)) True, + paraName <<<- ParaName "Test 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 (Test' s (TestSuiteExeV10 (Version [1,0] []) f) bi) = inj (s,f,bi)+ pinj _ = error "Unexpected Test Interface" + let pext = do+ mbp <- ext + case mbp of + Nothing -> return Nothing + Just (s,f,bi) -> return (Just $Test' s (TestSuiteExeV10 (Version [1,0] []) f) bi) + return (wid,pinj,pext) +#endif+ +buildInfoEditorP :: Int -> Editor Int +buildInfoEditorP numberOfBuildInfos para noti = do + (wid,inj,ext) <- intEditor (1.0,fromIntegral numberOfBuildInfos,1.0) + (paraName <<<- ParaName "Build Info" $para) noti + let pinj i = inj (i + 1) + let pext = do + mbV <- ext + case mbV of + Nothing -> return Nothing + Just i -> return (Just (i - 1)) + return (wid,pinj,pext) + +-- ------------------------------------------------------------ +-- * (Boring) default values +-- ------------------------------------------------------------ + + +instance Default CompilerFlavor + where getDefault = GHC + +instance Default BuildInfo + where getDefault = emptyBuildInfo + +instance Default Library + where getDefault = Library [] getDefault getDefault + +instance Default Executable + where getDefault = Executable getDefault getDefault getDefault + +instance Default RepoType + where getDefault = Darcs + +instance Default RepoKind + where getDefault = RepoThis + +instance Default SourceRepo + where getDefault = SourceRepo getDefault getDefault getDefault getDefault getDefault + getDefault getDefault + +instance Default BuildType + where getDefault = Simple + +
src/IDE/Pane/PackageFlags.hs view
@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses- -XTypeSynonymInstances -XRank2Types #-}+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, DeriveDataTypeable,+ MultiParamTypeClasses, TypeSynonymInstances, Rank2Types #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.PackageFlags@@ -42,7 +42,6 @@ mkFieldPP) import Text.ParserCombinators.Parsec hiding(Parser) import Debug.Trace (trace)-import Control.Monad.Trans (liftIO) data IDEFlags = IDEFlags { flagsBox :: VBox@@ -103,8 +102,8 @@ Nothing -> return () Just packWithNewFlags -> do reflectIDE (do- modifyIDE_ (\ide -> ide{activePack = Just packWithNewFlags})- closePane flagsPane) ideR -- we don't trigger the activePack event here+ changePackage packWithNewFlags+ closePane flagsPane) ideR writeFields ((dropExtension (ipdCabalFile packWithNewFlags)) ++ leksahFlagFileExtension) packWithNewFlags flatFlagsDescription) cancelB `onClicked` (reflectIDE (closePane flagsPane >> return ()) ideR)@@ -175,7 +174,7 @@ mkFieldPP (paraName <<<- ParaName "Config flags" $ emptyParams) (PP.text . show)- stringParser+ readParser (\p -> unargs (ipdConfigFlags p)) (\ b a -> a{ipdConfigFlags = args b}) (stringEditor (const True) True)@@ -183,15 +182,23 @@ , mkFieldPP (paraName <<<- ParaName "Build flags" $ emptyParams) (PP.text . show)- stringParser+ readParser (\p -> unargs (ipdBuildFlags p)) (\ b a -> a{ipdBuildFlags = args b}) (stringEditor (const True) True) (\ _ -> return ()) , mkFieldPP+ (paraName <<<- ParaName "Test flags" $ emptyParams)+ (PP.text . show)+ readParser+ (\p -> unargs (ipdTestFlags p))+ (\ b a -> a{ipdTestFlags = args b})+ (stringEditor (const True) True)+ (\ _ -> return ())+ , mkFieldPP (paraName <<<- ParaName "Haddock flags" $ emptyParams) (PP.text . show)- stringParser+ readParser (\p -> unargs (ipdHaddockFlags p)) (\ b a -> a{ipdHaddockFlags = args b}) (stringEditor (const True) True)@@ -199,7 +206,7 @@ , mkFieldPP (paraName <<<- ParaName "Executable flags" $ emptyParams) (PP.text . show)- stringParser+ readParser (\p -> unargs (ipdExeFlags p)) (\ b a -> a{ipdExeFlags = args b}) (stringEditor (const True) True)@@ -207,7 +214,7 @@ , mkFieldPP (paraName <<<- ParaName "Install flags" $ emptyParams) (PP.text . show)- stringParser+ readParser (\p -> unargs (ipdInstallFlags p)) (\ b a -> a{ipdInstallFlags = args b}) (stringEditor (const True) True)@@ -215,7 +222,7 @@ , mkFieldPP (paraName <<<- ParaName "Register flags" $ emptyParams) (PP.text . show)- stringParser+ readParser (\p -> unargs (ipdRegisterFlags p)) (\ b a -> a{ipdRegisterFlags = args b}) (stringEditor (const True) True)@@ -223,7 +230,7 @@ , mkFieldPP (paraName <<<- ParaName "Unregister flags" $ emptyParams) (PP.text . show)- stringParser+ readParser (\p -> unargs (ipdUnregisterFlags p)) (\ b a -> a{ipdUnregisterFlags = args b}) (stringEditor (const True) True)@@ -231,7 +238,7 @@ , mkFieldPP (paraName <<<- ParaName "Source Distribution flags" $ emptyParams) (PP.text . show)- stringParser+ readParser (\p -> unargs (ipdSdistFlags p)) (\ b a -> a{ipdSdistFlags = args b}) (stringEditor (const True) True)
src/IDE/Pane/Preferences.hs view
@@ -1,6 +1,5 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses- -XTypeSynonymInstances #-}+{-# LANGUAGE CPP, FlexibleInstances, ScopedTypeVariables, DeriveDataTypeable,+ MultiParamTypeClasses, TypeSynonymInstances #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Preferences@@ -34,7 +33,6 @@ buttonNewFromStock, hButtonBoxNew, vBoxNew, castToWidget, VBox, ShadowType(..), Packing(..), fontDescriptionFromString, AttrOp(..), FileChooserAction(..), Color(..), ResponseId(..))-import Control.Monad.Reader import qualified Text.PrettyPrint.HughesPJ as PP import Distribution.Package import Data.IORef@@ -71,6 +69,8 @@ (ButtonsType(..), MessageType(..)) import System.Glib.Attributes (set) import Graphics.UI.Gtk.General.Enums (WindowPosition(..))+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (forM_, when) -- --------------------------------------------------------------------- -- This needs to be incremented, when the preferences format changes@@ -130,11 +130,11 @@ Nothing -> return () Just newPrefs -> do lastAppliedPrefs <- readIORef lastAppliedPrefsRef- mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc+ mapM_ (\f -> reflectIDE (applicator f newPrefs lastAppliedPrefs) ideR) flatPrefsDesc writeIORef lastAppliedPrefsRef newPrefs) restore `onClicked` (do lastAppliedPrefs <- readIORef lastAppliedPrefsRef- mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF prefs lastAppliedPrefs) ideR ) flatPrefsDesc+ mapM_ (\f -> reflectIDE (applicator f prefs lastAppliedPrefs) ideR) flatPrefsDesc injb prefs writeIORef lastAppliedPrefsRef prefs markLabel nb (getTopWidget prefsPane) False@@ -146,7 +146,7 @@ case mbNewPrefs of Nothing -> return () Just newPrefs -> do- mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc+ mapM_ (\f -> reflectIDE (applicator f newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc fp <- getConfigFilePathForSave standardPreferencesFilename writePrefs fp newPrefs fp2 <- getConfigFilePathForSave strippedPreferencesFilename@@ -595,6 +595,14 @@ boolEditor (\i -> return ()) , mkFieldPP+ (paraName <<<- ParaName "Select first warning if built without errors" $ emptyParams)+ (PP.text . show)+ boolParser+ jumpToWarnings+ (\b a -> a{jumpToWarnings = b})+ boolEditor+ (\i -> return ())+ , mkFieldPP (paraName <<<- ParaName "Background build" $ emptyParams) (PP.text . show) boolParser@@ -603,6 +611,14 @@ boolEditor (\i -> return ()) , mkFieldPP+ (paraName <<<- ParaName "Run unit tests when building" $ emptyParams)+ (PP.text . show)+ boolParser+ runUnitTests+ (\b a -> a{runUnitTests = b})+ boolEditor+ (\i -> return ())+ , mkFieldPP (paraName <<<- ParaName "Make mode" $ emptyParams) (PP.text . show) boolParser@@ -725,6 +741,7 @@ , categoryForPane = [ ("*ClassHierarchy","ToolCategory") , ("*Debug","ToolCategory") , ("*Flags","ToolCategory")+ , ("*Files","ToolCategory") , ("*Grep","ToolCategory") , ("*Info","ToolCategory") , ("*Log","LogCategory")@@ -741,7 +758,9 @@ , docuSearchURL = "http://www.holumbus.org/hayoo/hayoo.html?query=" , completeRestricted = False , saveAllBeforeBuild = True+ , jumpToWarnings = True , backgroundBuild = True+ , runUnitTests = False , makeMode = True , singleBuildWithoutLinking = False , dontInstallLast = False
src/IDE/Pane/Search.hs view
@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances- -XScopedTypeVariables #-}+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses,+ TypeSynonymInstances, ScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Search@@ -17,16 +17,17 @@ module IDE.Pane.Search ( IDESearch(..) , SearchState-, setChoices-, searchMetaGUI+, buildSearchPane+--, launchSymbolNavigationDialog , getSearch ) where import Graphics.UI.Gtk- (listStoreGetValue, treeSelectionGetSelectedRows, widgetShowAll,- menuPopup, menuShellAppend, onActivateLeaf, menuItemNewWithLabel,- menuNew, listStoreAppend, listStoreClear, entrySetText,- afterKeyRelease, onKeyPress, onButtonPress, toggleButtonGetActive,+ (cellTextScaleSet, cellTextScale, listStoreGetValue,+ treeSelectionGetSelectedRows, widgetShowAll, menuPopup,+ menuShellAppend, onActivateLeaf, menuItemNewWithLabel, menuNew,+ listStoreAppend, listStoreClear, entrySetText, afterKeyRelease,+ onKeyPress, onButtonPress, toggleButtonGetActive, widgetSetSensitivity, onToggled, afterFocusIn, vBoxNew, entryNew, scrolledWindowSetPolicy, containerAdd, scrolledWindowNew, treeSelectionSetMode, treeViewGetSelection,@@ -36,24 +37,28 @@ treeViewColumnSetSizing, treeViewColumnSetTitle, treeViewColumnNew, cellRendererPixbufNew, cellRendererTextNew, treeViewSetModel, treeViewNew, listStoreNew, boxPackEnd, boxPackStart,- checkButtonNewWithLabel, toggleButtonSetActive,- radioButtonNewWithLabelFromWidget, radioButtonNewWithLabel,- hBoxNew, entryGetText, castToWidget, Entry, VBox, ListStore,- TreeView, ScrolledWindow, PolicyType(..), SelectionMode(..),- TreeViewColumnSizing(..), AttrOp(..),- Packing(..))+ checkButtonNewWithLabel, toggleButtonSetActive, ResponseId(..),+ dialogRun, radioButtonNewWithLabelFromWidget,+ radioButtonNewWithLabel, buttonNewFromStock, windowSetTransientFor,+ hButtonBoxNew, dialogGetUpper, dialogGetActionArea,+ widgetGrabDefault, set, get, dialogNew, onClicked, dialogResponse,+ widgetHideAll, buttonSetLabel, widgetCanDefault, hBoxNew,+ entryGetText, castToWidget, Entry, VBox, ListStore, TreeView,+ ScrolledWindow, PolicyType(..), SelectionMode(..),+ TreeViewColumnSizing(..), AttrOp(..), Packing(..)) import Graphics.UI.Gtk.Gdk.Events import Data.IORef (newIORef) import Data.IORef (writeIORef,readIORef,IORef(..))-import IDE.Pane.SourceBuffer (goToDefinition)+-- import IDE.Pane.SourceBuffer (goToDefinition) import IDE.Metainfo.Provider (searchMeta) import Data.Maybe-import Control.Monad.Reader import Data.Typeable import IDE.Core.State import IDE.Utils.GUIUtils import Distribution.Text(display) import Control.Event (triggerEvent)+import Control.Monad.IO.Class (MonadIO(..))+import qualified Data.ByteString.Char8 as BS (empty, unpack) -- | A search pane description --@@ -66,6 +71,10 @@ , searchModeRef :: IORef SearchMode , topBox :: VBox , entry :: Entry+, scopeSelection :: Scope -> IDEAction+, modeSelection :: SearchMode -> IDEAction+, searchMetaGUI :: String -> IDEAction+, setChoices :: [Descr] -> IDEAction } deriving Typeable data SearchState = SearchState {@@ -89,151 +98,222 @@ return (Just (SearchState str scope mode)) recoverState pp (SearchState str scope mode) = do nb <- getNotebook pp- mbP <- buildPane pp nb builder- scopeSelection scope- modeSelection mode- searchMetaGUI str+ mbP@(Just search) <- buildPane pp nb builder+ (scopeSelection search) scope+ (modeSelection search) mode+ (searchMetaGUI search) str return mbP- builder pp nb windows =- let scope = SystemScope- mode = Prefix False- in reifyIDE $ \ ideR -> do+ builder pp nb windows = buildSearchPane - scopebox <- hBoxNew True 2- rb1 <- radioButtonNewWithLabel "Package"- rb2 <- radioButtonNewWithLabelFromWidget rb1 "Workspace"- rb3 <- radioButtonNewWithLabelFromWidget rb1 "System"- toggleButtonSetActive rb3 True- cb2 <- checkButtonNewWithLabel "Imports" - boxPackStart scopebox rb1 PackGrow 2- boxPackStart scopebox rb2 PackGrow 2- boxPackStart scopebox rb3 PackGrow 2- boxPackEnd scopebox cb2 PackNatural 2+buildSearchPane :: IDEM (Maybe IDESearch,Connections)+buildSearchPane =+ let scope = SystemScope+ mode = Prefix False+ in reifyIDE $ \ ideR -> do - modebox <- hBoxNew True 2- mb1 <- radioButtonNewWithLabel "Exact"- mb2 <- radioButtonNewWithLabelFromWidget mb1 "Prefix"- mb3 <- radioButtonNewWithLabelFromWidget mb1 "Regex"- toggleButtonSetActive- (case mode of- Exact _ -> mb1- Prefix _ -> mb2- Regex _ -> mb3) True- mb4 <- checkButtonNewWithLabel "Case sensitive"- toggleButtonSetActive mb4 (caseSense mode)- boxPackStart modebox mb1 PackNatural 2- boxPackStart modebox mb2 PackNatural 2- boxPackStart modebox mb3 PackNatural 2- boxPackEnd modebox mb4 PackNatural 2+ scopebox <- hBoxNew True 2+ rb1 <- radioButtonNewWithLabel "Package"+ rb2 <- radioButtonNewWithLabelFromWidget rb1 "Workspace"+ rb3 <- radioButtonNewWithLabelFromWidget rb1 "System"+ toggleButtonSetActive rb3 True+ cb2 <- checkButtonNewWithLabel "Imports" - listStore <- listStoreNew []- treeView <- treeViewNew- treeViewSetModel treeView listStore+ boxPackStart scopebox rb1 PackGrow 2+ boxPackStart scopebox rb2 PackGrow 2+ boxPackStart scopebox rb3 PackGrow 2+ boxPackEnd scopebox cb2 PackNatural 2 - renderer3 <- cellRendererTextNew- renderer30 <- cellRendererPixbufNew- col3 <- treeViewColumnNew- treeViewColumnSetTitle col3 "Symbol"- treeViewColumnSetSizing col3 TreeViewColumnAutosize- treeViewColumnSetResizable col3 True- treeViewColumnSetReorderable col3 True- treeViewAppendColumn treeView col3- cellLayoutPackStart col3 renderer30 False- cellLayoutPackStart col3 renderer3 True- cellLayoutSetAttributes col3 renderer3 listStore- $ \row -> [ cellText := dscName row]- cellLayoutSetAttributes col3 renderer30 listStore- $ \row -> [- cellPixbufStockId := stockIdFromType ((descrType . dscTypeHint) row)]+ modebox <- hBoxNew True 2+ mb1 <- radioButtonNewWithLabel "Exact"+ mb2 <- radioButtonNewWithLabelFromWidget mb1 "Prefix"+ mb3 <- radioButtonNewWithLabelFromWidget mb1 "Regex"+ toggleButtonSetActive+ (case mode of+ Exact _ -> mb1+ Prefix _ -> mb2+ Regex _ -> mb3) True+ mb4 <- checkButtonNewWithLabel "Case sensitive"+ toggleButtonSetActive mb4 (caseSense mode)+ boxPackStart modebox mb1 PackNatural 2+ boxPackStart modebox mb2 PackNatural 2+ boxPackStart modebox mb3 PackNatural 2+ boxPackEnd modebox mb4 PackNatural 2 + listStore <- listStoreNew []+ treeView <- treeViewNew+ treeViewSetModel treeView listStore - renderer1 <- cellRendererTextNew- renderer10 <- cellRendererPixbufNew- col1 <- treeViewColumnNew- treeViewColumnSetTitle col1 "Module"- treeViewColumnSetSizing col1 TreeViewColumnAutosize- treeViewColumnSetResizable col1 True- treeViewColumnSetReorderable col1 True- treeViewAppendColumn treeView col1- cellLayoutPackStart col1 renderer10 False- cellLayoutPackStart col1 renderer1 True- cellLayoutSetAttributes col1 renderer1 listStore- $ \row -> [ cellText := case dsMbModu row of- Nothing -> ""- Just pm -> display $ modu pm]- cellLayoutSetAttributes col1 renderer10 listStore- $ \row -> [- cellPixbufStockId := if isReexported row- then "ide_reexported"- else if isJust (dscMbLocation row)- then "ide_source"- else ""]+ renderer3 <- cellRendererTextNew+ renderer30 <- cellRendererPixbufNew+ col3 <- treeViewColumnNew+ treeViewColumnSetTitle col3 "Symbol"+ treeViewColumnSetSizing col3 TreeViewColumnAutosize+ treeViewColumnSetResizable col3 True+ treeViewColumnSetReorderable col3 True+ treeViewAppendColumn treeView col3+ cellLayoutPackStart col3 renderer30 False+ cellLayoutPackStart col3 renderer3 True+ cellLayoutSetAttributes col3 renderer3 listStore+ $ \row -> [ cellText := dscName row]+ cellLayoutSetAttributes col3 renderer30 listStore+ $ \row -> [+ cellPixbufStockId := stockIdFromType ((descrType . dscTypeHint) row)] - renderer2 <- cellRendererTextNew- col2 <- treeViewColumnNew- treeViewColumnSetTitle col2 "Package"- treeViewColumnSetSizing col2 TreeViewColumnAutosize- treeViewColumnSetResizable col2 True- treeViewColumnSetReorderable col2 True- treeViewAppendColumn treeView col2- cellLayoutPackStart col2 renderer2 True- cellLayoutSetAttributes col2 renderer2 listStore- $ \row -> [ cellText := case dsMbModu row of- Nothing -> ""- Just pm -> display $ pack pm]- treeViewSetHeadersVisible treeView True- sel <- treeViewGetSelection treeView- treeSelectionSetMode sel SelectionSingle - sw <- scrolledWindowNew Nothing Nothing- containerAdd sw treeView- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ renderer1 <- cellRendererTextNew+ renderer10 <- cellRendererPixbufNew+ col1 <- treeViewColumnNew+ treeViewColumnSetTitle col1 "Module"+ treeViewColumnSetSizing col1 TreeViewColumnAutosize+ treeViewColumnSetResizable col1 True+ treeViewColumnSetReorderable col1 True+ treeViewAppendColumn treeView col1+ cellLayoutPackStart col1 renderer10 False+ cellLayoutPackStart col1 renderer1 True+ cellLayoutSetAttributes col1 renderer1 listStore+ $ \row -> [ cellText := case dsMbModu row of+ Nothing -> ""+ Just pm -> display $ modu pm]+ cellLayoutSetAttributes col1 renderer10 listStore+ $ \row -> [+ cellPixbufStockId := if isReexported row+ then "ide_reexported"+ else if isJust (dscMbLocation row)+ then "ide_source"+ else ""] - entry <- entryNew+ renderer2 <- cellRendererTextNew+ col2 <- treeViewColumnNew+ treeViewColumnSetTitle col2 "Package"+ treeViewColumnSetSizing col2 TreeViewColumnAutosize+ treeViewColumnSetResizable col2 True+ treeViewColumnSetReorderable col2 True+ treeViewAppendColumn treeView col2+ cellLayoutPackStart col2 renderer2 True+ cellLayoutSetAttributes col2 renderer2 listStore+ $ \row -> [ cellText := case dsMbModu row of+ Nothing -> ""+ Just pm -> display $ pack pm] - box <- vBoxNew False 2- boxPackStart box scopebox PackNatural 0- boxPackStart box sw PackGrow 0- boxPackStart box modebox PackNatural 0- boxPackEnd box entry PackNatural 0+ renderer3 <- cellRendererTextNew+ col3 <- treeViewColumnNew+ treeViewColumnSetTitle col3 "Type/Kind"+ treeViewColumnSetSizing col3 TreeViewColumnAutosize+ treeViewColumnSetResizable col3 True+ treeViewColumnSetReorderable col3 True+ treeViewAppendColumn treeView col3+ cellLayoutPackStart col3 renderer3 True+ cellLayoutSetAttributes col3 renderer3 listStore+ $ \row -> [ cellText := BS.unpack $ fromMaybe BS.empty $+ dscMbTypeStr row,+ cellTextScale := 0.8, cellTextScaleSet := True ] - scopeRef <- newIORef scope- modeRef <- newIORef mode- let search = IDESearch sw treeView listStore scopeRef modeRef box entry+ treeViewSetHeadersVisible treeView True+ sel <- treeViewGetSelection treeView+ treeSelectionSetMode sel SelectionSingle - cid1 <- treeView `afterFocusIn`- (\_ -> do reflectIDE (makeActive search) ideR ; return True)- rb1 `onToggled` (reflectIDE (scopeSelection' rb1 rb2 rb3 cb2) ideR )- rb2 `onToggled` (reflectIDE (scopeSelection' rb1 rb2 rb3 cb2) ideR )- rb3 `onToggled` (reflectIDE (scopeSelection' rb1 rb2 rb3 cb2) ideR )- cb2 `onToggled` (reflectIDE (scopeSelection' rb1 rb2 rb3 cb2) ideR)- mb1 `onToggled` do- widgetSetSensitivity mb4 False- active <- toggleButtonGetActive mb4- (reflectIDE (modeSelection (Exact active)) ideR )- mb2 `onToggled`do- widgetSetSensitivity mb4 True- active <- toggleButtonGetActive mb4- (reflectIDE (modeSelection (Prefix active)) ideR )- mb3 `onToggled` do- widgetSetSensitivity mb4 True- active <- toggleButtonGetActive mb4- (reflectIDE (modeSelection (Regex active)) ideR )- mb4 `onToggled` do- active <- toggleButtonGetActive mb4- (reflectIDE (modeSelectionCase active) ideR )- treeView `onButtonPress` (handleEvent ideR listStore treeView)- treeView `onButtonPress` (handleEvent ideR listStore treeView)- treeView `onKeyPress` (handleEvent ideR listStore treeView)+ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw treeView+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic++ entry <- entryNew++ box <- vBoxNew False 2+ boxPackStart box scopebox PackNatural 0+ boxPackStart box sw PackGrow 0+ boxPackStart box modebox PackNatural 0+ boxPackEnd box entry PackNatural 0++ scopeRef <- newIORef scope+ modeRef <- newIORef mode+ let search = IDESearch sw treeView listStore scopeRef modeRef box entry scopeSelection_ modeSelection_ searchMetaGUI_ setChoices_+ scopeSelection_ :: Scope -> IDEAction+ scopeSelection_ scope = do+ liftIO $ writeIORef (searchScopeRef search) scope+ text <- liftIO $ entryGetText entry+ searchMetaGUI_ text++ modeSelection_ :: SearchMode -> IDEAction+ modeSelection_ mode = do+ liftIO $ writeIORef (searchModeRef search) mode+ text <- liftIO $ entryGetText entry+ searchMetaGUI_ text+ searchMetaGUI_ :: String -> IDEAction+ searchMetaGUI_ str = do+ liftIO $ bringPaneToFront search+ liftIO $ entrySetText entry str+ scope <- liftIO $ getScope search+ mode <- liftIO $ getMode search+ -- let mode' = if length str > 2 then mode else Exact (caseSense mode)+ descrs <- if null str+ then return []+ else searchMeta scope str mode+ liftIO $ do+ listStoreClear (searchStore search)+ mapM_ (listStoreAppend (searchStore search)) (take 500 descrs)+ modeSelectionCase :: Bool -> IDEAction+ modeSelectionCase caseSense = do+ oldMode <- liftIO $ readIORef (searchModeRef search)+ liftIO $ writeIORef (searchModeRef search) oldMode{caseSense = caseSense}+ text <- liftIO $ entryGetText entry+ searchMetaGUI_ text+ setChoices_ :: [Descr] -> IDEAction+ setChoices_ descrs = do+ liftIO $ do+ listStoreClear (searchStore search)+ mapM_ (listStoreAppend (searchStore search)) descrs+ bringPaneToFront search+ entrySetText entry+ (case descrs of+ [] -> ""+ hd: _ -> dscName hd)+ scopeSelection' rb1 rb2 rb3 cb2 = do+ scope <- liftIO $ do+ withImports <- toggleButtonGetActive cb2+ 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)+ scopeSelection_ scope++ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive search) ideR ; return True)+ rb1 `onToggled` (reflectIDE (scopeSelection' rb1 rb2 rb3 cb2) ideR )+ rb2 `onToggled` (reflectIDE (scopeSelection' rb1 rb2 rb3 cb2) ideR )+ rb3 `onToggled` (reflectIDE (scopeSelection' rb1 rb2 rb3 cb2) ideR )+ cb2 `onToggled` (reflectIDE (scopeSelection' rb1 rb2 rb3 cb2) ideR)+ mb1 `onToggled` do+ widgetSetSensitivity mb4 False+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelection_ (Exact active)) ideR )+ mb2 `onToggled`do+ widgetSetSensitivity mb4 True+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelection_ (Prefix active)) ideR )+ mb3 `onToggled` do+ widgetSetSensitivity mb4 True+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelection_ (Regex active)) ideR )+ mb4 `onToggled` do+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelectionCase active) ideR )+ treeView `onButtonPress` (handleEvent ideR listStore treeView)+ treeView `onButtonPress` (handleEvent ideR listStore treeView)+ treeView `onKeyPress` (handleEvent ideR listStore treeView) -- sel `onSelectionChanged` do -- fillInfo search ideR- entry `afterKeyRelease` (\ event -> do- text <- entryGetText entry- reflectIDE (searchMetaGUI text) ideR- return False)- return (Just search,[ConnectC cid1])+ entry `afterKeyRelease` (\ event -> do+ text <- entryGetText entry+ reflectIDE (searchMetaGUI_ text) ideR+ return False)+ return (Just search,[ConnectC cid1]) + getScope :: IDESearch -> IO Scope getScope search = readIORef (searchScopeRef search) @@ -244,56 +324,8 @@ getSearch Nothing = forceGetPane (Right "*Search") getSearch (Just pp) = forceGetPane (Left pp) -scopeSelection' rb1 rb2 rb3 cb2 = do- scope <- liftIO $ do- withImports <- toggleButtonGetActive cb2- 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)- scopeSelection scope -scopeSelection :: Scope -> IDEAction-scopeSelection scope = do- search <- getSearch Nothing- liftIO $ writeIORef (searchScopeRef search) scope- text <- liftIO $ entryGetText (entry search)- searchMetaGUI text -modeSelection :: SearchMode -> IDEAction-modeSelection mode = do- search <- getSearch Nothing- liftIO $ writeIORef (searchModeRef search) mode- text <- liftIO $ entryGetText (entry search)- searchMetaGUI text--modeSelectionCase :: Bool -> IDEAction-modeSelectionCase caseSense = do- search <- getSearch Nothing- oldMode <- liftIO $ readIORef (searchModeRef search)- liftIO $ writeIORef (searchModeRef search) oldMode{caseSense = caseSense}- text <- liftIO $ entryGetText (entry search)- searchMetaGUI text--searchMetaGUI :: String -> IDEAction-searchMetaGUI str = do- search <- getSearch Nothing- liftIO $ bringPaneToFront search- liftIO $ entrySetText (entry search) str- scope <- liftIO $ getScope search- mode <- liftIO $ getMode search--- let mode' = if length str > 2 then mode else Exact (caseSense mode)- descrs <- if null str- then return []- else searchMeta scope str mode- liftIO $ do- listStoreClear (searchStore search)- mapM_ (listStoreAppend (searchStore search)) (take 500 descrs)- handleEvent :: IDERef -> ListStore Descr -> TreeView@@ -321,8 +353,8 @@ goToDef ideR store descrView = do sel <- getSelectionDescr descrView store case sel of- Just descr -> reflectIDE- (goToDefinition descr) ideR+ Just descr -> reflectIDE (triggerEvent ideR (GotoDefinition descr)) ideR >> return ()+ -- (goToDefinition descr) ideR otherwise -> sysMessage Normal "Search >> listViewPopup: no selection" selectDescr ideR store descrView= do@@ -356,16 +388,35 @@ -- entrySetText (entry search) (descrName descr) -- otherwise -> return () -setChoices :: [Descr] -> IDEAction-setChoices descrs = do- search <- getSearch Nothing+{--+launchSymbolNavigationDialog :: String -> (Descr -> IDEM ()) -> IDEM ()+launchSymbolNavigationDialog txt act = do+ dia <- liftIO $ dialogNew+ win <- getMainWindow+ (Just searchPane, _) <- buildSearchPane liftIO $ do- listStoreClear (searchStore search)- mapM_ (listStoreAppend (searchStore search)) descrs- bringPaneToFront search- entrySetText (entry search)- (case descrs of- [] -> ""- hd: _ -> dscName hd)-+ windowSetTransientFor dia win+ upper <- dialogGetUpper dia+ lower <- dialogGetActionArea dia+ boxPackStart upper (topBox searchPane) PackNatural 7 + bb <- hButtonBoxNew+ closeB <- buttonNewFromStock "gtk-cancel"+ okB <- buttonNewFromStock "gtk-ok"+ okB `onClicked` do+ dialogResponse dia ResponseOk+ widgetHideAll dia+ closeB `onClicked` do+ dialogResponse dia ResponseCancel+ widgetHideAll dia+ boxPackEnd bb closeB PackNatural 0+ boxPackEnd bb okB PackNatural 0+ boxPackStart lower bb PackNatural 7+ set okB [widgetCanDefault := True]+ buttonSetLabel okB "Goto"+ widgetGrabDefault okB+ widgetShowAll dia+ resp <- dialogRun dia+ return ()+ return ()+--}
src/IDE/Pane/SourceBuffer.hs view
@@ -1,5 +1,6 @@-{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances- -XScopedTypeVariables -XRankNTypes #-}+{-# LANGUAGE FlexibleInstances, DeriveDataTypeable, MultiParamTypeClasses,+ TypeSynonymInstances, ScopedTypeVariables, RankNTypes #-}+{-# OPTIONS_GHC -fwarn-unused-imports #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.SourceBuffer@@ -69,64 +70,70 @@ , selectedLocation , recentSourceBuffers , newTextBuffer- , belongsToPackage , belongsToWorkspace+, getIdentifierUnderCursorFromIter+ ) where import Prelude hiding(getChar, getLine)-import Control.Monad.Reader+import Control.Applicative import System.FilePath import System.Directory import qualified Data.Map as Map import Data.Map (Map) import Data.List hiding(insert, delete) import Data.Maybe+import Data.Char import Data.Typeable-import System.Time+import qualified Data.Set as Set -import Graphics.UI.Gtk.Gdk.Events as Gtk import IDE.Core.State import IDE.Utils.GUIUtils(getCandyState) import IDE.Utils.FileUtils import IDE.SourceCandy+import IDE.SymbolNavigation import IDE.Completion as Completion (complete,cancel) import IDE.TextEditor import qualified System.IO.UTF8 as UTF8-import Data.IORef (writeIORef,readIORef,newIORef,IORef(..))-import Data.Char (isAlphaNum, isSymbol)+import Data.IORef (writeIORef,readIORef,newIORef)+-- import Data.Char (isAlphaNum, isSymbol) import Control.Event (triggerEvent) import IDE.Metainfo.Provider (getSystemInfo, getWorkspaceInfo) import Distribution.Text (simpleParse) import Distribution.ModuleName (ModuleName)-import qualified Data.Set as Set (member)+import Distribution.PackageDescription (hsSourceDirs)+--import qualified Data.Set as Set (member) import Graphics.UI.Gtk (Notebook, clipboardGet, selectionClipboard, dialogAddButton, widgetDestroy, fileChooserGetFilename, widgetShow, fileChooserDialogNew, notebookGetNthPage, notebookPageNum, widgetHide, dialogRun,- messageDialogNew, postGUIAsync, scrolledWindowSetShadowType,- scrolledWindowSetPolicy, castToWidget, ScrolledWindow, dialogSetDefaultResponse,+ messageDialogNew, scrolledWindowSetShadowType,+ scrolledWindowSetPolicy, dialogSetDefaultResponse, postGUIAsync, fileChooserSetCurrentFolder, fileChooserSelectFilename) import System.Glib.MainLoop (priorityDefaultIdle, idleAdd)-#if MIN_VERSION_gtk(0,10,5)-import Graphics.UI.Gtk (windowWindowPosition, Underline(..))-#else-import Graphics.UI.Gtk.Pango.Types (Underline(..))-#endif-import qualified Graphics.UI.Gtk as Gtk (Window, Notebook)+import qualified Graphics.UI.Gtk as Gtk hiding (eventKeyName)+import Graphics.UI.Gtk.Windows.Window import Graphics.UI.Gtk.General.Enums- (WindowPosition(..), ShadowType(..), PolicyType(..))+ (ShadowType(..), PolicyType(..)) import Graphics.UI.Gtk.Windows.MessageDialog (ButtonsType(..), MessageType(..)) #if MIN_VERSION_gtk(0,10,5) import Graphics.UI.Gtk.Windows.Dialog (ResponseId(..))+import Graphics.UI.Gtk (Underline(..)) #else import Graphics.UI.Gtk.General.Structs (ResponseId(..))+import Graphics.UI.Gtk.Pango.Types (Underline(..)) #endif import Graphics.UI.Gtk.Selectors.FileChooser (FileChooserAction(..)) import System.Glib.Attributes (AttrOp(..), set)+import qualified Graphics.UI.Gtk.Gdk.Events as GtkOld+ import IDE.BufferMode+import Control.Monad.Trans.Reader (ask)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (foldM, forM, filterM, unless, when) allBuffers :: IDEM [IDEBuffer] allBuffers = getPanes@@ -161,10 +168,10 @@ case mbbuf of Just buf -> do useCandy <- useCandyFor buf- candy' <- readIDE candy gtkBuf <- getBuffer (sourceView buf) setText gtkBuf text- when useCandy $ transformToCandy candy' gtkBuf+ when useCandy $ modeTransformToCandy (mode buf)+ (modeEditInCommentOrString (mode buf)) gtkBuf iter <- getIterAtOffset gtkBuf i placeCursor gtkBuf iter mark <- getInsertMark gtkBuf@@ -182,10 +189,11 @@ writeOverwriteInStatusbar sv ids1 <- eBuf `afterModifiedChanged` markActiveLabelAsChanged ids2 <- sv `afterMoveCursor` writeCursorPositionInStatusbar sv- ids3 <- sv `onLookupInfo` selectInfo sv+ -- ids3 <- sv `onLookupInfo` selectInfo sv -- obsolete by hyperlinks ids4 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv- activateThisPane actbuf $ concat [ids1, ids2, ids3, ids4]+ activateThisPane actbuf $ concat [ids1, ids2, ids4] triggerEventIDE (Sensitivity [(SensitivityEditor, True)])+ grabFocus sv checkModTime actbuf return () closePane pane = do makeActive pane@@ -237,7 +245,7 @@ Just si -> sourcePathFromScope si Nothing -> Nothing when (isJust mbSourcePath2) $- goToSourceDefinition (fromJust $ mbSourcePath2) (dscMbLocation idDescr)+ goToSourceDefinition (fromJust $ mbSourcePath2) (dscMbLocation idDescr) >> return () return () where sourcePathFromScope :: GenScope -> Maybe FilePath@@ -252,9 +260,9 @@ Nothing -> Nothing Nothing -> Nothing -goToSourceDefinition :: FilePath -> Maybe Location -> IDEAction+goToSourceDefinition :: FilePath -> Maybe Location -> IDEM (Maybe IDEBuffer) goToSourceDefinition fp dscMbLocation = do- liftIO $ putStrLn $ "goToSourceDefinition " ++ fp+-- liftIO $ putStrLn $ "goToSourceDefinition " ++ fp mbBuf <- selectSourceBuf fp when (isJust mbBuf && isJust dscMbLocation) $ inActiveBufContext () $ \_ ebuf buf _ -> do@@ -263,7 +271,7 @@ iterTemp <- getIterAtLine ebuf (max 0 (min (lines-1) ((locationSLine location) -1))) chars <- getCharsInLine iterTemp- iter <- atLineOffset iterTemp (max 0 (min (chars-1) (locationSCol location)))+ iter <- atLineOffset iterTemp (max 0 (min (chars-1) (locationSCol location -1))) iter2Temp <- getIterAtLine ebuf (max 0 (min (lines-1) ((locationELine location) -1))) chars2 <- getCharsInLine iter2Temp@@ -277,6 +285,7 @@ reflectIDE (scrollToIter (sourceView buf) iter 0.0 (Just (0.3,0.3))) ideR return False) priorityDefaultIdle return ()+ return mbBuf insertInBuffer :: Descr -> IDEAction insertInBuffer idDescr = do@@ -381,6 +390,15 @@ ideMessage Normal ("File does not exist " ++ (fromJust mbfn)) return Nothing +data CharacterCategory = IdentifierCharacter | SpaceCharacter | SyntaxCharacter+ deriving (Eq)+getCharacterCategory :: Maybe Char -> CharacterCategory+getCharacterCategory Nothing = SpaceCharacter+getCharacterCategory (Just c)+ | isAlphaNum c || c == '\'' || c == '_' = IdentifierCharacter+ | isSpace c = SpaceCharacter+ | otherwise = SyntaxCharacter+ builder' :: Bool -> Maybe FilePath -> Int ->@@ -409,7 +427,8 @@ beginNotUndoableAction buffer let mod = modFromFileName mbfn- when (bs && isHaskellMode mod) $ transformToCandy ct buffer+ when (bs && isHaskellMode mod) $ modeTransformToCandy mod+ (modeEditInCommentOrString mod) buffer endNotUndoableAction buffer setModified buffer False siter <- getStartIter buffer@@ -446,40 +465,17 @@ mode = mod} -- events ids1 <- sv `afterFocusIn` makeActive buf- ids2 <- onCompletion sv (Completion.complete sv False) Completion.cancel+ ids2 <- onCompletion sv (do+ Completion.complete sv False) $ do+ Completion.cancel ids3 <- sv `onButtonPress` \event -> do- let click = eventClick event liftIO $ reflectIDE (do- case click of- DoubleClick -> do- let isIdent a = isAlphaNum a || a == '\'' || a == '_'- let isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-'- || a == '!' || a == '@' || a == '%' || a == '&' || a == '?'- (startSel, endSel) <- getSelectionBounds buffer- mbStartChar <- getChar startSel- mbEndChar <- getChar endSel- let isSelectChar =- case mbStartChar of- Just startChar | isIdent startChar -> isIdent- Just startChar | isOp startChar -> isOp- _ -> const False- start <- case mbStartChar of- Just startChar | isSelectChar startChar -> do- maybeIter <- backwardFindCharC startSel (not.isSelectChar) Nothing- case maybeIter of- Just iter -> forwardCharC iter- Nothing -> return startSel- _ -> return startSel- end <- case mbEndChar of- Just endChar | isSelectChar endChar -> do- maybeIter <- forwardFindCharC endSel (not.isSelectChar) Nothing- case maybeIter of- Just iter -> return iter- Nothing -> return endSel- _ -> return endSel+ case GtkOld.eventClick event of+ GtkOld.DoubleClick -> do+ (start, end) <- getIdentifierUnderCursor buffer liftIO $ postGUIAsync $ reflectIDE (selectRange buffer start end) ideR- return False+ return True _ -> return False) ideR (GetTextPopup mbTpm) <- triggerEvent ideR (GetTextPopup Nothing) ids4 <- case mbTpm of@@ -487,9 +483,112 @@ Nothing -> do sysMessage Normal "SourceBuffer>> no text popup" return []- return (Just buf,concat [ids1, ids2, ids3, ids4])+ ids5 <- sv `onKeyPress`+ \name modifier keyval -> do+ liftIO $ reflectIDE (do+ let moveToNextWord iterOp sel = do+ sel' <- iterOp sel+ rs <- isRangeStart sel'+ if rs then return sel' else moveToNextWord iterOp sel'+ let calculateNewPosition iterOp = getInsertIter buffer >>= moveToNextWord iterOp+ let continueSelection keepSelBound nsel = do+ im <- getInsertMark buffer+ moveMark buffer im nsel+ scrollToIter sv nsel 0 Nothing+ when (not keepSelBound) $ do+ sb <- getSelectionBoundMark buffer+ moveMark buffer sb nsel+ case (name, map mapControlCommand modifier, keyval) of+ ("Left",[GtkOld.Control],_) -> do+ calculateNewPosition backwardCharC >>= continueSelection False+ return True+ ("Left",[GtkOld.Shift, GtkOld.Control],_) -> do+ calculateNewPosition backwardCharC >>= continueSelection True+ return True+ ("Right",[GtkOld.Control],_) -> do+ calculateNewPosition forwardCharC >>= continueSelection False --placeCursor buffer+ return True+ ("Right",[GtkOld.Shift, GtkOld.Control],_) -> do+ calculateNewPosition forwardCharC >>= continueSelection True+ return True+ ("BackSpace",[GtkOld.Control],_) -> do -- delete word+ here <- getInsertIter buffer+ there <- calculateNewPosition backwardCharC+ delete buffer here there+ return True+ ("underscore",[GtkOld.Shift, GtkOld.Control],_) -> do+ (start, end) <- getIdentifierUnderCursor buffer+ slice <- getSlice buffer start end True+ triggerEventIDE (SelectInfo slice False)+ return True+ -- Redundant should become a go to definition directly+ ("minus",[GtkOld.Control],_) -> do+ (start, end) <- getIdentifierUnderCursor buffer+ slice <- getSlice buffer start end True+ triggerEventIDE (SelectInfo slice True)+ return True+ _ -> do+ -- liftIO $ print ("sourcebuffer key:",name,modifier,keyval)+ return False+ ) ideR+ ids6 <- case sv of+ GtkEditorView sv -> do+ (liftIO $ createHyperLinkSupport sv sw (\ctrl shift iter -> do+ (GtkEditorIter beg,GtkEditorIter en) <- reflectIDE (getIdentifierUnderCursorFromIter (GtkEditorIter iter, GtkEditorIter iter)) ideR+ return (beg, if ctrl then en else beg)) (\_ shift' slice -> do+ when (slice /= []) $ do+ -- liftIO$ print ("slice",slice)+ reflectIDE (triggerEventIDE+ (SelectInfo slice shift')) ideR+ return ()+ )) +#ifdef LEKSAH_WITH_YI+ _ -> return []+#endif+ return (Just buf,concat [ids1, ids2, ids3, ids4, ids5, ids6]) +isIdent a = isAlphaNum a || a == '\'' || a == '_' -- parts of haskell identifiers++isRangeStart sel = do -- if char and previous char are of different char categories+ currentChar <- getChar sel+ let mbStartCharCat = getCharacterCategory currentChar+ mbPrevCharCat <- getCharacterCategory <$> (backwardCharC sel >>= getChar)+ return $ currentChar == Nothing || currentChar == Just '\n' || mbStartCharCat /= mbPrevCharCat && (mbStartCharCat == SyntaxCharacter || mbStartCharCat == IdentifierCharacter)++getIdentifierUnderCursor :: EditorBuffer -> IDEM (EditorIter, EditorIter)+getIdentifierUnderCursor buffer = do+ (startSel, endSel) <- getSelectionBounds buffer+ getIdentifierUnderCursorFromIter (startSel, endSel)++getIdentifierUnderCursorFromIter :: (EditorIter, EditorIter) -> IDEM (EditorIter, EditorIter)+getIdentifierUnderCursorFromIter (startSel, endSel) = do+ let isIdent a = isAlphaNum a || a == '\'' || a == '_'+ let isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-'+ || a == '!' || a == '@' || a == '%' || a == '&' || a == '?'+ mbStartChar <- getChar startSel+ mbEndChar <- getChar endSel+ let isSelectChar =+ case mbStartChar of+ Just startChar | isIdent startChar -> isIdent+ Just startChar | isOp startChar -> isOp+ _ -> const False+ start <- case mbStartChar of+ Just startChar | isSelectChar startChar -> do+ maybeIter <- backwardFindCharC startSel (not.isSelectChar) Nothing+ case maybeIter of+ Just iter -> forwardCharC iter+ Nothing -> return startSel+ _ -> return startSel+ end <- case mbEndChar of+ Just endChar | isSelectChar endChar -> do+ maybeIter <- forwardFindCharC endSel (not.isSelectChar) Nothing+ case maybeIter of+ Just iter -> return iter+ Nothing -> return endSel+ _ -> return endSel+ return (start, end)+ checkModTime :: IDEBuffer -> IDEM (Bool, Bool) checkModTime buf = do currentState' <- readIDE currentState@@ -580,7 +679,8 @@ beginNotUndoableAction buffer setText buffer fc if useCandy- then transformToCandy ct buffer+ then modeTransformToCandy (mode buf)+ (modeEditInCommentOrString (mode buf)) buffer else return () endNotUndoableAction buffer setModified buffer False@@ -607,9 +707,9 @@ selectInfo sv = do ideR <- ask buf <- getBuffer sv- (l,r) <- getSelectionBounds buf+ (l,r) <- getIdentifierUnderCursor buf symbol <- getText buf l r True- triggerEvent ideR (SelectInfo symbol)+ triggerEvent ideR (SelectInfo symbol False) return () markActiveLabelAsChanged :: IDEAction@@ -1129,14 +1229,18 @@ then let srcPaths = map (\srcP -> basePath </> srcP) (ipdSrcDirs pack) relPaths = map (\p -> makeRelative p fp) srcPaths- in if or (map (\p -> Set.member p (ipdExtraSrcs pack)) relPaths)+ in if or $+ (fp `elem` possibleMains basePath) :+ (map (\p -> Set.member p (ipdExtraSrcs pack)) relPaths) then Just pack else case mbModuleName of Nothing -> Nothing- Just mn -> if Set.member mn (ipdModules pack)+ Just mn -> if Map.member mn (ipdModules pack) then Just pack else Nothing else Nothing+ where+ possibleMains basePath = concatMap (\(f, bi, isTest) -> map (\srcDir -> basePath </> srcDir </> f) $ hsSourceDirs bi) $ ipdMain pack belongsToWorkspace b = belongsToPackage b >>= return . isJust @@ -1149,5 +1253,8 @@ use <- getCandyState buffers <- allBuffers if use- then mapM_ (modeEditToCandy . mode) buffers+ then mapM_ (\b -> modeEditToCandy (mode b)+ (modeEditInCommentOrString (mode b))) buffers else mapM_ (modeEditFromCandy . mode) buffers++
src/IDE/Pane/Trace.hs view
@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -XRecordWildCards -XTypeSynonymInstances -XMultiParamTypeClasses- -XDeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances, RecordWildCards, TypeSynonymInstances,+ MultiParamTypeClasses, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Trace@@ -23,7 +23,6 @@ import Graphics.UI.Gtk import Data.Typeable (Typeable(..)) import IDE.Core.State-import Control.Monad.Reader import IDE.Package (tryDebug_) import IDE.Debug (debugForward, debugBack, debugCommand')@@ -48,6 +47,9 @@ import Graphics.UI.Gtk.General.Enums (MouseButton(..)) import System.Log.Logger (debugM) import IDE.Workspaces (packageTry_)+import qualified Data.Enumerator.List as EL (consume)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.IO.Class (MonadIO(..)) -- | A debugger pane description --@@ -161,7 +163,9 @@ mbTraces <- lift getPane case mbTraces of Nothing -> return ()- Just tracePane -> tryDebug_ $ debugCommand' ":history" (\to -> liftIO $ postGUIAsync $ do+ Just tracePane -> tryDebug_ $ debugCommand' ":history" $ do+ to <- EL.consume+ liftIO $ postGUIAsync $ do let parseRes = parse tracesParser "" (selectString to) r <- case parseRes of Left err -> do@@ -173,8 +177,8 @@ then h{thSelected = True} else h) r mapM_ (insertTrace (tracepoints tracePane))- (zip r' [0..length r']))- where+ (zip r' [0..length r'])+ where insertTrace treeStore (tr,index) = treeStoreInsert treeStore [] index tr selectString :: [ToolOutput] -> String
src/IDE/Pane/Variables.hs view
@@ -1,5 +1,5 @@-{-# OPTIONS_GHC -XRecordWildCards -XTypeSynonymInstances -XMultiParamTypeClasses- -XDeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances, RecordWildCards, TypeSynonymInstances,+ MultiParamTypeClasses, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Variables@@ -18,13 +18,13 @@ IDEVariables , VariablesState , fillVariablesList+, fillVariablesListQuiet ) where import Graphics.UI.Gtk import Data.Typeable (Typeable(..)) import IDE.Core.State-import Control.Monad.Reader-import IDE.Package (tryDebug_)+import IDE.Package (tryDebug_, tryDebugQuiet_) import IDE.Debug (debugCommand') import IDE.Utils.Tool (ToolOutput(..)) import Text.ParserCombinators.Parsec@@ -45,7 +45,10 @@ import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Graphics.UI.Gtk.General.Enums (Click(..), MouseButton(..))-import IDE.Workspaces (packageTry_)+import IDE.Workspaces (packageTry_, packageTryQuiet_)+import qualified Data.Enumerator.List as EL (consume)+import Control.Monad.Trans.Class (MonadTrans(..))+import Control.Monad.IO.Class (MonadIO(..)) -- | A variables pane description --@@ -136,20 +139,38 @@ return (Just pane,[ConnectC cid1]) +fillVariablesListQuiet :: IDEAction+fillVariablesListQuiet = packageTryQuiet_ $ do+ mbVariables <- lift getPane+ case mbVariables of+ Nothing -> return ()+ Just var -> tryDebugQuiet_ $ debugCommand' ":show bindings" $ do+ to <- EL.consume+ liftIO $ postGUIAsync $ do+ case parse variablesParser "" (selectString to) of+ Left e -> sysMessage Normal (show e)+ Right triples -> do+ treeStoreClear (variables var)+ mapM_ (insertBreak (variables var))+ (zip triples [0..length triples])+ where+ insertBreak treeStore (v,index) = treeStoreInsert treeStore [] index v+ fillVariablesList :: IDEAction fillVariablesList = packageTry_ $ do mbVariables <- lift getPane case mbVariables of Nothing -> return ()- Just var -> tryDebug_ $ debugCommand' ":show bindings" (\to -> liftIO $ postGUIAsync- $ (do- case parse variablesParser "" (selectString to) of- Left e -> sysMessage Normal (show e)- Right triples -> do- treeStoreClear (variables var)- mapM_ (insertBreak (variables var))- (zip triples [0..length triples])))- where+ Just var -> tryDebug_ $ debugCommand' ":show bindings" $ do+ to <- EL.consume+ liftIO $ postGUIAsync $ do+ case parse variablesParser "" (selectString to) of+ Left e -> sysMessage Normal (show e)+ Right triples -> do+ treeStoreClear (variables var)+ mapM_ (insertBreak (variables var))+ (zip triples [0..length triples])+ where insertBreak treeStore (v,index) = treeStoreInsert treeStore [] index v selectString :: [ToolOutput] -> String@@ -258,31 +279,39 @@ forceVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction forceVariable varDescr path treeStore = packageTry_ $ tryDebug_ $ do- debugCommand' (":force " ++ (varName varDescr)) (\to -> liftIO $ postGUIAsync (do- case parse valueParser "" (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)) (\to -> liftIO $ postGUIAsync (do- case parse typeParser "" (selectString to) of- Left e -> sysMessage Normal (show e)- Right typ -> do- var <- treeStoreGetValue treeStore path- treeStoreSetValue treeStore path var{varType = typ}))+ debugCommand' (":force " ++ (varName varDescr)) $ do+ to <- EL.consume+ liftIO $ postGUIAsync $ do+ case parse valueParser "" (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+ to <- EL.consume+ liftIO $ postGUIAsync $ do+ case parse typeParser "" (selectString to) of+ Left e -> sysMessage Normal (show e)+ Right typ -> do+ var <- treeStoreGetValue treeStore path+ treeStoreSetValue treeStore path var{varType = typ} printVariable :: VarDescription -> TreePath -> TreeStore VarDescription -> IDEAction printVariable varDescr path treeStore = packageTry_ $ tryDebug_ $ do- debugCommand' (":print " ++ (varName varDescr)) (\to -> liftIO $ postGUIAsync (do- case parse valueParser "" (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)) (\to -> liftIO $ postGUIAsync (do- case parse typeParser "" (selectString to) of- Left e -> sysMessage Normal (show e)- Right typ -> do- var <- treeStoreGetValue treeStore path- treeStoreSetValue treeStore path var{varType = typ}))+ debugCommand' (":print " ++ (varName varDescr)) $ do+ to <- EL.consume+ liftIO $ postGUIAsync $ do+ case parse valueParser "" (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+ to <- EL.consume+ liftIO $ postGUIAsync $ do+ case parse typeParser "" (selectString to) of+ Left e -> sysMessage Normal (show e)+ Right typ -> do+ var <- treeStoreGetValue treeStore path+ treeStoreSetValue treeStore path var{varType = typ}
src/IDE/Pane/Workspace.hs view
@@ -1,4 +1,5 @@-{-# OPTIONS_GHC -XScopedTypeVariables -XTypeSynonymInstances -XMultiParamTypeClasses -XDeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances, ScopedTypeVariables, TypeSynonymInstances,+ MultiParamTypeClasses, DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Workspace@@ -24,13 +25,14 @@ import Graphics.UI.Gtk hiding (get) import Graphics.UI.Gtk.Gdk.Events import Data.Maybe-import Control.Monad.Reader import Data.Typeable import IDE.Core.State import IDE.Workspaces import qualified Data.Map as Map (empty) import Data.List (sortBy)-+import IDE.Pane.Files (refreshFiles)+import Control.Monad (when)+import Control.Monad.IO.Class (MonadIO(..)) -- | Workspace pane state --@@ -206,4 +208,5 @@ let sorted = sortBy (\ (_,f) (_,s) -> compare (ipdPackageId f) (ipdPackageId s)) objs liftIO $ mapM_ (listStoreAppend (workspaceStore p)) sorted when showPane $ displayPane p False+ refreshFiles
src/IDE/PaneGroups.hs view
@@ -35,7 +35,6 @@ import Control.Monad (when, liftM) import IDE.Core.Types (frameState) import Graphics.UI.Editor.Parameters (Direction(..))-import Control.Monad.Trans (liftIO) import Graphics.UI.Gtk (widgetSetSensitive, notebookSetShowTabs, notebookSetTabPos) import Graphics.UI.Gtk.General.Enums (PositionType(..))@@ -47,6 +46,7 @@ import IDE.Pane.Variables (IDEVariables(..)) import IDE.Pane.Trace (IDETrace(..)) import IDE.Pane.Workspace (IDEWorkspace(..))+import Control.Monad.IO.Class (MonadIO(..)) showBrowser :: IDEAction showBrowser = do
src/IDE/Session.hs view
@@ -14,7 +14,6 @@ -- --------------------------------------------------------------------------------- - module IDE.Session ( saveSession , saveSessionAs@@ -26,7 +25,6 @@ ) where import Graphics.UI.Gtk hiding (showLayout)-import Control.Monad.Reader import System.FilePath import qualified Data.Map as Map import Data.Maybe@@ -48,6 +46,7 @@ import IDE.Pane.PackageFlags import IDE.Pane.Search import IDE.Pane.Grep+import IDE.Pane.Files import IDE.Pane.Breakpoints import IDE.Pane.Trace import IDE.Pane.Variables@@ -59,6 +58,8 @@ import IDE.Pane.Workspace (WorkspaceState(..)) import IDE.Workspaces (workspaceOpenThis) import IDE.Completion (setCompletionSize)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (forM_, forM, when) -- ---------------------------------------------------------------------@@ -78,6 +79,7 @@ | PrefsSt PrefsState | FlagsSt FlagsState | SearchSt SearchState+ | FilesSt FilesState | GrepSt GrepState | BreakpointsSt BreakpointsState | TraceSt TraceState@@ -94,6 +96,7 @@ asPaneState s | isJust ((cast s) :: Maybe PrefsState) = PrefsSt (fromJust $ cast s) asPaneState s | isJust ((cast s) :: Maybe FlagsState) = FlagsSt (fromJust $ cast s) asPaneState s | isJust ((cast s) :: Maybe SearchState) = SearchSt (fromJust $ cast s)+asPaneState s | isJust ((cast s) :: Maybe FilesState) = FilesSt (fromJust $ cast s) asPaneState s | isJust ((cast s) :: Maybe GrepState) = GrepSt (fromJust $ cast s) asPaneState s | isJust ((cast s) :: Maybe BreakpointsState) = BreakpointsSt (fromJust $ cast s) asPaneState s | isJust ((cast s) :: Maybe TraceState) = TraceSt (fromJust $ cast s)@@ -110,6 +113,7 @@ recover pp (PrefsSt p) = recoverState pp p >> return () recover pp (FlagsSt p) = recoverState pp p >> return () recover pp (SearchSt p) = recoverState pp p >> return ()+recover pp (FilesSt p) = recoverState pp p >> return () recover pp (GrepSt p) = recoverState pp p >> return () recover pp (BreakpointsSt p) = recoverState pp p >> return () recover pp (TraceSt p) = recoverState pp p >> return ()
src/IDE/SourceCandy.hs view
@@ -48,8 +48,8 @@ '^','|','-','~','\'','"'] notAfterOp = notBeforeOp -keystrokeCandy :: CandyTable -> Maybe Char -> EditorBuffer -> IDEM ()-keystrokeCandy (CT(transformTable,_)) mbc ebuf = do+keystrokeCandy :: CandyTable -> Maybe Char -> EditorBuffer -> (String -> Bool) -> IDEM ()+keystrokeCandy (CT(transformTable,_)) mbc ebuf editInCommentOrString = do cursorMark <- getInsertMark ebuf endIter <- getIterAtMark ebuf cursorMark lineNr <- getLine endIter@@ -61,7 +61,7 @@ Just c -> return (Just c) Nothing -> do getChar endIter- block <- isInCommentOrString lineNr columnNr slice+ let block = editInCommentOrString slice unless block $ replace mbc2 cursorMark slice offset transformTable where@@ -91,17 +91,17 @@ endNotUndoableAction ebuf else replace mbAfterChar cursorMark match offset rest -transformToCandy :: CandyTable -> EditorBuffer -> IDEM ()-transformToCandy (CT(transformTable,_)) ebuf = do+transformToCandy :: CandyTable -> EditorBuffer -> (String -> Bool) -> IDEM ()+transformToCandy (CT(transformTable,_)) ebuf editInCommentOrString = do beginUserAction ebuf modified <- getModified ebuf- mapM_ (\tbl -> replaceTo ebuf tbl 0) transformTable+ mapM_ (\tbl -> replaceTo ebuf tbl 0 editInCommentOrString) transformTable setModified ebuf modified endUserAction ebuf -replaceTo :: EditorBuffer -> (Bool,String,String) -> Int -> IDEM ()-replaceTo buf (isOp,from,to) offset = replaceTo' offset+replaceTo :: EditorBuffer -> (Bool,String,String) -> Int -> (String -> Bool) -> IDEM ()+replaceTo buf (isOp,from,to) offset editInCommentOrString = replaceTo' offset where replaceTo' offset = do iter <- getIterAtOffset buf offset@@ -114,7 +114,7 @@ columnNr <- getLineOffset end startIter <- backwardToLineStartC end slice <- getSlice buf startIter end True- block <- isInCommentOrString lineNr columnNr slice+ let block = editInCommentOrString slice unless block $ do beforeOk <- if stOff == 0@@ -182,7 +182,7 @@ stringToCandy :: CandyTable -> String -> IDEM String stringToCandy candyTable text = do workBuffer <- simpleGtkBuffer text- transformToCandy candyTable workBuffer+ transformToCandy candyTable workBuffer (\ _ -> False) i1 <- getStartIter workBuffer i2 <- getEndIter workBuffer text2 <- getText workBuffer i1 i2 True@@ -210,7 +210,7 @@ transformFromCandy candyTable workBuffer i3 <- getIterAtOffset workBuffer column mark <- createMark workBuffer i3 True- transformToCandy candyTable workBuffer+ transformToCandy candyTable workBuffer (\ _ -> False) i4 <- getIterAtMark workBuffer mark columnNew <- getLineOffset i4 return (line,columnNew)@@ -280,7 +280,7 @@ parseCandy fn = do res <- parseFromFile candyParser fn case res of- Left pe -> throwIDE $"Error reading keymap file " ++ show fn ++ " " ++ show pe+ Left pe -> throwIDE $"Error reading candy file " ++ show fn ++ " " ++ show pe Right r -> return (CT(forthFromTable r, backFromTable r)) candyParser :: CharParser () CandyTableI@@ -313,15 +313,4 @@ hd <- lexeme hexadecimal return (chr (fromIntegral hd)) --- TODO Literal Haskell-isInCommentOrString :: Int -> Int -> String -> IDEM Bool-isInCommentOrString line column preLine =- if isInfixOf "--" preLine- then return True- else let indices = elemIndices '"' preLine- in if length indices == 0- then return False- else if even (length indices) -- TODO Handle \"- then return False- else return True
src/IDE/Statusbar.hs view
@@ -22,7 +22,6 @@ PaneMonad(..), IDEAction(..), StatusbarCompartment(..))-import Control.Monad.Trans (liftIO) import Graphics.UI.Gtk (windowSetTitle, castToStatusbar,@@ -47,6 +46,7 @@ ) import Graphics.UI.Frame.Panes (IDEPane(..), paneName) import Text.Printf (printf)+import Control.Monad.IO.Class (MonadIO(..)) changeStatusbar :: [StatusbarCompartment] -> IDEAction
@@ -0,0 +1,334 @@+-----------------------------------------------------------------------------+--+-- Module : IDE.SymbolNavigation+-- Copyright : (c) Sanny Sannof, Juergen Nicklisch-Franken+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | The source editor part of Leksah+--+-----------------------------------------------------------------------------------++module IDE.SymbolNavigation (+ createHyperLinkSupport,+ mapControlCommand+) where++import Data.List+import Data.Ord+import Data.Maybe+import Data.Monoid+import Data.IORef+import IDE.Core.Types+import IDE.Core.CTypes+import IDE.Core.State+import IDE.Metainfo.Provider+import IDE.Utils.GUIUtils+import qualified Graphics.UI.Gtk.Gdk.Events as Gdk+import Graphics.UI.Gtk.Gdk.Cursor+import Graphics.UI.Gtk+import Graphics.UI.Frame.ViewFrame+import qualified Data.Set as Set+import Control.Applicative+import Distribution.ModuleName+import qualified Data.Text as T+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS+import qualified Graphics.UI.Gtk.Multiline.TextBuffer+import Graphics.UI.Gtk.SourceView.SourceGutter+import Graphics.UI.Gtk.SourceView+import qualified Graphics.UI.Gtk.Multiline.TextView+import qualified Graphics.UI.Gtk.Scrolling.ScrolledWindow+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad (when)+import Control.Monad.Trans.Reader (ask)++data Locality = LocalityPackage | LocalityWorkspace | LocalitySystem -- in which category symbol is located+ deriving (Ord,Eq,Show)++createHyperLinkSupport ::+ SourceView -> -- ^ source buffer view+ ScrolledWindow -> -- ^ container window+ (Bool -> Bool -> TextIter -> IO (TextIter, TextIter)) -> -- ^ identifiermapper (bools=control,shift)+ (Bool -> Bool -> String -> IO ()) -> -- ^ click handler+ IO [Connection]+createHyperLinkSupport sv sw identifierMapper clickHandler = do+ let tv = castToTextView sv+ tvb <- castToTextBuffer <$> get tv textViewBuffer :: IO TextBuffer+ let myAttr = textBufferTagTable :: ReadWriteAttr TextBuffer TextTagTable TextTagTable+ ttt <- castToTextTagTable <$> (get tvb myAttr) :: IO TextTagTable+ -- textBuffer+ noUnderline <- textTagNew Nothing+ set noUnderline [ textTagUnderline := UnderlineNone, textTagUnderlineSet := True ]+ underline <- textTagNew Nothing+ set underline [ textTagUnderline := UnderlineSingle, textTagUnderlineSet := True ]+ textTagTableAdd ttt noUnderline+ textTagTableAdd ttt underline+ cursor <- cursorNew Hand2+ cursorDef <- cursorNew Arrow++ id1 <- sw `onLeaveNotify` \e -> do+ pointerUngrab (Gdk.eventTime e)+ return True++ let moveOrClick e click = do+ sx <- scrolledWindowGetHAdjustment sw >>= adjustmentGetValue+ sy <- scrolledWindowGetVAdjustment sw >>= adjustmentGetValue++ let ex = Gdk.eventX e + sx+ ey = Gdk.eventY e + sy+ mods = Gdk.eventModifier e+ ctrlPressed = (mapControlCommand Gdk.Control) `elem` mods+ shiftPressed = Gdk.Shift `elem` mods+ iter <- textViewGetIterAtLocation tv (round ex) (round ey)+ (szx, szy) <- widgetGetSize sw+ if Gdk.eventX e < 0 || Gdk.eventY e < 0+ || round(Gdk.eventX e) > szx || round(Gdk.eventY e) > szy then do+ pointerUngrab (Gdk.eventTime e)+ return True+ else do+ (beg, en) <- identifierMapper ctrlPressed shiftPressed iter+ slice <- liftIO $ textBufferGetSlice tvb beg en True+ startIter <- textBufferGetStartIter tvb+ endIter <- textBufferGetEndIter tvb+ textBufferRemoveTag tvb underline startIter endIter+ offs <- textIterGetLineOffset beg+ offsc <- textIterGetLineOffset iter+ if (length slice > 1) then do+ if (click) then do+ pointerUngrab (Gdk.eventTime e)+ clickHandler ctrlPressed shiftPressed slice+ else do+ textBufferApplyTag tvb underline beg en+ Just screen <- screenGetDefault+ dw <- widgetGetDrawWindow tv+ pointerGrab dw False [PointerMotionMask,ButtonPressMask,LeaveNotifyMask] (Nothing :: Maybe DrawWindow) (Just cursor) (Gdk.eventTime e)+ return ()+ return ()+ else do+ pointerUngrab (Gdk.eventTime e)+ return ()+ return True;+ lineNumberBugFix <- newIORef Nothing+ let fixBugWithX e = do+ dw <- widgetGetDrawWindow tv+ ptr <- drawWindowGetPointer dw+ let hasNoControlModifier e = not $ (mapControlCommand Gdk.Control) `elem` (Gdk.eventModifier e)+ let+ eventIsHintSafe (e@Gdk.Motion {}) = Gdk.eventIsHint e+ eventIsHintSafe _ = False+ case ptr of+ Just (_, ptrx, _, _) -> do+ lnbf <- readIORef lineNumberBugFix+ -- print ("ishint?, adjusted, event.x, ptr.x, adjustment,hasControl?",eventIsHintSafe e,ptrx - fromMaybe (-1000) lnbf , Gdk.eventX e, ptrx, lnbf, hasNoControlModifier e)+ when (eventIsHintSafe e && hasNoControlModifier e) $ do+ -- get difference between event X and pointer x+ -- event X is in coordinates of sourceView text+ -- pointer X is in coordinates of window (remember "show line numbers" ?)+ writeIORef lineNumberBugFix $ Just (ptrx - round (Gdk.eventX e)) -- captured difference+ -- When control key is pressed, mostly NON-HINT events come,+ -- GTK gives (mistakenly?) X in window coordinates in such cases+ let nx = if (isJust lnbf && not (eventIsHintSafe e))+ then fromIntegral $ ptrx - fromJust lnbf -- translate X back+ else Gdk.eventX e+ return $ e { Gdk.eventX = nx}+ _ -> return e+ id2 <- onMotionNotify sw True $ \e -> do+ ne <- fixBugWithX e+ moveOrClick ne False+ return True+ id3 <- onButtonPress sw $ \e -> do+-- print ("button press")+ ne <- fixBugWithX e+-- print ("click adjustment: old, new", Gdk.eventX e, Gdk.eventX ne)+ moveOrClick ne True++ return $ map ConnectC [id1,id2,id3]++{--+launchSymbolNavigationDialog_ :: String -> (Descr -> IDEM ()) -> IDEM ()+launchSymbolNavigationDialog_ txt act = do+ dia <- liftIO $ dialogNew+ win <- getMainWindow+ ideR <- ask+ wi <- getSystemInfo+ wiW <- getWorkspaceInfo+ wiP <- getPackageInfo+ case (wi,wiW,wiP) of+ (Just (GenScopeC (PackScope _ syms)),+ Just (GenScopeC (PackScope _ symsW), GenScopeC (PackScope _ _ )),+ Just (GenScopeC (PackScope _ symsP), GenScopeC (PackScope _ _ ))) -> do+ let symbolsT = map T.pack $ Set.toList $ (symbols syms `Set.union` symbols symsP)+ liftIO $ do+ print "============================"+ print $ symLookup "launchAutoCompleteDialog" symsP+ windowSetTransientFor dia win+ windowSetTitle dia "Go to Symbol"+ upper <- dialogGetUpper dia+ lower <- dialogGetActionArea dia+ vb <- vBoxNew False 0+ boxPackStart upper vb PackNatural 7+ en <- entryNew+ store <- listStoreNew []+ tv <- treeViewNewWithModel store+ treeViewSetFixedHeightMode tv True+ treeViewSetHoverExpand tv True+ mapM_ (\(i,s) -> do+ col <- treeViewColumnNew+ renderer <- cellRendererTextNew+ treeViewColumnSetSizing col TreeViewColumnFixed+ treeViewColumnSetResizable col True+ treeViewColumnSetFixedWidth col ([200,300,200] !! i)+ treeViewAppendColumn tv col+ cellLayoutPackStart col renderer True++ cellLayoutSetAttributes col renderer store+ $ \(locality, _, ss) -> [cellText := replaceCR $ ss !! i] +++ case (i, locality) of+ (2, _) -> [cellTextScale := 0.8, cellTextScaleSet := True]+ (0, LocalityWorkspace) ->+ [cellTextStyle := StyleItalic, cellTextStyleSet := True, cellTextWeightSet := False, cellTextScaleSet := False]+ (0, LocalityPackage) ->+ [cellTextWeight := 1000, cellTextWeightSet := True, cellTextStyleSet := False, cellTextScaleSet := False]+ _ -> [cellTextStyleSet := False, cellTextWeightSet := False, cellTextScaleSet := False]++ treeViewColumnSetTitle col s) $ zip [0..] ["symbol","module","type/kind"]++ boxPackEnd vb tv PackNatural 7+ boxPackEnd vb en PackNatural 0+ widgetSetSizeRequest tv 900 600++ bb <- hButtonBoxNew+ closeB <- buttonNewFromStock "gtk-cancel"+ okB <- buttonNewFromStock "gtk-ok"+ okB `onClicked` do+ dialogResponse dia ResponseOk+ widgetHideAll dia+ closeB `onClicked` do+ dialogResponse dia ResponseCancel+ widgetHideAll dia+ boxPackEnd bb closeB PackNatural 0+ boxPackEnd bb okB PackNatural 0+ boxPackStart lower bb PackNatural 7+ set okB [widgetCanDefault := True]+ buttonSetLabel okB "Goto"+ widgetGrabDefault okB+ widgetShowAll dia+ entrySetText en txt+ let getSymbolLocality symbolName = case (symLookup symbolName symsP, symLookup symbolName symsW) of+ ((_:_),_) -> LocalityPackage+ (_,(_:_)) -> LocalityWorkspace+ _ -> LocalitySystem+ let+ compareLocalityThenLength (Real d1 ) (Real d2) =+ let+ desc1 = dscName' d1+ desc2 = dscName' d2+ l1 = getSymbolLocality $ desc1+ l2 = getSymbolLocality $ desc2+ lcomp = compare l1 l2+ in if lcomp == EQ+ then compare (length desc1) (length desc2)+ else lcomp+ compareLocalityThenLength _ _ = error "compareLocalityThenLength: not real desciptions"+ let updateList = do+ txt <- T.pack <$> entryGetText en+ let ttxt = T.toLower txt+ let symz_ = take 50+ $ sortBy (comparing getSymbolLocality)+ $ map (T.unpack)+ $ filter (matchCamelCase (txt :: T.Text) (ttxt:: T.Text)) (symbolsT ::[T.Text])+ let symz = sortBy compareLocalityThenLength+ $ filter (not . isReexported)+ $ concatMap (\sym -> symLookup sym syms `mappend` symLookup sym symsP) symz_+ listStoreClear store+ mapM (\descr_ -> do+ case descr_ of+ Real descr -> do+ let modn = case dscMbModu' descr of+ Just mn -> intercalate"." $ components $ modu mn+ Nothing -> "?"+ let symbolName = dscName' descr+ let typeDesc = map BS.w2c $ BS.unpack $ fromMaybe BS.empty $ dscMbTypeStr' descr+ listStoreAppend store (getSymbolLocality symbolName, descr_, [symbolName,modn,take 80 typeDesc])+-- treeVie+ return ()+ _ -> return ()+ ) symz+ when (length symz > 0) $ do+ treeViewSetCursor tv [0] Nothing+ return ()+ print ("symz found: ",length symz)+ return ()+ let gotoSelectedSymbol = do+ cursor <- treeViewGetCursor tv+ case cursor of+ ([pos],_) -> do+ (_,descr,_) <- listStoreGetValue store pos+ dialogResponse dia ResponseCancel+ widgetHideAll dia+ liftIO $ reflectIDE (act descr) ideR+ return ()+ _ -> return ()++ updateList+ let modifyTreeViewCursor :: (Int -> Int) -> IO ()+ modifyTreeViewCursor op = do+ cur <- treeViewGetCursor tv+ case cur of+ ([pos],_) -> do+ let npos = op pos+ storeSize <- listStoreGetSize store+ let npos' = if npos < 0 then 0 else if npos >= storeSize then storeSize-1 else npos+ when (npos < storeSize) $ do+ treeViewSetCursor tv [npos'] Nothing+ return ()+ _ -> return ()+ onEditableChanged en $ do+ updateList+ return ()+ en `onKeyPress` \e -> do+ case Gdk.eventKeyName e of+ "Escape" -> do+ dialogResponse dia ResponseCancel+ widgetHideAll dia+ return True+ "Up" -> do+ modifyTreeViewCursor (\x -> x-1)+ return True+ "Down" -> do+ modifyTreeViewCursor (\x -> x+1)+ return True+ "Return" -> do+ gotoSelectedSymbol+ return True+ nm -> do+ print nm+ return False+ resp <- dialogRun dia+ return ()+ _ -> return ()+ return ()+++-- this will be camel case one day+matchCamelCase :: T.Text -> T.Text -> T.Text -> Bool+matchCamelCase search lsearch item =+ search `T.isInfixOf` item || (lsearch `T.isInfixOf` (T.toLower item))++compareLength :: [a] -> [a] -> Ordering+compareLength s1 s2 = compare (length s1) (length s2)++compareLocality :: Locality -> Locality -> Ordering+compareLocality s1 s2 = compare s1 s2++replaceCR [] = []+replaceCR ('\n':ss) = ' ':(replaceCR ss)+replaceCR ('\r':ss) = ' ':(replaceCR ss)+replaceCR (s:ss) = s:(replaceCR ss)++--}+
src/IDE/TextEditor.hs view
@@ -40,6 +40,7 @@ , endUserAction , getEndIter , getInsertMark+, getInsertIter , getIterAtLine , getIterAtMark , getIterAtOffset@@ -129,20 +130,33 @@ , onKeyPress , onKeyRelease , onLookupInfo+, onMotionNotify+, onLeaveNotify , onPopulatePopup ) where import Prelude hiding(getChar, getLine) import Data.Char (isAlphaNum, isSymbol)-import Data.Maybe (fromJust)+import Data.Maybe (fromJust, maybeToList)+import Data.IORef import Control.Monad (when)-import Control.Monad.Reader (liftIO, ask) import Control.Applicative ((<$>)) import qualified Graphics.UI.Gtk as Gtk hiding(afterToggleOverwrite) import qualified Graphics.UI.Gtk.SourceView as Gtk+import Graphics.UI.Gtk.Multiline.TextTagTable+import qualified Graphics.UI.Gtk.Multiline.TextBuffer as Gtk+import qualified Graphics.UI.Gtk.Multiline.TextView as Gtk+import qualified Graphics.UI.Gtk.Scrolling.ScrolledWindow+import Graphics.UI.Gtk.Multiline.TextTag+import Graphics.UI.Gtk.Gdk.Cursor+--import Graphics.Rendering.Pango+import System.Glib.Attributes+import System.Glib.MainLoop+import qualified Graphics.UI.Gtk.Multiline.TextView as Gtk import qualified Graphics.UI.Gtk.Gdk.Events as GtkOld import System.Glib.Attributes (AttrOp(..))+import System.GIO.File.ContentType (contentTypeGuess) #ifdef LEKSAH_WITH_YI import qualified Yi as Yi hiding(withBuffer)@@ -154,8 +168,11 @@ import IDE.Core.State import IDE.Utils.GUIUtils(controlIsPressed)--+import Paths_leksah (getDataDir)+import System.FilePath ((</>))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (ask)+import qualified Control.Monad.Reader as Gtk (liftIO) -- Data types data EditorBuffer = GtkEditorBuffer Gtk.SourceBuffer@@ -188,6 +205,7 @@ | YiEditorTag #endif + #ifdef LEKSAH_WITH_YI withYiBuffer' :: Yi.BufferRef -> Yi.BufferM a -> IDEM a withYiBuffer' b f = liftYi $ Yi.liftEditor $ Yi.withGivenBuffer0 b f@@ -211,9 +229,17 @@ -- Buffer newGtkBuffer :: Maybe FilePath -> String -> IDEM EditorBuffer newGtkBuffer mbFilename contents = liftIO $ do- lm <- Gtk.sourceLanguageManagerNew- mbLang <- case mbFilename of- Just filename -> Gtk.sourceLanguageManagerGuessLanguage lm (Just filename) Nothing+ lm <- Gtk.sourceLanguageManagerNew+ dataDir <- getDataDir+ oldPath <- Gtk.sourceLanguageManagerGetSearchPath lm+ Gtk.sourceLanguageManagerSetSearchPath lm (Just $ (dataDir </> "language-specs") : oldPath)+ mbLang <- case mbFilename of+ Just filename -> do+ guess <- contentTypeGuess filename contents (length contents)+ Gtk.sourceLanguageManagerGuessLanguage lm (Just filename) $+ case guess of+ (True, _) -> Nothing+ (False, t) -> Just t Nothing -> Gtk.sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell") buffer <- case mbLang of Just sLang -> Gtk.sourceBufferNewWithLanguage sLang@@ -395,6 +421,18 @@ mkYiIter b (Yi.regionEnd region)) #endif +getInsertIter :: EditorBuffer -> IDEM EditorIter+getInsertIter (GtkEditorBuffer sb) = liftIO $ do+ insertMark <- Gtk.textBufferGetInsert sb+ insertIter <- Gtk.textBufferGetIterAtMark sb insertMark+ return (GtkEditorIter insertIter)+#ifdef LEKSAH_WITH_YI+getInsertIter (YiEditorBuffer b) = withYiBuffer b $ do+ insertMark <- Yi.insMark <$> Yi.askMarks+ mkYiIter b <$> Yi.getMarkPointB insertMark+#endif++ getSlice :: EditorBuffer -> EditorIter -> EditorIter@@ -1074,22 +1112,34 @@ ideR <- ask (GtkEditorBuffer sb) <- getBuffer (GtkEditorView sv) liftIO $ do+ -- when multiple afterBufferInsertText are called quickly,+ -- we cancel previous idle action which was not processed,+ -- its handler is stored here.+ -- Paste operation is example of such sequential events (each word!).+ lastHandler <- newIORef Nothing id1 <- sb `Gtk.afterBufferInsertText` \iter text -> do- let isIdent a = isAlphaNum a || a == '\'' || a == '_' || a == '.'- let isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-'- || a == '!' || a == '@' || a == '%' || a == '&' || a == '?'- if (all isIdent text) || (all isOp text)- then do- hasSel <- Gtk.textBufferHasSelection sb- if not hasSel+ mapM_ idleRemove =<< maybeToList <$> readIORef lastHandler+ writeIORef lastHandler =<< Just <$> do+ (flip idleAdd) priorityDefault $ do+ let isIdent a = isAlphaNum a || a == '\'' || a == '_' || a == '.'+ let isOp a = isSymbol a || a == ':' || a == '\\' || a == '*' || a == '/' || a == '-'+ || a == '!' || a == '@' || a == '%' || a == '&' || a == '?'+ if (all isIdent text) || (all isOp text) then do- (iterC, _) <- Gtk.textBufferGetSelectionBounds sb- atC <- Gtk.textIterEqual iter iterC- when atC $ reflectIDE start ideR- else+ hasSel <- Gtk.textBufferHasSelection sb+ if not hasSel+ then do+ (iterC, _) <- Gtk.textBufferGetSelectionBounds sb+ atC <- Gtk.textIterEqual iter iterC+ when atC $ reflectIDE start ideR+ return False+ else do+ reflectIDE cancel ideR+ return False+ else do reflectIDE cancel ideR- else- reflectIDE cancel ideR+ return False+ return () #if MIN_VERSION_gtk(0,10,5) id2 <- sv `Gtk.on` Gtk.moveCursor $ \_ _ _ -> reflectIDE cancel ideR #else@@ -1112,7 +1162,7 @@ name <- Gtk.eventKeyName modifier <- Gtk.eventModifier keyVal <- Gtk.eventKeyVal- liftIO $ reflectIDE (f name modifier keyVal) ideR+ Gtk.liftIO $ reflectIDE (f name modifier keyVal) ideR return [ConnectC id1] #ifdef LEKSAH_WITH_YI onKeyPress (YiEditorView v) f = do@@ -1126,6 +1176,47 @@ return [ConnectC id1] #endif +onMotionNotify :: EditorView+ -> (Double -> Double -> [Gtk.Modifier] -> IDEM Bool)+ -> IDEM [Connection]+onMotionNotify (GtkEditorView sv) f = do+ ideR <- ask+ liftIO $ do+ id1 <- sv `Gtk.on` Gtk.motionNotifyEvent $ do+ (ex,ey) <- Gtk.eventCoordinates+ modifier <- Gtk.eventModifier+ Gtk.liftIO $ reflectIDE (f ex ey modifier) ideR+ return [ConnectC id1]+#ifdef LEKSAH_WITH_YI+onMotionNotify (YiEditorView v) f = do+ ideR <- ask+ liftIO $ do+ id1 <- (Yi.drawArea v) `Gtk.on` Gtk.motionNotifyEvent $ do+ (ex,ey) <- Gtk.eventCoordinates+ modifier <- Gtk.eventModifier+ liftIO $ reflectIDE (f ex ey modifier) ideR+ return [ConnectC id1]+#endif++onLeaveNotify :: EditorView+ -> (IDEM Bool)+ -> IDEM [Connection]+onLeaveNotify (GtkEditorView sv) f = do+ ideR <- ask+ liftIO $ do+ id1 <- sv `Gtk.on` Gtk.leaveNotifyEvent $ do+ Gtk.liftIO $ reflectIDE (f) ideR+ return [ConnectC id1]+#ifdef LEKSAH_WITH_YI+onLeaveNotify (YiEditorView v) f = do+ ideR <- ask+ liftIO $ do+ id1 <- (Yi.drawArea v) `Gtk.on` Gtk.leaveNotifyEvent $ do+ liftIO $ reflectIDE (f) ideR+ return [ConnectC id1]+#endif++ onKeyRelease :: EditorView -> (String -> [Gtk.Modifier] -> Gtk.KeyVal -> IDEM Bool) -> IDEM [Connection]@@ -1136,7 +1227,7 @@ name <- Gtk.eventKeyName modifier <- Gtk.eventModifier keyVal <- Gtk.eventKeyVal- liftIO $ reflectIDE (f name modifier keyVal) ideR+ Gtk.liftIO $ reflectIDE (f name modifier keyVal) ideR return [ConnectC id1] #ifdef LEKSAH_WITH_YI onKeyRelease (YiEditorView v) f = do@@ -1186,6 +1277,5 @@ Gtk.menuPopup menu Nothing return [ConnectC id1] #endif-
src/IDE/Utils/GUIUtils.hs view
@@ -23,6 +23,8 @@ , getBackgroundBuildToggled , setBackgroundBuildToggled+, getRunUnitTests+, setRunUnitTests , getMakeModeToggled , setMakeModeToggled , getDebugToggled@@ -33,13 +35,14 @@ , controlIsPressed , stockIdFromType+, mapControlCommand+ ) where import Graphics.UI.Gtk-import IDE.System.Process+import IDE.Utils.Tool (runProcess) import Data.Maybe (fromJust, isJust) import Control.Monad-import Control.Monad.Trans(MonadIO,liftIO) import IDE.Core.State --import Graphics.UI.Gtk.Selectors.FileChooser -- (FileChooserAction(..))@@ -51,6 +54,7 @@ #else import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) #endif+import Control.Monad.IO.Class (liftIO) chooseDir :: Window -> String -> Maybe FilePath -> IO (Maybe FilePath) chooseDir window prompt mbFolder = do@@ -170,6 +174,16 @@ ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundBuild" castToToggleAction liftIO $ toggleActionSetActive ui b +getRunUnitTests :: PaneMonad alpha => alpha (Bool)+getRunUnitTests = do+ ui <- getUIAction "ui/toolbar/BuildToolItems/RunUnitTests" castToToggleAction+ liftIO $ toggleActionGetActive ui++setRunUnitTests :: PaneMonad alpha => Bool -> alpha ()+setRunUnitTests b = do+ ui <- getUIAction "ui/toolbar/BuildToolItems/RunUnitTests" castToToggleAction+ liftIO $ toggleActionSetActive ui b+ getMakeModeToggled :: PaneMonad alpha => alpha (Bool) getMakeModeToggled = do ui <- getUIAction "ui/toolbar/BuildToolItems/MakeMode" castToToggleAction@@ -211,6 +225,12 @@ stockIdFromType Field = "ide_slot" stockIdFromType Method = "ide_method" stockIdFromType _ = "ide_other"++-- maps control key for Macos+#if defined(darwin_HOST_OS)+mapControlCommand Alt = Control+#endif+mapControlCommand a = a
src/IDE/Utils/ServerConnection.hs view
@@ -20,15 +20,16 @@ import IDE.Core.State import Network (connectTo,PortID(..)) import Network.Socket (PortNumber(..))-import IDE.System.Process(runProcess)+import IDE.Utils.Tool (runProcess) import GHC.Conc(threadDelay)-import Control.Monad.Trans(liftIO) import System.IO import Control.Exception (SomeException(..), catch) import Prelude hiding(catch) import Control.Concurrent(forkIO) import Graphics.UI.Gtk(postGUIAsync) import Control.Event(triggerEvent)+import Control.Monad.IO.Class (MonadIO(..))+import System.Log.Logger (getLevel, getRootLogger) doServerCommand :: ServerCommand -> (ServerAnswer -> IDEM alpha) -> IDEAction doServerCommand command cont = do@@ -69,7 +70,12 @@ startServer :: Int -> IO () startServer port = do- runProcess "leksah-server" ["--server=" ++ show port, "+RTS", "-N2", "-RTS"]+ logger <- getRootLogger+ let verbosity = case getLevel logger of+ Just level -> ["--verbosity=" ++ show level]+ Nothing -> []+ runProcess "leksah-server"+ (["--server=" ++ show port, "+RTS", "-N2", "-RTS"] ++ verbosity) Nothing Nothing Nothing Nothing Nothing return ()
src/IDE/Workspaces.hs view
@@ -27,8 +27,12 @@ , workspaceAddPackage' , workspaceRemovePackage , workspacePackageNew+, workspaceTryQuiet+, workspaceNewHere , packageTry , packageTry_+, packageTryQuiet+, packageTryQuiet_ , backgroundMake , makePackage@@ -36,11 +40,9 @@ ) where import IDE.Core.State-import Control.Monad.Trans (liftIO) import Graphics.UI.Editor.Parameters (Parameter(..), (<<<-), paraName, emptyParams)-import Control.Monad (unless, when, liftM)-import Control.Monad.Reader (lift)+import Control.Monad (forM_, unless, when, liftM) import Data.Maybe (isJust,fromJust ) import IDE.Utils.GUIUtils (chooseFile, chooseSaveFile)@@ -77,7 +79,6 @@ import Graphics.UI.Gtk.General.Structs (ResponseId(..)) #endif import Control.Exception (SomeException(..))-import Control.Monad.Reader.Class (ask) import qualified Data.Map as Map (empty) import IDE.Pane.SourceBuffer (fileOpenThis, fileCheckAll, belongsToPackage) import qualified System.IO.UTF8 as UTF8 (writeFile)@@ -86,7 +87,11 @@ import Control.Applicative ((<$>)) import IDE.Build import IDE.Utils.FileUtils(myCanonicalizePath)-+import Control.Monad.Trans.Reader (ask)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Class (lift)+import qualified Data.Set as Set (toList)+import Distribution.PackageDescription (hsSourceDirs) setWorkspace :: Maybe Workspace -> IDEAction setWorkspace mbWs = do@@ -289,24 +294,20 @@ constructAndOpenMainModule :: Maybe IDEPackage -> IDEAction constructAndOpenMainModule Nothing = return () constructAndOpenMainModule (Just idePackage) =- case (ipdMain idePackage, ipdSrcDirs idePackage) of- ([target],[path]) -> do- mbPD <- getPackageDescriptionAndPath- case mbPD of- Just (pd,_) -> do- liftIO $ createDirectoryIfMissing True path- alreadyExists <- liftIO $ doesFileExist (path </> target)- if alreadyExists- then do- ideMessage Normal "Main file already exists"- fileOpenThis (path </> target)- else do- template <- liftIO $ getModuleTemplate pd (dropExtension target)- " main" "main = putStrLn \"Hello World!\""+ forM_ (ipdMain idePackage) $ \(target, bi, isTest) -> do+ mbPD <- getPackageDescriptionAndPath+ case mbPD of+ Just (pd,_) -> do+ case hsSourceDirs bi of+ path:_ -> do+ liftIO $ createDirectoryIfMissing True path+ alreadyExists <- liftIO $ doesFileExist (path </> target)+ unless alreadyExists $ do+ template <- liftIO $ getModuleTemplate "main" pd "Main" "" "" liftIO $ UTF8.writeFile (path </> target) template fileOpenThis (path </> target)- Nothing -> ideMessage Normal "No package description"- _ -> return ()+ _ -> return ()+ Nothing -> ideMessage Normal "No package description" workspaceAddPackage :: WorkspaceAction workspaceAddPackage = do@@ -517,7 +518,7 @@ settings <- lift $ do prefs' <- readIDE prefs return (defaultMakeSettings prefs')- makePackages settings (wsPackages ws) MoClean MoClean+ makePackages settings (wsPackages ws) MoClean MoClean moNoOp workspaceMake :: WorkspaceAction workspaceMake = do@@ -527,8 +528,10 @@ return ((defaultMakeSettings prefs'){ msMakeMode = True, msBackgroundBuild = False})- makePackages settings (wsPackages ws) (MoComposed [MoConfigure,MoBuild,MoInstall])- (MoComposed [MoConfigure,MoBuild,MoInstall])+ let steps = if msRunUnitTests settings+ then [MoConfigure,MoBuild,MoTest,MoCopy,MoRegister]+ else [MoConfigure,MoBuild,MoCopy,MoRegister]+ makePackages settings (wsPackages ws) (MoComposed steps) (MoComposed steps) MoMetaInfo backgroundMake :: IDEAction backgroundMake = catchIDE (do@@ -546,10 +549,14 @@ let settings = defaultMakeSettings prefs if msSingleBuildWithoutLinking settings && not (msMakeMode settings) then workspaceTryQuiet_ $- makePackages settings modifiedPacks MoBuild (MoComposed [])- else workspaceTryQuiet_ $- makePackages settings modifiedPacks (MoComposed [MoBuild,MoInstall])- (MoComposed [MoConfigure,MoBuild,MoInstall])+ makePackages settings modifiedPacks MoBuild (MoComposed []) moNoOp+ else do+ let steps = if msRunUnitTests settings+ then [MoBuild,MoTest,MoCopy,MoRegister]+ else [MoBuild,MoCopy,MoRegister]+ workspaceTryQuiet_ $+ makePackages settings modifiedPacks (MoComposed steps)+ (MoComposed (MoConfigure:steps)) MoMetaInfo ) (\(e :: SomeException) -> sysMessage Normal (show e)) @@ -566,9 +573,14 @@ Just ws -> lift $ if msSingleBuildWithoutLinking settings && not (msMakeMode settings) then runWorkspace- (makePackages settings [p] MoBuild (MoComposed [])) ws- else runWorkspace+ (makePackages settings [p] MoBuild (MoComposed []) moNoOp) ws+ else do+ let steps = if msRunUnitTests settings+ then [MoBuild,MoTest,MoCopy,MoRegister]+ else [MoBuild,MoCopy,MoRegister]+ runWorkspace (makePackages settings [p]- (MoComposed [MoBuild,MoInstall])- (MoComposed [MoConfigure,MoBuild,MoInstall])) ws+ (MoComposed steps)+ (MoComposed (MoConfigure:steps))+ MoMetaInfo) ws