diff --git a/data/Current.session b/data/Current.session deleted file mode 100644 --- a/data/Current.session +++ /dev/null @@ -1,15 +0,0 @@ -Time of storage: - "Mon May 25 15:28:15 CEST 2009" -Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 615) 889 -Population: [(Just (InfoSt (InfoState (Descr {descrName' = "multisetEditor", typeInfo' = "multisetEditor :: forall alpha.\n (Show alpha, Default alpha, Eq alpha) =>\n ColumnDescr alpha\n -> (Editor alpha, Parameters)\n -> Maybe ([alpha] -> [alpha])\n -> Maybe (alpha -> alpha -> Bool)\n -> Editor [alpha]\n", descrModu' = PM {pack = PackageIdentifier {pkgName = PackageName "leksah", pkgVersion = Version {versionBranch = [0,5,0], versionTags = []}}, modu = ModuleName ["Graphics","UI","Editor","Composite"]}, mbLocation' = Just (Location {locationSLine = 499, locationSCol = 0, locationELine = 616, locationECol = 25}), mbComment' = Just "An editor with a subeditor, of which a list of items can be selected\n\n", details' = VariableDescr}))),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 313 (Package,True) (Nothing,Nothing) (ExpanderState {localExp = ([],[]), localExpNoBlack = ([[5,16],[5,13],[5,1],[5],[4,0,1],[4,0,0],[4,0],[4],[1,0],[1],[0]],[]), packageExp = ([],[]), packageExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP]),(Just (BufferSt (BufferState "/home/jutaro/Develop/leksah/data/welcome.txt" 800)),[SplitP LeftP])] -Window size: (1476,1171) -Active package: - Nothing -Active pane: Just "welcome.txt" -Toolbar visible: - True -FindbarState: (False,FindState {entryStr = "paneP", entryHist = ["paneP","Group","stringxEditor","multiset"], replaceStr = "Category", replaceHist = [], caseSensitive = False, entireWord = False, wrapAround = True, regex = False, lineNr = 1}) -Recently opened files: - ["/home/jutaro/.leksah/Current.session","/home/jutaro/Develop/leksah/data/Current.session","/home/jutaro/Develop/leksah/doc/open_points.txt","/home/jutaro/Develop/leksah/src/Graphics/UI/Frame/ViewFrame.hs","/home/jutaro/Develop/leksah/src/IDE/Core/Types.hs","/home/jutaro/Develop/leksah/src/IDE/Pane/Preferences.hs","/home/jutaro/Develop/leksah/src/IDE/Pane/PackageEditor.hs","/home/jutaro/Develop/leksah/data/Default.prefs","/home/jutaro/.leksah/Default.prefs"] -Recently opened packages: - ["/home/jutaro/Develop/leksah/leksah.cabal"] diff --git a/data/Default.candy b/data/Default.candy deleted file mode 100644 --- a/data/Default.candy +++ /dev/null @@ -1,36 +0,0 @@ --- Candy file - -"->" 0x2192 Trimming --RIGHTWARDS ARROW -> - -"<-" 0x2190 Trimming --LEFTWARDS ARROW <- - -"=>" 0x21d2 --RIGHTWARDS DOUBLE ARROW => - -">=" 0x2265 --GREATER-THAN OR EQUAL TO >= - -"<=" 0x2264 --LESS-THAN OR EQUAL TO <= - -"/=" 0x2260 --NOT EQUAL TO /= - -"&&" 0x2227 --LOGICAL AND && - -"||" 0x2228 --LOGICAL OR || - -"++" 0x2295 --CIRCLED PLUS ++ - --- "::" 0x2237 Trimming --PROPORTION :: - --- ".." 0x2025 --TWO DOT LEADER .. - -"^" 0x2191 --UPWARDS ARROW ^ - -"==" 0x2261 --IDENTICAL TO == - -" . " 0x2218 --RING OPERATOR . - -"\" 0x03bb --GREEK SMALL LETTER LAMBDA \ - --- "=<<" 0x291e -- =<< - -">>=" 0x21a0 -- >>= - --- "$" 0x25ca -- $ - --- ">>" 0x226b -- MUCH GREATER THEN >> - - --- "forall" 0x2200 --FOR ALL --- "exist" 0x2203 --THERE EXISTS -"not" 0x00ac --NOT SIGN - -"alpha" 0x03b1 --ALPHA -"beta" 0x03b2 --BETA -"gamma" 0x03b3 --GAMMA -"delta" 0x03b4 --DELTA -"epsilon" 0x03b5 --EPSILON -"zeta" 0x03b6 --ZETA -"eta" 0x03b7 --ETA -"theta" 0x03b8 --THETA - - diff --git a/data/Default.keymap b/data/Default.keymap deleted file mode 100644 --- a/data/Default.keymap +++ /dev/null @@ -1,109 +0,0 @@ ---Default Keymap file for Leksah ---Allowed Modifiers are --- is the Windows key on PC keyboards --- is often labelled Alt Gr. ---The defined values for the keys can can be found at --- http://gitweb.freedesktop.org/?p=xorg/proto/x11proto.git;a=blob_plain;f=keysymdef.h. --- The names of the keys are the names of the macros without the prefix. - - ---File -n -> FileNew "Opens a new empty buffer" -o -> FileOpen "Opens an existing file" ---x/f -> FileOpen "Opens an existing file" - -s -> FileSave "Saves the current buffer" ---x/s -> FileSave "Saves the current buffer" - ---x/w -> FileSaveAs "Saves the current buffer as a new file" - -s -> FileSaveAll "Saves all modified buffers" - -w -> FileClose "Closes the current buffer" ---x/k -> FileClose "Closes the current buffer" - -F4 -> Quit "Quits this program" ---x/c -> Quit "Quits this program" - ---Edit -z -> EditUndo "Undos the last user action" ---x/u -> EditUndo "Undos the last user action" - -y -> EditRedo "Redos the last user action" ---x/r -> EditRedo "Redos the last user action" - ---x -> EditCut ---c -> EditCopy ---v -> EditPaste - -> EditDelete -a -> EditSelectAll "Select the whole text in the current buffer" - -f -> EditFind "Search for a text string (Toggles the " -F3 -> EditFindNext "Find the next occurence of the text string" - -F3 -> EditFindPrevious "Find the previous occurence of the text string" - -l -> EditGotoLine "Go to line with a known index" - -Right -> EditComment "Add a line style comment to the selected lies" -Left -> EditUncomment "Remove a line style comment" -Right -> EditShiftRight "Shift right" -Left -> EditShiftLeft "Shift Left" - ---View -Left -> ViewMoveLeft "Move the current pane left" -Right -> ViewMoveRight "Move the current pane right" -Up -> ViewMoveUp "Move the current pane up" -Down -> ViewMoveDown "Move the current pane down" - -2 -> ViewSplitHorizontal - "Split the current pane in horizontal direction" -3 -> ViewSplitVertical - "Split the current pane in vertical direction" -1 -> ViewCollapse "Collapse the panes around the currentla selected pane into one" - - -> ViewTabsLeft "Shows the tabs of the current notebook on the left" - -> ViewTabsRight "Shows the tabs of the current notebook on the right" - -> ViewTabsUp "Shows the tabs of the current notebook on the top" - -> ViewTabsDown "Shows the tabs of the current notebook on the bottom" - -> ViewSwitchTabs "Switches if tabs for the current notebook are visible" -t -> ToggleToolbar - -> HelpDebug - -> HelpAbout - -b -> BuildPackage -r -> AddAllImports - -r -> RunPackage - -j -> NextError -j -> PreviousError - -m -> ShowModules - - ---i -> ShowInterface --- i -> ShowInfo - - -e -> EditAlignEqual -l -> EditAlignLeftArrow -r -> EditAlignRightArrow -t -> EditAlignTypeSig - -i -> AddOneImport -i -> AddAllImports - --- "For the next to entries the modifier is mandatory" -Page_Up -> FlipUp "Switch to next pane in reverse recently used oder" -Page_Down -> FlipDown "Switch to next pane in recently used oder" - -space -> StartComplete "Initiate complete in a source buffer" - -F6 -> DebugStep -F7 -> DebugStepLocal -F8 -> DebugStepModule -F9 -> DebugContinue - - - diff --git a/data/Default.menu b/data/Default.menu deleted file mode 100644 --- a/data/Default.menu +++ /dev/null @@ -1,196 +0,0 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/data/Default.prefs b/data/Default.prefs deleted file mode 100644 --- a/data/Default.prefs +++ /dev/null @@ -1,59 +0,0 @@ -Show line numbers: - True - --(True/False) -TextView Font: "Monospace 10" -Right margin: 101 - --Size or 0 for no right margin -Tab width: 4 -Use standard line ends even on windows: - True -Remove trailing blanks when saving a file: - True -Source candy: "Default" - --Empty for do not use or the name of a candy file in a config dir -Editor Style: "" -LogView Font: "Sans 10" -Window default size: - (800,800) - --Default size of the main ide window specified as pair (int,int) -Use ctrl Tab for Notebook flipper: - True -Complete only on Hotkey: - False -Name of the keymap: - Default - --The name of a keymap file in a config dir -Categories for panes: - [("*ClassHierarchy","TreeCategory"),("*Debug","TreeCategory"),("*Grep","TreeCategory"),("*Info","LogCategory"),("*Log","LogCategory"),("*Modules","TreeCategory"),("*Package","DialogCategory"),("*Flags","DialogCategory"),("*Prefs","DialogCategory"),("*References","LogCategory"),("*Search","TreeCategory"),("*Errors","TreeCategory")] -Pane path for category: - [("EditorCategory",[SplitP LeftP]),("TreeCategory",[SplitP RightP,SplitP TopP]),("LogCategory",[SplitP RightP,SplitP BottomP]),("DialogCategory",[SplitP LeftP])] -Default pane path: - [SplitP LeftP] -Paths under which haskell sources for packages may be found: - ["xxx/.cabal/packages","xxx/Develop","xxx/Haskell"] -Extract packages from cabal-install: - Just "xxx/.cabal/packages" -Update metadata at startup: - True -Update metadata after every build: - True -Packages which are excluded from the modules pane: - [Dependency (PackageName "ghc") AnyVersion] -Automatically save all files before building: - True -Background build: - True -Include linking in background builds: - True -Enable usage of Show instances in :print: - True -Break on any exception thrown: - False -Break on uncaught exceptions and errors: - False -Turn on printing of binding results in GHCi: - False -Browser: "firefox" -URL for searching documentation: - "http://holumbus.fh-wedel.de/hayoo/hayoo.html?query=" - --e.g Hoogle: http://www.haskell.org/hoogle/?q= or Hayoo: http://holumbus.fh-wedel.de/hayoo/hayoo.html?query= diff --git a/data/Emacs.keymap b/data/Emacs.keymap deleted file mode 100644 --- a/data/Emacs.keymap +++ /dev/null @@ -1,66 +0,0 @@ ---Default Keymap file for Genuine Haskell Face ---Allowed Modifiers are ---Apple is the Windows key on PC keyboards ---Compose is often labelled Alt Gr. - - ---File -n -> FileNew "Opens a new empty buffer" -x/f -> FileOpen "Opens an existing file" -x/s -> FileSave "Saves the current buffer" -x/w -> FileSaveAs "Saves the current buffer as a new file" -x/k -> FileClose "Closes the current buffer" -x/c -> Quit "Quits kthis program" - - ---Edit -x/u -> EditUndo "Undos the last user action" ---_ -> EditUndo "Undos the last user action" -x/r -> EditRedo "Redos the last user action" -w -> EditCut -w -> EditCopy -y -> EditPaste - -> EditDelete -a -> EditSelectAll "Select the whole text in the current buffer" - -s -> EditFind "Search for a text string" -F3 -> EditFindNext "Find the next occurence of the text string" ---k -> EditFind "Search for a text string" - -r -> EditFindPrevious - "Find the previous occurence of the text string" -r -> EditReplace - -L -> EditGotoLine "Go to line with a known index" - -7 -> EditComment "Add a line style comment to the selected lies" -7 -> EditUncomment "Remove a line style comment" -Right -> EditShiftRight "Shift right" -Left -> EditShiftLeft "Shift Left" - ---View -Left -> ViewMoveLeft "Move the current pane left" -Right -> ViewMoveRight "Move the current pane right" -Up -> ViewMoveUp "Move the current pane up" -Down -> ViewMoveDown "Move the current pane down" - -2 -> ViewSplitHorizontal - "Split the current pane in horizontal direction" -3 -> ViewSplitVertical - "Split the current pane in vertical direction" -1 -> ViewCollapse "Collapse the panes around the currentla selected pane into one" - - -> ViewTabsLeft "Shows the tabs of the current notebook on the left" - -> ViewTabsRight "Shows the tabs of the current notebook on the right" - -> ViewTabsUp "Shows the tabs of the current notebook on the top" - -> ViewTabsDown "Shows the tabs of the current notebook on the bottom" - -> ViewSwitchTabs "Switches if tabs for the current notebook are visible" - -> HelpDebug - -> HelpAbout - -b -> BuildPackage - -r -> RunPackage - -j -> NextError -j -> PreviousError diff --git a/data/Module.template b/data/Module.template deleted file mode 100644 --- a/data/Module.template +++ /dev/null @@ -1,21 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : @ModuleName@ --- Copyright : @Copyright@ --- License : @License@ --- --- Maintainer : @Maintainer@ --- Stability : @Stability@ --- Portability : @Portability@ --- --- | --- ------------------------------------------------------------------------------ - -module @ModuleName@ ( - - -) where - - - diff --git a/data/candy.lkshc b/data/candy.lkshc new file mode 100644 --- /dev/null +++ b/data/candy.lkshc @@ -0,0 +1,36 @@ +-- Candy file + +"->" 0x2192 Trimming --RIGHTWARDS ARROW -> - +"<-" 0x2190 Trimming --LEFTWARDS ARROW <- - +"=>" 0x21d2 --RIGHTWARDS DOUBLE ARROW => - +">=" 0x2265 --GREATER-THAN OR EQUAL TO >= - +"<=" 0x2264 --LESS-THAN OR EQUAL TO <= - +"/=" 0x2260 --NOT EQUAL TO /= - +"&&" 0x2227 --LOGICAL AND && - +"||" 0x2228 --LOGICAL OR || - +"++" 0x2295 --CIRCLED PLUS ++ - +-- "::" 0x2237 Trimming --PROPORTION :: - +-- ".." 0x2025 --TWO DOT LEADER .. - +"^" 0x2191 --UPWARDS ARROW ^ - +"==" 0x2261 --IDENTICAL TO == - +" . " 0x2218 --RING OPERATOR . - +"\" 0x03bb --GREEK SMALL LETTER LAMBDA \ - +-- "=<<" 0x291e -- =<< - +">>=" 0x21a0 -- >>= - +-- "$" 0x25ca -- $ - +-- ">>" 0x226b -- MUCH GREATER THEN >> - + +-- "forall" 0x2200 --FOR ALL +-- "exist" 0x2203 --THERE EXISTS +"not" 0x00ac --NOT SIGN + +"alpha" 0x03b1 --ALPHA +"beta" 0x03b2 --BETA +"gamma" 0x03b3 --GAMMA +"delta" 0x03b4 --DELTA +"epsilon" 0x03b5 --EPSILON +"zeta" 0x03b6 --ZETA +"eta" 0x03b7 --ETA +"theta" 0x03b8 --THETA + + diff --git a/data/current.lkshs b/data/current.lkshs new file mode 100644 --- /dev/null +++ b/data/current.lkshs @@ -0,0 +1,16 @@ +Version of session file format: + 1 +Time of storage: + "Fri Feb 26 17:11:46 CET 2010" +Layout: VerticalP (TerminalP {paneGroups = fromList [], paneTabs = Just TopP, currentPage = -1, detachedId = Nothing, detachedSize = Nothing}) (HorizontalP (TerminalP {paneGroups = fromList [("Browser",HorizontalP (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Nothing, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 329)], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) (TerminalP {paneGroups = fromList [], paneTabs = Just BottomP, currentPage = 0, detachedId = Nothing, detachedSize = Nothing}) 658) 886 +Population: [(Just (InfoSt (InfoState Nothing)),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP BottomP]),(Just (LogSt LogState),[SplitP RightP,SplitP BottomP]),(Just (ModulesSt (ModulesState 401 (SystemScope,True) (Nothing,Nothing) (ExpanderState {packageExp = ([],[]), packageExpNoBlack = ([],[]), packageDExp = ([],[]), packageDExpNoBlack = ([],[]), workspaceExp = ([],[]), workspaceExpNoBlack = ([[6,13],[6]],[]), workspaceDExp = ([],[]), workspaceDExpNoBlack = ([],[]), systemExp = ([],[]), systemExpNoBlack = ([],[])}))),[SplitP RightP,SplitP TopP,GroupP "Browser",SplitP TopP]),(Just (WorkspaceSt WorkspaceState),[SplitP RightP,SplitP BottomP])] +Window size: (1643,1030) +Workspace: Nothing +Active pane: Nothing +Toolbar visible: + True +FindbarState: (True,FindState {entryStr = "", entryHist = [], replaceStr = "", replaceHist = [], caseSensitive = False, entireWord = False, wrapAround = False, regex = False, lineNr = 1}) +Recently opened files: + [] +Recently opened workspaces: + [] diff --git a/data/emacs.lkshk b/data/emacs.lkshk new file mode 100644 --- /dev/null +++ b/data/emacs.lkshk @@ -0,0 +1,66 @@ +--Default Keymap file for Genuine Haskell Face +--Allowed Modifiers are +--Apple is the Windows key on PC keyboards +--Compose is often labelled Alt Gr. + + +--File +n -> FileNew "Opens a new empty buffer" +x/f -> FileOpen "Opens an existing file" +x/s -> FileSave "Saves the current buffer" +x/w -> FileSaveAs "Saves the current buffer as a new file" +x/k -> FileClose "Closes the current buffer" +x/c -> Quit "Quits kthis program" + + +--Edit +x/u -> EditUndo "Undos the last user action" +--_ -> EditUndo "Undos the last user action" +x/r -> EditRedo "Redos the last user action" +w -> EditCut +w -> EditCopy +y -> EditPaste + -> EditDelete +a -> EditSelectAll "Select the whole text in the current buffer" + +s -> EditFind "Search for a text string" +F3 -> EditFindNext "Find the next occurence of the text string" +--k -> EditFind "Search for a text string" + +r -> EditFindPrevious + "Find the previous occurence of the text string" +r -> EditReplace + +L -> EditGotoLine "Go to line with a known index" + +7 -> EditComment "Add a line style comment to the selected lies" +7 -> EditUncomment "Remove a line style comment" +Right -> EditShiftRight "Shift right" +Left -> EditShiftLeft "Shift Left" + +--View +Left -> ViewMoveLeft "Move the current pane left" +Right -> ViewMoveRight "Move the current pane right" +Up -> ViewMoveUp "Move the current pane up" +Down -> ViewMoveDown "Move the current pane down" + +2 -> ViewSplitHorizontal + "Split the current pane in horizontal direction" +3 -> ViewSplitVertical + "Split the current pane in vertical direction" +1 -> ViewCollapse "Collapse the panes around the currentla selected pane into one" + + -> ViewTabsLeft "Shows the tabs of the current notebook on the left" + -> ViewTabsRight "Shows the tabs of the current notebook on the right" + -> ViewTabsUp "Shows the tabs of the current notebook on the top" + -> ViewTabsDown "Shows the tabs of the current notebook on the bottom" + -> ViewSwitchTabs "Switches if tabs for the current notebook are visible" + -> HelpDebug + -> HelpAbout + +b -> BuildPackage + +r -> RunPackage + +j -> NextError +j -> PreviousError diff --git a/data/ide_build.png b/data/ide_build.png deleted file mode 100644 Binary files a/data/ide_build.png and /dev/null differ diff --git a/data/ide_class.png b/data/ide_class.png deleted file mode 100644 Binary files a/data/ide_class.png and /dev/null differ diff --git a/data/ide_clean.png b/data/ide_clean.png deleted file mode 100644 Binary files a/data/ide_clean.png and /dev/null differ diff --git a/data/ide_configure.png b/data/ide_configure.png deleted file mode 100644 Binary files a/data/ide_configure.png and /dev/null differ diff --git a/data/ide_continue.png b/data/ide_continue.png deleted file mode 100644 Binary files a/data/ide_continue.png and /dev/null differ diff --git a/data/ide_data.png b/data/ide_data.png deleted file mode 100644 Binary files a/data/ide_data.png and /dev/null differ diff --git a/data/ide_debug.png b/data/ide_debug.png deleted file mode 100644 Binary files a/data/ide_debug.png and /dev/null differ diff --git a/data/ide_error_next.png b/data/ide_error_next.png deleted file mode 100644 Binary files a/data/ide_error_next.png and /dev/null differ diff --git a/data/ide_error_prev.png b/data/ide_error_prev.png deleted file mode 100644 Binary files a/data/ide_error_prev.png and /dev/null differ diff --git a/data/ide_function.png b/data/ide_function.png deleted file mode 100644 Binary files a/data/ide_function.png and /dev/null differ diff --git a/data/ide_instance.png b/data/ide_instance.png deleted file mode 100644 Binary files a/data/ide_instance.png and /dev/null differ diff --git a/data/ide_konstructor.png b/data/ide_konstructor.png deleted file mode 100644 Binary files a/data/ide_konstructor.png and /dev/null differ diff --git a/data/ide_link.png b/data/ide_link.png deleted file mode 100644 Binary files a/data/ide_link.png and /dev/null differ diff --git a/data/ide_local.png b/data/ide_local.png deleted file mode 100644 Binary files a/data/ide_local.png and /dev/null differ diff --git a/data/ide_make.png b/data/ide_make.png deleted file mode 100644 Binary files a/data/ide_make.png and /dev/null differ diff --git a/data/ide_method.png b/data/ide_method.png deleted file mode 100644 Binary files a/data/ide_method.png and /dev/null differ diff --git a/data/ide_module.png b/data/ide_module.png deleted file mode 100644 Binary files a/data/ide_module.png and /dev/null differ diff --git a/data/ide_newtype.png b/data/ide_newtype.png deleted file mode 100644 Binary files a/data/ide_newtype.png and /dev/null differ diff --git a/data/ide_other.png b/data/ide_other.png deleted file mode 100644 Binary files a/data/ide_other.png and /dev/null differ diff --git a/data/ide_rebuild_meta.png b/data/ide_rebuild_meta.png deleted file mode 100644 Binary files a/data/ide_rebuild_meta.png and /dev/null differ diff --git a/data/ide_reexported.png b/data/ide_reexported.png deleted file mode 100644 Binary files a/data/ide_reexported.png and /dev/null differ diff --git a/data/ide_rule.png b/data/ide_rule.png deleted file mode 100644 Binary files a/data/ide_rule.png and /dev/null differ diff --git a/data/ide_run.png b/data/ide_run.png deleted file mode 100644 Binary files a/data/ide_run.png and /dev/null differ diff --git a/data/ide_slot.png b/data/ide_slot.png deleted file mode 100644 Binary files a/data/ide_slot.png and /dev/null differ diff --git a/data/ide_source.png b/data/ide_source.png deleted file mode 100644 Binary files a/data/ide_source.png and /dev/null differ diff --git a/data/ide_step.png b/data/ide_step.png deleted file mode 100644 Binary files a/data/ide_step.png and /dev/null differ diff --git a/data/ide_type.png b/data/ide_type.png deleted file mode 100644 Binary files a/data/ide_type.png and /dev/null differ diff --git a/data/keymap.lkshk b/data/keymap.lkshk new file mode 100644 --- /dev/null +++ b/data/keymap.lkshk @@ -0,0 +1,112 @@ +--Default Keymap file for Leksah +--Allowed Modifiers are +-- is the Windows key on PC keyboards +-- is often labelled Alt Gr. +--The defined values for the keys can can be found at +-- http://gitweb.freedesktop.org/?p=xorg/proto/x11proto.git;a=blob_plain;f=keysymdef.h. +-- The names of the keys are the names of the macros without the prefix. + + +--File +n -> FileNew "Opens a new empty buffer" +o -> FileOpen "Opens an existing file" +--x/f -> FileOpen "Opens an existing file" + +s -> FileSave "Saves the current buffer" +--x/s -> FileSave "Saves the current buffer" + +--x/w -> FileSaveAs "Saves the current buffer as a new file" + +s -> FileSaveAll "Saves all modified buffers" + +w -> FileClose "Closes the current buffer" +--x/k -> FileClose "Closes the current buffer" + +F4 -> Quit "Quits this program" +--x/c -> Quit "Quits this program" + +--Edit +z -> EditUndo "Undos the last user action" +--x/u -> EditUndo "Undos the last user action" + +y -> EditRedo "Redos the last user action" +--x/r -> EditRedo "Redos the last user action" + +--x -> EditCut +--c -> EditCopy +--v -> EditPaste + -> EditDelete +a -> EditSelectAll "Select the whole text in the current buffer" + +f -> EditFind "Search for a text string (Toggles the " +F3 -> EditFindNext "Find the next occurence of the text string" + +F3 -> EditFindPrevious "Find the previous occurence of the text string" + +l -> EditGotoLine "Go to line with a known index" + +Right -> EditComment "Add a line style comment to the selected lies" +Left -> EditUncomment "Remove a line style comment" +Right -> EditShiftRight "Shift right" +Left -> EditShiftLeft "Shift Left" + +--View +Left -> ViewMoveLeft "Move the current pane left" +Right -> ViewMoveRight "Move the current pane right" +Up -> ViewMoveUp "Move the current pane up" +Down -> ViewMoveDown "Move the current pane down" + +2 -> ViewSplitHorizontal + "Split the current pane in horizontal direction" +3 -> ViewSplitVertical + "Split the current pane in vertical direction" +1 -> ViewCollapse "Collapse the panes around the currentla selected pane into one" + + -> ViewTabsLeft "Shows the tabs of the current notebook on the left" + -> ViewTabsRight "Shows the tabs of the current notebook on the right" + -> ViewTabsUp "Shows the tabs of the current notebook on the top" + -> ViewTabsDown "Shows the tabs of the current notebook on the bottom" + -> ViewSwitchTabs "Switches if tabs for the current notebook are visible" +t -> ToggleToolbar + -> HelpDebug + -> HelpAbout + +b -> BuildPackage +r -> AddAllImports + +r -> RunPackage + +j -> NextError +j -> PreviousError + +o -> ShowModules + + +--i -> ShowInterface +-- i -> ShowInfo + + +e -> EditAlignEqual +l -> EditAlignLeftArrow +r -> EditAlignRightArrow +t -> EditAlignTypeSig + +i -> AddOneImport +i -> AddAllImports + +-- "For the next to entries the modifier is mandatory" +Page_Up -> FlipUp "Switch to next pane in reverse recently used oder" +Page_Down -> FlipDown "Switch to next pane in recently used oder" + +space -> StartComplete "Initiate complete in a source buffer" + +F6 -> DebugStep +F7 -> DebugStepLocal +F8 -> DebugStepModule +F9 -> DebugContinue + +Return -> ExecuteSelection +m -> UpdateMetadataCurrent + + + diff --git a/data/leksah.menu b/data/leksah.menu new file mode 100644 --- /dev/null +++ b/data/leksah.menu @@ -0,0 +1,207 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/data/leksah.png b/data/leksah.png deleted file mode 100644 Binary files a/data/leksah.png and /dev/null differ diff --git a/data/module.lksht b/data/module.lksht new file mode 100644 --- /dev/null +++ b/data/module.lksht @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- +-- Module : @ModuleName@ +-- Copyright : @Copyright@ +-- License : @License@ +-- +-- Maintainer : @Maintainer@ +-- Stability : @Stability@ +-- Portability : @Portability@ +-- +-- | +-- +----------------------------------------------------------------------------- + +module @ModuleName@ ( + + +) where + + + diff --git a/data/prefs.lkshp b/data/prefs.lkshp new file mode 100644 --- /dev/null +++ b/data/prefs.lkshp @@ -0,0 +1,78 @@ +Version number of preferences file format: + 1 + --Integer +Time of last storage: + "Fri Feb 26 16:43:57 CET 2010" +Show line numbers: + True + --(True/False) +TextView Font: "Monospace 10" +Right margin: 100 + --Size or 0 for no right margin +Tab width: 4 +Use standard line ends even on windows: + True +Remove trailing blanks when saving a file: + True +Source candy: "candy" + --Empty for do not use or the name of a candy file in a config dir +Editor Style: "" +Found Text Background: + Color 65535 65535 32768 +Execution Context Text Background: + Color 65535 49152 49152 +Breakpoint Text Background: + Color 65535 49152 32768 +Use Yi - Experimental feature (could wipe your files): + False +LogView Font: "Sans 12" +Window default size: + (1024,800) + --Default size of the main ide window specified as pair (int,int) +Use ctrl Tab for Notebook flipper: + True +Complete only on Hotkey: + False +Name of the keymap: + 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")] +Pane path for category: + [("EditorCategory",[SplitP LeftP]),("ToolCategory",[SplitP RightP,SplitP TopP]),("LogCategory",[SplitP RightP,SplitP BottomP])] +Default pane path: + [SplitP LeftP] +Paths under which haskell sources for packages may be found: + [] +Maybe a directory for unpacking cabal packages: + Just "~/.leksah-0.8/packageSources" +Maybe an URL to load prebuild metadata : + Just "http://www.leksah.org" +Update metadata at startup: + True +Port number for server connection: + 11111 +Server IP address : + "127.0.0.1" +Packages which are excluded from the modules pane: + [Dependency (PackageName "ghc") AnyVersion] +Automatically save all files before building: + True +Background build: + True +Include linking in background builds: + True +Auto install packages: + InstallLibs +Enable usage of Show instances in :print: + True +Break on any exception thrown: + False +Break on uncaught exceptions and errors: + False +Turn on printing of binding results in GHCi: + False +Browser: "firefox" +URL for searching documentation: + "http://holumbus.fh-wedel.de/hayoo/hayoo.html?query=" + --e.g Hoogle: http://www.haskell.org/hoogle/?q= or Hayoo: http://holumbus.fh-wedel.de/hayoo/hayoo.html?query= diff --git a/data/prefscoll.lkshp b/data/prefscoll.lkshp new file mode 100644 --- /dev/null +++ b/data/prefscoll.lkshp @@ -0,0 +1,8 @@ +Paths under which haskell sources for packages may be found: + [] +Maybe a directory for unpacking cabal packages: + Just "~/.leksah-0.8/packageSources" +Maybe an URL to load prebuild metadata : + Just "http://www.leksah.org" +Port number for server connection: + 11111 diff --git a/data/welcome.txt b/data/welcome.txt --- a/data/welcome.txt +++ b/data/welcome.txt @@ -1,6 +1,48 @@ - - + + $=,:Z D7,,,,,,:7$Z + $......,= +.....,+$ + =...,~:..,+D D:~~::~=$ + O~.=????????..O 8III?II$Z + :.I??????????~:N 77I??778 + ??7777777II????+?8 877??I$O + O:$$$ZDNDZ$77I??I:= I7I?I$D + Z?$D $77I?II7 87II77O + $$ 77III:$ DIIII7$ + $N O7II7=D ?7II7Z + $D $77I77 87II7$ + Z$II7Z 8I7I7$N + $777?D IIII$N + $777+ O7777Z + D$77$O I7I77 + Z$III?Z Z777$D + $7III7? DI777D + $7777777Z I77$$ + O?77$8$77I 8777$N + ?777D D77$$ O?77$N + Z77$7 $$7IO I777$ + N+77$8 N$77? Z777$ + $777O D$7$$ I777$ + 7?77$ $77+.777O + N=77$O D$7I=I7$ + 8+77$8 $7III$O + ?I777 N$7I7$ + Z7I778 N7777$ + N~II7$ $777$ + 8I7I7$D $7I7:Z + I~I77O N7II=,N Z + $III7$ $7II7,N $ + $:II7$8 $7II~~Z O7N + O~7II78 D$7I?:.=8 ~$$ + ~III7$ O77??=..? N?,,$ + O~I??7$D $7I???:.........,7 + N,~I?I77 O7I???=,.....,+$N + $,II?I7$D $7I????????I7$8 + O,:???I7D 77II?????I7$N + $.II??I7$ N77IIII77Z + DI?I77777$O Z7777$O + "The Miracle comes quietly into the mind that stops an instant and is still" + # # ###### # #### #### # # ###### ##### #### # # # # # # # # ## ## # # # # # # ##### # # # # # ## # ##### # # # @@ -14,12 +56,9 @@ # ##### #### #### # # ###### # # # # # ###### # # # # # # # # # # # # - ###### ###### # # #### # # # # - - - - "The miracle comes quietly into the mind that stops an instant and is still" - - - For further info please consult: leksah.org + ###### ###### # # #### # # # # V.0.8 + + + + diff --git a/leksah.cabal b/leksah.cabal --- a/leksah.cabal +++ b/leksah.cabal @@ -1,10 +1,10 @@ name: leksah -version: 0.6.1 -cabal-version: >=1.4 +version: 0.8 +cabal-version: >=1.6 build-type: Simple license: GPL license-file: LICENSE -copyright: 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie +copyright: 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie maintainer: maintainer@leksah.org stability: provisional homepage: http://www.leksah.org @@ -14,101 +14,107 @@ 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.1 -data-files: LICENSE Readme data/Current.session data/Default.candy - data/Default.keymap data/Default.menu data/Default.prefs - data/Emacs.keymap data/LICENSE data/Module.template - data/ide_class.png data/ide_configure.png data/ide_data.png - data/ide_error_next.png data/ide_error_prev.png - data/ide_function.png data/ide_instance.png - data/ide_konstructor.png data/ide_make.png data/ide_method.png - data/ide_newtype.png data/ide_other.png data/ide_reexported.png - data/ide_rule.png data/ide_run.png data/ide_slot.png - data/ide_source.png data/ide_type.png data/leksah.png - data/ide_step.png data/ide_local.png data/ide_module.png data/ide_continue.png - data/ide_debug.png - data/welcome.txt data/ide_clean.png data/ide_build.png data/ide_link.png - data/ide_rebuild_meta.png +tested-with: GHC ==6.10 || ==6.12 +data-files: LICENSE + Readme + + data/current.lkshs + data/candy.lkshc + data/keymap.lkshk + data/leksah.menu + data/prefs.lkshp + data/prefscoll.lkshp + data/emacs.lkshk + data/LICENSE + data/module.lksht + data/welcome.txt + + pics/ide_class.png + pics/ide_configure.png + pics/ide_data.png + pics/ide_error_next.png + pics/ide_error_prev.png + pics/ide_function.png + pics/ide_instance.png + pics/ide_konstructor.png + pics/ide_make.png + pics/ide_method.png + pics/ide_newtype.png + pics/ide_other.png + pics/ide_reexported.png + pics/ide_rule.png + pics/ide_run.png + pics/ide_slot.png + pics/ide_source.png + pics/ide_source_local.png + pics/ide_type.png + pics/leksah.png + pics/ide_step.png + pics/ide_local.png + pics/ide_module.png + pics/ide_continue.png + pics/ide_debug.png + pics/ide_clean.png + pics/ide_build.png + pics/ide_link.png + pics/ide_rebuild_meta.png + pics/ide_empty.png data-dir: "" extra-source-files: Setup.lhs extra-tmp-files: + +flag yi + Default: False + Description: Experimental Yi support + Executable leksah if os(windows) build-depends: Win32 >=2.2.0.0 extra-libraries: kernel32 else build-depends: unix >=2.3.1.0 + if os(osx) extra-libraries: igemacintegration - build-depends: Cabal >=1.6.0.1, base >=4.0.0.0 && <= 5, binary >=0.4.4, + + if flag(yi) + build-depends: yi >=0.6.1 + cpp-options: -DYI + + build-depends: Cabal >=1.6.0.1, base >=4.0.0.0 && <= 5, binary >=0.5.0.0, bytestring >=0.9.0.1, containers >=0.2.0.0, directory >=1.0.0.2, - filepath >=1.1.0.1, ghc >=6.10.1, glib >=0.10, gtk >=0.10, + filepath >=1.1.0.1, glib >=0.10, gtk >=0.10, gtksourceview2 >=0.10.0, mtl >=1.1.0.2, old-time >=1.0.0.1, parsec >=2.1.0.1, pretty >=1.0.1.0, process >=1.0.1.0, - regex-posix >=0.72.0.3, regex-compat >=0.71.0.1, - regex-base ==0.72.0.2, utf8-string >=0.3.1.1, array >=0.2.0.0 - main-is: Main.hs + regex-tdfa ==1.1.*, regex-base ==0.93.*, utf8-string >=0.3.1.1, array >=0.2.0.0, + time >=0.1, ltk >= 0.8 && <= 0.9, binary-shared >= 0.8 && <= 0.9, deepseq >= 1.1.0.0, + hslogger >= 1.0.7, leksah-server >= 0.8 && <= 0.9, network >= 2.2 && <= 3.0 + main-is: IDE/Leksah.hs buildable: True - build-tools: - cpp-options: - cc-options: - ld-options: - pkgconfig-depends: - frameworks: - c-sources: extensions: CPP + hs-source-dirs: src if os(windows) -- extra-lib-dirs: C:/cygwin/lib/w32api includes: windows.h -- include-dirs: C:/cygwin/usr/include/w32api - install-includes: - hs-source-dirs: src - other-modules: Default DeepSeq MyMissing Data.Binary.Shared - Control.Event Graphics.UI.Frame.ViewFrame Graphics.UI.Frame.Panes - Graphics.UI.Editor.Composite Graphics.UI.Editor.Simple - Graphics.UI.Editor.Basics Graphics.UI.Editor.Parameters - Graphics.UI.Editor.MakeEditor IDE.Completion IDE.ImportTool - IDE.Find IDE.SaveSession IDE.Menu IDE.Keymap IDE.FileUtils - IDE.DescriptionPP IDE.PrinterParser IDE.Package IDE.Exception - IDE.Leksah IDE.GUIHistory IDE.SourceCandy IDE.NotebookFlipper - IDE.Core.Types IDE.Core.State IDE.Metainfo.GHCUtils - IDE.Metainfo.Provider IDE.Metainfo.SourceCollector - IDE.Metainfo.Serializable IDE.Metainfo.InterfaceCollector - IDE.Pane.Preferences IDE.Pane.ClassHierarchy IDE.Pane.PackageEditor + other-modules: IDE.Completion IDE.ImportTool + IDE.Find IDE.Session IDE.Command IDE.Keymap IDE.Utils.GUIUtils + IDE.Package + IDE.GUIHistory IDE.SourceCandy IDE.NotebookFlipper + IDE.Core.Types IDE.Core.State + IDE.Metainfo.Provider + IDE.Pane.Preferences IDE.Pane.PackageEditor IDE.Pane.Info IDE.Pane.Log IDE.Pane.SourceBuffer IDE.Pane.Modules IDE.Pane.Search IDE.Pane.References IDE.Pane.PackageFlags - IDE.Tool IDE.LogRef IDE.Debug IDE.Pane.Grep + IDE.LogRef IDE.Debug IDE.Pane.Grep IDE.Pane.Breakpoints IDE.Pane.Trace IDE.Pane.Variables - IDE.Pane.Errors IDE.Group.Debugger + IDE.Pane.Errors IDE.TextEditor IDE.Workspaces + IDE.Statusbar IDE.Pane.Workspace IDE.PaneGroups + IDE.Utils.ServerConnection ghc-prof-options: -auto-all -prof ghc-shared-options: -auto-all -prof ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans - hugs-options: - nhc98-options: - jhc-options: -Executable leksahecho - build-depends: - main-is: LeksahEcho.hs - buildable: True - build-tools: - cpp-options: - cc-options: - ld-options: - pkgconfig-depends: - frameworks: - c-sources: - extensions: CPP - extra-libraries: - extra-lib-dirs: - includes: - install-includes: - include-dirs: - hs-source-dirs: src - other-modules: - ghc-prof-options: -auto-all -prof - ghc-shared-options: -auto-all -prof - ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans - hugs-options: - nhc98-options: - jhc-options: + + + diff --git a/pics/ide_build.png b/pics/ide_build.png new file mode 100644 Binary files /dev/null and b/pics/ide_build.png differ diff --git a/pics/ide_class.png b/pics/ide_class.png new file mode 100644 Binary files /dev/null and b/pics/ide_class.png differ diff --git a/pics/ide_clean.png b/pics/ide_clean.png new file mode 100644 Binary files /dev/null and b/pics/ide_clean.png differ diff --git a/pics/ide_configure.png b/pics/ide_configure.png new file mode 100644 Binary files /dev/null and b/pics/ide_configure.png differ diff --git a/pics/ide_continue.png b/pics/ide_continue.png new file mode 100644 Binary files /dev/null and b/pics/ide_continue.png differ diff --git a/pics/ide_data.png b/pics/ide_data.png new file mode 100644 Binary files /dev/null and b/pics/ide_data.png differ diff --git a/pics/ide_debug.png b/pics/ide_debug.png new file mode 100644 Binary files /dev/null and b/pics/ide_debug.png differ diff --git a/pics/ide_empty.png b/pics/ide_empty.png new file mode 100644 Binary files /dev/null and b/pics/ide_empty.png differ diff --git a/pics/ide_error_next.png b/pics/ide_error_next.png new file mode 100644 Binary files /dev/null and b/pics/ide_error_next.png differ diff --git a/pics/ide_error_prev.png b/pics/ide_error_prev.png new file mode 100644 Binary files /dev/null and b/pics/ide_error_prev.png differ diff --git a/pics/ide_function.png b/pics/ide_function.png new file mode 100644 Binary files /dev/null and b/pics/ide_function.png differ diff --git a/pics/ide_instance.png b/pics/ide_instance.png new file mode 100644 Binary files /dev/null and b/pics/ide_instance.png differ diff --git a/pics/ide_konstructor.png b/pics/ide_konstructor.png new file mode 100644 Binary files /dev/null and b/pics/ide_konstructor.png differ diff --git a/pics/ide_link.png b/pics/ide_link.png new file mode 100644 Binary files /dev/null and b/pics/ide_link.png differ diff --git a/pics/ide_local.png b/pics/ide_local.png new file mode 100644 Binary files /dev/null and b/pics/ide_local.png differ diff --git a/pics/ide_make.png b/pics/ide_make.png new file mode 100644 Binary files /dev/null and b/pics/ide_make.png differ diff --git a/pics/ide_method.png b/pics/ide_method.png new file mode 100644 Binary files /dev/null and b/pics/ide_method.png differ diff --git a/pics/ide_module.png b/pics/ide_module.png new file mode 100644 Binary files /dev/null and b/pics/ide_module.png differ diff --git a/pics/ide_newtype.png b/pics/ide_newtype.png new file mode 100644 Binary files /dev/null and b/pics/ide_newtype.png differ diff --git a/pics/ide_other.png b/pics/ide_other.png new file mode 100644 Binary files /dev/null and b/pics/ide_other.png differ diff --git a/pics/ide_rebuild_meta.png b/pics/ide_rebuild_meta.png new file mode 100644 Binary files /dev/null and b/pics/ide_rebuild_meta.png differ diff --git a/pics/ide_reexported.png b/pics/ide_reexported.png new file mode 100644 Binary files /dev/null and b/pics/ide_reexported.png differ diff --git a/pics/ide_rule.png b/pics/ide_rule.png new file mode 100644 Binary files /dev/null and b/pics/ide_rule.png differ diff --git a/pics/ide_run.png b/pics/ide_run.png new file mode 100644 Binary files /dev/null and b/pics/ide_run.png differ diff --git a/pics/ide_slot.png b/pics/ide_slot.png new file mode 100644 Binary files /dev/null and b/pics/ide_slot.png differ diff --git a/pics/ide_source.png b/pics/ide_source.png new file mode 100644 Binary files /dev/null and b/pics/ide_source.png differ diff --git a/pics/ide_source_local.png b/pics/ide_source_local.png new file mode 100644 Binary files /dev/null and b/pics/ide_source_local.png differ diff --git a/pics/ide_step.png b/pics/ide_step.png new file mode 100644 Binary files /dev/null and b/pics/ide_step.png differ diff --git a/pics/ide_type.png b/pics/ide_type.png new file mode 100644 Binary files /dev/null and b/pics/ide_type.png differ diff --git a/pics/leksah.png b/pics/leksah.png new file mode 100644 Binary files /dev/null and b/pics/leksah.png differ diff --git a/src/Control/Event.hs b/src/Control/Event.hs deleted file mode 100644 --- a/src/Control/Event.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-} ------------------------------------------------------------------------------ --- --- Module : Control.Event --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | A simple event mechanism --- -------------------------------------------------------------------------------- -module Control.Event ( - EventSelector -, Event(..) -, EventSource(..) -, Handlers -) where - -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Unique -import Control.Monad - --- | Every event needs a selector, which should identify the type of event -class (Eq delta, Ord delta, Show delta) => EventSelector delta - --- | Every event needs to know its selector and its source -class EventSelector delta => Event beta delta | beta -> delta, delta -> beta where - getSelector :: beta -> delta - --- | This shows the implementation of the event mechnism -type Handlers beta gamma delta = Map delta [(Unique, beta -> gamma beta)] - --- | Everything which is an event source needs this -class (Monad gamma, Event beta delta) => EventSource alpha beta gamma delta - | alpha -> beta, alpha -> gamma where - getHandlers :: alpha -> gamma (Handlers beta gamma delta) - setHandlers :: alpha -> Handlers beta gamma delta -> gamma () - myUnique :: alpha -> gamma (Unique) - - -- | Reimplement this in instances to make triggering of events possible - canTriggerEvent :: alpha -> delta -> Bool - canTriggerEvent _ _ = False - - -- | Returns the event, so that you may get values back from an event - triggerEvent :: alpha -> beta -> gamma beta - triggerEvent o e = - if canTriggerEvent o (getSelector e) - then do - handlerMap <- getHandlers o - let selector = getSelector e - case selector `Map.lookup` handlerMap of - Nothing -> return e - Just l -> foldM (\e (_,ah) -> ah e) e (reverse l) - else error $ "Can't trigger event " ++ show (getSelector e) - - -- | use Left to register and Right to unregister - -- returns Unique if registration was successfull, else Nothing - registerEvent :: alpha -> delta - -> Either (beta -> gamma beta) Unique -> gamma (Maybe Unique) - registerEvent o e (Left handler) = - if canTriggerEvent o e - then do - handlerMap <- getHandlers o - unique <- myUnique o - let newHandlers = case e `Map.lookup` handlerMap of - Nothing -> Map.insert e [(unique,handler)] handlerMap - Just l -> Map.insert e ((unique,handler):l) handlerMap - setHandlers o newHandlers - return (Just unique) - else return Nothing - registerEvent o e (Right unique) = - if canTriggerEvent o e - then do - handlerMap <- getHandlers o - let newHandlers = case e `Map.lookup` handlerMap of - Nothing -> handlerMap - Just l -> let newList = filter (\ (mu,_) -> mu /= unique) l - in Map.insert e newList handlerMap - setHandlers o newHandlers - return (Just unique) - else return Nothing - diff --git a/src/Data/Binary/Shared.hs b/src/Data/Binary/Shared.hs deleted file mode 100644 --- a/src/Data/Binary/Shared.hs +++ /dev/null @@ -1,162 +0,0 @@ -{-# OPTIONS_GHC - -XExistentialQuantification - -XDeriveDataTypeable - -XScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Module : Data.Binary.Shared --- Copyright : 2007-2009 Jürgen Nicklisch-Franken --- License : GPL --- --- Maintainer : Jutaro --- Stability : provisional --- Portability : --- --- | Binary serializing with sharing --- ------------------------------------------------------------------------------ - -module Data.Binary.Shared ( - BinaryShared(..) -, encodeFileSer -, encodeSer -, decodeSer -) where - -import Data.Typeable (typeRepKey,cast,Typeable(..)) -import qualified Control.Monad.State as St (StateT(..),get,put) -import Data.Map (Map(..)) -import qualified Data.Map as Map (empty,fromDistinctAscList,toAscList,Map(..),insert,lookup) -import Data.IntMap (IntMap(..)) -import qualified Data.IntMap as IMap (empty,IntMap(..),insert,lookup) -import qualified Data.Binary as Bin (getWord8,putWord8,Get(..),Binary(..)) -import Data.Binary.Put (runPut,PutM(..),putWord64be) -import System.IO.Unsafe (unsafePerformIO) -import Control.Monad.Trans (lift) -import MyMissing (forceJust) -import Control.Monad (liftM2,replicateM,liftM) -import qualified Data.Set as Set (fromDistinctAscList,toAscList,Set(..)) -import qualified Data.ByteString.Lazy as L -import Data.ByteString (ByteString(..)) -import Control.Monad.State.Lazy (evalStateT) -import Data.Binary.Get (runGet,getWord64be) - --- | A class for storing Binary instances with shared nodes. --- Cycles are not supported, cause put and get is a one path process. - -class (Typeable alpha, Ord alpha, Eq alpha, Show alpha) => BinaryShared alpha where - -- | Encode a value in the Put monad. - put :: alpha -> PutShared - - putShared :: (alpha -> PutShared) -> alpha -> PutShared - putShared fput v = do - (dict, unique) <- St.get - case (ObjC v) `Map.lookup` dict of - Just i -> lift (Bin.putWord8 0 >> putWord64be (fromIntegral i)) - Nothing -> do - St.put (dict,unique + 1) - lift (Bin.putWord8 1) - lift (putWord64be (fromIntegral unique)) - fput v - (dict2, unique2) <- St.get - let newDict = Map.insert (ObjC v) unique dict2 - St.put (newDict,unique2) - - -- | Decode a value in the Get monad - get :: GetShared alpha - - getShared :: GetShared alpha -> GetShared alpha - getShared f = do - dict <- St.get - w <- lift Bin.getWord8 - case w of - 0 -> do - i <- lift (liftM fromIntegral (getWord64be)) - case IMap.lookup i dict of - Just (ObjC obj) -> return (forceJust (cast obj) - "Shared>>getShared: Cast failed") - Nothing -> error $ "Shared>>getShared : Dont find in Map " ++ show i - 1 -> do - i <- lift (liftM fromIntegral (getWord64be)) - obj <- f - dict2 <- St.get - St.put (IMap.insert i (ObjC obj) dict2) - return obj - _ -> error $ "Shared>>getShared : Encoding error" - - --- * How to call this - -encodeSer :: BinaryShared a => a -> L.ByteString -encodeSer v = runPut (evalStateT (put v) (Map.empty,0)) - -encodeFileSer :: BinaryShared a => FilePath -> a -> IO () -encodeFileSer f v = L.writeFile f (encodeSer v) - -decodeSer :: BinaryShared alpha => L.ByteString -> alpha -decodeSer = runGet (evalStateT get IMap.empty) - --- * The types needed internally - -data Object = forall alpha. (Typeable alpha, Ord alpha, Eq alpha, Show alpha) => ObjC {unObj :: alpha} - -instance Eq Object where - (ObjC a) == (ObjC b) = if typeOf a /= typeOf b - then False - else (Just a) == cast b - -instance Ord Object where - compare (ObjC a) (ObjC b) = if typeOf a /= typeOf b - then compare ((unsafePerformIO . typeRepKey . typeOf) a) - ((unsafePerformIO . typeRepKey . typeOf) b) - else compare (Just a) (cast b) - -type PutShared = St.StateT (Map Object Int, Int) PutM () -type GetShared = St.StateT (IntMap Object) Bin.Get - ------------ --- * Some standard instances, but very incomplete - -instance BinaryShared a => BinaryShared [a] where - put = putShared (\l -> lift (Bin.put (length l)) >> mapM_ put l) - get = getShared (do - n <- lift (Bin.get :: Bin.Get Int) - replicateM n get) - -instance (BinaryShared a) => BinaryShared (Maybe a) where - put Nothing = lift (Bin.putWord8 0) - put (Just x) = lift (Bin.putWord8 1) >> put x - get = do - w <- lift (Bin.getWord8) - case w of - 0 -> return Nothing - _ -> liftM Just get - -instance (BinaryShared a, BinaryShared b) => BinaryShared (a,b) where - put (a,b) = put a >> put b - get = liftM2 (,) get get - -instance BinaryShared a => BinaryShared (Set.Set a) where - put s = put (Set.toAscList s) - get = liftM Set.fromDistinctAscList get - -instance (BinaryShared k, BinaryShared e) => BinaryShared (Map.Map k e) where - put m = put (Map.toAscList m) - get = liftM Map.fromDistinctAscList get - -instance BinaryShared Char where - put = lift . Bin.put - get = lift Bin.get - -instance BinaryShared Int where - put = lift . Bin.put - get = lift Bin.get - -instance BinaryShared Integer where - put = lift . Bin.put - get = lift Bin.get - -instance BinaryShared ByteString where - put = lift . Bin.put - get = lift Bin.get - diff --git a/src/DeepSeq.hs b/src/DeepSeq.hs deleted file mode 100644 --- a/src/DeepSeq.hs +++ /dev/null @@ -1,74 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Default --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : provisional --- Portability : portable --- --- | Module for default values of a data type --- ------------------------------------------------------------------------------- - -module DeepSeq where - -class DeepSeq a where - deepSeq :: a -> b -> b - -infixr 0 `deepSeq`, $!! - -($!!) :: (DeepSeq a) => (a -> b) -> a -> b -f $!! x = x `deepSeq` f x - -instance DeepSeq () where deepSeq = seq - -instance DeepSeq Bool where deepSeq = seq -instance DeepSeq Char where deepSeq = seq - -instance (DeepSeq a) => DeepSeq (Maybe a) where - deepSeq Nothing y = y - deepSeq (Just x) y = deepSeq x y - -instance (DeepSeq a, DeepSeq b) => DeepSeq (Either a b) where - deepSeq (Left a) y = deepSeq a y - deepSeq (Right b) y = deepSeq b y - -instance DeepSeq Ordering where deepSeq = seq - -instance DeepSeq Int where deepSeq = seq -instance DeepSeq Integer where deepSeq = seq -instance DeepSeq Float where deepSeq = seq -instance DeepSeq Double where deepSeq = seq - -instance DeepSeq (a -> b) where deepSeq = seq - -instance DeepSeq (IO a) where deepSeq = seq - -instance (DeepSeq a) => DeepSeq [a] where - deepSeq [] y = y - deepSeq (x:xs) y = deepSeq x $ deepSeq xs y - -instance (DeepSeq a,DeepSeq b) => DeepSeq (a,b) where - deepSeq (a,b) = deepSeq a $ deepSeq b - -instance (DeepSeq a,DeepSeq b,DeepSeq c) => DeepSeq (a,b,c) where - deepSeq (a,b,c) = deepSeq a $ deepSeq b $ deepSeq c - -instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d) => DeepSeq (a,b,c,d) where - deepSeq (a,b,c,d) = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d - -instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e) => DeepSeq (a,b,c,d,e) where - deepSeq (a,b,c,d,e) = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e - -instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e,DeepSeq f) => DeepSeq (a,b,c,d,e,f) where - deepSeq (a,b,c,d,e,f) = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f - -instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e,DeepSeq f,DeepSeq g) => DeepSeq (a,b,c,d,e,f,g) where - deepSeq (a,b,c,d,e,f,g) = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f $ deepSeq g - - - - - diff --git a/src/Default.hs b/src/Default.hs deleted file mode 100644 --- a/src/Default.hs +++ /dev/null @@ -1,45 +0,0 @@ - ------------------------------------------------------------------------------ --- --- Module : Default --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : provisional --- Portability : portable --- --- | Module for default values of a data type --- ------------------------------------------------------------------------------- - -module Default ( - Default(..) -) where - --- --- | A class for providing default values for certain types of editors --- -class Default alpha where - getDefault :: alpha - -instance Default Int where - getDefault = 1 - -instance Default alpha => Default (Either alpha beta) where - getDefault = Left getDefault - -instance (Default alpha, Default beta) => Default (alpha, beta) where - getDefault = (getDefault,getDefault) - -instance (Default alpha, Default beta, Default gamma) => Default (alpha, beta, gamma) where - getDefault = (getDefault,getDefault,getDefault) - -instance Default [alpha] where - getDefault = [] - -instance Default (Maybe alpha) where - getDefault = Nothing - -instance Default Bool where - getDefault = True diff --git a/src/Graphics/UI/Editor/Basics.hs b/src/Graphics/UI/Editor/Basics.hs deleted file mode 100644 --- a/src/Graphics/UI/Editor/Basics.hs +++ /dev/null @@ -1,286 +0,0 @@ -{-# OPTIONS_GHC -XMultiParamTypeClasses -XScopedTypeVariables #-} - ------------------------------------------------------------------------------ --- --- Module : Graphics.UI.Editor.Basics --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | Module for the basiscs of composing GUIs from editors --- ------------------------------------------------------------------------------------ - -module Graphics.UI.Editor.Basics ( --- * Types - Getter -, Setter -, Injector -, Extractor -, Applicator -, Editor -, getStandardRegFunction -, emptyNotifier -, GUIEvent(..) -, GUIEventSelector(..) -, GtkRegFunc -, Notifier(..) -, GtkHandler - -, activateEvent -, propagateEvent -, allGUIEvents -) where - -import Graphics.UI.Gtk -import qualified Graphics.UI.Gtk.Gdk.Events as Gtk -import Data.Unique -import Data.IORef -import Control.Monad - -import Graphics.UI.Editor.Parameters -import Control.Event -import MyMissing(allOf) -import Data.Map (Map(..)) -import qualified Data.Map as Map (delete,insert,lookup,empty) -import Data.Maybe (isJust,fromJust) -import Unsafe.Coerce (unsafeCoerce) -import Control.Arrow (first) - - --- --------------------------------------------------------------------- --- * Basic Types --- - --- --- | A type for getting a field of a record --- -type Getter alpha beta = alpha -> beta --- --- | A type for setting the field of a record --- -type Setter alpha beta = beta -> alpha -> alpha - --- --- | A type for injecting a value into an editor --- -type Injector beta = beta -> IO() --- --- | A type for extracting a value from an editor --- -type Extractor beta = IO(Maybe (beta)) --- --- | A type for the application of a value to be reflected in the GUI --- -type Applicator beta gamma = beta -> gamma () - --- --- | A type to describe an editor. --- alpha is the type of the individual field of the record -type Editor alpha = Parameters -> Notifier - -> IO(Widget, Injector alpha , Extractor alpha) - - --- --- | A type for an event in the GUI --- -data GUIEvent = GUIEvent { - selector :: GUIEventSelector -, gtkEvent :: Gtk.Event -, eventPaneName :: String -, gtkReturn :: Bool -- ^ True means that the event has been completely handled, - -- gtk shoudn't do any further action about it (Often not - -- a good idea -} -instance Event GUIEvent GUIEventSelector where - getSelector = selector - -data GUIEventSelector = Clicked - | FocusOut - | FocusIn - | SelectionChanged - | ButtonRelease - | AfterKeyRelease - deriving (Eq,Ord,Show,Enum,Bounded) - -instance EventSelector GUIEventSelector - -allGUIEvents :: [GUIEventSelector] -allGUIEvents = allOf - --- ------------------------------------------------------------ --- * Implementation of GUI event system --- ------------------------------------------------------------ - --- | A type for handling an IO event --- Returning True: The event has been handles --- Returning False: Handling should proceed -type GtkHandler = Gtk.Event -> IO Bool - --- --- | A type for a function to register a gtk event --- | -type GtkRegFunc = Widget -> GtkHandler -> IO (ConnectId Widget) - --- --- | The widgets are the real event sources. --- The GtkRegFunc is the function used to register the event. --- The connectIds are set, when the event is activated, and --- can be used to deactivate the event. --- Or it is a propagated event and: --- The Notifier List is a list of event sources, to which registrations --- are propageted. --- The last map is used to unregister propagated events properly --- -type GUIEventReg = ([ConnectId Widget], - ([Notifier], Map Unique [(Unique,Notifier)])) - --- --- | The event source in the gtk editor context --- If the second argument is Left Handler the handler gets registered --- If the second argument is Right Unique the handler will be removed --- The returned unique value must be used for unregistering an event -newtype Notifier = Noti (IORef (Handlers GUIEvent IO GUIEventSelector, - Map GUIEventSelector GUIEventReg)) - - -emptyNotifier :: IO Notifier -emptyNotifier = do - h <- newIORef (Map.empty,Map.empty) - let noti = Noti h - return noti - -instance EventSource Notifier GUIEvent IO GUIEventSelector where - getHandlers (Noti pairRef) = do - (h,_) <- readIORef pairRef - return h - - setHandlers (Noti pairRef) h = do - (_,r) <- readIORef pairRef - writeIORef pairRef (h,r) - - myUnique _ = newUnique - - canTriggerEvent _ _ = True - - registerEvent o@(Noti pairRef) eventSel hand@(Left handler) = do - (handlers, ger) <- readIORef pairRef - unique <- myUnique o - newGer <- case Map.lookup eventSel ger of - Nothing -> return ger - Just (_,([],um)) -> return ger - Just (cids,(notifiers,um)) -> do - lu <- mapM (\es -> registerEvent es eventSel hand) - notifiers - let jl = map (first fromJust) - $ filter (isJust.fst) - $ zip lu notifiers - let newUm = Map.insert unique jl um - return (Map.insert eventSel (cids,(notifiers,newUm)) ger) - let newHandlers = case eventSel `Map.lookup` handlers of - Nothing -> Map.insert eventSel - [(unique,handler)] handlers - Just l -> Map.insert eventSel - ((unique,handler):l) handlers - writeIORef pairRef (newHandlers,newGer) - return (Just unique) - registerEvent o@(Noti pairRef) eventSel (Right unique) = do - (handlers, ger) <- readIORef pairRef - newGer <- case Map.lookup eventSel ger of - Nothing -> return ger - Just (cids,(notis,um)) -> - case unique `Map.lookup` um of - Nothing -> return ger - Just l -> do - mapM_ (\(u,es) -> registerEvent es eventSel (Right u)) l - let newUm = unique `Map.delete` um - return (Map.insert eventSel (cids,(notis,newUm)) ger) - let newHandlers = case eventSel `Map.lookup` handlers of - Nothing -> handlers - Just l -> case filter (\ (mu,_) -> mu /= unique) l of - [] -> Map.delete eventSel handlers - l -> Map.insert eventSel l handlers - writeIORef pairRef (newHandlers,newGer) - return (Just unique) - --- --- | Propagate the event with the selector from notifier to eventSource --- -propagateEvent :: Notifier -> [Notifier] -> GUIEventSelector -> IO () -propagateEvent (Noti pairRef) eventSources eventSel = do - (handlers,ger) <- readIORef pairRef - let newGer = case Map.lookup eventSel ger of - Nothing -> Map.insert eventSel - ([],(eventSources,Map.empty)) ger - Just (w,(notiList,unregMap)) -> Map.insert eventSel - (w,(eventSources ++ notiList,unregMap)) ger - --now propagate already registered events - newGer2 <- case eventSel `Map.lookup` handlers of - Nothing -> return newGer - Just hl -> foldM (repropagate eventSel) newGer hl - writeIORef pairRef (handlers,newGer) - where - repropagate :: GUIEventSelector - -> Map GUIEventSelector GUIEventReg - -> (Unique, GUIEvent -> IO GUIEvent) - -> IO (Map GUIEventSelector GUIEventReg) - repropagate eventSet ger (unique,hand) = - case Map.lookup eventSel ger of - Just (cids,(notifiers,um)) - -> do - lu <- mapM (\es -> registerEvent es eventSel (Left hand)) - notifiers - let jl = map (first fromJust) - $ filter (isJust.fst) - $ zip lu notifiers - let newUm = Map.insert unique jl um - return (Map.insert eventSel (cids,(notifiers,newUm)) ger) - _ -> error "Basics>>propagateEvent: impossible case" - --- --- | Activate the event after the event has been declared and the --- widget has been constructed --- -activateEvent :: Widget -> Notifier -> Maybe GtkRegFunc -> GUIEventSelector -> IO() -activateEvent widget (Noti pairRef) mbRegisterFunc eventSel = do - let registerFunc = case mbRegisterFunc of - Just f -> f - Nothing -> getStandardRegFunction eventSel - cid <- registerFunc widget (\ e -> do - (hi,_) <- readIORef pairRef - case Map.lookup eventSel hi of - Nothing -> return False - Just [] -> return False - Just handlers -> do - name <- widgetGetName widget - eventList <- mapM (\f -> do - let ev = GUIEvent eventSel e name False - f ev) - (map snd handlers) - let boolList = map gtkReturn eventList - return (foldr (&&) True boolList)) - (handerls,ger) <- readIORef pairRef - let newGer = case Map.lookup eventSel ger of - Nothing -> Map.insert eventSel ([cid],([],Map.empty)) - ger - Just (cids,prop) -> - Map.insert eventSel (cid:cids,prop) ger - writeIORef pairRef (handerls,newGer) - --- --- | A convinence method for not repeating this over and over again --- -getStandardRegFunction :: GUIEventSelector -> GtkRegFunc -getStandardRegFunction FocusOut = \w h -> w `onFocusOut` h -getStandardRegFunction FocusIn = \w h -> w `onFocusIn` h -getStandardRegFunction ButtonRelease = \w h -> w `onButtonRelease` h -getStandardRegFunction AfterKeyRelease = \w h -> w `afterKeyRelease` h -getStandardRegFunction Clicked = \w h -> do - res <- onClicked (castToButton w) (do - h (Gtk.Event True) - return ()) - return (unsafeCoerce res) -getStandardRegFunction SelectionChanged = error "yet not implemented" diff --git a/src/Graphics/UI/Editor/Composite.hs b/src/Graphics/UI/Editor/Composite.hs deleted file mode 100644 --- a/src/Graphics/UI/Editor/Composite.hs +++ /dev/null @@ -1,790 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Graphics.UI.Editor.Composite --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | Module for making composite editors --- ------------------------------------------------------------------------------------ - -module Graphics.UI.Editor.Composite ( - maybeEditor -, pairEditor -, tupel3Editor ---, tupel4Editor ---, tupel5Editor ---, tupel6Editor ---, tupel7Editor -, splitEditor -, eitherOrEditor -, multisetEditor -, ColumnDescr(..) - -, filesEditor -, stringsEditor - -, versionEditor -, versionRangeEditor -, dependencyEditor -, dependenciesEditor -) where - -import Graphics.UI.Gtk -import Control.Monad -import Data.IORef -import Data.Maybe - -import Default -import IDE.Exception -import Control.Event -import Graphics.UI.Editor.Parameters -import Graphics.UI.Editor.Basics -import Graphics.UI.Editor.MakeEditor -import Graphics.UI.Editor.Simple -import Data.List (sortBy, nub, sort, elemIndex) -import Distribution.Simple - (orEarlierVersion, - orLaterVersion, - VersionRange(..), - PackageName(..), - Dependency(..), - PackageIdentifier(..)) -import Distribution.Text (simpleParse, display) -import Distribution.Package (pkgName) -import Distribution.Version - (VersionRange(..)) -import Data.Version (Version(..)) -import MyMissing (forceJust) - --- --- | An editor which composes two subeditors --- -pairEditor :: (Editor alpha, Parameters) -> (Editor beta, Parameters) -> Editor (alpha,beta) -pairEditor (fstEd,fstPara) (sndEd,sndPara) parameters notifier = do - coreRef <- newIORef Nothing - noti1 <- emptyNotifier - noti2 <- emptyNotifier - mapM_ (propagateEvent notifier [noti2]) allGUIEvents - fst@(fstFrame,inj1,ext1) <- fstEd fstPara noti1 - snd@(sndFrame,inj2,ext2) <- sndEd sndPara noti2 - mkEditor - (\widget (v1,v2) -> do - core <- readIORef coreRef - case core of - Nothing -> do - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) - boxPackStart box fstFrame PackGrow 0 - boxPackStart box sndFrame PackGrow 0 - containerAdd widget box - inj1 v1 - inj2 v2 - writeIORef coreRef (Just (fst,snd)) - Just ((_,inj1,_),(_,inj2,_)) -> do - inj1 v1 - inj2 v2) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just ((_,_,ext1),(_,_,ext2)) -> do - r1 <- ext1 - r2 <- ext2 - if isJust r1 && isJust r2 - then return (Just (fromJust r1,fromJust r2)) - else return Nothing) - parameters - notifier - -tupel3Editor :: (Editor alpha, Parameters) - -> (Editor beta, Parameters) - -> (Editor gamma, Parameters) - -> Editor (alpha,beta,gamma) -tupel3Editor p1 p2 p3 parameters notifier = do - coreRef <- newIORef Nothing - noti1 <- emptyNotifier - noti2 <- emptyNotifier - noti3 <- emptyNotifier - mapM_ (propagateEvent notifier [noti2]) allGUIEvents - r1@(frame1,inj1,ext1) <- (fst p1) (snd p1) noti1 - r2@(frame2,inj2,ext2) <- (fst p2) (snd p2) noti2 - r3@(frame3,inj3,ext3) <- (fst p3) (snd p3) noti3 - mkEditor - (\widget (v1,v2,v3) -> do - core <- readIORef coreRef - case core of - Nothing -> do - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) - boxPackStart box frame1 PackGrow 0 - boxPackStart box frame2 PackGrow 0 - boxPackStart box frame3 PackGrow 0 - containerAdd widget box - inj1 v1 - inj2 v2 - inj3 v3 - writeIORef coreRef (Just (r1,r2,r3)) - Just ((_,inj1,_),(_,inj2,_),(_,inj3,_)) -> do - inj1 v1 - inj2 v2 - inj3 v3) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just ((_,_,ext1),(_,_,ext2),(_,_,ext3)) -> do - r1 <- ext1 - r2 <- ext2 - r3 <- ext3 - if isJust r1 && isJust r2 && isJust r3 - then return (Just (fromJust r1,fromJust r2, fromJust r3)) - else return Nothing) - parameters - notifier - -{-- -tupel4Editor :: (Editor alpha, Parameters) - -> (Editor beta, Parameters) - -> (Editor gamma, Parameters) - -> (Editor delta, Parameters) - -> Editor (alpha,beta,gamma,delta) -tupel4Editor p1 p2 p3 p4 parameters notifier = do - (widg,inj,ext) <- pairEditor ((tupel3Editor p1 p2 p3), parameters) p4 parameters notifier - return (widg, - (\ (a, b, c, d) -> inj ((a,b,c),d)), - (do - mb <- ext - case mb of - Nothing -> return Nothing - Just ((a,b,c),d) -> return (Just (a,b,c,d)))) - -tupel5Editor :: (Editor alpha, Parameters) - -> (Editor beta, Parameters) - -> (Editor gamma, Parameters) - -> (Editor delta, Parameters) - -> (Editor epsilon, Parameters) - -> Editor (alpha,beta,gamma,delta,epsilon) -tupel5Editor p1 p2 p3 p4 p5 parameters notifier = do - (widg,inj,ext) <- pairEditor ((tupel4Editor p1 p2 p3 p4), parameters) p5 parameters notifier - return (widg, - (\ (a, b, c, d, e) -> inj ((a,b,c,d),e)), - (do - mb <- ext - case mb of - Nothing -> return Nothing - Just ((a,b,c,d),e) -> return (Just (a,b,c,d,e)))) - -tupel6Editor :: (Editor alpha, Parameters) - -> (Editor beta, Parameters) - -> (Editor gamma, Parameters) - -> (Editor delta, Parameters) - -> (Editor epsilon, Parameters) - -> (Editor zeta, Parameters) - -> Editor (alpha,beta,gamma,delta,epsilon,zeta) -tupel6Editor p1 p2 p3 p4 p5 p6 parameters notifier = do - (widg,inj,ext) <- pairEditor ((tupel5Editor p1 p2 p3 p4 p5), parameters) p6 parameters notifier - return (widg, - (\ (a, b, c, d, e, f) -> inj ((a,b,c,d,e),f)), - (do - mb <- ext - case mb of - Nothing -> return Nothing - Just ((a,b,c,d,e),f) -> return (Just (a,b,c,d,e,f)))) - -tupel7Editor :: (Editor alpha, Parameters) - -> (Editor beta, Parameters) - -> (Editor gamma, Parameters) - -> (Editor delta, Parameters) - -> (Editor epsilon, Parameters) - -> (Editor zeta, Parameters) - -> (Editor eta, Parameters) - -> Editor (alpha,beta,gamma,delta,epsilon,zeta,eta) -tupel7Editor p1 p2 p3 p4 p5 p6 p7 parameters notifier = do - (widg,inj,ext) <- pairEditor ((tupel6Editor p1 p2 p3 p4 p5 p6), parameters) p7 parameters notifier - return (widg, - (\ (a, b, c, d, e, f, g) -> inj ((a,b,c,d,e,f),g)), - (do - mb <- ext - case mb of - Nothing -> return Nothing - Just ((a,b,c,d,e,f),g) -> return (Just (a,b,c,d,e,f,g)))) ---} - --- --- | Like a pair editor, but with a moveable split --- -splitEditor :: (Editor alpha, Parameters) -> (Editor beta, Parameters) -> Editor (alpha,beta) -splitEditor (fstEd,fstPara) (sndEd,sndPara) parameters notifier = do - coreRef <- newIORef Nothing - noti1 <- emptyNotifier - noti2 <- emptyNotifier - mapM_ (propagateEvent notifier [noti1,noti2]) allGUIEvents - fst@(fstFrame,inj1,ext1) <- fstEd fstPara noti1 - snd@(sndFrame,inj2,ext2) <- sndEd sndPara noti2 - mkEditor - (\widget (v1,v2) -> do - core <- readIORef coreRef - case core of - Nothing -> do - paned <- case getParameter paraDirection parameters of - Horizontal -> do h <- vPanedNew - return (castToPaned h) - Vertical -> do v <- hPanedNew - return (castToPaned v) - panedPack1 paned fstFrame True True - panedPack2 paned sndFrame True True - containerAdd widget paned - inj1 v1 - inj2 v2 - writeIORef coreRef (Just (fst,snd)) - Just ((_,inj1,_),(_,inj2,_)) -> do - inj1 v1 - inj2 v2) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just ((_,_,ext1),(_,_,ext2)) -> do - r1 <- ext1 - r2 <- ext2 - if isJust r1 && isJust r2 - then return (Just (fromJust r1,fromJust r2)) - else return Nothing) - parameters - notifier - --- --- | An editor with a subeditor which gets active, when a checkbox is selected --- or deselected (if the positive Argument is False) --- -maybeEditor :: Default beta => (Editor beta, Parameters) -> Bool -> String -> Editor (Maybe beta) -maybeEditor (childEdit, childParams) positive boolLabel parameters notifier = do - coreRef <- newIORef Nothing - childRef <- newIORef Nothing - notifierBool <- emptyNotifier - cNoti <- emptyNotifier - mapM_ (propagateEvent notifier [notifierBool]) [Clicked,FocusIn] - mapM_ (propagateEvent notifier [cNoti]) allGUIEvents - - mkEditor - (\widget mbVal -> do - core <- readIORef coreRef - case core of - Nothing -> do - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) - be@(boolFrame,inj1,ext1) <- boolEditor - (paraName <<<- ParaName boolLabel $ emptyParams) - notifierBool - boxPackStart box boolFrame PackNatural 0 - containerAdd widget box - registerEvent notifierBool Clicked (Left (onClickedHandler widget coreRef childRef cNoti)) - case mbVal of - Nothing -> inj1 (not positive) - Just val -> do - (childWidget,inj2,ext2) <- getChildEditor childRef childEdit childParams cNoti - boxPackEnd box childWidget PackGrow 0 - widgetShowAll childWidget - inj1 positive - inj2 val - writeIORef coreRef (Just (be,box)) - Just (be@(boolFrame,inj1,extt),box) -> do - hasChild <- hasChildEditor childRef - case mbVal of - Nothing -> - if hasChild - then do - (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti - inj1 (not positive) - widgetHideAll childWidget - else inj1 (not positive) - Just val -> - if hasChild - then do - inj1 positive - (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti - widgetShowAll childWidget - inj2 val - else do - inj1 positive - (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti - boxPackEnd box childWidget PackGrow 0 - widgetShowAll childWidget - inj2 val) - (do - core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (be@(boolFrame,inj1,ext1),_) -> do - bool <- ext1 - case bool of - Nothing -> return Nothing - Just bv | bv == positive -> do - (_,_,ext2) <- getChildEditor childRef childEdit childParams cNoti - value <- ext2 - case value of - Nothing -> return Nothing - Just value -> return (Just (Just value)) - otherwise -> return (Just Nothing)) - parameters - notifier - where - onClickedHandler widget coreRef childRef cNoti event = do - core <- readIORef coreRef - case core of - Nothing -> throwIDE "Impossible" - Just (be@(boolFrame,inj1,ext1),vBox) -> do - mbBool <- ext1 - case mbBool of - Just bool -> - if bool /= positive - then do - hasChild <- hasChildEditor childRef - when hasChild $ do - (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti - widgetHideAll childWidget - else do - hasChild <- hasChildEditor childRef - if hasChild - then do - (childWidget,_,_) <- getChildEditor childRef childEdit childParams cNoti - widgetShowAll childWidget - else do - (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti - boxPackEnd vBox childWidget PackNatural 0 - inj2 getDefault - widgetShowAll childWidget - Nothing -> return () - return (event {gtkReturn=True}) - getChildEditor childRef childEditor childParams cNoti = do - mb <- readIORef childRef - case mb of - Just editor -> return editor - Nothing -> do - let val = childEditor - editor@(_,_,_) <- childEditor childParams cNoti - writeIORef childRef (Just editor) - return editor - hasChildEditor childRef = do - mb <- readIORef childRef - return (isJust mb) - --- --- | An editor with a subeditor which gets active, when a checkbox is selected --- or deselected (if the positive Argument is False) -eitherOrEditor :: (Default alpha, Default beta) => (Editor alpha, Parameters) -> - (Editor beta, Parameters) -> String -> Editor (Either alpha beta) -eitherOrEditor (leftEditor,leftParams) (rightEditor,rightParams) - label2 parameters notifier = do - coreRef <- newIORef Nothing - noti1 <- emptyNotifier - noti2 <- emptyNotifier - noti3 <- emptyNotifier - mapM_ (propagateEvent notifier [noti1,noti2,noti3]) allGUIEvents - be@(boolFrame,inj1,ext1) <- boolEditor2 (getParameter paraName rightParams) leftParams noti1 - le@(leftFrame,inj2,ext2) <- leftEditor (paraName <<<- ParaName "" $ leftParams) noti2 - re@(rightFrame,inj3,ext3) <- rightEditor (paraName <<<- ParaName "" $ rightParams) noti3 - mkEditor - (\widget v -> do - core <- readIORef coreRef - case core of - Nothing -> do - registerEvent noti1 Clicked (Left (onClickedHandler widget coreRef)) - box <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 1 - return (castToBox b) - boxPackStart box boolFrame PackNatural 0 - containerAdd widget box - case v of - Left vl -> do - boxPackStart box leftFrame PackNatural 0 - inj2 vl - inj3 getDefault - inj1 True - Right vr -> do - boxPackStart box rightFrame PackNatural 0 - inj3 vr - inj2 getDefault - inj1 False - writeIORef coreRef (Just (be,le,re,box)) - Just ((_,inj1,_),(leftFrame,inj2,_),(rightFrame,inj3,_),box) -> - case v of - Left vl -> do - containerRemove box rightFrame - boxPackStart box leftFrame PackNatural 0 - inj2 vl - inj3 getDefault - inj1 True - Right vr -> do - containerRemove box leftFrame - boxPackStart box rightFrame PackNatural 0 - inj3 vr - inj2 getDefault - inj1 False) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just ((_,_,ext1),(_,_,ext2),(_,_,ext3),_) -> do - mbbool <- ext1 - case mbbool of - Nothing -> return Nothing - Just True -> do - value <- ext2 - case value of - Nothing -> return Nothing - Just value -> return (Just (Left value)) - Just False -> do - value <- ext3 - case value of - Nothing -> return Nothing - Just value -> return (Just (Right value))) - (paraName <<<- ParaName "" $ parameters) - notifier - where - onClickedHandler widget coreRef event = do - core <- readIORef coreRef - case core of - Nothing -> throwIDE "Impossible" - Just (be@(_,_,ext1),(leftFrame,_,_),(rightFrame,_,_),box) -> do - mbBool <- ext1 - case mbBool of - Just bool -> - if bool then do - containerRemove box rightFrame - boxPackStart box leftFrame PackNatural 0 - widgetShowAll box - else do - containerRemove box leftFrame - boxPackStart box rightFrame PackNatural 0 - widgetShowAll box - Nothing -> return () - return event{gtkReturn=True} - - --- a trivial example: (ColumnDescr False [("",(\row -> [cellText := show row]))]) --- and a nontrivial: --- [("Package",\(Dependency str _) -> [cellText := str]) --- ,("Version",\(Dependency _ vers) -> [cellText := showVersionRange vers])]) -data ColumnDescr row = ColumnDescr Bool [(String,(row -> [AttrOp CellRendererText]))] - --- --- | An editor with a subeditor, of which a list of items can be selected -multisetEditor :: (Show alpha, Default alpha, Eq alpha) => ColumnDescr alpha - -> (Editor alpha, Parameters) - -> Maybe ([alpha] -> [alpha]) -- ^ The 'mbSort' arg, a sort function if desired - -> Maybe (alpha -> alpha -> Bool) -- ^ The 'mbReplace' arg, a function which is a criteria for removing an - -- old entry when adding a new value - -> Editor [alpha] -multisetEditor (ColumnDescr showHeaders columnsDD) (singleEditor, sParams) mbSort mbReplace - parameters notifier = do - coreRef <- newIORef Nothing - cnoti <- emptyNotifier - mapM_ (propagateEvent notifier [cnoti]) allGUIEvents - mkEditor - (\widget vs -> do - core <- readIORef coreRef - case core of - Nothing -> do - (box,buttonBox) <- case getParameter paraDirection parameters of - Horizontal -> do - b <- hBoxNew False 1 - bb <- vButtonBoxNew - return (castToBox b,castToButtonBox bb) - Vertical -> do - b <- vBoxNew False 1 - bb <- hButtonBoxNew - return (castToBox b,castToButtonBox bb) - (frameS,injS,extS) <- singleEditor sParams cnoti - addButton <- buttonNewWithLabel "Add" - removeButton <- buttonNewWithLabel "Remove" - containerAdd buttonBox addButton - containerAdd buttonBox removeButton - listStore <- listStoreNew ([]:: [alpha]) - treeView <- treeViewNewWithModel listStore - let minSize = getParameter paraMinSize parameters - uncurry (widgetSetSizeRequest treeView) minSize - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw treeView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - sel <- treeViewGetSelection treeView - treeSelectionSetMode sel SelectionSingle - mapM_ (\(str,func) -> do - col <- treeViewColumnNew - treeViewColumnSetTitle col str - treeViewColumnSetResizable col True - treeViewAppendColumn treeView col - renderer <- cellRendererTextNew - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer listStore func - ) columnsDD - treeViewSetHeadersVisible treeView showHeaders - sel `onSelectionChanged` selectionHandler sel listStore injS - boxPackStart box sw PackGrow 0 - boxPackStart box buttonBox PackNatural 0 - boxPackStart box frameS PackNatural 0 - activateEvent (castToWidget treeView) notifier Nothing FocusOut - containerAdd widget box - listStoreClear listStore - mapM_ (listStoreAppend listStore) - (case mbSort of - Nothing -> vs - Just sortF -> sortF vs) - addButton `onClicked` do - mbv <- extS - case mbv of - Just v -> do - case mbReplace of - Nothing -> return () - Just replaceF -> do - cont <- listStoreToList listStore - mapM_ (listStoreRemove listStore) - $ map fst - $ filter (\(_,e) -> replaceF v e) - $ zip [0..] cont - case mbSort of - Nothing -> do - listStoreAppend listStore v - return () - Just sortF -> do - cont <- listStoreToList listStore - listStoreClear listStore - mapM_ (listStoreAppend listStore) (sortF (v:cont)) - cont <- listStoreToList listStore - case elemIndex v cont of - Just idx -> do - treeSelectionSelectPath sel [idx] - mbCol <- treeViewGetColumn treeView 0 - case mbCol of - Nothing -> return () - Just col -> treeViewScrollToCell treeView [idx] col Nothing - Nothing -> return () - Nothing -> return () - removeButton `onClicked` do - mbi <- treeSelectionGetSelected sel - case mbi of - Nothing -> return () - Just iter -> do - [i] <- treeModelGetPath listStore iter - listStoreRemove listStore i - writeIORef coreRef (Just listStore) - injS getDefault - Just listStore -> do - listStoreClear listStore - mapM_ (listStoreAppend listStore) - (case mbSort of - Nothing -> vs - Just sortF -> sortF vs)) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just listStore -> do - v <- listStoreToList listStore - return (Just v)) - (paraMinSize <<<- ParaMinSize (-1,-1) $ parameters) - notifier - where - selectionHandler :: TreeSelection -> ListStore a -> Injector a -> IO () - selectionHandler sel listStore inj = do - ts <- treeSelectionGetSelected sel - case ts of - Nothing -> return () - Just iter -> do - [i] <- treeModelGetPath listStore iter - v <- listStoreGetValue listStore i - inj v - return () - - -filesEditor :: Maybe FilePath -> FileChooserAction -> String -> Editor [FilePath] -filesEditor fp act label p = - multisetEditor - (ColumnDescr False [("",(\row -> [cellText := row]))]) - (fileEditor fp act label, emptyParams) - (Just sort) - (Just (==)) - (paraShadow <<<- ParaShadow ShadowIn $ - paraDirection <<<- ParaDirection Vertical $ p) - -stringsEditor :: (String -> Bool) -> Editor [String] -stringsEditor validation p = - multisetEditor - (ColumnDescr False [("",(\row -> [cellText := row]))]) - (stringEditor validation, emptyParams) - (Just sort) - (Just (==)) - (paraShadow <<<- ParaShadow ShadowIn $ p) - -dependencyEditor :: [PackageIdentifier] -> Editor Dependency -dependencyEditor packages para noti = do - (wid,inj,ext) <- pairEditor - ((eitherOrEditor (comboSelectionEditor ((sort . nub) (map (display . pkgName) packages)) id - , paraName <<<- ParaName "Select" $ emptyParams) - (stringEditor (const True), paraName <<<- ParaName "Enter" $ emptyParams) - "Select from list?"), paraName <<<- ParaName "Name"$ emptyParams) - (versionRangeEditor,paraName <<<- ParaName "Version" $ emptyParams) - (paraDirection <<<- ParaDirection Vertical $ para) - noti - let pinj (Dependency pn@(PackageName s) v) = if elem s (map (display . pkgName) packages) - then inj (Left s,v) - else inj (Right s,v) - let pext = do - mbp <- ext - case mbp of - Nothing -> return Nothing - Just (Left "",v) -> return Nothing - Just (Left s,v) -> return (Just $ Dependency (PackageName s) v) - Just (Right "",v) -> return Nothing - Just (Right s,v) -> return (Just $ Dependency (PackageName s) v) - return (wid,pinj,pext) - -dependenciesEditor :: [PackageIdentifier] -> Editor [Dependency] -dependenciesEditor packages p noti = - multisetEditor - (ColumnDescr True [("Package",\(Dependency (PackageName str) _) -> [cellText := str]) - ,("Version",\(Dependency _ vers) -> [cellText := display vers])]) - (dependencyEditor packages, - paraOuterAlignment <<<- ParaInnerAlignment (0.0, 0.5, 1.0, 1.0) - $ paraInnerAlignment <<<- ParaOuterAlignment (0.0, 0.5, 1.0, 1.0) - $ emptyParams) - (Just (sortBy (\ (Dependency p1 _) (Dependency p2 _) -> compare p1 p2))) - (Just (\ (Dependency p1 _) (Dependency p2 _) -> p1 == p2)) - (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 - -versionRangeEditor :: Editor VersionRange -versionRangeEditor para noti = do - (wid,inj,ext) <- - maybeEditor - ((eitherOrEditor - (pairEditor - (comboSelectionEditor v1 show, emptyParams) - (versionEditor, paraName <<<- ParaName "Enter Version" $ emptyParams), - (paraDirection <<<- ParaDirection Vertical - $ paraName <<<- ParaName "Simple" - $ 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)) - (tupel3Editor - (comboSelectionEditor v2 show, emptyParams) - (versionRangeEditor, paraShadow <<<- ParaShadow ShadowIn $ emptyParams) - (versionRangeEditor, paraShadow <<<- ParaShadow ShadowIn $ emptyParams), - paraName <<<- ParaName "Complex" - $ paraDirection <<<- ParaDirection Vertical - $ 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) "Select version range"), emptyParams) - False "Any Version" - (paraDirection <<<- ParaDirection Vertical $ para) - noti - let vrinj AnyVersion = inj Nothing - vrinj (ThisVersion v) = inj (Just (Left (ThisVersionS,v))) - vrinj (LaterVersion v) = inj (Just (Left (LaterVersionS,v))) - vrinj (EarlierVersion v) = inj (Just (Left (EarlierVersionS,v))) - vrinj (UnionVersionRanges (ThisVersion v1) (LaterVersion v2)) | v1 == v2 - = inj (Just (Left (ThisOrLaterVersionS,v1))) - vrinj (UnionVersionRanges (LaterVersion v1) (ThisVersion v2)) | v1 == v2 - = inj (Just (Left (ThisOrLaterVersionS,v1))) - vrinj (UnionVersionRanges (ThisVersion v1) (EarlierVersion v2)) | v1 == v2 - = inj (Just (Left (ThisOrEarlierVersionS,v1))) - vrinj (UnionVersionRanges (EarlierVersion v1) (ThisVersion v2)) | v1 == v2 - = inj (Just (Left (ThisOrEarlierVersionS,v1))) - vrinj (UnionVersionRanges v1 v2)= inj (Just (Right (UnionVersionRangesS,v1,v2))) - vrinj (IntersectVersionRanges v1 v2) - = inj (Just (Right (IntersectVersionRangesS,v1,v2))) - let vrext = do mvr <- ext - case mvr of - Nothing -> return (Just AnyVersion) - Just Nothing -> return (Just AnyVersion) - Just (Just (Left (ThisVersionS,v))) -> return (Just (ThisVersion v)) - Just (Just (Left (LaterVersionS,v))) -> return (Just (LaterVersion v)) - Just (Just (Left (EarlierVersionS,v))) -> return (Just (EarlierVersion v)) - - Just (Just (Left (ThisOrLaterVersionS,v))) -> return (Just (orLaterVersion v)) - Just (Just (Left (ThisOrEarlierVersionS,v))) -> return (Just (orEarlierVersion v)) - Just (Just (Right (UnionVersionRangesS,v1,v2))) - -> return (Just (UnionVersionRanges v1 v2)) - Just (Just (Right (IntersectVersionRangesS,v1,v2))) - -> return (Just (IntersectVersionRanges v1 v2)) - return (wid,vrinj,vrext) - where - v1 = [ThisVersionS,LaterVersionS,ThisOrLaterVersionS,EarlierVersionS,ThisOrEarlierVersionS] - v2 = [UnionVersionRangesS,IntersectVersionRangesS] - -data Version1 = ThisVersionS | LaterVersionS | ThisOrLaterVersionS | EarlierVersionS | ThisOrEarlierVersionS - deriving (Eq) -instance Show Version1 where - show ThisVersionS = "This Version" - show LaterVersionS = "Later Version" - show ThisOrLaterVersionS = "This or later Version" - show EarlierVersionS = "Earlier Version" - show ThisOrEarlierVersionS = "This or earlier Version" - -data Version2 = UnionVersionRangesS | IntersectVersionRangesS - deriving (Eq) -instance Show Version2 where - show UnionVersionRangesS = "Union Version Ranges" - show IntersectVersionRangesS = "Intersect Version Ranges" - -versionEditor :: Editor Version -versionEditor para noti = do - (wid,inj,ext) <- stringEditor (\s -> not (null s)) para noti - let pinj v = inj (display v) - let pext = do - s <- ext - case s of - Nothing -> return Nothing - Just s -> return (simpleParse s) - return (wid, pinj, pext) - -instance Default Version1 - where getDefault = ThisVersionS - -instance Default Version2 - where getDefault = UnionVersionRangesS - -instance Default Version - where getDefault = forceJust (simpleParse "0") "PackageEditor>>default version" - -instance Default VersionRange - where getDefault = AnyVersion - -instance Default Dependency - where getDefault = Dependency getDefault getDefault - -instance Default PackageName - where getDefault = PackageName getDefault - - - - - diff --git a/src/Graphics/UI/Editor/MakeEditor.hs b/src/Graphics/UI/Editor/MakeEditor.hs deleted file mode 100644 --- a/src/Graphics/UI/Editor/MakeEditor.hs +++ /dev/null @@ -1,252 +0,0 @@ ------------------------------------------------------------------------------ ---group_Test --- Module : Graphics.UI.Editor.MakeEditor --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | Module for making editors out of descriptions --- ------------------------------------------------------------------------------------ - -module Graphics.UI.Editor.MakeEditor ( - - buildEditor -, FieldDescription(..) -, mkField -, extractAndValidate -, extract -, mkEditor -, parameters - -, flattenFieldDescription -, getRealWidget -, MkFieldDescription - -) where - -import Graphics.UI.Gtk -import Control.Monad -import Data.List(unzip4) - -import Control.Event -import Graphics.UI.Editor.Parameters -import Graphics.UI.Editor.Basics ---import Graphics.UI.Frame.ViewFrame -import Data.Maybe (isNothing) - --- --- | A constructor type for a field desciption --- -type MkFieldDescription alpha beta = - Parameters -> - (Getter alpha beta) -> - (Setter alpha beta) -> - (Editor beta) -> - FieldDescription alpha - --- --- | A type to describe a field of a record, which can be edited --- | alpha is the type of the individual field of the record -data FieldDescription alpha = FD Parameters (alpha -> IO (Widget, Injector alpha , - alpha -> Extractor alpha , Notifier)) - | VFD Parameters [FieldDescription alpha] - | HFD Parameters [FieldDescription alpha] - | NFD [(String,FieldDescription alpha)] - -parameters :: FieldDescription alpha -> Parameters -parameters (FD p _) = p -parameters (VFD p _) = p -parameters (HFD p _) = p -parameters (NFD _) = emptyParams - --- --- | Construct a new notebook --- -newNotebook :: IO Notebook -newNotebook = do - nb <- notebookNew - notebookSetTabPos nb PosTop - notebookSetShowTabs nb True - notebookSetScrollable nb True - notebookSetPopup nb True - return nb - -buildEditor :: FieldDescription alpha -> alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) -buildEditor (FD paras editorf) v = editorf v -buildEditor (HFD paras descrs) v = buildBoxEditor descrs Horizontal v -buildEditor (VFD paras descrs) v = buildBoxEditor descrs Vertical v -buildEditor (NFD pairList) v = do - nb <- newNotebook - notebookSetShowTabs nb False - resList <- mapM (\d -> buildEditor d v) (map snd pairList) - let (widgets, setInjs, getExts, notifiers) = unzip4 resList - notifier <- emptyNotifier - mapM_ (\ (labelString, widget) -> do - sw <- scrolledWindowNew Nothing Nothing - scrolledWindowAddWithViewport sw widget - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - notebookAppendPage nb sw labelString) - (zip (map fst pairList) widgets) - listStore <- listStoreNew (map fst pairList) - listView <- treeViewNewWithModel listStore - widgetSetSizeRequest listView 100 (-1) - sel <- treeViewGetSelection listView - treeSelectionSetMode sel SelectionSingle - renderer <- cellRendererTextNew - col <- treeViewColumnNew - treeViewAppendColumn listView col - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer listStore $ \row -> - [ cellText := row ] - treeViewSetHeadersVisible listView False - treeSelectionSelectPath sel [0] - notebookSetCurrentPage nb 0 - sel `onSelectionChanged` (do - selections <- treeSelectionGetSelectedRows sel - case selections of - [[i]] -> notebookSetCurrentPage nb i - _ -> return ()) - - hb <- hBoxNew False 0 - boxPackStart hb listView PackNatural 7 - boxPackEnd hb nb PackGrow 7 - let newInj = (\v -> mapM_ (\ setInj -> setInj v) setInjs) - let newExt = (\v -> extract v getExts) - mapM_ (propagateEvent notifier notifiers) allGUIEvents - return (castToWidget hb, newInj, newExt, notifier) - -buildBoxEditor :: [FieldDescription alpha] -> Direction -> alpha - -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) -buildBoxEditor descrs dir v = do - resList <- mapM (\d -> buildEditor d v) descrs - notifier <- emptyNotifier - let (widgets, setInjs, getExts, notifiers) = unzip4 resList - hb <- case dir of - Horizontal -> do - b <- hBoxNew False 0 - return (castToBox b) - Vertical -> do - b <- vBoxNew False 0 - return (castToBox b) - let newInj = (\v -> mapM_ (\ setInj -> setInj v) setInjs) - let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of - Just s -> s - Nothing -> "Unnamed") descrs - let packParas = map (\fd -> getParameter paraPack (parameters fd)) descrs - let newExt = (\v -> extractAndValidate v getExts fieldNames) - mapM_ (\ (w,p) -> boxPackStart hb w p 0) $ zip widgets packParas - mapM_ (propagateEvent notifier notifiers) allGUIEvents - return (castToWidget hb, newInj, newExt, notifier) - - -flattenFieldDescription :: FieldDescription alpha -> [FieldDescription alpha] -flattenFieldDescription (VFD paras descrs) = concatMap flattenFieldDescription descrs -flattenFieldDescription (HFD paras descrs) = concatMap flattenFieldDescription descrs -flattenFieldDescription (NFD descrp) = concatMap (flattenFieldDescription.snd) descrp -flattenFieldDescription fd = [fd] - --- ------------------------------------------------------------ --- * Implementation of editing --- ------------------------------------------------------------ - --- --- | Function to construct a field description --- -mkField :: Eq beta => MkFieldDescription alpha beta -mkField parameters getter setter editor = - FD parameters - (\ dat -> do - noti <- emptyNotifier - (widget,inj,ext) <- editor parameters noti - let pext = (\a -> do - b <- ext - case b of - Just b -> return (Just (setter b a)) - Nothing -> return Nothing) - registerEvent noti FocusOut (Left (\e -> do - let name = eventPaneName e - e2 <- ext - when (isNothing e2) $ do - md <- messageDialogNew Nothing [] MessageWarning ButtonsClose - $ "The field " ++ name ++ " has an invalid value " - dialogRun md - widgetDestroy md - return (e{gtkReturn=False}))) - inj (getter dat) - return (widget, - (\a -> inj (getter a)), - pext, - noti)) - --- | Function to construct an editor --- -mkEditor :: (Container -> Injector alpha) -> Extractor alpha -> Editor alpha -mkEditor injectorC extractor parameters notifier = do - let (xalign, yalign, xscale, yscale) = getParameter paraOuterAlignment parameters - outerAlig <- alignmentNew xalign yalign xscale yscale - let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraOuterPadding parameters - alignmentSetPadding outerAlig paddingTop paddingBottom paddingLeft paddingRight - frame <- frameNew - frameSetShadowType frame (getParameter paraShadow parameters) - case getParameter paraName parameters of - "" -> return () - str -> frameSetLabel frame str - containerAdd outerAlig frame - let (xalign, yalign, xscale, yscale) = getParameter paraInnerAlignment parameters - innerAlig <- alignmentNew xalign yalign xscale yscale - let (paddingTop, paddingBottom, paddingLeft, paddingRight) = getParameter paraInnerPadding parameters - alignmentSetPadding innerAlig paddingTop paddingBottom paddingLeft paddingRight - containerAdd frame innerAlig - let (x,y) = getParameter paraMinSize parameters - widgetSetSizeRequest outerAlig x y - let name = getParameter paraName parameters - widgetSetName outerAlig name - let build = injectorC (castToContainer innerAlig) - return (castToWidget outerAlig, build, extractor) - --- | Convenience method to validate and extract fields --- -extractAndValidate :: alpha -> [alpha -> Extractor alpha] -> [String] -> IO (Maybe alpha) -extractAndValidate val getExts fieldNames = do - (newVal,errors) <- foldM (\ (val,errs) (ext,fn) -> do - extVal <- ext val - case extVal of - Just nval -> return (nval,errs) - Nothing -> return (val, (' ' : fn) : errs)) - (val,[]) (zip getExts fieldNames) - if null errors - then return (Just newVal) - else do - md <- messageDialogNew Nothing [] MessageWarning ButtonsClose - $ "The following fields have invalid values." ++ concat (reverse errors) - dialogRun md - widgetDestroy md - return Nothing - -extract :: alpha -> [alpha -> Extractor alpha] -> IO (Maybe alpha) -extract val = - foldM (\ mbVal ext -> - case mbVal of - Nothing -> return Nothing - Just val -> ext val) - (Just val) - --- | get through outerAlignment, frame, innerAlignment -getRealWidget :: Widget -> IO (Maybe Widget) -getRealWidget w = do - mbF <- binGetChild (castToBin w) - case mbF of - Nothing -> return Nothing - Just f -> do - mbIA <- binGetChild (castToBin f) - case mbIA of - Nothing -> return Nothing - Just iA -> binGetChild (castToBin iA) - - - - diff --git a/src/Graphics/UI/Editor/Parameters.hs b/src/Graphics/UI/Editor/Parameters.hs deleted file mode 100644 --- a/src/Graphics/UI/Editor/Parameters.hs +++ /dev/null @@ -1,178 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Graphics.UI.Editor.Parameters --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | Module for parameters for editors --- ------------------------------------------------------------------------------------ - -module Graphics.UI.Editor.Parameters ( - Parameters -, Parameter(..) -, paraName -, paraSynopsis -, paraDirection -, paraShadow -, paraOuterAlignment -, paraInnerAlignment -, paraOuterPadding -, paraInnerPadding -, paraMinSize -, paraHorizontal -, paraStockId -, paraMultiSel -, paraPack - -, getParameter -, getParameterPrim -, (<<<-) -, emptyParams -, Direction(..) -, HorizontalAlign(..) -) where - -import Graphics.UI.Gtk -import Data.Maybe -import qualified Data.List as List - -import IDE.Exception - --- --- | The direction of a split --- -data Direction = Horizontal | Vertical - deriving (Eq,Show) - -data HorizontalAlign = StartHorizontal | StopHorizontal | Keep - deriving (Eq,Show) --- --- | A type for parameters for editors --- -type Parameters = [Parameter] - -data Parameter = ParaName String - | ParaSynopsis String - | ParaDirection Direction - | ParaShadow ShadowType - | ParaOuterAlignment (Float,Float,Float,Float) - -- | xalign yalign xscale yscale - | ParaOuterPadding (Int,Int,Int,Int) - -- | paddingTop paddingBottom paddingLeft paddingRight - | ParaInnerAlignment (Float,Float,Float,Float) - -- | xalign yalign xscale yscale - | ParaInnerPadding (Int,Int,Int,Int) - -- | paddingTop paddingBottom paddingLeft paddingRight - | ParaMinSize (Int, Int) - | ParaHorizontal HorizontalAlign - | ParaStockId String - | ParaMultiSel Bool - | ParaPack Packing - deriving (Eq,Show) - - -{-- #if MIN_VERSION_gtk(0,9,13) - -- now defined in gtk - #else - instance Show ShadowType - where show _ = "Any Shadow" - #endif ---} - -emptyParams :: [Parameter] -emptyParams = [] - -paraName :: (Parameter -> (Maybe String)) -paraName (ParaName str) = Just str -paraName _ = Nothing - -paraSynopsis :: (Parameter -> (Maybe String)) -paraSynopsis (ParaSynopsis str) = Just str -paraSynopsis _ = Nothing - -paraDirection :: (Parameter -> (Maybe Direction)) -paraDirection (ParaDirection d) = Just d -paraDirection _ = Nothing - -paraShadow :: (Parameter -> (Maybe ShadowType)) -paraShadow (ParaShadow d) = Just d -paraShadow _ = Nothing - -paraOuterAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) -paraOuterAlignment (ParaOuterAlignment d) = Just d -paraOuterAlignment _ = Nothing - -paraInnerAlignment :: (Parameter -> (Maybe (Float,Float,Float,Float))) -paraInnerAlignment (ParaInnerAlignment d) = Just d -paraInnerAlignment _ = Nothing - -paraOuterPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) -paraOuterPadding (ParaOuterPadding d) = Just d -paraOuterPadding _ = Nothing - -paraInnerPadding :: (Parameter -> (Maybe (Int,Int,Int,Int))) -paraInnerPadding (ParaInnerPadding d) = Just d -paraInnerPadding _ = Nothing - -paraMinSize :: (Parameter -> (Maybe (Int, Int))) -paraMinSize (ParaMinSize d) = Just d -paraMinSize _ = Nothing - -paraHorizontal :: (Parameter -> (Maybe (HorizontalAlign))) -paraHorizontal (ParaHorizontal d) = Just d -paraHorizontal _ = Nothing - -paraStockId :: (Parameter -> (Maybe String)) -paraStockId (ParaStockId str) = Just str -paraStockId _ = Nothing - -paraMultiSel :: (Parameter -> (Maybe Bool)) -paraMultiSel (ParaMultiSel b) = Just b -paraMultiSel _ = Nothing - -paraPack :: (Parameter -> (Maybe Packing)) -paraPack (ParaPack b) = Just b -paraPack _ = Nothing - --- --- | Convenience method to get a parameter, or if not set the default parameter --- -getParameter :: (Parameter -> (Maybe beta)) -> Parameters -> beta -getParameter selector parameter = - case getParameterPrim selector parameter of - Just ele -> ele - _ -> case getParameterPrim selector defaultParameters of - Just ele -> ele - _ -> throwIDE "default parameter not defined" - -getParameterPrim :: (Parameter -> (Maybe beta)) -> Parameters -> Maybe beta -getParameterPrim selector parameter = - case filter isJust $ map selector parameter of - (Just ele) : _ -> Just ele - _ -> Nothing - -(<<<-) :: (Parameter -> (Maybe beta)) -> Parameter -> Parameters -> Parameters -(<<<-) selector para params = para : filter (isNothing . selector) params - -defaultParameters :: Parameters -defaultParameters = - [ ParaName "" - , ParaStockId "" - , ParaSynopsis "" - , ParaDirection Horizontal - , ParaShadow ShadowNone - , ParaOuterAlignment (0.4, 0.5, 1.0, 0.7) - , ParaOuterPadding (5, 5, 5, 5) - , ParaInnerAlignment (0.4, 0.5, 1.0, 0.7) - , ParaInnerPadding (5, 5, 5, 5) - , ParaMinSize (-1,-1) - , ParaHorizontal Keep - , ParaMultiSel True - , ParaPack PackNatural - ] - diff --git a/src/Graphics/UI/Editor/Simple.hs b/src/Graphics/UI/Editor/Simple.hs deleted file mode 100644 --- a/src/Graphics/UI/Editor/Simple.hs +++ /dev/null @@ -1,689 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Graphics.UI.Editor.Simple --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | Module for making simple editors --- ------------------------------------------------------------------------------------ - -module Graphics.UI.Editor.Simple ( - boolEditor -, boolEditor2 -, clickEditor -, stringEditor -, multilineStringEditor -, intEditor -, genericEditor -, fontEditor -, comboSelectionEditor -, staticListEditor -, staticListMultiEditor -, multiselectionEditor -, fileEditor -, otherEditor -, imageEditor - -, okCancelFields -) where - -import Graphics.UI.Gtk -import qualified Graphics.UI.Gtk as Gtk -import Control.Monad -import Data.IORef -import Data.List -import Data.Maybe -import System.FilePath.Posix - -import Graphics.UI.Editor.Parameters -import Graphics.UI.Editor.Basics -import Graphics.UI.Editor.MakeEditor -import Control.Event -import Graphics.UI.Gtk.Gdk.Events (Event(..)) - --- ------------------------------------------------------------ --- * Simple Editors --- ------------------------------------------------------------ - -instance ContainerClass Widget -instance BinClass Widget -instance ButtonClass Widget - --- --- | Editor for a boolean value in the form of a check button --- -boolEditor :: Editor Bool -boolEditor parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget bool -> do - core <- readIORef coreRef - case core of - Nothing -> do - button <- checkButtonNewWithLabel (getParameter paraName parameters) - widgetSetName button (getParameter paraName parameters) - containerAdd widget button - toggleButtonSetActive button bool - mapM_ (activateEvent (castToWidget button) notifier Nothing) - [Clicked,FocusOut,FocusIn] - writeIORef coreRef (Just button) - Just button -> toggleButtonSetActive button bool) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just button -> do - r <- toggleButtonGetActive button - return (Just r)) - (paraName <<<- ParaName "" $ parameters) - notifier - --- --- | Editor for a boolean value in the form of two radio buttons --- -boolEditor2 :: String -> Editor Bool -boolEditor2 label2 parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget bool -> do - core <- readIORef coreRef - case core of - Nothing -> do - box <- vBoxNew True 2 - radio1 <- radioButtonNewWithLabel (getParameter paraName parameters) - radio2 <- radioButtonNewWithLabelFromWidget radio1 label2 - boxPackStart box radio1 PackGrow 2 - boxPackStart box radio2 PackGrow 2 - widgetSetName radio1 $ getParameter paraName parameters ++ ".1" - widgetSetName radio2 $ getParameter paraName parameters ++ ".2" - containerAdd widget box - if bool - then toggleButtonSetActive radio1 True - else toggleButtonSetActive radio2 True - mapM_ (activateEvent (castToWidget radio1) notifier Nothing) - [Clicked,FocusOut,FocusIn] - mapM_ (activateEvent (castToWidget radio2) notifier Nothing) - [Clicked,FocusOut,FocusIn] - writeIORef coreRef (Just (radio1,radio2)) - Just (radio1,radio2) -> - if bool - then toggleButtonSetActive radio1 True - else toggleButtonSetActive radio2 True) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (radio1,radio2) -> do - r <- toggleButtonGetActive radio1 - return (Just r)) - (paraName <<<- ParaName "" $ parameters) - notifier - --- | An Editor for nothing (which may report a click) in the form of a button --- -clickEditor :: Editor () -clickEditor parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget bool -> do - core <- readIORef coreRef - case core of - Nothing -> do - button <- case getParameter paraStockId parameters of - "" -> buttonNewWithLabel (getParameter paraName parameters) - st -> buttonNewFromStock st - widgetSetName button (getParameter paraName parameters) - containerAdd widget button - activateEvent (castToWidget button) notifier Nothing Clicked - writeIORef coreRef (Just button) - Just button -> return ()) - (return (Just ())) - (paraName <<<- ParaName "" $ parameters) - notifier - --- | An Editor to display an image --- -imageEditor :: Editor StockId -imageEditor parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget stockId -> do - core <- readIORef coreRef - case core of - Nothing -> do - image <- imageNewFromStock stockId IconSizeLargeToolbar - widgetSetName image (getParameter paraName parameters) - containerAdd widget image - writeIORef coreRef (Just (image,stockId)) - Just (image,stockId2) -> imageSetFromStock image stockId IconSizeLargeToolbar) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (_,stockId3) -> return (Just stockId3)) - parameters - notifier - --- --- | Editor for a string in the form of a text entry --- -stringEditor :: (String -> Bool) -> Editor String -stringEditor validation parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget string -> do - core <- readIORef coreRef - case core of - Nothing -> do - entry <- entryNew - widgetSetName entry (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget entry) notifier Nothing) - [FocusOut,FocusIn,AfterKeyRelease] - containerAdd widget entry - entrySetText entry string - writeIORef coreRef (Just entry) - Just entry -> entrySetText entry string) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just entry -> do - r <- entryGetText entry - if validation r - then return (Just r) - else return Nothing) - parameters - notifier - --- --- | Editor for a multiline string in the form of a multiline text entry --- -multilineStringEditor :: Editor String -multilineStringEditor parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget string -> do - core <- readIORef coreRef - case core of - Nothing -> do - aTextView <- textViewNew - widgetSetName aTextView (getParameter paraName parameters) - aScrolledWindow <- scrolledWindowNew Nothing Nothing - scrolledWindowSetPolicy aScrolledWindow PolicyAutomatic PolicyAutomatic - containerAdd aScrolledWindow aTextView - containerAdd widget aScrolledWindow - mapM_ (activateEvent (castToWidget aTextView) notifier Nothing) - [ButtonRelease,FocusOut,FocusIn] - buffer <- textViewGetBuffer aTextView - textBufferSetText buffer string - writeIORef coreRef (Just (aScrolledWindow,aTextView)) - Just (aScrolledWindow,aTextView) -> do - buffer <- textViewGetBuffer aTextView - textBufferSetText buffer string) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (aScrolledWindow, aTextView) -> do - buffer <- textViewGetBuffer aTextView - start <- textBufferGetStartIter buffer - end <- textBufferGetEndIter buffer - r <- textBufferGetText buffer start end False - return (Just r)) - parameters - notifier - --- --- | Editor for an integer in the form of a spin entry --- -intEditor :: (Double,Double,Double) -> Editor Int -intEditor (min, max, step) parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget v -> do - core <- readIORef coreRef - case core of - Nothing -> do - spin <- spinButtonNewWithRange min max step - widgetSetName spin (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget spin) notifier Nothing) - [FocusOut,FocusIn] - containerAdd widget spin - spinButtonSetValue spin (fromIntegral v) - writeIORef coreRef (Just spin) - Just spin -> spinButtonSetValue spin (fromIntegral v)) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just spin -> do - newNum <- spinButtonGetValue spin - return (Just (truncate newNum))) - parameters - notifier - --- --- | Editor for for any value which is an instance of Read and Show in the form of a --- | text entry -genericEditor :: (Show beta, Read beta) => Editor beta -genericEditor parameters notifier = do - (wid,inj,ext) <- stringEditor (const True) parameters notifier - let ginj = inj . show - let gext = do - s <- ext - case s of - Nothing -> return Nothing - Just s -> catch (liftM Just (readIO s)) - (\e -> do - putStrLn ("Generic editor no parse for " ++ s ++ " " ++ show e) - return Nothing) - return (wid,ginj,gext) - --- --- | Editor for no value, it only emtis a clicked event and has the form of a check button --- -buttonEditor :: Editor () -buttonEditor parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget _ -> do - core <- readIORef coreRef - case core of - Nothing -> do - button <- buttonNewWithLabel (getParameter paraName parameters) - widgetSetName button (getParameter paraName parameters) - containerAdd widget button - mapM_ (activateEvent (castToWidget button) notifier Nothing) - [Clicked,FocusIn] - writeIORef coreRef (Just button) - Just button -> return ()) - (return (Just ())) - parameters - notifier - --- --- | Editor for the selection of some element from a static list of elements in the --- | form of a combo box - -comboSelectionEditor :: Eq beta => [beta] -> (beta -> String) -> Editor beta -comboSelectionEditor list showF parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget obj -> do - core <- readIORef coreRef - case core of - Nothing -> do - combo <- comboBoxNewText - mapM_ (\o -> comboBoxAppendText combo (showF o)) list - widgetSetName combo (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget combo) notifier Nothing) - [FocusOut,FocusIn] - comboBoxSetActive combo 1 - containerAdd widget combo - let ind = elemIndex obj list - case ind of - Just i -> comboBoxSetActive combo i - Nothing -> return () - writeIORef coreRef (Just combo) - Just combo -> do - let ind = elemIndex obj list - case ind of - Just i -> comboBoxSetActive combo i - Nothing -> return ()) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just combo -> do - ind <- comboBoxGetActive combo - case ind of - (-1) -> return Nothing - otherwise -> return (Just (list !! ind))) - parameters - notifier - --- --- | Editor for the selection of some elements from a list of elements in the --- | form of a list box -multiselectionEditor :: (Show beta, Eq beta) => Editor [beta] -multiselectionEditor parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget objs -> do - core <- readIORef coreRef - case core of - Nothing -> do - listStore <- listStoreNew ([]:: [alpha]) - listView <- treeViewNewWithModel listStore - widgetSetName listView (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget listView) notifier Nothing) - [FocusOut,FocusIn] - sel <- treeViewGetSelection listView - treeSelectionSetMode sel SelectionMultiple - renderer <- cellRendererTextNew - col <- treeViewColumnNew - treeViewAppendColumn listView col - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer listStore - $ \row -> [ cellText := show row ] - treeViewSetHeadersVisible listView False - listStoreClear listStore - mapM_ (listStoreAppend listStore) objs - containerAdd widget listView - treeSelectionUnselectAll sel - --let inds = catMaybes $map (\obj -> elemIndex obj list) objs - --mapM_ (\i -> treeSelectionSelectPath sel [i]) inds - writeIORef coreRef (Just (listView,listStore)) - Just (listView,listStore) -> do - listStoreClear listStore - mapM_ (listStoreAppend listStore) objs) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (listView,listStore) -> do - sel <- treeViewGetSelection listView - treePath <- treeSelectionGetSelectedRows sel - values <- mapM (\[i] -> listStoreGetValue listStore i) treePath - return (Just values)) - parameters - notifier - --- --- | Editor for the selection of some elements from a static list of elements in the --- | form of a list box with toggle elements - -staticListMultiEditor :: (Eq beta) => [beta] -> (beta -> String) -> Editor [beta] -staticListMultiEditor list showF parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget objs -> do - core <- readIORef coreRef - case core of - Nothing -> do - listStore <- listStoreNew ([]:: [(Bool,beta)]) - listView <- treeViewNewWithModel listStore - widgetSetName listView (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget listView) notifier Nothing) - [FocusOut,FocusIn] - sel <- treeViewGetSelection listView - treeSelectionSetMode sel SelectionSingle - rendererToggle <- cellRendererToggleNew - set rendererToggle [cellToggleActivatable := True] - rendererText <- cellRendererTextNew - col1 <- treeViewColumnNew - treeViewAppendColumn listView col1 - cellLayoutPackStart col1 rendererToggle True - cellLayoutSetAttributes col1 rendererToggle listStore - $ \row -> [ cellToggleActive := fst row] - col2 <- treeViewColumnNew - treeViewAppendColumn listView col2 - cellLayoutPackStart col2 rendererText True - cellLayoutSetAttributes col2 rendererText listStore - $ \row -> [ cellText := showF (snd row)] - treeViewSetHeadersVisible listView False - listStoreClear listStore - mapM_ (listStoreAppend listStore) $ map (\e -> (elem e objs,e)) list - let minSize = getParameter paraMinSize parameters - uncurry (widgetSetSizeRequest listView) minSize - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw listView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - containerAdd widget sw - -- update the model when the toggle buttons are activated - on rendererToggle cellToggled $ \pathStr -> do - let (i:_) = stringToTreePath pathStr - val <- listStoreGetValue listStore i - listStoreSetValue listStore i (not (fst val),snd val) - listView `onKeyPress` (\event -> do - let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event - case (name, modifier, char) of - ("Return", _, _) -> do - sel <- treeViewGetSelection listView - rows <- treeSelectionGetSelectedRows sel - mapM_ (\ (i:_) -> do - val <- listStoreGetValue listStore i - listStoreSetValue listStore i (not (fst val),snd val)) rows - return True - _ -> return False) - writeIORef coreRef (Just (listView,listStore)) - Just (listView,listStore) -> do - let model = map (\e -> (elem e objs,e)) list - listStoreClear listStore - mapM_ (listStoreAppend listStore) $ map (\e -> (elem e objs,e)) list) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (listView,listStore) -> do - model <- listStoreToList listStore - return (Just (map snd $ filter (\e -> fst e) model))) - parameters - notifier - --- --- | Editor for the selection of some elements from a static list of elements in the --- | form of a list box - -staticListEditor :: (Eq beta) => [beta] -> (beta -> String) -> Editor beta -staticListEditor list showF parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget obj -> do - core <- readIORef coreRef - case core of - Nothing -> do - listStore <- listStoreNew ([]:: [alpha]) - listView <- treeViewNewWithModel listStore - widgetSetName listView (getParameter paraName parameters) - mapM_ (activateEvent (castToWidget listView) notifier Nothing) - [FocusOut,FocusIn] - sel <- treeViewGetSelection listView - treeSelectionSetMode sel - (case getParameter paraMultiSel parameters of - True -> SelectionMultiple - False -> SelectionSingle) - renderer <- cellRendererTextNew - col <- treeViewColumnNew - treeViewAppendColumn listView col - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer listStore - $ \row -> [ cellText := showF row ] - treeViewSetHeadersVisible listView False - listStoreClear listStore - mapM_ (listStoreAppend listStore) list - let minSize = getParameter paraMinSize parameters - uncurry (widgetSetSizeRequest listView) minSize - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw listView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - containerAdd widget sw - treeSelectionUnselectAll sel - let mbInd = elemIndex obj list - case mbInd of - Nothing -> return () - Just ind -> treeSelectionSelectPath sel [ind] - writeIORef coreRef (Just listView) - Just listView -> do - sel <- treeViewGetSelection listView - treeSelectionUnselectAll sel - let mbInd = elemIndex obj list - case mbInd of - Nothing -> return () - Just ind -> treeSelectionSelectPath sel [ind]) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just listView -> do - sel <- treeViewGetSelection listView - treePaths <- treeSelectionGetSelectedRows sel - case treePaths of - [[i]] -> return (Just (list !! i)) - _ -> return Nothing) - parameters - notifier - - --- --- | Editor for the selection of a file path in the form of a text entry and a button, --- | which opens a gtk file chooser -fileEditor :: Maybe FilePath -> FileChooserAction -> String -> Editor FilePath -fileEditor mbFilePath action buttonName parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget filePath -> do - core <- readIORef coreRef - case core of - Nothing -> do - button <- buttonNewWithLabel buttonName - widgetSetName button $ getParameter paraName parameters ++ "-button" - mapM_ (activateEvent (castToWidget button) notifier Nothing) - [FocusOut,FocusIn,Clicked] - entry <- entryNew - widgetSetName entry $ getParameter paraName parameters ++ "-entry" - -- set entry [ entryEditable := False ] - mapM_ (activateEvent (castToWidget entry) notifier Nothing) - [FocusOut,FocusIn] - registerEvent notifier Clicked (Left (buttonHandler entry)) - box <- case getParameter paraDirection parameters of - Horizontal -> do - r <- hBoxNew False 1 - return (castToBox r) - Vertical -> do - r <- vBoxNew False 1 - return (castToBox r) - boxPackStart box entry PackGrow 0 - boxPackEnd box button PackNatural 0 - containerAdd widget box - entrySetText entry filePath - writeIORef coreRef (Just entry) - Just entry -> entrySetText entry filePath) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just entry -> do - str <- entryGetText entry - return (Just str)) - parameters - notifier - where - buttonHandler entry e = do - mbFileName <- do - dialog <- fileChooserDialogNew - (Just "Select File") - Nothing - action - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-open" - ,ResponseAccept)] - widgetShow dialog - response <- dialogRun dialog - case response of - ResponseAccept -> do - f <- fileChooserGetFilename dialog - widgetDestroy dialog - return f - ResponseCancel -> do - widgetDestroy dialog - return Nothing - ResponseDeleteEvent-> do - widgetDestroy dialog - return Nothing - _ -> return Nothing - case mbFileName of - Nothing -> return (e{gtkReturn=True}) - Just fn -> do - let relative = case mbFilePath of - Nothing -> fn - Just rel -> makeRelative rel fn - entrySetText entry relative --- triggerEvent notifier SelectionChanged... - return (e{gtkReturn=True}) - --- --- | Editor for a font selection --- -fontEditor :: Editor (Maybe String) -fontEditor parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget mbValue -> do - core <- readIORef coreRef - case core of - Nothing -> do - fs <- fontButtonNew - widgetSetName fs $ getParameter paraName parameters - mapM_ (activateEvent (castToWidget fs) notifier Nothing) - [FocusOut,FocusIn,Clicked] - containerAdd widget fs - case mbValue of - Nothing -> return True - Just s -> fontButtonSetFontName fs s - writeIORef coreRef (Just fs) - Just fs -> case mbValue of - Nothing -> return () - Just s -> do - fontButtonSetFontName fs s - return ()) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just fs -> do - f <- fontButtonGetFontName fs - return (Just (Just f))) - parameters - notifier - --- --- | An editor, which opens another editor --- You have to inject a value before the button can be clicked. --- -otherEditor :: (alpha -> String -> IO (Maybe alpha)) -> Editor alpha -otherEditor func parameters notifier = do - coreRef <- newIORef Nothing - mkEditor - (\widget val -> do - core <- readIORef coreRef - case core of - Nothing -> do - button <- buttonNewWithLabel (getParameter paraName parameters) - widgetSetName button $ getParameter paraName parameters - containerAdd widget button - mapM_ (activateEvent (castToWidget button) notifier Nothing) - [FocusOut,FocusIn,Clicked] - registerEvent notifier Clicked (Left (buttonHandler coreRef)) - writeIORef coreRef (Just (button,val)) - Just (button, oldval) -> writeIORef coreRef (Just (button, val))) - (do core <- readIORef coreRef - case core of - Nothing -> return Nothing - Just (_,val) -> return (Just val)) - (paraName <<<- ParaName "" $ parameters) - notifier - where - buttonHandler coreRef e = do - core <- readIORef coreRef - case core of - Nothing -> error "You have to inject a value before the button can be clicked" - Just (b,val) -> do - res <- func val (getParameter paraName parameters) - case res of - Nothing -> return (e{gtkReturn=True}) - Just nval -> do - writeIORef coreRef (Just (b, nval)) - return (e{gtkReturn=True}) - -okCancelFields :: FieldDescription () -okCancelFields = HFD emptyParams [ - mkField - (paraStockId <<<- ParaStockId stockOk - $ paraName <<<- ParaName "Ok" - $ emptyParams) - (const ()) - (\ a b -> b) - clickEditor - , mkField - (paraStockId <<<- ParaStockId stockCancel - $ paraName <<<- ParaName "Cancel" - $ emptyParams) - (const ()) - (\ _ b -> b) - clickEditor] - diff --git a/src/Graphics/UI/Frame/Panes.hs b/src/Graphics/UI/Frame/Panes.hs deleted file mode 100644 --- a/src/Graphics/UI/Frame/Panes.hs +++ /dev/null @@ -1,161 +0,0 @@ -{-# OPTIONS_GHC - -XExistentialQuantification - -XMultiParamTypeClasses - -XFunctionalDependencies - -XNoMonomorphismRestriction #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Core.Panes --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional21 --- Portability : portable --- --- | The basic definitions for all panes --- -------------------------------------------------------------------------------- - -module Graphics.UI.Frame.Panes ( - --- * Panes and pane layout - PaneMonad(..) -, Pane(..) -, IDEPane(..) -, RecoverablePane(..) -, PaneDirection(..) -, PanePathElement(..) -, PanePath -, PaneLayout(..) -, PaneName -, Connection(..) -, Connections -, StandardPath -, FrameState(..) -, signalDisconnectAll -) where - -import Graphics.UI.Gtk hiding (get) -import System.Glib.GObject -import System.Glib.Signals -import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Typeable -import Control.Monad.Trans - --- --------------------------------------------------------------------- --- Panes and pane layout --- - --- --- | A path to a pane --- -type PanePath = [PanePathElement] - --- --- | An element of a path to a pane --- -data PanePathElement = SplitP PaneDirection | GroupP String - deriving (Eq,Show,Read) - --- --- | The relative direction to a pane from the parent --- -data PaneDirection = TopP | BottomP | LeftP | RightP - deriving (Eq,Show,Read) - --- --- | Description of a window layout --- Horizontal: top bottom Vertical: left right --- -data PaneLayout = HorizontalP PaneLayout PaneLayout Int - | VerticalP PaneLayout PaneLayout Int - | TerminalP { - paneGroups :: Map String PaneLayout - , paneTabs :: Maybe PaneDirection - , currentPage :: Int - , detachedId :: Maybe String - , detachedSize :: Maybe (Int, Int) } - deriving (Eq,Show,Read) - --- --- | All kinds of panes are instances of pane --- - -class (Typeable alpha, PaneMonad beta) => Pane alpha beta | alpha -> beta where - paneName :: alpha -> PaneName - paneName b = if getAddedIndex b == 0 - then primPaneName b - else primPaneName b ++ "(" ++ show (getAddedIndex b) ++ ")" - primPaneName :: alpha -> String - getAddedIndex :: alpha -> Int - getAddedIndex _ = 0 - getTopWidget :: alpha -> Widget - paneId :: alpha -> String - makeActive :: alpha -> beta () - close :: alpha -> beta Bool - -class (Pane alpha delta, Read beta, Show beta, Typeable beta, PaneMonad delta) - => RecoverablePane alpha beta delta | beta -> alpha, alpha -> beta where - saveState :: alpha -> delta (Maybe beta) - recoverState :: PanePath -> beta -> delta () - -type PaneName = String - -data IDEPane delta = forall alpha beta. (RecoverablePane alpha beta delta) => PaneC alpha - -instance Eq (IDEPane delta) where - (==) (PaneC x) (PaneC y) = paneName x == paneName y - -instance Ord (IDEPane delta) where - (<=) (PaneC x) (PaneC y) = paneName x <= paneName y - -instance Show (IDEPane delta) where - show (PaneC x) = "Pane " ++ paneName x - -type StandardPath = PanePath - -data FrameState delta = FrameState { - windows :: [Window] -, uiManager :: UIManager -, panes :: Map PaneName (IDEPane delta) -, paneMap :: (Map PaneName (PanePath, Connections)) -, activePane :: Maybe (PaneName, Connections) -, panePathFromNB :: Map Notebook PanePath -, layout :: PaneLayout} - -class MonadIO delta => PaneMonad delta where - setFrameState :: FrameState delta -> delta () - getFrameState :: delta (FrameState delta) - runInIO :: forall alpha beta. (beta -> delta alpha) -> delta (beta -> IO alpha) - panePathForGroup:: String -> delta PanePath - --- --- | Signal handlers for the different pane types --- -data Connection = forall alpha . GObjectClass alpha => ConnectC (ConnectId alpha) - -type Connections = [Connection] - -signalDisconnectAll :: Connections -> IO () -signalDisconnectAll = mapM_ (\ (ConnectC s) -> signalDisconnect s) - - --- Necessary with pre 10.1 verion of gtk2hs - -#ifdef MIN_VERSION_gtk -#if MIN_VERSION_gtk(0,10,1) -#else -instance Eq Notebook - where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) - in pa == pb -instance Ord Notebook - where (<=) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) - in pa <= pb -instance Eq Window - where (==) a b = let (GObject pa, GObject pb) = (toGObject a, toGObject b) - in pa == pb -#endif -#endif diff --git a/src/Graphics/UI/Frame/ViewFrame.hs b/src/Graphics/UI/Frame/ViewFrame.hs deleted file mode 100644 --- a/src/Graphics/UI/Frame/ViewFrame.hs +++ /dev/null @@ -1,1360 +0,0 @@ -{-# OPTIONS_GHC - -XFunctionalDependencies - -XNoMonomorphismRestriction - -XFlexibleInstances - -XMultiParamTypeClasses - -XUndecidableInstances - -XDeriveDataTypeable #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Core.ViewFrame --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- --- | Splittable panes containing notebooks with any widgets --- ---------------------------------------------------------------------------------- - -module Graphics.UI.Frame.ViewFrame ( - removePaneAdmin -, addPaneAdmin -, notebookInsertOrdered -, markLabel - --- * Convenience methods for accesing Pane state -, posTypeToPaneDirection -, paneDirectionToPosType -, paneFromName -, mbPaneFromName -, guiPropertiesFromName - --- * View Actions -, viewMove -, viewSplitHorizontal -, viewSplitVertical -, viewSplit -, viewSplit' -, viewNewGroup -, newGroupOrBringToFront -, bringGroupToFront -, viewNest -, viewNest' -, viewDetach -, viewDetach' -, handleNotebookSwitch -, viewCollapse -, viewCollapse' -, viewTabsPos -, viewSwitchTabs - --- * View Queries -, getBestPanePath -, getBestPathForId -, getActivePanePath -, getActivePanePathOrStandard -, figureOutPaneName -, getNotebook -, getPaned -, getActiveNotebook -, getActivePane -, setActivePane -, getUiManager -, getWindows -, getMainWindow -, getLayout -, getPanesSt -, getPaneMapSt -, getPane -, getPanes - --- * View Actions -, bringPaneToFront -, newNotebook -, newNotebook' - --- * Accessing GUI elements ---, widgetFromPath -, getUIAction -, widgetGet - - -) where - -import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite) -import Control.Monad.Reader -import qualified Data.Map as Map -import Data.List -import Data.Maybe -import Data.Unique -import Data.Typeable - -import Graphics.UI.Frame.Panes -import Graphics.UI.Editor.Parameters -import System.Glib (isA) -import Graphics.UI.Gtk.Types (gTypeNotebook) -import System.CPUTime (getCPUTime) -import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) -import MyMissing -import Graphics.UI.Gtk.Gdk.EventM (TimeStamp(..)) -import Graphics.UI.Editor.MakeEditor - (mkField, FieldDescription(..), buildEditor) -import Graphics.UI.Editor.Simple (stringEditor, okCancelFields) -import Control.Event (registerEvent) -import Graphics.UI.Editor.Basics - (eventPaneName, GUIEventSelector(..)) -import qualified Data.Set as Set (unions, member) -import Data.Set (Set(..)) -import Graphics.UI.Gtk.Gdk.Events (Event(..)) --- import Debug.Trace (trace) -trace a b = b - -removePaneAdmin :: Pane alpha beta => alpha -> beta () -removePaneAdmin pane = do - panes' <- getPanesSt - paneMap' <- getPaneMapSt - setPanesSt (Map.delete (paneName pane) panes') - setPaneMapSt (Map.delete (paneName pane) paneMap') - -addPaneAdmin :: RecoverablePane alpha beta delta => alpha -> Connections -> PanePath -> delta () -addPaneAdmin pane conn pp = do - panes' <- getPanesSt - paneMap' <- getPaneMapSt - unique <- liftIO newUnique - liftIO $ widgetSetName (getTopWidget pane) (paneName pane) - trace ("addPaneAdmin name: " ++ paneName pane ++ " path: " ++ show pp) $ - setPaneMapSt (Map.insert (paneName pane) (pp, conn) paneMap') - setPanesSt (Map.insert (paneName pane) (PaneC pane) panes') - -getPane :: RecoverablePane alpha beta delta => delta (Maybe alpha) -getPane = do - selectedPanes <- getPanes - if null selectedPanes || length selectedPanes > 1 - then return Nothing - else (return (Just $ head selectedPanes)) - -getPanes :: RecoverablePane alpha beta delta => delta ([alpha]) -getPanes = do - panes' <- getPanesSt - return (catMaybes - $ map (\(PaneC p) -> cast p) - $ Map.elems panes') - -notebookInsertOrdered :: PaneMonad alpha => (NotebookClass self, WidgetClass child) - => self - -> child -- child - the Widget to use as the contents of the page. - -> String - -> Maybe Label -- the label for the page as String or Label - -> alpha () -notebookInsertOrdered nb widget labelStr mbLabel = do - label <- case mbLabel of - Nothing -> liftIO $ labelNew (Just labelStr) - Just l -> return l - menuLabel <- liftIO $ labelNew (Just labelStr) - numPages <- liftIO $ notebookGetNPages nb - mbWidgets <- liftIO $ mapM (notebookGetNthPage nb) [0 .. (numPages-1)] - -- trace ("numPages " ++ show numPages) $ - - let widgets = map (\v -> forceJust v "ViewFrame.notebookInsertOrdered: no widget") mbWidgets - labelStrs <- liftIO $ mapM (widgetGetName) widgets - let pos = case findIndex (\s -> s > labelStr) labelStrs of - Just i -> i - Nothing -> -1 - labelBox <- mkLabelBox label labelStr - liftIO $ do - markLabel nb labelBox False - realPos <- notebookInsertPageMenu nb widget labelBox menuLabel pos - widgetShowAll labelBox - notebookSetCurrentPage nb realPos - --- | Returns a label box -mkLabelBox :: PaneMonad alpha => Label -> String -> alpha EventBox -mkLabelBox lbl paneName = do - (tb,lb) <- liftIO $ do - miscSetAlignment (castToMisc lbl) 0.0 0.0 - miscSetPadding (castToMisc lbl) 0 0 - - labelBox <- eventBoxNew - eventBoxSetVisibleWindow labelBox False - innerBox <- hBoxNew False 0 - - tabButton <- buttonNew - widgetSetName tabButton "leksah-close-button" - buttonSetFocusOnClick tabButton False - buttonSetRelief tabButton ReliefNone - buttonSetAlignment tabButton (0.0,0.0) - - image <- imageNewFromStock stockClose IconSizeMenu - mbPB <- widgetRenderIcon tabButton stockClose IconSizeMenu "" - (height,width) <- case mbPB of - Nothing -> trace "no real size" return (14,14) - Just pb -> do - h <- pixbufGetHeight pb - w <- pixbufGetWidth pb - return (h,w) - on tabButton styleSet (\style -> do - widgetSetSizeRequest tabButton (height + 2) (width + 2)) - containerSetBorderWidth tabButton 0 - containerAdd tabButton image - - boxPackStart innerBox lbl PackNatural 0 - boxPackEnd innerBox tabButton PackNatural 0 - - containerAdd labelBox innerBox - dragSourceSet labelBox [Button1] [ActionCopy,ActionMove] - tl <- targetListNew - targetListAddTextTargets tl 0 - dragSourceSetTargetList labelBox tl - on labelBox dragDataGet (\ cont id timeStamp -> do - selectionDataSetText paneName - trace ("DragGet data: " ++ paneName) $ return ()) - return (tabButton,labelBox) - cl <- runInIO closeHandler - liftIO $ onClicked tb (cl ()) - - return lb - where - closeHandler :: PaneMonad alpha => () -> alpha () - closeHandler _ = case "group_" `stripPrefix` paneName of - Just group -> do - closeGroup group - Nothing -> do - (PaneC pane) <- paneFromName paneName - close pane - return () - --- | Add the change mark or removes it -markLabel :: (WidgetClass alpha, NotebookClass beta) => beta -> alpha -> Bool -> IO () -markLabel nb topWidget modified = do - mbBox <- notebookGetTabLabel nb topWidget - case mbBox of - Nothing -> return () - Just box -> do - mbContainer <- binGetChild (castToBin box) - case mbContainer of - Nothing -> return () - Just container -> do - children <- containerGetChildren container - let label = castToLabel $ forceHead children "ViewFrame>>markLabel: empty children" - text <- widgetGetName topWidget - labelSetUseMarkup (castToLabel label) True - labelSetMarkup (castToLabel label) - (if modified - then "" ++ text ++ "" - else text) - --- | Constructs a unique pane name, which is an index and a string -figureOutPaneName :: PaneMonad alpha => String -> Int -> alpha (Int,String) -figureOutPaneName bn ind = do - bufs <- getPanesSt - let ind = foldr (\(PaneC buf) ind -> - if primPaneName buf == bn - then max ind ((getAddedIndex buf) + 1) - else ind) - 0 (Map.elems bufs) - if ind == 0 - then return (0,bn) - else return (ind,bn ++ "(" ++ show ind ++ ")") - -paneFromName :: PaneMonad alpha => PaneName -> alpha (IDEPane alpha) -paneFromName pn = do - mbPane <- mbPaneFromName pn - case mbPane of - Just p -> return p - Nothing -> error $ "ViewFrame>>paneFromName:Can't find pane from unique name " ++ pn - -mbPaneFromName :: PaneMonad alpha => PaneName -> alpha (Maybe (IDEPane alpha)) -mbPaneFromName pn = do - panes <- getPanesSt - return (Map.lookup pn panes) - --- | -guiPropertiesFromName :: PaneMonad alpha => PaneName -> alpha (PanePath, Connections) -guiPropertiesFromName pn = do - paneMap <- getPaneMapSt - case Map.lookup pn paneMap of - Just it -> return it - otherwise -> error $"Cant't find guiProperties from unique name " ++ pn - -posTypeToPaneDirection PosLeft = LeftP -posTypeToPaneDirection PosRight = RightP -posTypeToPaneDirection PosTop = TopP -posTypeToPaneDirection PosBottom = BottomP - -paneDirectionToPosType LeftP = PosLeft -paneDirectionToPosType RightP = PosRight -paneDirectionToPosType TopP = PosTop -paneDirectionToPosType BottomP = PosBottom - --- --- | Toggle the tabs of the current notebook --- -viewSwitchTabs :: PaneMonad alpha => alpha () -viewSwitchTabs = do - mbNb <- getActiveNotebook - case mbNb of - Nothing -> return () - Just nb -> liftIO $ do - b <- notebookGetShowTabs nb - notebookSetShowTabs nb (not b) - --- --- | Sets the tab position in the current notebook --- -viewTabsPos :: PaneMonad alpha => PositionType -> alpha () -viewTabsPos pos = do - mbNb <- getActiveNotebook - case mbNb of - Nothing -> return () - Just nb -> liftIO $notebookSetTabPos nb pos - --- --- | Split the currently active pane in horizontal direction --- -viewSplitHorizontal :: PaneMonad alpha => alpha () -viewSplitHorizontal = viewSplit Horizontal - --- --- | Split the currently active pane in vertical direction --- -viewSplitVertical :: PaneMonad alpha => alpha () -viewSplitVertical = viewSplit Vertical - --- --- | The active view can be split in two (horizontal or vertical) --- -viewSplit :: PaneMonad alpha => Direction -> alpha () -viewSplit dir = do - mbPanePath <- getActivePanePath - case mbPanePath of - Nothing -> return () - Just panePath -> do - viewSplit' panePath dir - -viewSplit' :: PaneMonad alpha => PanePath -> Direction -> alpha () -viewSplit' panePath dir = do - l <- getLayout - case layoutFromPath panePath l of - (TerminalP _ _ _ (Just _) _) -> trace ("ViewFrame>>viewSplit': can't split detached: ") - return () - _ -> do - activeNotebook <- getNotebook panePath - mbPD <- do - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> trace ("ViewFrame>>viewSplit': parent not found: ") return Nothing - Just parent -> do - (nb,paneDir) <- do - let (name,altname,paneDir, - oldPath,newPath) = case dir of - Horizontal -> ("top", - "bottom", - TopP, - panePath ++ [SplitP TopP], - panePath ++ [SplitP BottomP]) - Vertical -> ("left", - "right", - LeftP, - panePath ++ [SplitP LeftP], - panePath ++ [SplitP RightP]) - nb <- newNotebook newPath - st <- getFrameState - setFrameState st{panePathFromNB = Map.insert activeNotebook oldPath (panePathFromNB st)} - (np,nbi) <- liftIO $ do - newpane <- case dir of - Horizontal -> do h <- vPanedNew - return (castToPaned h) - Vertical -> do v <- hPanedNew - return (castToPaned v) - rName <- widgetGetName activeNotebook - widgetSetName newpane rName - widgetSetName nb altname - panedPack2 newpane nb True True - nbIndex <- if parent `isA` gTypeNotebook - then notebookPageNum (castToNotebook parent) activeNotebook - else trace ("ViewFrame>>viewSplit': parent not a notebook: ") return Nothing - containerRemove (castToContainer parent) activeNotebook - widgetSetName activeNotebook name - panedPack1 newpane activeNotebook True True - return (newpane,nbIndex) - case (reverse panePath, nbi) of - (SplitP dir:_, _) - | dir `elem` [TopP, LeftP] -> liftIO $ panedPack1 (castToPaned parent) np True True - | otherwise -> liftIO $ panedPack2 (castToPaned parent) np True True - (GroupP group:_, Just n) -> do - liftIO $ notebookInsertPage (castToNotebook parent) np group n - label <- groupLabel group - liftIO $ notebookSetTabLabel (castToNotebook parent) np label - label2 <- groupMenuLabel group - liftIO $ notebookSetMenuLabel (castToNotebook parent) np label2 - return () - ([], _) -> do - liftIO $ boxPackStart (castToBox parent) np PackGrow 0 - liftIO $ boxReorderChild (castToVBox parent) np 2 - _ -> error "No notebook index found in viewSplit" - liftIO $ do - widgetShowAll np - widgetGrabFocus activeNotebook - case nbi of - Just n -> do - notebookSetCurrentPage (castToNotebook parent) n - return () - _ -> trace ("ViewFrame>>viewSplit': parent not a notebook: ")return () - return (nb,paneDir) - handleFunc <- runInIO (handleNotebookSwitch nb) - liftIO $ afterSwitchPage nb handleFunc - return (Just (paneDir,dir)) - case mbPD of - Just (paneDir,pdir) -> do - let toPane = panePath ++ [SplitP paneDir] - adjustPanes panePath toPane - adjustLayoutForSplit paneDir panePath - viewMove (otherDirection paneDir) - Nothing -> return () - -viewNewGroup :: PaneMonad alpha => alpha () -viewNewGroup = do - mainWindow <- getMainWindow - mbGroupName <- liftIO $ groupNameDialog mainWindow - case - mbGroupName of - Just groupName -> do - layout <- getLayoutSt - if groupName `Set.member` allGroupNames layout - then liftIO $ do - md <- messageDialogNew (Just mainWindow) [] MessageWarning ButtonsClose - ("Group name not unique " ++ groupName) - dialogRun md - widgetDestroy md - return () - else viewNest groupName - Nothing -> return () - -newGroupOrBringToFront :: PaneMonad alpha => String -> PanePath -> alpha (Maybe PanePath,Bool) -newGroupOrBringToFront groupName pp = do - layout <- getLayoutSt - if groupName `Set.member` allGroupNames layout - then do - mbPP <- bringGroupToFront groupName - return (mbPP,False) - else let realPath = getBestPanePath pp layout in do - viewNest' realPath groupName - return (Just (realPath ++ [GroupP groupName]),True) - -bringGroupToFront :: PaneMonad alpha => String -> alpha (Maybe PanePath) -bringGroupToFront groupName = do - layout <- getLayoutSt - case findGroupPath groupName layout of - Just path -> do - widget <- getNotebookOrPaned path castToWidget - liftIO $ setCurrentNotebookPages widget - return (Just path) - Nothing -> return Nothing - - --- Yet another stupid little dialog - -groupNameDialog :: Window -> IO (Maybe String) -groupNameDialog parent = liftIO $ do - dia <- dialogNew - windowSetTransientFor dia parent - windowSetTitle dia "Enter group name" - upper <- dialogGetUpper dia - lower <- dialogGetActionArea dia - (widget,inj,ext,_) <- buildEditor moduleFields "" - (widget2,_,_,notifier) <- buildEditor okCancelFields () - registerEvent notifier Clicked (Left (\e -> do - case eventPaneName e of - "Ok" -> dialogResponse dia ResponseOk - _ -> dialogResponse dia ResponseCancel - return e)) - boxPackStart upper widget PackGrow 7 - boxPackStart lower widget2 PackNatural 7 - widgetShowAll dia - resp <- dialogRun dia - value <- ext ("") - widgetDestroy dia - case resp of - ResponseOk | value /= Just "" -> return value - _ -> return Nothing - where - moduleFields :: FieldDescription String - moduleFields = VFD emptyParams [ - mkField - (paraName <<<- ParaName ("New group ") - $ emptyParams) - id - (\ a b -> a) - (stringEditor (\s -> True))] - -viewNest :: PaneMonad alpha => String -> alpha () -viewNest group = do - mbPanePath <- getActivePanePath - case mbPanePath of - Nothing -> return () - Just panePath -> do - viewNest' panePath group - -viewNest' :: PaneMonad alpha => PanePath -> String -> alpha () -viewNest' panePath group = do - activeNotebook <- getNotebook panePath - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> return () - Just parent -> do - layout <- getLayoutSt - let paneLayout = layoutFromPath panePath layout - case paneLayout of - (TerminalP {}) -> do - nb <- newNotebook (panePath ++ [GroupP group]) - liftIO $ do - widgetSetName nb ("group_" ++ group) - notebookAppendPage activeNotebook nb group - label <- groupLabel group - label2 <- groupMenuLabel group - liftIO $ do - notebookSetTabLabel activeNotebook nb label - notebookSetMenuLabel activeNotebook nb label2 - widgetShowAll nb - widgetGrabFocus activeNotebook - return nb - handleFunc <- runInIO (handleNotebookSwitch nb) - liftIO $ afterSwitchPage nb handleFunc - adjustLayoutForNest group panePath - _ -> return () - -closeGroup :: PaneMonad alpha => String -> alpha () -closeGroup groupName = do - layout <- getLayout - let mbPath = findGroupPath groupName layout - mainWindow <- getMainWindow - case mbPath of - Nothing -> trace ("ViewFrame>>closeGroup: Group path not found: " ++ groupName) return () - Just path -> do - panesMap <- getPaneMapSt - let nameAndpathList = filter (\(a,pp) -> path `isPrefixOf` pp) - $ map (\(a,b) -> (a,fst b)) (Map.assocs panesMap) - continue <- case nameAndpathList of - (_:_) -> liftIO $ do - md <- messageDialogNew (Just mainWindow) [] MessageQuestion ButtonsYesNo - ("Group " ++ groupName ++ " not empty. Close with all contents?") - rid <- dialogRun md - widgetDestroy md - case rid of - ResponseYes -> return True - otherwise -> return False - [] -> return True - when continue $ do - panes <- mapM paneFromName $ map fst nameAndpathList - results <- mapM (\ (PaneC p) -> close p) panes - when (foldr (&&) True results) $ do - nbOrPaned <- getNotebookOrPaned path castToWidget - mbParent <- liftIO $ widgetGetParent nbOrPaned - case mbParent of - Nothing -> error "ViewFrame>>closeGroup: closeGroup: no parent" - Just parent -> liftIO $ containerRemove (castToContainer parent) nbOrPaned - setLayoutSt (removeGL path layout) - ppMap <- getPanePathFromNB - setPanePathFromNB (Map.filter (\pa -> path `isPrefixOf` pa) ppMap) - return () - -viewDetach :: PaneMonad alpha => alpha (Maybe (Window,Widget)) -viewDetach = do - id <- liftIO $ fmap show getCPUTime - mbPanePath <- getActivePanePath - case mbPanePath of - Nothing -> return Nothing - Just panePath -> do - viewDetach' panePath id - -viewDetach' :: PaneMonad alpha => PanePath -> String -> alpha (Maybe (Window,Widget)) -viewDetach' panePath id = do - activeNotebook <- getNotebook panePath - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> return Nothing - Just parent -> do - layout <- getLayoutSt - let paneLayout = layoutFromPath panePath layout - case paneLayout of - (TerminalP{detachedSize = size}) -> do - window <- liftIO $ do - window <- windowNew - windowSetTitle window "leksah detached window" - widgetSetName window id - case size of - Just (width, height) -> do - windowSetDefaultSize window width height - Nothing -> do - (curWidth, curHeight) <- widgetGetSize activeNotebook - windowSetDefaultSize window curWidth curHeight - containerRemove (castToContainer parent) activeNotebook - containerAdd window activeNotebook - widgetShowAll window - return window - handleFunc <- runInIO (handleReattach id window) - liftIO $ window `onDelete` handleFunc - windows <- getWindowsSt - setWindowsSt $ windows ++ [window] - adjustLayoutForDetach id panePath - return (Just (window, castToWidget activeNotebook)) - _ -> return Nothing - - - -handleReattach :: PaneMonad alpha => String -> Window -> Event -> alpha Bool -handleReattach windowId window _ = do - layout <- getLayout - case findDetachedPath windowId layout of - Nothing -> trace ("ViewFrame>>handleReattach: panePath for id not found: " ++ windowId) - $ do - windows <- getWindowsSt - setWindowsSt $ delete window windows - return False - Just pp -> do - nb <- getNotebook pp - parent <- getNotebookOrPaned (init pp) castToContainer - liftIO $ containerRemove (castToContainer window) nb - liftIO $ containerAdd parent nb - adjustLayoutForReattach pp - windows <- getWindowsSt - setWindowsSt $ delete window windows - case last pp of - GroupP groupName -> do - label <- groupLabel groupName - liftIO $ notebookSetTabLabel (castToNotebook parent) nb label - otherwise -> return () - return False -- "now destroy the window" - -groupLabel :: PaneMonad beta => String -> beta EventBox -groupLabel group = do - label <- liftIO $ labelNew Nothing - liftIO $ labelSetUseMarkup label True - liftIO $ labelSetMarkup label ("" ++ group ++ "") - labelBox <- mkLabelBox label ("group_" ++ group) - liftIO $ widgetShowAll labelBox - return labelBox - -groupMenuLabel :: PaneMonad beta => String -> beta (Maybe Label) -groupMenuLabel group = liftM Just (liftIO $ labelNew (Just group)) - -handleNotebookSwitch :: PaneMonad beta => Notebook -> Int -> beta () -handleNotebookSwitch nb index = do - mbW <- liftIO $ notebookGetNthPage nb index - case mbW of - Nothing -> error "ViewFrame/handleNotebookSwitch: Can't find widget" - Just w -> do - name <- liftIO $ widgetGetName w - mbPane <- findPaneFor name - case mbPane of - Nothing -> return () -- trace ("ViewFrame>>handleNotebookSwitch: can't find pane " ++ name) - - Just (PaneC p) -> makeActive p -- trace ("ViewFrame>>handleNotebookSwitch: switch to pane " ++ name) - - where - findPaneFor :: PaneMonad beta => String -> beta (Maybe (IDEPane beta)) - findPaneFor n1 = do - panes' <- getPanesSt - foldM (\r (PaneC p) -> do - n2 <- liftIO $ widgetGetName (getTopWidget p) - return (if n1 == n2 then (Just (PaneC p)) else r)) - Nothing (Map.elems panes') - --- --- | Two notebooks can be collapsed to one --- -viewCollapse :: PaneMonad alpha => alpha () -viewCollapse = do - mbPanePath <- getActivePanePath - case mbPanePath of - Nothing -> return () - Just panePath -> do - viewCollapse' panePath - -viewCollapse' :: PaneMonad alpha => PanePath -> alpha () -viewCollapse' panePath = do - trace ("Collapse : " ++ (show panePath)) $ return () - layout1 <- getLayoutSt - case layoutFromPath panePath layout1 of - (TerminalP _ _ _ (Just _) _) -> trace ("ViewFrame>>viewCollapse': can't collapse detached: ") - return () - _ -> do - let newPanePath = init panePath - let mbOtherSidePath = otherSide panePath - case mbOtherSidePath of - Nothing -> return () - Just otherSidePath -> - let sp1 = getGroupPathForCollapse panePath layout1 - sp2 = getGroupPathForCollapse otherSidePath layout1 - in do - case sp1 of - Nothing -> return () - Just sp -> viewCollapse' sp - case sp2 of - Nothing -> return () - Just sp -> viewCollapse' sp - paneMap <- getPaneMapSt - activeNotebook <- getNotebook panePath - st <- getFrameState - otherSideNotebook <- getNotebook otherSidePath - setFrameState st{panePathFromNB = (Map.delete otherSideNotebook - (Map.insert activeNotebook newPanePath (panePathFromNB st)))} - let paneNamesToMove = map (\(w,(p,_)) -> w) - $filter (\(w,(p,_)) -> otherSidePath `isPrefixOf` p) - $Map.toList paneMap - panesToMove <- mapM paneFromName paneNamesToMove - mapM_ (\(PaneC p) -> move panePath p) panesToMove - mbParent <- liftIO $ widgetGetParent activeNotebook - case mbParent of - Nothing -> error "collapse: no parent" - Just parent -> do - mbGrandparent <- liftIO $ widgetGetParent parent - case mbGrandparent of - Nothing -> error "collapse: no grandparent" - Just grandparent -> do - nbIndex <- if grandparent `isA` gTypeNotebook - then liftIO $ notebookPageNum (castToNotebook grandparent) parent - else return Nothing - liftIO $ containerRemove (castToContainer grandparent) parent - liftIO $ containerRemove (castToContainer parent) activeNotebook - if length panePath > 1 - then do - let lasPathElem = last newPanePath - case (lasPathElem, nbIndex) of - (SplitP dir, _) | dir == TopP || dir == LeftP -> - liftIO $ panedPack1 (castToPaned grandparent) activeNotebook True True - (SplitP dir, _) | dir == BottomP || dir == RightP -> - liftIO $ panedPack2 (castToPaned grandparent) activeNotebook True True - (GroupP group, Just n) -> do - liftIO $ notebookInsertPage (castToNotebook grandparent) activeNotebook group n - label <- groupLabel group - liftIO $ do - notebookSetTabLabel (castToNotebook grandparent) activeNotebook label - notebookSetCurrentPage (castToNotebook grandparent) n - return () - _ -> error "collapse: Unable to find page index" - liftIO $ widgetSetName activeNotebook $panePathElementToWidgetName lasPathElem - else liftIO $ do - boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0 - boxReorderChild (castToVBox grandparent) activeNotebook 2 - widgetSetName activeNotebook "root" - adjustPanes panePath newPanePath - adjustPanes otherSidePath newPanePath - adjustLayoutForCollapse panePath - -getGroupPathForCollapse :: PanePath -> PaneLayout -> Maybe PanePath -getGroupPathForCollapse path layout = - case layoutFromPath path layout of - TerminalP {} -> Nothing - HorizontalP _ _ _ -> Just (path ++ [SplitP TopP]) - VerticalP _ _ _ -> Just (path ++ [SplitP LeftP]) - - - --- --- | Moves the activePane in the given direction, if possible --- | If their are many possibilities choose the leftmost and topmost --- -viewMove :: PaneMonad beta => PaneDirection -> beta () -viewMove direction = do - mbPane <- getActivePaneSt - case mbPane of - Nothing -> do - return () - Just (paneName,_) -> do - (PaneC pane) <- paneFromName paneName - mbPanePath <- getActivePanePath - case mbPanePath of - Nothing -> do - return () - Just panePath -> do - layout <- getLayoutSt - case findMoveTarget panePath layout direction of - Nothing -> do - return () - Just moveTo -> move moveTo pane - --- --- | Find the target for a move --- -findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath -findMoveTarget panePath layout direction= - let oppositeDir = otherDirection direction - canMove [] = [] - canMove reversedPath = - case head reversedPath of - SplitP d | d == oppositeDir - -> SplitP direction : (tail reversedPath) - GroupP group -> [] - _ -> canMove (tail reversedPath) - basePath = reverse (canMove $ reverse panePath) - in case basePath of - [] -> Nothing - _ -> let layoutP = layoutFromPath basePath layout - in trace (show basePath) Just $basePath ++ findAppropriate layoutP oppositeDir - -dragMove :: PaneMonad alpha => (PaneName,Notebook) -> alpha () -dragMove (paneName,toNB) = do - paneMap <- getPaneMapSt - panes <- getPanesSt - layout <- getLayout - frameState <- getFrameState - case "group_" `stripPrefix` paneName of - Just group -> do - trace ("dragMove a group Layout before: " ++ show layout) return () - case findGroupPath group layout of - Nothing -> trace ("ViewFrame>>dragMove: group not found: " ++ group) return () - Just fromPath -> do - groupNBOrPaned <- getNotebookOrPaned fromPath castToWidget - fromNB <- getNotebook (init fromPath) - case toNB `Map.lookup` (panePathFromNB frameState) of - Nothing -> trace "ViewFrame>>dragMove: panepath for Notebook not found" return () - Just toPath -> do - when (fromNB /= toNB && not (isPrefixOf fromPath toPath)) $ do - mbNum <- liftIO $ notebookPageNum fromNB groupNBOrPaned - case mbNum of - Nothing -> trace "ViewFrame>>dragMove: group notebook not found" return () - Just num -> do - liftIO $ notebookRemovePage fromNB num - label <- groupLabel group - notebookInsertOrdered toNB groupNBOrPaned group Nothing - liftIO $ notebookSetTabLabel toNB groupNBOrPaned label - adjustPanes fromPath (toPath ++ [GroupP group]) - adjustLayoutForGroupMove fromPath toPath group - adjustNotebooks fromPath (toPath ++ [GroupP group]) - layout2 <- getLayout - trace ("dragMove a group Layout after: " ++ show layout2) return () - return () - Nothing -> - case paneName `Map.lookup` panes of - Nothing -> trace ("ViewFrame>>dragMove: pane not found: " ++ paneName) return () - Just (PaneC pane) -> do - case toNB `Map.lookup` (panePathFromNB frameState) of - Nothing -> trace "ViewFrame>>dragMove: panepath for Notebook not found" return () - Just toPath -> - case paneName `Map.lookup`paneMap of - Nothing -> trace ("ViewFrame>>dragMove: pane data not found: " ++ paneName) - return () - Just (fromPath,_) -> do - let child = getTopWidget pane - (fromPane,cid) <- guiPropertiesFromName paneName - fromNB <- trace ("dragMove: pane name: " ++ paneName ++ " path: " ++ show fromPane) - getNotebook fromPane - when (fromNB /= toNB) $ do - mbNum <- liftIO $ notebookPageNum fromNB child - case mbNum of - Nothing -> trace "ViewFrame>>dragMove: widget not found" return () - Just num -> do - liftIO $ notebookRemovePage fromNB num - notebookInsertOrdered toNB child paneName Nothing - let paneMap1 = Map.delete paneName paneMap - trace ("drag move name: " ++ paneName ++ " path: " ++ show toPath) $ - setPaneMapSt $ Map.insert paneName (toPath,cid) paneMap1 - --- --- | Moves the given Pane to the given path --- TODO use adjust -move :: Pane alpha beta => PanePath -> alpha -> beta () -move toPane idew = do - paneMap <- getPaneMapSt - let child = getTopWidget idew - (fromPane,cid) <- guiPropertiesFromName (paneName idew) - fromNB <- getNotebook fromPane - toNB <- getNotebook toPane - mbNum <- liftIO $ notebookPageNum fromNB child - case mbNum of - Nothing -> return () - Just pn -> do - mbBox <- liftIO $ notebookGetTabLabel fromNB child - theText <- liftIO $ widgetGetName child - liftIO $ notebookRemovePage fromNB pn - notebookInsertOrdered toNB child theText Nothing - let paneMap1 = Map.delete (paneName idew) paneMap - trace ("move name: " ++ (paneName idew) ++ " path: " ++ show toPane) $ - setPaneMapSt $ Map.insert (paneName idew) (toPane,cid) paneMap1 - -findAppropriate :: PaneLayout -> PaneDirection -> PanePath -findAppropriate (TerminalP {}) _ = [] -findAppropriate (HorizontalP t b _) LeftP = SplitP TopP : findAppropriate t LeftP -findAppropriate (HorizontalP t b _) RightP = SplitP TopP : findAppropriate t RightP -findAppropriate (HorizontalP t b _) BottomP = SplitP BottomP : findAppropriate b BottomP -findAppropriate (HorizontalP t b _) TopP = SplitP TopP : findAppropriate b TopP -findAppropriate (VerticalP l r _) LeftP = SplitP LeftP : findAppropriate l LeftP -findAppropriate (VerticalP l r _) RightP = SplitP RightP : findAppropriate r RightP -findAppropriate (VerticalP l r _) BottomP = SplitP LeftP : findAppropriate l BottomP -findAppropriate (VerticalP l r _) TopP = SplitP LeftP : findAppropriate l TopP - --- --- | Bring the pane to the front position in its notebook --- -bringPaneToFront :: Pane alpha beta => alpha -> IO () -bringPaneToFront pane = do - let tv = getTopWidget pane - setCurrentNotebookPages tv - - -setCurrentNotebookPages widget = do - mbParent <- widgetGetParent widget - case mbParent of - Just parent -> do - setCurrentNotebookPages parent - if parent `isA` gTypeNotebook - then do - mbPageNum <- notebookPageNum (castToNotebook parent) widget - case mbPageNum of - Just pageNum -> do - notebookSetCurrentPage (castToNotebook parent) pageNum - return () - Nothing -> return () - else return () - Nothing -> return () - --do -- TODO use this? - -- widgetShowAll widget - -- windowPresent (castToWindow widget) - --- --- | Get a valid panePath from a standard path. --- -getBestPanePath :: StandardPath -> PaneLayout -> PanePath -getBestPanePath sp pl = let res = reverse $ getStandard' sp pl [] - in trace ("ViewFrame>>getBestPanePath in: " ++ show sp ++ " out: " ++ show res) res - where - getStandard' (GroupP group:sp) (TerminalP {paneGroups = groups}) p - | group `Map.member` groups = getStandard' sp (groups Map.! group) (GroupP group:p) - getStandard' _ (TerminalP {}) p = p - getStandard' (SplitP LeftP:sp) (VerticalP l r _) p = getStandard' sp l (SplitP LeftP:p) - getStandard' (SplitP RightP:sp) (VerticalP l r _) p = getStandard' sp r (SplitP RightP:p) - getStandard' (SplitP TopP:sp) (HorizontalP t b _) p = getStandard' sp t (SplitP TopP:p) - getStandard' (SplitP BottomP:sp) (HorizontalP t b _) p = getStandard' sp b (SplitP BottomP:p) - -- if no match get leftmost topmost - getStandard' _ (VerticalP l r _) p = getStandard' [] l (SplitP LeftP:p) - getStandard' _ (HorizontalP t b _) p = getStandard' [] t (SplitP TopP:p) - --- --- | Get a standard path. --- -getBestPathForId :: PaneMonad alpha => String -> alpha PanePath -getBestPathForId id = do - p <- panePathForGroup id - l <- getLayout - return (getBestPanePath p l) - --- --- | Construct a new notebook --- -newNotebook' :: IO Notebook -newNotebook' = do - nb <- notebookNew - notebookSetTabPos nb PosTop - notebookSetShowTabs nb True - notebookSetScrollable nb True - notebookSetPopup nb True - return nb - --- --- | Construct a new notebook, --- -newNotebook :: PaneMonad alpha => PanePath -> alpha Notebook -newNotebook pp = do - st <- trace ("newNotebook path: " ++ show pp) - getFrameState - nb <- liftIO newNotebook' - setFrameState st{panePathFromNB = Map.insert nb pp (panePathFromNB st)} - func <- runInIO (dragMove) - liftIO $ do - tl <- targetListNew - targetListAddTextTargets tl 0 - dragDestSet nb [DestDefaultAll] [ActionCopy, ActionMove] - dragDestSetTargetList nb tl - on nb dragDataReceived (dragFunc nb func) - return nb - where - dragFunc :: - Notebook -> - ((PaneName,Notebook) -> IO ()) -> - DragContext -> - Point -> - InfoId -> - TimeStamp -> - (SelectionDataM ()) - dragFunc nb func cont point id timeStamp = do - mbText <- selectionDataGetText - case mbText of - Nothing -> return () - Just str -> do - liftIO $ func (str,nb) - return () - -terminalsWithPanePath :: PaneLayout -> [(PanePath,PaneLayout)] -terminalsWithPanePath pl = map (\ (pp,l) -> (reverse pp,l)) $ terminalsWithPP [] pl - where - terminalsWithPP pp t@(TerminalP groups _ _ _ _) = [(pp,t)] - ++ concatMap (terminalsFromGroup pp) (Map.toList groups) - terminalsWithPP pp (VerticalP l r _) = terminalsWithPP (SplitP LeftP : pp) l - ++ terminalsWithPP (SplitP RightP : pp) r - terminalsWithPP pp (HorizontalP t b _) = terminalsWithPP (SplitP TopP : pp) t - ++ terminalsWithPP (SplitP BottomP : pp) b - terminalsFromGroup pp (name,layout) = terminalsWithPP (GroupP name : pp) layout - -findGroupPath :: String -> PaneLayout -> Maybe PanePath -findGroupPath group layout = - let terminalPairs = terminalsWithPanePath layout - in case (filter filterFunc terminalPairs) of - [] -> Nothing - (pp,_) : [] -> Just (pp ++ [GroupP group]) - _ -> error ("ViewFrame>>group name not unique: " ++ group) - where - filterFunc (_,(TerminalP groups _ _ _ _)) = group `Set.member` Map.keysSet groups - filterFunc _ = error "ViewFrame>>findGroupPath: impossible" - -findDetachedPath :: String -> PaneLayout -> Maybe PanePath -findDetachedPath id layout = - let terminalPairs = terminalsWithPanePath layout - in case (filter filterFunc terminalPairs) of - [] -> Nothing - (pp,_) : [] -> Just pp - _ -> error ("ViewFrame>>window id not unique: " ++ id) - where - filterFunc (_,(TerminalP _ _ _ (Just lid) _)) = lid == id - filterFunc _ = False - - -allGroupNames :: PaneLayout -> Set String -allGroupNames pl = Set.unions $ map getFunc (terminalsWithPanePath pl) - where - getFunc (_,(TerminalP groups _ _ _ _)) = Map.keysSet groups - getFunc _ = error "ViewFrame>>allGroupNames: impossible" - - --- --- | Get another pane path which points to the other side at the same level --- -otherSide :: PanePath -> Maybe PanePath -otherSide [] = Nothing -otherSide p = let rp = reverse p - in case head rp of - SplitP d -> Just (reverse $ SplitP (otherDirection d) : tail rp) - _ -> Nothing - --- --- | Get the opposite direction of a pane direction --- -otherDirection :: PaneDirection -> PaneDirection -otherDirection LeftP = RightP -otherDirection RightP = LeftP -otherDirection TopP = BottomP -otherDirection BottomP = TopP - --- --- | Get the layout at the given pane path --- -layoutFromPath :: PanePath -> PaneLayout -> PaneLayout -layoutFromPath [] l = l -layoutFromPath (GroupP group:r) (TerminalP {paneGroups = groups}) - | group `Map.member` groups = layoutFromPath r (groups Map.! group) -layoutFromPath (SplitP TopP:r) (HorizontalP t _ _) = layoutFromPath r t -layoutFromPath (SplitP BottomP:r) (HorizontalP _ b _) = layoutFromPath r b -layoutFromPath (SplitP LeftP:r) (VerticalP l _ _) = layoutFromPath r l -layoutFromPath (SplitP RightP:r) (VerticalP _ ri _) = layoutFromPath r ri -layoutFromPath pp l = error - $"inconsistent layout (layoutFromPath) " ++ show pp ++ " " ++ show l - -layoutsFromPath :: PanePath -> PaneLayout -> [PaneLayout] -layoutsFromPath (GroupP group:r) layout@(TerminalP {paneGroups = groups}) - | group `Map.member` groups - = layout:layoutsFromPath r (groups Map.! group) -layoutsFromPath [] layout = [layout] -layoutsFromPath (SplitP TopP:r) layout@(HorizontalP t b _) = layout:layoutsFromPath r t -layoutsFromPath (SplitP BottomP:r) layout@(HorizontalP t b _) = layout:layoutsFromPath r b -layoutsFromPath (SplitP LeftP:r) layout@(VerticalP l ri _) = layout:layoutsFromPath r l -layoutsFromPath (SplitP RightP:r) layout@(VerticalP l ri _) = layout:layoutsFromPath r ri -layoutsFromPath pp l = error - $"inconsistent layout (layoutsFromPath) " ++ show pp ++ " " ++ show l - -getWidgetNameList :: PanePath -> PaneLayout -> [String] -getWidgetNameList path layout = reverse $ nameList (reverse path) (reverse $ layoutsFromPath path layout) - where - nameList [] _ = reverse ["Leksah Main Window","topBox","root"] - nameList (pe:_) (TerminalP{detachedId = Just id}:_) = [panePathElementToWidgetName pe, id] - nameList (pe:rpath) (_:rlayout) = panePathElementToWidgetName pe : nameList rpath rlayout - nameList _ _ = error $ "inconsistent layout (getWidgetNameList) " ++ show path ++ " " ++ show layout - -getNotebookOrPaned :: PaneMonad alpha => PanePath -> (Widget -> beta) -> alpha beta -getNotebookOrPaned p cf = do - layout <- getLayout - (widgetGet $ getWidgetNameList p layout) cf - --- --- | Get the notebook widget for the given pane path --- -getNotebook :: PaneMonad alpha => PanePath -> alpha Notebook -getNotebook p = getNotebookOrPaned p castToNotebook - --- --- | Get the (gtk) Paned widget for a given path --- -getPaned :: PaneMonad alpha => PanePath -> alpha Paned -getPaned p = getNotebookOrPaned p castToPaned - --- --- | Get the path to the active pane --- -getActivePanePath :: PaneMonad alpha => alpha (Maybe PanePath) -getActivePanePath = do - mbPane <- getActivePaneSt - case mbPane of - Nothing -> return Nothing - Just (paneName,_) -> do - (pp,_) <- guiPropertiesFromName paneName - return (Just (pp)) - -getActivePanePathOrStandard :: PaneMonad alpha => StandardPath -> alpha (PanePath) -getActivePanePathOrStandard sp = do - mbApp <- getActivePanePath - case mbApp of - Just app -> return app - Nothing -> do - layout <- getLayoutSt - return (getBestPanePath sp layout) - --- --- | Get the active notebook --- -getActiveNotebook :: PaneMonad alpha => alpha (Maybe Notebook) -getActiveNotebook = do - mbPanePath <- getActivePanePath - case mbPanePath of - Just panePath -> do - nb <- getNotebook panePath - return (Just nb) - Nothing -> return Nothing - - --- --- | Translates a pane direction to the widget name --- -paneDirectionToWidgetName :: PaneDirection -> String -paneDirectionToWidgetName TopP = "top" -paneDirectionToWidgetName BottomP = "bottom" -paneDirectionToWidgetName LeftP = "left" -paneDirectionToWidgetName RightP = "right" - -panePathElementToWidgetName :: PanePathElement -> String -panePathElementToWidgetName (SplitP dir) = paneDirectionToWidgetName dir -panePathElementToWidgetName (GroupP group) = "group_" ++ group - --- --- | Changes a pane path in the pane map --- -adjustPanes :: PaneMonad alpha => PanePath -> PanePath -> alpha () -adjustPanes fromPane toPane = do - trace ("adjustPanes: " ++ show fromPane ++ " -> " ++ show toPane) $ return () - paneMap <- getPaneMapSt - setPaneMapSt (Map.map (\(pp,other) -> - case stripPrefix fromPane pp of - Just rest -> (toPane++rest,other) - _ -> (pp,other)) paneMap) - -adjustNotebooks :: PaneMonad alpha => PanePath -> PanePath -> alpha () -adjustNotebooks fromPane toPane = do - npMap <- getPanePathFromNB - setPanePathFromNB (Map.map (\pp -> - case stripPrefix fromPane pp of - Just rest -> toPane++rest - _ -> pp) npMap) - --- --- | Changes the layout for a split --- -adjustLayoutForSplit :: PaneMonad alpha => PaneDirection -> PanePath -> alpha () -adjustLayoutForSplit dir path = do - layout <- getLayoutSt - let paneLayout = layoutFromPath path layout - newLayout = TerminalP Map.empty Nothing 0 Nothing Nothing - newTerm = case dir of - LeftP -> VerticalP paneLayout newLayout 0 - RightP -> VerticalP newLayout paneLayout 0 - TopP -> HorizontalP paneLayout newLayout 0 - BottomP -> HorizontalP newLayout paneLayout 0 - setLayoutSt $ adjustLayout path layout newTerm - --- --- | Changes the layout for a nest --- -adjustLayoutForNest :: PaneMonad alpha => String -> PanePath -> alpha () -adjustLayoutForNest group path = do - layout <- getLayoutSt - let paneLayout = layoutFromPath path layout - newTerm = case paneLayout of - (TerminalP {paneGroups = groups}) -> paneLayout { - paneGroups = Map.insert group (TerminalP Map.empty Nothing 0 Nothing Nothing) groups} - _ -> error "Unexpected layout type in adjustLayoutForNest" - setLayoutSt $ adjustLayout path layout newTerm - --- --- | Changes the layout for a detach --- -adjustLayoutForDetach :: PaneMonad alpha => String -> PanePath -> alpha () -adjustLayoutForDetach id path = do - layout <- getLayoutSt - let paneLayout = layoutFromPath path layout - newTerm = case paneLayout of - (TerminalP {}) -> paneLayout {detachedId = Just id} - _ -> error "Unexpected layout type in adjustLayoutForDetach" - setLayoutSt $ adjustLayout path layout newTerm - --- --- | Changes the layout for a reattach --- -adjustLayoutForReattach :: PaneMonad alpha => PanePath -> alpha () -adjustLayoutForReattach path = do - layout <- getLayoutSt - let paneLayout = layoutFromPath path layout - newTerm = case paneLayout of - (TerminalP {}) -> paneLayout {detachedId = Nothing, detachedSize = Nothing} - _ -> error "Unexpected layout type in adjustLayoutForReattach" - setLayoutSt $ adjustLayout path layout newTerm - --- --- | Changes the layout for a collapse --- -adjustLayoutForCollapse :: PaneMonad alpha => PanePath -> alpha () -adjustLayoutForCollapse oldPath = do - layout <- getLayoutSt - let oldLayout = layoutFromPath oldPath layout - setLayoutSt $ adjustLayout (init oldPath) layout oldLayout - --- --- | Changes the layout for a move --- -adjustLayoutForGroupMove :: PaneMonad alpha => PanePath -> PanePath -> String -> alpha () -adjustLayoutForGroupMove fromPath toPath group = do - layout <- getLayout - let layoutToMove = layoutFromPath fromPath layout - let newLayout = removeGL fromPath layout - setLayoutSt (addGL layoutToMove (toPath ++ [GroupP group]) newLayout) - --- --- | Changes the layout for a remove --- -adjustLayoutForGroupRemove :: PaneMonad alpha => PanePath -> String -> alpha () -adjustLayoutForGroupRemove fromPath group = do - layout <- getLayout - setLayoutSt (removeGL fromPath layout) - --- --- | Remove group layout at a certain path --- -removeGL :: PanePath -> PaneLayout -> PaneLayout -removeGL [GroupP group] t@(TerminalP oldGroups _ _ _ _) - | group `Map.member` oldGroups = t{paneGroups = group `Map.delete` oldGroups} -removeGL (GroupP group:r) old@(TerminalP {paneGroups = groups}) - | group `Map.member` groups = old{paneGroups = Map.adjust (removeGL r) group groups} -removeGL (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (removeGL r tp) bp 0 -removeGL (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (removeGL r bp) 0 -removeGL (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (removeGL r lp) rp 0 -removeGL (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (removeGL r rp) 0 -removeGL p l = error $"ViewFrame>>removeGL: inconsistent layout" ++ show p ++ " " ++ show l - --- --- | Add group layout at a certain path --- -addGL :: PaneLayout -> PanePath -> PaneLayout -> PaneLayout -addGL toAdd [GroupP group] t@(TerminalP oldGroups _ _ _ _) = t{paneGroups = Map.insert group toAdd oldGroups} -addGL toAdd (GroupP group:r) old@(TerminalP {paneGroups = groups}) - | group `Map.member` groups = old{paneGroups = Map.adjust (addGL toAdd r) group groups} -addGL toAdd (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (addGL toAdd r tp) bp 0 -addGL toAdd (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (addGL toAdd r bp) 0 -addGL toAdd (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (addGL toAdd r lp) rp 0 -addGL toAdd (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (addGL toAdd r rp) 0 -addGL _ p l = error $"ViewFrame>>addGL: inconsistent layout" ++ show p ++ " " ++ show l - --- --- | Changes the layout by replacing element at pane path (pp) with replace --- -adjustLayout :: PanePath -> PaneLayout -> PaneLayout -> PaneLayout -adjustLayout pp layout replace = adjust' pp layout - where - adjust' [] _ = replace - adjust' (GroupP group:r) old@(TerminalP {paneGroups = groups}) - | group `Map.member` groups = - old{paneGroups = Map.adjust (adjustPaneGroupLayout r) group groups} - adjust' (SplitP TopP:r) (HorizontalP tp bp _) = HorizontalP (adjust' r tp) bp 0 - adjust' (SplitP BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (adjust' r bp) 0 - adjust' (SplitP LeftP:r) (VerticalP lp rp _) = VerticalP (adjust' r lp) rp 0 - adjust' (SplitP RightP:r) (VerticalP lp rp _) = VerticalP lp (adjust' r rp) 0 - adjust' p l = error $"inconsistent layout (adjust) " ++ show p ++ " " ++ show l - adjustPaneGroupLayout p group = adjust' p group - --- --- | Get the widget from a list of strings --- -widgetFromPath :: Widget -> [String] -> IO (Widget) -widgetFromPath w [] = return w -widgetFromPath w path = do - children <- containerGetChildren (castToContainer w) - chooseWidgetFromPath children path - -chooseWidgetFromPath :: [Widget] -> [String] -> IO (Widget) -chooseWidgetFromPath _ [] = error $"Cant't find widget (empty path)" -chooseWidgetFromPath widgets (h:t) = do - names <- mapM widgetGetName widgets - let mbiInd = findIndex (== h) names - case mbiInd of - Nothing -> error $"Cant't find widget path " ++ show (h:t) ++ " found only " ++ show names - Just ind -> widgetFromPath (widgets !! ind) t - -widgetGet :: PaneMonad alpha => [String] -> (Widget -> b) -> alpha (b) -widgetGet strL cf = do - windows <- getWindowsSt - r <- liftIO $chooseWidgetFromPath (map castToWidget windows) strL - return (cf r) - -widgetGetRel :: Widget -> [String] -> (Widget -> b) -> IO (b) -widgetGetRel w sl cf = do - r <- widgetFromPath w sl - return (cf r) - -getUIAction :: PaneMonad alpha => String -> (Action -> a) -> alpha (a) -getUIAction str f = do - uiManager <- getUiManagerSt - liftIO $ do - findAction <- uiManagerGetAction uiManager str - case findAction of - Just act -> return (f act) - Nothing -> error $"getUIAction can't find action " ++ str - -getThis :: PaneMonad delta => (FrameState delta -> alpha) -> delta alpha -getThis sel = do - st <- getFrameState - return (sel st) -setThis :: PaneMonad delta => (FrameState delta -> alpha -> FrameState delta) -> alpha -> delta () -setThis sel value = do - st <- getFrameState - setFrameState (sel st value) - -getWindowsSt = getThis windows -setWindowsSt = setThis (\st value -> st{windows = value}) -getUiManagerSt = getThis uiManager -getPanesSt = getThis panes -setPanesSt = setThis (\st value -> st{panes = value}) -getPaneMapSt = getThis paneMap -setPaneMapSt = setThis (\st value -> st{paneMap = value}) -getActivePaneSt = getThis activePane -setActivePaneSt = setThis (\st value -> st{activePane = value}) -getLayoutSt = getThis layout -setLayoutSt = setThis (\st value -> st{layout = value}) -getPanePathFromNB = getThis panePathFromNB -setPanePathFromNB = setThis (\st value -> st{panePathFromNB = value}) - - -getActivePane = getActivePaneSt -setActivePane = setActivePaneSt -getUiManager = getUiManagerSt -getWindows = getWindowsSt -getMainWindow = liftM head getWindows -getLayout = getLayoutSt diff --git a/src/IDE/Command.hs b/src/IDE/Command.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Command.hs @@ -0,0 +1,814 @@ +{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Menu +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- +-- | Module for actions, menus and toolbars and the rest ... +-- +------------------------------------------------------------------------------- + + +module IDE.Command ( + mkActions +, menuDescription +, makeMenu +, quit +, aboutDialog +, buildStatusbar +, newIcons +, setSensitivity +, updateRecentEntries +, handleSpecialKeystrokes +, registerEvents +, instrumentWindow +, instrumentSecWindow +) where + +import Graphics.UI.Gtk +import Graphics.UI.Gtk.Types +import Control.Monad.Reader +import System.FilePath +import Data.Version +import Prelude hiding (catch) +import Control.Exception +import Data.Maybe + + +import IDE.Core.State +import IDE.Pane.SourceBuffer +import IDE.Pane.Preferences +import IDE.Pane.PackageFlags +import IDE.Pane.PackageEditor +import IDE.Pane.Errors +import IDE.Package +import IDE.Pane.Log +import IDE.Session +import IDE.Pane.Modules +import IDE.Find +import IDE.Utils.FileUtils +import IDE.Utils.GUIUtils +import IDE.Pane.References +import Paths_leksah +import IDE.GUIHistory +import IDE.Metainfo.Provider + (getWorkspaceInfo, getIdentifierDescr, updateWorkspaceInfo, + updateSystemInfo, rebuildSystemInfo, rebuildWorkspaceInfo) +import IDE.NotebookFlipper +import IDE.ImportTool (addAllImports) +import IDE.LogRef +import IDE.Debug +import System.Directory (doesFileExist) +import qualified Graphics.UI.Gtk.Gdk.Events as GdkEvents +import Graphics.UI.Gtk.Gdk.Events + (Modifier(..), + Event(..)) +import qualified Data.Map as Map (lookup) +import Data.List (sort) +import Control.Event (registerEvent) +import IDE.Pane.Breakpoints + (fillBreakpointList, selectBreak) +import IDE.Workspaces +import IDE.Statusbar +import IDE.Pane.Workspace +import IDE.Pane.Variables (fillVariablesList) +import IDE.Pane.Trace (fillTraceList) +import IDE.PaneGroups +import IDE.Pane.Search (getSearch, setChoices, searchMetaGUI) +import IDE.Pane.Grep (getGrep) + +-- +-- | The Actions known to the system (they can be activated by keystrokes or menus) +-- +mkActions :: [ActionDescr IDERef] +mkActions = + [AD "File" "_File" Nothing Nothing (return ()) [] False + ,AD "FileNew" "_New" Nothing (Just "gtk-new") + fileNew [] False + ,AD "FileOpen" "_Open" Nothing (Just "gtk-open") + fileOpen [] False + ,AD "RecentFiles" "_Recent Files" Nothing Nothing (return ()) [] False + ,AD "FileRevert" "_Revert" Nothing Nothing + fileRevert [] False + ,AD "FileSave" "_Save" Nothing (Just "gtk-save") + (do fileSave False; return ()) [] False + ,AD "FileSaveAs" "Save _As" Nothing (Just "gtk-save-as") + (do fileSave True; return ()) [] False + ,AD "FileSaveAll" "Save A_ll" Nothing Nothing + (do fileSaveAll (\ b -> return (bufferName b /= "_Eval.hs")); return ()) [] False + ,AD "FileClose" "_Close" Nothing (Just "gtk-close") + (do fileClose; return ()) [] False + ,AD "FileCloseAll" "Close All" Nothing Nothing + (do fileCloseAll (\ b -> return (bufferName b /= "_Eval.hs")); return ()) [] False + ,AD "FileCloseAllButPackage" "Close All But Package" Nothing Nothing + (do fileCloseAllButPackage; return ()) [] False + ,AD "FileCloseAllButWorkspace" "Close All But Workspace" Nothing Nothing + (do fileCloseAllButWorkspace; return ()) [] False + ,AD "Quit" "_Quit" Nothing (Just "gtk-quit") + quit [] False + + ,AD "Edit" "_Edit" Nothing Nothing (return ()) [] False + ,AD "EditUndo" "_Undo" Nothing (Just "gtk-undo") + editUndo [] False + ,AD "EditRedo" "_Redo" Nothing (Just "gtk-redo") + editRedo [] False + ,AD "EditCut" "Cu_t" Nothing (Just "gtk-cut") + editCut [] {--Just "X"--} False + ,AD "EditCopy" "_Copy" Nothing (Just "gtk-copy") + editCopy [] {--Just "C"--} False + ,AD "EditPaste" "_Paste" Nothing (Just "gtk-paste") + editPaste [] {--Just "V"--} False + ,AD "EditDelete" "_Delete" Nothing (Just "gtk-delete") + editDelete [] False + ,AD "EditSelectAll" "Select_All" Nothing (Just "gtk-select-all") + editSelectAll [] False + ,AD "EditFind" "Find" Nothing (Just "gtk-find") + (editFindInc Initial) [] False + ,AD "EditFindNext" "Find _Next" Nothing (Just "gtk-find-next") + (editFindInc Forward) [] False + ,AD "EditFindPrevious" "Find _Previous" Nothing (Just "gtk-find-previous") + (editFindInc Backward) [] False + ,AD "EditGotoLine" "_Goto Line" Nothing (Just "gtk-jump") + editGotoLine [] False + + ,AD "EditComment" "_Comment" Nothing Nothing + editComment [] False + ,AD "EditUncomment" "_Uncomment" Nothing Nothing + editUncomment [] False + ,AD "EditShiftRight" "Shift _Right" Nothing Nothing + editShiftRight [] False + ,AD "EditShiftLeft" "Shift _Left" Nothing Nothing + editShiftLeft [] False + + --,AD "Align" "_Align" Nothing Nothing (return ()) [] False + ,AD "EditAlignEqual" "Align _=" Nothing Nothing + (align '=') [] False + ,AD "EditAlignRightArrow" "Align -_>" Nothing Nothing + (align '>') [] False + ,AD "EditAlignLeftArrow" "Align _<-" Nothing Nothing + (align '<') [] False + ,AD "EditAlignTypeSig" "Align _::" Nothing Nothing + (align ':') [] False + + ,AD "Workspace" "_Workspace" Nothing Nothing (return ()) [] False + ,AD "NewWorkspace" "_New Workspace" Nothing Nothing + workspaceNew [] False + ,AD "OpenWorkspace" "_Open Workspace" Nothing Nothing + workspaceOpen [] False + ,AD "RecentWorkspaces" "_Recent Workspaces" Nothing Nothing (return ()) [] False + ,AD "CloseWorkspace" "_Close Workspace" Nothing Nothing + workspaceClose [] False + + ,AD "CleanWorkspace" "Cl_ean Workspace" (Just "Cleans all packages") (Just "ide_clean") + workspaceClean [] False + ,AD "MakeWorkspace" "_Make Workspace" (Just "Makes all of this workspace") (Just "ide_configure") + workspaceMake [] False + ,AD "NextError" "_Next Error" (Just "Go to the next error") (Just "ide_error_next") + nextError [] False + ,AD "PreviousError" "_Previous Error" (Just "Go to the previous error") (Just "ide_error_prev") + previousError [] False + + ,AD "Package" "_Package" Nothing Nothing (return ()) [] False + ,AD "NewPackage" "_New Package" Nothing Nothing + packageNew [] False + ,AD "OpenPackage" "_Open Package" Nothing Nothing + packageOpen [] False +-- ,AD "RecentPackages" "_Recent Packages" Nothing Nothing (return ()) [] False + ,AD "EditPackage" "_Edit Package" Nothing Nothing + packageEdit [] False +-- ,AD "RemovePackage" "_Close Package" Nothing Nothing +-- removePackage [] False + + ,AD "PackageFlags" "Edit Flags" (Just "Edit the package flags") Nothing + (getFlags Nothing >>= \ p -> displayPane p False) [] False + ,AD "CleanPackage" "Cl_ean Package" (Just "Cleans the package") (Just "ide_clean") + (packageClean Nothing) [] False + ,AD "ConfigPackage" "_Configure Package" (Just "Configures the package") (Just "ide_configure") + packageConfig [] False + ,AD "BuildPackage" "_Build Package" (Just "Builds the package") (Just "ide_make") + makePackage [] False + ,AD "DocPackage" "_Build Documentation" (Just "Builds the documentation") Nothing + packageDoc [] False + ,AD "CopyPackage" "_Copy Package" (Just "Copies the package") Nothing + packageCopy [] False + ,AD "RunPackage" "_Run" (Just "Runs the package") (Just "ide_run") + packageRun [] False + ,AD "AddAllImports" "_Add All Imports" (Just "Resolve 'Not in scope' errors by adding the necessary imports") Nothing + addAllImports [] False + + ,AD "InstallPackage" "_Install Package" Nothing Nothing + packageInstall [] False + ,AD "RegisterPackage" "_Register Package" Nothing Nothing + packageRegister [] False + ,AD "UnregisterPackage" "_Unregister" Nothing Nothing + packageUnregister [] False + ,AD "TestPackage" "Test Package" Nothing Nothing + packageTest [] False + ,AD "SdistPackage" "Source Dist" Nothing Nothing + packageSdist [] False + ,AD "OpenDocPackage" "_Open Doc" Nothing Nothing + packageOpenDoc [] False + + ,AD "Debug" "_Debug" Nothing Nothing (return ()) [] False + ,AD "StartDebugger" "_Start Debugger" (Just "Starts using the GHCi debugger for build and run") Nothing + debugStart [] False + ,AD "QuitDebugger" "_Quit Debugger" (Just "Quit the GHCi debugger if it is running") Nothing + debugQuit [] False + ,AD "ExecuteSelection" "_Execute Selection" (Just "Sends the selected text to the debugger") Nothing + debugExecuteSelection [] False + + ,AD "DebugSetBreakpoint" "Set Breakpoint" (Just "Set a breakpoint on the selected name or current line") Nothing + debugSetBreakpoint [] False + ,AD "ShowNextBreakpoint" "Show Next Breakpoint" (Just "Show the next breakpoint") Nothing + nextBreakpoint [] False + ,AD "ShowPreviousBreakpoint" "Show Previous Breakpoint" (Just "Show the previous breakpoint") Nothing + previousBreakpoint [] False + ,AD "DebugDeleteAllBreakpoints" "Delete All Breakpoints" (Just "") Nothing + debugDeleteAllBreakpoints [] False + + ,AD "DebugContinue" "Continue" (Just "Resume after a breakpoint") (Just "ide_continue") + debugContinue [] False + ,AD "DebugAbandon" "Abandon" (Just "At a breakpoint, abandon current computation") Nothing + debugAbandon [] False + ,AD "DebugStop" "Stop" (Just "Interrupt the running operation.") Nothing + debugStop [] False + + ,AD "DebugStep" "Step" (Just "Single-step after stopping at a breakpoint") (Just "ide_step") + debugStep [] False + ,AD "DebugStepExpression" "Step Expression" (Just "Single-step into selected expression") Nothing + debugStepExpression [] False + ,AD "DebugStepLocal" "Step Local" (Just "Single-step within the current top-level binding") (Just "ide_local") + debugStepLocal [] False + ,AD "DebugStepModule" "Step Module" (Just "Single-step restricted to the current module") (Just "ide_module") + debugStepModule [] False + + ,AD "DebugTrace" "Trace" (Just "Trace after stopping at a breakpoint") Nothing + debugTrace [] False + ,AD "DebugTraceExpression" "Trace Expression" (Just "Evaluate the selected expression with tracing on") Nothing + debugTraceExpression [] False + ,AD "DebugHistory" "History" (Just "After 'Trace', show the execution history") Nothing + debugHistory [] False + ,AD "DebugBack" "Back" (Just "Go back in the history (after 'Trace')") Nothing + debugBack [] False + ,AD "DebugForward" "Forward" (Just "Go forward in the history (after 'Back')") Nothing + debugForward [] False + + ,AD "DebugForce" "Force" (Just "Print the selected expression, forcing unevaluated parts") Nothing + debugForce [] False + ,AD "DebugPrint" "Print" (Just "Prints a value without forcing its computation") Nothing + debugPrint [] False + ,AD "DebugSimplePrint" "SimplePrint" (Just "Simplifed version of Print") Nothing + debugSimplePrint [] False + + ,AD "ShowBindings" "Show Bin_dings" (Just "Show the current bindings") Nothing + debugShowBindings [] False + ,AD "ShowBreakpoints" "Show _Breakpoints" (Just "Show the active breakpoints") Nothing + debugShowBreakpoints [] False + ,AD "ShowContext" "Show _Context" (Just "Show the breakpoint context") Nothing + debugShowContext [] False + ,AD "ShowLoadedModules" "Show Loaded _Modules" (Just "Show the currently loaded modules") Nothing + debugShowModules [] False + ,AD "ShowPackages" "Show _Packages" (Just "Show the currently active packages") Nothing + debugShowPackages [] False + ,AD "ShowLanguages" "Show _Languages" (Just "Show the currently active language") Nothing + debugShowLanguages [] False + + ,AD "DebugInformation" "Information" (Just "Display information about the selected name(s)") Nothing + debugInformation [] False + ,AD "DebugKind" "Kind" (Just "Show the kind of the selected type") Nothing + debugKind [] False + ,AD "DebugType" "Type" (Just "Show the type of the selected expression") Nothing + debugType [] False + + ,AD "Metadata" "_Metadata" Nothing Nothing (return ()) [] False + ,AD "UpdateMetadataCurrent" "_Update workspace data" (Just "Updates data for the current workspace") + (Just "ide_rebuild_meta") updateWorkspaceInfo [] False + ,AD "RebuildMetadataCurrent" "_Rebuild workspace data" (Just "Rebuilds data for the current workspace") + Nothing rebuildWorkspaceInfo [] False + ,AD "UpdateMetadataLib" "U_pdate system data" Nothing Nothing + updateSystemInfo [] False + ,AD "RebuildMetadataLib" "R_ebuild system data" Nothing Nothing + rebuildSystemInfo [] False + + ,AD "Session" "_Session" Nothing Nothing (return ()) [] False + ,AD "SaveSession" "_Save Session" Nothing Nothing + saveSessionAsPrompt [] False + ,AD "LoadSession" "_Load Session" Nothing Nothing + loadSessionPrompt [] False + ,AD "ForgetSession" "_Forget Session" Nothing Nothing + (return ()) [] True + + ,AD "Panes" "_Panes" Nothing Nothing (return ()) [] False + ,AD "ShowBrowser" "Browser" Nothing Nothing + showBrowser [] False + ,AD "ShowDebugger" "Debugger" Nothing Nothing + showDebugger [] False + ,AD "ShowSearch" "Search" Nothing Nothing + (getSearch Nothing >>= \ p -> displayPane p False) [] False + ,AD "ShowGrep" "Grep" Nothing Nothing + (getGrep Nothing >>= \ p -> displayPane p False) [] False + ,AD "ShowErrors" "Errors" Nothing Nothing + (getErrors Nothing >>= \ p -> displayPane p False) [] False + ,AD "ShowLog" "Log" Nothing Nothing + showLog [] False + ,AD "ShowReferences" "References" Nothing Nothing + (getReferences Nothing >>= \ p -> displayPane p False) [] False + ,AD "ShowWorkspace" "Workspace" Nothing Nothing + (getWorkspace Nothing >>= \ p -> displayPane p False) [] False + + ,AD "View" "_View" Nothing Nothing (return ()) [] False + ,AD "ViewMoveLeft" "Move _Left" Nothing Nothing + (viewMove LeftP) [] False + ,AD "ViewMoveRight" "Move _Right" Nothing Nothing + (viewMove RightP) [] False + ,AD "ViewMoveUp" "Move _Up" Nothing Nothing + (viewMove TopP) [] False + ,AD "ViewMoveDown" "Move _Down" Nothing Nothing + (viewMove BottomP) [] False + ,AD "ViewSplitHorizontal" "Split H_orizontal" Nothing Nothing + viewSplitHorizontal [] False + ,AD "ViewSplitVertical" "Split _Vertical" Nothing Nothing + viewSplitVertical [] False + ,AD "ViewCollapse" "_Collapse" Nothing Nothing + viewCollapse [] False + ,AD "ViewNest" "_Group" Nothing Nothing + (viewNewGroup) [] False + ,AD "ViewDetach" "_Detach" Nothing Nothing + viewDetachInstrumented [] False + + ,AD "ViewTabsLeft" "Tabs Left" Nothing Nothing + (viewTabsPos PosLeft) [] False + ,AD "ViewTabsRight" "Tabs Right" Nothing Nothing + (viewTabsPos PosRight) [] False + ,AD "ViewTabsUp" "Tabs Up" Nothing Nothing + (viewTabsPos PosTop) [] False + ,AD "ViewTabsDown" "Tabs Down" Nothing Nothing + (viewTabsPos PosBottom) [] False + ,AD "ViewSwitchTabs" "Tabs On/Off" Nothing Nothing + viewSwitchTabs [] False + + ,AD "ViewClosePane" "Close pane" Nothing (Just "gtk-close") + sessionClosePane [] False + + ,AD "FlipDown" "Flip down" Nothing Nothing + flipDown [] False + ,AD "FlipUp" "Flip up" Nothing Nothing + flipUp [] False + ,AD "StartComplete" "StartComplete" Nothing Nothing + startComplete [] False + + ,AD "ViewHistoryBack" "Back" Nothing (Just "gtk-go-back") + historyBack [] False + ,AD "ViewHistoryForth" "Forward" Nothing (Just "gtk-go-forward") + historyForward [] False + + + ,AD "ClearLog" "_Clear Log" Nothing Nothing + clearLog [] False + ,AD "ToggleToolbar" "Toggle Toolbar" Nothing Nothing + toggleToolbar [] False + + ,AD "Configuration" "_Configuration" Nothing Nothing (return ()) [] False + ,AD "EditCandy" "_To Candy" Nothing Nothing + editCandy [] True + ,AD "PrefsEdit" "_Edit Prefs" Nothing Nothing + (getPrefs Nothing >>= \ p -> displayPane p False) [] False + + ,AD "Help" "_Help" Nothing Nothing (return ()) [] False + ,AD "HelpDebug" "Debug" Nothing Nothing (do + pack <- readIDE activePack + ideMessage Normal (show pack)) [] False +-- ,AD "HelpDebug2" "Debug2" (Just "d") Nothing dbgInstalledPackageInfo [] False + ,AD "HelpManual" "Manual" Nothing Nothing (openBrowser "http://leksah.org/leksah_manual.pdf") [] False + ,AD "HelpHomepage" "Homepage" Nothing Nothing (openBrowser "http://leksah.org") [] False + ,AD "HelpAbout" "About" Nothing (Just "gtk-about") (liftIO aboutDialog) [] False + + ,AD "BackgroundBuildToggled" "_BackgroundBuild" (Just "Build in the background and report errors") (Just "ide_build") + backgroundBuildToggled [] True + ,AD "BackgroundLinkToggled" "_BackgroundLink" (Just "Link in the background") (Just "ide_link") + backgroundLinkToggled [] True + ,AD "DebugToggled" "_Debug" (Just "Use GHCi debugger to build and run") (Just "ide_debug") + debugToggled [] True] + +-- +-- | The menu description in XML Syntax as defined by GTK +-- +menuDescription :: IO String +menuDescription = do + dataDir <- getDataDir + prefsPath <- getConfigFilePathForLoad "leksah.menu" Nothing dataDir + res <- readFile prefsPath + return res + +updateRecentEntries :: IDEAction +updateRecentEntries = do + recentFiles' <- readIDE recentFiles + recentWorkspaces' <- readIDE recentWorkspaces + recentFilesItem <- getRecentFiles + recentWorkspacesItem <- getRecentWorkspaces + reifyIDE (\ ideR -> do + recentFilesMenu <- menuNew + mapM_ (\s -> do + fe <- doesFileExist s + when fe $ do + mi <- menuItemNewWithLabel s + mi `onActivateLeaf` (reflectIDE (fileOpenThis s) ideR) + menuShellAppend recentFilesMenu mi) recentFiles' + oldSubmenu <- menuItemGetSubmenu recentFilesItem + when (isJust oldSubmenu) $ do + widgetHideAll (fromJust oldSubmenu) + widgetDestroy (fromJust oldSubmenu) + menuItemSetSubmenu recentFilesItem recentFilesMenu + widgetShowAll recentFilesMenu + recentWorkspacesMenu <- menuNew + mapM_ (\s -> do + fe <- doesFileExist s + when fe $ do + mi <- menuItemNewWithLabel s + mi `onActivateLeaf` (reflectIDE (workspaceOpenThis True (Just s) >> return ()) ideR) + menuShellAppend recentWorkspacesMenu mi) recentWorkspaces' + oldSubmenu <- menuItemGetSubmenu recentWorkspacesItem + when (isJust oldSubmenu) $ do + widgetHideAll (fromJust oldSubmenu) + widgetDestroy (fromJust oldSubmenu) + menuItemSetSubmenu recentWorkspacesItem recentWorkspacesMenu + widgetShowAll recentWorkspacesMenu) + + +-- +-- | Building the Menu +-- +makeMenu :: UIManager -> [ActionDescr IDERef] -> String -> IDEAction +makeMenu uiManager actions menuDescription = reifyIDE (\ideR -> do + actionGroupGlobal <- actionGroupNew "global" + mapM_ (actm ideR actionGroupGlobal) actions + uiManagerInsertActionGroup uiManager actionGroupGlobal 1 + uiManagerAddUiFromString uiManager menuDescription + return ()) + where + actm ideR ag (AD name label tooltip stockId ideAction accs isToggle) = do + let (acc,accString) = if null accs + then (Just "","=" ++ name) + else (Just (head accs),(head accs) ++ "=" ++ name) + if isToggle + then do + act <- toggleActionNew name label tooltip stockId + on act actionToggled (doAction ideAction ideR accString) + actionGroupAddActionWithAccel ag act acc + else do + act <- actionNew name label tooltip stockId + onActionActivate act (doAction ideAction ideR accString) + actionGroupAddActionWithAccel ag act acc + doAction ideAction ideR accStr = + (reflectIDE (do + ideAction + triggerEventIDE (StatusbarChanged [CompartmentCommand accStr]) + return ()) ideR) + +getMenuAndToolbars :: UIManager -> IO (AccelGroup, MenuBar, Toolbar) +getMenuAndToolbars uiManager = do + accGroup <- uiManagerGetAccelGroup uiManager + mbMenu <- uiManagerGetWidget uiManager "/ui/menubar" + let menu = case mbMenu of + Just it -> castToMenuBar it + Nothing -> throwIDE "Menu>>makeMenu: failed to create menubar" + mbToolbar <- uiManagerGetWidget uiManager "/ui/toolbar" + let toolbar = case mbToolbar of + Just it -> castToToolbar it + Nothing -> throwIDE "Menu>>makeMenu: failed to create toolbar" + toolbarSetIconSize toolbar IconSizeSmallToolbar + toolbarSetStyle toolbar ToolbarIcons + widgetSetSizeRequest toolbar 700 (-1) + return (accGroup,menu,toolbar) + +textPopupMenu :: IDERef -> Menu -> IO () +textPopupMenu ideR menu = do + items <- containerGetChildren menu + mi1 <- menuItemNewWithLabel "Eval" + mi1 `onActivateLeaf` (reflectIDE debugExecuteSelection ideR) + menuShellAppend menu mi1 + mi11 <- menuItemNewWithLabel "Eval & Insert" + mi11 `onActivateLeaf` (reflectIDE debugExecuteAndShowSelection ideR) + menuShellAppend menu mi11 + mi12 <- menuItemNewWithLabel "Step" + mi12 `onActivateLeaf` (reflectIDE debugStepExpression ideR) + menuShellAppend menu mi12 + mi13 <- menuItemNewWithLabel "Trace" + mi13 `onActivateLeaf` (reflectIDE debugTraceExpression ideR) + menuShellAppend menu mi13 + mi16 <- menuItemNewWithLabel "Set Breakpoint" + mi16 `onActivateLeaf` (reflectIDE debugSetBreakpoint ideR) + menuShellAppend menu mi16 + sep1 <- separatorMenuItemNew + menuShellAppend menu sep1 + mi14 <- menuItemNewWithLabel "Type" + mi14 `onActivateLeaf` (reflectIDE debugType ideR) + menuShellAppend menu mi14 + mi141 <- menuItemNewWithLabel "Info" + mi141 `onActivateLeaf` (reflectIDE debugInformation ideR) + menuShellAppend menu mi141 + mi15 <- menuItemNewWithLabel "Kind" + mi15 `onActivateLeaf` (reflectIDE debugKind ideR) + menuShellAppend menu mi15 + sep2 <- separatorMenuItemNew + menuShellAppend menu sep2 + mi2 <- menuItemNewWithLabel "Find (text)" + mi2 `onActivateLeaf` (reflectIDE (editFindInc Initial) ideR) + 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) + menuShellAppend menu mi3 + let interpretingEntries = [castToWidget mi16] + let interpretingSelEntries = [castToWidget mi1, castToWidget mi11, castToWidget mi12, + castToWidget mi13, castToWidget mi14, castToWidget mi141, + castToWidget mi15] + let otherEntries = [castToWidget mi2, castToWidget mi3] + isInterpreting' <- (reflectIDE isInterpreting ideR) + selected <- (reflectIDE selectedText ideR) + unless isInterpreting' + $ mapM_ (\w -> widgetSetSensitive w False) (interpretingEntries ++ interpretingSelEntries) +-- unless (isJust selected) +-- $ mapM_ (\w -> widgetSetSensitive w False) (otherEntries ++ interpretingSelEntries) + mapM_ widgetShow interpretingEntries + mapM_ widgetShow interpretingSelEntries + mapM_ widgetShow (castToWidget sep1 : castToWidget sep2 : otherEntries) + mapM_ widgetHide $ take 2 (reverse items) + +-- | Quit ide +quit :: IDEAction +quit = do + modifyIDE_ (\ide -> ide{currentState = IsShuttingDown}) + saveSession :: IDEAction + b <- fileCloseAll (\_ -> return True) + if b + then liftIO mainQuit + else modifyIDE_ (\ide -> ide{currentState = IsRunning}) + +-- +-- | Show the about dialog +-- +aboutDialog :: IO () +aboutDialog = do + d <- aboutDialogNew + aboutDialogSetName d "Leksah" + aboutDialogSetVersion d (showVersion version) + aboutDialogSetCopyright d "Copyright 2007-2010 Jürgen Nicklisch-Franken, Hamish Mackenzie" + aboutDialogSetComments d $ "An integrated development environement (IDE) for the " ++ + "programming language Haskell and the Glasgow Haskell Compiler" + dd <- getDataDir + license <- catch (readFile $ dd "LICENSE") (\ (_ :: SomeException) -> return "") + aboutDialogSetLicense d $ Just license + aboutDialogSetWebsite d "http://leksah.org/" + aboutDialogSetAuthors d ["Jürgen Nicklisch-Franken","Hamish Mackenzie"] + dialogRun d + widgetDestroy d + return () + + +newIcons :: IO () +newIcons = catch (do + iconFactory <- iconFactoryNew + dataDir <- getDataDir + mapM_ (loadIcon dataDir iconFactory) ["ide_class","ide_configure","ide_data","ide_error_next", + "ide_error_prev","ide_function","ide_instance", "ide_konstructor","ide_make", + "ide_method","ide_newtype","ide_other","ide_rule","ide_run","ide_slot", + "ide_source","ide_type","leksah", "ide_reexported", "ide_clean", "ide_link", "ide_build", + "ide_debug", "ide_step", "ide_local", "ide_module", "ide_continue", "ide_rebuild_meta", + "ide_empty","ide_source_local"] + iconFactoryAddDefault iconFactory) + (\(e :: SomeException) -> getDataDir >>= \dataDir -> throwIDE ("Can't load icons from " ++ dataDir ++ " " ++ show e)) + where + loadIcon dataDir iconFactory name = do + pb <- pixbufNewFromFile $ dataDir "pics" (name ++ ".png") + icon <- iconSetNewFromPixbuf pb + iconFactoryAdd iconFactory name icon + +setSensitivity :: [(SensitivityMask, Bool)] -> IDEAction +setSensitivity l = mapM_ setSensitivitySingle l + where setSensitivitySingle (sens,bool) = do + actions <- getActionsFor sens + liftIO $ mapM_ (\a -> actionSetSensitive a bool) actions + let additionalActions = getAdditionalActionsFor sens + mapM_ (\a -> a bool) additionalActions + +getActionsFor :: SensitivityMask -> IDEM [Action] +getActionsFor SensitivityForwardHist = getActionsFor' ["ViewHistoryForth"] +getActionsFor SensitivityBackwardHist = getActionsFor' ["ViewHistoryBack"] +getActionsFor SensitivityProjectActive = getActionsFor' + ["EditPackage", "PackageFlags", "ConfigPackage", "BuildPackage" + ,"DocPackage", "CleanPackage", "CopyPackage", "RunPackage","InstallPackage" + ,"RegisterPackage", "UnregisterPackage","TestPackage","SdistPackage" + ,"OpenDocPackage","FileCloseAll"] +getActionsFor SensitivityError = getActionsFor' ["NextError", "PreviousError"] +getActionsFor SensitivityEditor = getActionsFor' ["EditUndo", "EditRedo", "EditGotoLine" + ,"EditComment", "EditUncomment", "EditShiftLeft", "EditShiftRight"] +getActionsFor SensitivityInterpreting = getActionsFor' ["QuitDebugger" , "ExecuteSelection", + "DebugSetBreakpoint", "ShowNextBreakpoint", "ShowPreviousBreakpoint", "DebugDeleteAllBreakpoints", + "DebugContinue", "DebugAbandon", "DebugStop", "DebugStep", "DebugStepExpression", "DebugStepLocal", + "DebugStepModule", "DebugTrace", "DebugTraceExpression", "DebugHistory", "DebugBack", "DebugForward", + "DebugForce", "DebugPrint", "DebugSimplePrint", "ShowBindings", "ShowBreakpoints", "ShowContext", + "ShowLoadedModules", "ShowPackages", "ShowLanguages", "DebugInformation", "DebugKind", "DebugType"] +getActionsFor SensitivityWorkspaceOpen = return [] --TODO add here + +getActionsFor' :: [String] -> IDEM[Action] +getActionsFor' l = do + r <- mapM getActionFor l + return (catMaybes r) + where + getActionFor string = do + uiManager' <- getUiManager + actionGroups <- liftIO $ uiManagerGetActionGroups uiManager' + res <- liftIO $ actionGroupGetAction (head actionGroups) string + when (isNothing res) $ ideMessage Normal $ "Can't find UI Action " ++ string + return res + +getAdditionalActionsFor :: SensitivityMask -> [Bool -> IDEAction] +getAdditionalActionsFor SensitivityInterpreting = [setSensitivityDebugger] +getAdditionalActionsFor _ = [] + +viewDetachInstrumented :: IDEAction +viewDetachInstrumented = do + mbPair <- viewDetach + case mbPair of + Nothing -> return () + Just (win,wid) -> do + instrumentSecWindow win + liftIO $ widgetShowAll win + +instrumentWindow :: Window -> Prefs -> Widget -> IDEAction +instrumentWindow win prefs topWidget = do + -- sets the icon + ideR <- ask + uiManager' <- getUiManager + liftIO $ do + dataDir <- getDataDir + let iconPath = dataDir "pics" "leksah.png" + iconExists <- doesFileExist iconPath + when iconExists $ + windowSetIconFromFile win iconPath + vb <- vBoxNew False 1 -- Top-level vbox + widgetSetName vb "topBox" + (acc,menu,toolbar) <- getMenuAndToolbars uiManager' + boxPackStart vb menu PackNatural 0 + boxPackStart vb toolbar PackNatural 0 + boxPackStart vb topWidget PackGrow 0 + findbar <- reflectIDE (do + modifyIDE_ (\ide -> ide{toolbar = (True,Just toolbar)}) + constructFindReplace ) ideR + boxPackStart vb findbar PackNatural 0 + statusBar <- buildStatusbar + boxPackEnd vb statusBar PackNatural 0 + win `onKeyPress` (\ e -> reflectIDE (handleSpecialKeystrokes e) ideR) + windowAddAccelGroup win acc + containerAdd win vb + reflectIDE (do + setCandyState (isJust (sourceCandy prefs)) + setBackgroundBuildToggled (backgroundBuild prefs) + setBackgroundLinkToggled (backgroundLink prefs)) ideR + +instrumentSecWindow :: Window -> IDEAction +instrumentSecWindow win = do + ideR <- ask + uiManager' <- getUiManager + liftIO $ do + dataDir <- getDataDir + let iconPath = dataDir "data" "leksah.png" + iconExists <- doesFileExist iconPath + when iconExists $ + windowSetIconFromFile win iconPath + + (acc,_,_) <- getMenuAndToolbars uiManager' + windowAddAccelGroup win acc + win `onKeyPress` (\ e -> reflectIDE (handleSpecialKeystrokes e) ideR) + return () + +-- +-- | Callback function for onKeyPress of the main window, so 'preprocess' any key +-- +handleSpecialKeystrokes :: GdkEvents.Event -> IDEM Bool +handleSpecialKeystrokes (Key { eventKeyName = name, eventModifier = mods, + eventKeyVal = keyVal, eventKeyChar = mbChar}) = do + prefs' <- readIDE prefs + case (name, mods) of + (tab, [Control]) | (tab == "Tab" || tab == "ISO_Left_Tab") + && useCtrlTabFlipping prefs' -> do + flipDown + return True + (tab, [Shift, Control]) | (tab == "Tab" || tab == "ISO_Left_Tab") + && useCtrlTabFlipping prefs' -> do + flipUp + return True + _ -> do + bs <- getCandyState + when bs (editKeystrokeCandy mbChar) + sk <- readIDE specialKey + sks <- readIDE specialKeys + return True + case sk of + Nothing -> + case Map.lookup (keyVal,sort mods) sks of + Nothing -> do + triggerEventIDE (StatusbarChanged [CompartmentCommand ""]) + return False + Just map -> do + let sym = printMods mods ++ name + triggerEventIDE (StatusbarChanged [CompartmentCommand sym]) + modifyIDE_ (\ide -> ide{specialKey = Just (map,sym)}) + return True + Just (map,sym) -> do + case Map.lookup (keyVal,sort mods) map of + Nothing -> do + triggerEventIDE (StatusbarChanged [CompartmentCommand + (sym ++ printMods mods ++ name ++ "?")]) + return () + Just (AD actname _ _ _ ideAction _ _) -> do + triggerEventIDE (StatusbarChanged [CompartmentCommand + (sym ++ " " ++ printMods mods ++ name ++ "=" ++ actname)]) + ideAction + modifyIDE_ (\ide -> ide{specialKey = Nothing}) + return True + where + printMods :: [Modifier] -> String + printMods [] = "" + printMods (m:r) = show m ++ printMods r +handleSpecialKeystrokes _ = return True + +setSymbol :: String -> IDEAction +setSymbol symbol = do + currentInfo' <- getWorkspaceInfo + 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 + l -> setChoices l + +-- +-- | Register handlers for IDE events +-- +registerEvents :: IDEAction +registerEvents = do + stRef <- ask + registerEvent stRef "LogMessage" + (Left (\e@(LogMessage s t) -> getLog >>= \(log :: IDELog) -> liftIO $ appendLog log s t + >> return e)) + registerEvent stRef "SelectInfo" + (Left (\ e@(SelectInfo str) -> setSymbol str >> return e)) + registerEvent stRef "SelectIdent" + (Left (\ e@(SelectIdent id) -> selectIdentifier id >> return e)) + registerEvent stRef "InfoChanged" + (Left (\ e@(InfoChanged b) -> reloadKeepSelection b >> return e)) + registerEvent stRef "ActivePack" + (Left (\ e@(ActivePack _) -> updateWorkspaceInfo >> return e)) + registerEvent stRef "WorkspaceChanged" + (Left (\ e@WorkspaceChanged -> updateWorkspace >> return e)) + registerEvent stRef "RecordHistory" + (Left (\ rh@(RecordHistory h) -> recordHistory h >> return rh)) + registerEvent stRef "Sensitivity" + (Left (\ s@(Sensitivity h) -> setSensitivity h >> return s)) + registerEvent stRef "SearchMeta" + (Left (\ e@(SearchMeta string) -> searchMetaGUI string >> return e)) + registerEvent stRef "LoadSession" + (Left (\ e@(LoadSession fp) -> loadSession fp >> return e)) + registerEvent stRef "SaveSession" + (Left (\ e@(SaveSession fp) -> saveSessionAs fp Nothing >> return e)) + registerEvent stRef "UpdateRecent" + (Left (\ e@UpdateRecent -> updateRecentEntries >> return e)) + registerEvent stRef "VariablesChanged" + (Left (\ e@VariablesChanged -> fillVariablesList >> return e)) + registerEvent stRef "ErrorChanged" + (Left (\ e@ErrorChanged -> postAsyncIDE fillErrorList >> return e)) + registerEvent stRef "CurrentErrorChanged" + (Left (\ e@(CurrentErrorChanged mbLogRef) -> postAsyncIDE (do + selectRef mbLogRef + selectError mbLogRef) >> return e)) + registerEvent stRef "BreakpointChanged" + (Left (\ e@BreakpointChanged -> postAsyncIDE fillBreakpointList >> return e)) + registerEvent stRef "CurrentBreakChanged" + (Left (\ e@(CurrentBreakChanged mbLogRef) -> postAsyncIDE (do + selectRef mbLogRef + selectBreak mbLogRef) >> return e)) + registerEvent stRef "TraceChanged" + (Left (\ e@TraceChanged -> fillTraceList >> return e)) + registerEvent stRef "GetTextPopup" + (Left (\ e@(GetTextPopup _) -> return (GetTextPopup (Just textPopupMenu)))) + registerEvent stRef "StatusbarChanged" + (Left (\ e@(StatusbarChanged args) + -> changeStatusbar args >> return e)) + registerEvent stRef "WorkspaceAddPackage" + (Left (\ e@(WorkspaceAddPackage fp) + -> workspaceAddPackage' fp >> 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 @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Completion --- Copyright : 2007-2009 Hamish Mackenzie, Jürgen Nicklisch-Franken +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : @@ -14,19 +14,21 @@ module IDE.Completion (complete, cancel) where -import Data.List as List +import Prelude hiding(getChar, getLine) + +import Data.List as List hiding(insert) import Data.Char import Data.IORef import Control.Monad import Control.Monad.Trans (liftIO) -import Graphics.UI.Gtk as Gtk -import Graphics.UI.Gtk.SourceView -import Graphics.UI.Gtk.Gdk.Events as Gtk +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 -complete :: SourceView -> Bool -> IDEAction +complete :: EditorView -> Bool -> IDEAction complete sourceView always = do currentState' <- readIDE currentState prefs' <- readIDE prefs @@ -47,155 +49,146 @@ cancelCompletion window tv st conn _ -> return () -initCompletion :: SourceView -> IDEAction +initCompletion :: EditorView -> IDEAction initCompletion sourceView = do ideR <- ask completion' <- readIDE completion case completion' of Just (CompletionWindow window' tree' store') -> do - cids <- liftIO $ addEventHandling sourceView tree' store' ideR + cids <- addEventHandling window' sourceView tree' store' modifyIDE_ (\ide -> ide{currentState = IsCompleting cids}) updateOptions window' tree' store' sourceView cids Nothing -> do windows <- getWindows prefs <- readIDE prefs - (window', tree', store', cids) <- reifyIDE (\ideR -> do - window <- windowNewPopup - set window [ windowTypeHint := WindowTypeHintTooltip, - windowDecorated := False ] - --widgetSetSizeRequest window 700 300 - windowSetTransientFor window (head windows) - paned <- hPanedNew - containerAdd window paned - scrolledWindow <- scrolledWindowNew Nothing Nothing - widgetSetSizeRequest scrolledWindow 300 300 - containerAdd paned scrolledWindow - tree <- treeViewNew - containerAdd scrolledWindow tree - store <- listStoreNew [] - treeViewSetModel tree store - - font <- case textviewFont prefs of - Just str -> do - fontDescriptionFromString str - Nothing -> do - f <- fontDescriptionNew - fontDescriptionSetFamily f "Monospace" - return f - widgetModifyFont tree (Just font) + window <- liftIO $ do + windowNewPopup + liftIO $ set window [ windowTypeHint := WindowTypeHintUtility, + windowDecorated := False, + windowResizable := True ] + --liftIO $ widgetSetSizeRequest window 700 300 + liftIO $ containerSetBorderWidth window 3 + liftIO $ windowSetTransientFor window (head windows) + paned <- liftIO $ hPanedNew + liftIO $ containerAdd window paned + nameScrolledWindow <- liftIO $ scrolledWindowNew Nothing Nothing + liftIO $ widgetSetSizeRequest nameScrolledWindow 250 400 + tree <- liftIO $ treeViewNew + liftIO $ containerAdd nameScrolledWindow tree + store <- liftIO $ listStoreNew [] + liftIO $ treeViewSetModel tree store - column <- treeViewColumnNew - set column [ treeViewColumnSizing := TreeViewColumnAutosize ] - treeViewAppendColumn tree column - renderer <- cellRendererTextNew - treeViewColumnPackStart column renderer True - cellLayoutSetAttributes column renderer store (\name -> [ cellText := name ]) + font <- liftIO $ case textviewFont prefs of + Just str -> do + fontDescriptionFromString str + Nothing -> do + f <- fontDescriptionNew + fontDescriptionSetFamily f "Monospace" + return f + liftIO $ widgetModifyFont tree (Just font) - set tree [treeViewHeadersVisible := False] + column <- liftIO $ treeViewColumnNew + liftIO $ set column [ + treeViewColumnSizing := TreeViewColumnAutosize, + treeViewColumnMinWidth := 800] -- OSX does not like it if there is no hscroll + liftIO $ treeViewAppendColumn tree column + renderer <- liftIO $ cellRendererTextNew + liftIO $ treeViewColumnPackStart column renderer True + liftIO $ cellLayoutSetAttributes column renderer store (\name -> [ cellText := name ]) - descriptionView <- sourceViewNew - descriptionBuffer <- (get descriptionView textViewBuffer) >>= (return . castToSourceBuffer) - lm <- sourceLanguageManagerNew - mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell") - case mbLang of - Nothing -> return () - Just lang -> do sourceBufferSetLanguage descriptionBuffer lang + liftIO $ set tree [treeViewHeadersVisible := False] - -- This call is here because in the past I have had problems where the - -- language object became invalid if the manager was garbage collected - sourceLanguageManagerGetLanguageIds lm + descriptionBuffer <- newGtkBuffer Nothing "" + descriptionView <- newView descriptionBuffer + setFont descriptionView $ textviewFont prefs + setStyle descriptionBuffer $ sourceStyle prefs + descriptionScrolledWindow <- getScrolledWindow descriptionView - sourceBufferSetHighlightSyntax descriptionBuffer True - widgetModifyFont descriptionView (Just font) + liftIO $ widgetSetSizeRequest descriptionScrolledWindow 500 400 + visible <- liftIO $ newIORef False + activeView <- liftIO $ newIORef Nothing - containerAdd paned descriptionView + treeSelection <- liftIO $ treeViewGetSelection tree - visible <- newIORef False - activeView <- newIORef Nothing + liftIO $ treeSelection `onSelectionChanged` (do + treeSelectionSelectedForeach treeSelection (\treePath -> (do + rows <- treeSelectionGetSelectedRows treeSelection + case rows of + [treePath] -> reflectIDE (withWord store treePath (\name -> do + description <- getDescription name + setText descriptionBuffer description + )) ideR + _ -> return () + )) + ) - treeSelection <- treeViewGetSelection tree + liftIO $ panedAdd1 paned nameScrolledWindow + liftIO $ panedAdd2 paned descriptionScrolledWindow - treeSelection `onSelectionChanged` (do - treeSelectionSelectedForeach treeSelection (\treePath -> (do - rows <- treeSelectionGetSelectedRows treeSelection - case rows of - [treePath] -> withWord store treePath (\name -> do - description <- reflectIDE (getDescription name) ideR - textBufferSetText descriptionBuffer description - ) - _ -> return () - )) - ) + cids <- addEventHandling window sourceView tree store - cids <- liftIO $ addEventHandling sourceView tree store ideR - return (window, tree, store, cids) - ) modifyIDE_ (\ide -> ide{currentState = IsCompleting cids, - completion = Just (CompletionWindow window' tree' store')}) - updateOptions window' tree' store' sourceView cids + completion = Just (CompletionWindow window tree store)}) + updateOptions window tree store sourceView cids -addEventHandling :: SourceView -> TreeView -> ListStore String -> IDERef -> IO Connections -addEventHandling sourceView tree store ideR = do - cidPress <- sourceView `onKeyPress` (\event -> do - let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event - Just model <- treeViewGetModel tree - selection <- treeViewGetSelection tree - count <- treeModelIterNChildren model Nothing - Just column <- treeViewGetColumn tree 0 +addEventHandling :: Window -> EditorView -> TreeView -> ListStore String -> IDEM Connections +addEventHandling window sourceView tree store = do + ideR <- ask + cidsPress <- sourceView `onKeyPress` \name modifier keyVal -> do + char <- liftIO $ keyvalToChar keyVal + Just model <- liftIO $ treeViewGetModel tree + selection <- liftIO $ treeViewGetSelection tree + count <- liftIO $ treeModelIterNChildren model Nothing + Just column <- liftIO $ treeViewGetColumn tree 0 case (name, modifier, char) of ("Tab", _, _) -> (do - visible <- get tree widgetVisible + visible <- liftIO $ get tree widgetVisible if visible then (do - maybeRow <- getRow tree - case maybeRow of - Just row -> treeViewRowActivated tree [row] column - Nothing -> return () + tryToUpdateOptions window tree store sourceView True return True ) else return False ) ("Return", _, _) -> (do - visible <- get tree widgetVisible + visible <- liftIO $ get tree widgetVisible if visible then (do - maybeRow <- getRow tree + maybeRow <- liftIO $ getRow tree case maybeRow of Just row -> (do - treeViewRowActivated tree [row] column + liftIO $ treeViewRowActivated tree [row] column return True ) Nothing -> (do - reflectIDE cancel ideR + cancel return False ) ) else return False ) ("Down", _, _) -> (do - visible <- get tree widgetVisible + visible <- liftIO $ get tree widgetVisible if visible then (do - maybeRow <- getRow tree + maybeRow <- liftIO $ getRow tree let newRow = maybe 0 (\row -> row + 1) maybeRow - when (newRow < count) (do + when (newRow < count) $ liftIO $ do treeSelectionSelectPath selection [newRow] treeViewScrollToCell tree [newRow] column Nothing -- Crazy hack to avoid the horizontal scroll treeViewScrollToCell tree [newRow] column Nothing - ) return True ) else return False ) ("Up", _, _) -> (do - visible <- get tree widgetVisible + visible <- liftIO $ get tree widgetVisible if visible then (do - maybeRow <- getRow tree + maybeRow <- liftIO $ getRow tree let newRow = maybe 0 (\row -> row - 1) maybeRow - when (newRow >= 0) (do + when (newRow >= 0) $ liftIO $ do treeSelectionSelectPath selection [newRow] treeViewScrollToCell tree [newRow] column Nothing -- Crazy hack to avoid the horizontal scroll treeViewScrollToCell tree [newRow] column Nothing - ) return True ) else return False @@ -210,50 +203,56 @@ return False ) _ -> (do - reflectIDE cancel ideR + cancel return False ) - ) - cidRelease <- sourceView `onKeyRelease` (\event -> do - let Key { eventKeyName = name, eventModifier = modifier, eventKeyChar = char } = event - case (name, modifier, char) of - ("BackSpace", _, _) -> (do - reflectIDE (complete sourceView False) ideR + cidsRelease <- sourceView `onKeyRelease` \name modifier keyVal -> do + case (name, modifier) of + ("BackSpace", _) -> do + complete sourceView False return False - ) _ -> return False - ) - cidSelected <- tree `onRowActivated` (\treePath column -> (do - withWord store treePath (\name -> do - buffer <- textViewGetBuffer sourceView - (start, end) <- textBufferGetSelectionBounds buffer - isWordEnd <- textIterEndsWord end - if isWordEnd then (do - moveToWordStart start - wordStart <- textBufferGetText buffer start end True - if (isPrefixOf wordStart name) then (do - textBufferDelete buffer start end - textBufferInsert buffer start name - ) - else return () - ) - else return () - ) - reflectIDE cancel ideR)) - return [ConnectC cidPress,ConnectC cidRelease, ConnectC cidSelected] + idButtonPress <- liftIO $ window `on` buttonPressEvent $ do + button <- eventButton + (x, y) <- eventCoordinates + time <- eventTime + (width, _) <- liftIO $ widgetGetSize window + liftIO $ windowBeginResizeDrag window + (if floor x < width `div` 2 then WindowEdgeSouthWest else WindowEdgeSouthEast) + button (floor x) (floor y) time + return True + + idSelected <- liftIO $ tree `onRowActivated` (\treePath column -> (do + reflectIDE (withWord store treePath (replaceWordStart sourceView)) ideR + liftIO $ postGUIAsync $ reflectIDE cancel ideR)) + + return $ concat [cidsPress, cidsRelease, [ConnectC idButtonPress, ConnectC idSelected]] + +withWord :: ListStore String -> TreePath -> (String -> IDEM ()) -> IDEM () withWord store treePath f = (do case treePath of [row] -> (do - value <- listStoreGetValue store row + value <- liftIO $ listStoreGetValue store row f value ) _ -> return () ) -cancelCompletion :: TreeViewClass alpha => Window -> alpha -> - ListStore String -> Connections -> IDEAction +replaceWordStart :: EditorView -> String -> IDEM () +replaceWordStart sourceView name = do + buffer <- getBuffer sourceView + (selStart, end) <- getSelectionBounds buffer + isWordEnd <- endsWord end + when isWordEnd $ do + start <- findWordStart selStart + wordStart <- getText buffer start end True + case stripPrefix wordStart name of + Just extra -> insert buffer end extra + Nothing -> return () + +cancelCompletion :: Window -> TreeView -> ListStore String -> Connections -> IDEAction cancelCompletion window tree store connections = do liftIO (do listStoreClear (store :: ListStore String) @@ -262,59 +261,113 @@ ) modifyIDE_ (\ide -> ide{currentState = IsRunning}) -updateOptions :: TreeViewClass alpha => Window -> alpha -> ListStore String -> SourceView -> Connections -> IDEAction -updateOptions window tree store sourceView connections = - reifyIDE (\ideR -> do - buffer <- textViewGetBuffer sourceView - listStoreClear (store :: ListStore String) - (start, end) <- textBufferGetSelectionBounds buffer - moveToWordStart start - equal <- textIterEqual start end - if equal - then reflectIDE (cancelCompletion window tree store connections) ideR - else do - wordStart <- textBufferGetText buffer start end True - postGUIAsync $ do - options <- reflectIDE (getCompletionOptions wordStart) ideR - processResults ideR window tree store sourceView wordStart options - return () - return ()) +updateOptions :: Window -> TreeView -> ListStore String -> EditorView -> Connections -> IDEAction +updateOptions window tree store sourceView connections = do + result <- tryToUpdateOptions window tree store sourceView False + when (not result) $ cancelCompletion window tree store connections -moveToWordStart iter = do - textIterBackwardWordStart iter - isStart <- textIterIsStart iter - when (not isStart) $ do - prev <- textIterCopy iter - textIterBackwardChar prev - maybeChar <- textIterGetChar prev - case maybeChar of - Just '_' -> (do - textIterBackwardChar iter - moveToWordStart iter - ) - _ -> return () +tryToUpdateOptions :: Window -> TreeView -> ListStore String -> EditorView -> Bool -> IDEM Bool +tryToUpdateOptions window tree store sourceView selectLCP = do + ideR <- ask + liftIO $ listStoreClear (store :: ListStore String) + buffer <- getBuffer sourceView + (selStart, end) <- getSelectionBounds buffer + start <- findWordStart selStart + equal <- iterEqual start end + if equal + then return False + else do + wordStart <- getText buffer start end True + liftIO $ postGUIAsync $ do + reflectIDE (do + options <- getCompletionOptions wordStart + processResults window tree store sourceView wordStart options selectLCP) ideR + return () + return True -processResults ideR window tree store sourceView wordStart options = do +findWordStart :: EditorIter -> IDEM EditorIter +findWordStart iter = do + maybeWS <- backwardWordStartC iter + case maybeWS of + Nothing -> atOffset iter 0 + Just ws -> do + prev <- backwardCharC ws + maybeChar <- getChar prev + case maybeChar of + Just '_' -> findWordStart prev + _ -> return ws + +longestCommonPrefix (x:xs) (y:ys) | x == y = x : longestCommonPrefix xs ys +longestCommonPrefix _ _ = [] + +processResults :: Window -> TreeView -> ListStore String -> EditorView -> String -> [String] -> Bool -> IDEAction +processResults window tree store sourceView wordStart options selectLCP = do case options of - [] -> reflectIDE cancel ideR + [] -> cancel _ -> do - buffer <- textViewGetBuffer sourceView - (start, end) <- textBufferGetSelectionBounds buffer - isWordEnd <- textIterEndsWord end - when isWordEnd (do - moveToWordStart start - newWordStart <- textBufferGetText buffer start end True - when (isPrefixOf wordStart newWordStart) (do - listStoreClear store - forM_ (take 200 (List.filter (isPrefixOf newWordStart) options)) (listStoreAppend store) - Rectangle startx starty width height <- textViewGetIterLocation sourceView start - (x, y) <- textViewBufferToWindowCoords sourceView TextWindowWidget (startx, starty+height) - drawWindow <- widgetGetDrawWindow sourceView - (ox, oy) <- drawWindowGetOrigin drawWindow - windowMove window (ox+x) (oy+y) - when ((length options) == 1) $ treeViewSetCursor tree [0] Nothing - widgetShowAll window)) + buffer <- getBuffer sourceView + (selStart, end) <- getSelectionBounds buffer + isWordEnd <- endsWord end + when isWordEnd $ do + start <- findWordStart selStart + currentWordStart <- getText buffer start end True + newWordStart <- do + if selectLCP && currentWordStart == wordStart && (not $ null options) + then do + let lcp = foldl1 longestCommonPrefix options + return lcp + else + return currentWordStart + when (isPrefixOf wordStart newWordStart) $ do + liftIO $ listStoreClear store + let newOptions = List.filter (isPrefixOf newWordStart) options + liftIO $ forM_ (take 200 newOptions) (listStoreAppend store) + Rectangle startx starty width height <- getIterLocation sourceView start + (wWindow, hWindow) <- liftIO $ windowGetSize window + (x, y) <- bufferToWindowCoords sourceView (startx, starty+height) + drawWindow <- getDrawWindow sourceView + (ox, oy) <- liftIO $ drawWindowGetOrigin drawWindow + Just namesSW <- liftIO $ widgetGetParent tree + (wNames, hNames) <- liftIO $ widgetGetSize namesSW + Just paned <- liftIO $ widgetGetParent namesSW + Just first <- liftIO $ panedGetChild1 (castToPaned paned) + Just second <- liftIO $ panedGetChild2 (castToPaned paned) + screen <- liftIO $ windowGetScreen window + monitor <- liftIO $ screenGetMonitorAtPoint screen (ox+x) (oy+y) + monitorLeft <- liftIO $ screenGetMonitorAtPoint screen (ox+x-wWindow+wNames) (oy+y) + monitorRight <- liftIO $ screenGetMonitorAtPoint screen (ox+x+wWindow) (oy+y) + monitorBelow <- liftIO $ screenGetMonitorAtPoint screen (ox+x) (oy+y+hWindow) + wScreen <- liftIO $ screenGetWidth screen + hScreen <- liftIO $ screenGetHeight screen + top <- if monitorBelow /= monitor || (oy+y+hWindow) > hScreen + then do + sourceSW <- getScrolledWindow sourceView + (_, hSource) <- liftIO $ widgetGetSize sourceSW + scrollToIter sourceView end 0.1 (Just (1.0, 1.0 - (fromIntegral hWindow / fromIntegral hSource))) + (_, newy) <- bufferToWindowCoords sourceView (startx, starty+height) + return (oy+newy) + else return (oy+y) + swap <- if (monitorRight /= monitor || (ox+x+wWindow) > wScreen) && monitorLeft == monitor && (ox+x-wWindow+wNames) > 0 + then do + liftIO $ windowMove window (ox+x-wWindow+wNames) top + return $ first == namesSW + else do + liftIO $ windowMove window (ox+x) top + return $ first /= namesSW + when swap $ liftIO $ do + pos <- panedGetPosition (castToPaned paned) + containerRemove (castToPaned paned) first + containerRemove (castToPaned paned) second + panedAdd1 (castToPaned paned) second + panedAdd2 (castToPaned paned) first + panedSetPosition (castToPaned paned) (wWindow-pos) + when (not $ null newOptions) $ liftIO $ treeViewSetCursor tree [0] Nothing + liftIO $ widgetShowAll window + + when (newWordStart /= currentWordStart) $ + replaceWordStart sourceView newWordStart + getRow tree = do Just model <- treeViewGetModel tree selection <- treeViewGetSelection tree @@ -325,5 +378,3 @@ return $ Just row ) Nothing -> return Nothing - - 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,5 @@ {-# OPTIONS_GHC -XFlexibleContexts -XTypeSynonymInstances -XMultiParamTypeClasses - -XScopedTypeVariables #-} + -XScopedTypeVariables -XCPP -XDeriveDataTypeable #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.State @@ -17,10 +17,7 @@ ------------------------------------------------------------------------------- module IDE.Core.State ( - IDEObject -, IDEEditor -, IDE(..) -, window + window , errorRefs , breakpointRefs , contextRefs @@ -32,102 +29,188 @@ , setCurrentContext , isInterpreting -, IDEState(..) , isStartingOrClosing -, IDERef -, IDEM -, IDEAction -, IDEEvent(..) , triggerEventIDE +, deactivatePane + -- * Convenience methods for accesing the IDE State , readIDE , modifyIDE , modifyIDE_ , withIDE , getIDE +, throwIDE , reifyIDE , reflectIDE , catchIDE , postSyncIDE , postAsyncIDE - -, newPane +, forkIDE -, ideMessage -, logMessage , sysMessage , MessageLevel(..) +, ideMessage +, logMessage , withoutRecordingDo -, activatePane -, deactivatePane -, deactivatePaneIfActive -, closePane - -, getCandyState -, setCandyState -, getForgetSession - -, getSBSpecialKeys -, getSBActivePane -, getSBActivePackage -, getSBErrors -, getStatusbarIO -, getStatusbarLC - -, getBackgroundBuildToggled -, setBackgroundBuildToggled -, getBackgroundLinkToggled -, setBackgroundLinkToggled -, getDebugToggled -, setDebugToggled - -, getRecentFiles -, getRecentPackages -, controlIsPressed +--, deactivatePane +--, deactivatePaneIfActive +--, closePane +, activeProjectDir -, Session +#ifdef YI +, liftYiControl +#endif , module IDE.Core.Types +, module IDE.Core.CTypes +, module IDE.Utils.Utils , module Graphics.UI.Frame.Panes , module Graphics.UI.Frame.ViewFrame -, module IDE.Exception ) where import Graphics.UI.Gtk hiding (get) import Graphics.UI.Gtk.SourceView.SourceView () -import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) -import qualified Graphics.UI.Gtk.Gdk.Events as G (Event(..)) -import Data.Map (Map) -import qualified Data.Map as Map + import Data.IORef import Control.Monad.Reader hiding (liftIO) -import qualified Control.Monad.Reader (liftIO) -import Control.Monad.Trans -import HscTypes hiding (liftIO) -import Data.Unique import Control.Exception import Prelude hiding (catch) - +import Control.Monad.State import IDE.Core.Types import Graphics.UI.Frame.Panes -import Graphics.UI.Frame.ViewFrame hiding (notebookInsertOrdered) -import qualified Graphics.UI.Frame.ViewFrame as VF (notebookInsertOrdered) -import IDE.Exception +import Graphics.UI.Frame.ViewFrame --hiding (notebookInsertOrdered) import Control.Event import System.IO -import System.Process (ProcessHandle(..)) -import IDE.Tool (ToolState(..)) import Data.Maybe (isJust) +import System.FilePath (dropFileName) +import IDE.Core.CTypes +import Control.Concurrent (forkIO) +import IDE.Utils.Utils +import qualified Data.Map as Map (lookup) +import Data.Typeable(Typeable) --- this should not be repeated here, why is it necessary? -instance MonadIO Ghc where - liftIO ioA = Ghc $ \_ -> ioA +#ifdef YI +import qualified Yi as Yi +import qualified Yi.UI.Pango.Control as Yi +#endif + +instance PaneMonad IDEM where + getFrameState = readIDE frameState + setFrameState v = modifyIDE_ (\ide -> ide{frameState = v}) + runInIO f = reifyIDE (\ideRef -> return (\v -> reflectIDE (f v) ideRef)) + panePathForGroup id = do + prefs <- readIDE prefs + case id `lookup` (categoryForPane prefs) of + Just group -> case group `lookup` (pathForCategory prefs) of + Nothing -> return (defaultPath prefs) + Just p -> return p + Nothing -> return (defaultPath prefs) + getThisPane = getPanePrim + -- getThisPane :: forall alpha beta . RecoverablePane alpha beta delta => Maybe PanePath -> delta alpha + getOrBuildThisPane ePpoPid = do + mbPane <- getPanePrim + case mbPane of + Nothing -> do + pp <- case ePpoPid of + Right pId -> getBestPathForId pId + Left ppp -> do + layout <- getLayout + return (getBestPanePath ppp layout) + nb <- getNotebook pp + buildPane pp nb builder + Just pane -> return (Just pane) + + -- displayThisPane :: Bool -> delta alpha + displayThisPane pane shallGrabFocus = do + liftIO $ bringPaneToFront pane + when shallGrabFocus $ liftIO $ widgetGrabFocus $ getTopWidget pane + -- buildThisPane :: forall alpha beta . RecoverablePane alpha beta delta => PanePath -> + -- Notebook -> + -- (PanePath -> Notebook -> Window -> delta (alpha,Connections)) -> + -- delta alpha + buildThisPane panePath notebook builder = do + windows <- getWindows + + (mbBuf,cids) <- builder panePath notebook (head windows) + case mbBuf of + Nothing -> return Nothing + Just buf -> do + panes' <- getPanesSt + paneMap' <- getPaneMapSt + let b1 = case Map.lookup (paneName buf) paneMap' of + Nothing -> True + Just it -> False + let b2 = case Map.lookup (paneName buf) panes' of + Nothing -> True + Just it -> False + if b1 && b2 + then do + notebookInsertOrdered notebook (getTopWidget buf) (paneName buf) Nothing False + addPaneAdmin buf cids panePath + liftIO $ do + widgetSetName (getTopWidget buf) (paneName buf) + widgetShowAll (getTopWidget buf) + widgetGrabFocus (getTopWidget buf) + bringPaneToFront buf + return (Just buf) + else return Nothing + --activateThisPane :: forall alpha beta . RecoverablePane alpha beta delta => alpha -> Connections -> delta () + activateThisPane pane conn = do + mbAP <- getActivePane + case mbAP of + Just (pn,_) | pn == paneName pane -> return () + _ -> do + deactivatePaneWithout + triggerEventIDE (StatusbarChanged [CompartmentPane (Just (PaneC pane))]) + liftIO $ bringPaneToFront pane + setActivePane (Just (paneName pane,conn)) + trigger (Just (paneName pane)) + (case mbAP of + Nothing -> Nothing + Just (pn,_) -> Just pn) + modifyIDE_ (\ide -> ide{recentPanes = + paneName pane : filter (/= paneName pane) (recentPanes ide)}) + return () + where + trigger :: Maybe String -> Maybe String -> IDEAction + trigger s1 s2 = do + triggerEventIDE (RecordHistory ((PaneSelected s1), PaneSelected s2)) + triggerEventIDE (Sensitivity [(SensitivityEditor, False)]) + return () + --closeThisPane :: forall alpha beta . RecoverablePane alpha beta delta => alpha -> delta Bool + closeThisPane pane = do + (panePath,_) <- guiPropertiesFromName (paneName pane) + nb <- getNotebook panePath + mbI <- liftIO $notebookPageNum nb (getTopWidget pane) + case mbI of + Nothing -> liftIO $ do + error ("notebook page not found: unexpected " ++ paneName pane ++ " " ++ show panePath) + return False + Just i -> do + deactivatePaneIfActive pane + liftIO $ do + notebookRemovePage nb i + widgetDestroy (getTopWidget pane) + removePaneAdmin pane + modifyIDE_ (\ide -> ide{recentPanes = filter (/= paneName pane) (recentPanes ide)}) + return True + +data MessageLevel = Silent | Normal | High + deriving (Eq,Ord,Show) + + +-- Shall be replaced +sysMessage :: MonadIO m => MessageLevel -> String -> m () +sysMessage ml str = liftIO $ do + putStrLn str + hFlush stdout + ideMessage :: MessageLevel -> String -> IDEAction ideMessage level str = do triggerEventIDE (LogMessage (str ++ "\n") LogTag) @@ -137,57 +220,32 @@ logMessage str tag = do triggerEventIDE (LogMessage (str ++ "\n") tag) return () +-- with hslogger -sysMessage :: MonadIO m => MessageLevel -> String -> m () -sysMessage ml str = liftIO $ do - putStrLn str - hFlush stdout +---- --------------------------------------------------------------------- +---- Exception handling +---- -data MessageLevel = Silent | Normal | High - deriving (Eq,Ord,Show) +data IDEException = IDEException String + deriving Typeable -class IDEObject alpha -class IDEObject o => IDEEditor o +instance Show IDEException where + show (IDEException str) = str --- --------------------------------------------------------------------- --- IDE State --- +instance Exception IDEException --- --- | The IDE state --- -data IDE = IDE { - frameState :: FrameState IDEM -- ^ state of the windows framework -, recentPanes :: [PaneName] -, specialKeys :: SpecialKeyTable IDERef -- ^ a structure for emacs like keystrokes -, specialKey :: SpecialKeyCons IDERef -- ^ the first of a double keystroke -, candy :: CandyTable -- ^ table for source candy -, prefs :: Prefs -- ^ configuration preferences -, activePack :: Maybe IDEPackage -, projFilesCache :: Map FilePath Bool -- ^ caches property that a buffer belongs to a project -, allLogRefs :: [LogRef] -, currentEBC :: (Maybe LogRef, Maybe LogRef, Maybe LogRef) -, currentHist :: Int -, accessibleInfo :: (Maybe (PackageScope)) -- ^ the world scope -, currentInfo :: (Maybe (PackageScope,PackageScope)) - -- ^ the first is for the current package, - --the second is the scope in the current package -, handlers :: Map String [(Unique, IDEEvent -> IDEM IDEEvent)] - -- ^ event handling table -, currentState :: IDEState -, guiHistory :: (Bool,[GUIHistory],Int) -, findbar :: (Bool,Maybe (Toolbar,ListStore String)) -, toolbar :: (Bool,Maybe Toolbar) -, recentFiles :: [FilePath] -, recentPackages :: [FilePath] -, runningTool :: Maybe ProcessHandle -, ghciState :: Maybe ToolState -, completion :: Maybe CompletionWindow -} --deriving Show +throwIDE str = throw (IDEException str) --- Main window is just the first one in the list + +-- Main window is always the first one in the list window = head . windows +activeProjectDir :: IDEM FilePath +activeProjectDir = do + activePack' <- readIDE activePack + case activePack' of + Nothing -> return "." + Just pack -> return (dropFileName (ipdCabalFile pack)) errorRefs :: IDE -> [LogRef] errorRefs = (filter ((\t -> t == ErrorRef || t == WarningRef) . logRefType)) . allLogRefs @@ -210,14 +268,6 @@ triggerEventIDE (CurrentBreakChanged b) >> return () setCurrentContext c = modifyIDE_ (\ide -> ide{currentEBC = (currentError ide, currentBreak ide, c)}) - -data IDEState = - IsStartingUp - | IsShuttingDown - | IsRunning - | IsFlipping TreeView - | IsCompleting Connections - isStartingOrClosing :: IDEState -> Bool isStartingOrClosing IsStartingUp = True isStartingOrClosing IsShuttingDown = True @@ -227,95 +277,12 @@ isInterpreting = do readIDE ghciState >>= \mb -> return (isJust mb) - -data IDEEvent = - CurrentInfo - | ActivePack - | SelectInfo String - | SelectIdent Descr - | LogMessage String LogTag - | RecordHistory GUIHistory - | Sensitivity [(SensitivityMask,Bool)] - | DescrChoice [Descr] - | SearchMeta String - | LoadSession FilePath - | SaveSession FilePath - | UpdateRecent - | VariablesChanged - | ErrorChanged - | CurrentErrorChanged (Maybe LogRef) - | BreakpointChanged - | CurrentBreakChanged (Maybe LogRef) - | TraceChanged - | GetTextPopup (Maybe (IDERef -> Menu -> IO ())) --- --- | A mutable reference to the IDE state --- -type IDERef = IORef IDE - -instance Event IDEEvent String where - getSelector CurrentInfo = "CurrentInfo" - getSelector ActivePack = "ActivePack" - getSelector (LogMessage _ _) = "LogMessage" - getSelector (SelectInfo _) = "SelectInfo" - getSelector (SelectIdent _) = "SelectIdent" - getSelector (RecordHistory _) = "RecordHistory" - getSelector (Sensitivity _) = "Sensitivity" - getSelector (DescrChoice _) = "DescrChoice" - getSelector (SearchMeta _) = "SearchMeta" - getSelector (LoadSession _) = "LoadSession" - getSelector (SaveSession _) = "SaveSession" - getSelector UpdateRecent = "UpdateRecent" - getSelector VariablesChanged = "VariablesChanged" - getSelector ErrorChanged = "ErrorChanged" - getSelector (CurrentErrorChanged _) = "CurrentErrorChanged" - getSelector BreakpointChanged = "BreakpointChanged" - getSelector (CurrentBreakChanged _) = "CurrentBreakChanged" - getSelector TraceChanged = "TraceChanged" - getSelector (GetTextPopup _) = "GetTextPopup" - -instance EventSource IDERef IDEEvent IDEM String where - canTriggerEvent o "CurrentInfo" = True - canTriggerEvent o "ActivePack" = True - canTriggerEvent o "LogMessage" = True - canTriggerEvent o "SelectInfo" = True - canTriggerEvent o "SelectIdent" = True - canTriggerEvent o "RecordHistory" = True - canTriggerEvent o "Sensitivity" = True - canTriggerEvent o "DescrChoice" = True - canTriggerEvent o "SearchMeta" = True - canTriggerEvent o "LoadSession" = True - canTriggerEvent o "SaveSession" = True - canTriggerEvent o "UpdateRecent" = True - canTriggerEvent o "VariablesChanged" = True - canTriggerEvent o "ErrorChanged" = True - canTriggerEvent o "CurrentErrorChanged" = True - canTriggerEvent o "BreakpointChanged" = True - canTriggerEvent o "CurrentBreakChanged" = True - canTriggerEvent o "TraceChanged" = True - canTriggerEvent o "GetTextPopup" = True - canTriggerEvent _ _ = False - - getHandlers ideRef = do - ide <- liftIO $ readIORef ideRef - return (handlers ide) - - setHandlers ideRef nh = do - ide <- liftIO $ readIORef ideRef - liftIO $ writeIORef ideRef (ide {handlers= nh}) - - myUnique _ = do - liftIO $ newUnique - -instance EventSelector String - triggerEventIDE :: IDEEvent -> IDEM IDEEvent triggerEventIDE e = ask >>= \ideR -> triggerEvent ideR e -- -- | A reader monad for a mutable reference to the IDE state -- -type IDEM = ReaderT IDERef IO reifyIDE :: (IDERef -> IO a) -> IDEM a reifyIDE = ReaderT @@ -323,50 +290,27 @@ reflectIDE :: IDEM a -> IDERef -> IO a reflectIDE c ideR = runReaderT c ideR +#ifdef YI + +liftYiControl :: Yi.ControlM a -> IDEM a +liftYiControl f = do + control <- readIDE yiControl + liftIO $ Yi.runControl f control + +#endif + catchIDE :: Exception e => IDEM a -> (e -> IO a) -> IDEM a catchIDE block handler = reifyIDE (\ideR -> catch (reflectIDE block ideR) handler) +forkIDE :: IDEAction -> IDEAction +forkIDE block = reifyIDE (\ideR -> forkIO (reflectIDE block ideR) >> return ()) + postSyncIDE :: IDEM a -> IDEM a postSyncIDE f = reifyIDE (\ideR -> postGUISync (reflectIDE f ideR)) postAsyncIDE :: IDEM () -> IDEM () postAsyncIDE f = reifyIDE (\ideR -> postGUIAsync (reflectIDE f ideR)) -newPane :: RecoverablePane alpha beta IDEM => - PanePath -> - Notebook -> - (PanePath -> Notebook -> Window -> IDERef -> IO (alpha,Connections)) -> - IDEM alpha -newPane panePath notebook builder = do - windows <- getWindows - (buf,cids) <- reifyIDE (\ideR -> builder panePath notebook (head windows) ideR) - VF.notebookInsertOrdered notebook (getTopWidget buf) (paneName buf) Nothing - addPaneAdmin buf cids panePath - liftIO $ do - widgetShowAll (getTopWidget buf) - widgetGrabFocus (getTopWidget buf) - bringPaneToFront buf - return buf - --- --- | A shorthand for a reader monad for a mutable reference to the IDE state --- which does not return a value --- -type IDEAction = IDEM () - -instance PaneMonad IDEM where - getFrameState = readIDE frameState - setFrameState v = modifyIDE_ (\ide -> ide{frameState = v}) - runInIO f = reifyIDE (\ideRef -> return (\v -> reflectIDE (f v) ideRef)) - panePathForGroup id = do - prefs <- readIDE prefs - case id `lookup` (categoryForPane prefs) of - Just group -> case group `lookup` (pathForCategory prefs) of - Nothing -> return (defaultPath prefs) - Just p -> return p - Nothing -> return (defaultPath prefs) - - -- --------------------------------------------------------------------- -- Convenience methods for accesing the IDE State -- @@ -377,7 +321,7 @@ e <- ask liftIO $ liftM f (readIORef e) --- | Modify the contents, using an IO action. +-- | Modify the contents, without returning a value modifyIDE_ :: (IDE -> IDE) -> IDEM () modifyIDE_ f = let f' a = (f a,()) in do e <- ask @@ -416,31 +360,6 @@ -- (e.g. Events for history) -- -activatePane :: Pane alpha IDEM => alpha -> Connections -> IDEAction -activatePane pane conn = do - mbAP <- getActivePane - case mbAP of - Just (pn,_) | pn == paneName pane -> return () - _ -> do - deactivatePaneWithout - sb <- getSBActivePane - liftIO $ statusbarPop sb 1 - liftIO $ statusbarPush sb 1 (paneName pane) - liftIO $ bringPaneToFront pane - setActivePane (Just (paneName pane,conn)) - trigger (Just (paneName pane)) (case mbAP of - Nothing -> Nothing - Just (pn,_) -> Just pn) - modifyIDE_ (\ide -> ide{recentPanes = - paneName pane : filter (/= paneName pane) (recentPanes ide)}) - return () - -trigger :: Maybe String -> Maybe String -> IDEAction -trigger s1 s2 = do - triggerEventIDE (RecordHistory ((PaneSelected s1), PaneSelected s2)) - triggerEventIDE (Sensitivity [(SensitivityEditor, False)]) - return () - deactivatePane :: IDEAction deactivatePane = do mbAP <- getActivePane @@ -455,9 +374,7 @@ deactivatePaneWithout :: IDEAction deactivatePaneWithout = do - sb <- getSBActivePane - liftIO $ statusbarPop sb 1 - liftIO $ statusbarPush sb 1 "" + triggerEventIDE (StatusbarChanged [CompartmentPane Nothing]) mbAP <- getActivePane case mbAP of Just (_,signals) -> liftIO $do @@ -465,7 +382,7 @@ Nothing -> return () setActivePane Nothing -deactivatePaneIfActive :: Pane alpha IDEM => alpha -> IDEAction +deactivatePaneIfActive :: RecoverablePane alpha beta IDEM => alpha -> IDEAction deactivatePaneIfActive pane = do mbActive <- getActivePane case mbActive of @@ -474,104 +391,5 @@ then deactivatePane else return () -closePane :: Pane alpha IDEM => alpha -> IDEM Bool -closePane pane = do - (panePath,_) <- guiPropertiesFromName (paneName pane) - nb <- getNotebook panePath - mbI <- liftIO $notebookPageNum nb (getTopWidget pane) - case mbI of - Nothing -> liftIO $ do - throwIDE ("notebook page not found: unexpected " ++ paneName pane ++ " " ++ show panePath) - return False - Just i -> do - deactivatePaneIfActive pane - liftIO $ do - notebookRemovePage nb i - widgetDestroy (getTopWidget pane) - removePaneAdmin pane - modifyIDE_ (\ide -> ide{recentPanes = filter (/= paneName pane) (recentPanes ide)}) - return True --- get widget elements (menu & toolbar) - -getCandyState :: PaneMonad alpha => alpha Bool -getCandyState = do - ui <- getUIAction "ui/menubar/_Configuration/Source Candy" castToToggleAction - liftIO $toggleActionGetActive ui - -setCandyState :: PaneMonad alpha => Bool -> alpha () -setCandyState b = do - ui <- getUIAction "ui/menubar/_Configuration/Source Candy" castToToggleAction - liftIO $toggleActionSetActive ui b - -getForgetSession :: PaneMonad alpha => alpha (Bool) -getForgetSession = do - ui <- getUIAction "ui/menubar/_Session/Forget Session" castToToggleAction - liftIO $toggleActionGetActive ui - -getMenuItem :: String -> IDEM MenuItem -getMenuItem path = do - uiManager' <- getUiManager - mbWidget <- liftIO $ uiManagerGetWidget uiManager' path - case mbWidget of - Nothing -> throwIDE ("State.hs>>getMenuItem: Can't find ui path " ++ path) - Just widget -> return (castToMenuItem widget) - -getBackgroundBuildToggled :: PaneMonad alpha => alpha (Bool) -getBackgroundBuildToggled = do - ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundBuild" castToToggleAction - liftIO $ toggleActionGetActive ui - -setBackgroundBuildToggled :: PaneMonad alpha => Bool -> alpha () -setBackgroundBuildToggled b = do - ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundBuild" castToToggleAction - liftIO $ toggleActionSetActive ui b - -getBackgroundLinkToggled :: PaneMonad alpha => alpha (Bool) -getBackgroundLinkToggled = do - ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundLink" castToToggleAction - liftIO $ toggleActionGetActive ui - -setBackgroundLinkToggled :: PaneMonad alpha => Bool -> alpha () -setBackgroundLinkToggled b = do - ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundLink" castToToggleAction - liftIO $ toggleActionSetActive ui b - -getDebugToggled :: PaneMonad alpha => alpha (Bool) -getDebugToggled = do - ui <- getUIAction "ui/toolbar/BuildToolItems/Debug" castToToggleAction - liftIO $ toggleActionGetActive ui - -setDebugToggled :: PaneMonad alpha => Bool -> alpha () -setDebugToggled b = do - ui <- getUIAction "ui/toolbar/BuildToolItems/Debug" castToToggleAction - liftIO $ toggleActionSetActive ui b - -getRecentFiles , getRecentPackages :: IDEM MenuItem -getRecentFiles = getMenuItem "ui/menubar/_File/_Recent Files" -getRecentPackages = getMenuItem "ui/menubar/_Package/_Recent Packages" - --- (toolbar) - -getSBSpecialKeys :: PaneMonad alpha => alpha Statusbar -getSBSpecialKeys = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarSpecialKeys"] castToStatusbar - -getSBActivePane :: PaneMonad alpha => alpha Statusbar -getSBActivePane = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarActivePane"] castToStatusbar - -getSBActivePackage :: PaneMonad alpha => alpha Statusbar -getSBActivePackage = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarActiveProject"] castToStatusbar - -getSBErrors :: PaneMonad alpha => alpha Statusbar -getSBErrors = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarErrors"] castToStatusbar - -getStatusbarIO :: PaneMonad alpha => alpha Statusbar -getStatusbarIO = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarInsertOverwrite"] castToStatusbar - -getStatusbarLC :: PaneMonad alpha => alpha Statusbar -getStatusbarLC = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarLineColumn"] castToStatusbar - -controlIsPressed :: G.Event -> Bool -controlIsPressed (G.Button _ _ _ _ _ mods _ _ _) | Control `elem` mods = True -controlIsPressed _ = False 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 @@ -3,7 +3,12 @@ -XExistentialQuantification -XRank2Types -XFlexibleInstances - -XDeriveDataTypeable #-} + -XDeriveDataTypeable + -XFlexibleContexts + -XDeriveDataTypeable + -XTypeSynonymInstances + -XMultiParamTypeClasses #-} + ----------------------------------------------------------------------------- -- -- Module : IDE.Core.Data @@ -21,48 +26,31 @@ ------------------------------------------------------------------------------- module IDE.Core.Types ( - IDEPackage(..) + IDE(..) +, IDEState(..) +, IDERef +, IDEM +, IDEAction +, IDEEvent(..) +, IDEPackage(..) +, Workspace(..) + , ActionDescr(..) , ActionString , KeyString , Prefs(..) +, InstallFlag(..) , LogRefType(..) , LogRef(..) -, filePath +, logRefFilePath +, logRefFullFilePath , isError , isBreakpoint - -, PackageDescr(..) -, ModuleDescr(..) -, Descr(..) -, Present(..) -, SpDescr(..) -, DescrType(..) -, descrName -, typeInfo -, descrModu -, mbLocation -, mbComment -, details -, descrType -, stockIdFromType -, isReexported -, Symbol -, ClassId -, DataId -, TypeInfo -, SymbolTable -, PackageScope -, PackModule(..) -, parsePackModule -, showPackModule -, fromPackageIdentifier -, toPackageIdentifier -, Location(..) -, Scope(..) +, displaySrcSpan +, colorHexString , SearchHint(..) , CandyTable(..) @@ -72,64 +60,242 @@ , SpecialKeyTable , SpecialKeyCons -, LogTag(..) +, PackageDescrCache +, ModuleDescrCache +, CompletionWindow(..) +, LogTag(..) , GUIHistory , GUIHistory'(..) - , SensitivityMask(..) , SearchMode(..) - -, CompletionWindow(..) +, StatusbarCompartment(..) ) where +#ifdef YI +import Yi.UI.Pango.Control as Yi +#endif +import Graphics.UI.Gtk + (Window(..), KeyVal(..), Color(..), Menu(..), TreeView(..), + ListStore(..), Toolbar(..)) import Control.Monad.Reader -import Graphics.UI.Gtk hiding (get) -import Graphics.UI.Gtk.Gdk.Events(Modifier(..)) -import qualified Data.Map as Map ---import Data.Set(Set) -import qualified Data.Set as Set - -import Default -import IDE.Exception +import Data.Unique (newUnique, Unique(..)) import Graphics.UI.Frame.Panes -import Distribution.Package (PackageIdentifier(..),Dependency(..)) -import Distribution.Text +import Distribution.Package + (PackageIdentifier(..), Dependency(..)) import Data.Map (Map(..)) -import Distribution.ModuleName(ModuleName) -import Distribution.Text -import qualified Data.ByteString.Char8 as BS (unpack,empty) -import Data.ByteString.Char8 (ByteString) -import MyMissing -import Data.Typeable (Typeable(..)) -import SrcLoc (SrcSpan(..)) -import FastString (unpackFS) -import Outputable (ppr, showSDoc) import Data.Set (Set(..)) +import Distribution.ModuleName (ModuleName(..)) +import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) +import System.Time (ClockTime(..)) +import Distribution.Simple (Extension(..)) +import System.Process (ProcessHandle(..)) +import IDE.Utils.Tool (ToolState(..)) +import Data.IORef (writeIORef, readIORef, IORef(..)) +import Numeric (showHex) +import Control.Event + (EventSelector(..), EventSource(..), Event(..)) +import System.FilePath (()) +import IDE.Core.CTypes +import System.IO (Handle) -- --------------------------------------------------------------------- --- IDEPackages +-- IDE State -- +-- +-- | The IDE state +-- +data IDE = IDE { + frameState :: FrameState IDEM -- ^ state of the windows framework +, recentPanes :: [PaneName] -- ^ a list of panes which were selected last +, specialKeys :: SpecialKeyTable IDERef -- ^ a structure for emacs like keystrokes +, specialKey :: SpecialKeyCons IDERef -- ^ the first of a double keystroke +, candy :: CandyTable -- ^ table for source candy +, prefs :: Prefs -- ^ configuration preferences +, workspace :: Maybe Workspace -- ^ may be a workspace (set of packages) +, activePack :: Maybe IDEPackage +, bufferProjCache :: Map FilePath (Maybe IDEPackage) +, allLogRefs :: [LogRef] +, currentEBC :: (Maybe LogRef, Maybe LogRef, Maybe LogRef) +, currentHist :: Int +, systemInfo :: (Maybe GenScope) -- ^ the system scope +, packageInfo :: (Maybe (GenScope, GenScope)) -- ^ the second are the imports +, workspaceInfo :: (Maybe (GenScope, GenScope)) -- ^ the second are the imports +, workspInfoCache :: PackageDescrCache +, handlers :: Map String [(Unique, IDEEvent -> IDEM IDEEvent)] -- ^ event handling table +, currentState :: IDEState +, guiHistory :: (Bool,[GUIHistory],Int) +, findbar :: (Bool,Maybe (Toolbar,ListStore String)) +, toolbar :: (Bool,Maybe Toolbar) +, recentFiles :: [FilePath] +, recentWorkspaces :: [FilePath] +, runningTool :: Maybe ProcessHandle +, ghciState :: Maybe ToolState +, completion :: Maybe CompletionWindow +#ifdef YI +, yiControl :: Yi.Control +#endif +, server :: Maybe Handle +} --deriving Show + +-- +-- | A mutable reference to the IDE state +-- +type IDERef = IORef IDE + +-- +-- | The IDE Monad +-- +type IDEM = ReaderT IDERef IO + +-- +-- | A shorthand for a reader monad for a mutable reference to the IDE state +-- which does not return a value +-- +type IDEAction = IDEM () + + +data IDEState = + -- | Leksah is in startup mode + IsStartingUp + -- | Leksah is about to go down + | IsShuttingDown + -- | Leksah is running + | IsRunning + -- | The flipper is used to switch between sources + | IsFlipping TreeView + -- | The completion feature is used + | IsCompleting Connections + + +-- --------------------------------------------------------------------- +-- Events which can be signalled and handled +-- + +data IDEEvent = + InfoChanged Bool-- is it the initial = True else False + | ActivePack (Maybe IDEPackage) + | SelectInfo String + | SelectIdent Descr + | LogMessage String LogTag + | RecordHistory GUIHistory + | Sensitivity [(SensitivityMask,Bool)] + | SearchMeta String + | LoadSession FilePath + | SaveSession FilePath + | UpdateRecent + | VariablesChanged + | ErrorChanged + | CurrentErrorChanged (Maybe LogRef) + | BreakpointChanged + | CurrentBreakChanged (Maybe LogRef) + | TraceChanged + | GetTextPopup (Maybe (IDERef -> Menu -> IO ())) + | StatusbarChanged [StatusbarCompartment] + | WorkspaceChanged + | WorkspaceAddPackage FilePath + +instance Event IDEEvent String where + getSelector (InfoChanged _) = "InfoChanged" + getSelector (ActivePack _) = "ActivePack" + getSelector (LogMessage _ _) = "LogMessage" + getSelector (SelectInfo _) = "SelectInfo" + getSelector (SelectIdent _) = "SelectIdent" + getSelector (RecordHistory _) = "RecordHistory" + getSelector (Sensitivity _) = "Sensitivity" + getSelector (SearchMeta _) = "SearchMeta" + getSelector (LoadSession _) = "LoadSession" + getSelector (SaveSession _) = "SaveSession" + getSelector UpdateRecent = "UpdateRecent" + getSelector VariablesChanged = "VariablesChanged" + getSelector ErrorChanged = "ErrorChanged" + getSelector (CurrentErrorChanged _) = "CurrentErrorChanged" + getSelector BreakpointChanged = "BreakpointChanged" + getSelector (CurrentBreakChanged _) = "CurrentBreakChanged" + getSelector TraceChanged = "TraceChanged" + getSelector (GetTextPopup _) = "GetTextPopup" + getSelector (StatusbarChanged _) = "StatusbarChanged" + getSelector WorkspaceChanged = "WorkspaceChanged" + getSelector (WorkspaceAddPackage _) = "WorkspaceAddPackage" + +instance EventSource IDERef IDEEvent IDEM String where + canTriggerEvent _ "InfoChanged" = True + canTriggerEvent _ "ActivePack" = True + canTriggerEvent _ "LogMessage" = True + canTriggerEvent _ "SelectInfo" = True + canTriggerEvent _ "SelectIdent" = True + canTriggerEvent _ "RecordHistory" = True + canTriggerEvent _ "Sensitivity" = True + canTriggerEvent _ "DescrChoice" = True + canTriggerEvent _ "SearchMeta" = True + canTriggerEvent _ "LoadSession" = True + canTriggerEvent _ "SaveSession" = True + canTriggerEvent _ "UpdateRecent" = True + canTriggerEvent _ "VariablesChanged" = True + canTriggerEvent _ "ErrorChanged" = True + canTriggerEvent _ "CurrentErrorChanged" = True + canTriggerEvent _ "BreakpointChanged" = True + canTriggerEvent _ "CurrentBreakChanged" = True + canTriggerEvent _ "TraceChanged" = True + canTriggerEvent _ "GetTextPopup" = True + canTriggerEvent _ "StatusbarChanged" = True + canTriggerEvent _ "WorkspaceChanged" = True + canTriggerEvent _ "WorkspaceAddPackage" = True + canTriggerEvent _ _ = False + getHandlers ideRef = do + ide <- liftIO $ readIORef ideRef + return (handlers ide) + setHandlers ideRef nh = do + ide <- liftIO $ readIORef ideRef + liftIO $ writeIORef ideRef (ide {handlers= nh}) + myUnique _ = do + liftIO $ newUnique + +instance EventSelector String + +-- --------------------------------------------------------------------- +-- IDEPackages +-- data IDEPackage = IDEPackage { - packageId :: PackageIdentifier -, cabalFile :: FilePath -, depends :: [Dependency] -, modules :: Set ModuleName -, extraSrcs :: Set FilePath -, srcDirs :: [FilePath] -, configFlags :: [String] -, buildFlags :: [String] -, haddockFlags :: [String] -, exeFlags :: [String] -, installFlags :: [String] -, registerFlags :: [String] -, unregisterFlags :: [String] -, sdistFlags :: [String] + ipdPackageId :: PackageIdentifier +, ipdCabalFile :: FilePath +, ipdDepends :: [Dependency] +, ipdModules :: Set ModuleName +, ipdMain :: [FilePath] +, ipdExtraSrcs :: Set FilePath +, ipdSrcDirs :: [FilePath] +, ipdExtensions :: [Extension] +, ipdConfigFlags :: [String] +, ipdBuildFlags :: [String] +, ipdHaddockFlags :: [String] +, ipdExeFlags :: [String] +, ipdInstallFlags :: [String] +, ipdRegisterFlags :: [String] +, ipdUnregisterFlags :: [String] +, ipdSdistFlags :: [String] } deriving (Eq,Show) +instance Ord IDEPackage where + compare x y = compare (ipdPackageId x) (ipdPackageId y) + -- --------------------------------------------------------------------- +-- Workspace +-- +data Workspace = Workspace { + wsVersion :: Int +, wsSaveTime :: String +, wsName :: String +, wsFile :: FilePath +, wsPackages :: [IDEPackage] +, wsActivePack :: Maybe IDEPackage +, wsPackagesFiles :: [FilePath] +, wsActivePackFile:: Maybe FilePath +, wsReverseDeps :: Map IDEPackage [IDEPackage] +} deriving Show + +-- --------------------------------------------------------------------- -- Other data structures which are used in the state -- @@ -154,7 +320,9 @@ -- | Preferences is a data structure to hold configuration data -- data Prefs = Prefs { - showLineNumbers :: Bool + prefsFormat :: Int + , prefsSaveTime :: String + , showLineNumbers :: Bool , rightMargin :: Maybe Int , tabWidth :: Int , sourceCandy :: Maybe String @@ -163,17 +331,18 @@ , removeTBlanks :: Bool , textviewFont :: Maybe String , sourceStyle :: Maybe String + , foundBackground :: Color + , contextBackground :: Color + , breakpointBackground :: Color + , useYi :: Bool , logviewFont :: Maybe String , defaultSize :: (Int,Int) , browser :: String , pathForCategory :: [(String, PanePath)] , defaultPath :: PanePath , categoryForPane :: [(String, String)] - , sourceDirectories :: [FilePath] , packageBlacklist :: [Dependency] - , collectAfterBuild :: Bool , collectAtStart :: Bool - , autoExtractTars :: Maybe FilePath , useCtrlTabFlipping :: Bool , docuSearchURL :: String , completeRestricted :: Bool @@ -181,14 +350,24 @@ , backgroundBuild :: Bool , backgroundLink :: Bool , printEvldWithShow :: Bool + , autoInstall :: InstallFlag , breakOnException :: Bool , breakOnError :: Bool , printBindResult :: Bool + , serverIP :: String + -- As well used by server + , serverPort :: Int + , sourceDirectories :: [FilePath] + , unpackDirectory :: Maybe FilePath + , retreiveURL :: Maybe String } deriving(Eq,Show) data SearchHint = Forward | Backward | Insert | Delete | Initial deriving (Eq) +data InstallFlag = InstallAlways | InstallLibs | InstallNo + deriving(Eq,Show, Read, Enum, Bounded) + instance Ord Modifier where compare a b = compare (fromEnum a) (fromEnum b) @@ -199,17 +378,32 @@ data LogRef = LogRef { logRefSrcSpan :: SrcSpan +, logRefRootPath :: FilePath , refDescription :: String , logLines :: (Int,Int) , logRefType :: LogRefType } deriving (Eq) instance Show LogRef where - show lr = refDescription lr ++ showSDoc (ppr (logRefSrcSpan lr)) + show lr = refDescription lr ++ displaySrcSpan (logRefSrcSpan lr) -filePath :: LogRef -> FilePath -filePath = unpackFS . srcSpanFile. logRefSrcSpan +displaySrcSpan s = srcSpanFilename s ++ ":" ++ + if srcSpanStartLine s == srcSpanEndLine s + then show (srcSpanStartLine s) ++ ":" ++ + if srcSpanStartColumn s == srcSpanEndColumn s + then show (srcSpanStartColumn s) + else show (srcSpanStartColumn s) ++ "-" ++ show (srcSpanEndColumn s) + else show (srcSpanStartLine s) ++ ":" ++ + show (srcSpanStartColumn s) ++ "-" ++ show (srcSpanEndColumn s) + +logRefFilePath :: LogRef -> FilePath +logRefFilePath = srcSpanFilename . logRefSrcSpan + +logRefFullFilePath :: LogRef -- ^ The log ref + -> FilePath -- ^ the result +logRefFullFilePath lr = logRefRootPath lr logRefFilePath lr + isError :: LogRef -> Bool isError = (== ErrorRef) . logRefType @@ -219,205 +413,13 @@ isContext :: LogRef -> Bool isContext = (== ContextRef) . logRefType --- --------------------------------------------------------------------- --- | Information about the world, extraced from .hi and maybe source files --- - -newtype Present alpha = Present alpha - -type PackageScope = (Map PackageIdentifier PackageDescr,SymbolTable) -type SymbolTable = Map Symbol [Descr] - -data PackageDescr = PackageDescr { - packagePD :: PackageIdentifier -, mbSourcePathPD :: (Maybe FilePath) -, exposedModulesPD :: [ModuleDescr] -, buildDependsPD :: [PackageIdentifier] -} deriving (Show,Typeable) - -instance Show (Present PackageDescr) where - show (Present pd) = (fromPackageIdentifier . packagePD) pd - -instance Eq PackageDescr where - (== ) a b = packagePD a == packagePD b - -instance Ord PackageDescr where - (<=) a b = packagePD a <= packagePD b - -data ModuleDescr = ModuleDescr { - moduleIdMD :: PackModule -, mbSourcePathMD :: (Maybe FilePath) -, exportedNamesMD :: (Set Symbol) -- unqualified -, referencesMD :: (Map ModuleName (Set Symbol)) -- imports -, idDescriptionsMD :: [Descr] -} deriving (Show,Typeable) - -instance Show (Present ModuleDescr) where - show (Present md) = (show . moduleIdMD) md - -instance Eq ModuleDescr where - (== ) a b = moduleIdMD a == moduleIdMD b - -instance Ord ModuleDescr where - (<=) a b = moduleIdMD a <= moduleIdMD b - -data Descr = Descr { - descrName' :: Symbol -, typeInfo' :: TypeInfo -, descrModu' :: PackModule -, mbLocation' :: Maybe Location -, mbComment' :: Maybe ByteString -, details' :: SpDescr} - | Reexported { - descrModu' :: PackModule -, impDescr :: Descr} - deriving (Show,Read,Typeable) - -instance Show (Present Descr) where - showsPrec _ (Present descr) = case mbComment descr of - Just comment -> p . showChar '\n' . c comment . t - Nothing -> p . showChar '\n' . t - where p = showString "-- | " . shows (Present (descrModu' descr)) - c com = showString $ (unlines . map ((++) "-- ") . nonEmptyLines) (BS.unpack com) - t = showString $ BS.unpack (typeInfo descr) - - -isReexported :: Descr -> Bool -isReexported (Reexported _ _) = True -isReexported _ = False - -descrName :: Descr -> Symbol -descrName d - | isReexported d = descrName (impDescr d) - | otherwise = descrName' d - -typeInfo :: Descr -> TypeInfo -typeInfo d - | isReexported d = typeInfo (impDescr d) - | otherwise = typeInfo' d - -descrModu :: Descr -> PackModule -descrModu d - | isReexported d = descrModu (impDescr d) - | otherwise = descrModu' d - -mbLocation :: Descr -> Maybe Location -mbLocation d - | isReexported d = mbLocation (impDescr d) - | otherwise = mbLocation' d - -mbComment :: Descr -> Maybe ByteString -mbComment d - | isReexported d = mbComment (impDescr d) - | otherwise = mbComment' d - -details :: Descr -> SpDescr -details d - | isReexported d = details (impDescr d) - | otherwise = details' d +-- This should probably be in Gtk2Hs allong with a suitable parser +colorHexString (Color r g b) = '#' : (pad $ showHex r "") + ++ (pad $ showHex g "") + ++ (pad $ showHex b "") + where pad s = replicate (4 - length s) '0' ++ s -data SpDescr = VariableDescr - | FieldDescr {typeDescrF :: Descr} - | ConstructorDescr {typeDescrC :: Descr} - | DataDescr {constructors :: [(Symbol,TypeInfo)], - fields :: [(Symbol,TypeInfo)]} - | TypeDescr - | NewtypeDescr {constructor :: (Symbol,TypeInfo), - mbField :: Maybe (Symbol,TypeInfo)} - | ClassDescr {super :: [Symbol], methods :: [(Symbol,TypeInfo)]} - | MethodDescr {classDescrM :: Descr} - | InstanceDescr {binds :: [Symbol]} - --the descrName is the type Konstructor? - deriving (Show,Read,Eq,Ord,Typeable) - -instance Eq Descr where - (== ) a b = descrName a == descrName b - && descrType (details a) == descrType (details b) - -instance Ord Descr where - (<=) a b = if descrName a == descrName b - then descrType (details a) <= descrType (details b) - else descrName a < descrName b - -data DescrType = Variable | Field | Constructor | Data | Type | Newtype - | Class | Method | Instance - deriving (Show, Eq, Ord, Bounded, Enum, Read) - -instance Default DescrType where - getDefault = Variable - -descrType :: SpDescr -> DescrType -descrType VariableDescr = Variable -descrType (FieldDescr _) = Field -descrType (ConstructorDescr _) = Constructor -descrType (DataDescr _ _) = Data -descrType TypeDescr = Type -descrType (NewtypeDescr _ _) = Newtype -descrType (ClassDescr _ _) = Class -descrType (MethodDescr _) = Method -descrType (InstanceDescr _) = Instance - -stockIdFromType :: DescrType -> StockId -stockIdFromType Variable = "ide_function" -stockIdFromType Newtype = "ide_newtype" -stockIdFromType Type = "ide_type" -stockIdFromType Data = "ide_data" -stockIdFromType Class = "ide_class" -stockIdFromType Instance = "ide_instance" -stockIdFromType Constructor = "ide_konstructor" -stockIdFromType Field = "ide_slot" -stockIdFromType Method = "ide_method" - -type Symbol = String -- Qualified or unqualified -type ClassId = String -- Qualified or unqualified -type DataId = String -- Qualified or unqualified -type TypeInfo = ByteString ---type ModuleIdentifier = String -- always qualified - -data PackModule = PM { pack :: PackageIdentifier - , modu :: ModuleName} - deriving (Eq, Ord,Read,Show,Typeable) - -instance Show (Present PackModule) where - showsPrec _ (Present pd) = showString ((fromPackageIdentifier . pack) pd) . showChar ':' - . showString (display (modu pd)) - -parsePackModule :: String -> PackModule -parsePackModule str = let (pack',mod') = span (\c -> c /= ':') str - in case toPackageIdentifier $ pack' of - Nothing -> perror $ "Types>>parsePackModule: Can't parse package:" ++ str - Just pi'-> case simpleParse $ tail mod' of - Nothing -> perror $ - "Types>>parsePackModule: Can't parse module:" ++ str - Just mn -> (PM pi' mn) - where perror s = throwIDE $ "cannot parse PackModule from " ++ s - -showPackModule :: PackModule -> String -showPackModule = show. Present - -fromPackageIdentifier :: PackageIdentifier -> String -fromPackageIdentifier = display - -toPackageIdentifier :: String -> Maybe PackageIdentifier -toPackageIdentifier = simpleParse - -instance Default PackModule where - getDefault = parsePackModule "unknow-0:Undefined" - -data Location = Location { - locationSLine :: Int -, locationSCol :: Int -, locationELine :: Int -, locationECol :: Int -} deriving (Show,Eq,Ord,Read,Typeable) - -instance Default ByteString - where getDefault = BS.empty - -data Scope = Local | Package | System - deriving (Show, Eq, Ord, Enum, Read) - newtype CandyTable = CT (CandyTableForth,CandyTableBack) type CandyTableForth = [(Bool,String,String)] @@ -439,12 +441,12 @@ data GUIHistory' = ModuleSelected { moduleS :: Maybe ModuleName - , facetS :: Maybe Symbol} + , facetS :: Maybe String} | ScopeSelected { scope :: Scope , blacklist :: Bool} | InfoElementSelected { - info :: Descr} + mbInfo :: Maybe Descr} | PaneSelected { paneN :: Maybe (String)} deriving (Eq, Ord, Show) @@ -453,6 +455,7 @@ SensitivityForwardHist | SensitivityBackwardHist | SensitivityProjectActive + | SensitivityWorkspaceOpen | SensitivityError | SensitivityEditor | SensitivityInterpreting @@ -468,8 +471,16 @@ cwTreeView :: TreeView, cwListStore :: ListStore String} - - - +data StatusbarCompartment = + CompartmentCommand String + | CompartmentPane (Maybe (IDEPane IDEM)) + | CompartmentPackage String + | CompartmentState String + | CompartmentOverlay Bool + | CompartmentBufferPos (Int,Int) + | CompartmentBuild Bool + | CompartmentCollect Bool +type PackageDescrCache = Map PackageIdentifier ModuleDescrCache +type ModuleDescrCache = Map ModuleName (ClockTime, Maybe FilePath, ModuleDescr) diff --git a/src/IDE/Debug.hs b/src/IDE/Debug.hs --- a/src/IDE/Debug.hs +++ b/src/IDE/Debug.hs @@ -90,22 +90,20 @@ import System.Posix.Signals (Handler(..)) #endif -import Graphics.UI.Gtk import Control.Monad.Reader import IDE.Core.State -import IDE.Tool +import IDE.Utils.Tool import IDE.LogRef import Control.Exception (SomeException(..)) import IDE.Pane.SourceBuffer - (selectedLocation, - selectedModuleName, - selectedText, - insertTextAfterSelection) -import IDE.Pane.Log (appendLog) -import Data.List (isSuffixOf) + (selectedLocation, selectedText, selectedModuleName, + insertTextAfterSelection, selectedTextOrCurrentLine) import IDE.Metainfo.Provider (getActivePackageDescr) import Distribution.Text (display) +import IDE.Pane.Log (appendLog) +import Data.List (isSuffixOf) + #if defined(mingw32_HOST_OS) || defined(__MINGW32__) foreign import stdcall unsafe "winbase.h GetCurrentProcessId" c_GetCurrentProcessId :: IO DWORD @@ -119,14 +117,12 @@ maybeGhci <- readIDE ghciState case maybeGhci of Just ghci -> do - sb <- getSBErrors + triggerEventIDE (StatusbarChanged [CompartmentState command, CompartmentBuild True]) reifyIDE $ \ideR -> do - statusbarPop sb 1 - statusbarPush sb 1 $ (if '\n' `elem` command then (head $ lines command) ++ " ..." else command) executeGhciCommand ghci command $ \output -> reflectIDE (do handler output - liftIO $ statusbarPush sb 1 "" + triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False]) return () ) ideR _ -> sysMessage Normal "Debugger not running" @@ -137,7 +133,7 @@ handler to triggerEventIDE VariablesChanged return ()) - +-- | Comment3 debugCommand' :: String -> ([ToolOutput] -> IDEAction) -> IDEAction debugCommand' command handler = do ideR <- ask @@ -149,7 +145,7 @@ debugExecuteSelection :: IDEAction debugExecuteSelection = do - maybeText <- selectedText + maybeText <- selectedTextOrCurrentLine case maybeText of Just text -> do debugSetLiberalScope @@ -158,7 +154,7 @@ debugExecuteAndShowSelection :: IDEAction debugExecuteAndShowSelection = do - maybeText <- selectedText + maybeText <- selectedTextOrCurrentLine case maybeText of Just text -> do debugSetLiberalScope @@ -183,7 +179,7 @@ mbPackage <- getActivePackageDescr case mbPackage of Nothing -> return () - Just p -> let packageNames = map (display . modu . moduleIdMD) (exposedModulesPD p) + Just p -> let packageNames = map (display . modu . mdModuleId) (pdModules p) in debugCommand' (foldl (\a b -> a ++ " *" ++ b) ":module + " packageNames) (\ _ -> return ()) @@ -193,14 +189,16 @@ debugBack :: IDEAction debugBack = do currentHist' <- readIDE currentHist + rootPath <- activeProjectDir modifyIDE_ (\ide -> ide{currentHist = min (currentHist' - 1) 0}) - debugCommand ":back" logOutputForHistoricContext + debugCommand ":back" (logOutputForHistoricContext rootPath) debugForward :: IDEAction debugForward = do currentHist' <- readIDE currentHist + rootPath <- activeProjectDir modifyIDE_ (\ide -> ide{currentHist = currentHist' + 1}) - debugCommand ":forward" logOutputForHistoricContext + debugCommand ":forward" (logOutputForHistoricContext rootPath) debugStop :: IDEAction @@ -240,7 +238,9 @@ #endif debugContinue :: IDEAction -debugContinue = debugCommand ":continue" logOutputForLiveContext +debugContinue = do + rootPath <- activeProjectDir + debugCommand ":continue" (logOutputForLiveContext rootPath) debugDeleteAllBreakpoints :: IDEAction debugDeleteAllBreakpoints = do @@ -259,7 +259,7 @@ debugForce :: IDEAction debugForce = do - maybeText <- selectedText + maybeText <- selectedTextOrCurrentLine case maybeText of Just text -> debugCommand (":force " ++ text) logOutput Nothing -> ideMessage Normal "Please select an expression in the editor" @@ -269,51 +269,58 @@ debugPrint :: IDEAction debugPrint = do - maybeText <- selectedText + maybeText <- selectedTextOrCurrentLine case maybeText of Just text -> debugCommand (":print " ++ text) logOutput Nothing -> ideMessage Normal "Please select an name in the editor" debugSimplePrint :: IDEAction debugSimplePrint = do - maybeText <- selectedText + maybeText <- selectedTextOrCurrentLine case maybeText of Just text -> debugCommand (":force " ++ text) logOutput Nothing -> ideMessage Normal "Please select an name in the editor" debugStep :: IDEAction debugStep = do + rootPath <- activeProjectDir debugSetLiberalScope - debugCommand ":step" logOutputForLiveContext + debugCommand ":step" (logOutputForLiveContext rootPath) debugStepExpression :: IDEAction debugStepExpression = do - maybeText <- selectedText + maybeText <- selectedTextOrCurrentLine debugSetLiberalScope debugStepExpr maybeText debugStepExpr :: Maybe String -> IDEAction debugStepExpr maybeText = do + rootPath <- activeProjectDir case maybeText of - Just text -> debugCommand (":step " ++ text) logOutputForLiveContext + Just text -> debugCommand (":step " ++ text) (logOutputForLiveContext rootPath) Nothing -> ideMessage Normal "Please select an expression in the editor" debugStepLocal :: IDEAction -debugStepLocal = debugCommand ":steplocal" logOutputForLiveContext +debugStepLocal = do + rootPath <- activeProjectDir + debugCommand ":steplocal" (logOutputForLiveContext rootPath) debugStepModule :: IDEAction -debugStepModule = debugCommand ":stepmodule" logOutputForLiveContext +debugStepModule = do + rootPath <- activeProjectDir + debugCommand ":stepmodule" (logOutputForLiveContext rootPath) debugTrace :: IDEAction debugTrace = do + rootPath <- activeProjectDir debugCommand ":trace" (\to -> do - logOutputForLiveContext to + logOutputForLiveContext rootPath to triggerEventIDE TraceChanged return ()) debugTraceExpression :: IDEAction debugTraceExpression = do - maybeText <- selectedText + maybeText <- selectedTextOrCurrentLine debugSetLiberalScope debugTraceExpr maybeText @@ -321,7 +328,8 @@ debugTraceExpr maybeText = case maybeText of Just text -> debugCommand (":trace " ++ text) (\to -> do - logOutputForLiveContext to + rootPath <- activeProjectDir + logOutputForLiveContext rootPath to triggerEventIDE TraceChanged return ()) Nothing -> ideMessage Normal "Please select an expression in the editor" @@ -331,10 +339,14 @@ debugShowBindings = debugCommand ":show bindings" logOutput debugShowBreakpoints :: IDEAction -debugShowBreakpoints = debugCommand ":show breaks" logOutputForBreakpoints +debugShowBreakpoints = do + rootPath <- activeProjectDir + debugCommand ":show breaks" (logOutputForBreakpoints rootPath) debugShowContext :: IDEAction -debugShowContext = debugCommand ":show context" logOutputForLiveContext +debugShowContext = do + rootPath <- activeProjectDir + debugCommand ":show context" (logOutputForLiveContext rootPath) debugShowModules :: IDEAction debugShowModules = debugCommand ":show modules" $ @@ -345,6 +357,7 @@ -> appendLog log (line ++ "\n") LogTag ToolOutput line -> appendLog log (line ++ "\n") InfoTag ToolError line -> appendLog log (line ++ "\n") ErrorTag + ToolExit _ -> appendLog log "X--X--X ghci process exited unexpectedly X--X--X" FrameTag return () debugShowPackages :: IDEAction @@ -355,7 +368,7 @@ debugInformation :: IDEAction debugInformation = do - maybeText <- selectedText + maybeText <- selectedTextOrCurrentLine case maybeText of Just text -> do debugSetLiberalScope @@ -364,7 +377,7 @@ debugKind :: IDEAction debugKind = do - maybeText <- selectedText + maybeText <- selectedTextOrCurrentLine case maybeText of Just text -> do debugSetLiberalScope @@ -373,7 +386,7 @@ debugType :: IDEAction debugType = do - maybeText <- selectedText + maybeText <- selectedTextOrCurrentLine case maybeText of Just text -> do debugSetLiberalScope @@ -382,6 +395,7 @@ debugSetBreakpoint :: IDEAction debugSetBreakpoint = do + rootPath <- activeProjectDir maybeModuleName <- selectedModuleName case maybeModuleName of Just moduleName -> do @@ -390,13 +404,13 @@ case maybeText of Just text -> do debugCommand (":module *" ++ moduleName) logOutput - debugCommand (":break " ++ text) logOutputForSetBreakpoint + debugCommand (":break " ++ text) (logOutputForSetBreakpoint rootPath) Nothing -> do maybeLocation <- selectedLocation case maybeLocation of Just (line, lineOffset) -> debugCommand (":break " ++ moduleName ++ " " ++ (show (line+1)) ++ " " ++ - (show lineOffset)) logOutputForSetBreakpoint + (show lineOffset)) (logOutputForSetBreakpoint rootPath) Nothing -> ideMessage Normal "Unknown error setting breakpoint" ref <- ask return () diff --git a/src/IDE/DescriptionPP.hs b/src/IDE/DescriptionPP.hs deleted file mode 100644 --- a/src/IDE/DescriptionPP.hs +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : IDE.DescriptionPP --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | Description of a editor with additional fileds for printing and parsing --- ------------------------------------------------------------------------------------ -module IDE.DescriptionPP ( - Applicator -, FieldDescriptionPP(..) -, mkFieldPP -, extractFieldDescription -, flattenFieldDescriptionPP - -) where - -import Graphics.UI.Gtk -import Control.Monad -import qualified Text.PrettyPrint.HughesPJ as PP -import qualified Text.ParserCombinators.Parsec as P - -import IDE.PrinterParser hiding (fieldParser,parameters) -import Graphics.UI.Editor.Parameters ---import Graphics.UI.Editor.Basics -import Graphics.UI.Editor.MakeEditor -import IDE.Core.State -import Graphics.UI.Editor.Basics (Applicator(..),Editor(..),Setter(..),Getter(..),Notifier(..),Extractor(..),Injector(..)) - -data FieldDescriptionPP alpha = FDPP { - parameters :: Parameters - , fieldPrinter :: alpha -> PP.Doc - , fieldParser :: alpha -> P.CharParser () alpha - , fieldEditor :: alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier) - , applicator :: alpha -> alpha -> IDEAction - } - | VFDPP Parameters [FieldDescriptionPP alpha] - | HFDPP Parameters [FieldDescriptionPP alpha] - | NFDPP [(String,FieldDescriptionPP alpha)] - -type MkFieldDescriptionPP alpha beta = - Parameters -> - (Printer beta) -> - (Parser beta) -> - (Getter alpha beta) -> - (Setter alpha beta) -> - (Editor beta) -> - (Applicator beta IDEM) -> - FieldDescriptionPP alpha - -mkFieldPP :: Eq beta => MkFieldDescriptionPP alpha beta -mkFieldPP parameters printer parser getter setter editor applicator = - let FD _ ed = mkField parameters getter setter editor - in FDPP parameters - (\ dat -> (PP.text (case getParameterPrim paraName parameters of - Nothing -> "" - Just str -> str) PP.<> PP.colon) - PP.$$ (PP.nest 15 (printer (getter dat))) - PP.$$ (PP.nest 5 (case getParameterPrim paraSynopsis parameters of - Nothing -> PP.empty - Just str -> PP.text $"--" ++ str))) - (\ dat -> P.try (do - symbol (case getParameterPrim paraName parameters of - Nothing -> "" - Just str -> str) - colon - val <- parser - return (setter val dat))) - ed - (\ newDat oldDat -> do --applicator - let newField = getter newDat - let oldField = getter oldDat - if newField == oldField - then return () - else applicator newField) - -extractFieldDescription :: FieldDescriptionPP alpha -> FieldDescription alpha -extractFieldDescription (VFDPP paras descrs) = VFD paras (map extractFieldDescription descrs) -extractFieldDescription (HFDPP paras descrs) = HFD paras (map extractFieldDescription descrs) -extractFieldDescription (NFDPP descrsp) = NFD (map (\(s,d) -> - (s, extractFieldDescription d)) descrsp) -extractFieldDescription (FDPP parameters fieldPrinter fieldParser fieldEditor applicator) = - (FD parameters fieldEditor) - -flattenFieldDescriptionPP :: FieldDescriptionPP alpha -> [FieldDescriptionPP alpha] -flattenFieldDescriptionPP (VFDPP paras descrs) = concatMap flattenFieldDescriptionPP descrs -flattenFieldDescriptionPP (HFDPP paras descrs) = concatMap flattenFieldDescriptionPP descrs -flattenFieldDescriptionPP (NFDPP descrsp) = concatMap (flattenFieldDescriptionPP . snd) descrsp -flattenFieldDescriptionPP fdpp = [fdpp] - - diff --git a/src/IDE/Exception.hs b/src/IDE/Exception.hs deleted file mode 100644 --- a/src/IDE/Exception.hs +++ /dev/null @@ -1,95 +0,0 @@ -{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Exception --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | A Type for IDE exceptions --- Taken from Haddock example. --- -------------------------------------------------------------------------------- - -module IDE.Exception ( - IDEException -, throwIDE -, handleTopExceptions -) where - -import Data.Typeable -import System.IO -import Prelude hiding(catch) -import System.Exit - -import Debug.Trace -import Control.OldException (Exception(..),throwDyn) -import Control.Exception (catch) -import GHC.IOBase (AsyncException(..)) - -data IDEException = IDEException String - deriving Typeable - -instance Show IDEException where - show (IDEException str) = str - -throwIDE str = trace str (throwDyn (IDEException str)) - -sysMessage' :: MessageLevel -> String -> IO () -sysMessage' ml str = do - putStrLn str - hFlush stdout - -data MessageLevel = Silent | Normal | High - deriving (Eq,Ord,Show) - - --- --------------------------------------------------------------------- --- Exception handling --- - -handleTopExceptions = - handleNormalExceptions -- . handleIDEExceptions . handleGhcExceptions - -handleNormalExceptions inner = - catch inner (\exception -> do - hFlush stdout - case exception of - AsyncException StackOverflow -> do - sysMessage' Normal "stack overflow: use -g +RTS -K to increase it" - exitFailure - ExitException code -> exitWith code - _other -> do - sysMessage' Normal ("ide: internal IDE error: " ++ show exception) - exitFailure - ) - -{-- -handleIDEExceptions inner = - catchDyn inner (\(e::IDEException) -> do - sysMessage' Normal $ "ide: " ++ (show e) - exitFailure - ) - - -handleGhcExceptions inner = - -- throwIDE messages propagated as exceptions - let inner2 = catchDyn inner (\(dyn::GhcException) -> do - hFlush stdout - case dyn of - PhaseFailed _ code -> exitWith code - Interrupted -> exitFailure - _ -> do - print dyn - exitFailure) - in - -- compilation errors: messages with locations attached - catchDyn inner2 (\dyn -> do - sysMessage' Normal "ide: Compilation error(s):" - printBagOfErrors defaultDynFlags (unitBag dyn) - exitFailure - ) ---} diff --git a/src/IDE/FileUtils.hs b/src/IDE/FileUtils.hs deleted file mode 100644 --- a/src/IDE/FileUtils.hs +++ /dev/null @@ -1,321 +0,0 @@ -module IDE.FileUtils ( - allModules -, allHiFiles -, allHaskellSourceFiles -, cabalFileName -, allCabalFiles -, getConfigFilePathForLoad -, hasConfigDir -, getConfigDir -, getConfigFilePathForSave -, getCollectorPath -, getSysLibDir -, moduleNameFromFilePath -, moduleNameFromFilePath' -, findKnownPackages -, isSubPath -, findSourceFile -, autoExtractTarFiles -, openBrowser - -) where - -import System.FilePath -import System.Directory -import System.IO -import System.Process -import Text.ParserCombinators.Parsec hiding (Parser) -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language(haskell,haskellDef) -import Data.Maybe (catMaybes) -import Distribution.Simple.PreProcess.Unlit -import Control.Monad -import Control.Monad.Trans(MonadIO,liftIO) -import qualified Data.List as List -import qualified Data.Set as Set -import Data.Set (Set) -import Data.List (isSuffixOf,isPrefixOf) -import Distribution.ModuleName(ModuleName,toFilePath) -import Distribution.Text(simpleParse) -import Debug.Trace - -import Paths_leksah -import IDE.Core.State -import Data.Char (ord) - -openBrowser :: String -> IDEAction -openBrowser url = do - prefs' <- readIDE prefs - liftIO (catch (do - runProcess (browser prefs') [url] Nothing Nothing Nothing Nothing Nothing - return ()) - (\ _ -> sysMessage Normal ("Can't find browser executable " ++ browser prefs'))) - return () - --- | Returns True if the second path is a location which starts with the first path -isSubPath :: FilePath -> FilePath -> Bool -isSubPath fp1 fp2 = - let fpn1 = splitPath $ normalise fp1 - fpn2 = splitPath $ normalise fp2 - res = isPrefixOf fpn1 fpn2 - in res - -findSourceFile :: [FilePath] - -> [String] - -> ModuleName - -> IO (Maybe FilePath) -findSourceFile directories exts modId = - let modulePath = toFilePath modId - allPathes = map (\ d -> d modulePath) directories - allPossibles = concatMap (\ p -> map (addExtension p) exts) - allPathes - in find' allPossibles - -find' :: [FilePath] -> IO (Maybe FilePath) -find' [] = return Nothing -find' (h:t) = catch (do - exists <- doesFileExist h - if exists - then return (Just h) - else find' t) - $ \ _ -> return Nothing - -dots_to_slashes = map (\c -> if c == '.' then pathSeparator else c) - --- The directory where config files reside --- -getConfigDir :: IO FilePath -getConfigDir = do - d <- getHomeDirectory - let filePath = d ".leksah" - exists <- doesDirectoryExist filePath - if exists - then return filePath - else do - createDirectory filePath - return filePath - -getConfigDirForLoad :: IO (Maybe FilePath) -getConfigDirForLoad = do - d <- getHomeDirectory - let filePath = d ".leksah" - exists <- doesDirectoryExist filePath - if exists - then return (Just filePath) - else return Nothing - -hasConfigDir :: IO Bool -hasConfigDir = do - d <- getHomeDirectory - let filePath = d ".leksah" - doesDirectoryExist filePath - - -getConfigFilePathForLoad :: String -> IO FilePath -getConfigFilePathForLoad fn = do - mbCd <- getConfigDirForLoad - case mbCd of - Nothing -> getFromData - Just cd -> do - ex <- doesFileExist (cd fn) - if ex - then return (cd fn) - else getFromData - where getFromData = do - dd <- getDataDir - ex <- doesFileExist (dd "data" fn) - if ex - then return (dd "data" fn) - else throwIDE $"Config file not found: " ++ fn - -getConfigFilePathForSave :: String -> IO FilePath -getConfigFilePathForSave fn = do - cd <- getConfigDir - return (cd fn) - -allModules :: FilePath -> IO [ModuleName] -allModules filePath = catch (do - exists <- doesDirectoryExist filePath - if exists - then do - filesAndDirs <- getDirectoryContents filePath - let filesAndDirs' = map (\s -> combine filePath s) - $filter (\s -> s /= "." && s /= ".." && s /= "_darcs" && s /= "dist" - && s /= "Setup.lhs") filesAndDirs - dirs <- filterM (\f -> doesDirectoryExist f) filesAndDirs' - files <- filterM (\f -> doesFileExist f) filesAndDirs' - let hsFiles = filter (\f -> let ext = takeExtension f in - ext == ".hs" || ext == ".lhs") files - mbModuleNames <- mapM moduleNameFromFilePath hsFiles - otherModules <- mapM allModules dirs - return (catMaybes mbModuleNames ++ concat otherModules) - else return []) - $ \ _ -> return [] - -allHiFiles :: FilePath -> IO [FilePath] -allHiFiles = allFilesWithExtensions [".hi"] True [] - -allCabalFiles :: FilePath -> IO [FilePath] -allCabalFiles = allFilesWithExtensions [".cabal"] False [] - -allHaskellSourceFiles :: FilePath -> IO [FilePath] -allHaskellSourceFiles = allFilesWithExtensions [".hs",".lhs"] True [] - -allFilesWithExtensions :: [String] -> Bool -> [FilePath] -> FilePath -> IO [FilePath] -allFilesWithExtensions extensions recurseFurther collecting filePath = catch (do - exists <- doesDirectoryExist filePath - if exists - then do - filesAndDirs <- getDirectoryContents filePath - let filesAndDirs' = map (\s -> combine filePath s) - $filter (\s -> s /= "." && s /= ".." && s /= "_darcs") filesAndDirs - dirs <- filterM (\f -> doesDirectoryExist f) filesAndDirs' - files <- filterM (\f -> doesFileExist f) filesAndDirs' - let choosenFiles = filter (\f -> let ext = takeExtension f in - List.elem ext extensions) files - allFiles <- - if recurseFurther || (not recurseFurther && null choosenFiles) - then foldM (allFilesWithExtensions extensions recurseFurther) (choosenFiles ++ collecting) dirs - else return (choosenFiles ++ collecting) - return (allFiles) - else return collecting) - $ \ _ -> return collecting - - -moduleNameFromFilePath :: FilePath -> IO (Maybe ModuleName) -moduleNameFromFilePath fp = catch (do - exists <- doesFileExist fp - if exists - then do - str <- readFile fp - moduleNameFromFilePath' fp str - else return Nothing) - $ \ _ -> return Nothing - -moduleNameFromFilePath' :: FilePath -> String -> IO (Maybe ModuleName) -moduleNameFromFilePath' fp str = do - let unlitRes = if takeExtension fp == ".lhs" - then unlit fp str - else Left str - case unlitRes of - Right err -> do - sysMessage Normal $show err - return Nothing - Left str' -> do - let parseRes = parse moduleNameParser fp str' - case parseRes of - Left err -> do - return Nothing - Right str -> do - let res = simpleParse str - case res of - Nothing -> do - return Nothing - Just mn -> return (Just mn) - -lexer = haskell -lexeme = P.lexeme lexer -whiteSpace = P.whiteSpace lexer -hexadecimal = P.hexadecimal lexer -symbol = P.symbol lexer - -moduleNameParser :: CharParser () String -moduleNameParser = do - whiteSpace - many skipPreproc - whiteSpace - symbol "module" - str <- lexeme mident - return str - "module identifier" - -skipPreproc :: CharParser () () -skipPreproc = do - try (do - whiteSpace - char '#' - many (noneOf "\n") - return ()) - "preproc" - -mident - = do{ c <- P.identStart haskellDef - ; cs <- many (alphaNum <|> oneOf "_'.") - ; return (c:cs) - } - "midentifier" - -findKnownPackages :: FilePath -> IO (Set String) -findKnownPackages filePath = catch (do - paths <- getDirectoryContents filePath - let nameList = map dropExtension $filter (\s -> ".pack" `isSuffixOf` s) paths - return (Set.fromList nameList)) - $ \ _ -> return (Set.empty) - -cabalFileName :: FilePath -> IO (Maybe String) -cabalFileName filePath = catch (do - exists <- doesDirectoryExist filePath - if exists - then do - filesAndDirs <- getDirectoryContents filePath - files <- filterM (\f -> doesFileExist f) filesAndDirs - let cabalFiles = filter (\f -> let ext = takeExtension f in ext == ".cabal") files - if null cabalFiles - then return Nothing - else if length cabalFiles == 1 - then return (Just $head cabalFiles) - else do - sysMessage Normal "Multiple cabal files" - return Nothing - else return Nothing) - (\_ -> return Nothing) - -autoExtractTarFiles :: FilePath -> IO () -autoExtractTarFiles filePath = - catch (do - exists <- doesDirectoryExist filePath - if exists - then do - filesAndDirs <- getDirectoryContents filePath - let filesAndDirs' = map (\s -> combine filePath s) - $ filter (\s -> s /= "." && s /= ".." && not (isPrefixOf "00-index" s)) filesAndDirs - dirs <- filterM (\f -> doesDirectoryExist f) filesAndDirs' - files <- filterM (\f -> doesFileExist f) filesAndDirs' - let choosenFiles = filter (\f -> isSuffixOf ".tar.gz" f) files - let decompressionTargets = filter (\f -> (dropExtension . dropExtension) f `notElem` dirs) choosenFiles - mapM_ (\f -> let (dir,fn) = splitFileName f in do - setCurrentDirectory dir - handle <- runCommand $ "tar -zxf " ++ fn - waitForProcess handle - trace ("extracted " ++ fn) $ return ()) - decompressionTargets - mapM_ autoExtractTarFiles dirs - return () - else return () - ) $ \ _ -> trace ("error extractTarFiles" ++ filePath) $ return () - - -getCollectorPath :: MonadIO m => String -> m FilePath -getCollectorPath version = liftIO $ do - configDir <- getConfigDir - let filePath = configDir "ghc-" ++ version - exists <- doesDirectoryExist filePath - if exists - then return filePath - else do - createDirectory filePath - return filePath - -getSysLibDir :: IO FilePath -getSysLibDir = catch (do - (_, out, _, pid) <- runInteractiveProcess "ghc" ["--print-libdir"] Nothing Nothing - libDir <- hGetLine out - let libDir2 = if ord (last libDir) == 13 - then List.init libDir - else libDir - return (normalise libDir2) - ) $ \ _ -> error ("FileUtils>>getSysLibDir failed") - - - - diff --git a/src/IDE/Find.hs b/src/IDE/Find.hs --- a/src/IDE/Find.hs +++ b/src/IDE/Find.hs @@ -36,27 +36,23 @@ import Graphics.UI.Gtk hiding (get) import Graphics.UI.Gtk.Gdk.Events -import Data.Maybe import Control.Monad.Reader import IDE.Core.State +import IDE.TextEditor hiding(afterFocusIn) import IDE.Pane.SourceBuffer -import Data.Char (toLower) -import Text.Regex.Posix.String (compile) -import Text.Regex.Posix - (Regex(..), compNewline, compExtended, execBlank, compIgnoreCase) -import Data.Bits ((.|.)) +import Data.Char (digitToInt, isDigit, toLower, isAlphaNum) +import Text.Regex.TDFA hiding (caseSensitive) +import qualified Text.Regex.TDFA as Regex +import Text.Regex.TDFA.String (compile) import Data.List (nub, find, isPrefixOf) -import Data.Array ((!)) -import Text.Regex.Base.RegexLike (matchAll) -import Text.Regex (subRegex) -import IDE.Tool (runTool) +import Data.Array (bounds, (!), inRange) +import IDE.Utils.Tool (runTool) import Control.Concurrent (forkIO) import IDE.Pane.Grep -import GHC.Unicode (isAlphaNum) import IDE.Package (getPackageDescriptionAndPath) import Distribution.PackageDescription (allBuildInfo, hsSourceDirs) - +import System.FilePath (dropFileName) data FindState = FindState { entryStr :: String @@ -307,16 +303,15 @@ spinL `afterFocusIn` (\ _ -> (reflectIDE (inActiveBufContext True $ \_ gtkbuf currentBuffer _ -> do - max <- textBufferGetLineCount gtkbuf - spinButtonSetRange spinL 1.0 (fromIntegral max) + max <- getLineCount gtkbuf + liftIO $ spinButtonSetRange spinL 1.0 (fromIntegral max) return True) ideR)) spinL `afterEntryActivate` (reflectIDE (inActiveBufContext () $ \_ gtkbuf currentBuffer _ -> do - line <- spinButtonGetValueAsInt spinL - iter <- textBufferGetStartIter gtkbuf - textIterSetLine iter (line - 1) - textBufferPlaceCursor gtkbuf iter - textViewScrollToIter (sourceView currentBuffer) iter 0.2 Nothing + line <- liftIO $ spinButtonGetValueAsInt spinL + iter <- getIterAtLine gtkbuf (line - 1) + placeCursor gtkbuf iter + scrollToIter (sourceView currentBuffer) iter 0.2 Nothing return ()) ideR ) closeButton `onToolButtonClicked` do @@ -340,7 +335,7 @@ case mbbuf of Nothing -> return () Just buf -> do - liftIO $ widgetGrabFocus (sourceView buf) + grabFocus (sourceView buf) return () @@ -389,9 +384,10 @@ Nothing -> ideMessage Normal "No package description" Just (pd,cabalPath) -> do let srcPaths = nub $ concatMap hsSourceDirs $ allBuildInfo pd + let dir = dropFileName (cabalPath) liftIO $ forkIO $ do (output, pid) <- runTool "grep" ((if caseSensitive then [] else ["-i"]) - ++ ["-r", "-E", "-n", "--exclude=*~", regexString] ++ srcPaths) + ++ ["-r", "-E", "-n", "--exclude=*~", regexString] ++ srcPaths) (Just dir) reflectIDE (setGrepResults output) ideR return () @@ -456,53 +452,52 @@ editFind' :: Regex -> Int -> Bool -> String -> SearchHint -> IDEM Bool editFind' exp matchIndex wrapAround dummy hint = - inActiveBufContext' False $ \_ gtkbuf currentBuffer _ -> liftIO $ do - i1 <- textBufferGetStartIter gtkbuf - i2 <- textBufferGetEndIter gtkbuf - textBufferRemoveTagByName gtkbuf "found" i1 i2 - startMark <- textBufferGetInsert gtkbuf - st1 <- textBufferGetIterAtMark gtkbuf startMark - mbsr2 <- liftIO $ do + inActiveBufContext False $ \_ gtkbuf currentBuffer _ -> do + i1 <- getStartIter gtkbuf + i2 <- getEndIter gtkbuf + text <- getText gtkbuf i1 i2 True + removeTagByName gtkbuf "found" i1 i2 + startMark <- getInsertMark gtkbuf + st1 <- getIterAtMark gtkbuf startMark + mbsr2 <- do if hint == Backward then do - textIterBackwardChar st1 - textIterBackwardChar st1 - mbsr <- backSearch exp matchIndex st1 + st2 <- backwardCharC st1 + st3 <- backwardCharC st2 + mbsr <- backSearch exp matchIndex gtkbuf text st3 case mbsr of Nothing -> if wrapAround - then do backSearch exp matchIndex i2 + then do backSearch exp matchIndex gtkbuf text i2 else return Nothing - Just (start,end) -> return (Just (start,end)) + m -> return m else do - if hint == Forward - then textIterForwardChar st1 - else return True - mbsr <- forwardSearch exp matchIndex st1 + st2 <- if hint == Forward + then forwardCharC st1 + else return st1 + mbsr <- forwardSearch exp matchIndex gtkbuf text st2 case mbsr of Nothing -> if wrapAround - then do forwardSearch exp matchIndex i1 + then do forwardSearch exp matchIndex gtkbuf text i1 else return Nothing - Just (start,end) -> return (Just (start,end)) + m -> return m case mbsr2 of - Just (start,end) -> do --found + Just (start,end,_) -> do --found --widgetGrabFocus sourceView - textViewScrollToIter (sourceView currentBuffer) start 0.2 Nothing - textBufferApplyTagByName gtkbuf "found" start end - textBufferPlaceCursor gtkbuf start + scrollToIter (sourceView currentBuffer) start 0.2 Nothing + applyTagByName gtkbuf "found" start end + placeCursor gtkbuf start return True Nothing -> return False where - backSearch exp matchIndex iter = do - gtkbuf <- textIterGetBuffer iter - offset <- textIterGetOffset iter - findMatch exp matchIndex gtkbuf (<= offset) True + backSearch exp matchIndex gtkbuf text iter = do + offset <- getOffset iter + findMatch exp matchIndex gtkbuf text (<= offset) True - forwardSearch exp matchIndex iter = do - gtkbuf <- textIterGetBuffer iter - offset <- textIterGetOffset iter - findMatch exp matchIndex gtkbuf (>= offset) False + forwardSearch exp matchIndex gtkbuf text iter = do + offset <- getOffset iter + findMatch exp matchIndex gtkbuf text (>= offset) False regexAndMatchIndex :: Bool -> Bool -> Bool -> String -> IO (Maybe (Regex, Int)) regexAndMatchIndex caseSensitive entireWord regex string = do @@ -510,8 +505,11 @@ then return Nothing else do let (regexString, index) = regexStringAndMatchIndex entireWord regex string - mbRegex <- compileRegex caseSensitive regexString - return $ maybe Nothing (Just . (flip (,) index)) mbRegex + case compileRegex caseSensitive regexString of + Left err -> do + sysMessage Normal err + return Nothing + Right regex -> return $ Just (regex, index) regexStringAndMatchIndex :: Bool -> Bool -> String -> (String, Int) regexStringAndMatchIndex entireWord regex string = @@ -524,19 +522,15 @@ then ("(^|[^a-zA-Z0-9])(" ++ regexString ++ ")($|[^a-zA-Z0-9])", 2) else (regexString, 0) -findMatch :: Regex -> Int -> TextBuffer -> (Int -> Bool) -> Bool -> IO (Maybe (TextIter, TextIter)) -findMatch exp matchIndex gtkbuf offsetPred findLast = do - iterStart <- textBufferGetStartIter gtkbuf - iterEnd <- textBufferGetEndIter gtkbuf - text <- textBufferGetText gtkbuf iterStart iterEnd True +findMatch :: Regex -> Int -> EditorBuffer -> String -> (Int -> Bool) -> Bool -> IDEM (Maybe (EditorIter, EditorIter, MatchArray)) +findMatch exp matchIndex gtkbuf text offsetPred findLast = do let matches = (if findLast then reverse else id) (matchAll exp text) case find (offsetPred . fst . (!matchIndex)) matches of Just matches -> do - iter1 <- textIterCopy iterStart - textIterForwardChars iter1 (fst (matches!matchIndex)) - iter2 <- textIterCopy iter1 - textIterForwardChars iter2 (snd (matches!matchIndex)) - return $ Just (iter1, iter2) + iterStart <- getStartIter gtkbuf + iter1 <- forwardCharsC iterStart (fst (matches!matchIndex)) + iter2 <- forwardCharsC iter1 (snd (matches!matchIndex)) + return $ Just (iter1, iter2, matches) Nothing -> return Nothing editReplace :: Bool -> Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool @@ -545,22 +539,24 @@ editReplace' :: Bool -> Bool -> Bool -> Bool -> String -> String -> SearchHint -> Bool -> IDEM Bool editReplace' entireWord caseSensitive wrapAround regex search replace hint mayRepeat = - inActiveBufContext' False $ \_ gtkbuf currentBuffer _ -> do - insertMark <- liftIO $ textBufferGetInsert gtkbuf - iter <- liftIO $ textBufferGetIterAtMark gtkbuf insertMark - offset <- liftIO $ textIterGetOffset iter + inActiveBufContext False $ \_ gtkbuf currentBuffer _ -> do + insertMark <- getInsertMark gtkbuf + iter <- getIterAtMark gtkbuf insertMark + offset <- getOffset iter mbExpAndMatchIndex <- liftIO $ regexAndMatchIndex caseSensitive entireWord regex search case mbExpAndMatchIndex of Just (exp, matchIndex) -> do - match <- liftIO $ findMatch exp matchIndex gtkbuf (== offset) False + iStart <- getStartIter gtkbuf + iEnd <- getEndIter gtkbuf + text <- getText gtkbuf iStart iEnd True + match <- findMatch exp matchIndex gtkbuf text (== offset) False case match of - Just (iterStart, iterEnd) -> do - old <- liftIO $ textIterGetText iterStart iterEnd - mbText <- liftIO $ replacementText regex old replace + Just (iterStart, iterEnd, matches) -> do + mbText <- liftIO $ replacementText regex text matchIndex matches replace case mbText of Just text -> do - liftIO $ textBufferDelete gtkbuf iterStart iterEnd - liftIO $ textBufferInsert gtkbuf iterStart text + delete gtkbuf iterStart iterEnd + insert gtkbuf iterStart text Nothing -> do sysMessage Normal "Should never happen. findMatch worked but repleacementText failed" @@ -574,13 +570,28 @@ else return False Nothing -> return False where - replacementText False old replace = return $ Just replace - replacementText True old replace = do - mbExp <- compileRegex caseSensitive search - case mbExp of - Just exp -> return $ Just $ subRegex exp old replace - Nothing -> return Nothing + replacementText False _ _ _ replace = return $ Just replace + replacementText True text matchIndex matches replace = do + case compileRegex caseSensitive search of + Left err -> do + sysMessage Normal err + return Nothing + Right exp -> return $ Just $ regexReplacement text matchIndex matches replace +regexReplacement :: String -> Int -> MatchArray -> String -> String +regexReplacement _ _ _ [] = [] +regexReplacement text matchIndex matches ('\\' : '\\' : xs) = '\\' : regexReplacement text matchIndex matches xs +regexReplacement text matchIndex matches ('\\' : n : xs) | isDigit n = + let subIndex = matchIndex + digitToInt n + value = if inRange (bounds matches) subIndex + then + let subExp = matches!(matchIndex + digitToInt n) in + take (snd subExp) $ drop (fst subExp) text + else ['\\', n] in + value ++ regexReplacement text matchIndex matches xs + +regexReplacement text matchIndex matches (x : xs) = x : regexReplacement text matchIndex matches xs + editReplaceAll :: Bool -> Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool editReplaceAll entireWord caseSensitive wrapAround regex search replace hint = do res <- editReplace' entireWord caseSensitive False regex search replace hint True @@ -588,17 +599,12 @@ then editReplaceAll entireWord caseSensitive False regex search replace hint else return False -compileRegex :: Bool -> String -> IO (Maybe Regex) -compileRegex caseSense searchString = do - res <- compile ((if caseSense then id else (compIgnoreCase .|.)) - (compExtended .|. compNewline)) - execBlank searchString - case res of - Left err -> do - sysMessage Normal (show err) - return Nothing - Right regex -> return $ Just regex - +compileRegex :: Bool -> String -> Either String Regex +compileRegex caseSense searchString = + let compOption = defaultCompOpt { + Regex.caseSensitive = caseSense + , multiline = True } in + compile compOption defaultExecOpt searchString red = Color 64000 10000 10000 orange = Color 64000 48000 0 @@ -617,13 +623,13 @@ ideR <- ask (fb,_) <- needFindbar case hint of - Initial -> inActiveBufContext' () $ \_ gtkbuf currentBuffer _ -> liftIO $ do - hasSelection <- textBufferHasSelection gtkbuf + Initial -> inActiveBufContext () $ \_ gtkbuf currentBuffer _ -> do + hasSelection <- hasSelection gtkbuf when hasSelection $ do - (i1,i2) <- textBufferGetSelectionBounds gtkbuf - text <- textBufferGetText gtkbuf i1 i2 False - findEntry <- getFindEntry fb - entrySetText (castToEntry findEntry) text + (i1,i2) <- getSelectionBounds gtkbuf + text <- getText gtkbuf i1 i2 False + findEntry <- liftIO $ getFindEntry fb + liftIO $ entrySetText (castToEntry findEntry) text return () _ -> return () showFindbar diff --git a/src/IDE/GUIHistory.hs b/src/IDE/GUIHistory.hs --- a/src/IDE/GUIHistory.hs +++ b/src/IDE/GUIHistory.hs @@ -25,7 +25,6 @@ import IDE.Core.State import IDE.Pane.Modules import IDE.Pane.Info -import Control.Monad.Reader recordHistory :: GUIHistory -> IDEAction recordHistory entry = do diff --git a/src/IDE/Group/Debugger.hs b/src/IDE/Group/Debugger.hs deleted file mode 100644 --- a/src/IDE/Group/Debugger.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# OPTIONS_GHC -XScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Group.Debugger --- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GPL --- --- Maintainer : maintainer@leksah.org --- Stability : provisional --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module IDE.Group.Debugger ( - showDebugger, - setSensitivityDebugger -) where - -import IDE.Core.State - (getPane, - getBestPanePath, - frameState, - readIDE, - getNotebook, - viewSplit', - newGroupOrBringToFront, - IDEAction(..)) -import Graphics.UI.Frame.Panes - (getTopWidget, - layout, - PaneDirection(..), - PanePathElement(..), - panePathForGroup) -import IDE.Pane.SourceBuffer - (newTextBuffer, bufferName, allBuffers) -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(..)) -import IDE.Pane.Variables (IDEVariables, showVariables') -import IDE.Pane.Breakpoints - (IDEBreakpoints, showBreakpointList') -import IDE.Pane.Trace (IDETrace,showTrace') -import Control.Monad (liftM, when) - -setSensitivityDebugger :: Bool -> IDEAction -setSensitivityDebugger sens = do - mbBreakpoints :: Maybe IDEBreakpoints <- getPane - mbVariables :: Maybe IDEVariables <- getPane - mbTrace :: Maybe IDETrace <- getPane - liftIO $ do - case mbBreakpoints of - Nothing -> return () - Just idePane -> widgetSetSensitive (getTopWidget idePane) sens - case mbVariables of - Nothing -> return () - Just idePane -> widgetSetSensitive (getTopWidget idePane) sens - case mbTrace of - Nothing -> return () - Just idePane -> widgetSetSensitive (getTopWidget idePane) sens - -showDebugger :: IDEAction -showDebugger = do - pp <- panePathForGroup "*Debug" - ret <- newGroupOrBringToFront "Debug" pp - layout' <- liftM layout (readIDE frameState) - bufs <- allBuffers - case ret of - (Just rpp, True) -> do - viewSplit' rpp Horizontal - viewSplit' (rpp ++ [SplitP TopP]) Horizontal - let lowerP = rpp ++ [SplitP BottomP] - let middleP = rpp ++ [SplitP TopP,SplitP BottomP] - let upperP = rpp ++ [SplitP TopP,SplitP TopP] - lower <- getNotebook lowerP - middle <- getNotebook middleP - upper <- getNotebook upperP - liftIO $ do - notebookSetTabPos lower PosTop - notebookSetTabPos middle PosTop - notebookSetTabPos upper PosTop - notebookSetShowTabs upper False - showBreakpointList' middleP - showVariables' middleP - showTrace' lowerP - when (null $ filter (\b -> bufferName b == "_Eval.hs") bufs) $ - newTextBuffer upperP "_Eval.hs" Nothing >> return () - return () - (Just rpp, False) -> do - let lowerP = getBestPanePath (rpp ++ [SplitP BottomP]) layout' - let middleP = getBestPanePath (rpp ++ [SplitP TopP,SplitP BottomP]) layout' - let upperP = getBestPanePath (rpp ++ [SplitP TopP,SplitP TopP]) layout' - showBreakpointList' middleP - showVariables' middleP - showTrace' lowerP - when (null $ filter (\b -> bufferName b == "_Eval.hs") bufs) $ - newTextBuffer upperP "_Eval.hs" Nothing >> return () - return () - _ -> return () diff --git a/src/IDE/ImportTool.hs b/src/IDE/ImportTool.hs --- a/src/IDE/ImportTool.hs +++ b/src/IDE/ImportTool.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.ImportTool --- Copyright : 2007-2009 Jürgen Nicklisch-Franken +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : Jutaro @@ -19,48 +19,42 @@ , parseNotInScope ) where - import IDE.Core.State -import Data.List (sort,nub,nubBy) import Data.Maybe (isNothing,isJust) -import IDE.Metainfo.Provider (getIdentifierDescr) +import IDE.Metainfo.Provider + (getPackageImportInfo, getIdentifierDescr) import Text.PrettyPrint (render) import Distribution.Text (disp) import IDE.Pane.SourceBuffer - (fileSave, inActiveBufContext', selectSourceBuf) + (belongsToPackage, maybeActiveBuf, fileSave, + inActiveBufContext, selectSourceBuf) import Graphics.UI.Gtk -import IDE.SourceCandy (getCandylessText) import Text.ParserCombinators.Parsec.Language (haskellStyle) -import Graphics.UI.Editor.MakeEditor (buildEditor,mkField,FieldDescription(..)) +import Graphics.UI.Editor.MakeEditor + (FieldDescription(..), buildEditor, mkField) import Graphics.UI.Editor.Parameters - (paraMinSize, - emptyParams, - Parameter(..), - paraMultiSel, - (<<<-), - paraName) -import Graphics.UI.Editor.Basics (eventPaneName,GUIEventSelector(..)) -import IDE.Metainfo.GHCUtils(parseHeader) + ((<<<-), paraMinSize, emptyParams, Parameter(..), paraMultiSel, + paraName) +import Graphics.UI.Editor.Basics + (GUIEventSelector(..), eventPaneName) import Data.Maybe (fromJust) -import RdrName (mkRdrUnqual) -import OccName (mkDataOcc,mkVarOcc) -import Module (pprModuleName) -import Distribution.Text (display) -import GHC hiding (ModuleName) -import Text.ParserCombinators.Parsec -import qualified Text.ParserCombinators.Parsec.Token as P - (whiteSpace, - operator, - dot, - identifier, - symbol, - lexeme, - makeTokenParser) +import Text.ParserCombinators.Parsec hiding (parse) +import qualified Text.ParserCombinators.Parsec as Parsec (parse) import Graphics.UI.Editor.Simple (okCancelFields, staticListEditor) import Control.Event (registerEvent) -import Outputable (showSDoc, ppr) import Control.Monad.Trans (liftIO) -import Control.Monad (foldM_, when) +import Control.Monad (when) +import Distribution.Text (display) +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 Debug.Trace (trace) +--import Debug.Trace @@ -69,22 +63,23 @@ addAllImports = do prefs' <- readIDE prefs let buildInBackground = backgroundBuild prefs' - when buildInBackground ( - modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = False}})) + when buildInBackground $ + modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = False}}) errors <- readIDE errorRefs - foldM_ addThis (True,[]) + addAll buildInBackground [ y | (x,y) <- nubBy (\ (p1,_) (p2,_) -> p1 == p2) $ [(x,y) | (x,y) <- [((parseNotInScope . refDescription) e, e) | e <- errors]], - isJust x] - when buildInBackground $ - modifyIDE_ (\ide -> ide{prefs = prefs'{backgroundBuild = True}}) - + isJust x] (True,[]) where - addThis :: (Bool,[Descr]) -> LogRef -> IDEM (Bool,[Descr]) - addThis c@(False,_) _ = return c - addThis c@(True,descrList) errorSpec = addImport errorSpec descrList + 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 @@ -95,176 +90,150 @@ ideMessage Normal $ "No error selected" return () Just ref -> do - addImport ref [] >> return () + 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] -> IDEM (Bool, [Descr]) -addImport error descrList = +addImport :: LogRef -> [Descr] -> ((Bool,[Descr]) -> IDEAction) -> IDEAction +addImport error descrList continuation = case parseNotInScope (refDescription error) of - Nothing -> return (True,descrList) + Nothing -> continuation (True,descrList) Just nis -> do - currentInfo' <- readIDE currentInfo + currentInfo' <- getScopeForActiveBuffer case currentInfo' of - Nothing -> return (False,descrList) - Just ((_,symbolTable1),(_,symbolTable2)) -> - case (getIdentifierDescr (id' nis) symbolTable1 symbolTable2) 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" - return (True,descrList) - descr : [] -> addImport' nis (filePath error) descr descrList + continuation (True, descrList) + descr : [] -> addImport' nis (logRefFullFilePath error) descr descrList continuation list -> do window' <- getMainWindow - mbDescr <- liftIO $ selectModuleDialog window' list (id' nis) + mbDescr <- liftIO $ selectModuleDialog window' list (id' nis) (mbQual' nis) (if null descrList then Nothing else Just (head descrList)) case mbDescr of - Nothing -> return (False,descrList) + Nothing -> continuation (False, []) Just descr -> if elem descr descrList - then return (True, descrList) - else addImport' nis (filePath error) descr descrList + then continuation (True,descrList) + else addImport' nis (logRefFullFilePath error) + descr descrList continuation -addImport' :: NotInScopeParseResult -> FilePath -> Descr -> [Descr] -> IDEM (Bool,[Descr]) -addImport' nis filePath descr descrList = do - candy' <- readIDE candy - mbBuf <- selectSourceBuf filePath - let mod = modu (descrModu' descr) - case mbBuf of - Nothing -> return (False, descrList) +getScopeForActiveBuffer :: IDEM (Maybe (GenScope, GenScope)) +getScopeForActiveBuffer = do + mbActiveBuf <- maybeActiveBuf + case mbActiveBuf of + Nothing -> trace "getScopeForActiveBuffer: no activeBuffer" $ return Nothing Just buf -> do - inActiveBufContext' (False,descrList) $ \ nb gtkbuf idebuf n -> do - ideMessage Normal $ "addImport " ++ show (descrName descr) ++ " from " + mbPackage <- belongsToPackage buf + case mbPackage of + Nothing -> trace "getScopeForActiveBuffer: no package" $ 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) - text <- liftIO $ do - i1 <- textBufferGetStartIter gtkbuf - i2 <- textBufferGetEndIter gtkbuf - getCandylessText candy' gtkbuf - parseResult <- parseHeader filePath text - case parseResult of - Nothing -> do - ideMessage Normal ("Can't parse module header " ++ filePath) - return (False, descrList) - Just HsModule{ hsmodImports = imports } -> - case filter qualifyAsImportStatement imports of - [] -> let newLine = showSDoc (ppr newImpDecl) ++ "\n" - lastLoc = foldr max noSrcSpan (map getLoc imports) - mbLineSel = if isGoodSrcSpan lastLoc - then Just (srcSpanEndLine lastLoc) - else figureOutImportLine text - in case mbLineSel of - Nothing -> do - ideMessage Normal "No source location" - return (False,descrList) - Just lineSel -> do - liftIO $ do - i1 <- textBufferGetIterAtLine gtkbuf lineSel - textBufferInsert gtkbuf i1 newLine + 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 - liftIO $ textBufferSetModified gtkbuf True - return (True,descr : descrList) - l@(impDecl:_) -> - let newImpDecl = addToDecl (unLoc impDecl) - newLine = showSDoc (ppr newImpDecl) ++ "\n" - myLoc = getLoc impDecl - mbLineSel = if isGoodSrcSpan myLoc - then Just (srcSpanStartLine myLoc, - srcSpanEndLine myLoc) - else Nothing - - in case mbLineSel of - Nothing -> do - ideMessage Normal "No source location" - return (False,descrList) - Just (lineStart, lineEnd) -> do - liftIO $ do - i1 <- textBufferGetIterAtLine gtkbuf (lineStart - 1) - i2 <- textBufferGetIterAtLine gtkbuf (lineEnd) - textBufferDelete gtkbuf i1 i2 - textBufferInsert gtkbuf i1 newLine - fileSave False - liftIO $ textBufferSetModified gtkbuf True - return (True, descr : descrList) + 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 - isHiding (Just (_,False)) = True - isHiding _ = False - qualifyAsImportStatement :: LImportDecl alpha -> Bool - qualifyAsImportStatement limpDecl = - let impDecl = unLoc limpDecl in - showSDoc (ppr (ideclName impDecl)) == display (modu (descrModu' descr)) - && ((isNothing (mbQual' nis) && not (ideclQualified impDecl)) || - (isJust (mbQual' nis) && ideclQualified impDecl + 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 (ideclHiding impDecl) || not (fst (fromJust (ideclHiding impDecl)))) - newImpDecl :: LImportDecl RdrName - newImpDecl = noLoc (ImportDecl - (noLoc (mkModuleName (display (modu (descrModu' descr))))) - Nothing - False - (isJust (mbQual' nis)) - (if isJust (mbQual' nis) - then Just (mkModuleName (fromJust (mbQual' nis))) - else Nothing) - (Just (False, [noLoc (newIE)]))) - addToDecl :: ImportDecl RdrName -> ImportDecl RdrName - addToDecl impDecl = case ideclHiding impDecl of - Just (True,listIE) -> throwIDE "ImportTool>>addToDecl: ImpList is hiding" - Just (False,listIE) -> - impDecl{ideclHiding = Just (False, (noLoc newIE : listIE))} + && (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{ideclHiding = Just (False, [noLoc (newIE)])} - - newIE :: IE RdrName - newIE = if isSub' nis - then IEThingAll (mkRdrUnqual (mkDataOcc (getRealId descr (id' nis)))) - else if isOp' nis - then IEVar (mkRdrUnqual (mkVarOcc (id' nis))) - else IEVar (mkRdrUnqual (mkVarOcc (id' nis))) - + impDecl{importSpecs = Just (ImportSpecList False [newImportSpec])} + noLocation = Location 0 0 0 0 -getRealId descr id = if isReexported descr - then getRealId (impDescr descr) id - else getReal (details' descr) +getRealId descr id = case descr of + Reexported rdescr -> getRealId (dsrDescr rdescr) id + Real edescr -> getReal (dscTypeHint' edescr) where - getReal (FieldDescr d) = descrName' d - getReal (ConstructorDescr d) = descrName' d - getReal (MethodDescr d) = descrName' d - getReal _ = id + getReal (FieldDescr d) = IThingAll (dscName d) + getReal (ConstructorDescr d) = IThingAll (dscName d) + getReal (MethodDescr d) = IThingAll (dscName d) + getReal _ = IVar id -qualString :: ImportDecl alpha -> String -qualString impDecl = case ideclAs impDecl of +qualString :: ImportDecl -> String +qualString impDecl = case importAs impDecl of Nothing -> "" - Just modName -> showSDoc (pprModuleName modName) - --- | A single Haskell @import@ declaration. -{-- -type LImportDecl name = Located (ImportDecl name) -data ImportDecl name - = ImportDecl { - ideclName :: Located ModuleName, -- ^ Module name. - ideclPkgQual :: Maybe FastString, -- ^ Package qualifier. - ideclSource :: Bool, -- ^ True <=> {-# SOURCE #-} import - ideclQualified :: Bool, -- ^ True => qualified - ideclAs :: Maybe ModuleName, -- ^ as Module - ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names) - } -type LIE name = Located (IE name) - --- | Imported or exported entity. -data IE name - = IEVar name - | IEThingAbs name -- ^ Class/Type (can't tell) - | IEThingAll name -- ^ Class/Type plus all methods/constructors - | IEThingWith name [name] -- ^ Class/Type plus some methods/constructors - | IEModuleContents ModuleName -- ^ (Export Only) - | IEGroup Int (HsDoc name) -- ^ Doc section heading - | IEDoc (HsDoc name) -- ^ Some documentation - | IEDocNamed String -- ^ Reference to named doc ---} - + Just modName -> modName -- | The import data @@ -287,7 +256,7 @@ parseNotInScope :: String -> (Maybe NotInScopeParseResult) parseNotInScope str = - case parse scopeParser "" str of + case Parsec.parse scopeParser "" str of Left e -> Nothing Right r -> Just r @@ -319,33 +288,6 @@ "conid" --- |* Where to insert the first import statement? - -figureOutImportLine :: String -> Maybe Int -figureOutImportLine modSource = - case parse importPosParser "" modSource of - Left e -> Nothing - Right pos -> (Just pos) - -importPosParser :: CharParser () Int -importPosParser = do - whiteSpace - skipHeader - pos <- getPosition - skipMany anyChar - eof - return (max (sourceLine pos - 2) 0) - "importPosParser" - -skipHeader :: CharParser () () -skipHeader =do - try (do - symbol "module" - manyTill anyChar (try (symbol "where")) - return ()) - <|> return () - "skipHeader" - -- |* The little dialog to choose between possible modules moduleFields :: [String] -> String -> FieldDescription String @@ -357,39 +299,49 @@ $ emptyParams) (\ a -> a) (\ a b -> a) - (staticListEditor ((nub . sort) list) id) + (staticListEditor ( list) id) -selectModuleDialog :: Window -> [Descr] -> String -> Maybe Descr -> IO (Maybe Descr) -selectModuleDialog parentWindow list id mbDescr = do - let selectionList = map (render . disp . modu . descrModu') list - let mbSelectedString = case mbDescr of - Nothing -> Nothing - Just descr -> Just ((render . disp . modu . descrModu') descr) - let realSelectionString = case mbSelectedString of - Nothing -> head selectionList - Just str -> if elem str selectionList - then str - else head selectionList - dia <- dialogNew - windowSetTransientFor dia parentWindow - upper <- dialogGetUpper dia - lower <- dialogGetActionArea dia - (widget,inj,ext,_) <- buildEditor (moduleFields selectionList id) realSelectionString - (widget2,_,_,notifier) <- buildEditor okCancelFields () - registerEvent notifier Clicked (Left (\e -> do - case eventPaneName e of - "Ok" -> dialogResponse dia ResponseOk - _ -> dialogResponse dia ResponseCancel - return e)) - boxPackStart upper widget PackGrow 7 - boxPackStart lower widget2 PackNatural 7 - widgetShowAll dia - resp <- dialogRun dia - value <- ext ([]) - widgetDestroy dia - --find - case (resp,value) of - (ResponseOk,Just v) -> return (Just (head (filter (\e -> (render . disp . modu . descrModu') e == v) - list))) - _ -> return Nothing +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 + lower <- dialogGetActionArea dia + (widget,inj,ext,_) <- buildEditor (moduleFields selectionList qualId) realSelectionString + (widget2,_,_,notifier) <- buildEditor okCancelFields () + registerEvent notifier Clicked (Left (\e -> do + case eventPaneName e of + "Ok" -> dialogResponse dia ResponseOk + _ -> dialogResponse dia ResponseCancel + return e)) + boxPackStart upper widget PackGrow 7 + boxPackStart lower widget2 PackNatural 7 + widgetShowAll dia + resp <- dialogRun dia + value <- ext ([]) + 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 diff --git a/src/IDE/Keymap.hs b/src/IDE/Keymap.hs --- a/src/IDE/Keymap.hs +++ b/src/IDE/Keymap.hs @@ -13,19 +13,17 @@ import Text.ParserCombinators.Parsec import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language(emptyDef) -import Data.Maybe import Data.List (foldl',sort) import Data.Char(toLower) import Control.Monad.Reader import IDE.Core.State -class IDEObject alpha => Keymap alpha where +class Keymap alpha where parseKeymap :: FilePath -> IO alpha setKeymap :: alpha -> [ActionDescr IDERef] -> [ActionDescr IDERef] buildSpecialKeys :: alpha -> [ActionDescr IDERef] -> IO (SpecialKeyTable IDERef) -instance IDEObject KeymapI instance Keymap KeymapI where parseKeymap = parseKeymap' diff --git a/src/IDE/Leksah.hs b/src/IDE/Leksah.hs --- a/src/IDE/Leksah.hs +++ b/src/IDE/Leksah.hs @@ -2,7 +2,7 @@ {-# OPTIONS_GHC -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- --- Module : IDE.Leksah +-- Module : Main -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- @@ -15,8 +15,8 @@ -- --------------------------------------------------------------------------------- -module IDE.Leksah ( - runMain +module Main ( + main ) where import Graphics.UI.Gtk @@ -27,67 +27,66 @@ import qualified Data.Map as Map import System.Console.GetOpt import System.Environment -import GHC -import Config import Data.Version import Prelude hiding(catch) -import System.Directory #if defined(darwin_HOST_OS) import IDE.OSX #endif +#ifdef YI +import qualified Yi as Yi +import qualified Yi.UI.Pango.Control as Yi +#endif + import Paths_leksah -import IDE.SaveSession +import IDE.Session import IDE.Core.State import Control.Event import IDE.SourceCandy -import IDE.FileUtils +import IDE.Utils.FileUtils import Graphics.UI.Editor.MakeEditor import Graphics.UI.Editor.Parameters -import IDE.Menu +import IDE.Command import IDE.Pane.Preferences import IDE.Keymap import IDE.Pane.SourceBuffer -import IDE.Metainfo.SourceCollector -import IDE.Metainfo.InterfaceCollector import IDE.Find import Graphics.UI.Editor.Composite (filesEditor, maybeEditor) -import Graphics.UI.Editor.Simple (fileEditor) ---import Outputable (ppr,showSDoc) -import IDE.Metainfo.GHCUtils (inGhcIO) -import IDE.Package (packageBuild) +import Graphics.UI.Editor.Simple (fileEditor, intEditor, stringEditor) import IDE.Metainfo.Provider (initInfo) +import IDE.Workspaces (backgroundMake) +import IDE.Utils.GUIUtils +import System.FilePath(()) +import Network (withSocketsDo) +import Control.Exception +import System.Exit(exitFailure) +import qualified IDE.StrippedPrefs as SP +import IDE.Utils.Tool (runTool,toolline) +import System.Process(waitForProcess) +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +#else +import qualified System.Posix as P +#endif +import System.Log +import System.Log.Logger(updateGlobalLogger,rootLoggerName,setLevel) -- -------------------------------------------------------------------- -- Command line options -- -data Flag = UninstalledProject String | Collect | Rebuild | Sources | VersionF | DebugF - | SessionN String | NoGUI | ExtractTars (Maybe String) | Help +data Flag = VersionF | SessionN String | Help | Verbosity String deriving (Show,Eq) options :: [OptDescr Flag] -options = [Option ['r'] ["Rebuild"] (NoArg Rebuild) - "Cleans all .pack files and rebuild everything" - , Option ['c'] ["Collect"] (NoArg Collect) - "Collects new information in .pack files" - , Option ['u'] ["Uninstalled"] (ReqArg UninstalledProject "FILE") - "Gather info about an uninstalled package" - , Option ['s'] ["Sources"] (NoArg Sources) - "Gather info about pathes to sources" - , Option ['v'] ["Version"] (NoArg VersionF) +options = [Option ['v'] ["Version"] (NoArg VersionF) "Show the version number of ide" - , Option ['d'] ["Debug"] (NoArg DebugF) - "Write ascii pack files" , Option ['l'] ["LoadSession"] (ReqArg SessionN "NAME") "Load session" - , Option ['n'] ["NoGUI"] (NoArg NoGUI) - "Don't start the leksah GUI" - , Option ['x'] ["Extract"] (OptArg ExtractTars "FILE") - "Extract tars from cabal install directory" , Option ['h'] ["Help"] (NoArg Help) - "Display command line options"] + "Display command line options" + , Option ['e'] ["verbosity"] (ReqArg Verbosity "Verbosity") + "One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"] header = "Usage: ide [OPTION...] files..." @@ -102,86 +101,73 @@ -- | Main function -- -runMain = handleTopExceptions $ do +main = withSocketsDo $ handleExceptions $ do +#if defined(mingw32_HOST_OS) || defined(__MINGW32__) +#else + P.getProcessID >>= P.createProcessGroup +#endif args <- getArgs (o,_) <- ideOpts args - let uninstalled = filter (\x -> case x of - UninstalledProject _ -> True - _ -> False) o + isFirstStart <- liftM not hasConfigDir let sessions = filter (\x -> case x of SessionN _ -> True _ -> False) o let sessionFilename = if not (null sessions) - then (head $ map (\ (SessionN x) -> x) sessions) ++ ".session" - else "Current.session" + then (head $ map (\ (SessionN x) -> x) sessions) ++ leksahSessionFileExtension + else standardSessionFilename + let verbosity' = catMaybes $ + map (\x -> case x of + Verbosity s -> Just s + _ -> Nothing) o + let verbosity = case verbosity' of + [] -> INFO + h:_ -> read h + updateGlobalLogger rootLoggerName (\ l -> setLevel verbosity l) when (elem VersionF o) - (sysMessage Normal $ "Leksah an IDE for Haskell, version " ++ showVersion version) + (sysMessage Normal $ "Leksah the Haskell IDE, version " ++ showVersion version) when (elem Help o) - (sysMessage Normal $ "Leksah an IDE for Haskell, version " ++ usageInfo header options) - prefsPath <- getConfigFilePathForLoad "Default.prefs" - prefs <- readPrefs prefsPath - let extract = filter (\x -> case x of - ExtractTars _ -> True - _ -> False) o - when (not (null extract)) $ case head extract of - ExtractTars (Just path) -> do - dir <- getCurrentDirectory - autoExtractTarFiles path - setCurrentDirectory dir - _ -> do - case autoExtractTars prefs of - Nothing -> return () - Just path -> do - dir <- getCurrentDirectory - autoExtractTarFiles path - setCurrentDirectory dir - when (elem Sources o) (do - buildSourceForPackageDB prefs - sysMessage Normal "rebuild SourceForPackageDB") - when (elem Rebuild o || elem Collect o || not (null uninstalled)) $ do - inGhcIO $ do - flags <- getSessionDynFlags - let version = cProjectVersion - let uninstalled = filter (\x -> case x of - UninstalledProject _ -> True - _ -> False) o - let writeAscii = elem DebugF o - if length uninstalled > 0 - then mapM_ (collectUninstalled writeAscii version) - $ map (\ (UninstalledProject x) -> x) uninstalled - else do - collectInstalled' prefs writeAscii version (elem Rebuild o) - when (not (elem NoGUI o) && not (elem VersionF o) && not (elem Help o)) - (startGUI sessionFilename prefs) + (sysMessage Normal $ "Leksah the Haskell IDE, version " ++ usageInfo header options) + dataDir <- getDataDir + prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir + prefs <- readPrefs prefsPath + when (not (elem VersionF o) && not (elem Help o)) + (startGUI sessionFilename prefs isFirstStart) +handleExceptions inner = + catch inner (\(exception :: SomeException) -> do + sysMessage Normal ("leksah: internal IDE error: " ++ show exception) + exitFailure + ) + -- --------------------------------------------------------------------- -- | Start the GUI -startGUI :: String -> Prefs -> IO () -startGUI sessionFilename iprefs = do +startGUI :: String -> Prefs -> Bool -> IO () +startGUI sessionFilename iprefs isFirstStart = do st <- unsafeInitGUIForThreadedRTS when rtsSupportsBoundThreads (sysMessage Normal "Linked with -threaded") - timeoutAddFull (yield >> return True) priorityHigh 100 + timeoutAddFull (yield >> return True) priorityDefaultIdle 100 -- maybe switch back to priorityHigh/??? mapM_ (sysMessage Normal) st + initGtkRc uiManager <- uiManagerNew newIcons - hasConfigDir' <- hasConfigDir - (startupPrefs,isFirstStart) <- if hasConfigDir' - then return (iprefs,False) + dataDir <- getDataDir + startupPrefs <- if not isFirstStart + then return iprefs else do firstStart iprefs - prefsPath <- getConfigFilePathForLoad "Default.prefs" + prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir prefs <- readPrefs prefsPath - return (prefs,True) + return prefs candyPath <- getConfigFilePathForLoad (case sourceCandy startupPrefs of - Nothing -> "Default.candy" - Just name -> name ++ ".candy") + Nothing -> standardCandyFilename + Just name -> name ++ leksahCandyFileExtension) Nothing dataDir candySt <- parseCandy candyPath -- keystrokes - keysPath <- getConfigFilePathForLoad $ keymapName iprefs ++ ".keymap" + keysPath <- getConfigFilePathForLoad (keymapName iprefs ++ leksahKeymapFileExtension) Nothing dataDir keyMap <- parseKeymap keysPath let accelActions = setKeymap (keyMap :: KeymapI) mkActions specialKeys <- buildSpecialKeys keyMap accelActions @@ -197,36 +183,46 @@ , layout = (TerminalP Map.empty Nothing (-1) Nothing Nothing) , panePathFromNB = Map.empty } +#ifdef YI + yiControl <- Yi.newControl Yi.defaultVimConfig +#endif + let ide = IDE - { frameState = fs - , recentPanes = [] - , specialKeys = specialKeys - , specialKey = Nothing - , candy = candySt - , prefs = startupPrefs - , activePack = Nothing - , projFilesCache = Map.empty - , allLogRefs = [] - , currentHist = 0 - , currentEBC = (Nothing, Nothing, Nothing) - , accessibleInfo = Nothing - , currentInfo = Nothing - , handlers = Map.empty - , currentState = IsStartingUp - , guiHistory = (False,[],-1) - , findbar = (False,Nothing) - , toolbar = (True,Nothing) - , recentFiles = [] - , recentPackages = [] - , runningTool = Nothing - , ghciState = Nothing - , completion = Nothing + { frameState = fs + , recentPanes = [] + , specialKeys = specialKeys + , specialKey = Nothing + , candy = candySt + , prefs = startupPrefs + , workspace = Nothing + , activePack = Nothing + , bufferProjCache = Map.empty + , allLogRefs = [] + , currentHist = 0 + , currentEBC = (Nothing, Nothing, Nothing) + , systemInfo = Nothing + , packageInfo = Nothing + , workspaceInfo = Nothing + , workspInfoCache = Map.empty + , handlers = Map.empty + , currentState = IsStartingUp + , guiHistory = (False,[],-1) + , findbar = (False,Nothing) + , toolbar = (True,Nothing) + , recentFiles = [] + , recentWorkspaces = [] + , runningTool = Nothing + , ghciState = Nothing + , completion = Nothing +#ifdef YI + , yiControl = yiControl +#endif + , server = Nothing } - ideR <- newIORef ide - reflectIDE (initInfo :: IDEAction) ideR + ideR <- newIORef ide menuDescription' <- menuDescription reflectIDE (makeMenu uiManager accelActions menuDescription') ideR - nb <- reflectIDE (newNotebook []) ideR + nb <- reflectIDE (newNotebook []) ideR afterSwitchPage nb (\i -> reflectIDE (handleNotebookSwitch nb i) ideR) widgetSetName nb $"root" win `onDelete` (\ _ -> do reflectIDE quit ideR; return True) @@ -237,7 +233,7 @@ setBackgroundLinkToggled (backgroundLink startupPrefs)) ideR let (x,y) = defaultSize startupPrefs windowSetDefaultSize win x y - sessionPath <- getConfigFilePathForLoad sessionFilename + sessionPath <- getConfigFilePathForLoad sessionFilename Nothing dataDir (tbv,fbv) <- reflectIDE (do registerEvents pair <- recoverSession sessionPath @@ -261,20 +257,22 @@ else hideFindbar) ideR when isFirstStart $ do - welcomePath <- getConfigFilePathForLoad $ "welcome.txt" + welcomePath <- getConfigFilePathForLoad "welcome.txt" Nothing dataDir reflectIDE (fileOpenThis welcomePath) ideR - reflectIDE (modifyIDE_ (\ide -> ide{currentState = IsRunning})) ideR - + reflectIDE (initInfo (modifyIDE_ (\ide -> ide{currentState = IsRunning}))) ideR timeoutAddFull (do reflectIDE (do currentPrefs <- readIDE prefs - when (backgroundBuild currentPrefs) $ packageBuild True) ideR + when (backgroundBuild currentPrefs) $ backgroundMake) ideR return True) priorityDefaultIdle 1000 reflectIDE (triggerEvent ideR (Sensitivity [(SensitivityInterpreting, False)])) ideR +-- timeoutAddFull (do +-- reflectIDE (postAsyncIDE (initInfo (modifyIDE_ (\ide -> ide{currentState = IsRunning})))) ideR +-- return False) priorityDefault 100 mainGUI -fDescription :: FieldDescription Prefs -fDescription = VFD emptyParams [ +fDescription :: FilePath -> FieldDescription Prefs +fDescription configPath = VFD emptyParams [ mkField (paraName <<<- ParaName "Paths under which haskell sources may be found" $ paraDirection <<<- ParaDirection Vertical @@ -283,19 +281,31 @@ (\b a -> a{sourceDirectories = b}) (filesEditor Nothing FileChooserActionSelectFolder "Select folders") , mkField - (paraName <<<- ParaName "Extract packages from cabal-install" $ emptyParams) - autoExtractTars - (\b a -> a{autoExtractTars = b}) - (maybeEditor ((fileEditor (Just "~/.cabal/packages/") FileChooserActionSelectFolder - "Select folder"), emptyParams) True "Yes")] + (paraName <<<- ParaName "Maybe a directory for unpacking cabal packages" $ emptyParams) + unpackDirectory + (\b a -> a{unpackDirectory = b}) + (maybeEditor ((fileEditor (Just (configPath "packageSources")) FileChooserActionSelectFolder + "Select folder for unpacking cabal packages"), emptyParams) True "Yes") + , mkField + (paraName <<<- ParaName "Port number for server connection" $ emptyParams) + serverPort + (\b a -> a{serverPort = b}) + (intEditor (1.0, 65535.0, 1.0)) + , mkField + (paraName <<<- ParaName "Server IP address " $ emptyParams) + serverIP + (\b a -> a{serverIP = b}) + (stringEditor (\ s -> not $ null s))] -- --- | Called when leksah ist first called (the .leksah directory does not exist) +-- | Called when leksah ist first called (the .leksah-xx directory does not exist) -- firstStart :: Prefs -> IO () firstStart prefs = do - prefsPath <- getConfigFilePathForLoad "Default.prefs" - prefs <- readPrefs prefsPath + dataDir <- getDataDir + prefsPath <- getConfigFilePathForLoad standardPreferencesFilename Nothing dataDir + prefs <- readPrefs prefsPath + configDir <- getConfigDir dialog <- windowNew vb <- vBoxNew False 0 bb <- hButtonBoxNew @@ -303,12 +313,13 @@ cancel <- buttonNewFromStock "gtk-cancel" boxPackStart bb ok PackNatural 0 boxPackStart bb cancel PackNatural 0 - label <- labelNew (Just ("Welcome to Leksah, an IDE for Haskell.\n" ++ + label <- labelNew (Just ("Welcome to Leksah, the Haskell IDE.\n" ++ "At the first start, Leksah will collect metadata about your installed haskell packages.\n" ++ - "Select folders under which you have installed Haskell packages with sources below and click add.\n" ++ - "It may take some time before Leksah starts up.")) + "You can add folders under which you have sources for Haskell packages not available from Hackage.\n" ++ + "If you are not shure what to do, just keep the defaults \n" ++ + "This process may take a long time, but it only needs to run one time.")) (widget, setInj, getExt,notifier) - <- buildEditor fDescription prefs + <- buildEditor (fDescription configDir) prefs ok `onClicked` (do mbNewPrefs <- extract prefs [getExt] case mbNewPrefs of @@ -316,11 +327,18 @@ sysMessage Normal "No dialog results" return () Just newPrefs -> do - fp <- getConfigFilePathForSave "Default.prefs" + fp <- getConfigFilePathForSave standardPreferencesFilename writePrefs fp newPrefs + fp2 <- getConfigFilePathForSave strippedPreferencesFilename + SP.writeStrippedPrefs fp2 + (SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs, + SP.unpackDirectory = unpackDirectory newPrefs, + SP.retreiveURL = retreiveURL newPrefs, + SP.serverPort = serverPort newPrefs}) widgetDestroy dialog mainQuit - firstBuild newPrefs) + firstBuild newPrefs + ) cancel `onClicked` (do widgetDestroy dialog mainQuit) @@ -332,16 +350,15 @@ boxPackStart vb widget PackGrow 7 boxPackEnd vb bb PackNatural 7 containerAdd dialog vb - widgetSetSizeRequest dialog 700 400 + widgetSetSizeRequest dialog 1024 800 widgetShowAll dialog mainGUI return () -firstBuild :: Prefs -> IO () -firstBuild prefs = let version = cProjectVersion in do - buildSourceForPackageDB prefs - sources <- getSourcesMap prefs - libDir <- getSysLibDir - runGhc (Just libDir) $ collectInstalled' prefs False version True +firstBuild newPrefs = do + (output, pid) <- runTool "leksah-server" ["-sbo"] Nothing + mapM_ (putStrLn . toolline) output + waitForProcess pid + return () diff --git a/src/IDE/LogRef.hs b/src/IDE/LogRef.hs --- a/src/IDE/LogRef.hs +++ b/src/IDE/LogRef.hs @@ -44,32 +44,30 @@ import qualified Text.ParserCombinators.Parsec.Token as P import IDE.Core.State +import IDE.TextEditor import IDE.Pane.SourceBuffer import IDE.Pane.Log -import IDE.Tool +import IDE.Utils.Tool import System.FilePath (equalFilePath) import System.Directory (canonicalizePath) import Data.List (stripPrefix, elemIndex, isPrefixOf) -import SrcLoc - (srcLocSpan, mkSrcLoc, mkSrcSpan, SrcSpan(..)) -import FastString (mkFastString) import Data.Maybe (catMaybes) -import Outputable (ppr, showSDoc) +import Debug.Trace (trace) +import System.Exit (ExitCode(..)) showSourceSpan :: LogRef -> String -showSourceSpan = showSDoc . ppr . logRefSrcSpan - +showSourceSpan = displaySrcSpan . logRefSrcSpan selectRef :: Maybe LogRef -> IDEAction selectRef (Just ref) = do logRefs <- readIDE allLogRefs case elemIndex ref logRefs of - Nothing -> return () + Nothing -> trace "no index" $ return () Just index -> do - mbBuf <- selectSourceBuf (filePath ref) + mbBuf <- selectSourceBuf (logRefFullFilePath ref) case mbBuf of Just buf -> markRefInSourceBuf index buf ref True - Nothing -> return () + Nothing -> trace "no buf" $ return () log :: IDELog <- getLog liftIO $ markErrorInLog log (logLines ref) selectRef Nothing = return () @@ -80,7 +78,7 @@ allBufs <- allBuffers forM_ [0 .. ((length logRefs)-1)] (\index -> do let ref = logRefs !! index - fpc <- liftIO $ canonicalizePath $ filePath ref + fpc <- liftIO $ canonicalizePath $ logRefFullFilePath ref forM_ (filter (\buf -> case (fileName buf) of Just fn -> equalFilePath fpc fn Nothing -> False) allBufs) (f index ref)) @@ -91,11 +89,11 @@ unmarkLogRefs :: IDEAction unmarkLogRefs = do - forOpenLogRefs $ \index logRef buf -> liftIO $ do - gtkbuf <- textViewGetBuffer (sourceView buf) - i1 <- textBufferGetStartIter gtkbuf - i2 <- textBufferGetEndIter gtkbuf - textBufferRemoveTagByName gtkbuf (show (logRefType logRef) ++ show index) i1 i2 + forOpenLogRefs $ \index logRef buf -> do + gtkbuf <- getBuffer (sourceView buf) + i1 <- getStartIter gtkbuf + i2 <- getEndIter gtkbuf + removeTagByName gtkbuf (show (logRefType logRef) ++ show index) i1 i2 setErrorList :: [LogRef] -> IDEAction setErrorList errs = do @@ -247,7 +245,7 @@ srcSpanParser :: CharParser () SrcSpan srcSpanParser = try (do - filePath <- fmap mkFastString $ many (noneOf ":") + filePath <- many (noneOf ":") char ':' char '(' beginLine <- int @@ -260,25 +258,23 @@ char ',' endCol <- int char ')' - return $ mkSrcSpan (mkSrcLoc filePath beginLine beginCol) - (mkSrcLoc filePath endLine endCol)) + return $ SrcSpan filePath beginLine beginCol endLine endCol) <|> try (do - filePath <- fmap mkFastString $ many (noneOf ":") + filePath <- many (noneOf ":") char ':' line <- int char ':' beginCol <- int char '-' endCol <- int - return $ mkSrcSpan (mkSrcLoc filePath line beginCol) - (mkSrcLoc filePath line endCol)) + return $ SrcSpan filePath line beginCol line endCol) <|> try (do - filePath <- fmap mkFastString $ many (noneOf ":") + filePath <- many (noneOf ":") char ':' line <- int char ':' col <- int - return $ srcLocSpan (mkSrcLoc filePath line col)) + return $ SrcSpan filePath line col line col) "srcLocParser" data BuildError = BuildLine @@ -355,21 +351,24 @@ int = fmap fromInteger $ P.integer lexer defaultLineLogger :: IDELog -> ToolOutput -> IDEM Int -defaultLineLogger log out = liftIO $ do +defaultLineLogger log out = liftIO $ defaultLineLogger' log out + +defaultLineLogger' :: IDELog -> ToolOutput -> IO Int +defaultLineLogger' log out = do case out of - ToolInput line -> appendLog log (line ++ "\n") InputTag - ToolOutput line -> appendLog log (line ++ "\n") LogTag - ToolError line -> appendLog log (line ++ "\n") ErrorTag + ToolInput line -> appendLog log (line ++ "\n") InputTag + ToolOutput line -> appendLog log (line ++ "\n") LogTag + ToolError line -> appendLog log (line ++ "\n") ErrorTag + ToolExit ExitSuccess -> appendLog log (take 40 (repeat '-') ++ "\n") FrameTag + ToolExit (ExitFailure 1) -> appendLog log (take 40 (repeat '=') ++ "\n") FrameTag + ToolExit (ExitFailure n) -> appendLog log (take 40 ("========== " ++ 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 - liftIO $ appendLog log "----------------------------------\n" FrameTag - sb <- getSBErrors - liftIO $ statusbarPop sb 1 - liftIO $ statusbarPush sb 1 "" + triggerEventIDE (StatusbarChanged [CompartmentState "", CompartmentBuild False]) return results logOutputLines_ :: (IDELog -> ToolOutput -> IDEM a) -> [ToolOutput] -> IDEAction @@ -382,19 +381,18 @@ logOutputLines defaultLineLogger output return () -logOutputForBuild :: Bool -> [ToolOutput] -> IDEAction -logOutputForBuild backgroundBuild output = do +logOutputForBuild :: FilePath -> Bool -> [ToolOutput] -> IDEAction +logOutputForBuild rootPath 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))]) - sb <- getSBErrors let errorNum = length (filter isError errs) let warnNum = length errs - errorNum - liftIO $ statusbarPop sb 1 - liftIO $ statusbarPush sb 1 $show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings" + triggerEventIDE (StatusbarChanged [CompartmentState + (show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings"), CompartmentBuild False]) unless backgroundBuild nextError return () where @@ -403,7 +401,7 @@ let errorNum = length (filter isError errs) let warnNum = length errs - errorNum case errs of - [] -> appendLog log "----------------------------------\n" FrameTag + [] -> defaultLineLogger' log (ToolExit ExitSuccess) _ -> appendLog log ("----- " ++ show errorNum ++ " errors -- " ++ show warnNum ++ " warnings -----\n") FrameTag return errs @@ -429,18 +427,20 @@ sysMessage Normal (show e) readAndShow remainingOutput ideR log False errs (Right ne@(ErrorLine span str),_) -> - readAndShow remainingOutput ideR log True ((LogRef span str (lineNr,lineNr) ErrorRef):errs) - (Right (OtherLine str1),(LogRef span str (l1,l2) refType):tl) -> + readAndShow remainingOutput ideR log True ((LogRef span rootPath str (lineNr,lineNr) ErrorRef):errs) + (Right (OtherLine str1),(LogRef span rootPath str (l1,l2) refType):tl) -> if inError then readAndShow remainingOutput ideR 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 - (Right (WarningLine str1),(LogRef span str (l1,l2) isError):tl) -> + (Right (WarningLine str1),(LogRef span rootPath str (l1,l2) isError):tl) -> if inError then readAndShow remainingOutput ideR log True ((LogRef span + rootPath (if null str then line else str ++ "\n" ++ line) @@ -453,39 +453,47 @@ ToolInput line -> do appendLog log (line ++ "\n") InputTag readAndShow remainingOutput ideR log inError errs + ToolExit _ -> do + 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 -logOutputForBreakpoints :: [ToolOutput] -> IDEAction -logOutputForBreakpoints output = do +logOutputForBreakpoints :: FilePath -> [ToolOutput] -> IDEAction +logOutputForBreakpoints rootPath output = do breaks <- logOutputLines (\log out -> do case out of ToolOutput line -> do logLineNumber <- liftIO $ appendLog log (line ++ "\n") LogTag case parse breaksLineParser "" line of Right (BreakpointDescription n span) -> - return $ Just $ LogRef span line (logLineNumber, logLineNumber) BreakpointRef + return $ Just $ LogRef span rootPath line (logLineNumber, logLineNumber) BreakpointRef _ -> return Nothing _ -> do defaultLineLogger log out return Nothing) output setBreakpointList $ catMaybes breaks -logOutputForSetBreakpoint :: [ToolOutput] -> IDEAction -logOutputForSetBreakpoint output = do +logOutputForSetBreakpoint :: FilePath -> [ToolOutput] -> IDEAction +logOutputForSetBreakpoint rootPath output = do breaks <- logOutputLines (\log out -> do case out of ToolOutput line -> do logLineNumber <- liftIO $ appendLog log (line ++ "\n") LogTag case parse setBreakpointLineParser "" line of Right (BreakpointDescription n span) -> - return $ Just $ LogRef span line (logLineNumber, logLineNumber) BreakpointRef + return $ Just $ LogRef span rootPath line (logLineNumber, logLineNumber) BreakpointRef _ -> return Nothing _ -> do defaultLineLogger log out return Nothing) output addLogRefs $ catMaybes breaks -logOutputForContext :: (String -> [SrcSpan]) -> [ToolOutput] -> IDEAction -logOutputForContext getContexts output = do +logOutputForContext :: FilePath -> (String -> [SrcSpan]) -> [ToolOutput] -> IDEAction +logOutputForContext rootPath getContexts output = do refs <- fmap catMaybes $ logOutputLines (\log out -> do case out of ToolOutput line -> do @@ -493,7 +501,7 @@ let contexts = getContexts line if null contexts then return Nothing - else return $ Just $ LogRef (last contexts) line (logLineNumber, logLineNumber) ContextRef + else return $ Just $ LogRef (last contexts) rootPath line (logLineNumber, logLineNumber) ContextRef _ -> do defaultLineLogger log out return Nothing) output @@ -501,8 +509,8 @@ addLogRefs [last refs] lastContext -logOutputForLiveContext :: [ToolOutput] -> IDEAction -logOutputForLiveContext = logOutputForContext getContexts +logOutputForLiveContext :: FilePath -> [ToolOutput] -> IDEAction +logOutputForLiveContext rootPath = logOutputForContext rootPath getContexts where getContexts [] = [] getContexts line@(x:xs) = case stripPrefix "Stopped at " line of @@ -511,8 +519,8 @@ _ -> getContexts xs _ -> getContexts xs -logOutputForHistoricContext :: [ToolOutput] -> IDEAction -logOutputForHistoricContext = logOutputForContext getContexts +logOutputForHistoricContext :: FilePath -> [ToolOutput] -> IDEAction +logOutputForHistoricContext rootPath = logOutputForContext rootPath getContexts where getContexts line = case stripPrefix "Logged breakpoint at " line of Just rest -> case parse srcSpanParser "" rest of diff --git a/src/IDE/Menu.hs b/src/IDE/Menu.hs deleted file mode 100644 --- a/src/IDE/Menu.hs +++ /dev/null @@ -1,833 +0,0 @@ -{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Menu --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- --- | Module for actions, menus and toolbars and the rest ... --- -------------------------------------------------------------------------------- - - -module IDE.Menu ( - mkActions -, menuDescription -, makeMenu -, quit -, aboutDialog -, buildStatusbar -, newIcons -, setSensitivity -, updateRecentEntries -, handleSpecialKeystrokes -, registerEvents -, instrumentWindow -, instrumentSecWindow -) where - -import Graphics.UI.Gtk -import Graphics.UI.Gtk.Types -import Control.Monad.Reader -import System.FilePath -import Data.Version -import Prelude hiding (catch) -import Control.Exception -import Data.Maybe - - -import IDE.Core.State -import IDE.Pane.SourceBuffer -import IDE.Pane.Preferences -import IDE.Pane.PackageFlags -import IDE.Pane.PackageEditor -import IDE.Pane.Errors -import IDE.Package -import IDE.Pane.Log -import IDE.SaveSession -import IDE.Pane.Modules -import IDE.Find -import IDE.FileUtils -import IDE.Pane.ClassHierarchy -import IDE.Pane.Search -import IDE.Pane.References -import Paths_leksah -import IDE.GUIHistory -import IDE.Metainfo.Provider - (infoForActivePackage, rebuildLibInfo, rebuildActiveInfo) -import IDE.Pane.Info (setSymbol, showInfo) -import IDE.NotebookFlipper -import IDE.ImportTool (addAllImports) -import IDE.LogRef -import IDE.Debug -import System.Directory (doesFileExist) -import qualified Graphics.UI.Gtk.Gdk.Events as GdkEvents -import Graphics.UI.Gtk.Gdk.Events - (Modifier(..), - Event(..)) -import Graphics.UI.Gtk.Gdk.Enums (Modifier(..)) -import qualified Data.Map as Map (lookup) -import Data.List (sort) -import Control.Event (registerEvent) -import Paths_leksah -import IDE.Pane.Breakpoints - (showBreakpointList, fillBreakpointList, selectBreak) -import Debug.Trace (trace) -import IDE.Pane.Variables (showVariables, fillVariablesList) -import IDE.Pane.Trace (showTrace,fillTraceList) -import IDE.Group.Debugger (setSensitivityDebugger, showDebugger) --- --- | The Actions known to the system (they can be activated by keystrokes or menus) --- -mkActions :: [ActionDescr IDERef] -mkActions = - [AD "File" "_File" Nothing Nothing (return ()) [] False - ,AD "FileNew" "_New" Nothing (Just "gtk-new") - fileNew [] False - ,AD "FileOpen" "_Open" Nothing (Just "gtk-open") - fileOpen [] False - ,AD "RecentFiles" "_Recent Files" Nothing Nothing (return ()) [] False - ,AD "FileRevert" "_Revert" Nothing Nothing - fileRevert [] False - ,AD "FileSave" "_Save" Nothing (Just "gtk-save") - (do fileSave False; return ()) [] False - ,AD "FileSaveAs" "Save _As" Nothing (Just "gtk-save-as") - (do fileSave True; return ()) [] False - ,AD "FileSaveAll" "Save A_ll" Nothing Nothing - (do fileSaveAll (\ b -> return (bufferName b /= "_Eval.hs")); return ()) [] False - ,AD "FileClose" "_Close" Nothing (Just "gtk-close") - (do fileClose; return ()) [] False - ,AD "FileCloseAll" "Close All" Nothing Nothing - (do fileCloseAll (\ b -> return (bufferName b /= "_Eval.hs")); return ()) [] False - ,AD "FileCloseAllButPackage" "Close All But Package" Nothing Nothing - (do fileCloseAllButPackage; return ()) [] False - ,AD "Quit" "_Quit" Nothing (Just "gtk-quit") - quit [] False - - ,AD "Edit" "_Edit" Nothing Nothing (return ()) [] False - ,AD "EditUndo" "_Undo" Nothing (Just "gtk-undo") - editUndo [] False - ,AD "EditRedo" "_Redo" Nothing (Just "gtk-redo") - editRedo [] False - ,AD "EditCut" "Cu_t" Nothing (Just "gtk-cut") - editCut [] {--Just "X"--} False - ,AD "EditCopy" "_Copy" Nothing (Just "gtk-copy") - editCopy [] {--Just "C"--} False - ,AD "EditPaste" "_Paste" Nothing (Just "gtk-paste") - editPaste [] {--Just "V"--} False - ,AD "EditDelete" "_Delete" Nothing (Just "gtk-delete") - editDelete [] False - ,AD "EditSelectAll" "Select_All" Nothing (Just "gtk-select-all") - editSelectAll [] False - ,AD "EditFind" "Find" Nothing (Just "gtk-find") - (editFindInc Initial) [] False - ,AD "EditFindNext" "Find _Next" Nothing (Just "gtk-find-next") - (editFindInc Forward) [] False - ,AD "EditFindPrevious" "Find _Previous" Nothing (Just "gtk-find-previous") - (editFindInc Backward) [] False - ,AD "EditGotoLine" "_Goto Line" Nothing (Just "gtk-jump") - editGotoLine [] False - - ,AD "EditComment" "_Comment" Nothing Nothing - editComment [] False - ,AD "EditUncomment" "_Uncomment" Nothing Nothing - editUncomment [] False - ,AD "EditShiftRight" "Shift _Right" Nothing Nothing - editShiftRight [] False - ,AD "EditShiftLeft" "Shift _Left" Nothing Nothing - editShiftLeft [] False - - --,AD "Align" "_Align" Nothing Nothing (return ()) [] False - ,AD "EditAlignEqual" "Align _=" Nothing Nothing - (align '=') [] False - ,AD "EditAlignRightArrow" "Align -_>" Nothing Nothing - (align '>') [] False - ,AD "EditAlignLeftArrow" "Align _<-" Nothing Nothing - (align '<') [] False - ,AD "EditAlignTypeSig" "Align _::" Nothing Nothing - (align ':') [] False - - - ,AD "Package" "_Package" Nothing Nothing (return ()) [] False - ,AD "NewPackage" "_New Package" Nothing Nothing - packageNew [] False - ,AD "OpenPackage" "_Open Package" Nothing Nothing - packageOpen [] False - ,AD "RecentPackages" "_Recent Packages" Nothing Nothing (return ()) [] False - ,AD "EditPackage" "_Edit Package" Nothing Nothing - packageEdit [] False - ,AD "ClosePackage" "_Close Package" Nothing Nothing - deactivatePackage [] False - - ,AD "PackageFlags" "Edit Flags" (Just "Edit the package flags") Nothing - (do getFlags; return ()) [] False - ,AD "ConfigPackage" "_Configure Package" (Just "Configures the package") (Just "ide_configure") - packageConfig [] False - ,AD "BuildPackage" "_Build Package" (Just "Builds the package") (Just "ide_make") - (packageBuild False) [] False - ,AD "DocPackage" "_Build Documentation" (Just "Builds the documentation") Nothing - packageDoc [] False - ,AD "CleanPackage" "Cl_ean Package" (Just "Cleans the package") (Just "ide_clean") - packageClean [] False - ,AD "CopyPackage" "_Copy Package" (Just "Copies the package") Nothing - packageCopy [] False - ,AD "RunPackage" "_Run" (Just "Runs the package") (Just "ide_run") - packageRun [] False - ,AD "NextError" "_Next Error" (Just "Go to the next error") (Just "ide_error_next") - nextError [] False - ,AD "PreviousError" "_Previous Error" (Just "Go to the previous error") (Just "ide_error_prev") - previousError [] False - ,AD "AddAllImports" "_Add All Imports" (Just "Resolve 'Not in scope' errors by adding the necessary imports") Nothing - addAllImports [] False - - ,AD "InstallPackage" "_Install Package" Nothing Nothing - packageInstall [] False - ,AD "RegisterPackage" "_Register Package" Nothing Nothing - packageRegister [] False - ,AD "UnregisterPackage" "_Unregister" Nothing Nothing - packageUnregister [] False - ,AD "TestPackage" "Test Package" Nothing Nothing - packageTest [] False - ,AD "SdistPackage" "Source Dist" Nothing Nothing - packageSdist [] False - ,AD "OpenDocPackage" "_Open Doc" Nothing Nothing - packageOpenDoc [] False - - ,AD "Debug" "_Debug" Nothing Nothing (return ()) [] False - ,AD "StartDebugger" "_Start Debugger" (Just "Starts using the GHCi debugger for build and run") Nothing - debugStart [] False - ,AD "QuitDebugger" "_Quit Debugger" (Just "Quit the GHCi debugger if it is running") Nothing - debugQuit [] False - ,AD "ExecuteSelection" "_Execute Selection" (Just "Sends the selected text to the debugger") Nothing - debugExecuteSelection [] False - ,AD "ShowErrorsList" "Show Errors" Nothing Nothing - showErrors [] False - ,AD "ShowBreakpointsList" "Show Breakpoints List" Nothing Nothing - (trace "1" showBreakpointList) [] False - ,AD "ShowVariablesList" "Show Variables List" Nothing Nothing - showVariables [] False - ,AD "ShowTracesList" "Show Traces List" Nothing Nothing - showTrace [] False - ,AD "ShowEval" "Show Eval" Nothing Nothing - {--showTrace--} undefined [] False - ,AD "ShowDebugger" "Show Debugger" Nothing Nothing - showDebugger [] False - - ,AD "DebugSetBreakpoint" "Set Breakpoint" (Just "Set a breakpoint on the selected name or current line") Nothing - debugSetBreakpoint [] False - ,AD "ShowNextBreakpoint" "Show Next Breakpoint" (Just "Show the next breakpoint") Nothing - nextBreakpoint [] False - ,AD "ShowPreviousBreakpoint" "Show Previous Breakpoint" (Just "Show the previous breakpoint") Nothing - previousBreakpoint [] False - ,AD "DebugDeleteAllBreakpoints" "Delete All Breakpoints" (Just "") Nothing - debugDeleteAllBreakpoints [] False - - ,AD "DebugContinue" "Continue" (Just "Resume after a breakpoint") (Just "ide_continue") - debugContinue [] False - ,AD "DebugAbandon" "Abandon" (Just "At a breakpoint, abandon current computation") Nothing - debugAbandon [] False - ,AD "DebugStop" "Stop" (Just "Interrupt the running operation.") Nothing - debugStop [] False - - ,AD "DebugStep" "Step" (Just "Single-step after stopping at a breakpoint") (Just "ide_step") - debugStep [] False - ,AD "DebugStepExpression" "Step Expression" (Just "Single-step into selected expression") Nothing - debugStepExpression [] False - ,AD "DebugStepLocal" "Step Local" (Just "Single-step within the current top-level binding") (Just "ide_local") - debugStepLocal [] False - ,AD "DebugStepModule" "Step Module" (Just "Single-step restricted to the current module") (Just "ide_module") - debugStepModule [] False - - ,AD "DebugTrace" "Trace" (Just "Trace after stopping at a breakpoint") Nothing - debugTrace [] False - ,AD "DebugTraceExpression" "Trace Expression" (Just "Evaluate the selected expression with tracing on") Nothing - debugTraceExpression [] False - ,AD "DebugHistory" "History" (Just "After 'Trace', show the execution history") Nothing - debugHistory [] False - ,AD "DebugBack" "Back" (Just "Go back in the history (after 'Trace')") Nothing - debugBack [] False - ,AD "DebugForward" "Forward" (Just "Go forward in the history (after 'Back')") Nothing - debugForward [] False - - ,AD "DebugForce" "Force" (Just "Print the selected expression, forcing unevaluated parts") Nothing - debugForce [] False - ,AD "DebugPrint" "Print" (Just "Prints a value without forcing its computation") Nothing - debugPrint [] False - ,AD "DebugSimplePrint" "SimplePrint" (Just "Simplifed version of Print") Nothing - debugSimplePrint [] False - - ,AD "ShowBindings" "Show Bin_dings" (Just "Show the current bindings") Nothing - debugShowBindings [] False - ,AD "ShowBreakpoints" "Show _Breakpoints" (Just "Show the active breakpoints") Nothing - debugShowBreakpoints [] False - ,AD "ShowContext" "Show _Context" (Just "Show the breakpoint context") Nothing - debugShowContext [] False - ,AD "ShowLoadedModules" "Show Loaded _Modules" (Just "Show the currently loaded modules") Nothing - debugShowModules [] False - ,AD "ShowPackages" "Show _Packages" (Just "Show the currently active packages") Nothing - debugShowPackages [] False - ,AD "ShowLanguages" "Show _Languages" (Just "Show the currently active language") Nothing - debugShowLanguages [] False - - ,AD "DebugInformation" "Information" (Just "Display information about the selected name(s)") Nothing - debugInformation [] False - ,AD "DebugKind" "Kind" (Just "Show the kind of the selected type") Nothing - debugKind [] False - ,AD "DebugType" "Type" (Just "Show the type of the selected expression") Nothing - debugType [] False - - ,AD "Metadata" "_Metadata" Nothing Nothing (return ()) [] False - ,AD "UpdateMetadataCurrent" "_Update Project" (Just "Updates metadata for the current project") (Just "ide_rebuild_meta") - rebuildActiveInfo [] False - ,AD "UpdateMetadataLib" "_Update Lib" Nothing Nothing - rebuildLibInfo [] False - ,AD "ShowModules" "Show Modules" Nothing Nothing - showModules [] False - ,AD "ShowReferences" "Show References" Nothing Nothing - showReferences [] False - ,AD "ShowClasses" "Show Classes" Nothing Nothing - showClasses [] False - ,AD "ShowSearch" "Show Search" Nothing Nothing - showSearch [] False - ,AD "ShowInfo" "Show Info" Nothing Nothing - showInfo [] False - - ,AD "Session" "_Session" Nothing Nothing (return ()) [] False - ,AD "SaveSession" "_Save Session" Nothing Nothing - saveSessionAsPrompt [] False - ,AD "LoadSession" "_Load Session" Nothing Nothing - loadSessionPrompt [] False - ,AD "ForgetSession" "_Forget Session" Nothing Nothing - (return ()) [] True - - ,AD "View" "_View" Nothing Nothing (return ()) [] False - ,AD "ViewMoveLeft" "Move _Left" Nothing Nothing - (viewMove LeftP) [] False - ,AD "ViewMoveRight" "Move _Right" Nothing Nothing - (viewMove RightP) [] False - ,AD "ViewMoveUp" "Move _Up" Nothing Nothing - (viewMove TopP) [] False - ,AD "ViewMoveDown" "Move _Down" Nothing Nothing - (viewMove BottomP) [] False - ,AD "ViewSplitHorizontal" "Split H_orizontal" Nothing Nothing - viewSplitHorizontal [] False - ,AD "ViewSplitVertical" "Split _Vertical" Nothing Nothing - viewSplitVertical [] False - ,AD "ViewCollapse" "_Collapse" Nothing Nothing - viewCollapse [] False - ,AD "ViewNest" "_Group" Nothing Nothing - (viewNewGroup) [] False - ,AD "ViewDetach" "_Detach" Nothing Nothing - viewDetachInstrumented [] False - - ,AD "ViewTabsLeft" "Tabs Left" Nothing Nothing - (viewTabsPos PosLeft) [] False - ,AD "ViewTabsRight" "Tabs Right" Nothing Nothing - (viewTabsPos PosRight) [] False - ,AD "ViewTabsUp" "Tabs Up" Nothing Nothing - (viewTabsPos PosTop) [] False - ,AD "ViewTabsDown" "Tabs Down" Nothing Nothing - (viewTabsPos PosBottom) [] False - ,AD "ViewSwitchTabs" "Tabs On/Off" Nothing Nothing - viewSwitchTabs [] False - - ,AD "ViewClosePane" "Close pane" Nothing (Just "gtk-close") - sessionClosePane [] False - - ,AD "FlipDown" "Flip down" Nothing Nothing - flipDown [] False - ,AD "FlipUp" "Flip up" Nothing Nothing - flipUp [] False - ,AD "StartComplete" "StartComplete" Nothing Nothing - startComplete [] False - - ,AD "ViewHistoryBack" "Back" Nothing (Just "gtk-go-back") - historyBack [] False - ,AD "ViewHistoryForth" "Forward" Nothing (Just "gtk-go-forward") - historyForward [] False - - - ,AD "ClearLog" "_Clear Log" Nothing Nothing - clearLog [] False - ,AD "ToggleToolbar" "Toggle Toolbar" Nothing Nothing - toggleToolbar [] False - - ,AD "Configuration" "_Configuration" Nothing Nothing (return ()) [] False - ,AD "EditCandy" "_To Candy" Nothing Nothing - editCandy [] True - ,AD "PrefsEdit" "_Edit Prefs" Nothing Nothing - editPrefs [] False - - ,AD "Help" "_Help" Nothing Nothing (return ()) [] False - ,AD "HelpDebug" "Debug" Nothing Nothing (do - pack <- readIDE activePack - ideMessage Normal (show pack)) [] False --- ,AD "HelpDebug2" "Debug2" (Just "d") Nothing dbgInstalledPackageInfo [] False - ,AD "HelpManual" "Manual" Nothing Nothing (openBrowser "http://leksah.org/leksah_manual.pdf") [] False - ,AD "HelpHomepage" "Homepage" Nothing Nothing (openBrowser "http://leksah.org") [] False - ,AD "HelpAbout" "About" Nothing (Just "gtk-about") (liftIO aboutDialog) [] False - - ,AD "BackgroundBuildToggled" "_BackgroundBuild" (Just "Build in the background and report errors") (Just "ide_build") - backgroundBuildToggled [] True - ,AD "BackgroundLinkToggled" "_BackgroundLink" (Just "Link in the background") (Just "ide_link") - backgroundLinkToggled [] True - ,AD "DebugToggled" "_Debug" (Just "Use GHCi debugger to build and run") (Just "ide_debug") - debugToggled [] True] - --- --- | The menu description in XML Syntax as defined by GTK --- -menuDescription :: IO String -menuDescription = do - prefsPath <- getConfigFilePathForLoad "Default.menu" - res <- readFile prefsPath - return res - -updateRecentEntries :: IDEAction -updateRecentEntries = do - recentFiles' <- readIDE recentFiles - recentPackages' <- readIDE recentPackages - recentFilesItem <- getRecentFiles - recentPackagesItem <- getRecentPackages - reifyIDE (\ ideR -> do - recentFilesMenu <- menuNew - mapM_ (\s -> do - fe <- doesFileExist s - when fe $ do - mi <- menuItemNewWithLabel s - mi `onActivateLeaf` (reflectIDE (fileOpenThis s) ideR) - menuShellAppend recentFilesMenu mi) recentFiles' - oldSubmenu <- menuItemGetSubmenu recentFilesItem - when (isJust oldSubmenu) $ do - widgetHideAll (fromJust oldSubmenu) - widgetDestroy (fromJust oldSubmenu) - menuItemSetSubmenu recentFilesItem recentFilesMenu - widgetShowAll recentFilesMenu - recentPackagesMenu <- menuNew - mapM_ (\s -> do - fe <- doesFileExist s - when fe $ do - mi <- menuItemNewWithLabel s - mi `onActivateLeaf` (reflectIDE (packageOpenThis (Just s) >> return ()) ideR) - menuShellAppend recentPackagesMenu mi) recentPackages' - oldSubmenu <- menuItemGetSubmenu recentPackagesItem - when (isJust oldSubmenu) $ do - widgetHideAll (fromJust oldSubmenu) - widgetDestroy (fromJust oldSubmenu) - menuItemSetSubmenu recentPackagesItem recentPackagesMenu - widgetShowAll recentPackagesMenu) - - --- --- | Building the Menu --- -makeMenu :: UIManager -> [ActionDescr IDERef] -> String -> IDEAction -makeMenu uiManager actions menuDescription = reifyIDE (\ideR -> do - actionGroupGlobal <- actionGroupNew "global" - mapM_ (actm ideR actionGroupGlobal) actions - uiManagerInsertActionGroup uiManager actionGroupGlobal 1 - uiManagerAddUiFromString uiManager menuDescription - return ()) - where - actm ideR ag (AD name label tooltip stockId ideAction accs isToggle) = do - let (acc,accString) = if null accs - then (Just "","=" ++ name) - else (Just (head accs),(head accs) ++ "=" ++ name) - if isToggle - then do - act <- toggleActionNew name label tooltip stockId - on act actionToggled (doAction ideAction ideR accString) - actionGroupAddActionWithAccel ag act acc - else do - act <- actionNew name label tooltip stockId - onActionActivate act (doAction ideAction ideR accString) - actionGroupAddActionWithAccel ag act acc - doAction ideAction ideR accStr = - handleTopExceptions (reflectIDE (do - ideAction - sb <- getSBSpecialKeys - liftIO $statusbarPop sb 1 - liftIO $statusbarPush sb 1 $accStr - return ()) ideR) - -getMenuAndToolbars :: UIManager -> IO (AccelGroup, MenuBar, Toolbar) -getMenuAndToolbars uiManager = do - accGroup <- uiManagerGetAccelGroup uiManager - mbMenu <- uiManagerGetWidget uiManager "/ui/menubar" - let menu = case mbMenu of - Just it -> castToMenuBar it - Nothing -> throwIDE "Menu>>makeMenu: failed to create menubar" - mbToolbar <- uiManagerGetWidget uiManager "/ui/toolbar" - let toolbar = case mbToolbar of - Just it -> castToToolbar it - Nothing -> throwIDE "Menu>>makeMenu: failed to create toolbar" - toolbarSetIconSize toolbar IconSizeSmallToolbar - toolbarSetStyle toolbar ToolbarIcons - widgetSetSizeRequest toolbar 700 (-1) - return (accGroup,menu,toolbar) - -textPopupMenu :: IDERef -> Menu -> IO () -textPopupMenu ideR menu = do - items <- containerGetChildren menu - mi1 <- menuItemNewWithLabel "Eval" - mi1 `onActivateLeaf` (reflectIDE debugExecuteSelection ideR) - menuShellAppend menu mi1 - mi11 <- menuItemNewWithLabel "Eval & Insert" - mi11 `onActivateLeaf` (reflectIDE debugExecuteAndShowSelection ideR) - menuShellAppend menu mi11 - mi12 <- menuItemNewWithLabel "Step" - mi12 `onActivateLeaf` (reflectIDE debugStepExpression ideR) - menuShellAppend menu mi12 - mi13 <- menuItemNewWithLabel "Trace" - mi13 `onActivateLeaf` (reflectIDE debugTraceExpression ideR) - menuShellAppend menu mi13 - mi16 <- menuItemNewWithLabel "Set Breakpoint" - mi16 `onActivateLeaf` (reflectIDE debugSetBreakpoint ideR) - menuShellAppend menu mi16 - sep1 <- separatorMenuItemNew - menuShellAppend menu sep1 - mi14 <- menuItemNewWithLabel "Type" - mi14 `onActivateLeaf` (reflectIDE debugType ideR) - menuShellAppend menu mi14 - mi141 <- menuItemNewWithLabel "Info" - mi141 `onActivateLeaf` (reflectIDE debugInformation ideR) - menuShellAppend menu mi141 - mi15 <- menuItemNewWithLabel "Kind" - mi15 `onActivateLeaf` (reflectIDE debugKind ideR) - menuShellAppend menu mi15 - sep2 <- separatorMenuItemNew - menuShellAppend menu sep2 - mi2 <- menuItemNewWithLabel "Find (text)" - mi2 `onActivateLeaf` (reflectIDE (editFindInc Initial) ideR) - 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) - menuShellAppend menu mi3 - let interpretingEntries = [castToWidget mi16] - let interpretingSelEntries = [castToWidget mi1, castToWidget mi11, castToWidget mi12, - castToWidget mi13, castToWidget mi14, castToWidget mi141, - castToWidget mi15] - let otherEntries = [castToWidget mi2, castToWidget mi3] - isInterpreting' <- (reflectIDE isInterpreting ideR) - selected <- (reflectIDE selectedText ideR) - unless isInterpreting' - $ mapM_ (\w -> widgetSetSensitive w False) (interpretingEntries ++ interpretingSelEntries) - unless (isJust selected) - $ mapM_ (\w -> widgetSetSensitive w False) (otherEntries ++ interpretingSelEntries) - mapM_ widgetShow interpretingEntries - mapM_ widgetShow interpretingSelEntries - mapM_ widgetShow (castToWidget sep1 : castToWidget sep2 : otherEntries) - mapM_ widgetHide $ take 2 (reverse items) - --- | Quit ide -quit :: IDEAction -quit = do - modifyIDE_ (\ide -> ide{currentState = IsShuttingDown}) - saveSession :: IDEAction - b <- fileCloseAll (\_ -> return True) - if b - then liftIO mainQuit - else modifyIDE_ (\ide -> ide{currentState = IsRunning}) - --- --- | Show the about dialog --- -aboutDialog :: IO () -aboutDialog = do - d <- aboutDialogNew - aboutDialogSetName d "Leksah" - aboutDialogSetVersion d (showVersion version) - aboutDialogSetCopyright d "Copyright 2007-2009 Jürgen Nicklisch-Franken, Hamish Mackenzie" - aboutDialogSetComments d $ "An integrated development environement (IDE) for the " ++ - "programming language Haskell and the Glasgow Haskell Compiler" - dd <- getDataDir - license <- catch (readFile $ dd "LICENSE") (\ (_ :: SomeException) -> return "") - aboutDialogSetLicense d $ Just license - aboutDialogSetWebsite d "http://leksah.org/" - aboutDialogSetAuthors d ["Jürgen Nicklisch-Franken","Hamish Mackenzie"] - dialogRun d - widgetDestroy d - return () - -buildStatusbar ideR = do - sb <- statusbarNew - statusbarSetHasResizeGrip sb False - - sblk <- statusbarNew - widgetSetName sblk "statusBarSpecialKeys" - statusbarSetHasResizeGrip sblk False - widgetSetSizeRequest sblk 150 (-1) - - sbap <- statusbarNew - widgetSetName sbap "statusBarActivePane" - statusbarSetHasResizeGrip sbap False - widgetSetSizeRequest sbap 150 (-1) - - sbapr <- statusbarNew - widgetSetName sbapr "statusBarActiveProject" - statusbarSetHasResizeGrip sbapr False - widgetSetSizeRequest sbapr 150 (-1) - - sbe <- statusbarNew - widgetSetName sbe "statusBarErrors" - statusbarSetHasResizeGrip sbe False - widgetSetSizeRequest sbe 150 (-1) - - sblc <- statusbarNew - widgetSetName sblc "statusBarLineColumn" - statusbarSetHasResizeGrip sblc True - widgetSetSizeRequest sblc 150 (-1) - - sbio <- statusbarNew - widgetSetName sbio "statusBarInsertOverwrite" - statusbarSetHasResizeGrip sbio False - widgetSetSizeRequest sbio 60 (-1) - - dummy <- hBoxNew False 1 - widgetSetName dummy "dummyBox" - - - hb <- hBoxNew False 1 - widgetSetName hb "statusBox" - boxPackStart hb sblk PackGrow 0 - boxPackStart hb sbap PackGrow 0 - boxPackStart hb sbapr PackGrow 0 - --boxPackStart hb dummy PackGrow 0 - boxPackEnd hb sblc PackNatural 0 - boxPackEnd hb sbio PackNatural 0 - boxPackEnd hb sbe PackNatural 0 - - return hb - -newIcons :: IO () -newIcons = - catch (do - iconFactory <- iconFactoryNew - dataDir <- getDataDir - mapM_ (loadIcon dataDir iconFactory) ["ide_class","ide_configure","ide_data","ide_error_next", - "ide_error_prev","ide_function","ide_instance", "ide_konstructor","ide_make", - "ide_method","ide_newtype","ide_other","ide_rule","ide_run","ide_slot", - "ide_source","ide_type","leksah", "ide_reexported", "ide_clean", "ide_link", "ide_build", - "ide_debug", "ide_step", "ide_local", "ide_module", "ide_continue", "ide_rebuild_meta"] - iconFactoryAddDefault iconFactory) - (\(e :: SomeException) -> getDataDir >>= \dataDir -> throwIDE ("Can't load icons from " ++ dataDir)) - where - loadIcon dataDir iconFactory name = do - pb <- pixbufNewFromFile $ dataDir "data" (name ++ ".png") - icon <- iconSetNewFromPixbuf pb - iconFactoryAdd iconFactory name icon - -setSensitivity :: [(SensitivityMask, Bool)] -> IDEAction -setSensitivity l = mapM_ setSensitivitySingle l - where setSensitivitySingle (sens,bool) = do - actions <- getActionsFor sens - liftIO $ mapM_ (\a -> actionSetSensitive a bool) actions - let additionalActions = getAdditionalActionsFor sens - mapM_ (\a -> a bool) additionalActions - -getActionsFor :: SensitivityMask -> IDEM [Action] -getActionsFor SensitivityForwardHist = getActionsFor' ["ViewHistoryForth"] -getActionsFor SensitivityBackwardHist = getActionsFor' ["ViewHistoryBack"] -getActionsFor SensitivityProjectActive = getActionsFor' - ["EditPackage", "ClosePackage", "PackageFlags", "ConfigPackage", "BuildPackage" - ,"DocPackage", "CleanPackage", "CopyPackage", "RunPackage","InstallPackage" - ,"RegisterPackage", "UnregisterPackage","TestPackage","SdistPackage" - ,"OpenDocPackage","FileCloseAll"] -getActionsFor SensitivityError = getActionsFor' ["NextError", "PreviousError"] -getActionsFor SensitivityEditor = getActionsFor' ["EditUndo", "EditRedo", "EditGotoLine" - ,"EditComment", "EditUncomment", "EditShiftLeft", "EditShiftRight"] -getActionsFor SensitivityInterpreting = getActionsFor' ["QuitDebugger" , "ExecuteSelection", - "DebugSetBreakpoint", "ShowNextBreakpoint", "ShowPreviousBreakpoint", "DebugDeleteAllBreakpoints", - "DebugContinue", "DebugAbandon", "DebugStop", "DebugStep", "DebugStepExpression", "DebugStepLocal", - "DebugStepModule", "DebugTrace", "DebugTraceExpression", "DebugHistory", "DebugBack", "DebugForward", - "DebugForce", "DebugPrint", "DebugSimplePrint", "ShowBindings", "ShowBreakpoints", "ShowContext", - "ShowLoadedModules", "ShowPackages", "ShowLanguages", "DebugInformation", "DebugKind", "DebugType"] - -getActionsFor' :: [String] -> IDEM[Action] -getActionsFor' l = do - r <- mapM getActionFor l - return (catMaybes r) - where - getActionFor string = do - uiManager' <- getUiManager - actionGroups <- liftIO $ uiManagerGetActionGroups uiManager' - res <- liftIO $ actionGroupGetAction (head actionGroups) string - when (isNothing res) $ ideMessage Normal $ "Can't find UI Action " ++ string - return res - -getAdditionalActionsFor :: SensitivityMask -> [Bool -> IDEAction] -getAdditionalActionsFor SensitivityInterpreting = [setSensitivityDebugger] -getAdditionalActionsFor _ = [] - -viewDetachInstrumented :: IDEAction -viewDetachInstrumented = do - mbPair <- viewDetach - case mbPair of - Nothing -> return () - Just (win,wid) -> do - instrumentSecWindow win - liftIO $ widgetShowAll win - -instrumentWindow :: Window -> Prefs -> Widget -> IDEAction -instrumentWindow win prefs topWidget = do - -- sets the icon - ideR <- ask - uiManager' <- getUiManager - liftIO $ do - dataDir <- getDataDir - let iconPath = dataDir "data" "leksah.png" - iconExists <- doesFileExist iconPath - when iconExists $ - windowSetIconFromFile win iconPath - vb <- vBoxNew False 1 -- Top-level vbox - widgetSetName vb "topBox" - (acc,menu,toolbar) <- getMenuAndToolbars uiManager' - boxPackStart vb menu PackNatural 0 - boxPackStart vb toolbar PackNatural 0 - boxPackStart vb topWidget PackGrow 0 - findbar <- reflectIDE (do - modifyIDE_ (\ide -> ide{toolbar = (True,Just toolbar)}) - constructFindReplace ) ideR - boxPackStart vb findbar PackNatural 0 - statusBar <- buildStatusbar ideR - boxPackEnd vb statusBar PackNatural 0 - win `onKeyPress` (\ e -> reflectIDE (handleSpecialKeystrokes e) ideR) - windowAddAccelGroup win acc - containerAdd win vb - reflectIDE (do - setCandyState (isJust (sourceCandy prefs)) - setBackgroundBuildToggled (backgroundBuild prefs) - setBackgroundLinkToggled (backgroundLink prefs)) ideR - -instrumentSecWindow :: Window -> IDEAction -instrumentSecWindow win = do - ideR <- ask - uiManager' <- getUiManager - liftIO $ do - dataDir <- getDataDir - let iconPath = dataDir "data" "leksah.png" - iconExists <- doesFileExist iconPath - when iconExists $ - windowSetIconFromFile win iconPath - - (acc,_,_) <- getMenuAndToolbars uiManager' - windowAddAccelGroup win acc - win `onKeyPress` (\ e -> reflectIDE (handleSpecialKeystrokes e) ideR) - return () - --- --- | Callback function for onKeyPress of the main window, so 'preprocess' any key --- -handleSpecialKeystrokes :: GdkEvents.Event -> IDEM Bool -handleSpecialKeystrokes (Key { eventKeyName = name, eventModifier = mods, - eventKeyVal = keyVal, eventKeyChar = mbChar}) = do - sb <- getSBSpecialKeys - prefs' <- readIDE prefs - case (name, mods) of - (tab, [Control]) | (tab == "Tab" || tab == "ISO_Left_Tab") - && useCtrlTabFlipping prefs' -> do - flipDown - return True - (tab, [Shift, Control]) | (tab == "Tab" || tab == "ISO_Left_Tab") - && useCtrlTabFlipping prefs' -> do - flipUp - return True - _ -> do - bs <- getCandyState - when bs (editKeystrokeCandy mbChar) - sk <- readIDE specialKey - sks <- readIDE specialKeys - return True - case sk of - Nothing -> - case Map.lookup (keyVal,sort mods) sks of - Nothing -> do - liftIO $statusbarPop sb 1 - liftIO $statusbarPush sb 1 "" - return False - Just map -> do - let sym = printMods mods ++ name - liftIO $statusbarPop sb 1 - liftIO $statusbarPush sb 1 sym - modifyIDE_ (\ide -> ide{specialKey = Just (map,sym)}) - return True - Just (map,sym) -> do - case Map.lookup (keyVal,sort mods) map of - Nothing -> do - liftIO $statusbarPop sb 1 - liftIO $statusbarPush sb 1 $ sym ++ printMods mods ++ name ++ "?" - return () - Just (AD actname _ _ _ ideAction _ _) -> do - liftIO $statusbarPop sb 1 - liftIO $statusbarPush sb 1 - $ sym ++ " " ++ printMods mods ++ name ++ "=" ++ actname - ideAction - modifyIDE_ (\ide -> ide{specialKey = Nothing}) - return True - where - printMods :: [Modifier] -> String - printMods [] = "" - printMods (m:r) = show m ++ printMods r -handleSpecialKeystrokes _ = return True - --- --- | Register handlers for IDE events --- -registerEvents :: IDEAction -registerEvents = do - stRef <- ask - registerEvent stRef "LogMessage" - (Left (\e@(LogMessage s t) -> getLog >>= \(log :: IDELog) -> liftIO $ appendLog log s t - >> return e)) - registerEvent stRef "SelectInfo" - (Left (\ e@(SelectInfo str) -> setSymbol str >> return e)) - registerEvent stRef "SelectIdent" - (Left (\ e@(SelectIdent id) -> selectIdentifier id >> return e)) - registerEvent stRef "CurrentInfo" - (Left (\ CurrentInfo -> reloadKeepSelection >> return CurrentInfo)) - registerEvent stRef "ActivePack" - (Left (\ ActivePack -> (infoForActivePackage :: IDEAction) >> return ActivePack)) - registerEvent stRef "RecordHistory" - (Left (\ rh@(RecordHistory h) -> recordHistory h >> return rh)) - registerEvent stRef "Sensitivity" - (Left (\ s@(Sensitivity h) -> setSensitivity h >> return s)) - registerEvent stRef "DescrChoice" - (Left (\ e@(DescrChoice descrs) -> setChoices descrs >> return e)) - registerEvent stRef "SearchMeta" - (Left (\ e@(SearchMeta string) -> searchMetaGUI string >> return e)) - registerEvent stRef "LoadSession" - (Left (\ e@(LoadSession fp) -> loadSession fp >> return e)) - registerEvent stRef "SaveSession" - (Left (\ e@(SaveSession fp) -> saveSessionAs fp >> return e)) - registerEvent stRef "UpdateRecent" - (Left (\ e@UpdateRecent -> updateRecentEntries >> return e)) - registerEvent stRef "VariablesChanged" - (Left (\ e@VariablesChanged -> fillVariablesList >> return e)) - registerEvent stRef "ErrorChanged" - (Left (\ e@ErrorChanged -> postAsyncIDE fillErrorList >> return e)) - registerEvent stRef "CurrentErrorChanged" - (Left (\ e@(CurrentErrorChanged mbLogRef) -> postAsyncIDE (do - selectRef mbLogRef - selectError mbLogRef) >> return e)) - registerEvent stRef "BreakpointChanged" - (Left (\ e@BreakpointChanged -> postAsyncIDE fillBreakpointList >> return e)) - registerEvent stRef "CurrentBreakChanged" - (Left (\ e@(CurrentBreakChanged mbLogRef) -> postAsyncIDE (do - selectRef mbLogRef - selectBreak mbLogRef) >> return e)) - registerEvent stRef "TraceChanged" - (Left (\ e@TraceChanged -> fillTraceList >> return e)) - registerEvent stRef "GetTextPopup" - (Left (\ e@(GetTextPopup _) -> return (GetTextPopup (Just textPopupMenu)))) - return () - - diff --git a/src/IDE/Metainfo/GHCUtils.hs b/src/IDE/Metainfo/GHCUtils.hs deleted file mode 100644 --- a/src/IDE/Metainfo/GHCUtils.hs +++ /dev/null @@ -1,182 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : IDE.Metainfo.GHCUtils --- Copyright : 2007-2009 Jürgen Nicklisch-Franken --- License : GPL --- --- Maintainer : Jutaro --- Stability : provisional --- Portability : --- --- | --- ------------------------------------------------------------------------------ -module IDE.Metainfo.GHCUtils ( - - inGhc -, inGhcIO -, getInstalledPackageInfos -, findFittingPackages -, myParseModule -, parseHeader - -) where - -import IDE.Core.State (MessageLevel(..),sysMessage,IDEM(..),readIDE,IDE(..),IDEPackage(..)) -import UniqFM (eltsUFM) -import Distribution.Simple (withinRange,PackageIdentifier(..),Dependency(..)) -import qualified Distribution.InstalledPackageInfo as IPI (package) -import GHC -import StringBuffer (StringBuffer(..),hGetStringBuffer) -import FastString (mkFastString) -import Lexer (mkPState,ParseResult(..),getMessages,unP) -import Outputable (ppr) -import Bag (unitBag) -import IDE.FileUtils (getSysLibDir) -import ErrUtils (dumpIfSet_dyn,printErrorsAndWarnings,mkPlainErrMsg,showPass,ErrMsg(..),printBagOfErrors) -import PackageConfig (PackageConfig(..)) -import Data.Foldable (maximumBy) -import DynFlags (defaultDynFlags) -import qualified Parser as P (parseModule,parseHeader) -import HscStats (ppSourceStats) -import Control.Monad.Trans -import DriverPipeline (preprocess) -import System.FilePath (takeDirectory) - - -inGhc :: Ghc a -> IDEM a -inGhc = liftIO . inGhcIO - -inGhcIO :: Ghc a -> IO a -inGhcIO f = do - libDir <- getSysLibDir - runGhc (Just libDir) $ do - getSessionDynFlags >>= setSessionDynFlags - f - -getInstalledPackageInfos :: Ghc [PackageConfig] -getInstalledPackageInfos = do - dflags1 <- getSessionDynFlags - setSessionDynFlags dflags1{flags = Opt_ReadUserPackageConf : (flags dflags1)} - pkgInfos <- case pkgDatabase dflags1 of - Nothing -> return [] - Just fm -> return (eltsUFM fm) - return pkgInfos - -findFittingPackages :: [Dependency] -> Ghc [PackageIdentifier] -findFittingPackages dependencyList = do - knownPackages <- getInstalledPackageInfos - let packages = map IPI.package knownPackages - return (concatMap (fittingKnown packages) dependencyList) - where - fittingKnown packages (Dependency dname versionRange) = - let filtered = filter (\ (PackageIdentifier name version) -> - name == dname && withinRange version versionRange) - packages - in if length filtered > 1 - then [maximumBy (\a b -> compare (pkgVersion a) (pkgVersion b)) filtered] - else filtered - -parseHeader :: FilePath -> String -> IDEM (Maybe (HsModule RdrName)) -parseHeader fp str = do - activePack' <- readIDE activePack - case activePack' of - Nothing -> return Nothing - Just pack -> inGhc $ do - dflags <- getSessionDynFlags - let dflags2 = dflags { - topDir = takeDirectory (cabalFile pack), - hscTarget = HscNothing, - ghcMode = OneShot, - ghcLink = NoLink} - setSessionDynFlags dflags2 - session <- getSession - dynFlags <- getSessionDynFlags - (_,fp) <- preprocess session (fp,Nothing) - dynFlags <- getSessionDynFlags - liftIO $ do - stringBuffer <- hGetStringBuffer fp - parseResult <- myParseModuleHeader dynFlags fp (Just stringBuffer) - case parseResult of - Right (L _ mod) -> return (Just mod) - Left errMsg -> do - sysMessage Normal $ "Failed to parse " ++ fp - printBagOfErrors defaultDynFlags (unitBag errMsg) - return (Nothing) - - --------------------------------------------------------------------- --- | Parser function copied here, because it is not exported - -myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer - -> IO (Either ErrMsg (Located (HsModule RdrName))) -myParseModule dflags src_filename maybe_src_buf - = -------------------------- Parser ---------------- - showPass dflags "Parser" >> - {-# SCC "Parser" #-} do - - -- sometimes we already have the buffer in memory, perhaps - -- because we needed to parse the imports out of it, or get the - -- module name. - buf <- case maybe_src_buf of - Just b -> return b - Nothing -> hGetStringBuffer src_filename - - let loc = mkSrcLoc (mkFastString src_filename) 1 0 - - case unP P.parseModule (mkPState buf loc dflags) of { - - PFailed span err -> return (Left (mkPlainErrMsg span err)); - - POk pst rdr_module -> do { - - let {ms = getMessages pst}; - printErrorsAndWarnings dflags ms; - -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1); - - dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; - - dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" - (ppSourceStats False rdr_module) ; - - return (Right rdr_module) - -- ToDo: free the string buffer later. - }} - - --------------------------------------------------------------------- --- | Parser function copied here, because it is not exported - -myParseModuleHeader :: DynFlags -> FilePath -> Maybe StringBuffer - -> IO (Either ErrMsg (Located (HsModule RdrName))) -myParseModuleHeader dflags src_filename maybe_src_buf - = -------------------------- Parser ---------------- - showPass dflags "Parser" >> - {-# SCC "Parser" #-} do - - -- sometimes we already have the buffer in memory, perhaps - -- because we needed to parse the imports out of it, or get the - -- module name. - buf <- case maybe_src_buf of - Just b -> return b - Nothing -> hGetStringBuffer src_filename - - let loc = mkSrcLoc (mkFastString src_filename) 1 0 - - case unP P.parseHeader (mkPState buf loc dflags) of { - - PFailed span err -> return (Left (mkPlainErrMsg span err)); - - POk pst rdr_module -> do { - - let {ms = getMessages pst}; - printErrorsAndWarnings dflags ms; - -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1); - - dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; - - dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" - (ppSourceStats False rdr_module) ; - - return (Right rdr_module) - -- ToDo: free the string buffer later. - }} - diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs deleted file mode 100644 --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ /dev/null @@ -1,443 +0,0 @@ -{-# OPTIONS_GHC -XScopedTypeVariables -XFlexibleContexts#-} ------------------------------------------------------------------------------ --- --- Module : IDE.Metainfo.InterfaceCollector --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | This modulle extracts information from .hi files for installed packages --- -------------------------------------------------------------------------------- - -module IDE.Metainfo.InterfaceCollector ( - collectInstalled -, collectInstalled' -, collectUninstalled -, metadataVersion - -) where - - -import GHC hiding(Id,Failed,Succeeded,ModuleName) -import Module hiding (PackageId,ModuleName) -import IDE.Metainfo.GHCUtils (findFittingPackages,getInstalledPackageInfos) -import MyMissing (nonEmptyLines) -import qualified Module -import TcRnMonad hiding (liftIO,MonadIO) -import qualified Maybes as M -import HscTypes hiding (liftIO) -import LoadIface -import Outputable hiding(trace) -import IfaceSyn -import FastString -import Outputable hiding(trace) -import qualified PackageConfig as DP -import Name -import PrelNames -import PackageConfig(unpackPackageId,mkPackageId) -import Maybes -import TcRnTypes -import Finder -import qualified FastString as FS -import ErrUtils -import Config(cProjectVersion) -import Distribution.PackageDescription.Parse(readPackageDescription) -import Distribution.PackageDescription.Configuration(flattenPackageDescription) -import qualified IOEnv as IOEnv (liftIO,MonadIO) -import IOEnv hiding (liftIO,MonadIO) - -import Debug.Trace - -import Data.Char (isSpace) -import qualified Data.Map as Map -import Data.Maybe -import qualified Data.Set as Set -import Data.Set (Set) -import System.Directory -import Distribution.PackageDescription -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Package hiding (PackageId) -import Distribution.Verbosity -import Distribution.ModuleName -import Distribution.Text (simpleParse,display) -import Control.Monad.Reader -import System.IO -import Data.Maybe -import System.FilePath -import System.Directory -import Data.List(zip4,nub) -import qualified Data.ByteString.Char8 as BS - -import Default -import IDE.Core.State hiding (depends) -import IDE.FileUtils ---import IDE.Metainfo.Provider -import IDE.Metainfo.SourceCollector -import IDE.Metainfo.GHCUtils(inGhc) -import IDE.Metainfo.Serializable () -import Data.Binary.Shared - -metadataVersion :: Integer -metadataVersion = 5 - -data CollectStatistics = CollectStatistics { - packagesTotal :: Int -, packagesWithSource :: Int -, modulesTotal :: Int -, modulesWithSource :: Int -, parseFailures :: Int -} deriving Show - -instance Default CollectStatistics where - getDefault = CollectStatistics getDefault getDefault getDefault getDefault - getDefault - -collectInstalled :: Prefs -> Bool -> IDEAction -collectInstalled prefs b = inGhc $ collectInstalled' prefs False cProjectVersion b - -collectInstalled' :: Prefs -> Bool -> String -> Bool -> Ghc() -collectInstalled' prefs writeAscii version forceRebuild = do - session <- getSession - collectorPath <- liftIO $ getCollectorPath version - when forceRebuild $ liftIO $ do - removeDirectoryRecursive collectorPath - getCollectorPath version - return () - knownPackages <- liftIO $ findKnownPackages collectorPath - packageInfos <- getInstalledPackageInfos - let newPackages = filter (\pi -> not $Set.member (fromPackageIdentifier $ IPI.package pi) - knownPackages) - packageInfos - if null newPackages then do - sysMessage Normal "Metadata collector has nothing to do" - else do - liftIO $ buildSourceForPackageDB prefs - sources <- liftIO $ getSourcesMap prefs - exportedIfaceInfos <- mapM (\ info -> getIFaceInfos (mkPackageId $ IPI.package info) - (IPI.exposedModules info) session) newPackages - hiddenIfaceInfos <- mapM (\ info -> getIFaceInfos (mkPackageId $ IPI.package info) - (IPI.hiddenModules info) session) newPackages - let extracted = map extractInfo $ zip4 exportedIfaceInfos - hiddenIfaceInfos - (map IPI.package newPackages) - (map depends newPackages) - (packagesWithSource', modulesTotal', modulesWithSource', parseFailures') - <- foldM (\ (pws,mt,ms,failed) pdescr -> do - (pdescr, num) <- collectSources sources pdescr - writeExtracted collectorPath writeAscii False pdescr - let pws' = pws + if isJust (mbSourcePathPD pdescr) - then 1 - else 0 - let mt' = mt + (length . exposedModulesPD) pdescr - let ms' = ms + if isJust (mbSourcePathPD pdescr) - then (length . exposedModulesPD) pdescr - else 0 - return (pws',mt',ms',failed + num)) - (0,0,0,0) extracted - let statistic = CollectStatistics { - packagesTotal = length extracted - , packagesWithSource = packagesWithSource' - , modulesTotal = modulesTotal' - , modulesWithSource = modulesWithSource' - , parseFailures = parseFailures'} - liftIO $ sysMessage Normal $ show statistic - when (modulesWithSource statistic > 0) $ - sysMessage Normal $ "failure percentage " - ++ show ((round (((fromIntegral (parseFailures statistic)) :: Double) / - (fromIntegral (modulesTotal statistic)) * 100.0)):: Integer) - -collectUninstalled :: Bool -> String -> FilePath -> Ghc () -collectUninstalled writeAscii version cabalPath = do - trace ("collect Uninstalled " ++ show cabalPath) return () - cCabalPath <- liftIO $ canonicalizePath cabalPath - pd <- liftIO $ readPackageDescription normal cCabalPath - >>= return . flattenPackageDescription - let packageName = if hasExes pd - then "main" - else show $ package pd - let modules = nub $ exeModules pd ++ libModules pd - let basePath = takeDirectory cCabalPath - let buildPath = if hasExes pd - then let exeName' = exeName (head (executables pd)) - in "dist" "build" exeName' - exeName' ++ "-tmp" "" - else "dist" "build" "" - dflags0 <- getSessionDynFlags - setSessionDynFlags - dflags0 - { topDir = basePath - , importPaths = [buildPath,"dist" "build" "autogen"] - , thisPackage = if hasExes pd then mainPackageId else mkPackageId (package pd) - , ghcMode = OneShot - } - dflags1 <- getSessionDynFlags - (dflags2,_,_) <- parseDynamicFlags dflags1 [(noLoc "-fglasgow-exts")] - setSessionDynFlags dflags2 - let ghcmodules = map (mkModuleName . display) modules - allIfaceInfos <- getIFaceInfos2 ghcmodules packageName - deps <- findFittingPackages (buildDepends pd) - let extracted = extractInfo (allIfaceInfos, [], package pd, deps) - let sources = Map.fromList [(package pd,[cCabalPath])] - (extractedWithSources,_) <- collectSources sources extracted - collectorPath <- getCollectorPath version - writeExtracted collectorPath writeAscii True extractedWithSources - sysMessage Normal $ "\nExtracted infos for " ++ cCabalPath ++ - " size: " ++ (show . length) (exposedModulesPD extractedWithSources) - -------------------------------------------------------------------------- - -getIFaceInfos :: PackageId -> [Module.ModuleName] -> HscEnv -> Ghc [(ModIface, FilePath)] -getIFaceInfos pckg modules session = - case unpackPackageId pckg of - Nothing -> return [] - Just pid -> do - let isBase = pkgName pid == (PackageName "base") - let ifaces = mapM (\ mn -> findAndReadIface empty - (if isBase - then mkBaseModule_ mn - else mkModule pckg mn) - False) modules - hscEnv <- getSession - let gblEnv = IfGblEnv { if_rec_types = Nothing } - maybes <- liftIO $ initTcRnIf 'i' hscEnv gblEnv () ifaces - let res = catMaybes (map handleErr maybes) - return res - where - handleErr (M.Succeeded val) = Just val - handleErr (M.Failed mess) = Nothing - -getIFaceInfos2 :: [Module.ModuleName] -> String -> Ghc [(ModIface, FilePath)] -getIFaceInfos2 modules packageName = do - session <- getSession - let ifaces = mapM (\ mn -> findAndReadIface2 session mn - (mkModule (stringToPackageId packageName) mn)) modules - let gblEnv = IfGblEnv { if_rec_types = Nothing } - maybes <- liftIO $ initTcRnIf 'i' session gblEnv () ifaces - let res = catMaybes (map handleErr maybes) - return res - where - handleErr (M.Succeeded val) = Just val - handleErr (M.Failed mess) = trace ("failed !!!" ++ showSDoc mess) Nothing - -findAndReadIface2 :: HscEnv -> Module.ModuleName -> Module -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath)) -findAndReadIface2 session doc mod = do - mb_found <- IOEnv.liftIO $ findHomeModule session doc - case mb_found of - Found loc mod -> do - let file_path = ml_hi_file loc - filePath <- IOEnv.liftIO $ canonicalizePath file_path - read_result <- readIface mod filePath False - case read_result of - Failed mess -> return (Failed (text $ "can't read iface " ++ - moduleNameString doc ++ " at " ++ filePath ++ " " ++ showSDoc mess)) - Succeeded iface - | mi_module iface /= mod - -> return (Failed (text $ "read but not equal" ++ moduleNameString doc)) - | otherwise - -> return (Succeeded (iface, filePath)) - _ -> return (Failed (text $ "can't locate " ++ moduleNameString doc)) - - -------------------------------------------------------------------------- - -extractInfo :: ([(ModIface, FilePath)],[(ModIface, FilePath)],PackageIdentifier, - [PackageIdentifier]) -> PackageDescr -extractInfo (ifacesExp,ifacesHid,pi,depends) = - let allDescrs = concatMap (extractExportedDescrH pi) - (map fst (ifacesHid ++ ifacesExp)) - mods = map (extractExportedDescrR pi allDescrs) (map fst ifacesExp) - in PackageDescr { - packagePD = pi - , exposedModulesPD = mods - , buildDependsPD = depends - , mbSourcePathPD = Nothing} - -extractExportedDescrH :: PackageIdentifier -> ModIface -> [Descr] -extractExportedDescrH pid iface = - let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) - exportedNames = Set.fromList - $ map occNameString - $ concatMap availNames - $ concatMap snd (mi_exports iface) - exportedDecls = filter (\ ifdecl -> (occNameString $ ifName ifdecl) - `Set.member` exportedNames) - (map snd (mi_decls iface)) - in concatMap (extractIdentifierDescr pid [mid]) exportedDecls - -extractExportedDescrR :: PackageIdentifier - -> [Descr] - -> ModIface - -> ModuleDescr -extractExportedDescrR pid hidden iface = - let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) - exportedNames = Set.fromList - $map occNameString - $concatMap availNames - $concatMap snd (mi_exports iface) - exportedDecls = filter (\ ifdecl -> (occNameString $ifName ifdecl) - `Set.member` exportedNames) - (map snd (mi_decls iface)) - ownDecls = concatMap (extractIdentifierDescr pid [mid]) exportedDecls - otherDecls = exportedNames `Set.difference` (Set.fromList (map descrName ownDecls)) - reexported = map (\d -> Reexported (PM pid mid) d) - $ filter (\k -> (descrName k) `Set.member` otherDecls) hidden - inst = concatMap (extractInstances (PM pid mid)) (mi_insts iface) - uses = Map.fromList $ map extractUsages (mi_usages iface) - in ModuleDescr { - moduleIdMD = PM pid mid - , exportedNamesMD = exportedNames - , mbSourcePathMD = Nothing - , referencesMD = uses - , idDescriptionsMD = ownDecls ++ inst ++ reexported} - -extractIdentifierDescr :: PackageIdentifier -> [ModuleName] -> IfaceDecl - -> [Descr] -extractIdentifierDescr package modules decl - = if null modules - then [] - else - let descr = Descr{ - descrName' = unpackFS $occNameFS (ifName decl) - , typeInfo' = BS.pack $ unlines $ nonEmptyLines $ filterExtras $ showSDocUnqual $ppr decl - , descrModu' = PM package (last modules) - , mbLocation' = Nothing - , mbComment' = Nothing - , details' = VariableDescr - } - in case decl of - (IfaceId _ _ _ ) - -> [descr] - (IfaceData name _ _ ifCons _ _ _ _) - -> let d = case ifCons of - IfDataTyCon decls - -> let - fieldNames = concatMap extractFields (visibleIfConDecls ifCons) - constructors' = extractConstructors name (visibleIfConDecls ifCons) - in DataDescr{ - fields = fieldNames, - constructors = constructors'} - IfNewTyCon _ - -> let - fieldNames = concatMap extractFields (visibleIfConDecls ifCons) - constructors' = extractConstructors name (visibleIfConDecls ifCons) - mbField = case fieldNames of - [] -> Nothing - [fn] -> Just fn - _ -> error $ "InterfaceCollector >> extractIdentifierDescr: " - ++ "Newtype with more then one field" - constructor = case constructors' of - [c] -> c - _ -> error $ "InterfaceCollector >> extractIdentifierDescr: " - ++ "Newtype with not exactly one constructor" - in NewtypeDescr constructor mbField - IfAbstractTyCon -> DataDescr [] [] - IfOpenDataTyCon -> DataDescr [] [] - in [descr{details' = d}] - (IfaceClass context _ _ _ _ ifSigs _ ) - -> let - classOpsID = map extractClassOp ifSigs - superclasses = extractSuperClassNames context - in [descr{details' = ClassDescr{super = superclasses, - methods = classOpsID}}] - (IfaceSyn _ _ _ _ _ ) - -> [descr{details' = TypeDescr}] - (IfaceForeign _ _) - -> [descr] - -extractConstructors :: OccName -> [IfaceConDecl] -> [(Symbol,TypeInfo)] -extractConstructors name decls = map (\decl -> (unpackFS $occNameFS (ifConOcc decl), - (BS.pack $ filterExtras $ showSDocUnqual $ - pprIfaceForAllPart (ifConUnivTvs decl ++ ifConExTvs decl) - (eq_ctxt decl ++ ifConCtxt decl) (pp_tau decl)))) decls - where - pp_tau decl = case map pprParendIfaceType (ifConArgTys decl) ++ [pp_res_ty decl] of - (t:ts) -> fsep (t : map (arrow <+>) ts) - [] -> panic "pp_con_taus" - pp_res_ty decl = ppr name <+> fsep [ppr tv | (tv,_) <- ifConUnivTvs decl] - eq_ctxt decl = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) - | (tv,ty) <- ifConEqSpec decl] - -extractFields :: IfaceConDecl -> [(Symbol,TypeInfo)] -extractFields decl = zip (map extractFieldNames (ifConFields decl)) - (map extractType (ifConArgTys decl)) - -extractType :: IfaceType -> TypeInfo -extractType = BS.pack . filterExtras . showSDocUnqual . ppr - -extractFieldNames :: OccName -> Symbol -extractFieldNames occName = unpackFS $occNameFS occName - -extractClassOp :: IfaceClassOp -> (Symbol, TypeInfo) -extractClassOp (IfaceClassOp occName dm ty) = (unpackFS $occNameFS occName, - BS.pack $ showSDocUnqual (ppr ty)) - -extractSuperClassNames :: [IfacePredType] -> [Symbol] -extractSuperClassNames l = catMaybes $ map extractSuperClassName l - where extractSuperClassName (IfaceClassP name _) = - Just (unpackFS $occNameFS $ nameOccName name) - extractSuperClassName _ = Nothing - -extractInstances :: PackModule -> IfaceInst -> [Descr] -extractInstances pm ifaceInst = - let className = showSDocUnqual $ ppr $ ifInstCls ifaceInst - dataNames = map (\iftc -> showSDocUnqual $ ppr iftc) - $ map fromJust - $ filter isJust - $ ifInstTys ifaceInst - in [Descr - { descrName' = className - , typeInfo' = BS.empty - , descrModu' = pm - , mbLocation' = Nothing - , mbComment' = Nothing - , details' = InstanceDescr {binds = dataNames}}] - - -extractUsages :: Usage -> (ModuleName, Set Symbol) -extractUsages (UsagePackageModule usg_mod _ ) = - let name = (fromJust . simpleParse . moduleNameString) (moduleName usg_mod) - in (name, Set.fromList []) -extractUsages (UsageHomeModule usg_mod_name _ usg_entities _) = - let name = (fromJust . simpleParse . moduleNameString) usg_mod_name - ids = map (showSDocUnqual . ppr . fst) usg_entities - in (name, Set.fromList ids) - -filterExtras, filterExtras' :: String -> String -filterExtras ('{':'-':r) = filterExtras' r -filterExtras ('R':'e':'c':'F':'l':'a':'g':r) - = filterExtras (skipNextWord r) -filterExtras ('G':'e':'n':'e':'r':'i':'c':'s':':':r) - = filterExtras (skipNextWord r) -filterExtras ('F':'a':'m':'i':'l':'y':'I':'n':'s':'t':'a':'n':'c':'e':':':r) - = filterExtras (skipNextWord r) -filterExtras (c:r) = c : filterExtras r -filterExtras [] = [] - -filterExtras' ('-':'}':r) = filterExtras r -filterExtras' (_:r) = filterExtras' r -filterExtras' [] = [] - -skipNextWord, skipNextWord' :: String -> String -skipNextWord (a:r) - | isSpace a = skipNextWord r - | otherwise = skipNextWord' r -skipNextWord [] = [] - -skipNextWord'(a:r) - | a == '\n' = r - | isSpace a = a:r - | otherwise = skipNextWord' r -skipNextWord' [] = [] - -writeExtracted :: MonadIO m => FilePath -> Bool -> Bool -> PackageDescr -> m () -writeExtracted dirPath writeAscii isWorkingPackage pd = liftIO $ do - let filePath = dirPath fromPackageIdentifier (packagePD pd) ++ - (if isWorkingPackage then ".packw" else ".pack") - if writeAscii - then writeFile (filePath ++ "dpg") (show pd) - else encodeFileSer filePath (metadataVersion, pd) - 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 @@ -1,539 +1,828 @@ -{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Metainfo.Provider --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | This module provides the infos collected by the extractor before --- and an info pane to present some of them to the user --- ---------------------------------------------------------------------------------- - -module IDE.Metainfo.Provider ( - getIdentifierDescr -, getIdentifiersStartingWith -, getCompletionOptions -, getDescription -, getActivePackageDescr - -, initInfo -, updateAccessibleInfo -, infoForActivePackage -, rebuildActiveInfo -, searchMeta -, rebuildLibInfo -) where - -import System.IO -import qualified Data.Map as Map -import Config -import Control.Monad -import Control.Monad.Trans -import System.FilePath -import System.Directory -import qualified Data.Map as Map -import System.IO -import Data.List -import qualified PackageConfig as DP -import Data.Maybe -import Distribution.Package hiding (depends,packageId) -import Data.Set (Set) -import qualified Data.Set as Set -import Data.Map (Map) -import qualified Data.ByteString.Char8 as BS -import qualified Data.ByteString.Lazy as BSL -import Distribution.Version -import Distribution.ModuleName -import GHC (runGhc) - -import DeepSeq -import IDE.FileUtils -import IDE.Core.State -import IDE.Metainfo.InterfaceCollector -import Data.Char (toLower,isUpper,toUpper,isLower) -import Text.Regex.Posix -import System.IO.Unsafe (unsafePerformIO) -import Text.Regex.Posix.String (execute,compile) -import IDE.Metainfo.GHCUtils (findFittingPackages,getInstalledPackageInfos,inGhc) -import Data.Binary.Shared (decodeSer) -import System.Mem (performGC) - -getActivePackageDescr :: IDEM (Maybe PackageDescr) -getActivePackageDescr = do - mbActive <- readIDE activePack - case mbActive of - Nothing -> return Nothing - Just pack -> do - currentInfo' <- readIDE currentInfo - case currentInfo' of - Nothing -> return Nothing - Just ((map,_),(_,_)) -> return (packageId pack `Map.lookup` map) - --- --- | Lookup of an identifier description --- -getIdentifierDescr :: String -> SymbolTable -> SymbolTable -> [Descr] -getIdentifierDescr str st1 st2 = - let r1 = case str `Map.lookup` st1 of - Nothing -> [] - Just r -> r - r2 = case str `Map.lookup` st2 of - Nothing -> [] - Just r -> r - in r1 ++ r2 - --- --- | Lookup of an identifiers starting with the specified prefix and return a list. --- -getIdentifiersStartingWith :: String -> SymbolTable -> SymbolTable -> [String] -getIdentifiersStartingWith prefix st1 st2 = - takeWhile (isPrefixOf prefix) $ - if memberLocal || memberGlobal then - prefix : Set.toAscList names - else - Set.toAscList names - where - (_, memberLocal, localNames) = Set.splitMember prefix (Map.keysSet st1) - (_, memberGlobal, globalNames) = Set.splitMember prefix (Map.keysSet st2) - names = Set.union globalNames localNames - -getCompletionOptions :: String -> IDEM [String] -getCompletionOptions prefix = do - currentInfo' <- readIDE currentInfo - case currentInfo' of - Nothing -> return [] - Just ((_,symbolTable1),(_,symbolTable2)) -> - return $ getIdentifiersStartingWith prefix symbolTable1 symbolTable2 - -getDescription :: String -> IDEM String -getDescription name = do - currentInfo' <- readIDE currentInfo - case currentInfo' of - Nothing -> return "" - Just ((_,symbolTable1),(_,symbolTable2)) -> - return ((foldr (\d f -> shows (Present d) . showChar '\n' . f) id - (getIdentifierDescr name symbolTable1 symbolTable2)) "") - --- --- | Searching of metadata --- - -searchMeta :: Scope -> String -> SearchMode -> IDEM [Descr] -searchMeta _ "" _ = return [] -searchMeta Local searchString searchType = do - currentInfo' <- readIDE currentInfo - case currentInfo' of - Nothing -> return [] - Just (l,_) -> return (searchInScope searchType searchString (snd l)) -searchMeta Package searchString searchType = do - currentInfo' <- readIDE currentInfo - case currentInfo' of - Nothing -> return [] - Just (l,p) -> return (searchInScope searchType searchString (snd l) - ++ searchInScope searchType searchString (snd p)) -searchMeta System searchString searchType = do - accessibleInfo' <- readIDE accessibleInfo - let s = case accessibleInfo' of - Nothing -> Map.empty - Just (_,scope) -> scope - currentInfo' <- readIDE currentInfo - case currentInfo' of - Nothing -> return (searchInScope searchType searchString s) - Just (l,_) -> return (searchInScope searchType searchString (snd l) - ++ searchInScope searchType searchString s) - - -searchInScope :: SearchMode -> String -> SymbolTable -> [Descr] -searchInScope (Exact _) l st = searchInScopeExact l st -searchInScope (Prefix True) l st = (concat . Map.elems) (searchInScopePrefix l st) -searchInScope (Prefix False) [] _ = [] -searchInScope (Prefix False) l st = (concat . Map.elems) (searchInScopeCaseIns l st "") -searchInScope (Regex b) l st = searchRegex l st b - - -searchInScopeExact :: String -> SymbolTable -> [Descr] -searchInScopeExact searchString symbolTable = - case Map.lookup searchString symbolTable of - Nothing -> [] - Just l -> l - -searchInScopePrefix :: String -> SymbolTable -> SymbolTable -searchInScopePrefix searchString symbolTable = - let (_, exact, mapR) = Map.splitLookup searchString symbolTable - (mbL, _, _) = Map.splitLookup (searchString ++ "{") mapR - in case exact of - Nothing -> mbL - Just e -> Map.insert searchString e mbL - -searchInScopeCaseIns :: String -> SymbolTable -> String -> SymbolTable -searchInScopeCaseIns [] st _ = st -searchInScopeCaseIns (a:l) st pre | isLower a = - let s1 = pre ++ [a] - s2 = pre ++ [toUpper a] - in (Map.union (searchInScopeCaseIns l (searchInScopePrefix s1 st) s1) - (searchInScopeCaseIns l (searchInScopePrefix s2 st) s2)) - | isUpper a = - let s1 = pre ++ [a] - s2 = pre ++ [toLower a] - in (Map.union (searchInScopeCaseIns l (searchInScopePrefix s1 st) s1) - (searchInScopeCaseIns l (searchInScopePrefix s2 st) s2)) - | otherwise = - let s = pre ++ [a] - in searchInScopeCaseIns l (searchInScopePrefix s st) s - -searchRegex :: String -> SymbolTable -> Bool -> [Descr] -searchRegex searchString st caseSense = - unsafePerformIO $ do - res <- compile (if caseSense then compBlank else compIgnoreCase) - execBlank searchString - case res of - Left err -> do - sysMessage Normal (show err) - return [] - Right regex -> - filterM (\e -> do - res <- execute regex (descrName e) - case res of - Left e -> return False - Right Nothing -> return False - _ -> return True) - (concat (Map.elems st)) - --- --- | Update and initialize metadata for the world --- -initInfo :: IDEAction -initInfo = do - prefs <- readIDE prefs - when (collectAtStart prefs) $ do - ideMessage Normal "Now updating metadata ..." - collectInstalled prefs False - ideMessage Normal "Now loading metadata ..." - loadAccessibleInfo - ideMessage Normal "Finished loading ..." - --- --- | Load all infos for all installed and exposed packages --- (see shell command: ghc-pkg list) --- -loadAccessibleInfo :: IDEAction -loadAccessibleInfo = - let version = cProjectVersion in do - collectorPath <- lift $ getCollectorPath version - packageInfos <- inGhc $ getInstalledPackageInfos - -- trace ("allInfos " ++ show (map (DP.unpackPackageId . DP.packageConfigId) packageInfos)) $ return () - packageList <- liftIO $ mapM (loadInfosForPackage collectorPath False) - (map DP.package packageInfos) - let scope = foldr buildScope (Map.empty,Map.empty) - $ map fromJust - $ filter isJust packageList - liftIO performGC - modifyIDE_ (\ide -> ide{accessibleInfo = (Just scope)}) - --- --- | Clears the current info, not the world infos --- -clearCurrentInfo :: IDEAction -clearCurrentInfo = do - modifyIDE_ (\ide -> ide{currentInfo = Nothing}) - triggerEventIDE CurrentInfo - return () - --- --- | Set info for package --- -infoForActivePackage :: IDEAction -infoForActivePackage = do - activePack <- readIDE activePack - case activePack of - Nothing -> do - modifyIDE_ (\ide -> ide{currentInfo = Nothing}) - Just pack -> do - let depends' = depends pack - fp <- inGhc $ findFittingPackages depends' - mbActive <- loadOrBuildActiveInfo - case mbActive of - Nothing -> do - -- no meta info available - modifyIDE_ (\ide -> ide{currentInfo = Nothing}) - Just active -> do - - accessibleInfo' <- readIDE accessibleInfo - case accessibleInfo' of - Nothing -> modifyIDE_ (\ide -> ide{currentInfo = Nothing}) - Just (pdmap,_) -> do - let packageList = map (\ pin -> pin `Map.lookup` pdmap) fp - let scope = foldr buildScope (Map.empty,Map.empty) - $ map fromJust - $ filter isJust packageList - modifyIDE_ (\ide -> ide{currentInfo = Just (active, scope)}) - triggerEventIDE CurrentInfo - return () - - --- --- | Builds the current info for the activePackage --- -rebuildActiveInfo :: IDEAction -rebuildActiveInfo = setInfo buildActiveInfo - --- --- | Builds the current info for the activePackage --- -setInfo :: IDEM (Maybe PackageScope) -> IDEAction -setInfo f = do - currentInfo <- readIDE currentInfo - case currentInfo of - Nothing -> return () - Just (active, scope) -> do - newActive <- f - case newActive of - Nothing -> return () - Just newActive -> do - modifyIDE_ (\ide -> ide{currentInfo = Just (newActive, scope)}) - triggerEventIDE CurrentInfo - return () - --- --- | Loads the current info for the activePackage, or builds it if not available --- -loadOrBuildActiveInfo :: IDEM (Maybe PackageScope) -loadOrBuildActiveInfo = do - mbActiveInfo <- loadActiveInfo - case mbActiveInfo of - Just ai -> return (Just ai) - Nothing -> buildActiveInfo - --- --- | Loads the current info for the activePackage --- -loadActiveInfo :: IDEM (Maybe PackageScope) -loadActiveInfo = - let version = cProjectVersion in do - activePack <- readIDE activePack - case activePack of - Nothing -> return Nothing - Just idePackage -> do - collectorPath <- lift $ getCollectorPath cProjectVersion - packageDescr <- liftIO $ loadInfosForPackage collectorPath True - (packageId idePackage) - case packageDescr of - Nothing -> return Nothing - Just pd -> do - let scope = buildScope pd (Map.empty,Map.empty) - return (Just scope) - --- --- | Builds the current info for the activePackage --- -buildActiveInfo :: IDEM (Maybe PackageScope) -buildActiveInfo = - let version = cProjectVersion in do - activePack <- readIDE activePack - case activePack of - Nothing -> return Nothing - Just idePackage -> do - libDir <- liftIO $ getSysLibDir - liftIO $ runGhc (Just libDir) - $ collectUninstalled False cProjectVersion (takeFileName $ cabalFile idePackage) - -- ideMessage Normal "uninstalled collected" - collectorPath <- lift $ getCollectorPath cProjectVersion - packageDescr <- liftIO $ loadInfosForPackage collectorPath True - (packageId idePackage) - case packageDescr of - Nothing -> return Nothing - Just pd -> do - let scope = buildScope pd (Map.empty,Map.empty) - return (Just scope) - -rebuildLibInfo :: IDEAction -rebuildLibInfo = do - updateAccessibleInfo - rebuildActiveInfo - --- --- | Updates the world info (it is the responsibility of the caller to rebuild --- the current info) --- -updateAccessibleInfo :: IDEAction -updateAccessibleInfo = do - wi <- readIDE accessibleInfo - let version = cProjectVersion - case wi of - Nothing -> loadAccessibleInfo - Just (psmap,psst) -> do - packageInfos <- inGhc getInstalledPackageInfos - let packageIds = map DP.package packageInfos - let newPackages = filter (\ pi -> Map.member pi psmap) packageIds - let trashPackages = filter (\ e -> not (elem e packageIds))(Map.keys psmap) - if null newPackages && null trashPackages - then return () - else do - collectorPath <- lift $ getCollectorPath version - newPackageInfos <- liftIO $ mapM (\pid -> loadInfosForPackage collectorPath False pid) - newPackages - let psamp2 = foldr (\e m -> Map.insert (packagePD e) e m) - psmap - (map fromJust - $ filter isJust newPackageInfos) - let psamp3 = foldr (\e m -> Map.delete e m) psmap trashPackages - let scope = foldr buildScope (Map.empty,Map.empty) - (Map.elems psamp3) - modifyIDE_ (\ide -> ide{accessibleInfo = Just scope}) - --- --- | Loads the infos for the given packages --- -loadInfosForPackage :: FilePath -> Bool -> PackageIdentifier -> IO (Maybe PackageDescr) -loadInfosForPackage dirPath isWorkingPackage pid = do - let filePath = dirPath fromPackageIdentifier pid ++ (if isWorkingPackage then ".packw" else ".pack") - exists <- doesFileExist filePath - if exists - then catch (do - file <- openBinaryFile filePath ReadMode - -- trace ("now loading metadata for package" ++ filePath) return () - bs <- BSL.hGetContents file - let (metadataVersion', packageInfo) = decodeSer bs - if metadataVersion /= metadataVersion' - then do - hClose file - throwIDE ("Metadata has a wrong version." - ++ " Consider rebuilding metadata with -r option") - else do - packageInfo `deepSeq` (hClose file) - return (Just packageInfo)) - (\e -> do sysMessage Normal (show e); return Nothing) - else do - sysMessage Normal $"packageInfo not found for " ++ fromPackageIdentifier pid - return Nothing - --- --- | Loads the infos for the given packages (has an collecting argument) --- -buildScope :: PackageDescr -> PackageScope -> PackageScope -buildScope packageD (packageMap, symbolTable) = - let pid = packagePD packageD - in if pid `Map.member` packageMap - then (packageMap, symbolTable) - else (Map.insert pid packageD packageMap, - buildSymbolTable packageD symbolTable) - -buildSymbolTable :: PackageDescr -> SymbolTable -> SymbolTable -buildSymbolTable pDescr symbolTable = - foldl' buildScope symbolTable allDescriptions - where - allDescriptions = concatMap idDescriptionsMD (exposedModulesPD pDescr) - buildScope st idDescr = - let allDescrs = allDescrsFrom idDescr - in foldl' (\ map descr -> Map.insertWith (++) (descrName descr) [descr] map) - st allDescrs - allDescrsFrom descr | isReexported descr = [descr] - | otherwise = - case details descr of - DataDescr constructors fields -> - descr : (map (\(fn,ty) -> Descr{descrName' = fn, typeInfo' = ty, - descrModu' = descrModu descr, mbLocation' = mbLocation descr, - mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}}) - fields - ++ (map (\(fn,ty) -> Descr{descrName' = fn, typeInfo' = ty, - descrModu' = descrModu descr, mbLocation' = mbLocation descr, - mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}}) - constructors)) - ClassDescr _ methods -> - descr : (map (\(fn,ty) -> Descr{descrName' = fn, typeInfo' = ty, - descrModu' = descrModu descr, mbLocation' = mbLocation descr, - mbComment' = mbComment descr, details' = MethodDescr {classDescrM = descr}}) - methods) - NewtypeDescr constr mbField -> - descr : Descr{descrName' = fst constr, typeInfo' = snd constr, - descrModu' = descrModu descr, mbLocation' = mbLocation descr, - mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}} - : case mbField of - Just fld -> - [Descr{descrName' = fst fld, typeInfo' = snd fld, - descrModu' = descrModu descr, mbLocation' = mbLocation descr, - mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}}] - Nothing -> [] - InstanceDescr _ -> [] - _ -> [descr] - - - --- --------------------------------------------------------------------- --- DeepSeq instances for forcing evaluation --- - -instance DeepSeq Location where - deepSeq pd = deepSeq (locationSLine pd) - $ deepSeq (locationSCol pd) - $ deepSeq (locationELine pd) - $ deepSeq (locationECol pd) - -instance DeepSeq PackageDescr where - deepSeq pd = deepSeq (packagePD pd) - $ deepSeq (mbSourcePathPD pd) - $ deepSeq (exposedModulesPD pd) - $ deepSeq (buildDependsPD pd) - -instance DeepSeq ModuleDescr where - deepSeq pd = deepSeq (moduleIdMD pd) - $ deepSeq (mbSourcePathMD pd) - $ deepSeq (exportedNamesMD pd) - $ deepSeq (referencesMD pd) - -instance DeepSeq Descr where - deepSeq (Descr descrName' typeInfo' descrModu' - mbLocation' mbComment' details') = deepSeq descrName' - $ deepSeq typeInfo' - $ deepSeq descrModu' - $ deepSeq mbLocation' - $ deepSeq mbComment' - $ deepSeq details' - deepSeq (Reexported reexpModu' impDescr') = deepSeq reexpModu' - $ deepSeq impDescr' - -instance DeepSeq SpDescr where - deepSeq (FieldDescr typeDescrF') = deepSeq typeDescrF' - deepSeq (ConstructorDescr typeDescrC') = deepSeq typeDescrC' - deepSeq (DataDescr constructors' fields') = deepSeq constructors' - $ deepSeq fields' - deepSeq (NewtypeDescr constructor' mbField') = deepSeq constructor' - $ deepSeq mbField' - deepSeq (ClassDescr super' methods') = deepSeq super' - $ deepSeq methods' - deepSeq (MethodDescr classDescrM') = deepSeq classDescrM' - deepSeq (InstanceDescr binds') = deepSeq binds' - deepSeq a = seq a - - -instance DeepSeq PackageIdentifier where - deepSeq pd = deepSeq (pkgName pd) - $ deepSeq (pkgVersion pd) - -instance DeepSeq alpha => DeepSeq (Set alpha) where - deepSeq s = deepSeq (Set.elems s) - -instance (DeepSeq alpha, DeepSeq beta) => DeepSeq (Map alpha beta) where - deepSeq s = deepSeq (Map.toList s) - -instance DeepSeq DescrType where deepSeq = seq - -instance DeepSeq BS.ByteString where deepSeq = seq - -instance DeepSeq Version where deepSeq = seq - -instance DeepSeq PackModule where - deepSeq pd = deepSeq (pack pd) - $ deepSeq (modu pd) - -instance DeepSeq ModuleName where - deepSeq = deepSeq . components - -instance DeepSeq PackageName where - deepSeq (PackageName s) = deepSeq s +{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables -XNoMonomorphismRestriction + -XFlexibleContexts -XBangPatterns #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Metainfo.Provider +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- | This module provides the infos collected by the extractor before +-- and an info pane to present some of them to the user +-- +--------------------------------------------------------------------------------- + +module IDE.Metainfo.Provider ( + getIdentifierDescr +, getIdentifiersStartingWith +, getCompletionOptions +, getDescription +, getActivePackageDescr +, searchMeta + +, initInfo -- Update and rebuild +, updateSystemInfo +, rebuildSystemInfo +, updateWorkspaceInfo +, rebuildWorkspaceInfo + +, getPackageInfo -- Just retreive from State +, getWorkspaceInfo +, getSystemInfo + +, getPackageImportInfo -- Scope for the import tool +) where + +import System.IO +import qualified Data.Map as Map +import Control.Monad +import Control.Monad.Trans +import System.FilePath +import System.Directory +import Data.List +import Data.Maybe +import Distribution.Package hiding (depends,packageId) +import qualified Data.Set as Set +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BSL +import Distribution.Version +import Distribution.ModuleName + +import Control.DeepSeq +import IDE.Utils.FileUtils +import IDE.Core.State +import Data.Char (toLower,isUpper,toUpper,isLower) +import Text.Regex.TDFA +import qualified Text.Regex.TDFA as Regex +import System.IO.Unsafe (unsafePerformIO) +import Text.Regex.TDFA.String (execute,compile) +import Data.Binary.Shared (decodeSer) +import Language.Haskell.Extension (knownExtensions) +import Distribution.Text (display) +import IDE.Core.Serializable () +import Data.Map (Map(..)) +import Debug.Trace +import Control.Exception (SomeException(..), catch) +import Prelude hiding(catch) +import IDE.Utils.ServerConnection(doServerCommand) + +-- --------------------------------------------------------------------- +-- Updating metadata +-- + +-- +-- | Update and initialize metadata for the world -- Called at startup +-- +initInfo :: IDEAction -> IDEAction +initInfo continuation = trace "init info called" $ do + prefs <- readIDE prefs + if collectAtStart prefs + then do + ideMessage Normal "Now updating sytem metadata ..." + callCollector False True True $ \ _ -> do + ideMessage Normal "Now loading metadata ..." + loadSystemInfo + ideMessage Normal "Now updating workspace metadata ..." + updateWorkspaceInfo' False $ \ _ -> do + ideMessage Normal "Finished" + triggerEventIDE (InfoChanged True) >> return () + continuation + else do + ideMessage Normal "Now loading metadata ..." + loadSystemInfo + ideMessage Normal "Now updating workspace metadata ..." + updateWorkspaceInfo' False $ \ _ -> do + ideMessage Normal "Finished" + triggerEventIDE (InfoChanged True) >> return () + continuation + +updateSystemInfo :: IDEAction +updateSystemInfo = trace "update sys info called" $ do + updateSystemInfo' False $ \ _ -> + updateWorkspaceInfo' False $ \ _ -> do + triggerEventIDE (InfoChanged False) >> return () + +rebuildSystemInfo :: IDEAction +rebuildSystemInfo = trace "rebuild sys info called" $ do + updateSystemInfo' True $ \ _ -> + updateWorkspaceInfo' True $ \ _ -> + triggerEventIDE (InfoChanged False) >> return () + +updateWorkspaceInfo :: IDEAction +updateWorkspaceInfo = trace "update workspace info called" $ do + currentState' <- readIDE currentState + case currentState' of + IsStartingUp -> return () + _ -> do + updateWorkspaceInfo' False $ \ _ -> do + triggerEventIDE (InfoChanged False) >> return () + +rebuildWorkspaceInfo :: IDEAction +rebuildWorkspaceInfo = trace "rebuild workspace info called" $ do + updateWorkspaceInfo' True $ \ _ -> do + triggerEventIDE (InfoChanged False) >> return () + +-- +-- | Load all infos for all installed and exposed packages +-- (see shell command: ghc-pkg list) +-- +loadSystemInfo :: IDEAction +loadSystemInfo = do + collectorPath <- liftIO $ getCollectorPath + packageIds <- liftM nub $ liftIO $ getInstalledPackageIds + packageList <- liftIO $ mapM (loadInfosForPackage collectorPath) + packageIds + let scope = foldr buildScope (PackScope Map.empty getEmptyDefaultScope) + $ catMaybes packageList +-- liftIO performGC + modifyIDE_ (\ide -> ide{systemInfo = (Just (GenScopeC (addOtherToScope scope False)))}) + + return () + +-- +-- | Updates the system info +-- +updateSystemInfo' :: Bool -> (Bool -> IDEAction) -> IDEAction +updateSystemInfo' rebuild continuation = do + wi <- getSystemInfo + case wi of + Nothing -> loadSystemInfo + Just (GenScopeC (PackScope psmap psst)) -> do + packageIds <- liftIO $ getInstalledPackageIds + let newPackages = filter (\ pi -> Map.member pi psmap) packageIds + let trashPackages = filter (\ e -> not (elem e packageIds))(Map.keys psmap) + if null newPackages && null trashPackages + then continuation True + else do + callCollector rebuild True True $ \ _ -> do + collectorPath <- lift $ getCollectorPath + newPackageInfos <- liftIO $ mapM (\pid -> loadInfosForPackage collectorPath pid) + newPackages + let psmap2 = foldr (\e m -> Map.insert (pdPackage e) e m) + psmap + (map fromJust + $ filter isJust newPackageInfos) + let psmap3 = foldr (\e m -> Map.delete e m) psmap2 trashPackages + let scope :: PackScope (Map String [Descr]) + = foldr buildScope (PackScope Map.empty symEmpty) + (Map.elems psmap3) + modifyIDE_ (\ide -> ide{systemInfo = Just (GenScopeC (addOtherToScope scope False))}) + continuation True + +getEmptyDefaultScope :: Map String [Descr] +getEmptyDefaultScope = symEmpty +-- +-- | Rebuilds system info +-- +rebuildSystemInfo' :: (Bool -> IDEAction) -> IDEAction +rebuildSystemInfo' continuation = do + callCollector True True True $ \ _ -> do + loadSystemInfo + continuation True + +-- --------------------------------------------------------------------- +-- Metadata for the workspace and active package +-- + + +updateWorkspaceInfo' :: Bool -> (Bool -> IDEAction) -> IDEAction +updateWorkspaceInfo' rebuild continuation = do + mbWorkspace <- readIDE workspace + systemInfo' <- getSystemInfo + case mbWorkspace of + Nothing -> do + trace "no workspace" $ modifyIDE_ (\ide -> ide{workspaceInfo = Nothing, packageInfo = Nothing}) + continuation False + Just ws -> do + updatePackageInfos rebuild (wsPackages ws) $ \ _ packDescrs -> do + let dependPackIds = (nub $ concatMap pdBuildDepends packDescrs) + \\ map pdPackage packDescrs + let packDescrsI = case systemInfo' of + Nothing -> [] + Just (GenScopeC (PackScope pdmap _)) -> + catMaybes $ map (\ pid -> pid `Map.lookup` pdmap) dependPackIds + let scope1 :: PackScope (Map String [Descr]) + = foldr buildScope (PackScope Map.empty symEmpty) packDescrs + let scope2 :: PackScope (Map String [Descr]) + = foldr buildScope (PackScope Map.empty symEmpty) packDescrsI + modifyIDE_ (\ide -> ide{workspaceInfo = Just + (GenScopeC (addOtherToScope scope1 True), GenScopeC(addOtherToScope scope2 False))}) + -- Now care about active package + activePack <- readIDE activePack + case activePack of + Nothing -> do + modifyIDE_ (\ide -> ide{packageInfo = Nothing}) + Just pack -> do + case filter (\pd -> pdPackage pd == ipdPackageId pack) packDescrs of + [pd] -> let impPackDescrs = + case systemInfo' of + Nothing -> [] + Just (GenScopeC (PackScope pdmap _)) -> + catMaybes $ map (\ pid -> pid `Map.lookup` pdmap) + (pdBuildDepends pd) + -- The imported from the workspace should be treated different + workspacePackageIds = map ipdPackageId (wsPackages ws) + impPackDescrs' = filter (\pd -> not (elem (pdPackage pd) + workspacePackageIds)) impPackDescrs + impPackDescrs'' = catMaybes $ map (\pd -> + if (elem (pdPackage pd) workspacePackageIds) + then find (\pd' -> pdPackage pd == pdPackage pd') packDescrs + else Nothing) impPackDescrs + scope1 :: PackScope (Map String [Descr]) + = buildScope pd (PackScope Map.empty symEmpty) + scope2 :: PackScope (Map String [Descr]) + = foldr buildScope (PackScope Map.empty symEmpty) + (impPackDescrs' ++ impPackDescrs'') + in modifyIDE_ (\ide -> ide{packageInfo = Just + (GenScopeC (addOtherToScope scope1 False), + GenScopeC(addOtherToScope scope2 False))}) + _ -> modifyIDE_ (\ide -> ide{packageInfo = Nothing}) + continuation True + +updatePackageInfos :: Bool -> [IDEPackage] -> (Bool -> [PackageDescr] -> IDEAction) -> IDEAction +updatePackageInfos rebuild packs conts = updatePackageInfos' [] rebuild packs conts + where + updatePackageInfos' collector _ [] continuation = continuation True collector + updatePackageInfos' collector rebuild (hd:tail) continuation = + updatePackageInfo rebuild hd $ \ _ packDescr -> + updatePackageInfos' (packDescr : collector) rebuild tail continuation + +updatePackageInfo :: Bool -> IDEPackage -> (Bool -> PackageDescr -> IDEAction) -> IDEAction +updatePackageInfo rebuild idePack continuation = + trace ("updatePackageInfo " ++ show (ipdPackageId idePack)) $ do + workspInfoCache' <- readIDE workspInfoCache + let (packageMap, ic) = case pi `Map.lookup` workspInfoCache' of + Nothing -> (Map.empty,True) + Just m -> (m,False) + modPairsMb <- liftIO $ mapM (\ modName -> do + sf <- case modName `Map.lookup` packageMap of + Nothing -> findSourceFile srcDirs' haskellSrcExts modName + Just (_,Nothing,_) -> findSourceFile srcDirs' haskellSrcExts modName + Just (_,Just fp,_) -> return (Just fp) + return (modName, sf)) + $ Set.toList $ ipdModules idePack + mainModules <- liftIO $ mapM (\fn -> do + mbFn <- findSourceFile' srcDirs' 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 modWithoutSources = map fst $ modWithout + -- Now see which modules have to be truely updated + modToUpdate <- if rebuild + then return modWithSources + else liftIO $ figureOutRealSources idePack modWithSources + trace ("updatePackageInfo modToUpdate " ++ show (map (display.fst) modToUpdate)) $ + callCollectorWorkspace + rebuild + (dropFileName (ipdCabalFile idePack)) + (ipdPackageId idePack) + (map (\(x,y) -> (display x,y)) modToUpdate) + (\ b -> do + buildDepends <- liftIO $ findFittingPackages (ipdDepends idePack) + collectorPath <- liftIO $ getCollectorPath + let packageCollectorPath = collectorPath packageIdentifierToString pi + (moduleDescrs,packageMap, changed, modWithout) + <- liftIO $ foldM + (getModuleDescr packageCollectorPath) + ([],packageMap,False,modWithoutSources) + modPairsMb' + when changed $ modifyIDE_ (\ide -> ide{workspInfoCache = + Map.insert pi packageMap workspInfoCache'}) + continuation True $ (PackageDescr { + pdPackage = pi, + pdMbSourcePath = Just $ ipdCabalFile idePack, + pdModules = moduleDescrs, + pdBuildDepends = buildDepends})) + where + basePath = normalise $ (takeDirectory (ipdCabalFile idePack)) + srcDirs' = map (basePath ) (ipdSrcDirs idePack) + pi = ipdPackageId idePack + +figureOutRealSources :: IDEPackage -> [(ModuleName,FilePath)] -> IO [(ModuleName,FilePath)] +figureOutRealSources idePack modWithSources = do + collectorPath <- getCollectorPath + let packageCollectorPath = collectorPath packageIdentifierToString (ipdPackageId idePack) + filterM (ff packageCollectorPath) modWithSources + where + ff packageCollectorPath (md ,fp) = do + let modId = display md + let collectorModulePath = packageCollectorPath modId <.> leksahMetadataWorkspaceFileExtension + existCollectorFile <- doesFileExist collectorModulePath + existSourceFile <- doesFileExist fp + if (not existSourceFile) + then return True -- Maybe with preprocessing + else if not existCollectorFile + then return True + else do + sourceModTime <- getModificationTime fp + collModTime <- getModificationTime collectorModulePath + return (sourceModTime > collModTime) + + +getModuleDescr :: FilePath + -> ([ModuleDescr],ModuleDescrCache,Bool,[ModuleName]) + -> (ModuleName, Maybe FilePath) + -> IO ([ModuleDescr],ModuleDescrCache,Bool,[ModuleName]) +getModuleDescr packageCollectorPath (modDescrs,packageMap,changed,problemMods) (modName,mbFilePath) = + case modName `Map.lookup` packageMap of + Just (eTime,mbFp,mdescr) -> do + existMetadataFile <- doesFileExist moduleCollectorPath + if existMetadataFile + then do + modificationTime <- liftIO $ getModificationTime moduleCollectorPath + if modificationTime == eTime + then return (mdescr:modDescrs,packageMap,changed,problemMods) + else do + mbNewDescr <- trace ("loadInfo: " ++ display modName) $ + loadInfosForModule moduleCollectorPath + case mbNewDescr of + Just newDescr -> return (newDescr:modDescrs, + Map.insert modName (modificationTime,mbFilePath,newDescr) packageMap, + True, problemMods) + Nothing -> return (mdescr:modDescrs,packageMap,changed, + modName : problemMods) + else return (mdescr:modDescrs,packageMap,changed, modName : problemMods) + Nothing -> do + existMetadataFile <- doesFileExist moduleCollectorPath + if existMetadataFile + then do + modificationTime <- liftIO $ getModificationTime moduleCollectorPath + mbNewDescr <- loadInfosForModule moduleCollectorPath + case mbNewDescr of + Just newDescr -> return (newDescr:modDescrs, + Map.insert modName (modificationTime,mbFilePath,newDescr) packageMap, + True, problemMods) + Nothing -> return (modDescrs,packageMap,changed, + modName : problemMods) + else return (modDescrs,packageMap,changed, modName : problemMods) + where + moduleCollectorPath = packageCollectorPath display modName <.> leksahMetadataWorkspaceFileExtension + +-- --------------------------------------------------------------------- +-- Low level helpers for loading metadata +-- + +-- +-- | Loads the infos for the given packages +-- +loadInfosForPackage :: FilePath -> PackageIdentifier -> IO (Maybe PackageDescr) +loadInfosForPackage dirPath pid = do + let filePath = dirPath packageIdentifierToString pid ++ leksahMetadataSystemFileExtension + let filePath2 = dirPath packageIdentifierToString pid ++ leksahMetadataPathFileExtension + exists <- doesFileExist filePath + if exists + then catch (do + file <- openBinaryFile filePath ReadMode + trace ("now loading metadata for package " ++ packageIdentifierToString pid) return () + bs <- BSL.hGetContents file + let (metadataVersion', packageInfo) = decodeSer bs + if metadataVersion /= metadataVersion' + then do + hClose file + throwIDE ("Metadata has a wrong version." + ++ " Consider rebuilding metadata with: leksah-server -osb +RTS -N2 -RTS") + else do + packageInfo `deepseq` (hClose file) + exists' <- doesFileExist filePath2 + sourcePath <- if exists' + then liftM Just (readFile filePath2) + else return Nothing + let packageInfo' = trace ("source path= " ++ show sourcePath) $ + injectSourceInPack sourcePath packageInfo + return (Just packageInfo')) + (\ (e :: SomeException) -> do + sysMessage Normal + ("loadInfosForPackage: " ++ packageIdentifierToString pid ++ " Exception: " ++ show e) + return Nothing) + else do + sysMessage Normal $"packageInfo not found for " ++ packageIdentifierToString pid + return Nothing + +injectSourceInPack :: Maybe FilePath -> PackageDescr -> PackageDescr +injectSourceInPack Nothing pd = pd{ + pdMbSourcePath = Nothing, + pdModules = map (injectSourceInMod Nothing) (pdModules pd)} +injectSourceInPack (Just pp) pd = pd{ + pdMbSourcePath = (Just pp), + pdModules = map (injectSourceInMod (Just (dropFileName pp))) (pdModules pd)} + +injectSourceInMod :: Maybe FilePath -> ModuleDescr -> ModuleDescr +injectSourceInMod Nothing md = md{mdMbSourcePath = Nothing} +injectSourceInMod (Just bp) md = + case mdMbSourcePath md of + Just sp -> md{mdMbSourcePath = Just (bp sp)} + Nothing -> md + +-- +-- | Loads the infos for the given module +-- +loadInfosForModule :: FilePath -> IO (Maybe ModuleDescr) +loadInfosForModule filePath = do + exists <- doesFileExist filePath + if exists + then catch (do + file <- openBinaryFile filePath ReadMode + bs <- BSL.hGetContents file + let (metadataVersion', moduleInfo) = decodeSer bs + if metadataVersion /= metadataVersion' + then do + hClose file + throwIDE ("Metadata has a wrong version." + ++ " Consider rebuilding metadata with -r option") + else do + moduleInfo `deepseq` (hClose file) + return (Just moduleInfo)) + (\ (e :: SomeException) -> do sysMessage Normal ("loadInfosForModule: " ++ show e); return Nothing) + else do + sysMessage Normal $"moduleInfo not found for " ++ filePath + return Nothing + +findFittingPackages :: [Dependency] -> IO [PackageIdentifier] +findFittingPackages dependencyList = do + knownPackages <- getInstalledPackageIds + return (concatMap (fittingKnown knownPackages) dependencyList) + where + fittingKnown packages (Dependency dname versionRange) = + let filtered = filter (\ (PackageIdentifier name version) -> + name == dname && withinRange version versionRange) + packages + in if length filtered > 1 + then [maximumBy (\a b -> compare (pkgVersion a) (pkgVersion b)) filtered] + else filtered + +-- --------------------------------------------------------------------- +-- Looking up and searching metadata +-- + +getActivePackageDescr :: IDEM (Maybe PackageDescr) +getActivePackageDescr = do + mbActive <- readIDE activePack + case mbActive of + Nothing -> return Nothing + Just pack -> do + packageInfo' <- getPackageInfo + case packageInfo' of + Nothing -> return Nothing + Just (GenScopeC (PackScope map _),(GenScopeC (PackScope _ _))) -> + return (ipdPackageId pack `Map.lookup` map) + +-- +-- | Lookup of an identifier description +-- +getIdentifierDescr :: (SymbolTable alpha, SymbolTable beta) => String -> alpha -> beta -> [Descr] +getIdentifierDescr str st1 st2 = + let r1 = str `symLookup` st1 + r2 = str `symLookup` st2 + in r1 ++ r2 + +-- +-- | Lookup of an identifiers starting with the specified prefix and return a list. +-- +getIdentifiersStartingWith :: (SymbolTable alpha , SymbolTable beta) => String -> alpha -> beta -> [String] +getIdentifiersStartingWith prefix st1 st2 = + takeWhile (isPrefixOf prefix) $ + if memberLocal || memberGlobal then + prefix : Set.toAscList names + else + Set.toAscList names + where + (_, memberLocal, localNames) = Set.splitMember prefix (symbols st1) + (_, memberGlobal, globalNames) = Set.splitMember prefix (symbols st2) + names = Set.union globalNames localNames + +getCompletionOptions :: String -> IDEM [String] +getCompletionOptions prefix = do + workspaceInfo' <- getWorkspaceInfo + case workspaceInfo' of + Nothing -> return [] + Just ((GenScopeC (PackScope _ symbolTable1)),(GenScopeC (PackScope _ symbolTable2))) -> + return $ getIdentifiersStartingWith prefix symbolTable1 symbolTable2 + +getDescription :: String -> IDEM String +getDescription name = do + workspaceInfo' <- getWorkspaceInfo + case workspaceInfo' of + Nothing -> return "" + Just ((GenScopeC (PackScope _ symbolTable1)),(GenScopeC (PackScope _ symbolTable2))) -> + return ((foldr (\d f -> shows (Present d) . showChar '\n' . f) id + (getIdentifierDescr name symbolTable1 symbolTable2)) "") + +getPackageInfo :: IDEM (Maybe (GenScope, GenScope)) +getPackageInfo = readIDE packageInfo + +getWorkspaceInfo :: IDEM (Maybe (GenScope, GenScope)) +getWorkspaceInfo = readIDE workspaceInfo + +getSystemInfo :: IDEM (Maybe GenScope) +getSystemInfo = readIDE systemInfo + +-- | Only exported items +getPackageImportInfo :: IDEPackage -> IDEM (Maybe (GenScope,GenScope)) +getPackageImportInfo idePack = do + mbActivePack <- readIDE activePack + systemInfo' <- getSystemInfo + if isJust mbActivePack && ipdPackageId (fromJust mbActivePack) == ipdPackageId idePack + then do + packageInfo' <- getPackageInfo + case packageInfo' of + Nothing -> trace "getPackageImportInfo: no package info" $ return Nothing + Just ((GenScopeC (PackScope pdmap _)),_) -> do + case Map.lookup (ipdPackageId idePack) pdmap of + Nothing -> trace "getPackageImportInfo: package not found in package" $ return Nothing + Just pd -> buildIt pd systemInfo' + else do + workspaceInfo <- getWorkspaceInfo + case workspaceInfo of + Nothing -> trace "getPackageImportInfo: no workspace info" $ return Nothing + Just ((GenScopeC (PackScope pdmap _)),_) -> + case Map.lookup (ipdPackageId idePack) pdmap of + Nothing -> trace "getPackageImportInfo: package not found in workspace" $ return Nothing + Just pd -> buildIt pd systemInfo' + + where + filterPrivate :: ModuleDescr -> ModuleDescr + filterPrivate md = md{mdIdDescriptions = filter dscExported (mdIdDescriptions md)} + buildIt pd systemInfo' = + case systemInfo' of + Nothing -> trace "getPackageImportInfo: no system info" $ return Nothing + Just (GenScopeC (PackScope pdmap' _)) -> + let impPackDescrs = catMaybes $ map (\ pid -> pid `Map.lookup` pdmap') + (pdBuildDepends pd) + pd' = pd{pdModules = map filterPrivate (pdModules pd)} + scope1 :: PackScope (Map String [Descr]) + = buildScope pd (PackScope Map.empty symEmpty) + scope2 :: PackScope (Map String [Descr]) + = foldr buildScope (PackScope Map.empty symEmpty) impPackDescrs + in return (Just (GenScopeC scope1, GenScopeC scope2)) +-- +-- | Searching of metadata +-- + +searchMeta :: Scope -> String -> SearchMode -> IDEM [Descr] +searchMeta _ "" _ = return [] +searchMeta (PackageScope False) searchString searchType = do + packageInfo' <- getPackageInfo + case packageInfo' of + Nothing -> return [] + Just ((GenScopeC (PackScope _ rl)),_) -> return (searchInScope searchType searchString rl) +searchMeta (PackageScope True) searchString searchType = do + packageInfo' <- getPackageInfo + case packageInfo' of + Nothing -> return [] + Just ((GenScopeC (PackScope _ rl)),(GenScopeC (PackScope _ rr))) -> + return (searchInScope searchType searchString rl + ++ searchInScope searchType searchString rr) +searchMeta (WorkspaceScope False) searchString searchType = do + workspaceInfo' <- getWorkspaceInfo + case workspaceInfo' of + Nothing -> return [] + Just ((GenScopeC (PackScope _ rl)),_) -> return (searchInScope searchType searchString rl) +searchMeta (WorkspaceScope True) searchString searchType = do + workspaceInfo' <- getWorkspaceInfo + case workspaceInfo' of + Nothing -> return [] + Just ((GenScopeC (PackScope _ rl)),(GenScopeC (PackScope _ rr))) -> + return (searchInScope searchType searchString rl + ++ searchInScope searchType searchString rr) +searchMeta SystemScope searchString searchType = do + systemInfo' <- getSystemInfo + packageInfo' <- getPackageInfo + case systemInfo' of + Nothing -> + case packageInfo' of + Nothing -> return [] + Just ((GenScopeC (PackScope _ rl)),_) -> + return (searchInScope searchType searchString rl) + Just (GenScopeC (PackScope _ s)) -> + case packageInfo' of + Nothing -> return (searchInScope searchType searchString s) + Just ((GenScopeC (PackScope _ rl)),_) -> return (searchInScope searchType searchString rl + ++ searchInScope searchType searchString s) + +searchInScope :: SymbolTable alpha => SearchMode -> String -> alpha -> [Descr] +searchInScope (Exact _) l st = searchInScopeExact l st +searchInScope (Prefix True) l st = (concat . symElems) (searchInScopePrefix l st) +searchInScope (Prefix False) [] _ = [] +searchInScope (Prefix False) l st = (concat . symElems) (searchInScopeCaseIns l st "") +searchInScope (Regex b) l st = searchRegex l st b + + +searchInScopeExact :: SymbolTable alpha => String -> alpha -> [Descr] +searchInScopeExact = symLookup + +searchInScopePrefix :: SymbolTable alpha => String -> alpha -> alpha +searchInScopePrefix searchString symbolTable = + let (_, exact, mapR) = symSplitLookup searchString symbolTable + (mbL, _, _) = symSplitLookup (searchString ++ "{") mapR + in case exact of + Nothing -> mbL + Just e -> symInsert searchString e mbL + +searchInScopeCaseIns :: SymbolTable alpha => String -> alpha -> String -> alpha +searchInScopeCaseIns [] st _ = st +searchInScopeCaseIns (a:l) st pre | isLower a = + let s1 = pre ++ [a] + s2 = pre ++ [toUpper a] + in (symUnion (searchInScopeCaseIns l (searchInScopePrefix s1 st) s1) + (searchInScopeCaseIns l (searchInScopePrefix s2 st) s2)) + | isUpper a = + let s1 = pre ++ [a] + s2 = pre ++ [toLower a] + in (symUnion (searchInScopeCaseIns l (searchInScopePrefix s1 st) s1) + (searchInScopeCaseIns l (searchInScopePrefix s2 st) s2)) + | otherwise = + let s = pre ++ [a] + in searchInScopeCaseIns l (searchInScopePrefix s st) s + + +searchRegex :: SymbolTable alpha => String -> alpha -> Bool -> [Descr] +searchRegex searchString st caseSense = + case compileRegex caseSense searchString of + Left err -> + unsafePerformIO $ sysMessage Normal (show err) >> return [] + Right regex -> + filter (\e -> do + case execute regex (dscName e) of + Left e -> False + Right Nothing -> False + _ -> True) + (concat (symElems st)) + +compileRegex :: Bool -> String -> Either String Regex +compileRegex caseSense searchString = + let compOption = defaultCompOpt { + Regex.caseSensitive = caseSense + , multiline = True } in + compile compOption defaultExecOpt searchString + +-- --------------------------------------------------------------------- +-- Handling of scopes +-- + +-- +-- | Loads the infos for the given packages (has an collecting argument) +-- +buildScope :: SymbolTable alpha => PackageDescr -> PackScope alpha -> PackScope alpha +buildScope packageD (PackScope packageMap symbolTable) = + let pid = pdPackage packageD + in if pid `Map.member` packageMap + then (PackScope packageMap symbolTable) + else (PackScope (Map.insert pid packageD packageMap) + (buildSymbolTable packageD symbolTable)) + +buildSymbolTable :: SymbolTable alpha => PackageDescr -> alpha -> alpha +buildSymbolTable pDescr symbolTable = + foldl' buildScope' + symbolTable allDescriptions + where + allDescriptions = concatMap mdIdDescriptions (pdModules pDescr) + buildScope' st idDescr = + let allDescrs = allDescrsFrom idDescr + in foldl' (\ map descr -> symInsert (dscName descr) [descr] map) + st allDescrs + allDescrsFrom descr | isReexported descr = [descr] + | otherwise = + case dscTypeHint descr of + DataDescr constructors fields -> + descr : (map (\(SimpleDescr fn ty loc comm exp) -> + Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty, + dscMbModu' = dscMbModu descr, dscMbLocation' = loc, + dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp}) + fields) + ++ (map (\(SimpleDescr fn ty loc comm exp) -> + Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty, + dscMbModu' = dscMbModu descr, dscMbLocation' = loc, + dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp}) + constructors) + ClassDescr _ methods -> + descr : (map (\(SimpleDescr fn ty loc comm exp) -> + Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty, + dscMbModu' = dscMbModu descr, dscMbLocation' = loc, + dscMbComment' = comm, dscTypeHint' = MethodDescr descr, dscExported' = exp}) + methods) + NewtypeDescr (SimpleDescr fn ty loc comm exp) mbField -> + descr : (Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty, + dscMbModu' = dscMbModu descr, dscMbLocation' = loc, + dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp}) + : case mbField of + Just (SimpleDescr fn ty loc comm exp) -> + [Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty, + dscMbModu' = dscMbModu descr, dscMbLocation' = loc, + dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp}] + Nothing -> [] + InstanceDescr _ -> [] + _ -> [descr] + + +-- --------------------------------------------------------------------- +-- Low level functions for calling the collector +-- + +callCollector :: Bool -> Bool -> Bool -> (Bool -> IDEAction) -> IDEAction +callCollector rebuild sources extract cont = trace "callCollector" $ do + doServerCommand command $ \ res -> + case res of + ServerOK -> trace "callCollector finished" $ cont True + ServerFailed str -> trace str $ cont False + _ -> trace "impossible server answer" $ cont False + where command = SystemCommand { + scRebuild = rebuild, + scSources = sources, + scExtract = extract} + +callCollectorWorkspace :: Bool -> FilePath -> PackageIdentifier -> [(String,FilePath)] -> + (Bool -> IDEAction) -> IDEAction +callCollectorWorkspace rebuild fp pi modList cont = trace "callCollectorWorkspace" $ + if null modList + then trace "callCollectorWorkspace: Nothing to do" $ cont True + else do + doServerCommand command $ \ res -> + case res of + ServerOK -> trace "callCollectorWorkspace finished" $ cont True + ServerFailed str -> trace str $ cont False + _ -> trace "impossible server answer" $ cont False + where command = WorkspaceCommand { + wcRebuild = rebuild, + wcPackage = pi, + wcPath = fp, + wcModList = modList} + +-- --------------------------------------------------------------------- +-- Additions for completion +-- + +keywords :: [String] +keywords = [ + "as" + , "case" + , "of" + , "class" + , "data" + , "default" + , "deriving" + , "do" + , "forall" + , "foreign" + , "hiding" + , "if" + , "then" + , "else" + , "import" + , "infix" + , "infixl" + , "infixr" + , "instance" + , "let" + , "in" + , "mdo" + , "module" + , "newtype" + , "qualified" + , "type" + , "where"] + +keywordDescrs :: [Descr] +keywordDescrs = map (\s -> Real $ RealDescr + s + Nothing + Nothing + Nothing + (Just (BS.pack " Haskell keyword")) + KeywordDescr + True) keywords + +extensionDescrs :: [Descr] +extensionDescrs = map (\ext -> Real $ RealDescr + ("X" ++ show ext) + Nothing + Nothing + Nothing + (Just (BS.pack " Haskell language extension")) + ExtensionDescr + True) knownExtensions + +moduleNameDescrs :: PackageDescr -> [Descr] +moduleNameDescrs pd = map (\md -> Real $ RealDescr + ((display . modu . mdModuleId) md) + Nothing + (Just (mdModuleId md)) + Nothing + (Just (BS.pack " Module name")) + ModNameDescr + True) (pdModules pd) + +addOtherToScope :: SymbolTable alpha => PackScope alpha -> Bool -> PackScope alpha +addOtherToScope (PackScope packageMap symbolTable) addAll = (PackScope packageMap newSymbolTable) + where newSymbolTable = foldl' (\ map descr -> symInsert (dscName descr) [descr] map) + symbolTable (if addAll + then keywordDescrs ++ extensionDescrs ++ modNameDescrs + else modNameDescrs) + modNameDescrs = concatMap moduleNameDescrs (Map.elems packageMap) diff --git a/src/IDE/Metainfo/Serializable.hs b/src/IDE/Metainfo/Serializable.hs deleted file mode 100644 --- a/src/IDE/Metainfo/Serializable.hs +++ /dev/null @@ -1,212 +0,0 @@ -{-# OPTIONS_GHC - -XScopedTypeVariables - -XStandaloneDeriving - -XDeriveDataTypeable #-} - ----------------------------------------------------------------------------- --- --- Module : IDE.Metainfo.Serializable --- Copyright : 2007-2009 Jürgen Nicklisch-Franken --- License : GPL --- --- Maintainer : Jutaro --- Stability : provisional --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module IDE.Metainfo.Serializable ( - - -) where - -import IDE.Core.State -import Distribution.Text (simpleParse,display) -import Control.Monad (liftM) -import Data.Maybe (fromJust) -import Data.Binary.Shared (BinaryShared(..)) -import Data.Typeable (Typeable(..)) -import Distribution.Package (PackageName(..),PackageIdentifier(..)) -import Data.Version (Version(..)) -import Distribution.ModuleName (ModuleName(..)) - -deriving instance Typeable PackageIdentifier -deriving instance Typeable ModuleName -deriving instance Typeable PackageName ------------------------------------------------------------ - -instance BinaryShared PackModule where - put = putShared (\ (PM pack' modu') -> do - (put pack') - (put modu')) - get = getShared (do - pack' <- get - modu' <- get - return (PM pack' modu')) - - -instance BinaryShared PackageIdentifier where - put = putShared (\ (PackageIdentifier name' version') -> do - put name' - put version') - get = getShared (do - name' <- get - version' <- get - return (PackageIdentifier name' version')) - -instance BinaryShared Version where - put = putShared (\ (Version branch' tags') -> do - put branch' - put tags') - get = getShared (do - branch' <- get - tags' <- get - return (Version branch' tags')) - -instance BinaryShared PackageDescr where - put = putShared (\ (PackageDescr packagePD' exposedModulesPD' buildDependsPD' - mbSourcePathPD') -> do - put packagePD' - put exposedModulesPD' - put buildDependsPD' - put mbSourcePathPD') - get = getShared (do - packagePD' <- get - exposedModulesPD' <- get - buildDependsPD' <- get - mbSourcePathPD' <- get - return (PackageDescr packagePD' exposedModulesPD' buildDependsPD' - mbSourcePathPD')) - -instance BinaryShared ModuleDescr where - put = putShared (\ (ModuleDescr moduleIdMD' exportedNamesMD' mbSourcePathMD' usagesMD' - idDescriptionsMD') -> do - put moduleIdMD' - put exportedNamesMD' - put mbSourcePathMD' - put usagesMD' - put idDescriptionsMD') - get = getShared (do - moduleIdMD' <- get - exportedNamesMD' <- get - mbSourcePathMD' <- get - usagesMD' <- get - idDescriptionsMD' <- get - return (ModuleDescr moduleIdMD' exportedNamesMD' mbSourcePathMD' - usagesMD' idDescriptionsMD')) - -instance BinaryShared Descr where - put (Descr descrName2 typeInfo2 descrModu2 mbLocation2 mbComment2 details2) - = do put (1:: Int) - put descrName2 - put typeInfo2 - put descrModu2 - put mbLocation2 - put mbComment2 - put details2 - put (Reexported reexpModu' impDescr') - = do put (2:: Int) - put reexpModu' - put impDescr' - get = do (typeHint :: Int) <- get - case typeHint of - 1 -> do - descrName2 <- get - typeInfo2 <- get - descrModu2 <- get - mbLocation2 <- get - mbComment2 <- get - details2 <- get - return (Descr descrName2 typeInfo2 descrModu2 mbLocation2 - mbComment2 details2) - 2 -> do - reexpModu' <- get - impDescr' <- get - return (Reexported reexpModu' impDescr') - _ -> throwIDE "Impossible in Binary Descr get" - -instance BinaryShared SpDescr where - put VariableDescr - = do put (1:: Int) - put (FieldDescr typeDescrF') - = do put (2:: Int) - put typeDescrF' - put (ConstructorDescr typeDescrC') - = do put (3:: Int) - put typeDescrC' - put (DataDescr constructors' fields') - = do put (4:: Int) - put constructors' - put fields' - put TypeDescr - = do put (5:: Int) - put (NewtypeDescr constructor' mbField') - = do put (6:: Int) - put constructor' - put mbField' - put (ClassDescr super' methods') - = do put (7:: Int) - put super' - put methods' - put (MethodDescr classDescrM') - = do put (8:: Int) - put classDescrM' - put (InstanceDescr binds') - = do put (9:: Int) - put binds' - - get = do (typeHint :: Int) <- get - case typeHint of - 1 -> return VariableDescr - 2 -> do - typeDescrF' <- get - return (FieldDescr typeDescrF') - 3 -> do - typeDescrC' <- get - return (ConstructorDescr typeDescrC') - 4 -> do - constructors' <- get - fields' <- get - return (DataDescr constructors' fields') - 5 -> return TypeDescr - 6 -> do - constructor' <- get - mbField' <- get - return (NewtypeDescr constructor' mbField') - 7 -> do - super' <- get - methods' <- get - return (ClassDescr super' methods') - 8 -> do - classDescrM' <- get - return (MethodDescr classDescrM') - 9 -> do - binds' <- get - return (InstanceDescr binds') - _ -> throwIDE "Impossible in Binary SpDescr get" - -instance BinaryShared Location where - put (Location locationSLine' locationSCol' locationELine' locationECol') - = do put locationSLine' - put locationSCol' - put locationELine' - put locationECol' - get = do locationSLine' <- get - locationSCol' <- get - locationELine' <- get - locationECol' <- get - return (Location locationSLine' locationSCol' locationELine' locationECol') - -instance BinaryShared ModuleName where - put = put . display - get = liftM (fromJust . simpleParse) get - -instance BinaryShared PackageName where - put (PackageName pn) = put pn - get = liftM PackageName get - - - - - diff --git a/src/IDE/Metainfo/SourceCollector.hs b/src/IDE/Metainfo/SourceCollector.hs deleted file mode 100644 --- a/src/IDE/Metainfo/SourceCollector.hs +++ /dev/null @@ -1,517 +0,0 @@ -{-# OPTIONS_GHC -XScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Metainfo.SourceCollector --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | This module collects information for packages with source available --- -------------------------------------------------------------------------------- - -module IDE.Metainfo.SourceCollector ( - collectSources -, buildSourceForPackageDB -, sourceForPackage -, parseSourceForPackageDB -, getSourcesMap -) where - -import qualified Text.PrettyPrint.HughesPJ as PP -import qualified Data.Map as Map -import Data.Map (Map) -import Distribution.PackageDescription -import Distribution.Verbosity -import Text.ParserCombinators.Parsec -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec.Language(emptyDef) -import System.Directory -import Control.Monad.State -import System.FilePath -import System.IO -import Data.List (foldl',nub,delete,sort) -import Data.Maybe(catMaybes) -import qualified Data.ByteString.Char8 as BS - - -import GHC hiding (idType) -import SrcLoc -import RdrName -import OccName -import DynFlags -import StringBuffer -import Bag -import ErrUtils -import FastString -import Outputable hiding (char) - -import IDE.Core.State -import IDE.FileUtils -import Distribution.PackageDescription.Configuration (flattenPackageDescription) -import Distribution.PackageDescription.Parse (readPackageDescription) -import GHC.Exception (SomeException(..)) -import Distribution.Package (PackageIdentifier(..)) -import Distribution.Text (display) -import DriverPipeline (preprocess) -import GHC.Show (showSpace) -import IDE.Metainfo.GHCUtils (myParseModule) - - --- --------------------------------------------------------------------- --- | Collect infos from sources for one package --- -collectSources :: Map PackageIdentifier [FilePath] - -> PackageDescr - -> Ghc (PackageDescr,Int) -collectSources sourceMap pdescr = do - sysMessage Normal $ "Now collecting sources for " ++ display (packagePD pdescr) - case sourceForPackage (packagePD pdescr) sourceMap of - Nothing -> do - sysMessage Normal $ "No source for package " ++ display (packagePD pdescr) - return (pdescr,0) - Just cabalPath -> gcatch (do - let basePath = normalise $ (takeDirectory cabalPath) - pkgDescr <- gcatch (liftIO $ (liftM flattenPackageDescription - (readPackageDescription silent cabalPath))) - (\(e :: SomeException) -> return emptyPackageDescription) - let bis = allBuildInfo pkgDescr - let buildPaths = if hasExes pkgDescr - then let exeName' = exeName (head (executables pkgDescr)) - in map (\p -> basePath p) $ - ("dist" "build" exeName' - exeName' ++ "-tmp" "") : - ("dist" "build" "autogen") : (".") - : (nub $ concatMap hsSourceDirs bis) - else map (\p -> basePath p) $ - ("dist" "build" "autogen") : (".") - : (nub $ concatMap hsSourceDirs bis) - let includes = map (\p -> basePath p) $ nub $ concatMap includeDirs bis - - dflags <- getSessionDynFlags - let dflags2 = dflags { - topDir = basePath, - hscTarget = HscNothing, - ghcMode = CompManager, - ghcLink = NoLink} - setSessionDynFlags dflags2 - let flags = ["-fglasgow-exts"] - ++ ["-cpp"] - ++ ["-w"] - ++ ["-I" ++ dir | dir <- includes] - ++ ["-I" ++ dir | dir <- buildPaths] - ++ ["-i" ++ dir | dir <- includes] - ++ ["-i" ++ dir | dir <- buildPaths] - ++ ["-X" ++ show e | e <- nub $ concatMap extensions bis] - -- trace ("flags " ++ show flags) $ return () - dflags3 <- getSessionDynFlags - (dflags4,_,_) <- parseDynamicFlags dflags3 (map noLoc flags) - let dflags5 = dopt_set (dopt_set dflags4 Opt_Haddock) Opt_ReadUserPackageConf - setSessionDynFlags dflags5 - - let allMods = nub (exeModules pkgDescr ++ libModules pkgDescr) - let exposedMods = map (modu . moduleIdMD) (exposedModulesPD pdescr) - sourceFiles <- liftIO $ mapM (findSourceFile - buildPaths - ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp"]) - $ nub (exposedMods ++ allMods) - (newModDescrs,failureCount) - <- foldM collectSourcesForModule ([],0) - (zip (exposedModulesPD pdescr) sourceFiles) - let nPackDescr = pdescr{mbSourcePathPD = Just cabalPath, - exposedModulesPD = newModDescrs} - return (nPackDescr,failureCount)) - (\(e :: SomeException) -> do - sysMessage Normal $ "source collector throwIDE1 " ++ show e ++ " in " ++ - display (packagePD pdescr) ++ " missed " - ++ show (length $ exposedModulesPD pdescr) - return (pdescr,length $ exposedModulesPD pdescr)) - --- --------------------------------------------------------------------- --- | Collect infos from sources for one module --- -collectSourcesForModule :: ([ModuleDescr],Int) - -> (ModuleDescr, Maybe FilePath) - -> Ghc ([ModuleDescr],Int) -collectSourcesForModule (moduleDescrs,failureCount) (moduleDescr,mbfp) = - case mbfp of - Nothing -> do - sysMessage Normal $ "No source for module " ++ (display $ modu $ moduleIdMD moduleDescr) - return(moduleDescr : moduleDescrs, failureCount+1) - Just fp -> do - session <- getSession - (_,fp') <- preprocess session (fp,Nothing) - dynFlags <- getSessionDynFlags - liftIO $ do - stringBuffer <- hGetStringBuffer fp' - parseResult <- myParseModule dynFlags fp' (Just stringBuffer) - let newModD = moduleDescr{mbSourcePathMD = mbfp} - case parseResult of - Right (L _ (HsModule _ _ _ decls _ _ _ )) -> do - let map' = convertToMap (idDescriptionsMD newModD) - let commentedDecls = addComments (filterSignatures decls) - let (descrs,restMap) = foldl collectParseInfoForDecl ([],map') - commentedDecls - let newModD' = newModD{ - idDescriptionsMD = reverse descrs ++ concat (Map.elems restMap)} - return(newModD' : moduleDescrs, failureCount) - Left errMsg -> do - sysMessage Normal $ "Failed to parse " ++ fp - printBagOfErrors defaultDynFlags (unitBag errMsg) - return (newModD : moduleDescrs, failureCount+1) - where - convertToMap :: [Descr] -> Map Symbol [Descr] - convertToMap list = - foldl' (\ st idDescr -> Map.insertWith (++) (descrName idDescr) [idDescr] st) - Map.empty list - convertFromMap :: Map Symbol [Descr] -> [Descr] - convertFromMap = concat . Map.elems - - -filterSignatures :: [LHsDecl RdrName] -> [LHsDecl RdrName] -filterSignatures declList = filter filterSignature declList - where - filterSignature (L srcDecl (SigD _)) = False - filterSignature _ = True - -addComments :: [LHsDecl RdrName] -> [(Maybe (LHsDecl RdrName), Maybe String)] -addComments = reverse . snd . foldl' addComment (Nothing,[]) - where - addComment :: (Maybe String,[(Maybe (LHsDecl RdrName),Maybe String)]) - -> LHsDecl RdrName - -> (Maybe String,[(Maybe (LHsDecl RdrName),Maybe String)]) - addComment (maybeComment,((Just decl,Nothing):r)) (L srcDecl (DocD (DocCommentPrev doc))) = - (Nothing,((Just decl,Just (printHsDoc doc)):r)) - addComment other (L srcDecl (DocD (DocCommentPrev doc))) = - other - addComment (maybeComment,resultList) (L srcDecl (DocD (DocCommentNext doc))) = - (Just (printHsDoc doc),resultList) - addComment (maybeComment,resultList) (L srcDecl (DocD (DocGroup i doc))) = - (Nothing,(((Nothing,Just (printHsDoc doc)): resultList))) - addComment (maybeComment,resultList) (L srcDecl (DocD (DocCommentNamed str doc))) = - (Nothing,resultList) - addComment (Nothing,resultList) decl = (Nothing,(Just decl,Nothing):resultList) - addComment (Just comment,resultList) decl = (Nothing,(Just decl,Just comment):resultList) - -collectParseInfoForDecl :: ([Descr],SymbolTable) - -> (Maybe (LHsDecl RdrName),Maybe String) - -> ([Descr],SymbolTable) -collectParseInfoForDecl (l,st) (Just (L loc _),_) | not (isGoodSrcSpan loc) = (l,st) -collectParseInfoForDecl (l,st) ((Just (L loc (ValD (FunBind lid _ _ _ _ _)))), mbComment') - = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Variable] [] -collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TyData _ _ lid _ _ _ _ _)))), mbComment') - = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Data] [] -collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TyFamily _ lid _ _)))), mbComment') - = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [] [] -collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TySynonym lid _ _ _)))), mbComment') - = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Type] [] -collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (ClassDecl _ lid _ _ _ _ _ _ )))), mbComment') - = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Class] [] -collectParseInfoForDecl (l,st) ((Just (L loc (InstD (InstDecl lid binds sigs cldecl)))), mbComment') - = case unLoc lid of - HsForAllTy _ _ _ e -> - case unLoc e of - HsPredTy p -> - case p of - HsClassP n types - -> --trace ("name: " ++ unpackFS (occNameFS (rdrNameOcc n)) ++ "\n" ++ - --"binds : " ++ showSDocUnqual (ppr binds) ++ "\n" ++ - --"sigs : " ++ showSDocUnqual (ppr sigs) ++ "\n" ++ - --"cldecl : " ++ showSDocUnqual (ppr cldecl) ++ "\n" ++ - -- "types : " ++ showSDocUnqual (ppr types)) $ - addLocationAndComment (l,st) n loc mbComment' [Instance] - (map (\t -> analyse (unLoc t)) types) - _ -> trace ("lid3:Other") (l,st) - _ -> trace "lid2:Other" (l,st) - _ -> trace "lid:Other" (l,st) - where - analyse (HsTyVar n) = unpackFS (occNameFS (rdrNameOcc n)) - analyse (HsForAllTy n _ _ _) = trace "lid5:For all" "" - analyse _ = trace "lid5:Other" "" -collectParseInfoForDecl (l,st) (Just decl,mbComment') - = {--trace (declTypeToString (unLoc decl) ++ "--" ++ (showSDocUnqual $ppr decl))--} (l,st) -collectParseInfoForDecl (l,st) (Nothing, mbComment') = - {--trace ("Found comment " ++ show mbComment')--} (l,st) - - -addLocationAndComment :: ([Descr],SymbolTable) - -> RdrName - -> SrcSpan - -> Maybe String - -> [DescrType] - -> [String] - -> ([Descr],SymbolTable) -addLocationAndComment (l,st) lid srcSpan mbComment' types insts = - let occ = rdrNameOcc lid - name = unpackFS (occNameFS occ) - mbItems = Map.lookup name st - (mbItem,nst)= case mbItems of - Nothing -> (Nothing,st) - - Just [i] -> (Just i, Map.delete name st) - Just list -> - case filter (\i -> matches i types insts) list of - [] -> (Nothing,st) - l' -> (Just (head l'), - Map.adjust (\li -> delete (head l') li) - name st) - in case mbItem of - Just identDescr |not (isReexported identDescr) -> (identDescr{ - mbLocation' = Just (srcSpanToLocation srcSpan), - mbComment' = case mbComment' of - Nothing -> Nothing - Just s -> Just (BS.pack s)} - : l, nst) - otherwise -> (l,st) - - where - matches :: Descr -> [DescrType] -> [String] -> Bool - matches idDescr idTypes inst = - case descrType (details idDescr) of - Instance -> - --trace ("instances " ++ show (sort (binds idDescr)) ++ " -- ?= -- " ++ show (sort inst)) $ - elem Instance idTypes && sort (binds (details idDescr)) == sort inst - other -> elem other idTypes - -declTypeToString :: Show alpha => HsDecl alpha -> String -declTypeToString (TyClD _) = "TyClD" -declTypeToString (InstD _) = "InstD" -declTypeToString (DerivD _) = "DerivD" -declTypeToString (ValD _) = "ValD" -declTypeToString (SigD _) = "SigD" -declTypeToString (DefD _) = "DefD" -declTypeToString (ForD _) = "ForD" -declTypeToString (WarningD _)= "WarnD" -declTypeToString (RuleD _) = "RuleD" -declTypeToString (SpliceD _) = "SpliceD" -declTypeToString (DocD v) = "DocD " ++ show v - -srcSpanToLocation :: SrcSpan -> Location -srcSpanToLocation span | not (isGoodSrcSpan span) - = throwIDE "srcSpanToLocation: unhelpful span" -srcSpanToLocation span - = Location (srcSpanStartLine span) (srcSpanStartCol span) - (srcSpanEndLine span) (srcSpanEndCol span) - -printHsDoc :: Show alpha => HsDoc alpha -> String -printHsDoc d = show (PPDoc d) - -newtype PPDoc alpha = PPDoc (HsDoc alpha) - -instance Show alpha => Show (PPDoc alpha) where - showsPrec _ (PPDoc DocEmpty) = id - showsPrec _ (PPDoc (DocAppend l r)) = shows (PPDoc l) . shows (PPDoc r) - showsPrec _ (PPDoc (DocString str)) = showString str - showsPrec _ (PPDoc (DocParagraph d)) = shows (PPDoc d) . showChar '\n' - showsPrec _ (PPDoc (DocIdentifier l)) = foldr (\i f -> showChar '\'' . shows i . showChar '\'') id l - showsPrec _ (PPDoc (DocModule str)) = showChar '"' . showString str . showChar '"' - showsPrec _ (PPDoc (DocEmphasis doc)) = showChar '/' . shows (PPDoc doc) . showChar '/' - showsPrec _ (PPDoc (DocMonospaced doc)) = showChar '@' . shows (PPDoc doc) . showChar '@' - showsPrec _ (PPDoc (DocUnorderedList l)) = - foldr (\s r -> showString "* " . shows (PPDoc s) . showChar '\n' . r) id l - showsPrec _ (PPDoc (DocOrderedList l)) = - foldr (\(i,n) f -> shows n . showSpace . shows (PPDoc i)) id (zip l [1 .. length l]) - showsPrec _ (PPDoc (DocDefList li)) = - foldr (\(l,r) f -> showString "[@" . shows (PPDoc l) . showString "[@ " . shows (PPDoc r) . f) id li - showsPrec _ (PPDoc (DocCodeBlock doc)) = showChar '@' . shows (PPDoc doc) . showChar '@' - showsPrec _ (PPDoc (DocURL str)) = showChar '<' . showString str . showChar '>' - showsPrec _ (PPDoc (DocAName str)) = showChar '#' . showString str . showChar '#' - showsPrec _ (PPDoc _) = id - -instance Show RdrName where - show = unpackFS . occNameFS . rdrNameOcc - -instance Show alpha => Show (DocDecl alpha) where - show (DocCommentNext doc) = "DocCommentNext " ++ show doc - show (DocCommentPrev doc) = "DocCommentPrev " ++ show doc - show (DocCommentNamed str doc) = "DocCommentNamed" ++ " " ++ str ++ " " ++ show doc - show (DocGroup i doc) = "DocGroup" ++ " " ++ show i ++ " " ++ show doc - -unloadGhc :: Ghc () -unloadGhc = do - setTargets [] - load LoadAllTargets - return () - - --- --------------------------------------------------------------------- --- Function to map packages to file paths --- - -getSourcesMap :: Prefs -> IO (Map PackageIdentifier [FilePath]) -getSourcesMap prefs = do - mbSources <- parseSourceForPackageDB - case mbSources of - Just map -> return map - Nothing -> do - buildSourceForPackageDB prefs - mbSources <- parseSourceForPackageDB - case mbSources of - Just map -> do - return map - Nothing -> throwIDE "can't build/open source for package file" - -sourceForPackage :: PackageIdentifier - -> (Map PackageIdentifier [FilePath]) - -> Maybe FilePath -sourceForPackage id map = - case id `Map.lookup` map of - Just (h:_) -> Just h - _ -> Nothing - -buildSourceForPackageDB :: Prefs -> IO () -buildSourceForPackageDB prefs = do - case autoExtractTars prefs of - Nothing -> return () - Just path -> do - dir <- getCurrentDirectory - autoExtractTarFiles path - setCurrentDirectory dir - let dirs = sourceDirectories prefs - cabalFiles <- mapM allCabalFiles dirs - fCabalFiles <- mapM canonicalizePath $ concat cabalFiles - mbPackages <- mapM (\fp -> parseCabal fp) fCabalFiles - let pdToFiles = Map.fromListWith (++) - $ map (\(Just p,o ) -> (p,o)) - $ filter (\(mb, _) -> case mb of - Nothing -> False - _ -> True ) - $ zip mbPackages (map (\a -> [a]) fCabalFiles) - filePath <- getConfigFilePathForSave "source_packages.txt" - writeFile filePath (PP.render (showSourceForPackageDB pdToFiles)) - -showSourceForPackageDB :: Map String [FilePath] -> PP.Doc -showSourceForPackageDB aMap = PP.vcat (map showIt (Map.toList aMap)) - where - showIt :: (String,[FilePath]) -> PP.Doc - showIt (pd,list) = (foldl' (\l n -> l PP.$$ (PP.text $ show n)) label list) - PP.<> PP.char '\n' - where label = PP.text pd PP.<> PP.colon - -parseSourceForPackageDB :: IO (Maybe (Map PackageIdentifier [FilePath])) -parseSourceForPackageDB = do - filePath <- getConfigFilePathForLoad "source_packages.txt" - exists <- doesFileExist filePath - if exists - then do - res <- parseFromFile sourceForPackageParser filePath - case res of - Left pe -> do - sysMessage Normal $"Error reading source packages file " - ++ filePath ++ " " ++ show pe - return Nothing - Right r -> return (Just r) - else do - sysMessage Normal $"No source packages file found: " ++ filePath - return Nothing - ----- Returns the package name as a string (e.g. ohohoh-0.1.0) ---parseCabal :: FilePath -> IO (Maybe String) ---parseCabal cabalPath = gcatch (do --- gpd <- readPackageDescription silent cabalPath --- return (Just ((display . package . packageDescription) gpd))) --- $ \ (e :: SomeException) -> do --- sysMessage Normal ("SourceCollector>>parseCabal:Can't parse cabal " ++ show e) --- return Nothing --- --- --------------------------------------------------------------------- --- | Parser for Package DB --- -packageStyle :: P.LanguageDef st -packageStyle = emptyDef - { P.commentStart = "{-" - , P.commentEnd = "-}" - , P.commentLine = "--" - } - -lexer = P.makeTokenParser packageStyle -whiteSpace = P.whiteSpace lexer -symbol = P.symbol lexer - -sourceForPackageParser :: CharParser () (Map PackageIdentifier [FilePath]) -sourceForPackageParser = do - whiteSpace - ls <- many onePackageParser - whiteSpace - eof - return (Map.fromList (catMaybes ls)) - "sourceForPackageParser" - -onePackageParser :: CharParser () (Maybe (PackageIdentifier,[FilePath])) -onePackageParser = do - mbPd <- packageDescriptionParser - filePaths <- many filePathParser - case mbPd of - Nothing -> return Nothing - Just pd -> return (Just (pd,filePaths)) - "onePackageParser" - -packageDescriptionParser :: CharParser () (Maybe PackageIdentifier) -packageDescriptionParser = try (do - whiteSpace - str <- many (noneOf ":") - char ':' - return (toPackageIdentifier str)) - "packageDescriptionParser" - -filePathParser :: CharParser () FilePath -filePathParser = try (do - whiteSpace - char '"' - str <- many (noneOf ['"']) - char '"' - return (str)) - "filePathParser" - -parseCabal :: FilePath -> IO (Maybe String) -parseCabal fn = do - --putStrLn $ "Now parsing minimal " ++ fn - res <- parseFromFile cabalMinimalParser fn - case res of - Left pe -> do - sysMessage Normal $"Error reading cabal file " ++ show fn ++ " " ++ show pe - return Nothing - Right r -> do - sysMessage Normal r - return (Just r) - -cabalMinimalParser :: CharParser () String -cabalMinimalParser = do - r1 <- cabalMinimalP - r2 <- cabalMinimalP - case r1 of - Left v -> do - case r2 of - Right n -> return (n ++ "-" ++ v) - Left _ -> unexpected "Illegal cabal" - Right n -> do - case r2 of - Left v -> return (n ++ "-" ++ v) - Right _ -> unexpected "Illegal cabal" - -cabalMinimalP :: CharParser () (Either String String) -cabalMinimalP = - do try $(symbol "name:" <|> symbol "Name:") - whiteSpace - name <- (many $noneOf " \n") - (many $noneOf "\n") - char '\n' - return (Right name) - <|> do - try $(symbol "version:" <|> symbol "Version:") - whiteSpace - version <- (many $noneOf " \n") - (many $noneOf "\n") - char '\n' - return (Left version) - <|> do - many $noneOf "\n" - char '\n' - cabalMinimalP - "cabal minimal" - - - diff --git a/src/IDE/NotebookFlipper.hs b/src/IDE/NotebookFlipper.hs --- a/src/IDE/NotebookFlipper.hs +++ b/src/IDE/NotebookFlipper.hs @@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.NotebookFlipper --- Copyright : 2007-2009 Hamish Mackenzie, Jürgen Nicklisch-Franken +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : @@ -18,12 +18,10 @@ ) where import Graphics.UI.Gtk -import Graphics.UI.Frame.Panes (IDEPane(..)) import IDE.Core.State import Control.Monad.Trans (liftIO) import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Control.Monad (when) -import Graphics.UI.Frame.Panes (makeActive) import IDE.Pane.SourceBuffer(recentSourceBuffers) flipDown :: IDEAction diff --git a/src/IDE/Package.hs b/src/IDE/Package.hs --- a/src/IDE/Package.hs +++ b/src/IDE/Package.hs @@ -21,7 +21,8 @@ , packageOpenThis , packageNew , packageConfig -, packageBuild +, buildPackage + , packageDoc , packageClean , packageCopy @@ -29,9 +30,9 @@ , activatePackage , deactivatePackage , getActivePackage -, belongsToActivePackage -- :: FilePath -> IDEM Bool , packageInstall +, packageInstall' , packageRegister , packageUnregister , packageTest @@ -47,6 +48,9 @@ , debugStart , debugToggled +, choosePackageFile + +, idePackageFromPath ) where import Graphics.UI.Gtk @@ -58,40 +62,33 @@ import Distribution.Verbosity import System.FilePath import Control.Concurrent -import System.Directory - (doesFileExist, setCurrentDirectory) +import System.Directory (setCurrentDirectory, doesFileExist) import Prelude hiding (catch) import Data.Maybe (isJust, fromJust) import Control.Exception (SomeException(..), catch) +import Paths_leksah import IDE.Core.State +import IDE.Utils.GUIUtils import IDE.Pane.PackageEditor import IDE.Pane.SourceBuffer -import IDE.Pane.PackageFlags +import IDE.Pane.PackageFlags (readFlags) import Distribution.Text (display) -import IDE.FileUtils - (moduleNameFromFilePath', isSubPath, getConfigFilePathForLoad) +import IDE.Utils.FileUtils(getConfigFilePathForLoad) import IDE.LogRef import IDE.Debug import MyMissing (replace) import Distribution.ModuleName (ModuleName(..)) -import Data.List (nub, foldl') +import Data.List (isInfixOf, nub, foldl') import qualified System.IO.UTF8 as UTF8 (readFile) -import IDE.Tool (ToolOutput(..), runTool, newGhci, ToolState(..)) +import IDE.Utils.Tool (ToolOutput(..), runTool, newGhci, ToolState(..)) +import Debug.Trace (trace) #if defined(mingw32_HOST_OS) || defined(__MINGW32__) -import System.Process (getProcessExitCode, ProcessHandle(..)) import Data.Maybe (isNothing) -import GHC.ConsoleHandler (Handler(..), installHandler) import System.Win32 - (th32SnapEnumProcesses, - DWORD(..), - cTRL_BREAK_EVENT, - generateConsoleCtrlEvent, - tH32CS_SNAPPROCESS, - withTh32Snap) -import System.Process.Internals - (withProcessHandle, ProcessHandle__(..)) + (DWORD(..)) +import System.Process (getProcessExitCode) #else import System.Posix (getGroupProcessStatus, @@ -104,12 +101,12 @@ #endif -- Leave at least one import ofter this #endif -- so the auto import tool does not add stuf insied the -import IDE.Metainfo.Provider - (rebuildActiveInfo) -import qualified Data.Set as Set (member, fromList) -import qualified Data.Map as Map (empty, insert, lookup) -import IDE.SourceCandy (getCandylessText) +import qualified Data.Set as Set (fromList) +import qualified Data.Map as Map (empty) +import System.Exit (ExitCode(..)) + + #if defined(mingw32_HOST_OS) || defined(__MINGW32__) foreign import stdcall unsafe "winbase.h GetCurrentProcessId" c_GetCurrentProcessId :: IO DWORD @@ -118,8 +115,21 @@ c_GetProcessId :: DWORD -> IO DWORD #endif +#if MIN_VERSION_Cabal(1,8,0) +myLibModules pd = case library pd of + Nothing -> [] + Just l -> libModules l +myExeModules pd = concatMap exeModules (executables pd) +#else +myLibModules pd = libModules pd +myExeModules pd = exeModules pd +#endif + packageNew :: IDEAction -packageNew = packageNew' (\fp -> activatePackage fp >> return ()) +packageNew = packageNew' (\fp -> do + triggerEventIDE (WorkspaceAddPackage fp) + mbPack <- idePackageFromPath fp + activatePackage mbPack) packageOpen :: IDEAction packageOpen = packageOpenThis Nothing @@ -134,11 +144,7 @@ return () getActivePackage :: IDEM (Maybe IDEPackage) -getActivePackage = do - active <- readIDE activePack - case active of - Just p -> return (Just p) - Nothing -> selectActivePackage Nothing +getActivePackage = readIDE activePack selectActivePackage :: Maybe FilePath -> IDEM (Maybe IDEPackage) selectActivePackage mbFilePath' = do @@ -148,232 +154,167 @@ Just fp -> return (Just fp) case mbFilePath of Nothing -> return Nothing - Just filePath -> do - let ppath = dropFileName filePath - exists <- liftIO $ doesFileExist (ppath "IDE.session") - wantToLoadSession <- - if exists - then liftIO $ do - md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo - $ "Load the session settings stored with this project?" - rid <- dialogRun md - widgetDestroy md - case rid of - ResponseYes -> return True - otherwise -> return False - else return False - if wantToLoadSession - then do - triggerEventIDE (LoadSession (ppath "IDE.session")) - readIDE activePack - else activatePackage filePath - -activatePackage :: FilePath -> IDEM (Maybe IDEPackage) -activatePackage filePath = do - let ppath = dropFileName filePath - mbPackageD <- reifyIDE (\ideR -> catch (do - liftIO $ setCurrentDirectory ppath - pd <- readPackageDescription normal filePath - return (Just (flattenPackageDescription pd))) - (\(e :: SomeException) -> do - reflectIDE (ideMessage Normal ("Can't activate package " ++(show e))) ideR - return Nothing)) - case mbPackageD of - Nothing -> return (Nothing) - Just packageD -> do - let modules = Set.fromList $ libModules packageD ++ exeModules packageD - let files = Set.fromList $ extraSrcFiles packageD ++ map modulePath (executables packageD) - let srcDirs = nub $ concatMap hsSourceDirs (allBuildInfo packageD) - let packp = IDEPackage (package packageD) filePath (buildDepends packageD) modules - files srcDirs [] [] [] [] [] [] [] [] - pack <- (do - flagFileExists <- liftIO $ doesFileExist (ppath "IDE.flags") - if flagFileExists - then liftIO $ readFlags (ppath "IDE.flags") packp - else return packp) - modifyIDE_ (\ide -> ide{activePack = (Just pack), projFilesCache = Map.empty}) - ide <- getIDE - triggerEventIDE ActivePack - triggerEventIDE (Sensitivity [(SensitivityProjectActive,True)]) - sb <- getSBActivePackage - liftIO $ statusbarPop sb 1 - liftIO $ statusbarPush sb 1 (display $ packageId pack) - removeRecentlyUsedPackage filePath - return (Just pack) - + Just filePath -> idePackageFromPath filePath >>= (\ p -> activatePackage p >> return p) -belongsToActivePackage :: IDEBuffer -> IDEM Bool -belongsToActivePackage ideBuf = - case fileName ideBuf of - Nothing -> return False - Just fp -> do - projFilesCache' <- readIDE projFilesCache - activePack' <- readIDE activePack - case Map.lookup fp projFilesCache' of - Just b -> return b - Nothing -> case activePack' of - Nothing -> return False - Just pack -> let basePath = dropFileName $ cabalFile pack in do - r <- if isSubPath basePath fp - then - let srcPaths = map (\srcP -> basePath srcP) (srcDirs pack) - relPaths = map (\p -> makeRelative p fp) srcPaths in - if or (map (\p -> Set.member p (extraSrcs pack)) relPaths) - then return True - else do - -- do - gtkbuf <- liftIO $ textViewGetBuffer (sourceView ideBuf) - candy <- readIDE candy - text <- liftIO $ getCandylessText candy gtkbuf - mbMn <- liftIO $ moduleNameFromFilePath' fp text - case mbMn of - Nothing -> return False - Just mn -> return (Set.member mn (modules pack)) - else return False - modifyIDE_ (\ide -> ide{projFilesCache = - Map.insert fp r projFilesCache'}) - return r +activatePackage :: Maybe IDEPackage -> IDEM () +activatePackage mbPack@(Just pack) = do + modifyIDE_ (\ide -> ide{activePack = mbPack}) + liftIO $ setCurrentDirectory (dropFileName (ipdCabalFile pack)) + triggerEventIDE (ActivePack mbPack) + triggerEventIDE (Sensitivity [(SensitivityProjectActive,True)]) + mbWs <- readIDE workspace + let wsStr = case mbWs of + Nothing -> "" + Just ws -> wsName ws + let txt = wsStr ++ " > " ++ packageIdentifierToString (ipdPackageId pack) + triggerEventIDE (StatusbarChanged [CompartmentPackage txt]) + return () +activatePackage Nothing = return () deactivatePackage :: IDEAction deactivatePackage = do oldActivePack <- readIDE activePack - when (isJust oldActivePack) $ do - triggerEventIDE (SaveSession - ((dropFileName . cabalFile . fromJust) oldActivePack "IDE.session")) - addRecentlyUsedPackage ((cabalFile . fromJust) oldActivePack) - return () - modifyIDE_ (\ide -> ide{activePack = Nothing, projFilesCache = Map.empty}) - triggerEventIDE ActivePack + modifyIDE_ (\ide -> ide{activePack = Nothing}) + triggerEventIDE (ActivePack Nothing) when (isJust oldActivePack) $ do triggerEventIDE (Sensitivity [(SensitivityProjectActive,False)]) return () - sb <- getSBActivePackage - liftIO $ statusbarPop sb 1 - liftIO $ statusbarPush sb 1 "" + mbWs <- readIDE workspace + let wsStr = case mbWs of + Nothing -> "" + Just ws -> wsName ws + let txt = wsStr ++ ":" + triggerEventIDE (StatusbarChanged [CompartmentPackage txt]) return () packageConfig :: IDEAction -packageConfig = catchIDE (do +packageConfig = do mbPackage <- getActivePackage case mbPackage of Nothing -> return () - Just package -> do - mbPackageD <- reifyIDE (\ideR -> catch (do - reflectIDE (runExternalTool "Configuring" "runhaskell" (["Setup","configure"] - ++ (configFlags package)) logOutput) ideR - pd <- readPackageDescription normal (cabalFile package) - return (Just (flattenPackageDescription pd))) - (\(e :: SomeException) -> do - reflectIDE (ideMessage Normal (show e)) ideR - return Nothing)) - case mbPackageD of - Just packageD -> do - let modules = Set.fromList $ libModules packageD ++ exeModules packageD - let files = Set.fromList $ extraSrcFiles packageD ++ map modulePath (executables packageD) - let srcDirs = nub $ concatMap hsSourceDirs (allBuildInfo packageD) - modifyIDE_ (\ide -> ide{activePack = - Just package{depends=buildDepends packageD, modules = modules, - extraSrcs = files, srcDirs = srcDirs}}) - triggerEventIDE ActivePack - return () - Nothing -> return ()) + Just package -> packageConfig' package (return ()) + +packageConfig' :: IDEPackage -> IDEAction -> IDEAction +packageConfig' package continuation = catchIDE (do + mbPackageD <- reifyIDE (\ideR -> catch (do + let dir = dropFileName (ipdCabalFile package) + reflectIDE (runExternalTool "Configuring" "runhaskell" (["Setup","configure"] + ++ (ipdConfigFlags package)) (Just dir) logOutput) ideR + pd <- readPackageDescription normal (ipdCabalFile package) + return (Just (flattenPackageDescription pd))) + (\(e :: SomeException) -> do + reflectIDE (ideMessage Normal (show e)) ideR + return Nothing)) + case mbPackageD of + Just packageD -> + let modules = Set.fromList $ myLibModules packageD ++ myExeModules packageD + files = Set.fromList $ extraSrcFiles packageD ++ map modulePath (executables packageD) + ipdSrcDirs = nub $ concatMap hsSourceDirs (allBuildInfo packageD) + pack = Just package{ipdDepends=buildDepends packageD, ipdModules = modules, + ipdExtraSrcs = files, ipdSrcDirs = ipdSrcDirs} + in trace ("packageD :" ++ show packageD) $ do + modifyIDE_ (\ide -> ide{activePack = pack, bufferProjCache = Map.empty}) + triggerEventIDE (ActivePack pack) + continuation + return () + Nothing -> return()) -- Does not continue if config fails? (\(e :: SomeException) -> putStrLn (show e)) -runExternalTool :: String -> FilePath -> [String] -> ([ToolOutput] -> IDEAction) -> IDEAction -runExternalTool description executable args handleOutput = do - prefs <- readIDE prefs - alreadyRunning <- isRunning - unless alreadyRunning $ do - when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToActivePackage; return ()) - sb <- getSBErrors - liftIO $statusbarPop sb 1 - liftIO $statusbarPush sb 1 description - reifyIDE (\ideR -> forkIO $ do - (output, pid) <- runTool executable args - reflectIDE (do - modifyIDE_ (\ide -> ide{runningTool = Just pid}) - handleOutput output) ideR) - return () +runCabalBuild :: Bool -> IDEPackage -> Bool -> (Bool -> IDEAction) -> IDEAction +runCabalBuild backgroundBuild package shallConfigure continuation = do + prefs <- readIDE prefs + let dir = dropFileName (ipdCabalFile package) + let args = (["Setup","build"] ++ + if ((not backgroundBuild) || (backgroundLink prefs)) + then [] + else ["--ghc-options=-c", "--with-ar=true", "--with-ld=true"] + ++ ipdBuildFlags package) + runExternalTool "Building" "runhaskell" args (Just dir) $ \output -> do + logOutputForBuild dir backgroundBuild output + errs <- readIDE errorRefs + if shallConfigure && isConfigError output + then + packageConfig' package (runCabalBuild backgroundBuild package False continuation) + else do + continuation (last output == ToolExit ExitSuccess && not (any isError errs)) + return () -runCabalBuild :: Bool -> IDEPackage -> IDEAction -runCabalBuild backgroundBuild package = do - prefs <- readIDE prefs - let args = (["Setup","build"] ++ - if ((not backgroundBuild) || (backgroundLink prefs)) - then [] - else ["--ghc-options=-c", "--with-ar=true", "--with-ld=true"] - ++ buildFlags package) - runExternalTool "Building" "runhaskell" args $ \output -> do - logOutputForBuild backgroundBuild output - errs <- readIDE errorRefs - when ((not backgroundBuild) - && (collectAfterBuild prefs) - && (not (any isError errs))) $ do - ideMessage Normal "Update meta info for active package" - rebuildActiveInfo +isConfigError :: [ToolOutput] -> Bool +isConfigError = or . (map isCErr) + where + isCErr (ToolError str) = str1 `isInfixOf` str || str2 `isInfixOf` str + isCErr _ = False + str1 = "Run the 'configure' command first" + str2 = "please re-configure" -packageBuild :: Bool -> IDEAction -packageBuild backgroundBuild = catchIDE (do - mbPackage <- if backgroundBuild - then readIDE activePack - else getActivePackage - ideR <- ask - prefs <- readIDE prefs - case mbPackage of - Nothing -> return () - Just package -> do - modified <- if saveAllBeforeBuild prefs - then fileCheckAll belongsToActivePackage - else return False - when (not backgroundBuild || modified) $ do - maybeGhci <- readIDE ghciState - case maybeGhci of - Nothing -> do - alreadyRunning <- isRunning - if alreadyRunning - then do - interruptBuild - when (not backgroundBuild) $ liftIO $ do - timeoutAddFull (do - reflectIDE (do packageBuild False; return False) ideR - return False) priorityDefaultIdle 100 - return () - else runCabalBuild backgroundBuild package - Just ghci -> do - ready <- liftIO $ isEmptyMVar (currentToolCommand ghci) - when ready $ do - when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToActivePackage; return ()) - executeDebugCommand ":reload" $ logOutputForBuild backgroundBuild - ) - (\(e :: SomeException) -> putStrLn (show e)) +-- TODO Care for metadata + +buildPackage :: Bool -> IDEPackage -> (Bool -> IDEAction) -> IDEAction +buildPackage backgroundBuild package continuation = catchIDE (do + ideR <- ask + prefs <- readIDE prefs + maybeGhci <- readIDE ghciState + case maybeGhci of + Nothing -> do + alreadyRunning <- isRunning + if alreadyRunning + then do + interruptBuild + when (not backgroundBuild) $ liftIO $ do + timeoutAddFull (do + reflectIDE (do buildPackage backgroundBuild package continuation; return False) ideR + return False) priorityDefaultIdle 1000 + return () + else runCabalBuild backgroundBuild package True continuation + Just ghci -> do + ready <- liftIO $ isEmptyMVar (currentToolCommand ghci) + when ready $ do + let dir = dropFileName (ipdCabalFile package) + when (saveAllBeforeBuild prefs) (do fileSaveAll belongsToWorkspace; return ()) + executeDebugCommand ":reload" $ logOutputForBuild dir backgroundBuild + ) + (\(e :: SomeException) -> sysMessage Normal (show e)) + +--buildAndConfigPackage :: Bool -> IDEPackage -> (Bool -> IDEAction) -> IDEAction +--buildAndConfigPackage backgroundBuild package continuation = buildPackage backgroundBuild package continuation + packageDoc :: IDEAction packageDoc = catchIDE (do mbPackage <- getActivePackage case mbPackage of Nothing -> return () - Just package -> runExternalTool "Documenting" "runhaskell" (["Setup","haddock"] - ++ (haddockFlags package)) logOutput) + Just package -> let dir = dropFileName (ipdCabalFile package) + in runExternalTool "Documenting" "runhaskell" (["Setup","haddock"] + ++ (ipdHaddockFlags package)) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) -packageClean :: IDEAction -packageClean = do +packageClean :: Maybe IDEPackage -> IDEAction +packageClean Nothing = do mbPackage <- getActivePackage case mbPackage of Nothing -> return () - Just package -> runExternalTool "Cleaning" "runhaskell" ["Setup","clean"] logOutput + Just package -> packageClean' package +packageClean (Just package) = packageClean' package +packageClean' :: IDEPackage -> IDEAction +packageClean' package = + let dir = dropFileName (ipdCabalFile package) + in runExternalTool "Cleaning" "runhaskell" ["Setup","clean"] (Just dir) logOutput + packageCopy :: IDEAction packageCopy = catchIDE (do mbPackage <- getActivePackage - mbDir <- chooseDir "Select the target directory" + window <- getMainWindow + mbDir <- liftIO $ chooseDir window "Select the target directory" Nothing case mbDir of Nothing -> return () Just fp -> case mbPackage of Nothing -> return () - Just package -> runExternalTool "Copying" "runhaskell" (["Setup","copy"] - ++ ["--destdir=" ++ fp]) logOutput) + Just package -> let dir = dropFileName (ipdCabalFile package) + in runExternalTool "Copying" "runhaskell" (["Setup","copy"] + ++ ["--destdir=" ++ fp]) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) packageRun :: IDEAction @@ -384,33 +325,39 @@ case mbPackage of Nothing -> return () Just package -> do - pd <- liftIO $ readPackageDescription normal (cabalFile package) >>= return . flattenPackageDescription + pd <- liftIO $ readPackageDescription normal (ipdCabalFile package) >>= return . flattenPackageDescription case maybeGhci of Nothing -> do case executables pd of (Executable name _ _):_ -> do let path = "dist/build" name name - runExternalTool ("Running "++name) path (exeFlags package) logOutput + let dir = dropFileName (ipdCabalFile package) + runExternalTool ("Running " ++ name) path (ipdExeFlags package) (Just dir) logOutput otherwise -> do sysMessage Normal "no executable in selected package" return () Just ghci -> do case executables pd of (Executable _ mainFilePath _):_ -> do - executeDebugCommand (":module " ++ (map (\c -> if c == '/' then '.' else c) (takeWhile (/= '.') mainFilePath))) logOutput - executeDebugCommand (":main " ++ (unwords (exeFlags package))) logOutput + executeDebugCommand (":module *" ++ (map (\c -> if c == '/' then '.' else c) (takeWhile (/= '.') mainFilePath))) logOutput + executeDebugCommand (":main " ++ (unwords (ipdExeFlags package))) logOutput otherwise -> do sysMessage Normal "no executable in selected package" return ()) (\(e :: SomeException) -> putStrLn (show e)) packageInstall :: IDEAction -packageInstall = catchIDE (do +packageInstall = do mbPackage <- getActivePackage case mbPackage of Nothing -> return () - Just package -> runExternalTool "Installing" "runhaskell" (["Setup","install"] - ++ (installFlags package)) logOutput) + Just package -> 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) (\ to -> logOutput to >> continuation True)) --TODO (\(e :: SomeException) -> putStrLn (show e)) packageRegister :: IDEAction @@ -418,8 +365,9 @@ mbPackage <- getActivePackage case mbPackage of Nothing -> return () - Just package -> runExternalTool "Registering" "runhaskell" (["Setup","register"] - ++ (registerFlags package)) logOutput) + Just package -> let dir = dropFileName (ipdCabalFile package) + in runExternalTool "Registering" "runhaskell" (["Setup","register"] + ++ (ipdRegisterFlags package)) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) packageUnregister :: IDEAction @@ -427,8 +375,9 @@ mbPackage <- getActivePackage case mbPackage of Nothing -> return () - Just package -> runExternalTool "Unregistering" "runhaskell" (["Setup","unregister"] - ++ (unregisterFlags package)) logOutput) + Just package -> let dir = dropFileName (ipdCabalFile package) + in runExternalTool "Unregistering" "runhaskell" (["Setup","unregister"] + ++ (ipdUnregisterFlags package)) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) packageTest :: IDEAction @@ -436,7 +385,8 @@ mbPackage <- getActivePackage case mbPackage of Nothing -> return () - Just package -> runExternalTool "Testing" "runhaskell" (["Setup","test"]) logOutput) + Just package -> let dir = dropFileName (ipdCabalFile package) + in runExternalTool "Testing" "runhaskell" (["Setup","test"]) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) packageSdist :: IDEAction @@ -444,8 +394,9 @@ mbPackage <- getActivePackage case mbPackage of Nothing -> return () - Just package -> runExternalTool "Source Dist" "runhaskell" (["Setup","sdist"] - ++ (sdistFlags package)) logOutput) + Just package -> let dir = dropFileName (ipdCabalFile package) + in runExternalTool "Source Dist" "runhaskell" (["Setup","sdist"] + ++ (ipdSdistFlags package)) (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) @@ -456,41 +407,28 @@ case mbPackage of Nothing -> return () Just package -> - let path = dropFileName (cabalFile package) + let path = dropFileName (ipdCabalFile package) "dist/doc/html" - display (pkgName (packageId package)) - display (pkgName (packageId package)) + display (pkgName (ipdPackageId package)) + display (pkgName (ipdPackageId package)) "index.html" - in runExternalTool "Opening Documentation" (browser prefs) [path] logOutput) + dir = dropFileName (ipdCabalFile package) + in runExternalTool "Opening Documentation" (browser prefs) [path] (Just dir) logOutput) (\(e :: SomeException) -> putStrLn (show e)) - -chooseDir :: String -> IDEM (Maybe FilePath) -chooseDir str = do - win <- getMainWindow - liftIO $do - dialog <- fileChooserDialogNew - (Just $ str) - (Just win) - FileChooserActionSelectFolder - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-open" - ,ResponseAccept)] - widgetShow dialog - response <- dialogRun dialog - case response of - ResponseAccept -> do - fn <- fileChooserGetFilename dialog - widgetDestroy dialog - return fn - ResponseCancel -> do - widgetDestroy dialog - return Nothing - ResponseDeleteEvent -> do - widgetDestroy dialog - return Nothing - _ -> return Nothing +runExternalTool :: String -> FilePath -> [String] -> Maybe FilePath -> ([ToolOutput] -> IDEAction) -> 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 + (output, pid) <- runTool executable args mbDir + reflectIDE (do + modifyIDE_ (\ide -> ide{runningTool = Just pid}) + handleOutput output) ideR) + return () -- --------------------------------------------------------------------- @@ -571,21 +509,24 @@ Just p -> do ideR <- ask reifyIDE (\ideR -> catch (do - pd <- readPackageDescription normal (cabalFile p) - return (Just (flattenPackageDescription pd,cabalFile p))) + pd <- readPackageDescription normal (ipdCabalFile p) + return (Just (flattenPackageDescription pd,ipdCabalFile p))) (\(e :: SomeException) -> do reflectIDE (ideMessage Normal ("Can't load package " ++(show e))) ideR return Nothing)) getModuleTemplate :: PackageDescription -> String -> IO String -getModuleTemplate pd modName = do - filePath <- getConfigFilePathForLoad "Module.template" +getModuleTemplate pd modName = catch (do + dataDir <- getDataDir + filePath <- getConfigFilePathForLoad standardModuleTemplateFilename Nothing dataDir template <- UTF8.readFile filePath return (foldl' (\ a (from, to) -> replace from to a) template [("@License@", (show . license) pd), ("@Maintainer@", maintainer pd), ("@Stability@",stability pd), ("@Portability@",""), - ("@Copyright@", copyright pd),("@ModuleName@", modName)]) + ("@Copyright@", copyright pd),("@ModuleName@", modName)])) + (\ (e :: SomeException) -> sysMessage Normal ("Couldn't read template file: " ++ show e) >> return "") + addModuleToPackageDescr :: ModuleName -> Bool -> IDEM () addModuleToPackageDescr moduleName isExposed = do active <- readIDE activePack @@ -596,7 +537,7 @@ Just p -> do ideR <- ask reifyIDE (\ideR -> catch (do - gpd <- readPackageDescription normal (cabalFile p) + gpd <- readPackageDescription normal (ipdCabalFile p) if hasConfigs gpd then do reflectIDE (ideMessage High @@ -613,7 +554,7 @@ in npd1{executables = map (\exe -> exe{buildInfo = addModToBuildInfo (buildInfo exe) moduleName}) (executables npd1)} - in writePackageDescription (cabalFile p) npd) + in writePackageDescription (ipdCabalFile p) npd) (\(e :: SomeException) -> do reflectIDE (ideMessage Normal ("Can't upade package " ++ show e)) ideR return ())) @@ -621,27 +562,6 @@ addModToBuildInfo :: BuildInfo -> ModuleName -> BuildInfo addModToBuildInfo bi mn = bi {otherModules = mn : otherModules bi} - -addRecentlyUsedPackage :: FilePath -> IDEAction -addRecentlyUsedPackage fp = do - state <- readIDE currentState - when (not $ isStartingOrClosing state) $ do - recentPackages' <- readIDE recentPackages - unless (elem fp recentPackages') $ - modifyIDE_ (\ide -> ide{recentPackages = take 12 (fp : recentPackages')}) - triggerEventIDE UpdateRecent - return () - -removeRecentlyUsedPackage :: FilePath -> IDEAction -removeRecentlyUsedPackage fp = do - state <- readIDE currentState - when (not $ isStartingOrClosing state) $ do - recentPackages' <- readIDE recentPackages - when (elem fp recentPackages') $ - modifyIDE_ (\ide -> ide{recentPackages = filter (\e -> e /= fp) recentPackages'}) - triggerEventIDE UpdateRecent - return () - backgroundBuildToggled :: IDEAction backgroundBuildToggled = do toggled <- getBackgroundBuildToggled @@ -667,8 +587,9 @@ maybeGhci <- readIDE ghciState case maybeGhci of Nothing -> do - ghci <- reifyIDE $ \ideR -> newGhci (buildFlags package) (interactiveFlags prefs') - $ \output -> reflectIDE (logOutputForBuild True output) ideR + let dir = dropFileName (ipdCabalFile package) + ghci <- reifyIDE $ \ideR -> newGhci (ipdBuildFlags package) (interactiveFlags prefs') + $ \output -> reflectIDE (logOutputForBuild dir True output) ideR modifyIDE_ (\ide -> ide {ghciState = Just ghci}) triggerEventIDE (Sensitivity [(SensitivityInterpreting, True)]) -- Fork a thread to wait for the output from the process to close @@ -678,12 +599,14 @@ modifyIDE_ (\ide -> ide {ghciState = Nothing}) triggerEventIDE (Sensitivity [(SensitivityInterpreting, False)]) -- Kick of a build if one is not already due - modified <- fileCheckAll belongsToActivePackage + modifiedPacks <- fileCheckAll belongsToPackage + let modified = not (null modifiedPacks) prefs <- readIDE prefs when ((not modified) && (backgroundBuild prefs)) $ do + -- TODO Check with Hamish what this means. mbPackage <- readIDE activePack case mbPackage of - Just package -> runCabalBuild True package + Just package -> runCabalBuild True package True (\ _ -> return ()) Nothing -> return ()) ideRef return () _ -> do @@ -697,4 +620,31 @@ if toggled then debugStart else debugQuit + +idePackageFromPath :: FilePath -> IDEM (Maybe IDEPackage) +idePackageFromPath filePath = do + mbPackageD <- reifyIDE (\ideR -> catch (do + pd <- readPackageDescription normal filePath + return (Just (flattenPackageDescription pd))) + (\ (e :: SomeException) -> do + reflectIDE (ideMessage Normal ("Can't activate package " ++(show e))) ideR + return Nothing)) + 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 ipdSrcDirs = nub $ concatMap hsSourceDirs (allBuildInfo packageD) + let exts = nub $ concatMap extensions (allBuildInfo packageD) + let packp = IDEPackage (package packageD) filePath (buildDepends packageD) modules + + mainFiles files ipdSrcDirs exts ["--user"] [] [] [] [] [] [] [] + let pfile = dropExtension filePath + pack <- (do + flagFileExists <- liftIO $ doesFileExist (pfile ++ leksahFlagFileExtension) + if flagFileExists + then liftIO $ readFlags (pfile ++ leksahFlagFileExtension) packp + else return packp) + return (Just pack) 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 @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Breakpoints --- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org @@ -17,8 +17,6 @@ module IDE.Pane.Breakpoints ( IDEBreakpoints , BreakpointsState -, showBreakpointList -, showBreakpointList' , fillBreakpointList , selectBreak ) where @@ -51,108 +49,57 @@ } deriving(Eq,Ord,Read,Show,Typeable) -instance IDEObject IDEBreakpoints - instance Pane IDEBreakpoints IDEM where primPaneName _ = "Breakpoints" getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledView paneId b = "*Breakpoints" - makeActive pane = activatePane pane [] - close = closePane instance RecoverablePane IDEBreakpoints BreakpointsState IDEM where saveState p = do return (Just BreakpointsState) recoverState pp BreakpointsState = do nb <- getNotebook pp - newPane pp nb builder - return () - -showBreakpointList :: IDEAction -showBreakpointList = trace "showBreakpointList!!" $ do - m <- trace "now get breakpoints" getBreakpoints - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeView m) - -getBreakpoints :: IDEM IDEBreakpoints -getBreakpoints = do - mbBreakpoints <- getPane - case mbBreakpoints of - Nothing -> do - pp <- getBestPathForId "*Breakpoints" - nb <- getNotebook pp - newPane pp nb builder - mbBreakpoints <- getPane - case mbBreakpoints of - Nothing -> throwIDE "Can't init breakpoints" - Just m -> return m - Just m -> return m - -showBreakpointList' :: PanePath -> IDEAction -showBreakpointList' pp = do - m <- getBreakpoints' pp - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeView m) - -getBreakpoints' :: PanePath -> IDEM IDEBreakpoints -getBreakpoints' pp = do - mbBreakpoints <- getPane - case mbBreakpoints of - Nothing -> do - layout <- getLayout - nb <- getNotebook (getBestPanePath pp layout) - newPane pp nb builder - mbBreakpoints <- getPane - case mbBreakpoints of - Nothing -> throwIDE "Can't init breakpoints" - Just m -> return m - Just m -> return m - -builder :: PanePath -> - Notebook -> - Window -> - IDERef -> - IO (IDEBreakpoints, Connections) -builder pp nb windows ideR = do - breakpoints <- treeStoreNew [] - treeView <- treeViewNew - treeViewSetModel treeView breakpoints + buildPane pp nb builder + builder pp nb windows = reifyIDE $ \ ideR -> do + breakpoints <- treeStoreNew [] + treeView <- treeViewNew + treeViewSetModel treeView breakpoints - rendererA <- cellRendererTextNew - colA <- treeViewColumnNew - treeViewColumnSetTitle colA "Location" - treeViewColumnSetSizing colA TreeViewColumnAutosize - treeViewColumnSetResizable colA True - treeViewColumnSetReorderable colA True - treeViewAppendColumn treeView colA - cellLayoutPackStart colA rendererA False - cellLayoutSetAttributes colA rendererA breakpoints - $ \row -> [cellText := showSourceSpan row] + rendererA <- cellRendererTextNew + colA <- treeViewColumnNew + treeViewColumnSetTitle colA "Location" + treeViewColumnSetSizing colA TreeViewColumnAutosize + treeViewColumnSetResizable colA True + treeViewColumnSetReorderable colA True + treeViewAppendColumn treeView colA + cellLayoutPackStart colA rendererA False + cellLayoutSetAttributes colA rendererA breakpoints + $ \row -> [cellText := showSourceSpan row] - rendererB <- cellRendererTextNew - colB <- treeViewColumnNew - treeViewColumnSetTitle colB "Breakpoints" - treeViewColumnSetSizing colB TreeViewColumnAutosize - treeViewColumnSetResizable colB True - treeViewColumnSetReorderable colB True - treeViewAppendColumn treeView colB - cellLayoutPackStart colB rendererB False - cellLayoutSetAttributes colB rendererB breakpoints - $ \row -> [ cellText := refDescription row] + rendererB <- cellRendererTextNew + colB <- treeViewColumnNew + treeViewColumnSetTitle colB "Breakpoints" + treeViewColumnSetSizing colB TreeViewColumnAutosize + treeViewColumnSetResizable colB True + treeViewColumnSetReorderable colB True + treeViewAppendColumn treeView colB + cellLayoutPackStart colB rendererB False + cellLayoutSetAttributes colB rendererB breakpoints + $ \row -> [ cellText := refDescription row] - treeViewSetHeadersVisible treeView True - selB <- treeViewGetSelection treeView - treeSelectionSetMode selB SelectionSingle - scrolledView <- scrolledWindowNew Nothing Nothing - containerAdd scrolledView treeView - scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic - let pane = IDEBreakpoints scrolledView treeView breakpoints - treeView `onButtonPress` (breakpointViewPopup ideR breakpoints treeView) - cid1 <- treeView `afterFocusIn` - (\_ -> do reflectIDE (makeActive pane) ideR ; return True) - return (pane,[ConnectC cid1]) + treeViewSetHeadersVisible treeView True + selB <- treeViewGetSelection treeView + treeSelectionSetMode selB SelectionSingle + scrolledView <- scrolledWindowNew Nothing Nothing + containerAdd scrolledView treeView + scrolledWindowSetPolicy scrolledView PolicyAutomatic PolicyAutomatic + let pane = IDEBreakpoints scrolledView treeView breakpoints + treeView `onButtonPress` (breakpointViewPopup ideR breakpoints treeView) + cid1 <- treeView `afterFocusIn` + (\_ -> do reflectIDE (makeActive pane) ideR ; return True) + return (Just pane,[ConnectC cid1]) fillBreakpointList :: IDEAction fillBreakpointList = do @@ -163,9 +110,8 @@ refs <- readIDE breakpointRefs liftIO $ do treeStoreClear (breakpoints b) - mapM_ (insertBreak (breakpoints b)) (zip refs [0..length refs]) - where - insertBreak treeStore (lr,index) = treeStoreInsert treeStore [] index lr + mapM_ (\ (lr,index) -> treeStoreInsert (breakpoints b) [] index lr) + (zip refs [0..length refs]) getSelectedBreakpoint :: TreeView -> TreeStore LogRef @@ -182,7 +128,7 @@ selectBreak :: Maybe LogRef -> IDEAction selectBreak mbLogRef = do breakRefs' <- readIDE breakpointRefs - breaks <- getBreakpoints + breaks <- forceGetPane (Right "*Breakpoints") liftIO $ do selection <- treeViewGetSelection (treeView breaks) case mbLogRef of diff --git a/src/IDE/Pane/ClassHierarchy.hs b/src/IDE/Pane/ClassHierarchy.hs deleted file mode 100644 --- a/src/IDE/Pane/ClassHierarchy.hs +++ /dev/null @@ -1,900 +0,0 @@ -{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances - -XScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Pane.ClassHierarchy --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- | The pane of ide where modules are presented in tree form with their --- packages and exports --- -------------------------------------------------------------------------------- - -module IDE.Pane.ClassHierarchy ( - IDEClassHierarchy(..) -, ClassHierarchyState(..) -, showClasses ---, showInstances -, selectClass ---, reloadKeepSelection -) where - -import Graphics.UI.Gtk hiding (get) -import Data.Maybe -import Control.Monad.Reader -import qualified Data.Map as Map -import Data.Tree -import Data.List -import Data.Typeable -import Prelude hiding (catch) - - -import IDE.Core.State - --- | A modules pane description --- - -data IDEClassHierarchy = IDEClassHierarchy { - outer :: VBox -, paned :: HPaned -, treeView :: TreeView -, treeStore :: TreeStore ClassWrapper ---, facetView :: TreeView ---, facetStore :: TreeStore FacetWrapper -, localScopeB :: RadioButton -, packageScopeB :: RadioButton -, worldScopeB :: RadioButton -, blacklistB :: CheckButton -} deriving Typeable - -data ClassHierarchyState = ClassHierarchyState Int (Scope,Bool) - (Maybe String, Maybe String) - deriving(Eq,Ord,Read,Show,Typeable) - -instance IDEObject IDEClassHierarchy - -instance Pane IDEClassHierarchy IDEM - where - primPaneName _ = "ClassHierarchy" - getAddedIndex _ = 0 - getTopWidget = castToWidget . outer - paneId b = "*ClassHierarchy" - makeActive p = activatePane p [] - close = closePane - -instance RecoverablePane IDEClassHierarchy ClassHierarchyState IDEM where - saveState p = return Nothing - recoverState pp _ = return () - -{-- -instance RecoverablePane IDEClassHierarchy ClassHierarchyState where - saveState p = do - (IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules - sc <- getScope - mbModules <- getPane - case mbModules of - Nothing -> return Nothing - Just p -> liftIO $ do - i <- panedGetPosition (paned p) - mbTreeSelection <- getSelectionTree treeView treeStore - mbFacetSelection <- getSelectionFacet facetView facetStore - let mbs = (case mbTreeSelection of - Nothing -> Nothing - Just (_,[]) -> Nothing - Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), - case mbFacetSelection of - Nothing -> Nothing - Just fw -> Just (symbolFromFacetWrapper fw)) - return (Just (ModulesState i sc mbs)) - recoverState pp (ModulesState i sc@(scope,useBlacklist) se) = do - nb <- getNotebook pp - initModules pp nb - mod@(IDEModules _ _ treeView treeStore facetView facetStore lb pb wb blb) - <- getModules - case scope of - Local -> liftIO $ toggleButtonSetActive lb True - Package -> liftIO $ toggleButtonSetActive pb True - World -> liftIO $ toggleButtonSetActive wb True - liftIO $ toggleButtonSetActive blb useBlacklist - liftIO $ panedSetPosition (paned mod) i - fillModulesList sc - selectNames se ---} - - -selectClass :: Descr -> IDEAction -selectClass d@(Descr descrName _ descrModu _ _ details) = - case details of - (ClassDescr _ _)-> selectClass' (modu descrModu) descrName - _ -> return () -selectClass _ = return () - -selectClass' moduleName symbol = return () -{-- -selectClass' :: ModuleIdentifier -> Symbol -> IDEAction -selectClass' moduleName symbol = - let nameArray = breakAtDots [] moduleName - in do - mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules - mbTree <- liftIO $ treeStoreGetTreeSave treeStore [] - case treePathFromNameArray mbTree nameArray [] of - Just treePath -> liftIO $ do - treeViewExpandToPath treeView treePath - sel <- treeViewGetSelection treeView - treeSelectionSelectPath sel treePath - col <- treeViewGetColumn treeView 0 - treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3)) - mbFacetTree <- treeStoreGetTreeSave facetStore [] - selF <- treeViewGetSelection facetView - case findPathFor symbol mbFacetTree of - Nothing -> sysMessage Normal "no path found" - Just path -> do - treeSelectionSelectPath selF path - col <- treeViewGetColumn facetView 0 - treeViewScrollToCell facetView path (fromJust col) (Just (0.3,0.3)) - bringPaneToFront mods - Nothing -> return () ---} - -showClasses :: IDEAction -showClasses = do - m <- getClassHierarchy - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeView m) - ---showInstances :: IDEAction ---showInstances = do --- m <- getClassHierarchy --- liftIO $ bringPaneToFront m --- liftIO $ widgetGrabFocus (facetView m) - -getClassHierarchy :: IDEM IDEClassHierarchy -getClassHierarchy = do - mbCH <- getPane - case mbCH of - Nothing -> do - pp <- getBestPathForId "*ClassHierarchy" - nb <- getNotebook pp - ci <- readIDE currentInfo - newPane pp nb (builder ci) - mbCH <- getPane - case mbCH of - Nothing -> throwIDE "Can't init class hierarchy" - Just m -> return m - Just m -> return m - -type ClassHierarchy = Forest ClassWrapper -type ClassWrapper = (Symbol, [Symbol], Descr) - --- --- | Make a Tree with a class hierarchy for display. --- -buildClassHierarchyTree :: (PackageScope,PackageScope) -> ClassHierarchy -buildClassHierarchyTree ((_,sc1),(_,sc2)) = - let allClasses = nub - $ filter isClassDescr - $ concat (Map.elems sc1) - ++ concat (Map.elems sc2) - wrappers = map asClassWrapper allClasses - (basics,other) = partition (\(_,sc,_) -> null sc) wrappers - basicForest = map (\ n -> Node n []) basics - resultForest = insertInForest basicForest other - in sortForest resultForest - where - insertInForest :: ClassHierarchy -> [ClassWrapper] -> ClassHierarchy - insertInForest basicForest [] = basicForest - insertInForest basicForest other = - let (newForest,rest) = foldl' insertInForest' (basicForest,[]) other - in if length rest >= length other - then throwIDE "ClassHierarchy>>buildClassHierarchyTree: Can't build tree" - else insertInForest newForest rest - - insertInForest' :: (ClassHierarchy,[ClassWrapper]) -> ClassWrapper - -> (ClassHierarchy,[ClassWrapper]) - insertInForest' (forest,rest) wrap@(id,superList,idDescr) = - let (newForest,newSuperList) = foldl' (insertInForest2 wrap) - (forest, []) superList - in if null newSuperList - then (newForest,rest) - else (newForest,(id,newSuperList,idDescr): rest) - - insertInForest2 :: ClassWrapper -> (ClassHierarchy,[String]) -> String - -> (ClassHierarchy,[String]) - insertInForest2 wrapper (forest,rest) super = - let (newForest,success) = foldl' (insertInTree wrapper super) ([],False) forest - in if success - then (newForest,rest) - else (newForest, super : rest) - - insertInTree :: ClassWrapper -> String -> (ClassHierarchy,Bool) - -> Tree ClassWrapper -> (ClassHierarchy,Bool) - insertInTree wrapper superS (forest,bool) n@(Node w@(symbol,super,idDescr) subForest) = - if superS == symbol - then (Node w ((Node wrapper []) : subForest) : forest, True) - else - let (newSubForest,newBool) = foldl' (insertInTree wrapper superS) ([],False) - subForest - in if newBool - then ((Node w newSubForest) : forest, True) - else (n: forest, bool) - - -isClassDescr :: Descr -> Bool -isClassDescr descr = case details descr of - ClassDescr _ _ -> True - _ -> False -asClassWrapper :: Descr -> ClassWrapper -asClassWrapper descr = - case details descr of - ClassDescr super _ -> (descrName descr, super, descr) - _ -> throwIDE "ClassHierarchy>>asClassWrapper: No class" - -instance Ord a => Ord (Tree a) where - compare (Node l1 _) (Node l2 _) = compare l1 l2 - -sortForest :: Ord a => Forest a -> Forest a -sortForest forest = sort (map sortTree forest) - -sortTree :: Ord a => Tree a -> Tree a -sortTree (Node l forest) = Node l (sort (map sortTree forest)) - -builder :: Maybe (PackageScope, PackageScope) -> - PanePath -> - Notebook -> - Window -> - IDERef -> - IO (IDEClassHierarchy, Connections) -builder currentInfo pp nb windows ideR = do - let forest = case currentInfo of - Nothing -> [] - Just pair -> buildClassHierarchyTree pair - treeStore <- treeStoreNew forest - treeView <- treeViewNew - treeViewSetModel treeView treeStore - --treeViewSetRulesHint treeView True - - renderer0 <- cellRendererPixbufNew - set renderer0 [ cellPixbufStockId := "ide_no_source" ] - - renderer <- cellRendererTextNew - col <- treeViewColumnNew - treeViewColumnSetTitle col "Classes" - treeViewColumnSetSizing col TreeViewColumnAutosize - treeViewColumnSetResizable col True - treeViewColumnSetReorderable col True - treeViewAppendColumn treeView col - cellLayoutPackStart col renderer0 False - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer treeStore - $ \(s,_,_) -> [ cellText := s] - cellLayoutSetAttributes col renderer0 treeStore - $ \(_,_,d) -> [ - cellPixbufStockId := - if isJust (mbLocation d) - then "ide_source" - else "ide_no_source"] - - treeViewSetHeadersVisible treeView True --- treeViewSetEnableSearch treeView True --- treeViewSetSearchColumn treeView 0 --- treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore) - --- Facet view -{-- - facetView <- treeViewNew - facetStore <- treeStoreNew [] - treeViewSetModel facetView facetStore - renderer30 <- cellRendererPixbufNew - renderer31 <- cellRendererPixbufNew - renderer3 <- cellRendererTextNew - col <- treeViewColumnNew - treeViewColumnSetTitle col "Interface" - --treeViewColumnSetSizing col TreeViewColumnAutosize - treeViewAppendColumn facetView col - cellLayoutPackStart col renderer30 False - cellLayoutPackStart col renderer31 False - cellLayoutPackStart col renderer3 True - cellLayoutSetAttributes col renderer3 facetStore - $ \row -> [ cellText := facetTreeText row] - cellLayoutSetAttributes col renderer30 facetStore - $ \row -> [ - cellPixbufStockId := stockIdFromType (facetIdType row)] - cellLayoutSetAttributes col renderer31 facetStore - $ \row -> [ - cellPixbufStockId := if isJust (mbLocation(facetIdDescr row)) - then "ide_source" - else ""] - treeViewSetHeadersVisible facetView True - treeViewSetEnableSearch facetView True - treeViewSetSearchColumn facetView 0 - treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore) ---} - pane' <- hPanedNew - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw treeView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - -{-- sw2 <- scrolledWindowNew Nothing Nothing - containerAdd sw2 facetView - scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic--} - panedAdd1 pane' sw --- panedAdd2 pane' sw2 - (x,y) <- widgetGetSize nb - panedSetPosition pane' (x `quot` 2) - box <- hBoxNew True 2 - rb1 <- radioButtonNewWithLabel "Local" - rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package" - rb3 <- radioButtonNewWithLabelFromWidget rb1 "World" - toggleButtonSetActive rb3 True - cb <- checkButtonNewWithLabel "Blacklist" - - boxPackStart box rb1 PackGrow 2 - boxPackStart box rb2 PackGrow 2 - boxPackStart box rb3 PackGrow 2 - boxPackEnd box cb PackNatural 2 - - boxOuter <- vBoxNew False 2 - boxPackStart boxOuter box PackNatural 2 - boxPackStart boxOuter pane' PackGrow 2 - - let classes = IDEClassHierarchy boxOuter pane' treeView treeStore - {--facetView facetStore--} rb1 rb2 rb3 cb - cid3 <- treeView `onRowActivated` - (\ treePath _ -> do - treeViewExpandRow treeView treePath False - return ()) - cid1 <- treeView `afterFocusIn` - (\_ -> do reflectIDE (makeActive classes) ideR; return True) --- cid2 <- facetView `afterFocusIn` --- (\_ -> do runReaderT (makeActive classes) ideR; return True) --- treeView `onButtonPress` (treeViewPopup ideR treeStore treeView) --- facetView `onButtonPress` (facetViewPopup ideR facetStore facetView) --- rb1 `onToggled` (runReaderT scopeSelection ideR) --- rb2 `onToggled` (runReaderT scopeSelection ideR) --- rb3 `onToggled` (runReaderT scopeSelection ideR) --- cb `onToggled` (runReaderT scopeSelection ideR) - sel <- treeViewGetSelection treeView --- sel `onSelectionChanged` (fillFacets treeView treeStore facetView facetStore) --- sel2 <- treeViewGetSelection facetView --- sel2 `onSelectionChanged` (fillInfo facetView facetStore ideR) - - return (classes,[ConnectC cid1{--,ConnectC cid2--}, ConnectC cid3]) - - -{-- -treeViewSearch :: TreeView - -> TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> Int - -> String - -> TreeIter - -> IO Bool -treeViewSearch treeView treeStore _ string iter = do - path <- treeModelGetPath treeStore iter - val <- treeStoreGetValue treeStore path - mbTree <- treeStoreGetTreeSave treeStore path - exp <- treeViewRowExpanded treeView path - when (isJust mbTree && (not (null (subForest (fromJust mbTree)))) && not exp) $ - let found = searchInModSubnodes (fromJust mbTree) string - in when found $ do - treeViewExpandRow treeView path False - return () - let str2 = case snd val of - [] -> fst val - (m,_):_ -> showPackModule (moduleIdMD m) - return (isInfixOf (map toLower string) (map toLower str2)) - -searchInModSubnodes :: ModTree -> String -> Bool -searchInModSubnodes tree str = - not $ null - $ filter (\ val -> - let cstr = case snd val of - [] -> fst val - (m,_):_ -> showPackModule (moduleIdMD m) - in isInfixOf (map toLower str) (map toLower cstr)) - $ concatMap flatten (subForest tree) - -facetViewSearch :: TreeView - -> TreeStore FacetWrapper - -> Int - -> String - -> TreeIter - -> IO Bool -facetViewSearch facetView facetStore _ string iter = do - path <- treeModelGetPath facetStore iter - val <- treeStoreGetValue facetStore path - tree <- treeStoreGetTree facetStore path - exp <- treeViewRowExpanded facetView path - when (not (null (subForest tree)) && not exp) $ - let found = searchInFacetSubnodes tree string - in when found $ do - treeViewExpandRow facetView path False - return () - return (isInfixOf (map toLower string) (map toLower (facetTreeText val))) - -searchInFacetSubnodes :: FacetTree -> String -> Bool -searchInFacetSubnodes tree str = - not $ null - $ filter (\ val -> - isInfixOf (map toLower str) (map toLower (facetTreeText val))) - $ concatMap flatten (subForest tree) ---} - -{-- -fillFacets :: TreeView - -> TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> TreeView - -> TreeStore FacetWrapper - -> IO () -fillFacets treeView treeStore facetView facetStore = do - sel <- getSelectionTree treeView treeStore - case sel of - Just val - -> case snd val of - ((mod,package):_) - -> let forest = buildFacetForest mod in do - emptyModel <- treeStoreNew [] - treeViewSetModel facetView emptyModel - treeStoreClear facetStore - mapM_ (\(e,i) -> treeStoreInsertTree facetStore [] i e) - $ zip forest [0 .. length forest] - treeViewSetModel facetView facetStore - treeViewSetEnableSearch facetView True - treeViewSetSearchColumn facetView 0 - treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore) - - [] -> return () - Nothing - -> do - treeStoreClear facetStore - return () ---} -{-- -getSelectionTree :: TreeView - -> TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> IO (Maybe (String, [(ModuleDescr,PackageDescr)])) -getSelectionTree treeView treeStore = do - treeSelection <- treeViewGetSelection treeView - paths <- treeSelectionGetSelectedRows treeSelection - case paths of - [] -> return Nothing - a:r -> do - val <- treeStoreGetValue treeStore a - return (Just val) - -getSelectionFacet :: TreeView - -> TreeStore FacetWrapper - -> IO (Maybe FacetWrapper) -getSelectionFacet treeView treeStore = do - treeSelection <- treeViewGetSelection treeView - paths <- treeSelectionGetSelectedRows treeSelection - case paths of - a:r -> do - val <- treeStoreGetValue treeStore a - return (Just val) - _ -> return Nothing - - -fillInfo :: TreeView - -> TreeStore FacetWrapper - -> IDERef - -> IO () -fillInfo treeView lst ideR = do - treeSelection <- treeViewGetSelection treeView - paths <- treeSelectionGetSelectedRows treeSelection - case paths of - [] -> return () - [a] -> do - wrapper <- treeStoreGetValue lst a - runReaderT (setInfos [facetIdDescr wrapper]) ideR - return () - _ -> return () - -findDescription :: PackModule -> SymbolTable -> Symbol -> Maybe (Symbol,IdentifierDescr) -findDescription md st s = - case Map.lookup s st of - Nothing -> Nothing - Just l -> case filter (\id -> md == moduleIdID id) l of - [] -> Nothing - l -> Just (s,head l) - -fillModulesList :: (Scope,Bool) -> IDEAction -fillModulesList (scope,useBlacklist) = do - (IDEModules _ _ treeView treeStore _ _ _ _ _ _) <- getModules - prefs <- readIDE prefs - currentInfo' <- readIDE currentInfo - accessibleInfo' <- readIDE accessibleInfo - case currentInfo' of - Nothing -> case (scope,accessibleInfo') of - (World,Just ai@(pm,ps)) -> - let p2 = if useBlacklist - then (Map.filter (filterBlacklist - (packageBlacklist prefs)) pm, ps) - else ai - (Node _ li) = buildModulesTree - ((Map.empty,Map.empty),p2) - in liftIO $ do - treeStoreClear treeStore - mapM_ (\(e,i) -> treeStoreInsertTree treeStore [] i e) - $ zip li [0 .. length li] - _ -> liftIO $ do - treeStoreClear treeStore - treeStoreInsertTree treeStore [] 0 (Node ("",[]) []) - Just (l,p) -> let (l',p'@(pm,ps)) = case scope of - Local -> (l,(Map.empty,Map.empty)) - Package -> (l,p) - World -> case accessibleInfo' of - Just ai -> (l,ai) - Nothing -> (l,p) - p2 = if useBlacklist - then (Map.filter (filterBlacklist - (packageBlacklist prefs)) pm, ps) - else p' - (Node _ li) = buildModulesTree (l',p2) - in liftIO $ do - emptyModel <- treeStoreNew [] - treeViewSetModel treeView emptyModel - treeStoreClear treeStore - mapM_ (\(e,i) -> treeStoreInsertTree treeStore [] i e) - $ zip li [0 .. length li] - treeViewSetModel treeView treeStore - treeViewSetEnableSearch treeView True - treeViewSetSearchColumn treeView 0 - treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore) - - where - filterBlacklist :: [Dependency] -> PackageDescr -> Bool - filterBlacklist dependencies packageDescr = - let packageId = packagePD packageDescr - name = pkgName packageId - version = pkgVersion packageId - in isNothing $ find (\ (Dependency str vr) -> str == name && withinRange version vr) - dependencies - - -type FacetForest = Forest FacetWrapper -type FacetTree = Tree FacetWrapper - - -facetTreeText :: FacetWrapper -> String -facetTreeText (Itself (SimpleDescr id FunctionS _ _ _ _)) = {-- "function " ++ --} id -facetTreeText (Itself (SimpleDescr id NewtypeS _ _ _ _)) = {-- "newtype " ++ --} id -facetTreeText (Itself (SimpleDescr id TypeS _ _ _ _)) = {-- "type " ++ --} id -facetTreeText (Itself (SimpleDescr id _ _ _ _ _)) = id -facetTreeText (Itself (DataDescr id _ _ _ _ _ _)) = {-- "data " ++ --} id -facetTreeText (Itself (ClassDescr id _ _ _ _ _)) = {-- "class " ++ --} id -facetTreeText (Itself (InstanceDescr cl _ _ _ _ )) = {-- "instance " ++ --} cl -facetTreeText (ConstructorW s _) = {-- "constructor " ++ --} s -facetTreeText (FieldW s _) = {-- "slot " ++ --} s -facetTreeText (MethodW s _) = {-- "method " ++ --} s -facetTreeText (OrphanedData (InstanceDescr cl binds _ _ _)) = {-- "instance " ++ --} cl - ++ " " ++ printBinds binds - where - printBinds [] = "" - printBinds (a:[]) = a - printBinds (a:b) = a ++ " " ++ printBinds b -facetTreeText _ = throwIDE "impossible in facetTreeText" - -facetIdType :: FacetWrapper -> IdType -facetIdType (Itself descr) = idType descr -facetIdType (ConstructorW _ _) = Constructor -facetIdType (FieldW _ _) = Field -facetIdType (MethodW _ _) = Method -facetIdType (OrphanedData _) = OrphanedInstance - -facetIdDescr :: FacetWrapper -> IdentifierDescr -facetIdDescr (Itself descr) = descr -facetIdDescr (ConstructorW _ descr) = descr -facetIdDescr (FieldW _ descr) = descr -facetIdDescr (MethodW _ descr) = descr -facetIdDescr (OrphanedData descr) = descr - -buildFacetForest :: ModuleDescr -> FacetForest -buildFacetForest modDescr = - let (instances,other) = partition (\id -> case id of - InstanceDescr _ _ _ _ _ -> True - _ -> False) - $ idDescriptionsMD modDescr - forestWithoutInstances = map buildFacet other - (forest2,orphaned) = foldl' addInstances (forestWithoutInstances,[]) - instances - orphanedNodes = map (\ inst -> Node (OrphanedData inst) []) orphaned - in forest2 ++ reverse orphanedNodes - where - buildFacet :: IdentifierDescr -> FacetTree - buildFacet d@(SimpleDescr _ _ _ _ _ _) - = Node (Itself d) [] - buildFacet d@(DataDescr _ _ _ constID fieldsID _ _) - = (Node (Itself d) ((map (\ s -> Node (ConstructorW s d) []) constID) - ++ (map (\ s -> Node (FieldW s d) []) fieldsID))) - buildFacet d@(ClassDescr _ _ _ classOpsID _ _) - = Node (Itself d) (map (\ s -> Node (MethodW s d) []) classOpsID) - buildFacet d@(InstanceDescr _ _ _ _ _) - = throwIDE "Impossible in buildFacet" - - addInstances :: (FacetForest,[IdentifierDescr]) - -> IdentifierDescr - -> (FacetForest,[IdentifierDescr]) - addInstances (forest,orphaned) instDescr = - case foldl' (matches instDescr) ([],False) forest of - (f,True) -> (f,orphaned) - (f,False) -> (forest, instDescr:orphaned) - - matches :: IdentifierDescr - -> (FacetForest,Bool) - -> FacetTree - -> (FacetForest,Bool) - matches instDescr (forest,False) (Node (Itself dd@(DataDescr id _ _ _ _ _ _)) sub) - | [id] == binds instDescr - = ((Node (Itself dd) (sub ++ [Node (Itself instDescr) []])):forest,True) - matches instDescr (forest,False) (Node (Itself dd@(SimpleDescr id ty _ _ _ _ )) sub) - | [id] == binds instDescr && ty == NewtypeS - = ((Node (Itself dd) (sub ++ [Node (Itself instDescr) []])):forest,True) - matches _ (forest,b) node = (node:forest,b) - - - ---} - -{-- -treeViewPopup :: IDERef - -> TreeStore (String, [(ModuleDescr,PackageDescr)]) - -> TreeView - -> Event - -> IO (Bool) -treeViewPopup ideR store treeView (Button _ click _ _ _ _ button _ _) = do - if button == RightButton - then do - theMenu <- menuNew - item1 <- menuItemNewWithLabel "Edit" - item1 `onActivateLeaf` do - sel <- getSelectionTree treeView store - case sel of - Just (_,[(m,_)]) -> case mbSourcePathMD m of - Nothing -> return () - Just fp -> do - runReaderT (selectSourceBuf fp) ideR - return () - otherwise -> return () - item2 <- menuItemNewWithLabel "ExpandAll" - item2 `onActivateLeaf` (treeViewExpandAll treeView) - item3 <- menuItemNewWithLabel "CollapseAll" - item3 `onActivateLeaf` (treeViewCollapseAll treeView) - mapM_ (menuShellAppend theMenu) [item1,item2,item3] - menuPopup theMenu Nothing - widgetShowAll theMenu - return True - else if button == LeftButton && click == DoubleClick - then do sel <- getSelectionTree treeView store - case sel of - Just (_,[(m,_)]) -> case mbSourcePathMD m of - Nothing -> return () - Just fp -> do - runReaderT (selectSourceBuf fp) ideR - return () - otherwise -> return () - return True - else return False -treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type" - -facetViewPopup :: IDERef - -> TreeStore FacetWrapper - -> TreeView - -> Event - -> IO (Bool) -facetViewPopup ideR store facetView (Button _ click _ _ _ _ button _ _) = do - if button == RightButton - then do - theMenu <- menuNew - item1 <- menuItemNewWithLabel "Go to definition" - item1 `onActivateLeaf` do - sel <- getSelectionFacet facetView store - case sel of - Just wrapper -> runReaderT - (goToDefinition (facetIdDescr wrapper)) ideR - otherwise -> sysMessage Normal "no selection" - menuShellAppend theMenu item1 - menuPopup theMenu Nothing - widgetShowAll theMenu - return True - else if button == LeftButton && click == DoubleClick - then do sel <- getSelectionFacet facetView store - case sel of - Just wrapper -> runReaderT (goToDefinition - (facetIdDescr wrapper)) ideR - otherwise -> sysMessage Normal "no selection" - return True - else do - mbPane :: Maybe IDEInfo <- runReaderT getPane ideR - when (isJust mbPane) $ bringPaneToFront (fromJust mbPane) - return False - -facetViewPopup _ _ _ _ = throwIDE "facetViewPopup wrong event type" - ---} -{-- -getScope :: IDEM (Scope,Bool) -getScope = do - (IDEModules _ _ treeView treeStore facetView facetStore localScopeB - packageScopeB worldScopeB blacklistB) <- getModules - rb1s <- liftIO $ toggleButtonGetActive localScopeB - rb2s <- liftIO $ toggleButtonGetActive packageScopeB - rb3s <- liftIO $ toggleButtonGetActive worldScopeB - cbs <- liftIO $ toggleButtonGetActive blacklistB - let scope = if rb1s - then Local - else if rb2s - then Package - else if rb3s - then World - else throwIDE - "ModulesPane.scopeSelection: No check button selected" - return (scope,cbs) - -scopeSelection :: IDEAction -scopeSelection = do - mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) - <- getModules - mbTreeSelection <- liftIO $ getSelectionTree treeView treeStore - mbFacetSelection <- liftIO $ getSelectionFacet facetView facetStore - - sc <- getScope - ts <- liftIO $ treeViewGetSelection treeView - liftIO $ treeSelectionUnselectAll ts - fillModulesList sc - let mbs = (case mbTreeSelection of - Nothing -> Nothing - Just (_,[]) -> Nothing - Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), - case mbFacetSelection of - Nothing -> Nothing - Just fw -> Just (symbolFromFacetWrapper fw)) - selectNames mbs - liftIO $ bringPaneToFront mods - -selectNames :: (Maybe String, Maybe Symbol) -> IDEAction -selectNames (mbModuleName, mbIdName) = do - (IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) - <- getModules - case mbModuleName of - Nothing -> return () - Just moduleName -> - let nameArray = breakAtDots [] moduleName - in do - mbTree <- liftIO $ treeStoreGetTreeSave treeStore [] - case treePathFromNameArray mbTree nameArray [] of - Nothing -> return () - Just treePath -> liftIO $ do - treeViewExpandToPath treeView treePath - sel <- treeViewGetSelection treeView - treeSelectionSelectPath sel treePath - col <- treeViewGetColumn treeView 0 - treeViewScrollToCell treeView treePath (fromJust col) - (Just (0.3,0.3)) - case mbIdName of - Nothing -> return () - Just symbol -> do - mbFacetTree <- treeStoreGetTreeSave facetStore [] - selF <- treeViewGetSelection facetView - case findPathFor symbol mbFacetTree of - Nothing -> sysMessage Normal "no path found" - Just path -> do - treeSelectionSelectPath selF path - col <- treeViewGetColumn facetView 0 - treeViewScrollToCell facetView path (fromJust col) - (Just (0.3,0.3)) - - -symbolFromFacetWrapper :: FacetWrapper -> Symbol -symbolFromFacetWrapper (Itself idDescr) = identifierID idDescr -symbolFromFacetWrapper (ConstructorW _ idDescr) = identifierID idDescr -symbolFromFacetWrapper (FieldW _ idDescr) = identifierID idDescr -symbolFromFacetWrapper (MethodW _ idDescr) = identifierID idDescr -symbolFromFacetWrapper (OrphanedData idDescr) = identifierID idDescr - -reloadKeepSelection :: IDEAction -reloadKeepSelection = do - mbMod <- getPane - case mbMod of - Nothing -> return () - Just mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) - -> do - mbTreeSelection <- liftIO $ getSelectionTree treeView treeStore - mbFacetSelection <- liftIO $ getSelectionFacet facetView facetStore - sc <- getScope - fillModulesList sc - liftIO $ treeStoreClear facetStore - let mbs = (case mbTreeSelection of - Nothing -> Nothing - Just (_,[]) -> Nothing - Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), - case mbFacetSelection of - Nothing -> Nothing - Just fw -> Just (symbolFromFacetWrapper fw)) - selectNames mbs - - -treeStoreGetTreeSave :: TreeStore a -> TreePath -> IO (Maybe (Tree a)) -treeStoreGetTreeSave treeStore treePath = catch (do - res <- treeStoreGetTree treeStore treePath - return (Just res)) (\ _ -> return Nothing) - - -findPathFor :: Symbol -> Maybe (Tree FacetWrapper) -> Maybe TreePath -findPathFor symbol (Just (Node _ forest)) = - foldr ( \i mbTreePath -> findPathFor' [i] (forest !! i) mbTreePath) - Nothing [0 .. ((length forest) - 1)] - where - findPathFor' :: TreePath -> Tree FacetWrapper -> Maybe TreePath -> Maybe TreePath - findPathFor' _ node (Just p) = Just p - findPathFor' path (Node wrap sub) Nothing = - if identifierID (facetIdDescr wrap) == symbol - then Just (reverse path) - else - foldr ( \i mbTreePath -> findPathFor' (i:path) (sub !! i) mbTreePath) - Nothing [0 .. ((length sub) - 1)] -findPathFor symbol Nothing = Nothing - -treePathFromNameArray :: Maybe ModTree -> [String] -> [Int] -> Maybe [Int] -treePathFromNameArray (Just tree) [] accu = Just (reverse accu) -treePathFromNameArray (Just tree) (h:t) accu = - let names = map (\t -> fst $ rootLabel t) (subForest tree) - mbIdx = elemIndex h names - in case mbIdx of - Nothing -> Nothing - Just i -> treePathFromNameArray (Just (subForest tree !! i)) t (i:accu) -treePathFromNameArray Nothing _ _ = Nothing - ---} -{-- -extractSuperclasses :: String -> [String] -extractSuperclasses str = - let parseRes = trace ("now extracting superclasses for " ++ show str) - parse superclassParser "" str - in case parseRes of - Left err -> throwIDE $show err - Right l -> trace ("found " ++ show l) l - -lexer = haskell -lexeme = P.lexeme lexer -whiteSpace = P.whiteSpace lexer -symbol = P.symbol lexer - -superclassParser :: CharParser () [String] -superclassParser = do - symbol "class" - whiteSpace - try (do - sc <- classDefParser - symbol "=>" - return [sc]) - <|> try (do - symbol "(" - scs <- sepBy classDefParser (char ',') - symbol ")" - symbol "=>" - return scs) - <|> return [] - "superclasses" - -classDefParser :: CharParser () String -classDefParser = do - whiteSpace - c <- oneOf['A'..'Z'] - cs <- many (alphaNum <|> oneOf "_'.") - many typeVarParser - return (c:cs) - "classDef" - -typeVarParser :: CharParser () String -typeVarParser = do - whiteSpace - c <- oneOf['a'..'z'] - cs <- many (alphaNum <|> oneOf "_'.") - return (c:cs) - "typeVar" ---} 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 @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Errors --- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org @@ -17,22 +17,21 @@ module IDE.Pane.Errors ( IDEErrors , ErrorsState -, showErrors -, showErrors' , fillErrorList , selectError +, getErrors ) where import Graphics.UI.Gtk import Data.Typeable (Typeable(..)) import IDE.Core.State import Control.Monad.Reader -import IDE.LogRef import Graphics.UI.Gtk.General.Enums (Click(..), MouseButton(..)) import Graphics.UI.Gtk.Gdk.Events (Event(..)) import IDE.ImportTool (addImport,parseNotInScope, addAllImports) import Data.List (elemIndex) +import IDE.LogRef (showSourceSpan) -- | A breakpoints pane description -- @@ -47,75 +46,27 @@ data ErrorsState = ErrorsState { } deriving(Eq,Ord,Read,Show,Typeable) - -instance IDEObject IDEErrors - instance Pane IDEErrors IDEM where primPaneName _ = "Errors" - getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledView paneId b = "*Errors" - makeActive pane = activatePane pane [] - close = closePane instance RecoverablePane IDEErrors ErrorsState IDEM where saveState p = do return (Just ErrorsState) recoverState pp ErrorsState = do nb <- getNotebook pp - newPane pp nb builder + p <- buildPane pp nb builder fillErrorList - return () - -showErrors :: IDEAction -showErrors = do - m <- getErrors - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeView m) - -getErrors :: IDEM IDEErrors -getErrors = do - mbErrors <- getPane - case mbErrors of - Nothing -> do - pp <- getBestPathForId "*Errors" - nb <- getNotebook pp - newPane pp nb builder - fillErrorList - mbErrors <- getPane - case mbErrors of - Nothing -> throwIDE "Can't init errors" - Just m -> return m - Just m -> return m - -showErrors' :: PanePath -> IDEAction -showErrors' pp = do - m <- getErrors' pp - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeView m) - -getErrors' :: PanePath -> IDEM IDEErrors -getErrors' pp = do - mbErrors <- getPane - case mbErrors of - Nothing -> do - layout <- getLayout - nb <- getNotebook (getBestPanePath pp layout) - newPane pp nb builder - fillErrorList - mbErrors <- getPane - case mbErrors of - Nothing -> throwIDE "Can't init errors" - Just m -> return m - Just m -> return m + return p + builder = builder' -builder :: PanePath -> +builder' :: PanePath -> Notebook -> Window -> - IDERef -> - IO (IDEErrors, Connections) -builder pp nb windows ideR = do + IDEM (Maybe IDEErrors, Connections) +builder' pp nb windows = reifyIDE $ \ ideR -> do errorStore <- treeStoreNew [] treeView <- treeViewNew treeViewSetModel treeView errorStore @@ -154,8 +105,12 @@ treeView `onButtonPress` (errorViewPopup ideR errorStore treeView) cid1 <- treeView `afterFocusIn` (\_ -> do reflectIDE (makeActive pane) ideR ; return True) - return (pane,[ConnectC cid1]) + return (Just pane,[ConnectC cid1]) +getErrors :: Maybe PanePath -> IDEM IDEErrors +getErrors Nothing = forceGetPane (Right "*Errors") +getErrors (Just pp) = forceGetPane (Left pp) + fillErrorList :: IDEAction fillErrorList = do mbErrors <- getPane @@ -191,7 +146,7 @@ selectError :: Maybe LogRef -> IDEAction selectError mbLogRef = do errorRefs' <- readIDE errorRefs - errors <- getErrors + errors <- getErrors Nothing liftIO $ do selection <- treeViewGetSelection (treeView errors) case mbLogRef of @@ -223,7 +178,7 @@ Just _ -> do item1 <- menuItemNewWithLabel "Add import" item1 `onActivateLeaf` do - reflectIDE (addImport sel [] >> return()) ideR + reflectIDE (addImport sel [] (\ _ -> return ())) ideR menuShellAppend theMenu item1 Nothing -> return () menuPopup theMenu Nothing 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 @@ -16,9 +16,9 @@ module IDE.Pane.Grep ( IDEGrep(..) -, showGrep , setGrepResults , GrepState(..) +, getGrep ) where import Graphics.UI.Gtk hiding (get) @@ -29,7 +29,7 @@ import Control.Monad.Reader import Data.Typeable import IDE.Core.State -import IDE.Tool (ToolOutput(..)) +import IDE.Utils.Tool (ToolOutput(..)) import Control.Concurrent (forkIO) import IDE.LogRef (logOutput) import IDE.Pane.SourceBuffer @@ -53,114 +53,87 @@ data GrepState = GrepState deriving(Eq,Ord,Read,Show,Typeable) -instance IDEObject IDEGrep - instance Pane IDEGrep IDEM where primPaneName _ = "Grep" getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledView paneId b = "*Grep" - makeActive p = activatePane p [] - close = closePane instance RecoverablePane IDEGrep GrepState IDEM where saveState p = do return (Just GrepState) recoverState pp GrepState = do nb <- getNotebook pp - newPane pp nb builder - return () + buildPane pp nb builder + builder pp nb windows = reifyIDE $ \ ideR -> do + listStore <- listStoreNew [] + treeView <- treeViewNew + treeViewSetModel treeView listStore -showGrep :: IDEAction -showGrep = do - m <- getGrep - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeView m) + 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 listStore + $ \row -> [ cellText := file row] -getGrep :: IDEM IDEGrep -getGrep = do - mbGrep <- getPane - case mbGrep of - Just m -> return m - Nothing -> do - pp <- getBestPathForId "*Grep" - nb <- getNotebook pp - newPane pp nb builder - mbGrep <- getPane - case mbGrep of - Nothing -> throwIDE "Can't init grep" - Just m -> return m + renderer2 <- cellRendererTextNew + col2 <- treeViewColumnNew + treeViewColumnSetTitle col2 "Line" + treeViewColumnSetSizing col2 TreeViewColumnAutosize + treeViewColumnSetResizable col2 True + treeViewColumnSetReorderable col2 True + treeViewAppendColumn treeView col2 + cellLayoutPackStart col2 renderer2 True + cellLayoutSetAttributes col2 renderer2 listStore + $ \row -> [ cellText := show $ line row] -builder :: PanePath -> - Notebook -> - Window -> - IDERef -> - IO (IDEGrep,Connections) -builder pp nb windows ideR = do - listStore <- listStoreNew [] - treeView <- treeViewNew - treeViewSetModel treeView listStore + renderer3 <- cellRendererTextNew + renderer30 <- cellRendererPixbufNew + col3 <- treeViewColumnNew + treeViewColumnSetTitle col3 "Context" + 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 := context row] - 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 listStore - $ \row -> [ cellText := file row] - renderer2 <- cellRendererTextNew - col2 <- treeViewColumnNew - treeViewColumnSetTitle col2 "Line" - treeViewColumnSetSizing col2 TreeViewColumnAutosize - treeViewColumnSetResizable col2 True - treeViewColumnSetReorderable col2 True - treeViewAppendColumn treeView col2 - cellLayoutPackStart col2 renderer2 True - cellLayoutSetAttributes col2 renderer2 listStore - $ \row -> [ cellText := show $ line row] - - renderer3 <- cellRendererTextNew - renderer30 <- cellRendererPixbufNew - col3 <- treeViewColumnNew - treeViewColumnSetTitle col3 "Context" - 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 := context row] - + treeViewSetHeadersVisible treeView True + sel <- treeViewGetSelection treeView + treeSelectionSetMode sel SelectionSingle - treeViewSetHeadersVisible treeView True - sel <- treeViewGetSelection treeView - treeSelectionSetMode sel SelectionSingle + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw treeView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + let grep = IDEGrep sw treeView listStore - let grep = IDEGrep sw treeView listStore + cid1 <- treeView `afterFocusIn` + (\_ -> do reflectIDE (makeActive grep) ideR ; return True) + sel `onSelectionChanged` do + sel <- getSelectionGrepRecord treeView listStore + case sel of + Just record -> reflectIDE (do + goToSourceDefinition (file record) + $ Just $ Location (line record) 0 (line record) 0) ideR + Nothing -> return () - cid1 <- treeView `afterFocusIn` - (\_ -> do reflectIDE (makeActive grep) ideR ; return True) - sel `onSelectionChanged` do - sel <- getSelectionGrepRecord treeView listStore - case sel of - Just record -> reflectIDE (do - goToSourceDefinition (file record) - $ Just $ Location (line record) 0 (line record) 0) ideR - Nothing -> return () + return (Just grep,[ConnectC cid1]) - return (grep,[ConnectC cid1]) +getGrep :: Maybe PanePath -> IDEM IDEGrep +getGrep Nothing = forceGetPane (Right "*Grep") +getGrep (Just pp) = forceGetPane (Left pp) grepLineParser :: CharParser () GrepRecord grepLineParser = try (do @@ -197,7 +170,7 @@ setGrepResults :: [ToolOutput] -> IDEAction setGrepResults output = do - grep <- getGrep + grep <- getGrep Nothing ideRef <- ask liftIO $ do let (displayed, dropped) = splitAt 10000 output 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 @@ -18,23 +18,19 @@ IDEInfo , InfoState , setInfo -, setSymbol , replayInfoHistory -, showInfo ) where import Graphics.UI.Gtk hiding (afterToggleOverwrite) import Control.Monad import Control.Monad.Trans -import Data.Maybe import Data.IORef import Data.Typeable import IDE.Core.State import IDE.Pane.SourceBuffer import IDE.Pane.References -import IDE.FileUtils (openBrowser) -import IDE.Metainfo.Provider (getIdentifierDescr) +import IDE.Utils.GUIUtils (openBrowser,controlIsPressed) import Graphics.UI.Gtk.SourceView @@ -42,24 +38,19 @@ -- data IDEInfo = IDEInfo { sw :: VBox -, currentDescr :: IORef Descr +, currentDescr :: IORef (Maybe Descr) , descriptionView :: SourceView } deriving Typeable -data InfoState = InfoState Descr +data InfoState = InfoState (Maybe Descr) deriving(Eq,Ord,Read,Show,Typeable) - -instance IDEObject IDEInfo - instance Pane IDEInfo IDEM where primPaneName _ = "Info" getAddedIndex _ = 0 getTopWidget = castToWidget . sw paneId b = "*Info" - makeActive pane = activatePane pane [] - close = closePane instance RecoverablePane IDEInfo InfoState IDEM where saveState p = do @@ -67,106 +58,98 @@ return (Just (InfoState currentDescr')) recoverState pp (InfoState descr) = do nb <- getNotebook pp + buildPane pp nb builder + builder pp nb windows = + let idDescr = Nothing in do prefs <- readIDE prefs - newPane pp nb (builder descr prefs) - return () - -showInfo :: IDEAction -showInfo = do - mbInfo :: Maybe IDEInfo <- getPane - case mbInfo of - Nothing -> return () - Just p -> liftIO $ bringPaneToFront p - -builder :: Descr -> - Prefs -> - PanePath -> - Notebook -> - Window -> - IDERef -> - IO (IDEInfo,Connections) -builder idDescr prefs pp nb windows ideR = do - ibox <- vBoxNew False 0 --- Buttons - bb <- hButtonBoxNew - buttonBoxSetLayout bb ButtonboxSpread - definitionB <- buttonNewWithLabel "Source" - moduB <- buttonNewWithLabel "Modules" - usesB <- buttonNewWithLabel "Refs" - docuB <- buttonNewWithLabel "Docu" - searchB <- buttonNewWithLabel "Search" - boxPackStartDefaults bb definitionB - boxPackStartDefaults bb moduB - boxPackStartDefaults bb usesB - boxPackStartDefaults bb docuB - boxPackStartDefaults bb searchB --- Descr View - font <- case textviewFont prefs of - Just str -> do - fontDescriptionFromString str - Nothing -> do - f <- fontDescriptionNew - fontDescriptionSetFamily f "Monospace" - return f + reifyIDE $ \ ideR -> do + ibox <- vBoxNew False 0 + -- Buttons + bb <- hButtonBoxNew + buttonBoxSetLayout bb ButtonboxSpread + definitionB <- buttonNewWithLabel "Source" + moduB <- buttonNewWithLabel "Modules" + usesB <- buttonNewWithLabel "Refs" + docuB <- buttonNewWithLabel "Docu" + searchB <- buttonNewWithLabel "Search" + boxPackStartDefaults bb definitionB + boxPackStartDefaults bb moduB + boxPackStartDefaults bb usesB + boxPackStartDefaults bb docuB + boxPackStartDefaults bb searchB + -- Descr View + font <- case textviewFont prefs of + Just str -> do + fontDescriptionFromString str + Nothing -> do + f <- fontDescriptionNew + fontDescriptionSetFamily f "Monospace" + return f - descriptionView <- sourceViewNew - descriptionBuffer <- (get descriptionView textViewBuffer) >>= (return . castToSourceBuffer) - lm <- sourceLanguageManagerNew - mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell") - case mbLang of - Nothing -> return () - Just lang -> do sourceBufferSetLanguage descriptionBuffer lang + descriptionView <- sourceViewNew + descriptionBuffer <- (get descriptionView textViewBuffer) >>= (return . castToSourceBuffer) + lm <- sourceLanguageManagerNew + mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell") + case mbLang of + Nothing -> return () + Just lang -> do sourceBufferSetLanguage descriptionBuffer lang - -- This call is here because in the past I have had problems where the - -- language object became invalid if the manager was garbage collected - sourceLanguageManagerGetLanguageIds lm + -- This call is here because in the past I have had problems where the + -- language object became invalid if the manager was garbage collected + sourceLanguageManagerGetLanguageIds lm - sourceBufferSetHighlightSyntax descriptionBuffer True - widgetModifyFont descriptionView (Just font) + sourceBufferSetHighlightSyntax descriptionBuffer True + widgetModifyFont descriptionView (Just font) - case sourceStyle prefs of - Nothing -> return () - Just str -> do - styleManager <- sourceStyleSchemeManagerNew - ids <- sourceStyleSchemeManagerGetSchemeIds styleManager - when (elem str ids) $ do - scheme <- sourceStyleSchemeManagerGetScheme styleManager str - sourceBufferSetStyleScheme descriptionBuffer scheme + case sourceStyle prefs of + Nothing -> return () + Just str -> do + styleManager <- sourceStyleSchemeManagerNew + ids <- sourceStyleSchemeManagerGetSchemeIds styleManager + when (elem str ids) $ do + scheme <- sourceStyleSchemeManagerGetScheme styleManager str + sourceBufferSetStyleScheme descriptionBuffer scheme - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw descriptionView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw descriptionView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - boxPackStart ibox sw PackGrow 10 - boxPackEnd ibox bb PackNatural 10 + boxPackStart ibox sw PackGrow 10 + boxPackEnd ibox bb PackNatural 10 - --openType - currentDescr' <- newIORef idDescr - let info = IDEInfo ibox currentDescr' descriptionView - definitionB `onClicked` (reflectIDE gotoSource ideR ) - moduB `onClicked` (reflectIDE gotoModule' ideR ) - usesB `onClicked` (reflectIDE referencedFrom' ideR ) - searchB `onClicked` (do - descr <- readIORef currentDescr' - reflectIDE (do - triggerEventIDE (SearchMeta (descrName descr)) - showInfo) ideR ) - docuB `onClicked` (do - descr <- readIORef currentDescr' - reflectIDE (openBrowser $ docuSearchURL prefs ++ descrName descr) ideR) - descriptionView `widgetAddEvents` [ButtonReleaseMask] - id5 <- descriptionView `onButtonRelease` - (\ e -> do - buf <- textViewGetBuffer descriptionView - (l,r) <- textBufferGetSelectionBounds buf - symbol <- textBufferGetText buf l r True - when (controlIsPressed e) - (reflectIDE (do - triggerEventIDE (SelectInfo symbol) - return ()) ideR) - return False) - return (info,[]) + --openType + currentDescr' <- newIORef idDescr + let info = IDEInfo ibox currentDescr' descriptionView + definitionB `onClicked` (reflectIDE gotoSource ideR ) + moduB `onClicked` (reflectIDE gotoModule' ideR ) + usesB `onClicked` (reflectIDE referencedFrom' ideR ) + searchB `onClicked` (do + mbDescr <- readIORef currentDescr' + case mbDescr of + Nothing -> return () + Just descr -> reflectIDE (do + triggerEventIDE (SearchMeta (dscName descr)) + i :: IDEInfo <- forceGetPane (Right "*Info") + displayPane i False + return ()) ideR ) + docuB `onClicked` (do + mbDescr <- readIORef currentDescr' + case mbDescr of + Nothing -> return () + Just descr -> reflectIDE (openBrowser $ docuSearchURL prefs ++ dscName descr) ideR) + descriptionView `widgetAddEvents` [ButtonReleaseMask] + id5 <- descriptionView `onButtonRelease` + (\ e -> do + buf <- textViewGetBuffer descriptionView + (l,r) <- textBufferGetSelectionBounds buf + symbol <- textBufferGetText buf l r True + when (controlIsPressed e) + (reflectIDE (do + triggerEventIDE (SelectInfo symbol) + return ()) ideR) + return False) + return (Just info,[]) gotoSource :: IDEAction gotoSource = do @@ -190,59 +173,37 @@ Nothing -> return () Just info -> referencedFrom info >> return () -setSymbol :: String -> IDEAction -setSymbol symbol = do - currentInfo' <- readIDE currentInfo - case currentInfo' of - Nothing -> return () - Just ((_,symbolTable1),(_,symbolTable2)) -> - case getIdentifierDescr symbol symbolTable1 symbolTable2 of - [] -> return () - (a:r) -> do - setInfo a - showInfo - if length (a:r) > 1 - then triggerEventIDE (DescrChoice (a:r)) >> return () - else triggerEventIDE (SelectIdent a) >> return () - - setInfo :: Descr -> IDEAction setInfo identifierDescr = do - mbPane <- getPane - case mbPane of - Nothing -> do - pp <- getBestPathForId "*Info" - nb <- getNotebook pp - prefs <- readIDE prefs - newPane pp nb (builder identifierDescr prefs) - return () - Just info -> do - oldDescr <- liftIO $ readIORef (currentDescr info) - liftIO $ do - writeIORef (currentDescr info) identifierDescr - tb <- get (descriptionView info) textViewBuffer - textBufferSetText tb (show (Present identifierDescr)) - recordInfoHistory identifierDescr oldDescr + info <- forceGetPane (Right "*Info") + oldDescr <- liftIO $ readIORef (currentDescr info) + liftIO $ do + writeIORef (currentDescr info) (Just identifierDescr) + tb <- get (descriptionView info) textViewBuffer + textBufferSetText tb (show (Present identifierDescr)) + recordInfoHistory (Just identifierDescr) oldDescr getInfoCont :: IDEM (Maybe (Descr)) getInfoCont = do mbPane <- getPane case mbPane of Nothing -> return Nothing - Just p -> liftIO $ readIORef (currentDescr p) >>= return . Just + Just p -> liftIO $ readIORef (currentDescr p) -- * GUI History -recordInfoHistory :: Descr -> Descr -> IDEAction +recordInfoHistory :: Maybe Descr -> Maybe Descr -> IDEAction recordInfoHistory descr oldDescr = do triggerEventIDE (RecordHistory ((InfoElementSelected descr), (InfoElementSelected oldDescr))) return () -replayInfoHistory :: Descr -> IDEAction -replayInfoHistory descr = do - setInfo descr +replayInfoHistory :: Maybe Descr -> IDEAction +replayInfoHistory mbDescr = do + case mbDescr of + Nothing -> return () + Just descr -> setInfo 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 @@ -16,10 +16,13 @@ module IDE.Pane.Log ( IDELog(..) -, LogView(..) -, clearLog , LogState , LogTag(..) +, showLog +, clearLog +, getLog -- :: beta alpha +, appendLog -- :: alpha -> String -> LogTag -> IO Int +, markErrorInLog -- :: alpha -> (Int, Int) -> IO () , readOut , readErr @@ -28,17 +31,37 @@ import Data.Typeable (Typeable(..)) import IDE.Core.State -import Graphics.UI.Gtk import Graphics.UI.Gtk.Gdk.Events import Control.Monad.Trans (liftIO) import IDE.Pane.SourceBuffer (markRefInSourceBuf,selectSourceBuf) import System.IO import Prelude hiding (catch) import Control.Exception hiding (try) -import IDE.ImportTool (addAllImports,addImport,parseNotInScope) -import System.Process - (runInteractiveProcess, ProcessHandle(..)) +import IDE.ImportTool (addImport, parseNotInScope, addAllImports) +import System.Process (runInteractiveProcess, ProcessHandle) +import Graphics.UI.Gtk + (textBufferSetText, textViewScrollToMark, + textBufferGetIterAtLineOffset, textViewScrollMarkOnscreen, + textBufferGetMark, textBufferMoveMarkByName, + textBufferApplyTagByName, textBufferGetIterAtOffset, + textBufferGetCharCount, textBufferInsert, textBufferSelectRange, + widgetHide, widgetShowAll, menuShellAppend, onActivateLeaf, + menuItemNewWithLabel, containerGetChildren, textIterGetLine, + textViewGetLineAtY, textViewWindowToBufferCoords, widgetGetPointer, + onPopulatePopup, onButtonPress, afterFocusIn, + scrolledWindowSetShadowType, scrolledWindowSetPolicy, containerAdd, + scrolledWindowNew, widgetModifyFont, fontDescriptionSetFamily, + fontDescriptionNew, fontDescriptionFromString, textViewSetEditable, + textTagBackground, textTagTableAdd, textTagForeground, textTagNew, + textBufferGetTagTable, textBufferCreateMark, textBufferGetEndIter, + textViewGetBuffer, textViewNew, Window, Notebook, castToWidget, + ScrolledWindow, TextView) +import System.Glib.Attributes (AttrOp(..), set) +import Graphics.UI.Gtk.General.Enums + (TextWindowType(..), ShadowType(..), PolicyType(..)) +import System.Glib.MainLoop (priorityDefaultIdle, idleAdd) + ------------------------------------------------------------------------------- -- -- * Interface @@ -57,94 +80,80 @@ data LogState = LogState deriving(Eq,Ord,Read,Show,Typeable) - -class Pane alpha beta => LogView alpha beta where - getLog :: beta alpha - appendLog :: alpha -> String -> LogTag -> IO Int - markErrorInLog :: alpha -> (Int, Int) -> IO () - -instance IDEObject IDELog - -instance LogView IDELog IDEM - where - getLog = getLog' - appendLog = appendLog' - markErrorInLog = markErrorInLog' - instance Pane IDELog IDEM where primPaneName _ = "Log" getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledWindowL paneId b = "*Log" - makeActive log = activatePane log [] - close = closePane instance RecoverablePane IDELog LogState IDEM where saveState p = return (Just LogState) recoverState pp LogState = do - nb <- getNotebook pp - prefs' <- readIDE prefs - newPane pp nb (builder prefs') - return () - + mbPane :: Maybe IDELog <- getPane + case mbPane of + Nothing -> do + nb <- getNotebook pp + prefs' <- readIDE prefs + buildPane pp nb builder + Just p -> return (Just p) + builder = builder' ------------------------------------------------------------------------------- -- -- * Implementation -- - -builder :: Prefs -> - PanePath -> +builder' :: PanePath -> Notebook -> Window -> - IDERef -> - IO (IDELog,Connections) -builder prefs pp nb windows ideR = do - tv <- textViewNew - buf <- textViewGetBuffer tv - iter <- textBufferGetEndIter buf - textBufferCreateMark buf (Just "end") iter True + IDEM (Maybe IDELog,Connections) +builder' pp nb windows = do + prefs <- readIDE prefs + reifyIDE $ \ideR -> do + tv <- textViewNew + buf <- textViewGetBuffer tv + iter <- textBufferGetEndIter buf + textBufferCreateMark buf (Just "end") iter True - tags <- textBufferGetTagTable buf - errtag <- textTagNew (Just "err") - set errtag[textTagForeground := "red"] - textTagTableAdd tags errtag - frametag <- textTagNew (Just "frame") - set frametag[textTagForeground := "dark green"] - textTagTableAdd tags frametag - activeErrtag <- textTagNew (Just "activeErr") - set activeErrtag[textTagBackground := "yellow"] - textTagTableAdd tags activeErrtag - intputTag <- textTagNew (Just "input") - set intputTag[textTagForeground := "blue"] - textTagTableAdd tags intputTag - infoTag <- textTagNew (Just "info") - set infoTag[textTagForeground := "grey"] - textTagTableAdd tags infoTag + tags <- textBufferGetTagTable buf + errtag <- textTagNew (Just "err") + set errtag[textTagForeground := "red"] + textTagTableAdd tags errtag + frametag <- textTagNew (Just "frame") + set frametag[textTagForeground := "dark green"] + textTagTableAdd tags frametag + activeErrtag <- textTagNew (Just "activeErr") + set activeErrtag[textTagBackground := "yellow"] + textTagTableAdd tags activeErrtag + intputTag <- textTagNew (Just "input") + set intputTag[textTagForeground := "blue"] + textTagTableAdd tags intputTag + infoTag <- textTagNew (Just "info") + set infoTag[textTagForeground := "grey"] + textTagTableAdd tags infoTag - textViewSetEditable tv False - fd <- case logviewFont prefs of - Just str -> do - fontDescriptionFromString str - Nothing -> do - f <- fontDescriptionNew - fontDescriptionSetFamily f "Sans" - return f - widgetModifyFont tv (Just fd) - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw tv - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - scrolledWindowSetShadowType sw ShadowIn + textViewSetEditable tv False + fd <- case logviewFont prefs of + Just str -> do + fontDescriptionFromString str + Nothing -> do + f <- fontDescriptionNew + fontDescriptionSetFamily f "Sans" + return f + widgetModifyFont tv (Just fd) + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw tv + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + scrolledWindowSetShadowType sw ShadowIn - let buf = IDELog tv sw - cid1 <- tv `afterFocusIn` - (\_ -> do reflectIDE (makeActive buf) ideR ; return False) - cid2 <- tv `onButtonPress` - (\ b -> do reflectIDE (clicked b buf) ideR ; return False) - cid3 <- tv `onPopulatePopup` (populatePopup buf ideR) - return (buf,[ConnectC cid1, ConnectC cid2]) + let buf = IDELog tv sw + cid1 <- tv `afterFocusIn` + (\_ -> do reflectIDE (makeActive buf) ideR ; return False) + cid2 <- tv `onButtonPress` + (\ b -> do reflectIDE (clicked b buf) ideR ; return False) + cid3 <- tv `onPopulatePopup` (populatePopup buf ideR) + return (Just buf,[ConnectC cid1, ConnectC cid2]) clicked :: Event -> IDELog -> IDEAction clicked (Button _ SingleClick _ _ _ _ LeftButton x y) ideLog = do @@ -157,7 +166,7 @@ case filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1)) (zip logRefs' [0..(length logRefs')]) of [(thisRef,n)] -> do - mbBuf <- selectSourceBuf (filePath thisRef) + mbBuf <- selectSourceBuf (logRefFullFilePath thisRef) case mbBuf of Just buf -> markRefInSourceBuf n buf thisRef True Nothing -> return () @@ -192,36 +201,33 @@ Just _ -> do item1 <- menuItemNewWithLabel "Add import" item1 `onActivateLeaf` do - reflectIDE (addImport thisRef [] >> return()) ideR + reflectIDE (addImport thisRef [] (\_ -> return ())) ideR menuShellAppend menu item1 widgetShowAll menu return () otherwise -> return () mapM_ widgetHide $ take 2 (reverse items) -getLog' :: IDEM IDELog -getLog' = do - mbPane <- getPane +getLog :: IDEM IDELog +getLog = do + mbPane <- getOrBuildPane (Right "*Log") case mbPane of - Nothing -> do - pp <- getBestPathForId "*Log" - nb <- getNotebook pp - prefs' <- readIDE prefs - newPane pp nb (builder prefs') - mbPane <- getPane - case mbPane of - Nothing -> throwIDE "Can't init log" - Just l -> return l + Nothing -> throwIDE "Can't init log" Just p -> return p +showLog :: IDEAction +showLog = do + l <- getLog + displayPane l False + simpleLog :: String -> IDEAction simpleLog str = do log :: IDELog <- getLog liftIO $ appendLog log str LogTag return () -appendLog' :: IDELog -> String -> LogTag -> IO Int -appendLog' l@(IDELog tv _) string tag = do +appendLog :: IDELog -> String -> LogTag -> IO Int +appendLog l@(IDELog tv _) string tag = do buf <- textViewGetBuffer tv iter <- textBufferGetEndIter buf textBufferSelectRange buf iter iter @@ -249,8 +255,8 @@ Just mark -> textViewScrollMarkOnscreen tv mark return line -markErrorInLog' :: IDELog -> (Int,Int) -> IO () -markErrorInLog' (IDELog tv _) (l1,l2) = do +markErrorInLog :: IDELog -> (Int,Int) -> IO () +markErrorInLog (IDELog tv _) (l1,l2) = do idleAdd (do buf <- textViewGetBuffer tv iter <- textBufferGetIterAtLineOffset buf (l1-1) 0 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 @@ -18,9 +18,7 @@ module IDE.Pane.Modules ( IDEModules(..) , ModulesState(..) - -, showModules -, showInterface +--, showInterface , selectIdentifier , reloadKeepSelection , replaySelHistory @@ -32,6 +30,7 @@ import Data.Maybe import Control.Monad.Reader import qualified Data.Map as Map +import Data.Map (Map) import Data.Tree import Data.List import Distribution.Package @@ -55,9 +54,11 @@ import Graphics.UI.Editor.Parameters (paraMultiSel,Parameter(..),emptyParams,(<<<-),paraName) import Graphics.UI.Editor.Simple (boolEditor,okCancelFields,staticListEditor,stringEditor) import Graphics.UI.Editor.Basics (eventPaneName,GUIEventSelector(..)) -import IDE.Metainfo.Provider (rebuildActiveInfo) import qualified System.IO.UTF8 as UTF8 (writeFile) - +import IDE.Utils.GUIUtils (stockIdFromType) +import Debug.Trace +import IDE.Metainfo.Provider + (getSystemInfo, getWorkspaceInfo, getPackageInfo) -- | A modules pane description -- @@ -69,9 +70,10 @@ , treeStore :: TreeStore (String, [(ModuleDescr,PackageDescr)]) , descrView :: TreeView , descrStore :: TreeStore Descr -, localScopeB :: RadioButton , packageScopeB :: RadioButton -, systemScopeB :: RadioButton +, workspaceScopeB :: RadioButton +, systemScopeB :: RadioButton +, dependsB :: CheckButton , blacklistB :: CheckButton , oldSelection :: IORef SelectionState , expanderState :: IORef ExpanderState @@ -79,16 +81,20 @@ data ModulesState = ModulesState Int (Scope,Bool) - (Maybe ModuleName, Maybe Symbol) ExpanderState + (Maybe ModuleName, Maybe String) ExpanderState deriving(Eq,Ord,Read,Show,Typeable) data ExpanderState = ExpanderState { - localExp :: ExpanderFacet -, localExpNoBlack :: ExpanderFacet -, packageExp :: ExpanderFacet -, packageExpNoBlack :: ExpanderFacet -, systemExp :: ExpanderFacet -, systemExpNoBlack :: ExpanderFacet + packageExp :: ExpanderFacet +, packageExpNoBlack :: ExpanderFacet +, packageDExp :: ExpanderFacet +, packageDExpNoBlack :: ExpanderFacet +, workspaceExp :: ExpanderFacet +, workspaceExpNoBlack :: ExpanderFacet +, workspaceDExp :: ExpanderFacet +, workspaceDExpNoBlack :: ExpanderFacet +, systemExp :: ExpanderFacet +, systemExpNoBlack :: ExpanderFacet } deriving (Eq,Ord,Show,Read) type ExpanderFacet = ([TreePath], [TreePath]) @@ -100,22 +106,22 @@ , blacklist' :: Bool} deriving (Eq,Ord,Show) -instance IDEObject IDEModules - instance Pane IDEModules IDEM where primPaneName _ = "Modules" getAddedIndex _ = 0 getTopWidget = castToWidget . outer paneId b = "*Modules" - makeActive p = do - activatePane p [] --liftIO $ widgetGrabFocus (descrView p) - close = closePane +getModules :: Maybe PanePath -> IDEM IDEModules +getModules Nothing = forceGetPane (Right "*Modules") +getModules (Just pp) = forceGetPane (Left pp) + + instance RecoverablePane IDEModules ModulesState IDEM where saveState p = do - m <- getModules + m <- getModules Nothing sc <- getScope mbModules <- getPane recordExpanderState @@ -129,63 +135,215 @@ let mbs = (case mbTreeSelection of Nothing -> Nothing Just (_,[]) -> Nothing - Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), + Just (_,((md,_):_)) -> Just (modu $ mdModuleId md), case mbFacetSelection of Nothing -> Nothing - Just fw -> Just (descrName fw)) + Just fw -> Just (dscName fw)) return (Just (ModulesState i sc mbs expander)) recoverState pp (ModulesState i sc@(scope,useBlacklist) se exp) = do - nb <- getNotebook pp - ci <- readIDE currentInfo - newPane pp nb (builder ci) - mod <- getModules - liftIO $ writeIORef (expanderState mod) exp - case scope of - Local -> liftIO $ toggleButtonSetActive (localScopeB mod) True - Package -> liftIO $ toggleButtonSetActive (packageScopeB mod) True - System -> liftIO $ toggleButtonSetActive (systemScopeB mod) True - liftIO $ toggleButtonSetActive (blacklistB mod) useBlacklist - liftIO $ panedSetPosition (paned mod) i - fillModulesList sc - selectNames se - applyExpanderState - return () + nb <- getNotebook pp + p <- buildPane pp nb builder + mod <- getModules Nothing + liftIO $ writeIORef (expanderState mod) exp + liftIO $ writeIORef (oldSelection mod) (SelectionState (fst se) (snd se) scope useBlacklist) + liftIO $ panedSetPosition (paned mod) i + return p + builder pp nb windows = do + packageInfo' <- getPackageInfo + reifyIDE $ \ ideR -> do + let forest = case packageInfo' of + Nothing -> [] + Just (GenScopeC fst,GenScopeC snd) + -> subForest (buildModulesTree (fst,snd)) + treeStore <- treeStoreNew forest + treeView <- treeViewNew + treeViewSetModel treeView treeStore + --treeViewSetRulesHint treeView True + renderer0 <- cellRendererPixbufNew + set renderer0 [ cellPixbufStockId := "" ] + + renderer <- cellRendererTextNew + col <- treeViewColumnNew + treeViewColumnSetTitle col "Modules" + treeViewColumnSetSizing col TreeViewColumnAutosize + treeViewColumnSetResizable col True + treeViewColumnSetReorderable col True + treeViewAppendColumn treeView col + cellLayoutPackStart col renderer0 False + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer treeStore + $ \row -> [ cellText := fst row] + cellLayoutSetAttributes col renderer0 treeStore + $ \row -> [ + cellPixbufStockId := + if null (snd row) + then "" + else if isJust (mdMbSourcePath (fst (head (snd row)))) + then "ide_source" + else ""] + + renderer2 <- cellRendererTextNew + col2 <- treeViewColumnNew + treeViewColumnSetTitle col2 "Packages" + treeViewColumnSetSizing col2 TreeViewColumnAutosize + treeViewColumnSetResizable col2 True + treeViewColumnSetReorderable col2 True + treeViewAppendColumn treeView col2 + cellLayoutPackStart col2 renderer2 True + cellLayoutSetAttributes col2 renderer2 treeStore + $ \row -> [ cellText := (concat . intersperse ", ") + $ map (display . pdPackage . snd) (snd row)] + treeViewSetHeadersVisible treeView True + treeViewSetEnableSearch treeView True + treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore)) + + -- Facet view + + descrView <- treeViewNew + descrStore <- treeStoreNew [] + treeViewSetModel descrView descrStore + renderer30 <- cellRendererPixbufNew + renderer31 <- cellRendererPixbufNew + renderer3 <- cellRendererTextNew + col <- treeViewColumnNew + treeViewColumnSetTitle col "Interface" + --treeViewColumnSetSizing col TreeViewColumnAutosize + treeViewAppendColumn descrView col + cellLayoutPackStart col renderer30 False + cellLayoutPackStart col renderer31 False + cellLayoutPackStart col renderer3 True + cellLayoutSetAttributes col renderer3 descrStore + $ \row -> [ cellText := descrTreeText row] + cellLayoutSetAttributes col renderer30 descrStore + $ \row -> [ + cellPixbufStockId := stockIdFromType (descrIdType row)] + cellLayoutSetAttributes col renderer31 descrStore + $ \row -> [ + cellPixbufStockId := if isReexported row + then "ide_reexported" + else if isJust (dscMbLocation row) + then + if dscExported row + then "ide_source" + else "ide_source_local" + else ""] + treeViewSetHeadersVisible descrView True + treeViewSetEnableSearch descrView True + treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore)) + pane' <- hPanedNew + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + sw2 <- scrolledWindowNew Nothing Nothing + containerAdd sw2 descrView + scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic + panedAdd1 pane' sw + panedAdd2 pane' sw2 + (x,y) <- widgetGetSize nb + panedSetPosition pane' (max 200 (x `quot` 2)) + box <- hBoxNew True 2 + rb1 <- radioButtonNewWithLabel "Package" + rb2 <- radioButtonNewWithLabelFromWidget rb1 "Workspace" + rb3 <- radioButtonNewWithLabelFromWidget rb1 "System" + toggleButtonSetActive rb3 True + cb2 <- checkButtonNewWithLabel "Imports" + cb <- checkButtonNewWithLabel "Blacklist" + + boxPackStart box rb1 PackGrow 2 + boxPackStart box rb2 PackGrow 2 + boxPackStart box rb3 PackGrow 2 + boxPackEnd box cb PackNatural 2 + boxPackEnd box cb2 PackNatural 2 + + + boxOuter <- vBoxNew False 2 + boxPackStart boxOuter box PackNatural 2 + boxPackStart boxOuter pane' PackGrow 2 + oldState <- liftIO $ newIORef $ SelectionState Nothing Nothing SystemScope False + expanderState <- liftIO $ newIORef emptyExpansion + scopeRef <- newIORef (SystemScope,True) + let modules = IDEModules boxOuter pane' treeView treeStore descrView descrStore + rb1 rb2 rb3 cb2 cb oldState expanderState + cid3 <- treeView `onRowActivated` + (\ treePath _ -> do + treeViewExpandRow treeView treePath False + return ()) + cid1 <- treeView `afterFocusIn` + (\_ -> do reflectIDE (makeActive modules) ideR; return True) + cid2 <- descrView `afterFocusIn` + (\_ -> do reflectIDE (makeActive modules) ideR; return True) + treeView `onButtonPress` (treeViewPopup ideR treeStore treeView) + descrView `onButtonPress` (descrViewPopup ideR descrStore descrView) + rb1 `onToggled` (reflectIDE scopeSelection ideR) + rb2 `onToggled` (reflectIDE scopeSelection ideR) + rb3 `onToggled` (reflectIDE scopeSelection ideR) + cb `onToggled` (reflectIDE scopeSelection ideR) + cb2 `onToggled` (reflectIDE scopeSelection ideR) + sel <- treeViewGetSelection treeView + sel `onSelectionChanged` do + fillFacets treeView treeStore descrView descrStore + reflectIDE recordSelHistory ideR + return () + sel2 <- treeViewGetSelection descrView + sel2 `onSelectionChanged` do + fillInfo descrView descrStore ideR + reflectIDE recordSelHistory ideR + return () + return (Just modules,[ConnectC cid1,ConnectC cid2, ConnectC cid3]) + selectIdentifier :: Descr -> IDEAction selectIdentifier idDescr = do - accessibleInfo' <- readIDE accessibleInfo - currentInfo' <- readIDE currentInfo - currentScope <- getScope - let pid = pack (descrModu idDescr) - let mbNeededScope = case currentInfo' of - Just (localScope,packageScope) -> - if Map.member pid (fst localScope) - then Just Local - else if Map.member pid (fst packageScope) - then Just Package - else case accessibleInfo' of - Just worldScope -> - if Map.member pid (fst worldScope) - then Just System - else Nothing - Nothing -> Nothing - Nothing -> case accessibleInfo' of - Just worldScope -> - if Map.member pid (fst worldScope) - then Just System - else Nothing - Nothing -> Nothing - case mbNeededScope of + systemScope <- getSystemInfo + workspaceScope <- getWorkspaceInfo + packageScope <- getPackageInfo + currentScope <- getScope + case dsMbModu idDescr of Nothing -> return () - Just sc -> do - when (fst currentScope < sc) (setScope (sc,snd currentScope)) - selectIdentifier' (modu $ descrModu idDescr) (descrName idDescr) + Just pm -> case scopeForDescr pm packageScope workspaceScope systemScope of + Nothing -> return () + Just sc -> do + when (fst currentScope < sc) (setScope (sc,snd currentScope)) + selectIdentifier' (modu pm) (dscName idDescr) -selectIdentifier' :: ModuleName -> Symbol -> IDEAction +scopeForDescr :: PackModule -> Maybe (GenScope,GenScope) -> + Maybe (GenScope,GenScope) -> Maybe GenScope -> Maybe Scope +scopeForDescr pm packageScope workspaceScope systemScope = + case ps of + (True, r) -> Just (PackageScope r) + _ -> + case ws of + (True, r) -> Just (WorkspaceScope r) + _ -> case systemScope of + Nothing -> Nothing + Just (GenScopeC(PackScope ssc _)) -> if Map.member pid ssc + then Just SystemScope + else Nothing + where + pid = pack pm + ps = case packageScope of + Nothing -> (False,False) + Just (GenScopeC (PackScope psc1 _), GenScopeC (PackScope psc2 _)) -> + if Map.member pid psc1 + then (True,False) + else if Map.member pid psc2 + then (True,True) + else (False, False) + ws = case workspaceScope of + Nothing -> (False,False) + Just (GenScopeC (PackScope wsc1 _), GenScopeC (PackScope wsc2 _)) -> + if Map.member pid wsc1 + then (True,False) + else if Map.member pid wsc2 + then (True,True) + else (False, False) + + +selectIdentifier' :: ModuleName -> String -> IDEAction selectIdentifier' moduleName symbol = let nameArray = components moduleName in do - mods <- getModules + mods <- getModules Nothing mbTree <- liftIO $ treeStoreGetTreeSave (treeStore mods) [] case treePathFromNameArray mbTree nameArray [] of Just treePath -> liftIO $ do @@ -206,7 +364,7 @@ bringPaneToFront mods Nothing -> return () -findPathFor :: Symbol -> Maybe (Tree Descr) -> Maybe TreePath +findPathFor :: String -> Maybe (Tree Descr) -> Maybe TreePath findPathFor symbol (Just (Node _ forest)) = foldr ( \i mbTreePath -> findPathFor' [i] (forest !! i) mbTreePath) Nothing [0 .. ((length forest) - 1)] @@ -214,7 +372,7 @@ findPathFor' :: TreePath -> Tree Descr -> Maybe TreePath -> Maybe TreePath findPathFor' _ node (Just p) = Just p findPathFor' path (Node wrap sub) Nothing = - if descrName wrap == symbol + if dscName wrap == symbol then Just (reverse path) else foldr ( \i mbTreePath -> findPathFor' (i:path) (sub !! i) mbTreePath) @@ -231,173 +389,6 @@ Just i -> treePathFromNameArray (Just (subForest tree !! i)) t (i:accu) treePathFromNameArray Nothing _ _ = Nothing -showModules :: IDEAction -showModules = do - m <- getModules - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeView m) - -showInterface :: IDEAction -showInterface = do - m <- getModules - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (descrView m) - -getModules :: IDEM IDEModules -getModules = do - mbMod <- getPane - case mbMod of - Nothing -> do - pp <- getBestPathForId "*Modules" - nb <- getNotebook pp - ci <- readIDE currentInfo - newPane pp nb (builder ci) - mbMod <- getPane - case mbMod of - Nothing -> throwIDE "Can't init modules" - Just m -> return m - Just m -> return m - -builder :: Maybe (PackageScope, PackageScope) -> - PanePath -> - Notebook -> - Window -> - IDERef -> - IO (IDEModules,Connections) -builder currentInfo pp nb windows ideR = do - let forest = case currentInfo of - Nothing -> [] - Just pair -> subForest (buildModulesTree pair) - treeStore <- treeStoreNew forest - treeView <- treeViewNew - treeViewSetModel treeView treeStore - --treeViewSetRulesHint treeView True - - renderer0 <- cellRendererPixbufNew - set renderer0 [ cellPixbufStockId := "" ] - - renderer <- cellRendererTextNew - col <- treeViewColumnNew - treeViewColumnSetTitle col "Modules" - treeViewColumnSetSizing col TreeViewColumnAutosize - treeViewColumnSetResizable col True - treeViewColumnSetReorderable col True - treeViewAppendColumn treeView col - cellLayoutPackStart col renderer0 False - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer treeStore - $ \row -> [ cellText := fst row] - cellLayoutSetAttributes col renderer0 treeStore - $ \row -> [ - cellPixbufStockId := - if null (snd row) - then "" - else if isJust (mbSourcePathMD (fst (head (snd row)))) - then "ide_source" - else ""] - - renderer2 <- cellRendererTextNew - col2 <- treeViewColumnNew - treeViewColumnSetTitle col2 "Packages" - treeViewColumnSetSizing col2 TreeViewColumnAutosize - treeViewColumnSetResizable col2 True - treeViewColumnSetReorderable col2 True - treeViewAppendColumn treeView col2 - cellLayoutPackStart col2 renderer2 True - cellLayoutSetAttributes col2 renderer2 treeStore - $ \row -> [ cellText := (concat . intersperse ", ") - $ map (display . packagePD . snd) (snd row)] - treeViewSetHeadersVisible treeView True - treeViewSetEnableSearch treeView True - treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore)) - --- Facet view - - descrView <- treeViewNew - descrStore <- treeStoreNew [] - treeViewSetModel descrView descrStore - renderer30 <- cellRendererPixbufNew - renderer31 <- cellRendererPixbufNew - renderer3 <- cellRendererTextNew - col <- treeViewColumnNew - treeViewColumnSetTitle col "Interface" - --treeViewColumnSetSizing col TreeViewColumnAutosize - treeViewAppendColumn descrView col - cellLayoutPackStart col renderer30 False - cellLayoutPackStart col renderer31 False - cellLayoutPackStart col renderer3 True - cellLayoutSetAttributes col renderer3 descrStore - $ \row -> [ cellText := descrTreeText row] - cellLayoutSetAttributes col renderer30 descrStore - $ \row -> [ - cellPixbufStockId := stockIdFromType (descrIdType row)] - cellLayoutSetAttributes col renderer31 descrStore - $ \row -> [ - cellPixbufStockId := if isReexported row - then "ide_reexported" - else if isJust (mbLocation row) - then "ide_source" - else ""] - treeViewSetHeadersVisible descrView True - treeViewSetEnableSearch descrView True - treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore)) - pane' <- hPanedNew - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw treeView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - sw2 <- scrolledWindowNew Nothing Nothing - containerAdd sw2 descrView - scrolledWindowSetPolicy sw2 PolicyAutomatic PolicyAutomatic - panedAdd1 pane' sw - panedAdd2 pane' sw2 - (x,y) <- widgetGetSize nb - panedSetPosition pane' (x `quot` 2) - box <- hBoxNew True 2 - rb1 <- radioButtonNewWithLabel "Local" - rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package" - rb3 <- radioButtonNewWithLabelFromWidget rb1 "System" - toggleButtonSetActive rb3 True - cb <- checkButtonNewWithLabel "Blacklist" - - boxPackStart box rb1 PackGrow 2 - boxPackStart box rb2 PackGrow 2 - boxPackStart box rb3 PackGrow 2 - boxPackEnd box cb PackNatural 2 - - boxOuter <- vBoxNew False 2 - boxPackStart boxOuter box PackNatural 2 - boxPackStart boxOuter pane' PackGrow 2 - oldState <- liftIO $ newIORef $ SelectionState Nothing Nothing System False - expanderState <- liftIO $ newIORef emptyExpansion - scopeRef <- newIORef (System,True) - let modules = IDEModules boxOuter pane' treeView treeStore descrView descrStore - rb1 rb2 rb3 cb oldState expanderState - cid3 <- treeView `onRowActivated` - (\ treePath _ -> do - treeViewExpandRow treeView treePath False - return ()) - cid1 <- treeView `afterFocusIn` - (\_ -> do reflectIDE (makeActive modules) ideR; return True) - cid2 <- descrView `afterFocusIn` - (\_ -> do reflectIDE (makeActive modules) ideR; return True) - treeView `onButtonPress` (treeViewPopup ideR treeStore treeView) - descrView `onButtonPress` (descrViewPopup ideR descrStore descrView) - rb1 `onToggled` (reflectIDE scopeSelection ideR) - rb2 `onToggled` (reflectIDE scopeSelection ideR) - rb3 `onToggled` (reflectIDE scopeSelection ideR) - cb `onToggled` (reflectIDE scopeSelection ideR) - sel <- treeViewGetSelection treeView - sel `onSelectionChanged` do - fillFacets treeView treeStore descrView descrStore - reflectIDE recordSelHistory ideR - return () - sel2 <- treeViewGetSelection descrView - sel2 `onSelectionChanged` do - fillInfo descrView descrStore ideR - reflectIDE recordSelHistory ideR - return () - return (modules,[ConnectC cid1,ConnectC cid2, ConnectC cid3]) - treeViewSearch :: TreeView -> TreeStore (String, [(ModuleDescr,PackageDescr)]) -> String @@ -415,7 +406,7 @@ return () let str2 = case snd val of [] -> fst val - (m,_):_ -> showPackModule (moduleIdMD m) + (m,_):_ -> showPackModule (mdModuleId m) let res = isInfixOf (map toLower string) (map toLower str2) return res @@ -425,7 +416,7 @@ $ filter (\ val -> let cstr = case snd val of [] -> fst val - (m,_):_ -> show (Present (moduleIdMD m)) + (m,_):_ -> show (Present (mdModuleId m)) in isInfixOf (map toLower str) (map toLower cstr)) $ concatMap flatten (subForest tree) @@ -517,62 +508,80 @@ return () _ -> return () -findDescription :: PackModule -> SymbolTable -> Symbol -> Maybe (Symbol,Descr) +findDescription :: SymbolTable alpha => PackModule -> alpha -> String -> Maybe (String,Descr) findDescription md st s = - case Map.lookup s st of - Nothing -> Nothing - Just l -> case filter (\id -> md == descrModu id) l of - [] -> Nothing - l -> Just (s,head l) + case filter (\id -> case dsMbModu id of + Nothing -> False + Just pm -> md == pm) (symLookup s st) of + [] -> Nothing + l -> Just (s,head l) +getEmptyDefaultScope :: Map String [Descr] +getEmptyDefaultScope = Map.empty + fillModulesList :: (Scope,Bool) -> IDEAction fillModulesList (scope,useBlacklist) = do - mods <- getModules + mods <- getModules Nothing prefs <- readIDE prefs - currentInfo' <- readIDE currentInfo - accessibleInfo' <- readIDE accessibleInfo - case currentInfo' of - Nothing -> case (scope,accessibleInfo') of - (System,Just ai@(pm,ps)) -> - let p2 = if useBlacklist - then (Map.filter (filterBlacklist - (packageBlacklist prefs)) pm, ps) - else ai - (Node _ li) = buildModulesTree - ((Map.empty,Map.empty),p2) - in liftIO $ do - treeStoreClear (treeStore mods) - mapM_ (\(e,i) -> treeStoreInsertTree (treeStore mods) [] i e) - $ zip li [0 .. length li] - _ -> liftIO $ do + case scope of + SystemScope -> do + accessibleInfo' <- getSystemInfo + case accessibleInfo' of + Nothing -> liftIO $ do treeStoreClear (treeStore mods) treeStoreInsertTree (treeStore mods) [] 0 (Node ("",[]) []) - Just (l,p) -> let (l',p'@(pm,ps)) = case scope of - Local -> (l,(Map.empty,Map.empty)) - Package -> (l,p) - System -> case accessibleInfo' of - Just ai -> (l,ai) - Nothing -> (l,p) - p2 = if useBlacklist - then (Map.filter (filterBlacklist - (packageBlacklist prefs)) pm, ps) - else p' - (Node _ li) = buildModulesTree (l',p2) - in liftIO $ do - emptyModel <- treeStoreNew [] - treeViewSetModel (treeView mods) emptyModel - treeStoreClear (treeStore mods) - mapM_ (\(e,i) -> treeStoreInsertTree (treeStore mods) [] i e) - $ zip li [0 .. length li] - treeViewSetModel (treeView mods) (treeStore mods) - treeViewSetEnableSearch (treeView mods) True - treeViewSetSearchEqualFunc (treeView mods) - (Just (treeViewSearch (treeView mods) (treeStore mods))) + Just (GenScopeC ai@(PackScope pm ps)) -> + let p2 = if useBlacklist + then PackScope (Map.filter (filterBlacklist + (packageBlacklist prefs)) pm) ps + else ai + (Node _ li) = buildModulesTree (PackScope Map.empty getEmptyDefaultScope,p2) + in insertIt li mods + WorkspaceScope withImports -> do + workspaceInfo' <- getWorkspaceInfo + packageInfo' <- getPackageInfo + case workspaceInfo' of + Nothing -> insertIt [] mods + Just (GenScopeC l,GenScopeC p) -> + let (l',p'@(PackScope pm ps)) = if withImports + then (l, p) + else (l, PackScope Map.empty symEmpty) + p2 = if useBlacklist + then PackScope (Map.filter (filterBlacklist + (packageBlacklist prefs)) pm) ps + else p' + (Node _ li) = buildModulesTree (l', p2) + in insertIt li mods + PackageScope withImports -> do + packageInfo' <- getPackageInfo + case packageInfo' of + Nothing -> insertIt [] mods + Just (GenScopeC l,GenScopeC p) -> + let (l',p'@(PackScope pm ps)) = if withImports + then (l,p) + else (l, PackScope Map.empty symEmpty) + p2 = if useBlacklist + then PackScope (Map.filter (filterBlacklist + (packageBlacklist prefs)) pm) ps + else p' + (Node _ li) = buildModulesTree (l', p2) + in insertIt li mods + where + insertIt li mods = liftIO $ do + emptyModel <- treeStoreNew [] + treeViewSetModel (treeView mods) emptyModel + treeStoreClear (treeStore mods) + mapM_ (\(e,i) -> treeStoreInsertTree (treeStore mods) [] i e) + $ zip li [0 .. length li] + treeViewSetModel (treeView mods) (treeStore mods) + treeViewSetEnableSearch (treeView mods) True + treeViewSetSearchEqualFunc (treeView mods) + (Just (treeViewSearch (treeView mods) (treeStore mods))) filterBlacklist :: [Dependency] -> PackageDescr -> Bool filterBlacklist dependencies packageDescr = - let packageId = packagePD packageDescr + let packageId = pdPackage packageDescr name = pkgName packageId version = pkgVersion packageId in isNothing $ find (\ (Dependency str vr) -> str == name && withinRange version vr) @@ -584,91 +593,95 @@ descrTreeText :: Descr -> String -descrTreeText (Descr id _ _ _ _ (InstanceDescr binds)) = id ++ " " ++ printBinds binds +descrTreeText (Real (RealDescr id _ _ _ _ (InstanceDescr binds) _)) = id ++ " " ++ printBinds binds where printBinds [] = "" printBinds (a:[]) = a printBinds (a:b) = a ++ " " ++ printBinds b -descrTreeText d = descrName d +descrTreeText d = dscName d descrIdType :: Descr -> DescrType -descrIdType = descrType . details +descrIdType = descrType . dscTypeHint buildFacetForrest :: ModuleDescr -> DescrForest buildFacetForrest modDescr = - let (instances,other) = partition (\id -> case details id of + let (instances,other) = partition (\id -> case dscTypeHint id of InstanceDescr _ -> True _ -> False) - $ take 2000 $ idDescriptionsMD modDescr + $ take 2000 $ mdIdDescriptions modDescr -- TODO: Patch for toxioc TypeLevel package with 28000 aliases forestWithoutInstances = map buildFacet other (forest2,orphaned) = foldl' addInstances (forestWithoutInstances,[]) - instances + instances orphanedNodes = map (\ inst -> Node inst []) orphaned in forest2 ++ reverse orphanedNodes where -- expand nodes in a module desciption for the description tree buildFacet :: Descr -> DescrTree buildFacet descr = - case details descr of + case dscTypeHint descr of DataDescr constructors fields -> - Node descr ((map (\(fn,ty) -> Node (makeReexported descr (Descr{descrName' = fn, typeInfo' = ty, - descrModu' = descrModu descr, mbLocation' = mbLocation descr, - mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}})) []) + Node descr ((map (\(SimpleDescr fn ty loc comm exp) -> + Node (makeReexported descr (Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty, + dscMbModu' = dsMbModu descr, dscMbLocation' = loc, + dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp})) []) constructors) - ++ (map (\(fn,ty) -> Node (makeReexported descr (Descr{descrName' = fn, typeInfo' = ty, - descrModu' = descrModu descr, mbLocation' = mbLocation descr, - mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}})) []) + ++ (map (\(SimpleDescr fn ty loc comm exp) -> + Node (makeReexported descr (Real $ + RealDescr{dscName' = fn, dscMbTypeStr' = ty, + dscMbModu' = dsMbModu descr, dscMbLocation' = loc, + dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp})) []) fields)) - NewtypeDescr constr mbField -> - Node descr (Node (makeReexported descr (Descr{descrName' = fst constr, typeInfo' = snd constr, - descrModu' = descrModu descr, mbLocation' = mbLocation descr, - mbComment' = mbComment descr, details' = ConstructorDescr {typeDescrC = descr}})) [] + NewtypeDescr (SimpleDescr fn ty loc comm exp) mbField -> + Node descr (Node (makeReexported descr (Real $ + RealDescr{dscName' = fn, dscMbTypeStr' = ty, + dscMbModu' = dsMbModu descr, dscMbLocation' = loc, + dscMbComment' = comm, dscTypeHint' = ConstructorDescr descr, dscExported' = exp})) [] : case mbField of - Just fld -> - [Node (makeReexported descr (Descr{descrName' = fst fld, typeInfo' = snd fld, - descrModu' = descrModu descr, mbLocation' = mbLocation descr, - mbComment' = mbComment descr, details' = FieldDescr {typeDescrF = descr}})) []] + Just (SimpleDescr fn ty loc comm exp) -> + [Node (makeReexported descr (Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty, + dscMbModu' = dsMbModu descr, dscMbLocation' = loc, + dscMbComment' = comm, dscTypeHint' = FieldDescr descr, dscExported' = exp})) []] Nothing -> []) ClassDescr _ methods -> - Node descr (map (\(fn,ty) -> Node (makeReexported descr (Descr{descrName' = fn, typeInfo' = ty, - descrModu' = descrModu descr, mbLocation' = mbLocation descr, - mbComment' = mbComment descr, details' = MethodDescr {classDescrM = descr}})) []) - methods) + Node descr (map (\(SimpleDescr fn ty loc comm exp) -> + Node (makeReexported descr (Real $ RealDescr{dscName' = fn, dscMbTypeStr' = ty, + dscMbModu' = dsMbModu descr, dscMbLocation' = loc, + dscMbComment' = comm, dscTypeHint' = MethodDescr descr, dscExported' = exp})) []) + methods) _ -> Node descr [] where makeReexported :: Descr -> Descr -> Descr - makeReexported d1 d2 - | isReexported d1 = Reexported{descrModu' = descrModu' d1, impDescr = d2} - | otherwise = d2 + makeReexported (Reexported d1) d2 = Reexported $ ReexportedDescr{dsrMbModu = dsrMbModu d1, dsrDescr = d2} + makeReexported _ d2 = d2 addInstances :: (DescrForest,[Descr]) -> Descr -> (DescrForest,[Descr]) addInstances (forest,orphaned) instDescr = - case foldl' (matches instDescr) ([],False) forest of + case foldr (matches instDescr) ([],False) forest of (f,True) -> (f,orphaned) (f,False) -> (forest, instDescr:orphaned) matches :: Descr - -> (DescrForest,Bool) -> DescrTree -> (DescrForest,Bool) - matches instDescr (forest,False) (Node dd@(Descr id _ _ _ _ (DataDescr _ _)) sub) - | not (null (binds (details instDescr))) && - id == head (binds (details instDescr)) + -> (DescrForest,Bool) + matches (Real (instDescr@RealDescr{dscTypeHint' = InstanceDescr binds})) + (Node dd@(Real (RealDescr id _ _ _ _ (DataDescr _ _) _)) sub) (forest,False) + | not (null binds) && id == head binds = ((Node dd (sub ++ [Node newInstDescr []])):forest,True) - where newInstDescr = if isNothing (mbLocation instDescr) - then instDescr{mbLocation' = mbLocation dd} - else instDescr - matches instDescr (forest,False) (Node dd@(Descr id _ _ _ _ (NewtypeDescr _ _)) sub) - | not (null (binds (details instDescr))) && - id == head (binds (details instDescr)) + where newInstDescr = if isNothing (dscMbLocation' instDescr) + then Real $ instDescr{dscMbLocation' = dscMbLocation dd} + else Real $ instDescr + matches (Real (instDescr@RealDescr{dscTypeHint' = InstanceDescr binds})) + (Node dd@(Real (RealDescr id _ _ _ _ (NewtypeDescr _ _) _)) sub) (forest,False) + | not (null binds) && id == head binds = ((Node dd (sub ++ [Node newInstDescr []])):forest,True) - where newInstDescr = if isNothing (mbLocation instDescr) - then instDescr{mbLocation' = mbLocation dd} - else instDescr - matches _ (forest,b) node = (node:forest,b) + where newInstDescr = if isNothing (dscMbLocation' instDescr) + then Real $ instDescr{dscMbLocation' = dscMbLocation dd} + else Real $ instDescr + matches _ node (forest,b) = (node:forest,b) type ModTree = Tree (String, [(ModuleDescr,PackageDescr)]) @@ -676,9 +689,9 @@ -- | Make a Tree with a module desription, package description pairs tree to display. -- Their are nodes with a label but without a module (like e.g. Data). -- -buildModulesTree :: (PackageScope,PackageScope) -> ModTree -buildModulesTree ((localMap,_),(otherMap,_)) = - let flatPairs = concatMap (\p -> map (\m -> (m,p)) (exposedModulesPD p)) +buildModulesTree :: (SymbolTable alpha, SymbolTable beta) => (PackScope alpha,PackScope beta ) -> ModTree +buildModulesTree (PackScope localMap _,PackScope otherMap _) = + let flatPairs = concatMap (\p -> map (\m -> (m,p)) (pdModules p)) (Map.elems localMap ++ Map.elems otherMap) emptyTree = (Node ("",[]) []) resultTree = foldl' insertPairsInTree emptyTree flatPairs @@ -686,7 +699,7 @@ where insertPairsInTree :: ModTree -> (ModuleDescr,PackageDescr) -> ModTree insertPairsInTree tree pair = - let nameArray = components $ modu $ moduleIdMD $ fst pair + let nameArray = components $ modu $ mdModuleId $ fst pair pairedWith = map (\n -> (n,pair)) nameArray in insertNodesInTree pairedWith tree @@ -736,7 +749,7 @@ item1 `onActivateLeaf` do sel <- getSelectionTree treeView store case sel of - Just (_,[(m,_)]) -> case mbSourcePathMD m of + Just (_,[(m,_)]) -> case mdMbSourcePath m of Nothing -> return () Just fp -> do reflectIDE (selectSourceBuf fp) ideR @@ -764,7 +777,7 @@ else if button == LeftButton && click == DoubleClick then do sel <- getSelectionTree treeView store case sel of - Just (_,[(m,_)]) -> case mbSourcePathMD m of + Just (_,[(m,_)]) -> case mdMbSourcePath m of Nothing -> return () Just fp -> do reflectIDE (selectSourceBuf fp) ideR @@ -789,7 +802,13 @@ case sel of Just descr -> reflectIDE (goToDefinition descr) ideR otherwise -> sysMessage Normal "Modules>> descrViewPopup: no selection" - menuShellAppend theMenu item1 + item2 <- menuItemNewWithLabel "Insert in buffer" + item2 `onActivateLeaf` do + sel <- getSelectionDescr descrView store + case sel of + Just descr -> reflectIDE (insertInBuffer descr) ideR + otherwise -> sysMessage Normal "Modules>> descrViewPopup: no selection" + mapM_ (menuShellAppend theMenu) [item1, item2] menuPopup theMenu Nothing widgetShowAll theMenu return True @@ -808,37 +827,55 @@ setScope :: (Scope,Bool) -> IDEAction setScope (sc,bl) = do - mods <- getModules + mods <- getModules Nothing case sc of - Local -> liftIO $ toggleButtonSetActive (localScopeB mods) True - Package -> liftIO $ toggleButtonSetActive (packageScopeB mods) True - System -> liftIO $ toggleButtonSetActive (systemScopeB mods) True + (PackageScope False) -> liftIO $ do + toggleButtonSetActive (packageScopeB mods) True + widgetSetSensitive (dependsB mods) True + toggleButtonSetActive (dependsB mods) False + (PackageScope True) -> liftIO $ do + toggleButtonSetActive (packageScopeB mods) True + widgetSetSensitive (dependsB mods) True + toggleButtonSetActive (dependsB mods) True + (WorkspaceScope False) -> liftIO $ do + toggleButtonSetActive (workspaceScopeB mods) True + widgetSetSensitive (dependsB mods) True + toggleButtonSetActive (dependsB mods) False + (WorkspaceScope True) -> liftIO $ do + toggleButtonSetActive (workspaceScopeB mods) True + widgetSetSensitive (dependsB mods) True + toggleButtonSetActive (dependsB mods) True + SystemScope -> liftIO $ do + toggleButtonSetActive (systemScopeB mods) True + widgetSetSensitive (dependsB mods) False liftIO $ toggleButtonSetActive (blacklistB mods) bl selectScope (sc,bl) getScope :: IDEM (Scope,Bool) getScope = do - mods <- getModules - rb1s <- liftIO $ toggleButtonGetActive (localScopeB mods) - rb2s <- liftIO $ toggleButtonGetActive (packageScopeB mods) + mods <- getModules Nothing + rb1s <- liftIO $ toggleButtonGetActive (packageScopeB mods) + rb2s <- liftIO $ toggleButtonGetActive (workspaceScopeB mods) rb3s <- liftIO $ toggleButtonGetActive (systemScopeB mods) + cb1s <- liftIO $ toggleButtonGetActive (dependsB mods) cbs <- liftIO $ toggleButtonGetActive (blacklistB mods) let scope = if rb1s - then Local + then PackageScope cb1s else if rb2s - then Package - else System + then WorkspaceScope cb1s + else SystemScope return (scope,cbs) scopeSelection :: IDEAction scopeSelection = do (sc,bl) <- getScope + setScope (sc,bl) selectScope (sc,bl) selectScope :: (Scope,Bool) -> IDEAction selectScope (sc,bl) = do recordExpanderState - mods <- getModules + mods <- getModules Nothing mbTreeSelection <- liftIO $ getSelectionTree (treeView mods) (treeStore mods) mbDescrSelection <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods) @@ -849,18 +886,18 @@ let mbs = (case mbTreeSelection of Nothing -> Nothing Just (_,[]) -> Nothing - Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), + Just (_,((md,_):_)) -> Just (modu $ mdModuleId md), case mbDescrSelection of Nothing -> Nothing - Just fw -> Just (descrName fw)) + Just fw -> Just (dscName fw)) selectNames mbs recordScopeHistory applyExpanderState liftIO $ bringPaneToFront mods -selectNames :: (Maybe ModuleName, Maybe Symbol) -> IDEAction +selectNames :: (Maybe ModuleName, Maybe String) -> IDEAction selectNames (mbModuleName, mbIdName) = do - mods <- getModules + mods <- getModules Nothing case mbModuleName of Nothing -> liftIO $ do sel <- treeViewGetSelection (treeView mods) @@ -895,30 +932,39 @@ treeViewScrollToCell (descrView mods) path (fromJust col) (Just (0.3,0.3)) -reloadKeepSelection :: IDEAction -reloadKeepSelection = do +reloadKeepSelection :: Bool -> IDEAction +reloadKeepSelection isInitial = trace (">>>Info Changed!!! " ++ show isInitial) $ do mbMod <- getPane case mbMod of Nothing -> return () - Just mods - -> do - mbTreeSelection <- liftIO $ getSelectionTree (treeView mods) (treeStore mods) - mbDescrSelection <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods) - sc <- getScope - recordExpanderState - fillModulesList sc - liftIO $ treeStoreClear (descrStore mods) - let mbs = (case mbTreeSelection of - Nothing -> Nothing - Just (_,[]) -> Nothing - Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md), - case mbDescrSelection of + Just mods -> do + state <- readIDE currentState + if not $ isStartingOrClosing state + then do + mbTreeSelection <- liftIO $ getSelectionTree (treeView mods) (treeStore mods) + mbDescrSelection <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods) + sc <- getScope + recordExpanderState + fillModulesList sc + liftIO $ treeStoreClear (descrStore mods) + let mbs = (case mbTreeSelection of Nothing -> Nothing - Just fw -> Just (descrName fw)) - applyExpanderState - selectNames mbs - - + Just (_,[]) -> Nothing + Just (_,((md,_):_)) -> Just (modu $ mdModuleId md), + case mbDescrSelection of + Nothing -> Nothing + Just fw -> Just (dscName fw)) + applyExpanderState + selectNames mbs + else if isInitial == True + then do + SelectionState moduleS' facetS' sc bl <- trace (">>>Info Changed Initial") $ + liftIO $ readIORef (oldSelection mods) + setScope (sc,bl) + fillModulesList (sc, bl) + selectNames (moduleS', facetS') + applyExpanderState + else return () treeStoreGetTreeSave :: TreeStore a -> TreePath -> IO (Maybe (Tree a)) treeStoreGetTreeSave treeStore treePath = catch (do @@ -975,7 +1021,6 @@ liftIO $ UTF8.writeFile target template addModuleToPackageDescr moduleName isExposed packageConfig - rebuildActiveInfo fileOpenThis target @@ -1033,11 +1078,11 @@ -- * Expander State -emptyExpansion = ExpanderState ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) +emptyExpansion = ExpanderState ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) ([],[]) recordExpanderState :: IDEAction recordExpanderState = do - m <- getModules + m <- getModules Nothing liftIO $ do oldSel <- readIORef (oldSelection m) let (sc,bl) = (scope' oldSel, blacklist' oldSel) @@ -1045,12 +1090,18 @@ paths2 <- getExpandedRows (descrView m) (descrStore m) modifyIORef (expanderState m) (\ es -> case (sc,bl) of - (Local,True) -> es{localExp = (paths1,paths2)} - (Local,False) -> es{localExpNoBlack = (paths1,paths2)} - (Package,True) -> es{packageExp = (paths1,paths2)} - (Package,False) -> es{packageExpNoBlack = (paths1,paths2)} - (System,True) -> es{systemExp = (paths1,paths2)} - (System,False) -> es{systemExpNoBlack = (paths1,paths2)}) + ((PackageScope False),True) -> es{packageExp = (paths1,paths2)} + ((PackageScope False),False) -> es{packageExpNoBlack = (paths1,paths2)} + (PackageScope True,True) -> es{packageDExp = (paths1,paths2)} + (PackageScope True,False) -> es{packageDExpNoBlack = (paths1,paths2)} + + ((WorkspaceScope False),True) -> es{workspaceExp = (paths1,paths2)} + ((WorkspaceScope False),False) -> es{workspaceExpNoBlack = (paths1,paths2)} + (WorkspaceScope True,True) -> es{workspaceDExp = (paths1,paths2)} + (WorkspaceScope True,False) -> es{workspaceDExpNoBlack = (paths1,paths2)} + + (SystemScope,True) -> es{systemExp = (paths1,paths2)} + (SystemScope,False) -> es{systemExpNoBlack = (paths1,paths2)}) st <- readIORef (expanderState m) return () @@ -1081,17 +1132,21 @@ applyExpanderState :: IDEAction applyExpanderState = do - m <- getModules + m <- getModules Nothing (sc,bl) <- getScope liftIO $ do es <- readIORef (expanderState m) let (paths1,paths2) = case (sc,bl) of - (Local,True) -> localExp es - (Local,False) -> localExpNoBlack es - (Package,True) -> packageExp es - (Package,False) -> packageExpNoBlack es - (System,True) -> systemExp es - (System,False) -> systemExpNoBlack es + ((PackageScope False),True) -> packageExp es + ((PackageScope False),False) -> packageExpNoBlack es + (PackageScope True,True) -> packageDExp es + (PackageScope True,False) -> packageDExpNoBlack es + ((WorkspaceScope False),True) -> workspaceExp es + ((WorkspaceScope False),False) -> workspaceExpNoBlack es + (WorkspaceScope True,True) -> workspaceDExp es + (WorkspaceScope True,False) -> workspaceDExpNoBlack es + (SystemScope,True) -> systemExp es + (SystemScope,False) -> systemExpNoBlack es mapM_ (\p -> treeViewExpandToPath (treeView m) p) paths1 mapM_ (\p -> treeViewExpandToPath (descrView m) p) paths2 @@ -1099,26 +1154,26 @@ recordSelHistory :: IDEAction recordSelHistory = do - mods <- getModules + mods <- getModules Nothing ideR <- ask selTree <- liftIO $ getSelectionTree (treeView mods) (treeStore mods) selDescr <- liftIO $ getSelectionDescr (descrView mods) (descrStore mods) let selMod = case selTree of Nothing -> Nothing Just (_,[]) -> Nothing - Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md) + Just (_,((md,_):_)) -> Just (modu $ mdModuleId md) let selFacet = case selDescr of Nothing -> Nothing - Just descr -> Just (descrName descr) + Just descr -> Just (dscName descr) oldSel <- liftIO $ readIORef (oldSelection mods) triggerEventIDE (RecordHistory ((ModuleSelected selMod selFacet), (ModuleSelected (moduleS' oldSel) (facetS' oldSel)))) liftIO $ writeIORef (oldSelection mods) (oldSel{moduleS'= selMod, facetS' = selFacet}) return () -replaySelHistory :: Maybe ModuleName -> Maybe Symbol -> IDEAction +replaySelHistory :: Maybe ModuleName -> Maybe String -> IDEAction replaySelHistory mbModName mbFacetName = do - mods <- getModules + mods <- getModules Nothing selectNames (mbModName, mbFacetName) oldSel <- liftIO $ readIORef (oldSelection mods) liftIO $ writeIORef (oldSelection mods) @@ -1128,7 +1183,7 @@ recordScopeHistory = do (sc,bl) <- getScope ideR <- ask - mods <- getModules + mods <- getModules Nothing oldSel <- liftIO $ readIORef (oldSelection mods) triggerEventIDE (RecordHistory ((ScopeSelected sc bl), (ScopeSelected (scope' oldSel) (blacklist' oldSel)))) @@ -1137,12 +1192,12 @@ replayScopeHistory :: Scope -> Bool -> IDEAction replayScopeHistory sc bl = do - mods <- getModules + mods <- getModules Nothing liftIO $ do toggleButtonSetActive (blacklistB mods) bl - toggleButtonSetActive (localScopeB mods) (sc == Local) - toggleButtonSetActive (packageScopeB mods) (sc == Package) - toggleButtonSetActive (systemScopeB mods) (sc == System) + toggleButtonSetActive (packageScopeB mods) (sc == (PackageScope False)) + toggleButtonSetActive (workspaceScopeB mods) (sc == PackageScope True) + toggleButtonSetActive (systemScopeB mods) (sc == SystemScope) setScope (sc,bl) oldSel <- liftIO $ readIORef (oldSelection mods) liftIO $ writeIORef (oldSelection mods) (oldSel{scope'= sc, blacklist' = bl}) 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 @@ -30,19 +30,17 @@ import Distribution.PackageDescription import Distribution.Verbosity import System.FilePath -import Data.List import Data.Maybe import System.Directory import IDE.Core.State -import IDE.FileUtils +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 Debug.Trace (trace) -import qualified Distribution.InstalledPackageInfo as IPI (package) import Graphics.UI.Editor.Composite (versionEditor, versionRangeEditor, @@ -81,8 +79,6 @@ comboSelectionEditor, multilineStringEditor, stringEditor) -import Distribution.License (License(..)) -import IDE.Metainfo.GHCUtils (inGhc,getInstalledPackageInfos) import Graphics.UI.Editor.Basics (Editor(..)) import Distribution.Compiler (CompilerFlavor(..)) @@ -90,64 +86,22 @@ (knownExtensions, Extension(..), VersionRange(..)) -import Distribution.Version - (VersionRange(..)) import Default (Default(..)) -import Packages (PackageConfig(..)) +import IDE.Utils.GUIUtils +#if MIN_VERSION_Cabal(1,8,0) +#else +import Distribution.License +#endif -- --------------------------------------------------------------------- -- The exported stuff goes here -- choosePackageDir :: Window -> IO (Maybe FilePath) -choosePackageDir window = do - dialog <- fileChooserDialogNew - (Just $ "Select root folder for project") - (Just window) - FileChooserActionSelectFolder - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-open" - ,ResponseAccept)] - widgetShow dialog - response <- dialogRun dialog - case response of - ResponseAccept -> do - fn <- fileChooserGetFilename dialog - widgetDestroy dialog - return fn - ResponseCancel -> do - widgetDestroy dialog - return Nothing - ResponseDeleteEvent -> do - widgetDestroy dialog - return Nothing - _ -> return Nothing +choosePackageDir window = chooseDir window "Select root folder for project" Nothing choosePackageFile :: Window -> IO (Maybe FilePath) -choosePackageFile window = do - dialog <- fileChooserDialogNew - (Just $ "Select .cabal project file") - (Just window) - FileChooserActionOpen - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-open" - ,ResponseAccept)] - widgetShow dialog - response <- dialogRun dialog - case response of - ResponseAccept -> do - fn <- fileChooserGetFilename dialog - widgetDestroy dialog - return fn - ResponseCancel -> do - widgetDestroy dialog - return Nothing - ResponseDeleteEvent -> do - widgetDestroy dialog - return Nothing - _ -> return Nothing +choosePackageFile window = chooseFile window "Select cabal package file (.cabal)" Nothing packageEdit :: IDEAction packageEdit = do @@ -155,9 +109,9 @@ case mbActivePackage of Nothing -> sysMessage Normal "No active package to edit" Just idePackage -> do - let dirName = dropFileName (cabalFile idePackage) + let dirName = dropFileName (ipdCabalFile idePackage) modules <- liftIO $ allModules dirName - package <- liftIO $ readPackageDescription normal (cabalFile idePackage) + package <- liftIO $ readPackageDescription normal (ipdCabalFile idePackage) if hasConfigs package then do ideMessage High ("Cabal file with configurations can't be edited with the " @@ -210,7 +164,17 @@ writeFile (dirName "Setup.lhs") standardSetup else sysMessage Normal "Setup.(l)hs already exist" allModules dirName - editPackage emptyPackageDescription{buildType = Just Simple} dirName modules activateAction + 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 return () standardSetup = "#!/usr/bin/runhaskell \n" @@ -262,7 +226,6 @@ packageBox :: VBox } deriving Typeable -instance IDEObject PackagePane data PackageState = PackageState deriving (Read, Show, Typeable) @@ -273,12 +236,12 @@ getAddedIndex _ = 0 getTopWidget = castToWidget . packageBox paneId b = "*Package" - makeActive p = activatePane p [] - close = closePane instance RecoverablePane PackagePane PackageState IDEM where saveState p = return Nothing - recoverState pp st = return () + 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 @@ -287,11 +250,11 @@ Nothing -> do pp <- getBestPathForId "*Package" nb <- getNotebook pp - packageInfos <- inGhc $ getInstalledPackageInfos + packageInfos <- liftIO $ getInstalledPackageIds let packageEd = toEditor packageD initPackage packagePath packageEd (packageDD - (map IPI.package packageInfos) + packageInfos (takeDirectory packagePath) modules (length (bis packageEd)) @@ -311,27 +274,26 @@ initPackage packageDir packageD packageDescr panePath nb modules afterSaveAction = do let fields = trace ("initPackage called " ++ packageDir) $ flattenFieldDescription packageDescr let initialPackagePath = packageDir (display . pkgName . package . pd) packageD ++ ".cabal" - liftIO $ setCurrentDirectory packageDir - packageInfos <- inGhc $ getInstalledPackageInfos - newPane panePath nb (builder packageDir packageD packageDescr afterSaveAction initialPackagePath - modules packageInfos fields) + packageInfos <- liftIO $ getInstalledPackageIds + buildThisPane panePath nb + (builder' packageDir packageD packageDescr afterSaveAction + initialPackagePath modules packageInfos fields) return () -builder :: FilePath -> +builder' :: FilePath -> PackageDescriptionEd -> FieldDescription PackageDescriptionEd -> (FilePath -> IDEAction) -> FilePath -> [ModuleName] -> - [PackageConfig] -> + [PackageId] -> [FieldDescription PackageDescriptionEd] -> PanePath -> Notebook -> Window -> - IDERef -> - IO (PackagePane,Connections) -builder packageDir packageD packageDescr afterSaveAction initialPackagePath modules packageInfos fields - panePath nb window ideR = do + IDEM (Maybe PackagePane,Connections) +builder' packageDir packageD packageDescr afterSaveAction initialPackagePath modules packageInfos fields + panePath nb window = reifyIDE $ \ ideR -> do vb <- vBoxNew False 0 let packagePane = PackagePane vb bb <- hButtonBoxNew @@ -367,7 +329,7 @@ rid <- dialogRun md widgetDestroy md case rid of - ResponseYes -> (reflectIDE (close packagePane >> return ()) ideR) + ResponseYes -> (reflectIDE (closePane packagePane >> return ()) ideR) otherwise -> return () Just newPackage -> do let packagePath = packageDir (display . pkgName . package . pd) newPackage @@ -407,7 +369,7 @@ ResponseNo -> return False _ -> return False else return False - when (not cancel) (reflectIDE (close packagePane >> return ()) ideR)) + when (not cancel) (reflectIDE (closePane packagePane >> return ()) ideR)) restore `onClicked` (do package <- readPackageDescription normal initialPackagePath setInj (toEditor (flattenPackageDescription package))) @@ -417,10 +379,10 @@ Nothing -> sysMessage Normal "Content doesn't validate" Just pde -> do reflectIDE (do - close packagePane + closePane packagePane initPackage packageDir pde {bis = bis pde ++ [bis pde !! 0]} (packageDD - (map IPI.package packageInfos) + (packageInfos) packageDir modules (length (bis pde) + 1) @@ -433,10 +395,10 @@ Nothing -> sysMessage Normal "Content doesn't validate" Just pde | length (bis pde) == 1 -> sysMessage Normal "Just one Build Info" | otherwise -> reflectIDE (do - close packagePane + closePane packagePane initPackage packageDir pde{bis = take (length (bis pde) - 1) (bis pde)} (packageDD - (map IPI.package packageInfos) + packageInfos packageDir modules (length (bis pde) - 1) @@ -445,7 +407,7 @@ panePath nb modules afterSaveAction) ideR) boxPackStart vb widget PackGrow 7 boxPackEnd vb bb PackNatural 7 - return (packagePane,[]) + return (Just packagePane,[]) -- --------------------------------------------------------------------- -- The description with some tricks @@ -502,11 +464,15 @@ (stability . pd) (\ a b -> b{pd = (pd b){stability = a}}) (stringEditor (const 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) 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 #-} + -XTypeSynonymInstances -XRank2Types #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.PackageFlags @@ -19,31 +19,28 @@ module IDE.Pane.PackageFlags ( readFlags , writeFlags -, getFlags , IDEFlags(..) , FlagsState +, getFlags ) where import Graphics.UI.Gtk -import Control.Monad.Reader -import qualified Text.ParserCombinators.Parsec as P -import Data.List -import System.IO import qualified Text.PrettyPrint.HughesPJ as PP import Data.Typeable import System.FilePath.Posix - import IDE.Core.State import Graphics.UI.Editor.Basics import Graphics.UI.Editor.MakeEditor import Graphics.UI.Editor.Simple import Graphics.UI.Editor.Parameters - -import IDE.PrinterParser hiding (fieldParser,parameters) - +import Text.PrinterParser hiding (fieldParser,parameters) import Control.Event (registerEvent) -import IDE.DescriptionPP (extractFieldDescription,FieldDescriptionPP(..), - mkFieldPP,flattenFieldDescriptionPP) +import Graphics.UI.Editor.DescriptionPP + (flattenFieldDescriptionPPToS, + extractFieldDescription, + FieldDescriptionPP(..), + mkFieldPP) +import Text.ParserCombinators.Parsec hiding(Parser) data IDEFlags = IDEFlags { flagsBox :: VBox @@ -52,16 +49,12 @@ data FlagsState = FlagsState deriving(Eq,Ord,Read,Show,Typeable) -instance IDEObject IDEFlags - instance Pane IDEFlags IDEM where primPaneName _ = "Package Flags" getAddedIndex _ = 0 getTopWidget = castToWidget . flagsBox paneId b = "*Flags" - makeActive prefs = activatePane prefs [] - close = closePane instance RecoverablePane IDEFlags FlagsState IDEM where saveState p = do @@ -75,79 +68,160 @@ Just pack -> do pp <- getBestPathForId "*Flags" nb <- getNotebook pp - initFlags pack pp nb - Nothing -> return () + case mbPack of + Nothing -> return Nothing + Just pack -> buildThisPane pp nb builder + Nothing -> return Nothing + builder pp nb w = + let flagsDesc = extractFieldDescription flagsDescription + flatflagsDesc = flattenFieldDescription flagsDesc + in do + mbPack <- readIDE activePack + case mbPack of + Nothing -> return (Nothing,[]) + Just p -> reifyIDE $ \ideR -> builder' p flagsDesc flatflagsDesc pp nb window ideR -concatString :: [String] -> String -concatString l = foldl' (\r s -> if null r then s else r ++ " " ++ s) "" l +builder' idePackage flagsDesc flatflagsDesc pp nb window ideR = do + vb <- vBoxNew False 0 + let flagsPane = IDEFlags vb + bb <- hButtonBoxNew + ok <- buttonNewFromStock "gtk-ok" + closeB <- buttonNewFromStock "gtk-close" + boxPackStart bb ok PackNatural 0 + boxPackStart bb closeB PackNatural 0 + (widget,injb,ext,notifier) + <- buildEditor flagsDesc idePackage + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowAddWithViewport sw widget + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + ok `onClicked` (do + mbPackWithNewFlags <- extract idePackage [ext] + case mbPackWithNewFlags of + Nothing -> return () + Just packWithNewFlags -> do + reflectIDE (do + modifyIDE_ (\ide -> ide{activePack = Just packWithNewFlags}) + closePane flagsPane) ideR -- we don't trigger the activePack event here + writeFields ((dropExtension (ipdCabalFile packWithNewFlags)) ++ leksahFlagFileExtension) + packWithNewFlags flatFlagsDescription) + closeB `onClicked` (reflectIDE (closePane flagsPane >> return ()) ideR) + registerEvent notifier FocusIn (Left (\e -> do + reflectIDE (makeActive flagsPane) ideR + return (e{gtkReturn=False}))) + boxPackStart vb sw PackGrow 7 + boxPackEnd vb bb PackNatural 7 + return (Just flagsPane,[]) -flatFlagsDescription :: [FieldDescriptionPP IDEPackage] -flatFlagsDescription = flattenFieldDescriptionPP flagsDescription +getFlags :: Maybe PanePath -> IDEM IDEFlags +getFlags Nothing = forceGetPane (Right "*Flags") +getFlags (Just pp) = forceGetPane (Left pp) -flagsDescription :: FieldDescriptionPP IDEPackage +quoteArg :: String -> String +quoteArg s | ' ' `elem` s = "\"" ++ (escapeQuotes s) ++ "\"" +quoteArg s = s + +escapeQuotes = foldr (\c s -> if c == '"' then '\\':c:s else c:s) "" + +quotedArgCharParser :: CharParser () Char +quotedArgCharParser = try (do + char '\\' + anyChar) + <|> try (do + noneOf "\"") + "argsParser" + +argParser :: CharParser () String +argParser = try (do + char '"' + s <- many quotedArgCharParser + char '"' + return s) + <|> try (do + many1 (noneOf " ")) + "argParser" + +argsParser :: CharParser () [String] +argsParser = try (do + many (do + many (char ' ') + argParser)) + "argsParser" + +unargs :: [String] -> String +unargs = unwords . (map quoteArg) + +args :: String -> [String] +args s = case parse argsParser "" s of + Right result -> result + _ -> [s] + +flatFlagsDescription :: [FieldDescriptionS IDEPackage] +flatFlagsDescription = flattenFieldDescriptionPPToS flagsDescription + +flagsDescription :: FieldDescriptionPP IDEPackage IDEM flagsDescription = VFDPP emptyParams [ mkFieldPP (paraName <<<- ParaName "Config flags" $ emptyParams) (PP.text . show) stringParser - (\p -> concatString (configFlags p)) - (\ b a -> a{configFlags = if null b then [] else [b]}) + (\p -> unargs (ipdConfigFlags p)) + (\ b a -> a{ipdConfigFlags = args b}) (stringEditor (const True)) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Build flags" $ emptyParams) (PP.text . show) stringParser - (\p -> concatString (buildFlags p)) - (\ b a -> a{buildFlags = if null b then [] else [b]}) + (\p -> unargs (ipdBuildFlags p)) + (\ b a -> a{ipdBuildFlags = args b}) (stringEditor (const True)) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Haddock flags" $ emptyParams) (PP.text . show) stringParser - (\p -> concatString (haddockFlags p)) - (\ b a -> a{haddockFlags = if null b then [] else [b]}) + (\p -> unargs (ipdHaddockFlags p)) + (\ b a -> a{ipdHaddockFlags = args b}) (stringEditor (const True)) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Executable flags" $ emptyParams) (PP.text . show) stringParser - (\p -> concatString (exeFlags p)) - (\ b a -> a{exeFlags = if null b then [] else [b]}) + (\p -> unargs (ipdExeFlags p)) + (\ b a -> a{ipdExeFlags = args b}) (stringEditor (const True)) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Install flags" $ emptyParams) (PP.text . show) stringParser - (\p -> concatString (installFlags p)) - (\ b a -> a{installFlags = if null b then [] else [b]}) + (\p -> unargs (ipdInstallFlags p)) + (\ b a -> a{ipdInstallFlags = args b}) (stringEditor (const True)) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Register flags" $ emptyParams) (PP.text . show) stringParser - (\p -> concatString (registerFlags p)) - (\ b a -> a{registerFlags = if null b then [] else [b]}) + (\p -> unargs (ipdRegisterFlags p)) + (\ b a -> a{ipdRegisterFlags = args b}) (stringEditor (const True)) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Unregister flags" $ emptyParams) (PP.text . show) stringParser - (\p -> concatString (unregisterFlags p)) - (\ b a -> a{unregisterFlags = if null b then [] else [b]}) + (\p -> unargs (ipdUnregisterFlags p)) + (\ b a -> a{ipdUnregisterFlags = args b}) (stringEditor (const True)) (\ _ -> return ()) , mkFieldPP (paraName <<<- ParaName "Source Distribution flags" $ emptyParams) (PP.text . show) stringParser - (\p -> concatString (sdistFlags p)) - (\ b a -> a{sdistFlags = if null b then [] else [b]}) + (\p -> unargs (ipdSdistFlags p)) + (\ b a -> a{ipdSdistFlags = args b}) (stringEditor (const True)) (\ _ -> return ())] @@ -156,102 +230,14 @@ -- ------------------------------------------------------------ readFlags :: FilePath -> IDEPackage -> IO IDEPackage -readFlags fn pack = do - res <- P.parseFromFile (flagsParser pack flatFlagsDescription) fn - case res of - Left pe -> throwIDE $"Error reading flags file " ++ show fn ++ " " ++ show pe - Right r -> return r - -flagsParser :: a -> [FieldDescriptionPP a] -> P.CharParser () a -flagsParser def descriptions = - let parsersF = map fieldParser descriptions in do - whiteSpace - res <- applyFieldParsers def parsersF - return res - P. "flags parser" +readFlags fn pack = readFields fn flatFlagsDescription pack -- ------------------------------------------------------------ -- * Printing -- ------------------------------------------------------------ writeFlags :: FilePath -> IDEPackage -> IO () -writeFlags fpath flags = - writeFile fpath (showFlags flags flatFlagsDescription) +writeFlags fpath flags = writeFields fpath flags flatFlagsDescription -showFlags :: a -> [FieldDescriptionPP a] -> String -showFlags flags flagsDesc = PP.render $ - foldl' (\ doc (FDPP _ printer _ _ _ ) -> doc PP.$+$ printer flags) PP.empty flagsDesc --- ------------------------------------------------------------ --- * Editing --- ------------------------------------------------------------ -getFlags :: IDEM (Maybe IDEFlags) -getFlags = do - mbFlags <- getPane - case mbFlags of - Nothing -> do - mbPack <- readIDE activePack - case mbPack of - Nothing -> do - ideMessage Normal "can't edit flags without active package" - return Nothing - Just pack -> do - pp <- getBestPathForId "*Flags" - nb <- getNotebook pp - initFlags pack pp nb - mbFlags <- getPane - case mbFlags of - Nothing -> throwIDE "Can't init flags pane" - Just m -> do - liftIO $bringPaneToFront m - return (Just m) - Just m -> do - liftIO $bringPaneToFront m - return (Just m) - -initFlags :: IDEPackage -> PanePath -> Notebook -> IDEAction -initFlags idePackage panePath nb = do - let flagsDesc = extractFieldDescription flagsDescription - let flatflagsDesc = flattenFieldDescription flagsDesc - newPane panePath nb (builder idePackage flagsDesc flatflagsDesc) - return () - -builder :: IDEPackage -> - FieldDescription IDEPackage -> - [FieldDescription IDEPackage] -> - PanePath -> - Notebook -> - Window -> - IDERef -> - IO (IDEFlags,Connections) -builder idePackage flagsDesc flatflagsDesc pp nb window ideR = do - vb <- vBoxNew False 0 - let flagsPane = IDEFlags vb - bb <- hButtonBoxNew - ok <- buttonNewFromStock "gtk-ok" - closeB <- buttonNewFromStock "gtk-close" - boxPackStart bb ok PackNatural 0 - boxPackStart bb closeB PackNatural 0 - (widget,injb,ext,notifier) - <- buildEditor flagsDesc idePackage - sw <- scrolledWindowNew Nothing Nothing - scrolledWindowAddWithViewport sw widget - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - ok `onClicked` (do - mbPackWithNewFlags <- extract idePackage [ext] - case mbPackWithNewFlags of - Nothing -> return () - Just packWithNewFlags -> do - reflectIDE (do - modifyIDE_ (\ide -> ide{activePack = Just packWithNewFlags}) - close flagsPane) ideR -- we don't trigger the activePack event here - writeFlags ((dropFileName (cabalFile packWithNewFlags)) "IDE.flags") - packWithNewFlags) - closeB `onClicked` (reflectIDE (close flagsPane >> return ()) ideR) - registerEvent notifier FocusIn (Left (\e -> do - reflectIDE (makeActive flagsPane) ideR - return (e{gtkReturn=False}))) - boxPackStart vb sw PackGrow 7 - boxPackEnd vb bb PackNatural 7 - return (flagsPane,[]) 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 @@ -24,14 +24,11 @@ , writePrefs , defaultPrefs , prefsDescription -, editPrefs +, getPrefs ) where -import Graphics.UI.Gtk.SourceView -import Graphics.UI.Gtk +import Graphics.UI.Gtk hiding(background) import Control.Monad.Reader -import qualified Text.ParserCombinators.Parsec as P -import Data.List import qualified Text.PrettyPrint.HughesPJ as PP import Distribution.Package import Data.IORef @@ -44,23 +41,34 @@ import Graphics.UI.Editor.Composite import Graphics.UI.Editor.Parameters import Graphics.UI.Editor.MakeEditor hiding (parameters) -import IDE.DescriptionPP -import IDE.PrinterParser hiding (fieldParser,parameters) +import Graphics.UI.Editor.DescriptionPP +import Text.PrinterParser hiding (fieldParser,parameters) +import IDE.TextEditor import IDE.Pane.SourceBuffer import IDE.Pane.Log import Default -import IDE.FileUtils -import System.IO -import Distribution.InstalledPackageInfo (package) -import IDE.Metainfo.GHCUtils (getInstalledPackageInfos,inGhc) -import Packages (PackageConfig(..)) +import IDE.Utils.FileUtils +import IDE.Utils.GUIUtils import IDE.Debug (debugSetPrintBindResult, debugSetBreakOnError, debugSetBreakOnException, debugSetPrintEvldWithShow) +import Graphics.UI.Gtk.SourceView + (sourceStyleSchemeManagerGetSchemeIds, sourceStyleSchemeManagerNew) +import System.Time (getClockTime) +import System.FilePath(()) +import qualified IDE.StrippedPrefs as SP +import Control.Exception(SomeException,catch) +import Prelude hiding(catch) +-- --------------------------------------------------------------------- +-- This needs to be incremented, when the preferences format changes -- +prefsVersion :: Int +prefsVersion = 1 + +-- -- | The Preferences Pane -- @@ -71,122 +79,107 @@ data PrefsState = PrefsState deriving(Eq,Ord,Read,Show,Typeable) -instance IDEObject IDEPrefs - instance Pane IDEPrefs IDEM where primPaneName _ = "Prefs" getAddedIndex _ = 0 getTopWidget = castToWidget . prefsBox paneId b = "*Prefs" - makeActive prefs = activatePane prefs [] - close = closePane instance RecoverablePane IDEPrefs PrefsState IDEM where saveState p = return Nothing - recoverState pp st = return () - --- ------------------------------------------------------------ --- * Editing --- ------------------------------------------------------------ - -editPrefs :: IDEAction -editPrefs = do - getPrefs - return () - -getPrefs :: IDEM IDEPrefs -getPrefs = do - mbPrefs <- getPane - case mbPrefs of - Nothing -> do - pp <- getBestPathForId "*Prefs" - nb <- getNotebook pp - initPrefs pp nb - mbPrefs <- getPane - case mbPrefs of - Nothing -> throwIDE "Can't init prefs pane" - Just m -> do - liftIO $bringPaneToFront m - return m - Just m -> do - liftIO $bringPaneToFront m - return m - -initPrefs :: PanePath -> Notebook -> IDEAction -initPrefs panePath nb2 = do - packageInfos <- inGhc getInstalledPackageInfos - let flatPrefsDesc = flattenFieldDescriptionPP (prefsDescription (map package packageInfos)) - prefs <- readIDE prefs - lastAppliedPrefsRef <- liftIO $ newIORef prefs - currentInfo <- readIDE currentInfo - newPane panePath nb2 (builder lastAppliedPrefsRef packageInfos flatPrefsDesc prefs) - return () - -builder :: IORef Prefs -> - [PackageConfig] -> - [FieldDescriptionPP Prefs] -> - Prefs -> - PanePath -> - Notebook -> - Window -> - IDERef -> - IO (IDEPrefs,Connections) -builder lastAppliedPrefsRef packageInfos flatPrefsDesc prefs pp nb windows ideR = do - vb <- vBoxNew False 0 - bb <- hButtonBoxNew - apply <- buttonNewFromStock "gtk-apply" - restore <- buttonNewFromStock "Restore" - save <- buttonNewFromStock "gtk-save" - closeB <- buttonNewFromStock "gtk-close" - boxPackStart bb apply PackNatural 0 - boxPackStart bb restore PackNatural 0 - boxPackStart bb save PackNatural 0 - boxPackStart bb closeB PackNatural 0 - (widget,injb,ext,notifier) <- buildEditor (extractFieldDescription $ prefsDescription (map package packageInfos)) prefs - boxPackStart vb widget PackGrow 7 - boxPackEnd vb bb PackNatural 7 - let prefsPane = IDEPrefs vb - apply `onClicked` (do - mbNewPrefs <- extract prefs [ext] - case mbNewPrefs of - Nothing -> return () - Just newPrefs -> do - lastAppliedPrefs <- readIORef lastAppliedPrefsRef - mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc - writeIORef lastAppliedPrefsRef newPrefs) - restore `onClicked` (do - lastAppliedPrefs <- readIORef lastAppliedPrefsRef - mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF prefs lastAppliedPrefs) ideR ) flatPrefsDesc - injb prefs - writeIORef lastAppliedPrefsRef prefs) - save `onClicked` (do - lastAppliedPrefs <- readIORef lastAppliedPrefsRef - mbNewPrefs <- extract prefs [ext] - case mbNewPrefs of - Nothing -> return () - Just newPrefs -> do - mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc - fp <- getConfigFilePathForSave "Default.prefs" - writePrefs fp newPrefs - reflectIDE (modifyIDE_ (\ide -> ide{prefs = newPrefs})) ideR ) - closeB `onClicked` (reflectIDE (close prefsPane >> return ()) ideR ) - registerEvent notifier FocusIn (Left (\e -> do - reflectIDE (makeActive prefsPane) ideR - return (e{gtkReturn=False}))) - return (prefsPane,[]) + recoverState pp st = return Nothing + builder pp nb windows = do + prefs <- readIDE prefs + configDir <- liftIO getConfigDir + lastAppliedPrefsRef <- liftIO $ newIORef prefs + packageInfos <- liftIO $ getInstalledPackageIds + let flatPrefsDesc = flattenFieldDescriptionPP (prefsDescription configDir packageInfos) + reifyIDE $ \ ideR -> do + vb <- vBoxNew False 0 + bb <- hButtonBoxNew + apply <- buttonNewFromStock "gtk-apply" + restore <- buttonNewFromStock "Restore" + save <- buttonNewFromStock "gtk-save" + closeB <- buttonNewFromStock "gtk-close" + boxPackStart bb apply PackNatural 0 + boxPackStart bb restore PackNatural 0 + boxPackStart bb save PackNatural 0 + boxPackStart bb closeB PackNatural 0 + (widget,injb,ext,notifier) <- buildEditor + (extractFieldDescription $ prefsDescription configDir packageInfos) prefs + boxPackStart vb widget PackGrow 7 + boxPackEnd vb bb PackNatural 7 + let prefsPane = IDEPrefs vb + apply `onClicked` (do + mbNewPrefs <- extract prefs [ext] + case mbNewPrefs of + Nothing -> return () + Just newPrefs -> do + lastAppliedPrefs <- readIORef lastAppliedPrefsRef + mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc + writeIORef lastAppliedPrefsRef newPrefs) + restore `onClicked` (do + lastAppliedPrefs <- readIORef lastAppliedPrefsRef + mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF prefs lastAppliedPrefs) ideR ) flatPrefsDesc + injb prefs + writeIORef lastAppliedPrefsRef prefs) + save `onClicked` (do + lastAppliedPrefs <- readIORef lastAppliedPrefsRef + mbNewPrefs <- extract prefs [ext] + case mbNewPrefs of + Nothing -> return () + Just newPrefs -> do + mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF newPrefs lastAppliedPrefs) ideR ) flatPrefsDesc + fp <- getConfigFilePathForSave standardPreferencesFilename + writePrefs fp newPrefs + fp2 <- getConfigFilePathForSave strippedPreferencesFilename + SP.writeStrippedPrefs fp2 + (SP.Prefs {SP.sourceDirectories = sourceDirectories newPrefs, + SP.unpackDirectory = unpackDirectory newPrefs, + SP.retreiveURL = retreiveURL newPrefs, + SP.serverPort = serverPort newPrefs}) + reflectIDE (modifyIDE_ (\ide -> ide{prefs = newPrefs})) ideR ) + closeB `onClicked` (reflectIDE (closePane prefsPane >> return ()) ideR ) + registerEvent notifier FocusIn (Left (\e -> do + reflectIDE (makeActive prefsPane) ideR + return (e{gtkReturn=False}))) + return (Just prefsPane,[]) +getPrefs :: Maybe PanePath -> IDEM IDEPrefs +getPrefs Nothing = forceGetPane (Right "*Prefs") +getPrefs (Just pp) = forceGetPane (Left pp) -- ------------------------------------------------------------ -- * Dialog definition -- ------------------------------------------------------------ -prefsDescription :: [PackageIdentifier] -> FieldDescriptionPP Prefs -prefsDescription packages = NFDPP [ +prefsDescription :: FilePath -> [PackageIdentifier] -> FieldDescriptionPP Prefs IDEM +prefsDescription configDir packages = NFDPP [ ("Editor", VFDPP emptyParams [ mkFieldPP + (paraName <<<- ParaName "Version number of preferences file format" + $ paraSynopsis <<<- ParaSynopsis "Integer" + $ paraShowLabel <<<- ParaShowLabel False $ emptyParams) + (PP.text . show) + intParser + prefsFormat + (\ b a -> a{prefsFormat = b}) + (noEditor 0) + (\b -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Time of last storage" + $ paraShowLabel <<<- ParaShowLabel False $ emptyParams) + (PP.text . show) + stringParser + prefsSaveTime + (\ b a -> a{prefsSaveTime = b}) + (noEditor "") + (\b -> return ()) + , mkFieldPP (paraName <<<- ParaName "Show line numbers" - $ paraSynopsis <<<- ParaSynopsis "(True/False)" $ emptyParams) + $ paraSynopsis <<<- ParaSynopsis "(True/False)" + $ emptyParams) (PP.text . show) boolParser showLineNumbers @@ -194,7 +187,7 @@ boolEditor (\b -> do buffers <- allBuffers - mapM_ (\buf -> liftIO $ sourceViewSetShowLineNumbers (sourceView buf) b) buffers) + mapM_ (\buf -> setShowLineNumbers (sourceView buf) b) buffers) , mkFieldPP (paraName <<<- ParaName "TextView Font" $ emptyParams) (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s)) @@ -205,8 +198,7 @@ fontEditor (\mbs -> do buffers <- allBuffers - fdesc <- liftIO $ fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "") - liftIO $mapM_ (\buf -> widgetModifyFont (castToWidget $sourceView buf) (Just fdesc)) buffers) + mapM_ (\buf -> setFont (sourceView buf) mbs) buffers) , mkFieldPP (paraName <<<- ParaName "Right margin" $ paraSynopsis <<<- ParaSynopsis "Size or 0 for no right margin" @@ -221,12 +213,7 @@ True "Show it ?") (\b -> do buffers <- allBuffers - mapM_ (\buf -> case b of - Just n -> do - liftIO $sourceViewSetRightMarginPosition (sourceView buf) (fromIntegral n) - liftIO $sourceViewSetShowRightMargin (sourceView buf) True - Nothing -> liftIO $sourceViewSetShowRightMargin (sourceView buf) False) - buffers) + mapM_ (\buf -> setRightMargin (sourceView buf) b) buffers) , mkFieldPP (paraName <<<- ParaName "Tab width" $ emptyParams) (PP.text . show) @@ -236,7 +223,7 @@ (intEditor (1.0, 20.0, 1.0)) (\i -> do buffers <- allBuffers - mapM_ (\buf -> liftIO $sourceViewSetIndentWidth (sourceView buf) i) buffers) + mapM_ (\buf -> setIndentWidth (sourceView buf) i) buffers) , mkFieldPP (paraName <<<- ParaName "Use standard line ends even on windows" $ emptyParams) (PP.text . show) @@ -281,22 +268,62 @@ (\b a -> a{sourceStyle = b}) styleEditor (\mbs -> do - styleManager <- liftIO sourceStyleSchemeManagerNew - mbStyle <- case mbs of - Nothing -> return Nothing - Just str -> liftIO $ do - ids <- sourceStyleSchemeManagerGetSchemeIds styleManager - if elem str ids - then liftM Just - (sourceStyleSchemeManagerGetScheme styleManager str) - else return Nothing - case mbStyle of - Nothing -> return () - Just style -> do - buffers <- allBuffers - mapM_ (\buf -> do - gtkBuf <- liftIO $ textViewGetBuffer (sourceView buf) - liftIO $ sourceBufferSetStyleScheme (castToSourceBuffer gtkBuf) style) buffers) + buffers <- allBuffers + mapM_ (\buf -> do + ebuf <- getBuffer (sourceView buf) + setStyle ebuf mbs) buffers) + , mkFieldPP + (paraName <<<- ParaName "Found Text Background" $ emptyParams) + (PP.text . show) + colorParser + foundBackground + (\ b a -> a{foundBackground = b}) + colorEditor + (\c -> do + buffers <- allBuffers + forM_ buffers $ \buf -> do + ebuf <- getBuffer (sourceView buf) + tagTable <- getTagTable ebuf + mbTag <- lookupTag tagTable "found" + case mbTag of + Just tag -> background tag c + Nothing -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Execution Context Text Background" $ emptyParams) + (PP.text . show) + colorParser + contextBackground + (\ b a -> a{contextBackground = b}) + colorEditor + (\c -> do + buffers <- allBuffers + forM_ buffers $ \buf -> do + ebuf <- getBuffer (sourceView buf) + tagTable <- getTagTable ebuf + -- TODO find and set the tag background + return ()) + , mkFieldPP + (paraName <<<- ParaName "Breakpoint Text Background" $ emptyParams) + (PP.text . show) + colorParser + breakpointBackground + (\ b a -> a{breakpointBackground = b}) + colorEditor + (\c -> do + buffers <- allBuffers + forM_ buffers $ \buf -> do + ebuf <- getBuffer (sourceView buf) + tagTable <- getTagTable ebuf + -- TODO find and set the tag background + return ()) + , mkFieldPP + (paraName <<<- ParaName "Use Yi - Experimental feature (could wipe your files)" $ emptyParams) + (PP.text . show) + boolParser + useYi + (\b a -> a{useYi = b}) + boolEditor + (\i -> return ()) ]), ("GUI Options", VFDPP emptyParams [ mkFieldPP @@ -409,15 +436,23 @@ (filesEditor Nothing FileChooserActionSelectFolder "Select folder") (\i -> return ()) , mkFieldPP - (paraName <<<- ParaName "Extract packages from cabal-install" $ emptyParams) + (paraName <<<- ParaName "Maybe a directory for unpacking cabal packages" $ emptyParams) (PP.text . show) readParser - autoExtractTars - (\b a -> a{autoExtractTars = b}) - (maybeEditor ((fileEditor (Just "~/.cabal/packages/") FileChooserActionSelectFolder + unpackDirectory + (\b a -> a{unpackDirectory = b}) + (maybeEditor ((fileEditor (Just (configDir "packageSources")) FileChooserActionSelectFolder "Select folder"), emptyParams) True "Yes") (\i -> return ()) , mkFieldPP + (paraName <<<- ParaName "Maybe an URL to load prebuild metadata " $ emptyParams) + (PP.text . show) + readParser + retreiveURL + (\b a -> a{retreiveURL = b}) + (maybeEditor ((stringEditor (\ _ -> True)), emptyParams) True "Yes") + (\i -> return ()) + , mkFieldPP (paraName <<<- ParaName "Update metadata at startup" $ emptyParams) (PP.text . show) boolParser @@ -426,13 +461,21 @@ boolEditor (\i -> return ()) , mkFieldPP - (paraName <<<- ParaName "Update metadata after every build" $ emptyParams) + (paraName <<<- ParaName "Port number for server connection" $ emptyParams) (PP.text . show) - boolParser - collectAfterBuild - (\b a -> a{collectAfterBuild = b}) - boolEditor + intParser + serverPort + (\b a -> a{serverPort = b}) + (intEditor (1.0, 65535.0, 1.0)) (\i -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Server IP address " $ emptyParams) + (PP.text . show) + stringParser + serverIP + (\b a -> a{serverIP = b}) + (stringEditor (\ s -> not $ null s)) + (\i -> return ()) ]), ("Blacklist", VFDPP emptyParams [ mkFieldPP @@ -470,6 +513,17 @@ (\b a -> a{backgroundLink = b}) boolEditor (\i -> return ()) + , mkFieldPP + (paraName <<<- ParaName "Auto install packages" $ + paraShadow <<<- ParaShadow ShadowIn $emptyParams) + (PP.text . show) + readParser + autoInstall + (\b a -> a{autoInstall = b}) + (enumEditor ["Install always after a succesful build", + "Install if it's a library with dependend packages in the workspace", + "Never install"]) + (\i -> return ()) ]), ("Debug", VFDPP emptyParams [ mkFieldPP @@ -537,44 +591,49 @@ instance Default PackageIdentifier where - getDefault = case toPackageIdentifier "unknown-0" of + getDefault = case packageIdentifierFromString "unknown-0" of Nothing -> throwIDE "Preferences.getDefault: Can't parse Package Identifier" Just it -> it defaultPrefs = Prefs { - showLineNumbers = True + prefsFormat = prefsVersion + , prefsSaveTime = "" + , showLineNumbers = True , rightMargin = Just 100 , tabWidth = 4 - , sourceCandy = Just("Default") - , keymapName = "Default" + , sourceCandy = Just("candy") + , keymapName = "keymap" , forceLineEnds = True , removeTBlanks = True , textviewFont = Nothing , sourceStyle = Nothing + , foundBackground = Color 65535 65535 32768 + , contextBackground = Color 65535 49152 49152 + , breakpointBackground = Color 65535 49152 32768 + , useYi = False , logviewFont = Nothing , defaultSize = (1024,800) , browser = "firefox" , sourceDirectories = [] , packageBlacklist = [] , pathForCategory = [ ("EditorCategory",[SplitP (LeftP)]) - , ("TreeCategory",[SplitP (RightP),SplitP (TopP)]) - , ("LogCategory",[SplitP (RightP), SplitP (BottomP)]) - , ("DialogCategory",[SplitP (RightP),SplitP (TopP)])] + , ("ToolCategory",[SplitP (RightP),SplitP (TopP)]) + , ("LogCategory",[SplitP (RightP), SplitP (BottomP)])] , defaultPath = [SplitP (LeftP)] - , categoryForPane = [ ("*ClassHierarchy","TreeCategory") - , ("*Debug","TreeCategory") - , ("*Grep","TreeCategory") - , ("*Info","LogCategory") + , categoryForPane = [ ("*ClassHierarchy","ToolCategory") + , ("*Debug","ToolCategory") + , ("*Grep","ToolCategory") + , ("*Info","ToolCategory") , ("*Log","LogCategory") - , ("*Modules","TreeCategory") - , ("*Package","DialogCategory") - , ("*Flags","DialogCategory") - , ("*Prefs","DialogCategory") - , ("*References","LogCategory") - , ("*Search","TreeCategory")] - , collectAfterBuild = False + , ("*Modules","ToolCategory") + , ("*Package","ToolCategory") + , ("*Flags","ToolCategory") + , ("*Prefs","ToolCategory") + , ("*References","ToolCategory") + , ("*Search","ToolCategory")] , collectAtStart = True - , autoExtractTars = Nothing + , unpackDirectory = Nothing + , retreiveURL = Just "http://www.leksah.org" , useCtrlTabFlipping = True , docuSearchURL = "http://holumbus.fh-wedel.de/hayoo/hayoo.html?query=" , completeRestricted = False @@ -586,10 +645,13 @@ #else True #endif + , autoInstall = InstallLibs , printEvldWithShow = True , breakOnException = True , breakOnError = True , printBindResult = False + , serverPort = 11111 + , serverIP = "127.0.0.1" } -- ------------------------------------------------------------ @@ -598,28 +660,20 @@ readPrefs :: FilePath -> IO Prefs readPrefs fn = catch (do - res <- P.parseFromFile (prefsParser defaultPrefs (flattenFieldDescriptionPP - (prefsDescription []))) fn - case res of - Left pe -> throwIDE $ "Error reading prefs file " ++ show fn ++ " " ++ show pe - Right r -> return r) - (\ e -> throwIDE $ "Error reading prefs file " ++ show fn ++ " " ++ show e) - -prefsParser :: a -> [FieldDescriptionPP a] -> P.CharParser () a -prefsParser def descriptions = - let parsersF = map fieldParser descriptions in do - res <- applyFieldParsers def parsersF - return res - P. "prefs parser" - + configDir <- getConfigDir + readFields fn (flattenFieldDescriptionPPToS (prefsDescription configDir [])) defaultPrefs) + (\ (e :: SomeException) -> do + sysMessage Normal (show e) + return defaultPrefs) -- ------------------------------------------------------------ -- * Printing -- ------------------------------------------------------------ writePrefs :: FilePath -> Prefs -> IO () -writePrefs fpath prefs = writeFile fpath (showPrefs prefs (flattenFieldDescriptionPP (prefsDescription []))) +writePrefs fpath prefs = do + timeNow <- liftIO getClockTime + configDir <- getConfigDir + let newPrefs = prefs {prefsSaveTime = show timeNow, prefsFormat = prefsVersion} + writeFields fpath newPrefs (flattenFieldDescriptionPPToS (prefsDescription configDir [])) -showPrefs :: a -> [FieldDescriptionPP a] -> String -showPrefs prefs prefsDesc = PP.render $ - foldl (\ doc (FDPP _ printer _ _ _) -> doc PP.$+$ printer prefs) PP.empty prefsDesc diff --git a/src/IDE/Pane/References.hs b/src/IDE/Pane/References.hs --- a/src/IDE/Pane/References.hs +++ b/src/IDE/Pane/References.hs @@ -14,10 +14,10 @@ ------------------------------------------------------------------------------- module IDE.Pane.References ( - IDE(..) -, ReferencesState + ReferencesState +, IDEReferences , referencedFrom -, showReferences +, getReferences ) where import Graphics.UI.Gtk hiding (get) @@ -35,6 +35,8 @@ import Distribution.Text import Text.PrettyPrint (render) import IDE.Core.State +import IDE.Metainfo.Provider + (getSystemInfo, getWorkspaceInfo, getPackageInfo) -- | A References pane description @@ -44,7 +46,7 @@ scrolledView :: ScrolledWindow , treeViewC :: TreeView , referencesDescr :: IORef (Maybe Descr) -, referencesStore :: ListStore (ModuleDescr,Symbol) +, referencesStore :: ListStore (ModuleDescr,String) , refScopeRef :: IORef Scope , referencesEntry :: Entry , topBox :: VBox @@ -55,98 +57,177 @@ , refScope :: Scope} deriving(Eq,Ord,Read,Show,Typeable) - -instance IDEObject IDEReferences - instance Pane IDEReferences IDEM where primPaneName _ = "References" getAddedIndex _ = 0 getTopWidget = castToWidget . topBox paneId b = "*References" - makeActive p = activatePane p [] - close = closePane - --- | We don't recover this pane +-- | instance RecoverablePane IDEReferences ReferencesState IDEM where saveState p = do mbDescr <- liftIO $ readIORef (referencesDescr p) scope <- liftIO $ readIORef (refScopeRef p) return (Just (ReferencesState mbDescr scope)) - recoverState pp (ReferencesState mbDescr scope) = do - nb <- getNotebook pp - initReferences pp nb (Just scope) - when (isJust mbDescr) (referencedFrom (fromJust mbDescr)) + recoverState pp (ReferencesState mbDescr scope) = do + nb <- getNotebook pp + p <- buildPane pp nb builder + scopeSelection scope + when (isJust mbDescr) (referencedFrom (fromJust mbDescr)) + return p + builder pp nb windows = reifyIDE $ \ ideR -> do + scopebox <- hBoxNew True 2 + rb1 <- radioButtonNewWithLabel "Package" + rb2 <- radioButtonNewWithLabelFromWidget rb1 "Workspace" + rb3 <- radioButtonNewWithLabelFromWidget rb1 "System" + toggleButtonSetActive rb3 True + cb2 <- checkButtonNewWithLabel "Imports" -showReferences :: IDEAction -showReferences = do - m <- getReferences - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeViewC m) + boxPackStart scopebox rb1 PackGrow 2 + boxPackStart scopebox rb2 PackGrow 2 + boxPackStart scopebox rb3 PackGrow 2 + boxPackEnd scopebox cb2 PackNatural 2 + listStore <- listStoreNew [] + treeView <- treeViewNew + treeViewSetModel treeView listStore + renderer0 <- cellRendererPixbufNew + set renderer0 [ cellPixbufStockId := stockYes ] + + renderer <- cellRendererTextNew + col <- treeViewColumnNew + treeViewColumnSetTitle col "Modules" + treeViewColumnSetSizing col TreeViewColumnAutosize + treeViewColumnSetResizable col True + treeViewColumnSetReorderable col True + treeViewAppendColumn treeView col + cellLayoutPackStart col renderer0 False + cellLayoutPackStart col renderer True + cellLayoutSetAttributes col renderer listStore + $ \row -> [ cellText := render $ disp $ modu $ mdModuleId $ fst row] + cellLayoutSetAttributes col renderer0 listStore + $ \row -> [cellPixbufStockId := + if isJust (mdMbSourcePath $ fst row) + then stockJumpTo + else stockYes] + + renderer2 <- cellRendererTextNew + col2 <- treeViewColumnNew + treeViewColumnSetTitle col2 "Packages" + treeViewColumnSetSizing col2 TreeViewColumnAutosize + treeViewColumnSetResizable col True + treeViewColumnSetReorderable col2 True + treeViewAppendColumn treeView col2 + cellLayoutPackStart col2 renderer2 True + cellLayoutSetAttributes col2 renderer2 listStore + $ \row -> [ cellText := render $ disp $ pack $ mdModuleId $ fst row] + + treeViewSetHeadersVisible treeView True + sel <- treeViewGetSelection treeView + treeSelectionSetMode sel SelectionSingle + + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + entry <- entryNew + set entry [ entryEditable := False ] + box <- vBoxNew False 2 + boxPackStart box scopebox PackNatural 0 + boxPackStart box entry PackNatural 0 + boxPackEnd box sw PackGrow 0 + referencesDescr' <- newIORef Nothing + scopeRef <- newIORef SystemScope + let references = IDEReferences sw treeView referencesDescr' listStore scopeRef entry box + widgetShowAll box + cid1 <- treeView `afterFocusIn` + (\_ -> do reflectIDE (makeActive references) ideR ; return True) + treeView `onButtonPress` (treeViewPopup ideR references) + 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) + return (Just references,[ConnectC cid1]) + +getReferences :: Maybe PanePath -> IDEM IDEReferences +getReferences Nothing = forceGetPane (Right "*References") +getReferences (Just pp) = forceGetPane (Left pp) + + -- | Open a pane with the references of this identifier referencedFrom :: Descr -> IDEAction -referencedFrom idDescr = do - references <- getReferences - scope <- liftIO $ getScope references - mbCurrentInfo <- readIDE currentInfo - mbAccessibleInfo <- readIDE accessibleInfo - packages <- case scope of - System -> case mbAccessibleInfo of - Nothing -> case mbCurrentInfo of - Nothing -> return [] - Just currentInfo -> return - ((Map.elems . fst . fst) currentInfo) - Just scope -> case mbCurrentInfo of - Nothing -> return ((Map.elems . fst) scope) - Just currentInfo -> return - ((Map.elems . fst . fst) currentInfo - ++ (Map.elems . fst) scope) - Package -> case mbCurrentInfo of - Nothing -> return [] - Just currentInfo -> return ((Map.elems . fst . fst) currentInfo - ++ (Map.elems . fst . snd) currentInfo) - Local -> case mbCurrentInfo of - Nothing -> return [] - Just currentInfo -> return ((Map.elems . fst . fst) currentInfo) - let modulesList = modulesForCallerFromPackages packages (descrName idDescr, modu $ descrModu idDescr) - liftIO $ do - writeIORef (referencesDescr references) (Just idDescr) - listStoreClear (referencesStore references) - mapM_ (listStoreAppend (referencesStore references)) - $ sort $ zip modulesList (repeat (descrName idDescr)) - entrySetText (referencesEntry references) - $ descrName idDescr ++ - " << " ++ showPackModule (descrModu idDescr) - bringPaneToFront references +referencedFrom idDescr = + case dsMbModu idDescr of + Nothing -> return () + Just pm -> do + references <- getReferences Nothing + scope <- liftIO $ getScope references + mbPackageInfo <- getPackageInfo + mbWorkspaceInfo <- getWorkspaceInfo + mbSystemInfo <- getSystemInfo + let packages = packagesFromScope scope mbPackageInfo mbWorkspaceInfo mbSystemInfo + let modulesList = modulesForCallerFromPackages packages (dscName idDescr, modu pm) + liftIO $ do + writeIORef (referencesDescr references) (Just idDescr) + listStoreClear (referencesStore references) + mapM_ (listStoreAppend (referencesStore references)) + $ sort $ zip modulesList (repeat (dscName idDescr)) + entrySetText (referencesEntry references) + $ dscName idDescr ++ + " << " ++ showPackModule pm + bringPaneToFront references -modulesForCallerFromPackages :: [PackageDescr] -> (Symbol,ModuleName) -> [ModuleDescr] +packagesFromScope SystemScope + _ + (Just (_,GenScopeC (PackScope p1 _))) + (Just (GenScopeC (PackScope p2 _))) = Map.elems p1 ++ Map.elems p2 +packagesFromScope SystemScope + _ + (Just (GenScopeC (PackScope p1 _),GenScopeC (PackScope p2 _))) + _ = Map.elems p1 ++ Map.elems p2 +packagesFromScope (WorkspaceScope True) + _ + (Just (GenScopeC (PackScope p1 _),GenScopeC (PackScope p2 _))) + _ = Map.elems p1 ++ Map.elems p2 +packagesFromScope (WorkspaceScope False) + _ + (Just (GenScopeC (PackScope p1 _),_)) + _ = Map.elems p1 +packagesFromScope (PackageScope True) + (Just (GenScopeC (PackScope p1 _),GenScopeC (PackScope p2 _))) + _ + _ = Map.elems p1 ++ Map.elems p2 +packagesFromScope (PackageScope False) + (Just (GenScopeC (PackScope p1 _),_)) + _ + _ = Map.elems p1 +packagesFromScope _ _ _ _ = [] + +modulesForCallerFromPackages :: [PackageDescr] -> (String,ModuleName) -> [ModuleDescr] modulesForCallerFromPackages [] _ = [] modulesForCallerFromPackages (p :rest) (sym,mod) = - (filter (\ md -> case mod `Map.lookup` (referencesMD md) of + (filter (\ md -> case mod `Map.lookup` (mdReferences md) of Nothing -> False - Just syms -> sym `Set.member` syms) (exposedModulesPD p)) + Just syms -> sym `Set.member` syms) (pdModules p)) ++ modulesForCallerFromPackages rest (sym,mod) -getReferences :: IDEM IDEReferences -getReferences = do - mbMod <- getPane - case mbMod of - Nothing -> do - pp <- getBestPathForId "*References" - nb <- getNotebook pp - initReferences pp nb Nothing - mbMod <- getPane - case mbMod of - Nothing -> throwIDE "Can't init references" - Just m -> return m - Just m -> return m +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 - refs <- getReferences + refs <- getReferences Nothing liftIO $ writeIORef (refScopeRef refs) scope mbDescr <- liftIO $ readIORef (referencesDescr refs) case mbDescr of @@ -156,98 +237,10 @@ getScope :: IDEReferences -> IO Scope getScope refs = readIORef (refScopeRef refs) -initReferences :: PanePath -> Notebook -> Maybe Scope -> IDEAction -initReferences panePath nb mbScope = do - let scope = case mbScope of - Just s -> s - Nothing -> Package - newPane panePath nb (builder scope) - return () -builder :: Scope -> - PanePath -> - Notebook -> - Window -> - IDERef -> - IO (IDEReferences,Connections) -builder scope pp nb windows ideR = do - scopebox <- hBoxNew True 2 - rb1 <- radioButtonNewWithLabel "Local" - rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package" - rb3 <- radioButtonNewWithLabelFromWidget rb1 "System" - toggleButtonSetActive - (case scope of - Local -> rb1 - Package -> rb2 - System -> rb3) True - boxPackStart scopebox rb1 PackNatural 2 - boxPackStart scopebox rb2 PackNatural 2 - boxPackEnd scopebox rb3 PackNatural 2 - - listStore <- listStoreNew [] - treeView <- treeViewNew - treeViewSetModel treeView listStore - - renderer0 <- cellRendererPixbufNew - set renderer0 [ cellPixbufStockId := stockYes ] - - renderer <- cellRendererTextNew - col <- treeViewColumnNew - treeViewColumnSetTitle col "Modules" - treeViewColumnSetSizing col TreeViewColumnAutosize - treeViewColumnSetResizable col True - treeViewColumnSetReorderable col True - treeViewAppendColumn treeView col - cellLayoutPackStart col renderer0 False - cellLayoutPackStart col renderer True - cellLayoutSetAttributes col renderer listStore - $ \row -> [ cellText := render $ disp $ modu $ moduleIdMD $ fst row] - cellLayoutSetAttributes col renderer0 listStore - $ \row -> [cellPixbufStockId := - if isJust (mbSourcePathMD $ fst row) - then stockJumpTo - else stockYes] - - renderer2 <- cellRendererTextNew - col2 <- treeViewColumnNew - treeViewColumnSetTitle col2 "Packages" - treeViewColumnSetSizing col2 TreeViewColumnAutosize - treeViewColumnSetResizable col True - treeViewColumnSetReorderable col2 True - treeViewAppendColumn treeView col2 - cellLayoutPackStart col2 renderer2 True - cellLayoutSetAttributes col2 renderer2 listStore - $ \row -> [ cellText := render $ disp $ pack $ moduleIdMD $ fst row] - - treeViewSetHeadersVisible treeView True - sel <- treeViewGetSelection treeView - treeSelectionSetMode sel SelectionSingle - - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw treeView - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - entry <- entryNew - set entry [ entryEditable := False ] - box <- vBoxNew False 2 - boxPackStart box scopebox PackNatural 0 - boxPackStart box entry PackNatural 0 - boxPackEnd box sw PackGrow 0 - referencesDescr' <- newIORef Nothing - scopeRef <- newIORef scope - let references = IDEReferences sw treeView referencesDescr' listStore scopeRef entry box - widgetShowAll box - cid1 <- treeView `afterFocusIn` - (\_ -> do reflectIDE (makeActive references) ideR ; return True) - treeView `onButtonPress` (treeViewPopup ideR references) - rb1 `onToggled` (reflectIDE (scopeSelection Local) ideR ) - rb2 `onToggled` (reflectIDE (scopeSelection Package) ideR ) - rb3 `onToggled` (reflectIDE (scopeSelection System) ideR ) - return (references,[ConnectC cid1]) - - getSelectionTree :: TreeView - -> ListStore (ModuleDescr,Symbol) - -> IO (Maybe (ModuleDescr,Symbol)) + -> ListStore (ModuleDescr,String) + -> IO (Maybe (ModuleDescr,String)) getSelectionTree treeView listStore = do treeSelection <- treeViewGetSelection treeView rows <- treeSelectionGetSelectedRows treeSelection @@ -269,7 +262,7 @@ item1 `onActivateLeaf` do sel <- getSelectionTree (treeViewC references) (referencesStore references) case sel of - Just (m,_) -> case mbSourcePathMD m of + Just (m,_) -> case mdMbSourcePath m of Nothing -> return () Just fp -> do text <- entryGetText (referencesEntry references) @@ -288,7 +281,7 @@ (referencesStore references) case sel of Just (m,_) - -> case mbSourcePathMD m of + -> case mdMbSourcePath m of Nothing -> return False Just fp -> do text <- entryGetText (referencesEntry references) 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 @@ -17,22 +17,22 @@ module IDE.Pane.Search ( IDESearch(..) , SearchState -, showSearch , setChoices , searchMetaGUI +, getSearch ) where import Graphics.UI.Gtk hiding (get) import Graphics.UI.Gtk.Gdk.Events import Data.IORef (newIORef) import Data.IORef (writeIORef,readIORef,IORef(..)) -import IDE.Pane.Info (setInfo,IDEInfo(..)) 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) @@ -55,16 +55,12 @@ , searchMode :: SearchMode } deriving(Eq,Ord,Read,Show,Typeable) -instance IDEObject IDESearch - instance Pane IDESearch IDEM where primPaneName _ = "Search" getAddedIndex _ = 0 getTopWidget = castToWidget . topBox paneId b = "*Search" - makeActive p = activatePane p [] - close = closePane instance RecoverablePane IDESearch SearchState IDEM where saveState p = do @@ -74,167 +70,150 @@ return (Just (SearchState str scope mode)) recoverState pp (SearchState str scope mode) = do nb <- getNotebook pp - newPane pp nb (builder scope mode) + mbP <- buildPane pp nb builder + scopeSelection scope + modeSelection mode searchMetaGUI str - -showSearch :: IDEAction -showSearch = do - m <- getSearch - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (entry m) - -getSearch :: IDEM IDESearch -getSearch = do - mbSearch <- getPane - case mbSearch of - Just m -> return m - Nothing -> do - pp <- getBestPathForId "*Search" - nb <- getNotebook pp - newPane pp nb (builder System (Prefix False)) - mbSearch <- getPane - case mbSearch of - Nothing -> throwIDE "Can't init search" - Just m -> return m + return mbP + builder pp nb windows = + let scope = SystemScope + mode = Prefix False + in reifyIDE $ \ ideR -> do + scopebox <- hBoxNew True 2 + rb1 <- radioButtonNewWithLabel "Package" + rb2 <- radioButtonNewWithLabelFromWidget rb1 "Workspace" + rb3 <- radioButtonNewWithLabelFromWidget rb1 "System" + toggleButtonSetActive rb3 True + cb2 <- checkButtonNewWithLabel "Imports" -builder :: Scope -> - SearchMode -> - PanePath -> - Notebook -> - Window -> - IDERef -> - IO (IDESearch,Connections) -builder scope mode pp nb windows ideR = do - scopebox <- hBoxNew True 2 - rb1 <- radioButtonNewWithLabel "Local" - rb2 <- radioButtonNewWithLabelFromWidget rb1 "Package" - rb3 <- radioButtonNewWithLabelFromWidget rb1 "System" - toggleButtonSetActive - (case scope of - Local -> rb1 - Package -> rb2 - System -> rb3) True - boxPackStart scopebox rb1 PackNatural 2 - boxPackStart scopebox rb2 PackNatural 2 - boxPackEnd scopebox rb3 PackNatural 2 + boxPackStart scopebox rb1 PackGrow 2 + boxPackStart scopebox rb2 PackGrow 2 + boxPackStart scopebox rb3 PackGrow 2 + boxPackEnd scopebox cb2 PackNatural 2 - 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 + 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 + listStore <- listStoreNew [] + treeView <- treeViewNew + treeViewSetModel treeView listStore - 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 := descrName row] - cellLayoutSetAttributes col3 renderer30 listStore - $ \row -> [ - cellPixbufStockId := stockIdFromType ((descrType . details) row)] + 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)] - 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 := display $ modu $ descrModu' row] - cellLayoutSetAttributes col1 renderer10 listStore - $ \row -> [ - cellPixbufStockId := if isReexported row - then "ide_reexported" - else if isJust (mbLocation row) - then "ide_source" - else ""] - - 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 := display $ pack $ descrModu' row] + 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 ""] - treeViewSetHeadersVisible treeView True - sel <- treeViewGetSelection treeView - treeSelectionSetMode sel SelectionSingle + 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 + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - entry <- entryNew + 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 + 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 + scopeRef <- newIORef scope + modeRef <- newIORef mode + let search = IDESearch sw treeView listStore scopeRef modeRef box entry - cid1 <- treeView `afterFocusIn` - (\_ -> do reflectIDE (makeActive search) ideR ; return True) - rb1 `onToggled` (reflectIDE (scopeSelection Local) ideR ) - rb2 `onToggled` (reflectIDE (scopeSelection Package) ideR ) - rb3 `onToggled` (reflectIDE (scopeSelection System) 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` (listViewPopup ideR listStore treeView) - sel `onSelectionChanged` do - fillInfo search ideR - entry `afterKeyRelease` (\ event -> do - text <- entryGetText entry - reflectIDE (searchMetaGUI text) ideR - return False) - return (search,[ConnectC cid1]) + 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]) getScope :: IDESearch -> IO Scope getScope search = readIORef (searchScopeRef search) @@ -242,23 +221,40 @@ getMode :: IDESearch -> IO SearchMode getMode search = readIORef (searchModeRef search) +getSearch :: Maybe PanePath -> IDEM IDESearch +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 + search <- getSearch Nothing liftIO $ writeIORef (searchScopeRef search) scope text <- liftIO $ entryGetText (entry search) searchMetaGUI text modeSelection :: SearchMode -> IDEAction modeSelection mode = do - search <- getSearch + search <- getSearch Nothing liftIO $ writeIORef (searchModeRef search) mode text <- liftIO $ entryGetText (entry search) searchMetaGUI text modeSelectionCase :: Bool -> IDEAction modeSelectionCase caseSense = do - search <- getSearch + search <- getSearch Nothing oldMode <- liftIO $ readIORef (searchModeRef search) liftIO $ writeIORef (searchModeRef search) oldMode{caseSense = caseSense} text <- liftIO $ entryGetText (entry search) @@ -266,7 +262,7 @@ searchMetaGUI :: String -> IDEAction searchMetaGUI str = do - search <- getSearch + search <- getSearch Nothing liftIO $ bringPaneToFront search liftIO $ entrySetText (entry search) str scope <- liftIO $ getScope search @@ -279,39 +275,45 @@ listStoreClear (searchStore search) mapM_ (listStoreAppend (searchStore search)) (take 500 descrs) -listViewPopup :: IDERef +handleEvent :: IDERef -> ListStore Descr -> TreeView -> Event -> IO (Bool) -listViewPopup ideR store descrView (Button _ click _ _ _ _ button _ _) = do +handleEvent ideR store descrView (Button {eventClick = click, eventButton = button}) = do if button == RightButton then do theMenu <- menuNew item1 <- menuItemNewWithLabel "Go to definition" - item1 `onActivateLeaf` do - sel <- getSelectionDescr descrView store - case sel of - Just descr -> reflectIDE - (goToDefinition descr) ideR - otherwise -> sysMessage Normal "Search >> listViewPopup: no selection" + item1 `onActivateLeaf` (goToDef ideR store descrView) + menuShellAppend theMenu item1 menuPopup theMenu Nothing widgetShowAll theMenu return True else if button == LeftButton && click == DoubleClick - then do sel <- getSelectionDescr descrView store - case sel of - Just descr -> reflectIDE (triggerEvent ideR (SelectIdent descr)) - ideR >> return () - otherwise -> sysMessage Normal "Search >> listViewPopup: no selection2" - return True - else do - mbPane :: Maybe IDEInfo <- reflectIDE getPane ideR - when (isJust mbPane) $ bringPaneToFront (fromJust mbPane) - return False -listViewPopup _ _ _ _ = throwIDE "listViewPopup wrong event type" + then selectDescr ideR store descrView + else return False +handleEvent ideR store descrView (Key { eventKeyName = "Return"}) = + selectDescr ideR store descrView +handleEvent _ _ _ _ = return False + +goToDef ideR store descrView = do + sel <- getSelectionDescr descrView store + case sel of + Just descr -> reflectIDE + (goToDefinition descr) ideR + otherwise -> sysMessage Normal "Search >> listViewPopup: no selection" + +selectDescr ideR store descrView= do + sel <- getSelectionDescr descrView store + case sel of + Just descr -> reflectIDE (triggerEvent ideR (SelectIdent descr)) + ideR >> return () + otherwise -> sysMessage Normal "Search >> listViewPopup: no selection2" + return True + getSelectionDescr :: TreeView -> ListStore Descr -> IO (Maybe Descr) @@ -324,24 +326,27 @@ return (Just val) _ -> return Nothing -fillInfo :: IDESearch - -> IDERef - -> IO () -fillInfo search ideR = do - sel <- getSelectionDescr (treeView search) (searchStore search) - case sel of - Just descr -> do - reflectIDE (setInfo descr) ideR - entrySetText (entry search) (descrName descr) - otherwise -> return () +--fillInfo :: IDESearch +-- -> IDERef +-- -> IO () +--fillInfo search ideR = do +-- sel <- getSelectionDescr (treeView search) (searchStore search) +-- case sel of +-- Just descr -> do +-- reflectIDE (setInfo descr) ideR +-- entrySetText (entry search) (descrName descr) +-- otherwise -> return () setChoices :: [Descr] -> IDEAction setChoices descrs = do - search <- getSearch + search <- getSearch Nothing liftIO $ do listStoreClear (searchStore search) mapM_ (listStoreAppend (searchStore search)) descrs bringPaneToFront search - entrySetText (entry search) "" + entrySetText (entry search) + (case descrs of + [] -> "" + hd: _ -> dscName hd) 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,5 @@ -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances -XScopedTypeVariables #-} +{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances + -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.SourceBuffer @@ -18,12 +18,12 @@ IDEBuffer(..) , BufferState(..) - , allBuffers , maybeActiveBuf , selectSourceBuf , goToSourceDefinition , goToDefinition +, insertInBuffer , fileNew , fileOpenThis @@ -32,6 +32,7 @@ , fileClose , fileCloseAll , fileCloseAllButPackage +, fileCloseAllButWorkspace , fileSave , fileSaveAll , fileSaveBuffer @@ -55,54 +56,68 @@ , editCandy , markRefInSourceBuf -, inBufContext' , inBufContext -, inActiveBufContext' , inActiveBufContext , align , startComplete , selectedText +, selectedTextOrCurrentLine , insertTextAfterSelection , selectedModuleName , selectedLocation , recentSourceBuffers , newTextBuffer + +, belongsToPackage +, belongsToWorkspace ) where -import Graphics.UI.Gtk hiding (afterToggleOverwrite) -import Graphics.UI.Gtk.SourceView -import Graphics.UI.Gtk.Multiline.TextView -import Graphics.UI.Gtk.General.Enums (Click(..)) -import Graphics.UI.Gtk.Gdk.Events (eventClick) +import Prelude hiding(getChar, getLine) import Control.Monad.Reader -import System.IO import System.FilePath import System.Directory -import Text.Printf import qualified Data.Map as Map import Data.Map (Map) -import Data.List +import Data.List hiding(insert, delete) import Data.Maybe import Data.Typeable import System.Time - import IDE.Core.State -import IDE.FileUtils +import IDE.Utils.GUIUtils(getCandyState) +import IDE.Utils.FileUtils import IDE.SourceCandy import IDE.Completion as Completion (complete,cancel) +import IDE.TextEditor import Debug.Trace (trace) import qualified System.IO.UTF8 as UTF8 import Data.IORef (writeIORef,readIORef,newIORef,IORef(..)) -import Graphics.UI.Frame.Panes (IDEPane(..)) import Data.Char (isAlphaNum) import Control.Event (triggerEvent) -import SrcLoc - (srcLocCol, srcLocLine, srcSpanEnd, srcSpanStart) -import IDE.Metainfo.GHCUtils (parseHeader) -import GHC (SrcLoc(..), unLoc, moduleNameString, HsModule(..)) +import IDE.Metainfo.Provider (getSystemInfo, getWorkspaceInfo) +import Distribution.Text (simpleParse) +import Distribution.ModuleName (ModuleName) +import qualified Data.Set as Set (member) +import Graphics.UI.Gtk.Gdk.Events as Gtk +import Graphics.UI.Gtk + (Notebook, clipboardGet, atomNew, dialogAddButton, widgetDestroy, + fileChooserGetFilename, widgetShow, fileChooserDialogNew, + notebookGetNthPage, notebookPageNum, widgetHide, dialogRun, + messageDialogNew, postGUIAsync, scrolledWindowSetShadowType, + scrolledWindowSetPolicy, castToWidget, ScrolledWindow) +import System.Glib.MainLoop (priorityDefaultIdle, idleAdd) +import Graphics.UI.Gtk.Pango.Types (Underline(..)) +import qualified Graphics.UI.Gtk as Gtk (Window, Notebook) +import Graphics.UI.Gtk.General.Enums + (ShadowType(..), PolicyType(..)) +import Graphics.UI.Gtk.Windows.MessageDialog + (ButtonsType(..), MessageType(..)) +import Graphics.UI.Gtk.General.Structs (ResponseId(..)) +import Graphics.UI.Gtk.Selectors.FileChooser + (FileChooserAction(..)) + -- -- | A text editor pane description -- @@ -110,100 +125,87 @@ fileName :: Maybe FilePath , bufferName :: String , addedIndex :: Int -, sourceView :: SourceView +, sourceView :: EditorView , scrolledWindow :: ScrolledWindow , modTime :: IORef (Maybe (ClockTime)) -, language :: Maybe String } deriving (Typeable) data BufferState = BufferState FilePath Int | BufferStateTrans String String Int deriving(Eq,Ord,Read,Show,Typeable) -instance IDEObject IDEBuffer instance Pane IDEBuffer IDEM where primPaneName = bufferName getAddedIndex = addedIndex getTopWidget = castToWidget . scrolledWindow - paneId b = case fileName b of - Just s -> s - Nothing -> "?" ++ bufferName b - makeActive actbuf = do - ideR <- ask - sbLC <- getStatusbarLC - sbIO <- getStatusbarIO - infos <- readIDE accessibleInfo - let sv = sourceView actbuf - (cids) <- reifyIDE $ \ideR -> do - gtkBuf <- textViewGetBuffer sv - bringPaneToFront actbuf - writeCursorPositionInStatusbar sv sbLC - writeOverwriteInStatusbar sv sbIO - id1 <- gtkBuf `afterModifiedChanged` reflectIDE (markActiveLabelAsChanged) ideR - id2 <- sv `afterMoveCursor` - (\_ _ _ -> writeCursorPositionInStatusbar sv sbLC) - id3 <- gtkBuf `afterEndUserAction` writeCursorPositionInStatusbar sv sbLC - sv `widgetAddEvents` [ButtonReleaseMask] - id5 <- sv `onButtonRelease` - (\ e -> do - writeCursorPositionInStatusbar sv sbLC - when (controlIsPressed e) $ showInfo sv ideR - return False) - id6 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv sbIO - return [ConnectC id2,ConnectC id6,ConnectC id1,ConnectC id3] - activatePane actbuf cids - triggerEventIDE (Sensitivity [(SensitivityEditor, True)]) - checkModTime actbuf - return () - close pane = do makeActive pane - fileClose + paneId b = "" instance RecoverablePane IDEBuffer BufferState IDEM where - saveState p = do buf <- liftIO $ textViewGetBuffer (sourceView p) - ins <- liftIO $ textBufferGetInsert buf - iter <- liftIO $ textBufferGetIterAtMark buf ins - offset <- liftIO $ textIterGetOffset iter + saveState p = do buf <- getBuffer (sourceView p) + ins <- getInsertMark buf + iter <- getIterAtMark buf ins + offset <- getOffset iter case fileName p of Nothing -> do ct <- readIDE candy - text <- liftIO $ getCandylessText ct buf + text <- getCandylessText ct buf return (Just (BufferStateTrans (bufferName p) text offset)) Just fn -> return (Just (BufferState fn offset)) recoverState pp (BufferState n i) = do mbbuf <- newTextBuffer pp (takeFileName n) (Just n) case mbbuf of - Just buf -> liftIO $ do - gtkBuf <- textViewGetBuffer (sourceView buf) - iter <- textBufferGetIterAtOffset gtkBuf i - textBufferPlaceCursor gtkBuf iter - mark <- textBufferGetInsert gtkBuf - idleAdd (do - textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3)) + Just buf -> do + gtkBuf <- getBuffer (sourceView buf) + iter <- getIterAtOffset gtkBuf i + placeCursor gtkBuf iter + mark <- getInsertMark gtkBuf + ideR <- ask + liftIO $ idleAdd (do + reflectIDE (scrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3))) ideR return False) priorityDefaultIdle - return () - Nothing -> return () + return (Just buf) + Nothing -> return Nothing recoverState pp (BufferStateTrans bn text i) = do mbbuf <- newTextBuffer pp bn Nothing useCandy <- getCandyState case mbbuf of Just buf -> do - candy' <- readIDE candy - liftIO $ do - gtkBuf <- textViewGetBuffer (sourceView buf) - textBufferSetText gtkBuf text + candy' <- readIDE candy + gtkBuf <- getBuffer (sourceView buf) + setText gtkBuf text - when useCandy $ transformToCandy candy' gtkBuf - iter <- textBufferGetIterAtOffset gtkBuf i - textBufferPlaceCursor gtkBuf iter - mark <- textBufferGetInsert gtkBuf - idleAdd (do - textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3)) - return False) priorityDefaultIdle - return () - Nothing -> return () + when useCandy $ transformToCandy candy' gtkBuf + iter <- getIterAtOffset gtkBuf i + placeCursor gtkBuf iter + mark <- getInsertMark gtkBuf + ideR <- ask + liftIO $ idleAdd (do + reflectIDE (scrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3))) ideR + return False) priorityDefaultIdle + return (Just buf) + Nothing -> return Nothing + makeActive actbuf = do + ideR <- ask + let sv = sourceView actbuf + eBuf <- getBuffer sv + writeCursorPositionInStatusbar sv + writeOverwriteInStatusbar sv + ids1 <- eBuf `afterModifiedChanged` markActiveLabelAsChanged + ids2 <- sv `afterMoveCursor` writeCursorPositionInStatusbar sv + ids3 <- sv `onLookupInfo` selectInfo sv + ids4 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv + activateThisPane actbuf $ concat [ids1, ids2, ids3, ids4] + triggerEventIDE (Sensitivity [(SensitivityEditor, True)]) + checkModTime actbuf + return () + closePane pane = do makeActive pane + fileClose + buildPane panePath notebook builder = return Nothing + builder pp nb w = return (Nothing,[]) + startComplete :: IDEAction startComplete = do trace "start complete" return () @@ -248,122 +250,144 @@ _ -> return Nothing goToDefinition :: Descr -> IDEAction -goToDefinition idDescr = do - mbAccesibleInfo <- readIDE accessibleInfo - mbCurrentInfo <- readIDE currentInfo - if isJust mbAccesibleInfo && isJust mbCurrentInfo - then do - let packageId = pack $ descrModu idDescr - let mbPack = case packageId `Map.lookup` fst - (fromJust mbAccesibleInfo) of - Just it -> Just it - Nothing -> packageId `Map.lookup` fst (fst - (fromJust mbCurrentInfo)) - case mbPack of - Just pack -> case filter (\md -> moduleIdMD md == descrModu idDescr) - (exposedModulesPD pack) of - (mod : tl) -> if isJust (mbSourcePathMD mod) - then goToSourceDefinition - (fromJust $ mbSourcePathMD mod) - (mbLocation idDescr) - else return () - [] -> do ideMessage Normal "no module" - Nothing -> do ideMessage Normal "no package" - else ideMessage Normal "no infos" +goToDefinition idDescr = do + mbWorkspaceInfo <- getWorkspaceInfo + mbSystemInfo <- getSystemInfo + let mbSourcePath1 = case mbWorkspaceInfo of + Nothing -> Nothing + Just (sc, _) -> sourcePathFromScope sc + let mbSourcePath2 = case mbSourcePath1 of + Just sp -> Just sp + Nothing -> case mbSystemInfo of + Just si -> sourcePathFromScope si + Nothing -> Nothing + when (isJust mbSourcePath2) $ + goToSourceDefinition (fromJust $ mbSourcePath2) (dscMbLocation idDescr) + return () + where + sourcePathFromScope :: GenScope -> Maybe FilePath + sourcePathFromScope (GenScopeC (PackScope l _)) = + case dscMbModu idDescr of + Just mod -> case (pack mod) `Map.lookup` l of + Just pack -> + case filter (\md -> mdModuleId md == fromJust (dscMbModu idDescr)) + (pdModules pack) of + (mod : tl) -> mdMbSourcePath mod + [] -> Nothing + Nothing -> Nothing + Nothing -> Nothing goToSourceDefinition :: FilePath -> Maybe Location -> IDEAction -goToSourceDefinition fp mbLocation = do +goToSourceDefinition fp dscMbLocation = do mbBuf <- selectSourceBuf fp - when (isJust mbBuf && isJust mbLocation) $ - inActiveBufContext () $ \_ gtkbuf buf _ -> do - let location = fromJust mbLocation - lines <- textBufferGetLineCount gtkbuf - iter <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) + when (isJust mbBuf && isJust dscMbLocation) $ + inActiveBufContext () $ \_ ebuf buf _ -> do + let location = fromJust dscMbLocation + lines <- getLineCount ebuf + iterTemp <- getIterAtLine ebuf (max 0 (min (lines-1) ((locationSLine location) -1))) - chars <- textIterGetCharsInLine iter - textIterSetLineOffset iter (max 0 (min (chars-1) (locationSCol location))) - iter2 <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) + chars <- getCharsInLine iterTemp + iter <- atLineOffset iterTemp (max 0 (min (chars-1) (locationSCol location))) + iter2Temp <- getIterAtLine ebuf (max 0 (min (lines-1) ((locationELine location) -1))) - chars2 <- textIterGetCharsInLine iter2 - textIterSetLineOffset iter2 (max 0 (min (chars2-1) (locationECol location))) - textBufferPlaceCursor gtkbuf iter - smark <- textBufferGetSelectionBound gtkbuf - textBufferMoveMark gtkbuf smark iter2 + chars2 <- getCharsInLine iter2Temp + iter2 <- atLineOffset iter2Temp (max 0 (min (chars2-1) (locationECol location))) + placeCursor ebuf iter + smark <- getSelectionBoundMark ebuf + moveMark ebuf smark iter2 -- ### we had a problem before using this idleAdd thing - idleAdd (do - textViewScrollToIter (sourceView buf) iter 0.0 (Just (0.3,0.3)) + ideR <- ask + liftIO $ idleAdd (do + reflectIDE (scrollToIter (sourceView buf) iter 0.0 (Just (0.3,0.3))) ideR return False) priorityDefaultIdle return () +insertInBuffer :: Descr -> IDEAction +insertInBuffer idDescr = do + mbPaneName <- lastActiveBufferPane + case mbPaneName of + Nothing -> return () + Just name -> do + PaneC p <- paneFromName name + let mbBuf = cast p + case mbBuf of + Nothing -> return () + Just buf -> + inBufContext () buf $ \_ ebuf buf _ -> do + mark <- getInsertMark ebuf + iter <- getIterAtMark ebuf mark + insert ebuf iter (dscName idDescr) + markRefInSourceBuf :: Int -> IDEBuffer -> LogRef -> Bool -> IDEAction markRefInSourceBuf index buf logRef scrollTo = do useCandy <- getCandyState candy' <- readIDE candy contextRefs <- readIDE contextRefs - inBufContext () buf $ \_ gtkbuf buf _ -> do + prefs <- readIDE prefs + inBufContext () buf $ \_ ebuf buf _ -> do let tagName = (show $ logRefType logRef) ++ show index - tagTable <- textBufferGetTagTable gtkbuf - mbTag <- textTagTableLookup tagTable tagName + tagTable <- getTagTable ebuf + mbTag <- lookupTag tagTable tagName case mbTag of Just existingTag -> do - i1 <- textBufferGetStartIter gtkbuf - i2 <- textBufferGetEndIter gtkbuf - textBufferRemoveTagByName gtkbuf tagName i1 i2 + i1 <- getStartIter ebuf + i2 <- getEndIter ebuf + removeTagByName ebuf tagName i1 i2 Nothing -> do - errtag <- textTagNew (Just tagName) + errtag <- newTag tagTable tagName case logRefType logRef of ErrorRef -> do - set errtag[textTagUnderline := UnderlineError] + underline errtag UnderlineError WarningRef -> do - set errtag[textTagUnderline := UnderlineError] + underline errtag UnderlineError BreakpointRef -> do - set errtag[textTagBackground := "yellow"] + background errtag $ breakpointBackground prefs ContextRef -> do - set errtag[textTagBackground := "pink"] - textTagTableAdd tagTable errtag + background errtag $ contextBackground prefs - let start' = srcLocToPair $ srcSpanStart (logRefSrcSpan logRef) - let end' = srcLocToPair $ srcSpanEnd (logRefSrcSpan logRef) + let start' = (srcSpanStartLine (logRefSrcSpan logRef), + srcSpanStartColumn (logRefSrcSpan logRef)) + let end' = (srcSpanEndLine (logRefSrcSpan logRef), + srcSpanEndColumn (logRefSrcSpan logRef)) start <- if useCandy - then positionToCandy candy' gtkbuf start' + then positionToCandy candy' ebuf start' else return start' end <- if useCandy - then positionToCandy candy' gtkbuf end' + then positionToCandy candy' ebuf end' else return end' - lines <- textBufferGetLineCount gtkbuf - iter <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) ((fst start)-1))) - chars <- textIterGetCharsInLine iter - textIterSetLineOffset iter (max 0 (min (chars-1) (snd start))) + lines <- getLineCount ebuf + iterTmp <- getIterAtLine ebuf (max 0 (min (lines-1) ((fst start)-1))) + chars <- getCharsInLine iterTmp + iter <- atLineOffset iterTmp (max 0 (min (chars-1) (snd start))) iter2 <- if start == end then do - copy <- textIterCopy iter - textIterForwardWordEnd copy - return copy + maybeWE <- forwardWordEndC iter + case maybeWE of + Nothing -> atEnd iter + Just we -> return we else do - new <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) ((fst end)-1))) - chars <- textIterGetCharsInLine new - textIterSetLineOffset new (max 0 (min (chars-1) (snd end))) - textIterForwardChar new - return new + newTmp <- getIterAtLine ebuf (max 0 (min (lines-1) ((fst end)-1))) + chars <- getCharsInLine newTmp + new <- atLineOffset newTmp (max 0 (min (chars-1) (snd end))) + forwardCharC new let latest = if null contextRefs then Nothing else Just $ last contextRefs let isOldContext = case (logRefType logRef, latest) of (ContextRef, Just ctx) | ctx /= logRef -> True _ -> False - unless isOldContext $ textBufferApplyTagByName gtkbuf tagName iter iter2 - when scrollTo $ textBufferPlaceCursor gtkbuf iter - mark <- textBufferGetInsert gtkbuf + unless isOldContext $ applyTagByName ebuf tagName iter iter2 + when scrollTo $ placeCursor ebuf iter + mark <- getInsertMark ebuf when scrollTo $ do - idleAdd (do - textViewScrollToMark (sourceView buf) mark 0.3 Nothing - when (isOldContext && scrollTo) $ textBufferSelectRange gtkbuf iter iter2 + ideR <- ask + liftIO $ idleAdd (do + reflectIDE (do + scrollToMark (sourceView buf) mark 0.3 Nothing + when (isOldContext && scrollTo) $ selectRange ebuf iter iter2) ideR return False) priorityDefaultIdle return () -srcLocToPair :: SrcLoc -> (Int,Int) -srcLocToPair srcLoc = (srcLocLine srcLoc, srcLocCol srcLoc) - allBuffers :: IDEM [IDEBuffer] allBuffers = getPanes @@ -390,13 +414,12 @@ bs <- getCandyState ct <- readIDE candy (ind,rbn) <- figureOutPaneName bn 0 - pane <- newPane panePath nb (builder bs mbfn ind bn rbn ct prefs) - return (Just pane) + buildThisPane panePath nb (builder' bs mbfn ind bn rbn ct prefs) else do ideMessage Normal ("File does not exist " ++ (fromJust mbfn)) return Nothing -builder :: Bool -> +builder' :: Bool -> Maybe FilePath -> Int -> String -> @@ -404,123 +427,84 @@ CandyTable -> Prefs -> PanePath -> - Notebook -> - Window -> - IDERef -> - IO (IDEBuffer,Connections) -builder bs mbfn ind bn rbn ct prefs pp nb windows ideR = do - lm <- sourceLanguageManagerNew - (mbLanguage, mbSLang) <- sourceLanguageForFilename lm mbfn - - -- create a new SourceBuffer object - buffer <- case mbSLang of - Just sLang -> sourceBufferNewWithLanguage sLang - Nothing -> sourceBufferNew Nothing - sourceBufferSetMaxUndoLevels buffer (-1) - tagTable <- textBufferGetTagTable buffer - foundTag <- textTagNew (Just "found") - set foundTag [textTagBackground := "yellow"] - textTagTableAdd tagTable foundTag - + Gtk.Notebook -> + Gtk.Window -> + IDEM (Maybe IDEBuffer,Connections) +builder' bs mbfn ind bn rbn ct prefs pp nb windows = do + ideR <- ask -- load up and display a file (fileContents,modTime) <- case mbfn of Just fn -> do - fc <- UTF8.readFile fn - mt <- getModificationTime fn + fc <- liftIO $ UTF8.readFile fn + mt <- liftIO $ getModificationTime fn return (fc,Just mt) Nothing -> return ("\n",Nothing) - sourceBufferBeginNotUndoableAction buffer - textBufferSetText buffer fileContents - when bs $ transformToCandy ct (castToTextBuffer buffer) - sourceBufferEndNotUndoableAction buffer - textBufferSetModified buffer False - siter <- textBufferGetStartIter buffer - textBufferPlaceCursor buffer siter - iter <- textBufferGetEndIter buffer - textBufferCreateMark buffer (Just "end") iter True + buffer <- (if useYi prefs then newYiBuffer else newGtkBuffer) mbfn fileContents + tagTable <- getTagTable buffer + foundTag <- newTag tagTable "found" + background foundTag $ foundBackground prefs + + beginNotUndoableAction buffer + when bs $ transformToCandy ct buffer + endNotUndoableAction buffer + setModified buffer False + siter <- getStartIter buffer + placeCursor buffer siter + iter <- getEndIter buffer + -- create a new SourceView Widget - sv <- sourceViewNewWithBuffer buffer - fd <- case textviewFont prefs of - Just str -> do - fontDescriptionFromString str - Nothing -> do - f <- fontDescriptionNew - fontDescriptionSetFamily f "Monospace" - return f - widgetModifyFont sv (Just fd) - set sv [sourceViewHighlightCurrentLine := True] - sourceViewSetShowLineNumbers sv (showLineNumbers prefs) - case rightMargin prefs of - Just n -> do - set sv [sourceViewShowRightMargin := True] - sourceViewSetRightMarginPosition sv (fromIntegral n) - Nothing -> set sv [sourceViewShowRightMargin := False] - sourceViewSetInsertSpacesInsteadOfTabs sv True - sourceViewSetIndentWidth sv (tabWidth prefs) - sourceViewSetTabWidth sv (tabWidth prefs) - sourceViewSetIndentOnTab sv True - sourceViewSetAutoIndent sv True - sourceViewSetSmartHomeEnd sv SourceSmartHomeEndBefore - case sourceStyle prefs of - Nothing -> return () - Just str -> do - styleManager <- sourceStyleSchemeManagerNew - ids <- sourceStyleSchemeManagerGetSchemeIds styleManager - when (elem str ids) $ do - scheme <- sourceStyleSchemeManagerGetScheme styleManager str - sourceBufferSetStyleScheme buffer scheme + sv <- newView buffer + setFont sv $ textviewFont prefs + setShowLineNumbers sv $ showLineNumbers prefs + setRightMargin sv $ rightMargin prefs + setIndentWidth sv $ tabWidth prefs + setTabWidth sv $ tabWidth prefs + setStyle buffer $ sourceStyle prefs -- put it in a scrolled window - sw <- scrolledWindowNew Nothing Nothing - containerAdd sw sv - scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic - scrolledWindowSetShadowType sw ShadowIn - modTimeRef <- newIORef modTime - let buf = IDEBuffer mbfn bn ind sv sw modTimeRef mbLanguage + sw <- getScrolledWindow sv + liftIO $ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + liftIO $ scrolledWindowSetShadowType sw ShadowIn + modTimeRef <- liftIO $ newIORef modTime + let buf = IDEBuffer mbfn bn ind sv sw modTimeRef -- events - cid <- sv `afterFocusIn` - (\_ -> do reflectIDE (makeActive buf) ideR ; return False) - buffer `afterBufferInsertText` - (\iter text -> do - case text of - [c] | ((isAlphaNum c) || (c == '.') || (c == '_')) -> do - reflectIDE (Completion.complete sv False) ideR - _ -> return () - ) - sv `onMoveCursor` - (\step n select -> do reflectIDE Completion.cancel ideR) - sv `onButtonPress` + ids1 <- sv `afterFocusIn` makeActive buf + ids2 <- onCompletion sv (Completion.complete sv False) Completion.cancel + ids3 <- sv `onButtonPress` \event -> do let click = eventClick event - liftIO $ do - reflectIDE Completion.cancel ideR + liftIO $ reflectIDE (do case click of DoubleClick -> do let isSelectChar a = (isAlphaNum a) || (a == '_') - (start, end) <- textBufferGetSelectionBounds buffer - mbStartChar <- textIterGetChar start - mbEndChar <- textIterGetChar end - case mbStartChar of + (startSel, endSel) <- getSelectionBounds buffer + mbStartChar <- getChar startSel + mbEndChar <- getChar endSel + start <- case mbStartChar of Just startChar | isSelectChar startChar -> do - found <- textIterBackwardFindChar start (not.isSelectChar) Nothing - when found $ do - textIterForwardChar start - return () - _ -> return () - case mbEndChar of + 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 - textIterForwardFindChar end (not.isSelectChar) Nothing - return () - _ -> return () - textBufferSelectRange buffer start end - return True - _ -> return False - (GetTextPopup mbTpm) <- reflectIDE (triggerEvent ideR (GetTextPopup Nothing)) ideR - case mbTpm of - Just tpm -> sv `onPopulatePopup` (tpm ideR) >> return () - Nothing -> sysMessage Normal "SourceBuffer>> no text popup" >> return () - return (buf,[ConnectC cid]) + maybeIter <- forwardFindCharC endSel (not.isSelectChar) Nothing + case maybeIter of + Just iter -> return iter + Nothing -> return endSel + _ -> return endSel + liftIO $ postGUIAsync $ reflectIDE (selectRange buffer start end) ideR + return False + _ -> return False) ideR + (GetTextPopup mbTpm) <- triggerEvent ideR (GetTextPopup Nothing) + ids4 <- case mbTpm of + Just tpm -> sv `onPopulatePopup` \menu -> liftIO $ (tpm ideR menu) + Nothing -> do + sysMessage Normal "SourceBuffer>> no text popup" + return [] + return (Just buf,concat [ids1, ids2, ids3, ids4]) checkModTime :: IDEBuffer -> IDEM Bool @@ -577,7 +561,7 @@ writeIORef (modTime buf) (Just nmt) fileRevert :: IDEAction -fileRevert = inActiveBufContext' () $ \ _ _ currentBuffer _ -> do +fileRevert = inActiveBufContext () $ \ _ _ currentBuffer _ -> do revert currentBuffer revert :: IDEBuffer -> IDEAction @@ -587,46 +571,43 @@ let name = paneName buf case fileName buf of Nothing -> return () - Just fn -> liftIO $do - buffer' <- textViewGetBuffer (sourceView buf) - let buffer = castToSourceBuffer buffer' - fc <- UTF8.readFile fn - mt <- getModificationTime fn - sourceBufferBeginNotUndoableAction buffer - textBufferSetText buffer fc + Just fn -> do + buffer <- getBuffer (sourceView buf) + fc <- liftIO $ UTF8.readFile fn + mt <- liftIO $ getModificationTime fn + beginNotUndoableAction buffer + setText buffer fc if useCandy - then transformToCandy ct (castToTextBuffer buffer) + then transformToCandy ct buffer else return () - sourceBufferEndNotUndoableAction buffer - textBufferSetModified buffer False + endNotUndoableAction buffer + setModified buffer False return mt - writeIORef (modTime buf) (Just mt) + liftIO $ writeIORef (modTime buf) (Just mt) -writeCursorPositionInStatusbar :: SourceView -> Statusbar -> IO() -writeCursorPositionInStatusbar sv sb = do - buf <- textViewGetBuffer sv - mark <- textBufferGetInsert buf - iter <- textBufferGetIterAtMark buf mark - line <- textIterGetLine iter - col <- textIterGetLineOffset iter - statusbarPop sb 1 - statusbarPush sb 1 $printf "Ln %4d, Col %3d" (line + 1) (col + 1) +writeCursorPositionInStatusbar :: EditorView -> IDEAction +writeCursorPositionInStatusbar sv = do + buf <- getBuffer sv + mark <- getInsertMark buf + iter <- getIterAtMark buf mark + line <- getLine iter + col <- getLineOffset iter + triggerEventIDE (StatusbarChanged [CompartmentBufferPos (line,col)]) return () -writeOverwriteInStatusbar :: SourceView -> Statusbar -> IO() -writeOverwriteInStatusbar sv sb = do - modi <- textViewGetOverwrite sv - statusbarPop sb 1 - statusbarPush sb 1 $ if modi then "OVR" else "INS" +writeOverwriteInStatusbar :: EditorView -> IDEAction +writeOverwriteInStatusbar sv = do + mode <- getOverwrite sv + triggerEventIDE (StatusbarChanged [CompartmentOverlay mode]) return () - -showInfo :: SourceView -> IDERef -> IO () -showInfo sv ideR = do - buf <- textViewGetBuffer sv - (l,r) <- textBufferGetSelectionBounds buf - symbol <- textBufferGetText buf l r True - reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR +selectInfo :: EditorView -> IDEAction +selectInfo sv = do + ideR <- ask + buf <- getBuffer sv + (l,r) <- getSelectionBounds buf + symbol <- getText buf l r True + triggerEvent ideR (SelectInfo symbol) return () markActiveLabelAsChanged :: IDEAction @@ -639,16 +620,16 @@ mbBS <- maybeActiveBuf case mbBS of Nothing -> return () - Just buf -> liftIO $ markLabelAsChanged nb buf + Just buf -> markLabelAsChanged nb buf -markLabelAsChanged :: Notebook -> IDEBuffer -> IO () +markLabelAsChanged :: Notebook -> IDEBuffer -> IDEAction markLabelAsChanged nb buf = do - gtkbuf <- textViewGetBuffer (sourceView buf) - modified <- textBufferGetModified gtkbuf - markLabel nb (getTopWidget buf) modified + ebuf <- getBuffer (sourceView buf) + modified <- getModified ebuf + liftIO $ markLabel nb (getTopWidget buf) modified -inBufContext' :: alpha -> IDEBuffer -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha -inBufContext' def ideBuf f = do +inBufContext :: alpha -> IDEBuffer -> (Notebook -> EditorBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha +inBufContext def ideBuf f = do (pane,_) <- guiPropertiesFromName (paneName ideBuf) nb <- getNotebook pane mbI <- liftIO $notebookPageNum nb (scrolledWindow ideBuf) @@ -657,25 +638,19 @@ sysMessage Normal $ bufferName ideBuf ++ " notebook page not found: unexpected" return def Just i -> do - gtkbuf <- liftIO $ textViewGetBuffer (sourceView ideBuf) - f nb gtkbuf ideBuf i - -inBufContext :: alpha -> IDEBuffer -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IO alpha) -> IDEM alpha -inBufContext def ideBuff f = inBufContext' def ideBuff (\ a b c d -> liftIO $ f a b c d) + ebuf <- getBuffer (sourceView ideBuf) + f nb ebuf ideBuf i -inActiveBufContext' :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha -inActiveBufContext' def f = do +inActiveBufContext :: alpha -> (Notebook -> EditorBuffer -> IDEBuffer -> Int -> IDEM alpha) -> IDEM alpha +inActiveBufContext def f = do mbBuf <- maybeActiveBuf case mbBuf of Nothing -> return def Just ideBuf -> do - inBufContext' def ideBuf f - -inActiveBufContext :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IO alpha) -> IDEM alpha -inActiveBufContext def f = inActiveBufContext' def (\ a b c d -> liftIO $ f a b c d) + inBufContext def ideBuf f -fileSaveBuffer :: Bool -> Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool -fileSaveBuffer query nb gtkbuf ideBuf i = do +fileSaveBuffer :: Bool -> Notebook -> EditorBuffer -> IDEBuffer -> Int -> IDEM Bool +fileSaveBuffer query nb ebuf ideBuf i = do ideR <- ask window <- getMainWindow prefs <- readIDE prefs @@ -689,10 +664,10 @@ Just page -> if isJust mbfn && query == False then do modifiedOnDisk <- checkModTime ideBuf -- The user is given option to reload - modifiedInBuffer <- liftIO $ textBufferGetModified gtkbuf + modifiedInBuffer <- getModified ebuf if (modifiedOnDisk || modifiedInBuffer) then do - liftIO $fileSave' (forceLineEnds prefs) (removeTBlanks prefs) nb ideBuf bs candy $fromJust mbfn + fileSave' (forceLineEnds prefs) (removeTBlanks prefs) nb ideBuf bs candy $fromJust mbfn setModTime ideBuf return True else return False @@ -729,44 +704,44 @@ case resp of ResponseYes -> do cfn <- canonicalizePath fn - fileSave' (forceLineEnds prefs) (removeTBlanks prefs) nb ideBuf bs candy cfn reflectIDE (do - close ideBuf + fileSave' (forceLineEnds prefs) (removeTBlanks prefs) nb ideBuf bs candy cfn + closePane ideBuf newTextBuffer panePath (takeFileName fn) (Just cfn) ) ideR return True ResponseNo -> return False _ -> return False where - fileSave' :: Bool -> Bool -> Notebook -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IO() + fileSave' :: Bool -> Bool -> Notebook -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IDEAction fileSave' forceLineEnds removeTBlanks nb ideBuf bs ct fn = do - buf <- textViewGetBuffer $ sourceView ideBuf + buf <- getBuffer $ sourceView ideBuf text <- getCandylessText ct buf let text' = if removeTBlanks then unlines $ map removeTrailingBlanks $lines text else text - succ <- catch (do UTF8.writeFile fn text'; return True) + succ <- liftIO $ catch (do UTF8.writeFile fn text'; return True) (\e -> do sysMessage Normal (show e) return False) - textBufferSetModified buf (not succ) + setModified buf (not succ) markLabelAsChanged nb ideBuf removeTrailingBlanks :: String -> String removeTrailingBlanks = reverse . dropWhile (\c -> c == ' ') . reverse fileSave :: Bool -> IDEM Bool -fileSave query = inActiveBufContext' False $ fileSaveBuffer query +fileSave query = inActiveBufContext False $ fileSaveBuffer query fileSaveAll :: (IDEBuffer -> IDEM Bool) -> IDEM Bool fileSaveAll filterFunc = do bufs <- allBuffers filtered <- filterM filterFunc bufs - results <- forM filtered (\buf -> inBufContext' False buf (fileSaveBuffer False)) + results <- forM filtered (\buf -> inBufContext False buf (fileSaveBuffer False)) return $ True `elem` results -fileCheckBuffer :: Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool -fileCheckBuffer nb gtkbuf ideBuf i = do +fileCheckBuffer :: Notebook -> EditorBuffer -> IDEBuffer -> Int -> IDEM Bool +fileCheckBuffer nb ebuf ideBuf i = do ideR <- ask window <- getMainWindow prefs <- readIDE prefs @@ -779,17 +754,23 @@ Nothing -> throwIDE "fileCheck: Page not found" Just page -> if isJust mbfn - then do modifiedOnDisk <- checkModTime ideBuf -- The user is given option to reload - modifiedInBuffer <- liftIO $ textBufferGetModified gtkbuf + then do modifiedOnDisk <- checkModTime ideBuf -- The user is given option to reload + modifiedInBuffer <- getModified ebuf return (modifiedOnDisk || modifiedInBuffer) else return False -fileCheckAll :: (IDEBuffer -> IDEM Bool) -> IDEM Bool +fileCheckAll :: (IDEBuffer -> IDEM (Maybe alpha)) -> IDEM [alpha] fileCheckAll filterFunc = do - bufs <- allBuffers - filtered <- filterM filterFunc bufs - results <- forM filtered (\buf -> inBufContext' False buf fileCheckBuffer) - return $ True `elem` results + bufs <- allBuffers + foldM (\ packs buf -> do + mbFilt <- filterFunc buf + case mbFilt of + Nothing -> return packs + Just p -> do + modified <- inBufContext False buf fileCheckBuffer + if modified + then return (p : packs) + else return packs) [] bufs fileNew :: IDEAction fileNew = do @@ -799,13 +780,13 @@ return () fileClose :: IDEM Bool -fileClose = inActiveBufContext' True $ fileClose' +fileClose = inActiveBufContext True $ fileClose' -fileClose' :: Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool -fileClose' nb gtkbuf currentBuffer i = do +fileClose' :: Notebook -> EditorBuffer -> IDEBuffer -> Int -> IDEM Bool +fileClose' nb ebuf currentBuffer i = do window <- getMainWindow + modified <- getModified ebuf cancel <- reifyIDE $ \ideR -> do - modified <- textBufferGetModified gtkbuf if modified then do md <- messageDialogNew (Just window) [] @@ -830,7 +811,7 @@ if cancel then return False else do - closePane currentBuffer + closeThisPane currentBuffer when (isJust $ fileName currentBuffer) (addRecentlyUsedFile (fromJust $ fileName currentBuffer)) return True @@ -862,13 +843,37 @@ case mbI of Nothing -> throwIDE "notebook page not found: unexpected" Just i -> do - gtkbuf <- liftIO $ textViewGetBuffer (sourceView buf) - let dir = dropFileName $ cabalFile activePack + ebuf <- getBuffer (sourceView buf) + let dir = dropFileName $ ipdCabalFile activePack when (isJust (fileName buf)) $ do - modified <- liftIO $ textBufferGetModified gtkbuf + modified <- getModified ebuf when (not modified && not (isSubPath dir (fromJust (fileName buf)))) - $ do fileClose' nb gtkbuf buf i; return () + $ do fileClose' nb ebuf buf i; return () +fileCloseAllButWorkspace :: IDEAction +fileCloseAllButWorkspace = do + mbWorkspace <- readIDE workspace + bufs <- allBuffers + when (not (null bufs) && isJust mbWorkspace) $ do + mapM_ (close' (fromJust mbWorkspace)) bufs + where + close' workspace buf = do + (pane,_) <- guiPropertiesFromName (paneName buf) + nb <- getNotebook pane + mbI <- liftIO $notebookPageNum nb (scrolledWindow buf) + case mbI of + Nothing -> throwIDE "notebook page not found: unexpected" + Just i -> do + ebuf <- getBuffer (sourceView buf) + when (isJust (fileName buf)) $ do + modified <- getModified ebuf + when (not modified && not (isSubPathOfAny workspace (fromJust (fileName buf)))) + $ do fileClose' nb ebuf buf i; return () + isSubPathOfAny workspace fileName = + let pathes = map (dropFileName . ipdCabalFile) (wsPackages workspace) + in or (map (\dir -> isSubPath dir fileName) pathes) + + fileOpen :: IDEAction fileOpen = do window <- getMainWindow @@ -930,89 +935,81 @@ return () editUndo :: IDEAction -editUndo = inActiveBufContext () $ \_ gtkbuf _ _ -> - let sb = castToSourceBuffer gtkbuf in - do canUndo <- sourceBufferGetCanUndo sb - if canUndo - then sourceBufferUndo sb - else return () +editUndo = inActiveBufContext () $ \_ buf _ _ -> do + can <- canUndo buf + when can $ undo buf editRedo :: IDEAction -editRedo = inActiveBufContext () $ \_ gtkbuf _ _ -> - let sb = castToSourceBuffer gtkbuf in - do canRedo <- sourceBufferGetCanRedo sb - if canRedo - then sourceBufferRedo sb - else return () +editRedo = inActiveBufContext () $ \_ buf _ _ -> do + can <- canRedo buf + when can $ redo buf editDelete :: IDEAction -editDelete = inActiveBufContext () $ \_ gtkbuf _ _ -> do - textBufferDeleteSelection gtkbuf True True +editDelete = inActiveBufContext () $ \_ ebuf _ _ -> do + deleteSelection ebuf True True return () editSelectAll :: IDEAction -editSelectAll = inActiveBufContext () $ \_ gtkbuf _ _ -> do - start <- textBufferGetStartIter gtkbuf - end <- textBufferGetEndIter gtkbuf - textBufferSelectRange gtkbuf start end +editSelectAll = inActiveBufContext () $ \_ ebuf _ _ -> do + start <- getStartIter ebuf + end <- getEndIter ebuf + selectRange ebuf start end editCut :: IDEAction -editCut = inActiveBufContext () $ \_ gtkbuf _ _ -> do - cb <- atomNew "GDK_SELECTION_CLIPBOARD" - clip <- clipboardGet cb - textBufferCutClipboard gtkbuf clip True +editCut = inActiveBufContext () $ \_ ebuf _ _ -> do + cb <- liftIO $ atomNew "GDK_SELECTION_CLIPBOARD" + clip <- liftIO $ clipboardGet cb + cutClipboard ebuf clip True editCopy :: IDEAction -editCopy = inActiveBufContext () $ \_ gtkbuf _ _ -> do - cb <- atomNew "GDK_SELECTION_CLIPBOARD" - clip <- clipboardGet cb - textBufferCopyClipboard gtkbuf clip +editCopy = inActiveBufContext () $ \_ ebuf _ _ -> do + cb <- liftIO $ atomNew "GDK_SELECTION_CLIPBOARD" + clip <- liftIO $ clipboardGet cb + copyClipboard ebuf clip editPaste :: IDEAction -editPaste = inActiveBufContext () $ \_ gtkbuf _ _ -> do - cb <- atomNew "GDK_SELECTION_CLIPBOARD" - mark <- textBufferGetInsert gtkbuf - iter <- textBufferGetIterAtMark gtkbuf mark - clip <- clipboardGet cb - textBufferPasteClipboard gtkbuf clip iter True +editPaste = inActiveBufContext () $ \_ ebuf _ _ -> do + cb <- liftIO $ atomNew "GDK_SELECTION_CLIPBOARD" + mark <- getInsertMark ebuf + iter <- getIterAtMark ebuf mark + clip <- liftIO $ clipboardGet cb + pasteClipboard ebuf clip iter True -getStartAndEndLineOfSelection :: TextBuffer -> IO (Int,Int) -getStartAndEndLineOfSelection gtkbuf = do - startMark <- textBufferGetInsert gtkbuf - endMark <- textBufferGetSelectionBound gtkbuf - startIter <- textBufferGetIterAtMark gtkbuf startMark - endIter <- textBufferGetIterAtMark gtkbuf endMark - startLine <- textIterGetLine startIter - endLine <- textIterGetLine endIter +getStartAndEndLineOfSelection :: EditorBuffer -> IDEM (Int,Int) +getStartAndEndLineOfSelection ebuf = do + startMark <- getInsertMark ebuf + endMark <- getSelectionBoundMark ebuf + startIter <- getIterAtMark ebuf startMark + endIter <- getIterAtMark ebuf endMark + startLine <- getLine startIter + endLine <- getLine endIter let (startLine',endLine',endIter') = if endLine >= startLine then (startLine,endLine,endIter) else (endLine,startLine,startIter) - b <- textIterStartsLine endIter' - let endLineReal = if b then endLine' - 1 else endLine' + b <- startsLine endIter' + let endLineReal = if b && endLine /= startLine then endLine' - 1 else endLine' return (startLine',endLineReal) -doForSelectedLines :: [a] -> (TextBuffer -> TextIter -> Int -> IO a) -> IDEM [a] -doForSelectedLines d f = inActiveBufContext' d $ \_ gtkbuf currentBuffer _ -> liftIO $do - (start,end) <- getStartAndEndLineOfSelection gtkbuf - iter <- textBufferGetStartIter gtkbuf - mapM (f gtkbuf iter) [start .. end] +doForSelectedLines :: [a] -> (EditorBuffer -> Int -> IDEM a) -> IDEM [a] +doForSelectedLines d f = inActiveBufContext d $ \_ ebuf currentBuffer _ -> do + (start,end) <- getStartAndEndLineOfSelection ebuf + mapM (f ebuf) [start .. end] editComment :: IDEAction editComment = do - doForSelectedLines [] $ \gtkbuf iter lineNr -> do - textIterSetLine iter lineNr - textBufferInsert gtkbuf iter "--" + doForSelectedLines [] $ \ebuf lineNr -> do + sol <- getIterAtLine ebuf lineNr + insert ebuf sol "--" return () editUncomment :: IDEAction editUncomment = do - doForSelectedLines [] $ \gtkbuf iter lineNr -> do - textIterSetLine iter lineNr - iter2 <- textIterCopy iter - textIterForwardChars iter 2 - str <- textIterGetText iter iter2 + doForSelectedLines [] $ \ebuf lineNr -> do + sol <- getIterAtLine ebuf lineNr + sol2 <- forwardCharsC sol 2 + str <- getText ebuf sol sol2 True if str == "--" - then do textBufferDelete gtkbuf iter iter2 + then do delete ebuf sol sol2 else return () return () @@ -1023,20 +1020,18 @@ b <- canShiftLeft str prefs if b then do - doForSelectedLines [] $ \gtkbuf iter lineNr -> do - textIterSetLine iter lineNr - iter2 <- textIterCopy iter - textIterForwardChars iter (tabWidth prefs) - textBufferDelete gtkbuf iter iter2 + doForSelectedLines [] $ \ebuf lineNr -> do + sol <- getIterAtLine ebuf lineNr + sol2 <- forwardCharsC sol (tabWidth prefs) + delete ebuf sol sol2 return () else return () where canShiftLeft str prefs = do - boolList <- doForSelectedLines [] $ \gtkbuf iter lineNr -> do - textIterSetLine iter lineNr - iter2 <- textIterCopy iter - textIterForwardChars iter (tabWidth prefs) - str1 <- textIterGetText iter iter2 + boolList <- doForSelectedLines [] $ \ebuf lineNr -> do + sol <- getIterAtLine ebuf lineNr + sol2 <- forwardCharsC sol (tabWidth prefs) + str1 <- getText ebuf sol sol2 True return (str1 == str) return (foldl' (&&) True boolList) @@ -1045,38 +1040,38 @@ editShiftRight = do prefs <- readIDE prefs let str = map (\_->' ') [1 .. (tabWidth prefs)] - doForSelectedLines [] $ \gtkbuf iter lineNr -> do - textIterSetLine iter lineNr - textBufferInsert gtkbuf iter str + doForSelectedLines [] $ \ebuf lineNr -> do + sol <- getIterAtLine ebuf lineNr + insert ebuf sol str return () editToCandy :: IDEAction editToCandy = do ct <- readIDE candy - inActiveBufContext () $ \_ gtkbuf _ _ -> do - transformToCandy ct gtkbuf + inActiveBufContext () $ \_ ebuf _ _ -> do + transformToCandy ct ebuf editFromCandy :: IDEAction editFromCandy = do ct <- readIDE candy - inActiveBufContext () $ \_ gtkbuf _ _ -> do - transformFromCandy ct gtkbuf + inActiveBufContext () $ \_ ebuf _ _ -> do + transformFromCandy ct ebuf editKeystrokeCandy :: Maybe Char -> IDEAction editKeystrokeCandy c = do ct <- readIDE candy - inActiveBufContext () $ \_ gtkbuf _ _ -> do - keystrokeCandy ct c gtkbuf + inActiveBufContext () $ \_ ebuf _ _ -> do + keystrokeCandy ct c ebuf editCandy :: IDEAction editCandy = do ct <- readIDE candy buffers <- allBuffers - gtkbufs <- liftIO $mapM (\ b -> textViewGetBuffer (sourceView b)) buffers + gtkbufs <- mapM (\ b -> getBuffer (sourceView b)) buffers bs <- getCandyState if bs - then liftIO $mapM_ (transformToCandy ct) gtkbufs - else liftIO $mapM_ (transformFromCandy ct) gtkbufs + then mapM_ (transformToCandy ct) gtkbufs + else mapM_ (transformFromCandy ct) gtkbufs alignChar :: Char -> IDEAction alignChar char = do @@ -1087,20 +1082,19 @@ else return () where positionsOfChar :: IDEM ([(Int, Maybe Int)]) - positionsOfChar = doForSelectedLines [] $ \gtkbuf iter lineNr -> do - textIterSetLine iter lineNr - iter2 <- textIterCopy iter - textIterForwardToLineEnd iter2 - line <- textIterGetText iter iter2 + positionsOfChar = doForSelectedLines [] $ \ebuf lineNr -> do + sol <- getIterAtLine ebuf lineNr + eol <- forwardToLineEndC sol + line <- getText ebuf sol eol True return (lineNr, elemIndex char line) alignChar :: Map Int (Maybe Int) -> Int -> IDEM () alignChar positions alignTo = do - doForSelectedLines [] $ \gtkbuf iter lineNr -> do + doForSelectedLines [] $ \ebuf lineNr -> do case lineNr `Map.lookup` positions of Just (Just n) -> do - textIterSetLine iter lineNr - textIterForwardChars iter n - textBufferInsert gtkbuf iter (replicate (alignTo - n) ' ') + sol <- getIterAtLine ebuf lineNr + insertLoc <- forwardCharsC sol n + insert ebuf insertLoc (replicate (alignTo - n) ' ') _ -> return () return () @@ -1113,23 +1107,6 @@ align :: Char -> IDEAction align = alignChar . transChar -sourceLanguageForFilename :: SourceLanguageManager -> Maybe String -> IO (Maybe String, Maybe SourceLanguage) -sourceLanguageForFilename lm Nothing = do - mbLang <- sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell") - case mbLang of - Nothing -> return (Nothing,Nothing) - Just lang -> do - name <- sourceLanguageGetName lang - return (Just name, Just lang) - -sourceLanguageForFilename lm (Just filename) = do - mbLang <- sourceLanguageManagerGuessLanguage lm (Just filename) Nothing - case mbLang of - Nothing -> return (Nothing,Nothing) - Just lang -> do - name <- sourceLanguageGetName lang - return (Just name, Just lang) - addRecentlyUsedFile :: FilePath -> IDEAction addRecentlyUsedFile fp = do state <- readIDE currentState @@ -1153,25 +1130,40 @@ selectedText :: IDEM (Maybe String) selectedText = do candy' <- readIDE candy - inActiveBufContext Nothing $ \_ gtkbuf currentBuffer _ -> do - hasSelection <- liftIO $ textBufferHasSelection gtkbuf + inActiveBufContext Nothing $ \_ ebuf currentBuffer _ -> do + hasSelection <- hasSelection ebuf if hasSelection then do - (i1,i2) <- liftIO $ textBufferGetSelectionBounds gtkbuf - text <- getCandylessPart candy' gtkbuf i1 i2 + (i1,i2) <- getSelectionBounds ebuf + text <- getCandylessPart candy' ebuf i1 i2 return $ Just text else return Nothing +selectedTextOrCurrentLine :: IDEM (Maybe String) +selectedTextOrCurrentLine = do + candy' <- readIDE candy + inActiveBufContext Nothing $ \_ ebuf currentBuffer _ -> do + hasSelection <- hasSelection ebuf + (i1, i2) <- if hasSelection + then getSelectionBounds ebuf + else do + (i, _) <- getSelectionBounds ebuf + line <- getLine i + iStart <- getIterAtLine ebuf line + iEnd <- forwardToLineEndC iStart + return (iStart, iEnd) + fmap Just $ getCandylessPart candy' ebuf i1 i2 + selectedLocation :: IDEM (Maybe (Int, Int)) selectedLocation = do useCandy <- getCandyState candy' <- readIDE candy - inActiveBufContext Nothing $ \_ gtkbuf currentBuffer _ -> do - (start, _) <- liftIO $ textBufferGetSelectionBounds gtkbuf - line <- textIterGetLine start - lineOffset <- textIterGetLineOffset start + inActiveBufContext Nothing $ \_ ebuf currentBuffer _ -> do + (start, _) <- getSelectionBounds ebuf + line <- getLine start + lineOffset <- getLineOffset start res <- if useCandy - then positionFromCandy candy' gtkbuf (line, lineOffset) + then positionFromCandy candy' ebuf (line, lineOffset) else return (line, lineOffset) return $ Just res @@ -1181,29 +1173,60 @@ insertTextAfterSelection str = do candy' <- readIDE candy useCandy <- getCandyState - inActiveBufContext () $ \_ gtkbuf currentBuffer _ -> do - hasSelection <- liftIO $ textBufferHasSelection gtkbuf - when hasSelection $ liftIO $ do + inActiveBufContext () $ \_ ebuf currentBuffer _ -> do + hasSelection <- hasSelection ebuf + when hasSelection $ do realString <- if useCandy then stringToCandy candy' str else return str - (_,i) <- textBufferGetSelectionBounds gtkbuf - mark <- textBufferCreateMark gtkbuf Nothing i True - textBufferInsert gtkbuf i realString - i1 <- textBufferGetIterAtMark gtkbuf mark - i2 <- textIterCopy i1 - textIterForwardChars i2 (length str) - textBufferSelectRange gtkbuf i1 i2 + (_,i) <- getSelectionBounds ebuf + mark <- createMark ebuf i True + insert ebuf i realString + i1 <- getIterAtMark ebuf mark + i2 <- forwardCharsC i1 (length str) + selectRange ebuf i1 i2 selectedModuleName :: IDEM (Maybe String) selectedModuleName = do candy' <- readIDE candy - inActiveBufContext' Nothing $ \_ gtkbuf currentBuffer _ -> do + inActiveBufContext Nothing $ \_ ebuf currentBuffer _ -> do case fileName currentBuffer of - Just filePath -> do - text <- liftIO $ getCandylessText candy' gtkbuf - parseResult <- parseHeader filePath text - case parseResult of - Just HsModule{ hsmodName = Just name } - -> return $ Just $ moduleNameString (unLoc name) - _ -> return Nothing - Nothing -> return Nothing + Just filePath -> liftIO $ moduleNameFromFilePath filePath + Nothing -> return Nothing +-- | Returns the package, to which this buffer belongs, if possible +belongsToPackage :: IDEBuffer -> IDEM(Maybe IDEPackage) +belongsToPackage ideBuf | fileName ideBuf == Nothing = return Nothing + | otherwise = do + bufferToProject' <- readIDE bufferProjCache + ws <- readIDE workspace + let fp = fromJust (fileName ideBuf) + case Map.lookup fp bufferToProject' of + Just p -> return p + Nothing -> case ws of + Nothing -> return Nothing + Just workspace -> do + mbMn <- liftIO $ moduleNameFromFilePath fp + let mbMn2 = case mbMn of + Nothing -> Nothing + Just mn -> simpleParse mn + let res = foldl (belongsToPackage' fp mbMn2) Nothing (wsPackages workspace) + modifyIDE_ (\ide -> ide{bufferProjCache = Map.insert fp res bufferToProject'}) + return res + +belongsToPackage' :: FilePath -> Maybe ModuleName -> Maybe IDEPackage -> IDEPackage -> Maybe IDEPackage +belongsToPackage' _ _ r@(Just pack) _ = r +belongsToPackage' fp mbModuleName Nothing pack = + let basePath = dropFileName $ ipdCabalFile pack + in if isSubPath basePath fp + then + 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) + then Just pack + else case mbModuleName of + Nothing -> Nothing + Just mn -> if Set.member mn (ipdModules pack) + then Just pack + else Nothing + else Nothing + +belongsToWorkspace b = belongsToPackage b >>= return . isJust 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 @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Trace --- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org @@ -17,8 +17,6 @@ module IDE.Pane.Trace ( IDETrace , TraceState -, showTrace -, showTrace' , fillTraceList ) where @@ -27,8 +25,8 @@ import IDE.Core.State import Control.Monad.Reader import IDE.Debug - (debugForward, debugBack, debugCommand', debugHistory) -import IDE.Tool (ToolOutput(..)) + (debugForward, debugBack, debugCommand') +import IDE.Utils.Tool (ToolOutput(..)) import IDE.LogRef (srcSpanParser) import Debug.Trace (trace) import Text.ParserCombinators.Parsec @@ -46,8 +44,6 @@ import qualified Text.ParserCombinators.Parsec.Token as P (integer, whiteSpace, colon, symbol, makeTokenParser) import Text.ParserCombinators.Parsec.Language (emptyDef) -import GHC (SrcSpan(..)) -import Outputable (ppr, showSDoc) import Graphics.UI.Gtk.Gdk.Events (Event(..)) import Graphics.UI.Gtk.General.Enums (MouseButton(..)) @@ -70,73 +66,26 @@ thPosition :: SrcSpan } -instance IDEObject IDETrace - instance Pane IDETrace IDEM where primPaneName _ = "Trace" getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledView paneId b = "*Trace" - makeActive pane = activatePane pane [] - close = closePane instance RecoverablePane IDETrace TraceState IDEM where saveState p = do return (Just TraceState) recoverState pp TraceState = do nb <- getNotebook pp - newPane pp nb builder - return () - -showTrace :: IDEAction -showTrace = do - debugHistory - m <- getTrace - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeView m) - -showTrace' :: PanePath -> IDEAction -showTrace' pp = do - m <- getTrace' pp - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeView m) - - -getTrace :: IDEM IDETrace -getTrace = do - mbTrace <- getPane - case mbTrace of - Nothing -> do - pp <- getBestPathForId "*Trace" - nb <- getNotebook pp - newPane pp nb builder - mbTrace <- getPane - case mbTrace of - Nothing -> throwIDE "Can't init trace" - Just m -> return m - Just m -> return m - -getTrace' :: PanePath -> IDEM IDETrace -getTrace' pp = do - mbTrace <- getPane - case mbTrace of - Nothing -> do - layout <- getLayout - nb <- getNotebook (getBestPanePath pp layout) - newPane pp nb builder - mbTrace <- getPane - case mbTrace of - Nothing -> throwIDE "Can't init trace" - Just m -> return m - Just m -> return m + buildPane pp nb builder + builder = builder' -builder :: PanePath -> +builder' :: PanePath -> Notebook -> Window -> - IDERef -> - IO (IDETrace,Connections) -builder pp nb windows ideR = do + IDEM (Maybe IDETrace,Connections) +builder' pp nb windows = reifyIDE $ \ ideR -> do tracepoints <- treeStoreNew [] treeView <- treeViewNew treeViewSetModel treeView tracepoints @@ -183,7 +132,7 @@ treeViewAppendColumn treeView col3 cellLayoutPackStart col3 renderer3 False cellLayoutSetAttributes col3 renderer3 tracepoints - $ \row -> [ cellText := (showSDoc . ppr) (thPosition row)] + $ \row -> [ cellText := displaySrcSpan (thPosition row)] treeViewSetHeadersVisible treeView True sel <- treeViewGetSelection treeView @@ -203,7 +152,7 @@ Just ref -> return () -- TODO reflectIDE (selectRef (Just ref)) ideR Nothing -> return () treeView `onButtonPress` (traceViewPopup ideR tracepoints treeView) - return (pane,[ConnectC cid1]) + return (Just pane,[ConnectC cid1]) fillTraceList :: IDEAction fillTraceList = do 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 @@ -3,7 +3,7 @@ ----------------------------------------------------------------------------- -- -- Module : IDE.Pane.Variables --- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org @@ -17,8 +17,6 @@ module IDE.Pane.Variables ( IDEVariables , VariablesState -, showVariables -, showVariables' , fillVariablesList ) where @@ -27,7 +25,7 @@ import IDE.Core.State import Control.Monad.Reader import IDE.Debug (debugCommand') -import IDE.Tool (ToolOutput(..)) +import IDE.Utils.Tool (ToolOutput(..)) import Text.ParserCombinators.Parsec (anyChar, lookAhead, @@ -63,71 +61,27 @@ data VariablesState = VariablesState { } deriving(Eq,Ord,Read,Show,Typeable) -instance IDEObject IDEVariables - instance Pane IDEVariables IDEM where primPaneName _ = "Variables" getAddedIndex _ = 0 getTopWidget = castToWidget . scrolledView paneId b = "*Variables" - makeActive pane = activatePane pane [] - close = closePane instance RecoverablePane IDEVariables VariablesState IDEM where saveState p = do return (Just VariablesState) recoverState pp VariablesState = do nb <- getNotebook pp - newPane pp nb builder - return () + buildPane pp nb builder + builder = builder' -showVariables :: IDEAction -showVariables = do - m <- getVariables - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeView m) -getVariables :: IDEM IDEVariables -getVariables = do - mbVar <- getPane - case mbVar of - Nothing -> do - pp <- getBestPathForId "*Variables" - nb <- getNotebook pp - newPane pp nb builder - mbVar <- getPane - case mbVar of - Nothing -> throwIDE "Can't init variables" - Just m -> return m - Just m -> return m - -showVariables' :: PanePath -> IDEAction -showVariables' pp = do - m <- getVariables' pp - liftIO $ bringPaneToFront m - liftIO $ widgetGrabFocus (treeView m) - -getVariables' :: PanePath -> IDEM IDEVariables -getVariables' pp = do - mbVar <- getPane - case mbVar of - Nothing -> do - layout <- getLayout - nb <- getNotebook (getBestPanePath pp layout) - newPane pp nb builder - mbVar <- getPane - case mbVar of - Nothing -> throwIDE "Can't init variables" - Just m -> return m - Just m -> return m - -builder :: PanePath -> +builder' :: PanePath -> Notebook -> Window -> - IDERef -> - IO (IDEVariables, Connections) -builder pp nb windows ideR = do + IDEM (Maybe IDEVariables, Connections) +builder' pp nb windows = reifyIDE $ \ideR -> do variables <- treeStoreNew [] treeView <- treeViewNew treeViewSetModel treeView variables @@ -177,7 +131,7 @@ treeView `onButtonPress` (variablesViewPopup ideR variables treeView) cid1 <- treeView `afterFocusIn` (\_ -> do reflectIDE (makeActive pane) ideR ; return True) - return (pane,[ConnectC cid1]) + return (Just pane,[ConnectC cid1]) fillVariablesList :: IDEAction diff --git a/src/IDE/Pane/Workspace.hs b/src/IDE/Pane/Workspace.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Pane/Workspace.hs @@ -0,0 +1,202 @@ +{-# OPTIONS_GHC -XScopedTypeVariables -XTypeSynonymInstances -XMultiParamTypeClasses -XDeriveDataTypeable #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Pane.Workspace +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module IDE.Pane.Workspace ( + WorkspaceState +, IDEWorkspace +, updateWorkspace +, getWorkspace +) where + +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 Debug.Trace (trace) + + +-- | Workspace pane state +-- + +data IDEWorkspace = IDEWorkspace { + scrolledView :: ScrolledWindow +, treeViewC :: TreeView +, workspaceStore :: ListStore (Bool,IDEPackage) +, wsEntry :: Entry +, topBox :: VBox +} deriving Typeable + +instance Pane IDEWorkspace IDEM + where + primPaneName _ = "Workspace" + getAddedIndex _ = 0 + getTopWidget = castToWidget . topBox + paneId b = "*Workspace" + +-- | Nothing to remember here, everything comes from the IDE state +data WorkspaceState = WorkspaceState + deriving(Eq,Ord,Read,Show,Typeable) + +instance RecoverablePane IDEWorkspace WorkspaceState IDEM where + saveState p = do + return (Just WorkspaceState) + recoverState pp WorkspaceState = do + nb <- getNotebook pp + buildPane pp nb builder + buildPane pp nb builder = do + res <- buildThisPane pp nb builder + when (isJust res) updateWorkspace + return res + builder pp nb windows = reifyIDE $ \ideR -> do + listStore <- listStoreNew [] + treeView <- treeViewNew + treeViewSetModel treeView listStore + + renderer0 <- cellRendererPixbufNew + col0 <- treeViewColumnNew + treeViewColumnSetTitle col0 "Active" + treeViewColumnSetSizing col0 TreeViewColumnAutosize + treeViewColumnSetResizable col0 True + treeViewColumnSetReorderable col0 True + treeViewAppendColumn treeView col0 + cellLayoutPackStart col0 renderer0 True + cellLayoutSetAttributes col0 renderer0 listStore + $ \row -> [cellPixbufStockId := + if (\(b,_)-> b) row + then stockYes + else ""] + + renderer1 <- cellRendererTextNew + col1 <- treeViewColumnNew + treeViewColumnSetTitle col1 "Package" + treeViewColumnSetSizing col1 TreeViewColumnAutosize + treeViewColumnSetResizable col1 True + treeViewColumnSetReorderable col1 True + treeViewAppendColumn treeView col1 + cellLayoutPackStart col1 renderer1 True + cellLayoutSetAttributes col1 renderer1 listStore + $ \row -> [ cellText := (\(_,pack)-> (packageIdentifierToString . ipdPackageId) pack) row ] + + renderer2 <- cellRendererTextNew + col2 <- treeViewColumnNew + treeViewColumnSetTitle col2 "File path" + treeViewColumnSetSizing col2 TreeViewColumnAutosize + treeViewColumnSetResizable col2 True + treeViewColumnSetReorderable col2 True + treeViewAppendColumn treeView col2 + cellLayoutPackStart col2 renderer2 True + cellLayoutSetAttributes col2 renderer2 listStore + $ \row -> [ cellText := (\(_,pack)-> ipdCabalFile pack) row ] + + treeViewSetHeadersVisible treeView True + sel <- treeViewGetSelection treeView + treeSelectionSetMode sel SelectionSingle + + sw <- scrolledWindowNew Nothing Nothing + containerAdd sw treeView + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + entry <- entryNew + set entry [ entryEditable := False ] + box <- vBoxNew False 2 + boxPackStart box entry PackNatural 0 + boxPackEnd box sw PackGrow 0 + let workspacePane = IDEWorkspace sw treeView listStore entry box + widgetShowAll box + cid1 <- treeView `afterFocusIn` + (\_ -> do reflectIDE (makeActive workspacePane) ideR ; return True) + treeView `onButtonPress` (treeViewPopup ideR workspacePane) + return (Just workspacePane,[ConnectC cid1]) + +getWorkspace :: Maybe PanePath -> IDEM IDEWorkspace +getWorkspace Nothing = forceGetPane (Right "*Workspace") +getWorkspace (Just pp) = forceGetPane (Left pp) + +getSelectionTree :: TreeView + -> ListStore (Bool, IDEPackage) + -> IO (Maybe (Bool, IDEPackage)) +getSelectionTree treeView listStore = do + treeSelection <- treeViewGetSelection treeView + rows <- treeSelectionGetSelectedRows treeSelection + case rows of + [[n]] -> do + val <- listStoreGetValue listStore n + return (Just val) + _ -> return Nothing + +treeViewPopup :: IDERef + -> IDEWorkspace + -> Event + -> IO (Bool) +treeViewPopup ideR workspacePane (Button _ click _ _ _ _ button _ _) = do + if button == RightButton + then do + theMenu <- menuNew + item1 <- menuItemNewWithLabel "Activate Package" + item2 <- menuItemNewWithLabel "Add Package" + item3 <- menuItemNewWithLabel "Remove Package" + item4 <- menuItemNewWithLabel "Build Package" + + item1 `onActivateLeaf` do + sel <- getSelectionTree (treeViewC workspacePane) + (workspaceStore workspacePane) + case sel of + Just (_,ideP) -> reflectIDE (workspaceActivatePackage ideP) ideR + + otherwise -> return () + item2 `onActivateLeaf` reflectIDE workspaceAddPackage ideR + item3 `onActivateLeaf` do + sel <- getSelectionTree (treeViewC workspacePane) + (workspaceStore workspacePane) + case sel of + Just (_,ideP) -> reflectIDE (workspaceRemovePackage ideP) ideR + otherwise -> return () + -- TODO ... + menuShellAppend theMenu item1 + menuShellAppend theMenu item2 + menuShellAppend theMenu item3 + -- TODO ... + menuPopup theMenu Nothing + widgetShowAll theMenu + return True + else if button == LeftButton && click == DoubleClick + then do sel <- getSelectionTree (treeViewC workspacePane) + (workspaceStore workspacePane) + case sel of + Just (_,ideP) -> reflectIDE (workspaceActivatePackage ideP) ideR + >> return True + otherwise -> return False + else return False +treeViewPopup _ _ _ = throwIDE "treeViewPopup wrong event type" + +updateWorkspace :: IDEAction +updateWorkspace = do + mbMod <- trace "update workspace called" getPane + case mbMod of + Nothing -> return () + Just (p :: IDEWorkspace) -> do + mbWs <- readIDE workspace + case mbWs of + Nothing -> liftIO $ do + listStoreClear (workspaceStore p) + entrySetText (wsEntry p) "" + Just ws -> liftIO $ do + entrySetText (wsEntry p) (wsName ws) + listStoreClear (workspaceStore p) + let objs = map (\ ideP -> (Just ideP == wsActivePack ws, ideP)) (wsPackages ws) + mapM_ (listStoreAppend (workspaceStore p)) objs + diff --git a/src/IDE/PaneGroups.hs b/src/IDE/PaneGroups.hs new file mode 100644 --- /dev/null +++ b/src/IDE/PaneGroups.hs @@ -0,0 +1,128 @@ +{-# OPTIONS_GHC -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.PaneGroups +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module IDE.PaneGroups ( + + showBrowser +, setSensitivityDebugger +, showDebugger + +) where + +import IDE.Core.State (IDEM(..), readIDE, IDEAction(..)) +import Graphics.UI.Frame.Panes + (getTopWidget, + getPane, + getOrBuildPane, + PaneDirection(..), + PanePathElement(..), + layout, + panePathForGroup) +import Graphics.UI.Frame.ViewFrame + (getBestPanePath, getNotebook, viewSplit', newGroupOrBringToFront) +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(..)) +import IDE.Pane.Modules (IDEModules(..)) +import IDE.Pane.Info (IDEInfo(..)) +import IDE.Pane.SourceBuffer + (newTextBuffer, bufferName, allBuffers) +import IDE.Pane.Breakpoints (IDEBreakpoints(..)) +import IDE.Pane.Variables (IDEVariables(..)) +import IDE.Pane.Trace (IDETrace(..)) + +showBrowser :: IDEAction +showBrowser = do + pp <- panePathForGroup "*Browser" + ret <- newGroupOrBringToFront "Browser" pp + layout' <- liftM layout (readIDE frameState) + case ret of + (Just rpp, True) -> do + viewSplit' rpp Horizontal + let lowerP = rpp ++ [SplitP BottomP] + let upperP = rpp ++ [SplitP TopP] + lower <- getNotebook lowerP + upper <- getNotebook upperP + liftIO $ do + notebookSetTabPos lower PosTop + notebookSetTabPos upper PosTop + notebookSetShowTabs upper False + notebookSetShowTabs lower False + getOrBuildPane (Left upperP) :: IDEM (Maybe IDEModules) + getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEInfo) + return () + (Just rpp, False) -> do + let lowerP = getBestPanePath (rpp ++ [SplitP BottomP]) layout' + let upperP = getBestPanePath (rpp ++ [SplitP TopP]) layout' + getOrBuildPane (Left upperP) :: IDEM (Maybe IDEModules) + getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEInfo) + return () + _ -> return () + +setSensitivityDebugger :: Bool -> IDEAction +setSensitivityDebugger sens = do + mbBreakpoints :: Maybe IDEBreakpoints <- getPane + mbVariables :: Maybe IDEVariables <- getPane + mbTrace :: Maybe IDETrace <- getPane + liftIO $ do + case mbBreakpoints of + Nothing -> return () + Just idePane -> widgetSetSensitive (getTopWidget idePane) sens + case mbVariables of + Nothing -> return () + Just idePane -> widgetSetSensitive (getTopWidget idePane) sens + case mbTrace of + Nothing -> return () + Just idePane -> widgetSetSensitive (getTopWidget idePane) sens + +showDebugger :: IDEAction +showDebugger = do + pp <- panePathForGroup "*Debug" + ret <- newGroupOrBringToFront "Debug" pp + layout' <- liftM layout (readIDE frameState) + bufs <- allBuffers + case ret of + (Just rpp, True) -> do + viewSplit' rpp Horizontal + let lowerP = rpp ++ [SplitP BottomP] + let upperP = rpp ++ [SplitP TopP] + lower <- getNotebook lowerP + upper <- getNotebook upperP + liftIO $ do + notebookSetTabPos lower PosTop + notebookSetTabPos upper PosTop + notebookSetShowTabs upper False + getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEBreakpoints) + getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEVariables) + getOrBuildPane (Left lowerP) :: IDEM (Maybe IDETrace) + when (null $ filter (\b -> bufferName b == "_Eval.hs") bufs) $ + newTextBuffer upperP "_Eval.hs" Nothing >> return () + return () + (Just rpp, False) -> do + let lowerP = getBestPanePath (rpp ++ [SplitP BottomP]) layout' + let upperP = getBestPanePath (rpp ++ [SplitP TopP]) layout' + getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEBreakpoints) + getOrBuildPane (Left lowerP) :: IDEM (Maybe IDEVariables) + getOrBuildPane (Left lowerP) :: IDEM (Maybe IDETrace) + when (null $ filter (\b -> bufferName b == "_Eval.hs") bufs) $ + newTextBuffer upperP "_Eval.hs" Nothing >> return () + return () + _ -> return () + + diff --git a/src/IDE/PrinterParser.hs b/src/IDE/PrinterParser.hs deleted file mode 100644 --- a/src/IDE/PrinterParser.hs +++ /dev/null @@ -1,173 +0,0 @@ --- --- | Module for saving and restoring preferences --- - -module IDE.PrinterParser ( - - Printer -, Parser -, FieldDescriptionS(..) -, MkFieldDescriptionS -, mkFieldS - -, applyFieldParsers -, boolParser -, intParser -, lineParser -, pairParser -, identifier -, emptyParser -, whiteSpace -, stringParser -, readParser - -, emptyPrinter -, symbol -, colon - - -) where - -import Text.ParserCombinators.Parsec.Language -import qualified Text.ParserCombinators.Parsec.Token as P -import Text.ParserCombinators.Parsec hiding(Parser) -import qualified Text.PrettyPrint.HughesPJ as PP - -import Graphics.UI.Editor.Parameters -import Graphics.UI.Editor.Basics -import Data.Maybe (listToMaybe) - - -type Printer beta = beta -> PP.Doc -type Parser beta = CharParser () beta - --- ------------------------------------------------------------ --- * Parsing with Parsec --- ------------------------------------------------------------ - -data FieldDescriptionS alpha = FDS { - parameters :: Parameters - , fieldPrinter :: alpha -> PP.Doc - , fieldParser :: alpha -> CharParser () alpha - } - -type MkFieldDescriptionS alpha beta = - Parameters -> - (Printer beta) -> - (Parser beta) -> - (Getter alpha beta) -> - (Setter alpha beta) -> - FieldDescriptionS alpha - -mkFieldS :: {--Eq beta =>--} MkFieldDescriptionS alpha beta -mkFieldS parameter printer parser getter setter = - FDS parameter - (\ dat -> (PP.text (case getParameterPrim paraName parameter of - Nothing -> "" - Just str -> str) PP.<> PP.colon) - PP.$$ (PP.nest 15 (printer (getter dat))) - PP.$$ (PP.nest 5 (case getParameterPrim paraSynopsis parameter of - Nothing -> PP.empty - Just str -> PP.text $"--" ++ str))) - (\ dat -> try (do - symbol (case getParameterPrim paraName parameter of - Nothing -> "" - Just str -> str) - colon - val <- parser - return (setter val dat))) - -applyFieldParsers :: a -> [a -> CharParser () a] -> CharParser () a -applyFieldParsers prefs parseF = do - eof - return (prefs) - <|> do - let parsers = map (\a -> a prefs) parseF - newprefs <- choice parsers - whiteSpace - applyFieldParsers newprefs parseF - "field parser" - -boolParser :: CharParser () Bool -boolParser = do - (symbol "True" <|> symbol "true") - return True - <|> do - (symbol "False"<|> symbol "false") - return False - "bool parser" - -readParser :: Read a => CharParser () a -readParser = do - str <- many (noneOf ['\n']) - if null str - then unexpected "read parser on empty string" - else do - case maybeRead str of - Nothing -> unexpected $ "read parser no parse " ++ str - Just r -> return r - "read parser" - where maybeRead = listToMaybe . map fst . filter (null . snd) . reads - -pairParser :: CharParser () alpha -> CharParser () (alpha,alpha) -pairParser p2 = do - char '(' - v1 <- p2 - char ',' - v2 <- p2 - char ')' - return (v1,v2) - "pair parser" - -stringParser :: CharParser () String -stringParser = do - char '"' - str <- many (noneOf ['"']) - char '"' - return (str) - "string parser" - -lineParser :: CharParser () String -lineParser = do - str <- many (noneOf ['\n']) - return (str) - "line parser" - - -intParser :: CharParser () Int -intParser = do - i <- integer - return (fromIntegral i) - -emptyParser :: CharParser () () -emptyParser = pzero - -prefsStyle :: P.LanguageDef st -prefsStyle = emptyDef { - P.commentStart = "{-" - , P.commentEnd = "-}" - , P.commentLine = "--" - } - -lexer :: P.TokenParser st -lexer = P.makeTokenParser prefsStyle - -whiteSpace :: CharParser st () -whiteSpace = P.whiteSpace lexer - -symbol :: String -> CharParser st String -symbol = P.symbol lexer - -identifier, colon :: CharParser st String -identifier = P.identifier lexer -colon = P.colon lexer - -integer = P.integer lexer - --- ------------------------------------------------------------ --- * Printing --- ------------------------------------------------------------ - - -emptyPrinter :: () -> PP.Doc -emptyPrinter _ = PP.empty diff --git a/src/IDE/SaveSession.hs b/src/IDE/SaveSession.hs deleted file mode 100644 --- a/src/IDE/SaveSession.hs +++ /dev/null @@ -1,532 +0,0 @@ -{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Module : IDE.SaveSession --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : --- Stability : provisional --- Portability : portable --- --- --- | Module for saving and recovering the layout --- ---------------------------------------------------------------------------------- - - -module IDE.SaveSession ( - saveSession -, saveSessionAs -, saveSessionAsPrompt -, recoverSession -, sessionClosePane -, loadSession -, loadSessionPrompt -, standardSessionFilename -) where - -import Graphics.UI.Gtk hiding (showLayout) -import Text.ParserCombinators.Parsec hiding(Parser) -import Control.Monad.Reader -import System.FilePath -import qualified Data.Map as Map -import Data.Maybe -import Data.Typeable - -import IDE.Core.State -import IDE.FileUtils -import IDE.PrinterParser -import qualified Text.PrettyPrint.HughesPJ as PP -import Graphics.UI.Editor.Parameters -import IDE.Pane.Modules -import IDE.Pane.SourceBuffer -import IDE.Pane.Info -import IDE.Pane.References -import IDE.Pane.Log -import IDE.Pane.Preferences -import IDE.Pane.PackageFlags -import IDE.Pane.Search -import IDE.Pane.Grep -import IDE.Pane.Breakpoints -import IDE.Pane.Trace -import IDE.Pane.Variables -import IDE.Find -import System.Time (getClockTime) -import IDE.Package (activatePackage,deactivatePackage) -import Data.List (foldl') -import IDE.Pane.Errors (ErrorsState(..)) -import Control.Exception (SomeException(..)) - --- --------------------------------------------------------------------- --- All pane types must be in here ! --- - -data PaneState = BufferSt BufferState - | LogSt LogState - | InfoSt InfoState - | ModulesSt ModulesState - | ReferencesSt ReferencesState - | PrefsSt PrefsState - | FlagsSt FlagsState - | SearchSt SearchState - | GrepSt GrepState - | BreakpointsSt BreakpointsState - | TraceSt TraceState - | VariablesSt VariablesState - | ErrorsSt ErrorsState - deriving(Eq,Ord,Read,Show) - -asPaneState :: RecoverablePane alpha beta gamma => beta -> PaneState -asPaneState s | isJust ((cast s) :: Maybe BufferState) = BufferSt (fromJust $ cast s) -asPaneState s | isJust ((cast s) :: Maybe LogState) = LogSt (fromJust $ cast s) -asPaneState s | isJust ((cast s) :: Maybe InfoState) = InfoSt (fromJust $ cast s) -asPaneState s | isJust ((cast s) :: Maybe ModulesState) = ModulesSt (fromJust $ cast s) -asPaneState s | isJust ((cast s) :: Maybe ReferencesState) = ReferencesSt (fromJust $ cast s) -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 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) -asPaneState s | isJust ((cast s) :: Maybe VariablesState) = VariablesSt (fromJust $ cast s) -asPaneState s | isJust ((cast s) :: Maybe ErrorsState) = ErrorsSt (fromJust $ cast s) -asPaneState s = error "SaveSession>>asPaneState incomplete cast" - -recover :: PanePath -> PaneState -> IDEAction -recover pp (BufferSt p) = recoverState pp p -recover pp (LogSt p) = recoverState pp p -recover pp (InfoSt p) = recoverState pp p -recover pp (ModulesSt p) = recoverState pp p -recover pp (ReferencesSt p) = recoverState pp p -recover pp (PrefsSt p) = recoverState pp p -recover pp (FlagsSt p) = recoverState pp p -recover pp (SearchSt p) = recoverState pp p -recover pp (GrepSt p) = recoverState pp p -recover pp (BreakpointsSt p) = recoverState pp p -recover pp (TraceSt p) = recoverState pp p -recover pp (VariablesSt p) = recoverState pp p -recover pp (ErrorsSt p) = recoverState pp p - --- --------------------------------------------------------------------- - -standardSessionFilename = "Current.session" - --- | *Implementation - -sessionClosePane :: IDEAction -sessionClosePane = do - activePane' <- getActivePane - case activePane' of - Nothing -> return () - Just (pn,_) -> do - (PaneC p) <- paneFromName pn - close p - return () - -data SessionState = SessionState { - saveTime :: String - , layoutS :: PaneLayout - , population :: [(Maybe PaneState,PanePath)] - , windowSize :: (Int,Int) - , activePackage :: Maybe FilePath - , activePaneN :: Maybe String - , toolbarVisibleS :: Bool - , findbarState :: (Bool,FindState) - , recentOpenedFiles :: [FilePath] - , recentOpenedPackages :: [FilePath] -} deriving() - -defaultLayout = SessionState { - saveTime = "" - , layoutS = TerminalP Map.empty (Just TopP) (-1) Nothing Nothing - , population = [] - , windowSize = (1024,768) - , activePackage = Nothing - , activePaneN = Nothing - , toolbarVisibleS = True - , findbarState = (False,FindState{ - entryStr = "" - , entryHist = [] - , replaceStr = "" - , replaceHist = [] - , caseSensitive = False - , entireWord = False - , wrapAround = True - , regex = False - , lineNr = 1}) - , recentOpenedFiles = [] - , recentOpenedPackages = [] -} - -layoutDescr :: [FieldDescriptionS SessionState] -layoutDescr = [ - mkFieldS - (paraName <<<- ParaName "Time of storage" $ emptyParams) - (PP.text . show) - stringParser - saveTime - (\ b a -> a{saveTime = b}) - , mkFieldS - (paraName <<<- ParaName "Layout" $ emptyParams) - (PP.text . show) - readParser - layoutS - (\ b a -> a{layoutS = b}) - , mkFieldS - (paraName <<<- ParaName "Population" $ emptyParams) - (PP.text . show) - readParser - population - (\ b a -> a{population = b}) - , mkFieldS - (paraName <<<- ParaName "Window size" $ emptyParams) - (PP.text . show) - (pairParser intParser) - windowSize - (\(c,d) a -> a{windowSize = (c,d)}) - , mkFieldS - (paraName <<<- ParaName "Active package" $ emptyParams) - (PP.text . show) - readParser - activePackage - (\fp a -> a{activePackage = fp}) - , mkFieldS - (paraName <<<- ParaName "Active pane" $ emptyParams) - (PP.text . show) - readParser - activePaneN - (\fp a -> a{activePaneN = fp}) - , mkFieldS - (paraName <<<- ParaName "Toolbar visible" $ emptyParams) - (PP.text . show) - readParser - toolbarVisibleS - (\fp a -> a{toolbarVisibleS = fp}) - , mkFieldS - (paraName <<<- ParaName "FindbarState" $ emptyParams) - (PP.text . show) - readParser - findbarState - (\fp a -> a{findbarState = fp}) - , mkFieldS - (paraName <<<- ParaName "Recently opened files" $ emptyParams) - (PP.text . show) - readParser - recentOpenedFiles - (\fp a -> a{recentOpenedFiles = fp}) - , mkFieldS - (paraName <<<- ParaName "Recently opened packages" $ emptyParams) - (PP.text . show) - readParser - recentOpenedPackages - (\fp a -> a{recentOpenedPackages = fp})] - --- --- | Get and save the current layout --- -saveSession :: IDEAction -saveSession = do - sessionPath <- liftIO $ getConfigFilePathForSave standardSessionFilename - saveSessionAs sessionPath - -saveSessionAs :: FilePath -> IDEAction -saveSessionAs sessionPath = do - forget <- getForgetSession - if forget - then ideMessage Normal "Forget this session" - else do - sysMessage Normal "Now saving session" - bufs <- allBuffers - case filter (\b -> bufferName b == "_Eval.hs") bufs of - [buf] -> liftIO $ do - gtkbuf <- textViewGetBuffer (sourceView buf) - textBufferSetModified gtkbuf False - _ -> return () - wdw <- getMainWindow - layout <- mkLayout - population <- getPopulation - size <- liftIO $ windowGetSize wdw - active <- getActive - activePane' <- getActivePane - let activeP = case activePane' of - Nothing -> Nothing - Just (s,_) -> Just s - (toolbarVisible,_) <- readIDE toolbar - findState <- getFindState - (findbarVisible,_) <- readIDE findbar - timeNow <- liftIO getClockTime - recentFiles' <- readIDE recentFiles - recentPackages' <- readIDE recentPackages - liftIO $ writeLayout sessionPath (SessionState { - saveTime = show timeNow - , layoutS = layout - , population = population - , windowSize = size - , activePackage = active - , activePaneN = activeP - , toolbarVisibleS = toolbarVisible - , findbarState = (findbarVisible,findState) - , recentOpenedFiles = recentFiles' - , recentOpenedPackages= recentPackages'}) - -saveSessionAsPrompt :: IDEAction -saveSessionAsPrompt = do - window' <- getMainWindow - response <- liftIO $ do - configFolder <- getConfigDir - dialog <- fileChooserDialogNew - (Just $ "Save Session as") - (Just window') - FileChooserActionSave - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-save" - , ResponseAccept)] - fileChooserSetCurrentFolder dialog configFolder - widgetShow dialog - res <- dialogRun dialog - case res of - ResponseAccept -> do - fileName <- fileChooserGetFilename dialog - widgetHide dialog - return fileName - _ -> do - widgetHide dialog - return Nothing - case response of - Just fn -> saveSessionAs fn - Nothing -> return () - -loadSessionPrompt :: IDEAction -loadSessionPrompt = do - window' <- getMainWindow - response <- liftIO $ do - configFolder <- getConfigDir - dialog <- fileChooserDialogNew - (Just $ "Select session file") - (Just window') - FileChooserActionOpen - [("gtk-cancel" - ,ResponseCancel) - ,("gtk-open" - , ResponseAccept)] - fileChooserSetCurrentFolder dialog configFolder - widgetShow dialog - res <- dialogRun dialog - case res of - ResponseAccept -> do - fileName <- fileChooserGetFilename dialog - widgetHide dialog - return fileName - _ -> do - widgetHide dialog - return Nothing - case response of - Just fn -> loadSession fn - Nothing -> return () - -loadSession :: FilePath -> IDEAction -loadSession sessionPath = do - saveSession :: IDEAction - deactivatePackage - recentFiles' <- readIDE recentFiles - recentPackages' <- readIDE recentPackages - b <- fileCloseAll (\_ -> return True) - if b - then do - paneCloseAll - viewCollapseAll - recoverSession sessionPath - modifyIDE_ (\ide -> ide{recentFiles = recentFiles', recentPackages = recentPackages'}) - return () - else return () - -paneCloseAll :: IDEAction -paneCloseAll = do - panes' <- getPanesSt - mapM_ (\ (PaneC p) -> close p) (Map.elems panes') - -viewCollapseAll :: IDEAction -viewCollapseAll = do - layout' <- getLayout - case layout' of - TerminalP {} -> return () - VerticalP _ _ _ -> viewCollapse' [SplitP LeftP] - HorizontalP _ _ _ -> viewCollapse' [SplitP TopP] - -writeLayout :: FilePath -> SessionState -> IO () -writeLayout fpath ls = writeFile fpath (showLayout ls layoutDescr) - -showLayout :: a -> [FieldDescriptionS a] -> String -showLayout prefs prefsDesc = PP.render $ - foldl' (\ doc (FDS _ printer _) -> doc PP.$+$ printer prefs) PP.empty prefsDesc - -mkLayout :: IDEM(PaneLayout) -mkLayout = do - rawLayout <- getLayout - getLayout' rawLayout [] - where - getLayout' (HorizontalP l r _) pp = do - l2 <- getLayout' l (pp ++ [SplitP TopP]) - r2 <- getLayout' r (pp ++ [SplitP BottomP]) - pane <- getPaned pp - pos <- liftIO $ panedGetPosition pane - return (HorizontalP l2 r2 pos) - getLayout' (VerticalP l r _) pp = do - l2 <- getLayout' l (pp ++ [SplitP LeftP]) - r2 <- getLayout' r (pp ++ [SplitP RightP]) - pane <- getPaned pp - pos <- liftIO $ panedGetPosition pane - return (VerticalP l2 r2 pos) - getLayout' raw@(TerminalP {paneGroups = groups}) pp = do - groups2 <- forM (Map.toAscList groups) $ \(group, g) -> do - l <- getLayout' g (pp ++ [GroupP group]) - return (group, l) - nb <- getNotebook pp - showTabs <- liftIO $ notebookGetShowTabs nb - pos <- liftIO $ notebookGetTabPos nb - current <- liftIO $ notebookGetCurrentPage nb - size <- case detachedId raw of - Just _ -> do - Just parent <- liftIO $ widgetGetParent nb - liftIO $ fmap Just $ windowGetSize (castToWindow parent) - Nothing -> return $ detachedSize raw - return raw{ - paneGroups = Map.fromAscList groups2 - , paneTabs = if showTabs then Just (posTypeToPaneDirection pos) else Nothing - , currentPage = current - , detachedSize = size} - -getPopulation :: IDEM[(Maybe PaneState,PanePath)] -getPopulation = do - paneMap <- getPaneMapSt - mapM (\ (pn,v) -> do - (PaneC p) <- paneFromName pn - mbSt <- saveState p - case mbSt of - Nothing -> return (Nothing, fst v) - Just st -> return (Just (asPaneState st), fst v)) - $ Map.toList paneMap - -getActive :: IDEM(Maybe String) -getActive = do - active <- readIDE activePack - case active of - Nothing -> return Nothing - Just p -> return (Just (cabalFile p)) - --- ------------------------------------------------------------ --- * Parsing --- ------------------------------------------------------------ - --- --- | Read and apply the saved layout --- - -recoverSession :: FilePath -> IDEM (Bool,Bool) -recoverSession sessionPath = catchIDE (do - wdw <- getMainWindow - sessionSt <- liftIO $ readLayout sessionPath - liftIO $ windowSetDefaultSize wdw (fst (windowSize sessionSt))(snd (windowSize sessionSt)) - applyLayout (layoutS sessionSt) - case activePackage sessionSt of - Just fp -> activatePackage fp >> return () - Nothing -> return () - populate (population sessionSt) - setCurrentPages (layoutS sessionSt) - when (isJust (activePaneN sessionSt)) $ do - mbPane <- mbPaneFromName (fromJust (activePaneN sessionSt)) - case mbPane of - Nothing -> return () - Just (PaneC p) -> makeActive p - setFindState ((snd . findbarState) sessionSt) - if toolbarVisibleS sessionSt - then showToolbar - else hideToolbar - if (fst . findbarState) sessionSt - then showFindbar - else hideFindbar - modifyIDE_ (\ide -> ide{recentFiles = recentOpenedFiles sessionSt, - recentPackages = recentOpenedPackages sessionSt}) - return (toolbarVisibleS sessionSt, (fst . findbarState) sessionSt)) - (\ (e :: SomeException) -> do - sysMessage Normal (show e) - return (True,True)) - - -readLayout :: FilePath -> IO SessionState -readLayout sessionPath = do - res <- parseFromFile (prefsParser defaultLayout layoutDescr) sessionPath - case res of - Left pe -> throwIDE $"Error reading session file " ++ show sessionPath ++ " " ++ show pe - Right r -> return r - -prefsParser :: a -> [FieldDescriptionS a] -> CharParser () a -prefsParser def descriptions = - let parsersF = map fieldParser descriptions in do - whiteSpace - applyFieldParsers def parsersF - "layout parser" - -applyLayout :: PaneLayout -> IDEAction -applyLayout layoutS = do - old <- getLayout - case old of - TerminalP {} -> applyLayout' layoutS [] - otherwise -> throwIDE "apply Layout can only be allied to empty Layout" - where - applyLayout' (TerminalP groups mbTabPos _ mbDetachedId mbDetachedSize) pp = do - forM_ (Map.keys groups) $ \group -> viewNest' pp group - nb <- getNotebook pp - case (mbDetachedId, mbDetachedSize) of - (Just id, Just (width, height)) -> do - mbPair <- viewDetach' pp id - case mbPair of - Nothing -> return () - Just (win,wid) -> do - liftIO $ widgetShowAll win - liftIO $ windowSetDefaultSize win width height - _ -> return () - liftIO $notebookSetShowTabs nb (isJust mbTabPos) - case mbTabPos of - Just p -> liftIO $notebookSetTabPos nb (paneDirectionToPosType p) - _ -> return () - forM_ (Map.toAscList groups) $ \(group, g) -> do - applyLayout' g (pp ++ [GroupP group]) - applyLayout' (VerticalP l r pos) pp = do - viewSplit' pp Vertical - pane <- getPaned pp - liftIO $panedSetPosition pane pos - applyLayout' l (pp ++ [SplitP LeftP]) - applyLayout' r (pp ++ [SplitP RightP]) - applyLayout' (HorizontalP t b pos) pp = do - viewSplit' pp Horizontal - pane <- getPaned pp - liftIO $panedSetPosition pane pos - applyLayout' t (pp ++ [SplitP TopP]) - applyLayout' b (pp ++ [SplitP BottomP]) - -populate :: [(Maybe PaneState,PanePath)] -> IDEAction -populate = mapM_ (\ (mbPs,pp) -> - case mbPs of - Nothing -> return () - Just s -> recover pp s) - -setCurrentPages :: PaneLayout -> IDEAction -setCurrentPages layout = setCurrentPages' layout [] - where - setCurrentPages' (HorizontalP t b _) p = do setCurrentPages' t (SplitP TopP : p) - setCurrentPages' b (SplitP BottomP : p) - setCurrentPages' (VerticalP l r _) p = do setCurrentPages' l (SplitP LeftP : p) - setCurrentPages' r (SplitP RightP : p) - setCurrentPages' (TerminalP groups _ ind _ _) p = do - forM_ (Map.toAscList groups) $ \(group, g) -> do - setCurrentPages' g (GroupP group : p) - when (ind >= 0) $ do - nb <- getNotebook (reverse p) - liftIO $ notebookSetCurrentPage nb ind - - - - diff --git a/src/IDE/Session.hs b/src/IDE/Session.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Session.hs @@ -0,0 +1,537 @@ +{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Session +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- +-- | Module for saving and recovering the layout +-- +--------------------------------------------------------------------------------- + + +module IDE.Session ( + saveSession +, saveSessionAs +, saveSessionAsPrompt +, recoverSession +, sessionClosePane +, loadSession +, loadSessionPrompt +) where + +import Graphics.UI.Gtk hiding (showLayout) +import Control.Monad.Reader +import System.FilePath +import qualified Data.Map as Map +import Data.Maybe +import Data.Typeable +import qualified Data.Set as Set + +import IDE.Core.State +import IDE.Utils.GUIUtils +import IDE.Utils.FileUtils +import Text.PrinterParser +import qualified Text.PrettyPrint.HughesPJ as PP +import Graphics.UI.Editor.Parameters +import IDE.TextEditor +import IDE.Pane.Modules +import IDE.Pane.SourceBuffer +import IDE.Pane.Info +import IDE.Pane.References +import IDE.Pane.Log +import IDE.Pane.Preferences +import IDE.Pane.PackageFlags +import IDE.Pane.Search +import IDE.Pane.Grep +import IDE.Pane.Breakpoints +import IDE.Pane.Trace +import IDE.Pane.Variables +import IDE.Find +import System.Time (getClockTime) +import IDE.Package (deactivatePackage) +import IDE.Pane.Errors (ErrorsState(..)) +import Control.Exception (SomeException(..)) +import IDE.Pane.Workspace (WorkspaceState(..)) +import IDE.Workspaces (workspaceOpenThis) + + +-- --------------------------------------------------------------------- +-- This needs to be incremented, when the session format changes +-- +theSessionVersion :: Int +theSessionVersion = 1 + +-- --------------------------------------------------------------------- +-- All pane types must be in here ! +-- + +data PaneState = BufferSt BufferState + | LogSt LogState + | InfoSt InfoState + | ModulesSt ModulesState + | ReferencesSt ReferencesState + | PrefsSt PrefsState + | FlagsSt FlagsState + | SearchSt SearchState + | GrepSt GrepState + | BreakpointsSt BreakpointsState + | TraceSt TraceState + | VariablesSt VariablesState + | ErrorsSt ErrorsState + | WorkspaceSt WorkspaceState + deriving(Eq,Ord,Read,Show) + +asPaneState :: RecoverablePane alpha beta gamma => beta -> PaneState +asPaneState s | isJust ((cast s) :: Maybe BufferState) = BufferSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe LogState) = LogSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe InfoState) = InfoSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe ModulesState) = ModulesSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe ReferencesState) = ReferencesSt (fromJust $ cast s) +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 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) +asPaneState s | isJust ((cast s) :: Maybe VariablesState) = VariablesSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe ErrorsState) = ErrorsSt (fromJust $ cast s) +asPaneState s | isJust ((cast s) :: Maybe WorkspaceState) = WorkspaceSt (fromJust $ cast s) +asPaneState s = error "SaveSession>>asPaneState incomplete cast" + +recover :: PanePath -> PaneState -> IDEAction +recover pp (BufferSt p) = recoverState pp p >> return () +recover pp (LogSt p) = recoverState pp p >> return () +recover pp (InfoSt p) = recoverState pp p >> return () +recover pp (ModulesSt p) = recoverState pp p >> return () +recover pp (ReferencesSt p) = recoverState pp p >> return () +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 (GrepSt p) = recoverState pp p >> return () +recover pp (BreakpointsSt p) = recoverState pp p >> return () +recover pp (TraceSt p) = recoverState pp p >> return () +recover pp (VariablesSt p) = recoverState pp p >> return () +recover pp (ErrorsSt p) = recoverState pp p >> return () +recover pp (WorkspaceSt p) = recoverState pp p >> return () + +-- --------------------------------------------------------------------- + + + +-- | *Implementation + +sessionClosePane :: IDEAction +sessionClosePane = do + activePane' <- getActivePane + case activePane' of + Nothing -> return () + Just (pn,_) -> do + (PaneC p) <- paneFromName pn + closePane p + return () + +data SessionState = SessionState { + sessionVersion :: Int + , saveTime :: String + , layoutS :: PaneLayout + , population :: [(Maybe PaneState,PanePath)] + , windowSize :: (Int,Int) + , workspacePath :: Maybe FilePath + , activePaneN :: Maybe String + , toolbarVisibleS :: Bool + , findbarState :: (Bool,FindState) + , recentOpenedFiles :: [FilePath] + , recentOpenedWorksp :: [FilePath] +} + +defaultSession = SessionState { + sessionVersion = theSessionVersion + , saveTime = "" + , layoutS = TerminalP Map.empty (Just TopP) (-1) Nothing Nothing + , population = [] + , windowSize = (1024,768) + , workspacePath = Nothing + , activePaneN = Nothing + , toolbarVisibleS = True + , findbarState = (False,FindState{ + entryStr = "" + , entryHist = [] + , replaceStr = "" + , replaceHist = [] + , caseSensitive = False + , entireWord = False + , wrapAround = True + , regex = False + , lineNr = 1}) + , recentOpenedFiles = [] + , recentOpenedWorksp = [] +} + +sessionDescr :: [FieldDescriptionS SessionState] +sessionDescr = [ + mkFieldS + (paraName <<<- ParaName "Version of session file format" $ emptyParams) + (PP.text . show) + intParser + sessionVersion + (\ b a -> a{sessionVersion = b}) + , mkFieldS + (paraName <<<- ParaName "Time of storage" $ emptyParams) + (PP.text . show) + stringParser + saveTime + (\ b a -> a{saveTime = b}) + , mkFieldS + (paraName <<<- ParaName "Layout" $ emptyParams) + (PP.text . show) + readParser + layoutS + (\ b a -> a{layoutS = b}) + , mkFieldS + (paraName <<<- ParaName "Population" $ emptyParams) + (PP.text . show) + readParser + population + (\ b a -> a{population = b}) + , mkFieldS + (paraName <<<- ParaName "Window size" $ emptyParams) + (PP.text . show) + (pairParser intParser) + windowSize + (\(c,d) a -> a{windowSize = (c,d)}) + , mkFieldS + (paraName <<<- ParaName "Workspace" $ emptyParams) + (PP.text . show) + readParser + workspacePath + (\fp a -> a{workspacePath = fp}) + , mkFieldS + (paraName <<<- ParaName "Active pane" $ emptyParams) + (PP.text . show) + readParser + activePaneN + (\fp a -> a{activePaneN = fp}) + , mkFieldS + (paraName <<<- ParaName "Toolbar visible" $ emptyParams) + (PP.text . show) + readParser + toolbarVisibleS + (\fp a -> a{toolbarVisibleS = fp}) + , mkFieldS + (paraName <<<- ParaName "FindbarState" $ emptyParams) + (PP.text . show) + readParser + findbarState + (\fp a -> a{findbarState = fp}) + , mkFieldS + (paraName <<<- ParaName "Recently opened files" $ emptyParams) + (PP.text . show) + readParser + recentOpenedFiles + (\fp a -> a{recentOpenedFiles = fp}) + , mkFieldS + (paraName <<<- ParaName "Recently opened workspaces" $ emptyParams) + (PP.text . show) + readParser + recentOpenedWorksp + (\fp a -> a{recentOpenedWorksp = fp})] + +-- +-- | Get and save the current session +-- +saveSession :: IDEAction +saveSession = do + sessionPath <- liftIO $ getConfigFilePathForSave standardSessionFilename + mbSessionPath2 <- do + ws <- readIDE workspace + case ws of + Nothing -> return Nothing + Just ws -> return $ Just (dropExtension (wsFile ws) ++ + leksahSessionFileExtension) + saveSessionAs sessionPath mbSessionPath2 + +saveSessionAs :: FilePath -> Maybe FilePath -> IDEAction +saveSessionAs sessionPath mbSecondPath = do + forget <- getForgetSession + if forget + then ideMessage Normal "Forget this session" + else do + sysMessage Normal "Now saving session" + bufs <- allBuffers + case filter (\b -> bufferName b == "_Eval.hs") bufs of + [buf] -> do + ebuf <- getBuffer (sourceView buf) + setModified ebuf False + _ -> return () + wdw <- getMainWindow + layout <- mkLayout + population <- getPopulation + size <- liftIO $ windowGetSize wdw + mbWs <- readIDE workspace + activePane' <- getActivePane + let activeP = case activePane' of + Nothing -> Nothing + Just (s,_) -> Just s + (toolbarVisible,_) <- readIDE toolbar + findState <- getFindState + (findbarVisible,_) <- readIDE findbar + timeNow <- liftIO getClockTime + recentFiles' <- readIDE recentFiles + recentWorkspaces' <- readIDE recentWorkspaces + let state = SessionState { + sessionVersion = theSessionVersion + , saveTime = show timeNow + , layoutS = layout + , population = population + , windowSize = size + , workspacePath = case mbWs of + Nothing -> Nothing + Just ws -> Just (wsFile ws) + , activePaneN = activeP + , toolbarVisibleS = toolbarVisible + , findbarState = (findbarVisible,findState) + , recentOpenedFiles = recentFiles' + , recentOpenedWorksp = recentWorkspaces'} + liftIO $ writeFields sessionPath state sessionDescr + when (isJust mbSecondPath) $ + liftIO $ writeFields (fromJust mbSecondPath) state sessionDescr + +saveSessionAsPrompt :: IDEAction +saveSessionAsPrompt = do + window <- getMainWindow + response <- liftIO $ do + configFolder <- getConfigDir + chooseSaveFile window "Save Session as" (Just configFolder) + case response of + Just fn -> saveSessionAs (if takeExtension fn == leksahSessionFileExtension + then fn + else addExtension fn leksahSessionFileExtension) + Nothing + Nothing -> return () + +loadSessionPrompt :: IDEAction +loadSessionPrompt = do + window' <- getMainWindow + response <- liftIO $ do + configFolder <- getConfigDir + dialog <- fileChooserDialogNew + (Just $ "Select session file") + (Just window') + FileChooserActionOpen + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-open" + , ResponseAccept)] + fileChooserSetCurrentFolder dialog configFolder + widgetShow dialog + res <- dialogRun dialog + case res of + ResponseAccept -> do + fileName <- fileChooserGetFilename dialog + widgetHide dialog + return fileName + _ -> do + widgetHide dialog + return Nothing + case response of + Just fn -> loadSession fn + Nothing -> return () + +loadSession :: FilePath -> IDEAction +loadSession sessionPath = do + saveSession :: IDEAction + deactivatePackage + recentFiles' <- readIDE recentFiles + recentWorkspaces' <- readIDE recentWorkspaces + b <- fileCloseAll (\_ -> return True) + if b + then do + detachedCloseAll + paneCloseAll + groupsCloseAll + viewCollapseAll + recoverSession sessionPath + modifyIDE_ (\ide -> ide{recentFiles = recentFiles', recentWorkspaces = recentWorkspaces'}) + return () + else return () + +detachedCloseAll :: IDEAction +detachedCloseAll = do + windows <- getWindows + liftIO $ mapM_ widgetDestroy (tail windows) + +paneCloseAll :: IDEAction +paneCloseAll = do + panes' <- getPanesSt + mapM_ (\ (PaneC p) -> closePane p) (Map.elems panes') + +groupsCloseAll :: IDEAction +groupsCloseAll = do + layout' <- getLayout + mapM_ closeGroup (Set.toList $ allGroupNames layout') + +viewCollapseAll :: IDEAction +viewCollapseAll = do + layout' <- getLayout + case layout' of + TerminalP {} -> return () + VerticalP _ _ _ -> viewCollapse' [SplitP LeftP] + HorizontalP _ _ _ -> viewCollapse' [SplitP TopP] + +mkLayout :: IDEM(PaneLayout) +mkLayout = do + rawLayout <- getLayout + getLayout' rawLayout [] + where + getLayout' (HorizontalP l r _) pp = do + l2 <- getLayout' l (pp ++ [SplitP TopP]) + r2 <- getLayout' r (pp ++ [SplitP BottomP]) + pane <- getPaned pp + pos <- liftIO $ panedGetPosition pane + return (HorizontalP l2 r2 pos) + getLayout' (VerticalP l r _) pp = do + l2 <- getLayout' l (pp ++ [SplitP LeftP]) + r2 <- getLayout' r (pp ++ [SplitP RightP]) + pane <- getPaned pp + pos <- liftIO $ panedGetPosition pane + return (VerticalP l2 r2 pos) + getLayout' raw@(TerminalP {paneGroups = groups}) pp = do + groups2 <- forM (Map.toAscList groups) $ \(group, g) -> do + l <- getLayout' g (pp ++ [GroupP group]) + return (group, l) + nb <- getNotebook pp + showTabs <- liftIO $ notebookGetShowTabs nb + pos <- liftIO $ notebookGetTabPos nb + current <- liftIO $ notebookGetCurrentPage nb + size <- case detachedId raw of + Just _ -> do + Just parent <- liftIO $ widgetGetParent nb + liftIO $ fmap Just $ windowGetSize (castToWindow parent) + Nothing -> return $ detachedSize raw + return raw { + paneGroups = Map.fromAscList groups2 + , paneTabs = if showTabs then Just (posTypeToPaneDirection pos) else Nothing + , currentPage = current + , detachedSize = size} + +getPopulation :: IDEM[(Maybe PaneState,PanePath)] +getPopulation = do + paneMap <- getPaneMapSt + mapM (\ (pn,v) -> do + (PaneC p) <- paneFromName pn + mbSt <- saveState p + case mbSt of + Nothing -> return (Nothing, fst v) + Just st -> return (Just (asPaneState st), fst v)) + $ Map.toList paneMap + +getActive :: IDEM(Maybe String) +getActive = do + active <- readIDE activePack + case active of + Nothing -> return Nothing + Just p -> return (Just (ipdCabalFile p)) + +-- ------------------------------------------------------------ +-- * Parsing +-- ------------------------------------------------------------ + +-- +-- | Read and apply the saved layout +-- + +recoverSession :: FilePath -> IDEM (Bool,Bool) +recoverSession sessionPath = catchIDE (do + wdw <- getMainWindow + sessionSt <- liftIO $ readFields sessionPath sessionDescr defaultSession + liftIO $ windowSetDefaultSize wdw (fst (windowSize sessionSt))(snd (windowSize sessionSt)) + applyLayout (layoutS sessionSt) + workspaceOpenThis False (workspacePath sessionSt) + populate (population sessionSt) + setCurrentPages (layoutS sessionSt) + when (isJust (activePaneN sessionSt)) $ do + mbPane <- mbPaneFromName (fromJust (activePaneN sessionSt)) + case mbPane of + Nothing -> return () + Just (PaneC p) -> makeActive p + setFindState ((snd . findbarState) sessionSt) + if toolbarVisibleS sessionSt + then showToolbar + else hideToolbar + if (fst . findbarState) sessionSt + then showFindbar + else hideFindbar + modifyIDE_ (\ide -> ide{recentFiles = recentOpenedFiles sessionSt, + recentWorkspaces = recentOpenedWorksp sessionSt}) + return (toolbarVisibleS sessionSt, (fst . findbarState) sessionSt)) + (\ (e :: SomeException) -> do + sysMessage Normal (show e) + return (True,True)) + +applyLayout :: PaneLayout -> IDEAction +applyLayout layoutS = do + old <- getLayout + case old of + TerminalP {} -> applyLayout' layoutS [] + otherwise -> throwIDE "apply Layout can only be allied to empty Layout" + where + applyLayout' (TerminalP groups mbTabPos _ mbDetachedId mbDetachedSize) pp = do + forM_ (Map.keys groups) $ \group -> viewNest' pp group + nb <- getNotebook pp + case (mbDetachedId, mbDetachedSize) of + (Just id, Just (width, height)) -> do + mbPair <- viewDetach' pp id + case mbPair of + Nothing -> return () + Just (win,wid) -> do + liftIO $ widgetShowAll win + liftIO $ windowSetDefaultSize win width height + _ -> return () + liftIO $notebookSetShowTabs nb (isJust mbTabPos) + case mbTabPos of + Just p -> liftIO $notebookSetTabPos nb (paneDirectionToPosType p) + _ -> return () + forM_ (Map.toAscList groups) $ \(group, g) -> do + applyLayout' g (pp ++ [GroupP group]) + applyLayout' (VerticalP l r pos) pp = do + viewSplit' pp Vertical + pane <- getPaned pp + liftIO $panedSetPosition pane pos + applyLayout' l (pp ++ [SplitP LeftP]) + applyLayout' r (pp ++ [SplitP RightP]) + applyLayout' (HorizontalP t b pos) pp = do + viewSplit' pp Horizontal + pane <- getPaned pp + liftIO $panedSetPosition pane pos + applyLayout' t (pp ++ [SplitP TopP]) + applyLayout' b (pp ++ [SplitP BottomP]) + +populate :: [(Maybe PaneState,PanePath)] -> IDEAction +populate = mapM_ (\ (mbPs,pp) -> + case mbPs of + Nothing -> return () + Just s -> recover pp s) + +setCurrentPages :: PaneLayout -> IDEAction +setCurrentPages layout = setCurrentPages' layout [] + where + setCurrentPages' (HorizontalP t b _) p = do setCurrentPages' t (SplitP TopP : p) + setCurrentPages' b (SplitP BottomP : p) + setCurrentPages' (VerticalP l r _) p = do setCurrentPages' l (SplitP LeftP : p) + setCurrentPages' r (SplitP RightP : p) + setCurrentPages' (TerminalP groups _ ind _ _) p = do + forM_ (Map.toAscList groups) $ \(group, g) -> do + setCurrentPages' g (GroupP group : p) + when (ind >= 0) $ do + nb <- getNotebook (reverse p) + liftIO $ notebookSetCurrentPage nb ind + + + + diff --git a/src/IDE/SourceCandy.hs b/src/IDE/SourceCandy.hs --- a/src/IDE/SourceCandy.hs +++ b/src/IDE/SourceCandy.hs @@ -26,17 +26,17 @@ , positionFromCandy -- :: CandyTable -> TextBuffer -> (Int,Int) -> IO (Int,Int) ) where +import Prelude hiding(getChar, getLine) + import Data.Char(chr) import Data.List(isSuffixOf) -import Graphics.UI.Gtk -import Graphics.UI.Gtk.SourceView.SourceBuffer -import Control.Monad.Reader import Text.ParserCombinators.Parsec import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language(emptyDef) import qualified Data.Set as Set import IDE.Core.State +import IDE.TextEditor --------------------------------------------------------------------------------- -- * Implementation @@ -47,21 +47,21 @@ '^','|','-','~','\'','"','\n'] notAfterOp = notBeforeOp -keystrokeCandy :: CandyTable -> Maybe Char -> TextBuffer -> IO () -keystrokeCandy (CT(transformTable,_)) mbc gtkbuf = do - cursorMark <- textBufferGetInsert gtkbuf - endIter <- textBufferGetIterAtMark gtkbuf cursorMark - offset <- textIterGetOffset endIter +keystrokeCandy :: CandyTable -> Maybe Char -> EditorBuffer -> IDEM () +keystrokeCandy (CT(transformTable,_)) mbc ebuf = do + cursorMark <- getInsertMark ebuf + endIter <- getIterAtMark ebuf cursorMark + offset <- getOffset endIter let sliceStart = if offset < 8 then 0 else offset - 8 - startIter <- textBufferGetIterAtOffset gtkbuf sliceStart - slice <- textIterGetSlice startIter endIter + startIter <- getIterAtOffset ebuf sliceStart + slice <- getSlice ebuf startIter endIter True mbc2 <- case mbc of Just c -> return (Just c) Nothing -> do - textIterGetChar endIter + getChar endIter replace mbc2 cursorMark slice offset transformTable where - replace :: Maybe Char -> TextMark -> String -> Int -> [(Bool,String,String)] -> IO () + replace :: Maybe Char -> EditorMark -> String -> Int -> [(Bool,String,String)] -> IDEM () replace mbAfterChar cursorMark match offset list = replace' list where replace' [] = return () @@ -78,40 +78,40 @@ else Set.member afterChar notAfterId in if isSuffixOf from match && beforeOk && afterOk then do - sourceBufferBeginNotUndoableAction (castToSourceBuffer gtkbuf) - start <- textBufferGetIterAtOffset gtkbuf (offset - (length from)) - end <- textBufferGetIterAtOffset gtkbuf offset - textBufferDelete gtkbuf start end - ins <- textBufferGetIterAtMark gtkbuf cursorMark - textBufferInsert gtkbuf ins to - sourceBufferEndNotUndoableAction (castToSourceBuffer gtkbuf) + beginNotUndoableAction ebuf + start <- getIterAtOffset ebuf (offset - (length from)) + end <- getIterAtOffset ebuf offset + delete ebuf start end + ins <- getIterAtMark ebuf cursorMark + insert ebuf ins to + endNotUndoableAction ebuf else replace mbAfterChar cursorMark match offset rest -transformToCandy :: CandyTable -> TextBuffer -> IO () -transformToCandy (CT(transformTable,_)) gtkbuf = do - textBufferBeginUserAction gtkbuf - modified <- textBufferGetModified gtkbuf - mapM_ (\tbl -> replaceTo gtkbuf tbl 0) transformTable - textBufferSetModified gtkbuf modified - textBufferEndUserAction gtkbuf +transformToCandy :: CandyTable -> EditorBuffer -> IDEM () +transformToCandy (CT(transformTable,_)) ebuf = do + beginUserAction ebuf + modified <- getModified ebuf + mapM_ (\tbl -> replaceTo ebuf tbl 0) transformTable + setModified ebuf modified + endUserAction ebuf -replaceTo :: TextBuffer -> (Bool,String,String) -> Int -> IO () +replaceTo :: EditorBuffer -> (Bool,String,String) -> Int -> IDEM () replaceTo buf (isOp,from,to) offset = replaceTo' offset where replaceTo' offset = do - iter <- textBufferGetIterAtOffset buf offset - mbStartEnd <- textIterForwardSearch iter from [] Nothing + iter <- getIterAtOffset buf offset + mbStartEnd <- forwardSearch iter from [] Nothing case mbStartEnd of Nothing -> return () Just (st,end) -> do - stOff <- textIterGetOffset st + stOff <- getOffset st beforeOk <- if stOff == 0 then return True else do - iter <- textBufferGetIterAtOffset buf (stOff - 1) - mbChar <- textIterGetChar iter + iter <- getIterAtOffset buf (stOff - 1) + mbChar <- getChar iter case mbChar of Nothing -> return True Just char -> return (not $if isOp @@ -120,9 +120,9 @@ if beforeOk then do afterOk <- do - endOff <- textIterGetOffset end - iter <- textBufferGetIterAtOffset buf endOff - mbChar <- textIterGetChar iter + endOff <- getOffset end + iter <- getIterAtOffset buf endOff + mbChar <- getChar iter case mbChar of Nothing -> return True Just char -> return (not $if isOp @@ -130,8 +130,8 @@ else Set.member char notAfterId) if afterOk then do - textBufferDelete buf st end - textBufferInsert buf st to + delete buf st end + insert buf st to return () else do return () @@ -139,104 +139,97 @@ return () replaceTo' (stOff + 1) -transformFromCandy :: CandyTable -> TextBuffer -> IO () -transformFromCandy (CT(_,transformTableBack)) gtkbuf = do - textBufferBeginUserAction gtkbuf - modified <- textBufferGetModified gtkbuf - mapM_ (\tbl -> replaceFrom gtkbuf tbl 0) transformTableBack - textBufferEndUserAction gtkbuf - textBufferSetModified gtkbuf modified +transformFromCandy :: CandyTable -> EditorBuffer -> IDEM () +transformFromCandy (CT(_,transformTableBack)) ebuf = do + beginUserAction ebuf + modified <- getModified ebuf + mapM_ (\tbl -> replaceFrom ebuf tbl 0) transformTableBack + endUserAction ebuf + setModified ebuf modified -getCandylessText :: CandyTable -> TextBuffer -> IO String -getCandylessText (CT(_,transformTableBack)) gtkbuf = do - workBuffer <- textBufferNew Nothing - i1 <- textBufferGetStartIter gtkbuf - i2 <- textBufferGetEndIter gtkbuf - text1 <- textBufferGetText gtkbuf i1 i2 True - textBufferSetText workBuffer text1 +getCandylessText :: CandyTable -> EditorBuffer -> IDEM String +getCandylessText (CT(_,transformTableBack)) ebuf = do + i1 <- getStartIter ebuf + i2 <- getEndIter ebuf + text1 <- getText ebuf i1 i2 True + workBuffer <- simpleGtkBuffer text1 mapM_ (\tbl -> replaceFrom workBuffer tbl 0) transformTableBack - i1 <- textBufferGetStartIter workBuffer - i2 <- textBufferGetEndIter workBuffer - text2 <- textBufferGetText workBuffer i1 i2 True + i1 <- getStartIter workBuffer + i2 <- getEndIter workBuffer + text2 <- getText workBuffer i1 i2 True return text2 -getCandylessPart :: CandyTable -> TextBuffer -> TextIter -> TextIter -> IO String -getCandylessPart (CT(_,transformTableBack)) gtkbuf i1 i2 = do - workBuffer <- textBufferNew Nothing - text1 <- textBufferGetText gtkbuf i1 i2 True - textBufferSetText workBuffer text1 +getCandylessPart :: CandyTable -> EditorBuffer -> EditorIter -> EditorIter -> IDEM String +getCandylessPart (CT(_,transformTableBack)) ebuf i1 i2 = do + text1 <- getText ebuf i1 i2 True + workBuffer <- simpleGtkBuffer text1 mapM_ (\tbl -> replaceFrom workBuffer tbl 0) transformTableBack - i1 <- textBufferGetStartIter workBuffer - i2 <- textBufferGetEndIter workBuffer - text2 <- textBufferGetText workBuffer i1 i2 True + i1 <- getStartIter workBuffer + i2 <- getEndIter workBuffer + text2 <- getText workBuffer i1 i2 True return text2 -stringToCandy :: CandyTable -> String -> IO String +stringToCandy :: CandyTable -> String -> IDEM String stringToCandy candyTable text = do - workBuffer <- textBufferNew Nothing - textBufferSetText workBuffer text + workBuffer <- simpleGtkBuffer text transformToCandy candyTable workBuffer - i1 <- textBufferGetStartIter workBuffer - i2 <- textBufferGetEndIter workBuffer - text2 <- textBufferGetText workBuffer i1 i2 True + i1 <- getStartIter workBuffer + i2 <- getEndIter workBuffer + text2 <- getText workBuffer i1 i2 True return text2 -positionFromCandy :: CandyTable -> TextBuffer -> (Int,Int) -> IO (Int,Int) -positionFromCandy candyTable gtkbuf (line,column) = do - i1 <- textBufferGetIterAtLine gtkbuf (max 0 (line - 1)) - i2 <- textIterCopy i1 - textIterForwardToLineEnd i2 - text <- textBufferGetText gtkbuf i1 i2 True - workBuffer <- textBufferNew Nothing - textBufferSetText workBuffer text - i3 <- textBufferGetIterAtOffset workBuffer column - mark <- textBufferCreateMark workBuffer Nothing i3 True +positionFromCandy :: CandyTable -> EditorBuffer -> (Int,Int) -> IDEM (Int,Int) +positionFromCandy candyTable ebuf (line,column) = do + i1 <- getIterAtLine ebuf (max 0 (line - 1)) + i2 <- forwardToLineEndC i1 + text <- getText ebuf i1 i2 True + workBuffer <- simpleGtkBuffer text + i3 <- getIterAtOffset workBuffer column + mark <- createMark workBuffer i3 True transformFromCandy candyTable workBuffer - i4 <- textBufferGetIterAtMark workBuffer mark - columnNew <- textIterGetLineOffset i4 + i4 <- getIterAtMark workBuffer mark + columnNew <- getLineOffset i4 return (line,columnNew) -positionToCandy :: CandyTable -> TextBuffer -> (Int,Int) -> IO (Int,Int) -positionToCandy candyTable gtkbuf (line,column) = do - i1 <- textBufferGetIterAtLine gtkbuf (max 0 (line - 1)) - i2 <- textIterCopy i1 - textIterForwardToLineEnd i2 - text <- textBufferGetText gtkbuf i1 i2 True - workBuffer <- textBufferNew Nothing - textBufferSetText workBuffer text +positionToCandy :: CandyTable -> EditorBuffer -> (Int,Int) -> IDEM (Int,Int) +positionToCandy candyTable ebuf (line,column) = do + i1 <- getIterAtLine ebuf (max 0 (line - 1)) + i2 <- forwardToLineEndC i1 + text <- getText ebuf i1 i2 True + workBuffer <- simpleGtkBuffer text transformFromCandy candyTable workBuffer - i3 <- textBufferGetIterAtOffset workBuffer column - mark <- textBufferCreateMark workBuffer Nothing i3 True + i3 <- getIterAtOffset workBuffer column + mark <- createMark workBuffer i3 True transformToCandy candyTable workBuffer - i4 <- textBufferGetIterAtMark workBuffer mark - columnNew <- textIterGetLineOffset i4 + i4 <- getIterAtMark workBuffer mark + columnNew <- getLineOffset i4 return (line,columnNew) -replaceFrom :: TextBuffer -> (String,String,Int) -> Int -> IO () +replaceFrom :: EditorBuffer -> (String,String,Int) -> Int -> IDEM () replaceFrom buf (to,from,spaces) offset = replaceFrom' offset where replaceFrom' offset = do - iter <- textBufferGetIterAtOffset buf offset - mbStartEnd <- textIterForwardSearch iter from [] Nothing + iter <- getIterAtOffset buf offset + mbStartEnd <- forwardSearch iter from [] Nothing case mbStartEnd of Nothing -> return () Just (st,end) -> do - offset <- textIterGetOffset st - textBufferDelete buf st end + offset <- getOffset st + delete buf st end if spaces > 0 then do - iter2 <- textBufferGetIterAtOffset buf offset - iter3 <- textBufferGetIterAtOffset buf (offset + spaces + 1) - slice <- textIterGetSlice iter2 iter3 + iter2 <- getIterAtOffset buf offset + iter3 <- getIterAtOffset buf (offset + spaces + 1) + slice <- getSlice buf iter2 iter3 True let l = length (takeWhile (== ' ') slice) if l > 1 then do - textIterSetOffset iter3 (offset + l - 1) - textBufferDelete buf iter2 iter3 + iter4 <- atOffset iter3 (offset + l - 1) + delete buf iter2 iter4 else return () else return () - iter <- textBufferGetIterAtOffset buf offset - textBufferInsert buf iter to + iter <- getIterAtOffset buf offset + insert buf iter to replaceFrom' offset type CandyTableI = [(String,Char,Bool)] diff --git a/src/IDE/Statusbar.hs b/src/IDE/Statusbar.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Statusbar.hs @@ -0,0 +1,182 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Statusbar +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : +-- +-- | Builds and updates the Statusbar, To update the bar triiger the Statusbar changed event. +-- +----------------------------------------------------------------------------- + +module IDE.Statusbar ( + changeStatusbar +, buildStatusbar +) where +import IDE.Core.State + (getMainWindow, + widgetGet, + PaneMonad(..), + IDEAction(..), + StatusbarCompartment(..)) +import Control.Monad.Trans (liftIO) +import Graphics.UI.Gtk + (windowSetTitle, + castToStatusbar, + Statusbar(..), + boxPackStart, + hBoxNew, + widgetSetSizeRequest, + widgetSetName, + statusbarSetHasResizeGrip, + statusbarNew, + HBox(..), + statusbarPush, + statusbarPop, + Packing(..), + boxPackEnd, + imageSetPixelSize, + imageNewFromStock, + IconSize(..), + Image, + castToImage, + imageSetFromStock + ) +import Graphics.UI.Frame.Panes (IDEPane(..), paneName) +import Text.Printf (printf) + + +changeStatusbar :: [StatusbarCompartment] -> IDEAction +changeStatusbar = mapM_ changeStatusbar' + where + changeStatusbar' (CompartmentCommand accStr) = do + sb <- getSBSpecialKeys + liftIO $statusbarPop sb 1 + liftIO $statusbarPush sb 1 accStr + return () + changeStatusbar' (CompartmentPane (Just (PaneC pane))) = do + sb <- getSBActivePane + liftIO $ statusbarPop sb 1 + liftIO $ statusbarPush sb 1 (paneName pane) + return () + changeStatusbar' (CompartmentPane Nothing) = do + sb <- getSBActivePane + liftIO $ statusbarPop sb 1 + liftIO $ statusbarPush sb 1 "" + return () + changeStatusbar' (CompartmentState string) = do + let realStr = if '\n' `elem` string then (head $ lines string) ++ " ..." else string + sb <- getSBErrors + liftIO $ statusbarPop sb 1 + liftIO $ statusbarPush sb 1 realStr + return () + changeStatusbar' (CompartmentPackage string) = do + sb <- getSBActivePackage + window <- getMainWindow + liftIO $ statusbarPop sb 1 + liftIO $ statusbarPush sb 1 string + liftIO $ windowSetTitle window $ "Leksah: " ++ string + return () + changeStatusbar' (CompartmentBufferPos (line,col)) = do + sb <- getStatusbarLC + liftIO $ statusbarPop sb 1 + liftIO $ statusbarPush sb 1 $ printf "Ln %4d, Col %3d" (line + 1) (col + 1) + return () + changeStatusbar' (CompartmentOverlay modi) = do + sb <- getStatusbarIO + liftIO $ statusbarPop sb 1 + liftIO $ statusbarPush sb 1 $ if modi then "OVR" else "INS" + return () + changeStatusbar' (CompartmentBuild bool) = do + im <- getImBuild + liftIO $ imageSetFromStock im (if bool then "ide_build" else "ide_empty") IconSizeMenu + return () + changeStatusbar' (CompartmentCollect bool) = do + im <- getImCollect + liftIO $ imageSetFromStock im (if bool then "ide_rebuild_meta" else "ide_empty") IconSizeMenu + return () + + +buildStatusbar :: IO HBox +buildStatusbar = do + sb <- statusbarNew + statusbarSetHasResizeGrip sb False + + sblk <- statusbarNew + widgetSetName sblk "statusBarSpecialKeys" + statusbarSetHasResizeGrip sblk False + widgetSetSizeRequest sblk 150 (-1) + + sbap <- statusbarNew + widgetSetName sbap "statusBarActivePane" + statusbarSetHasResizeGrip sbap False + widgetSetSizeRequest sbap 150 (-1) + + sbapr <- statusbarNew + widgetSetName sbapr "statusBarActiveProject" + statusbarSetHasResizeGrip sbapr False + widgetSetSizeRequest sbapr 150 (-1) + + sbe <- statusbarNew + widgetSetName sbe "statusBarErrors" + statusbarSetHasResizeGrip sbe False + widgetSetSizeRequest sbe 150 (-1) + + sblc <- statusbarNew + widgetSetName sblc "statusBarLineColumn" + statusbarSetHasResizeGrip sblc True + widgetSetSizeRequest sblc 150 (-1) + + sbio <- statusbarNew + widgetSetName sbio "statusBarInsertOverwrite" + statusbarSetHasResizeGrip sbio False + widgetSetSizeRequest sbio 60 (-1) + + buildImage <- imageNewFromStock "ide_empty" IconSizeMenu + widgetSetName buildImage "buildImage" + imageSetPixelSize buildImage 16 + + collectImage <- imageNewFromStock "ide_empty" IconSizeMenu + widgetSetName collectImage "collectImage" + imageSetPixelSize collectImage 16 + + hb <- hBoxNew False 1 + widgetSetName hb "statusBox" + boxPackStart hb sblk PackGrow 0 + boxPackStart hb sbap PackGrow 0 + boxPackStart hb sbapr PackGrow 0 + --boxPackStart hb dummy PackGrow 0 + boxPackEnd hb sblc PackNatural 0 + boxPackEnd hb sbio PackNatural 0 + boxPackEnd hb collectImage PackNatural 0 + boxPackEnd hb buildImage PackNatural 0 + boxPackEnd hb sbe PackNatural 0 + + return hb + +getSBSpecialKeys :: PaneMonad alpha => alpha Statusbar +getSBSpecialKeys = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarSpecialKeys"] castToStatusbar + +getSBActivePane :: PaneMonad alpha => alpha Statusbar +getSBActivePane = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarActivePane"] castToStatusbar + +getSBActivePackage :: PaneMonad alpha => alpha Statusbar +getSBActivePackage = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarActiveProject"] castToStatusbar + +getSBErrors :: PaneMonad alpha => alpha Statusbar +getSBErrors = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarErrors"] castToStatusbar + +getStatusbarIO :: PaneMonad alpha => alpha Statusbar +getStatusbarIO = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarInsertOverwrite"] castToStatusbar + +getStatusbarLC :: PaneMonad alpha => alpha Statusbar +getStatusbarLC = widgetGet ["Leksah Main Window", "topBox","statusBox","statusBarLineColumn"] castToStatusbar + +getImBuild :: PaneMonad alpha => alpha Image +getImBuild = widgetGet ["Leksah Main Window", "topBox","statusBox","buildImage"] castToImage + +getImCollect :: PaneMonad alpha => alpha Image +getImCollect = widgetGet ["Leksah Main Window", "topBox","statusBox","collectImage"] castToImage diff --git a/src/IDE/TextEditor.hs b/src/IDE/TextEditor.hs new file mode 100644 --- /dev/null +++ b/src/IDE/TextEditor.hs @@ -0,0 +1,1085 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.TextEditor +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : +-- +-- | +-- +----------------------------------------------------------------------------- + +module IDE.TextEditor ( + +-- Data Types + EditorBuffer(..) +, EditorView(..) +, EditorMark(..) +, EditorIter(..) +, EditorTagTable(..) +, EditorTag(..) + +-- Buffer +, newGtkBuffer +, newYiBuffer +, simpleGtkBuffer +, applyTagByName +, beginNotUndoableAction +, beginUserAction +, canRedo +, canUndo +, copyClipboard +, createMark +, cutClipboard +, delete +, deleteSelection +, endNotUndoableAction +, endUserAction +, getEndIter +, getInsertMark +, getIterAtLine +, getIterAtMark +, getIterAtOffset +, getLineCount +, getModified +, getSelectionBoundMark +, getSelectionBounds +, getSlice +, getStartIter +, getTagTable +, getText +, hasSelection +, insert +, moveMark +, newView +, pasteClipboard +, placeCursor +, redo +, removeTagByName +, selectRange +, setModified +, setStyle +, setText +, undo + +-- View +, bufferToWindowCoords +, getBuffer +, getDrawWindow +, getIterLocation +, getOverwrite +, getScrolledWindow +, grabFocus +, scrollToMark +, scrollToIter +, setFont +, setIndentWidth +, setRightMargin +, setShowLineNumbers +, setTabWidth + +-- Iterator +, backwardCharC +, backwardFindCharC +, backwardWordStartC +, endsWord +, forwardCharC +, forwardCharsC +, forwardFindCharC +, forwardToLineEndC +, forwardWordEndC +, forwardSearch +, getChar +, getCharsInLine +, getLine +, getLineOffset +, getOffset +, isStart +, isEnd +, iterEqual +, startsLine +, atEnd +, atLine +, atLineOffset +, atOffset +, atStart + +-- Tag Table +, newTag +, lookupTag + +-- Tag +, background +, underline + +-- Events +, afterFocusIn +, afterModifiedChanged +, afterMoveCursor +, afterToggleOverwrite +, onButtonPress +, onCompletion +, onKeyPress +, onKeyRelease +, onLookupInfo +, onPopulatePopup +) where + +import Prelude hiding(getChar, getLine) +import Data.Char (isAlphaNum) +import Data.Maybe (fromJust) +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 qualified Graphics.UI.Gtk.Multiline.TextView as Gtk +import qualified Graphics.UI.Gtk.Gdk.Events as GtkOld +import qualified Graphics.UI.Gtk.Gdk.EventM as Gtk +import System.Glib.Attributes (AttrOp(..)) + +#ifdef YI +import qualified Yi as Yi hiding(withBuffer) +import qualified Yi.Buffer.Misc as Yi +import qualified Yi.UI.Pango.Control as Yi +import Data.Time (getCurrentTime) +import Control.Monad (unless) +#endif + +import IDE.Core.State +import IDE.Utils.GUIUtils(controlIsPressed) + + + +-- Data types +data EditorBuffer = GtkEditorBuffer Gtk.SourceBuffer +#ifdef YI + | YiEditorBuffer Yi.Buffer +#endif + +data EditorView = GtkEditorView Gtk.SourceView +#ifdef YI + | YiEditorView Yi.View +#endif + +data EditorMark = GtkEditorMark Gtk.TextMark +#ifdef YI + | YiEditorMark Yi.Mark +#endif + +data EditorIter = GtkEditorIter Gtk.TextIter +#ifdef YI + | YiEditorIter Yi.Iter +#endif + +data EditorTagTable = GtkEditorTagTable Gtk.TextTagTable +#ifdef YI + | YiEditorTagTable +#endif + +data EditorTag = GtkEditorTag Gtk.TextTag +#ifdef YI + | YiEditorTag +#endif + +#ifdef YI +withYiBuffer' :: Yi.BufferRef -> Yi.BufferM a -> IDEM a +withYiBuffer' b f = liftYiControl $ Yi.liftEditor $ Yi.withGivenBuffer0 b f + +withYiBuffer :: Yi.Buffer -> Yi.BufferM a -> IDEM a +withYiBuffer b f = withYiBuffer' (Yi.fBufRef b) f + +mkYiIter' :: Yi.BufferRef -> Yi.Point -> EditorIter +mkYiIter' b p = YiEditorIter $ Yi.Iter b p + +mkYiIter :: Yi.Buffer -> Yi.Point -> EditorIter +mkYiIter b p = mkYiIter' (Yi.fBufRef b) p + +iterFromYiBuffer' :: Yi.BufferRef -> Yi.BufferM Yi.Point -> IDEM EditorIter +iterFromYiBuffer' b f = mkYiIter' b <$> withYiBuffer' b f + +iterFromYiBuffer :: Yi.Buffer -> Yi.BufferM Yi.Point -> IDEM EditorIter +iterFromYiBuffer b f = iterFromYiBuffer' (Yi.fBufRef b) f +#endif + +-- 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 + Nothing -> Gtk.sourceLanguageManagerGuessLanguage lm Nothing (Just "text/x-haskell") + buffer <- case mbLang of + Just sLang -> Gtk.sourceBufferNewWithLanguage sLang + Nothing -> Gtk.sourceBufferNew Nothing + Gtk.sourceBufferSetMaxUndoLevels buffer (-1) + Gtk.sourceBufferBeginNotUndoableAction buffer + Gtk.textBufferSetText buffer contents + Gtk.sourceBufferEndNotUndoableAction buffer + return $ GtkEditorBuffer buffer + +-- Buffer +simpleGtkBuffer :: String -> IDEM EditorBuffer +simpleGtkBuffer contents = liftIO $ do + buffer <- Gtk.sourceBufferNew Nothing + Gtk.textBufferSetText buffer contents + return $ GtkEditorBuffer buffer + + +newYiBuffer :: Maybe FilePath -> String -> IDEM EditorBuffer +#ifdef YI +newYiBuffer mbFilename contents = liftYiControl $ do + let (filename, id) = case mbFilename of + Just fn -> (fn, Right fn) + Nothing -> ("Unknown.hs", Left "*leksah*") + buffer <- Yi.newBuffer id contents + Yi.setBufferMode filename buffer + return $ YiEditorBuffer buffer +#else +newYiBuffer = newGtkBuffer +#endif + +applyTagByName :: EditorBuffer + -> String + -> EditorIter + -> EditorIter + -> IDEM () +applyTagByName (GtkEditorBuffer sb) name (GtkEditorIter first) (GtkEditorIter last) = liftIO $ + Gtk.textBufferApplyTagByName sb name first last +#ifdef YI +applyTagByName (YiEditorBuffer fb) name (YiEditorIter first) (YiEditorIter last) = return () -- TODO +applyTagByName _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in createMark" +#endif + +beginNotUndoableAction :: EditorBuffer -> IDEM () +beginNotUndoableAction (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferBeginNotUndoableAction sb +#ifdef YI +beginNotUndoableAction (YiEditorBuffer fb) = return () -- TODO +#endif + +beginUserAction :: EditorBuffer -> IDEM () +beginUserAction (GtkEditorBuffer sb) = liftIO $ Gtk.textBufferBeginUserAction sb +#ifdef YI +beginUserAction (YiEditorBuffer fb) = return () -- TODO +#endif + +canRedo :: EditorBuffer -> IDEM Bool +canRedo (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferGetCanRedo sb +#ifdef YI +canRedo (YiEditorBuffer fb) = return True -- TODO +#endif + +canUndo :: EditorBuffer -> IDEM Bool +canUndo (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferGetCanUndo sb +#ifdef YI +canUndo (YiEditorBuffer fb) = return True -- TODO +#endif + +copyClipboard :: EditorBuffer -> Gtk.Clipboard -> IDEM () +copyClipboard (GtkEditorBuffer sb) clipboard = liftIO $ Gtk.textBufferCopyClipboard sb clipboard +#ifdef YI +copyClipboard (YiEditorBuffer fb) _ = return () -- TODO +#endif + +createMark :: EditorBuffer + -> EditorIter + -> Bool + -> IDEM EditorMark +createMark (GtkEditorBuffer sb) (GtkEditorIter i) leftGravity = liftIO $ + GtkEditorMark <$> Gtk.textBufferCreateMark sb Nothing i leftGravity +#ifdef YI +createMark (YiEditorBuffer b) (YiEditorIter (Yi.Iter _ p)) leftGravity = withYiBuffer b $ + YiEditorMark <$> Yi.newMarkB (Yi.MarkValue p (if leftGravity then Yi.Backward else Yi.Forward)) +createMark _ _ _ = liftIO $ fail "Mismatching TextEditor types in createMark" +#endif + +cutClipboard :: EditorBuffer -> Gtk.Clipboard -> Bool -> IDEM () +cutClipboard (GtkEditorBuffer sb) clipboard defaultEditable = liftIO $ Gtk.textBufferCutClipboard sb clipboard defaultEditable +#ifdef YI +cutClipboard (YiEditorBuffer fb) clipboard defaultEditable = return () -- TODO +#endif + +delete :: EditorBuffer -> EditorIter -> EditorIter -> IDEM () +delete (GtkEditorBuffer sb) (GtkEditorIter first) (GtkEditorIter last) = liftIO $ + Gtk.textBufferDelete sb first last +#ifdef YI +delete (YiEditorBuffer b) (YiEditorIter (Yi.Iter _ first)) (YiEditorIter (Yi.Iter _ last)) = + withYiBuffer b $ Yi.deleteRegionB $ Yi.mkRegion first last +delete _ _ _ = liftIO $ fail "Mismatching TextEditor types in delete" +#endif + +deleteSelection :: EditorBuffer -> Bool -> Bool -> IDEM () +deleteSelection (GtkEditorBuffer sb) interactive defaultEditable = liftIO $ + Gtk.textBufferDeleteSelection sb interactive defaultEditable >> return () +#ifdef YI +deleteSelection (YiEditorBuffer b) interactive defaultEditable = withYiBuffer b $ do + region <- Yi.getRawestSelectRegionB + Yi.deleteRegionB region -- TODO support flags +#endif + +endNotUndoableAction :: EditorBuffer -> IDEM () +endNotUndoableAction (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferEndNotUndoableAction sb +#ifdef YI +endNotUndoableAction (YiEditorBuffer fb) = return () -- TODO +#endif + +endUserAction :: EditorBuffer -> IDEM () +endUserAction (GtkEditorBuffer sb) = liftIO $ Gtk.textBufferEndUserAction sb +#ifdef YI +endUserAction (YiEditorBuffer fb) = return () -- TODO +#endif + +getEndIter :: EditorBuffer -> IDEM EditorIter +getEndIter (GtkEditorBuffer sb) = liftIO $ GtkEditorIter <$> Gtk.textBufferGetEndIter sb +#ifdef YI +getEndIter (YiEditorBuffer b) = iterFromYiBuffer b Yi.sizeB +#endif + +getInsertMark :: EditorBuffer -> IDEM EditorMark +getInsertMark (GtkEditorBuffer sb) = liftIO $ fmap GtkEditorMark $ Gtk.textBufferGetInsert sb +#ifdef YI +getInsertMark (YiEditorBuffer b) = YiEditorMark <$> (withYiBuffer b $ Yi.insMark <$> Yi.askMarks) +#endif + +getIterAtLine :: EditorBuffer -> Int -> IDEM EditorIter +getIterAtLine (GtkEditorBuffer sb) line = liftIO $ GtkEditorIter <$> Gtk.textBufferGetIterAtLine sb line +#ifdef YI +getIterAtLine (YiEditorBuffer b) line = iterFromYiBuffer b $ Yi.pointOfLineColB line 1 +#endif + +getIterAtMark :: EditorBuffer -> EditorMark -> IDEM EditorIter +getIterAtMark (GtkEditorBuffer sb) (GtkEditorMark m) = liftIO $ GtkEditorIter <$> Gtk.textBufferGetIterAtMark sb m +#ifdef YI +getIterAtMark (YiEditorBuffer b) (YiEditorMark m) = iterFromYiBuffer b $ Yi.getMarkPointB m +getIterAtMark _ _ = liftIO $ fail "Mismatching TextEditor types in getIterAtMark" +#endif + +getIterAtOffset :: EditorBuffer -> Int -> IDEM EditorIter +getIterAtOffset (GtkEditorBuffer sb) offset = liftIO $ GtkEditorIter <$> Gtk.textBufferGetIterAtOffset sb offset +#ifdef YI +getIterAtOffset (YiEditorBuffer b) offset = return $ mkYiIter b $ Yi.Point offset +#endif + +getLineCount :: EditorBuffer -> IDEM Int +getLineCount (GtkEditorBuffer sb) = liftIO $ Gtk.textBufferGetLineCount sb +#ifdef YI +getLineCount (YiEditorBuffer b) = return 0 -- TODO +#endif + +getModified :: EditorBuffer -> IDEM Bool +getModified (GtkEditorBuffer sb) = liftIO $ Gtk.textBufferGetModified sb +#ifdef YI +getModified (YiEditorBuffer b) = not <$> (withYiBuffer b $ Yi.gets Yi.isUnchangedBuffer) +#endif + +getSelectionBoundMark :: EditorBuffer -> IDEM EditorMark +getSelectionBoundMark (GtkEditorBuffer sb) = liftIO $ fmap GtkEditorMark $ Gtk.textBufferGetSelectionBound sb +#ifdef YI +getSelectionBoundMark (YiEditorBuffer b) = YiEditorMark . Yi.selMark <$> (withYiBuffer b $ Yi.askMarks) +#endif + +getSelectionBounds :: EditorBuffer -> IDEM (EditorIter, EditorIter) +getSelectionBounds (GtkEditorBuffer sb) = liftIO $ do + (first, last) <- Gtk.textBufferGetSelectionBounds sb + return (GtkEditorIter first, GtkEditorIter last) +#ifdef YI +getSelectionBounds (YiEditorBuffer b) = withYiBuffer b $ do + region <- Yi.getRawestSelectRegionB + return (mkYiIter b (Yi.regionStart region), + mkYiIter b (Yi.regionEnd region)) +#endif + +getSlice :: EditorBuffer + -> EditorIter + -> EditorIter + -> Bool + -> IDEM String +getSlice (GtkEditorBuffer sb) (GtkEditorIter first) (GtkEditorIter last) includeHidenChars = liftIO $ + Gtk.textBufferGetSlice sb first last includeHidenChars +#ifdef YI +getSlice (YiEditorBuffer b) (YiEditorIter first) (YiEditorIter last) includeHidenChars = liftYiControl $ + Yi.getText b first last +getSlice _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in getSlice" +#endif + +getStartIter :: EditorBuffer -> IDEM EditorIter +getStartIter (GtkEditorBuffer sb) = liftIO $ GtkEditorIter <$> Gtk.textBufferGetStartIter sb +#ifdef YI +getStartIter (YiEditorBuffer b) = return $ mkYiIter b $ Yi.Point 0 +#endif + +getTagTable :: EditorBuffer -> IDEM EditorTagTable +getTagTable (GtkEditorBuffer sb) = liftIO $ fmap GtkEditorTagTable $ Gtk.textBufferGetTagTable sb +#ifdef YI +getTagTable (YiEditorBuffer b) = return YiEditorTagTable -- TODO +#endif + +getText :: EditorBuffer + -> EditorIter + -> EditorIter + -> Bool + -> IDEM String +getText (GtkEditorBuffer sb) (GtkEditorIter first) (GtkEditorIter last) includeHidenChars = liftIO $ + Gtk.textBufferGetText sb first last includeHidenChars +#ifdef YI +getText (YiEditorBuffer b) (YiEditorIter first) (YiEditorIter last) includeHidenChars = liftYiControl $ + Yi.getText b first last +getText _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in getText" +#endif + +hasSelection :: EditorBuffer -> IDEM Bool +hasSelection (GtkEditorBuffer sb) = liftIO $ Gtk.textBufferHasSelection sb +#ifdef YI +hasSelection (YiEditorBuffer b) = withYiBuffer b $ do + region <- Yi.getRawestSelectRegionB + return $ not $ Yi.regionIsEmpty region +#endif + +insert :: EditorBuffer -> EditorIter -> String -> IDEM () +insert (GtkEditorBuffer sb) (GtkEditorIter i) text = liftIO $ Gtk.textBufferInsert sb i text +#ifdef YI +insert (YiEditorBuffer b) (YiEditorIter (Yi.Iter _ p)) text = withYiBuffer b $ Yi.insertNAt text p +insert _ _ _ = liftIO $ fail "Mismatching TextEditor types in insert" +#endif + +moveMark :: EditorBuffer -> EditorMark -> EditorIter -> IDEM () +moveMark (GtkEditorBuffer sb) (GtkEditorMark m) (GtkEditorIter i) = liftIO $ Gtk.textBufferMoveMark sb m i +#ifdef YI +moveMark (YiEditorBuffer b) (YiEditorMark m) (YiEditorIter (Yi.Iter _ p)) = withYiBuffer b $ Yi.setMarkPointB m p +moveMark _ _ _ = liftIO $ fail "Mismatching TextEditor types in moveMark" +#endif + +newView :: EditorBuffer -> IDEM EditorView +newView (GtkEditorBuffer sb) = liftIO $ do + sv <- Gtk.sourceViewNewWithBuffer sb + Gtk.sourceViewSetHighlightCurrentLine sv True + Gtk.sourceViewSetInsertSpacesInsteadOfTabs sv True + Gtk.sourceViewSetIndentOnTab sv True + Gtk.sourceViewSetAutoIndent sv True + Gtk.sourceViewSetSmartHomeEnd sv Gtk.SourceSmartHomeEndBefore + sw <- Gtk.scrolledWindowNew Nothing Nothing + Gtk.containerAdd sw sv + return (GtkEditorView sv) +#ifdef YI +newView (YiEditorBuffer b) = liftYiControl $ fmap YiEditorView $ Yi.newView b +#endif + +pasteClipboard :: EditorBuffer + -> Gtk.Clipboard + -> EditorIter + -> Bool + -> IDEM () +pasteClipboard (GtkEditorBuffer sb) clipboard (GtkEditorIter i) defaultEditable = liftIO $ + Gtk.textBufferPasteClipboard sb clipboard i defaultEditable +#ifdef YI +pasteClipboard (YiEditorBuffer b) clipboard (YiEditorIter (Yi.Iter _ p)) defaultEditable = return () -- TODO +pasteClipboard _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in pasteClipboard" +#endif + +placeCursor :: EditorBuffer -> EditorIter -> IDEM () +placeCursor (GtkEditorBuffer sb) (GtkEditorIter i) = liftIO $ Gtk.textBufferPlaceCursor sb i +#ifdef YI +placeCursor (YiEditorBuffer b) (YiEditorIter (Yi.Iter _ p)) = withYiBuffer b $ Yi.moveTo p +placeCursor _ _ = liftIO $ fail "Mismatching TextEditor types in placeCursor" +#endif + +redo :: EditorBuffer -> IDEM () +redo (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferRedo sb +#ifdef YI +redo (YiEditorBuffer b) = withYiBuffer b Yi.redoB +#endif + +removeTagByName :: EditorBuffer + -> String + -> EditorIter + -> EditorIter + -> IDEM () +removeTagByName (GtkEditorBuffer sb) name (GtkEditorIter first) (GtkEditorIter last) = liftIO $ + Gtk.textBufferRemoveTagByName sb name first last +#ifdef YI +removeTagByName (YiEditorBuffer b) name (YiEditorIter (Yi.Iter _ first)) (YiEditorIter (Yi.Iter _ last)) = return () -- TODO +removeTagByName _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in removeTagByName" +#endif + +selectRange :: EditorBuffer -> EditorIter -> EditorIter -> IDEM () +selectRange (GtkEditorBuffer sb) (GtkEditorIter first) (GtkEditorIter last) = liftIO $ + Gtk.textBufferSelectRange sb first last +#ifdef YI +selectRange (YiEditorBuffer b) (YiEditorIter (Yi.Iter _ first)) (YiEditorIter (Yi.Iter _ last)) = withYiBuffer b $ + Yi.setSelectRegionB $ Yi.mkRegion first last +selectRange _ _ _ = liftIO $ fail "Mismatching TextEditor types in selectRange" +#endif + +setModified :: EditorBuffer -> Bool -> IDEM () +setModified (GtkEditorBuffer sb) modified = liftIO $ Gtk.textBufferSetModified sb modified >> return () +#ifdef YI +setModified (YiEditorBuffer b) modified = unless modified $ do + now <- liftIO $ getCurrentTime + withYiBuffer b $ Yi.markSavedB now +#endif + +setStyle :: EditorBuffer -> Maybe String -> IDEM () +setStyle (GtkEditorBuffer sb) mbStyle = liftIO $ do + case mbStyle of + Nothing -> return () + Just str -> do + styleManager <- Gtk.sourceStyleSchemeManagerNew + ids <- Gtk.sourceStyleSchemeManagerGetSchemeIds styleManager + when (elem str ids) $ do + scheme <- Gtk.sourceStyleSchemeManagerGetScheme styleManager str + Gtk.sourceBufferSetStyleScheme sb scheme +#ifdef YI +setStyle (YiEditorBuffer b) mbStyle = return () -- TODO +#endif + +setText :: EditorBuffer -> String -> IDEM () +setText (GtkEditorBuffer sb) text = liftIO $ Gtk.textBufferSetText sb text +#ifdef YI +setText (YiEditorBuffer b) text = liftYiControl $ Yi.setText b text +#endif + +undo :: EditorBuffer -> IDEM () +undo (GtkEditorBuffer sb) = liftIO $ Gtk.sourceBufferUndo sb +#ifdef YI +undo (YiEditorBuffer b) = withYiBuffer b Yi.undoB +#endif + +-- View +bufferToWindowCoords :: EditorView -> (Int, Int) -> IDEM (Int, Int) +bufferToWindowCoords (GtkEditorView sv) point = liftIO $ Gtk.textViewBufferToWindowCoords sv Gtk.TextWindowWidget point +#ifdef YI +bufferToWindowCoords (YiEditorView v) point = return point -- TODO +#endif + +getBuffer :: EditorView -> IDEM EditorBuffer +getBuffer (GtkEditorView sv) = liftIO $ fmap (GtkEditorBuffer . Gtk.castToSourceBuffer) $ sv `Gtk.get` Gtk.textViewBuffer +#ifdef YI +getBuffer (YiEditorView v) = return $ YiEditorBuffer $ Yi.getBuffer v +#endif + +getDrawWindow :: EditorView -> IDEM Gtk.DrawWindow +getDrawWindow (GtkEditorView sv) = liftIO $ Gtk.widgetGetDrawWindow sv +#ifdef YI +getDrawWindow (YiEditorView v) = liftIO $ Gtk.widgetGetDrawWindow (Yi.drawArea v) +#endif + +getIterLocation :: EditorView -> EditorIter -> IDEM Gtk.Rectangle +getIterLocation (GtkEditorView sv) (GtkEditorIter i) = liftIO $ Gtk.textViewGetIterLocation sv i +#ifdef YI +getIterLocation (YiEditorView v) (YiEditorIter i) = return $ Gtk.Rectangle 0 0 0 0 -- TODO +getIterLocation _ _ = liftIO $ fail "Mismatching TextEditor types in getIterLocation" +#endif + +getOverwrite :: EditorView -> IDEM Bool +getOverwrite (GtkEditorView sv) = liftIO $ Gtk.textViewGetOverwrite sv +#ifdef YI +getOverwrite (YiEditorView v) = return False -- TODO +#endif + +getScrolledWindow :: EditorView -> IDEM Gtk.ScrolledWindow +getScrolledWindow (GtkEditorView sv) = liftIO $ fmap (Gtk.castToScrolledWindow . fromJust) $ Gtk.widgetGetParent sv +#ifdef YI +getScrolledWindow (YiEditorView v) = return $ Yi.scrollWin v +#endif + +grabFocus :: EditorView -> IDEM () +grabFocus (GtkEditorView sv) = liftIO $ Gtk.widgetGrabFocus sv +#ifdef YI +grabFocus (YiEditorView Yi.View{Yi.drawArea = da}) = liftIO $ Gtk.widgetGrabFocus da +#endif + +scrollToMark :: EditorView + -> EditorMark + -> Double + -> Maybe (Double, Double) + -> IDEM () +scrollToMark (GtkEditorView sv) (GtkEditorMark m) withMargin mbAlign = liftIO $ Gtk.textViewScrollToMark sv m withMargin mbAlign +#ifdef YI +scrollToMark (YiEditorView v) (YiEditorMark m) withMargin mbAlign = return () -- TODO +scrollToMark _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in scrollToMark" +#endif + +scrollToIter :: EditorView + -> EditorIter + -> Double + -> Maybe (Double, Double) + -> IDEM () +scrollToIter (GtkEditorView sv) (GtkEditorIter i) withMargin mbAlign = liftIO $ Gtk.textViewScrollToIter sv i withMargin mbAlign >> return () +#ifdef YI +scrollToIter (YiEditorView v) (YiEditorIter i) withMargin mbAlign = return () -- TODO +scrollToIter _ _ _ _ = liftIO $ fail "Mismatching TextEditor types in scrollToIter" +#endif + +setFont :: EditorView -> Maybe String -> IDEM () +setFont (GtkEditorView sv) mbFontString = liftIO $ do + fd <- case mbFontString of + Just str -> do + Gtk.fontDescriptionFromString str + Nothing -> do + f <- Gtk.fontDescriptionNew + Gtk.fontDescriptionSetFamily f "Monospace" + return f + Gtk.widgetModifyFont sv (Just fd) +#ifdef YI +setFont (YiEditorView v) mbFontString = liftIO $ do + fd <- case mbFontString of + Just str -> do + Gtk.fontDescriptionFromString str + Nothing -> do + f <- Gtk.fontDescriptionNew + Gtk.fontDescriptionSetFamily f "Monospace" + return f + Gtk.layoutSetFontDescription (Yi.layout v) (Just fd) +#endif + +setIndentWidth :: EditorView -> Int -> IDEM () +setIndentWidth (GtkEditorView sv) width = liftIO $ Gtk.sourceViewSetIndentWidth sv width +#ifdef YI +setIndentWidth (YiEditorView v) width = return () -- TODO +#endif + +setRightMargin :: EditorView -> Maybe Int -> IDEM () +setRightMargin (GtkEditorView sv) mbRightMargin = liftIO $ do + case mbRightMargin of + Just n -> do + Gtk.sourceViewSetShowRightMargin sv True + Gtk.sourceViewSetRightMarginPosition sv (fromIntegral n) + Nothing -> Gtk.sourceViewSetShowRightMargin sv False +#ifdef YI +setRightMargin (YiEditorView v) mbRightMargin = return () -- TODO +#endif + +setShowLineNumbers :: EditorView -> Bool -> IDEM () +setShowLineNumbers (GtkEditorView sv) show = liftIO $ Gtk.sourceViewSetShowLineNumbers sv show +#ifdef YI +setShowLineNumbers (YiEditorView v) show = return () -- TODO +#endif + +setTabWidth :: EditorView -> Int -> IDEM () +setTabWidth (GtkEditorView sv) width = liftIO $ Gtk.sourceViewSetTabWidth sv width +#ifdef YI +setTabWidth (YiEditorView v) width = return () -- TODO +#endif + +-- Iterator +transformGtkIter :: Gtk.TextIter -> (Gtk.TextIter -> IO a) -> IDEM EditorIter +transformGtkIter i f = do + new <- liftIO $ Gtk.textIterCopy i + liftIO $ f new + return $ GtkEditorIter new + +transformGtkIterMaybe :: Gtk.TextIter -> (Gtk.TextIter -> IO Bool) -> IDEM (Maybe EditorIter) +transformGtkIterMaybe i f = do + new <- liftIO $ Gtk.textIterCopy i + found <- liftIO $ f new + return $ if found + then Just $ GtkEditorIter new + else Nothing + +#ifdef YI +withYiIter :: Yi.Iter -> Yi.BufferM a -> IDEM a +withYiIter (Yi.Iter b p) f = withYiBuffer' b $ do + oldPoint <- Yi.pointB + insertMark <- Yi.insMark <$> Yi.askMarks + Yi.setMarkPointB insertMark p -- Using this becauls moveTo forgets the prefered column + result <- f + Yi.setMarkPointB insertMark oldPoint + return result + +transformYiIter' :: Yi.Iter -> Yi.BufferM Yi.Point -> IDEM EditorIter +transformYiIter' i f = mkYiIter' (Yi.iterFBufRef i) <$> withYiIter i f + +transformYiIter :: Yi.Iter -> Yi.BufferM a -> IDEM EditorIter +transformYiIter i f = transformYiIter' i (f >> Yi.pointB) +#endif + +backwardCharC :: EditorIter -> IDEM EditorIter +backwardCharC (GtkEditorIter i) = transformGtkIter i Gtk.textIterBackwardChar +#ifdef YI +backwardCharC (YiEditorIter i) = transformYiIter' i Yi.prevPointB +#endif + +backwardFindCharC :: EditorIter + -> (Char -> Bool) + -> Maybe EditorIter + -> IDEM (Maybe EditorIter) +backwardFindCharC (GtkEditorIter i) pred mbLimit = transformGtkIterMaybe i $ \x -> + Gtk.textIterBackwardFindChar x pred $ + case mbLimit of + Just (GtkEditorIter limit) -> Just limit + Nothing -> Nothing +#ifdef YI + _ -> fail "Mismatching TextEditor types in backwardFindChar" +#endif + +#ifdef YI +backwardFindCharC (YiEditorIter i) pred mbLimit = return Nothing -- TODO +#endif + +backwardWordStartC :: EditorIter -> IDEM (Maybe EditorIter) +backwardWordStartC (GtkEditorIter i) = transformGtkIterMaybe i Gtk.textIterBackwardWordStart +#ifdef YI +backwardWordStartC (YiEditorIter i) = return Nothing -- TODO +#endif + +endsWord :: EditorIter -> IDEM Bool +endsWord (GtkEditorIter i) = liftIO $ Gtk.textIterEndsWord i +#ifdef YI +endsWord (YiEditorIter i) = return False -- TODO +#endif + +forwardCharC :: EditorIter -> IDEM EditorIter +forwardCharC (GtkEditorIter i) = transformGtkIter i Gtk.textIterForwardChar +#ifdef YI +forwardCharC (YiEditorIter i) = transformYiIter' i Yi.nextPointB +#endif + +forwardCharsC :: EditorIter -> Int -> IDEM EditorIter +forwardCharsC (GtkEditorIter i) n = transformGtkIter i $ flip Gtk.textIterForwardChars n +#ifdef YI +forwardCharsC (YiEditorIter i) n = transformYiIter i $ Yi.rightN n +#endif + +forwardFindCharC :: EditorIter + -> (Char -> Bool) + -> Maybe EditorIter + -> IDEM (Maybe EditorIter) +forwardFindCharC (GtkEditorIter i) pred mbLimit = transformGtkIterMaybe i $ \x -> + Gtk.textIterForwardFindChar x pred $ + case mbLimit of + Just (GtkEditorIter limit) -> Just limit + Nothing -> Nothing +#ifdef YI + _ -> fail "Mismatching TextEditor types in forwardFindChar" +#endif + +#ifdef YI +forwardFindCharC (YiEditorIter i) pred mbLimit = return Nothing -- TODO +#endif + +forwardSearch :: EditorIter + -> String + -> [Gtk.TextSearchFlags] + -> Maybe EditorIter + -> IDEM (Maybe (EditorIter, EditorIter)) +forwardSearch (GtkEditorIter i) str flags mbLimit = liftIO $ do + fmap (fmap (\(start, end) -> (GtkEditorIter start, GtkEditorIter end))) $ + Gtk.textIterForwardSearch i str flags $ + case mbLimit of + Just (GtkEditorIter limit) -> Just limit + Nothing -> Nothing +#ifdef YI + _ -> fail "Mismatching TextEditor types in forwardSearch" +#endif + +#ifdef YI +forwardSearch (YiEditorIter i) str pred mbLimit = return Nothing -- TODO +#endif + +forwardToLineEndC :: EditorIter -> IDEM EditorIter +forwardToLineEndC (GtkEditorIter i) = transformGtkIter i Gtk.textIterForwardToLineEnd +#ifdef YI +forwardToLineEndC (YiEditorIter i) = transformYiIter i Yi.moveToEol +#endif + +forwardWordEndC :: EditorIter -> IDEM (Maybe EditorIter) +forwardWordEndC (GtkEditorIter i) = transformGtkIterMaybe i Gtk.textIterForwardWordEnd +#ifdef YI +forwardWordEndC (YiEditorIter i) = return Nothing -- TODO +#endif + +getChar :: EditorIter -> IDEM (Maybe Char) +getChar (GtkEditorIter i) = liftIO $ Gtk.textIterGetChar i +#ifdef YI +getChar (YiEditorIter i) = withYiIter i Yi.readCharB +#endif + +getCharsInLine :: EditorIter -> IDEM Int +getCharsInLine (GtkEditorIter i) = liftIO $ Gtk.textIterGetCharsInLine i +#ifdef YI +getCharsInLine (YiEditorIter i) = withYiIter i $ length <$> Yi.readLnB +#endif + +getLine :: EditorIter -> IDEM Int +getLine (GtkEditorIter i) = liftIO $ Gtk.textIterGetLine i +#ifdef YI +getLine (YiEditorIter i) = withYiIter i Yi.curLn +#endif + +getLineOffset :: EditorIter -> IDEM Int +getLineOffset (GtkEditorIter i) = liftIO $ Gtk.textIterGetLineOffset i +#ifdef YI +getLineOffset (YiEditorIter i) = withYiIter i Yi.curCol +#endif + +getOffset :: EditorIter -> IDEM Int +getOffset (GtkEditorIter i) = liftIO $ Gtk.textIterGetOffset i +#ifdef YI +getOffset (YiEditorIter (Yi.Iter _ (Yi.Point o))) = return o +#endif + +isStart :: EditorIter -> IDEM Bool +isStart (GtkEditorIter i) = liftIO $ Gtk.textIterIsStart i +#ifdef YI +isStart (YiEditorIter i) = withYiIter i Yi.atSof +#endif + +isEnd :: EditorIter -> IDEM Bool +isEnd (GtkEditorIter i) = liftIO $ Gtk.textIterIsEnd i +#ifdef YI +isEnd (YiEditorIter i) = withYiIter i Yi.atEof +#endif + +iterEqual :: EditorIter -> EditorIter -> IDEM Bool +iterEqual (GtkEditorIter i1) (GtkEditorIter i2) = liftIO $ Gtk.textIterEqual i1 i2 +#ifdef YI +iterEqual (YiEditorIter (Yi.Iter _ p1)) (YiEditorIter (Yi.Iter _ p2)) = return $ p1 == p2 +iterEqual _ _ = liftIO $ fail "Mismatching TextEditor types in iterEqual" +#endif + +startsLine :: EditorIter -> IDEM Bool +startsLine (GtkEditorIter i) = liftIO $ Gtk.textIterStartsLine i +#ifdef YI +startsLine (YiEditorIter i) = withYiIter i Yi.atSol +#endif + +atEnd :: EditorIter -> IDEM EditorIter +atEnd (GtkEditorIter i) = liftIO $ GtkEditorIter <$> do + buffer <- Gtk.textIterGetBuffer i + Gtk.textBufferGetEndIter buffer +#ifdef YI +atEnd (YiEditorIter (Yi.Iter b _)) = iterFromYiBuffer' b Yi.sizeB +#endif + +atLine :: EditorIter -> Int -> IDEM EditorIter +atLine (GtkEditorIter i) line = transformGtkIter i $ flip Gtk.textIterSetLine line +#ifdef YI +atLine (YiEditorIter i) line = transformYiIter i $ Yi.gotoLn line +#endif + +atLineOffset :: EditorIter -> Int -> IDEM EditorIter +atLineOffset (GtkEditorIter i) column = transformGtkIter i $ flip Gtk.textIterSetLineOffset column +#ifdef YI +atLineOffset (YiEditorIter i) column = transformYiIter i $ Yi.moveToColB column +#endif + +atOffset :: EditorIter -> Int -> IDEM EditorIter +atOffset (GtkEditorIter i) offset = transformGtkIter i $ flip Gtk.textIterSetOffset offset +#ifdef YI +atOffset (YiEditorIter (Yi.Iter b _)) offset = return $ YiEditorIter $ Yi.Iter b (Yi.Point offset) +#endif + +atStart :: EditorIter -> IDEM EditorIter +atStart (GtkEditorIter i) = liftIO $ GtkEditorIter <$> do + buffer <- Gtk.textIterGetBuffer i + Gtk.textBufferGetEndIter buffer +#ifdef YI +atStart (YiEditorIter (Yi.Iter b _)) = return $ mkYiIter' b $ Yi.Point 0 +#endif + +-- Tag Table +newTag :: EditorTagTable -> String -> IDEM EditorTag +newTag (GtkEditorTagTable tt) name = liftIO $ do + t <- Gtk.textTagNew (Just name) + Gtk.textTagTableAdd tt t + return $ GtkEditorTag t +#ifdef YI +newTag (YiEditorTagTable) name = return YiEditorTag -- TODO +#endif + +lookupTag :: EditorTagTable -> String -> IDEM (Maybe EditorTag) +lookupTag (GtkEditorTagTable tt) name = liftIO $ fmap (fmap GtkEditorTag) $ Gtk.textTagTableLookup tt name +#ifdef YI +lookupTag (YiEditorTagTable) name = return Nothing -- TODO +#endif + +-- Tag +background :: EditorTag -> Gtk.Color -> IDEM () +background (GtkEditorTag t) color = liftIO $ Gtk.set t [Gtk.textTagBackground := colorHexString color] +#ifdef YI +background (YiEditorTag) color = return () -- TODO +#endif + +underline :: EditorTag -> Gtk.Underline -> IDEM () +underline (GtkEditorTag t) value = liftIO $ Gtk.set t [Gtk.textTagUnderline := value] +#ifdef YI +underline (YiEditorTag) value = return () -- TODO +#endif + +-- Events +afterFocusIn :: EditorView -> IDEM () -> IDEM [Connection] +afterFocusIn (GtkEditorView sv) f = do + ideR <- ask + liftIO $ do + id1 <- sv `Gtk.afterFocusIn` \_ -> reflectIDE f ideR >> return False + return [ConnectC id1] +#ifdef YI +afterFocusIn (YiEditorView v) f = do + ideR <- ask + liftIO $ do + id1 <- (Yi.drawArea v) `Gtk.afterFocusIn` \_ -> reflectIDE f ideR >> return False + return [ConnectC id1] +#endif + +afterModifiedChanged :: EditorBuffer -> IDEM () -> IDEM [Connection] +afterModifiedChanged (GtkEditorBuffer sb) f = do + ideR <- ask + liftIO $ do + id1 <- sb `Gtk.afterModifiedChanged` reflectIDE f ideR + return [ConnectC id1] +#ifdef YI +afterModifiedChanged (YiEditorBuffer b) f = return [] -- TODO +#endif + +afterMoveCursor :: EditorView -> IDEM () -> IDEM [Connection] +afterMoveCursor (GtkEditorView sv) f = do + ideR <- ask + GtkEditorBuffer sb <- getBuffer (GtkEditorView sv) + liftIO $ do + id1 <- sv `Gtk.afterMoveCursor` \_ _ _ -> reflectIDE f ideR + sv `Gtk.widgetAddEvents` [Gtk.ButtonReleaseMask] + id2 <- sv `Gtk.onButtonRelease` \_ -> reflectIDE f ideR >> return False + id3 <- sb `Gtk.afterEndUserAction` reflectIDE f ideR + return [ConnectC id1, ConnectC id2, ConnectC id3] +#ifdef YI +afterMoveCursor (YiEditorView v) f = return [] -- TODO +#endif + +afterToggleOverwrite :: EditorView -> IDEM () -> IDEM [Connection] +afterToggleOverwrite (GtkEditorView sv) f = do + ideR <- ask + liftIO $ do + id1 <- sv `Gtk.afterToggleOverwrite` reflectIDE f ideR + return [ConnectC id1] +#ifdef YI +afterToggleOverwrite (YiEditorView v) f = return [] -- TODO +#endif + +onButtonPress :: EditorView + -> (GtkOld.Event -> IDEM Bool) + -> IDEM [Connection] +onButtonPress (GtkEditorView sv) f = do + ideR <- ask + liftIO $ do + id1 <- sv `Gtk.onButtonPress` \event -> reflectIDE (f event) ideR + return [ConnectC id1] +#ifdef YI +onButtonPress (YiEditorView v) f = do + ideR <- ask + liftIO $ do + id1 <- (Yi.drawArea v) `Gtk.onButtonPress` \event -> reflectIDE (f event) ideR + return [ConnectC id1] +#endif + +onCompletion :: EditorView -> IDEM () -> IDEM () -> IDEM [Connection] +onCompletion (GtkEditorView sv) start cancel = do + ideR <- ask + (GtkEditorBuffer sb) <- getBuffer (GtkEditorView sv) + liftIO $ do + id1 <- sb `Gtk.afterBufferInsertText` \iter text -> + if (all (\c -> (isAlphaNum c) || (c == '.') || (c == '_')) text) + then do + hasSel <- Gtk.textBufferHasSelection sb + if not hasSel + then do + (iterC, _) <- Gtk.textBufferGetSelectionBounds sb + atC <- Gtk.textIterEqual iter iterC + when atC $ reflectIDE start ideR + else + reflectIDE cancel ideR + else + reflectIDE cancel ideR + id2 <- sv `Gtk.onMoveCursor` \_ _ _ -> reflectIDE cancel ideR + id3 <- sv `Gtk.onButtonPress` \_ -> reflectIDE cancel ideR >> return False + return [ConnectC id1] +#ifdef YI +onCompletion (YiEditorView v) start cancel = return [] -- TODO +#endif + +onKeyPress :: EditorView + -> (String -> [Gtk.Modifier] -> Gtk.KeyVal -> IDEM Bool) + -> IDEM [Connection] +onKeyPress (GtkEditorView sv) f = do + ideR <- ask + liftIO $ do + id1 <- sv `Gtk.on` Gtk.keyPressEvent $ do + name <- Gtk.eventKeyName + modifier <- Gtk.eventModifier + keyVal <- Gtk.eventKeyVal + liftIO $ reflectIDE (f name modifier keyVal) ideR + return [ConnectC id1] +#ifdef YI +onKeyPress (YiEditorView v) f = do + ideR <- ask + liftIO $ do + id1 <- (Yi.drawArea v) `Gtk.on` Gtk.keyPressEvent $ do + name <- Gtk.eventKeyName + modifier <- Gtk.eventModifier + keyVal <- Gtk.eventKeyVal + liftIO $ reflectIDE (f name modifier keyVal) ideR + return [ConnectC id1] +#endif + +onKeyRelease :: EditorView + -> (String -> [Gtk.Modifier] -> Gtk.KeyVal -> IDEM Bool) + -> IDEM [Connection] +onKeyRelease (GtkEditorView sv) f = do + ideR <- ask + liftIO $ do + id1 <- sv `Gtk.on` Gtk.keyReleaseEvent $ do + name <- Gtk.eventKeyName + modifier <- Gtk.eventModifier + keyVal <- Gtk.eventKeyVal + liftIO $ reflectIDE (f name modifier keyVal) ideR + return [ConnectC id1] +#ifdef YI +onKeyRelease (YiEditorView v) f = do + ideR <- ask + liftIO $ do + id1 <- (Yi.drawArea v) `Gtk.on` Gtk.keyReleaseEvent $ do + name <- Gtk.eventKeyName + modifier <- Gtk.eventModifier + keyVal <- Gtk.eventKeyVal + liftIO $ reflectIDE (f name modifier keyVal) ideR + return [ConnectC id1] +#endif + +onLookupInfo :: EditorView -> IDEM () -> IDEM [Connection] +onLookupInfo (GtkEditorView sv) f = do + ideR <- ask + liftIO $ do + sv `Gtk.widgetAddEvents` [Gtk.ButtonReleaseMask] + id1 <- sv `Gtk.onButtonRelease` \e -> when (controlIsPressed e) (reflectIDE f ideR) >> return False + return [ConnectC id1] +#ifdef YI +onLookupInfo (YiEditorView v) f = do + ideR <- ask + liftIO $ do + (Yi.drawArea v) `Gtk.widgetAddEvents` [Gtk.ButtonReleaseMask] + id1 <- (Yi.drawArea v) `Gtk.onButtonRelease` \e -> when (controlIsPressed e) (reflectIDE f ideR) >> return False + return [ConnectC id1] +#endif + +onPopulatePopup :: EditorView -> (Gtk.Menu -> IDEM ()) -> IDEM [Connection] +onPopulatePopup (GtkEditorView sv) f = do + ideR <- ask + liftIO $ do + id1 <- sv `Gtk.onPopulatePopup` \menu -> reflectIDE (f menu) ideR + return [ConnectC id1] +#ifdef YI +onPopulatePopup (YiEditorView v) f = do + ideR <- ask + liftIO $ do + id1 <- (Yi.drawArea v) `Gtk.onPopupMenu` do + menu <- Gtk.menuNew + reflectIDE (f menu) ideR + Gtk.menuPopup menu Nothing + return [ConnectC id1] +#endif + + + diff --git a/src/IDE/Tool.hs b/src/IDE/Tool.hs deleted file mode 100644 --- a/src/IDE/Tool.hs +++ /dev/null @@ -1,326 +0,0 @@ -{-# OPTIONS_GHC -XRecordWildCards #-} ------------------------------------------------------------------------------ --- --- Module : IDE.Tool --- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken --- License : GPL --- --- Maintainer : --- Stability : provisional --- Portability : --- --- | Support for running external tools. Written mainly for GHCi but with --- | support for others in mind. --- ------------------------------------------------------------------------------ - -module IDE.Tool ( - ToolOutput(..), - toolline, - ToolCommand(..), - ToolState(..), - newToolState, - runTool, - runInteractiveTool, - newGhci, - executeCommand, - executeGhciCommand) -where - -import System.IO -import Control.Concurrent - (takeMVar, - putMVar, - newEmptyMVar, - forkIO, - newChan, - MVar(..), - Chan(..), - writeChan, - getChanContents, - dupChan) -import Control.Monad (when) -import Data.List (stripPrefix) -import Data.Maybe (isJust, catMaybes) -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) -import System.Posix (sigQUIT, sigINT, installHandler) -import System.Posix.Signals (Handler(..)) -#endif -import System.Process - (waitForProcess, ProcessHandle(..), runInteractiveProcess) - -data ToolOutput = ToolInput String | ToolError String | ToolOutput String deriving(Eq, Show) -data ToolCommand = ToolCommand String ([ToolOutput] -> IO ()) -data ToolState = ToolState { - toolProcess :: MVar ProcessHandle, - outputClosed :: MVar Bool, - toolCommands :: Chan ToolCommand, - toolCommandsRead :: Chan ToolCommand, - currentToolCommand :: MVar ToolCommand} - -data RawToolOutput = RawToolOutput ToolOutput - | ToolPrompt - | ToolOutClosed - | ToolErrClosed - | ToolClosed deriving(Eq, Show) - -toolline :: ToolOutput -> String -toolline (ToolInput l) = l -toolline (ToolOutput l) = l -toolline (ToolError l) = l - -runTool :: FilePath -> [String] -> IO ([ToolOutput], ProcessHandle) -runTool executable arguments = do -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - installHandler sigINT Ignore Nothing - installHandler sigQUIT Ignore Nothing -#endif - - (inp,out,err,pid) <- runInteractiveProcess executable arguments Nothing Nothing - output <- getOutputNoPrompt inp out err pid - return (output, pid) - -newToolState :: IO ToolState -newToolState = do - toolProcess <- newEmptyMVar - outputClosed <- newEmptyMVar - toolCommands <- newChan - toolCommandsRead <- dupChan toolCommands - currentToolCommand <- newEmptyMVar - return ToolState{..} - -runInteractiveTool :: ToolState -> (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO () -runInteractiveTool tool getOutput executable arguments = do -#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) - installHandler sigINT Ignore Nothing - installHandler sigQUIT Ignore Nothing -#endif - - (inp,out,err,pid) <- runInteractiveProcess executable arguments Nothing Nothing - putMVar (toolProcess tool) pid - output <- getOutput inp out err pid - -- This is handy to show the processed output - -- forkIO $ forM_ output (putStrLn.show) - forkIO $ do - commands <- getChanContents (toolCommandsRead tool) - processCommand commands inp output - return () - where - processCommand [] _ _ = return () - processCommand ((command@(ToolCommand commandString handler)):remainingCommands) inp allOutput = do - putMVar (currentToolCommand tool) command - hPutStrLn inp commandString - hFlush inp - let (output, remainingOutputWithPrompt) = span (/= ToolPrompt) allOutput - handler $ (map ToolInput (lines commandString)) ++ fromRawOutput output - takeMVar (currentToolCommand tool) - case remainingOutputWithPrompt of - (ToolPrompt:remainingOutput) -> do - processCommand remainingCommands inp remainingOutput - [] -> do - putMVar (outputClosed tool) True - _ -> do - putStrLn "This should never happen in Tool.hs" - -newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ToolState -newInteractiveTool getOutput executable arguments = do - tool <- newToolState - runInteractiveTool tool getOutput executable arguments - return tool - -ghciPrompt :: String -ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX" - -data CommanLineReader = CommanLineReader { - stripInitialPrompt :: String -> Maybe String, - stripFollowingPrompt :: String -> Maybe String, - errorSyncCommand :: Maybe String, - stripExpectedError :: String -> Maybe String - } - -ghciStripInitialPrompt :: String -> Maybe String -ghciStripInitialPrompt output = - case catMaybes [stripPrefix "Prelude" output, stripPrefix "*" output] of - remaining:_ -> - case dropWhile (/= '>') remaining of - '>':' ':next -> Just next - _ -> Nothing - _ -> Nothing - -ghciStripFollowingPrompt :: String -> Maybe String -ghciStripFollowingPrompt = stripPrefix ghciPrompt - -ghciStripExpectedError :: String -> Maybe String -ghciStripExpectedError output = case stripPrefix "\n:1:0" output of - Just rest -> - stripPrefix ": Not in scope: `kM2KWR7LZZbHdXfHUOA5YBBsJVYoC'\n" - (maybe rest id (stripPrefix "-28" rest)) - Nothing -> Nothing - -ghciCommandLineReader = CommanLineReader { - stripInitialPrompt = ghciStripInitialPrompt, - stripFollowingPrompt = ghciStripFollowingPrompt, - errorSyncCommand = Just "kM2KWR7LZZbHdXfHUOA5YBBsJVYoC", - stripExpectedError = ghciStripExpectedError - } - -noInputCommandLineReader = CommanLineReader { - stripInitialPrompt = const Nothing, - stripFollowingPrompt = const Nothing, - errorSyncCommand = Nothing, - stripExpectedError = const Nothing - } ---waitTillEmpty :: Handle -> IO () ---waitTillEmpty handle = do --- ready <- hReady handle --- when ready $ do --- yield --- threadDelay 100 --- yield --- waitTillEmpty handle - -getOutput :: CommanLineReader -> Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput] -getOutput clr inp out err pid = do - chan <- newChan - -- hSetBuffering out NoBuffering - -- hSetBuffering err NoBuffering - foundExpectedError <- newEmptyMVar - -- Use this and the too putStr threads bellow if you want to see the raw output - -- hSetBuffering stdout NoBuffering - forkIO $ do - errors <- hGetContents err - -- forkIO $ putStr errors - readError chan (filter (/= '\r') errors) foundExpectedError - writeChan chan ToolErrClosed - forkIO $ do - output <- hGetContents out - -- forkIO $ putStr output - readOutput chan (filter (/= '\r') output) True foundExpectedError False - writeChan chan ToolOutClosed - forkIO $ do - testClosed <- dupChan chan - output <- getChanContents testClosed - when ((ToolOutClosed `elem` output) && (ToolErrClosed `elem` output)) $ do - waitForProcess pid - writeChan chan ToolClosed - fmap (takeWhile ((/=) ToolClosed)) $ getChanContents chan - where - readError chan errors foundExpectedError = do - case stripExpectedError clr errors of - Just unexpectedErrors -> do - putMVar foundExpectedError True - readError chan unexpectedErrors foundExpectedError - Nothing -> do - let (line, remaining) = break (== '\n') errors - case remaining of - [] -> return () - _:remainingLines -> do - writeChan chan $ RawToolOutput $ ToolError line - readError chan remainingLines foundExpectedError - - readOutput chan output initial foundExpectedError synced = do - let stripPrompt = (if initial then (stripInitialPrompt clr) else (stripFollowingPrompt clr)) - let line = getLine stripPrompt output - let remaining = drop (length line) output - case remaining of - [] -> do - when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line - '\n':remainingLines -> do - writeChan chan $ RawToolOutput $ ToolOutput line - readOutput chan remainingLines initial foundExpectedError synced - _ -> do - when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line - case stripPrompt remaining of - Just afterPrompt -> do - case (initial, synced, errorSyncCommand clr) of - (True, _, _) -> do - readOutput chan afterPrompt False foundExpectedError synced - (False, _, Nothing) -> do - writeChan chan ToolPrompt - readOutput chan afterPrompt False foundExpectedError synced - (False, False, Just syncCmd) -> do - hPutStrLn inp syncCmd - hFlush inp - takeMVar foundExpectedError - readOutput chan afterPrompt False foundExpectedError True - (False, True, Just _) -> do - writeChan chan ToolPrompt - readOutput chan afterPrompt False foundExpectedError False - _ -> return () -- Should never happen - getLine _ [] = [] - getLine _ ('\n':xs) = [] - getLine stripPrompt output@(x:xs) - | isJust (stripPrompt output) = [] - | otherwise = x : (getLine stripPrompt xs) - -fromRawOutput :: [RawToolOutput] -> [ToolOutput] -fromRawOutput [] = [] -fromRawOutput (RawToolOutput output:xs) = output : (fromRawOutput xs) -fromRawOutput (ToolClosed:xs) = [] -fromRawOutput (_:xs) = fromRawOutput xs - -getGhciOutput :: Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput] -getGhciOutput = getOutput ghciCommandLineReader - -getOutputNoPrompt :: Handle -> Handle -> Handle -> ProcessHandle -> IO [ToolOutput] -getOutputNoPrompt inp out err pid = fmap fromRawOutput $ getOutput noInputCommandLineReader inp out err pid - -newGhci :: [String] -> [String] -> ([ToolOutput] -> IO ()) -> IO ToolState -newGhci buildFlags interactiveFlags startupOutputHandler = do - tool <- newToolState - writeChan (toolCommands tool) $ - ToolCommand (":set prompt " ++ ghciPrompt) startupOutputHandler - putStrLn "Working out GHCi options" - forkIO $ do - (output, pid) <- runTool "runhaskell" (["Setup","build","--with-ghc=leksahecho"] ++ buildFlags) - case catMaybes $ map (findMake . toolline) output of - options:_ -> do - let newOptions = filterUnwanted options - putStrLn newOptions - putStrLn "Starting GHCi" - runInteractiveTool tool getGhciOutput "ghci" - (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags) - _ -> do - startupOutputHandler output - putMVar (outputClosed tool) True - return tool - where - findMake [] = Nothing - findMake line@(x:xs) = - case stripPrefix " --make " line of - Nothing -> findMake xs - s -> s - filterUnwanted [] = [] - filterUnwanted line@(x:xs) = - case stripPrefix "-O " line of - Nothing -> x: filterUnwanted xs - Just s -> filterUnwanted s - - -executeCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO () -executeCommand tool command handler = do - writeChan (toolCommands tool) $ ToolCommand command handler - -executeGhciCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO () -executeGhciCommand tool command handler = do - if '\n' `elem` command - then executeCommand tool safeCommand $ \output -> do - handler $ fixInput $ fixOutput output - else executeCommand tool command handler - where - filteredLines = (filter safeLine (lines command)) - promptCount = (length filteredLines)+1 - safeCommand = (unlines ([":{"] ++ filteredLines)) ++ ":}" - safeLine ":{" = False - safeLine ":}" = False - safeLine _ = True - fixOutput ((ToolOutput line):xs) = (ToolOutput (removePrompts line line promptCount)):xs - fixOutput (x:xs) = x:(fixOutput xs) - fixOutput [] = [] - fixInput = filter (\x -> (x /= ToolInput ":{") && (x /= ToolInput ":}")) - removePrompts fullLine line 0 = line - removePrompts fullLine line n = case dropWhile ((/=) '|') line of - '|':' ':xs -> removePrompts fullLine xs (n-1) - _ -> fullLine - - diff --git a/src/IDE/Utils/GUIUtils.hs b/src/IDE/Utils/GUIUtils.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/GUIUtils.hs @@ -0,0 +1,213 @@ +----------------------------------------------------------------------------- +-- +-- Module : IDE.Utils.GUIUtils +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- | +-- +------------------------------------------------------------------------------- +module IDE.Utils.GUIUtils ( + chooseFile +, chooseDir +, chooseSaveFile +, openBrowser + +, getCandyState +, setCandyState +, getForgetSession + +, getBackgroundBuildToggled +, setBackgroundBuildToggled +, getBackgroundLinkToggled +, setBackgroundLinkToggled +, getDebugToggled +, setDebugToggled + +, getRecentFiles +, getRecentWorkspaces +, controlIsPressed + +, stockIdFromType +) where + +import Graphics.UI.Gtk +import System.Process +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(..)) +--import Graphics.UI.Gtk.General.Structs +-- (ResponseId(..)) +import qualified Graphics.UI.Gtk.Gdk.Events as G (Event(..)) +import Graphics.UI.Gtk.Gdk.Enums(Modifier(..)) + + +chooseDir :: Window -> String -> Maybe FilePath -> IO (Maybe FilePath) +chooseDir window prompt mbFolder = do + dialog <- fileChooserDialogNew + (Just $ prompt) + (Just window) + FileChooserActionSelectFolder + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-open" + ,ResponseAccept)] + when (isJust mbFolder) $ fileChooserSetCurrentFolder dialog (fromJust mbFolder) >> return () + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do + fn <- fileChooserGetFilename dialog + widgetDestroy dialog + return fn + ResponseCancel -> do + widgetDestroy dialog + return Nothing + ResponseDeleteEvent -> do + widgetDestroy dialog + return Nothing + _ -> return Nothing + +chooseFile :: Window -> String -> Maybe FilePath -> IO (Maybe FilePath) +chooseFile window prompt mbFolder = do + dialog <- fileChooserDialogNew + (Just $ prompt) + (Just window) + FileChooserActionOpen + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-open" + ,ResponseAccept)] + when (isJust mbFolder) $ fileChooserSetCurrentFolder dialog (fromJust mbFolder) >> return () + widgetShow dialog + response <- dialogRun dialog + case response of + ResponseAccept -> do + fn <- fileChooserGetFilename dialog + widgetDestroy dialog + return fn + ResponseCancel -> do + widgetDestroy dialog + return Nothing + ResponseDeleteEvent -> do + widgetDestroy dialog + return Nothing + _ -> return Nothing + +chooseSaveFile :: Window -> String -> Maybe FilePath -> IO (Maybe FilePath) +chooseSaveFile window prompt mbFolder = do + dialog <- fileChooserDialogNew + (Just $ prompt) + (Just window) + FileChooserActionSave + [("gtk-cancel" + ,ResponseCancel) + ,("gtk-save" + , ResponseAccept)] + when (isJust mbFolder) $ fileChooserSetCurrentFolder dialog (fromJust mbFolder) >> return () + widgetShow dialog + res <- dialogRun dialog + case res of + ResponseAccept -> do + mbFileName <- fileChooserGetFilename dialog + widgetDestroy dialog + return mbFileName + _ -> do + widgetDestroy dialog + return Nothing + +openBrowser :: String -> IDEAction +openBrowser url = do + prefs' <- readIDE prefs + liftIO (catch (do + runProcess (browser prefs') [url] Nothing Nothing Nothing Nothing Nothing + return ()) + (\ _ -> sysMessage Normal ("Can't find browser executable " ++ browser prefs'))) + return () + +-- get widget elements (menu & toolbar) + +getCandyState :: PaneMonad alpha => alpha Bool +getCandyState = do + ui <- getUIAction "ui/menubar/_Configuration/Source Candy" castToToggleAction + liftIO $toggleActionGetActive ui + +setCandyState :: PaneMonad alpha => Bool -> alpha () +setCandyState b = do + ui <- getUIAction "ui/menubar/_Configuration/Source Candy" castToToggleAction + liftIO $toggleActionSetActive ui b + +getForgetSession :: PaneMonad alpha => alpha (Bool) +getForgetSession = do + ui <- getUIAction "ui/menubar/_Configuration/Forget Session" castToToggleAction + liftIO $toggleActionGetActive ui + +getMenuItem :: String -> IDEM MenuItem +getMenuItem path = do + uiManager' <- getUiManager + mbWidget <- liftIO $ uiManagerGetWidget uiManager' path + case mbWidget of + Nothing -> throwIDE ("State.hs>>getMenuItem: Can't find ui path " ++ path) + Just widget -> return (castToMenuItem widget) + +getBackgroundBuildToggled :: PaneMonad alpha => alpha (Bool) +getBackgroundBuildToggled = do + ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundBuild" castToToggleAction + liftIO $ toggleActionGetActive ui + +setBackgroundBuildToggled :: PaneMonad alpha => Bool -> alpha () +setBackgroundBuildToggled b = do + ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundBuild" castToToggleAction + liftIO $ toggleActionSetActive ui b + +getBackgroundLinkToggled :: PaneMonad alpha => alpha (Bool) +getBackgroundLinkToggled = do + ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundLink" castToToggleAction + liftIO $ toggleActionGetActive ui + +setBackgroundLinkToggled :: PaneMonad alpha => Bool -> alpha () +setBackgroundLinkToggled b = do + ui <- getUIAction "ui/toolbar/BuildToolItems/BackgroundLink" castToToggleAction + liftIO $ toggleActionSetActive ui b + +getDebugToggled :: PaneMonad alpha => alpha (Bool) +getDebugToggled = do + ui <- getUIAction "ui/toolbar/BuildToolItems/Debug" castToToggleAction + liftIO $ toggleActionGetActive ui + +setDebugToggled :: PaneMonad alpha => Bool -> alpha () +setDebugToggled b = do + ui <- getUIAction "ui/toolbar/BuildToolItems/Debug" castToToggleAction + liftIO $ toggleActionSetActive ui b + +getRecentFiles , getRecentWorkspaces :: IDEM MenuItem +getRecentFiles = getMenuItem "ui/menubar/_File/_Recent Files" +getRecentWorkspaces = getMenuItem "ui/menubar/_Workspace/_Recent Workspaces" + +-- (toolbar) + +controlIsPressed :: G.Event -> Bool +controlIsPressed (G.Button _ _ _ _ _ mods _ _ _) | Control `elem` mods = True +controlIsPressed _ = False + +stockIdFromType :: DescrType -> StockId +stockIdFromType Variable = "ide_function" +stockIdFromType Newtype = "ide_newtype" +stockIdFromType Type = "ide_type" +stockIdFromType Data = "ide_data" +stockIdFromType Class = "ide_class" +stockIdFromType Instance = "ide_instance" +stockIdFromType Constructor = "ide_konstructor" +stockIdFromType Field = "ide_slot" +stockIdFromType Method = "ide_method" +stockIdFromType _ = "ide_other" + + + diff --git a/src/IDE/Utils/ServerConnection.hs b/src/IDE/Utils/ServerConnection.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/ServerConnection.hs @@ -0,0 +1,88 @@ +{-# OPTIONS_GHC -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Utils.ServerConnection +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : +-- +-- | Server functionality +-- +----------------------------------------------------------------------------- + +module IDE.Utils.ServerConnection ( + doServerCommand, +) where + +import IDE.Core.State +import Network (connectTo,PortID(..)) +import Network.Socket (PortNumber(..)) +import System.Process(runCommand) +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) + + +doServerCommand :: ServerCommand -> (ServerAnswer -> IDEM alpha) -> IDEAction +doServerCommand command cont = do + server' <- readIDE server + case server' of + Just handle -> do + isOpen <- liftIO $ hIsOpen handle + if isOpen + then doCommand handle >> return () + else do + modifyIDE_ (\ ide -> ide{server = Nothing}) + doServerCommand command cont + Nothing -> do + prefs' <- readIDE prefs + handle <- reifyIDE $ \ideR -> do + catch (connectTo (serverIP prefs') (PortNumber(PortNum (fromIntegral $ serverPort prefs')))) + (\(exc :: SomeException) -> do + catch (startServer (serverPort prefs')) + (\(exc :: SomeException) -> throwIDE ("Can't start leksah-server" ++ show exc)) + mbHandle <- waitForServer prefs' 100 + case mbHandle of + Just handle -> return handle + Nothing -> throwIDE ("Can't connect to leksah-server")) + modifyIDE_ (\ ide -> ide{server = Just handle}) + doCommand handle + return () + where + doCommand handle = do + triggerEventIDE (StatusbarChanged [CompartmentCollect True]) + reifyIDE $ \ideR -> forkIO $ do + hPutStrLn handle (show command) + hFlush handle + resp <- hGetLine handle + postGUIAsync (reflectIDE (do + triggerEvent ideR (StatusbarChanged [CompartmentCollect False]) + cont (read resp) + return ()) ideR) + +startServer :: Int -> IO () +startServer port = do + runCommand ("leksah-server --server=" ++ show port ++ " +RTS -N2 -RTS") + return () + +-- | s is in tenth's of seconds +waitForServer :: Prefs -> Int -> IO (Maybe Handle) +waitForServer _ 0 = return Nothing +waitForServer prefs s = do + threadDelay 100000 -- 0.1 second + catch (do + handle <- liftIO $ connectTo (serverIP prefs) (PortNumber(PortNum (fromIntegral $ serverPort prefs))) + return (Just handle)) + (\(exc :: SomeException) -> waitForServer prefs (s-1)) + + + + diff --git a/src/IDE/Workspaces.hs b/src/IDE/Workspaces.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Workspaces.hs @@ -0,0 +1,468 @@ +{-# OPTIONS_GHC -XScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Workspace +-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GPL +-- +-- Maintainer : maintainer@leksah.org +-- Stability : provisional +-- Portability : +-- +-- | Represents a workspace, a work unit, which can be composed of multiple packages +-- +----------------------------------------------------------------------------- + +module IDE.Workspaces ( + workspaceNew +, workspaceOpen +, workspaceOpenThis +, workspaceClose +, workspaceClean +, workspaceMake +, workspaceActivatePackage +, workspaceAddPackage +, workspaceAddPackage' +, workspaceRemovePackage + +, makePackage +, backgroundMake +) where + +import IDE.Core.State +import Control.Monad.Trans (liftIO) +import Graphics.UI.Editor.Parameters + (Parameter(..), (<<<-), paraName, emptyParams) +import Control.Monad (unless, when) +import Data.Maybe (isJust,fromJust ) +import IDE.Utils.GUIUtils + (chooseFile, chooseSaveFile) +import System.FilePath + ((), isAbsolute, dropFileName, makeRelative, dropExtension, + takeBaseName, addExtension, takeExtension) +import Text.PrinterParser + (readFields, + writeFields, + readParser, + stringParser, + intParser, + mkFieldS, + FieldDescriptionS(..)) +import qualified Text.PrettyPrint as PP (text) +import Graphics.UI.Gtk + (widgetDestroy, dialogRun, messageDialogNew, Window(..)) +import IDE.Pane.PackageEditor (choosePackageFile) +import Data.List ((\\), foldl', nub, delete) +import IDE.Package + (buildPackage, + packageInstall', + packageClean, + activatePackage, + deactivatePackage, + idePackageFromPath) +import System.Directory (doesFileExist, canonicalizePath) +import System.Time (getClockTime) +import Graphics.UI.Gtk.Windows.MessageDialog + (ButtonsType(..), MessageType(..)) +import Graphics.UI.Gtk.General.Structs (ResponseId(..)) +import Control.Exception (SomeException(..)) +import Control.Monad.Reader.Class (ask) +import Data.Map (Map(..)) +import qualified Data.Map as Map + (lookup, empty, mapWithKey, fromList, map) +import Distribution.Package (pkgVersion, pkgName, Dependency(..)) +import Distribution.Version (withinRange) +import qualified GHC.List as List (or) +import IDE.Pane.SourceBuffer (belongsToPackage, fileCheckAll) + + +setWorkspace :: Maybe Workspace -> IDEAction +setWorkspace mbWs = do + let mbRealWs = case mbWs of + Nothing -> Nothing + Just ws -> Just ws{wsReverseDeps = calculateReverseDependencies ws} + mbOldWs <- readIDE workspace +-- trace ("deps " ++ case mbRealWs of +-- Nothing -> "empty ws" +-- Just ws -> show $ map (\ (k,v) -> (packageId k, map packageId v)) +-- (Map.toList (wsReverseDeps ws))) + modifyIDE_ (\ide -> ide{workspace = mbRealWs}) + let pack = case mbRealWs of + Nothing -> Nothing + Just ws -> wsActivePack ws + let oldPack = case mbOldWs of + Nothing -> Nothing + Just ws -> wsActivePack ws + when (pack /= oldPack) $ + case pack of + Nothing -> deactivatePackage + Just p -> activatePackage pack >> return () + mbPack <- readIDE activePack + triggerEventIDE WorkspaceChanged + let wsStr = case mbRealWs of + Nothing -> "" + Just ws -> wsName ws + let txt = wsStr ++ " > " ++ + (case mbPack of + Nothing -> "" + Just p -> packageIdentifierToString (ipdPackageId p)) + triggerEventIDE (StatusbarChanged [CompartmentPackage txt]) + return () + + +-- --------------------------------------------------------------------- +-- This needs to be incremented, when the workspace format changes +-- +workspaceVersion :: Int +workspaceVersion = 1 + +-- | Constructs a new workspace and makes it the current workspace +workspaceNew :: IDEAction +workspaceNew = do + window <- getMainWindow + mbFile <- liftIO $ do + chooseSaveFile window "New file for wokspace" Nothing + case mbFile of + Nothing -> return () + Just filePath -> + let realPath = if takeExtension filePath == leksahWorkspaceFileExtension + then filePath + else addExtension filePath leksahWorkspaceFileExtension + in do + cPath <- liftIO $ canonicalizePath realPath + let newWorkspace = emptyWorkspace { + wsName = takeBaseName cPath, + wsFile = cPath} + liftIO $ writeFields cPath newWorkspace workspaceDescr + workspaceOpenThis False (Just cPath) + return () + +workspaceOpen :: IDEAction +workspaceOpen = do + window <- getMainWindow + mbFilePath <- liftIO $ chooseWorkspaceFile window + workspaceOpenThis True mbFilePath + +chooseWorkspaceFile :: Window -> IO (Maybe FilePath) +chooseWorkspaceFile window = chooseFile window "Select leksah workspace file (.lkshw)" Nothing + +workspaceOpenThis :: Bool -> Maybe FilePath -> IDEAction +workspaceOpenThis askForSession mbFilePath = + case mbFilePath of + Nothing -> return () + Just filePath -> do + let spath = dropExtension filePath ++ leksahSessionFileExtension + workspaceClose + exists <- liftIO $ doesFileExist spath + wantToLoadSession <- + if exists && askForSession + then liftIO $ do + md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo + $ "Load the session settings stored with this workspace?" + rid <- dialogRun md + widgetDestroy md + case rid of + ResponseYes -> return True + otherwise -> return False + else return False + if wantToLoadSession + then triggerEventIDE (LoadSession spath) >> return () + else do + ideR <- ask + catchIDE (do + workspace <- readWorkspace filePath + setWorkspace (Just workspace {wsFile = filePath, + wsReverseDeps = calculateReverseDependencies workspace})) + (\ (e :: SomeException) -> reflectIDE + (ideMessage Normal ("Can't load workspace file " ++ filePath ++ "\n" ++ show e)) ideR) + + +-- | Closes a workspace +workspaceClose :: IDEAction +workspaceClose = do + oldWorkspace <- readIDE workspace + case oldWorkspace of + Nothing -> return () + Just ws -> do + let oldActivePack = wsActivePack ws + triggerEventIDE (SaveSession ((dropExtension (wsFile ws)) + ++ leksahSessionFileExtension)) + addRecentlyUsedWorkspace (wsFile ws) + setWorkspace Nothing + triggerEventIDE (ActivePack Nothing) + when (isJust oldActivePack) $ do + triggerEventIDE (Sensitivity [(SensitivityProjectActive, False), + (SensitivityWorkspaceOpen, False)]) + return () + return () + return () + + +workspaceAddPackage :: IDEAction +workspaceAddPackage = do + window <- getMainWindow + mbFilePath <- liftIO $ choosePackageFile window + case mbFilePath of + Nothing -> return () + Just fp -> workspaceAddPackage' fp + +workspaceAddPackage' :: FilePath -> IDEAction +workspaceAddPackage' fp = do + mbWs <- readIDE workspace + cfp <- liftIO $ canonicalizePath fp + case mbWs of + Nothing -> return () + Just ws -> do + mbPack <- idePackageFromPath cfp + case mbPack of + Just pack -> do + unless (elem cfp (map ipdCabalFile (wsPackages ws))) $ + writeWorkspace $ ws {wsPackages = pack : wsPackages ws} + return () + Nothing -> return () + + +workspaceRemovePackage :: IDEPackage -> IDEAction +workspaceRemovePackage pack = do + mbWs <- readIDE workspace + case mbWs of + Nothing -> return () + Just ws -> do + when (elem pack (wsPackages ws)) $ + writeWorkspace ws {wsPackages = delete pack (wsPackages ws)} + return () + +workspaceActivatePackage :: IDEPackage -> IDEAction +workspaceActivatePackage pack = do + mbWs <- readIDE workspace + case mbWs of + Nothing -> return () + Just ws -> do + when (elem pack (wsPackages ws)) $ do + writeWorkspace ws {wsActivePack = Just pack} + return () + return () + +writeWorkspace :: Workspace -> IDEAction +writeWorkspace ws = do + timeNow <- liftIO getClockTime + let newWs = ws {wsSaveTime = show timeNow, + wsVersion = workspaceVersion, + wsActivePackFile = case wsActivePack ws of + Nothing -> Nothing + Just pack -> Just (ipdCabalFile pack), + wsPackagesFiles = map ipdCabalFile (wsPackages ws)} + setWorkspace $ Just newWs + newWs' <- liftIO $ makePathesRelative newWs + liftIO $ writeFields (wsFile newWs') (newWs' {wsFile = ""}) workspaceDescr + +readWorkspace :: FilePath -> IDEM Workspace +readWorkspace fp = do + ws <- liftIO $ readFields fp workspaceDescr emptyWorkspace + ws' <- liftIO $ makePathesAbsolute ws fp + activePack <- case wsActivePackFile ws' of + Nothing -> return Nothing + Just fp -> idePackageFromPath fp + packages <- mapM idePackageFromPath (wsPackagesFiles ws') + return ws'{ wsActivePack = activePack, wsPackages = map fromJust $ filter isJust $ packages} + +makePathesRelative :: Workspace -> IO Workspace +makePathesRelative ws = do + wsFile' <- canonicalizePath (wsFile ws) + wsActivePackFile' <- case wsActivePackFile ws of + Nothing -> return Nothing + Just fp -> do + nfp <- canonicalizePath fp + return (Just (makeRelative (dropFileName wsFile') nfp)) + wsPackagesFiles' <- mapM canonicalizePath (wsPackagesFiles ws) + let relativePathes = map (\p -> makeRelative (dropFileName wsFile') p) wsPackagesFiles' + return ws {wsActivePackFile = wsActivePackFile', wsFile = wsFile', wsPackagesFiles = relativePathes} + +makePathesAbsolute :: Workspace -> FilePath -> IO Workspace +makePathesAbsolute ws bp = do + wsFile' <- canonicalizePath bp + wsActivePackFile' <- case wsActivePackFile ws of + Nothing -> return Nothing + Just fp -> do + fp' <- makeAbsolute (dropFileName wsFile') fp + return (Just fp') + wsPackagesFiles' <- mapM (makeAbsolute (dropFileName wsFile')) (wsPackagesFiles ws) + return ws {wsActivePackFile = wsActivePackFile', wsFile = wsFile', wsPackagesFiles = wsPackagesFiles'} + where + makeAbsolute basePath relativePath = + if isAbsolute relativePath + then canonicalizePath relativePath + else canonicalizePath (basePath relativePath) + +emptyWorkspace = Workspace { + wsVersion = workspaceVersion +, wsSaveTime = "" +, wsName = "" +, wsFile = "" +, wsPackages = [] +, wsActivePack = Nothing +, wsPackagesFiles = [] +, wsActivePackFile = Nothing +, wsReverseDeps = Map.empty +} + +workspaceDescr :: [FieldDescriptionS Workspace] +workspaceDescr = [ + mkFieldS + (paraName <<<- ParaName "Version of workspace file format" $ emptyParams) + (PP.text . show) + intParser + wsVersion + (\ b a -> a{wsVersion = b}) + , mkFieldS + (paraName <<<- ParaName "Time of storage" $ emptyParams) + (PP.text . show) + stringParser + wsSaveTime + (\ b a -> a{wsSaveTime = b}) + , mkFieldS + (paraName <<<- ParaName "Name of the workspace" $ emptyParams) + (PP.text . show) + stringParser + wsName + (\ b a -> a{wsName = b}) + , mkFieldS + (paraName <<<- ParaName "File paths of contained packages" $ emptyParams) + (PP.text . show) + readParser + wsPackagesFiles + (\b a -> a{wsPackagesFiles = b}) + , mkFieldS + (paraName <<<- ParaName "Maybe file path of an active package" $ emptyParams) + (PP.text . show) + readParser + wsActivePackFile + (\fp a -> a{wsActivePackFile = fp})] + + +addRecentlyUsedWorkspace :: FilePath -> IDEAction +addRecentlyUsedWorkspace fp = do + state <- readIDE currentState + when (not $ isStartingOrClosing state) $ do + recentWorkspaces' <- readIDE recentWorkspaces + unless (elem fp recentWorkspaces') $ + modifyIDE_ (\ide -> ide{recentWorkspaces = take 12 (fp : recentWorkspaces')}) + triggerEventIDE UpdateRecent + return () + +removeRecentlyUsedWorkspace :: FilePath -> IDEAction +removeRecentlyUsedWorkspace fp = do + state <- readIDE currentState + when (not $ isStartingOrClosing state) $ do + recentWorkspaces' <- readIDE recentWorkspaces + when (elem fp recentWorkspaces') $ + modifyIDE_ (\ide -> ide{recentWorkspaces = filter (\e -> e /= fp) recentWorkspaces'}) + triggerEventIDE UpdateRecent + return () + +------------------------ +-- Workspace make + +-- | Calculates for every package a list of packages, that depends directly on it +-- This is the reverse info from cabal, were we specify what a package depends on +calculateReverseDependencies :: Workspace -> Map IDEPackage [IDEPackage] +calculateReverseDependencies ws = Map.map nub $ foldl' calc mpacks packages + where + packages = wsPackages ws + mpacks = Map.fromList (map (\p -> (p,[])) packages) + + calc :: Map IDEPackage [IDEPackage] -> IDEPackage -> Map IDEPackage [IDEPackage] + calc theMap pack = Map.mapWithKey (addDeps (ipdDepends pack) pack ) theMap + + addDeps :: [Dependency] -> IDEPackage -> IDEPackage -> [IDEPackage] -> [IDEPackage] + addDeps dependencies pack pack2 revDeps = if depsMatch then pack : revDeps else revDeps + where + depsMatch = List.or (map (matchOne pack2) dependencies) + matchOne thePack (Dependency name versionRange) = + name == pkgName (ipdPackageId thePack) + && withinRange (pkgVersion (ipdPackageId thePack)) versionRange + + +-- | Select a package which is not direct or indirect dependent on any other package +selectFirstReasonableTarget :: [IDEPackage] -> Map IDEPackage [IDEPackage] -> IDEPackage +selectFirstReasonableTarget [] _ = error "Workspaces>>selectFirstReasonableTarget: empty package list" +selectFirstReasonableTarget [p] _ = p +selectFirstReasonableTarget l revDeps = + case foldl' removeDeps l l of + hd:_ -> hd + [] -> error "Workspaces>>selectFirstReasonableTarget: no remaining" + where + removeDeps :: [IDEPackage] -> IDEPackage -> [IDEPackage] + removeDeps packs p = packs \\ allDeps p + + allDeps :: IDEPackage -> [IDEPackage] + allDeps p = case Map.lookup p revDeps of + Nothing -> [] + Just list -> list ++ concatMap allDeps list + +makePackages :: Bool -> [IDEPackage] -> IDEAction +makePackages _ [] = return () +makePackages isBackgroundBuild packages = do + mbWs <- readIDE workspace + prefs' <- readIDE prefs + case mbWs of + Nothing -> return () + Just ws -> do + let package = selectFirstReasonableTarget packages (wsReverseDeps ws) + buildPackage isBackgroundBuild package (cont prefs' package ws) + where + cont prefs' package ws res = + if res + then do + let deps = case Map.lookup package (wsReverseDeps ws) of + Nothing -> [] + Just list -> list + -- install if either + -- AlwaysInstall is set or + -- deps are not empty and + when ((not (null deps) && autoInstall prefs' == InstallLibs) + || autoInstall prefs' == InstallAlways) + $ packageInstall' package (cont2 deps package) + else return () -- don't continue, when their was an error + cont2 deps package res = do + when res $ do + let nextTargets = delete package $ nub $ packages ++ deps + makePackages isBackgroundBuild nextTargets + + +backgroundMake :: IDEAction +backgroundMake = catchIDE (do + ideR <- ask + prefs <- readIDE prefs + mbPackage <- readIDE activePack + case mbPackage of + Nothing -> return () + Just package -> do + modifiedPacks <- if saveAllBeforeBuild prefs + then fileCheckAll belongsToPackage + else return [] + let isModified = not (null modifiedPacks) + when isModified $ do + makePackages True modifiedPacks + ) + (\(e :: SomeException) -> sysMessage Normal (show e)) + +makePackage :: IDEAction +makePackage = do + activePack' <- readIDE activePack + case activePack' of + Nothing -> return () + Just p -> makePackages False [p] + +workspaceClean = do + mbWs <- readIDE workspace + case mbWs of + Nothing -> return () + Just ws -> mapM_ (packageClean . Just) (wsPackages ws) + +workspaceMake = do + mbWs <- readIDE workspace + case mbWs of + Nothing -> return () + Just ws -> makePackages False (wsPackages ws) + diff --git a/src/LeksahEcho.hs b/src/LeksahEcho.hs deleted file mode 100644 --- a/src/LeksahEcho.hs +++ /dev/null @@ -1,24 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Main --- Copyright : 2007-2009 Jürgen Nicklisch-Franken, Hamish Mackenzie --- License : GPL --- --- Maintainer : maintainer@leksah.org --- Stability : provisional --- Portability : --- --- | Windows systems do not often have a real echo executable (so --with-ghc=echo fails) --- ------------------------------------------------------------------------------ - -module Main ( -main -) where - -import System.Environment - -main = do - args <- getArgs - putStrLn $ unwords args - diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,22 +0,0 @@ ------------------------------------------------------------------------------ --- --- Module : Main --- Copyright : 2007-2009 Jürgen Nicklisch-Franken --- License : GPL --- --- Maintainer : Jutaro --- Stability : provisional --- Portability : --- --- | --- ------------------------------------------------------------------------------ - -module Main ( -main -) where - -import IDE.Leksah (runMain) - -main = runMain - diff --git a/src/MyMissing.hs b/src/MyMissing.hs deleted file mode 100644 --- a/src/MyMissing.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# OPTIONS_GHC -XScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Module : MyMissing --- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie --- License : GNU-GPL --- --- Maintainer : Juergen Nicklisch-Franken --- Stability : provisional --- Portability : portable --- --- | Module for missing base functions --- ------------------------------------------------------------------------------- - -module MyMissing ( - allOf -, forceJust -, forceHead -, split -, replace -, nonEmptyLines -) where - -import Data.List (find,unfoldr) -import Data.Maybe (isJust) -import Data.Char (isSpace) - --- --------------------------------------------------------------------- --- | A class for pretty printing --- - -nonEmptyLines :: String -> [String] -nonEmptyLines = filter (\line -> isJust $ find (not . isSpace) line) . lines - - -allOf :: forall alpha. (Bounded alpha, Enum alpha) => [alpha] -allOf = map toEnum [fromEnum (minBound :: alpha) .. fromEnum (maxBound :: alpha)] - --- --------------------------------------------------------------------- --- Convenience methods with error handling --- -forceJust :: Maybe alpha -> String -> alpha -forceJust mb str = case mb of - Nothing -> error str - Just it -> it - --- --------------------------------------------------------------------- --- Convenience methods with error handling --- -forceHead :: [alpha] -> String -> alpha -forceHead (h:_) str = h -forceHead [] str = error str - - --- --------------------------------------------------------------------- --- Splitting a string into parts based on a token delimiter --- - -split :: Eq a => a -> [a] -> [[a]] -split = unfoldr . split' - -split' :: Eq a => a -> [a] -> Maybe ([a], [a]) -split' c l - | null l = Nothing - | otherwise = Just (h, drop 1 t) - where (h, t) = span (/=c) l - --- --------------------------------------------------------------------- --- Simple replacement --- - -replace :: Eq a => [a] -> [a] -> [a] -> [a] -replace _ _ [] = [] -replace from to xs@(a:as) = - if isPrefixOf from xs - then to ++ replace from to (drop (length from) xs) - else a : replace from to as - where isPrefixOf as bs = and $ zipWith (== ) as bs