leksah 0.6.1 → 0.8
raw patch · 139 files changed
+8843/−14049 lines, 139 filesdep +binary-shareddep +deepseqdep +hsloggerdep −ghcdep −regex-compatdep −regex-posixdep ~binarydep ~regex-basebinary-added
Dependencies added: binary-shared, deepseq, hslogger, leksah-server, ltk, network, regex-tdfa, time, yi
Dependencies removed: ghc, regex-compat, regex-posix
Dependency ranges changed: binary, regex-base
Files
- data/Current.session +0/−15
- data/Default.candy +0/−36
- data/Default.keymap +0/−109
- data/Default.menu +0/−196
- data/Default.prefs +0/−59
- data/Emacs.keymap +0/−66
- data/Module.template +0/−21
- data/candy.lkshc +36/−0
- data/current.lkshs +16/−0
- data/emacs.lkshk +66/−0
- data/ide_build.png binary
- data/ide_class.png binary
- data/ide_clean.png binary
- data/ide_configure.png binary
- data/ide_continue.png binary
- data/ide_data.png binary
- data/ide_debug.png binary
- data/ide_error_next.png binary
- data/ide_error_prev.png binary
- data/ide_function.png binary
- data/ide_instance.png binary
- data/ide_konstructor.png binary
- data/ide_link.png binary
- data/ide_local.png binary
- data/ide_make.png binary
- data/ide_method.png binary
- data/ide_module.png binary
- data/ide_newtype.png binary
- data/ide_other.png binary
- data/ide_rebuild_meta.png binary
- data/ide_reexported.png binary
- data/ide_rule.png binary
- data/ide_run.png binary
- data/ide_slot.png binary
- data/ide_source.png binary
- data/ide_step.png binary
- data/ide_type.png binary
- data/keymap.lkshk +112/−0
- data/leksah.menu +207/−0
- data/leksah.png binary
- data/module.lksht +21/−0
- data/prefs.lkshp +78/−0
- data/prefscoll.lkshp +8/−0
- data/welcome.txt +49/−10
- leksah.cabal +80/−74
- pics/ide_build.png binary
- pics/ide_class.png binary
- pics/ide_clean.png binary
- pics/ide_configure.png binary
- pics/ide_continue.png binary
- pics/ide_data.png binary
- pics/ide_debug.png binary
- pics/ide_empty.png binary
- pics/ide_error_next.png binary
- pics/ide_error_prev.png binary
- pics/ide_function.png binary
- pics/ide_instance.png binary
- pics/ide_konstructor.png binary
- pics/ide_link.png binary
- pics/ide_local.png binary
- pics/ide_make.png binary
- pics/ide_method.png binary
- pics/ide_module.png binary
- pics/ide_newtype.png binary
- pics/ide_other.png binary
- pics/ide_rebuild_meta.png binary
- pics/ide_reexported.png binary
- pics/ide_rule.png binary
- pics/ide_run.png binary
- pics/ide_slot.png binary
- pics/ide_source.png binary
- pics/ide_source_local.png binary
- pics/ide_step.png binary
- pics/ide_type.png binary
- pics/leksah.png binary
- src/Control/Event.hs +0/−86
- src/Data/Binary/Shared.hs +0/−162
- src/DeepSeq.hs +0/−74
- src/Default.hs +0/−45
- src/Graphics/UI/Editor/Basics.hs +0/−286
- src/Graphics/UI/Editor/Composite.hs +0/−790
- src/Graphics/UI/Editor/MakeEditor.hs +0/−252
- src/Graphics/UI/Editor/Parameters.hs +0/−178
- src/Graphics/UI/Editor/Simple.hs +0/−689
- src/Graphics/UI/Frame/Panes.hs +0/−161
- src/Graphics/UI/Frame/ViewFrame.hs +0/−1360
- src/IDE/Command.hs +814/−0
- src/IDE/Completion.hs +227/−176
- src/IDE/Core/State.hs +175/−357
- src/IDE/Core/Types.hs +290/−279
- src/IDE/Debug.hs +51/−37
- src/IDE/DescriptionPP.hs +0/−96
- src/IDE/Exception.hs +0/−95
- src/IDE/FileUtils.hs +0/−321
- src/IDE/Find.hs +102/−96
- src/IDE/GUIHistory.hs +0/−1
- src/IDE/Group/Debugger.hs +0/−102
- src/IDE/ImportTool.hs +196/−244
- src/IDE/Keymap.hs +1/−3
- src/IDE/Leksah.hs +158/−141
- src/IDE/LogRef.hs +62/−54
- src/IDE/Menu.hs +0/−833
- src/IDE/Metainfo/GHCUtils.hs +0/−182
- src/IDE/Metainfo/InterfaceCollector.hs +0/−443
- src/IDE/Metainfo/Provider.hs +827/−538
- src/IDE/Metainfo/Serializable.hs +0/−212
- src/IDE/Metainfo/SourceCollector.hs +0/−517
- src/IDE/NotebookFlipper.hs +1/−3
- src/IDE/Package.hs +245/−295
- src/IDE/Pane/Breakpoints.hs +40/−94
- src/IDE/Pane/ClassHierarchy.hs +0/−900
- src/IDE/Pane/Errors.hs +16/−61
- src/IDE/Pane/Grep.hs +62/−89
- src/IDE/Pane/Info.hs +100/−139
- src/IDE/Pane/Log.hs +97/−91
- src/IDE/Pane/Modules.hs +447/−392
- src/IDE/Pane/PackageEditor.hs +46/−80
- src/IDE/Pane/PackageFlags.hs +115/−129
- src/IDE/Pane/Preferences.hs +236/−182
- src/IDE/Pane/References.hs +155/−162
- src/IDE/Pane/Search.hs +193/−188
- src/IDE/Pane/SourceBuffer.hs +496/−473
- src/IDE/Pane/Trace.hs +10/−61
- src/IDE/Pane/Variables.hs +8/−54
- src/IDE/Pane/Workspace.hs +202/−0
- src/IDE/PaneGroups.hs +128/−0
- src/IDE/PrinterParser.hs +0/−173
- src/IDE/SaveSession.hs +0/−532
- src/IDE/Session.hs +537/−0
- src/IDE/SourceCandy.hs +97/−104
- src/IDE/Statusbar.hs +182/−0
- src/IDE/TextEditor.hs +1085/−0
- src/IDE/Tool.hs +0/−326
- src/IDE/Utils/GUIUtils.hs +213/−0
- src/IDE/Utils/ServerConnection.hs +88/−0
- src/IDE/Workspaces.hs +468/−0
- src/LeksahEcho.hs +0/−24
- src/Main.hs +0/−22
- src/MyMissing.hs +0/−79
− data/Current.session
@@ -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"]
− data/Default.candy
@@ -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--
− data/Default.keymap
@@ -1,109 +0,0 @@---Default Keymap file for Leksah---Allowed Modifiers are <shift> <ctrl> <alt> <apple> <compose>---<apple> is the Windows key on PC keyboards---<compose> 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-<ctrl>n -> FileNew "Opens a new empty buffer"-<ctrl>o -> FileOpen "Opens an existing file"---<ctrl>x/<ctrl>f -> FileOpen "Opens an existing file"--<ctrl>s -> FileSave "Saves the current buffer"---<ctrl>x/<ctrl>s -> FileSave "Saves the current buffer"----<ctrl>x/<ctrl>w -> FileSaveAs "Saves the current buffer as a new file"--<ctrl><shift>s -> FileSaveAll "Saves all modified buffers"--<ctrl>w -> FileClose "Closes the current buffer"---<ctrl>x/k -> FileClose "Closes the current buffer"--<alt>F4 -> Quit "Quits this program"---<ctrl>x/<ctrl>c -> Quit "Quits this program"----Edit-<ctrl>z -> EditUndo "Undos the last user action"---<ctrl>x/u -> EditUndo "Undos the last user action"--<shift><ctrl>y -> EditRedo "Redos the last user action"---<ctrl>x/r -> EditRedo "Redos the last user action"----<ctrl>x -> EditCut---<ctrl>c -> EditCopy---<ctrl>v -> EditPaste- -> EditDelete-<ctrl>a -> EditSelectAll "Select the whole text in the current buffer"--<ctrl>f -> EditFind "Search for a text string (Toggles the "-F3 -> EditFindNext "Find the next occurence of the text string"--<shift>F3 -> EditFindPrevious "Find the previous occurence of the text string"--<ctrl>l -> EditGotoLine "Go to line with a known index"--<ctrl><alt>Right -> EditComment "Add a line style comment to the selected lies"-<ctrl><alt>Left -> EditUncomment "Remove a line style comment"-<alt>Right -> EditShiftRight "Shift right"-<alt>Left -> EditShiftLeft "Shift Left"----View-<alt><shift>Left -> ViewMoveLeft "Move the current pane left"-<alt><shift>Right -> ViewMoveRight "Move the current pane right"-<alt><shift>Up -> ViewMoveUp "Move the current pane up"-<alt><shift>Down -> ViewMoveDown "Move the current pane down"--<ctrl>2 -> ViewSplitHorizontal- "Split the current pane in horizontal direction"-<ctrl>3 -> ViewSplitVertical- "Split the current pane in vertical direction"-<ctrl>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"-<ctrl>t -> ToggleToolbar- -> HelpDebug- -> HelpAbout--<ctrl>b -> BuildPackage-<ctrl>r -> AddAllImports--<ctrl><alt>r -> RunPackage--<ctrl>j -> NextError-<ctrl><shift>j -> PreviousError--<ctrl>m -> ShowModules-----<ctrl>i -> ShowInterface--- <ctrl>i -> ShowInfo---<ctrl><shift>e -> EditAlignEqual-<ctrl><shift>l -> EditAlignLeftArrow-<ctrl><shift>r -> EditAlignRightArrow-<ctrl><shift>t -> EditAlignTypeSig--<alt>i -> AddOneImport-<alt><shift>i -> AddAllImports---- "For the next to entries the <ctrl> modifier is mandatory"-<ctrl>Page_Up -> FlipUp "Switch to next pane in reverse recently used oder"-<ctrl>Page_Down -> FlipDown "Switch to next pane in recently used oder"--<ctrl>space -> StartComplete "Initiate complete in a source buffer"--F6 -> DebugStep-F7 -> DebugStepLocal-F8 -> DebugStepModule-F9 -> DebugContinue---
@@ -1,196 +0,0 @@- <ui>- <menubar>- <menu name="_File" action="File">- <menuitem name="_New" action="FileNew" />- <menuitem name="_Open" action="FileOpen" />- <menuitem name="_Recent Files" action="RecentFiles"/>- <menuitem name="_Save" action="FileSave" />- <menuitem name="Save _As" action="FileSaveAs" />- <menuitem name="Save _All" action="FileSaveAll" />- <menuitem name="_Revert" action="FileRevert" />- <menuitem name="_Close" action="FileClose" />- <separator/>- <menuitem name="Close All" action="FileCloseAll" />- <menuitem name="Close All but Package" action="FileCloseAllButPackage" />- <separator/>- <menuitem name="_Quit" action="Quit" />- </menu>- <menu name="_Edit" action="Edit">- <menuitem name="_Undo" action="EditUndo" />- <menuitem name="_Redo" action="EditRedo" />- <separator/>- <menuitem name="Cu_t" action="EditCut" />- <menuitem name="_Copy" action="EditCopy" />- <menuitem name="_Paste" action="EditPaste" />- <menuitem name="_Delete" action="EditDelete" />- <menuitem name="Select _All" action="EditSelectAll" />- <separator/>- <menuitem name="_Find" action="EditFind" />- <menuitem name="Find_Next" action="EditFindNext" />- <menuitem name="Find_Previous" action="EditFindPrevious" />- <menuitem name="_Goto Line" action="EditGotoLine" />- <separator/>- <menuitem name="Comment" action="EditComment" />- <menuitem name="Uncomment" action="EditUncomment" />- <menuitem name="Shift Left" action="EditShiftLeft" />- <menuitem name="Shift Right" action="EditShiftRight" />- <separator/>- <menuitem name="Align =" action="EditAlignEqual" />- <menuitem name="Align <-" action="EditAlignLeftArrow" />- <menuitem name="Align ->" action="EditAlignRightArrow" />- <menuitem name="Align ::" action="EditAlignTypeSig" />- </menu>- <menu name="_Package" action="Package">- <menuitem name="_New Package" action="NewPackage" />- <menuitem name="_Open Package" action="OpenPackage" />- <menuitem name="_Recent Packages" action="RecentPackages"/>- <menuitem name="_Close Package" action="ClosePackage" />- <separator/>- <menuitem name="_Edit Cabal" action="EditPackage" />- <menuitem name="Edit _Flags" action="PackageFlags" />- <separator/>- <menuitem name="Clea_n Package" action="CleanPackage" />- <menuitem name="_Configure Package" action="ConfigPackage" />- <menuitem name="_Build Package" action="BuildPackage" />- <menuitem name="_Run" action="RunPackage" />- <menuitem name="_Next Error" action="NextError" />- <menuitem name="_Previous Error" action="PreviousError" />- <menuitem name="_Add All Imports" action="AddAllImports" />- <separator/>- <menuitem name="C_opy Package" action="CopyPackage" />- <menuitem name="_Install Package" action="InstallPackage" />- <menuitem name="Re_gister Package" action="RegisterPackage" />- <menuitem name="_Unregister Package" action="UnregisterPackage" />- <menuitem name="Test Package" action="TestPackage" />- <menuitem name="SDist Package" action="SdistPackage" />- <menuitem name="_Build Documentation" action="DocPackage" />- <separator/>- <menuitem name="Open Documentation" action="OpenDocPackage" />- </menu>- <menu name="_Debug" action="Debug">- <menuitem name="Continue" action="DebugContinue" />- <menuitem name="Abandon" action="DebugAbandon" />- <menuitem name="Stop" action="DebugStop" />- <separator/>- <menuitem name="Step" action="DebugStep" />- <menuitem name="Step Local" action="DebugStepLocal" />- <menuitem name="Step Module" action="DebugStepModule" />- <separator/>- <menuitem name="Show Bin_dings" action="ShowBindings" />- <menuitem name="Show _Context" action="ShowContext" />- <menuitem name="Show Loaded _Modules" action="ShowLoadedModules" />- <menuitem name="Show _Packages" action="ShowPackages" />- <menuitem name="Show _Languages" action="ShowLanguages" />- <separator/>- <menuitem name="Show Debugger" action="ShowDebugger" />- </menu>- <menu name="_Metadata" action="Metadata">- <menuitem name="Update Project" action="UpdateMetadataCurrent" />- <menuitem name="Update Library" action="UpdateMetadataLib" />- <separator/>- <menuitem name="Show _Info" action="ShowInfo" />- <menuitem name="Show _Modules" action="ShowModules" />- <menuitem name="Show _Search" action="ShowSearch" />- </menu>- <menu name="_Session" action="Session">- <menuitem name="Save Session" action="SaveSession" />- <menuitem name="Load Session" action="LoadSession" />- <menuitem name="Forget Session" action="ForgetSession" />- </menu>- <menu name="_View" action="View">- <menuitem name="Split H_orizontal" action="ViewSplitHorizontal" />- <menuitem name="Split V_ertical" action="ViewSplitVertical" />- <menuitem name="_Collapse" action="ViewCollapse" />- <menuitem name="Close Pane" action="ViewClosePane" />- <separator/>- <menuitem name="_Group" action="ViewNest" />- <menuitem name="_Detach" action="ViewDetach" />- <separator/>- <menuitem name="Move _Left" action="ViewMoveLeft" />- <menuitem name="Move _Right" action="ViewMoveRight" />- <menuitem name="Move _Up" action="ViewMoveUp" />- <menuitem name="Move _Down" action="ViewMoveDown" />- <separator/>- <menuitem name="Tabs _Left" action="ViewTabsLeft" />- <menuitem name="Tabs _Right" action="ViewTabsRight" />- <menuitem name="Tabs _Up" action="ViewTabsUp" />- <menuitem name="Tabs _Down" action="ViewTabsDown" />- <menuitem name="Switch Tabs" action="ViewSwitchTabs" />- <separator/>- <menuitem name="Clear Log" action="ClearLog" />- <menuitem name="Toggle Toolbar" action="ToggleToolbar" />- </menu>- <menu name="_Configuration" action="Configuration">- <menuitem name="Source Candy" action="EditCandy" />- <menuitem name="Edit general Preferences" action="PrefsEdit" />- </menu>- <menu name="_Help" action="Help">- <menuitem name="_Homepage" action="HelpHomepage" />- <menuitem name="_Manual (pdf)" action="HelpManual" />- <menuitem name="_About" action="HelpAbout" />- </menu>- </menubar>- <toolbar name="toolbar">- <placeholder name="FileToolItems">- <separator/>- <toolitem name="New" action="FileNew"/>- <toolitem name="Open" action="FileOpen"/>- <toolitem name="Save" action="FileSave"/>- <toolitem name="Close" action="ViewClosePane"/>- <separator/>- </placeholder>- <placeholder name="FileEditItems">- <separator/>- <toolitem name="Undo" action="EditUndo"/>- <toolitem name="Redo" action="EditRedo"/>- <separator/>- <toolitem name="Find" action="EditFind"/>- </placeholder>- <placeholder name="BuildToolItems">- <separator/>- <toolitem name="CleanPackage" action="CleanPackage"/>- <toolitem name="Configure" action="ConfigPackage"/>- <toolitem name="Build" action="BuildPackage"/>- <toolitem name="Run" action="RunPackage"/>- <toolitem name="Next Error" action="NextError"/>- <toolitem name="Previous Error" action="PreviousError"/>- <separator/>- <toolitem name="Back" action="ViewHistoryBack"/>- <toolitem name="Forward" action="ViewHistoryForth"/>- <separator/>- <toolitem name="BackgroundBuild" action="BackgroundBuildToggled"/>- <toolitem name="BackgroundLink" action="BackgroundLinkToggled"/>- <separator/>- <toolitem name="Update Project" action="UpdateMetadataCurrent" />- <separator/>- <toolitem name="Debug" action="DebugToggled"/>- <toolitem name="Step" action="DebugStep"/>- <toolitem name="StepLocal" action="DebugStepLocal"/>- <toolitem name="StepModule" action="DebugStepModule"/>- <toolitem name="StepContinue" action="DebugContinue"/>- </placeholder>- </toolbar>- <accelerator name="FlipUp" action="FlipUp"/>- <accelerator name="FlipDown" action="FlipDown"/>- <accelerator name="StartComplete" action="StartComplete"/>- <accelerator name="_Start Debugger" action="StartDebugger" />- <accelerator name="_Quit Debugger" action="QuitDebugger" />- <accelerator name="_Execute Selection" action="ExecuteSelection" />- <accelerator name="Set Breakpoint" action="DebugSetBreakpoint" />- <accelerator name="Show Breakpoints" action="ShowBreakpoints" />- <accelerator name="Show Next Breakpoint" action="ShowNextBreakpoint" />- <accelerator name="Show Previous Breakpoint" action="ShowPreviousBreakpoint" />- <accelerator name="Delete All Breakpoints" action="DebugDeleteAllBreakpoints" />- <accelerator name="Step Expression" action="DebugStepExpression" />- <accelerator name="Trace Expression" action="DebugTraceExpression" />- <accelerator name="Trace" action="DebugTrace" />- <accelerator name="History" action="DebugHistory" />- <accelerator name="Back" action="DebugBack" />- <accelerator name="Forward" action="DebugForward" />- <accelerator name="Force" action="DebugForce" />- <accelerator name="Print" action="DebugPrint" />- <accelerator name="Simple Print" action="DebugSimplePrint" />- <accelerator name="Information" action="DebugInformation" />- <accelerator name="Kind" action="DebugKind" />- <accelerator name="Type" action="DebugType" />- </ui>
− data/Default.prefs
@@ -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=
− data/Emacs.keymap
@@ -1,66 +0,0 @@---Default Keymap file for Genuine Haskell Face---Allowed Modifiers are <shift> <ctrl> <alt> <apple> <compose>---Apple is the Windows key on PC keyboards---Compose is often labelled Alt Gr.-----File-<ctrl>n -> FileNew "Opens a new empty buffer"-<ctrl>x/<ctrl>f -> FileOpen "Opens an existing file"-<ctrl>x/<ctrl>s -> FileSave "Saves the current buffer"-<ctrl>x/<ctrl>w -> FileSaveAs "Saves the current buffer as a new file"-<ctrl>x/k -> FileClose "Closes the current buffer"-<ctrl>x/<ctrl>c -> Quit "Quits kthis program"-----Edit-<ctrl>x/u -> EditUndo "Undos the last user action"---<ctrl><shift>_ -> EditUndo "Undos the last user action"-<ctrl>x/r -> EditRedo "Redos the last user action"-<ctrl>w -> EditCut-<alt>w -> EditCopy-<ctrl>y -> EditPaste- -> EditDelete-<ctrl>a -> EditSelectAll "Select the whole text in the current buffer"--<ctrl>s -> EditFind "Search for a text string"-F3 -> EditFindNext "Find the next occurence of the text string"---<ctrl>k -> EditFind "Search for a text string"--<ctrl>r -> EditFindPrevious- "Find the previous occurence of the text string"-<alt>r -> EditReplace--<ctrl>L -> EditGotoLine "Go to line with a known index"--<ctrl>7 -> EditComment "Add a line style comment to the selected lies"-<ctrl><shift>7 -> EditUncomment "Remove a line style comment"-<alt>Right -> EditShiftRight "Shift right"-<alt>Left -> EditShiftLeft "Shift Left"----View-<alt><shift>Left -> ViewMoveLeft "Move the current pane left"-<alt><shift>Right -> ViewMoveRight "Move the current pane right"-<alt><shift>Up -> ViewMoveUp "Move the current pane up"-<alt><shift>Down -> ViewMoveDown "Move the current pane down"--<Ctrl>2 -> ViewSplitHorizontal- "Split the current pane in horizontal direction"-<Ctrl>3 -> ViewSplitVertical- "Split the current pane in vertical direction"-<Ctrl>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--<ctrl>b -> BuildPackage--<ctrl><shift>r -> RunPackage--<ctrl>j -> NextError-<ctrl><shift>j -> PreviousError
− data/Module.template
@@ -1,21 +0,0 @@------------------------------------------------------------------------------------ Module : @ModuleName@--- Copyright : @Copyright@--- License : @License@------ Maintainer : @Maintainer@--- Stability : @Stability@--- Portability : @Portability@------ |-----------------------------------------------------------------------------------module @ModuleName@ (---) where---
+ data/candy.lkshc view
@@ -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++
+ data/current.lkshs view
@@ -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:+ []
+ data/emacs.lkshk view
@@ -0,0 +1,66 @@+--Default Keymap file for Genuine Haskell Face+--Allowed Modifiers are <shift> <ctrl> <alt> <apple> <compose>+--Apple is the Windows key on PC keyboards+--Compose is often labelled Alt Gr.+++--File+<ctrl>n -> FileNew "Opens a new empty buffer"+<ctrl>x/<ctrl>f -> FileOpen "Opens an existing file"+<ctrl>x/<ctrl>s -> FileSave "Saves the current buffer"+<ctrl>x/<ctrl>w -> FileSaveAs "Saves the current buffer as a new file"+<ctrl>x/k -> FileClose "Closes the current buffer"+<ctrl>x/<ctrl>c -> Quit "Quits kthis program"+++--Edit+<ctrl>x/u -> EditUndo "Undos the last user action"+--<ctrl><shift>_ -> EditUndo "Undos the last user action"+<ctrl>x/r -> EditRedo "Redos the last user action"+<ctrl>w -> EditCut+<alt>w -> EditCopy+<ctrl>y -> EditPaste+ -> EditDelete+<ctrl>a -> EditSelectAll "Select the whole text in the current buffer"++<ctrl>s -> EditFind "Search for a text string"+F3 -> EditFindNext "Find the next occurence of the text string"+--<ctrl>k -> EditFind "Search for a text string"++<ctrl>r -> EditFindPrevious+ "Find the previous occurence of the text string"+<alt>r -> EditReplace++<ctrl>L -> EditGotoLine "Go to line with a known index"++<ctrl>7 -> EditComment "Add a line style comment to the selected lies"+<ctrl><shift>7 -> EditUncomment "Remove a line style comment"+<alt>Right -> EditShiftRight "Shift right"+<alt>Left -> EditShiftLeft "Shift Left"++--View+<alt><shift>Left -> ViewMoveLeft "Move the current pane left"+<alt><shift>Right -> ViewMoveRight "Move the current pane right"+<alt><shift>Up -> ViewMoveUp "Move the current pane up"+<alt><shift>Down -> ViewMoveDown "Move the current pane down"++<Ctrl>2 -> ViewSplitHorizontal+ "Split the current pane in horizontal direction"+<Ctrl>3 -> ViewSplitVertical+ "Split the current pane in vertical direction"+<Ctrl>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++<ctrl>b -> BuildPackage++<ctrl><shift>r -> RunPackage++<ctrl>j -> NextError+<ctrl><shift>j -> PreviousError
− data/ide_build.png
binary file changed (1958 → absent bytes)
− data/ide_class.png
binary file changed (521 → absent bytes)
− data/ide_clean.png
binary file changed (875 → absent bytes)
− data/ide_configure.png
binary file changed (1353 → absent bytes)
− data/ide_continue.png
binary file changed (601 → absent bytes)
− data/ide_data.png
binary file changed (172 → absent bytes)
− data/ide_debug.png
binary file changed (3648 → absent bytes)
− data/ide_error_next.png
binary file changed (766 → absent bytes)
− data/ide_error_prev.png
binary file changed (756 → absent bytes)
− data/ide_function.png
binary file changed (778 → absent bytes)
− data/ide_instance.png
binary file changed (239 → absent bytes)
− data/ide_konstructor.png
binary file changed (203 → absent bytes)
− data/ide_link.png
binary file changed (2965 → absent bytes)
− data/ide_local.png
binary file changed (1340 → absent bytes)
− data/ide_make.png
binary file changed (425 → absent bytes)
− data/ide_method.png
binary file changed (811 → absent bytes)
− data/ide_module.png
binary file changed (1307 → absent bytes)
− data/ide_newtype.png
binary file changed (161 → absent bytes)
− data/ide_other.png
binary file changed (1210 → absent bytes)
− data/ide_rebuild_meta.png
binary file changed (5083 → absent bytes)
− data/ide_reexported.png
binary file changed (393 → absent bytes)
− data/ide_rule.png
binary file changed (356 → absent bytes)
− data/ide_run.png
binary file changed (3972 → absent bytes)
− data/ide_slot.png
binary file changed (173 → absent bytes)
− data/ide_source.png
binary file changed (469 → absent bytes)
− data/ide_step.png
binary file changed (1285 → absent bytes)
− data/ide_type.png
binary file changed (365 → absent bytes)
+ data/keymap.lkshk view
@@ -0,0 +1,112 @@+--Default Keymap file for Leksah+--Allowed Modifiers are <shift> <ctrl> <alt> <apple> <compose>+--<apple> is the Windows key on PC keyboards+--<compose> 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+<ctrl>n -> FileNew "Opens a new empty buffer"+<ctrl>o -> FileOpen "Opens an existing file"+--<ctrl>x/<ctrl>f -> FileOpen "Opens an existing file"++<ctrl>s -> FileSave "Saves the current buffer"+--<ctrl>x/<ctrl>s -> FileSave "Saves the current buffer"++--<ctrl>x/<ctrl>w -> FileSaveAs "Saves the current buffer as a new file"++<ctrl><shift>s -> FileSaveAll "Saves all modified buffers"++<ctrl>w -> FileClose "Closes the current buffer"+--<ctrl>x/k -> FileClose "Closes the current buffer"++<alt>F4 -> Quit "Quits this program"+--<ctrl>x/<ctrl>c -> Quit "Quits this program"++--Edit+<ctrl>z -> EditUndo "Undos the last user action"+--<ctrl>x/u -> EditUndo "Undos the last user action"++<shift><ctrl>y -> EditRedo "Redos the last user action"+--<ctrl>x/r -> EditRedo "Redos the last user action"++--<ctrl>x -> EditCut+--<ctrl>c -> EditCopy+--<ctrl>v -> EditPaste+ -> EditDelete+<ctrl>a -> EditSelectAll "Select the whole text in the current buffer"++<ctrl>f -> EditFind "Search for a text string (Toggles the "+F3 -> EditFindNext "Find the next occurence of the text string"++<shift>F3 -> EditFindPrevious "Find the previous occurence of the text string"++<ctrl>l -> EditGotoLine "Go to line with a known index"++<ctrl><alt>Right -> EditComment "Add a line style comment to the selected lies"+<ctrl><alt>Left -> EditUncomment "Remove a line style comment"+<alt>Right -> EditShiftRight "Shift right"+<alt>Left -> EditShiftLeft "Shift Left"++--View+<alt><shift>Left -> ViewMoveLeft "Move the current pane left"+<alt><shift>Right -> ViewMoveRight "Move the current pane right"+<alt><shift>Up -> ViewMoveUp "Move the current pane up"+<alt><shift>Down -> ViewMoveDown "Move the current pane down"++<ctrl>2 -> ViewSplitHorizontal+ "Split the current pane in horizontal direction"+<ctrl>3 -> ViewSplitVertical+ "Split the current pane in vertical direction"+<ctrl>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"+<ctrl>t -> ToggleToolbar+ -> HelpDebug+ -> HelpAbout++<ctrl>b -> BuildPackage+<ctrl>r -> AddAllImports++<ctrl><alt>r -> RunPackage++<ctrl>j -> NextError+<ctrl><shift>j -> PreviousError++<ctrl>o -> ShowModules+++--<ctrl>i -> ShowInterface+-- <ctrl>i -> ShowInfo+++<ctrl><shift>e -> EditAlignEqual+<ctrl><shift>l -> EditAlignLeftArrow+<ctrl><shift>r -> EditAlignRightArrow+<ctrl><shift>t -> EditAlignTypeSig++<alt>i -> AddOneImport+<alt><shift>i -> AddAllImports++-- "For the next to entries the <ctrl> modifier is mandatory"+<ctrl>Page_Up -> FlipUp "Switch to next pane in reverse recently used oder"+<ctrl>Page_Down -> FlipDown "Switch to next pane in recently used oder"++<ctrl>space -> StartComplete "Initiate complete in a source buffer"++F6 -> DebugStep+F7 -> DebugStepLocal+F8 -> DebugStepModule+F9 -> DebugContinue++<ctrl>Return -> ExecuteSelection+<ctrl>m -> UpdateMetadataCurrent+++
@@ -0,0 +1,207 @@+ <ui>+ <menubar>+ <menu name="_File" action="File">+ <menuitem name="_New" action="FileNew" />+ <menuitem name="_Open" action="FileOpen" />+ <menuitem name="_Recent Files" action="RecentFiles"/>+ <menuitem name="_Save" action="FileSave" />+ <menuitem name="Save _As" action="FileSaveAs" />+ <menuitem name="Save _All" action="FileSaveAll" />+ <menuitem name="_Revert" action="FileRevert" />+ <menuitem name="_Close" action="FileClose" />+ <separator/>+ <menuitem name="Close All" action="FileCloseAll" />+ <menuitem name="Close All but Package" action="FileCloseAllButPackage" />+ <menuitem name="Close All but Workspace" action="FileCloseAllButWorkspace" />+ <separator/>+ <menuitem name="_Quit" action="Quit" />+ </menu>+ <menu name="_Edit" action="Edit">+ <menuitem name="_Undo" action="EditUndo" />+ <menuitem name="_Redo" action="EditRedo" />+ <separator/>+ <menuitem name="Cu_t" action="EditCut" />+ <menuitem name="_Copy" action="EditCopy" />+ <menuitem name="_Paste" action="EditPaste" />+ <menuitem name="_Delete" action="EditDelete" />+ <menuitem name="Select _All" action="EditSelectAll" />+ <separator/>+ <menuitem name="_Find" action="EditFind" />+ <menuitem name="Find_Next" action="EditFindNext" />+ <menuitem name="Find_Previous" action="EditFindPrevious" />+ <menuitem name="_Goto Line" action="EditGotoLine" />+ <separator/>+ <menuitem name="Comment" action="EditComment" />+ <menuitem name="Uncomment" action="EditUncomment" />+ <menuitem name="Shift Left" action="EditShiftLeft" />+ <menuitem name="Shift Right" action="EditShiftRight" />+ <separator/>+ <menuitem name="Align =" action="EditAlignEqual" />+ <menuitem name="Align <-" action="EditAlignLeftArrow" />+ <menuitem name="Align ->" action="EditAlignRightArrow" />+ <menuitem name="Align ::" action="EditAlignTypeSig" />+ </menu>+ <menu name="_Workspace" action="Workspace">+ <menuitem name="_New Workspace" action="NewWorkspace" />+ <menuitem name="_Open Workspace" action="OpenWorkspace" />+ <menuitem name="_Recent Workspaces" action="RecentWorkspaces"/>+ <menuitem name="_Close Workspace" action="CloseWorkspace" />+ <separator/>+ <menuitem name="_Clean Workspace" action="CleanWorkspace" />+ <menuitem name="_Make Workspace" action="MakeWorkspace" />+ <separator/>+ <menuitem name="_Next Error" action="NextError" />+ <menuitem name="_Previous Error" action="PreviousError" />+ <menuitem name="_Add All Imports" action="AddAllImports" />+ </menu>+ <menu name="_Package" action="Package">+ <menuitem name="_New Package" action="NewPackage" />+ <menuitem name="_Edit Package" action="EditPackage" />+ <menuitem name="Edit _Flags" action="PackageFlags" />+ <separator/>+ <menuitem name="Clea_n Package" action="CleanPackage" />+ <menuitem name="_Configure Package" action="ConfigPackage" />+ <menuitem name="_Build Package" action="BuildPackage" />+ <menuitem name="_Run" action="RunPackage" />+ <separator/>+ <menuitem name="C_opy Package" action="CopyPackage" />+ <menuitem name="_Install Package" action="InstallPackage" />+ <menuitem name="Re_gister Package" action="RegisterPackage" />+ <menuitem name="_Unregister Package" action="UnregisterPackage" />+ <menuitem name="Test Package" action="TestPackage" />+ <menuitem name="SDist Package" action="SdistPackage" />+ <menuitem name="_Build Documentation" action="DocPackage" />+ <separator/>+ <menuitem name="Open Documentation" action="OpenDocPackage" />+ </menu>+ <menu name="_Debug" action="Debug">+ <menuitem name="Continue" action="DebugContinue" />+ <menuitem name="Abandon" action="DebugAbandon" />+ <menuitem name="Stop" action="DebugStop" />+ <separator/>+ <menuitem name="Step" action="DebugStep" />+ <menuitem name="Step Local" action="DebugStepLocal" />+ <menuitem name="Step Module" action="DebugStepModule" />+ <separator/>+ <menuitem name="Show Bin_dings" action="ShowBindings" />+ <menuitem name="Show _Context" action="ShowContext" />+ <menuitem name="Show Loaded _Modules" action="ShowLoadedModules" />+ <menuitem name="Show _Packages" action="ShowPackages" />+ <menuitem name="Show _Languages" action="ShowLanguages" />+ </menu>+ <menu name="_Panes" action="Panes">+ <menuitem name="_Browser" action="ShowBrowser" />+ <menuitem name="_Debugger" action="ShowDebugger" />+ <menuitem name="_Errors" action="ShowErrors" />+ <menuitem name="_Grep" action="ShowGrep" />+ <menuitem name="_Log" action="ShowLog" />+ <menuitem name="_References" action="ShowReferences" />+ <menuitem name="_Search" action="ShowSearch" />+ <menuitem name="_Workspace" action="ShowWorkspace" />+ </menu>+ <menu name="_View" action="View">+ <menuitem name="Split H_orizontal" action="ViewSplitHorizontal" />+ <menuitem name="Split V_ertical" action="ViewSplitVertical" />+ <menuitem name="_Collapse" action="ViewCollapse" />+ <menuitem name="Close Pane" action="ViewClosePane" />+ <separator/>+ <menuitem name="_Group" action="ViewNest" />+ <menuitem name="_Detach" action="ViewDetach" />+ <separator/>+ <menuitem name="Move _Left" action="ViewMoveLeft" />+ <menuitem name="Move _Right" action="ViewMoveRight" />+ <menuitem name="Move _Up" action="ViewMoveUp" />+ <menuitem name="Move _Down" action="ViewMoveDown" />+ <separator/>+ <menuitem name="Tabs _Left" action="ViewTabsLeft" />+ <menuitem name="Tabs _Right" action="ViewTabsRight" />+ <menuitem name="Tabs _Up" action="ViewTabsUp" />+ <menuitem name="Tabs _Down" action="ViewTabsDown" />+ <menuitem name="Switch Tabs" action="ViewSwitchTabs" />+ <separator/>+ <menuitem name="Clear Log" action="ClearLog" />+ <menuitem name="Toggle Toolbar" action="ToggleToolbar" />+ </menu>+ <menu name="_Configuration" action="Configuration">+ <menuitem name="Source Candy" action="EditCandy" />+ <menuitem name="Edit general Preferences" action="PrefsEdit" />+ <separator/>+ <menuitem name="Update workspace data" action="UpdateMetadataCurrent" />+ <menuitem name="Rebuild workspace data" action="RebuildMetadataCurrent" />+ <menuitem name="Update system data" action="UpdateMetadataLib" />+ <menuitem name="Rebuild system data" action="RebuildMetadataLib" />+ <separator/>+ <menuitem name="Save Session" action="SaveSession" />+ <menuitem name="Load Session" action="LoadSession" />+ <menuitem name="Forget Session" action="ForgetSession" />+ </menu>+ <menu name="_Help" action="Help">+ <menuitem name="_Homepage" action="HelpHomepage" />+ <menuitem name="_Manual (pdf)" action="HelpManual" />+ <menuitem name="_About" action="HelpAbout" />+ </menu>+ </menubar>+ <toolbar name="toolbar">+ <placeholder name="FileToolItems">+ <separator/>+ <toolitem name="New" action="FileNew"/>+ <toolitem name="Open" action="FileOpen"/>+ <toolitem name="Save" action="FileSave"/>+ <toolitem name="Close" action="ViewClosePane"/>+ <separator/>+ </placeholder>+ <placeholder name="FileEditItems">+ <separator/>+ <toolitem name="Undo" action="EditUndo"/>+ <toolitem name="Redo" action="EditRedo"/>+ <separator/>+ <toolitem name="Find" action="EditFind"/>+ </placeholder>+ <placeholder name="BuildToolItems">+ <separator/>+ <toolitem name="CleanPackage" action="CleanPackage"/>+ <toolitem name="Configure" action="ConfigPackage"/>+ <toolitem name="Build" action="BuildPackage"/>+ <toolitem name="Run" action="RunPackage"/>+ <toolitem name="Next Error" action="NextError"/>+ <toolitem name="Previous Error" action="PreviousError"/>+ <separator/>+ <toolitem name="Back" action="ViewHistoryBack"/>+ <toolitem name="Forward" action="ViewHistoryForth"/>+ <separator/>+ <toolitem name="BackgroundBuild" action="BackgroundBuildToggled"/>+ <toolitem name="BackgroundLink" action="BackgroundLinkToggled"/>+ <separator/>+ <toolitem name="Update Project" action="UpdateMetadataCurrent" />+ <separator/>+ <toolitem name="Debug" action="DebugToggled"/>+ <toolitem name="Step" action="DebugStep"/>+ <toolitem name="StepLocal" action="DebugStepLocal"/>+ <toolitem name="StepModule" action="DebugStepModule"/>+ <toolitem name="StepContinue" action="DebugContinue"/>+ </placeholder>+ </toolbar>+ <accelerator name="FlipUp" action="FlipUp"/>+ <accelerator name="FlipDown" action="FlipDown"/>+ <accelerator name="StartComplete" action="StartComplete"/>+ <accelerator name="_Start Debugger" action="StartDebugger" />+ <accelerator name="_Quit Debugger" action="QuitDebugger" />+ <accelerator name="_Execute Selection" action="ExecuteSelection" />+ <accelerator name="Set Breakpoint" action="DebugSetBreakpoint" />+ <accelerator name="Show Breakpoints" action="ShowBreakpoints" />+ <accelerator name="Show Next Breakpoint" action="ShowNextBreakpoint" />+ <accelerator name="Show Previous Breakpoint" action="ShowPreviousBreakpoint" />+ <accelerator name="Delete All Breakpoints" action="DebugDeleteAllBreakpoints" />+ <accelerator name="Step Expression" action="DebugStepExpression" />+ <accelerator name="Trace Expression" action="DebugTraceExpression" />+ <accelerator name="Trace" action="DebugTrace" />+ <accelerator name="History" action="DebugHistory" />+ <accelerator name="Back" action="DebugBack" />+ <accelerator name="Forward" action="DebugForward" />+ <accelerator name="Force" action="DebugForce" />+ <accelerator name="Print" action="DebugPrint" />+ <accelerator name="Simple Print" action="DebugSimplePrint" />+ <accelerator name="Information" action="DebugInformation" />+ <accelerator name="Kind" action="DebugKind" />+ <accelerator name="Type" action="DebugType" />+ </ui>
− data/leksah.png
binary file changed (12052 → absent bytes)
+ data/module.lksht view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+--+-- Module : @ModuleName@+-- Copyright : @Copyright@+-- License : @License@+--+-- Maintainer : @Maintainer@+-- Stability : @Stability@+-- Portability : @Portability@+--+-- |+--+-----------------------------------------------------------------------------++module @ModuleName@ (+++) where+++
+ data/prefs.lkshp view
@@ -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=
+ data/prefscoll.lkshp view
@@ -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
data/welcome.txt view
@@ -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 + + + +
leksah.cabal view
@@ -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:+++
+ pics/ide_build.png view
binary file changed (absent → 1958 bytes)
+ pics/ide_class.png view
binary file changed (absent → 521 bytes)
+ pics/ide_clean.png view
binary file changed (absent → 875 bytes)
+ pics/ide_configure.png view
binary file changed (absent → 1353 bytes)
+ pics/ide_continue.png view
binary file changed (absent → 601 bytes)
+ pics/ide_data.png view
binary file changed (absent → 172 bytes)
+ pics/ide_debug.png view
binary file changed (absent → 3648 bytes)
+ pics/ide_empty.png view
binary file changed (absent → 493 bytes)
+ pics/ide_error_next.png view
binary file changed (absent → 766 bytes)
+ pics/ide_error_prev.png view
binary file changed (absent → 756 bytes)
+ pics/ide_function.png view
binary file changed (absent → 778 bytes)
+ pics/ide_instance.png view
binary file changed (absent → 239 bytes)
+ pics/ide_konstructor.png view
binary file changed (absent → 203 bytes)
+ pics/ide_link.png view
binary file changed (absent → 2965 bytes)
+ pics/ide_local.png view
binary file changed (absent → 1340 bytes)
+ pics/ide_make.png view
binary file changed (absent → 425 bytes)
+ pics/ide_method.png view
binary file changed (absent → 811 bytes)
+ pics/ide_module.png view
binary file changed (absent → 1307 bytes)
+ pics/ide_newtype.png view
binary file changed (absent → 161 bytes)
+ pics/ide_other.png view
binary file changed (absent → 1210 bytes)
+ pics/ide_rebuild_meta.png view
binary file changed (absent → 5083 bytes)
+ pics/ide_reexported.png view
binary file changed (absent → 393 bytes)
+ pics/ide_rule.png view
binary file changed (absent → 356 bytes)
+ pics/ide_run.png view
binary file changed (absent → 3972 bytes)
+ pics/ide_slot.png view
binary file changed (absent → 173 bytes)
+ pics/ide_source.png view
binary file changed (absent → 469 bytes)
+ pics/ide_source_local.png view
binary file changed (absent → 324 bytes)
+ pics/ide_step.png view
binary file changed (absent → 1285 bytes)
+ pics/ide_type.png view
binary file changed (absent → 365 bytes)
+ pics/leksah.png view
binary file changed (absent → 65909 bytes)
− src/Control/Event.hs
@@ -1,86 +0,0 @@-{-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-}------------------------------------------------------------------------------------ Module : Control.Event--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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-
@@ -1,162 +0,0 @@-{-# OPTIONS_GHC- -XExistentialQuantification- -XDeriveDataTypeable- -XScopedTypeVariables #-}------------------------------------------------------------------------------------ Module : Data.Binary.Shared--- Copyright : 2007-2009 Jürgen Nicklisch-Franken--- License : GPL------ Maintainer : Jutaro <jutaro@leksah.org>--- 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-
− src/DeepSeq.hs
@@ -1,74 +0,0 @@------------------------------------------------------------------------------------ Module : Default--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <info@leksah.org>--- 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-----
− src/Default.hs
@@ -1,45 +0,0 @@------------------------------------------------------------------------------------- Module : Default--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <info@leksah.org>--- 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
− src/Graphics/UI/Editor/Basics.hs
@@ -1,286 +0,0 @@-{-# OPTIONS_GHC -XMultiParamTypeClasses -XScopedTypeVariables #-}------------------------------------------------------------------------------------- Module : Graphics.UI.Editor.Basics--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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"
− src/Graphics/UI/Editor/Composite.hs
@@ -1,790 +0,0 @@------------------------------------------------------------------------------------ Module : Graphics.UI.Editor.Composite--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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-----
− src/Graphics/UI/Editor/MakeEditor.hs
@@ -1,252 +0,0 @@---------------------------------------------------------------------------------group_Test--- Module : Graphics.UI.Editor.MakeEditor--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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)----
− src/Graphics/UI/Editor/Parameters.hs
@@ -1,178 +0,0 @@------------------------------------------------------------------------------------ Module : Graphics.UI.Editor.Parameters--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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- ]-
− src/Graphics/UI/Editor/Simple.hs
@@ -1,689 +0,0 @@------------------------------------------------------------------------------------ Module : Graphics.UI.Editor.Simple--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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]-
− src/Graphics/UI/Frame/Panes.hs
@@ -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 : <maintainer at leksah.org>--- 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
− src/Graphics/UI/Frame/ViewFrame.hs
@@ -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 : <maintainer at leksah.org>--- 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 "<span foreground=\"red\">" ++ text ++ "</span>"- 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 ("<b>" ++ group ++ "</b>")- 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
+ src/IDE/Command.hs view
@@ -0,0 +1,814 @@+{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Menu+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- 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 "<control>X"--} False+ ,AD "EditCopy" "_Copy" Nothing (Just "gtk-copy")+ editCopy [] {--Just "<control>C"--} False+ ,AD "EditPaste" "_Paste" Nothing (Just "gtk-paste")+ editPaste [] {--Just "<control>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 "<Ctrl>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 ()++
src/IDE/Completion.hs view
@@ -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 : <maintainer@leksah.org>@@ -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--
src/IDE/Core/State.hs view
@@ -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
src/IDE/Core/Types.hs view
@@ -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)
src/IDE/Debug.hs view
@@ -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 ()
− src/IDE/DescriptionPP.hs
@@ -1,96 +0,0 @@------------------------------------------------------------------------------------ Module : IDE.DescriptionPP--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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]--
− src/IDE/Exception.hs
@@ -1,95 +0,0 @@-{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable #-}------------------------------------------------------------------------------------ Module : IDE.Exception--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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<size> 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- )---}
− src/IDE/FileUtils.hs
@@ -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")----
src/IDE/Find.hs view
@@ -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
src/IDE/GUIHistory.hs view
@@ -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
− src/IDE/Group/Debugger.hs
@@ -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 ()
src/IDE/ImportTool.hs view
@@ -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 <jutaro@leksah.org>@@ -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
src/IDE/Keymap.hs view
@@ -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'
src/IDE/Leksah.hs view
@@ -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 ()
src/IDE/LogRef.hs view
@@ -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
− src/IDE/Menu.hs
@@ -1,833 +0,0 @@-{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-}------------------------------------------------------------------------------------ Module : IDE.Menu--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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 "<control>X"--} False- ,AD "EditCopy" "_Copy" Nothing (Just "gtk-copy")- editCopy [] {--Just "<control>C"--} False- ,AD "EditPaste" "_Paste" Nothing (Just "gtk-paste")- editPaste [] {--Just "<control>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 "<Ctrl>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 ()--
− src/IDE/Metainfo/GHCUtils.hs
@@ -1,182 +0,0 @@------------------------------------------------------------------------------------ Module : IDE.Metainfo.GHCUtils--- Copyright : 2007-2009 Jürgen Nicklisch-Franken--- License : GPL------ Maintainer : Jutaro <jutaro@leksah.org>--- 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.- }}-
− src/IDE/Metainfo/InterfaceCollector.hs
@@ -1,443 +0,0 @@-{-# OPTIONS_GHC -XScopedTypeVariables -XFlexibleContexts#-}------------------------------------------------------------------------------------ Module : IDE.Metainfo.InterfaceCollector--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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)-
src/IDE/Metainfo/Provider.hs view
@@ -1,539 +1,828 @@-{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-}------------------------------------------------------------------------------------ Module : IDE.Metainfo.Provider--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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 : <maintainer at leksah.org>+-- 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)
− src/IDE/Metainfo/Serializable.hs
@@ -1,212 +0,0 @@-{-# OPTIONS_GHC- -XScopedTypeVariables- -XStandaloneDeriving- -XDeriveDataTypeable #-}- ----------------------------------------------------------------------------------- Module : IDE.Metainfo.Serializable--- Copyright : 2007-2009 Jürgen Nicklisch-Franken--- License : GPL------ Maintainer : Jutaro <jutaro@leksah.org>--- 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-----
− src/IDE/Metainfo/SourceCollector.hs
@@ -1,517 +0,0 @@-{-# OPTIONS_GHC -XScopedTypeVariables #-}------------------------------------------------------------------------------------ Module : IDE.Metainfo.SourceCollector--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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"---
src/IDE/NotebookFlipper.hs view
@@ -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 : <maintainer@leksah.org>@@ -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
src/IDE/Package.hs view
@@ -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)
src/IDE/Pane/Breakpoints.hs view
@@ -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
− src/IDE/Pane/ClassHierarchy.hs
@@ -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 : <maintainer at leksah.org>--- 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"---}
src/IDE/Pane/Errors.hs view
@@ -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
src/IDE/Pane/Grep.hs view
@@ -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
src/IDE/Pane/Info.hs view
@@ -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
src/IDE/Pane/Log.hs view
@@ -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
src/IDE/Pane/Modules.hs view
@@ -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})
src/IDE/Pane/PackageEditor.hs view
@@ -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)
src/IDE/Pane/PackageFlags.hs view
@@ -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,[])
src/IDE/Pane/Preferences.hs view
@@ -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
src/IDE/Pane/References.hs view
@@ -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)
src/IDE/Pane/Search.hs view
@@ -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)
src/IDE/Pane/SourceBuffer.hs view
@@ -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
src/IDE/Pane/Trace.hs view
@@ -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
src/IDE/Pane/Variables.hs view
@@ -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
+ src/IDE/Pane/Workspace.hs view
@@ -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+
+ src/IDE/PaneGroups.hs view
@@ -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 ()++
− src/IDE/PrinterParser.hs
@@ -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
− src/IDE/SaveSession.hs
@@ -1,532 +0,0 @@-{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-}------------------------------------------------------------------------------------ Module : IDE.SaveSession--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : <maintainer at leksah.org>--- 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----
+ src/IDE/Session.hs view
@@ -0,0 +1,537 @@+{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Session+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- 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++++
src/IDE/SourceCandy.hs view
@@ -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)]
+ src/IDE/Statusbar.hs view
@@ -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
+ src/IDE/TextEditor.hs view
@@ -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+++
− src/IDE/Tool.hs
@@ -1,326 +0,0 @@-{-# OPTIONS_GHC -XRecordWildCards #-}------------------------------------------------------------------------------------ Module : IDE.Tool--- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken--- License : GPL------ Maintainer : <maintainer@leksah.org>--- 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<interactive>: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--
+ src/IDE/Utils/GUIUtils.hs view
@@ -0,0 +1,213 @@+-----------------------------------------------------------------------------+--+-- Module : IDE.Utils.GUIUtils+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- 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"+++
+ src/IDE/Utils/ServerConnection.hs view
@@ -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))++++
+ src/IDE/Workspaces.hs view
@@ -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)+
− src/LeksahEcho.hs
@@ -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-
− src/Main.hs
@@ -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-
− src/MyMissing.hs
@@ -1,79 +0,0 @@-{-# OPTIONS_GHC -XScopedTypeVariables #-}------------------------------------------------------------------------------------ Module : MyMissing--- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <info@leksah.org>--- 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