diff --git a/data/leksah-welcome/Setup.lhs b/data/leksah-welcome/Setup.lhs
new file mode 100644
--- /dev/null
+++ b/data/leksah-welcome/Setup.lhs
@@ -0,0 +1,6 @@
+#!/usr/bin/runhaskell
+> module Main where
+> import Distribution.Simple
+> main :: IO ()
+> main = defaultMain
+
diff --git a/data/leksah-welcome/leksah-welcome.cabal b/data/leksah-welcome/leksah-welcome.cabal
new file mode 100644
--- /dev/null
+++ b/data/leksah-welcome/leksah-welcome.cabal
@@ -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
diff --git a/data/leksah-welcome/src/Main.hs b/data/leksah-welcome/src/Main.hs
new file mode 100644
--- /dev/null
+++ b/data/leksah-welcome/src/Main.hs
@@ -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
+
diff --git a/data/leksah.menu b/data/leksah.menu
--- a/data/leksah.menu
+++ b/data/leksah.menu
@@ -66,8 +66,8 @@
+
-
@@ -94,6 +94,7 @@
+
@@ -170,6 +171,7 @@
+
diff --git a/data/main.lksht b/data/main.lksht
new file mode 100644
--- /dev/null
+++ b/data/main.lksht
@@ -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
+
diff --git a/data/prefs.lkshp b/data/prefs.lkshp
--- a/data/prefs.lkshp
+++ b/data/prefs.lkshp
@@ -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:
diff --git a/data/prefscoll.lkshp b/data/prefscoll.lkshp
--- a/data/prefscoll.lkshp
+++ b/data/prefscoll.lkshp
@@ -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:
diff --git a/language-specs/cassius.lang b/language-specs/cassius.lang
new file mode 100644
--- /dev/null
+++ b/language-specs/cassius.lang
@@ -0,0 +1,529 @@
+
+
+
+
+
+ text/css
+ *.cassius
+ /*
+ */
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ \\([a-fA-F0-9]{1,5}[ \t]|[a-fA-F0-9]{6})
+
+
+
+ first-line
+ first-letter
+ before
+ after
+
+
+
+ first-child
+ link
+ visited
+ hover
+ active
+ focus
+ lang
+
+
+
+ ^[ \t]*@
+ charset
+ font-face
+ media
+ page
+ import
+
+
+
+ #([a-fA-F0-9]{6}|[a-fA-F0-9]{3})\b
+
+
+
+ aqua
+ black
+ blue
+ fuchsia
+ gray
+ green
+ lime
+ maroon
+ navy
+ olive
+ orange
+ purple
+ red
+ silver
+ teal
+ white
+ yellow
+
+
+
+ [a-zA-Z][a-z0-9-]+\(
+ \)
+
+
+
+
+
+
+
+ [\+-]?([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)
+
+
+
+ \b(0|[\+-]?[1-9][0-9]*)
+
+
+
+ [uU]\+[a-fA-F0-9]{1,6}(-[a-fA-F0-9]{1,6})?
+
+
+
+ \![ \t]*important
+
+
+
+ (?=\s*:)
+ azimuth
+ background-attachment
+ background-color
+ background-image
+ background-position
+ background-repeat
+ background
+ border-bottom-color
+ border-bottom-style
+ border-bottom-width
+ border-bottom
+ border-collapse
+ border-color
+ border-left-color
+ border-left-style
+ border-left-width
+ border-left
+ border-right-color
+ border-right-style
+ border-right-width
+ border-right
+ border-spacing
+ border-style
+ border-top-color
+ border-top-style
+ border-top-width
+ border-top
+ border-width
+ border
+ bottom
+ caption-side
+ clear
+ clip
+ color
+ content
+ counter-increment
+ counter-reset
+ cue-after
+ cue-before
+ cue
+ cursor
+ direction
+ display
+ elevation
+ empty-cells
+ float
+ font-family
+ font-size-adjust
+ font-size
+ font-style
+ font-variant
+ font-weight
+ font
+ height
+ left
+ letter-spacing
+ line-height
+ list-style-image
+ list-style-position
+ list-style-type
+ list-style
+ margin-bottom
+ margin-left
+ margin-right
+ margin-top
+ margin
+ marker-offset
+ marks
+ max-height
+ max-width
+ min-height
+ min-width
+ orphans
+ outline-color
+ outline-style
+ outline-width
+ outline
+ overflow
+ padding-bottom
+ padding-left
+ padding-right
+ padding-top
+ padding
+ page-break-after
+ page-break-before
+ page-break-inside
+ page
+ pause-after
+ pause-before
+ pause
+ pitch-range
+ pitch
+ play-during
+ position
+ quotes
+ richness
+ right
+ size
+ speak-header
+ speak-numerical
+ speak-punctuation
+ speak
+ speech-rate
+ stress
+ table-layout
+ text-align
+ text-decoration
+ text-indent
+ text-shadow
+ text-transform
+ top
+ unicode-bidi
+ vertical-align
+ visibility
+ voice-family
+ volume
+ white-space
+ widows
+ width
+ word-spacing
+ z-index
+
+
+
+ above
+ absolute
+ always
+ armenian
+ auto
+ avoid
+ baseline
+ behind
+ below
+ bidi-override
+ blink
+ block
+ bolder
+ bold
+ bottom
+ capitalize
+ center-left
+ center-right
+ center
+ circle
+ cjk-ideographic
+ close-quote
+ code
+ collapse
+ compact
+ condensed
+ continuous
+ crop
+ crosshair
+ cross
+ cue-after
+ cue-before
+ cursive
+ dashed
+ decimal
+ decimal-leading-zero
+ default
+ digits
+ disc
+ dotted
+ double
+ embed
+ e-resize
+ expanded
+ extra-condensed
+ extra-expanded
+ fantasy
+ far-left
+ far-right
+ faster
+ fast
+ fixed
+ fixed
+ georgian
+ groove
+ hebrew
+ help
+ hidden
+ hide
+ higher
+ high
+ hiragana-iroha
+ hiragana
+ inherit
+ inline
+ inline-table
+ inset
+ inside
+ invert
+ italic
+ justify
+ katakana-iroha
+ katakana
+ landscape
+ large
+ larger
+ left
+ left-side
+ leftwards
+ level
+ lighter
+ line-through
+ list-item
+ loud
+ lower-alpha
+ lowercase
+ lower-greek
+ lower-latin
+ lower-roman
+ lower
+ low
+ ltr
+ marker
+ medium
+ medium
+ middle
+ mix
+ monospace
+ move
+ narrower
+ ne-resize
+ no-close-quote
+ none
+ no-open-quote
+ no-repeat
+ normal
+ nowrap
+ n-resize
+ nw-resize
+ oblique
+ once
+ open-quote
+ outset
+ outside
+ overline
+ pointer
+ portait
+ pre
+ relative
+ repeat-x
+ repeat-y
+ repeat
+ ridge
+ right-side
+ right
+ rightwards
+ rlt
+ run-in
+ sans-serif
+ scroll
+ scroll
+ semi-condensed
+ semi-expanded
+ separate
+ se-resize
+ serif
+ show
+ silent
+ slower
+ slow
+ small-caps
+ smaller
+ small
+ soft
+ solid
+ spell-out
+ square
+ s-resize
+ static
+ sub
+ super
+ sw-resize
+ table-caption
+ table-cell
+ table-column-group
+ table-column
+ table-footer-group
+ table-header-group
+ table-row-group
+ table-row
+ table
+ text-bottom
+ text
+ text-top
+ thick
+ thin
+ top
+ top
+ transparent
+ ultra-condensed
+ ultra-expanded
+ underline
+ upper-alpha
+ uppercase
+ upper-latin
+ upper-roman
+ visible
+ wait
+ wider
+ w-resize
+ x-fast
+ x-high
+ x-large
+ x-loud
+ x-low
+ x-slow
+ x-small
+ x-soft
+ xx-large
+ xx-small
+
+
+
+ [();,]
+
+
+
+ (\[|\])
+
+
+
+ [@%~|!=]
+
+
+
+ [*#.>+]
+
+
+
+ [#@^]\{
+ \}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/language-specs/hamlet.lang b/language-specs/hamlet.lang
new file mode 100644
--- /dev/null
+++ b/language-specs/hamlet.lang
@@ -0,0 +1,201 @@
+
+
+
+
+ text/x-hamlet
+ *.hamlet
+ <!--
+ -->
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ <!
+ >
+
+
+
+
+ \%{def:never-match}
+
+
+
+
+
+
+
+
+
+ [A-Za-z0-9:_-]+ # attribute name
+ \s*=\s* # "="
+ (\") # string beginning
+
+ \"
+
+
+
+
+ \%{def:always-match}
+
+
+
+
+
+
+
+
+
+
+
+
+
+ [a-z0-9:_-]+ # attribute name
+ \s*=\s* # "="
+
+ (?=>|\s)
+
+
+
+
+
+
+
+
+
+
+
+ [a-z0-9:_-]+ # attribute name
+
+
+
+
+
+ \#
+
+ (?=>|\s)
+
+
+
+
+
+
+
+
+
+
+ \.
+
+ (?=>|\s)
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ ^\s*\$[a-zA-Z0-9]+
+
+
+
+
+
+
+
+ [#@^]\{
+ \}
+
+
+
+
+
+
+
+
+ ^\s*\\
+
+
+
+ \#$
+
+
+
+ <\s*/?\s*[a-z0-9_-]+
+ /?\s*>
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/language-specs/haskell-literate.lang b/language-specs/haskell-literate.lang
new file mode 100644
--- /dev/null
+++ b/language-specs/haskell-literate.lang
@@ -0,0 +1,58 @@
+
+
+
+
+ text/x-literate-haskell
+ *.lhs
+
+
+
+
+
+
+
+
+
+
+
+
+
+ ^>
+
+
+
+
+
+
+ ^\\begin\{code\}
+ ^\\end\{code\}
+
+
+
+
+
+
+
+
+
+
diff --git a/language-specs/haskell.lang b/language-specs/haskell.lang
new file mode 100644
--- /dev/null
+++ b/language-specs/haskell.lang
@@ -0,0 +1,270 @@
+
+
+
+
+ text/x-haskell
+ *.hs
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ [!#$%&*+./>=<?@:\\^|~-]
+
+
+
+
+
+
+ \{-#
+ #-\}
+
+
+
+
+
+
+
+
+
+
+
+
+
+ \[\$?(s|i|w|)hamlet\|
+ \|\]
+
+
+
+
+
+
+
+
+ \[\$?cassius\|
+ \|\]
+
+
+
+
+
+
+
+
+ \[\$?lucius\|
+ \|\]
+
+
+
+
+
+
+
+
+ \[\$?julius\|
+ \|\]
+
+
+
+
+
+
+
+
+ \b[a-z_][0-9a-zA-Z_'#]*
+
+
+
+ \b[A-Z][0-9a-zA-Z_'#]*
+
+
+
+
+ \%{symbolchar}+
+
+
+
+ (?<!\%{symbolchar})
+ (?!\%{symbolchar})
+ \.\.
+ ::
+ =
+ \|
+ \
+ ->
+ <-
+ @
+ ~
+ =>
+
+
+
+ \\( # 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
+ )
+
+
+
+ "
+ "
+
+
+
+ \%{escaped-character}
+
+
+
+
+
+ '
+ '
+
+
+ \%{escaped-character}
+
+
+ .
+
+
+ .
+
+
+
+
+
+
+ [0-9]+ \. [0-9]+ ([eE][+-]?[0-9]+)?
+ | [0-9]+ [eE][+-]?[0-9]+
+
+
+
+
+ 0[xX][0-9a-fA-F]+
+
+
+
+ 0[oO][0-7]+
+
+
+
+ [0-9]+
+
+
+
+ case
+ class
+ data
+ default
+ deriving
+ do
+ mdo
+ else
+ forall
+ foreign
+ hiding
+ if
+ import
+ in
+ infix
+ infixl
+ infixr
+ instance
+ let
+ module
+ newtype
+ of
+ qualified
+ then
+ where
+ type
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/language-specs/julius.lang b/language-specs/julius.lang
new file mode 100644
--- /dev/null
+++ b/language-specs/julius.lang
@@ -0,0 +1,350 @@
+
+
+
+
+ application/x-julius;text/x-julius
+ *.julius
+ //
+ /*
+ */
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ [#@^]\{
+ \}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ "
+ "
+
+
+
+
+
+
+
+
+ '
+ '
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ null
+
+
+ undefined
+
+
+ false
+ true
+
+
+
+
+ break
+ case
+ catch
+ const
+ continue
+ default
+ delete
+ do
+ else
+ export
+ finally
+ for
+ function
+ if
+ import
+ instanceof
+ in
+ let
+ new
+ return
+ switch
+ this
+ throw
+ try
+ typeof
+ while
+ with
+ var
+ void
+
+
+
+ constructor
+ prototype
+
+
+
+ Infinity
+ Math
+ NaN
+ NEGATIVE_INFINITY
+ POSITIVE_INFINITY
+
+
+
+ abs
+ acos
+ apply
+ asin
+ atan2
+ atan
+ call
+ ceil
+ charAt
+ charCodeAt
+ concat
+ cos
+ decodeURIComponent
+ decodeURI
+ encodeURIComponent
+ encodeURI
+ escape
+ eval
+ exec
+ exp
+ floor
+ fromCharCode
+ getDate
+ getDay
+ getFullYear
+ getHours
+ getMilliseconds
+ getMinutes
+ getMonth
+ getSeconds
+ getTime
+ getTimezoneOffset
+ getUTCDate
+ getUTCDay
+ getUTCFullYear
+ getUTCHours
+ getUTCMilliseconds
+ getUTCMinutes
+ getUTCMonth
+ getUTCSeconds
+ getYear
+ hasOwnProperty
+ indexOf
+ isFinite
+ isNaN
+ isPrototypeOf
+ join
+ lastIndexOf
+ localeCompare
+ log
+ match
+ max
+ min
+ parseFloat
+ parseInt
+ parse
+ pop
+ pow
+ propertyIsEnumerable
+ push
+ random
+ replace
+ reverse
+ round
+ search
+ setDate
+ setFullYear
+ setHours
+ setMilliseconds
+ setMinutes
+ setMonth
+ setSeconds
+ setTime
+ setUTCDate
+ setUTCFullYear
+ setUTCHours
+ setUTCMilliseconds
+ setUTCMinutes
+ setUTCMonth
+ setUTCSeconds
+ setYear
+ shift
+ sin
+ slice
+ sort
+ split
+ sqrt
+ substring
+ substr
+ tan
+ toDateString
+ toExponential
+ toFixed
+ toGMTString
+ toLocaleDateString
+ toLocaleLowerCase
+ toLocaleString
+ toLocaleTimeString
+ toLocaleUpperCase
+ toLowerCase
+ toPrecision
+ toString
+ toTimeString
+ toUpperCase
+ toUTCString
+ unescape
+ unshift
+ UTC
+ valueOf
+
+
+
+ global
+ ignoreCase
+ lastIndex
+ length
+ message
+ multiline
+ name
+ source
+
+
+
+ Array
+ Boolean
+ Date
+ Error
+ EvalError
+ Function
+ Number
+ Object
+ RangeError
+ RegExp
+ String
+ SyntaxError
+ TypeError
+ URIError
+
+
+
+ abstract
+ boolean
+ byte
+ char
+ class
+ debugger
+ double
+ enum
+ extends
+ final
+ float
+ goto
+ implements
+ interface
+ int
+ long
+ native
+ package
+ private
+ protected
+ public
+ short
+ static
+ super
+ synchronized
+ throws
+ transient
+ volatile
+
+
+
+
+
+
diff --git a/language-specs/lucius.lang b/language-specs/lucius.lang
new file mode 100644
--- /dev/null
+++ b/language-specs/lucius.lang
@@ -0,0 +1,528 @@
+
+
+
+
+
+ text/css
+ *.lucius
+ /*
+ */
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+ \\([a-fA-F0-9]{1,5}[ \t]|[a-fA-F0-9]{6})
+
+
+
+ first-line
+ first-letter
+ before
+ after
+
+
+
+ first-child
+ link
+ visited
+ hover
+ active
+ focus
+ lang
+
+
+
+ ^[ \t]*@
+ charset
+ font-face
+ media
+ page
+ import
+
+
+
+ #([a-fA-F0-9]{6}|[a-fA-F0-9]{3})\b
+
+
+
+ aqua
+ black
+ blue
+ fuchsia
+ gray
+ green
+ lime
+ maroon
+ navy
+ olive
+ orange
+ purple
+ red
+ silver
+ teal
+ white
+ yellow
+
+
+
+ [a-zA-Z][a-z0-9-]+\(
+ \)
+
+
+
+
+
+
+
+ [\+-]?([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)
+
+
+
+ \b(0|[\+-]?[1-9][0-9]*)
+
+
+
+ [uU]\+[a-fA-F0-9]{1,6}(-[a-fA-F0-9]{1,6})?
+
+
+
+ \![ \t]*important
+
+
+
+ (?=\s*:)
+ azimuth
+ background-attachment
+ background-color
+ background-image
+ background-position
+ background-repeat
+ background
+ border-bottom-color
+ border-bottom-style
+ border-bottom-width
+ border-bottom
+ border-collapse
+ border-color
+ border-left-color
+ border-left-style
+ border-left-width
+ border-left
+ border-right-color
+ border-right-style
+ border-right-width
+ border-right
+ border-spacing
+ border-style
+ border-top-color
+ border-top-style
+ border-top-width
+ border-top
+ border-width
+ border
+ bottom
+ caption-side
+ clear
+ clip
+ color
+ content
+ counter-increment
+ counter-reset
+ cue-after
+ cue-before
+ cue
+ cursor
+ direction
+ display
+ elevation
+ empty-cells
+ float
+ font-family
+ font-size-adjust
+ font-size
+ font-style
+ font-variant
+ font-weight
+ font
+ height
+ left
+ letter-spacing
+ line-height
+ list-style-image
+ list-style-position
+ list-style-type
+ list-style
+ margin-bottom
+ margin-left
+ margin-right
+ margin-top
+ margin
+ marker-offset
+ marks
+ max-height
+ max-width
+ min-height
+ min-width
+ orphans
+ outline-color
+ outline-style
+ outline-width
+ outline
+ overflow
+ padding-bottom
+ padding-left
+ padding-right
+ padding-top
+ padding
+ page-break-after
+ page-break-before
+ page-break-inside
+ page
+ pause-after
+ pause-before
+ pause
+ pitch-range
+ pitch
+ play-during
+ position
+ quotes
+ richness
+ right
+ size
+ speak-header
+ speak-numerical
+ speak-punctuation
+ speak
+ speech-rate
+ stress
+ table-layout
+ text-align
+ text-decoration
+ text-indent
+ text-shadow
+ text-transform
+ top
+ unicode-bidi
+ vertical-align
+ visibility
+ voice-family
+ volume
+ white-space
+ widows
+ width
+ word-spacing
+ z-index
+
+
+
+ above
+ absolute
+ always
+ armenian
+ auto
+ avoid
+ baseline
+ behind
+ below
+ bidi-override
+ blink
+ block
+ bolder
+ bold
+ bottom
+ capitalize
+ center-left
+ center-right
+ center
+ circle
+ cjk-ideographic
+ close-quote
+ code
+ collapse
+ compact
+ condensed
+ continuous
+ crop
+ crosshair
+ cross
+ cue-after
+ cue-before
+ cursive
+ dashed
+ decimal
+ decimal-leading-zero
+ default
+ digits
+ disc
+ dotted
+ double
+ embed
+ e-resize
+ expanded
+ extra-condensed
+ extra-expanded
+ fantasy
+ far-left
+ far-right
+ faster
+ fast
+ fixed
+ fixed
+ georgian
+ groove
+ hebrew
+ help
+ hidden
+ hide
+ higher
+ high
+ hiragana-iroha
+ hiragana
+ inherit
+ inline
+ inline-table
+ inset
+ inside
+ invert
+ italic
+ justify
+ katakana-iroha
+ katakana
+ landscape
+ large
+ larger
+ left
+ left-side
+ leftwards
+ level
+ lighter
+ line-through
+ list-item
+ loud
+ lower-alpha
+ lowercase
+ lower-greek
+ lower-latin
+ lower-roman
+ lower
+ low
+ ltr
+ marker
+ medium
+ medium
+ middle
+ mix
+ monospace
+ move
+ narrower
+ ne-resize
+ no-close-quote
+ none
+ no-open-quote
+ no-repeat
+ normal
+ nowrap
+ n-resize
+ nw-resize
+ oblique
+ once
+ open-quote
+ outset
+ outside
+ overline
+ pointer
+ portait
+ pre
+ relative
+ repeat-x
+ repeat-y
+ repeat
+ ridge
+ right-side
+ right
+ rightwards
+ rlt
+ run-in
+ sans-serif
+ scroll
+ scroll
+ semi-condensed
+ semi-expanded
+ separate
+ se-resize
+ serif
+ show
+ silent
+ slower
+ slow
+ small-caps
+ smaller
+ small
+ soft
+ solid
+ spell-out
+ square
+ s-resize
+ static
+ sub
+ super
+ sw-resize
+ table-caption
+ table-cell
+ table-column-group
+ table-column
+ table-footer-group
+ table-header-group
+ table-row-group
+ table-row
+ table
+ text-bottom
+ text
+ text-top
+ thick
+ thin
+ top
+ top
+ transparent
+ ultra-condensed
+ ultra-expanded
+ underline
+ upper-alpha
+ uppercase
+ upper-latin
+ upper-roman
+ visible
+ wait
+ wider
+ w-resize
+ x-fast
+ x-high
+ x-large
+ x-loud
+ x-low
+ x-slow
+ x-small
+ x-soft
+ xx-large
+ xx-small
+
+
+
+ [{}();,]
+
+
+
+ (\[|\])
+
+
+
+ [@%~|!=]
+
+
+
+ [*#.>+]
+
+
+
+ [#@^]\{
+ \}
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/leksah.cabal b/leksah.cabal
--- a/leksah.cabal
+++ b/leksah.cabal
@@ -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
diff --git a/src/Distribution/PackageDescription/ParseCopied.hs b/src/Distribution/PackageDescription/ParseCopied.hs
new file mode 100644
--- /dev/null
+++ b/src/Distribution/PackageDescription/ParseCopied.hs
@@ -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."
+--}
+
diff --git a/src/Distribution/PackageDescription/PrettyPrintCopied.hs b/src/Distribution/PackageDescription/PrettyPrintCopied.hs
new file mode 100644
--- /dev/null
+++ b/src/Distribution/PackageDescription/PrettyPrintCopied.hs
@@ -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
+
+
+
diff --git a/src/IDE/BufferMode.hs b/src/IDE/BufferMode.hs
--- a/src/IDE/BufferMode.hs
+++ b/src/IDE/BufferMode.hs
@@ -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)
diff --git a/src/IDE/Build.hs b/src/IDE/Build.hs
--- a/src/IDE/Build.hs
+++ b/src/IDE/Build.hs
@@ -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
diff --git a/src/IDE/Command.hs b/src/IDE/Command.hs
--- a/src/IDE/Command.hs
+++ b/src/IDE/Command.hs
@@ -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 ()
+
diff --git a/src/IDE/Completion.hs b/src/IDE/Completion.hs
--- a/src/IDE/Completion.hs
+++ b/src/IDE/Completion.hs
@@ -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
diff --git a/src/IDE/Core/State.hs b/src/IDE/Core/State.hs
--- a/src/IDE/Core/State.hs
+++ b/src/IDE/Core/State.hs
@@ -1,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
diff --git a/src/IDE/Core/Types.hs b/src/IDE/Core/Types.hs
--- a/src/IDE/Core/Types.hs
+++ b/src/IDE/Core/Types.hs
@@ -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
diff --git a/src/IDE/Debug.hs b/src/IDE/Debug.hs
--- a/src/IDE/Debug.hs
+++ b/src/IDE/Debug.hs
@@ -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
diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs
--- a/src/IDE/Find.hs
+++ b/src/IDE/Find.hs
@@ -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 ()
diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs
--- a/src/IDE/ImportTool.hs
+++ b/src/IDE/ImportTool.hs
@@ -1,399 +1,425 @@
------------------------------------------------------------------------------
---
--- Module : IDE.ImportTool
--- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie
--- License : GPL
---
--- Maintainer : Jutaro
--- 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
+-- 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"
diff --git a/src/IDE/Keymap.hs b/src/IDE/Keymap.hs
--- a/src/IDE/Keymap.hs
+++ b/src/IDE/Keymap.hs
@@ -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
diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs
--- a/src/IDE/Leksah.hs
+++ b/src/IDE/Leksah.hs
@@ -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
diff --git a/src/IDE/LogRef.hs b/src/IDE/LogRef.hs
--- a/src/IDE/LogRef.hs
+++ b/src/IDE/LogRef.hs
@@ -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
diff --git a/src/IDE/Metainfo/Provider.hs b/src/IDE/Metainfo/Provider.hs
--- a/src/IDE/Metainfo/Provider.hs
+++ b/src/IDE/Metainfo/Provider.hs
@@ -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)]
diff --git a/src/IDE/NotebookFlipper.hs b/src/IDE/NotebookFlipper.hs
--- a/src/IDE/NotebookFlipper.hs
+++ b/src/IDE/NotebookFlipper.hs
@@ -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
diff --git a/src/IDE/OSX.hs b/src/IDE/OSX.hs
--- a/src/IDE/OSX.hs
+++ b/src/IDE/OSX.hs
@@ -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
diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs
--- a/src/IDE/Package.hs
+++ b/src/IDE/Package.hs
@@ -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 = [],
diff --git a/src/IDE/Pane/Breakpoints.hs b/src/IDE/Pane/Breakpoints.hs
--- a/src/IDE/Pane/Breakpoints.hs
+++ b/src/IDE/Pane/Breakpoints.hs
@@ -1,5 +1,5 @@
-{-# 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
diff --git a/src/IDE/Pane/Errors.hs b/src/IDE/Pane/Errors.hs
--- a/src/IDE/Pane/Errors.hs
+++ b/src/IDE/Pane/Errors.hs
@@ -1,5 +1,5 @@
-{-# 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
--
diff --git a/src/IDE/Pane/Files.hs b/src/IDE/Pane/Files.hs
new file mode 100644
--- /dev/null
+++ b/src/IDE/Pane/Files.hs
@@ -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 :
+-- 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
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/src/IDE/Pane/Grep.hs b/src/IDE/Pane/Grep.hs
--- a/src/IDE/Pane/Grep.hs
+++ b/src/IDE/Pane/Grep.hs
@@ -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
diff --git a/src/IDE/Pane/Info.hs b/src/IDE/Pane/Info.hs
--- a/src/IDE/Pane/Info.hs
+++ b/src/IDE/Pane/Info.hs
@@ -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))
diff --git a/src/IDE/Pane/Log.hs b/src/IDE/Pane/Log.hs
--- a/src/IDE/Pane/Log.hs
+++ b/src/IDE/Pane/Log.hs
@@ -1,5 +1,5 @@
-{-# 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(..))
-------------------------------------------------------------------------------
diff --git a/src/IDE/Pane/Modules.hs b/src/IDE/Pane/Modules.hs
--- a/src/IDE/Pane/Modules.hs
+++ b/src/IDE/Pane/Modules.hs
@@ -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
diff --git a/src/IDE/Pane/PackageEditor.hs b/src/IDE/Pane/PackageEditor.hs
--- a/src/IDE/Pane/PackageEditor.hs
+++ b/src/IDE/Pane/PackageEditor.hs
@@ -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
--- 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 $ "The following fields have invalid values: "
- ++ eventText e ++ ""
- 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
+-- 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 $ "The following fields have invalid values: "
+ ++ eventText e ++ ""
+ 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
+
+
diff --git a/src/IDE/Pane/PackageFlags.hs b/src/IDE/Pane/PackageFlags.hs
--- a/src/IDE/Pane/PackageFlags.hs
+++ b/src/IDE/Pane/PackageFlags.hs
@@ -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)
diff --git a/src/IDE/Pane/Preferences.hs b/src/IDE/Pane/Preferences.hs
--- a/src/IDE/Pane/Preferences.hs
+++ b/src/IDE/Pane/Preferences.hs
@@ -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
diff --git a/src/IDE/Pane/Search.hs b/src/IDE/Pane/Search.hs
--- a/src/IDE/Pane/Search.hs
+++ b/src/IDE/Pane/Search.hs
@@ -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 ()
+--}
diff --git a/src/IDE/Pane/SourceBuffer.hs b/src/IDE/Pane/SourceBuffer.hs
--- a/src/IDE/Pane/SourceBuffer.hs
+++ b/src/IDE/Pane/SourceBuffer.hs
@@ -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
+
+
diff --git a/src/IDE/Pane/Trace.hs b/src/IDE/Pane/Trace.hs
--- a/src/IDE/Pane/Trace.hs
+++ b/src/IDE/Pane/Trace.hs
@@ -1,5 +1,5 @@
-{-# 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
diff --git a/src/IDE/Pane/Variables.hs b/src/IDE/Pane/Variables.hs
--- a/src/IDE/Pane/Variables.hs
+++ b/src/IDE/Pane/Variables.hs
@@ -1,5 +1,5 @@
-{-# 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}
diff --git a/src/IDE/Pane/Workspace.hs b/src/IDE/Pane/Workspace.hs
--- a/src/IDE/Pane/Workspace.hs
+++ b/src/IDE/Pane/Workspace.hs
@@ -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
diff --git a/src/IDE/PaneGroups.hs b/src/IDE/PaneGroups.hs
--- a/src/IDE/PaneGroups.hs
+++ b/src/IDE/PaneGroups.hs
@@ -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
diff --git a/src/IDE/Session.hs b/src/IDE/Session.hs
--- a/src/IDE/Session.hs
+++ b/src/IDE/Session.hs
@@ -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 ()
diff --git a/src/IDE/SourceCandy.hs b/src/IDE/SourceCandy.hs
--- a/src/IDE/SourceCandy.hs
+++ b/src/IDE/SourceCandy.hs
@@ -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
diff --git a/src/IDE/Statusbar.hs b/src/IDE/Statusbar.hs
--- a/src/IDE/Statusbar.hs
+++ b/src/IDE/Statusbar.hs
@@ -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
diff --git a/src/IDE/SymbolNavigation.hs b/src/IDE/SymbolNavigation.hs
new file mode 100644
--- /dev/null
+++ b/src/IDE/SymbolNavigation.hs
@@ -0,0 +1,334 @@
+-----------------------------------------------------------------------------
+--
+-- Module : IDE.SymbolNavigation
+-- Copyright : (c) Sanny Sannof, Juergen Nicklisch-Franken
+-- License : GNU-GPL
+--
+-- Maintainer :
+-- 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)
+
+--}
+
diff --git a/src/IDE/TextEditor.hs b/src/IDE/TextEditor.hs
--- a/src/IDE/TextEditor.hs
+++ b/src/IDE/TextEditor.hs
@@ -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
-
diff --git a/src/IDE/Utils/GUIUtils.hs b/src/IDE/Utils/GUIUtils.hs
--- a/src/IDE/Utils/GUIUtils.hs
+++ b/src/IDE/Utils/GUIUtils.hs
@@ -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
diff --git a/src/IDE/Utils/ServerConnection.hs b/src/IDE/Utils/ServerConnection.hs
--- a/src/IDE/Utils/ServerConnection.hs
+++ b/src/IDE/Utils/ServerConnection.hs
@@ -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 ()
diff --git a/src/IDE/Workspaces.hs b/src/IDE/Workspaces.hs
--- a/src/IDE/Workspaces.hs
+++ b/src/IDE/Workspaces.hs
@@ -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