leksah 0.1.1 → 0.4
raw patch · 80 files changed
+13224/−9540 lines, 80 filesdep +gtksourceview2dep +regex-posixdep +utf8-stringdep −sourceviewdep ~Cabaldep ~basedep ~binarybinary-added
Dependencies added: gtksourceview2, regex-posix, utf8-string
Dependencies removed: sourceview
Dependency ranges changed: Cabal, base, binary, containers, directory, filepath, ghc, glib, gtk, mtl, old-time, parsec, pretty, process
Files
- Readme +6/−12
- data/Current.session +6/−3
- data/Default.candy +6/−4
- data/Default.keymap +43/−32
- data/Default.menu +39/−26
- data/Default.prefs +18/−8
- data/LICENSE +339/−0
- data/Module.template +21/−0
- data/ide_no_source.png binary
- data/ide_reexported.png binary
- data/ide_source.png binary
- doc/Todo.txt +0/−52
- doc/leksah_manual.pdf binary
- leksah.cabal +64/−62
- src/Control/Event.hs +86/−0
- src/DeepSeq.hs +60/−0
- src/Default.hs +42/−0
- src/Graphics/UI/Editor/Basics.hs +288/−0
- src/Graphics/UI/Editor/Composite.hs +453/−0
- src/Graphics/UI/Editor/MakeEditor.hs +241/−0
- src/Graphics/UI/Editor/Parameters.hs +178/−0
- src/Graphics/UI/Editor/Simple.hs +610/−0
- src/Graphics/UI/Frame/Panes.hs +137/−0
- src/Graphics/UI/Frame/ViewFrame.hs +656/−0
- src/IDE/BuildInfoEditor.hs +0/−315
- src/IDE/CallersPane.hs +0/−219
- src/IDE/Core/Exception.hs +0/−101
- src/IDE/Core/Panes.hs +0/−370
- src/IDE/Core/State.hs +279/−108
- src/IDE/Core/State.hs-boot +0/−20
- src/IDE/Core/Types.hs +185/−148
- src/IDE/DescriptionPP.hs +32/−31
- src/IDE/Exception.hs +95/−0
- src/IDE/FileUtils.hs +304/−0
- src/IDE/Find.hs +504/−0
- src/IDE/FindPane.hs +0/−361
- src/IDE/Framework/CompositeEditors.hs +0/−402
- src/IDE/Framework/EditorBasics.hs +0/−90
- src/IDE/Framework/MakeEditor.hs +0/−265
- src/IDE/Framework/Parameters.hs +0/−148
- src/IDE/Framework/SimpleEditors.hs +0/−561
- src/IDE/Framework/ViewFrame.hs +0/−697
- src/IDE/GUIHistory.hs +97/−0
- src/IDE/InfoPane.hs +0/−318
- src/IDE/Keymap.hs +5/−4
- src/IDE/Leksah.hs +183/−122
- src/IDE/Log.hs +0/−244
- src/IDE/Menu.hs +133/−68
- src/IDE/Metainfo/Info.hs +0/−391
- src/IDE/Metainfo/InterfaceCollector.hs +332/−328
- src/IDE/Metainfo/Provider.hs +504/−0
- src/IDE/Metainfo/SourceCollector.hs +135/−227
- src/IDE/ModulesPane.hs +0/−792
- src/IDE/Package.hs +341/−271
- src/IDE/PackageEditor.hs +0/−368
- src/IDE/PackageFlags.hs +0/−209
- src/IDE/Pane/Callers.hs +288/−0
- src/IDE/Pane/ClassHierarchy.hs +919/−0
- src/IDE/Pane/Info.hs +345/−0
- src/IDE/Pane/Log.hs +707/−0
- src/IDE/Pane/Modules.hs +1094/−0
- src/IDE/Pane/PackageEditor.hs +724/−0
- src/IDE/Pane/PackageFlags.hs +268/−0
- src/IDE/Pane/Preferences.hs +467/−0
- src/IDE/Pane/Search.hs +365/−0
- src/IDE/Pane/SourceBuffer.hs +1036/−0
- src/IDE/Preferences.hs +0/−350
- src/IDE/PrinterParser.hs +14/−7
- src/IDE/RecoverPanes.hs +0/−36
- src/IDE/ReplacePane.hs +0/−247
- src/IDE/SaveSession.hs +253/−69
- src/IDE/SourceCandy.hs +25/−45
- src/IDE/SourceEditor.hs +0/−894
- src/IDE/SpecialEditors.hs +210/−68
- src/IDE/ToolbarPane.hs +0/−94
- src/IDE/Utils/DeepSeq.hs +0/−60
- src/IDE/Utils/Default.hs +0/−40
- src/IDE/Utils/File.hs +0/−252
- src/Main.hs +19/−1
- src/MyMissing.hs +68/−0
Readme view
@@ -15,22 +15,16 @@ =================== Leksah currently requires:- GHC version 6.8.x- gtk >=0.9.12, glib >=0.9.12, sourceview >=0.9.12- which are part of gtk2hs and require GTk+ to be installed- binary >= 0.4.1+ GHC version 6.10.x+ gtk2hs 0.9.14+ other dependencies see cabal file Leksah works better if you install GHC and additional packages with sources -Personal words-==============-The development of an IDE is a big issue, so Leksah is intended to become a-community project and everyone is invited to contribute.--If you are a user or just test Leksah, I would appreciate to here from you.+If you are a user or just test Leksah, we would appreciate to here from you. -Please send questions and suggestions to me:-Jutaro <jnf@arcor.de>+Please send questions and suggestions to the developers+info(at)leksah(dot)org
data/Current.session view
@@ -1,6 +1,9 @@-Layout: VerticalP (TerminalP (Just TopP) 0) (HorizontalP (HorizontalP (TerminalP (Just TopP) 1) (TerminalP (Just BottomP) 0) 124) (TerminalP (Just BottomP) 0) 587) 769-Population: [(Just (FindSt FindState),[RightP,TopP,TopP]),(Just (LogSt LogState),[RightP,BottomP]),(Just (ModulesSt (ModulesState 348 (Package,True) (Nothing,Nothing))),[RightP,TopP,BottomP]),(Just (ToolbarSt ToolbarState),[RightP,TopP,TopP])]-Window size: (1400,1001)+Layout: VerticalP (TerminalP (Just LeftP) (-1)) (HorizontalP (TerminalP (Just BottomP) 0) (TerminalP (Just BottomP) 1) 376) 737+Population: [(Just (LogSt LogState),[RightP,BottomP]),(Just (ModulesSt (ModulesState 335 (Package,True) (Nothing,Nothing))),[RightP,TopP]),(Just (SearchSt (SearchState {searchString = "", searchScope = System, searchMode = Prefix {caseSense = False}})),[RightP,TopP])]+Window size: (1024,780) Active package: Nothing Active pane: Nothing+Toolbar visible:+ True+FindbarState: (True,FindState {entryStr = "", entryHist = [], replaceStr = "", replaceHist = [], caseSensitive = False, entireWord = False, wrapAround = True, backward = False, lineNr = 1})
data/Default.candy view
@@ -9,14 +9,17 @@ "&&" 0x2227 --LOGICAL AND "||" 0x2228 --LOGICAL OR "++" 0x2295 --CIRCLED PLUS-"::" 0x2237 --PROPORTION+--"::" 0x2551 Trimming --BAR+"::" 0x2237 Trimming --PROPORTION ".." 0x2025 --TWO DOT LEADER "^" 0x2191 --UPWARDS ARROW-"==" 0x2261 Trimming --IDENTICAL TO---"." 0x2218 --RING OPERATOR+"==" 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@@ -26,5 +29,4 @@ "gamma" 0x03b3 "delta" 0x03b4 "epsilon" 0x03b5-
data/Default.keymap view
@@ -5,49 +5,46 @@ --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>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>s -> FileSave "Saves the current buffer"+--<ctrl>x/<ctrl>s -> FileSave "Saves the current buffer" -<ctrl><shift>s -> FileSaveAs "Saves the current buffer as a new file"---<ctrl>x/<ctrl>w -> FileSaveAs "Saves the current buffer as a new file"+<ctrl><shift>s -> FileSaveAs "Saves the current buffer as a new file"+--<ctrl>x/<ctrl>w -> FileSaveAs "Saves the current buffer as a new file" -<ctrl>w -> FileClose "Closes the current buffer"---<ctrl>x/k -> FileClose "Closes the current buffer"+<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"+<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"+<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"+<shift><ctrl>y -> EditRedo "Redos the last user action"+--<ctrl>x/r -> EditRedo "Redos the last user action" ---Just "<ctrl>X" -> EditCut---Just "<ctrl>C" -> EditCopy---Just "<ctrl>V" -> EditPaste- -> EditDelete-<ctrl>a -> EditSelectAll "Select the whole text in the current buffer"+--<ctrl>x -> EditCut+--<ctrl>c -> EditCopy+--<ctrl>v -> EditPaste+ -> EditDelete+<ctrl>a -> EditSelectAll "Select the whole text in the current buffer" -F3 -> EditFind "Quits this program"-<ctrl>f -> EditFindNext "Search for a text string"+<ctrl>f -> EditFind "Search for a text string (Toggles the "+F3 -> EditFindNext "Find the next occurence of the text string" -<ctrl><shift>f -> EditFindPrevious- "Find the previous occurence of the text string"-<ctrl>r -> EditReplace+<shift>F3 -> EditFindPrevious "Find the previous occurence of the text string" -<ctrl>l -> EditGotoLine "Go to line with a known index"+<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"+<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"@@ -55,7 +52,7 @@ <alt><shift>Up -> ViewMoveUp "Move the current pane up" <alt><shift>Down -> ViewMoveDown "Move the current pane down" -<ctrl>2 -> ViewSplitHorizontal+<ctrl>2 -> ViewSplitHorizontal "Split the current pane in horizontal direction" <ctrl>3 -> ViewSplitVertical "Split the current pane in vertical direction"@@ -66,6 +63,7 @@ -> 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 @@ -75,3 +73,16 @@ <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
@@ -3,14 +3,14 @@ <menu name="_File" action="File"> <menuitem name="_New" action="FileNew" /> <menuitem name="_Open" action="FileOpen" />- <menuitem name="_Revert" action="FileRevert" />- <separator/> <menuitem name="_Save" action="FileSave" /> <menuitem name="Save_As" action="FileSaveAs" />- <separator/>+ <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">@@ -21,7 +21,6 @@ <menuitem name="_Copy" action="EditCopy" /> <menuitem name="_Paste" action="EditPaste" /> <menuitem name="_Delete" action="EditDelete" />- <separator/> <menuitem name="Select _All" action="EditSelectAll" /> <separator/> <menuitem name="_Find" action="EditFind" />@@ -29,70 +28,82 @@ <menuitem name="Find_Previous" action="EditFindPrevious" /> <menuitem name="_Goto Line" action="EditGotoLine" /> <separator/>- <menuitem name="Replace" action="EditReplace" />- <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" />+ <separator/> <menuitem name="Source Candy" action="EditCandy" />+ <menuitem name="Edit general Preferences" action="PrefsEdit" /> </menu> <menu name="_Package" action="Package"> <menuitem name="_New Package" action="NewPackage" /> <menuitem name="_Open Package" action="OpenPackage" />- <menuitem name="_Edit Package" action="EditPackage" /> <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" /> <separator/>- <menuitem name="Clea_n Package" action="CleanPackage" /> <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" />- <separator/> <menuitem name="_Build Documentation" action="DocPackage" />+ <separator/> <menuitem name="Open Documentation" action="OpenDocPackage" /> </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 _Classes" action="ShowClasses" />+ </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="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="Split H_orizontal" action="ViewSplitHorizontal" />- <menuitem name="Split V_ertical" action="ViewSplitVertical" />- <menuitem name="_Collapse" action="ViewCollapse" />- <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="Close Pane" action="ViewClosePane" />- <separator/> <menuitem name="Clear Log" action="ClearLog" />- <menuitem name="Show Toolbar" action="ShowToolbar" />- <menuitem name="Show Find" action="ShowFind" />- <menuitem name="Show Replace" action="ShowReplace" />- <menuitem name="Show _Modules" action="ShowModules" />+ <menuitem name="Toggle Toolbar" action="ToggleToolbar" /> </menu> <menu name="_Help" action="Help">- <menuitem name="Edit Preferences" action="PrefsEdit" /> <menuitem name="_About" action="HelpAbout" />- <menuitem name="Debug" action="HelpDebug" />- </menu>+ </menu> </menubar>- <toolbar name="toolbar1">+ <toolbar name="toolbar"> <placeholder name="FileToolItems"> <separator/> <toolitem name="New" action="FileNew"/>@@ -108,8 +119,6 @@ <separator/> <toolitem name="Find" action="EditFind"/> </placeholder>- </toolbar>- <toolbar name="toolbar2"> <placeholder name="BuildToolItems"> <separator/> <toolitem name="Configure" action="ConfigPackage"/>@@ -118,6 +127,10 @@ <toolitem name="Next Error" action="NextError"/> <toolitem name="Previous Error" action="PreviousError"/> <separator/>- </placeholder>+ <separator/>+ <toolitem name="Back" action="ViewHistoryBack"/>+ <toolitem name="Forward" action="ViewHistoryForth"/>+ <separator/>+ </placeholder> </toolbar> </ui>
data/Default.prefs view
@@ -1,26 +1,36 @@- Show line numbers: True --(True/False)-TextView Font: ""-Right margin: 96+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 Name of the keymap: Default --The name of a keymap file in a config dir-LogView Font: ""+Editor Style: ""+LogView Font: "Sans 10" Window default size: (800,800)- --Default size of the main leksah window specified as pair (int,int)+ --Default size of the main ide window specified as pair (int,int) Browser: "firefox"-Standard source editor path:- LeftTop+Standard source pane path:+ [LeftP]+Standard log pane path:+ [RightP,BottomP]+Standard modules pane path:+ [RightP,TopP] Paths under which haskell sources for packages may be found: [] Packages which are excluded from the modules pane:- [Dependency "ghc" AnyVersion]+ [Dependency (PackageName "ghc") AnyVersion]+Update metadata after every build:+ True+Update metadata at startup:+ True
+ data/LICENSE view
@@ -0,0 +1,339 @@+ GNU GENERAL PUBLIC LICENSE+ Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users. This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it. (Some other Free Software Foundation software is covered by+the GNU Lesser General Public License instead.) You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++ To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have. You must make sure that they, too, receive or can get the+source code. And you must show them these terms so they know their+rights.++ We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++ Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software. If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++ Finally, any free program is threatened constantly by software+patents. We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary. To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++ The precise terms and conditions for copying, distribution and+modification follow.++ GNU GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License. The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language. (Hereinafter, translation is included without limitation in+the term "modification".) Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++ 1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++ 2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) You must cause the modified files to carry prominent notices+ stating that you changed the files and the date of any change.++ b) You must cause any work that you distribute or publish, that in+ whole or in part contains or is derived from the Program or any+ part thereof, to be licensed as a whole at no charge to all third+ parties under the terms of this License.++ c) If the modified program normally reads commands interactively+ when run, you must cause it, when started running for such+ interactive use in the most ordinary way, to print or display an+ announcement including an appropriate copyright notice and a+ notice that there is no warranty (or else, saying that you provide+ a warranty) and that users may redistribute the program under+ these conditions, and telling the user how to view a copy of this+ License. (Exception: if the Program itself is interactive but+ does not normally print such an announcement, your work based on+ the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++ a) Accompany it with the complete corresponding machine-readable+ source code, which must be distributed under the terms of Sections+ 1 and 2 above on a medium customarily used for software interchange; or,++ b) Accompany it with a written offer, valid for at least three+ years, to give any third party, for a charge no more than your+ cost of physically performing source distribution, a complete+ machine-readable copy of the corresponding source code, to be+ distributed under the terms of Sections 1 and 2 above on a medium+ customarily used for software interchange; or,++ c) Accompany it with the information you received as to the offer+ to distribute corresponding source code. (This alternative is+ allowed only for noncommercial distribution and only if you+ received the program in object code or executable form with such+ an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it. For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable. However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++ 4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License. Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++ 5. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Program or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++ 6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++ 7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all. For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded. In such case, this License incorporates+the limitation as if written in the body of this License.++ 9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number. If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation. If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++ 10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission. For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this. Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++ NO WARRANTY++ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along+ with this program; if not, write to the Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++ Gnomovision version 69, Copyright (C) year name of author+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the program+ `Gnomovision' (which makes passes at compilers) written by James Hacker.++ <signature of Ty Coon>, 1 April 1989+ Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs. If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License.
+ data/Module.template view
@@ -0,0 +1,21 @@+-----------------------------------------------------------------------------+--+-- Module : @ModuleName@+-- Copyright : @Copyright@+-- License : @License@+--+-- Maintainer : @Maintainer@+-- Stability : @Stability@+-- Portability : @Portability@+--+-- |+--+-----------------------------------------------------------------------------++module @ModuleName@ (+++) where+++
− data/ide_no_source.png
binary file changed (154 → absent bytes)
+ data/ide_reexported.png view
binary file changed (absent → 353 bytes)
data/ide_source.png view
binary file changed (353 → 154 bytes)
− doc/Todo.txt
@@ -1,52 +0,0 @@-Version 0.1--Development--ok - 1 page Documentation-ok - Add next and previous error (and open package) to toolbar-start - Populate Keystrokes-ok - First start feature--Bugs- - Dynamic exceptions are not caught- - Double log error- - Slow refresh in Modules pane on 6.8.2- - Candy bug (e.g. exists)- - Activate Pane switching- - GTK Warnings- - Revert on close (2 times even)- - <ctrl><alt>r does not work for PackageRun- - No horizontal centering for errors in source editor- - (Windows only) Gtk runs out of memory and does not displayx correctly ???- _win32_scaled_font_set_world_transform: Für diesen Befehl ist nicht genügend Speicher verfügbar.- Doesn't happen with Raleigh Theme in Gtk2Hs\etc\gtk-2.0- - Changed red color not preserved when moving panes- - Collector: No reexported declarations.- - Collector: Getting Instances types right- - empty lines in shift left/right--ok - Sort field in Info Pane doesn't work- - Sort order of interfaces in module pane?- = Reverse order source collector bug--Version 0.x-- - Search in interface tree- - Working Cabal Editor with Configurations (etc..) "Change"- - Completion- - Search- - Class Hierarchy pane- - Import helper- - Editor; Highliting according to file type- - Editor Templates for new files- - Properties of single editor (no highlight, no candy,...)- - Haddock (deferr to Haddock 2.0)- - Generic record editor- - Using find in sources without location- - Build only one time - Cancel build- - Source collector only one time - Make it run in background- - Preferences embedden- - Uses Pane---
doc/leksah_manual.pdf view
binary file changed (535399 → 1364761 bytes)
leksah.cabal view
@@ -1,72 +1,74 @@ name: leksah-version: 0.1.1-cabal-version: >= 1.2+version: 0.4+cabal-version: >=1.4 build-type: Custom license: GPL license-file: LICENSE-copyright: 2007 Juergen Nicklisch-Franken-maintainer: Juergen Nicklisch-Franken+copyright: 2007-2009 Jürgen Nicklisch-Franken+maintainer: Jutaro <jutaro@leksah.org>+build-depends: regex-posix >=0.72.0.3, utf8-string >=0.3.1.1,+ bytestring >=0.9.0.1, binary >=0.4.4, ghc >=6.10.1, glib >=0.10,+ gtk >=0.10, directory >=1.0.0.2, pretty >=1.0.1.0,+ containers >=0.2.0.0, process >=1.0.1.0, mtl >=1.1.0.2,+ parsec >=2.1.0.1, Cabal >=1.6.0.1, filepath >=1.1.0.1,+ base >=4.0.0.0, old-time >=1.0.0.1, gtksourceview2 >=0.10.0 stability: provisional-homepage:-package-url: http://code.haskell.org/leksah+homepage: http://www.leksah.org+package-url: http://code.haskell.org/leksah+bug-reports: synopsis: Haskell IDE written in Haskell description: An Integrated Development Environment for Haskell written in Haskell.-category: Development-author: Jutaro (Juergen Nicklisch-Franken)+category: Development, IDE, Editor+author: Jutaro+tested-with: GHC ==6.10.1 data-files: data/Current.session data/Default.candy- data/Default.keymap data/Default.prefs- data/Emacs.keymap data/Default.menu- data/ide_class.png data/ide_configure.png- data/ide_data.png data/ide_error_next.png- data/ide_error_prev.png data/ide_field.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_no_source.png- data/ide_other.png data/ide_rule.png- data/ide_run.png data/ide_slot.png- data/ide_source.png data/ide_type.png- data/leksah.png doc/leksah_manual.pdf- doc/Todo.txt Readme+ data/Default.keymap data/Default.prefs data/Emacs.keymap+ data/Default.menu data/ide_class.png data/ide_configure.png+ data/ide_data.png data/ide_error_next.png data/ide_error_prev.png+ data/ide_field.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_reexported.png data/ide_other.png+ data/ide_rule.png data/ide_run.png data/ide_slot.png+ data/ide_source.png data/ide_type.png data/leksah.png+ doc/leksah_manual.pdf Readme LICENSE data/LICENSE+ data/Module.template+data-dir: "" extra-source-files: Setup.lhs extra-tmp-files:-executable leksah- build-depends: base >=2.1, filepath >=1.0, Cabal >=1.1.6.2,- parsec >=2.0, mtl >=1.0.1, process >=1.0, old-time >=1.0,- containers >=0.1, pretty >=1.0, directory >=1.0, gtk >=0.9.12,- glib >=0.9.12, sourceview >=0.9.12, ghc >= 6.8, binary >= 0.4.1,- bytestring >= 0.9.0.1- main-is: Main.hs- buildable: True- build-tools:- cpp-options:- cc-options:- ld-options:- pkgconfig-depends:- frameworks:- c-sources:- extensions:- extra-libraries:- extra-lib-dirs:- includes:- install-includes:- include-dirs:- hs-source-dirs: src- other-modules: IDE.Utils.Default- IDE.BuildInfoEditor IDE.CallersPane- IDE.DescriptionPP IDE.Utils.File IDE.FindPane IDE.Leksah IDE.Metainfo.Info- IDE.InfoPane IDE.Metainfo.InterfaceCollector IDE.Keymap- IDE.Log IDE.Menu IDE.ModulesPane IDE.Package IDE.PackageEditor- IDE.PackageFlags IDE.Preferences IDE.PrinterParser- IDE.ReplacePane IDE.RecoverPanes IDE.SaveSession IDE.SourceCandy- IDE.Metainfo.SourceCollector IDE.SourceEditor IDE.SpecialEditors- IDE.ToolbarPane IDE.Framework.ViewFrame IDE.Core.Exception IDE.Core.Panes- IDE.Core.State IDE.Core.Types IDE.Utils.DeepSeq- IDE.Framework.CompositeEditors IDE.Framework.EditorBasics IDE.Framework.MakeEditor- IDE.Framework.Parameters IDE.Framework.SimpleEditors- ghc-prof-options: -prof -auto-all- ghc-shared-options:- ghc-options: -cpp -D__GHC__=680 -D_Newgtk -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -O2- hugs-options:- nhc98-options:- jhc-options:++executable: leksah+main-is: Main.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: MyMissing DeepSeq Default Control.Event+ Graphics.UI.Editor.Parameters Graphics.UI.Editor.Composite+ Graphics.UI.Editor.Basics Graphics.UI.Editor.MakeEditor+ Graphics.UI.Editor.Simple Graphics.UI.Frame.ViewFrame+ Graphics.UI.Frame.Panes IDE.Leksah IDE.PrinterParser IDE.FileUtils+ IDE.Menu IDE.DescriptionPP IDE.Find IDE.SourceCandy IDE.Package+ IDE.SpecialEditors IDE.GUIHistory IDE.SaveSession IDE.Keymap+ IDE.Exception IDE.Pane.Modules IDE.Pane.PackageEditor IDE.Pane.Log+ IDE.Pane.Search IDE.Pane.Info IDE.Pane.SourceBuffer+ IDE.Pane.Preferences IDE.Pane.Callers IDE.Pane.ClassHierarchy+ IDE.Pane.PackageFlags IDE.Metainfo.SourceCollector+ IDE.Metainfo.Provider IDE.Metainfo.InterfaceCollector+ IDE.Core.Types IDE.Core.State+ghc-prof-options: -prof -auto-all+ghc-shared-options: -prof -auto-all+ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -O2+hugs-options:+nhc98-options:+jhc-options:
+ src/Control/Event.hs view
@@ -0,0 +1,86 @@+{-# OPTIONS_GHC -XMultiParamTypeClasses -XFunctionalDependencies #-}+-----------------------------------------------------------------------------+--+-- Module : Control.Event+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- 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+
+ src/DeepSeq.hs view
@@ -0,0 +1,60 @@+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 view
@@ -0,0 +1,42 @@++-----------------------------------------------------------------------------+--+-- Module : Default+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org>+-- Stability : experimental+-- 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] where+ getDefault = []++instance Default (Maybe alpha) where+ getDefault = Nothing++instance Default Bool where+ getDefault = True
+ src/Graphics/UI/Editor/Basics.hs view
@@ -0,0 +1,288 @@+{-# OPTIONS_GHC -XMultiParamTypeClasses -XScopedTypeVariables #-}++-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.Basics+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- 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 Debug.Trace++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 view
@@ -0,0 +1,453 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.Composite+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | Module for making composite editors+--+-----------------------------------------------------------------------------------++module Graphics.UI.Editor.Composite (+ maybeEditor+, pairEditor+, splitEditor+, eitherOrEditor+, multisetEditor+, ColumnDescr(..)+) where++import Graphics.UI.Gtk+import Graphics.UI.Gtk.ModelView as New+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++--+-- | 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++--+-- | 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+ (childWidget,inj2,_) <- getChildEditor childRef childEdit childParams cNoti+ widgetShowAll childWidget+ inj2 val+ else do+ (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 label2 parameters noti1+ le@(leftFrame,inj2,ext2) <- leftEditor leftParams noti2+ re@(rightFrame,inj3,ext3) <- rightEditor 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 -> [New.cellText := show row]))])+-- and a nontrivial:+-- [("Package",\(Dependency str _) -> [New.cellText := str])+-- ,("Version",\(Dependency _ vers) -> [New.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) =>+ ColumnDescr alpha -> (Editor alpha, Parameters) -> Editor [alpha]+multisetEditor (ColumnDescr showHeaders columnsDD) (singleEditor, sParams)+ parameters notifier = do+ coreRef <- newIORef Nothing+ cnoti <- emptyNotifier+ mapM_ (propagateEvent notifier [cnoti]) allGUIEvents+ mkEditor+ (\widget v -> 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 <- New.listStoreNew ([]:: [alpha])+ list <- New.treeViewNewWithModel listStore+ let minSize = getParameter paraMinSize parameters+ uncurry (widgetSetSizeRequest list) minSize+ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw list+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ sel <- New.treeViewGetSelection list+ New.treeSelectionSetMode sel SelectionSingle+ mapM_ (\(str,func) -> do+ col <- New.treeViewColumnNew+ New.treeViewColumnSetTitle col str+ New.treeViewColumnSetResizable col True+ New.treeViewAppendColumn list col+ renderer <- New.cellRendererTextNew+ New.cellLayoutPackStart col renderer True+ New.cellLayoutSetAttributes col renderer listStore func+ ) columnsDD+ New.treeViewSetHeadersVisible list showHeaders+ sel `New.onSelectionChanged` selectionHandler sel listStore injS+ boxPackStart box sw PackGrow 0+ boxPackStart box buttonBox PackNatural 0+ boxPackStart box frameS PackNatural 0+ activateEvent (castToWidget list) notifier Nothing FocusOut+ containerAdd widget box+ New.listStoreClear listStore+ mapM_ (New.listStoreAppend listStore) v+ addButton `onClicked` do+ mbv <- extS+ case mbv of+ Just v -> do+ seq <- New.listStoreAppend listStore v+ New.treeSelectionSelectPath sel [seq]+ mbCol <- treeViewGetColumn list 0+ case mbCol of+ Nothing -> return ()+ Just col -> New.treeViewScrollToCell list [seq] col Nothing+ return ()+ Nothing -> return ()+ removeButton `onClicked` do+ mbi <- New.treeSelectionGetSelected sel+ case mbi of+ Nothing -> return ()+ Just iter -> do+ [i] <- New.treeModelGetPath listStore iter+ New.listStoreRemove listStore i+ writeIORef coreRef (Just listStore)+ injS getDefault+ Just listStore -> do+ New.listStoreClear listStore+ mapM_ (New.listStoreAppend listStore) v)+ (do core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just listStore -> do+ v <- listStoreGetValues listStore+ return (Just v))+ (paraMinSize <<<- ParaMinSize (-1,-1) $ parameters)+ notifier+ where+ listStoreGetValues :: New.ListStore a -> IO [a]+ listStoreGetValues listStore = New.treeModelGetIterFirst listStore >>= getTail+ where getTail mbi = case mbi of+ Nothing -> return []+ Just iter -> do+ [i] <- New.treeModelGetPath listStore iter+ v <- New.listStoreGetValue listStore i+ mbi2 <- New.treeModelIterNext listStore iter+ rest <- getTail mbi2+ return (v : rest)+ selectionHandler :: New.TreeSelection -> New.ListStore a -> Injector a -> IO ()+ selectionHandler sel listStore inj = do+ ts <- New.treeSelectionGetSelected sel+ case ts of+ Nothing -> return ()+ Just iter -> do+ [i] <- New.treeModelGetPath listStore iter+ v <- New.listStoreGetValue listStore i+ inj v+ return ()+
+ src/Graphics/UI/Editor/MakeEditor.hs view
@@ -0,0 +1,241 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.MakeEditor+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- 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 Graphics.UI.Gtk.ModelView as New+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++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 <- New.listStoreNew (map fst pairList)+ listView <- New.treeViewNewWithModel listStore+ widgetSetSizeRequest listView 100 (-1)+ sel <- New.treeViewGetSelection listView+ New.treeSelectionSetMode sel SelectionSingle+ renderer <- New.cellRendererTextNew+ col <- New.treeViewColumnNew+ New.treeViewAppendColumn listView col+ New.cellLayoutPackStart col renderer True+ New.cellLayoutSetAttributes col renderer listStore $ \row ->+ [ New.cellText := row ]+ New.treeViewSetHeadersVisible listView False+ New.treeSelectionSelectPath sel [0]+ notebookSetCurrentPage nb 0+ sel `New.onSelectionChanged` (do+ selections <- New.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 view
@@ -0,0 +1,178 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.Parameters+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- 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 view
@@ -0,0 +1,610 @@+-----------------------------------------------------------------------------+--+-- Module : Graphics.UI.Editor.Simple+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | Module for making simple editors+--+-----------------------------------------------------------------------------------++module Graphics.UI.Editor.Simple (+ boolEditor+, boolEditor2+, clickEditor+, stringEditor+, multilineStringEditor+, intEditor+, genericEditor+, fontEditor+, comboSelectionEditor+, staticListEditor+, multiselectionEditor+, fileEditor+, otherEditor+, imageEditor++, okCancelFields+) where++import Graphics.UI.Gtk+import qualified Graphics.UI.Gtk as Gtk+import Graphics.UI.Gtk.ModelView as New+import IDE.Core.State (MessageLevel(..))+import IDE.Core.State (sysMessage)+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++-- ------------------------------------------------------------+-- * 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+ sysMessage Normal $"Generic editor no parse for " ++ s ++ " " ++ show e+ return Nothing)+ return (wid,ginj,gext)++--+-- | Editor for a boolean value in 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 :: (Show beta, Eq beta) => [beta] -> Editor beta+comboSelectionEditor list parameters notifier = do+ coreRef <- newIORef Nothing+ mkEditor+ (\widget obj -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ (combo,ls) <- New.comboBoxNewText show list+ widgetSetName combo (getParameter paraName parameters)+ mapM_ (activateEvent (castToWidget combo) notifier Nothing)+ [FocusOut,FocusIn]+ New.comboBoxSetActive combo 1+ containerAdd widget combo+ let ind = elemIndex obj list+ case ind of+ Just i -> New.comboBoxSetActive combo i+ Nothing -> return ()+ writeIORef coreRef (Just combo)+ Just combo -> do+ let ind = elemIndex obj list+ case ind of+ Just i -> New.comboBoxSetActive combo i+ Nothing -> return ())+ (do core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just combo -> do+ ind <- New.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 <- New.listStoreNew ([]:: [alpha])+ listView <- New.treeViewNewWithModel listStore+ widgetSetName listView (getParameter paraName parameters)+ mapM_ (activateEvent (castToWidget listView) notifier Nothing)+ [FocusOut,FocusIn]+ sel <- New.treeViewGetSelection listView+ New.treeSelectionSetMode sel SelectionMultiple+ renderer <- New.cellRendererTextNew+ col <- New.treeViewColumnNew+ New.treeViewAppendColumn listView col+ New.cellLayoutPackStart col renderer True+ New.cellLayoutSetAttributes col renderer listStore+ $ \row -> [ New.cellText := show row ]+ New.treeViewSetHeadersVisible listView False+ New.listStoreClear listStore+ mapM_ (New.listStoreAppend listStore) objs+ containerAdd widget listView+ New.treeSelectionUnselectAll sel+ --let inds = catMaybes $map (\obj -> elemIndex obj list) objs+ --mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds+ writeIORef coreRef (Just (listView,listStore))+ Just (listView,listStore) -> do+ New.listStoreClear listStore+ mapM_ (New.listStoreAppend listStore) objs)+ (do core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just (listView,listStore) -> do+ sel <- New.treeViewGetSelection listView+ treePath <- New.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++staticListEditor :: (Show beta, Eq beta) => [beta] -> Editor [beta]+staticListEditor list parameters notifier = do+ coreRef <- newIORef Nothing+ mkEditor+ (\widget objs -> do+ core <- readIORef coreRef+ case core of+ Nothing -> do+ listStore <- New.listStoreNew ([]:: [alpha])+ listView <- New.treeViewNewWithModel listStore+ widgetSetName listView (getParameter paraName parameters)+ mapM_ (activateEvent (castToWidget listView) notifier Nothing)+ [FocusOut,FocusIn]+ sel <- New.treeViewGetSelection listView+ New.treeSelectionSetMode sel+ (case getParameter paraMultiSel parameters of+ True -> SelectionMultiple+ False -> SelectionSingle)+ renderer <- New.cellRendererTextNew+ col <- New.treeViewColumnNew+ New.treeViewAppendColumn listView col+ New.cellLayoutPackStart col renderer True+ New.cellLayoutSetAttributes col renderer listStore+ $ \row -> [ New.cellText := show row ]+ New.treeViewSetHeadersVisible listView False+ New.listStoreClear listStore+ mapM_ (New.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+ New.treeSelectionUnselectAll sel+ let inds = catMaybes $map (\obj -> elemIndex obj list) objs+ mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds+ writeIORef coreRef (Just listView)+ Just listView -> do+ sel <- New.treeViewGetSelection listView+ New.treeSelectionUnselectAll sel+ let inds = catMaybes $map (\obj -> elemIndex obj list) objs+ mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds)+ (do core <- readIORef coreRef+ case core of+ Nothing -> return Nothing+ Just listView -> do+ sel <- New.treeViewGetSelection listView+ treePath <- New.treeSelectionGetSelectedRows sel+ return (Just (map (\[i] -> list !! i) treePath)))+ 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 view
@@ -0,0 +1,137 @@+{-# OPTIONS_GHC+ -XExistentialQuantification+ -XMultiParamTypeClasses+ -XFunctionalDependencies #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Core.Panes+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | The basic definitions for all panes+--+-------------------------------------------------------------------------------++module Graphics.UI.Frame.Panes (++-- * Panes and pane layout+ PaneMonad(..)+, Pane(..)+, IDEPane(..)+, RecoverablePane(..)+, PaneDirection(..)+, PanePath+, PaneLayout(..)+, PaneName+, Connection(..)+, Connections+, StandardPath+, 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 = [PaneDirection]++--+-- | The relative direction to a pane from the parent+--+data PaneDirection = TopP | BottomP | LeftP | RightP+ deriving (Eq,Show,Read)+ +--+-- | Description of a window layout+--+data PaneLayout = HorizontalP PaneLayout PaneLayout Int+ | VerticalP PaneLayout PaneLayout Int+ | TerminalP (Maybe PaneDirection) 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 ()+ makeActive _ = return ()+ close :: alpha -> beta ()++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+++class MonadIO delta => PaneMonad delta where+ getWindowSt :: delta Window+ getUIManagerSt :: delta UIManager++ getPanesSt :: delta (Map PaneName (IDEPane delta))+ setPanesSt :: Map PaneName (IDEPane delta) -> delta ()++ getPaneMapSt :: delta (Map PaneName (PanePath, Connections))+ setPaneMapSt :: Map PaneName (PanePath, Connections) -> delta ()++ getActivePaneSt :: delta (Maybe (PaneName, Connections))+ setActivePaneSt :: Maybe (PaneName, Connections) -> delta ()++ getLayoutSt :: delta PaneLayout+ setLayoutSt :: PaneLayout -> delta ()++ runInIO :: forall beta. (beta -> delta()) -> delta (beta -> IO ())+++--+-- | 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)+++
+ src/Graphics/UI/Frame/ViewFrame.hs view
@@ -0,0 +1,656 @@+{-# OPTIONS_GHC #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Core.ViewFrame+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+--+-- | Splittable panes containing notebooks with any widgets+--+---------------------------------------------------------------------------------++module Graphics.UI.Frame.ViewFrame (+ removePaneAdmin+, addPaneAdmin+, notebookInsertOrdered++-- * Convenience methods for accesing Pane state+, posTypeToPaneDirection+, paneDirectionToPosType+, paneFromName+, mbPaneFromName+, guiPropertiesFromName++-- * View Actions+, viewMove+, viewSplitHorizontal+, viewSplitVertical+, viewSplit+, viewSplit'+, handleNotebookSwitch+, viewCollapse+, viewCollapse'+, viewTabsPos+, viewSwitchTabs++-- * View Queries+, getStandardPanePath+, getActivePanePath+, getActivePanePathOrStandard+, figureOutPaneName+, getNotebook+, getPaned+, getActiveNotebook+, getPane+, getPanes++-- * View Actions+, bringPaneToFront+, 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.Map (Map)+import Data.List+import Data.Maybe+#if __GLASGOW_HASKELL__ >= 609+import Control.OldException(evaluate,catch)+#else+import Control.Exception(evaluate,catch)+#endif+import Prelude hiding(catch)+import Data.Unique+import Data.Typeable++import Graphics.UI.Frame.Panes+import Graphics.UI.Editor.Parameters++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) (show (hashUnique unique))+ 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 :: (NotebookClass self, WidgetClass child) + => self + -> child -- child - the Widget to use as the contents of the page.+ -> String -- tabLabel - the label for the page+ -> Maybe Label+ -> IO ()+notebookInsertOrdered nb widget label mbTabLabel = do+ menuLabel <- labelNew (Just label)+ tabLabel <- case mbTabLabel of+ Nothing -> labelNew (Just label)+ Just l -> return l+ numPages <- notebookGetNPages nb+ mbWidgets <- mapM (notebookGetNthPage nb) [0 .. (numPages-1)]+ widgets <- catch (evaluate (map fromJust mbWidgets))+ (\e -> error "ViewFrame.notebookInsertOrdered: no widget")+ mbLabels <- mapM (notebookGetTabLabelText nb) widgets+ labels <- catch (evaluate (map fromJust mbLabels))+ (\e -> error "ViewFrame.notebookInsertOrdered: no label")+ let pos = case findIndex (\s -> s > label) labels of+ Just i -> i+ Nothing -> -1+ realPos <- notebookInsertPageMenu nb widget tabLabel menuLabel pos+ notebookSetCurrentPage nb realPos++++-- | Constructs a unique pane name, which is an index and a string+figureOutPaneName :: Map String (IDEPane alpha) -> String -> Int -> (Int,String)+figureOutPaneName bufs bn ind =+ let ind = foldr (\(PaneC buf) ind ->+ if primPaneName buf == bn+ then max ind ((getAddedIndex buf) + 1)+ else ind)+ 0 (Map.elems bufs)+ in if ind == 0+ then (0,bn)+ else (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 $"Cant'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 -> viewSplit' panePath dir++viewSplit' :: PaneMonad alpha => PanePath -> Direction -> alpha ()+viewSplit' panePath dir = do+ activeNotebook <- getNotebook panePath++ mbPD <- do+ mbParent <- liftIO $ widgetGetParent activeNotebook+ case mbParent of+ Nothing -> return Nothing+ Just parent -> do+ (nb,paneDir) <- liftIO $ do+ --trace ("Pane path " ++ show panePath) return ()+ newpane <- case dir of+ Horizontal -> do h <- vPanedNew+ return (castToPaned h)+ Vertical -> do v <- hPanedNew+ return (castToPaned v)+ let (name,altname,paneDir) = case dir of+ Horizontal -> ("top","bottom",TopP)+ Vertical -> ("left","right",LeftP)+ rName <- widgetGetName activeNotebook+ widgetSetName newpane rName+ nb <- newNotebook+ widgetSetName nb altname+ panedPack2 newpane nb True True+ containerRemove (castToContainer parent) activeNotebook+ widgetSetName activeNotebook name+ panedPack1 newpane activeNotebook True True+ if not (null panePath)+ then+ if (last panePath == TopP || last panePath == LeftP)+ then panedPack1 (castToPaned parent) newpane True True+ else panedPack2 (castToPaned parent) newpane True True+ else do+ boxPackStart (castToBox parent) newpane PackGrow 0+ boxReorderChild (castToVBox parent) newpane 2+ widgetShowAll newpane+ widgetGrabFocus activeNotebook+ return (nb,paneDir)+ handleFunc <- runInIO (handleNotebookSwitch nb)+ liftIO $ afterSwitchPage nb handleFunc+ return (Just (paneDir,dir))+ case mbPD of+ Just (paneDir,dir) -> do+ let toPane = panePath ++ [paneDir]+ adjustPane panePath toPane+ adjustLayoutForSplit dir panePath+ Nothing -> return ()++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+ mbPane <- findPaneFor w+ case mbPane of+ Nothing -> return ()+ Just (PaneC p) -> makeActive p+ where+ findPaneFor :: PaneMonad beta => Widget -> beta (Maybe (IDEPane beta))+ findPaneFor w = do+ panes' <- getPanesSt+ n1 <- liftIO $ widgetGetName w+ 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+ layout1 <- getLayoutSt+ let newPanePath = reverse $tail $reverse panePath+ let mbOtherSidePath = otherSide panePath+ case mbOtherSidePath of+ Nothing -> return ()+ Just otherSidePath ->+ let sp1 = getSubpath panePath layout1+ sp2 = getSubpath 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+ let paneNamesToMove = map (\(w,(p,_)) -> w)+ $filter (\(w,(p,_)) -> p == otherSidePath)+ $Map.toList paneMap+ panesToMove <- mapM paneFromName paneNamesToMove+ mapM_ (\(PaneC p) -> move panePath p) panesToMove+ liftIO $ do+ mbParent <- widgetGetParent activeNotebook+ case mbParent of+ Nothing -> error "collapse: no parent"+ Just parent -> do+ mbGrandparent <- widgetGetParent parent+ case mbGrandparent of+ Nothing -> error "collapse: no grandparent"+ Just grandparent -> do+ containerRemove (castToContainer grandparent) parent+ containerRemove (castToContainer parent) activeNotebook+ if length panePath > 1+ then do+ let dir = last newPanePath+ if (dir == TopP || dir == LeftP)+ then panedPack1 (castToPaned grandparent)+ activeNotebook True True+ else panedPack2 (castToPaned grandparent)+ activeNotebook True True+ widgetSetName activeNotebook $paneDirectionToWidgetName dir+ else do+ boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0+ boxReorderChild (castToVBox grandparent) activeNotebook 2+ widgetSetName activeNotebook "root"+ adjustLayoutForCollapse newPanePath+ adjustPane panePath newPanePath+ --adjustPane otherSidePath newPanePath++--+-- | Moves the given Pane to the given path+--+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+ liftIO $ do+ mbNum <- notebookPageNum fromNB child+ case mbNum of+ Nothing -> return ()+ Just pn -> do+ mbText <- notebookGetTabLabelText fromNB child+ mbLabel <- notebookGetTabLabel fromNB child+ case (mbText,mbLabel) of+ (Just text, Just label) -> do+ notebookRemovePage fromNB pn+ notebookInsertOrdered toNB child text (Just (castToLabel label))+ _ -> return ()+ let paneMap1 = Map.delete (paneName idew) paneMap+ setPaneMapSt $ Map.insert (paneName idew) (toPane,cid) paneMap1++--+-- | 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 reversedPath = reverse panePath+ oppositeDir = otherDirection direction+ cutPath = dropWhile (\d -> d /= oppositeDir) reversedPath+ in if null cutPath+ then Nothing+ else let basePath = reverse (direction : tail cutPath)+ layoutP = layoutFromPath basePath layout+ in Just $basePath ++ findAppropriate layoutP oppositeDir++findAppropriate :: PaneLayout -> PaneDirection -> PanePath+findAppropriate (TerminalP _ _) _ = []+findAppropriate (HorizontalP t b _) LeftP = TopP : findAppropriate t LeftP+findAppropriate (HorizontalP t b _) RightP = TopP : findAppropriate t RightP+findAppropriate (HorizontalP t b _) BottomP = BottomP : findAppropriate b BottomP+findAppropriate (HorizontalP t b _) TopP = TopP : findAppropriate b TopP+findAppropriate (VerticalP l r _) LeftP = LeftP : findAppropriate l LeftP+findAppropriate (VerticalP l r _) RightP = RightP : findAppropriate r RightP+findAppropriate (VerticalP l r _) BottomP = LeftP : findAppropriate l BottomP+findAppropriate (VerticalP l r _) TopP = 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+ mbParent <- widgetGetParent tv+ case mbParent of+ Just parent -> do+ let nb = castToNotebook parent+ n <- notebookGetNPages nb+ r <- filterM (\i -> do+ mbp <- notebookGetNthPage nb i+ case mbp of+ Nothing -> return False+ Just p -> do+ mbs <- notebookGetTabLabelText nb p+ case mbs of+ Nothing -> return False+ Just s -> return (s == paneName pane))+ [0..(n-1)]+ case r of+ [i] -> notebookSetCurrentPage nb i+ otherwise -> return ()+ Nothing -> return ()++--+-- | Get a valid panePath from a standard path.+--+getStandardPanePath :: StandardPath -> PaneLayout -> PanePath+getStandardPanePath sp pl = reverse $ getStandard' sp pl []+ where+ getStandard' _ (TerminalP _ _) p = p+ getStandard' (LeftP:sp) (VerticalP l r _) p = getStandard' sp l (LeftP:p)+ getStandard' (RightP:sp) (VerticalP l r _) p = getStandard' sp r (RightP:p)+ getStandard' (TopP:sp) (HorizontalP t b _) p = getStandard' sp t (TopP:p)+ getStandard' (BottomP:sp) (HorizontalP t b _) p = getStandard' sp b (BottomP:p)+ -- if no match get leftmost topmost+ getStandard' _ (VerticalP l r _) p = getStandard' [] l (LeftP:p)+ getStandard' _ (HorizontalP t b _) p = getStandard' [] t (TopP:p)++--+-- | 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+++--+-- | 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+ ae = otherDirection $head rp+ in Just (reverse $ae : tail rp)++--+-- | 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 (TopP:r) (HorizontalP t _ _) = layoutFromPath r t+layoutFromPath (BottomP:r) (HorizontalP _ b _) = layoutFromPath r b+layoutFromPath (LeftP:r) (VerticalP l _ _) = layoutFromPath r l+layoutFromPath (RightP:r) (VerticalP _ ri _) = layoutFromPath r ri+layoutFromPath pp l = error+ $"inconsistent layout " ++ show pp ++ " " ++ show l+++getNotebookOrPaned :: PaneMonad alpha => PanePath -> (Widget -> beta) -> alpha beta+getNotebookOrPaned p cf = (widgetGet $["topBox","root"] ++ map paneDirectionToWidgetName p) 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 (getStandardPanePath 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"++--+-- | Changes a pane path in the pane map+--+adjustPane :: PaneMonad alpha => PanePath -> PanePath -> alpha ()+adjustPane fromPane toPane = do+ paneMap <- getPaneMapSt+ let newMap = Map.map (\(pp,other) -> do+ if pp == fromPane+ then (toPane,other)+ else (pp,other)) paneMap+ setPaneMapSt newMap++--+-- | Changes the layout for a split+--+adjustLayoutForSplit :: PaneMonad alpha => Direction -> PanePath -> alpha ()+adjustLayoutForSplit dir path = do+ layout <- getLayoutSt+ let newTerm = case dir of+ Horizontal -> HorizontalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0+ Vertical -> VerticalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0+ setLayoutSt $ adjust path layout newTerm++--+-- | Changes the layout for a collapse++--+adjustLayoutForCollapse :: PaneMonad alpha => PanePath -> alpha ()+adjustLayoutForCollapse path = do+ layout <- getLayoutSt+ setLayoutSt $ adjust path layout (TerminalP Nothing 0)++getSubpath :: PanePath -> PaneLayout -> Maybe PanePath+getSubpath path layout =+ case layoutFromPath path layout of+ TerminalP _ _ -> Nothing+ HorizontalP _ _ _ -> Just (path ++ [TopP])+ VerticalP _ _ _ -> Just (path ++ [LeftP])++--+-- | Changes the layout by replacing element at pane path with replace+--+adjust :: PanePath -> PaneLayout -> PaneLayout -> PaneLayout+adjust pp layout replace = adjust' pp layout+ where+ adjust' [] _ = replace+ adjust' (TopP:r) (HorizontalP tp bp _) = HorizontalP (adjust' r tp) bp 0+ adjust' (BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (adjust' r bp) 0+ adjust' (LeftP:r) (VerticalP lp rp _) = VerticalP (adjust' r lp) rp 0+ adjust' (RightP:r) (VerticalP lp rp _) = VerticalP lp (adjust' r rp) 0+ adjust' p l = error $"inconsistent layout " ++ show p ++ " " ++ show l++--+-- | Get the widget from a list of strings+--+widgetFromPath :: Widget -> [String] -> IO (Widget)+widgetFromPath w [] = return w+widgetFromPath w (h:t) = do+ children <- containerGetChildren (castToContainer w)+ names <- mapM widgetGetName children+ let mbiInd = findIndex (== h) names+ case mbiInd of+ Nothing -> error $"Cant't find widget path " ++ show (h:t)+ Just ind -> widgetFromPath (children !! ind) t+++widgetGet :: PaneMonad alpha => [String] -> (Widget -> b) -> alpha (b)+widgetGet strL cf = do+ w <- getWindowSt+ r <- liftIO $widgetFromPath (castToWidget w) 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
− src/IDE/BuildInfoEditor.hs
@@ -1,315 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------ | Module for editing of cabal build infos-----module IDE.BuildInfoEditor (- editBuildInfo -- Maybe FilePath -> [String] -> BuildInfo -> String -> IO (Maybe BuildInfo)-, BuildEditorFactory(..)-, BuildEditorFactoryI(..)-) where--import Graphics.UI.Gtk-import qualified Graphics.UI.Gtk.ModelView as New(cellText)-import Control.Monad.Reader-import Distribution.PackageDescription-import Data.IORef-import Data.List--import IDE.Core.State-import IDE.SpecialEditors-import IDE.Framework.ViewFrame-import IDE.Framework.EditorBasics-import IDE.Framework.MakeEditor-import IDE.Framework.SimpleEditors-import IDE.Framework.CompositeEditors-import IDE.Framework.Parameters--class IDEEditor alpha => BuildEditorFactory alpha where- buildInfoEditor :: alpha -> Maybe FilePath -> [String] -> Editor BuildInfo- libraryEditor :: alpha -> Maybe FilePath -> [String] -> Editor Library- executableEditor :: alpha -> Maybe FilePath -> [String] -> Editor Executable- executablesEditor :: alpha -> Maybe FilePath -> [String] -> Editor [Executable]--data BuildEditorFactoryI = BuildEditorFactoryI- deriving (Eq,Ord,Show)--instance IDEObject BuildEditorFactoryI-instance IDEEditor BuildEditorFactoryI-instance BuildEditorFactory BuildEditorFactoryI where- buildInfoEditor factory mbFp list = buildInfoEditor' mbFp list- libraryEditor factory mbFp list = libraryEditor' mbFp list- executableEditor factory mbFp list = executableEditor' mbFp list- executablesEditor factory mbFp list = executablesEditor' mbFp list---- --------------------------------------------------------------- * Build Infos--- --------------------------------------------------------------buildInfoEditor' :: Maybe FilePath -> [String] -> Editor BuildInfo-buildInfoEditor' fp modules p = do- (wid,inj,ext,notif) <- otherEditor (editBuildInfo fp modules) p- box <- vBoxNew False 1- textView <- textViewNew- widgetSetSizeRequest textView (-1) 300- containerAdd box wid- containerAdd box textView- buffer <- textViewGetBuffer textView- let binj bi = do- inj bi- textBufferSetText buffer $showHookedBuildInfo (Just bi,[])- notif FocusIn $Left (changedHandler buffer ext)- return (castToWidget box,binj,ext,notif)- where- changedHandler buffer ext _ = do- mbv <- ext- case mbv of- Just v -> textBufferSetText buffer $showHookedBuildInfo (Just v,[])- Nothing -> return ()- return True--libraryEditor' :: Maybe FilePath -> [String] -> Editor Library-libraryEditor' fp modules para = do- (wid,inj,ext,notif) <-- pairEditor- (modulesEditor modules, paraName <<<- ParaName "Exposed Modules" $para)- (buildInfoEditor' fp modules, paraName <<<- ParaName "Build Info" $ para)- (paraDirection <<<- ParaDirection Vertical $ emptyParams)- let pinj (Library em bi) = inj (em,bi)- let pext = do- mbp <- ext- case mbp of- Nothing -> return Nothing- Just (em,bi) -> return (Just $Library em bi)- return (wid,pinj,pext,notif)--modulesEditor :: [String] -> Editor [String]-modulesEditor modules = staticMultiselectionEditor modules--moduleEditor :: [String] -> Editor String-moduleEditor modules = staticSelectionEditor modules---executableEditor' :: Maybe FilePath -> [String] -> Editor Executable-executableEditor' fp modules para = do- (wid,inj,ext,notif) <- pairEditor- (pairEditor- (stringEditor, paraName <<<- ParaName "Executable Name" $ emptyParams)- (fileEditor fp FileChooserActionOpen "Select File",- paraName <<<- ParaName "Main Module" $ emptyParams),- (paraDirection <<<- ParaDirection Vertical $ emptyParams))- (buildInfoEditor' fp modules, paraName <<<- ParaName "Build Info" $ emptyParams)- (paraDirection <<<- ParaDirection Vertical $ para)- let pinj (Executable s f bi) = inj ((s,f),bi)- let pext = do- mbp <- ext- case mbp of- Nothing -> return Nothing- Just ((s,f),bi) -> return (Just $Executable s f bi)- return (wid,pinj,pext,notif)--executablesEditor' :: Maybe FilePath -> [String] -> Editor [Executable]-executablesEditor' fp modules p =- multisetEditor- (ColumnDescr False [("Executable Name",\(Executable exeName _ _) -> [New.cellText := exeName])- ,("Module Path",\(Executable _ mp _) -> [New.cellText := mp])])- (executableEditor' fp modules ,emptyParams)- (paraShadow <<<- ParaShadow ShadowIn $ p)--buildInfoD :: Maybe FilePath -> [String] -> [(String,[FieldDescription BuildInfo])]-buildInfoD fp modules = [- ("Description", [- mkField- (paraName <<<- ParaName "Component is buildable here" $ emptyParams)- buildable- (\ a b -> b{buildable = a})- boolEditor- , mkField- (paraName <<<- ParaName "Non-exposed or non-main modules"- $ paraSynopsis <<<- ParaSynopsis ("A list of modules used by the component but "- ++ "not exposed to users.")- $ paraShadow <<<- ParaShadow ShadowIn- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- otherModules- (\ a b -> b{otherModules = a})- (modulesEditor modules)- , mkField- (paraName <<<- ParaName- "Where to look for the haskell module hierarchy"- $ paraSynopsis <<<- ParaSynopsis- "Root directories for the module hierarchy."- $ paraShadow <<<- ParaShadow ShadowIn- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- hsSourceDirs- (\ a b -> b{hsSourceDirs = a})- (filesEditor fp FileChooserActionSelectFolder "Select folder")- ]),- ("Extensions",[- mkField- (paraName <<<- ParaName "Extensions"- $ paraSynopsis <<<- ParaSynopsis- "A list of Haskell extensions used by every module."- $ emptyParams)- extensions- (\ a b -> b{extensions = a})- extensionsEditor- ]),- ("Options",[- mkField- (paraName <<<- ParaName "Options for haskell compilers"- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- options- (\ a b -> b{options = a})- (multisetEditor- (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv])- ,("Options",\(_,op) -> [New.cellText := show op])])- ((pairEditor- (compilerFlavorEditor,emptyParams)- (stringsEditor,emptyParams)),- (paraDirection <<<- ParaDirection Vertical- $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)))- , mkField- (paraName <<<- ParaName "Additional options for GHC when built with profiling"- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- ghcProfOptions- (\ a b -> b{ghcProfOptions = a})- stringsEditor- , mkField- (paraName <<<- ParaName "Options for C compiler"- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- ccOptions- (\ a b -> b{ccOptions = a})- stringsEditor- , mkField- (paraName <<<- ParaName "Options for linker"- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- ldOptions- (\ a b -> b{ldOptions = a})- stringsEditor- ]),- ("C",[- mkField- (paraName <<<- ParaName "A list of header files already installed on the system"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- includes- (\ a b -> b{includes = a})- stringsEditor- , mkField- (paraName <<<- ParaName "A list of header files from this package"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- installIncludes- (\ a b -> b{installIncludes = a})- (filesEditor fp FileChooserActionOpen "Select File")- , mkField- (paraName <<<- ParaName "A list of directories to search for header files"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- includeDirs- (\ a b -> b{includeDirs = a})- (filesEditor fp FileChooserActionSelectFolder "Select Folder")- , mkField- (paraName <<<- ParaName- "A list of C source files to be compiled,linked with the Haskell files."- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- cSources- (\ a b -> b{cSources = a})- (filesEditor fp FileChooserActionOpen "Select file")- , mkField- (paraName <<<- ParaName "A list of extra libraries to link with"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- extraLibs- (\ a b -> b{extraLibs = a})- stringsEditor- , mkField- (paraName <<<- ParaName "A list of directories to search for libraries."- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- extraLibDirs- (\ a b -> b{extraLibDirs = a})- (filesEditor fp FileChooserActionSelectFolder "Select Folder")- ]),- ("Mac OS X",[- mkField- (paraName <<<- ParaName "Support frameworks for Mac OS X"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- cSources- (\ a b -> b{cSources = a})- stringsEditor- ])]---editBuildInfo :: Maybe FilePath -> [String] -> BuildInfo -> String -> IO (Maybe BuildInfo)-editBuildInfo fp modules buildInfo contextStr = do- res <- editBuildInfo' buildInfo contextStr (buildInfoD fp modules)- return res--editBuildInfo' :: BuildInfo -> String -> [(String,[FieldDescription BuildInfo])] -> IO (Maybe BuildInfo)-editBuildInfo' buildInfo contextStr buildInfoD = do- resRef <- newIORef Nothing- dialog <- windowNew- windowSetModal dialog True- vb <- vBoxNew False 7- bb <- hButtonBoxNew- ok <- buttonNewFromStock "gtk-ok"- cancel <- buttonNewFromStock "gtk-cancel"- boxPackStart bb ok PackNatural 0- boxPackStart bb cancel PackNatural 0- nb <- newNotebook- notebookSetTabPos nb PosTop- res <- mapM- (\ (tabLabel, partBuildInfoD) -> do- resList <- mapM (\ (FD _ editorF) -> editorF buildInfo) partBuildInfoD- let (widgetsP, setInjsP, getExtsP,notifiersP) = unzip4 resList- nbbox <- vBoxNew False 0- mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP- sw <- scrolledWindowNew Nothing Nothing- scrolledWindowAddWithViewport sw nbbox- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- notebookAppendPage nb sw tabLabel- return (widgetsP, setInjsP, getExtsP, notifiersP))- buildInfoD- let (widgets, setInjs, getExts, notifiers) =- foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res- let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of- Just s -> s- Nothing -> "Unnamed")- $concatMap snd buildInfoD- ok `onClicked` (do- mbNewBuildInfo <- extractAndValidate buildInfo getExts fieldNames- case mbNewBuildInfo of- Nothing -> do- sysMessage Normal "Cant't validate build info"- return ()- Just newBuildInfo -> do- writeIORef resRef (Just newBuildInfo)- widgetDestroy dialog- mainQuit- return ())- cancel `onClicked` (do- widgetDestroy dialog- mainQuit- return ())- dialog `onDelete` (\e -> do- widgetDestroy dialog- mainQuit- return True)- boxPackStart vb nb PackGrow 7- boxPackEnd vb bb PackNatural 7- containerAdd dialog vb- widgetSetSizeRequest dialog 500 700- widgetShowAll dialog- mainGUI- res <- readIORef resRef- return (res)--------
− src/IDE/CallersPane.hs
@@ -1,219 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.CallersPane--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | The pane of ide where modules are presented in tree form with their--- packages and exports-------------------------------------------------------------------------------------module IDE.CallersPane (- calledBy-) where--import Graphics.UI.Gtk hiding (get)-import Graphics.UI.Gtk.ModelView as New-import Data.Maybe-import Control.Monad.Reader-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.List-import Distribution.Package--import IDE.Core.State-import IDE.Framework.ViewFrame--instance IDEObject IDECallers-instance Pane IDECallers- where- primPaneName _ = "Callers"- getAddedIndex _ = 0- getTopWidget = castToWidget . scrolledView- paneId b = "*Callers"- makeActive p = do- activatePane p (BufConnections[][] [])- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- lift $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> lift $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- deactivatePaneIfActive pane- lift $notebookRemovePage nb i- removePaneAdmin pane---- | We don't recover this pane-instance RecoverablePane IDECallers CallersState where- saveState p = return Nothing- recoverState pp _ = return ()----- | Open a pane with the callers of this identifier-calledBy :: IdentifierDescr- -> IDEAction-calledBy idDescr = do- mbCurrentInfo <- readIDE currentInfo- case mbCurrentInfo of- Nothing -> return ()- Just currentInfo' ->- let symModPair = (identifierID idDescr, modu $ moduleIdID idDescr)- modulesList1 = modulesForCallerFromPackages- (Map.elems $ fst $ fst currentInfo') symModPair- modulesList2 = modulesForCallerFromPackages- (Map.elems $ fst $ snd currentInfo') symModPair- modulesList = nub $ modulesList1 ++ modulesList2- finalList = zip modulesList (repeat (identifierID idDescr))- in do callers <- getCallers- lift $ do- New.listStoreClear (callersStore callers)- mapM_ (New.listStoreAppend (callersStore callers)) finalList- bringPaneToFront callers--modulesForCallerFromPackages :: [PackageDescr] -> (Symbol,ModuleIdentifier) -> [ModuleDescr]-modulesForCallerFromPackages [] _ = []-modulesForCallerFromPackages (p :rest) (sym,mod) =- (filter (\ md -> case mod `Map.lookup` (usagesMD md) of- Nothing -> False- Just syms -> sym `Set.member` syms) (exposedModulesPD p))- ++ modulesForCallerFromPackages rest (sym,mod)--getCallers :: IDEM IDECallers-getCallers = do- mbMod <- getPane CallersCasting- case mbMod of- Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (modulesPanePath prefs) layout- nb <- getNotebook pp- initCallers pp nb- mbMod <- getPane CallersCasting- case mbMod of- Nothing -> throwIDE "Can't init callers"- Just m -> return m- Just m -> return m--initCallers :: PanePath -> Notebook -> IDEAction-initCallers panePath nb = do- ideR <- ask- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- currentInfo <- readIDE currentInfo- (buf,cids) <- lift $ do- treeStore <- New.listStoreNew []- treeView <- New.treeViewNew- New.treeViewSetModel treeView treeStore-- renderer0 <- New.cellRendererPixbufNew- set renderer0 [ cellPixbufStockId := stockYes ]-- renderer <- New.cellRendererTextNew- col <- New.treeViewColumnNew- New.treeViewColumnSetTitle col "Modules"- New.treeViewColumnSetSizing col TreeViewColumnAutosize- New.treeViewColumnSetReorderable col True- New.treeViewAppendColumn treeView col- New.cellLayoutPackStart col renderer0 False- New.cellLayoutPackStart col renderer True- New.cellLayoutSetAttributes col renderer treeStore- $ \row -> [ New.cellText := modu $ moduleIdMD $ fst row]- New.cellLayoutSetAttributes col renderer0 treeStore- $ \row -> [cellPixbufStockId :=- if isJust (mbSourcePathMD $ fst row)- then stockJumpTo- else stockYes]-- renderer2 <- New.cellRendererTextNew- col2 <- New.treeViewColumnNew- New.treeViewColumnSetTitle col2 "Packages"- New.treeViewColumnSetSizing col2 TreeViewColumnAutosize- New.treeViewColumnSetReorderable col2 True- New.treeViewAppendColumn treeView col2- New.cellLayoutPackStart col2 renderer2 True- New.cellLayoutSetAttributes col2 renderer2 treeStore- $ \row -> [ New.cellText := showPackageId $ pack $ moduleIdMD $ fst row]-- New.treeViewSetHeadersVisible treeView True-- sw <- scrolledWindowNew Nothing Nothing- containerAdd sw treeView- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- let modules = IDECallers sw treeView treeStore- notebookInsertOrdered nb sw (paneName modules)- widgetShowAll sw---- cid1 <- treeView `afterFocusIn`--- (\_ -> do runReaderT (makeActive modules) ideR; return True)--- cid2 <- facetView `afterFocusIn`--- (\_ -> do runReaderT (makeActive modules) ideR; return True)--- treeView `onButtonPress` (treeViewPopup ideR treeStore treeView)--- facetView `onButtonPress` (facetViewPopup ideR facetStore facetView)--- sel <- New.treeViewGetSelection treeView--- sel `New.onSelectionChanged` (fillFacets treeView treeStore facetStore)--- sel2 <- New.treeViewGetSelection facetView--- sel2 `New.onSelectionChanged` (fillInfo facetView facetStore ideR)-- return (modules,[])- addPaneAdmin buf (BufConnections [] [] []) panePath- lift $widgetGrabFocus (scrolledView buf)-----getSelectionTree :: New.TreeView--- -> New.ListStore (String, [(ModuleDescr,PackageDescr)])--- -> IO (Maybe (String, [(ModuleDescr,PackageDescr)]))---getSelectionTree treeView listStore = do--- treeSelection <- New.treeViewGetSelection treeView--- paths <- New.treeSelectionGetSelectedRows treeSelection--- case paths of--- [] -> return Nothing--- a:r -> do--- val <- New.listStoreGetValue listStore a--- return (Just val)----treeViewPopup :: IDERef--- -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])--- -> New.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 ()--- menuShellAppend theMenu item1--- 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"-
− src/IDE/Core/Exception.hs
@@ -1,101 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.Core.Exception--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | A Type for IDE exceptions--- Taken from Haddock example.-------------------------------------------------------------------------------------module IDE.Core.Exception (- IDEException-, throwIDE-, sysMessage-, MessageLevel(..)-, handleTopExceptions-) where--import Data.Typeable-import Control.Exception-import System.IO-import Prelude hiding(catch)-import System.Exit--import Panic-import Bag-import ErrUtils-import DynFlags--data IDEException = IDEException String- deriving Typeable--instance Show IDEException where- show (IDEException str) = str---- dynamic exceptions doesn't work for me, why---throwIDE str = throwDyn (IDEException str)-throwIDE str = error 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)- hFlush stdout- 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/Core/Panes.hs
@@ -1,370 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.Core.Panes--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | The core state of ide. This module is imported from every other module,--- | and all data structures of the state are declared here, to avoid circular--- | module dependencies.-------------------------------------------------------------------------------------module IDE.Core.Panes (--- Casting(..)---, CastingS(..)---- * Panes and pane layout- Pane(..)-, CastablePane(..)-, Casting(..)-, IDEPane(..)-, RecoverablePane(..)-, PaneDirection(..)-, PanePath-, PaneLayout(..)-, PaneName-, Connections(..)--, IDEState(..)-, PaneState(..)-, Recoverable(..)---- * The pane types-, IDEBuffer(..)-, BufferState(..)-, IDEInfo(..)-, InfoState(..)-, FacetWrapper(..)-, IDEModules(..)-, ModulesState(..)-, IDECallers(..)-, CallersState(..)-, IDEToolbar(..)-, ToolbarState(..)--, IDEReplace(..)-, ReplaceState(..)--, IDELog(..)-, LogState(..)-, LogTag(..)--, IDEFind(..)-, FindState(..)----) where--import Graphics.UI.Gtk.SourceView-import Graphics.UI.Gtk hiding (get)-import Graphics.UI.Gtk.ModelView as New-import System.Glib.Signals-import Data.Maybe-import System.Time-import GHC.IOBase hiding (BufferState)--import IDE.Core.Types-import {-# SOURCE #-} IDE.Core.State-import IDE.Framework.EditorBasics--- ------------------------------------------------------------------------ Panes and pane layout----------- | A path to a pane----type PanePath = [PaneDirection]------- | The relative direction to a pane from the parent----data PaneDirection = TopP | BottomP | LeftP | RightP- deriving (Eq,Show,Read)- ------ | Description of a window layout----data PaneLayout = HorizontalP PaneLayout PaneLayout Int- | VerticalP PaneLayout PaneLayout Int- | TerminalP (Maybe PaneDirection) Int- deriving (Eq,Show,Read)------- | Signal handlers for the different pane types----data Connections = BufConnections- [ConnectId SourceView]- [ConnectId TextBuffer]- [ConnectId TextView]--- [ConnectId New.TreeView]--type PaneName = String------- | Description of the different pane types-----class IDEObject alpha => Pane alpha 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 -> IDEAction- close :: alpha -> IDEAction---class (Pane alpha, Recoverable beta) => RecoverablePane alpha beta | beta -> alpha, alpha -> beta where- saveState :: alpha -> IDEM (Maybe IDEState)- recoverState :: PanePath -> beta -> IDEAction--class CastablePane alpha where- casting :: alpha -> Casting alpha- downCast :: Casting alpha -> IDEPane -> Maybe alpha- isIt :: Casting alpha -> IDEPane -> Bool- isIt t i = isJust (downCast t i)--data Casting alpha where- LogCasting :: Casting IDELog- InfoCasting :: Casting IDEInfo- BufferCasting :: Casting IDEBuffer- ModulesCasting :: Casting IDEModules- CallersCasting :: Casting IDECallers- ToolbarCasting :: Casting IDEToolbar- FindCasting :: Casting IDEFind- ReplaceCasting :: Casting IDEReplace--data IDEPane = forall alpha beta . (CastablePane alpha, RecoverablePane alpha beta) => PaneC alpha--instance IDEObject IDEPane--instance Pane IDEPane where- paneName (PaneC a) = paneName a- primPaneName (PaneC a) = primPaneName a- getAddedIndex (PaneC a) = getAddedIndex a- getTopWidget (PaneC a) = getTopWidget a- paneId (PaneC a) = paneId a- makeActive (PaneC a) = makeActive a- close (PaneC a) = close a--class Recoverable alpha where- toPaneState :: alpha -> PaneState--data IDEState = forall alpha beta . (RecoverablePane alpha beta, Recoverable beta) => StateC beta--instance Recoverable IDEState where- toPaneState (StateC a) = toPaneState a--instance RecoverablePane IDEPane IDEState where- saveState (PaneC p) = saveState p- recoverState pp (StateC s) = recoverState pp s---- ------------------------------------------------------------------------ All pane types must be in here !-----data PaneState = BufferSt BufferState- | LogSt LogState- | InfoSt InfoState- | ModulesSt ModulesState- | CallersSt CallersState- | ToolbarSt ToolbarState- | FindSt FindState- | ReplaceSt ReplaceState- deriving(Eq,Ord,Read,Show)---- ------------------------------------------------------------------------ Special Panes - The data structures for the panes---------- | A text editor pane description----data IDEBuffer = IDEBuffer {- fileName :: Maybe FilePath-, bufferName :: String-, addedIndex :: Int-, sourceView :: SourceView-, scrolledWindow :: ScrolledWindow-, modTime :: Maybe (ClockTime)-}---instance CastablePane IDEBuffer where- casting _ = BufferCasting- downCast _ (PaneC a)- = case casting a of- BufferCasting -> Just a- _ -> Nothing--data BufferState = BufferState FilePath Int- deriving(Eq,Ord,Read,Show)--instance Recoverable BufferState where- toPaneState a = BufferSt a-------- | An info pane description----data IDEInfo = IDEInfo {- sw :: ScrolledWindow-, currentIDs :: IORef [IdentifierDescr]-, currentInd :: IORef Int-, injectors :: [IdentifierDescr -> IO()]-, extractors :: [IdentifierDescr -> Extractor IdentifierDescr]-, nextB :: Button-, prevB :: Button-, numLabel :: Label-}--instance CastablePane IDEInfo where- casting _ = InfoCasting- downCast _ (PaneC a) = case casting a of- InfoCasting -> Just a- _ -> Nothing--data InfoState = InfoState [IdentifierDescr] Int- deriving(Eq,Ord,Read,Show)--instance Recoverable InfoState where- toPaneState a = InfoSt a----- | A modules pane description-----data IDEModules = IDEModules {- outer :: VBox-, paned :: HPaned-, treeView :: New.TreeView-, treeStore :: New.TreeStore (String, [(ModuleDescr,PackageDescr)])-, facetView :: New.TreeView-, facetStore :: New.TreeStore FacetWrapper-, localScopeB :: RadioButton-, packageScopeB :: RadioButton-, worldScopeB :: RadioButton-, blacklistB :: CheckButton-}--instance CastablePane IDEModules where- casting _ = ModulesCasting- downCast _ (PaneC a) = case casting a of- ModulesCasting -> Just a- _ -> Nothing--data FacetWrapper =- Itself IdentifierDescr- | ConstructorW Symbol IdentifierDescr- | FieldW Symbol IdentifierDescr- | MethodW Symbol IdentifierDescr- | OrphanedData IdentifierDescr--data ModulesState = ModulesState Int (Scope,Bool)- (Maybe String, Maybe String)- deriving(Eq,Ord,Read,Show)--instance Recoverable ModulesState where- toPaneState a = ModulesSt a----- | A callers pane description-----data IDECallers = IDECallers {- scrolledView :: ScrolledWindow-, treeViewC :: New.TreeView-, callersStore :: New.ListStore (ModuleDescr,Symbol)-}--instance CastablePane IDECallers where- casting _ = CallersCasting- downCast _ (PaneC a) = case casting a of- CallersCasting -> Just a- _ -> Nothing--data CallersState = CallersState- deriving(Eq,Ord,Read,Show)--instance Recoverable CallersState where- toPaneState a = CallersSt a---- | A Toolbar pane description----data IDEToolbar = IDEToolbar {- toolbar :: VBox-}--instance CastablePane IDEToolbar where- casting _ = ToolbarCasting- downCast _ (PaneC a) = case casting a of- ToolbarCasting -> Just a- _ -> Nothing--data ToolbarState = ToolbarState- deriving(Eq,Ord,Read,Show)--instance Recoverable ToolbarState where- toPaneState a = ToolbarSt a---- | A Control pane for simple text replace-----data IDEReplace = IDEReplace {- replaceBox :: VBox---, replaceExtractor :: Extractor ReplaceState-}--data ReplaceState = ReplaceState{- searchFor :: String-, replaceWith :: String-, matchCase :: Bool-, matchEntire :: Bool-, searchBackwards :: Bool}- deriving(Eq,Ord,Read,Show)------- | The Log Viev-----data IDELog = IDELog {- textView :: TextView-, scrolledWindowL :: ScrolledWindow}--data LogState = LogState- deriving(Eq,Ord,Read,Show)--data LogTag = LogTag | ErrorTag | FrameTag----- | A Find pane description-----data IDEFind = IDEFind {- findBox :: HBox-, caseSensitive :: ToggleButton-, wrapAround :: ToggleButton-, entireWord :: ToggleButton-, gotoLine :: SpinButton-, findEntry :: Entry-}--data FindState = FindState- deriving(Eq,Ord,Read,Show)-----
src/IDE/Core/State.hs view
@@ -1,11 +1,12 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -XFlexibleContexts -XTypeSynonymInstances -XMultiParamTypeClasses+ -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.State -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL ----- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org> -- Stability : experimental -- Portability : portable --@@ -16,14 +17,13 @@ ------------------------------------------------------------------------------- module IDE.Core.State (- IDEObject(..)+ IDEObject , IDEEditor , IDE(..) , IDERef , IDEM , IDEAction , IDEEvent(..)-, EventSelector(..) -- * Convenience methods for accesing the IDE State , readIDE@@ -32,12 +32,37 @@ , withIDE , getIDE +, reifyIDE+, reflectIDE+, catchIDE+ , ideMessage , logMessage-, forceJust+, sysMessage+, MessageLevel(..)++, withoutRecordingDo+, activatePane+, deactivatePane+, deactivatePaneIfActive++, getCandyState+, setCandyState+, getForgetSession++, getSBSpecialKeys+, getSBActivePane+, getSBActivePackage+, getSBErrors+, getStatusbarIO+, getStatusbarLC++, Session+ , module IDE.Core.Types-, module IDE.Core.Panes-, module IDE.Core.Exception+, module Graphics.UI.Frame.Panes+, module Graphics.UI.Frame.ViewFrame+, module IDE.Exception ) where @@ -45,19 +70,30 @@ import Data.Map (Map) import qualified Data.Map as Map import Data.IORef-import Control.Monad.Reader-import GHC (Session)+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 IDE.Core.Types-import IDE.Core.Panes-import IDE.Core.Exception+import Graphics.UI.Frame.Panes+import Graphics.UI.Frame.ViewFrame+import IDE.Exception+import Control.Event+import System.IO +-- this should not be repeated here, why is it necessary?+instance MonadIO Ghc where+ liftIO ioA = Ghc $ \_ -> ioA+ ideMessage :: MessageLevel -> String -> IDEAction ideMessage level str = do st <- ask triggerEvent st (LogMessage (str ++ "\n") LogTag)- lift $ sysMessage level str+ liftIO $ sysMessage level str logMessage :: String -> LogTag -> IDEAction logMessage str tag = do@@ -65,66 +101,15 @@ triggerEvent st (LogMessage (str ++ "\n") tag) return () -data IDEEvent =- CurrentInfo- | ActivePack- | SelectInfo String- | SelectIdent IdentifierDescr- | LogMessage String LogTag- | GetToolbar [Widget]+sysMessage :: MonadIO m => MessageLevel -> String -> m ()+sysMessage ml str = liftIO $ do+ putStrLn str+ hFlush stdout -data EventSelector =- CurrentInfoS- | ActivePackS- | SelectInfoS- | SelectIdentS- | LogMessageS- | GetToolbarS+data MessageLevel = Silent | Normal | High deriving (Eq,Ord,Show) -eventAsSelector :: IDEEvent -> EventSelector-eventAsSelector CurrentInfo = CurrentInfoS-eventAsSelector ActivePack = ActivePackS-eventAsSelector (LogMessage _ _) = LogMessageS-eventAsSelector (GetToolbar _) = GetToolbarS-eventAsSelector (SelectInfo _) = SelectInfoS-eventAsSelector (SelectIdent _) = SelectIdentS--class IDEObject alpha where-- canTriggerEvent :: alpha -> EventSelector -> Bool- canTriggerEvent _ _ = False-- triggerEvent :: alpha -> IDEEvent -> IDEM IDEEvent- triggerEvent o e =- if canTriggerEvent o (eventAsSelector e)- then do- handlerMap <- readIDE handlers- let selector = eventAsSelector e- case selector `Map.lookup` handlerMap of- Nothing -> return e- Just l -> foldM (\e (_,ah) -> ah e) e l- else throwIDE $ "Object can't trigger event " ++ show (eventAsSelector e)-- registerEvent :: alpha -> EventSelector -> Either (IDEEvent -> IDEM IDEEvent) Unique -> IDEM Unique- registerEvent o e (Left handler) = do- handlerMap <- readIDE handlers- unique <- lift $ newUnique- let newHandlers = case e `Map.lookup` handlerMap of- Nothing -> Map.insert e [(unique,handler)] handlerMap- Just l -> Map.insert e ((unique,handler):l) handlerMap- modifyIDE_ (\ide -> return (ide{handlers = newHandlers}))- return unique- registerEvent o e (Right unique) = do- handlerMap <- readIDE handlers- 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- modifyIDE_ (\ide -> return (ide{handlers = newHandlers}))- return unique--+class IDEObject alpha class IDEObject o => IDEEditor o @@ -136,55 +121,133 @@ -- | The IDE state -- data IDE = IDE {- window :: Window -- ^ the gtk window-, uiManager :: UIManager -- ^ the gtk uiManager-, panes :: Map PaneName IDEPane -- ^ a map with all panes (subwindows)-, activePane :: Maybe (PaneName,Connections)-, paneMap :: Map PaneName (PanePath, Connections)+ window :: Window -- ^ the gtk window+, uiManager :: UIManager -- ^ the gtk uiManager+, panes :: Map PaneName (IDEPane IDEM) -- ^ a map with all panes (subwindows)+, activePane :: Maybe (PaneName,Connections)+, lastActiveBufferPane :: Maybe PaneName+, paneMap :: Map PaneName (PanePath, Connections) -- ^ a map from the pane name to its gui path and signal connections-, layout :: PaneLayout -- ^ a description of the general gui layout-, 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-, errors :: [ErrorSpec]-, currentErr :: Maybe Int-, accessibleInfo :: (Maybe (PackageScope)) -- ^ the world scope-, currentInfo :: (Maybe (PackageScope,PackageScope))+, layout :: PaneLayout -- ^ a description of the general gui layout+, 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+, errors :: [ErrorSpec]+, currentErr :: Maybe 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-, session :: Session -- ^ a ghc session object, side effects- -- reusing with sessions?-, handlers :: Map EventSelector [(Unique, IDEEvent -> IDEM IDEEvent)]+, handlers :: Map String [(Unique, IDEEvent -> IDEM IDEEvent)] -- ^ event handling table+, isShuttingDown :: Bool+, guiHistory :: (Bool,[GUIHistory],Int)+, findbar :: Toolbar+, toolbar :: Maybe Toolbar+, findbarVisible :: Bool+, toolbarVisible :: Bool } --deriving Show -instance IDEObject IDERef where- canTriggerEvent o LogMessageS = True- canTriggerEvent o GetToolbarS = True- canTriggerEvent o SelectInfoS = True- canTriggerEvent o SelectIdentS = True- canTriggerEvent o CurrentInfoS = True- canTriggerEvent o ActivePackS = True--- canTriggerEvent o _ = False +data IDEEvent =+ CurrentInfo+ | ActivePack+ | SelectInfo String+ | SelectIdent Descr+ | LogMessage String LogTag+ | RecordHistory GUIHistory+ | Sensitivity [(SensitivityMask,Bool)]+ | DescrChoice [Descr]+ | SearchMeta String+ | LoadSession FilePath+ | SaveSession FilePath+ -- -- | 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"++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 _ _ = 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++ -- -- | A reader monad for a mutable reference to the IDE state ---type IDEM = ReaderT (IDERef) IO+type IDEM = ReaderT IDERef Ghc +reifyIDE :: (IDERef -> Session -> IO a) -> IDEM a+reifyIDE f = ask >>= \ideR -> lift $ reifyGhc (f ideR)++reflectIDE :: IDEM a -> IDERef -> Session -> IO a+reflectIDE c ideR = reflectGhc (runReaderT c ideR)++catchIDE :: Exception e => IDEM a -> (e -> IO a) -> IDEM a+catchIDE block handler = reifyIDE (\ideR session -> catch (reflectIDE block ideR session) handler)+ -- -- | 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+ getWindowSt = readIDE window+ getUIManagerSt = readIDE uiManager+ getPanesSt = readIDE panes+ getPaneMapSt = readIDE paneMap+ getActivePaneSt = readIDE activePane+ getLayoutSt = readIDE layout+ setPanesSt v = modifyIDE_ (\ide -> return ide{panes = v})+ setPaneMapSt v = modifyIDE_ (\ide -> return ide{paneMap = v})+ setActivePaneSt v = modifyIDE_ (\ide -> return ide{activePane = v})+ setLayoutSt v = modifyIDE_ (\ide -> return ide{layout = v})++ runInIO f = reifyIDE (\ideRef session ->+ return (\v -> reflectIDE (f v) ideRef session))+++ -- --------------------------------------------------------------------- -- Convenience methods for accesing the IDE State --@@ -193,39 +256,147 @@ readIDE :: (IDE -> beta) -> IDEM beta readIDE f = do e <- ask- lift $ liftM f (readIORef e)+ liftIO $ liftM f (readIORef e) -- | Modify the contents, using an IO action. modifyIDE_ :: (IDE -> IO IDE) -> IDEM () modifyIDE_ f = do e <- ask- e' <- lift $ (f =<< readIORef e)- lift $ writeIORef e e'+ e' <- liftIO $ (f =<< readIORef e)+ liftIO $ writeIORef e e' -- | Variation on modifyIDE_ that lets you return a value modifyIDE :: (IDE -> IO (IDE,beta)) -> IDEM beta modifyIDE f = do e <- ask- (e',result) <- lift (f =<< readIORef e)- lift $ writeIORef e e'+ (e',result) <- liftIO (f =<< readIORef e)+ liftIO $ writeIORef e e' return result withIDE :: (IDE -> IO alpha) -> IDEM alpha withIDE f = do e <- ask- lift $ f =<< readIORef e+ liftIO $ f =<< readIORef e getIDE :: IDEM(IDE) getIDE = do e <- ask- st <- lift $ readIORef e+ st <- liftIO $ readIORef e return st +withoutRecordingDo :: IDEAction -> IDEAction+withoutRecordingDo act = do+ (b,l,n) <- readIDE guiHistory+ if not b then do+ modifyIDE_ (\ide -> return ide{guiHistory = (True,l,n)})+ act+ (b,l,n) <- readIDE guiHistory+ modifyIDE_ (\ide -> return ide{guiHistory = (False,l,n)})+ else act+ -- ------------------------------------------------------------------------ Convenience methods for accesing the IDE State+-- Activating and deactivating Panes.+-- This is here and not in Views because it needs some dependencies+-- (e.g. Events for history) ---forceJust :: Maybe alpha -> String -> alpha-forceJust mb str = case mb of- Nothing -> throwIDE str- Just it -> it++activatePane :: Pane alpha IDEM => alpha -> Connections -> IDEAction+activatePane pane conn = do+ mbAP <- getActivePaneSt+ 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+ setActivePaneSt (Just (paneName pane,conn))+ trigger (Just (paneName pane)) (case mbAP of+ Nothing -> Nothing+ Just (pn,_) -> Just pn)+ ideRef <- ask+ return ()++trigger :: Maybe String -> Maybe String -> IDEAction+trigger s1 s2 = do+ st <- ask+ triggerEvent st (RecordHistory ((PaneSelected s1), PaneSelected s2))+ triggerEvent st (Sensitivity [(SensitivityEditor, False)])+ return ()++deactivatePane :: IDEAction+deactivatePane = do+ ideR <- ask+ mbAP <- getActivePaneSt+ case mbAP of+ Nothing -> return ()+ Just (pn, _) -> do+ deactivatePaneWithout+ triggerEvent ideR (RecordHistory (PaneSelected Nothing,+ PaneSelected (Just pn)))+ triggerEvent ideR (Sensitivity [(SensitivityEditor, False)])+ return ()++deactivatePaneWithout :: IDEAction+deactivatePaneWithout = do+ sb <- getSBActivePane+ liftIO $ statusbarPop sb 1+ liftIO $ statusbarPush sb 1 ""+ mbAP <- getActivePaneSt+ case mbAP of+ Just (_,signals) -> liftIO $do+ signalDisconnectAll signals+ Nothing -> return ()+ setActivePaneSt Nothing++deactivatePaneIfActive :: Pane alpha IDEM => alpha -> IDEAction+deactivatePaneIfActive pane = do+ mbActive <- getActivePaneSt+ case mbActive of+ Nothing -> return ()+ Just (n,_) -> if n == paneName pane+ then deactivatePane+ else return ()+++-- get widget elements (menu)++getCandyState :: PaneMonad alpha => alpha (Bool)+getCandyState = do+ ui <- getUIAction "ui/menubar/_Edit/Source Candy" castToToggleAction+ liftIO $toggleActionGetActive ui++setCandyState :: PaneMonad alpha => Bool -> alpha ()+setCandyState b = do+ ui <- getUIAction "ui/menubar/_Edit/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++-- (toolbar)++getSBSpecialKeys :: PaneMonad alpha => alpha Statusbar+getSBSpecialKeys = widgetGet ["topBox","statusBox","statusBarSpecialKeys"] castToStatusbar++getSBActivePane :: PaneMonad alpha => alpha Statusbar+getSBActivePane = widgetGet ["topBox","statusBox","statusBarActivePane"] castToStatusbar++getSBActivePackage :: PaneMonad alpha => alpha Statusbar+getSBActivePackage = widgetGet ["topBox","statusBox","statusBarActiveProject"] castToStatusbar++getSBErrors :: PaneMonad alpha => alpha Statusbar+getSBErrors = widgetGet ["topBox","statusBox","statusBarErrors"] castToStatusbar++getStatusbarIO :: PaneMonad alpha => alpha Statusbar+getStatusbarIO = widgetGet ["topBox","statusBox","statusBarInsertOverwrite"] castToStatusbar++getStatusbarLC :: PaneMonad alpha => alpha Statusbar+getStatusbarLC = widgetGet ["topBox","statusBox","statusBarLineColumn"] castToStatusbar+++
− src/IDE/Core/State.hs-boot
@@ -1,20 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}-module IDE.Core.State (- IDEObject-, IDERef-, IDEM-, IDEAction-) where--import Data.IORef-import Control.Monad.Reader---class IDEObject o--data IDE-type IDERef = IORef IDE-type IDEM = ReaderT (IDERef) IO-type IDEAction = IDEM ()--
src/IDE/Core/Types.hs view
@@ -1,11 +1,11 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -XDisambiguateRecordFields -XExistentialQuantification -XRank2Types #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.Data -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL ----- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org> -- Stability : experimental -- Portability : portable --@@ -16,9 +16,7 @@ ------------------------------------------------------------------------------- module IDE.Core.Types (- IDEPackage(..)-, StandardPath(..) , ActionDescr(..) , ActionString@@ -30,14 +28,22 @@ , PackageDescr(..) , ModuleDescr(..)-, IdentifierDescr(..)+, Descr(..)+, SpDescr(..)+, DescrType(..)+, descrName+, typeInfo+, descrModu+, mbLocation+, mbComment+, details+, descrType+, stockIdFromType+, isReexported , Symbol , ClassId , DataId , TypeInfo-, ModuleIdentifier-, IdType(..)-, IdTypeS(..) , SymbolTable , PackageScope , PackModule(..)@@ -45,13 +51,6 @@ , parsePackModule , fromPackageIdentifier , toPackageIdentifier-, idDescriptionsPD-, allFieldsID-, allConstructorsID-, allClassOpsID-, typeInfo-, idType- , Location(..) , Scope(..) @@ -63,26 +62,35 @@ , SpecialKeyTable , SpecialKeyCons +, LogTag(..)++, GUIHistory+, GUIHistory'(..)++, SensitivityMask(..)+, SearchMode(..) ) where import Control.Monad.Reader import Graphics.UI.Gtk hiding (get)-import Distribution.Package-import Distribution.Version-import Data.Map (Map)+import Graphics.UI.Gtk.Gdk.Events(Modifier(..)) import qualified Data.Map as Map import Data.Set(Set) import qualified Data.Set as Set-import Text.ParserCombinators.ReadP-import qualified Data.ByteString.Char8 as BS-import Data.ByteString.Char8 (ByteString)+import GHC(Ghc) -import IDE.Utils.Default-import IDE.Core.Exception+import Default+import IDE.Exception+import Graphics.UI.Frame.Panes+import Data.ByteString (ByteString(..))+import Distribution.Package (PackageIdentifier(..),Dependency(..))+import Distribution.Text+import Data.Map (Map(..))+import Distribution.ModuleName(ModuleName)+import Distribution.Text+import qualified Data.ByteString as BS (empty) -data StandardPath = LeftTop | LeftBottom | RightTop | RightBottom- deriving(Read,Show,Eq,Enum) -- --------------------------------------------------------------------- -- IDEPackages@@ -116,7 +124,7 @@ , label :: String , tooltip :: Maybe String , stockID :: Maybe String-, action :: ReaderT alpha IO ()+, action :: ReaderT alpha Ghc () , accelerator :: [KeyString] , isToggle :: Bool }@@ -128,36 +136,32 @@ -- | Preferences is a data structure to hold configuration data -- data Prefs = Prefs {- showLineNumbers :: Bool-, rightMargin :: Maybe Int-, tabWidth :: Int-, sourceCandy :: Maybe String-, keymapName :: String-, forceLineEnds :: Bool-, textviewFont :: Maybe String-, logviewFont :: Maybe String-, defaultSize :: (Int,Int)-, browser :: String-, sourcePanePath :: StandardPath-, logPanePath :: StandardPath-, infoPanePath :: StandardPath-, modulesPanePath :: StandardPath-, controlPanePath :: StandardPath-, sourceDirectories :: [FilePath]-, packageBlacklist :: [Dependency]+ showLineNumbers :: Bool+ , rightMargin :: Maybe Int+ , tabWidth :: Int+ , sourceCandy :: Maybe String+ , keymapName :: String+ , forceLineEnds :: Bool+ , removeTBlanks :: Bool+ , textviewFont :: Maybe String+ , sourceStyle :: Maybe String+ , logviewFont :: Maybe String+ , defaultSize :: (Int,Int)+ , browser :: String+ , sourcePanePath :: StandardPath+ , logPanePath :: StandardPath+ , modulesPanePath :: StandardPath+ , sourceDirectories :: [FilePath]+ , packageBlacklist :: [Dependency]+ , collectAfterBuild :: Bool+ , collectAtStart :: Bool } deriving(Eq,Show) data SearchHint = Forward | Backward | Insert | Delete | Initial deriving (Eq) ---instance Show Modifier- where show Shift = "<shift>"- show Control = "<ctrl>"- show Alt = "<alt>"- show Apple = "<apple>"- show Compose = "<compose>"+instance Ord Modifier+ where compare a b = compare (fromEnum a) (fromEnum b) -- -- | Other types@@ -176,7 +180,7 @@ -- type PackageScope = (Map PackageIdentifier PackageDescr,SymbolTable)-type SymbolTable = Map Symbol [IdentifierDescr]+type SymbolTable = Map Symbol [Descr] data PackageDescr = PackageDescr { packagePD :: PackageIdentifier@@ -186,7 +190,7 @@ } deriving Show instance Eq PackageDescr where- (==) a b = packagePD a == packagePD b+ (== ) a b = packagePD a == packagePD b instance Ord PackageDescr where (<=) a b = packagePD a <= packagePD b@@ -196,140 +200,143 @@ moduleIdMD :: PackModule , mbSourcePathMD :: (Maybe FilePath) , exportedNamesMD :: (Set Symbol) -- unqualified-, usagesMD :: (Map ModuleIdentifier (Set Symbol)) -- imports-, idDescriptionsMD :: [IdentifierDescr]+, usagesMD :: (Map ModuleName (Set Symbol)) -- imports+, idDescriptionsMD :: [Descr] } deriving Show instance Eq ModuleDescr where- (==) a b = moduleIdMD a == moduleIdMD b+ (== ) a b = moduleIdMD a == moduleIdMD b instance Ord ModuleDescr where (<=) a b = moduleIdMD a <= moduleIdMD b -data IdentifierDescr =- SimpleDescr {- identifierID :: Symbol- , identifierTypeID :: IdTypeS- , typeInfoID :: TypeInfo- , moduleIdID :: PackModule- , mbLocation :: (Maybe Location)- , mbComment :: (Maybe ByteString)}- | DataDescr {- identifierID :: Symbol- , typeInfoID :: TypeInfo- , moduleIdID :: PackModule- , constructorsID :: [Symbol]- , fieldsID :: [Symbol]- , mbLocation :: (Maybe Location)- , mbComment :: (Maybe ByteString)}- | ClassDescr {- identifierID :: Symbol- , typeInfoID :: TypeInfo- , moduleIdID :: PackModule- , classOpsID :: [Symbol]- , mbLocation :: (Maybe Location)- , mbComment :: (Maybe ByteString)}- | InstanceDescr {- identifierID :: Symbol --the class- , binds :: [Symbol]- , moduleIdID :: PackModule- , mbLocation :: (Maybe Location)- , mbComment :: (Maybe ByteString)}+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) -instance Eq IdentifierDescr where- (==) a b = identifierID a == identifierID b- && typeInfo a == typeInfo b+isReexported :: Descr -> Bool+isReexported (Reexported _ _) = True+isReexported _ = False -instance Ord IdentifierDescr where- (<=) a b = if identifierID a == identifierID b- then typeInfo a <= typeInfo b- else identifierID a < identifierID b+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 -allFieldsID :: IdentifierDescr -> [Symbol]-allFieldsID (DataDescr _ _ _ _ fieldsId _ _) = fieldsId-allFieldsID _ = []+descrModu :: Descr -> PackModule+descrModu d+ | isReexported d = descrModu (impDescr d)+ | otherwise = descrModu' d -allConstructorsID :: IdentifierDescr -> [Symbol]-allConstructorsID (DataDescr _ _ _ constructorsID _ _ _) = constructorsID-allConstructorsID _ = []+mbLocation :: Descr -> Maybe Location+mbLocation d+ | isReexported d = mbLocation (impDescr d)+ | otherwise = mbLocation' d -allClassOpsID :: IdentifierDescr -> [Symbol]-allClassOpsID (ClassDescr _ _ _ classOpsID _ _) = classOpsID-allClassOpsID _ = []+mbComment :: Descr -> Maybe ByteString+mbComment d+ | isReexported d = mbComment (impDescr d)+ | otherwise = mbComment' d -typeInfo :: IdentifierDescr -> TypeInfo-typeInfo (SimpleDescr _ _ ti _ _ _) = ti-typeInfo (DataDescr _ ti _ _ _ _ _) = ti-typeInfo (ClassDescr _ ti _ _ _ _) = ti-typeInfo (InstanceDescr _ _ _ _ _) = BS.pack ""+details :: Descr -> SpDescr+details d+ | isReexported d = details (impDescr d)+ | otherwise = details' d -idDescriptionsPD :: PackageDescr -> [IdentifierDescr]-idDescriptionsPD pd = concatMap idDescriptionsMD (exposedModulesPD pd) -instance Default IdentifierDescr where- getDefault = SimpleDescr getDefault getDefault getDefault getDefault getDefault- getDefault+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) -data IdType = Function | Newtype | Type | AbstractData | OpenData | Foreign- | Data | Class | Instance | Constructor | Field | Method | OrphanedInstance- deriving (Show, Eq, Ord, Enum, Read)+instance Eq Descr where+ (== ) a b = descrName a == descrName b+ && descrType (details a) == descrType (details b) -instance Default IdType where- getDefault = Function+instance Ord Descr where+ (<=) a b = if descrName a == descrName b+ then descrType (details a) <= descrType (details b)+ else descrName a < descrName b -data IdTypeS = FunctionS | NewtypeS | TypeS | AbstractDataS | OpenDataS | ForeignS- deriving (Show, Eq, Ord, Enum, Read)+data DescrType = Variable | Field | Constructor | Data | Type | Newtype+ | Class | Method | Instance+ deriving (Show, Eq, Ord, Bounded, Enum, Read) -instance Default IdTypeS where- getDefault = FunctionS+instance Default DescrType where+ getDefault = Variable -idType :: IdentifierDescr -> IdType-idType (SimpleDescr _ stype _ _ _ _) = case stype of- FunctionS -> Function- NewtypeS -> Newtype- TypeS -> Type- AbstractDataS -> AbstractData- OpenDataS -> OpenData- ForeignS -> Foreign-idType (DataDescr _ _ _ _ _ _ _) = Data-idType (ClassDescr _ _ _ _ _ _) = Class-idType (InstanceDescr _ _ _ _ _) = Instance+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+--type ModuleIdentifier = String -- always qualified data PackModule = PM { pack :: PackageIdentifier- , modu :: ModuleIdentifier}+ , modu :: ModuleName} deriving (Eq, Ord,Read,Show) -- showPackModule :: PackModule -> String-showPackModule (PM p m) = showPackageId p ++ ":" ++ m+showPackModule (PM p m) = display p ++ ":" ++ display m parsePackModule :: String -> PackModule parsePackModule str = let (pack',mod') = span (\c -> c /= ':') str- in if null (tail mod')- then perror str- else case toPackageIdentifier $ pack' of- Nothing -> perror str- Just pi'-> (PM pi' (tail mod'))+ 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 fromPackageIdentifier :: PackageIdentifier -> String-fromPackageIdentifier = showPackageId+fromPackageIdentifier = display toPackageIdentifier :: String -> Maybe PackageIdentifier-toPackageIdentifier pd = let l = filter (\ (_,s) -> null s)- $ readP_to_S parsePackageId pd- in if null l- then Nothing- else Just (fst $ head l)+toPackageIdentifier = simpleParse instance Default PackModule where getDefault = parsePackModule "unknow-0:Undefined"@@ -344,7 +351,7 @@ instance Default ByteString where getDefault = BS.empty -data Scope = World | Package | Local+data Scope = Local | Package | System deriving (Show, Eq, Ord, Enum, Read) newtype CandyTable = CT (CandyTableForth,CandyTableBack)@@ -360,6 +367,36 @@ type SpecialKeyCons alpha = Maybe ((Map (KeyVal,[Modifier]) (ActionDescr alpha)),String) +data LogTag = LogTag | ErrorTag | FrameTag++-- | the first one is the new and the second the old state+type GUIHistory = (GUIHistory', GUIHistory')++data GUIHistory' =+ ModuleSelected {+ moduleS :: Maybe ModuleName+ , facetS :: Maybe Symbol}+ | ScopeSelected {+ scope :: Scope+ , blacklist :: Bool}+ | InfoElementSelected {+ info :: Descr}+ | PaneSelected {+ paneN :: Maybe (String)}+ deriving (Eq, Ord, Show)++data SensitivityMask =+ SensitivityForwardHist+ | SensitivityBackwardHist+ | SensitivityProjectActive+ | SensitivityError+ | SensitivityEditor++ deriving (Eq, Ord, Show)++data SearchMode = Exact {caseSense :: Bool} | Prefix {caseSense :: Bool}+ | Regex {caseSense :: Bool}+ deriving (Eq,Ord,Read,Show)
src/IDE/DescriptionPP.hs view
@@ -4,31 +4,33 @@ -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL ----- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org> -- Stability : experimental -- Portability : portable ----- | Description with additional fileds for printing and parsing+-- | Description of a editor with additional fileds for printing and parsing -- ----------------------------------------------------------------------------------- module IDE.DescriptionPP ( Applicator , FieldDescriptionPP(..) , mkFieldPP+, extractFieldDescription+, flattenFieldDescriptionPP ) where -import Graphics.UI.Gtk hiding (Event)+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 IDE.Framework.Parameters-import IDE.Framework.EditorBasics+import Graphics.UI.Editor.Parameters+--import Graphics.UI.Editor.Basics+import Graphics.UI.Editor.MakeEditor import IDE.Core.State--type Applicator alpha = alpha -> IDEAction+import Graphics.UI.Editor.Basics (Applicator(..),Editor(..),Setter(..),Getter(..),Notifier(..),Extractor(..),Injector(..)) data FieldDescriptionPP alpha = FDPP { parameters :: Parameters@@ -37,6 +39,9 @@ , 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 ->@@ -45,12 +50,13 @@ (Getter alpha beta) -> (Setter alpha beta) -> (Editor beta) ->- (Applicator beta) ->+ (Applicator beta IDEM) -> FieldDescriptionPP alpha mkFieldPP :: Eq beta => MkFieldDescriptionPP alpha beta-mkFieldPP parameters printer parser getter setter editor applicator =- FDPP parameters+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)@@ -65,31 +71,26 @@ colon val <- parser return (setter val dat)))- (\ dat -> do- (widget, inj,ext,noti) <- editor parameters- inj (getter dat)- noti FocusOut (Left (\e -> do- v <- ext- case v of- Just _ -> do- widgetModifyFg widget StateNormal (Color 0 0 0)- return False- Nothing -> do- widgetModifyFg widget StateNormal (Color 65535 65535 0)- return False))- return (widget,- (\a -> inj (getter a)),- (\a -> do- b <- ext- case b of- Just b -> return (Just (setter b a))- Nothing -> return Nothing),- noti))- (\ newDat oldDat -> do --appicator+ 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 view
@@ -0,0 +1,95 @@+{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Exception+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- 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 view
@@ -0,0 +1,304 @@+module IDE.FileUtils (+ allModules+, allHiFiles+, allHaskellSourceFiles+, cabalFileName+, allCabalFiles+, getConfigFilePathForLoad+, hasConfigDir+, getConfigDir+, getConfigFilePathForSave+, getCollectorPath+, getSysLibDir+, moduleNameFromFilePath+, findKnownPackages+, isSubPath+, findSourceFile++, getInstalledPackageInfos+, findFittingPackages+) 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 (maximumBy,isSuffixOf,isPrefixOf)+import Distribution.ModuleName(ModuleName,toFilePath)+import Distribution.Text(simpleParse)+import Debug.Trace++import Paths_leksah+import IDE.Core.State+import GHC (setSessionDynFlags,getSessionDynFlags,Ghc(..))+import PackageConfig (PackageConfig(..))+import DynFlags (DynFlag(..),flags,pkgDatabase)+import UniqFM (eltsUFM)+import Distribution.Simple (PackageIdentifier(..),Dependency(..))+import qualified Distribution.InstalledPackageInfo as IPI (package)+import Distribution.Version (withinRange)+import Distribution.Package (pkgVersion)+import Data.Char (ord)++-- | 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) = do+ exists <- doesFileExist h+ if exists+ then return (Just h)+ else find' t++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++hasConfigDir :: IO Bool+hasConfigDir = do+ d <- getHomeDirectory+ let filePath = d </> ".leksah"+ doesDirectoryExist filePath+++getConfigFilePathForLoad :: String -> IO FilePath+getConfigFilePathForLoad fn = do+ cd <- getConfigDir+ ex <- doesFileExist (cd </> fn)+ if ex+ then return (cd </> fn)+ else 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 = 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 []++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 = do+ exists <- trace ("allFilesWithExtensions " ++ filePath) $ 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++++moduleNameFromFilePath :: FilePath -> IO (Maybe ModuleName)+moduleNameFromFilePath fp = do+ exists <- doesFileExist fp+ if exists+ then do+ str <- readFile fp+ 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+ sysMessage Normal $show err+ return Nothing+ Right str -> do+ let res = simpleParse str+ case res of+ Nothing -> do+ sysMessage Normal $ "FileUtils>>moduleNameFromFilePath " +++ "Can't parse module name " ++ str+ return Nothing+ Just mn -> return (Just mn)+ else return Nothing++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+-- skipMany anyChar+-- eof+ 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 = do+ paths <- getDirectoryContents filePath+ let nameList = map dropExtension $filter (\s -> ".pack" `isSuffixOf` s) paths+ return (Set.fromList nameList)++cabalFileName :: FilePath -> IO (Maybe String)+cabalFileName filePath = 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++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 = 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+ trace ("getSysLibDir " ++ libDir2) $ waitForProcess pid+ return (normalise libDir2)++-- ---------------------------------------------------------------------+-- The (mothers) little helpers+--++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++++
+ src/IDE/Find.hs view
@@ -0,0 +1,504 @@+{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses+ -XTypeSynonymInstances #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Find+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | The toolbar for searching and replacing in a text buffer+--+-------------------------------------------------------------------------------++module IDE.Find (+ toggleFindbar+, constructFindReplace+, hideFindbar+, showFindbar+, focusFindEntry+, editFindInc+, editGotoLine+, FindState(..)+, getFindState+, setFindState+, editFind++, showToolbar+, hideToolbar+, toggleToolbar+++) where++import Graphics.UI.Gtk hiding (get)+import Graphics.UI.Gtk.SourceView+import Graphics.UI.Gtk.Gdk.Events+import Data.Maybe+import Control.Monad.Reader+import Data.List++import IDE.Core.State+import IDE.Pane.SourceBuffer+import Data.Char (toUpper)+import Debug.Trace++data FindState = FindState {+ entryStr :: String+ , entryHist :: [String]+ , replaceStr :: String+ , replaceHist :: [String]+ , caseSensitive :: Bool+ , entireWord :: Bool+ , wrapAround :: Bool+ , backward :: Bool+ , lineNr :: Int}+ deriving(Eq,Ord,Show,Read)++getFindState :: IDEM FindState+getFindState = do+ fb <- readIDE findbar+ liftIO $ do+ lineNr <- getLineEntry fb >>= (\e -> spinButtonGetValueAsInt (castToSpinButton e))+ replaceStr <- getReplaceEntry fb >>= (\e -> entryGetText (castToEntry e))+ entryStr <- getFindEntry fb >>= (\e -> entryGetText (castToEntry e))+ entireWord <- getEntireWord fb+ wrapAround <- getWrapAround fb+ caseSensitive <- getCaseSensitive fb+ backward <- getBackward fb+ return FindState{+ entryStr = entryStr+ , entryHist = []+ , replaceStr = replaceStr+ , replaceHist = []+ , caseSensitive = caseSensitive+ , entireWord = entireWord+ , wrapAround = wrapAround+ , backward = backward+ , lineNr = lineNr}++setFindState :: FindState -> IDEAction+setFindState fs = do+ fb <- readIDE findbar+ liftIO $ do+ getLineEntry fb >>= (\e -> spinButtonSetValue (castToSpinButton e) (fromIntegral (lineNr fs)))+ getReplaceEntry fb >>= (\e -> entrySetText (castToEntry e) (replaceStr fs))+ getFindEntry fb >>= (\e -> entrySetText (castToEntry e) (entryStr fs))+ setEntireWord fb (entireWord fs)+ setWrapAround fb (wrapAround fs)+ setCaseSensitive fb (caseSensitive fs)+ setBackward fb (backward fs)+++hideToolbar :: IDEAction+hideToolbar = do+ mbtb <- trace "hide tool bar" $ readIDE toolbar+ case mbtb of+ Nothing -> return ()+ Just tb -> do+ modifyIDE_ (\ide -> return (ide{toolbarVisible = False}))+ liftIO $ widgetHideAll tb++showToolbar :: IDEAction+showToolbar = do+ mbtb <- readIDE toolbar+ case mbtb of+ Nothing -> return ()+ Just tb -> do+ modifyIDE_ (\ide -> return (ide{toolbarVisible = True}))+ liftIO $ widgetShowAll tb++toggleToolbar :: IDEAction+toggleToolbar = do+ toolBarVisible' <- readIDE toolbarVisible+ if toolBarVisible'+ then hideToolbar+ else showToolbar++hideFindbar :: IDEAction+hideFindbar = do+ fb <- readIDE findbar+ modifyIDE_ (\ide -> return (ide{findbarVisible = False}))+ liftIO $ widgetHideAll fb++showFindbar :: IDEAction+showFindbar = do+ fb <- readIDE findbar+ modifyIDE_ (\ide -> return (ide{findbarVisible = True}))+ liftIO $ widgetShowAll fb++focusFindEntry :: IDEAction+focusFindEntry = do+ fb <- readIDE findbar+ findbarVisible' <- readIDE findbarVisible+ when findbarVisible' $ liftIO $ do+ entry <- getFindEntry fb+ widgetGrabFocus entry++++toggleFindbar :: IDEAction+toggleFindbar = do+ findbarVisible' <- readIDE findbarVisible+ if findbarVisible'+ then hideFindbar+ else showFindbar++constructFindReplace :: Toolbar -> IDEM (Toolbar)+constructFindReplace toolbar = reifyIDE $ \ ideR session -> do+ closeButton <- toolButtonNewFromStock "gtk-close"+ toolbarInsert toolbar closeButton 0++ sep0 <- separatorToolItemNew+ separatorToolItemSetDraw sep0 False+ toolItemSetExpand sep0 True+ toolbarInsert toolbar sep0 0++ spinTool <- toolItemNew+ spinL <- spinButtonNewWithRange 1.0 1000.0 10.0+ widgetSetName spinL "gotoLineEntry"+ containerAdd spinTool spinL+ widgetSetName spinTool "gotoLineEntryTool"+ toolbarInsert toolbar spinTool 0++ labelTool3 <- toolItemNew+ label3 <- labelNew (Just "Goto Line :")+ containerAdd labelTool3 label3+ toolbarInsert toolbar labelTool3 0++ sep1 <- separatorToolItemNew+ toolbarInsert toolbar sep1 0++ replaceAllButton <- toolButtonNew (Nothing :: Maybe Widget) (Just "Replace All")+ toolbarInsert toolbar replaceAllButton 0++ replaceButton <- toolButtonNewFromStock "gtk-find-and-replace"+ toolbarInsert toolbar replaceButton 0++ replaceTool <- toolItemNew+ rentry <- entryNew+ widgetSetName rentry "replaceEntry"+ containerAdd replaceTool rentry+ widgetSetName replaceTool "replaceTool"+ toolbarInsert toolbar replaceTool 0++ labelTool2 <- toolItemNew+ label2 <- labelNew (Just "Replace: ")+ containerAdd labelTool2 label2+ toolbarInsert toolbar labelTool2 0++ sep2 <- separatorToolItemNew+ toolbarInsert toolbar sep2 0++ backwardButton <- toggleToolButtonNew+ toolButtonSetLabel backwardButton (Just "Backward")+ widgetSetName backwardButton "backwardButton"+ toolbarInsert toolbar backwardButton 0++ wrapAroundButton <- toggleToolButtonNew+ toolButtonSetLabel wrapAroundButton (Just "Wrap around")+ widgetSetName wrapAroundButton "wrapAroundButton"+ toolbarInsert toolbar wrapAroundButton 0++ entireWordButton <- toggleToolButtonNew+ toolButtonSetLabel entireWordButton (Just "Entire word")+ widgetSetName entireWordButton "entireWordButton"+ toolbarInsert toolbar entireWordButton 0++ caseSensitiveButton <- toggleToolButtonNew+ toolButtonSetLabel caseSensitiveButton (Just "Case sensitive")+ widgetSetName caseSensitiveButton "caseSensitiveButton"+ toolbarInsert toolbar caseSensitiveButton 0++ findButton <- toolButtonNewFromStock "gtk-find"+ toolbarInsert toolbar findButton 0++ entryTool <- toolItemNew+ entry <- entryNew+ widgetSetName entry "searchEntry"+ containerAdd entryTool entry+ widgetSetName entryTool "searchEntryTool"+ toolbarInsert toolbar entryTool 0++ labelTool <- toolItemNew+ label <- labelNew (Just "Search: ")+ containerAdd labelTool label+ toolbarInsert toolbar labelTool 0++ findButton `onToolButtonClicked` (doSearch toolbar Forward ideR session)++ entry `afterInsertText` (\t i -> do+ doSearch toolbar Insert ideR session+ return i)+ entry `afterDeleteText` (\ _ _ -> doSearch toolbar Delete ideR session)+ entry `afterKeyPress` (\ e -> case e of+ k@(Key _ _ _ _ _ _ _ _ _ _)+ | eventKeyName k == "Down" -> do+ doSearch toolbar Forward ideR session+ return True+ | eventKeyName k == "Up" -> do+ doSearch toolbar Backward ideR session+ return True+ | eventKeyName k == "Escape" -> do+ getOut ideR session+ return True+ | otherwise -> return True+ _ -> return True)+ entry `onEntryActivate` getOut ideR session+ replaceButton `onToolButtonClicked` replace toolbar Forward ideR session++ replaceAllButton `onToolButtonClicked` replaceAll toolbar Forward ideR session+++ spinL `afterFocusIn` (\ _ -> (reflectIDE (inBufContext True $ \_ gtkbuf currentBuffer _ -> do+ max <- textBufferGetLineCount gtkbuf+ spinButtonSetRange spinL 1.0 (fromIntegral max)+ return True) ideR session))+++ spinL `afterEntryActivate` (reflectIDE (inBufContext () $ \_ gtkbuf currentBuffer _ -> do+ line <- spinButtonGetValueAsInt spinL+ iter <- textBufferGetStartIter gtkbuf+ textIterSetLine iter (line - 1)+ textBufferPlaceCursor gtkbuf iter+ textViewScrollToIter (sourceView currentBuffer) iter 0.2 Nothing+ return ()) ideR session)++ closeButton `onToolButtonClicked` do+ reflectIDE hideFindbar ideR session++ set toolbar [ toolbarChildHomogeneous spinTool := False ]+ set toolbar [ toolbarChildHomogeneous wrapAroundButton := False ]+ set toolbar [ toolbarChildHomogeneous entireWordButton := False ]+ set toolbar [ toolbarChildHomogeneous caseSensitiveButton := False ]+ set toolbar [ toolbarChildHomogeneous backwardButton := False ]+ set toolbar [ toolbarChildHomogeneous replaceAllButton := False ]+ set toolbar [ toolbarChildHomogeneous labelTool := False ]+ set toolbar [ toolbarChildHomogeneous labelTool2 := False ]+ set toolbar [ toolbarChildHomogeneous labelTool3 := False ]++ return toolbar+ where getOut = reflectIDE $ do+ hideFindbar+ mbbuf <- maybeActiveBuf+ case mbbuf of+ Nothing -> return ()+ Just buf -> do+ liftIO $ widgetGrabFocus (sourceView buf)+ return ()+++doSearch :: Toolbar -> SearchHint -> IDERef -> Session -> IO ()+doSearch fb hint ideR session = do+ entry <- getFindEntry fb+ search <- entryGetText (castToEntry entry)+ entireWord <- getEntireWord fb+ caseSensitive <- getCaseSensitive fb+ wrapAround <- getWrapAround fb+ res <- reflectIDE (editFind entireWord caseSensitive wrapAround search "" hint) ideR session+ if res || null search+ then do+ widgetModifyBase entry StateNormal white+ widgetModifyText entry StateNormal black+ else do+ widgetModifyBase entry StateNormal red+ widgetModifyText entry StateNormal white+ return ()++replace :: Toolbar -> SearchHint -> IDERef -> Session -> IO ()+replace fb hint ideR session = do+ entry <- getFindEntry fb+ search <- entryGetText (castToEntry entry)+ rentry <- getReplaceEntry fb+ replace <- entryGetText (castToEntry rentry)+ entireWord <- getEntireWord fb+ caseSensitive <- getCaseSensitive fb+ wrapAround <- getWrapAround fb+ found <- reflectIDE (editReplace entireWord caseSensitive wrapAround search replace hint)+ ideR session+ return ()+++replaceAll :: Toolbar -> SearchHint -> IDERef -> Session -> IO ()+replaceAll fb hint ideR session = do+ entry <- getFindEntry fb+ search <- entryGetText (castToEntry entry)+ rentry <- getReplaceEntry fb+ replace <- entryGetText (castToEntry rentry)+ entireWord <- getEntireWord fb+ caseSensitive <- getCaseSensitive fb+ wrapAround <- getWrapAround fb+ found <- reflectIDE (editReplaceAll entireWord caseSensitive wrapAround search replace hint)+ ideR session+ return ()++editFind :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool+editFind entireWord caseSensitive wrapAround search dummy hint =+ let searchflags = (if caseSensitive then [] else [toEnum 4]) ++ [toEnum 1,toEnum 2] in+ if null search+ then return False+ else inBufContext' False $ \_ gtkbuf currentBuffer _ -> liftIO $ do+ i1 <- textBufferGetStartIter gtkbuf+ i2 <- textBufferGetEndIter gtkbuf+ textBufferRemoveTagByName gtkbuf "found" i1 i2+ startMark <- textBufferGetInsert gtkbuf+ st1 <- textBufferGetIterAtMark gtkbuf startMark+ mbsr2 <-+ if hint == Backward+ then do+ textIterBackwardChar st1+ textIterBackwardChar st1+ mbsr <- backSearch st1 search searchflags entireWord searchflags+ case mbsr of+ Nothing ->+ if wrapAround+ then do backSearch i2 search searchflags entireWord searchflags+ else return Nothing+ Just (start,end) -> return (Just (start,end))+ else do+ if hint == Forward+ then textIterForwardChar st1+ else return True+ mbsr <- forwardSearch st1 search searchflags entireWord searchflags+ case mbsr of+ Nothing ->+ if wrapAround+ then do forwardSearch i1 search searchflags entireWord searchflags+ else return Nothing+ Just (start,end) -> return (Just (start,end))+ case mbsr2 of+ Just (start,end) -> do --found+ --widgetGrabFocus sourceView+ textViewScrollToIter (sourceView currentBuffer) start 0.2 Nothing+ textBufferApplyTagByName gtkbuf "found" start end+ textBufferPlaceCursor gtkbuf start+ return True+ Nothing -> return False+ where+ backSearch iter string flags entireWord searchflags = do+ mbsr <- sourceIterBackwardSearch iter search searchflags Nothing+ case mbsr of+ Nothing -> return Nothing+ Just (iter1,iter2) ->+ if entireWord+ then do+ b1 <- textIterStartsWord iter1+ b2 <- textIterEndsWord iter2+ if b1 && b2 then return $Just (iter1,iter2) else return Nothing+ else return (Just (iter1,iter2))+ forwardSearch iter string flags entireWord searchflags = do+ mbsr <- sourceIterForwardSearch iter search searchflags Nothing+ case mbsr of+ Nothing -> return Nothing+ Just (iter1,iter2) ->+ if entireWord+ then do+ b1 <- textIterStartsWord iter1+ b2 <- textIterEndsWord iter2+ if b1 && b2 then return $Just (iter1,iter2) else return Nothing+ else return $Just (iter1,iter2)++editReplace :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool+editReplace entireWord caseSensitive wrapAround search replace hint =+ editReplace' entireWord caseSensitive wrapAround search replace hint True++editReplace' :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> Bool -> IDEM Bool+editReplace' entireWord caseSensitive wrapAround search replace hint mayRepeat =+ inBufContext' False $ \_ gtkbuf currentBuffer _ -> do+ startMark <- liftIO $textBufferGetInsert gtkbuf+ iter <- liftIO $textBufferGetIterAtMark gtkbuf startMark+ iter2 <- liftIO $textIterCopy iter+ liftIO $textIterForwardChars iter2 (length search)+ str1 <- liftIO $textIterGetText iter iter2+ if compare str1 search caseSensitive+ then do+ liftIO $textBufferDelete gtkbuf iter iter2+ liftIO $textBufferInsert gtkbuf iter replace+ editFind entireWord caseSensitive wrapAround search "" hint+ else do+ r <- editFind entireWord caseSensitive wrapAround search "" hint+ if r+ then editReplace' entireWord caseSensitive wrapAround search+ replace hint False+ else return False+ where+ compare s1 s2 True = s1 == s2+ compare s1 s2 False = map toUpper s1 == map toUpper s2++editReplaceAll :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool+editReplaceAll entireWord caseSensitive wrapAround search replace hint = do+ res <- editReplace' entireWord caseSensitive wrapAround search replace hint True+ if res+ then editReplaceAll entireWord caseSensitive wrapAround search replace hint+ else return False++red = Color 640000 10000 10000+white = Color 64000 64000 64000+black = Color 0 0 0++editFindInc :: SearchHint -> IDEAction+editFindInc hint = do+ showFindbar+ fb <- readIDE findbar+ reifyIDE $ \ideR session -> do+ entry <- getFindEntry fb+ widgetGrabFocus entry+ case hint of+ Forward -> doSearch fb Forward ideR session+ Backward -> doSearch fb Backward ideR session+ _ -> return ()++editGotoLine :: IDEAction+editGotoLine = do+ showFindbar+ fb <- readIDE findbar+ entry <- liftIO $ getLineEntry fb+ liftIO $ widgetGrabFocus entry++getLineEntry, getReplaceEntry, getFindEntry :: Toolbar -> IO Widget+getLineEntry = getWidget "gotoLineEntryTool"+getReplaceEntry = getWidget "replaceTool"+getFindEntry = getWidget "searchEntryTool"++getWidget :: String -> Toolbar -> IO Widget+getWidget str tb = do+ widgets <- containerGetChildren tb+ entryL <- filterM (\w -> liftM (== str) (widgetGetName w) ) widgets+ case entryL of+ [w] -> do+ mbw <- binGetChild (castToBin w)+ case mbw of+ Nothing -> throwIDE "Find>>getWidget not found(1)"+ Just w -> return w+ _ -> throwIDE "Find>>getWidget not found(2)"++getEntireWord, getWrapAround, getCaseSensitive :: Toolbar -> IO Bool+getEntireWord = getSelection "entireWordButton"+getWrapAround = getSelection "wrapAroundButton"+getCaseSensitive = getSelection "caseSensitiveButton"+getBackward = getSelection "backwardButton"++getSelection :: String -> Toolbar -> IO Bool+getSelection str tb = do+ widgets <- containerGetChildren tb+ entryL <- filterM (\w -> liftM (== str) (widgetGetName w) ) widgets+ case entryL of+ [w] -> toggleToolButtonGetActive (castToToggleToolButton w)+ _ -> throwIDE "Find>>getIt widget not found"++setEntireWord, setWrapAround, setCaseSensitive, setBackward :: Toolbar -> Bool -> IO ()+setEntireWord = setSelection "entireWordButton"+setWrapAround = setSelection "wrapAroundButton"+setCaseSensitive = setSelection "caseSensitiveButton"+setBackward = setSelection "backwardButton"++setSelection :: String -> Toolbar -> Bool -> IO ()+setSelection str tb bool = do+ widgets <- containerGetChildren tb+ entryL <- filterM (\w -> liftM (== str) (widgetGetName w) ) widgets+ case entryL of+ [w] -> toggleToolButtonSetActive (castToToggleToolButton w) bool+ _ -> throwIDE "Find>>getIt widget not found"
− src/IDE/FindPane.hs
@@ -1,361 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.FindPane--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | The pane of ide for searching in a text buffer-------------------------------------------------------------------------------------module IDE.FindPane (- IDEFind(..)-, FindAction(..)-, FindState(..)-, editFind-) where--import Graphics.UI.Gtk hiding (get)-import Graphics.UI.Gtk.SourceView-import Data.Maybe-import Control.Monad.Reader-import Data.List--import IDE.Core.State-import IDE.Framework.ViewFrame-import IDE.SourceEditor--------------------------------------------------------------------------------------- * Interface-----class FindAction alpha where- doFind :: alpha- editFindInc :: SearchHint -> alpha- editFindKey :: Event -> alpha- editGotoLine :: alpha- editGotoLineEnd :: alpha- editGotoLineKey :: Event -> alpha--instance FindAction IDEAction where- doFind = doFind'- editFindInc = editFindInc'- editFindKey = editFindKey'- editGotoLine = editGotoLine'- editGotoLineEnd = editGotoLineEnd'- editGotoLineKey = editGotoLineKey'--instance IDEObject IDEFind--instance CastablePane IDEFind where- casting _ = FindCasting- downCast _ (PaneC a) = case casting a of- FindCasting -> Just a- _ -> Nothing---instance Recoverable FindState where- toPaneState a = FindSt a--instance Pane IDEFind- where- primPaneName _ = "Find"- getAddedIndex _ = 0- getTopWidget = castToWidget . findBox- paneId b = "*Find"- makeActive p = throwIDE "don't activate find bar"- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- lift $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> lift $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- lift $notebookRemovePage nb i- removePaneAdmin pane---instance RecoverablePane IDEFind FindState where- saveState p = do- mbFind <- getPane FindCasting- case mbFind of- Nothing -> return Nothing- Just p -> lift $ do- return (Just (StateC FindState))- recoverState pp FindState = do- nb <- getNotebook pp- initFind pp nb--------------------------------------------------------------------------------------- * Implementation-----doFind' :: IDEAction-doFind' = do- find :: IDEFind <- getFind- lift $ bringPaneToFront find- lift $ widgetGrabFocus (getTopWidget find)---getFind :: IDEM IDEFind-getFind = do- mbFind <- getPane FindCasting- case mbFind of- Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (controlPanePath prefs) layout- nb <- getNotebook pp- initFind pp nb- mbFind <- getPane FindCasting- case mbFind of- Nothing -> throwIDE "Can't init find pane"- Just m -> return m- Just m -> return m--initFind :: PanePath -> Notebook -> IDEAction-initFind panePath nb = do- ideR <- ask- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- currentInfo <- readIDE currentInfo- (buf,cids) <- lift $ do- hBox <- hBoxNew False 10- bBox <- hButtonBoxNew-- entry <- entryNew- widgetSetName entry "searchEntry"-- caseSensitiveButton <- toggleButtonNew- buttonSetLabel caseSensitiveButton "Case sensitive"- widgetSetName caseSensitiveButton "caseSensitiveButton"-- entireWordButton <- toggleButtonNew- buttonSetLabel entireWordButton "Entire word"- widgetSetName entireWordButton "entireWordButton"-- wrapAroundButton <- toggleButtonNew- buttonSetLabel wrapAroundButton "Wrap around"- toggleButtonSetActive wrapAroundButton True- widgetSetName wrapAroundButton "wrapAroundButton"-- spinL <- spinButtonNewWithRange 1.0 1000.0 10.0- widgetSetName spinL "gotoLineEntry"-- boxPackStart hBox entry PackNatural 10- boxPackStart bBox caseSensitiveButton PackNatural 10- boxPackStart bBox entireWordButton PackNatural 10- boxPackStart bBox wrapAroundButton PackNatural 10- boxPackStart hBox bBox PackNatural 10- boxPackStart hBox spinL PackNatural 10-- entry `afterInsertText` (\ _ _ -> do- runReaderT ((editFindInc Insert)::IDEAction) ideR- t <- entryGetText entry- return (length t))- entry `afterDeleteText` (\ _ _ -> do runReaderT ((editFindInc Delete)::IDEAction)- ideR; return ())- entry `afterKeyPress` (\ e -> do runReaderT ((editFindKey e)::IDEAction)- ideR; return True)- spinL `afterKeyPress` (\ e -> do runReaderT ((editGotoLineKey e)::IDEAction)- ideR; return True)- spinL `afterEntryActivate` runReaderT editGotoLineEnd ideR- spinL `afterFocusOut` (\ _ -> do runReaderT (editGotoLineEnd::IDEAction) ideR;- return False)- let find = IDEFind hBox caseSensitiveButton wrapAroundButton entireWordButton- spinL entry- notebookInsertOrdered nb hBox (paneName find)- widgetShowAll hBox- return (find,[])- addPaneAdmin buf (BufConnections [] [] []) panePath- lift $widgetGrabFocus (findBox buf)--getFindEntry' :: IDEFind -> Entry-getFindEntry' f = findEntry f--getCaseSensitive' :: IDEFind -> ToggleButton-getCaseSensitive' f = caseSensitive f--getWrapAround' :: IDEFind -> ToggleButton-getWrapAround' f = wrapAround f--getEntireWord' :: IDEFind -> ToggleButton-getEntireWord' f = entireWord f--getGotoLineSpin' :: IDEFind -> SpinButton-getGotoLineSpin' f = gotoLine f--red = Color 640000 10000 10000-white = Color 64000 64000 64000-black = Color 0 0 0--{-- can't be used currently becuase of an export error- toEnum 1 = SourceSearchVisibleOnly- toEnum 2 = SourceSearchTextOnly- toEnum 4 = SourceSearchCaseInsensitive---}----- | Keys for searching-editFindKey' :: Event -> IDEAction-editFindKey' k@(Key _ _ _ _ _ _ _ _ _ _)- | eventKeyName k == "Down" =- editFindInc Forward- | eventKeyName k == "Up" =- editFindInc Backward- | eventKeyName k == "Escape" = do- --entry <- getFindEntry- inBufContext' () $ \_ gtkbuf currentBuffer _ -> lift $ do- i1 <- textBufferGetStartIter gtkbuf- i2 <- textBufferGetEndIter gtkbuf- textBufferRemoveTagByName gtkbuf "found" i1 i2- startMark <- textBufferGetInsert gtkbuf- st1 <- textBufferGetIterAtMark gtkbuf startMark- textBufferPlaceCursor gtkbuf st1- widgetGrabFocus $ sourceView currentBuffer- | otherwise = return ()-editFindKey' _ = return ()--editFindInc' :: SearchHint -> IDEAction-editFindInc' hint = do- find :: IDEFind <- getFind- let entry = getFindEntry' find- lift $ widgetGrabFocus entry- lift $ bringPaneToFront find- when (hint == Initial) $ lift $ editableSelectRegion entry 0 (-1)- search <- lift $entryGetText entry- if null search- then return ()- else do- let caseSensitiveW = getCaseSensitive' find- caseSensitive <- lift $toggleButtonGetActive caseSensitiveW- let entireWButton = getEntireWord' find- entireW <- lift $toggleButtonGetActive entireWButton- let wrapAroundButton = getWrapAround' find- wrapAround <- lift $toggleButtonGetActive wrapAroundButton- res <- editFind entireW caseSensitive wrapAround search "" hint- if res || null search- then lift $do- widgetModifyBase entry StateNormal white- widgetModifyText entry StateNormal black- else lift $do- widgetModifyBase entry StateNormal red- widgetModifyText entry StateNormal white- lift $do- widgetGrabFocus entry- editableSelectRegion entry 0 (-1)---editFind :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool-editFind entireWord caseSensitive wrapAround search dummy hint =- let searchflags = (if caseSensitive then [] else [toEnum 4]) ++ [toEnum 1,toEnum 2] in- if null search- then return False- else inBufContext' False $ \_ gtkbuf currentBuffer _ -> lift $ do- i1 <- textBufferGetStartIter gtkbuf- i2 <- textBufferGetEndIter gtkbuf- textBufferRemoveTagByName gtkbuf "found" i1 i2- startMark <- textBufferGetInsert gtkbuf- st1 <- textBufferGetIterAtMark gtkbuf startMark- mbsr2 <-- if hint == Backward- then do- textIterBackwardChar st1- textIterBackwardChar st1- mbsr <- backSearch st1 search searchflags entireWord searchflags- case mbsr of- Nothing ->- if wrapAround- then do backSearch i2 search searchflags entireWord searchflags- else return Nothing- Just (start,end) -> return (Just (start,end))- else do- if hint == Forward- then textIterForwardChar st1- else return True- mbsr <- forwardSearch st1 search searchflags entireWord searchflags- case mbsr of- Nothing ->- if wrapAround- then do forwardSearch i1 search searchflags entireWord searchflags- else return Nothing- Just (start,end) -> return (Just (start,end))- case mbsr2 of- Just (start,end) -> do --found- --widgetGrabFocus sourceView- textViewScrollToIter (sourceView currentBuffer) start 0.2 Nothing- textBufferApplyTagByName gtkbuf "found" start end- textBufferPlaceCursor gtkbuf start- return True- Nothing -> return False- where- backSearch iter string flags entireWord searchflags = do- mbsr <- sourceIterBackwardSearch iter search searchflags Nothing- case mbsr of- Nothing -> return Nothing- Just (iter1,iter2) ->- if entireWord- then do- b1 <- textIterStartsWord iter1- b2 <- textIterEndsWord iter2- if b1 && b2 then return $Just (iter1,iter2) else return Nothing- else return (Just (iter1,iter2))- forwardSearch iter string flags entireWord searchflags = do- mbsr <- sourceIterForwardSearch iter search searchflags Nothing- case mbsr of- Nothing -> return Nothing- Just (iter1,iter2) ->- if entireWord- then do- b1 <- textIterStartsWord iter1- b2 <- textIterEndsWord iter2- if b1 && b2 then return $Just (iter1,iter2) else return Nothing- else return $Just (iter1,iter2)--editGotoLine' :: IDEAction-editGotoLine' = inBufContext' () $ \_ gtkbuf currentBuffer _ -> do- find :: IDEFind <- getFind- let spin = getGotoLineSpin' find- lift $ bringPaneToFront find- lift $do- max <- textBufferGetLineCount gtkbuf- spinButtonSetRange spin 1.0 (fromIntegral max)- widgetGrabFocus spin--editGotoLineKey' :: Event -> IDEAction-editGotoLineKey' k@(Key _ _ _ _ _ _ _ _ _ _)- | eventKeyName k == "Escape" =- inBufContext' () $ \_ gtkbuf currentBuffer _ -> do- find :: IDEFind <- getFind- let spin = getGotoLineSpin' find- lift $ do- widgetGrabFocus $ sourceView currentBuffer- | otherwise = return ()-editGotoLineKey' _ = return ()--editGotoLineEnd' :: IDEAction-editGotoLineEnd' = inBufContext' () $ \_ gtkbuf currentBuffer _ -> do- find :: IDEFind <- getFind- let spin = getGotoLineSpin' find- lift $ bringPaneToFront find- lift $ do- line <- spinButtonGetValueAsInt spin- iter <- textBufferGetStartIter gtkbuf- textIterSetLine iter (line - 1)- textBufferPlaceCursor gtkbuf iter- textViewScrollToIter (sourceView currentBuffer) iter 0.2 Nothing- widgetGrabFocus $ sourceView currentBuffer----
− src/IDE/Framework/CompositeEditors.hs
@@ -1,402 +0,0 @@------------------------------------------------------------------------------------ Module : IDE.Framework.CompositeEditors--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | Module for making composite editors-----------------------------------------------------------------------------------------module IDE.Framework.CompositeEditors (- maybeEditor-, pairEditor-, eitherOrEditor-, multisetEditor-, ColumnDescr(..)-) where--import Graphics.UI.Gtk-import Graphics.UI.Gtk.ModelView as New-import Control.Monad-import Data.IORef-import Data.Maybe--import IDE.Utils.Default-import IDE.Core.Exception-import IDE.Framework.Parameters-import IDE.Framework.EditorBasics-import IDE.Framework.MakeEditor-import IDE.Framework.SimpleEditors------- | An editor which composes two subeditors----pairEditor :: (Editor alpha, Parameters) -> (Editor beta, Parameters) -> Editor (alpha,beta)-pairEditor (fstEd,fstPara) (sndEd,sndPara) parameters = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier- mkEditor- (\widget (v1,v2) -> do- core <- readIORef coreRef- case core of- Nothing -> do- fst@(fstFrame,inj1,ext1,noti1) <- fstEd fstPara- snd@(sndFrame,inj2,ext2,noti2) <- sndEd sndPara- 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- propagateEvent FocusOut noti2 notifier- 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)- (mkNotifier notifier)- parameters------- | 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 = do- coreRef <- newIORef Nothing- childRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier- mkEditor- (\widget mbVal -> do- core <- readIORef coreRef- case core of- Nothing -> do- be@(boolFrame,inj1,ext1,notifierBool) <- boolEditor- (paraName <<<- (ParaName boolLabel) $ emptyParams)- propagateEvent FocusOut notifierBool notifier- 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- notifierBool Clicked (Left (onClickedHandler widget coreRef childRef notifier))- case mbVal of- Nothing -> do- inj1 (if positive then False else True)- Just val -> do- (childWidget,inj2,ext2,noti2) <- getChildEditor childRef childEdit childParams notifier- boxPackEnd box childWidget PackNatural 0- widgetShowAll childWidget- inj1 (if positive then True else False)- inj2 val- writeIORef coreRef (Just (be,box))- Just (be@(boolFrame,inj1,ext1,notiRef1),box) -> do- hasChild <- hasChildEditor childRef- case mbVal of- Nothing -> do- if hasChild- then do- (childWidget,_,_,_) <- getChildEditor childRef childEdit childParams notifier- inj1 (if positive then False else True)- widgetHideAll childWidget- else inj1 (if positive then False else True)- Just val -> do- if hasChild- then do- (childWidget,inj2,_,_) <- getChildEditor childRef childEdit childParams notifier- widgetShowAll childWidget- inj2 val- else do- (childWidget,inj2,_,_) <- getChildEditor childRef childEdit childParams notifier- boxPackEnd box childWidget PackNatural 0- widgetShowAll childWidget- inj2 val)- (do- core <- readIORef coreRef- case core of- Nothing -> return Nothing- Just (be@(boolFrame,inj1,ext1,notiRef1),_) -> do- bool <- ext1- case bool of- Nothing -> return Nothing- Just bv | bv == positive -> do- (_,_,ext2,_) <- getChildEditor childRef childEdit childParams notifier- value <- ext2- case value of- Nothing -> return Nothing- Just value -> return (Just (Just value))- otherwise -> return (Just Nothing))- (mkNotifier notifier)- parameters- where- onClickedHandler widget coreRef childRef notifier = (\ event -> do- core <- readIORef coreRef- case core of- Nothing -> throwIDE "Impossible"- Just (be@(boolFrame,inj1,ext1,notiRef1),vBox) -> do- mbBool <- ext1- case mbBool of- Just bool ->- if not (bool == positive)- then do- hasChild <- hasChildEditor childRef- if hasChild- then do- (childWidget,_,_,_) <- getChildEditor childRef childEdit childParams notifier- widgetHideAll childWidget- else return ()- else do- hasChild <- hasChildEditor childRef- if hasChild- then do- (childWidget,_,_,_) <- getChildEditor childRef childEdit childParams notifier- widgetShowAll childWidget- else do- (childWidget,inj2,_,_) <- getChildEditor childRef childEdit childParams notifier- boxPackEnd vBox childWidget PackNatural 0- inj2 getDefault- widgetShowAll childWidget- Nothing -> return ()- return True)- getChildEditor childRef childEditor childParams notifier = do- mb <- readIORef childRef- case mb of- Just editor -> return editor- Nothing -> do- let val = childEditor- editor@(_,_,_,cnoti) <- childEditor childParams- propagateEvent FocusOut cnoti notifier- 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 = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier- mkEditor- (\widget v -> do- core <- readIORef coreRef- case core of- Nothing -> do- be@(boolFrame,inj1,ext1,noti1) <- boolEditor2 label2 parameters- le@(leftFrame,inj2,ext2,noti2) <- leftEditor leftParams- re@(rightFrame,inj3,ext3,noti3) <- rightEditor rightParams- noti1 Clicked (Left (onClickedHandler widget coreRef))- propagateEvent FocusOut noti2 notifier- propagateEvent FocusOut noti3 notifier- 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- activateEvent (castToWidget box) FocusOut notifier- 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) -> do- 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)))- (mkNotifier notifier)- (paraName <<<- (ParaName "") $ parameters)- 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 True)----- a trivial example: (ColumnDescr False [("",(\row -> [New.cellText := show row]))])--- and a nontrivial:--- [("Package",\(Dependency str _) -> [New.cellText := str])--- ,("Version",\(Dependency _ vers) -> [New.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) =>- ColumnDescr alpha -> (Editor alpha, Parameters) -> Editor [alpha]-multisetEditor (ColumnDescr showHeaders columnsDD) (singleEditor, sParams) parameters = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier- mkEditor- (\widget v -> 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,notS) <- singleEditor sParams- addButton <- buttonNewWithLabel "Add"- removeButton <- buttonNewWithLabel "Remove"- containerAdd buttonBox addButton- containerAdd buttonBox removeButton- listStore <- New.listStoreNew ([]:: [alpha])- list <- New.treeViewNewWithModel listStore- widgetSetSizeRequest list 50 50- sel <- New.treeViewGetSelection list- New.treeSelectionSetMode sel SelectionSingle- mapM_ (\(str,func) -> do- col <- New.treeViewColumnNew- New.treeViewColumnSetTitle col str- New.treeViewColumnSetResizable col True- New.treeViewAppendColumn list col- renderer <- New.cellRendererTextNew- New.cellLayoutPackStart col renderer True- New.cellLayoutSetAttributes col renderer listStore func- ) columnsDD- New.treeViewSetHeadersVisible list showHeaders- sel `New.onSelectionChanged` (selectionHandler sel listStore injS)- boxPackStart box list PackNatural 0- boxPackStart box buttonBox PackNatural 0- boxPackEnd box frameS PackGrow 0- activateEvent (castToWidget list) FocusOut notifier- containerAdd widget box- New.listStoreClear listStore- mapM_ (New.listStoreAppend listStore) v- addButton `onClicked` do- mbv <- extS- case mbv of- Just v -> do- New.listStoreAppend listStore v- return ()- Nothing -> return ()- removeButton `onClicked` do- mbi <- New.treeSelectionGetSelected sel- case mbi of- Nothing -> return ()- Just iter -> do- [i] <- New.treeModelGetPath listStore iter- New.listStoreRemove listStore i- writeIORef coreRef (Just listStore)- injS getDefault- Just listStore -> do- New.listStoreClear listStore- mapM_ (New.listStoreAppend listStore) v)- (do core <- readIORef coreRef- case core of- Nothing -> return Nothing- Just listStore -> do- v <- listStoreGetValues listStore- return (Just v))- (mkNotifier notifier)- parameters- where- listStoreGetValues :: New.ListStore a -> IO [a]- listStoreGetValues listStore = do- mbi <- New.treeModelGetIterFirst listStore- getTail mbi- where getTail mbi = case mbi of- Nothing -> return []- Just iter -> do- [i] <- New.treeModelGetPath listStore iter- v <- New.listStoreGetValue listStore i- mbi2 <- New.treeModelIterNext listStore iter- rest <- getTail mbi2- return (v : rest)- selectionHandler :: New.TreeSelection -> New.ListStore a -> Injector a -> IO ()- selectionHandler sel listStore inj = do- ts <- New.treeSelectionGetSelected sel- case ts of- Nothing -> return ()- Just iter -> do- [i] <- New.treeModelGetPath listStore iter- v <- New.listStoreGetValue listStore i- inj v- return ()-
− src/IDE/Framework/EditorBasics.hs
@@ -1,90 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.Framework.EditorBasics--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | Module for the basiscs of composing GUIs from editors-----------------------------------------------------------------------------------------module IDE.Framework.EditorBasics (--- * Types- Getter-, Setter-, Injector-, Extractor-, Editor---, Applicator-, Handler-, Notifier-, EventSelector(..)-) where--import Graphics.UI.Gtk --hiding (Event)-import Data.Unique--import Graphics.UI.Gtk --hiding (Event)--import IDE.Framework.Parameters---- ------------------------------------------------------------------------ * 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))----type Applicator beta = beta -> IDEAction ()----class EventSource alpha where----class Event alpha where--- event :: a -> Event------- | A type for handling an IO event--- Returning True: The event has been handles--- Returning False: Handling should proceed-type Handler = Event -> IO Bool--data EventSelector = Clicked- | FocusOut- | FocusIn- | SelectionChanged- | ButtonRelease- deriving (Eq,Ord,Show)------- | A type to register or unregister a handler--- 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-type Notifier = EventSelector -> Either Handler Unique -> IO (Unique)------- | A type to describe an editor.--- alpha is the type of the individual field of the record-type Editor alpha = Parameters -> IO(Widget, Injector alpha , Extractor alpha , Notifier)--
− src/IDE/Framework/MakeEditor.hs
@@ -1,265 +0,0 @@------------------------------------------------------------------------------------ Module : IDE.Framework.MakeEditor--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | Module for making editors out of descriptions-----------------------------------------------------------------------------------------module IDE.Framework.MakeEditor (-- FieldDescription(..)-, mkField-, emptyNotifier-, EventSelector(..)-, extractAndValidate-, extract-, mkEditor--, declareEvent-, activateEvent-, propagateEvent-, mkNotifier--) where--import Graphics.UI.Gtk hiding (Event)-import Control.Monad-import Data.IORef-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Unique--import IDE.Core.Exception-import IDE.Framework.Parameters-import IDE.Framework.EditorBasics------- | 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 :: Parameters- , fieldEditor :: alpha -> IO (Widget, Injector alpha , alpha -> Extractor alpha , Notifier)- }---- --------------------------------------------------------------- * Implementation of editing--- ------------------------------------------------------------------- | Function to construct a field description----mkField :: Eq beta => MkFieldDescription alpha beta-mkField parameters getter setter editor =- FD parameters- (\ dat -> do- (widget, inj,ext,noti) <- editor parameters- inj (getter dat)- noti FocusOut (Left (\e -> do- v <- ext- case v of- Just _ -> do- return False- Nothing -> do- sysMessage Normal "Validation Failure"- let message = case getParameterPrim paraName parameters of- Just s -> "in field " ++ s- Nothing -> "in unnamed field"- dia <- messageDialogNew Nothing [] MessageWarning ButtonsClose- ("Validation Failure " ++ message)- dialogRun dia- widgetDestroy dia- return False))- return (widget,- (\a -> inj (getter a)),- (\a -> do- b <- ext- case b of- Just b -> return (Just (setter b a))- Nothing -> return Nothing),- noti))---- | Function to construct an editor----mkEditor :: (Container -> Injector alpha) -> Extractor alpha -> Notifier -> Editor alpha-mkEditor injectorC extractor notifier parameters = 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- return ((castToWidget) outerAlig, injectorC (castToContainer innerAlig), extractor, notifier)---- | 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 getExts =- foldM (\ mbVal ext -> do- case mbVal of- Nothing -> return Nothing- Just val -> do- newVal <- ext val- return newVal)- (Just val) getExts---- --------------------------------------------------------------- * Implementation of notifications--- ------------------------------------------------------------------- | A type for a function to register an event----type RegFunc = Widget -> Handler -> IO (ConnectId Widget)------- | A type for the state of the notification system----type NotifierSt = IORef (Map EventSelector- (Maybe Widget,RegFunc,Maybe (ConnectId Widget),[(Unique, Handler)]))------- | Initial state of the notification system----emptyNotifier :: IO (NotifierSt)-emptyNotifier = newIORef(Map.empty)------- | Declare that the event can be thrown from this editor----declareEvent :: EventSelector -> RegFunc -> NotifierSt -> IO()-declareEvent eventSel regFunc notifierState = do- noti <- readIORef notifierState- case Map.lookup eventSel noti of- Nothing -> do- let noti2 = Map.insert eventSel (Nothing, regFunc, Nothing,[]) noti- writeIORef notifierState noti2- Just _ -> throwIDE $"editor has already declared event " ++ show eventSel------- | Activate the event after the widget has been constructed----activateEvent :: Widget -> EventSelector -> NotifierSt -> IO()-activateEvent widget eventSel notifierState = do- noti <- readIORef notifierState- case Map.lookup eventSel noti of- Nothing -> throwIDE $"editor has not declared event before activating it " ++ show eventSel- Just (Nothing,registerFunc,Nothing,handlers) -> do- cid <- registerFunc widget (\ e -> do- noti <- readIORef notifierState- case Map.lookup eventSel noti of- Nothing -> return False- Just (_,_,_,[]) -> return False- Just (_,_,_,handlers2) -> do- boolList <- mapM (\f -> f e) (map snd handlers2)- return (foldl (&&) True boolList))- let noti2 = Map.insert eventSel (Just widget,registerFunc,Just cid,handlers) noti- writeIORef notifierState noti2- Just _ -> throwIDE $"editor has already been activated " ++ show eventSel------- | Propagate the event with the selector from notifier to notifierst----propagateEvent :: EventSelector -> Notifier -> NotifierSt -> IO()-propagateEvent eventSel notiFrom notifierState = do- noti <- readIORef notifierState- case Map.lookup eventSel noti of- Nothing -> throwIDE $"can't propagte event which is not activated " ++ show eventSel- Just (mbWidget,registerFunc,Nothing,handlers) -> do- cid <- notiFrom eventSel (Left (\ e -> do- noti <- readIORef notifierState- case Map.lookup eventSel noti of- Nothing -> return False- Just (_,_,_,[]) -> return False- Just (_,_,_,handlers2) -> do- boolList <- mapM (\f -> f e) (map snd handlers2)- return (foldl (&&) True boolList)))- let noti2 = Map.insert eventSel (mbWidget,registerFunc,Nothing,handlers) noti- writeIORef notifierState noti2- Just _ -> throwIDE $"editor has already been activated " ++ show eventSel------- | Constructor for a notifier----mkNotifier :: NotifierSt -> Notifier-mkNotifier notifierState = notFunc- where- notFunc :: EventSelector -> Either Handler Unique -> IO (Unique)- notFunc eventSel (Left handler) = do- noti <- readIORef notifierState- uni <- newUnique- case Map.lookup eventSel noti of- Nothing -> throwIDE $"editor does not support event " ++ show eventSel- Just (Just widget,registerFunc,Nothing,handlers)- -> throwIDE $"mkNotifier for activated event" ++ show eventSel- Just (mbWidget, registerFunc, mbUnique, handlers)- -> do unique <- newUnique- let noti2 = Map.insert eventSel- (mbWidget,registerFunc,mbUnique,handlers++[(uni,handler)]) noti- writeIORef notifierState noti2- return unique- notFunc eventSel (Right uni) = do- noti <- readIORef notifierState- case Map.lookup eventSel noti of- Nothing -> throwIDE $"editor does not support event " ++ show eventSel- Just (mbWidget,regFunc,Just cid,l) -> do- let l2 = filter (\(u,_) -> u /= uni) l- if null l2- then do- signalDisconnect cid- let noti2 = Map.insert eventSel (mbWidget,regFunc,Nothing,[]) noti- writeIORef notifierState noti2- else do- let noti2 = Map.insert eventSel (mbWidget,regFunc,Just cid,l2) noti- writeIORef notifierState noti2- _ -> return ()- return uni----
− src/IDE/Framework/Parameters.hs
@@ -1,148 +0,0 @@------------------------------------------------------------------------------------ Module : IDE.Framework.Parameters--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | Module for parameters for editors-----------------------------------------------------------------------------------------module IDE.Framework.Parameters (- Parameters-, Parameter(..)-, paraName-, paraSynopsis-, paraDirection-, paraShadow-, paraOuterAlignment-, paraInnerAlignment-, paraOuterPadding-, paraInnerPadding-, paraMinSize-, paraHorizontal-, getParameter-, getParameterPrim-, (<<<-)-, emptyParams-, Direction(..)-, HorizontalAlign(..)-) where--import Graphics.UI.Gtk-import Data.Maybe-import qualified Data.List as List--import IDE.Core.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- deriving (Eq,Show)--instance Show ShadowType- where show _ = "Any Shadow"--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------- | 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 ""- , ParaSynopsis ""- , ParaDirection Horizontal- , ParaShadow ShadowNone- , ParaOuterAlignment (0.5, 0.5, 0.95, 0.95)- , ParaOuterPadding (2, 5, 3, 3)- , ParaInnerAlignment (0.5, 0.5, 0.95, 0.95)- , ParaInnerPadding (2, 5, 3, 3)- , ParaMinSize (-1,-1)- , ParaHorizontal Keep]
− src/IDE/Framework/SimpleEditors.hs
@@ -1,561 +0,0 @@------------------------------------------------------------------------------------ Module : IDE.Framework.SimpleEditors--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | Module for making simple editors-----------------------------------------------------------------------------------------module IDE.Framework.SimpleEditors (- boolEditor-, boolEditor2-, stringEditor-, multilineStringEditor-, intEditor-, genericEditor-, fontEditor-, staticSelectionEditor-, staticMultiselectionEditor-, multiselectionEditor-, fileEditor-, otherEditor-) where--import Graphics.UI.Gtk-import Graphics.UI.Gtk.ModelView as New-import Control.Monad-import Data.IORef-import Data.List-import Data.Maybe-import System.FilePath.Posix--import IDE.Framework.Parameters-import IDE.Framework.EditorBasics-import IDE.Framework.MakeEditor-import IDE.Core.Exception---- --------------------------------------------------------------- * 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 = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier- declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier- mkEditor- (\widget bool -> do- core <- readIORef coreRef- case core of- Nothing -> do- button <- checkButtonNewWithLabel (getParameter paraName parameters)- containerAdd widget button- toggleButtonSetActive button bool- activateEvent (castToWidget button) Clicked notifier- activateEvent (castToWidget button) FocusOut notifier- 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))- (mkNotifier notifier)- (paraName <<<- (ParaName "") $ parameters)------- | Editor for a boolean value in the form of two radio buttons----boolEditor2 :: String -> Editor Bool-boolEditor2 label2 parameters = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier- declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier- 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- containerAdd widget box- if bool- then do- toggleButtonSetActive radio1 True- else do- toggleButtonSetActive radio2 True- activateEvent (castToWidget radio1) Clicked notifier- activateEvent (castToWidget radio1) FocusOut notifier- writeIORef coreRef (Just (radio1,radio2))- Just (radio1,radio2) ->- if bool- then do- toggleButtonSetActive radio1 True- else do- toggleButtonSetActive radio2 True)- (do core <- readIORef coreRef- case core of- Nothing -> return Nothing- Just (radio1,radio2) -> do- r <- toggleButtonGetActive radio1- return (Just r))- (mkNotifier notifier)- (paraName <<<- (ParaName "") $ parameters)------- | Editor for a string in the form of a text entry----stringEditor :: Editor String-stringEditor parameters = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier- mkEditor- (\widget string -> do- core <- readIORef coreRef- case core of- Nothing -> do- entry <- entryNew- activateEvent (castToWidget entry) FocusOut notifier- 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- return (Just r))- (mkNotifier notifier)- parameters------- | Editor for a multiline string in the form of a multiline text entry----multilineStringEditor :: Editor String-multilineStringEditor parameters = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier- declareEvent ButtonRelease (\w h -> w `onButtonRelease` h) notifier- mkEditor- (\widget string -> do- core <- readIORef coreRef- case core of- Nothing -> do- aTextView <- textViewNew- aScrolledWindow <- scrolledWindowNew Nothing Nothing- scrolledWindowSetPolicy aScrolledWindow PolicyAutomatic PolicyAutomatic- containerAdd aScrolledWindow aTextView- containerAdd widget aScrolledWindow- activateEvent (castToWidget aTextView) FocusOut notifier- activateEvent (castToWidget aTextView) ButtonRelease notifier- 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))- (mkNotifier notifier)- parameters------- | Editor for an integer in the form of a spin entry----intEditor :: (Double,Double,Double) -> Editor Int-intEditor (min, max, step) parameters = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier- mkEditor- (\widget v -> do- core <- readIORef coreRef- case core of- Nothing -> do- spin <- spinButtonNewWithRange min max step- activateEvent (castToWidget spin) FocusOut notifier- 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)))- (mkNotifier notifier)- parameters------- | 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 = do- (wid,inj,ext,notif) <- stringEditor parameters- let ginj v = inj (show v)- let gext = do- s <- ext- case s of- Nothing -> return Nothing- Just s ->- let l = read s in- if null l then- return Nothing- else return (Just (head l))- return (wid,ginj,gext,notif)--#ifdef False------ | Editor for the selection of an element from a static list of elements in the--- | form of a combo box-staticSelectionEditor :: (Show beta, Eq beta) => [beta] -> Editor beta-staticSelectionEditor list parameters = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier- mkEditor- (\widget obj -> do- core <- readIORef coreRef- case core of- Nothing -> do- (combo,_) <- New.comboBoxNewText show list- activateEvent (castToWidget combo) FocusOut notifier- New.comboBoxSetActive combo 1- containerAdd widget combo- let ind = elemIndex obj list- case ind of- Just i -> New.comboBoxSetActive combo i- Nothing -> return ()- writeIORef coreRef (Just combo)- Just combo -> do- let ind = elemIndex obj list- case ind of- Just i -> New.comboBoxSetActive combo i- Nothing -> return ())- (do core <- readIORef coreRef- case core of- Nothing -> return Nothing- Just combo -> do- ind <- New.comboBoxGetActive combo- case ind of- i | i >= 0 -> return (Just (list !! i))- otherwise -> return Nothing)- (mkNotifier notifier)- parameters--#else-staticSelectionEditor :: (Show beta, Eq beta) => [beta] -> Editor beta-staticSelectionEditor list parameters = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier- mkEditor- (\widget obj -> do- core <- readIORef coreRef- case core of- Nothing -> do- combo <- New.comboBoxNewText- activateEvent (castToWidget combo) FocusOut notifier- New.comboBoxSetActive combo 1- containerAdd widget combo- mapM_ (\t -> New.comboBoxAppendText combo (show t)) list- let ind = elemIndex obj list- case ind of- Just i -> New.comboBoxSetActive combo i- Nothing -> return ()- writeIORef coreRef (Just combo)- Just combo -> do- let ind = elemIndex obj list- case ind of- Just i -> New.comboBoxSetActive combo i- Nothing -> return ())- (do core <- readIORef coreRef- case core of- Nothing -> return Nothing- Just combo -> do- mbInd <- New.comboBoxGetActive combo- case mbInd of- Just i -> return (Just (list !! i))- otherwise -> return Nothing)- (mkNotifier notifier)- parameters-#endif-------- | Editor for the selection of some elements from a static list of elements in the--- | form of a list box--multiselectionEditor :: (Show beta, Eq beta) => Editor [beta]-multiselectionEditor parameters = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier- mkEditor- (\widget objs -> do- core <- readIORef coreRef- case core of- Nothing -> do- listStore <- New.listStoreNew ([]:: [alpha])- listView <- New.treeViewNewWithModel listStore- activateEvent (castToWidget listView) FocusOut notifier- sel <- New.treeViewGetSelection listView- New.treeSelectionSetMode sel SelectionMultiple- renderer <- New.cellRendererTextNew- col <- New.treeViewColumnNew- New.treeViewAppendColumn listView col- New.cellLayoutPackStart col renderer True- New.cellLayoutSetAttributes col renderer listStore $ \row -> [ New.cellText := show row ]- New.treeViewSetHeadersVisible listView False- New.listStoreClear listStore- mapM_ (New.listStoreAppend listStore) objs- containerAdd widget listView- New.treeSelectionUnselectAll sel- --let inds = catMaybes $map (\obj -> elemIndex obj list) objs- --mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds- writeIORef coreRef (Just (listView,listStore))- Just (listView,listStore) -> do- New.listStoreClear listStore- mapM_ (New.listStoreAppend listStore) objs)- (do core <- readIORef coreRef- case core of- Nothing -> return Nothing- Just (listView,listStore) -> do- sel <- New.treeViewGetSelection listView- treePath <- New.treeSelectionGetSelectedRows sel- values <- mapM (\[i] -> listStoreGetValue listStore i) treePath- return (Just values))- (mkNotifier notifier)- parameters------- | Editor for the selection of some elements from a static list of elements in the--- | form of a list box--staticMultiselectionEditor :: (Show beta, Eq beta) => [beta] -> Editor [beta]-staticMultiselectionEditor list parameters = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier- mkEditor- (\widget objs -> do- core <- readIORef coreRef- case core of- Nothing -> do- listStore <- New.listStoreNew ([]:: [alpha])- listView <- New.treeViewNewWithModel listStore- activateEvent (castToWidget listView) FocusOut notifier- sel <- New.treeViewGetSelection listView- New.treeSelectionSetMode sel SelectionMultiple- renderer <- New.cellRendererTextNew- col <- New.treeViewColumnNew- New.treeViewAppendColumn listView col- New.cellLayoutPackStart col renderer True- New.cellLayoutSetAttributes col renderer listStore $ \row -> [ New.cellText := show row ]- New.treeViewSetHeadersVisible listView False- New.listStoreClear listStore- mapM_ (New.listStoreAppend listStore) list- containerAdd widget listView- New.treeSelectionUnselectAll sel- let inds = catMaybes $map (\obj -> elemIndex obj list) objs- mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds- writeIORef coreRef (Just listView)- Just listView -> do- sel <- New.treeViewGetSelection listView- New.treeSelectionUnselectAll sel- let inds = catMaybes $map (\obj -> elemIndex obj list) objs- mapM_ (\i -> New.treeSelectionSelectPath sel [i]) inds)- (do core <- readIORef coreRef- case core of- Nothing -> return Nothing- Just listView -> do- sel <- New.treeViewGetSelection listView- treePath <- New.treeSelectionGetSelectedRows sel- return (Just (map (\[i] -> list !! i) treePath)))- (mkNotifier notifier)- parameters------- | 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 = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent Clicked- (\widget handler -> do widget `onClicked` do- handler (Event True)- return ()) notifier- declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier- mkEditor- (\widget filePath -> do- core <- readIORef coreRef- case core of- Nothing -> do- button <- buttonNewWithLabel buttonName- entry <- entryNew- set entry [ entryEditable := False ]- activateEvent (castToWidget button) Clicked notifier- (mkNotifier 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)- activateEvent (castToWidget button) FocusOut notifier- 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))- (mkNotifier notifier)- parameters- 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 True- Just fn -> do- let relative = case mbFilePath of- Nothing -> fn- Just rel -> makeRelative rel fn- entrySetText entry relative- return True)------- | Editor for a font selection----fontEditor :: Editor (Maybe String)-fontEditor parameters = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent FocusOut (\w h -> w `onFocusOut` h) notifier- mkEditor- (\widget mbValue -> do- core <- readIORef coreRef- case core of- Nothing -> do- fs <- fontButtonNew- activateEvent (castToWidget fs) FocusOut notifier- 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)))- (mkNotifier notifier)- parameters------- | 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 = do- coreRef <- newIORef Nothing- notifier <- emptyNotifier- declareEvent Clicked (\w h -> w `onClicked` do h (Event True); return ()) notifier- declareEvent FocusIn (\w h -> w `onFocusIn` do h) notifier- declareEvent FocusOut (\w h -> w `onFocusOut` do h) notifier- mkEditor- (\widget val -> do- core <- readIORef coreRef- case core of- Nothing -> do- button <- buttonNewWithLabel (getParameter paraName parameters)- containerAdd widget button- activateEvent (castToWidget button) Clicked notifier- activateEvent (castToWidget button) FocusIn notifier- activateEvent (castToWidget button) FocusOut notifier- (mkNotifier 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))- (mkNotifier notifier)- (paraName <<<- (ParaName "") $ parameters)- where- buttonHandler coreRef = (\ e -> do- core <- readIORef coreRef- case core of- Nothing -> throwIDE "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 True- Just nval -> do- writeIORef coreRef (Just (b, nval))- return True)
− src/IDE/Framework/ViewFrame.hs
@@ -1,697 +0,0 @@------------------------------------------------------------------------------------ Module : IDE.Framework.ViewFrame--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable--------- | Splittable panes containing notebooks with any widgets---------------------------------------------------------------------------------------module IDE.Framework.ViewFrame (- removePaneAdmin-, addPaneAdmin-, notebookInsertOrdered---- * Convenience methods for accesing Pane state-, posTypeToPaneDirection-, paneDirectionToPosType-, paneFromName-, mbPaneFromName-, guiPropertiesFromName---- * View Actions-, viewMove-, viewSplitHorizontal-, viewSplitVertical-, viewSplit-, viewSplit'-, viewCollapse-, viewTabsPos-, viewSwitchTabs---- * View Queries-, getStandardPanePath-, getActivePanePath-, getActivePanePathOrStandard-, figureOutPaneName-, getNotebook-, getPaned-, getActiveNotebook-, getPane-, getPanes---- * View Actions-, bringPaneToFront-, newNotebook-, activatePane-, deactivatePane-, deactivatePaneIfActive---- * Accessing GUI elements-, widgetFromPath-, getCandyState-, setCandyState--, getSBSpecialKeys-, getSBActivePane-, getSBActivePackage-, getSBErrors-, getStatusbarIO-, getStatusbarLC--) where--import Graphics.UI.Gtk hiding (afterToggleOverwrite,onToggleOverwrite)-import Control.Monad.Reader-import qualified Data.Map as Map-import Data.Map (Map)-import Data.List-import Data.Maybe-import GHC.Exception(evaluate,catch)--import IDE.Core.State-import IDE.Core.Types-import IDE.Core.Panes-import IDE.Framework.Parameters--removePaneAdmin :: (CastablePane alpha,RecoverablePane alpha beta) => alpha -> IDEAction-removePaneAdmin pane = do- panes' <- readIDE panes- paneMap' <- readIDE paneMap- let newPanes = Map.delete (paneName pane) panes'- let newPaneMap = Map.delete (paneName pane) paneMap'- modifyIDE_ (\ide -> return (ide{panes = newPanes, paneMap = newPaneMap}))--addPaneAdmin :: (CastablePane alpha,RecoverablePane alpha beta) => alpha -> Connections -> PanePath -> IDEAction-addPaneAdmin pane conn pp = do- panes' <- readIDE panes- paneMap' <- readIDE paneMap- let newPaneMap = Map.insert (paneName pane) (pp, conn) paneMap'- let newPanes = Map.insert (paneName pane) (PaneC pane) panes'- modifyIDE_ (\ide -> return (ide{panes = newPanes,- paneMap = newPaneMap}))---notebookInsertOrdered :: (NotebookClass self, WidgetClass child) - => self - -> child -- child - the Widget to use as the contents of the page.- -> String -- tabLabel - the label for the page- -> IO ()-notebookInsertOrdered nb widget label = do- numPages <- notebookGetNPages nb- mbWidgets <- mapM (notebookGetNthPage nb) [0 .. (numPages-1)]- widgets <- catch (evaluate (map fromJust mbWidgets))- (\e -> throwIDE "ViewFrame.notebookInsertOrdered: no widget")- mbLabels <- mapM (notebookGetTabLabelText nb) widgets- labels <- catch (evaluate (map fromJust mbLabels))- (\e -> throwIDE "ViewFrame.notebookInsertOrdered: no label")- let pos = case findIndex (\s -> s > label) labels of- Just i -> i- Nothing -> -1- realPos <- notebookInsertPage nb widget label pos- notebookSetCurrentPage nb realPos-getPane :: CastablePane alpha => Casting alpha -> IDEM (Maybe alpha)-getPane casting = do- selectedPanes <- getPanes casting- if null selectedPanes || length selectedPanes > 1- then return Nothing- else (return (Just $head selectedPanes))--getPanes :: CastablePane alpha => Casting alpha -> IDEM ([alpha])-getPanes casting = do- panes' <- readIDE panes- return (catMaybes $ map (downCast casting) $ Map.elems panes')---- | Constructs a unique pane name, which is an index and a string-figureOutPaneName :: Pane alpha => Map String alpha -> String -> Int -> (Int,String)-figureOutPaneName bufs bn ind =- let ind = foldr (\buf ind ->- if primPaneName buf == bn- then max ind ((getAddedIndex buf) + 1)- else ind)- 0 (Map.elems bufs)- in if ind == 0- then (0,bn)- else (ind,bn ++ "(" ++ show ind ++ ")")--paneFromName :: PaneName -> IDEM IDEPane-paneFromName pn = do- mbPane <- mbPaneFromName pn- case mbPane of- Just p -> return p- Nothing -> throwIDE $"Cant't find pane from unique name " ++ pn--mbPaneFromName :: PaneName -> IDEM (Maybe IDEPane)-mbPaneFromName pn = do- panes <- readIDE panes- return (Map.lookup pn panes)---- |-guiPropertiesFromName :: PaneName -> IDEM (PanePath, Connections)-guiPropertiesFromName pn = do- paneMap <- readIDE paneMap- case Map.lookup pn paneMap of- Just it -> return it- otherwise -> throwIDE $"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--activatePane :: Pane alpha => alpha -> Connections -> IDEAction-activatePane pane conn = do- deactivatePane- sb <- getSBActivePane- lift $statusbarPop sb 1- lift $statusbarPush sb 1 (paneName pane)- modifyIDE_ $ \ide -> do- bringPaneToFront pane- return (ide{activePane = Just (paneName pane,conn)})--deactivatePane :: IDEAction-deactivatePane = do- sb <- getSBActivePane- lift $statusbarPop sb 1- lift $statusbarPush sb 1 ""- mbAP <- readIDE activePane- case mbAP of- Just (_,BufConnections signals signals2 signals3) -> lift $do- mapM_ signalDisconnect signals- mapM_ signalDisconnect signals2- mapM_ signalDisconnect signals3- Nothing -> return ()- modifyIDE_ $ \ide -> do- return (ide{activePane = Nothing})--deactivatePaneIfActive :: Pane alpha => alpha -> IDEAction-deactivatePaneIfActive pane = do- mbActive <- readIDE activePane- case mbActive of- Nothing -> return ()- Just (n,_) -> if n == paneName pane- then deactivatePane- else return ()------ | Toggle the tabs of the current notebook----viewSwitchTabs :: IDEAction-viewSwitchTabs = do- mbNb <- getActiveNotebook- case mbNb of- Nothing -> return ()- Just nb -> lift $do- b <- notebookGetShowTabs nb- notebookSetShowTabs nb (not b)------- | Sets the tab position in the current notebook----viewTabsPos :: PositionType -> IDEAction-viewTabsPos pos = do- mbNb <- getActiveNotebook- case mbNb of- Nothing -> return ()- Just nb -> lift $notebookSetTabPos nb pos------- | Split the currently active pane in horizontal direction----viewSplitHorizontal :: IDEAction-viewSplitHorizontal = viewSplit Horizontal------- | Split the currently active pane in vertical direction----viewSplitVertical :: IDEAction-viewSplitVertical = viewSplit Vertical------- | The active view can be split in two (horizontal or vertical)----viewSplit :: Direction -> IDEAction-viewSplit dir = do- mbPanePath <- getActivePanePath- case mbPanePath of- Nothing -> return ()- Just panePath -> viewSplit' panePath dir--viewSplit' :: PanePath -> Direction -> IDEAction-viewSplit' panePath dir = do- activeNotebook <- getNotebook panePath- mbPD <- lift $ do- mbParent <- widgetGetParent activeNotebook- case mbParent of- Nothing -> return Nothing- Just parent -> do- --trace ("Pane path " ++ show panePath) return ()- newpane <- case dir of- Horizontal -> do h <- vPanedNew- return (castToPaned h)- Vertical -> do v <- hPanedNew- return (castToPaned v)- let (name,altname,paneDir) = case dir of- Horizontal -> ("top","bottom",TopP)- Vertical -> ("left","right",LeftP)- rName <- widgetGetName activeNotebook- widgetSetName newpane rName- nb <- newNotebook- widgetSetName nb altname- panedPack2 newpane nb True True- containerRemove (castToContainer parent) activeNotebook- widgetSetName activeNotebook name- panedPack1 newpane activeNotebook True True- if not (null panePath)- then- if (last panePath == TopP || last panePath == LeftP)- then panedPack1 (castToPaned parent) newpane True True- else panedPack2 (castToPaned parent) newpane True True- else do- boxPackStart (castToBox parent) newpane PackGrow 0- boxReorderChild (castToVBox parent) newpane 2- widgetShowAll newpane- widgetGrabFocus activeNotebook- return (Just (paneDir,dir))- case mbPD of- Just (paneDir,dir) -> do- let toPane = panePath ++ [paneDir]- adjustPane panePath toPane- adjustLayoutForSplit dir panePath- Nothing -> return ()------- | Two notebooks can be collapsed to one----viewCollapse :: IDEAction-viewCollapse = do- mbPanePath <- getActivePanePath- case mbPanePath of- Nothing -> return ()- Just panePath -> do- viewCollapse' panePath--viewCollapse' :: PanePath -> IDEAction-viewCollapse' panePath = do- layout1 <- readIDE layout- let newPanePath = reverse $tail $reverse panePath- let mbOtherSidePath = otherSide panePath- case mbOtherSidePath of- Nothing -> ideMessage Normal "Can't collapse top level"- Just otherSidePath ->- let sp1 = getSubpath panePath layout1- sp2 = getSubpath otherSidePath layout1- in do- case sp1 of- Nothing -> return ()- Just sp -> viewCollapse' sp- case sp2 of- Nothing -> return ()- Just sp -> viewCollapse' sp- paneMap <- readIDE paneMap- activeNotebook <- getNotebook panePath- let paneNamesToMove = map (\(w,(p,_)) -> w)- $filter (\(w,(p,_)) -> p == otherSidePath)- $Map.toList paneMap- panesToMove <- mapM paneFromName paneNamesToMove- mapM_ (move panePath) panesToMove- lift $ do- mbParent <- widgetGetParent activeNotebook- case mbParent of- Nothing -> throwIDE "collapse: no parent"- Just parent -> do- mbGrandparent <- widgetGetParent parent- case mbGrandparent of- Nothing -> throwIDE "collapse: no grandparent"- Just grandparent -> do- containerRemove (castToContainer grandparent) parent- containerRemove (castToContainer parent) activeNotebook- if length panePath > 1- then do- let dir = last newPanePath- if (dir == TopP || dir == LeftP)- then panedPack1 (castToPaned grandparent)- activeNotebook True True- else panedPack2 (castToPaned grandparent)- activeNotebook True True- widgetSetName activeNotebook $paneDirectionToWidgetName dir- else do- boxPackStart (castToVBox grandparent) activeNotebook PackGrow 0- boxReorderChild (castToVBox grandparent) activeNotebook 2- widgetSetName activeNotebook "root"- adjustLayoutForCollapse newPanePath- adjustPane panePath newPanePath- --adjustPane otherSidePath newPanePath------- | Moves the given Pane to the given path----move :: PanePath -> IDEPane -> IDEAction-move toPane idew = do- paneMap <- readIDE paneMap- let child = getTopWidget idew- (fromPane,cid) <- guiPropertiesFromName (paneName idew)- fromNB <- getNotebook fromPane- toNB <- getNotebook toPane- lift $ do- mbNum <- notebookPageNum fromNB child- case mbNum of- Nothing -> return ()- Just pn -> do- mbText <- notebookGetTabLabelText fromNB child- case mbText of- Nothing -> return ()- Just text -> do- notebookRemovePage fromNB pn- notebookInsertOrdered toNB child text- let paneMap1 = Map.delete (paneName idew) paneMap- let newPaneMap = Map.insert (paneName idew) (toPane,cid) paneMap1- modifyIDE_ (\ide -> return (ide{paneMap = newPaneMap}))------- | Moves the activePane in the given direction, if possible--- | If their are many possibilities choose the leftmost and topmost----viewMove :: PaneDirection -> IDEAction-viewMove direction = do- mbPane <- readIDE activePane- case mbPane of- Nothing -> do- ideMessage Normal "no active pane"- return ()- Just (paneName,_) -> do- pane <- paneFromName paneName- mbPanePath <- getActivePanePath- case mbPanePath of- Nothing -> do- ideMessage Normal "no active pane path"- return ()- Just panePath -> do- layout <- readIDE layout- case findMoveTarget panePath layout direction of- Nothing -> do- ideMessage Normal "no target found"- return ()- Just moveTo -> move moveTo pane------- | Find the target for a move----findMoveTarget :: PanePath -> PaneLayout -> PaneDirection -> Maybe PanePath-findMoveTarget panePath layout direction=- let reversedPath = reverse panePath- oppositeDir = otherDirection direction- cutPath = dropWhile (\d -> d /= oppositeDir) reversedPath- in if null cutPath- then Nothing- else let basePath = reverse (direction : tail cutPath)- layoutP = layoutFromPath basePath layout- in Just $basePath ++ findAppropriate layoutP oppositeDir--findAppropriate :: PaneLayout -> PaneDirection -> PanePath-findAppropriate (TerminalP _ _) _ = []-findAppropriate (HorizontalP t b _) LeftP = TopP : findAppropriate t LeftP-findAppropriate (HorizontalP t b _) RightP = TopP : findAppropriate t RightP-findAppropriate (HorizontalP t b _) BottomP = BottomP : findAppropriate b BottomP-findAppropriate (HorizontalP t b _) TopP = TopP : findAppropriate b TopP-findAppropriate (VerticalP l r _) LeftP = LeftP : findAppropriate l LeftP-findAppropriate (VerticalP l r _) RightP = RightP : findAppropriate r RightP-findAppropriate (VerticalP l r _) BottomP = LeftP : findAppropriate l BottomP-findAppropriate (VerticalP l r _) TopP = LeftP : findAppropriate l TopP------- | Bring the pane to the front position in its notebook----bringPaneToFront :: Pane alpha => alpha -> IO ()-bringPaneToFront pane = do- let tv = getTopWidget pane- mbParent <- widgetGetParent tv- case mbParent of- Just parent -> do- let nb = castToNotebook parent- n <- notebookGetNPages nb- r <- filterM (\i -> do- mbp <- notebookGetNthPage nb i- case mbp of- Nothing -> return False- Just p -> do- mbs <- notebookGetTabLabelText nb p- case mbs of- Nothing -> return False- Just s -> return (s == paneName pane))- [0..(n-1)]- case r of- [i] -> notebookSetCurrentPage nb i- otherwise -> return ()- Nothing -> return ()------- | Get a concrete panePath from a standard path.--- Standard path is for example left top.----getStandardPanePath :: StandardPath -> PaneLayout -> PanePath-getStandardPanePath sp pl = reverse $ getStandard' sp pl []- where- getStandard' _ (TerminalP _ _) p = p- getStandard' LeftTop (VerticalP l r _) p = getStandard' LeftTop l (LeftP:p)- getStandard' LeftBottom (VerticalP l r _) p = getStandard' LeftBottom l (LeftP:p)- getStandard' RightTop (VerticalP l r _) p = getStandard' RightTop r (RightP:p)- getStandard' RightBottom (VerticalP l r _) p = getStandard' RightBottom r (RightP:p)- getStandard' LeftTop (HorizontalP t b _) p = getStandard' LeftTop t (TopP:p)- getStandard' LeftBottom (HorizontalP t b _) p = getStandard' LeftBottom b (BottomP:p)- getStandard' RightTop (HorizontalP t b _) p = getStandard' RightTop t (TopP:p)- getStandard' RightBottom (HorizontalP t b _) p = getStandard' RightBottom b (BottomP:p)------- | 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-------- | 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- ae = otherDirection $head rp- in Just (reverse $ae : tail rp)------- | 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 (TopP:r) (HorizontalP t _ _) = layoutFromPath r t-layoutFromPath (BottomP:r) (HorizontalP _ b _) = layoutFromPath r b-layoutFromPath (LeftP:r) (VerticalP l _ _) = layoutFromPath r l-layoutFromPath (RightP:r) (VerticalP _ ri _) = layoutFromPath r ri-layoutFromPath pp l = error- $"inconsistent layout " ++ show pp ++ " " ++ show l---getNotebookOrPaned :: PanePath -> (Widget -> beta) -> IDEM beta-getNotebookOrPaned p cf = (widgetGet $["topBox","root"] ++ map paneDirectionToWidgetName p) cf------- | Get the notebook widget for the given pane path----getNotebook :: PanePath -> IDEM Notebook-getNotebook p = getNotebookOrPaned p castToNotebook------- | Get the (gtk) Paned widget for a given path----getPaned :: PanePath -> IDEM Paned-getPaned p = getNotebookOrPaned p castToPaned------- | Get the path to the active pane----getActivePanePath :: IDEM (Maybe PanePath)-getActivePanePath = do- mbPane <- readIDE activePane- case mbPane of- Nothing -> return Nothing- Just (paneName,_) -> do- (pp,_) <- guiPropertiesFromName paneName- return (Just (pp))--getActivePanePathOrStandard :: StandardPath -> IDEM (PanePath)-getActivePanePathOrStandard sp = do- mbApp <- getActivePanePath- case mbApp of- Just app -> return app- Nothing -> do- layout <- readIDE layout- return (getStandardPanePath sp layout)-------- | Get the active notebook----getActiveNotebook :: IDEM (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"------- | Changes a pane path in the pane map----adjustPane :: PanePath -> PanePath -> IDEAction-adjustPane fromPane toPane = do- paneMap <- readIDE paneMap- let newMap = Map.map (\(pp,other) -> do- if pp == fromPane- then (toPane,other)- else (pp,other)) paneMap- modifyIDE_ $ \ide -> return (ide{paneMap = newMap})------- | Changes the layout for a split----adjustLayoutForSplit :: Direction -> PanePath -> IDEAction-adjustLayoutForSplit dir path = do- layout <- readIDE layout- let newTerm = case dir of- Horizontal -> HorizontalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0- Vertical -> VerticalP (TerminalP Nothing 0) (TerminalP Nothing 0) 0- let newLayout = adjust path layout newTerm- modifyIDE_ $ \ide -> return (ide{layout = newLayout})------- | Changes the layout for a collapse (HorizontalP TerminalP (VerticalP (HorizontalP TerminalP TerminalP) TerminalP))-----adjustLayoutForCollapse :: PanePath -> IDEAction-adjustLayoutForCollapse path = do- layout <- readIDE layout- let newLayout = adjust path layout (TerminalP Nothing 0)- modifyIDE_ $ \ide -> return (ide{layout = newLayout})--getSubpath :: PanePath -> PaneLayout -> Maybe PanePath-getSubpath path layout =- case layoutFromPath path layout of- TerminalP _ _ -> Nothing- HorizontalP _ _ _ -> Just (path ++ [TopP])- VerticalP _ _ _ -> Just (path ++ [LeftP])------- | Changes the layout by replacing element at pane path with replace----adjust :: PanePath -> PaneLayout -> PaneLayout -> PaneLayout-adjust pp layout replace = adjust' pp layout- where- adjust' [] _ = replace- adjust' (TopP:r) (HorizontalP tp bp _) = HorizontalP (adjust' r tp) bp 0- adjust' (BottomP:r) (HorizontalP tp bp _) = HorizontalP tp (adjust' r bp) 0- adjust' (LeftP:r) (VerticalP lp rp _) = VerticalP (adjust' r lp) rp 0- adjust' (RightP:r) (VerticalP lp rp _) = VerticalP lp (adjust' r rp) 0- adjust' p l = throwIDE $"inconsistent layout " ++ show p ++ " " ++ show l------- | Get the widget from a list of strings----widgetFromPath :: Widget -> [String] -> IO (Widget)-widgetFromPath w [] = return w-widgetFromPath w (h:t) = do- children <- containerGetChildren (castToContainer w)- names <- mapM widgetGetName children- let mbiInd = findIndex (== h) names- case mbiInd of- Nothing -> throwIDE $"Cant't find widget path " ++ show (h:t)- Just ind -> widgetFromPath (children !! ind) t---widgetGet :: [String] -> (Widget -> b) -> IDEM (b)-widgetGet strL cf = do- w <- readIDE window- r <- lift $widgetFromPath (castToWidget w) strL- return (cf r)--widgetGetRel :: Widget -> [String] -> (Widget -> b) -> IO (b)-widgetGetRel w sl cf = do- r <- widgetFromPath w sl- return (cf r)--getUIAction :: String -> (Action -> a) -> IDEM(a)-getUIAction str f = do- uiManager <- readIDE uiManager- lift $ do- findAction <- uiManagerGetAction uiManager str- case findAction of- Just act -> return (f act)- Nothing -> throwIDE $"getUIAction can't find action " ++ str----get widget elements--getCandyState :: IDEM (Bool)-getCandyState = do- ui <- getUIAction "ui/menubar/_Edit/Source Candy" castToToggleAction- lift $toggleActionGetActive ui--setCandyState :: Bool -> IDEAction-setCandyState b = do- ui <- getUIAction "ui/menubar/_Edit/Source Candy" castToToggleAction- lift $toggleActionSetActive ui b-----getSBSpecialKeys :: IDEM (Statusbar)-getSBSpecialKeys = widgetGet ["topBox","statusBox","statusBarSpecialKeys"] castToStatusbar--getSBActivePane :: IDEM (Statusbar)-getSBActivePane = widgetGet ["topBox","statusBox","statusBarActivePane"] castToStatusbar--getSBActivePackage :: IDEM (Statusbar)-getSBActivePackage = widgetGet ["topBox","statusBox","statusBarActiveProject"] castToStatusbar--getSBErrors :: IDEM (Statusbar)-getSBErrors = widgetGet ["topBox","statusBox","statusBarErrors"] castToStatusbar--getStatusbarIO :: IDEM (Statusbar)-getStatusbarIO = widgetGet ["topBox","statusBox","statusBarInsertOverwrite"] castToStatusbar--getStatusbarLC :: IDEM (Statusbar)-getStatusbarLC = widgetGet ["topBox","statusBox","statusBarLineColumn"] castToStatusbar--
+ src/IDE/GUIHistory.hs view
@@ -0,0 +1,97 @@+{-# OPTIONS_GHC #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.GUIHistory+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+--+-- | Recording the history for going back and forth+--+---------------------------------------------------------------------------------+++module IDE.GUIHistory (+ recordHistory+, historyBack+, historyForward+, withoutRecordingDo+) where++import IDE.Core.State+import IDE.Pane.Modules+import IDE.Pane.Info+import Control.Event+import Control.Monad.Reader++recordHistory :: GUIHistory -> IDEAction+recordHistory entry = do+ (b,l,n) <- readIDE guiHistory+ if b || (n >= 0 && fst entry == fst (l !! n))+ then return ()+ else do+ modifyIDE_ (\ide -> return ide{guiHistory = (b,entry:(drop n l),0)})+ st <- ask+ triggerEvent st (Sensitivity+ [(SensitivityForwardHist,False),(SensitivityBackwardHist,0 < length (drop n l) - 1)])+ return ()+ -- liftIO $ putStrLn $ "record n : " ++ show 0 -- ++ " hist: " ++ show (entry:(drop n l))++historyBack :: IDEAction+historyBack = do+ (b,list,index) <- readIDE guiHistory+ case (list,index) of+ (_,-1) -> return ()+ (l,n) | n + 1 >= length l -> return ()+ | otherwise -> do+ withoutRecordingDo (activateHistory (snd (l !! n)))+ modifyIDE_ (\ide -> return ide{guiHistory = (b,l, n + 1)})+ st <- ask+ triggerEvent st (Sensitivity+ [(SensitivityForwardHist,(n + 1) > 0),(SensitivityBackwardHist,(n + 1) < (length l) - 1)])+ return ()+ -- liftIO $ putStrLn $ "back n : " ++ show (n + 1) -- ++ " hist: " ++ show l+++historyForward :: IDEAction+historyForward = do+ (b,list,index) <- readIDE guiHistory+ case (list,index) of+ (l,n) | n < 1 -> return ()+ | otherwise -> do+ withoutRecordingDo (activateHistory (fst (l !! n)))+ modifyIDE_ (\ide -> return ide{guiHistory = (b,l, n - 1)})+ st <- ask+ triggerEvent st (Sensitivity+ [(SensitivityForwardHist,(n - 1) > 0),(SensitivityBackwardHist,(n - 1) < (length l) - 1)])+ return ()+ -- liftIO $ putStrLn $ "forward n : " ++ show (n - 1) -- ++ " hist: " ++ show l++activateHistory :: GUIHistory' -> IDEAction+activateHistory ms@(ModuleSelected s1 s2) = do+ -- liftIO $ putStrLn $ "activate with module selected " ++ show s1 ++ " " ++ show s2+ replaySelHistory s1 s2+activateHistory ms@(ScopeSelected bl sc) = do+ -- liftIO $ putStrLn $ "activate with scope selected " ++ show ms+ replayScopeHistory bl sc+activateHistory ms@(InfoElementSelected descr) = do+ -- liftIO $ putStrLn $ "activate with " ++ show ms+ replayInfoHistory descr+activateHistory ms@(PaneSelected mbPaneName) = do+ -- liftIO $ putStrLn $ "activate with " ++ show ms+ case mbPaneName of+ Nothing -> withoutRecordingDo deactivatePane+ Just paneName -> do+ mbPane <- mbPaneFromName paneName+ case mbPane of+ Nothing -> return ()+ Just (PaneC p) -> do+ makeActive p+ return ()+++
− src/IDE/InfoPane.hs
@@ -1,318 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.InfoPane--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | The GUI stuff for infos-------------------------------------------------------------------------------------module IDE.InfoPane (- setInfos-, setSymbol-) where--import Graphics.UI.Gtk hiding (afterToggleOverwrite)-import Control.Monad.Reader-import System.IO-import Control.Monad-import Control.Monad.Trans-import System.IO-import Data.List-import Data.Maybe-import qualified Data.ByteString.Char8 as BS-import Data.IORef(newIORef,readIORef,writeIORef)-import qualified Data.Map as Map--import IDE.Core.State-import IDE.Framework.ViewFrame-import IDE.Framework.MakeEditor-import IDE.Framework.SimpleEditors-import IDE.Framework.Parameters-import IDE.SourceEditor-import IDE.CallersPane-import IDE.Framework.EditorBasics--instance IDEObject IDEInfo--instance Pane IDEInfo- where- primPaneName _ = "Info"- getAddedIndex _ = 0- getTopWidget = castToWidget . sw- paneId b = "*Info"- makeActive pane = activatePane pane (BufConnections[][][])- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- lift $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> lift $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- deactivatePaneIfActive pane- lift $notebookRemovePage nb i- removePaneAdmin pane--instance RecoverablePane IDEInfo InfoState where- saveState p = do- currentIDsU <- lift $ readIORef (currentIDs p)- currentIndU <- lift $ readIORef (currentInd p)- return (Just (StateC (InfoState currentIDsU currentIndU)))- recoverState pp (InfoState currentIDsU currentIndu) = do- nb <- getNotebook pp- initInfo pp nb currentIDsU currentIndu--idDescrDescr :: IDERef -> [FieldDescription IdentifierDescr]-idDescrDescr ideR = [- mkField- (paraName <<<- ParaName "Symbol"- $ paraHorizontal <<<- ParaHorizontal StartHorizontal- $ emptyParams)- identifierID- (\ b a -> a{identifierID = b})- stringEditor- , mkField- (paraName <<<- ParaName "Sort"- $ emptyParams)- idType- (\b a -> a)- (staticSelectionEditor allIdTypes)- , mkField- (paraName <<<- ParaName "Exported by"- $ paraHorizontal <<<- ParaHorizontal StopHorizontal- $ emptyParams)- (\l -> showPackModule (moduleIdID l))- (\ b a -> a{moduleIdID = parsePackModule b})- stringEditor- , mkField- (paraName <<<- ParaName "Type" $ emptyParams)- (BS.unpack . typeInfo)- (\b a -> a)- (typeEditor ideR)- , mkField- (paraName <<<- ParaName "Comment" $ emptyParams)- (\l -> case mbComment l of- Nothing -> ""- Just s -> BS.unpack s)- (\ b a -> case b of- "" -> a{mbComment = Nothing}- s -> a{mbComment = Just (BS.pack s)})- multilineStringEditor]--{-- , mkField (emptyParams- {paraName = Just "Documentation"})- typeInfo- (\b a -> a{typeInfo = b})- multilineStringEditor--}--allIdTypes = [Function, Newtype, Type, AbstractData, OpenData, Foreign- , Data, Class, Instance, Constructor, Field, Method, OrphanedInstance]--typeEditor :: IDERef -> Editor String-typeEditor ideR para = do- ed@(wid,inj,ext,notif) <- multilineStringEditor para- notif ButtonRelease $Left (\e -> showInfoHandler wid ideR)- return ed--showInfoHandler :: Widget -> IDERef -> IO Bool-showInfoHandler wid ideR = do- mbFrame <- binGetChild (castToAlignment wid)- mbInner <- binGetChild (castToFrame (forceJust mbFrame "InfoPane>>typeEditor: Can't find child"))- mbScrolled <- binGetChild (castToAlignment (forceJust mbInner "InfoPane>>typeEditor: Can't find child2")) - mbTV <- binGetChild (castToScrolledWindow (forceJust mbScrolled "InfoPane>>typeEditor: Can't find child3")) - buf <- textViewGetBuffer (castToTextView (forceJust mbTV "InfoPane>>typeEditor: Can't find child4"))- (l,r) <- textBufferGetSelectionBounds buf- symbol <- textBufferGetText buf l r True- runReaderT (triggerEvent ideR (SelectInfo symbol)) ideR- return False--initInfo :: PanePath -> Notebook -> [IdentifierDescr] -> Int -> IDEAction-initInfo panePath nb idDescrs index = do- when (length idDescrs > index) $ do- ideR <- ask- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- (pane,cids) <- lift $ do- nbbox <- hBoxNew False 0- ibox <- vBoxNew False 0- bb <- vButtonBoxNew- buttonBoxSetLayout bb ButtonboxStart- definitionB <- buttonNewWithLabel "Source"- moduB <- buttonNewWithLabel "Selection"- usesB <- buttonNewWithLabel "Uses"- docuB <- buttonNewWithLabel "Docu"- widgetSetSensitivity docuB False- nextB <- buttonNewWithLabel "Next"- prevB <- buttonNewWithLabel "Prev"- when (length idDescrs < 2) $ widgetSetSensitivity nextB False- widgetSetSensitivity prevB False- label <- labelNew (Just ("1" ++ "/" ++ show (length idDescrs)))- boxPackStart bb definitionB PackNatural 0- boxPackStart bb moduB PackNatural 0- boxPackStart bb usesB PackNatural 0- boxPackStart bb docuB PackNatural 0- boxPackStart bb label PackNatural 0- boxPackStart bb nextB PackNatural 0- boxPackStart bb prevB PackNatural 0-- resList <- mapM (\ fd -> (fieldEditor fd) (head idDescrs)) (idDescrDescr ideR)- let (widgets, setInjs, getExts, notifiers) = unzip4 resList- foldM_ (\ box (w,mbh) ->- case mbh of- Keep -> do boxPackStart box w PackGrow 0- return box- StartHorizontal -> do newBox <- hBoxNew True 0- boxPackStart box newBox PackNatural 0- boxPackStart newBox w PackGrow 0- return (castToBox newBox)- StopHorizontal -> do boxPackStart box w PackGrow 0- par <- widgetGetParent box- case par of- Nothing -> throwIDE "initInfo - no parent"- Just p -> return (castToBox p))- (castToBox ibox)- (zip widgets (map (getParameter paraHorizontal . parameters)- (idDescrDescr ideR)))- boxPackStart nbbox ibox PackGrow 0- boxPackEnd nbbox bb PackNatural 0- --openType- sw <- scrolledWindowNew Nothing Nothing- scrolledWindowAddWithViewport sw nbbox- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- currentIDs' <- newIORef idDescrs- currentInd <- newIORef 0- let info = IDEInfo sw currentIDs' currentInd setInjs getExts nextB prevB label-- --mapM_ (\w -> widgetSetExtensionEvents w [ExtensionEventsAll]) widgets- cids <- mapM- (\w -> w `onFocus` --onFocusIn doesn't work here - why?- (\_ -> do runReaderT (makeActive info) ideR- return False))- widgets- definitionB `onClicked` (runReaderT gotoSource ideR)- moduB `onClicked` (runReaderT gotoModule' ideR)- usesB `onClicked` (runReaderT calledBy' ideR)- nextB `onClicked` (next info)- prevB `onClicked` (prev info)- notebookInsertOrdered nb sw (paneName info)- widgetShowAll sw- return (info,cids)- addPaneAdmin pane (BufConnections [] [] []) panePath- lift $widgetGrabFocus (sw pane)- lift $bringPaneToFront pane--next :: IDEInfo -> IO ()-next (IDEInfo _ currentIDs' currentInd' injectors' _ nextB prevB label) = do- currentIdsU <- readIORef currentIDs'- currentIndU <- readIORef currentInd'- when (length currentIdsU > currentIndU + 1) $ do- writeIORef currentInd' (currentIndU + 1)- mapM_ (\ a -> a (currentIdsU !! (currentIndU + 1))) injectors'- when (length currentIdsU == currentIndU + 1) $ widgetSetSensitivity nextB False- widgetSetSensitivity prevB True- labelSetText label (show (currentIndU + 2) ++ "/" ++ show (length currentIdsU))---prev :: IDEInfo -> IO ()-prev (IDEInfo _ currentIDs' currentInd' injectors' _ nextB prevB label) = do- currentIdsU <- readIORef currentIDs'- currentIndU <- readIORef currentInd'- when (currentIndU >= 1) $ do- writeIORef currentInd' (currentIndU - 1)- mapM_ (\ a -> a (currentIdsU !! (currentIndU - 1))) injectors'- when (currentIndU - 1 == 0) $ widgetSetSensitivity prevB False- widgetSetSensitivity nextB True- labelSetText label (show currentIndU ++ "/" ++ show (length currentIdsU))--gotoSource :: IDEAction-gotoSource = do- mbInfo <- getInfoCont- case mbInfo of- Nothing -> do ideMessage Normal "gotoSource:noDefition"- return ()- Just info -> do goToDefinition info- return ()--gotoModule' :: IDEAction-gotoModule' = do- mbInfo <- getInfoCont- ideR <- ask- case mbInfo of- Nothing -> return ()- Just info -> do triggerEvent ideR (SelectIdent info)- return ()--calledBy' :: IDEAction-calledBy' = do- mbInfo <- getInfoCont- case mbInfo of- Nothing -> return ()- Just info -> do calledBy 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 -> setInfos a---setInfos :: [IdentifierDescr] -> IDEM ()-setInfos identifierDescrs = do- mbPane <- getPane InfoCasting- case mbPane of- Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (infoPanePath prefs) layout- nb <- getNotebook pp- initInfo pp nb identifierDescrs 0- Just info -> lift $ do- writeIORef (currentInd info) 0- writeIORef (currentIDs info) identifierDescrs- mapM_ (\ a -> a (head identifierDescrs)) (injectors info)- labelSetText (numLabel info) ("1/" ++ show (length identifierDescrs))- widgetSetSensitivity (prevB info) False- widgetSetSensitivity (nextB info)- (if length identifierDescrs > 1 then True else False)- bringPaneToFront info---getInfoCont :: IDEM (Maybe (IdentifierDescr))-getInfoCont = do- mbPane <- getPane InfoCasting- case mbPane of- Nothing -> return Nothing- Just p -> lift $ do- currentIndU <- readIORef (currentInd p)- currentIDsU <- readIORef (currentIDs p)- if length currentIDsU > currentIndU- then return (Just (currentIDsU !! currentIndU))- else return Nothing------- | Lookup of an identifier description----getIdentifierDescr :: String -> SymbolTable -> SymbolTable -> [IdentifierDescr]-getIdentifierDescr str st1 st2 =- case str `Map.lookup` st1 of- Nothing -> case str `Map.lookup` st2 of- Nothing -> []- Just list -> list- Just list -> case str `Map.lookup` st2 of- Nothing -> list- Just list2 -> list ++ list2-
src/IDE/Keymap.hs view
@@ -8,12 +8,13 @@ ) where import Graphics.UI.Gtk+import Graphics.UI.Gtk.Gdk.Events(Modifier(..)) import qualified Data.Map as Map import Text.ParserCombinators.Parsec import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec.Language(emptyDef) import Data.Maybe-import Data.List(sort)+import Data.List (foldl',sort) import Data.Char(toLower) import Control.Monad.Reader @@ -50,7 +51,7 @@ where setAccel act = case Map.lookup (name act) keymap of Nothing -> act Just [] -> act- Just keyList -> foldl setAccelerator act keyList+ Just keyList -> foldl' setAccelerator act keyList setAccelerator act (Just (Left acc),Nothing) = act{accelerator= acc : accelerator act} setAccelerator act (Just (Left acc),Just expl) = act{accelerator= acc : accelerator act, tooltip= Just expl}@@ -170,9 +171,9 @@ return Alt <|> do try $symbol2 "<apple>"- return Apple+ return Super <|> do try $symbol2 "<compose>"- return Compose+ return Hyper <?>"modparser"
src/IDE/Leksah.hs view
@@ -1,16 +1,17 @@-{-# OPTIONS_GHC -fglasgow-exts #-}++{-# OPTIONS_GHC -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Leksah -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL ----- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org> -- Stability : experimental -- Portability : portable -- ----- Main function of Genuine Haskell Face, an Haskell IDE written in Haskell+-- Main function of Leksah, an Haskell IDE written in Haskell -- --------------------------------------------------------------------------------- @@ -19,6 +20,8 @@ ) where import Graphics.UI.Gtk+import Graphics.UI.Gtk.Gdk.Events+import qualified Graphics.UI.Gtk.Gdk.Events as GdkEvents import Control.Monad.Reader import Control.Concurrent import Data.IORef@@ -28,39 +31,43 @@ import System.Console.GetOpt import System.Environment import GHC+import HscTypes hiding (liftIO) import Config import Data.Version import Prelude hiding(catch) import System.FilePath import System.Directory-+import Debug.Trace import Paths_leksah import IDE.SaveSession import IDE.Core.State+import Control.Event import IDE.SourceCandy-import IDE.Utils.File-import IDE.Framework.ViewFrame-import IDE.Framework.MakeEditor-import IDE.Framework.Parameters+import IDE.FileUtils+import Graphics.UI.Editor.MakeEditor+import Graphics.UI.Editor.Parameters import IDE.Menu-import IDE.Preferences+import IDE.Pane.Preferences import IDE.Keymap-import IDE.SourceEditor+import IDE.Pane.SourceBuffer import IDE.SpecialEditors-import IDE.Metainfo.Info+import IDE.Metainfo.Provider import IDE.Metainfo.SourceCollector import IDE.Metainfo.InterfaceCollector-import IDE.Log(getLog,appendLog)-import IDE.InfoPane-import IDE.ModulesPane-+import IDE.Pane.Log+import IDE.Pane.Info+import IDE.Pane.Modules+import IDE.GUIHistory+import IDE.Pane.Search(setChoices,searchMetaGUI)+import IDE.Find -- --------------------------------------------------------------------- -- Command line options -- data Flag = UninstalledProject String | Collect | Rebuild | Sources | VersionF | DebugF+ | SessionN String | NoGUI deriving (Show,Eq) options :: [OptDescr Flag]@@ -75,8 +82,13 @@ , Option ['v'] ["Version"] (NoArg VersionF) "Show the version number of ide" , Option ['d'] ["Debug"] (NoArg DebugF)- "Write ascii pack files"]+ "Write ascii pack files"+ , Option ['l'] ["LoadSession"] (ReqArg SessionN "NAME")+ "Load session"+ , Option ['n'] ["NoGUI"] (NoArg NoGUI)+ "Don't start the leksah GUI"] + ideOpts :: [String] -> IO ([Flag], [String]) ideOpts argv = case getOpt Permute options argv of@@ -89,50 +101,47 @@ -- | Main function -- -runMain = handleTopExceptions $do+runMain = handleTopExceptions $ do args <- getArgs- (o,_) <- ideOpts args- let uninstalled = filter (\x -> case x of+ (o,_) <- ideOpts args+ let uninstalled = filter (\x -> case x of UninstalledProject _ -> True _ -> False) o- if elem VersionF o- then do sysMessage Normal $ "Leksah an IDE for Haskell, version " ++ showVersion version- else- if elem Sources o- then do- buildSourceForPackageDB- sysMessage Normal "rebuild SourceForPackageDB"- else if elem Rebuild o- || elem Collect o- || not (null uninstalled)- then do- libDir <- getSysLibDir-#if __GHC__ > 670- session <- newSession (Just libDir)-#else- session <- newSession JustTypecheck (Just libDir)-#endif- dflags0 <- getSessionDynFlags session- setSessionDynFlags session dflags0- 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 session version)- $ map (\ (UninstalledProject x) -> x) uninstalled- else do- sources <- getSourcesMap- collectInstalled' writeAscii session version (elem Rebuild o) sources- else startGUI+ 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"+ when (elem VersionF o)+ (sysMessage Normal $ "Leksah an IDE for Haskell, version " ++ showVersion version)+ when (elem Sources o) (do+ buildSourceForPackageDB+ sysMessage Normal "rebuild SourceForPackageDB")+ when (elem Rebuild o || elem Collect o || not (null uninstalled)) $ do+ libDir <- getSysLibDir+ runGhc (Just libDir) $ do+ getSessionDynFlags >>= setSessionDynFlags+ 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+ sources <- liftIO $ getSourcesMap+ collectInstalled' writeAscii version (elem Rebuild o) sources+ when (not (elem NoGUI o) && not (elem VersionF o)) (startGUI sessionFilename) -- --------------------------------------------------------------------- -- | Start the GUI -startGUI :: IO ()-startGUI = do--- sysMessage Normal "Leksah says welcome"- st <- initGUI+startGUI :: String -> IO ()+startGUI sessionFilename = do+ trace "start gui called" $ return ()+ st <- unsafeInitGUIForThreadedRTS -- initGUI when rtsSupportsBoundThreads (sysMessage Normal "Linked with -threaded") timeoutAddFull (yield >> return True) priorityHigh 25@@ -158,63 +167,93 @@ iconExists <- doesFileExist iconPath when iconExists $ windowSetIconFromFile win iconPath- libDir <- getSysLibDir-#if __GHC__ > 670- session <- newSession (Just libDir)-#else- session <- newSession JustTypecheck (Just libDir)-#endif- dflags0 <- getSessionDynFlags session- setSessionDynFlags session dflags0+ findBar <- liftIO $ toolbarNew+ toolbarSetStyle findBar ToolbarIcons let ide = IDE { window = win , uiManager = uiManager , panes = Map.empty , activePane = Nothing+ , lastActiveBufferPane = Nothing , paneMap = Map.empty , layout = (TerminalP Nothing (-1)) , specialKeys = specialKeys , specialKey = Nothing , candy = candySt , prefs = prefs--- , packages = [] , activePack = Nothing , errors = [] , currentErr = Nothing , accessibleInfo = Nothing , currentInfo = Nothing- , session = session- , handlers = Map.empty}+ , handlers = Map.empty+ , isShuttingDown = False+ , guiHistory = (False,[],-1)+ , findbar = findBar+ , toolbar = Nothing+ , findbarVisible = True+ , toolbarVisible = True+} ideR <- newIORef ide- runReaderT (initInfo :: IDEAction) ideR- menuDescription' <- menuDescription- (acc,menus) <- runReaderT (makeMenu uiManager accelActions menuDescription') ideR- when (length menus /= 3) $ throwIDE ("Failed to build menu" ++ show (length menus))- windowAddAccelGroup win acc- nb <- newNotebook- widgetSetName nb $"root"- statusBar <- buildStatusbar ideR- vb <- vBoxNew False 1 -- Top-level vbox- widgetSetName vb "topBox"- boxPackStart vb (menus !! 0) PackNatural 0- boxPackStart vb nb PackGrow 0- boxPackEnd vb statusBar PackNatural 0- win `onDelete` (\ _ -> do runReaderT quit ideR; return True)- win `onKeyPress` (\ e -> runReaderT (handleSpecialKeystrokes e) ideR)- containerAdd win vb- runReaderT (setCandyState (isJust (sourceCandy prefs))) ideR- let (x,y) = defaultSize prefs- windowSetDefaultSize win x y- runReaderT (do- registerEvents menus- recoverSession :: IDEAction) ideR- widgetShowAll win- mainGUI+ libDir <- getSysLibDir+ runGhc (Just libDir) (do+ getSessionDynFlags >>= setSessionDynFlags+ reifyGhc (\session -> do+ menuDescription' <- menuDescription+ (acc,menus) <- reflectIDE (makeMenu uiManager accelActions menuDescription') ideR session+ when (length menus /= 2) $ throwIDE ("Failed to build menu" ++ show (length menus))+ let toolbar = castToToolbar (menus !! 1)+ reflectIDE (do+ constructFindReplace findBar+ modifyIDE_ (\ide -> return ide{toolbar = Just toolbar})+ initInfo :: IDEAction) ideR session+ sep0 <- separatorToolItemNew+ separatorToolItemSetDraw sep0 False+ toolItemSetExpand sep0 True+ toolbarInsert toolbar sep0 (-1)+ closeButton <- toolButtonNewFromStock "gtk-close"+ toolbarInsert toolbar closeButton (-1)+ closeButton `onToolButtonClicked` do+ reflectIDE hideToolbar ideR session + windowAddAccelGroup win acc+ nb <- newNotebook+ afterSwitchPage nb (\i -> reflectIDE (handleNotebookSwitch nb i) ideR session)+ widgetSetName nb $"root"+ statusBar <- buildStatusbar ideR+ vb <- vBoxNew False 1 -- Top-level vbox+ widgetSetName vb "topBox"+ toolbarSetStyle (castToToolbar (menus !! 1)) ToolbarIcons+ boxPackStart vb (menus !! 0) PackNatural 0+ boxPackStart vb (menus !! 1) PackNatural 0+ boxPackStart vb nb PackGrow 0+ boxPackStart vb findBar PackNatural 0+ boxPackEnd vb statusBar PackNatural 0+ win `onDelete` (\ _ -> do reflectIDE quit ideR session; return True)+ win `onKeyPress` (\ e -> reflectIDE (handleSpecialKeystrokes e) ideR session)+ containerAdd win vb+ reflectIDE (setCandyState (isJust (sourceCandy prefs))) ideR session+ let (x,y) = defaultSize prefs+ windowSetDefaultSize win x y+ sessionPath <- getConfigFilePathForLoad sessionFilename+ (tbv,fbv) <- reflectIDE (do+ registerEvents menus+ recoverSession sessionPath+ ) ideR session+ widgetShowAll win+ reflectIDE (do+ if tbv+ then showToolbar+ else hideToolbar+ if fbv+ then showFindbar+ else hideFindbar) ideR session+ mainGUI))+ -- -- | Callback function for onKeyPress of the main window, so preprocess any key ---handleSpecialKeystrokes :: Event -> IDEM Bool+handleSpecialKeystrokes :: GdkEvents.Event -> IDEM Bool handleSpecialKeystrokes (Key _ _ _ mods _ _ _ keyVal name mbChar) = do bs <- getCandyState when bs $ editKeystrokeCandy mbChar@@ -225,27 +264,27 @@ Nothing -> do case Map.lookup (keyVal,sort mods) sks of Nothing -> do- lift $statusbarPop sb 1- lift $statusbarPush sb 1 ""+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 "" return False Just map -> do sb <- getSBSpecialKeys let sym = printMods mods ++ name- lift $statusbarPop sb 1- lift $statusbarPush sb 1 sym+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 sym modifyIDE_ (\ide -> return (ide{specialKey = Just (map,sym)})) return True Just (map,sym) -> do case Map.lookup (keyVal,sort mods) map of Nothing -> do sb <- getSBSpecialKeys- lift $statusbarPop sb 1- lift $statusbarPush sb 1 $sym ++ printMods mods ++ name ++ "?"+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 $sym ++ printMods mods ++ name ++ "?" return () Just (AD actname _ _ _ ideAction _ _) -> do sb <- getSBSpecialKeys- lift $statusbarPop sb 1- lift $statusbarPush sb 1+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 $sym ++ " " ++ printMods mods ++ name ++ "=" ++ actname ideAction modifyIDE_ (\ide -> return (ide{specialKey = Nothing}))@@ -256,27 +295,33 @@ printMods (m:r) = show m ++ printMods r handleSpecialKeystrokes _ = return True +--+-- | Register handlers for IDE events+-- registerEvents :: [Widget] -> IDEAction registerEvents tbl = do stRef <- ask- registerEvent stRef LogMessageS (Left logHandler)- registerEvent stRef GetToolbarS (Left tbHandler)- registerEvent stRef SelectInfoS (Left siHandler)- registerEvent stRef SelectIdentS (Left sidHandler)- registerEvent stRef CurrentInfoS (Left ciuHandler)- registerEvent stRef ActivePackS (Left apHandler)+ registerEvent stRef "LogMessage" (Left logHandler)+ registerEvent stRef "SelectInfo" (Left siHandler)+ registerEvent stRef "SelectIdent" (Left sidHandler)+ registerEvent stRef "CurrentInfo" (Left ciuHandler)+ registerEvent stRef "ActivePack" (Left apHandler)+ registerEvent stRef "RecordHistory" (Left rhHandler)+ registerEvent stRef "Sensitivity" (Left sHandler)+ registerEvent stRef "DescrChoice" (Left dcHandler)+ registerEvent stRef "SearchMeta" (Left smHandler)+ registerEvent stRef "LoadSession" (Left lsHandler)+ registerEvent stRef "SaveSession" (Left ssHandler) + return () where logHandler e@(LogMessage s t) = do (log :: IDELog) <- getLog- lift $ appendLog log s t+ liftIO $ appendLog log s t return e logHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" - tbHandler (GetToolbar _) = return (GetToolbar tbl)- tbHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"- siHandler e@(SelectInfo str) = do setSymbol str return e@@ -297,11 +342,30 @@ return ActivePack apHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + rhHandler rh@(RecordHistory h) = do+ recordHistory h+ return rh+ rhHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" + sHandler s@(Sensitivity h) = do+ setSensitivity h+ return s+ sHandler _ = throwIDE "Leksah>>registerEvents: Impossible event" ------ | Called when leksah ist first called---+ dcHandler e@(DescrChoice descrs) = do+ setChoices descrs+ return e+ dcHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"++ smHandler e@(SearchMeta string) = searchMetaGUI string >> return e+ smHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"++ lsHandler e@(LoadSession fp) = loadSession fp >> return e+ lsHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"++ ssHandler e@(SaveSession fp) = saveSessionAs fp >> return e+ ssHandler _ = throwIDE "Leksah>>registerEvents: Impossible event"+ fDescription :: FieldDescription Prefs fDescription = mkField@@ -312,6 +376,9 @@ (\b a -> a{sourceDirectories = b}) (filesEditor Nothing FileChooserActionSelectFolder "Select folders") +--+-- | Called when leksah ist first called (the .leksah directory does not exist)+-- firstStart :: IO () firstStart = do prefsPath <- getConfigFilePathForLoad "Default.prefs"@@ -328,7 +395,7 @@ "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.")) (widget, setInj, getExt,notifier)- <- fieldEditor fDescription prefs+ <- buildEditor fDescription prefs ok `onClicked` (do mbNewPrefs <- extract prefs [getExt] case mbNewPrefs of@@ -356,16 +423,10 @@ return () firstBuild :: IO ()-firstBuild = do- libDir <- getSysLibDir-#if __GHC__ > 670- session <- newSession (Just libDir)-#else- session <- newSession JustTypecheck (Just libDir)-#endif- dflags0 <- getSessionDynFlags session- setSessionDynFlags session dflags0- let version = cProjectVersion+firstBuild = let version = cProjectVersion in do buildSourceForPackageDB sources <- getSourcesMap- collectInstalled' False session version True sources+ libDir <- getSysLibDir+ runGhc (Just libDir) $ collectInstalled' False version True sources++
− src/IDE/Log.hs
@@ -1,244 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------ Module : IDE.Log--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | Log pane--------------------------------------------------------------------------------------module IDE.Log (- LogView(..)-, LogAction(..)-, IDELog(..)-, LogState-, LogTag(..)-) where--import Graphics.UI.Gtk hiding (afterToggleOverwrite)-import Graphics.UI.Gtk.Multiline.TextView-import Control.Monad.Reader-import Data.Maybe--import IDE.Core.State-import IDE.SourceEditor-import IDE.Framework.ViewFrame---------------------------------------------------------------------------------------- * Interface---------- | The Log Viev-----class LogAction alpha where- clearLog :: alpha--instance LogAction IDEAction where- clearLog = clearLog'--class Pane alpha => LogView alpha where- getLog :: IDEM alpha- appendLog :: alpha -> String -> LogTag -> IO Int- markErrorInLog :: alpha -> (Int, Int) -> IO ()--instance IDEObject IDELog--instance LogView IDELog- where- getLog = getLog'- appendLog = appendLog'- markErrorInLog = markErrorInLog'--instance CastablePane IDELog where- casting _ = LogCasting- downCast _ (PaneC a) = case casting a of- LogCasting -> Just a- _ -> Nothing---instance Recoverable LogState where- toPaneState a = LogSt a--instance Pane IDELog- where- primPaneName _ = "Log"- getAddedIndex _ = 0- getTopWidget = castToWidget . scrolledWindowL- paneId b = "*Log"- makeActive log = do- activatePane log (BufConnections[][] [])- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- lift $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> lift $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- deactivatePaneIfActive pane- lift $notebookRemovePage nb i- removePaneAdmin pane--instance RecoverablePane IDELog LogState where- saveState p = return (Just (StateC LogState))- recoverState pp LogState = do- nb <- getNotebook pp- initLog pp nb---------------------------------------------------------------------------------------- * Implementation------initLog :: PanePath -> Notebook -> IDEAction-initLog panePath nb = do- ideR <- ask- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- (buf,cids) <- lift $ 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 := "green"]- textTagTableAdd tags frametag- activeErrtag <- textTagNew (Just "activeErr")- set activeErrtag[textTagBackground := "yellow"]- textTagTableAdd tags activeErrtag-- textViewSetEditable tv True- 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- notebookInsertOrdered nb sw (paneName buf)- widgetShowAll (scrolledWindowL buf)- cid1 <- tv `afterFocusIn`- (\_ -> do runReaderT (makeActive buf) ideR; return True)- cid2 <- tv `onButtonPress`- (\ b -> do runReaderT (clicked b buf) ideR; return True)- return (buf,[cid1])- addPaneAdmin buf (BufConnections [] [] cids) panePath- lift $widgetGrabFocus (textView buf)--clicked :: Event -> IDELog -> IDEAction-clicked (Button _ SingleClick _ _ _ _ LeftButton x y) ideLog = do- errors' <- readIDE errors- line' <- lift $ do- (x,y) <- widgetGetPointer (textView ideLog)- (_,y') <- textViewWindowToBufferCoords (textView ideLog) TextWindowWidget (x,y)- (iter,_) <- textViewGetLineAtY (textView ideLog) y'- textIterGetLine iter- case filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1))- (zip errors' [0..(length errors')]) of- [(thisErr,n)] -> do- succ <- selectSourceBuf (filePath thisErr)- if succ- then markErrorInSourceBuf (line thisErr) (column thisErr)- (errDescription thisErr)- else return ()- log :: IDELog <- getLog- lift $ markErrorInLog log (logLines thisErr)- modifyIDE_ (\ide -> return (ide{currentErr = Just n}))- otherwise -> return ()-clicked _ _ = return ()---getLog' :: IDEM IDELog-getLog' = do- mbPane <- getPane LogCasting- case mbPane of- Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (logPanePath prefs) layout- nb <- getNotebook pp- initLog pp nb- mbPane <- getPane LogCasting- case mbPane of- Nothing -> throwIDE "Can't init log"- Just l -> return l- Just p -> return p--simpleLog :: String -> IDEAction-simpleLog str = do- log :: IDELog <- getLog- lift $ appendLog log str LogTag- return ()--appendLog' :: IDELog -> String -> LogTag -> IO Int-appendLog' l@(IDELog tv _) string tag = do- buf <- textViewGetBuffer tv- iter <- textBufferGetEndIter buf- textBufferSelectRange buf iter iter- textBufferInsert buf iter string- iter2 <- textBufferGetEndIter buf- case tag of- LogTag -> return ()- ErrorTag -> do- len <- textBufferGetCharCount buf- strti <- textBufferGetIterAtOffset buf (len - length string)- textBufferApplyTagByName buf "err" iter2 strti- FrameTag -> do- len <- textBufferGetCharCount buf- strti <- textBufferGetIterAtOffset buf (len - length string)- textBufferApplyTagByName buf "frame" iter2 strti- textBufferMoveMarkByName buf "end" iter2- mbMark <- textBufferGetMark buf "end"- line <- textIterGetLine iter2- case mbMark of- Nothing -> return ()- Just mark -> textViewScrollMarkOnscreen tv mark- bringPaneToFront l- return line--markErrorInLog' :: IDELog -> (Int,Int) -> IO ()-markErrorInLog' (IDELog tv _) (l1,l2) = do- buf <- textViewGetBuffer tv- iter <- textBufferGetIterAtLineOffset buf (l1-1) 0- iter2 <- textBufferGetIterAtLineOffset buf l2 0- textBufferSelectRange buf iter iter2--- textBufferApplyTagByName buf "activeErr" iter iter2- textBufferMoveMarkByName buf "end" iter- mbMark <- textBufferGetMark buf "end"- case mbMark of- Nothing -> return ()- Just mark -> textViewScrollToMark tv mark 0.0 (Just (0.3,0.3))--clearLog' :: IDEAction-clearLog' = do- log <- getLog- buf <- lift$ textViewGetBuffer $textView log- lift $textBufferSetText buf ""- modifyIDE_ (\ide -> return (ide{errors = [], currentErr = Nothing}))-
src/IDE/Menu.hs view
@@ -1,11 +1,11 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Menu -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL ----- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org> -- Stability : experimental -- Portability : portable --@@ -23,6 +23,7 @@ , aboutDialog , buildStatusbar , newIcons+, setSensitivity ) where import Graphics.UI.Gtk@@ -32,22 +33,28 @@ import Data.Version import Prelude hiding (catch) import Control.Exception+import Data.Maybe + import IDE.Core.State-import IDE.SourceEditor-import IDE.Framework.ViewFrame-import IDE.Preferences-import IDE.PackageEditor+import IDE.Pane.SourceBuffer+import IDE.Pane.Preferences+import IDE.Pane.PackageFlags+import IDE.Pane.PackageEditor import IDE.Package-import IDE.Log+import IDE.Pane.Log import IDE.SaveSession-import IDE.ModulesPane-import IDE.ToolbarPane-import IDE.FindPane-import IDE.ReplacePane-import IDE.Utils.File+import IDE.Pane.Modules+import IDE.Find+import IDE.FileUtils+import IDE.Pane.ClassHierarchy+import IDE.Pane.Search+import IDE.Pane.Callers import Paths_leksah-+import IDE.GUIHistory+import Debug.Trace+import IDE.Metainfo.Provider (rebuildLibInfo,rebuildActiveInfo)+import IDE.Pane.Info (showInfo) -- -- | The Actions known to the system (they can be activated by keystrokes or menus) --@@ -94,8 +101,6 @@ (editFindInc Forward) [] False ,AD "EditFindPrevious" "Find _Previous" Nothing (Just "gtk-find-previous") (editFindInc Backward) [] False- ,AD "EditReplace" "_Replace" Nothing (Just "gtk-replace")- doReplace [] False ,AD "EditGotoLine" "_Goto Line" Nothing (Just "gtk-jump") editGotoLine [] False @@ -108,10 +113,20 @@ ,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 "EditCandy" "_To Candy" Nothing Nothing editCandy [] True - ,AD "Package" "Package" Nothing Nothing (return ()) [] False+ ,AD "Package" "_Package" Nothing Nothing (return ()) [] False ,AD "NewPackage" "_New Package" Nothing Nothing packageNew [] False ,AD "OpenPackage" "_Open Package" Nothing Nothing@@ -121,23 +136,23 @@ ,AD "ClosePackage" "_Close Package" Nothing Nothing deactivatePackage [] False - ,AD "PackageFlags" "Edit Flags" Nothing Nothing- packageFlags [] False- ,AD "ConfigPackage" "_Configure Package" Nothing (Just "ide_configure")+ ,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" Nothing (Just "ide_make")+ ,AD "BuildPackage" "_Build Package" (Just "Builds the package") (Just "ide_make") packageBuild [] False- ,AD "DocPackage" "_Build Documentation" Nothing Nothing+ ,AD "DocPackage" "_Build Documentation" (Just "Builds the documentation") Nothing packageDoc [] False- ,AD "CleanPackage" "Cl_ean Package" Nothing Nothing+ ,AD "CleanPackage" "Cl_ean Package" (Just "Cleans the package") Nothing packageClean [] False- ,AD "CopyPackage" "_Copy Package" Nothing Nothing+ ,AD "CopyPackage" "_Copy Package" (Just "Copies the package") Nothing packageCopy [] False- ,AD "RunPackage" "_Run" Nothing (Just "ide_run")+ ,AD "RunPackage" "_Run" (Just "Runs the package") (Just "ide_run") packageRun [] False- ,AD "NextError" "_Next Error" Nothing (Just "ide_error_next")+ ,AD "NextError" "_Next Error" (Just "Go to the next error") (Just "ide_error_next") nextError [] False- ,AD "PreviousError" "_Previous Error" Nothing (Just "ide_error_prev")+ ,AD "PreviousError" "_Previous Error" (Just "Go to the previous error") (Just "ide_error_prev") previousError [] False ,AD "InstallPackage" "_Install Package" Nothing Nothing@@ -153,6 +168,30 @@ ,AD "OpenDocPackage" "_Open Doc" Nothing Nothing packageOpenDoc [] False + ,AD "Metadata" "_Metadata" Nothing Nothing (return ()) [] False+ ,AD "UpdateMetadataCurrent" "_Update Project" Nothing Nothing+ rebuildActiveInfo [] False+ ,AD "UpdateMetadataLib" "_Update Lib" Nothing Nothing+ rebuildLibInfo [] False+ ,AD "ShowModules" "Show Modules" Nothing Nothing+ showModules [] False+ ,AD "ShowCallers" "Show Callers" Nothing Nothing+ showCallers [] 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@@ -183,18 +222,16 @@ ,AD "ViewClosePane" "Close pane" Nothing (Just "gtk-close") sessionClosePane [] False - ,AD "ClearLog" "_Clear Log" Nothing Nothing- clearLog [] False- ,AD "ShowToolbar" "Show Toolbar" Nothing Nothing- (do getToolbar; return ()) [] False- ,AD "ShowFind" "Show Find" Nothing Nothing- doFind [] False- ,AD "ShowReplace" "Show Replace" Nothing Nothing- doReplace [] False- ,AD "ShowModules" "Show Modules" Nothing Nothing- showModules [] 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 "Help" "_Help" Nothing Nothing (return ()) [] False ,AD "PrefsEdit" "_Edit Prefs" Nothing Nothing@@ -211,47 +248,45 @@ menuDescription :: IO String menuDescription = do prefsPath <- getConfigFilePathForLoad "Default.menu"- res <- readFile prefsPath+ res <- trace ("read from path : " ++ prefsPath) $ readFile prefsPath return res -- -- | Building the Menu -- makeMenu :: UIManager -> [ActionDescr IDERef] -> String -> IDEM (AccelGroup, [Widget])-makeMenu uiManager actions menuDescription = do- ideR <- ask- lift $ do- actionGroupGlobal <- actionGroupNew "global"- mapM_ (actm ideR actionGroupGlobal) actions- uiManagerInsertActionGroup uiManager actionGroupGlobal 1- uiManagerAddUiFromString uiManager menuDescription- accGroup <- uiManagerGetAccelGroup uiManager- mbWidgets <- mapM (uiManagerGetWidget uiManager) ["ui/menubar","ui/toolbar1","ui/toolbar2"]- let widgets = map (\mb -> case mb of+makeMenu uiManager actions menuDescription = reifyIDE (\ideR session -> do+ actionGroupGlobal <- actionGroupNew "global"+ mapM_ (actm ideR session actionGroupGlobal) actions+ uiManagerInsertActionGroup uiManager actionGroupGlobal 1+ uiManagerAddUiFromString uiManager menuDescription+ accGroup <- uiManagerGetAccelGroup uiManager+ mbWidgets <- mapM (uiManagerGetWidget uiManager) ["ui/menubar","ui/toolbar"]+ let widgets = map (\mb -> case mb of Just it -> it Nothing -> throwIDE "Menu>>makeMenu: failed to build menu") mbWidgets- return (accGroup,widgets)+ return (accGroup,widgets)) where- actm ideR ag (AD name label tooltip stockId ideAction accs isToggle) = do+ actm ideR session 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- onToggleActionToggled act (doAction ideAction ideR accString)+ on act actionToggled (doAction ideAction ideR session accString) actionGroupAddActionWithAccel ag act acc else do act <- actionNew name label tooltip stockId- onActionActivate act (doAction ideAction ideR accString)+ onActionActivate act (doAction ideAction ideR session accString) actionGroupAddActionWithAccel ag act acc- doAction ideAction ideR accStr =- runReaderT (do+ doAction ideAction ideR session accStr =+ handleTopExceptions (reflectIDE (do ideAction sb <- getSBSpecialKeys- lift $statusbarPop sb 1- lift $statusbarPush sb 1 $accStr- return ()) ideR+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 $accStr+ return ()) ideR session) -- | Quit ide -- ### make reasonable@@ -259,27 +294,28 @@ quit :: IDEAction quit = do saveSession :: IDEAction+ modifyIDE_ (\ide -> return (ide{isShuttingDown = True})) b <- fileCloseAll if b- then lift mainQuit- else return ()+ then liftIO mainQuit+ else modifyIDE_ (\ide -> return (ide{isShuttingDown = False})) -- -- | Show the about dialog -- aboutDialog :: IDEAction-aboutDialog = lift $ do+aboutDialog = liftIO $ do d <- aboutDialogNew aboutDialogSetName d "Leksah" aboutDialogSetVersion d (showVersion version)- aboutDialogSetCopyright d "Copyright 2007 Juergen Nicklisch-Franken aka Jutaro"+ aboutDialogSetCopyright d "Copyright 2007-2009 Jürgen Nicklisch-Franken" aboutDialogSetComments d $ "An integrated development environement (IDE) for the " ++- "programming language Haskell and the Glasgow Haskell compiler"+ "programming language Haskell and the Glasgow Haskell Compiler" dd <- getDataDir- license <- readFile $ dd </> "data" </> "gpl.txt"+ license <- catch (readFile $ dd </> "LICENSE") (\ (_ :: SomeException) -> return "") aboutDialogSetLicense d $ Just license- aboutDialogSetWebsite d "code.haskell.org/leksah"- aboutDialogSetAuthors d ["Juergen Nicklisch-Franken aka Jutaro"]+ aboutDialogSetWebsite d "http://leksah.org/"+ aboutDialogSetAuthors d ["Jürgen Nicklisch-Franken (Jutaro)"] dialogRun d widgetDestroy d return ()@@ -335,24 +371,53 @@ return hb newIcons :: IO ()-newIcons = +newIcons = catch (do iconFactory <- iconFactoryNew dataDir <- getDataDir mapM_ (loadIcon dataDir iconFactory) ["ide_class","ide_configure","ide_data","ide_error_next", "ide_error_prev","ide_field","ide_function","ide_instance", "ide_konstructor","ide_make",- "ide_method","ide_newtype","ide_no_source","ide_other","ide_rule","ide_run","ide_slot",- "ide_source","ide_type","leksah"+ "ide_method","ide_newtype","ide_other","ide_rule","ide_run","ide_slot",+ "ide_source","ide_type","leksah", "ide_reexported" ] iconFactoryAddDefault iconFactory)- (\e -> throwIDE "Can't load icons") + (\(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 +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' :: [String] -> IDEM[Action]+getActionsFor' l = do+ r <- mapM getActionFor l+ return (catMaybes r)+ where+ getActionFor string = do+ uiManager' <- readIDE uiManager+ actionGroups <- liftIO $ uiManagerGetActionGroups uiManager'+ res <- liftIO $ actionGroupGetAction (head actionGroups) string+ when (isNothing res) $ ideMessage Normal $ "Can't find UI Action " ++ string+ return res
− src/IDE/Metainfo/Info.hs
@@ -1,391 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.Metainfo.Info--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- 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.Info (- InfoAction(..)-) 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 Data.Binary-import qualified Data.ByteString.Lazy as BS-import Distribution.Package-import Data.Set (Set)-import qualified Data.Set as Set-import Data.Map (Map)-import Data.ByteString.Char8 (ByteString)-import System.Process(ProcessHandle,getProcessExitCode)-import System.Glib.MainLoop(timeoutAddFull,priorityDefaultIdle)-import Control.Monad.Reader(runReaderT,ask)-import Distribution.Version--import IDE.Utils.DeepSeq-import IDE.Utils.File-import IDE.Core.State-import IDE.Metainfo.InterfaceCollector--class InfoAction alpha where- -- | Initialize metadata for the world- initInfo :: alpha- -- | Update world metadata- updateAccessibleInfo :: alpha- -- | Builds the current info for a package- -- Called when a package gets active or after a reconfigure- infoForActivePackage :: alpha- -- | Builds the current info for the activePackage in the background.- -- If a process handle is given, it waits for this process to finish before building- -- and only rebuilds if build was successful- -- Called after a build- mayRebuildInBackground :: Maybe ProcessHandle -> alpha- -- | Rebuild current info- rebuildActiveInfo :: alpha--instance InfoAction IDEAction where- initInfo = initInfo'- updateAccessibleInfo = updateAccessibleInfo'- infoForActivePackage = infoForActivePackage'- mayRebuildInBackground = mayRebuildInBackground'- rebuildActiveInfo = setInfo buildActiveInfo------- | Update and initialize metadata for the world----initInfo' :: IDEAction-initInfo' = do- session' <- readIDE session- ideMessage Normal "Now updating metadata ..."- lift $ collectInstalled session' 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- session' <- readIDE session-- collectorPath <- lift $ getCollectorPath version- packageInfos <- lift $ getInstalledPackageInfos session'- packageList <- lift $ mapM (loadInfosForPackage collectorPath)- (map (fromDPid . DP.package) packageInfos)- let scope = foldr buildScope (Map.empty,Map.empty)- $ map fromJust- $ filter isJust packageList- modifyIDE_ (\ide -> return (ide{accessibleInfo = (Just scope)}))------- | Clears the current info, not the world infos----clearCurrentInfo :: IDEAction-clearCurrentInfo = do- modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))- ideR <- ask- triggerEvent ideR CurrentInfo- return ()------- | Set info for package----infoForActivePackage' :: IDEAction-infoForActivePackage' = do- activePack <- readIDE activePack- case activePack of- Nothing -> do- modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))- Just pack -> do- let depends' = depends pack- session' <- readIDE session- fp <- lift $findFittingPackages session' depends'- mbActive <- loadOrBuildActiveInfo- case mbActive of- Nothing -> do- -- no meta info available- modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))- Just active -> do-- accessibleInfo' <- readIDE accessibleInfo- case accessibleInfo' of- Nothing -> modifyIDE_ (\ide -> return (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 -> return (ide{currentInfo = Just (active, scope)}))- ideR <- ask- triggerEvent ideR CurrentInfo- return ()-------- | Builds the current info for the activePackage in the background--- If a process handle is given, it waits for this process to finish before building----mayRebuildInBackground' :: Maybe ProcessHandle -> IDEAction-mayRebuildInBackground' mbHandle = do- ideR <- ask- lift $ do- timeoutAddFull (myRebuild ideR) priorityDefaultIdle 500- return ()- where- myRebuild :: IDERef -> IO Bool- myRebuild ideR =- case mbHandle of- Just hdl -> do- mbExitCode <- getProcessExitCode hdl- case mbExitCode of- --process not finished, wait for next call- Nothing -> return True- Just _ -> doIt ideR- Nothing -> doIt ideR- doIt :: IDERef -> IO Bool- doIt ideR = do- runReaderT (do- errs <- readIDE errors- when (length (filter isError errs) == 0) $ do- ideMessage Normal "Update meta info for active package"- setInfo buildActiveInfo) ideR- return False------- | 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 -> return (ide{currentInfo = Just (newActive, scope)}))- ideR <- ask- triggerEvent ideR 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- session <- readIDE session- case activePack of- Nothing -> return Nothing- Just idePackage -> do- collectorPath <- lift $ getCollectorPath cProjectVersion- packageDescr <- lift $ loadInfosForPackage collectorPath- (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- session <- readIDE session- case activePack of- Nothing -> return Nothing- Just idePackage -> do- lift $ collectUninstalled False session cProjectVersion (cabalFile idePackage)- -- ideMessage Normal "uninstalled collected"- collectorPath <- lift $ getCollectorPath cProjectVersion- packageDescr <- lift $ loadInfosForPackage collectorPath- (packageId idePackage)- case packageDescr of- Nothing -> return Nothing- Just pd -> do- let scope = buildScope pd (Map.empty,Map.empty)- return (Just scope)------- | Updates the world info (it is the responsibility of the caller to rebuild--- the current info)----updateAccessibleInfo' :: IDEAction-updateAccessibleInfo' = do- wi <- readIDE accessibleInfo- session <- readIDE session- let version = cProjectVersion- case wi of- Nothing -> loadAccessibleInfo- Just (psmap,psst) -> do- packageInfos <- lift $ getInstalledPackageInfos session- let packageIds = map (fromDPid . 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 <- lift $ mapM (\pid -> loadInfosForPackage collectorPath 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 -> return (ide{accessibleInfo = Just scope}))------- | Loads the infos for the given packages----loadInfosForPackage :: FilePath -> PackageIdentifier -> IO (Maybe PackageDescr)-loadInfosForPackage dirPath pid = do- let filePath = dirPath </> showPackageId pid ++ ".pack"- exists <- doesFileExist filePath- if exists- then catch (do- file <- openBinaryFile filePath ReadMode- bs <- BS.hGetContents file- let packageInfo = decode bs- packageInfo `deepSeq` (hClose file)- return (Just packageInfo))- (\e -> do sysMessage Normal (show e); return Nothing)- else do- sysMessage Normal $"packageInfo not found for " ++ showPackageId 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 (\ st idDescr -> let allIds = identifierID idDescr : (allConstructorsID idDescr- ++ allFieldsID idDescr ++ allClassOpsID idDescr)- in foldl (\ st2 id -> Map.insertWith (++) id [idDescr] st2) st allIds)- symbolTable (idDescriptionsPD pDescr)------ ------------------------------------------------------------------------ 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)- $ deepSeq (idDescriptionsPD pd)--instance DeepSeq ModuleDescr where- deepSeq pd = deepSeq (moduleIdMD pd)- $ deepSeq (mbSourcePathMD pd)- $ deepSeq (exportedNamesMD pd)- $ deepSeq (usagesMD pd)--instance DeepSeq IdentifierDescr where- deepSeq (SimpleDescr identifierID' identifierTypeID' typeInfoID' moduleIdID'- mbLocation' mbComment') = deepSeq identifierID'- $ deepSeq identifierTypeID'- $ deepSeq typeInfoID'- $ deepSeq moduleIdID'- $ deepSeq mbLocation'- $ deepSeq mbComment'- deepSeq (DataDescr identifierID' typeInfoID' moduleIdID' constructorsID' fieldsID'- mbLocation' mbComment') = deepSeq identifierID'- $ deepSeq typeInfoID'- $ deepSeq moduleIdID'- $ deepSeq constructorsID'- $ deepSeq fieldsID'- $ deepSeq mbLocation'- $ deepSeq mbComment'- deepSeq (ClassDescr identifierID' typeInfoID' classOpsID' moduleIdID'- mbLocation' mbComment') = deepSeq identifierID'- $ deepSeq typeInfoID'- $ deepSeq moduleIdID'- $ deepSeq classOpsID'- $ deepSeq mbLocation'- $ deepSeq mbComment'- deepSeq (InstanceDescr identifierID' classID' moduleIdID'- mbLocation' mbComment') = deepSeq identifierID'- $ deepSeq classID'- $ deepSeq moduleIdID'- $ deepSeq mbLocation'- $ deepSeq mbComment'--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 IdType where deepSeq = seq--instance DeepSeq IdTypeS where deepSeq = seq--instance DeepSeq ByteString where deepSeq = seq--instance DeepSeq Version where deepSeq = seq--instance DeepSeq PackModule where- deepSeq pd = deepSeq (pack pd)- $ deepSeq (modu pd)-
src/IDE/Metainfo/InterfaceCollector.hs view
@@ -1,11 +1,11 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -XScopedTypeVariables -XFlexibleContexts#-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.InterfaceCollector -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL ----- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org> -- Stability : experimental -- Portability : portable --@@ -19,18 +19,18 @@ , collectInstalled' , collectUninstalled , getInstalledPackageInfos-, asDPid-, fromDPid , findFittingPackages+, metadataVersion ) where -import GHC hiding(Id,Failed,Succeeded)-import Module-import TcRnMonad+import GHC hiding(Id,Failed,Succeeded,ModuleName)+import Module hiding (PackageId,ModuleName)+import qualified Module+import TcRnMonad hiding (liftIO,MonadIO) import qualified Maybes as M-import HscTypes+import HscTypes hiding (liftIO) import LoadIface import Outputable hiding(trace) import IfaceSyn@@ -39,16 +39,20 @@ import qualified PackageConfig as DP import Name import PrelNames-import PackageConfig(mainPackageId,unpackPackageId,mkPackageId)+import PackageConfig(unpackPackageId,mkPackageId) import Maybes import TcRnTypes import Finder import qualified FastString as FS import ErrUtils import Config(cProjectVersion)-import UniqFM+import Distribution.PackageDescription.Parse(readPackageDescription)+import Distribution.PackageDescription.Configuration(flattenPackageDescription)+import qualified IOEnv as IOEnv (liftIO,MonadIO)+import IOEnv hiding (liftIO,MonadIO) -import Data.List (maximumBy)+import Debug.Trace+ import Data.Char (isSpace) import qualified Data.Map as Map import Data.Map (Map)@@ -56,12 +60,13 @@ import qualified Data.Set as Set import Data.Set (Set) import System.Directory-import qualified PackageConfig as DP import Distribution.PackageDescription-import Distribution.InstalledPackageInfo hiding (package)-import Distribution.Package+import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.Package hiding (PackageId) import Distribution.Verbosity import Distribution.Version+import Distribution.ModuleName+import Distribution.Text (simpleParse,display) import Control.Monad.Reader import System.IO import Data.Maybe@@ -71,13 +76,15 @@ import Data.Binary import qualified Data.ByteString.Char8 as BS --import IDE.Utils.Default-import IDE.Core.State-import IDE.Utils.File---import IDE.Metainfo.Info+import Default+import IDE.Core.State hiding (depends)+import IDE.FileUtils+--import IDE.Metainfo.Provider import IDE.Metainfo.SourceCollector +metadataVersion :: Integer+metadataVersion = 3+ data CollectStatistics = CollectStatistics { packagesTotal :: Int , packagesWithSource :: Int@@ -92,167 +99,195 @@ collectInstalledI :: Bool -> IDEAction collectInstalledI b = do- session' <- readIDE session- sources <- lift $ getSourcesMap- lift $ collectInstalled' False session' cProjectVersion b sources+ session' <- lift $ getSession+ sources <- liftIO $ getSourcesMap+ lift $ collectInstalled' False cProjectVersion b sources -collectInstalled :: Session -> Bool -> IO ()+collectInstalled :: HscEnv -> Bool -> Ghc () collectInstalled session b = do- sources <- getSourcesMap- collectInstalled' False session cProjectVersion b sources+ sources <- liftIO $ getSourcesMap+ collectInstalled' False cProjectVersion b sources -collectInstalled' :: Bool -> Session -> String -> Bool -> Map PackageIdentifier [FilePath] -> IO()-collectInstalled' writeAscii session version forceRebuild sources = do- collectorPath <- getCollectorPath version- when forceRebuild $ do+collectInstalled' :: Bool -> String -> Bool -> Map PackageIdentifier [FilePath] -> Ghc()+collectInstalled' writeAscii version forceRebuild sources = do+ session <- getSession+ setTargets []+ load LoadAllTargets+ depanal [] False+ collectorPath <- liftIO $ getCollectorPath version+ when forceRebuild $ liftIO $ do removeDirectoryRecursive collectorPath getCollectorPath version return ()- knownPackages <- findKnownPackages collectorPath- packageInfos <- getInstalledPackageInfos session- let newPackages = filter (\pi -> not $Set.member (showPackageId $ fromDPid $ DP.package pi)+ knownPackages <- liftIO $ findKnownPackages collectorPath+ packageInfos <- getInstalledPackageInfos+ let newPackages = filter (\pi -> not $Set.member (fromPackageIdentifier $ IPI.package pi) knownPackages) packageInfos- exportedIfaceInfos <- mapM (\ info -> getIFaceInfos (DP.mkPackageId $ DP.package info)- (DP.exposedModules info) session) newPackages- hiddenIfaceInfos <- mapM (\ info -> getIFaceInfos (DP.mkPackageId $ DP.package info)- (DP.hiddenModules info) session) newPackages+ 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 (fromDPid . DP.package) newPackages)- ((map (\p -> map fromDPid (DP.depends p)))- newPackages)- (extracted',failedToParse) <- collectAllSources session sources extracted+ (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 newPackages- , packagesWithSource = length $ filter (\p -> isJust (mbSourcePathPD p)) extracted'- , modulesTotal = foldl (\n p -> n + length (exposedModulesPD p)) 0 extracted'- , modulesWithSource = foldl (\n p -> n + length (- filter (\p -> isJust (mbSourcePathMD p)) (exposedModulesPD p)))- 0 extracted'- , parseFailures = failedToParse}- sysMessage Normal $ show statistic+ 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 (modulesWithSource statistic)) * 100.0)):: Integer)- mapM_ (writeExtracted collectorPath writeAscii) extracted' -collectUninstalled :: Bool -> Session -> String -> FilePath -> IO ()-collectUninstalled writeAscii session version cabalPath = do- pd <- readPackageDescription normal cabalPath+collectUninstalled :: Bool -> String -> FilePath -> Ghc ()+collectUninstalled writeAscii version cabalPath = do+ setTargets []+ load LoadAllTargets+ depanal [] False+ pd <- liftIO $ readPackageDescription normal cabalPath >>= return . flattenPackageDescription+ let packageName = if hasExes pd+ then "main"+ else show $ package pd let modules = nub $ exeModules pd ++ libModules pd- let basePath = takeDirectory cabalPath- let buildPath = "dist" </> "build" </> pkgName (package pd) </>- (pkgName (package pd) ++ "-tmp/")- dflags0 <- getSessionDynFlags session- setSessionDynFlags session+ cCabalPath <- liftIO $ canonicalizePath cabalPath+ 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" </> ""+ trace ("basePath = " ++ basePath) (return ())+ trace ("buildPath = " ++ buildPath) (return ())++ dflags0 <- getSessionDynFlags+ setSessionDynFlags dflags0- { topDir = basePath- , importPaths = [buildPath]- --, thisPackage = mkPackageId (package pd)- , ghcMode = OneShot+ { topDir = basePath+ , importPaths = [buildPath,"dist" </> "build" </> "autogen"]+ , thisPackage = if hasExes pd then mainPackageId else mkPackageId (package pd)+ , ghcMode = OneShot }- dflags1 <- getSessionDynFlags session- (dflags2,_) <- parseDynamicFlags dflags1 ["-fglasgow-exts","-haddock"]- setSessionDynFlags session dflags2- allIfaceInfos <- getIFaceInfos2 modules session- deps <- findFittingPackages session (buildDepends pd)- let extracted = extractInfo (allIfaceInfos,[], package pd, deps)+ dflags1 <- getSessionDynFlags+ (dflags2,_,_) <- parseDynamicFlags dflags1 [(noLoc "-fglasgow-exts")]+ setSessionDynFlags dflags2+-- trace ("modules = " ++ show modules) (return ())+ let ghcmodules = map (mkModuleName . display) modules+ allIfaceInfos <- getIFaceInfos2 ghcmodules packageName+ deps <- findFittingPackages (buildDepends pd)+ let extracted = extractInfo (allIfaceInfos, [], package pd, deps)+-- trace ("extracted = " ++ show extracted) (return ()) let sources = Map.fromList [(package pd,[cabalPath])]- (extractedWithSources,_) <- collectSources session sources extracted+ (extractedWithSources,_) <- collectSources sources extracted collectorPath <- getCollectorPath version- writeExtracted collectorPath writeAscii extractedWithSources- writeExtracted collectorPath True extractedWithSources+ writeExtracted collectorPath writeAscii True extractedWithSources sysMessage Normal $ "\nExtracted infos for " ++ cabalPath ------------------------------------------------------------------------- -getIFaceInfos :: PackageId -> [String] -> Session -> IO [(ModIface, FilePath)]+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 == "base"+ let isBase = pkgName pid == (PackageName "base") let ifaces = mapM (\ mn -> findAndReadIface empty (if isBase- then mkBaseModule_ (mkModuleName mn)- else mkModule pckg- (mkModuleName mn))+ then mkBaseModule_ mn+ else mkModule pckg mn) False) modules- hscEnv <- sessionHscEnv session+ hscEnv <- getSession let gblEnv = IfGblEnv { if_rec_types = Nothing }- maybes <- initTcRnIf 'i' hscEnv gblEnv () ifaces+ 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 :: [String] -> Session -> IO [(ModIface, FilePath)]-getIFaceInfos2 modules session = do- let ifaces = mapM (\ mn -> findAndReadIface2 mn- (mkModule mainPackageId (mkModuleName mn))) modules- hscEnv <- sessionHscEnv session+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 <- initTcRnIf 'i' hscEnv gblEnv () ifaces+ 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) = Nothing+ handleErr (M.Failed mess) = trace ("failed !!!" ++ showSDoc mess) Nothing -findAndReadIface2 :: String -> Module -> TcRnIf gbl lcl (MaybeErr Message (ModIface, FilePath))-findAndReadIface2 doc mod = do- hsc_env <- getTopEnv- mb_found <- ioToIOEnv (findExactModule hsc_env mod)+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- read_result <- readIface mod file_path False+ filePath <- IOEnv.liftIO $ canonicalizePath file_path+ read_result <- readIface mod filePath False case read_result of- Failed _ -> returnM (Failed (text $ "can't read iface " ++- doc ++ " at " ++ file_path))+ 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" ++ doc))+ -> return (Failed (text $ "read but not equal" ++ moduleNameString doc)) | otherwise- -> returnM (Succeeded (iface, file_path))- _ -> return (Failed (text $ "can't locate " ++ doc))+ -> 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 hiddenDescrs = foldr (extractExportedDescrH pi) Map.empty (map fst ifacesHid)- mods = --trace ("\nhidden: " ++ show (Map.keysSet hiddenDescrs))- map (extractExportedDescrR pi hiddenDescrs) (map fst ifacesExp)+ 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 -> SymbolTable -> SymbolTable-extractExportedDescrH pid iface amap =- let exportedNames = Set.fromList+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 foldr (extractIdentifierDescr' pid []) amap exportedDecls+ in concatMap (extractIdentifierDescr pid [mid]) exportedDecls extractExportedDescrR :: PackageIdentifier- -> SymbolTable+ -> [Descr] -> ModIface -> ModuleDescr extractExportedDescrR pid hidden iface =- let mid = moduleNameString $moduleName (mi_module iface)+ let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) exportedNames = Set.fromList $map occNameString $concatMap availNames@@ -261,11 +296,9 @@ `Set.member` exportedNames) (map snd (mi_decls iface)) ownDecls = concatMap (extractIdentifierDescr pid [mid]) exportedDecls--- otherDecls = exportedNames `Set.difference` (Map.keysSet mapWithOwnDecls)--- reexported = Map.map (\v -> map (\id -> id{moduleIdID = (PM pid mid)}) v)--- {--: [moduleIdID id]--}--- $Map.filterWithKey (\k _ -> k `Set.member` otherDecls)--- hidden+ 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 {@@ -273,126 +306,118 @@ , exportedNamesMD = exportedNames , mbSourcePathMD = Nothing , usagesMD = uses- , idDescriptionsMD = ownDecls ++ inst}--extractIdentifierDescr' :: PackageIdentifier -> [ModuleIdentifier] -> IfaceDecl ->- SymbolTable -> SymbolTable-extractIdentifierDescr' pid mods ifDecl amap =- let descrs = extractIdentifierDescr pid mods ifDecl- in foldr addToMap amap descrs- where- addToMap :: IdentifierDescr -> SymbolTable -> SymbolTable- addToMap iddescr amap =- let allIds = identifierID iddescr : (constructorsID iddescr- ++ fieldsID iddescr- ++ classOpsID iddescr)- in foldl (\ st id -> Map.insertWith (++) id [iddescr] st) amap allIds+ , idDescriptionsMD = ownDecls ++ inst ++ reexported} -extractIdentifierDescr :: PackageIdentifier -> [ModuleIdentifier] -> IfaceDecl- -> [IdentifierDescr]+extractIdentifierDescr :: PackageIdentifier -> [ModuleName] -> IfaceDecl+ -> [Descr] extractIdentifierDescr package modules decl- = if null modules- then []- else case decl of+ = if null modules+ then []+ else+ let descr = Descr{+ descrName' = unpackFS $occNameFS (ifName decl)+ , typeInfo' = BS.pack $ filterExtras $ showSDocUnqual $ppr decl+ , descrModu' = PM package (last modules)+ , mbLocation' = Nothing+ , mbComment' = Nothing+ , details' = VariableDescr+ }+ in case decl of (IfaceId _ _ _ )- -> [SimpleDescr{- identifierID = unpackFS $occNameFS (ifName decl)- , typeInfoID = BS.pack $ filterExtras $ showSDocUnqual $ppr decl- , identifierTypeID = FunctionS- , moduleIdID = PM package (last modules)- , mbLocation = Nothing- , mbComment = Nothing- }]- (IfaceData _ _ _ ifCons _ _ _ _)- -> case ifCons of- IfDataTyCon _- -> [DataDescr{- identifierID = unpackFS $occNameFS (ifName decl)- , typeInfoID = BS.pack $ filterExtras- $ showSDocUnqual $ppr decl- , moduleIdID = PM package (last modules)- , constructorsID = map extractConstructorName- (visibleIfConDecls ifCons)- , fieldsID = concatMap extractFieldNames- (visibleIfConDecls ifCons)- , mbLocation = Nothing- , mbComment = Nothing- }]- other -> [SimpleDescr{- identifierID = unpackFS $occNameFS (ifName decl)- , typeInfoID = BS.pack $ filterExtras- $ showSDocUnqual $ppr decl- , identifierTypeID = case other of- IfNewTyCon _ -> NewtypeS- IfAbstractTyCon -> AbstractDataS- IfOpenDataTyCon -> OpenDataS- _ -> throwIDE- "Impossible"- , moduleIdID = PM package (last modules)- , mbLocation = Nothing- , mbComment = Nothing- }]- (IfaceClass _ _ _ _ _ ifSigs _ )- -> [ClassDescr{- identifierID = unpackFS $occNameFS (ifName decl)- , typeInfoID = BS.pack $ filterExtras- $ showSDocUnqual $ppr decl- , moduleIdID = PM package (last modules)- , classOpsID = map (extractClassOpName) ifSigs- , mbLocation = Nothing- , mbComment = Nothing- }]+ -> [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 _ _ _ _ _ )- -> [SimpleDescr{- identifierID = unpackFS $occNameFS (ifName decl)- , typeInfoID = BS.pack $ filterExtras- $ showSDocUnqual $ppr decl- , identifierTypeID = TypeS- , moduleIdID = PM package (last modules)- , mbLocation = Nothing- , mbComment = Nothing- }]+ -> [descr] (IfaceForeign _ _)- -> [SimpleDescr{- identifierID = unpackFS $occNameFS (ifName decl)- , typeInfoID = BS.pack $ filterExtras- $ showSDocUnqual $ppr decl- , identifierTypeID = ForeignS- , moduleIdID = PM package (last modules)- , mbLocation = Nothing- , mbComment = Nothing- }]+ -> [descr] -extractConstructorName :: IfaceConDecl -> Symbol-extractConstructorName decl = unpackFS $occNameFS (ifConOcc decl)+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] -extractFieldNames :: IfaceConDecl -> [Symbol]-extractFieldNames decl = map (extractFieldNames') (ifConFields decl)+extractFields :: IfaceConDecl -> [(Symbol,TypeInfo)]+extractFields decl = zip (map extractFieldNames (ifConFields decl))+ (map extractType (ifConArgTys decl)) -extractFieldNames' :: OccName -> Symbol-extractFieldNames' occName = unpackFS $occNameFS occName+extractType :: IfaceType -> TypeInfo+extractType decl = BS.pack $ filterExtras $ showSDocUnqual $ppr decl -extractClassOpName :: IfaceClassOp -> Symbol-extractClassOpName (IfaceClassOp occName _ _) = unpackFS $occNameFS occName+extractFieldNames :: OccName -> Symbol+extractFieldNames occName = unpackFS $occNameFS occName -extractInstances :: PackModule -> IfaceInst -> [IdentifierDescr]+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 [InstanceDescr- { identifierID = className- , binds = dataNames- , moduleIdID = pm- , mbLocation = Nothing- , mbComment = Nothing}]+ in [Descr+ { descrName' = className+ , typeInfo' = BS.empty+ , descrModu' = pm+ , mbLocation' = Nothing+ , mbComment' = Nothing+ , details' = InstanceDescr {binds = dataNames}}] -extractUsages :: Usage -> (ModuleIdentifier, Set Symbol)-extractUsages usage =- let name = (showSDoc . ppr) $ usg_name usage- ids = map (showSDocUnqual . ppr . fst) $ usg_entities usage++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@@ -422,49 +447,13 @@ | otherwise = skipNextWord' r skipNextWord' [] = [] -writeExtracted :: FilePath -> Bool -> PackageDescr -> IO ()-writeExtracted dirPath writeAscii pd = do- let filePath = dirPath </> showPackageId (packagePD pd) ++ ".pack"+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 encodeFile filePath pd---- ------------------------------------------------------------------------ The (mothers) little helpers-----getInstalledPackageInfos :: Session -> IO [DP.InstalledPackageInfo]-getInstalledPackageInfos session = do- dflags1 <- getSessionDynFlags session- pkgInfos <- case pkgDatabase dflags1 of- Nothing -> return []- Just fm -> return (eltsUFM fm)- return pkgInfos--asDPid :: PackageIdentifier -> DP.PackageIdentifier-asDPid (PackageIdentifier name version) = DP.PackageIdentifier name version--fromDPid :: DP.PackageIdentifier -> PackageIdentifier-fromDPid (DP.PackageIdentifier name version) = PackageIdentifier name version--findFittingPackages :: Session -> [Dependency] -> IO [PackageIdentifier]-findFittingPackages session dependencyList = do- knownPackages <- getInstalledPackageInfos session- let packages = map (fromDPid . DP.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--findFittingPackagesDP :: Session -> [Dependency] -> IO [PackageIdentifier]-findFittingPackagesDP session dependencyList = do- fp <- (findFittingPackages session dependencyList)- return fp+ else encodeFile filePath (metadataVersion, pd) -- --------------------------------------------------------------------- -- Binary Instances for linear storage@@ -524,87 +513,95 @@ return (ModuleDescr moduleIdMD' exportedNamesMD' mbSourcePathMD' usagesMD' idDescriptionsMD') -instance Binary IdentifierDescr where- put (SimpleDescr identifierID' identifierTypeID' typeInfoID' moduleIdID'- mbLocation' mbComment')- = do put (1::Int)- put identifierID'- put identifierTypeID'- put typeInfoID'- put moduleIdID'- put mbLocation'- put mbComment'- put (DataDescr identifierID' typeInfoID' moduleIdID'- constructorsID' fieldsID' mbLocation' mbComment')- = do put (2::Int)- put identifierID'- put typeInfoID'- put moduleIdID'- put constructorsID'- put fieldsID'- put mbLocation'- put mbComment'- put (ClassDescr identifierID' typeInfoID' moduleIdID'- classOpsID' mbLocation' mbComment')- = do put (3::Int)- put identifierID'- put typeInfoID'- put moduleIdID'- put classOpsID'- put mbLocation'- put mbComment'- put (InstanceDescr identifierID' classID' moduleIdID' mbLocation' mbComment')- = do put (4::Int)- put identifierID'- put classID'- put moduleIdID'- put mbLocation'- put mbComment'- get = do (typeHint :: Int) <- get+instance Binary 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- identifierID' <- get- identifierTypeID' <- get- typeInfoID' <- get- moduleIdID' <- get- mbLocation' <- get- mbComment' <- get- return (SimpleDescr identifierID' identifierTypeID' typeInfoID'- moduleIdID' mbLocation' mbComment')+ descrName2 <- get+ typeInfo2 <- get+ descrModu2 <- get+ mbLocation2 <- get+ mbComment2 <- get+ details2 <- get+ return (Descr descrName2 typeInfo2 descrModu2 mbLocation2+ mbComment2 details2) 2 -> do- identifierID' <- get- typeInfoID' <- get- moduleIdID' <- get- constructorsID' <- get- fieldsID' <- get- mbLocation' <- get- mbComment' <- get- return (DataDescr identifierID' typeInfoID' moduleIdID'- constructorsID' fieldsID' mbLocation' mbComment')- 3 -> do- identifierID' <- get- typeInfoID' <- get- moduleIdID' <- get- classOpsID' <- get- mbLocation' <- get- mbComment' <- get- return (ClassDescr identifierID' typeInfoID' moduleIdID'- classOpsID' mbLocation' mbComment')- 4 -> do- identifierID' <- get- classID' <- get- moduleIdID' <- get- mbLocation' <- get- mbComment' <- get- return (InstanceDescr identifierID' classID' moduleIdID'- mbLocation' mbComment')- _ -> throwIDE "Impossible in Binary IdentifierDescr get"+ reexpModu' <- get+ impDescr' <- get+ return (Reexported reexpModu' impDescr')+ _ -> throwIDE "Impossible in Binary Descr get" +instance Binary 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' -instance Binary IdTypeS where- put it = do put (fromEnum it)- get = do code <- get- return (toEnum code)+ 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 Binary Location where put (Location locationSLine' locationSCol' locationELine' locationECol')@@ -618,4 +615,11 @@ locationECol' <- get return (Location locationSLine' locationSCol' locationELine' locationECol') +instance Binary ModuleName where+ put = put . display+ get = liftM (fromJust . simpleParse) get++instance Binary PackageName where+ put (PackageName pn) = put pn+ get = liftM PackageName get
+ src/IDE/Metainfo/Provider.hs view
@@ -0,0 +1,504 @@+{-# OPTIONS_GHC -XTypeSynonymInstances -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Metainfo.Provider+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- 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 (+ initInfo+, updateAccessibleInfo+, infoForActivePackage+, mayRebuildInBackground+, 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 Data.Binary+import qualified Data.ByteString.Lazy as BS+import Distribution.Package hiding (depends,packageId)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import Data.ByteString.Char8 (ByteString)+import System.Process (ProcessHandle(..),getProcessExitCode)+import System.Glib.MainLoop(timeoutAddFull,priorityDefaultIdle)+import Control.Monad.Reader(ask)+import Distribution.Version+import Distribution.ModuleName+import GHC (runGhc,getSession)++import DeepSeq+import IDE.FileUtils+import IDE.Core.State+import IDE.Metainfo.InterfaceCollector+import Control.Event+import Data.Char (toLower,isUpper,toUpper,isLower)+import Text.Regex.Posix+import System.IO.Unsafe (unsafePerformIO)+import Text.Regex.Posix.String (execute,compile)++--+-- | Searching of metadata+--+searchMeta :: Scope -> String -> SearchMode -> IDEM [Descr]+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+ session' <- lift getSession+ when (collectAtStart prefs) $ do+ ideMessage Normal "Now updating metadata ..."+ lift $ collectInstalled session' 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 <- lift $ getInstalledPackageInfos+ packageList <- liftIO $ mapM (loadInfosForPackage collectorPath False)+ (map DP.package packageInfos)+ let scope = foldr buildScope (Map.empty,Map.empty)+ $ map fromJust+ $ filter isJust packageList+ modifyIDE_ (\ide -> return (ide{accessibleInfo = (Just scope)}))++--+-- | Clears the current info, not the world infos+--+clearCurrentInfo :: IDEAction+clearCurrentInfo = do+ modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))+ ideR <- ask+ triggerEvent ideR CurrentInfo+ return ()++--+-- | Set info for package+--+infoForActivePackage :: IDEAction+infoForActivePackage = do+ activePack <- readIDE activePack+ case activePack of+ Nothing -> do+ modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))+ Just pack -> do+ let depends' = depends pack+ fp <- lift $findFittingPackages depends'+ mbActive <- loadOrBuildActiveInfo+ case mbActive of+ Nothing -> do+ -- no meta info available+ modifyIDE_ (\ide -> return (ide{currentInfo = Nothing}))+ Just active -> do++ accessibleInfo' <- readIDE accessibleInfo+ case accessibleInfo' of+ Nothing -> modifyIDE_ (\ide -> return (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 -> return (ide{currentInfo = Just (active, scope)}))+ ideR <- ask+ triggerEvent ideR CurrentInfo+ return ()+++--+-- | Builds the current info for the activePackage in the background+-- If a process handle is given, it waits for this process to finish before building+--+mayRebuildInBackground :: Maybe ProcessHandle -> IDEAction+mayRebuildInBackground mbHandle = reifyIDE $ \ ideR session ->+ let+ myRebuild :: IO Bool+ myRebuild =+ case mbHandle of+ Just hdl -> do+ mbExitCode <- getProcessExitCode hdl+ case mbExitCode of+ --process not finished, wait for next call+ Nothing -> return True+ Just _ -> doIt+ Nothing -> doIt+ doIt :: IO Bool+ doIt = do+ reflectIDE (do+ errs <- readIDE errors+ when (length (filter isError errs) == 0) $ do+ ideMessage Normal "Update meta info for active package"+ setInfo buildActiveInfo) ideR session+ return False+ in do+ timeoutAddFull myRebuild priorityDefaultIdle 500+ return ()++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 -> return (ide{currentInfo = Just (newActive, scope)}))+ ideR <- ask+ triggerEvent ideR 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 (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 <- lift 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 -> return (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+ bs <- BS.hGetContents file+ let (metadataVersion', packageInfo) = decode 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 (usagesMD 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 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+
src/IDE/Metainfo/SourceCollector.hs view
@@ -1,10 +1,11 @@+{-# OPTIONS_GHC -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.SourceCollector -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL ----- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org> -- Stability : experimental -- Portability : portable --@@ -13,8 +14,7 @@ ------------------------------------------------------------------------------- module IDE.Metainfo.SourceCollector (- collectAllSources-, collectSources+ collectSources , buildSourceForPackageDB , sourceForPackage , parseSourceForPackageDB@@ -33,17 +33,13 @@ import Control.Monad.State import System.FilePath import System.IO-import Data.List(nub,delete,sort)-import Distribution.Simple.PreProcess.Unlit-import Distribution.Simple.PreProcess(runSimplePreProcessor,ppCpp)-import Distribution.Simple.Program(defaultProgramConfiguration)-import Distribution.Compiler(CompilerFlavor(..))-import Distribution.Simple.LocalBuildInfo(LocalBuildInfo(..))-import Distribution.Simple.Configure(configure)-import Distribution.Simple.Setup(emptyConfigFlags)+import Data.List (foldl',nub,delete,sort) import Data.Maybe(catMaybes) import qualified Control.Exception as C import qualified Data.ByteString.Char8 as BS+import Distribution.PackageDescription.Parse (readPackageDescription)+import Distribution.PackageDescription.Configuration (flattenPackageDescription)+import Control.Exception (SomeException) import GHC hiding (idType)@@ -52,18 +48,14 @@ import OccName import DynFlags import PackageConfig hiding (exposedModules)-import StringBuffer-import Bag-import ErrUtils import FastString-import Lexer hiding (lexer)-import Parser import Outputable hiding (char)-import HscStats import IDE.Core.State-import IDE.Utils.File-import IDE.Preferences+import IDE.FileUtils+import IDE.Pane.Preferences+import Digraph (flattenSCCs)+import HscTypes (msHsFilePath) -- --------------------------------------------------------------------- -- Function to map packages to file paths@@ -73,8 +65,7 @@ getSourcesMap = do mbSources <- parseSourceForPackageDB case mbSources of- Just map -> do- return map+ Just map -> return map Nothing -> do buildSourceForPackageDB mbSources <- parseSourceForPackageDB@@ -98,8 +89,13 @@ let dirs = sourceDirectories prefs cabalFiles <- mapM allCabalFiles dirs fCabalFiles <- mapM canonicalizePath $ concat cabalFiles- packages <- mapM (\fp -> parseCabal fp) fCabalFiles- let pdToFiles = Map.fromListWith (++) (zip packages (map (\a -> [a]) fCabalFiles))+ 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)) @@ -107,7 +103,7 @@ 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)+ 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 @@ -182,17 +178,17 @@ whiteSpace = P.whiteSpace lexer symbol = P.symbol lexer -parseCabal :: FilePath -> IO String+parseCabal :: FilePath -> IO (Maybe String) parseCabal fn = do putStrLn $ "Now parsing minimal " ++ fn res <- parseFromFile cabalMinimalParser fn case res of Left pe -> do- putStrLn "before throw"- throwIDE $"Error reading cabal file " ++ show fn ++ " " ++ show pe+ sysMessage Normal $"Error reading cabal file " ++ show fn ++ " " ++ show pe+ return Nothing Right r -> do sysMessage Normal r- return r+ return (Just r) cabalMinimalParser :: CharParser () String cabalMinimalParser = do@@ -202,11 +198,11 @@ Left v -> do case r2 of Right n -> return (n ++ "-" ++ v)- Left _ -> throwIDE "Illegal cabal"+ Left _ -> unexpected "Illegal cabal" Right n -> do case r2 of Left v -> return (n ++ "-" ++ v)- Right _ -> throwIDE "Illegal cabal"+ Right _ -> unexpected "Illegal cabal" cabalMinimalP :: CharParser () (Either String String) cabalMinimalP =@@ -234,110 +230,110 @@ -- -- ------------------------------------------------------------------------ | Collect infos from sources for a list of packages----collectAllSources :: Session- -> Map PackageIdentifier [FilePath]- -> [PackageDescr]- -> IO ([PackageDescr],Int)-collectAllSources session sourceMap pdescrs =- foldM (\ (pdescrs, failureNum) pdescr -> do- (pdescr, num) <- collectSources session sourceMap pdescr- return (pdescr:pdescrs,failureNum + num))- ([],0) pdescrs---- --------------------------------------------------------------------- -- | Collect infos from sources for one package ---collectSources :: Session- -> Map PackageIdentifier [FilePath]+collectSources :: Map PackageIdentifier [FilePath] -> PackageDescr- -> IO (PackageDescr,Int)-collectSources session sourceMap pdescr = do- putStrLn $ "Now collecting sources for " ++ show (packagePD pdescr)+ -> 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 " ++ showPackageId (packagePD pdescr)+ sysMessage Normal $ "No source for package " ++ display (packagePD pdescr) return (pdescr,0)- Just cabalPath -> C.catch (do- let basePath = takeDirectory cabalPath- dflags0 <- getSessionDynFlags session- setSessionDynFlags session dflags0- { topDir = basePath- , ghcMode = CompManager- }- dflags1 <- getSessionDynFlags session- let flags = ["-fglasgow-exts",("-I" ++ basePath </> "include"),"-haddock"]- (dflags2,_) <- parseDynamicFlags dflags1 flags+ Just cabalPath -> gcatch (do+ setTargets []+ load LoadAllTargets+ basePath <- liftIO $ canonicalizePath (takeDirectory cabalPath)+ pkgDescr <- gcatch (liftIO $ (liftM flattenPackageDescription+ (readPackageDescription silent cabalPath)))+ (\(e :: SomeException) -> return emptyPackageDescription)+ dflags <- getSessionDynFlags+ let flags = [noLoc "-fglasgow-exts", noLoc "-cpp", noLoc ("-I" ++ basePath </> "include"),+ noLoc ("-I" ++ basePath)]+ (dflags2,_,_) <- parseDynamicFlags dflags flags+ let buildPaths = nub $ ("dist" </> "build" </> "autogen") : (".") :+ (concatMap hsSourceDirs $ allBuildInfo pkgDescr)+ let dflags3 = dopt_set dflags2 Opt_Haddock+ let dflags4 = dflags3 {+ topDir = basePath,+ importPaths = buildPaths,+-- hscTarget = HscAsm,+ ghcMode = CompManager,+ ghcLink = NoLink}+ setSessionDynFlags dflags4+ trace ("basePath = " ++ basePath) (return ())+ trace ("buildPaths = " ++ show buildPaths) (return ()) - setSessionDynFlags session dflags2+ defaultCleanupHandler dflags (do+ let exposedMods = map (display . modu . moduleIdMD) $ exposedModulesPD pdescr+ sourceFiles <- liftIO $ mapM (findSourceFile+ (map (\p -> basePath </> p) buildPaths)+ ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp"])+ $ map (modu . moduleIdMD) (exposedModulesPD pdescr) - genPkgDescr <- readPackageDescription silent cabalPath- let pkgDescr = flattenPackageDescription genPkgDescr- localBuildInfo <- configure (Left genPkgDescr, emptyHookedBuildInfo)- (emptyConfigFlags defaultProgramConfiguration)- --let allModules = libModules pd ++ exeModules pd- let exposedMods = exposedModulesPD pdescr- let buildPaths = nub $ ("dist" </> "build" </> "autogen") :- (concatMap hsSourceDirs $ allBuildInfo pkgDescr)- let basePath = normalise $ (takeDirectory cabalPath)- sourceFiles <- mapM (findSourceFile- (map (\p -> basePath </> p) buildPaths)- ["hs","lhs"])- (map (modu . moduleIdMD) exposedMods)- (newModDescrs,failureCount)- <- foldM (collectSourcesForModule session genPkgDescr- localBuildInfo) ([],0)- (zip (exposedModulesPD pdescr) sourceFiles)- let nPackDescr = pdescr{mbSourcePathPD = Just cabalPath,- exposedModulesPD = newModDescrs}- return (nPackDescr,failureCount))- (\e -> do sysMessage Normal $ "source collector throwIDE " ++ show e ++ " in " ++- showPackageId (packagePD pdescr)- return (pdescr,length $ exposedModulesPD pdescr))+ liftIO $ mapM_ (\(mbSf, mn) ->+ case mbSf of+ Nothing -> putStrLn $ "Cant find source file for " ++ mn+ Just _ -> return ()) $ zip sourceFiles exposedMods+ (newModDescrs,failureCount) <- collectSourcesForPackage pdescr (catMaybes 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 :: Session- -> GenericPackageDescription- -> LocalBuildInfo- -> ([ModuleDescr],Int)- -> (ModuleDescr, Maybe FilePath)- -> IO ([ModuleDescr],Int)-collectSourcesForModule session pkgDescr localBuildInfo (moduleDescrs,failureCount)- (moduleDescr,mbfp) =- case mbfp of- Nothing -> do- sysMessage Normal $ "No source for module " ++ (modu $ moduleIdMD moduleDescr)- return(moduleDescr : moduleDescrs, failureCount+1)- Just fp -> do- str <- preprocess fp pkgDescr localBuildInfo- stringBuffer <- stringToStringBuffer str- dynFlags <- getSessionDynFlags session- 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)++--------------------------++collectSourcesForPackage :: PackageDescr -> [String] -> Ghc ([ModuleDescr],Int)+collectSourcesForPackage pkgDescr modules = do+ targets <- mapM (\f -> guessTarget f Nothing) modules+ setTargets targets+ modgraph <- depanal [] False+ let orderedMods = flattenSCCs $ topSortModuleGraph False modgraph Nothing+-- let interestingMods = filter (\m -> elem (moduleNameString (ms_mod_name m)) modules) orderedMods+ let orderedTupels = catMaybes (map (\om -> case filter (\m -> ((moduleNameString . moduleName . ms_mod) om) ==+ (display . modu . moduleIdMD) m)+ (exposedModulesPD pkgDescr) of+ [] -> trace ("Cant find module source " ++ (moduleNameString . moduleName . ms_mod) om) $ Nothing+ (x:_) -> (Just (x,om))) orderedMods)+-- trace ("ordered tupels " ++ (show . length) orderedTupels) $ return ()+ foldM collectSourcesForModule ([],0) orderedTupels++collectSourcesForModule :: ([ModuleDescr],Int) -> (ModuleDescr, ModSummary) -> Ghc ([ModuleDescr],Int)+collectSourcesForModule (moduleDescrs,failureCount) (modD,modsum) = gcatch (do+ let filename = msHsFilePath modsum+ let dynflags = ms_hspp_opts modsum+ parsedMod <- parseModule modsum+ let decls = (hsmodDecls . unLoc . parsedSource) $ parsedMod+ let map' = convertToMap (idDescriptionsMD modD)+ let commentedDecls = addComments (filterSignatures decls)+ let (descrs,restMap) = foldl' collectParseInfoForDecl ([],map') commentedDecls+ let newMod = modD{+ idDescriptionsMD = reverse descrs ++ concat (Map.elems restMap),+ mbSourcePathMD = Just filename}+ return(newMod : moduleDescrs, failureCount))+ (\(e :: SomeException) -> do+ sysMessage Normal $ "source collector throwIDE2 " ++ show e ++ " in " +++ msHsFilePath modsum+ return (modD : moduleDescrs, failureCount + 1)) where- convertToMap :: [IdentifierDescr] -> Map Symbol [IdentifierDescr]- convertToMap list =- foldl (\ st idDescr -> Map.insertWith (++) (identifierID idDescr) [idDescr] st)- Map.empty list- convertFromMap :: Map Symbol [IdentifierDescr] -> [IdentifierDescr]- convertFromMap = concat . Map.elems+ 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@@ -345,7 +341,7 @@ filterSignature _ = True addComments :: [LHsDecl RdrName] -> [(Maybe (LHsDecl RdrName), Maybe String)]-addComments declList = reverse $ snd $ foldl addComment (Nothing,[]) declList+addComments = reverse . snd . foldl' addComment (Nothing,[]) where addComment :: (Maybe String,[(Maybe (LHsDecl RdrName),Maybe String)]) -> LHsDecl RdrName@@ -360,17 +356,15 @@ (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)+ addComment (Nothing,resultList) decl = (Nothing,(Just decl,Nothing):resultList)+ addComment (Just comment,resultList) decl = (Nothing,(Just decl,Just comment):resultList) -collectParseInfoForDecl :: ([IdentifierDescr],SymbolTable)+collectParseInfoForDecl :: ([Descr],SymbolTable) -> (Maybe (LHsDecl RdrName),Maybe String)- -> ([IdentifierDescr],SymbolTable)+ -> ([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' [Function] []+ = 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')@@ -401,18 +395,18 @@ 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)+ = {--trace (declTypeToString (unLoc decl) ++ "--" ++ (showSDocUnqual $ppr decl))--} (l,st) collectParseInfoForDecl (l,st) (Nothing, mbComment') =- trace ("Found comment " ++ show mbComment') (l,st)+ {--trace ("Found comment " ++ show mbComment')--} (l,st) -addLocationAndComment :: ([IdentifierDescr],SymbolTable)+addLocationAndComment :: ([Descr],SymbolTable) -> RdrName -> SrcSpan -> Maybe String- -> [IdType]+ -> [DescrType] -> [String]- -> ([IdentifierDescr],SymbolTable)+ -> ([Descr],SymbolTable) addLocationAndComment (l,st) lid srcSpan mbComment' types insts = let occ = rdrNameOcc lid name = unpackFS (occNameFS occ)@@ -427,21 +421,21 @@ Map.adjust (\li -> delete (head l') li) name st) in case mbItem of- Nothing -> (l,st)- Just identDescr -> (identDescr{- mbLocation = Just (srcSpanToLocation srcSpan),- mbComment = case mbComment' 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 :: IdentifierDescr -> [IdType] -> [String] -> Bool+ matches :: Descr -> [DescrType] -> [String] -> Bool matches idDescr idTypes inst =- case idType idDescr of+ case descrType (details idDescr) of Instance -> --trace ("instances " ++ show (sort (binds idDescr)) ++ " -- ?= -- " ++ show (sort inst)) $- elem Instance idTypes && sort (binds idDescr) == sort inst+ elem Instance idTypes && sort (binds (details idDescr)) == sort inst other -> elem other idTypes declTypeToString :: Show alpha => HsDecl alpha -> String@@ -452,12 +446,11 @@ declTypeToString (SigD _) = "SigD" declTypeToString (DefD _) = "DefD" declTypeToString (ForD _) = "ForD"-declTypeToString (DeprecD _)= "DeprecD"+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"@@ -493,89 +486,4 @@ show (DocCommentPrev doc) = "DocCommentPrev " ++ show doc show (DocCommentNamed str doc) = "DocCommentNamed" ++ " " ++ str ++ " " ++ show doc show (DocGroup i doc) = "DocGroup" ++ " " ++ show i ++ " " ++ show doc----instance Show alpha => Show (HsDoc alpha) where--- show d = printHsDoc d--- ------------------------------------------------------------------------ | Simple preprocessing--preprocess :: FilePath -> GenericPackageDescription -> LocalBuildInfo -> IO String-preprocess fp pkgDescr localBuildInfo =- let aBuildInfo = head (allBuildInfo (flattenPackageDescription pkgDescr))- needCpp = elem "-cpp" (hcOptions GHC (options aBuildInfo))- in C.catch (do- str' <- if True- then do- tempFileName <- getConfigFilePathForSave "Temp.hspp"- isItTheir <- doesFileExist tempFileName- when isItTheir $- removeFile tempFileName--- (_, conf') <- requireProgram normal ghcProgram--- (orLaterVersion (Version [6,2] []))--- defaultProgramConfiguration---- localBuildInfo' <- localBuildInfo pkgDescr conf'-- runSimplePreProcessor (ppCpp aBuildInfo localBuildInfo)- fp tempFileName normal- isItTheir <- doesFileExist tempFileName- if isItTheir- then do- str <- readFile tempFileName- return str- else do- sysMessage Normal $ "Failed to preprocess " ++ fp- str <- readFile fp- return str- else do- str <- readFile fp- return str- let str2 = if takeExtension fp == ".lhs"- then unlit fp str'- else str'- return str2)- (\e -> do sysMessage Normal $ "preprocess throwIDE " ++ show e ++ " in " ++ fp- str <- readFile fp- return str)-- ------------------------------------------------------------------------ | 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 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.- }}-
− src/IDE/ModulesPane.hs
@@ -1,792 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.ModulesPane--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | The pane of ide where modules are presented in tree form with their--- packages and exports-------------------------------------------------------------------------------------module IDE.ModulesPane (- showModules-, selectIdentifier-, reloadKeepSelection-) where--import Graphics.UI.Gtk hiding (get)-import Graphics.UI.Gtk.ModelView as New-import Data.Maybe-import Control.Monad.Reader-import qualified Data.Map as Map-import Data.Tree-import Data.List-import Distribution.Package-import Distribution.Version-import Data.Char (toLower)---import IDE.Core.State-import IDE.Framework.ViewFrame-import IDE.InfoPane-import IDE.SourceEditor--instance IDEObject IDEModules--instance Pane IDEModules- where- primPaneName _ = "Modules"- getAddedIndex _ = 0- getTopWidget = castToWidget . outer- paneId b = "*Modules"- makeActive p = activatePane p (BufConnections[][] [])- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- lift $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> throwIDE "Pane>IDEModules: notebook page not found: unexpected"- Just i -> do- deactivatePaneIfActive pane- lift $notebookRemovePage nb i- removePaneAdmin pane--instance RecoverablePane IDEModules ModulesState where- saveState p = do- (IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules- sc <- getScope- mbModules <- getPane ModulesCasting- case mbModules of- Nothing -> return Nothing- Just p -> lift $ 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 (StateC (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 -> lift $ toggleButtonSetActive lb True- Package -> lift $ toggleButtonSetActive pb True- World -> lift $ toggleButtonSetActive wb True- lift $ toggleButtonSetActive blb useBlacklist- lift $ panedSetPosition (paned mod) i- fillModulesList sc- selectNames se--selectIdentifier :: IdentifierDescr -> IDEAction-selectIdentifier idDescr = selectIdentifier' (modu $ moduleIdID idDescr) (identifierID idDescr)---selectIdentifier' :: ModuleIdentifier -> Symbol -> IDEAction-selectIdentifier' moduleName symbol =- let nameArray = breakAtDots [] moduleName- in do- mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _) <- getModules- tree <- lift $ New.treeStoreGetTree treeStore []- case treePathFromNameArray tree nameArray [] of- Just treePath -> lift $ do- New.treeViewExpandToPath treeView treePath- sel <- New.treeViewGetSelection treeView- New.treeSelectionSelectPath sel treePath- col <- New.treeViewGetColumn treeView 0- New.treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3))- facetTree <- New.treeStoreGetTree facetStore []- selF <- New.treeViewGetSelection facetView- case findPathFor symbol facetTree of- Nothing -> sysMessage Normal "no path found"- Just path -> do- New.treeSelectionSelectPath selF path- col <- New.treeViewGetColumn facetView 0- New.treeViewScrollToCell facetView path (fromJust col) (Just (0.3,0.3))- bringPaneToFront mods- Nothing -> return ()--findPathFor :: Symbol -> Tree FacetWrapper -> Maybe TreePath-findPathFor symbol (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)]----treePathFromNameArray :: ModTree -> [String] -> [Int] -> Maybe [Int]-treePathFromNameArray tree [] accu = Just (reverse accu)-treePathFromNameArray 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 (subForest tree !! i) t (i:accu)--showModules :: IDEAction-showModules = do- sc <- getScope- fillModulesList sc- m <- getModules- lift $ bringPaneToFront m--getModules :: IDEM IDEModules-getModules = do- mbMod <- getPane ModulesCasting- case mbMod of- Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (modulesPanePath prefs) layout- nb <- getNotebook pp- initModules pp nb- mbMod <- getPane ModulesCasting- case mbMod of- Nothing -> throwIDE "Can't init modules"- Just m -> return m- Just m -> return m--initModules :: PanePath -> Notebook -> IDEAction-initModules panePath nb = do- ideR <- ask- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- currentInfo <- readIDE currentInfo- (buf,cids) <- lift $ do---- Modules List-- let forest = case currentInfo of- Nothing -> []- Just pair -> subForest (buildModulesTree pair)- treeStore <- New.treeStoreNew forest- treeView <- New.treeViewNew- New.treeViewSetModel treeView treeStore- New.treeViewSetEnableSearch treeView True- New.treeViewSetSearchColumn treeView 0- New.treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore)-- --New.treeViewSetRulesHint treeView True-- renderer0 <- New.cellRendererPixbufNew- set renderer0 [ cellPixbufStockId := "ide_no_source" ]-- renderer <- New.cellRendererTextNew- col <- New.treeViewColumnNew- New.treeViewColumnSetTitle col "Modules"- New.treeViewColumnSetSizing col TreeViewColumnAutosize- New.treeViewColumnSetReorderable col True- New.treeViewAppendColumn treeView col- New.cellLayoutPackStart col renderer0 False- New.cellLayoutPackStart col renderer True- New.cellLayoutSetAttributes col renderer treeStore- $ \row -> [ New.cellText := fst row]- New.cellLayoutSetAttributes col renderer0 treeStore- $ \row -> [- cellPixbufStockId :=- if null (snd row)- then ""- else if isJust (mbSourcePathMD (fst (head (snd row))))- then "ide_source"- else "ide_no_source"]-- renderer2 <- New.cellRendererTextNew- col2 <- New.treeViewColumnNew- New.treeViewColumnSetTitle col2 "Packages"- New.treeViewColumnSetSizing col2 TreeViewColumnAutosize- New.treeViewColumnSetReorderable col2 True- New.treeViewAppendColumn treeView col2- New.cellLayoutPackStart col2 renderer2 True- New.cellLayoutSetAttributes col2 renderer2 treeStore- $ \row -> [ New.cellText :=- concat- $ intersperse ", "- $ map (showPackageId . packagePD . snd) (snd row)]---- Facet view-- facetView <- New.treeViewNew- facetStore <- New.treeStoreNew []- New.treeViewSetModel facetView facetStore- New.treeViewSetEnableSearch facetView True--- New.treeViewSetSearchColumn facetView 0--- New.treeViewSetSearchEqualFunc facetView--- (\ _ string iter -> do--- [ind] <- New.treeModelGetPath facetStore iter--- val <- New.listStoreGetValue facetStore ind--- return (isInfixOf (map toLower string) (map toLower (fst val))))-- renderer30 <- New.cellRendererPixbufNew- renderer31 <- New.cellRendererPixbufNew- renderer3 <- New.cellRendererTextNew- col <- New.treeViewColumnNew- New.treeViewColumnSetTitle col "Interface"- --New.treeViewColumnSetSizing col TreeViewColumnAutosize- New.treeViewAppendColumn facetView col- New.cellLayoutPackStart col renderer30 False- New.cellLayoutPackStart col renderer31 False- New.cellLayoutPackStart col renderer3 True- New.cellLayoutSetAttributes col renderer3 facetStore- $ \row -> [ New.cellText := facetTreeText row]- New.cellLayoutSetAttributes col renderer30 facetStore- $ \row -> [- cellPixbufStockId := stockIdFromType (facetIdType row)]- New.cellLayoutSetAttributes col renderer31 facetStore- $ \row -> [- cellPixbufStockId := if isJust (mbLocation(facetIdDescr row))- then "ide_source"- else ""]- New.treeViewSetHeadersVisible treeView True-- 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"- 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 modules = IDEModules boxOuter pane' treeView treeStore facetView facetStore- rb1 rb2 rb3 cb- notebookInsertOrdered nb boxOuter (paneName modules)- widgetShowAll boxOuter- cid0 <- treeView `New.onStartInteractiveSearch`- (New.treeViewExpandAll treeView)- cid3 <- treeView `New.onRowActivated`- (\ treePath _ -> do- New.treeViewExpandRow treeView treePath False- return ())- cid1 <- treeView `afterFocusIn`- (\_ -> do runReaderT (makeActive modules) ideR; return True)- cid2 <- facetView `afterFocusIn`- (\_ -> do runReaderT (makeActive modules) 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 <- New.treeViewGetSelection treeView- sel `New.onSelectionChanged` (fillFacets treeView treeStore facetStore)- sel2 <- New.treeViewGetSelection facetView- sel2 `New.onSelectionChanged` (fillInfo facetView facetStore ideR)-- return (modules,[cid1,cid2])- addPaneAdmin buf (BufConnections [] [] []) panePath- lift $widgetGrabFocus (paned buf)--stockIdFromType :: IdType -> StockId-stockIdFromType Function = "ide_function"-stockIdFromType Newtype = "ide_newtype"-stockIdFromType Type = "ide_type"-stockIdFromType AbstractData = "ide_data"-stockIdFromType OpenData = "ide_data"-stockIdFromType Foreign = "ide_other"-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 OrphanedInstance = "ide_instance"--treeViewSearch :: TreeView- -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])- -> Int- -> String- -> TreeIter- -> IO Bool-treeViewSearch treeView treeStore _ string iter = do- path <- New.treeModelGetPath treeStore iter- val <- New.treeStoreGetValue treeStore path- tree <- New.treeStoreGetTree treeStore path- exp <- New.treeViewRowExpanded treeView path- when (not (null (subForest tree)) && not exp) $- let found = searchInSubnodes tree string- in when found $ do- New.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))--searchInSubnodes :: ModTree -> String -> Bool-searchInSubnodes 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)--fillFacets :: New.TreeView- -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])- -> New.TreeStore FacetWrapper- -> IO ()-fillFacets treeView tst treeStore = do- sel <- getSelectionTree treeView tst- case sel of- Just val- -> case snd val of- ((mod,package):_)- -> let forest = buildFacetForrest mod in do- New.treeStoreClear treeStore- mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e)- $ zip forest [0 .. length forest]- [] -> return ()- Nothing- -> New.treeStoreClear treeStore---getSelectionTree :: New.TreeView- -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])- -> IO (Maybe (String, [(ModuleDescr,PackageDescr)]))-getSelectionTree treeView treeStore = do- treeSelection <- New.treeViewGetSelection treeView- paths <- New.treeSelectionGetSelectedRows treeSelection- case paths of- [] -> return Nothing- a:r -> do- val <- New.treeStoreGetValue treeStore a- return (Just val)--getSelectionFacet :: New.TreeView- -> New.TreeStore FacetWrapper- -> IO (Maybe FacetWrapper)-getSelectionFacet treeView treeStore = do- treeSelection <- New.treeViewGetSelection treeView- paths <- New.treeSelectionGetSelectedRows treeSelection- case paths of- a:r -> do- val <- New.treeStoreGetValue treeStore a- return (Just val)- _ -> return Nothing---fillInfo :: New.TreeView- -> New.TreeStore FacetWrapper- -> IDERef- -> IO ()-fillInfo treeView lst ideR = do- treeSelection <- New.treeViewGetSelection treeView- paths <- New.treeSelectionGetSelectedRows treeSelection- case paths of- [] -> return ()- [a] -> do- wrapper <- New.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 lift $ do- New.treeStoreClear treeStore- mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e)- $ zip li [0 .. length li]- New.treeViewExpandAll treeView- _ -> lift $ do- New.treeStoreClear treeStore- New.treeStoreInsertTree treeStore [] 0 (Node ("",[]) [])- New.treeViewExpandAll treeView- 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 lift $ do- emptyModel <- New.treeStoreNew []- New.treeViewSetModel treeView emptyModel- New.treeStoreClear treeStore- mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e)- $ zip li [0 .. length li]- New.treeViewSetModel treeView treeStore- New.treeViewExpandAll treeView- 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--buildFacetForrest :: ModuleDescr -> FacetForest-buildFacetForrest 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)---type ModTree = Tree (String, [(ModuleDescr,PackageDescr)])------ | 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))- (Map.elems localMap ++ Map.elems otherMap)- emptyTree = (Node ("",[]) [])- resultTree = foldl insertPairsInTree emptyTree flatPairs- in sortTree resultTree- where- insertPairsInTree :: ModTree -> (ModuleDescr,PackageDescr) -> ModTree- insertPairsInTree tree pair =- let nameArray = breakAtDots [] $ modu $ moduleIdMD $ fst pair- pairedWith = map (\n -> (n,pair)) nameArray- in insertNodesInTree pairedWith tree-- insertNodesInTree :: [(String,(ModuleDescr,PackageDescr))] -> ModTree -> ModTree- insertNodesInTree list@[(str2,pair)] (Node (str1,pairs) forest) =- case partition (\ (Node (s,_) _) -> s == str2) forest of- ([],_) -> (Node (str1,pairs) (makeNodes list : forest))- ([(Node (_,pairsf) l)],rest)- -> (Node (str1,pairs) ((Node (str2,pair : pairsf) l) : rest))- (_,_) -> throwIDE "insertNodesInTree: impossible1"- insertNodesInTree list@((str2,pair):tl) (Node (str1,pairs) forest) =- case partition (\ (Node (s,_) _) -> s == str2) forest of- ([],_) -> (Node (str1,pairs) (makeNodes list : forest))- ([found],rest) -> (Node (str1,pairs) (insertNodesInTree tl found : rest))- (_,_) -> throwIDE "insertNodesInTree: impossible2"- insertNodesInTree [] t = t-- makeNodes :: [(String,(ModuleDescr,PackageDescr))] -> ModTree- makeNodes [(str,pair)] = Node (str,[pair]) []- makeNodes ((str,_):tl) = Node (str,[]) [makeNodes tl]- makeNodes _ = throwIDE "Impossible in makeNodes"--breakAtDots :: [String] -> String -> [String]-breakAtDots res [] = reverse res-breakAtDots res toBreak = let (newRes,newToBreak) = span (\c -> c /= '.') toBreak- in if null newToBreak- then reverse (newRes : res)- else breakAtDots (newRes : res) (tail newToBreak)---instance Ord a => Ord (Tree a) where- compare (Node l1 _) (Node l2 _) = compare l1 l2--sortTree :: Ord a => Tree a -> Tree a-sortTree (Node l forest) = Node l (sort (map sortTree forest))--treeViewPopup :: IDERef- -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])- -> New.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` (New.treeViewExpandAll treeView)- item3 <- menuItemNewWithLabel "CollapseAll"- item3 `onActivateLeaf` (New.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- -> New.TreeStore FacetWrapper- -> New.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- 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 <- lift $ toggleButtonGetActive localScopeB- rb2s <- lift $ toggleButtonGetActive packageScopeB- rb3s <- lift $ toggleButtonGetActive worldScopeB- cbs <- lift $ 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 <- lift $ getSelectionTree treeView treeStore- mbFacetSelection <- lift $ getSelectionFacet facetView facetStore-- sc <- getScope- ts <- lift $ New.treeViewGetSelection treeView- lift $ New.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- lift $ 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- tree <- lift $ New.treeStoreGetTree treeStore []- case treePathFromNameArray tree nameArray [] of- Nothing -> return ()- Just treePath -> lift $ do- New.treeViewExpandToPath treeView treePath- sel <- New.treeViewGetSelection treeView- New.treeSelectionSelectPath sel treePath- col <- New.treeViewGetColumn treeView 0- New.treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3))- case mbIdName of- Nothing -> return ()- Just symbol -> do- facetTree <- New.treeStoreGetTree facetStore []- selF <- New.treeViewGetSelection facetView- case findPathFor symbol facetTree of- Nothing -> sysMessage Normal "no path found"- Just path -> do- New.treeSelectionSelectPath selF path- col <- New.treeViewGetColumn facetView 0- New.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 ModulesCasting- case mbMod of- Nothing -> return ()- Just mods@(IDEModules _ _ treeView treeStore facetView facetStore _ _ _ _)- -> do- mbTreeSelection <- lift $ getSelectionTree treeView treeStore- mbFacetSelection <- lift $ getSelectionFacet facetView facetStore- sc <- getScope- fillModulesList sc- lift $ New.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-------
src/IDE/Package.hs view
@@ -1,11 +1,11 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -XScopedTypeVariables #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Package -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL ----- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org> -- Stability : experimental -- Portability : portable --@@ -17,6 +17,7 @@ module IDE.Package ( packageOpen+, packageNew , packageConfig , packageBuild , packageDoc@@ -27,7 +28,7 @@ , previousError , activatePackage , deactivatePackage-, packageFlags+, getActivePackage , packageInstall , packageRegister@@ -35,34 +36,46 @@ , packageTest , packageSdist , packageOpenDoc++, getPackageDescriptionAndPath+, getModuleTemplate+, addModuleToPackageDescr ) where import Graphics.UI.Gtk import Control.Monad.Reader-import Distribution.Package+import Distribution.Package hiding (depends,packageId) import Distribution.PackageDescription+import Distribution.PackageDescription.Parse+import Distribution.PackageDescription.Configuration import Distribution.Verbosity import System.FilePath import Control.Concurrent import System.Directory import System.IO---import System.Process import Prelude hiding (catch) import Text.ParserCombinators.Parsec.Language import qualified Text.ParserCombinators.Parsec.Token as P import Text.ParserCombinators.Parsec hiding(Parser) import Data.Maybe(isJust,fromJust) import Control.Exception hiding (try)-import System.Process -import IDE.Log+import IDE.Pane.Log+import Control.Event import IDE.Core.State-import IDE.PackageEditor-import IDE.SourceEditor-import IDE.PackageFlags-import IDE.Framework.ViewFrame-import IDE.Metainfo.Info+import IDE.Pane.PackageEditor+import IDE.Pane.SourceBuffer+import IDE.Pane.PackageFlags+import IDE.Metainfo.Provider+import Distribution.Text (display)+import IDE.FileUtils (getConfigFilePathForLoad)+import MyMissing (replace)+import Distribution.ModuleName (ModuleName(..))+import Data.List (foldl') +packageNew :: IDEAction+packageNew = packageNew' (\fp -> activatePackage fp >> return ())+ packageOpen :: IDEAction packageOpen = do active <- readIDE activePack@@ -72,6 +85,7 @@ selectActivePackage return () + getActivePackage :: IDEM (Maybe IDEPackage) getActivePackage = do active <- readIDE activePack@@ -79,127 +93,141 @@ Just p -> return (Just p) Nothing -> selectActivePackage +selectActivePackage :: IDEM (Maybe IDEPackage)+selectActivePackage = do+ ideR <- ask+ window <- readIDE window+ mbFilePath <- liftIO $choosePackageFile window+ 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 triggerEvent ideR (LoadSession (ppath </> "IDE.session")) >> getActivePackage+ else activatePackage filePath+ activatePackage :: FilePath -> IDEM (Maybe IDEPackage) activatePackage filePath = do- session <- readIDE session+ ideR <- ask let ppath = dropFileName filePath- lift $setCurrentDirectory ppath- ideR <- ask- mbPackageD <- lift $ catch (do+ liftIO $ setCurrentDirectory ppath+ mbPackageD <- reifyIDE (\ideR session -> catch (do pd <- readPackageDescription normal filePath return (Just (flattenPackageDescription pd)))- (\e -> do- runReaderT (ideMessage Normal ("Can't activate package " ++(show e))) ideR- return Nothing)+ (\(e :: SomeException) -> do+ reflectIDE (ideMessage Normal ("Can't activate package " ++(show e))) ideR session+ return Nothing)) case mbPackageD of Nothing -> return (Nothing) Just packageD -> do let packp = IDEPackage (package packageD) filePath (buildDepends packageD) [] [] [] [] [] [] [] [] pack <- (do- flagFileExists <- lift $doesFileExist (ppath </> "IDE.flags")+ flagFileExists <- liftIO $ doesFileExist (ppath </> "IDE.flags") if flagFileExists- then lift $readFlags (ppath </> "IDE.flags") packp+ then liftIO $ readFlags (ppath </> "IDE.flags") packp else return packp) modifyIDE_ (\ide -> return (ide{activePack = (Just pack)})) ide <- getIDE triggerEvent ideR ActivePack+ triggerEvent ideR (Sensitivity [(SensitivityProjectActive,True)]) sb <- getSBActivePackage- lift $statusbarPop sb 1- lift $statusbarPush sb 1 (showPackageId $packageId pack)+ liftIO $ statusbarPop sb 1+ liftIO $ statusbarPush sb 1 (display $ packageId pack) return (Just pack) deactivatePackage :: IDEAction deactivatePackage = do+ ideR <- ask+ oldActivePack <- readIDE activePack+ when (isJust oldActivePack) $ do+ triggerEvent ideR (SaveSession+ ((dropFileName . cabalFile . fromJust) oldActivePack </> "IDE.session"))+ return () modifyIDE_ (\ide -> return (ide{activePack = Nothing}))- ideR <- ask+ ideR <- ask triggerEvent ideR ActivePack- sb <- getSBActivePackage- lift $statusbarPop sb 1- lift $statusbarPush sb 1 ""+ when (isJust oldActivePack) $ do+ triggerEvent ideR (Sensitivity [(SensitivityProjectActive,False)])+ return ()+ sb <- getSBActivePackage+ liftIO $ statusbarPop sb 1+ liftIO $ statusbarPush sb 1 "" return () -packageFlags :: IDEAction-packageFlags = do- active <- getActivePackage- case active of- Nothing -> return ()- Just p -> do- editFlags- active2 <- getActivePackage- case active2 of- Nothing -> do- ideMessage Normal "no more active package"- return ()- Just p ->- lift $writeFlags ((dropFileName (cabalFile p)) </> "IDE.flags") p--selectActivePackage :: IDEM (Maybe IDEPackage)-selectActivePackage = do- window <- readIDE window- mbFilePath <- lift $choosePackageFile window- case mbFilePath of- Nothing -> return Nothing- Just filePath -> activatePackage filePath-- packageConfig :: IDEAction-packageConfig = do- mbPackage <- getActivePackage- log <- getLog- ideR <- ask- case mbPackage of- Nothing -> return ()- Just package -> do- mbPackageD <- lift $ catch (do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","configure"]- ++ (configFlags package))- oid <- forkIO(readOut log out)- eid <- forkIO (readErr log err)- pd <- readPackageDescription normal (cabalFile package)- return (Just (flattenPackageDescription pd)))- (\e -> do- runReaderT (ideMessage Normal (show e)) ideR- return Nothing)- case mbPackageD of- Just packageD -> do- modifyIDE_ (\ide -> return (ide{activePack =- Just package{depends=buildDepends packageD}}))- triggerEvent ideR ActivePack- return ()- Nothing -> return ()+packageConfig = catchIDE (do+ mbPackage <- getActivePackage+ log <- getLog+ case mbPackage of+ Nothing -> return ()+ Just package -> do+ mbPackageD <- reifyIDE (\ideR session -> catch (do+ (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","configure"]+ ++ (configFlags package))+ oid <- forkIO(readOut log out)+ eid <- forkIO (readErr log err)+ pd <- readPackageDescription normal (cabalFile package)+ return (Just (flattenPackageDescription pd)))+ (\(e :: SomeException) -> do+ reflectIDE (ideMessage Normal (show e)) ideR session+ return Nothing))+ case mbPackageD of+ Just packageD -> do+ modifyIDE_ (\ide -> return (ide{activePack =+ Just package{depends=buildDepends packageD}}))+ ask >>= \ideR -> triggerEvent ideR ActivePack+ return ()+ Nothing -> return ())+ (\(e :: SomeException) -> putStrLn (show e)) packageBuild :: IDEAction-packageBuild = do- mbPackage <- getActivePackage- log <- getLog- ideR <- ask- case mbPackage of- Nothing -> return ()- Just package -> do- sb <- getSBErrors- lift $statusbarPop sb 1- lift $statusbarPush sb 1 "Building"- unmarkCurrentError- pid' <- lift $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","build"]- ++ buildFlags package)- oid <- forkIO (readOut log out)- eid <- forkIO (runReaderT (readErrForBuild log err) ideR)- return pid- mayRebuildInBackground (Just pid')+packageBuild = catchIDE (do+ mbPackage <- getActivePackage+ log <- getLog+ ideR <- ask+ prefs <- readIDE prefs+ case mbPackage of+ Nothing -> return ()+ Just package -> do+ sb <- getSBErrors+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 "Building"+ unmarkCurrentError+ pid' <- reifyIDE (\ideR session -> do+ (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","build"]+ ++ buildFlags package)+ oid <- forkIO (readOut log out)+ hSetBuffering err NoBuffering+ eid <- forkIO (reflectIDE (readErrForBuild log err) ideR session)+ return pid)+ when (collectAfterBuild prefs) $ mayRebuildInBackground (Just pid'))+ (\(e :: SomeException) -> putStrLn (show e)) packageDoc :: IDEAction-packageDoc = do- mbPackage <- getActivePackage- log <- getLog- case mbPackage of- Nothing -> return ()- Just package -> lift $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","haddock"]- ++ (haddockFlags package))- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ()+packageDoc = catchIDE (do+ mbPackage <- getActivePackage+ log <- getLog+ case mbPackage of+ Nothing -> return ()+ Just package -> liftIO $do+ (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","haddock"]+ ++ (haddockFlags package))+ oid <- forkIO (readOut log out)+ eid <- forkIO (readErr log err)+ return ())+ (\(e :: SomeException) -> putStrLn (show e)) packageClean :: IDEAction packageClean = do@@ -207,131 +235,145 @@ log <- getLog case mbPackage of Nothing -> return ()- Just package -> lift $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","clean"]- ++ (haddockFlags package))+ Just package -> liftIO $do+ (inp,out,err,pid) <- runExternal "runhaskell" ["Setup","clean"] oid <- forkIO (readOut log out) eid <- forkIO (readErr log err) return () packageCopy :: IDEAction-packageCopy = do- mbPackage <- getActivePackage- log <- getLog- mbDir <- chooseDir "Select the target directory"- case mbDir of- Nothing -> return ()- Just fp ->- case mbPackage of- Nothing -> return ()- Just package -> lift $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","copy"]- ++ ["--destdir=" ++ fp])- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ()+packageCopy = catchIDE (do+ mbPackage <- getActivePackage+ log <- getLog+ mbDir <- chooseDir "Select the target directory"+ case mbDir of+ Nothing -> return ()+ Just fp ->+ case mbPackage of+ Nothing -> return ()+ Just package -> liftIO $ do+ (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","copy"]+ ++ ["--destdir=" ++ fp])+ oid <- forkIO (readOut log out)+ eid <- forkIO (readErr log err)+ return ())+ (\(e :: SomeException) -> putStrLn (show e)) packageRun :: IDEAction-packageRun = do- mbPackage <- getActivePackage- log <- getLog- case mbPackage of- Nothing -> return ()- Just package -> lift $do- pd <- readPackageDescription normal (cabalFile package) >>= return . flattenPackageDescription- case executables pd of- [(Executable name _ _)] -> do- let path = "dist/build" </> pkgName (packageId package) </> name- (inp,out,err,pid) <- runExternal path (exeFlags package)- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ()- otherwise -> do- sysMessage Normal "no single executable in selected package"- return ()+packageRun = catchIDE (do+ mbPackage <- getActivePackage+ log <- getLog+ case mbPackage of+ Nothing -> return ()+ Just package -> liftIO $do+ pd <- readPackageDescription normal (cabalFile package) >>= return . flattenPackageDescription+ case executables pd of+ [(Executable name _ _)] -> do+ let path = "dist/build" </> name </> name+ (inp,out,err,pid) <- runExternal path (exeFlags package)+ oid <- forkIO (readOut log out)+ eid <- forkIO (readErr log err)+ return ()+ otherwise -> do+ sysMessage Normal "no single executable in selected package"+ return ())+ (\(e :: SomeException) -> putStrLn (show e)) packageInstall :: IDEAction-packageInstall = do- mbPackage <- getActivePackage- log <- getLog- case mbPackage of- Nothing -> return ()- Just package -> lift $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","install"]- ++ (installFlags package))- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ()+packageInstall = catchIDE (do+ mbPackage <- getActivePackage+ log <- getLog+ case mbPackage of+ Nothing -> return ()+ Just package -> liftIO $ do+ (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","install"]+ ++ (installFlags package))+ oid <- forkIO (readOut log out)+ eid <- forkIO (readErr log err)+ return ())+ (\(e :: SomeException) -> putStrLn (show e)) packageRegister :: IDEAction-packageRegister = do- mbPackage <- getActivePackage- log <- getLog- case mbPackage of- Nothing -> return ()- Just package -> lift $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","register"]- ++ (registerFlags package))- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ()+packageRegister = catchIDE (do+ mbPackage <- getActivePackage+ log <- getLog+ case mbPackage of+ Nothing -> return ()+ Just package -> liftIO $do+ (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","register"]+ ++ (registerFlags package))+ oid <- forkIO (readOut log out)+ eid <- forkIO (readErr log err)+ return ())+ (\(e :: SomeException) -> putStrLn (show e)) packageUnregister :: IDEAction-packageUnregister = do+packageUnregister = catchIDE (do mbPackage <- getActivePackage log <- getLog case mbPackage of Nothing -> return ()- Just package -> lift $do+ Just package -> liftIO $do (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","unregister"] ++ (unregisterFlags package)) oid <- forkIO (readOut log out) eid <- forkIO (readErr log err)- return ()+ return ())+ (\(e :: SomeException) -> putStrLn (show e)) packageTest :: IDEAction-packageTest = do- mbPackage <- getActivePackage- log <- getLog- case mbPackage of- Nothing -> return ()- Just package -> lift $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","test"])- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ()+packageTest = catchIDE (do+ mbPackage <- getActivePackage+ log <- getLog+ case mbPackage of+ Nothing -> return ()+ Just package -> liftIO $do+ (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","test"])+ oid <- forkIO (readOut log out)+ eid <- forkIO (readErr log err)+ return ())+ (\(e :: SomeException) -> putStrLn (show e)) packageSdist :: IDEAction-packageSdist = do- mbPackage <- getActivePackage- log <- getLog- case mbPackage of- Nothing -> return ()- Just package -> lift $do- (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","sdist"]- ++ (sdistFlags package))- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ()+packageSdist = catchIDE (do+ mbPackage <- getActivePackage+ log <- getLog+ case mbPackage of+ Nothing -> return ()+ Just package -> liftIO $do+ (inp,out,err,pid) <- runExternal "runhaskell" (["Setup","sdist"]+ ++ (sdistFlags package))+ oid <- forkIO (readOut log out)+ eid <- forkIO (readErr log err)+ return ())+ (\(e :: SomeException) -> putStrLn (show e)) + packageOpenDoc :: IDEAction-packageOpenDoc = do- mbPackage <- getActivePackage- prefs <- readIDE prefs- log <- getLog- case mbPackage of- Nothing -> return ()- Just package -> lift $do- let path = "dist/doc/html" </> pkgName (packageId package) </> "index.html"- (inp,out,err,pid) <- runExternal (browser prefs) [path]- oid <- forkIO (readOut log out)- eid <- forkIO (readErr log err)- return ()+packageOpenDoc = catchIDE (do+ mbPackage <- getActivePackage+ prefs <- readIDE prefs+ log <- getLog+ case mbPackage of+ Nothing -> return ()+ Just package ->+ let path = dropFileName (cabalFile package)+ </> "dist/doc/html"+ </> display (pkgName (packageId package))+ </> display (pkgName (packageId package))+ </> "index.html"+ in liftIO $do+ (inp,out,err,pid) <- runExternal (browser prefs) [path]+ oid <- forkIO (readOut log out)+ eid <- forkIO (readErr log err)+ return ())+ (\(e :: SomeException) -> putStrLn (show e)) + chooseDir :: String -> IDEM (Maybe FilePath) chooseDir str = do win <- readIDE window- lift $do+ liftIO $do dialog <- fileChooserDialogNew (Just $ str) (Just win)@@ -355,52 +397,55 @@ return Nothing _ -> return Nothing + -- --------------------------------------------------------------------- -- | Handling of Compiler errors -- readErrForBuild :: IDELog -> Handle -> IDEAction readErrForBuild log hndl = do- errs <- lift $readAndShow False []+ ideRef <- ask+ errs <- liftIO $readAndShow False [] modifyIDE_ (\ide -> return (ide{errors = reverse errs, currentErr = Nothing}))+ triggerEvent ideRef (Sensitivity [(SensitivityError,not (null errs))]) sb <- getSBErrors let errorNum = length (filter isError errs) let warnNum = length errs - errorNum- lift $statusbarPop sb 1- lift $statusbarPush sb 1 $show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings"+ liftIO $statusbarPop sb 1+ liftIO $statusbarPush sb 1 $show errorNum ++ " Errors, " ++ show warnNum ++ " Warnings" when (not (null errs)) nextError where- readAndShow inError errs = do- isEnd <- hIsEOF hndl- if isEnd- then return errs- else do- line <- hGetLine hndl- let parsed = parse buildLineParser "" line- lineNr <- appendLog log (line ++ "\n") ErrorTag- case (parsed, errs) of- (Left e,_) -> do- sysMessage Normal (show e)- readAndShow False errs- (Right ne@(ErrorLine fp l c str),_) ->- readAndShow True ((ErrorSpec fp l c str (lineNr,lineNr) True):errs)- (Right (OtherLine str1),(ErrorSpec fp i1 i2 str (l1,l2) isError):tl) ->- if inError- then readAndShow True ((ErrorSpec fp i1 i2- (if null str- then line- else str ++ "\n" ++ line)- (l1,lineNr) isError) : tl)- else readAndShow False errs- (Right (WarningLine str1),(ErrorSpec fp i1 i2 str (l1,l2) isError):tl) ->- if inError- then readAndShow True ((ErrorSpec fp i1 i2- (if null str- then line- else str ++ "\n" ++ line)- (l1,lineNr) False) : tl)- else readAndShow False errs- otherwise -> readAndShow False errs+ readAndShow :: Bool -> [ErrorSpec] -> IO [ErrorSpec]+ readAndShow inError errs = catch (do+ line <- hGetLine hndl+ let parsed = parse buildLineParser "" line+ lineNr <- appendLog log (line ++ "\n") ErrorTag+ case (parsed, errs) of+ (Left e,_) -> do+ sysMessage Normal (show e)+ readAndShow False errs+ (Right ne@(ErrorLine fp l c str),_) ->+ readAndShow True ((ErrorSpec fp l c str (lineNr,lineNr) True):errs)+ (Right (OtherLine str1),(ErrorSpec fp i1 i2 str (l1,l2) isError):tl) ->+ if inError+ then readAndShow True ((ErrorSpec fp i1 i2+ (if null str+ then line+ else str ++ "\n" ++ line)+ (l1,lineNr) isError) : tl)+ else readAndShow False errs+ (Right (WarningLine str1),(ErrorSpec fp i1 i2 str (l1,l2) isError):tl) ->+ if inError+ then readAndShow True ((ErrorSpec fp i1 i2+ (if null str+ then line+ else str ++ "\n" ++ line)+ (l1,lineNr) False) : tl)+ else readAndShow False errs+ otherwise -> readAndShow False errs)+ (\ (_ :: SomeException) -> do+ hClose hndl+ return errs) selectErr :: Int -> IDEAction selectErr index = do@@ -410,12 +455,12 @@ else do let thisErr = errors !! index succ <- selectSourceBuf (filePath thisErr)- if succ+ if isJust succ then markErrorInSourceBuf (line thisErr) (column thisErr) (errDescription thisErr) else return () log :: IDELog <- getLog- lift $ markErrorInLog log (logLines thisErr)+ liftIO $ markErrorInLog log (logLines thisErr) unmarkCurrentError :: IDEAction unmarkCurrentError = do@@ -424,13 +469,13 @@ when (isJust currentErr') $ do let theError = errors' !! fromJust currentErr' allBufs <- allBuffers- fpc <- lift $ canonicalizePath $ filePath theError+ fpc <- liftIO $ canonicalizePath $ filePath theError let theBufs = filter (\ buf -> isJust (fileName buf) && equalFilePath fpc (fromJust (fileName buf))) allBufs mapM_ removeMark theBufs where- removeMark buf = lift $ do+ removeMark buf = liftIO $ do gtkbuf <- textViewGetBuffer (sourceView buf) i1 <- textBufferGetStartIter gtkbuf i2 <- textBufferGetEndIter gtkbuf@@ -518,41 +563,66 @@ colon = P.colon lexer integer = P.integer lexer --- Spawning external processes+-- ---------------------------------------------------------------------+-- | * Utility functions/procedures, that have to do with packages+-- -readOut :: IDELog -> Handle -> IO ()-readOut log hndl =- catch (readAndShow)- (\e -> do- --appendLog log ("----------------------------------------\n") FrameTag- hClose hndl- return ())- where- readAndShow = do- line <- hGetLine hndl- appendLog log (line ++ "\n") LogTag- readAndShow+getPackageDescriptionAndPath :: IDEM (Maybe (PackageDescription,FilePath))+getPackageDescriptionAndPath = do+ active <- readIDE activePack+ case active of+ Nothing -> do+ ideMessage Normal "No active packjage"+ return Nothing+ Just p -> do+ ideR <- ask+ reifyIDE (\ideR session -> catch (do+ pd <- readPackageDescription normal (cabalFile p)+ return (Just (flattenPackageDescription pd,cabalFile p)))+ (\(e :: SomeException) -> do+ reflectIDE (ideMessage Normal ("Can't load package " ++(show e))) ideR session+ return Nothing)) -readErr :: IDELog -> Handle -> IO ()-readErr log hndl =- catch (readAndShow)- (\e -> do- hClose hndl- return ())- where- readAndShow = do- line <- hGetLine hndl- appendLog log (line ++ "\n") ErrorTag- readAndShow+getModuleTemplate :: PackageDescription -> String -> IO String+getModuleTemplate pd modName = do+ filePath <- getConfigFilePathForLoad "Module.template"+ template <- 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)]) -runExternal :: FilePath -> [String] -> IO (Handle, Handle, Handle, ProcessHandle)-runExternal path args = do- putStrLn $ "Run external called with args " ++ show args- hndls@(inp, out, err, _) <- runInteractiveProcess path args Nothing Nothing- sysMessage Normal $ "Starting external tool: " ++ path ++ " with args " ++ (show args)- hSetBuffering out NoBuffering- hSetBuffering err NoBuffering- hSetBuffering inp NoBuffering- hSetBinaryMode out True- hSetBinaryMode err True- return hndls+addModuleToPackageDescr :: ModuleName -> Bool -> IDEM ()+addModuleToPackageDescr moduleName isExposed = do+ active <- readIDE activePack+ case active of+ Nothing -> do+ ideMessage Normal "No active packjage"+ return ()+ Just p -> do+ ideR <- ask+ reifyIDE (\ideR session -> catch (do+ gpd <- readPackageDescription normal (cabalFile p)+ if hasConfigs gpd+ then do+ reflectIDE (ideMessage High+ "Cabal File with configurations can't be automatically updated") ideR session+ else+ let pd = flattenPackageDescription gpd+ npd = if isExposed && isJust (library pd)+ then pd{library = Just ((fromJust (library pd)){exposedModules =+ moduleName : exposedModules (fromJust $ library pd)})}+ else let npd1 = case library pd of+ Nothing -> pd+ Just lib -> pd{library = Just (lib{libBuildInfo =+ addModToBuildInfo (libBuildInfo lib) moduleName})}+ in npd1{executables = map+ (\exe -> exe{buildInfo = addModToBuildInfo (buildInfo exe) moduleName})+ (executables npd1)}+ in writePackageDescription (cabalFile p) npd)+ (\(e :: SomeException) -> do+ reflectIDE (ideMessage Normal ("Can't upade package " ++ show e)) ideR session+ return ()))+ where+ addModToBuildInfo :: BuildInfo -> ModuleName -> BuildInfo+ addModToBuildInfo bi mn = bi {otherModules = mn : otherModules bi}
− src/IDE/PackageEditor.hs
@@ -1,368 +0,0 @@------------------------------------------------------------------------------------ Module : IDE.PackageEditor--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | Module for editing of cabal packages------------------------------------------------------------------------------------------module IDE.PackageEditor (- packageNew-, packageEdit-, choosePackageDir-, choosePackageFile-) where--import Graphics.UI.Gtk-import Control.Monad.Reader-import Distribution.Compiler-import Distribution.License-import Distribution.Package-import Distribution.PackageDescription-import Distribution.Version-import Distribution.Verbosity-import System.FilePath-import Data.IORef-import Data.List-import Data.Maybe-import System.Directory--import IDE.Core.State-import IDE.Utils.File-import IDE.SpecialEditors-import IDE.Framework.ViewFrame-import IDE.BuildInfoEditor-import IDE.Framework.MakeEditor-import IDE.Framework.SimpleEditors-import IDE.Framework.CompositeEditors-import IDE.Framework.Parameters--standardSetup = "#!/usr/bin/runhaskell \n"- ++ "> module Main where\n"- ++ "> import Distribution.Simple\n"- ++ "> main :: IO ()\n"- ++ "> main = defaultMain\n\n"--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--choosePackageFile :: Window -> IO (Maybe FilePath)-choosePackageFile window = do- dialog <- fileChooserDialogNew- (Just $ "Select file of project")- (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--packageEdit :: IDEAction-packageEdit = do- window <- readIDE window- mbFileName <- lift $choosePackageFile window- case mbFileName of- Nothing -> return ()- Just fileName -> do- let dirName = dropFileName fileName- modules <- lift $allModules dirName- package <- lift $readPackageDescription normal fileName- editPackage (flattenPackageDescription package) dirName modules- return ()--packageNew :: IDEAction-packageNew = do- window <- readIDE window- mbDirName <- lift $choosePackageDir window- case mbDirName of- Nothing -> return ()- Just dirName -> do- cfn <- lift $cabalFileName dirName- continue <- do- if isJust cfn- then lift $do- md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo- $ "There is already a .cabal file in this directory."- ++ " Continue anyway?"- rid <- dialogRun md- widgetDestroy md- case rid of- ResponseYes -> return True- otherwise -> return False- else return True- when continue $do- modules <- lift $do- b1 <- doesFileExist (dirName </> "Setup.hs")- b2 <- doesFileExist (dirName </> "Setup.lhs")- if not (b1 || b2)- then do- sysMessage Normal "Setup.(l)hs does not exist. Writing Standard"- writeFile (dirName </> "Setup.lhs") standardSetup- else sysMessage Normal "Setup.(l)hs already exist"- allModules dirName- editPackage emptyPackageDescription dirName modules- return ()--type PDescr = [(String,[FieldDescription PackageDescription])]--packageDD :: FilePath -> [String] -> PDescr-packageDD fp modules = [- ("Description -1-", [- mkField- (paraName <<<- ParaName "Package Identifier" $ emptyParams)- package- (\ a b -> b{package = a})- packageEditor- , mkField- (paraName <<<- ParaName "Cabal version"- $ paraSynopsis <<<- ParaSynopsis- "Does this package depends on a specific version of Cabal?"- $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)- descCabalVersion- (\ a b -> b{descCabalVersion = a})- versionRangeEditor- , mkField- (paraName <<<- ParaName "License" $ emptyParams)- license- (\ a b -> b{license = a})- (staticSelectionEditor [GPL, LGPL, BSD3, BSD4, PublicDomain, AllRightsReserved, OtherLicense])- , mkField- (paraName <<<- ParaName "License File" $ emptyParams)- licenseFile- (\ a b -> b{licenseFile = a})- (fileEditor (Just fp) FileChooserActionOpen "Select file")- , mkField- (paraName <<<- ParaName "Copyright" $ emptyParams)- copyright- (\ a b -> b{copyright = a})- stringEditor- , mkField- (paraName <<<- ParaName "Author" $ emptyParams)- author- (\ a b -> b{author = a})- stringEditor- , mkField- (paraName <<<- ParaName "Maintainer" $ emptyParams)- maintainer- (\ a b -> b{maintainer = a})- stringEditor- ]),- ("Description -2-",[- mkField- (paraName <<<- ParaName "Stability" $ emptyParams)- stability- (\ a b -> b{stability = a})- stringEditor- , mkField- (paraName <<<- ParaName "Homepage" $ emptyParams)- homepage- (\ a b -> b{homepage = a})- stringEditor- , mkField- (paraName <<<- ParaName "Package URL" $ emptyParams)- pkgUrl- (\ a b -> b{pkgUrl = a})- stringEditor- , mkField- (paraName <<<- ParaName "Synopsis"- $ paraSynopsis <<<- ParaSynopsis "A one-line summary of this package"- $ emptyParams)- synopsis- (\ a b -> b{synopsis = a})- stringEditor- , mkField- (paraName <<<- ParaName "Description"- $ paraSynopsis <<<- ParaSynopsis "A more verbose description of this package"- $ paraShadow <<<- ParaShadow ShadowOut- $ paraMinSize <<<- ParaMinSize (-1,250)- $ emptyParams)- description- (\ a b -> if null a then b{description = " \n\n\n\n\n"} else b{description = a})- multilineStringEditor- , mkField- (paraName <<<- ParaName "Category" $ emptyParams)- category- (\ a b -> b{category = a})- stringEditor- ]),- ("Tested With",[- mkField- (paraName <<<- ParaName "Tested with compiler"- $ paraShadow <<<- ParaShadow ShadowIn- $ paraDirection <<<- ParaDirection Vertical- $ emptyParams)- (\a -> case testedWith a of- [] -> [(GHC,AnyVersion)]- l -> l)- (\ a b -> b{testedWith = a})- testedWidthEditor- ]),- ("Dependencies",[- mkField- (paraName <<<- ParaName "Build Dependencies"- $ paraSynopsis <<<- ParaSynopsis "Does this package depends on other packages?"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- buildDepends- (\ a b -> b{buildDepends = a})- dependenciesEditor- ]),- ("Other Files",[- mkField- (paraName <<<- ParaName "Data Files"- $ paraSynopsis <<<- ParaSynopsis- "A list of files to be installed for run-time use by the package."- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- dataFiles- (\ a b -> b{dataFiles = a})- (filesEditor (Just fp) FileChooserActionOpen "Select File")- , mkField- (paraName <<<- ParaName "Extra Source Files"- $ paraSynopsis <<<- ParaSynopsis- "A list of additional files to be included in source distributions."- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- extraSrcFiles- (\ a b -> b{extraSrcFiles = a})- (filesEditor (Just fp) FileChooserActionOpen "Select File")- , mkField- (paraName <<<- ParaName "Extra Tmp Files"- $ paraSynopsis <<<- ParaSynopsis- "A list of additional files or directories to be removed by setup clean."- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- extraTmpFiles- (\ a b -> b{extraTmpFiles = a})- (filesEditor (Just fp) FileChooserActionOpen "Select File")- ]),- ("Library",[- mkField- (paraName <<<- ParaName "Library"- $ paraSynopsis <<<- ParaSynopsis- "If the package contains a library, specify the exported modules here"- $ paraDirection <<<- ParaDirection Vertical- $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)- library- (\ a b -> b{library = a})- (maybeEditor (libraryEditor BuildEditorFactoryI (Just fp) modules,- paraName <<<- ParaName "Specify exported modules" $ emptyParams) True- "Does this package contain a library?")- ]),- ("Executables",[- mkField- (paraName <<<- ParaName "Executables"- $ paraSynopsis <<<- ParaSynopsis- "Describe executable programs contained in the package"- $ paraDirection <<<- ParaDirection Vertical $ emptyParams)- executables- (\ a b -> b{executables = a})- (executablesEditor BuildEditorFactoryI (Just fp) modules)- ])]---editPackage :: PackageDescription -> FilePath -> [String] -> IDEAction-editPackage packageD packageDir modules = do- ideR <- ask- lift $editPackage' packageDir packageD (packageDD packageDir modules) ideR--- ideMessage Normal $show res--editPackage' :: String -> PackageDescription -> PDescr -> IDERef -> IO ()-editPackage' packageDir packageD packageDD ideR =- let flatPackageDesc = concatMap snd packageDD- in do- lastAppliedPackageRef <- newIORef packageD- dialog <- windowNew- vb <- vBoxNew False 7- bb <- hButtonBoxNew- restore <- buttonNewFromStock "Restore"- ok <- buttonNewFromStock "gtk-ok"- cancel <- buttonNewFromStock "gtk-cancel"- boxPackStart bb restore PackNatural 0- boxPackStart bb ok PackNatural 0- boxPackStart bb cancel PackNatural 0- nb <- newNotebook- notebookSetTabPos nb PosTop- res <- mapM- (\ (tabLabel, partPackageDesc) -> do- resList <- mapM (\ (FD _ editorF) -> editorF packageD) partPackageDesc- let (widgetsP, setInjsP, getExtsP, notifiersP) = unzip4 resList- nbbox <- vBoxNew False 0- mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP- sw <- scrolledWindowNew Nothing Nothing- scrolledWindowAddWithViewport sw nbbox- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- notebookAppendPage nb sw tabLabel- return (widgetsP, setInjsP, getExtsP, notifiersP))- packageDD- let (widgets, setInjs, getExts, notifiers) =- foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res- let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of- Just s -> s- Nothing -> "Unnamed")- $concat- $map snd packageDD- ok `onClicked` (do- mbNewPackage <- extractAndValidate packageD getExts fieldNames- case mbNewPackage of- Nothing -> return ()- Just newPackage -> do- lastAppliedPackage <- readIORef lastAppliedPackageRef- let PackageIdentifier n v = package newPackage- writePackageDescription (packageDir ++ "/" ++ n ++ ".cabal") newPackage- widgetDestroy dialog- mainQuit)- cancel `onClicked` (do- widgetDestroy dialog- mainQuit)- dialog `onDelete` (\e -> do- widgetDestroy dialog- mainQuit- return True)- boxPackStart vb nb PackGrow 7- boxPackEnd vb bb PackNatural 7- containerAdd dialog vb- widgetSetSizeRequest dialog 500 700- widgetShowAll dialog- mainGUI- return ()-
− src/IDE/PackageFlags.hs
@@ -1,209 +0,0 @@------------------------------------------------------------------------------------ Module : IDE.PackageFlags--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable--------- | Module for saving, restoring and editing projectFlags----------------------------------------------------------------------------------------module IDE.PackageFlags (- readFlags-, writeFlags-, editFlags-) 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 IDE.Core.State-import IDE.Framework.MakeEditor hiding (fieldEditor, parameters)-import IDE.Framework.SimpleEditors-import IDE.Framework.Parameters--import IDE.PrinterParser hiding (fieldParser, parameters)-import IDE.Framework.ViewFrame-import IDE.DescriptionPP--concatString :: [String] -> String-concatString l = foldl (\r s -> if null r then s else r ++ " " ++ s) "" l--flagsDescription :: [(String,[FieldDescriptionPP IDEPackage])]-flagsDescription = [- ("Flags", [- mkFieldPP- (paraName <<<- ParaName "Config flags" $ emptyParams)- (PP.text . show)- stringParser- (\p -> concatString (configFlags p))- (\ b a -> a{configFlags = if null b then [] else [b]})- stringEditor- (\ _ -> 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]})- stringEditor- (\ _ -> 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]})- stringEditor- (\ _ -> 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]})- stringEditor- (\ _ -> 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]})- stringEditor- (\ _ -> 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]})- stringEditor- (\ _ -> 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]})- stringEditor- (\ _ -> 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]})- stringEditor- (\ _ -> return ())- ])]---- --------------------------------------------------------------- * Parsing--- --------------------------------------------------------------readFlags :: FilePath -> IDEPackage -> IO IDEPackage-readFlags fn pack = do- res <- P.parseFromFile (flagsParser pack (concatMap snd flagsDescription)) 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"---- --------------------------------------------------------------- * Printing--- --------------------------------------------------------------writeFlags :: FilePath -> IDEPackage -> IO ()-writeFlags fpath flags =- writeFile fpath (showFlags flags (concatMap snd flagsDescription))--showFlags :: a -> [FieldDescriptionPP a] -> String-showFlags flags flagsDesc = PP.render $- foldl (\ doc (FDPP _ printer _ _ _ ) -> doc PP.$+$ printer flags) PP.empty flagsDesc---- --------------------------------------------------------------- * Editing--- --------------------------------------------------------------editFlags :: IDEAction-editFlags = do- ideR <- ask- mbP <- readIDE activePack- case mbP of- Nothing -> return ()- Just p -> lift $editFlags' p flagsDescription ideR---editFlags' :: IDEPackage -> [(String,[FieldDescriptionPP IDEPackage])] -> IDERef -> IO ()-editFlags' flags flagsDesc ideR = do- let flatflagsDesc = concatMap snd flagsDesc- dialog <- windowNew- vb <- vBoxNew False 0- bb <- hButtonBoxNew- ok <- buttonNewFromStock "gtk-ok"- cancel <- buttonNewFromStock "gtk-cancel"- boxPackStart bb ok PackNatural 0- boxPackStart bb cancel PackNatural 0- nb <- newNotebook- notebookSetTabPos nb PosTop- res <- mapM- (\ (tabLabel, partflagsDesc) -> do- resList <- mapM (\ fd -> (fieldEditor fd) flags) partflagsDesc- let (widgetsP, setInjsP, getExtsP,notifiersP) = unzip4 resList- nbbox <- vBoxNew False 0- mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP- sw <- scrolledWindowNew Nothing Nothing- scrolledWindowAddWithViewport sw nbbox- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- notebookAppendPage nb sw tabLabel- return (widgetsP, setInjsP, getExtsP, notifiersP))- flagsDesc- let (widgets, setInjs, getExts, notifiers) =- foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res- let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of- Just s -> s- Nothing -> "Unnamed") flatflagsDesc- ok `onClicked` (do- mbPackWithNewFlags <- extractAndValidate flags getExts fieldNames- case mbPackWithNewFlags of- Nothing -> return ()- Just packWithNewFlags -> do- runReaderT (modifyIDE_ (\ide -> return (ide{activePack = Just packWithNewFlags})))- ideR -- we don't trigger the activePack event here- widgetDestroy dialog- mainQuit)- cancel `onClicked` (do- widgetDestroy dialog- mainQuit)- boxPackStart vb nb PackGrow 7- boxPackEnd vb bb PackNatural 7- containerAdd dialog vb- widgetSetSizeRequest dialog 500 700- widgetShowAll dialog- mainGUI- return ()-------
+ src/IDE/Pane/Callers.hs view
@@ -0,0 +1,288 @@+{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.Callers+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | The pane of ide where modules are presented in tree form with their+-- packages and exports+--+-------------------------------------------------------------------------------++module IDE.Pane.Callers (+ IDECallers(..)+, CallersState+, calledBy+, showCallers+) where++import Graphics.UI.Gtk hiding (get)+import Graphics.UI.Gtk.ModelView as New+import IDE.Find (focusFindEntry,showFindbar,setFindState,entryStr, getFindState, editFind)+import IDE.Pane.SourceBuffer (selectSourceBuf)+import Graphics.UI.Gtk.Gdk.Events+import Data.IORef (newIORef,writeIORef,readIORef,IORef(..))+import Data.Maybe+import Control.Monad.Reader+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.List+import Data.Typeable+import Distribution.ModuleName(ModuleName)+import Distribution.Text+import Text.PrettyPrint (render)++import IDE.Core.State+++-- | A callers pane description+--++data IDECallers = IDECallers {+ scrolledView :: ScrolledWindow+, treeViewC :: New.TreeView+, callersDescr :: IORef (Maybe Descr)+, callersStore :: New.ListStore (ModuleDescr,Symbol)+, callersEntry :: Entry+, topBox :: VBox+} deriving Typeable++data CallersState = CallersState (Maybe Descr)+ deriving(Eq,Ord,Read,Show,Typeable)+++instance IDEObject IDECallers++instance Pane IDECallers IDEM+ where+ primPaneName _ = "Usage"+ getAddedIndex _ = 0+ getTopWidget = castToWidget . topBox+ paneId b = "*Usage"+ makeActive p = activatePane p []+ close pane = do+ (panePath,_) <- guiPropertiesFromName (paneName pane)+ nb <- getNotebook panePath+ mbI <- liftIO $notebookPageNum nb (getTopWidget pane)+ case mbI of+ Nothing -> liftIO $ do+ sysMessage Normal "notebook page not found: unexpected"+ return ()+ Just i -> do+ deactivatePaneIfActive pane+ liftIO $ do+ notebookRemovePage nb i+ widgetDestroy (getTopWidget pane)+ removePaneAdmin pane++-- | We don't recover this pane+instance RecoverablePane IDECallers CallersState IDEM where+ saveState p = do+ mbDescr <- liftIO $ readIORef (callersDescr p)+ return (Just (CallersState mbDescr))+ recoverState pp (CallersState mbDescr) = do+ nb <- getNotebook pp+ initCallers pp nb+ when (isJust mbDescr) (calledBy (fromJust mbDescr))++showCallers :: IDEAction+showCallers = do+ m <- getCallers+ liftIO $ bringPaneToFront m+ liftIO $ widgetGrabFocus (treeViewC m)+++-- | Open a pane with the callers of this identifier+calledBy :: Descr -> IDEAction+calledBy idDescr = do+ mbCurrentInfo <- readIDE currentInfo+ case mbCurrentInfo of+ Nothing -> return ()+ Just currentInfo' ->+ let symModPair = (descrName idDescr, modu $ descrModu idDescr)+ modulesList1 = modulesForCallerFromPackages+ (Map.elems $ fst $ fst currentInfo') symModPair+ modulesList2 = modulesForCallerFromPackages+ (Map.elems $ fst $ snd currentInfo') symModPair+ modulesList = nub $ modulesList1 ++ modulesList2+ finalList = sort $ zip modulesList (repeat (descrName idDescr))+ in do callers <- getCallers+ liftIO $ do+ writeIORef (callersDescr callers) (Just idDescr)+ New.listStoreClear (callersStore callers)+ mapM_ (New.listStoreAppend (callersStore callers)) finalList+ entrySetText (callersEntry callers)+ $ descrName idDescr +++ " << " ++ showPackModule (descrModu idDescr)+ bringPaneToFront callers++modulesForCallerFromPackages :: [PackageDescr] -> (Symbol,ModuleName) -> [ModuleDescr]+modulesForCallerFromPackages [] _ = []+modulesForCallerFromPackages (p :rest) (sym,mod) =+ (filter (\ md -> case mod `Map.lookup` (usagesMD md) of+ Nothing -> False+ Just syms -> sym `Set.member` syms) (exposedModulesPD p))+ ++ modulesForCallerFromPackages rest (sym,mod)++getCallers :: IDEM IDECallers+getCallers = do+ mbMod <- getPane+ case mbMod of+ Nothing -> do+ prefs <- readIDE prefs+ layout <- readIDE layout+ let pp = getStandardPanePath (modulesPanePath prefs) layout+ nb <- getNotebook pp+ initCallers pp nb+ mbMod <- getPane+ case mbMod of+ Nothing -> throwIDE "Can't init callers"+ Just m -> return m+ Just m -> return m++initCallers :: PanePath -> Notebook -> IDEAction+initCallers panePath nb = do+ panes <- readIDE panes+ paneMap <- readIDE paneMap+ prefs <- readIDE prefs+ currentInfo <- readIDE currentInfo+ (buf,cids) <- reifyIDE $ \ideR session -> do+ listStore <- New.listStoreNew []+ treeView <- New.treeViewNew+ New.treeViewSetModel treeView listStore++ renderer0 <- New.cellRendererPixbufNew+ set renderer0 [ cellPixbufStockId := stockYes ]++ renderer <- New.cellRendererTextNew+ col <- New.treeViewColumnNew+ New.treeViewColumnSetTitle col "Modules"+ New.treeViewColumnSetSizing col TreeViewColumnAutosize+ New.treeViewColumnSetResizable col True+ New.treeViewColumnSetReorderable col True+ New.treeViewAppendColumn treeView col+ New.cellLayoutPackStart col renderer0 False+ New.cellLayoutPackStart col renderer True+ New.cellLayoutSetAttributes col renderer listStore+ $ \row -> [ New.cellText := render $ disp $ modu $ moduleIdMD $ fst row]+ New.cellLayoutSetAttributes col renderer0 listStore+ $ \row -> [cellPixbufStockId :=+ if isJust (mbSourcePathMD $ fst row)+ then stockJumpTo+ else stockYes]++ renderer2 <- New.cellRendererTextNew+ col2 <- New.treeViewColumnNew+ New.treeViewColumnSetTitle col2 "Packages"+ New.treeViewColumnSetSizing col2 TreeViewColumnAutosize+ New.treeViewColumnSetResizable col True+ New.treeViewColumnSetReorderable col2 True+ New.treeViewAppendColumn treeView col2+ New.cellLayoutPackStart col2 renderer2 True+ New.cellLayoutSetAttributes col2 renderer2 listStore+ $ \row -> [ New.cellText := render $ disp $ pack $ moduleIdMD $ fst row]++ New.treeViewSetHeadersVisible treeView True+ sel <- New.treeViewGetSelection treeView+ New.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+ callersDescr' <- newIORef Nothing+ let callers = IDECallers sw treeView callersDescr' listStore entry box+ notebookInsertOrdered nb box (paneName callers) Nothing+ widgetShowAll box+ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive callers) ideR session; return True)+ treeView `onButtonPress` (treeViewPopup ideR session callers)+ return (callers,[ConnectC cid1])+ addPaneAdmin buf cids panePath+ liftIO $widgetGrabFocus (scrolledView buf)+++getSelectionTree :: New.TreeView+ -> New.ListStore (ModuleDescr,Symbol)+ -> IO (Maybe (ModuleDescr,Symbol))+getSelectionTree treeView listStore = do+ treeSelection <- New.treeViewGetSelection treeView+ rows <- New.treeSelectionGetSelectedRows treeSelection+ case rows of+ [[n]] -> do+ val <- New.listStoreGetValue listStore n+ return (Just val)+ _ -> return Nothing++treeViewPopup :: IDERef+ -> Session+ -> IDECallers+ -> Event+ -> IO (Bool)+treeViewPopup ideR session callers (Button _ click _ _ _ _ button _ _) = do+ if button == RightButton+ then do+ theMenu <- menuNew+ item1 <- menuItemNewWithLabel "Edit"+ item1 `onActivateLeaf` do+ sel <- getSelectionTree (treeViewC callers) (callersStore callers)+ case sel of+ Just (m,_) -> case mbSourcePathMD m of+ Nothing -> return ()+ Just fp -> do+ text <- entryGetText (callersEntry callers)+ case words text of+ (hd : tl) -> do+ reflectIDE (selectText fp hd) ideR session+ return ()+ _ -> return ()+ otherwise -> return ()+ menuShellAppend theMenu item1+ menuPopup theMenu Nothing+ widgetShowAll theMenu+ return True+ else if button == LeftButton && click == DoubleClick+ then do sel <- getSelectionTree (treeViewC callers)+ (callersStore callers)+ case sel of+ Just (m,_)+ -> case mbSourcePathMD m of+ Nothing -> return False+ Just fp -> do+ text <- entryGetText (callersEntry callers)+ case words text of+ (hd : tl) -> do+ reflectIDE (selectText fp hd) ideR session+ return True+ _ -> return False+ otherwise -> return False+ else return False+treeViewPopup _ _ _ _ = throwIDE "treeViewPopup wrong event type"++selectText :: FilePath -> String -> IDEM Bool+selectText fp text = do+ res <- selectSourceBuf fp+ fs <- getFindState+ case res of+ Nothing -> return False+ Just _ -> do+ setFindState fs {entryStr = text}+ showFindbar+ focusFindEntry+ reifyIDE $ \ideR session -> do+ idleAdd (do+ reflectIDE (editFind True True True text "" Forward) ideR session+ return False)+ priorityDefaultIdle+ return True++
+ src/IDE/Pane/ClassHierarchy.hs view
@@ -0,0 +1,919 @@+{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances+ -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.ClassHierarchy+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- 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 Graphics.UI.Gtk.ModelView as New+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 :: New.TreeView+, treeStore :: New.TreeStore ClassWrapper+--, facetView :: New.TreeView+--, facetStore :: New.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 pane = do+ (panePath,_) <- guiPropertiesFromName (paneName pane)+ nb <- getNotebook panePath+ mbI <- liftIO $notebookPageNum nb (getTopWidget pane)+ case mbI of+ Nothing -> throwIDE "Pane>IDEClassHierarchy: notebook page not found: unexpected"+ Just i -> do+ deactivatePaneIfActive pane+ liftIO $ do+ notebookRemovePage nb i+ widgetDestroy (getTopWidget pane)+ removePaneAdmin pane++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+ New.treeViewExpandToPath treeView treePath+ sel <- New.treeViewGetSelection treeView+ New.treeSelectionSelectPath sel treePath+ col <- New.treeViewGetColumn treeView 0+ New.treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3))+ mbFacetTree <- treeStoreGetTreeSave facetStore []+ selF <- New.treeViewGetSelection facetView+ case findPathFor symbol mbFacetTree of+ Nothing -> sysMessage Normal "no path found"+ Just path -> do+ New.treeSelectionSelectPath selF path+ col <- New.treeViewGetColumn facetView 0+ New.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+ prefs <- readIDE prefs+ layout <- readIDE layout+ let pp = getStandardPanePath (modulesPanePath prefs) layout+ nb <- getNotebook pp+ initClassHierarchy pp nb+ 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))++initClassHierarchy :: PanePath -> Notebook -> IDEAction+initClassHierarchy panePath nb = do+ panes <- readIDE panes+ paneMap <- readIDE paneMap+ prefs <- readIDE prefs+ currentInfo <- readIDE currentInfo+ (buf,cids) <- reifyIDE $ \ideR session -> do++-- Class Hierarchy+ let forest = case currentInfo of+ Nothing -> []+ Just pair -> buildClassHierarchyTree pair+ treeStore <- New.treeStoreNew forest+ treeView <- New.treeViewNew+ New.treeViewSetModel treeView treeStore+ --New.treeViewSetRulesHint treeView True++ renderer0 <- New.cellRendererPixbufNew+ set renderer0 [ cellPixbufStockId := "ide_no_source" ]++ renderer <- New.cellRendererTextNew+ col <- New.treeViewColumnNew+ New.treeViewColumnSetTitle col "Classes"+ New.treeViewColumnSetSizing col TreeViewColumnAutosize+ New.treeViewColumnSetResizable col True+ New.treeViewColumnSetReorderable col True+ New.treeViewAppendColumn treeView col+ New.cellLayoutPackStart col renderer0 False+ New.cellLayoutPackStart col renderer True+ New.cellLayoutSetAttributes col renderer treeStore+ $ \(s,_,_) -> [ New.cellText := s]+ New.cellLayoutSetAttributes col renderer0 treeStore+ $ \(_,_,d) -> [+ cellPixbufStockId :=+ if isJust (mbLocation d)+ then "ide_source"+ else "ide_no_source"]++ New.treeViewSetHeadersVisible treeView True+ -- New.treeViewSetEnableSearch treeView True+ -- New.treeViewSetSearchColumn treeView 0+ -- New.treeViewSetSearchEqualFunc treeView (treeViewSearch treeView treeStore)++-- Facet view+{--+ facetView <- New.treeViewNew+ facetStore <- New.treeStoreNew []+ New.treeViewSetModel facetView facetStore+ renderer30 <- New.cellRendererPixbufNew+ renderer31 <- New.cellRendererPixbufNew+ renderer3 <- New.cellRendererTextNew+ col <- New.treeViewColumnNew+ New.treeViewColumnSetTitle col "Interface"+ --New.treeViewColumnSetSizing col TreeViewColumnAutosize+ New.treeViewAppendColumn facetView col+ New.cellLayoutPackStart col renderer30 False+ New.cellLayoutPackStart col renderer31 False+ New.cellLayoutPackStart col renderer3 True+ New.cellLayoutSetAttributes col renderer3 facetStore+ $ \row -> [ New.cellText := facetTreeText row]+ New.cellLayoutSetAttributes col renderer30 facetStore+ $ \row -> [+ cellPixbufStockId := stockIdFromType (facetIdType row)]+ New.cellLayoutSetAttributes col renderer31 facetStore+ $ \row -> [+ cellPixbufStockId := if isJust (mbLocation(facetIdDescr row))+ then "ide_source"+ else ""]+ New.treeViewSetHeadersVisible facetView True+ New.treeViewSetEnableSearch facetView True+ New.treeViewSetSearchColumn facetView 0+ New.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+ notebookInsertOrdered nb boxOuter (paneName classes) Nothing+ widgetShowAll boxOuter+ cid3 <- treeView `New.onRowActivated`+ (\ treePath _ -> do+ New.treeViewExpandRow treeView treePath False+ return ())+ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive classes) ideR session; 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 <- New.treeViewGetSelection treeView+-- sel `New.onSelectionChanged` (fillFacets treeView treeStore facetView facetStore)+-- sel2 <- New.treeViewGetSelection facetView+-- sel2 `New.onSelectionChanged` (fillInfo facetView facetStore ideR)++ return (classes,[ConnectC cid1{--,ConnectC cid2--}, ConnectC cid3])+ addPaneAdmin buf cids panePath+ liftIO $widgetGrabFocus (paned buf)+++{--+treeViewSearch :: TreeView+ -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])+ -> Int+ -> String+ -> TreeIter+ -> IO Bool+treeViewSearch treeView treeStore _ string iter = do+ path <- New.treeModelGetPath treeStore iter+ val <- New.treeStoreGetValue treeStore path+ mbTree <- treeStoreGetTreeSave treeStore path+ exp <- New.treeViewRowExpanded treeView path+ when (isJust mbTree && (not (null (subForest (fromJust mbTree)))) && not exp) $+ let found = searchInModSubnodes (fromJust mbTree) string+ in when found $ do+ New.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+ -> New.TreeStore FacetWrapper+ -> Int+ -> String+ -> TreeIter+ -> IO Bool+facetViewSearch facetView facetStore _ string iter = do+ path <- New.treeModelGetPath facetStore iter+ val <- New.treeStoreGetValue facetStore path+ tree <- New.treeStoreGetTree facetStore path+ exp <- New.treeViewRowExpanded facetView path+ when (not (null (subForest tree)) && not exp) $+ let found = searchInFacetSubnodes tree string+ in when found $ do+ New.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 :: New.TreeView+ -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])+ -> New.TreeView+ -> New.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 <- New.treeStoreNew []+ New.treeViewSetModel facetView emptyModel+ New.treeStoreClear facetStore+ mapM_ (\(e,i) -> New.treeStoreInsertTree facetStore [] i e)+ $ zip forest [0 .. length forest]+ New.treeViewSetModel facetView facetStore+ New.treeViewSetEnableSearch facetView True+ New.treeViewSetSearchColumn facetView 0+ New.treeViewSetSearchEqualFunc facetView (facetViewSearch facetView facetStore)++ [] -> return ()+ Nothing+ -> do+ New.treeStoreClear facetStore+ return ()+--}+{--+getSelectionTree :: New.TreeView+ -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])+ -> IO (Maybe (String, [(ModuleDescr,PackageDescr)]))+getSelectionTree treeView treeStore = do+ treeSelection <- New.treeViewGetSelection treeView+ paths <- New.treeSelectionGetSelectedRows treeSelection+ case paths of+ [] -> return Nothing+ a:r -> do+ val <- New.treeStoreGetValue treeStore a+ return (Just val)++getSelectionFacet :: New.TreeView+ -> New.TreeStore FacetWrapper+ -> IO (Maybe FacetWrapper)+getSelectionFacet treeView treeStore = do+ treeSelection <- New.treeViewGetSelection treeView+ paths <- New.treeSelectionGetSelectedRows treeSelection+ case paths of+ a:r -> do+ val <- New.treeStoreGetValue treeStore a+ return (Just val)+ _ -> return Nothing+++fillInfo :: New.TreeView+ -> New.TreeStore FacetWrapper+ -> IDERef+ -> IO ()+fillInfo treeView lst ideR = do+ treeSelection <- New.treeViewGetSelection treeView+ paths <- New.treeSelectionGetSelectedRows treeSelection+ case paths of+ [] -> return ()+ [a] -> do+ wrapper <- New.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+ New.treeStoreClear treeStore+ mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e)+ $ zip li [0 .. length li]+ _ -> liftIO $ do+ New.treeStoreClear treeStore+ New.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 <- New.treeStoreNew []+ New.treeViewSetModel treeView emptyModel+ New.treeStoreClear treeStore+ mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e)+ $ zip li [0 .. length li]+ New.treeViewSetModel treeView treeStore+ New.treeViewSetEnableSearch treeView True+ New.treeViewSetSearchColumn treeView 0+ New.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+ -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])+ -> New.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` (New.treeViewExpandAll treeView)+ item3 <- menuItemNewWithLabel "CollapseAll"+ item3 `onActivateLeaf` (New.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+ -> New.TreeStore FacetWrapper+ -> New.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 $ New.treeViewGetSelection treeView+ liftIO $ New.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+ New.treeViewExpandToPath treeView treePath+ sel <- New.treeViewGetSelection treeView+ New.treeSelectionSelectPath sel treePath+ col <- New.treeViewGetColumn treeView 0+ New.treeViewScrollToCell treeView treePath (fromJust col)+ (Just (0.3,0.3))+ case mbIdName of+ Nothing -> return ()+ Just symbol -> do+ mbFacetTree <- treeStoreGetTreeSave facetStore []+ selF <- New.treeViewGetSelection facetView+ case findPathFor symbol mbFacetTree of+ Nothing -> sysMessage Normal "no path found"+ Just path -> do+ New.treeSelectionSelectPath selF path+ col <- New.treeViewGetColumn facetView 0+ New.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 $ New.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 :: New.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/Info.hs view
@@ -0,0 +1,345 @@+{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses+ -XScopedTypeVariables -XTypeSynonymInstances #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.Info+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | The GUI stuff for infos+--+-------------------------------------------------------------------------------++module IDE.Pane.Info (+ IDEInfo+, InfoState+, setInfo+, setSymbol+, replayInfoHistory+, getIdentifierDescr+, showInfo+) where++import Graphics.UI.Gtk hiding (afterToggleOverwrite)+import Control.Monad.Reader+import System.IO+import Control.Monad+import Control.Monad.Trans+import System.IO+--import Data.List+import Data.Maybe+import qualified Data.ByteString.Char8 as BS+import Data.IORef+import qualified Data.Map as Map+import Data.Typeable++import IDE.Core.State+import Control.Event+import Graphics.UI.Editor.MakeEditor+import Graphics.UI.Editor.Simple+import Graphics.UI.Editor.Composite+import Graphics.UI.Editor.Parameters+import IDE.Pane.SourceBuffer+import IDE.Pane.Callers+import Graphics.UI.Editor.Basics+import MyMissing++++-- | An info pane description+--+data IDEInfo = IDEInfo {+ sw :: ScrolledWindow+, currentDescr :: IORef Descr+, injector :: Descr -> IO()+, extractor :: Descr -> Extractor Descr+} deriving Typeable++data InfoState = InfoState 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 pane = do+ (panePath,_) <- guiPropertiesFromName (paneName pane)+ nb <- getNotebook panePath+ mbI <- liftIO $notebookPageNum nb (getTopWidget pane)+ case mbI of+ Nothing -> liftIO $ do+ sysMessage Normal "notebook page not found: unexpected"+ return ()+ Just i -> do+ deactivatePaneIfActive pane+ liftIO $ do+ notebookRemovePage nb i+ widgetDestroy (getTopWidget pane)+ removePaneAdmin pane++instance RecoverablePane IDEInfo InfoState IDEM where+ saveState p = do+ currentDescr' <- liftIO $ readIORef (currentDescr p)+ return (Just (InfoState currentDescr'))+ recoverState pp (InfoState descr) = do+ setInfo descr++showInfo :: IDEAction+showInfo = do+ mbInfo :: Maybe IDEInfo <- getPane+ case mbInfo of+ Nothing -> return ()+ Just p -> liftIO $ bringPaneToFront p++idDescrDescr :: IDERef -> Session -> FieldDescription Descr+idDescrDescr ideR session = VFD emptyParams [+ HFD emptyParams [+ mkField+ (paraName <<<- ParaName "Identifier"+ $ paraName <<<- ParaPack PackGrow+ $ emptyParams)+ descrName+ (\ b a -> if isReexported a then a else a{descrName' = b})+ (symbolEditor ideR session)+ , mkField+ emptyParams+ (stockIdFromType . descrType . details)+ (\b a -> a)+ imageEditor+ , mkField+ (paraName <<<- ParaName "Sort"+ $ emptyParams)+ (descrType . details)+ (\b a -> a)+ (comboSelectionEditor allOf)+ , mkField+ (paraName <<<- ParaName "Exported by"+ $ paraPack <<<- ParaPack PackGrow+ $ emptyParams)+ (\l -> showPackModule (descrModu l))+ (\ b a -> if isReexported a then a else a{descrModu' = parsePackModule b})+ (stringEditor (const True))]+ , mkField+ (paraPack <<<- ParaPack PackGrow $ emptyParams)+ (\ a -> (BS.unpack $ typeInfo a,+ (case mbComment a of+ Nothing -> ""+ Just s -> BS.unpack s)))+ (\ b a ->+ (if isReexported a+ then a+ else a {typeInfo' = BS.pack (fst b),+ mbComment' = case snd b of+ "" -> Nothing+ s -> Just (BS.pack s)}))+ (typeAndCommentEditor ideR session)]++--allIdTypes = [Function, Newtype, Type, AbstractData, OpenData, Foreign+-- , Data, Class, Instance, Constructor, Field, Method, OrphanedInstance]++typeEditor :: IDERef -> Session -> Editor String+typeEditor ideR session para noti = do+ ed@(wid,inj,ext) <- multilineStringEditor para noti+ registerEvent noti ButtonRelease $Left (\e -> do+ res <- showInfoHandler wid ideR session+ return e {gtkReturn = res})+ return ed++typeAndCommentEditor :: IDERef -> Session -> Editor (String,String)+typeAndCommentEditor ideR session para noti =+ splitEditor (typeEditor ideR session,+ paraName <<<- ParaName "Type"+ $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0)+ $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0)+ $ emptyParams)+ (multilineStringEditor,+ paraName <<<- ParaName "Comment"+ $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0)+ $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0)+ $ emptyParams)+ (paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0)+ $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0)+ $ para) noti++symbolEditor :: IDERef -> Session -> Editor String+symbolEditor ideR session parameters notifier = do+ window <- reflectIDE (readIDE window) ideR session+ ed@(w,i,ext) <- stringEditor (\_ -> True) parameters notifier+ registerEvent notifier AfterKeyRelease (Left (\event -> do+ mbText <- ext+ case mbText of+ Just t -> do+ reflectIDE (do+ triggerEvent ideR (SearchMeta t)+ rw <- liftIO $ getRealWidget w+ when (isJust rw) $ liftIO $ do+ widgetGrabFocus (fromJust rw)+ editableSelectRegion (castToEditable (fromJust rw)) 0 0+ editableSetPosition (castToEditable (fromJust rw)) (-1)) ideR session+ Nothing -> return ()+ return event))+ return ed++showInfoHandler :: Widget -> IDERef -> Session -> IO Bool+showInfoHandler wid ideR session = do+ mbFrame <- binGetChild (castToAlignment wid)+ mbInner <- binGetChild (castToFrame (forceJust mbFrame "InfoPane>>typeEditor: Can't find child"))+ mbScrolled <- binGetChild (castToAlignment (forceJust mbInner "InfoPane>>typeEditor: Can't find child2")) + mbTV <- binGetChild (castToScrolledWindow (forceJust mbScrolled "InfoPane>>typeEditor: Can't find child3")) + buf <- textViewGetBuffer (castToTextView (forceJust mbTV "InfoPane>>typeEditor: Can't find child4"))+ (l,r) <- textBufferGetSelectionBounds buf+ symbol <- textBufferGetText buf l r True+ reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR session+ return False++initInfo :: PanePath -> Notebook -> Descr -> IDEAction+initInfo panePath nb idDescr = do+ panes <- readIDE panes+ paneMap <- readIDE paneMap+ prefs <- readIDE prefs+ (pane,cids) <- reifyIDE $ \ideR session -> do+ ibox <- vBoxNew False 0+ bb <- hButtonBoxNew+ buttonBoxSetLayout bb ButtonboxSpread+ definitionB <- buttonNewWithLabel "Source"+ moduB <- buttonNewWithLabel "Modules"+ usesB <- buttonNewWithLabel "Usage"+ docuB <- buttonNewWithLabel "Docu"+ searchB <- buttonNewWithLabel "Find"+ widgetSetSensitivity docuB False+ boxPackStartDefaults bb definitionB+ boxPackStartDefaults bb moduB+ boxPackStartDefaults bb usesB+ boxPackStartDefaults bb docuB+ boxPackStartDefaults bb searchB+ (widget,injb,ext,notifier) <- buildEditor (idDescrDescr ideR session) idDescr+ boxPackStart ibox widget PackGrow 0+ boxPackEnd ibox bb PackNatural 0+ --openType+ sw <- scrolledWindowNew Nothing Nothing+ scrolledWindowAddWithViewport sw ibox+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ currentDescr' <- newIORef idDescr+ let info = IDEInfo sw currentDescr' injb ext+ -- mapM_ (\w -> widgetSetExtensionEvents w [ExtensionEventsAll]) widgets+ widget `onFocus` (\_ -> do reflectIDE (makeActive info) ideR session+ return False)+ definitionB `onClicked` (reflectIDE gotoSource ideR session)+ moduB `onClicked` (reflectIDE gotoModule' ideR session)+ usesB `onClicked` (reflectIDE calledBy' ideR session)+ searchB `onClicked` (do+ mbDescr <- ext idDescr+ case mbDescr of+ Nothing -> return ()+ Just descr -> reflectIDE (do+ triggerEvent ideR (SearchMeta (descrName' descr))+ showInfo) ideR session)+ notebookInsertOrdered nb sw (paneName info) Nothing+ widgetShowAll sw+ return (info,[])+ addPaneAdmin pane [] panePath+ liftIO $widgetGrabFocus (sw pane)+ liftIO $bringPaneToFront pane++gotoSource :: IDEAction+gotoSource = do+ mbInfo <- getInfoCont+ case mbInfo of+ Nothing -> do ideMessage Normal "gotoSource:noDefition"+ return ()+ Just info -> goToDefinition info >> return ()++gotoModule' :: IDEAction+gotoModule' = do+ mbInfo <- getInfoCont+ ideR <- ask+ case mbInfo of+ Nothing -> return ()+ Just info -> triggerEvent ideR (SelectIdent info) >> return ()++calledBy' :: IDEAction+calledBy' = do+ mbInfo <- getInfoCont+ case mbInfo of+ Nothing -> return ()+ Just info -> calledBy info >> return ()++setSymbol :: String -> IDEAction+setSymbol symbol = do+ ideR <- ask+ 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 triggerEvent ideR (DescrChoice (a:r)) >> return ()+ else triggerEvent ideR (SelectIdent a) >> return ()+++setInfo :: Descr -> IDEAction+setInfo identifierDescr = do+ mbPane <- getPane+ case mbPane of+ Nothing -> do+ prefs <- readIDE prefs+ layout <- readIDE layout+ let pp = getStandardPanePath (logPanePath prefs) layout+ nb <- getNotebook pp+ initInfo pp nb identifierDescr+ Just info -> do+ oldDescr <- liftIO $ readIORef (currentDescr info)+ liftIO $ do+ writeIORef (currentDescr info) identifierDescr+ (injector info) identifierDescr+ recordInfoHistory identifierDescr oldDescr++getInfoCont :: IDEM (Maybe (Descr))+getInfoCont = do+ mbPane <- getPane+ case mbPane of+ Nothing -> return Nothing+ Just p -> liftIO $ readIORef (currentDescr p) >>= return . Just++--+-- | 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++-- * GUI History++recordInfoHistory :: Descr -> Descr -> IDEAction+recordInfoHistory descr oldDescr = do+ ideR <- ask+ triggerEvent ideR (RecordHistory+ ((InfoElementSelected descr),+ (InfoElementSelected oldDescr)))+ return ()++replayInfoHistory :: Descr -> IDEAction+replayInfoHistory descr = do+ setInfo descr++
+ src/IDE/Pane/Log.hs view
@@ -0,0 +1,707 @@+{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses+ -XTypeSynonymInstances -XParallelListComp #-}+--+-- Module : IDE.Pane.Log+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | Log pane+--+-------------------------------------------------------------------------------+++module IDE.Pane.Log (+ IDELog(..)+, LogView(..)+, LogAction(..)+, LogState+, LogTag(..)++, readOut+, readErr+, runExternal+) where++import Data.Typeable (Typeable(..))+import Text.ParserCombinators.Parsec+import IDE.Core.State+import Graphics.UI.Gtk+import Graphics.UI.Gtk.Gdk.Events+import Graphics.UI.Editor.MakeEditor (buildEditor)+import Control.Monad.Trans (liftIO)+import Graphics.UI.Editor.Basics (eventPaneName)+import Graphics.UI.Editor.Basics (GUIEventSelector(..))+import Control.Event (registerEvent)+import Graphics.UI.Editor.Simple (okCancelFields)+import Graphics.UI.Editor.Parameters+import Text.ParserCombinators.Parsec.Language (haskellDef)+import Data.Char (isUpper)+import qualified Text.ParserCombinators.Parsec.Token as P+import Text.ParserCombinators.Parsec.Language (haskellStyle)+import Data.List (foldl',sort,nub)+import IDE.SourceCandy (getCandylessText)+import IDE.Pane.SourceBuffer (inBufContext')+import IDE.Pane.Info (getIdentifierDescr)+import Debug.Trace (trace)+import Data.List (nubBy)+import IDE.Pane.SourceBuffer (markErrorInSourceBuf)+import IDE.Pane.SourceBuffer (selectSourceBuf)+import Graphics.UI.Editor.MakeEditor (FieldDescription(..),mkField)+import Graphics.UI.Editor.Simple (staticListEditor)+import Data.Maybe (isNothing,isJust)+import Distribution.ModuleName(ModuleName)+import Distribution.Text(disp)+import Text.PrettyPrint (render)+import System.Process+import System.IO+import Prelude hiding (catch)+import Control.Exception hiding (try)+-------------------------------------------------------------------------------+--+-- * Interface+--++--+-- | The Log pane+--+++data IDELog = IDELog {+ textView :: TextView+, scrolledWindowL :: ScrolledWindow+} deriving Typeable++data LogState = LogState+ deriving(Eq,Ord,Read,Show,Typeable)+++class LogAction alpha where+ clearLog :: alpha+ addAllImports :: alpha+ addOneImport :: alpha++instance LogAction IDEAction where+ clearLog = clearLog'+ addAllImports = addAllImports'+ addOneImport = addOneImport'++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 pane = do+ (panePath,_) <- guiPropertiesFromName (paneName pane)+ nb <- getNotebook panePath+ mbI <- liftIO $notebookPageNum nb (getTopWidget pane)+ case mbI of+ Nothing -> liftIO $ do+ sysMessage Normal "notebook page not found: unexpected"+ return ()+ Just i -> do+ deactivatePaneIfActive pane+ liftIO $ do+ notebookRemovePage nb i+ widgetDestroy (getTopWidget pane)+ removePaneAdmin pane++instance RecoverablePane IDELog LogState IDEM where+ saveState p = return (Just LogState)+ recoverState pp LogState = do+ nb <- getNotebook pp+ initLog pp nb+++-------------------------------------------------------------------------------+--+-- * Implementation+--+++initLog :: PanePath -> Notebook -> IDEAction+initLog panePath nb = do+ panes <- readIDE panes+ paneMap <- readIDE paneMap+ prefs <- readIDE prefs+ (buf,cids) <- reifyIDE $ \ideR session -> 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 := "green"]+ textTagTableAdd tags frametag+ activeErrtag <- textTagNew (Just "activeErr")+ set activeErrtag[textTagBackground := "yellow"]+ textTagTableAdd tags activeErrtag++ textViewSetEditable tv True+ 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+ notebookInsertOrdered nb sw (paneName buf) Nothing+ widgetShowAll (scrolledWindowL buf)+ cid1 <- tv `afterFocusIn`+ (\_ -> do reflectIDE (makeActive buf) ideR session; return True)+ cid2 <- tv `onButtonPress`+ (\ b -> do reflectIDE (clicked b buf) ideR session; return True)+ return (buf,[ConnectC cid1, ConnectC cid2])+ addPaneAdmin buf cids panePath+ liftIO $widgetGrabFocus (textView buf)++clicked :: Event -> IDELog -> IDEAction+clicked (Button _ SingleClick _ _ _ _ LeftButton x y) ideLog = do+ errors' <- readIDE errors+ line' <- liftIO $ do+ (x,y) <- widgetGetPointer (textView ideLog)+ (_,y') <- textViewWindowToBufferCoords (textView ideLog) TextWindowWidget (x,y)+ (iter,_) <- textViewGetLineAtY (textView ideLog) y'+ textIterGetLine iter+ case filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1))+ (zip errors' [0..(length errors')]) of+ [(thisErr,n)] -> do+ succ <- selectSourceBuf (filePath thisErr)+ if isJust succ+ then markErrorInSourceBuf (line thisErr) (column thisErr)+ (errDescription thisErr)+ else return ()+ log :: IDELog <- getLog+ liftIO $ markErrorInLog log (logLines thisErr)+ modifyIDE_ (\ide -> return (ide{currentErr = Just n}))+ otherwise -> return ()+clicked (Button _ SingleClick _ _ _ _ RightButton x y) ideLog = do+ errors' <- readIDE errors+ line' <- reifyIDE $ \ideR session -> do+ (x,y) <- widgetGetPointer (textView ideLog)+ (_,y') <- textViewWindowToBufferCoords (textView ideLog) TextWindowWidget (x,y)+ (iter,_) <- textViewGetLineAtY (textView ideLog) y'+ textIterGetLine iter+ case filter (\(es,_) -> fst (logLines es) <= (line'+1) && snd (logLines es) >= (line'+1))+ (zip errors' [0..(length errors')]) of+ [(thisErr,n)] -> reifyIDE $ \ideR session -> do+ theMenu <- menuNew+ item0 <- menuItemNewWithLabel "Add all imports"+ item0 `onActivateLeaf` do+ reflectIDE addAllImports' ideR session+ menuShellAppend theMenu item0+ case parseNotInScope (errDescription thisErr) of+ Nothing -> do+ return ()+ Just _ -> do+ item1 <- menuItemNewWithLabel "Add import"+ item1 `onActivateLeaf` do+ reflectIDE (addImport thisErr >> return()) ideR session+ menuShellAppend theMenu item1+ menuPopup theMenu Nothing+ widgetShowAll theMenu+ return ()+ otherwise -> return ()+clicked _ _ = return ()++getLog' :: IDEM IDELog+getLog' = do+ mbPane <- getPane+ case mbPane of+ Nothing -> do+ prefs <- readIDE prefs+ layout <- readIDE layout+ let pp = getStandardPanePath (logPanePath prefs) layout+ nb <- getNotebook pp+ initLog pp nb+ mbPane <- getPane+ case mbPane of+ Nothing -> throwIDE "Can't init log"+ Just l -> return l+ Just p -> return p++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+ buf <- textViewGetBuffer tv+ iter <- textBufferGetEndIter buf+ textBufferSelectRange buf iter iter+ textBufferInsert buf iter string+ iter2 <- textBufferGetEndIter buf+ case tag of+ LogTag -> return ()+ ErrorTag -> do+ len <- textBufferGetCharCount buf+ strti <- textBufferGetIterAtOffset buf (len - length string)+ textBufferApplyTagByName buf "err" iter2 strti+ FrameTag -> do+ len <- textBufferGetCharCount buf+ strti <- textBufferGetIterAtOffset buf (len - length string)+ textBufferApplyTagByName buf "frame" iter2 strti+ textBufferMoveMarkByName buf "end" iter2+ mbMark <- textBufferGetMark buf "end"+ line <- textIterGetLine iter2+ case mbMark of+ Nothing -> return ()+ Just mark -> textViewScrollMarkOnscreen tv mark+ bringPaneToFront l+ return line++markErrorInLog' :: IDELog -> (Int,Int) -> IO ()+markErrorInLog' (IDELog tv _) (l1,l2) = do+ idleAdd (do+ buf <- textViewGetBuffer tv+ iter <- textBufferGetIterAtLineOffset buf (l1-1) 0+ iter2 <- textBufferGetIterAtLineOffset buf l2 0+ textBufferSelectRange buf iter iter2+ textBufferMoveMarkByName buf "end" iter+ mbMark <- textBufferGetMark buf "end"+ case mbMark of+ Nothing -> return ()+ Just mark -> do+ textViewScrollToMark tv mark 0.0 (Just (0.3,0.3))+ return ()+ return False) priorityDefaultIdle+ return ()+++clearLog' :: IDEAction+clearLog' = do+ log <- getLog+ buf <- liftIO$ textViewGetBuffer $textView log+ liftIO $textBufferSetText buf ""+ modifyIDE_ (\ide -> return (ide{errors = [], currentErr = Nothing}))++----------------------------------------------------------------------------+-- |* Import Wizard++-- | Add all imports which gave error messages ...+addAllImports' :: IDEAction+addAllImports' = do+ errors <- readIDE errors+ mapM_ addImport [ y | (x,y) <-+ nubBy (\ (p1,_) (p2,_) -> p1 == p2)+ $ [(x,y) | (x,y) <- [((parseNotInScope . errDescription) e, e) | e <- errors]],+ isJust x]++-- | Add import for current error ...+addOneImport' :: IDEAction+addOneImport' = do+ errors' <- readIDE errors+ currentErr' <- readIDE currentErr+ case currentErr' of+ Nothing -> do+ ideMessage Normal $ "No error selected"+ return ()+ Just i -> do+ if 0 <= i && i < length errors'+ then let error = errors' !! i+ in addImport error >> return ()+ else error "Log>>addOneImport: Error out of range"++-- | Add one missing import+addImport :: ErrorSpec -> IDEM (Bool,Maybe ModuleName)+addImport error =+ case parseNotInScope (errDescription error) of+ Nothing -> trace "Dont parse as not in scope error" return (True,Nothing)+ Just nis -> do+ currentInfo' <- readIDE currentInfo+ case currentInfo' of+ Nothing -> trace "No current info" return (False,Nothing)+ Just ((_,symbolTable1),(_,symbolTable2)) ->+ case (getIdentifierDescr (id' nis) symbolTable1 symbolTable2) of+ [] -> do+ ideMessage Normal $ "Identifier " ++ (id' nis) +++ " not found in imported packages"+ return (True,Nothing)+ descr : [] -> addImport' nis (filePath error) descr+ list -> do+ mbDescr <- liftIO $ selectModuleDialog list (id' nis)+ case mbDescr of+ Nothing -> return (False,Nothing)+ Just descr -> addImport' nis (filePath error) descr++addImport' :: NotInScopeParseResult -> FilePath -> Descr -> IDEM (Bool,Maybe ModuleName)+addImport' nis filePath descr = let+ mbQ = mbQual' nis+ id = id' nis+ mod = case descr of+ Descr _ _ m _ _ _ -> modu m+ Reexported m _ -> modu m+ importId = if isSub' nis+ then ImportCoC (getRealId descr id) Nothing+ else if isOp' nis+ then ImportOp (id' nis)+ else ImportId (id' nis)+ importSpec = ImportSpec (render $disp mod) mbQ (Just ([importId],True)) 0+ in do+ candy' <- readIDE candy+ mbBuf <- selectSourceBuf filePath+ case mbBuf of+ Nothing -> return (True,Nothing)+ Just buf -> do+ inBufContext' () $ \ _ gtkbuf _ _ -> do+ ideMessage Normal $ "addImport " ++ show id ++ " from " ++ (render $ disp $ mod)+ liftIO $ do+ i1 <- textBufferGetStartIter gtkbuf+ i2 <- textBufferGetEndIter gtkbuf+ text <- getCandylessText candy' gtkbuf+ let (importSpecs,lastImport) = getImportSpecs text+ linesToModify = filter (\ is -> modid is == (render $ disp $ mod)+ && mbQual is == mbQ+ && not(isHiding (mbImpspec is))) importSpecs+ case linesToModify of+ [] -> let newSpec = importSpec+ newLine = show newSpec ++ "\n"+ lineSel = let bv = foldl' max 0 (map lineNr importSpecs) in+ if bv == 0+ then (lastImport `max` 0)+ else bv+ in do+ textIterSetLine i1 lineSel+ textBufferInsert gtkbuf i1 newLine+ (spec:t) -> let newSpec = spec{mbImpspec =+ case mbImpspec spec of+ Nothing -> Just ([importId],True)+ Just (ids,b) -> Just (nub(importId:ids),b)}+ newLine = show newSpec ++ "\n"+ in do+ textIterSetLine i1 (lineNr spec - 1)+ textIterSetLine i2 (lineNr spec)+ textBufferDelete gtkbuf i1 i2+ textBufferInsert gtkbuf i1 newLine+ return (True,Just mod)+ where+ isHiding (Just (_,False)) = True+ isHiding _ = False++getRealId descr id = if isReexported descr+ then getRealId (impDescr descr) id+ else getReal (details' descr)+ where+ getReal (FieldDescr d) = descrName' d+ getReal (ConstructorDescr d) = descrName' d+ getReal (MethodDescr d) = descrName' d+ getReal _ = id++-- |* The import data++data NotInScopeParseResult = NotInScopeParseResult {+ mbQual' :: Maybe String+ , id' :: String+ , isSub' :: Bool+ , isOp' :: Bool}+ deriving Eq++data ImportSpec = ImportSpec+ { modid :: String+ , mbQual :: Maybe String+ , mbImpspec :: Maybe ([ImportItem],Bool)+ , lineNr :: Int}++data ImportItem =+ ImportId String+ | ImportOp String+ | ImportCoC String (Maybe [ImportSubItem])+ deriving Eq++instance Show ImportItem where+ show (ImportId str) = str+ show (ImportOp str) = "(" ++ str ++ ")"+ show (ImportCoC str Nothing) = str ++ "(..)"+ show (ImportCoC str (Just [])) = str+ show (ImportCoC str (Just l)) = str ++ "(" ++ showCoC l+ where+ showCoC [a] = show a ++ ")"+ showCoC (a:b) = show a ++ "," ++ showCoC b+ showCoC _ = error "Log>>instance ImportItem Show: Empty list"+++data ImportSubItem =+ ImportSubId String+ | ImportSubOp String+ deriving Eq++instance Show ImportSubItem where+ show (ImportSubId str) = str+ show (ImportSubOp str) = "(" ++ str ++ ")"++instance Show ImportSpec where+ show (ImportSpec modid mbQual mbImpspec _) = "import "+ ++ case mbQual of+ Nothing -> ""+ Just _ -> "qualified "+ ++ modid+ ++ case mbQual of+ Nothing -> ""+ Just str -> " as " ++ str ++ " "+ ++ case mbImpspec of+ Nothing -> ""+ Just ([],True) -> ""+ Just (l,True) -> " (" ++ showImportSpecs l+ Just (l, False) -> " hiding (" ++ showImportSpecs l+ where+ showImportSpecs [a] = show a ++ ")"+ showImportSpecs (a:b) = show a ++ "," ++ showImportSpecs b+ showImportSpecs _ = error "Log>>showImportSpecs: Empty list"+++-- |* The error line parser++lexer = P.makeTokenParser haskellStyle+lexeme = P.lexeme lexer+whiteSpace = P.whiteSpace lexer+symbol = P.symbol lexer+identifier = P.identifier lexer+comma = P.comma lexer+dot = P.dot lexer+integer = P.integer lexer+parens = P.parens lexer+operator = P.operator lexer++parseNotInScope :: String -> (Maybe NotInScopeParseResult)+parseNotInScope str =+ case parse scopeParser "" str of+ Left e -> Nothing+ Right r -> Just r++scopeParser :: CharParser () NotInScopeParseResult+scopeParser = do+ whiteSpace+ symbol "Not in scope:"+ isSub <- optionMaybe (try (choice [symbol "type constructor or class"+ , symbol "data constructor"]))+ symbol "`"+ mbQual <- optionMaybe (try (do+ q <- lexeme conid+ dot+ return q))+ id <- optionMaybe (try identifier)+ case id of+ Just id -> return (NotInScopeParseResult mbQual+ (take (length id - 1) id) (isJust isSub) False)+ Nothing -> do+ op <- operator+ symbol "'"+ return (NotInScopeParseResult mbQual op (isJust isSub) True)+ <?> "scopeParser"++-- |* The import parser++getImportSpecs :: String -> ([ImportSpec],Int)+getImportSpecs modSource =+ case parse importSpecParser "" modSource of+ Left e -> trace ("parse failed with " ++ show e) ([],0)+ Right specs -> trace (show specs) specs++importSpecParser :: CharParser () ([ImportSpec],Int)+importSpecParser = do+ whiteSpace+ skipHeader+ lines <- sepBy (try parseImportLine) (many newline)+ pos <- getPosition+ skipMany anyChar+ eof+ return (lines, sourceLine pos - 2)+ <?> "importSpecParser"++skipHeader :: CharParser () ()+skipHeader =do+ try (do+ symbol "module"+ manyTill anyChar (try (symbol "where"))+ trace "with module header " (return ()))+ <|> trace "no module header " (return ())+ <?> "skipHeader"++parseImportLine :: CharParser () ImportSpec+parseImportLine = do+ symbol "import"+ pos <- getPosition+ isQualified <- optionMaybe (try (symbol "qualified"))+ modid <- lexeme mident+ whiteSpace+ mbQName <- if isJust isQualified+ then do+ symbol "as"+ qid <- identifier+ return (Just qid)+ else return Nothing+ mbImpSpec <- optionMaybe+ (try (do+ mbHiding <- optionMaybe (try (symbol "hiding"))+ idList <- parens (sepBy parseImportItem comma)+ return (idList, isNothing mbHiding)))+ whiteSpace+ return (ImportSpec modid mbQName mbImpSpec (sourceLine pos))+ <?> "parseImportLine"++parseImportItem :: CharParser () ImportItem+parseImportItem = do+ id <- optionMaybe (try identifier)+ case id of+ Just id -> if isUpper (head id)+ then do+ ccList <- optionMaybe (try parseSubList)+ return (ImportCoC id Nothing)+ else return (ImportId id)+ Nothing -> do+ op <- optionMaybe (try (parens operator))+ case op of+ Just op -> return (ImportOp op)+ Nothing -> do+ pos <- getPosition+ error $ "Can't parse import item " ++ show pos+ <?> "parseImportItem"++parseSubList :: CharParser () (Maybe [ImportSubItem])+parseSubList = do+ all <- optionMaybe (try (symbol "(..)"))+ case all of+ Just _ -> return Nothing+ Nothing -> do+ list <- optionMaybe (try (parens (sepBy parseSubItem comma)))+ case list of+ Nothing -> return (Just [])+ Just l -> return list+ <?> "parseSubList"++parseSubItem :: CharParser () ImportSubItem+parseSubItem = do+ id <- optionMaybe (try identifier)+ case id of+ Just id -> return (ImportSubId id)+ Nothing -> do+ op <- optionMaybe (try operator)+ case op of+ Just op -> return (ImportSubOp op)+ Nothing -> do+ pos <- getPosition+ error $ "Can't parse sub import item " ++ show pos+ <?> "parseSubItem"++mident = do+ c <- P.identStart haskellDef+ cs <- many (alphaNum <|> oneOf "_'.")+ return (c:cs)+ <?> "midentifier"++conid = do+ c <- upper+ cs <- many (alphaNum <|> oneOf "_'")+ return (c:cs)+ <?> "conid"++-- |* The stupid little dialog++moduleFields :: [String] -> String -> FieldDescription String+moduleFields list id =+ mkField+ (paraName <<<- ParaName ("From which module is " ++ id)+ $ paraMultiSel <<<- ParaMultiSel False+ $ emptyParams)+ (\ a -> [a])+ (\ [a] b -> a)+ (staticListEditor ((nub . sort) list))++selectModuleDialog :: [Descr] -> String -> IO (Maybe Descr)+selectModuleDialog list id = do+ dia <- dialogNew+ upper <- dialogGetUpper dia+ lower <- dialogGetActionArea dia+ (widget,_,ext,_) <- buildEditor (moduleFields+ (map (render . disp . modu . descrModu') list) id)+ ((render . disp . modu . descrModu') (head list))+ (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)))+ _ -> trace ("cancel") return Nothing++-- ---------------------------------------------------------------------+-- ** Spawning external processes+--++readOut :: IDELog -> Handle -> IO ()+readOut log hndl =+ catch (readAndShow)+ (\(e :: SomeException) -> do+ --appendLog log ("----------------------------------------\n") FrameTag+ hClose hndl+ return ())+ where+ readAndShow = do+ line <- hGetLine hndl+ appendLog log (line ++ "\n") LogTag+ readAndShow++readErr :: IDELog -> Handle -> IO ()+readErr log hndl =+ catch (readAndShow)+ (\(e :: SomeException) -> do+ hClose hndl+ return ())+ where+ readAndShow = do+ line <- hGetLine hndl+ appendLog log (line ++ "\n") ErrorTag+ readAndShow++runExternal :: FilePath -> [String] -> IO (Handle, Handle, Handle, ProcessHandle)+runExternal path args = do+ putStrLn $ "Run external called with args " ++ show args+ hndls@(inp, out, err, _) <- runInteractiveProcess path args Nothing Nothing+ sysMessage Normal $ "Starting external tool: " ++ path ++ " with args " ++ (show args)+ hSetBuffering out NoBuffering+ hSetBuffering err NoBuffering+ hSetBuffering inp NoBuffering+ hSetBinaryMode out True+ hSetBinaryMode err True+ return hndls+
+ src/IDE/Pane/Modules.hs view
@@ -0,0 +1,1094 @@+{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses+ -XScopedTypeVariables -XTypeSynonymInstances #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.Modules+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | The pane of ide where modules are presented in tree form with their+-- packages and exports+--+-------------------------------------------------------------------------------++module IDE.Pane.Modules (+ IDEModules(..)+, ModulesState(..)++, showModules+, showInterface+, selectIdentifier+, reloadKeepSelection+, replaySelHistory+, replayScopeHistory+) where++import Graphics.UI.Gtk hiding (get)+import qualified Graphics.UI.Gtk.ModelView as New+import Graphics.UI.Gtk.Gdk.Events+import Data.Maybe+import Control.Monad.Reader+import qualified Data.Map as Map+import Data.Tree+import Data.List+import Distribution.Package+import Distribution.Version+import Data.Char (toLower)+import Prelude hiding (catch)+import Data.IORef+import IDE.Core.State+import IDE.Pane.Info+import IDE.Pane.SourceBuffer+import Control.Event hiding (Event)+import Distribution.ModuleName+import Distribution.Text (simpleParse,display)+import Data.Typeable (Typeable(..))+import Control.Exception (SomeException(..),catch)+import IDE.Package (packageConfig,addModuleToPackageDescr,getModuleTemplate,getPackageDescriptionAndPath)+import Distribution.PackageDescription (allBuildInfo,hsSourceDirs)+import System.FilePath ((</>),dropFileName)+import System.Directory (doesFileExist,createDirectoryIfMissing)+import Graphics.UI.Editor.MakeEditor (buildEditor,FieldDescription(..),mkField)+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 MyMissing (forceJust,forceHead,split)+import IDE.Metainfo.Provider (rebuildActiveInfo)+import Debug.Trace (trace)+++-- | A modules pane description+--++data IDEModules = IDEModules {+ outer :: VBox+, paned :: HPaned+, treeView :: New.TreeView+, treeStore :: New.TreeStore (String, [(ModuleDescr,PackageDescr)])+, descrView :: New.TreeView+, descrStore :: New.TreeStore Descr+, localScopeB :: RadioButton+, packageScopeB :: RadioButton+, worldScopeB :: RadioButton+, blacklistB :: CheckButton+, oldSelection :: IORef SelectionState+} deriving Typeable+++data ModulesState = ModulesState Int (Scope,Bool)+ (Maybe ModuleName, Maybe Symbol)+ deriving(Eq,Ord,Read,Show,Typeable)+++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 pane = do+ (panePath,_) <- guiPropertiesFromName (paneName pane)+ nb <- getNotebook panePath+ mbI <- liftIO $notebookPageNum nb (getTopWidget pane)+ case mbI of+ Nothing -> throwIDE "Pane>IDEModules: notebook page not found: unexpected"+ Just i -> do+ deactivatePaneIfActive pane+ liftIO $ do+ notebookRemovePage nb i+ widgetDestroy (getTopWidget pane)+ removePaneAdmin pane++instance RecoverablePane IDEModules ModulesState IDEM where+ saveState p = do+ (IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) <- getModules+ sc <- getScope+ mbModules <- getPane+ case mbModules of+ Nothing -> return Nothing+ Just p -> liftIO $ do+ i <- panedGetPosition (paned p)+ mbTreeSelection <- getSelectionTree treeView treeStore+ mbFacetSelection <- getSelectionDescr descrView descrStore+ let mbs = (case mbTreeSelection of+ Nothing -> Nothing+ Just (_,[]) -> Nothing+ Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md),+ case mbFacetSelection of+ Nothing -> Nothing+ Just fw -> Just (descrName 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 descrView descrStore lb pb wb blb _)+ <- getModules+ case scope of+ Local -> liftIO $ toggleButtonSetActive lb True+ Package -> liftIO $ toggleButtonSetActive pb True+ System -> liftIO $ toggleButtonSetActive wb True+ liftIO $ toggleButtonSetActive blb useBlacklist+ liftIO $ panedSetPosition (paned mod) i+ fillModulesList sc+ selectNames se++++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+ Nothing -> return ()+ Just sc -> do+ when (fst currentScope < sc) (setScope (sc,snd currentScope))+ selectIdentifier' (modu $ descrModu idDescr) (descrName idDescr)++selectIdentifier' :: ModuleName -> Symbol -> IDEAction+selectIdentifier' moduleName symbol =+ let nameArray = components moduleName+ in do+ mods@(IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _) <- getModules+ mbTree <- liftIO $ treeStoreGetTreeSave treeStore []+ case treePathFromNameArray mbTree nameArray [] of+ Just treePath -> liftIO $ do+ New.treeViewExpandToPath treeView treePath+ sel <- New.treeViewGetSelection treeView+ New.treeSelectionSelectPath sel treePath+ col <- New.treeViewGetColumn treeView 0+ New.treeViewScrollToCell treeView treePath (fromJust col) (Just (0.3,0.3))+ mbFacetTree <- treeStoreGetTreeSave descrStore []+ selF <- New.treeViewGetSelection descrView+ case findPathFor symbol mbFacetTree of+ Nothing -> sysMessage Normal "no path found"+ Just path -> do+ New.treeViewExpandToPath descrView path+ New.treeSelectionSelectPath selF path+ col <- New.treeViewGetColumn descrView 0+ New.treeViewScrollToCell descrView path (fromJust col) (Just (0.3,0.3))+ bringPaneToFront mods+ Nothing -> return ()++findPathFor :: Symbol -> Maybe (Tree Descr) -> Maybe TreePath+findPathFor symbol (Just (Node _ forest)) =+ foldr ( \i mbTreePath -> findPathFor' [i] (forest !! i) mbTreePath)+ Nothing [0 .. ((length forest) - 1)]+ where+ findPathFor' :: TreePath -> Tree Descr -> Maybe TreePath -> Maybe TreePath+ findPathFor' _ node (Just p) = Just p+ findPathFor' path (Node wrap sub) Nothing =+ if descrName 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++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+ prefs <- readIDE prefs+ layout <- readIDE layout+ let pp = getStandardPanePath (modulesPanePath prefs) layout+ nb <- getNotebook pp+ initModules pp nb+ mbMod <- getPane+ case mbMod of+ Nothing -> throwIDE "Can't init modules"+ Just m -> return m+ Just m -> return m++initModules :: PanePath -> Notebook -> IDEAction+initModules panePath nb = do+ panes <- readIDE panes+ paneMap <- readIDE paneMap+ prefs <- readIDE prefs+ currentInfo <- readIDE currentInfo+ (buf,cids) <- reifyIDE $ \ideR session -> do+-- Modules List+ let forest = case currentInfo of+ Nothing -> []+ Just pair -> subForest (buildModulesTree pair)+ treeStore <- New.treeStoreNew forest+ treeView <- New.treeViewNew+ New.treeViewSetModel treeView treeStore+ --New.treeViewSetRulesHint treeView True++ renderer0 <- New.cellRendererPixbufNew+ set renderer0 [ New.cellPixbufStockId := "" ]++ renderer <- New.cellRendererTextNew+ col <- New.treeViewColumnNew+ New.treeViewColumnSetTitle col "Modules"+ New.treeViewColumnSetSizing col TreeViewColumnAutosize+ New.treeViewColumnSetResizable col True+ New.treeViewColumnSetReorderable col True+ New.treeViewAppendColumn treeView col+ New.cellLayoutPackStart col renderer0 False+ New.cellLayoutPackStart col renderer True+ New.cellLayoutSetAttributes col renderer treeStore+ $ \row -> [ New.cellText := fst row]+ New.cellLayoutSetAttributes col renderer0 treeStore+ $ \row -> [+ New.cellPixbufStockId :=+ if null (snd row)+ then ""+ else if isJust (mbSourcePathMD (fst (head (snd row))))+ then "ide_source"+ else ""]++ renderer2 <- New.cellRendererTextNew+ col2 <- New.treeViewColumnNew+ New.treeViewColumnSetTitle col2 "Packages"+ New.treeViewColumnSetSizing col2 TreeViewColumnAutosize+ New.treeViewColumnSetResizable col2 True+ New.treeViewColumnSetReorderable col2 True+ New.treeViewAppendColumn treeView col2+ New.cellLayoutPackStart col2 renderer2 True+ New.cellLayoutSetAttributes col2 renderer2 treeStore+ $ \row -> [ New.cellText := (concat . intersperse ", ")+ $ map (display . packagePD . snd) (snd row)]+ New.treeViewSetHeadersVisible treeView True+ New.treeViewSetEnableSearch treeView True+ New.treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore))++-- Facet view++ descrView <- New.treeViewNew+ descrStore <- New.treeStoreNew []+ New.treeViewSetModel descrView descrStore+ renderer30 <- New.cellRendererPixbufNew+ renderer31 <- New.cellRendererPixbufNew+ renderer3 <- New.cellRendererTextNew+ col <- New.treeViewColumnNew+ New.treeViewColumnSetTitle col "Interface"+ --New.treeViewColumnSetSizing col TreeViewColumnAutosize+ New.treeViewAppendColumn descrView col+ New.cellLayoutPackStart col renderer30 False+ New.cellLayoutPackStart col renderer31 False+ New.cellLayoutPackStart col renderer3 True+ New.cellLayoutSetAttributes col renderer3 descrStore+ $ \row -> [ New.cellText := descrTreeText row]+ New.cellLayoutSetAttributes col renderer30 descrStore+ $ \row -> [+ New.cellPixbufStockId := stockIdFromType (descrIdType row)]+ New.cellLayoutSetAttributes col renderer31 descrStore+ $ \row -> [+ New.cellPixbufStockId := if isReexported row+ then "ide_reexported"+ else if isJust (mbLocation row)+ then "ide_source"+ else ""]+ New.treeViewSetHeadersVisible descrView True+ New.treeViewSetEnableSearch descrView True+ New.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+ scopeRef <- newIORef (System,True)+ let modules = IDEModules boxOuter pane' treeView treeStore descrView descrStore+ rb1 rb2 rb3 cb oldState+ notebookInsertOrdered nb boxOuter (paneName modules) Nothing+ widgetShowAll boxOuter+ cid3 <- treeView `New.onRowActivated`+ (\ treePath _ -> do+ New.treeViewExpandRow treeView treePath False+ return ())+ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive modules) ideR session; return True)+ cid2 <- descrView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive modules) ideR session; return True)+ treeView `onButtonPress` (treeViewPopup ideR session treeStore treeView)+ descrView `onButtonPress` (descrViewPopup ideR session descrStore descrView)+ rb1 `onToggled` (reflectIDE scopeSelection ideR session)+ rb2 `onToggled` (reflectIDE scopeSelection ideR session)+ rb3 `onToggled` (reflectIDE scopeSelection ideR session)+ cb `onToggled` (reflectIDE scopeSelection ideR session)+ sel <- New.treeViewGetSelection treeView+ sel `New.onSelectionChanged` do+ fillFacets treeView treeStore descrView descrStore+ reflectIDE recordSelHistory ideR session+ return ()+ sel2 <- New.treeViewGetSelection descrView+ sel2 `New.onSelectionChanged` do+ fillInfo descrView descrStore ideR session+ reflectIDE recordSelHistory ideR session+ return ()+ return (modules,[ConnectC cid1,ConnectC cid2, ConnectC cid3])+ addPaneAdmin buf cids panePath+ liftIO $widgetGrabFocus (paned buf)++treeViewSearch :: TreeView+ -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])+ -> String+ -> New.TreeIter+ -> IO Bool+treeViewSearch treeView treeStore string iter = do+ path <- New.treeModelGetPath treeStore iter+ val <- New.treeStoreGetValue treeStore path+ mbTree <- treeStoreGetTreeSave treeStore path+ exp <- New.treeViewRowExpanded treeView path+ when (isJust mbTree && (not (null (subForest (fromJust mbTree)))) && not exp) $+ let found = searchInModSubnodes (fromJust mbTree) string+ in when found $ do+ New.treeViewExpandRow treeView path False+ return ()+ let str2 = case snd val of+ [] -> fst val+ (m,_):_ -> showPackModule (moduleIdMD m)+ let res = isInfixOf (map toLower string) (map toLower str2)+ return res++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)++descrViewSearch :: TreeView+ -> New.TreeStore Descr+ -> String+ -> New.TreeIter+ -> IO Bool+descrViewSearch descrView descrStore string iter = do+ path <- New.treeModelGetPath descrStore iter+ val <- New.treeStoreGetValue descrStore path+ tree <- New.treeStoreGetTree descrStore path+ exp <- New.treeViewRowExpanded descrView path+ when (not (null (subForest tree)) && not exp) $+ let found = searchInFacetSubnodes tree string+ in when found $ do+ New.treeViewExpandRow descrView path False+ return ()+ return (isInfixOf (map toLower string) (map toLower (descrTreeText val)))++searchInFacetSubnodes :: DescrTree -> String -> Bool+searchInFacetSubnodes tree str =+ not $ null+ $ filter (\ val ->+ isInfixOf (map toLower str) (map toLower (descrTreeText val)))+ $ concatMap flatten (subForest tree)++fillFacets :: New.TreeView+ -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])+ -> New.TreeView+ -> New.TreeStore Descr+ -> IO ()+fillFacets treeView treeStore descrView descrStore = do+ sel <- getSelectionTree treeView treeStore+ case sel of+ Just val+ -> case snd val of+ ((mod,package):_)+ -> let forest = buildFacetForrest mod in do+ emptyModel <- New.treeStoreNew []+ New.treeViewSetModel descrView emptyModel+ New.treeStoreClear descrStore+ mapM_ (\(e,i) -> New.treeStoreInsertTree descrStore [] i e)+ $ zip forest [0 .. length forest]+ New.treeViewSetModel descrView descrStore+ New.treeViewSetEnableSearch descrView True+ New.treeViewSetSearchEqualFunc descrView (Just (descrViewSearch descrView descrStore))+ [] -> New.treeStoreClear descrStore+ Nothing+ -> New.treeStoreClear descrStore++getSelectionTree :: New.TreeView+ -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])+ -> IO (Maybe (String, [(ModuleDescr,PackageDescr)]))+getSelectionTree treeView treeStore = do+ treeSelection <- New.treeViewGetSelection treeView+ paths <- New.treeSelectionGetSelectedRows treeSelection+ case paths of+ [] -> return Nothing+ a:r -> do+ val <- New.treeStoreGetValue treeStore a+ return (Just val)++getSelectionDescr :: New.TreeView+ -> New.TreeStore Descr+ -> IO (Maybe Descr)+getSelectionDescr treeView treeStore = do+ treeSelection <- New.treeViewGetSelection treeView+ paths <- New.treeSelectionGetSelectedRows treeSelection+ case paths of+ a:r -> do+ val <- New.treeStoreGetValue treeStore a+ return (Just val)+ _ -> return Nothing+++fillInfo :: New.TreeView+ -> New.TreeStore Descr+ -> IDERef+ -> Session+ -> IO ()+fillInfo treeView lst ideR session = do+ treeSelection <- New.treeViewGetSelection treeView+ paths <- New.treeSelectionGetSelectedRows treeSelection+ case paths of+ [] -> return ()+ [a] -> do+ descr <- New.treeStoreGetValue lst a+ reflectIDE (setInfo descr) ideR session+ return ()+ _ -> return ()++findDescription :: PackModule -> SymbolTable -> Symbol -> Maybe (Symbol,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)++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+ (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+ New.treeStoreClear treeStore+ mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e)+ $ zip li [0 .. length li]+ _ -> liftIO $ do+ New.treeStoreClear treeStore+ New.treeStoreInsertTree treeStore [] 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 <- New.treeStoreNew []+ New.treeViewSetModel treeView emptyModel+ New.treeStoreClear treeStore+ mapM_ (\(e,i) -> New.treeStoreInsertTree treeStore [] i e)+ $ zip li [0 .. length li]+ New.treeViewSetModel treeView treeStore+ New.treeViewSetEnableSearch treeView True+ New.treeViewSetSearchEqualFunc treeView (Just (treeViewSearch treeView treeStore))+++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 DescrForest = Forest Descr+type DescrTree = Tree Descr+++descrTreeText :: Descr -> String+descrTreeText (Descr id _ _ _ _ (InstanceDescr binds)) = id ++ " " ++ printBinds binds+ where+ printBinds [] = ""+ printBinds (a:[]) = a+ printBinds (a:b) = a ++ " " ++ printBinds b+descrTreeText d = descrName d++descrIdType :: Descr -> DescrType+descrIdType = descrType . details++buildFacetForrest :: ModuleDescr -> DescrForest+buildFacetForrest modDescr =+ let (instances,other) = partition (\id -> case details id of+ InstanceDescr _ -> True+ _ -> False)+ $ idDescriptionsMD modDescr+ forestWithoutInstances = map buildFacet other+ (forest2,orphaned) = foldl' addInstances (forestWithoutInstances,[])+ 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+ 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}})) [])+ 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}})) [])+ 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}})) []+ : 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}})) []]+ 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 []+ where+ makeReexported :: Descr -> Descr -> Descr+ makeReexported d1 d2+ | isReexported d1 = Reexported{descrModu' = descrModu' d1, impDescr = d2}+ | otherwise = d2++ addInstances :: (DescrForest,[Descr])+ -> Descr+ -> (DescrForest,[Descr])+ addInstances (forest,orphaned) instDescr =+ case foldl' (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))+ = ((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))+ = ((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)+++type ModTree = Tree (String, [(ModuleDescr,PackageDescr)])+--+-- | 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))+ (Map.elems localMap ++ Map.elems otherMap)+ emptyTree = (Node ("",[]) [])+ resultTree = foldl' insertPairsInTree emptyTree flatPairs+ in sortTree resultTree+ where+ insertPairsInTree :: ModTree -> (ModuleDescr,PackageDescr) -> ModTree+ insertPairsInTree tree pair =+ let nameArray = components $ modu $ moduleIdMD $ fst pair+ pairedWith = map (\n -> (n,pair)) nameArray+ in insertNodesInTree pairedWith tree++ insertNodesInTree :: [(String,(ModuleDescr,PackageDescr))] -> ModTree -> ModTree+ insertNodesInTree list@[(str2,pair)] (Node (str1,pairs) forest) =+ case partition (\ (Node (s,_) _) -> s == str2) forest of+ ([],_) -> (Node (str1,pairs) (makeNodes list : forest))+ ([(Node (_,pairsf) l)],rest)+ -> (Node (str1,pairs) ((Node (str2,pair : pairsf) l) : rest))+ (_,_) -> throwIDE "insertNodesInTree: impossible1"+ insertNodesInTree list@((str2,pair):tl) (Node (str1,pairs) forest) =+ case partition (\ (Node (s,_) _) -> s == str2) forest of+ ([],_) -> (Node (str1,pairs) (makeNodes list : forest))+ ([found],rest) -> (Node (str1,pairs) (insertNodesInTree tl found : rest))+ (_,_) -> throwIDE "insertNodesInTree: impossible2"+ insertNodesInTree [] t = t++ makeNodes :: [(String,(ModuleDescr,PackageDescr))] -> ModTree+ makeNodes [(str,pair)] = Node (str,[pair]) []+ makeNodes ((str,_):tl) = Node (str,[]) [makeNodes tl]+ makeNodes _ = throwIDE "Impossible in makeNodes"++breakAtDots :: [String] -> String -> [String]+breakAtDots res [] = reverse res+breakAtDots res toBreak = let (newRes,newToBreak) = span (\c -> c /= '.') toBreak+ in if null newToBreak+ then reverse (newRes : res)+ else breakAtDots (newRes : res) (tail newToBreak)+++instance Ord a => Ord (Tree a) where+ compare (Node l1 _) (Node l2 _) = compare l1 l2++sortTree :: Ord a => Tree a -> Tree a+sortTree (Node l forest) = Node l (sort (map sortTree forest))++treeViewPopup :: IDERef+ -> Session+ -> New.TreeStore (String, [(ModuleDescr,PackageDescr)])+ -> New.TreeView+ -> Event+ -> IO (Bool)+treeViewPopup ideR session store treeView (Button _ click _ _ _ _ button _ _) = do+ if button == RightButton+ then do+ theMenu <- menuNew+ item1 <- menuItemNewWithLabel "Edit source"+ item1 `onActivateLeaf` do+ sel <- getSelectionTree treeView store+ case sel of+ Just (_,[(m,_)]) -> case mbSourcePathMD m of+ Nothing -> return ()+ Just fp -> do+ reflectIDE (selectSourceBuf fp) ideR session+ return ()+ otherwise -> return ()+ sep1 <- separatorMenuItemNew+ item2 <- menuItemNewWithLabel "Expand here"+ item2 `onActivateLeaf` (expandHere treeView)+ item3 <- menuItemNewWithLabel "Collapse here"+ item3 `onActivateLeaf` (collapseHere treeView)+ item4 <- menuItemNewWithLabel "Expand all"+ item4 `onActivateLeaf` (New.treeViewExpandAll treeView)+ item5 <- menuItemNewWithLabel "Collapse all"+ item5 `onActivateLeaf` (New.treeViewCollapseAll treeView)+ sep2 <- separatorMenuItemNew+ item6 <- menuItemNewWithLabel "Add module"+ item6 `onActivateLeaf` (reflectIDE (addModule treeView store) ideR session)++ mapM_ (menuShellAppend theMenu) [castToMenuItem item1, castToMenuItem sep1, castToMenuItem item2,+ castToMenuItem item3, castToMenuItem item4, castToMenuItem item5, castToMenuItem sep2,+ castToMenuItem item6{--,item7,item8--}]+ 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+ reflectIDE (selectSourceBuf fp) ideR session+ return ()+ otherwise -> return ()+ return True+ else return False+treeViewPopup _ _ _ _ _ = throwIDE "treeViewPopup wrong event type"++descrViewPopup :: IDERef+ -> Session+ -> New.TreeStore Descr+ -> New.TreeView+ -> Event+ -> IO (Bool)+descrViewPopup ideR session store descrView (Button _ click _ _ _ _ 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 session+ otherwise -> sysMessage Normal "no selection"+ 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 (goToDefinition descr) ideR session+ otherwise -> sysMessage Normal "no selection"+ return True+ else do+ mbPane :: Maybe IDEInfo <- reflectIDE getPane ideR session+ when (isJust mbPane) $ bringPaneToFront (fromJust mbPane)+ return False++descrViewPopup _ _ _ _ _ = throwIDE "descrViewPopup wrong event type"++setScope :: (Scope,Bool) -> IDEAction+setScope (sc,bl) = do+ (IDEModules _ _ treeView treeStore descrView descrStore localScopeB+ packageScopeB worldScopeB blacklistB _) <- getModules+ case sc of+ Local -> liftIO $ toggleButtonSetActive localScopeB True+ Package -> liftIO $ toggleButtonSetActive packageScopeB True+ System -> liftIO $ toggleButtonSetActive worldScopeB True+ liftIO $ toggleButtonSetActive blacklistB bl+ selectScope (sc,bl)++getScope :: IDEM (Scope,Bool)+getScope = do+ (IDEModules _ _ treeView treeStore descrView descrStore 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 System+ return (scope,cbs)++scopeSelection :: IDEAction+scopeSelection = do+ (sc,bl) <- getScope+ selectScope (sc,bl)++selectScope :: (Scope,Bool) -> IDEAction+selectScope (sc,bl) = do+ mods@(IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _)+ <- getModules+ mbTreeSelection <- liftIO $ getSelectionTree treeView treeStore+ mbDescrSelection <- liftIO $ getSelectionDescr descrView descrStore++ ts <- liftIO $ New.treeViewGetSelection treeView+ withoutRecordingDo $ do+ liftIO $ New.treeSelectionUnselectAll ts+ fillModulesList (sc,bl)+ let mbs = (case mbTreeSelection of+ Nothing -> Nothing+ Just (_,[]) -> Nothing+ Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md),+ case mbDescrSelection of+ Nothing -> Nothing+ Just fw -> Just (descrName fw))+ selectNames mbs+ recordScopeHistory+ liftIO $ bringPaneToFront mods++selectNames :: (Maybe ModuleName, Maybe Symbol) -> IDEAction+selectNames (mbModuleName, mbIdName) = do+ (IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _)+ <- getModules+ case mbModuleName of+ Nothing -> liftIO $ do+ sel <- New.treeViewGetSelection treeView+ New.treeSelectionUnselectAll sel+ selF <- New.treeViewGetSelection descrView+ New.treeSelectionUnselectAll selF+ Just moduleName ->+ let nameArray = components moduleName+ in do+ mbTree <- liftIO $ treeStoreGetTreeSave treeStore []+ case treePathFromNameArray mbTree nameArray [] of+ Nothing -> return ()+ Just treePath -> liftIO $ do+ New.treeViewExpandToPath treeView treePath+ sel <- New.treeViewGetSelection treeView+ New.treeSelectionSelectPath sel treePath+ col <- New.treeViewGetColumn treeView 0+ New.treeViewScrollToCell treeView treePath (fromJust col)+ (Just (0.3,0.3))+ case mbIdName of+ Nothing -> do+ selF <- New.treeViewGetSelection descrView+ New.treeSelectionUnselectAll selF+ Just symbol -> do+ mbDescrTree <- treeStoreGetTreeSave descrStore []+ selF <- New.treeViewGetSelection descrView+ case findPathFor symbol mbDescrTree of+ Nothing -> sysMessage Normal "no path found"+ Just path -> do+ New.treeSelectionSelectPath selF path+ col <- New.treeViewGetColumn descrView 0+ New.treeViewScrollToCell descrView path (fromJust col)+ (Just (0.3,0.3))++reloadKeepSelection :: IDEAction+reloadKeepSelection = do+ mbMod <- getPane+ case mbMod of+ Nothing -> return ()+ Just mods@(IDEModules _ _ treeView treeStore descrView descrStore _ _ _ _ _)+ -> do+ mbTreeSelection <- liftIO $ getSelectionTree treeView treeStore+ mbDescrSelection <- liftIO $ getSelectionDescr descrView descrStore+ sc <- getScope+ fillModulesList sc+ liftIO $ New.treeStoreClear descrStore+ let mbs = (case mbTreeSelection of+ Nothing -> Nothing+ Just (_,[]) -> Nothing+ Just (_,((md,_):_)) -> Just (modu $ moduleIdMD md),+ case mbDescrSelection of+ Nothing -> Nothing+ Just fw -> Just (descrName fw))+ selectNames mbs+++treeStoreGetTreeSave :: New.TreeStore a -> TreePath -> IO (Maybe (Tree a))+treeStoreGetTreeSave treeStore treePath = catch (do+ res <- New.treeStoreGetTree treeStore treePath+ return (Just res)) (\ (_ :: SomeException) -> return Nothing)++expandHere :: TreeView -> IO ()+expandHere treeView = do+ sel <- treeViewGetSelection treeView+ paths <- treeSelectionGetSelectedRows sel+ case paths of+ [] -> return ()+ (hd:_) -> treeViewExpandRow treeView hd True >> return ()++collapseHere :: TreeView -> IO ()+collapseHere treeView = do+ sel <- treeViewGetSelection treeView+ paths <- treeSelectionGetSelectedRows sel+ case paths of+ [] -> return ()+ (hd:_) -> treeViewCollapseRow treeView hd >> return ()++addModule :: TreeView -> TreeStore (String, [(ModuleDescr,PackageDescr)]) -> IDEAction+addModule treeView store = do+ sel <- liftIO $ treeViewGetSelection treeView+ paths <- liftIO $ treeSelectionGetSelectedRows sel+ case paths of+ [] -> return ()+ (treePath:_) -> do+ categories <- liftIO $ mapM (treeStoreGetValue store)+ $ map (\n -> take n treePath) [1 .. length treePath]+ mbPD <- getPackageDescriptionAndPath+ case mbPD of+ Nothing -> ideMessage Normal "No package description"+ Just (pd,cabalPath) -> let srcPaths = concatMap hsSourceDirs $ allBuildInfo pd+ rootPath = dropFileName cabalPath+ modPath = foldr (\a b -> a ++ "." ++ b) ""+ (map fst categories)+ in do+ mbResp <- liftIO $ addModuleDialog modPath srcPaths+ case mbResp of+ Nothing -> return ()+ Just (AddModule modPath srcPath isExposed) ->+ let splitter = split '.' modPath+ (modPaths,[modName])= splitAt (length splitter - 1) splitter+ targetPath = foldl' (</>) (rootPath </> srcPath) modPaths+ targetFile = targetPath </> (modName ++ ".hs")+ in do+ liftIO $ createDirectoryIfMissing True targetPath+ alreadyExists <- liftIO $ doesFileExist targetFile+ if alreadyExists+ then ideMessage Normal "File already exists"+ else do+ template <- liftIO $ getModuleTemplate pd modName+ liftIO $ writeFile targetFile template+ addModuleToPackageDescr+ (forceJust (simpleParse modPath)+ ("Modules>>addModule Can't parse module name " ++ modPath))+ isExposed+ packageConfig+ rebuildActiveInfo+ trace ("now openening " ++ targetFile) $ return ()+ fileOpenThis targetFile+++-- |* Yet another stupid little dialog++data AddModule = AddModule {moduleName :: String, sourceRoot :: FilePath, isExposed :: Bool}++addModuleDialog :: String -> [String] -> IO (Maybe AddModule)+addModuleDialog modString sourceRoots = do+ dia <- dialogNew+ windowSetTitle dia "Construct new module"+ upper <- dialogGetUpper dia+ lower <- dialogGetActionArea dia+ (widget,inj,ext,_) <- buildEditor (moduleFields sourceRoots)+ (AddModule modString (head sourceRoots) False)+ (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 (AddModule modString (head sourceRoots) False)+ widgetDestroy dia+ --find+ case resp of+ ResponseOk -> return value+ _ -> return Nothing++moduleFields :: [FilePath] -> FieldDescription AddModule+moduleFields list = VFD emptyParams [+ mkField+ (paraName <<<- ParaName ("New module ")+ $ emptyParams)+ moduleName+ (\ a b -> b{moduleName = a})+ (stringEditor (\s -> True)),+ mkField+ (paraName <<<- ParaName ("Root of the source path")+ $ paraMultiSel <<<- ParaMultiSel False+ $ emptyParams)+ (\a -> [sourceRoot a])+ (\ a b -> b{sourceRoot = forceHead a "Modules>>moduleFields"})+ (staticListEditor list),+ mkField+ (paraName <<<- ParaName ("Is this an exposed library module")+ $ emptyParams)+ isExposed+ (\ a b -> b{isExposed = a})+ boolEditor]++-- * GUI History++data SelectionState = SelectionState {+ moduleS' :: Maybe ModuleName+, facetS' :: Maybe String+, scope' :: Scope+, blacklist' :: Bool}+ deriving (Eq,Ord,Show)++recordSelHistory :: IDEAction+recordSelHistory = do+ mods <- getModules+ 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)+ let selFacet = case selDescr of+ Nothing -> Nothing+ Just descr -> Just (descrName descr)+ oldSel <- liftIO $ readIORef (oldSelection mods)+ triggerEvent ideR (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 mbModName mbFacetName = do+ mods <- getModules+ selectNames (mbModName, mbFacetName)+ oldSel <- liftIO $ readIORef (oldSelection mods)+ liftIO $ writeIORef (oldSelection mods)+ (oldSel{moduleS'= mbModName, facetS' = mbFacetName})++recordScopeHistory :: IDEAction+recordScopeHistory = do+ (sc,bl) <- getScope+ ideR <- ask+ mods <- getModules+ oldSel <- liftIO $ readIORef (oldSelection mods)+ triggerEvent ideR (RecordHistory ((ScopeSelected sc bl),+ (ScopeSelected (scope' oldSel) (blacklist' oldSel))))+ liftIO $ writeIORef (oldSelection mods) (oldSel{scope'= sc, blacklist' = bl})+ return ()++replayScopeHistory :: Scope -> Bool -> IDEAction+replayScopeHistory sc bl = do+ mods@(IDEModules _ _ _ _ _ _ localScopeB packageScopeB worldScopeB blacklistB _)+ <- getModules+ liftIO $ do+ toggleButtonSetActive blacklistB bl+ toggleButtonSetActive localScopeB (sc == Local)+ toggleButtonSetActive packageScopeB (sc == Package)+ toggleButtonSetActive worldScopeB (sc == System)+ setScope (sc,bl)+ oldSel <- liftIO $ readIORef (oldSelection mods)+ liftIO $ writeIORef (oldSelection mods) (oldSel{scope'= sc, blacklist' = bl})
+ src/IDE/Pane/PackageEditor.hs view
@@ -0,0 +1,724 @@+{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses+ -XTypeSynonymInstances #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.PackageEditor+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | Module for editing of cabal packages and build infos+--+-----------------------------------------------------------------------------------+++module IDE.Pane.PackageEditor (+ packageNew'+, packageEdit+, choosePackageDir+, choosePackageFile++, hasConfigs+) where++import Graphics.UI.Gtk+import Control.Monad.Reader+import Distribution.Package+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.SpecialEditors+import Graphics.UI.Editor.MakeEditor+import Distribution.PackageDescription.Parse (readPackageDescription,writePackageDescription)+import Distribution.PackageDescription.Configuration (freeVars,flattenPackageDescription)+import Distribution.ModuleName(ModuleName)+import Data.Typeable (Typeable(..))+import Debug.Trace (trace)+import IDE.Metainfo.InterfaceCollector (getInstalledPackageInfos)+import qualified Distribution.InstalledPackageInfo as IPI (package)+import Graphics.UI.Editor.Composite (maybeEditor,pairEditor,ColumnDescr(..),multisetEditor)+import qualified Graphics.UI.Gtk as New (cellText)+import Distribution.Text (simpleParse,display)+import MyMissing+import Graphics.UI.Editor.Parameters (Parameter(..),paraPack,Direction(..),paraDirection,paraMinSize,paraShadow,paraSynopsis,(<<<-),emptyParams,paraName,getParameterPrim)+import Graphics.UI.Editor.Simple (boolEditor,fileEditor,comboSelectionEditor,multilineStringEditor,stringEditor)+import Distribution.License (License(..))++-- ---------------------------------------------------------------------+-- 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++choosePackageFile :: Window -> IO (Maybe FilePath)+choosePackageFile window = do+ dialog <- fileChooserDialogNew+ (Just $ "Select file of project")+ (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++packageEdit :: IDEAction+packageEdit = do+ mbActivePackage <- readIDE activePack+ case mbActivePackage of+ Nothing -> sysMessage Normal "No active package to edit"+ Just idePackage -> do+ let dirName = dropFileName (cabalFile idePackage)+ modules <- liftIO $ allModules dirName+ package <- liftIO $ readPackageDescription normal (cabalFile idePackage)+ if hasConfigs package+ then do+ ideMessage High ("Cabal File with configurations can't be edited with the"+ ++ "Current version of the editor")+ return ()+ else do+ editPackage (flattenPackageDescription package) dirName modules (\ _ -> return ())+ return ()++hasConfigs :: GenericPackageDescription -> Bool+hasConfigs gpd =+ let freeVars1 = case condLibrary gpd of+ Nothing -> []+ Just ct -> freeVars ct+ freeVars2 = concatMap (freeVars . snd) (condExecutables gpd)+ in trace ("freeVars " ++ show freeVars1 ++ "-" ++ show freeVars2)+ $ not (null freeVars1 && null freeVars2)++packageNew' :: (FilePath -> IDEAction) -> IDEAction+packageNew' activateAction = do+ window <- readIDE window+ mbDirName <- liftIO $ choosePackageDir window+ case mbDirName of+ Nothing -> return ()+ Just dirName -> do+ cfn <- liftIO $ cabalFileName dirName+ continue <- do+ if isJust cfn+ then liftIO $ do+ md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo+ $ "There is already a .cabal file in this directory."+ ++ " Continue anyway?"+ rid <- dialogRun md+ widgetDestroy md+ case rid of+ ResponseYes -> return True+ otherwise -> return False+ else return True+ when continue $ do+ modules <- liftIO $ do+ b1 <- doesFileExist (dirName </> "Setup.hs")+ b2 <- doesFileExist (dirName </> "Setup.lhs")+ if not (b1 || b2)+ then do+ sysMessage Normal "Setup.(l)hs does not exist. Writing Standard"+ writeFile (dirName </> "Setup.lhs") standardSetup+ else sysMessage Normal "Setup.(l)hs already exist"+ allModules dirName+ editPackage emptyPackageDescription{buildType = Just Simple} dirName modules activateAction+ return ()++standardSetup = "#!/usr/bin/runhaskell \n"+ ++ "> module Main where\n"+ ++ "> import Distribution.Simple\n"+ ++ "> main :: IO ()\n"+ ++ "> main = defaultMain\n\n"++-- ---------------------------------------------------------------------+-- | We do some twist for handling build infos seperately to edit them in one editor together+-- with the other stuff. This type show what we really edit here+--++data PackageDescriptionEd = PDE {+ pd :: PackageDescription,+ exes :: [Executable'],+ mbLib :: Maybe Library',+ bis :: [BuildInfo]}++fromEditor :: PackageDescriptionEd -> PackageDescription+fromEditor (PDE pd exes' mbLib' buildInfos) =+ let exes = map (\ (Executable' s fb bii) -> if bii + 1 > length buildInfos+ then Executable s fb (buildInfos !! (length buildInfos - 1))+ else Executable s fb (buildInfos !! bii)) exes'+ mbLib = case mbLib' of+ Nothing -> Nothing+ Just (Library' mn b bii) -> if bii + 1 > length buildInfos+ then Just (Library mn b (buildInfos !! (length buildInfos - 1)))+ else Just (Library mn b (buildInfos !! bii))+ in pd {library = mbLib, executables = exes}++toEditor :: PackageDescription -> PackageDescriptionEd+toEditor pd =+ let (exes,bis) = unzip $ map (\ ((Executable s fb bi), i) -> (Executable' s fb i, bi))+ (zip (executables pd) [0 .. length (executables pd)])+ (mbLib,bis2) = case library pd of+ Nothing -> (Nothing,bis)+ Just (Library mn b bi) -> (Just (Library' mn b (length bis)), bis ++ [bi])+ bis3 = if null bis2+ then [emptyBuildInfo]+ else bis2+ in PDE (pd {library = Nothing , executables = []}) exes mbLib bis3++-- ---------------------------------------------------------------------+-- The pane stuff+--++data PackagePane = PackagePane {+ packageBox :: VBox+} deriving Typeable++instance IDEObject PackagePane++data PackageState = PackageState+ deriving (Read, Show, Typeable)++instance Pane PackagePane IDEM+ where+ primPaneName _ = "Package"+ getAddedIndex _ = 0+ getTopWidget = castToWidget . packageBox+ paneId b = "*Package"+ makeActive p = activatePane p []+ close pane = do+ (panePath,_) <- guiPropertiesFromName (paneName pane)+ nb <- getNotebook panePath+ mbI <- liftIO $notebookPageNum nb (getTopWidget pane)+ case mbI of+ Nothing -> liftIO $ do+ sysMessage Normal "notebook page not found: unexpected"+ return ()+ Just i -> do+ deactivatePaneIfActive pane+ liftIO $ do+ notebookRemovePage nb i+ widgetDestroy (getTopWidget pane)+ removePaneAdmin pane++instance RecoverablePane PackagePane PackageState IDEM where+ saveState p = return Nothing+ recoverState pp st = return ()++editPackage :: PackageDescription -> FilePath -> [ModuleName] -> (FilePath -> IDEAction) -> IDEAction+editPackage packageD packagePath modules afterSaveAction = do+ mbPane :: Maybe PackagePane <- getPane+ case mbPane of+ Nothing -> do+ ideR <- ask+ prefs <- readIDE prefs+ layout <- readIDE layout+ let pp = getStandardPanePath (sourcePanePath prefs) layout+ nb <- getNotebook pp+ packageInfos <- lift $ getInstalledPackageInfos+ let packageEd = toEditor packageD+ initPackage packagePath packageEd+ (packageDD+ (map IPI.package packageInfos)+ (takeDirectory packagePath)+ modules+ (length (bis packageEd))+ (concatMap (buildInfoD (Just (takeDirectory packagePath)) modules)+ [0..length (bis packageEd) - 1]))+ pp nb modules afterSaveAction+ Just p -> liftIO $ bringPaneToFront p++initPackage :: FilePath+ -> PackageDescriptionEd+ -> FieldDescription PackageDescriptionEd+ -> PanePath+ -> Notebook+ -> [ModuleName]+ -> (FilePath -> IDEAction)+ -> IDEM ()+initPackage packageDir packageD packageDescr panePath nb2 modules afterSaveAction = do+ let fields = trace ("initPackage called " ++ packageDir) $ flattenFieldDescription packageDescr+ let initialPackagePath = packageDir </> (display . pkgName . package . pd) packageD ++ ".cabal"+ liftIO $ setCurrentDirectory packageDir+ panes <- readIDE panes+ window <- readIDE window+ paneMap <- readIDE paneMap+ currentInfo <- readIDE currentInfo+ packageInfos <- lift $ getInstalledPackageInfos+ (buf,cids) <- reifyIDE $ \ideR session -> do+ vb <- vBoxNew False 0+ let packagePane = PackagePane vb+ bb <- hButtonBoxNew+ restore <- buttonNewFromStock "Revert"+ save <- buttonNewFromStock "gtk-save"+ closeB <- buttonNewFromStock "gtk-close"+ addB <- buttonNewFromStock "Add Build Info"+ removeB <- buttonNewFromStock "Remove Build Info"+ boxPackStart bb addB PackNatural 0+ boxPackStart bb removeB PackNatural 0+ boxPackStart bb restore PackNatural 0+ boxPackStart bb save PackNatural 0+ boxPackStart bb closeB PackNatural 0+ (widget, setInj, getExt, notifier) <- buildEditor packageDescr packageD+ let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of+ Just s -> s+ Nothing -> "Unnamed") fields+ save `onClicked` (do+ mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames+ case mbNewPackage' of+ Nothing -> return ()+ Just newPackage' -> let newPackage = fromEditor newPackage' in do+ let packagePath = packageDir </> (display . pkgName . package . pd) newPackage'+ ++ ".cabal"+ writePackageDescription packagePath newPackage+ reflectIDE (afterSaveAction packagePath) ideR session)+ closeB `onClicked` (do+ mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames+ case mbNewPackage' of+ Nothing -> do+ md <- messageDialogNew Nothing [] MessageQuestion ButtonsYesNo+ "Package does not validate. Close anyway?"+ rid <- dialogRun md+ widgetDestroy md+ case rid of+ ResponseYes -> (reflectIDE (close packagePane) ideR session)+ otherwise -> return ()+ Just newPackage -> do+ let packagePath = packageDir </> (display . pkgName . package . pd) newPackage+ modified <- do+ exists <- liftIO $ doesFileExist packagePath+ if exists+ then do+ packageNow <- readPackageDescription normal packagePath+ let simpleNow = flattenPackageDescription packageNow+ case mbNewPackage' of+ Nothing -> return True --doesn't validate, so something has changed+ Just pd -> return (fromEditor pd /=+ simpleNow{buildDepends = reverse (buildDepends simpleNow)})+ else return False+ cancel <- if modified+ then do+ md <- messageDialogNew (Just window) []+ MessageQuestion+ ButtonsNone+ ("Save changes to Cabal file: "+ ++ packagePath+ ++ "?")+ dialogAddButton md "_Save" ResponseYes+ dialogAddButton md "_Don't Save" ResponseNo+ dialogAddButton md "_Cancel" ResponseCancel+ resp <- dialogRun md+ widgetDestroy md+ case resp of+ ResponseYes -> do+ case mbNewPackage' of+ Nothing -> return False+ Just newPackage' -> let newPackage = fromEditor newPackage' in do+ let PackageIdentifier (PackageName n) v = package newPackage+ writePackageDescription packagePath newPackage+ return False+ ResponseCancel -> return True+ ResponseNo -> return False+ _ -> return False+ else return False+ when (not cancel) (reflectIDE (close packagePane) ideR session))+ restore `onClicked` (do+ package <- readPackageDescription normal initialPackagePath+ setInj (toEditor (flattenPackageDescription package)))+ addB `onClicked` (do+ mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames+ case mbNewPackage' of+ Nothing -> sysMessage Normal "Content doesn't validate"+ Just pde -> do+ reflectIDE (do+ close packagePane+ initPackage packageDir pde {bis = bis pde ++ [bis pde !! 0]}+ (packageDD+ (map IPI.package packageInfos)+ packageDir+ modules+ (length (bis pde) + 1)+ (concatMap (buildInfoD (Just packageDir) modules)+ [0..length (bis pde)]))+ panePath nb2 modules afterSaveAction) ideR session)+ removeB `onClicked` (do+ mbNewPackage' <- extractAndValidate packageD [getExt] fieldNames+ case mbNewPackage' of+ Nothing -> sysMessage Normal "Content doesn't validate"+ Just pde | length (bis pde) == 1 -> sysMessage Normal "Just one Build Info"+ | otherwise -> reflectIDE (do+ close packagePane+ initPackage packageDir pde{bis = take (length (bis pde) - 1) (bis pde)}+ (packageDD+ (map IPI.package packageInfos)+ packageDir+ modules+ (length (bis pde) - 1)+ (concatMap (buildInfoD (Just packageDir) modules)+ [0..length (bis pde) - 2]))+ panePath nb2 modules afterSaveAction) ideR session)+ boxPackStart vb widget PackGrow 7+ boxPackEnd vb bb PackNatural 7+ widgetShowAll vb+ i <- notebookInsertOrdered nb2 vb (paneName packagePane) Nothing+ return (packagePane,[])+ addPaneAdmin buf [] panePath+ liftIO $widgetGrabFocus (packageBox buf)++-- ---------------------------------------------------------------------+-- The description with some tricks+--++packageDD :: [PackageIdentifier]+ -> FilePath+ -> [ModuleName]+ -> Int+ -> [(String, FieldDescription PackageDescriptionEd)]+ -> FieldDescription PackageDescriptionEd+packageDD packages fp modules numBuildInfos extras = NFD ([+ ("Package", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Synopsis"+ $ paraSynopsis <<<- ParaSynopsis "A one-line summary of this package"+ $ emptyParams)+ (synopsis . pd)+ (\ a b -> b{pd = (pd b){synopsis = a}})+ (stringEditor (const True))+ , mkField+ (paraName <<<- ParaName "Package Identifier" $ emptyParams)+ (package . pd)+ (\ a b -> b{pd = (pd b){package = a}})+ packageEditor+ , mkField+ (paraName <<<- ParaName "Description"+ $ paraSynopsis <<<- ParaSynopsis "A more verbose description of this package"+ $ paraShadow <<<- ParaShadow ShadowOut+ $ paraMinSize <<<- ParaMinSize (-1,250)+ $ emptyParams)+ (description . pd)+ (\ a b -> b{pd = (pd b){description = if null a then " \n\n\n\n\n" else a}})+ multilineStringEditor+ , mkField+ (paraName <<<- ParaName "Homepage" $ emptyParams)+ (homepage . pd)+ (\ a b -> b{pd = (pd b){homepage = a}})+ (stringEditor (const True))+ , mkField+ (paraName <<<- ParaName "Package URL" $ emptyParams)+ (pkgUrl . pd)+ (\ a b -> b{pd = (pd b){pkgUrl = a}})+ (stringEditor (const True))+ , mkField+ (paraName <<<- ParaName "Category" $ emptyParams)+ (category . pd)+ (\ a b -> b{pd = (pd b){category = a}})+ (stringEditor (const True))+ ]),+ ("Description", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Stability" $ emptyParams)+ (stability . pd)+ (\ a b -> b{pd = (pd b){stability = a}})+ (stringEditor (const True))+ , mkField+ (paraName <<<- ParaName "License" $ emptyParams)+ (license . pd)+ (\ a b -> b{pd = (pd b){license = a}})+ (comboSelectionEditor [GPL, LGPL, BSD3, BSD4, PublicDomain, AllRightsReserved, OtherLicense])+ , mkField+ (paraName <<<- ParaName "License File" $ emptyParams)+ (licenseFile . pd)+ (\ a b -> b{pd = (pd b){licenseFile = a}})+ (fileEditor (Just fp) FileChooserActionOpen "Select file")+ , mkField+ (paraName <<<- ParaName "Copyright" $ emptyParams)+ (copyright . pd)+ (\ a b -> b{pd = (pd b){copyright = a}})+ (stringEditor (const True))+ , mkField+ (paraName <<<- ParaName "Author" $ emptyParams)+ (author . pd)+ (\ a b -> b{pd = (pd b){author = a}})+ (stringEditor (const True))+ , mkField+ (paraName <<<- ParaName "Maintainer" $ emptyParams)+ (maintainer . pd)+ (\ a b -> b{pd = (pd b){maintainer = a}})+ (stringEditor (const True))+ ]),+ ("Dependencies ", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Build Dependencies"+ $ paraSynopsis <<<- ParaSynopsis "Does this package depends on other packages?"+ $ paraDirection <<<- ParaDirection Vertical+ $ paraPack <<<- ParaPack PackGrow+ $ emptyParams)+ (reverse . buildDepends . pd)+ (\ a b -> b{pd = (pd b){buildDepends = a}})+ (dependenciesEditor packages)+ ]),+ ("Meta Dep.", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Cabal version"+ $ paraSynopsis <<<- ParaSynopsis+ "Does this package depends on a specific version of Cabal?"+ $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)+ (descCabalVersion . pd)+ (\ a b -> b{pd = (pd b){descCabalVersion = a}})+ versionRangeEditor+ , mkField+ (paraName <<<- ParaName "Tested with compiler"+ $ paraShadow <<<- ParaShadow ShadowIn+ $ paraDirection <<<- ParaDirection Vertical+ $ emptyParams)+ (\a -> case (testedWith . pd) a of+ [] -> []--(GHC,AnyVersion)]+ l -> l)+ (\ a b -> b{pd = (pd b){testedWith = a}})+ testedWidthEditor+ ]),+ ("Extra Files", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Data Files"+ $ paraSynopsis <<<- ParaSynopsis+ "A list of files to be installed for run-time use by the package."+ $ paraDirection <<<- ParaDirection Vertical+ $ paraMinSize <<<- ParaMinSize (-1,130)+ $ emptyParams)+ (dataFiles . pd)+ (\ a b -> b{pd = (pd b){dataFiles = a}})+ (filesEditor (Just fp) FileChooserActionOpen "Select File")+ , mkField+ (paraName <<<- ParaName "Extra Source Files"+ $ paraSynopsis <<<- ParaSynopsis+ "A list of additional files to be included in source distributions."+ $ paraDirection <<<- ParaDirection Vertical+ $ paraMinSize <<<- ParaMinSize (-1,130)+ $ emptyParams)+ (extraSrcFiles . pd)+ (\ a b -> b{pd = (pd b){extraSrcFiles = a}})+ (filesEditor (Just fp) FileChooserActionOpen "Select File")+ , mkField+ (paraName <<<- ParaName "Extra Tmp Files"+ $ paraSynopsis <<<- ParaSynopsis+ "A list of additional files or directories to be removed by setup clean."+ $ paraDirection <<<- ParaDirection Vertical+ $ paraMinSize <<<- ParaMinSize (-1,130)+ $ emptyParams)+ (extraTmpFiles . pd)+ (\ a b -> b{pd = (pd b){extraTmpFiles = a}})+ (filesEditor (Just fp) FileChooserActionOpen "Select File")+ ]),+ ("Executables",VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Executables"+ $ paraSynopsis <<<- ParaSynopsis+ "Describe executable programs contained in the package"+ $ paraDirection <<<- ParaDirection Vertical $ emptyParams)+ exes+ (\ a b -> b{exes = a})+ (executablesEditor (Just fp) modules numBuildInfos)+ ]),+ ("Library", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Library"+ $ paraSynopsis <<<- ParaSynopsis+ "If the package contains a library, specify the exported modules here"+ $ paraDirection <<<- ParaDirection Vertical+ $ paraPack <<<- ParaPack PackGrow+ $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)+ mbLib+ (\ a b -> b{mbLib = a})+ (maybeEditor (libraryEditor (Just fp) modules numBuildInfos,+ paraName <<<- ParaName "Specify exported modules"+ $ paraPack <<<- ParaPack PackGrow+ $ emptyParams) True+ "Does this package contain a library?")+ ])+ ] ++ extras)++update :: [BuildInfo] -> Int -> (BuildInfo -> BuildInfo) -> [BuildInfo]+update bis index func =+ map (\(bi,ind) -> if ind == index+ then func bi+ else bi)+ (zip bis [0..length bis - 1])++buildInfoD :: Maybe FilePath -> [ModuleName] -> Int -> [(String,FieldDescription PackageDescriptionEd)]+buildInfoD fp modules i = [+ (show (i + 1) ++ " Build Info", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Component is buildable here" $ emptyParams)+ (buildable . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{buildable = a})})+ boolEditor+ , mkField+ (paraName <<<- ParaName+ "Where to look for the source hierarchy"+ $ paraSynopsis <<<- ParaSynopsis+ "Root directories for the source hierarchy."+ $ paraShadow <<<- ParaShadow ShadowIn+ $ paraDirection <<<- ParaDirection Vertical+ $ emptyParams)+ (hsSourceDirs . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{hsSourceDirs = a})})+ (filesEditor fp FileChooserActionSelectFolder "Select folder")+ , mkField+ (paraName <<<- ParaName "Non-exposed or non-main modules"+ $ paraSynopsis <<<- ParaSynopsis ("A list of modules used by the component but "+ ++ "not exposed to users.")+ $ paraShadow <<<- ParaShadow ShadowIn+ $ paraDirection <<<- ParaDirection Vertical+ $ paraMinSize <<<- ParaMinSize (-1,400)+ $ paraPack <<<- ParaPack PackGrow+ $ emptyParams)+ (map display. otherModules . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi ->+ bi{otherModules = (map (\i -> forceJust (simpleParse i)+ " PackageEditor >> buildInfoD: no parse for moduile name" ) a)})})+ (modulesEditor modules)+ ]),+ (show (i + 1) ++ " Compiler ", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Options for haskell compilers"+ $ paraDirection <<<- ParaDirection Vertical+ $ paraShadow <<<- ParaShadow ShadowIn+ $ paraPack <<<- ParaPack PackGrow $ emptyParams)+ (options . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{options = a})})+ (multisetEditor+ (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv])+ ,("Options",\(_,op) -> [New.cellText := concatMap (\s -> ' ' : s) op])])+ ((pairEditor+ (compilerFlavorEditor,emptyParams)+ (stringsEditor (const True),emptyParams)),+ (paraDirection <<<- ParaDirection Vertical+ $ paraMinSize <<<- ParaMinSize (-1,400)+ $ paraPack <<<- ParaPack PackGrow+ $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)))+ , mkField+ (paraName <<<- ParaName "Additional options for GHC when built with profiling"+ $ paraDirection <<<- ParaDirection Vertical+ $ emptyParams)+ (ghcProfOptions . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{ghcProfOptions = a})})+ (stringsEditor (const True))+ ]),+ (show (i + 1) ++ " Extensions ", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Extensions"+ $ paraSynopsis <<<- ParaSynopsis+ "A list of Haskell extensions used by every module."+ $ paraMinSize <<<- ParaMinSize (-1,400)+ $ paraPack <<<- ParaPack PackGrow+ $ emptyParams)+ (extensions . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{extensions = a})})+ extensionsEditor+ ]),+ (show (i + 1) ++ " Opts C ", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Options for C compiler"+ $ paraDirection <<<- ParaDirection Vertical+ $ emptyParams)+ (ccOptions . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{ccOptions = a})})+ (stringsEditor (const True))+ , mkField+ (paraName <<<- ParaName "Options for linker"+ $ paraDirection <<<- ParaDirection Vertical+ $ emptyParams)+ (ldOptions . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{ldOptions = a})})+ (stringsEditor (const True))+ , mkField+ (paraName <<<- ParaName "A list of header files already installed on the system"+ $ paraDirection <<<- ParaDirection Vertical $ emptyParams)+ (includes . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{includes = a})})+ (stringsEditor (const True))+ , mkField+ (paraName <<<- ParaName "A list of header files from this package"+ $ paraDirection <<<- ParaDirection Vertical $ emptyParams)+ (installIncludes . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{installIncludes = a})})+ (filesEditor fp FileChooserActionOpen "Select File")+ ]),+ (show (i + 1) ++ " More Opts C", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "A list of directories to search for header files"+ $ paraDirection <<<- ParaDirection Vertical $ emptyParams)+ (includeDirs . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{includeDirs = a})})+ (filesEditor fp FileChooserActionSelectFolder "Select Folder")+ , mkField+ (paraName <<<- ParaName+ "A list of C source files to be compiled,linked with the Haskell files."+ $ paraDirection <<<- ParaDirection Vertical $ emptyParams)+ (cSources . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{cSources = a})})+ (filesEditor fp FileChooserActionOpen "Select file")+ , mkField+ (paraName <<<- ParaName "A list of extra libraries to link with"+ $ paraDirection <<<- ParaDirection Vertical $ emptyParams)+ (extraLibs . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{extraLibs = a})})+ (stringsEditor (const True))+ , mkField+ (paraName <<<- ParaName "A list of directories to search for libraries."+ $ paraDirection <<<- ParaDirection Vertical $ emptyParams)+ (extraLibDirs . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{extraLibDirs = a})})+ (filesEditor fp FileChooserActionSelectFolder "Select Folder")+ ]),+ (show (i + 1) ++ " Opts OSX", VFD emptyParams [+ mkField+ (paraName <<<- ParaName "Support frameworks for Mac OS X"+ $ paraDirection <<<- ParaDirection Vertical $ emptyParams)+ (cSources . (\a -> a !! i) . bis)+ (\ a b -> b{bis = update (bis b) i (\bi -> bi{cSources = a})})+ (stringsEditor (const True))+ ])]+
+ src/IDE/Pane/PackageFlags.hs view
@@ -0,0 +1,268 @@+{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses+ -XTypeSynonymInstances #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.PackageFlags+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+--+-- | Module for saving, restoring and editing projectFlags+--+---------------------------------------------------------------------------------+++module IDE.Pane.PackageFlags (+ readFlags+, writeFlags+, getFlags+, IDEFlags(..)+, FlagsState+) 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 Control.Event (registerEvent)+import IDE.DescriptionPP (extractFieldDescription,FieldDescriptionPP(..),+ mkFieldPP,flattenFieldDescriptionPP)++data IDEFlags = IDEFlags {+ flagsBox :: VBox+} deriving Typeable++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 pane = do+ (panePath,_) <- guiPropertiesFromName (paneName pane)+ nb <- getNotebook panePath+ mbI <- liftIO $notebookPageNum nb (getTopWidget pane)+ case mbI of+ Nothing -> liftIO $ do+ sysMessage Normal "notebook page not found: unexpected"+ return ()+ Just i -> do+ deactivatePaneIfActive pane+ liftIO $ do+ notebookRemovePage nb i+ widgetDestroy (getTopWidget pane)+ removePaneAdmin pane++instance RecoverablePane IDEFlags FlagsState IDEM where+ saveState p = do+ mbFlags :: Maybe IDEFlags <- getPane+ case mbFlags of+ Nothing -> return Nothing+ Just p -> return (Just FlagsState)+ recoverState pp st = do+ mbPack <- readIDE activePack+ case mbPack of+ Just pack -> do+ nb <- getNotebook pp+ initFlags pack pp nb+ Nothing -> return ()+++concatString :: [String] -> String+concatString l = foldl' (\r s -> if null r then s else r ++ " " ++ s) "" l++flatFlagsDescription :: [FieldDescriptionPP IDEPackage]+flatFlagsDescription = flattenFieldDescriptionPP flagsDescription++flagsDescription :: FieldDescriptionPP IDEPackage+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]})+ (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]})+ (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]})+ (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]})+ (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]})+ (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]})+ (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]})+ (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]})+ (stringEditor (const True))+ (\ _ -> return ())]++-- ------------------------------------------------------------+-- * Parsing+-- ------------------------------------------------------------++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"++-- ------------------------------------------------------------+-- * Printing+-- ------------------------------------------------------------++writeFlags :: FilePath -> IDEPackage -> IO ()+writeFlags fpath flags =+ writeFile fpath (showFlags 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+ prefs <- readIDE prefs+ layout <- readIDE layout+ let pp = getStandardPanePath (sourcePanePath prefs) layout+ 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+ (buf,cids) <- reifyIDE $ \ ideR session -> 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 -> return (ide{activePack = Just packWithNewFlags}))+ close flagsPane) ideR session -- we don't trigger the activePack event here+ writeFlags ((dropFileName (cabalFile packWithNewFlags)) </> "IDE.flags")+ packWithNewFlags)+ closeB `onClicked` (reflectIDE (close flagsPane) ideR session)+ registerEvent notifier FocusIn (Left (\e -> do+ reflectIDE (makeActive flagsPane) ideR session+ return (e{gtkReturn=False})))+ boxPackStart vb sw PackGrow 7+ boxPackEnd vb bb PackNatural 7+ notebookInsertOrdered nb vb (paneName flagsPane) Nothing+ widgetShowAll vb+ return (flagsPane,[])+ addPaneAdmin buf [] panePath+ liftIO $widgetGrabFocus (flagsBox buf)+++
+ src/IDE/Pane/Preferences.hs view
@@ -0,0 +1,467 @@+{-# OPTIONS_GHC -XScopedTypeVariables -XDeriveDataTypeable -XMultiParamTypeClasses+ -XTypeSynonymInstances #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.Preferences+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+--+-- | Module for saving, restoring and editing preferences+--+---------------------------------------------------------------------------------+++module IDE.Pane.Preferences (+ IDEPrefs(..)+, PrefsState+, readPrefs+, writePrefs+, defaultPrefs+, prefsDescription+, editPrefs+) where++import Graphics.UI.Gtk.SourceView+import Graphics.UI.Gtk+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+import Data.Typeable++import Control.Event+import Graphics.UI.Editor.Basics+import IDE.Core.State+import Graphics.UI.Editor.Simple+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 IDE.Pane.SourceBuffer+import IDE.Pane.Log+import IDE.SpecialEditors+import Default+import IDE.FileUtils+import System.IO+import Distribution.InstalledPackageInfo (package)++--+-- | The Preferences Pane+--++data IDEPrefs = IDEPrefs {+ prefsBox :: VBox+} deriving Typeable++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 pane = do+ (panePath,_) <- guiPropertiesFromName (paneName pane)+ nb <- getNotebook panePath+ mbI <- liftIO $notebookPageNum nb (getTopWidget pane)+ case mbI of+ Nothing -> liftIO $ do+ sysMessage Normal "notebook page not found: unexpected"+ return ()+ Just i -> do+ deactivatePaneIfActive pane+ liftIO $ do+ notebookRemovePage nb i+ widgetDestroy (getTopWidget pane)+ removePaneAdmin pane++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+ prefs <- readIDE prefs+ layout <- readIDE layout+ let pp = getStandardPanePath (sourcePanePath prefs) layout+ 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 <- lift $ getInstalledPackageInfos+ let flatPrefsDesc = flattenFieldDescriptionPP (prefsDescription (map package packageInfos))+ prefs <- readIDE prefs+ lastAppliedPrefsRef <- liftIO $ newIORef prefs+ panes <- readIDE panes+ paneMap <- readIDE paneMap+ currentInfo <- readIDE currentInfo+ (buf,cids) <- reifyIDE $ \ideR session -> 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 session) flatPrefsDesc+ writeIORef lastAppliedPrefsRef newPrefs)+ restore `onClicked` (do+ lastAppliedPrefs <- readIORef lastAppliedPrefsRef+ mapM_ (\ (FDPP _ _ _ _ applyF) -> reflectIDE (applyF prefs lastAppliedPrefs) ideR session) 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 session) flatPrefsDesc+ fp <- getConfigFilePathForSave "Default.prefs"+ writePrefs fp newPrefs+ reflectIDE (modifyIDE_ (\ide -> return (ide{prefs = newPrefs}))) ideR session)+ closeB `onClicked` (reflectIDE (close prefsPane) ideR session)+ registerEvent notifier FocusIn (Left (\e -> do+ reflectIDE (makeActive prefsPane) ideR session+ return (e{gtkReturn=False})))+ notebookInsertOrdered nb2 vb (paneName prefsPane) Nothing+ widgetShowAll vb+ return (prefsPane,[])+ addPaneAdmin buf [] panePath+ liftIO $widgetGrabFocus (prefsBox buf)+++-- ------------------------------------------------------------+-- * Dialog definition+-- ------------------------------------------------------------++prefsDescription :: [PackageIdentifier] -> FieldDescriptionPP Prefs+prefsDescription packages = NFDPP [+ ("Editor", VFDPP emptyParams [+ mkFieldPP+ (paraName <<<- ParaName "Show line numbers"+ $ paraSynopsis <<<- ParaSynopsis "(True/False)" $ emptyParams)+ (PP.text . show)+ boolParser+ showLineNumbers+ (\ b a -> a{showLineNumbers = b})+ boolEditor+ (\b -> do+ buffers <- allBuffers+ mapM_ (\buf -> liftIO$sourceViewSetShowLineNumbers (sourceView buf) b) buffers)+ , mkFieldPP+ (paraName <<<- ParaName "TextView Font" $ emptyParams)+ (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))+ (do str <- stringParser+ return (if null str then Nothing else Just (str)))+ textviewFont+ (\ b a -> a{textviewFont = b})+ 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)+ , mkFieldPP+ (paraName <<<- ParaName "Right margin"+ $ paraSynopsis <<<- ParaSynopsis "Size or 0 for no right margin"+ $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)+ (\a -> (PP.text . show) (case a of Nothing -> 0; Just i -> i))+ (do i <- intParser+ return (if i == 0 then Nothing else Just i))+ rightMargin+ (\b a -> a{rightMargin = b})+ (maybeEditor (intEditor (1.0, 200.0, 5.0), paraName <<<- ParaName "Position"+ $ emptyParams)+ 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)+ , mkFieldPP+ (paraName <<<- ParaName "Tab width" $ emptyParams)+ (PP.text . show)+ intParser+ tabWidth+ (\b a -> a{tabWidth = b})+ (intEditor (1.0, 20.0, 1.0))+ (\i -> do+ buffers <- allBuffers+ mapM_ (\buf -> liftIO $sourceViewSetIndentWidth (sourceView buf) i) buffers)+ , mkFieldPP+ (paraName <<<- ParaName "Use standard line ends even on windows" $ emptyParams)+ (PP.text . show)+ boolParser+ forceLineEnds+ (\b a -> a{forceLineEnds = b})+ boolEditor+ (\i -> return ())+ , mkFieldPP+ (paraName <<<- ParaName "Remove trailing blanks when saving a file" $ emptyParams)+ (PP.text . show)+ boolParser+ removeTBlanks+ (\b a -> a{removeTBlanks = b})+ boolEditor+ (\i -> return ())+ , mkFieldPP+ (paraName <<<- ParaName "Source candy"+ $ paraSynopsis <<<- ParaSynopsis+ "Empty for do not use or the name of a candy file in a config dir"+ $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)+ (\a -> PP.text (case a of Nothing -> ""; Just s -> s))+ (do id <- identifier+ return (if null id then Nothing else Just (id)))+ sourceCandy (\b a -> a{sourceCandy = b})+ (maybeEditor ((stringEditor (\s -> not (null s))), paraName <<<- ParaName "Candy specification"+ $ emptyParams)+ True "Use it ?")+ (\cs -> case cs of+ Nothing -> do+ setCandyState False+ editCandy+ Just name -> do+ setCandyState True+ editCandy)+ , mkFieldPP+ (paraName <<<- ParaName "Editor Style" $ emptyParams)+ (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))+ (do str <- stringParser+ return (if null str then Nothing else Just (str)))+ sourceStyle+ (\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)+ ]),+ ("GUI Options", VFDPP emptyParams [+ mkFieldPP+ (paraName <<<- ParaName "LogView Font" $ emptyParams)+ (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))+ (do str <- stringParser+ return (if null str then Nothing else Just (str)))+ logviewFont+ (\ b a -> a{logviewFont = b})+ fontEditor+ (\mbs -> do+ buffer <- getLog+ fdesc <- liftIO $fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "")+ liftIO $widgetModifyFont (castToWidget $textView buffer) (Just fdesc))+ , mkFieldPP+ (paraName <<<- ParaName "Window default size"+ $ paraSynopsis <<<- ParaSynopsis+ "Default size of the main ide window specified as pair (int,int)"+ $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)+ (PP.text.show)+ (pairParser intParser)+ defaultSize (\(c,d) a -> a{defaultSize = (c,d)})+ (pairEditor ((intEditor (0.0, 3000.0, 25.0)),+ paraName <<<- ParaName "X" $ emptyParams)+ ((intEditor (0.0, 3000.0, 25.0)),+ paraName <<<- ParaName "Y" $ emptyParams))+ (\a -> return ())+ , mkFieldPP+ (paraName <<<- ParaName "Browser" $ emptyParams)+ (PP.text . show)+ stringParser+ browser+ (\b a -> a{browser = b})+ (stringEditor (\s -> not (null s)))+ (\i -> return ())+ , mkFieldPP+ (paraName <<<- ParaName "Standard source pane path" $ emptyParams)+ (PP.text . show)+ readParser+ sourcePanePath+ (\b a -> a{sourcePanePath = b})+ panePathEditor+ (\i -> return ())+ , mkFieldPP+ (paraName <<<- ParaName "Standard log pane path" $ emptyParams)+ (PP.text . show)+ readParser+ logPanePath+ (\b a -> a{logPanePath = b})+ panePathEditor+ (\i -> return ())+ , mkFieldPP+ (paraName <<<- ParaName "Standard modules pane path" $ emptyParams)+ (PP.text . show)+ readParser+ modulesPanePath+ (\b a -> a{modulesPanePath = b})+ panePathEditor+ (\i -> return ())+ , mkFieldPP+ (paraName <<<- ParaName "Name of the keymap"+ $ paraSynopsis <<<- ParaSynopsis+ "The name of a keymap file in a config dir"+ $ paraDirection <<<- ParaDirection Horizontal $ emptyParams)+ PP.text+ identifier+ keymapName+ (\b a -> a{keymapName = b})+ (stringEditor (\s -> not (null s)))+ (\ a -> return ())+ ]),+ ("Metadata", VFDPP emptyParams [+ mkFieldPP+ (paraName <<<- ParaName+ "Paths under which haskell sources for packages may be found" $ emptyParams)+ (PP.text . show)+ readParser+ sourceDirectories+ (\b a -> a{sourceDirectories = b})+ (filesEditor Nothing FileChooserActionSelectFolder "Select folder")+ (\i -> return ())+ , mkFieldPP+ (paraName <<<- ParaName+ "Packages which are excluded from the modules pane" $ emptyParams)+ (PP.text . show)+ readParser+ packageBlacklist+ (\b a -> a{packageBlacklist = b})+ (dependenciesEditor packages)+ (\i -> return ())+ , mkFieldPP+ (paraName <<<- ParaName "Update metadata after every build" $ emptyParams)+ (PP.text . show)+ boolParser+ collectAfterBuild+ (\b a -> a{collectAfterBuild = b})+ boolEditor+ (\i -> return ())+ , mkFieldPP+ (paraName <<<- ParaName "Update metadata at startup" $ emptyParams)+ (PP.text . show)+ boolParser+ collectAtStart+ (\b a -> a{collectAtStart = b})+ boolEditor+ (\i -> return ())+ ])]++instance Default PackageIdentifier where+ getDefault = case toPackageIdentifier "unknown-0" of+ Nothing -> throwIDE "Preferences.getDefault: Can't parse Package Identifier"+ Just it -> it++defaultPrefs = Prefs {+ showLineNumbers = True+ , rightMargin = Just 100+ , tabWidth = 4+ , sourceCandy = Just("Default")+ , keymapName = "Default"+ , forceLineEnds = True+ , removeTBlanks = True+ , textviewFont = Nothing+ , sourceStyle = Nothing+ , logviewFont = Nothing+ , defaultSize = (1024,800)+ , browser = "firefox"+ , sourcePanePath = [LeftP]+ , logPanePath = [RightP,BottomP]+ , modulesPanePath = [RightP,TopP]+ , sourceDirectories = []+ , packageBlacklist = []+ , collectAfterBuild = False+ , collectAtStart = True+ }++-- ------------------------------------------------------------+-- * Parsing+-- ------------------------------------------------------------++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"++-- ------------------------------------------------------------+-- * Printing+-- ------------------------------------------------------------++writePrefs :: FilePath -> Prefs -> IO ()+writePrefs fpath prefs = writeFile fpath (showPrefs prefs (flattenFieldDescriptionPP (prefsDescription [])))++showPrefs :: a -> [FieldDescriptionPP a] -> String+showPrefs prefs prefsDesc = PP.render $+ foldl (\ doc (FDPP _ printer _ _ _) -> doc PP.$+$ printer prefs) PP.empty prefsDesc+
+ src/IDE/Pane/Search.hs view
@@ -0,0 +1,365 @@+{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances+ -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.Search+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | The pane of ide where metadata searches can be done+--+-------------------------------------------------------------------------------++module IDE.Pane.Search (+ IDESearch(..)+, SearchState+, showSearch+, setChoices+, searchMetaGUI+) where++import Graphics.UI.Gtk hiding (get)+import qualified Graphics.UI.Gtk.ModelView as New+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 Debug.Trace (trace)+import IDE.Metainfo.Provider (searchMeta)+import Data.Maybe+import Control.Monad.Reader+--import Distribution.Package+import Data.Typeable+import IDE.Core.State+import Distribution.Text(display)+import Control.Event (triggerEvent)++-- | A search pane description+--++data IDESearch = IDESearch {+ scrolledView :: ScrolledWindow+, treeView :: New.TreeView+, searchStore :: New.ListStore Descr+, searchStringRef :: IORef String+, searchScopeRef :: IORef Scope+, searchModeRef :: IORef SearchMode+, topBox :: VBox+} deriving Typeable++data SearchState = SearchState {+ searchString :: String+, searchScope :: Scope+, 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 pane = do+ (panePath,_) <- guiPropertiesFromName (paneName pane)+ nb <- getNotebook panePath+ mbI <- liftIO $notebookPageNum nb (getTopWidget pane)+ case mbI of+ Nothing -> liftIO $ do+ sysMessage Normal "notebook page not found: unexpected"+ return ()+ Just i -> do+ deactivatePaneIfActive pane+ liftIO $ do+ notebookRemovePage nb i+ widgetDestroy (getTopWidget pane)+ removePaneAdmin pane++instance RecoverablePane IDESearch SearchState IDEM where+ saveState p = do+ str <- liftIO $ readIORef (searchStringRef p)+ mode <- liftIO $ readIORef (searchModeRef p)+ scope <- liftIO $ readIORef (searchScopeRef p)+ return (Just (SearchState str scope mode))+ recoverState pp (SearchState str scope mode) = do+ nb <- getNotebook pp+ initSearch pp nb scope mode+ searchMetaGUI str++showSearch :: IDEAction+showSearch = do+ m <- getSearch+ liftIO $ bringPaneToFront m+ liftIO $ widgetGrabFocus (treeView m)++getSearch :: IDEM IDESearch+getSearch = do+ mbSearch <- getPane+ case mbSearch of+ Just m -> return m+ Nothing -> do+ prefs <- readIDE prefs+ layout <- readIDE layout+ let pp = getStandardPanePath (modulesPanePath prefs) layout+ nb <- getNotebook pp+ initSearch pp nb System (Prefix False)+ mbSearch <- getPane+ case mbSearch of+ Nothing -> throwIDE "Can't init search"+ Just m -> return m+++initSearch :: PanePath -> Notebook -> Scope -> SearchMode -> IDEAction+initSearch panePath nb scope mode = do+ panes <- readIDE panes+ paneMap <- readIDE paneMap+ prefs <- readIDE prefs+ currentInfo <- readIDE currentInfo+ (buf,cids) <- reifyIDE $ \ideR session -> 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++ 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 <- New.listStoreNew []+ treeView <- New.treeViewNew+ New.treeViewSetModel treeView listStore+++ renderer3 <- New.cellRendererTextNew+ renderer30 <- New.cellRendererPixbufNew+ col3 <- New.treeViewColumnNew+ New.treeViewColumnSetTitle col3 "Symbol"+ New.treeViewColumnSetSizing col3 TreeViewColumnAutosize+ New.treeViewColumnSetResizable col3 True+ New.treeViewColumnSetReorderable col3 True+ New.treeViewAppendColumn treeView col3+ New.cellLayoutPackStart col3 renderer30 False+ New.cellLayoutPackStart col3 renderer3 True+ New.cellLayoutSetAttributes col3 renderer3 listStore+ $ \row -> [ New.cellText := descrName row]+ New.cellLayoutSetAttributes col3 renderer30 listStore+ $ \row -> [+ New.cellPixbufStockId := stockIdFromType ((descrType . details) row)]+++ renderer1 <- New.cellRendererTextNew+ renderer10 <- New.cellRendererPixbufNew+ col1 <- New.treeViewColumnNew+ New.treeViewColumnSetTitle col1 "Module"+ New.treeViewColumnSetSizing col1 TreeViewColumnAutosize+ New.treeViewColumnSetResizable col1 True+ New.treeViewColumnSetReorderable col1 True+ New.treeViewAppendColumn treeView col1+ New.cellLayoutPackStart col1 renderer10 False+ New.cellLayoutPackStart col1 renderer1 True+ New.cellLayoutSetAttributes col1 renderer1 listStore+ $ \row -> [ New.cellText := display $ modu $ descrModu' row]+ New.cellLayoutSetAttributes col1 renderer10 listStore+ $ \row -> [+ New.cellPixbufStockId := if isReexported row+ then "ide_reexported"+ else if isJust (mbLocation row)+ then "ide_source"+ else ""]++ renderer2 <- New.cellRendererTextNew+ col2 <- New.treeViewColumnNew+ New.treeViewColumnSetTitle col2 "Package"+ New.treeViewColumnSetSizing col2 TreeViewColumnAutosize+ New.treeViewColumnSetResizable col2 True+ New.treeViewColumnSetReorderable col2 True+ New.treeViewAppendColumn treeView col2+ New.cellLayoutPackStart col2 renderer2 True+ New.cellLayoutSetAttributes col2 renderer2 listStore+ $ \row -> [ New.cellText := display $ pack $ descrModu' row]++ New.treeViewSetHeadersVisible treeView True+ sel <- New.treeViewGetSelection treeView+ New.treeSelectionSetMode sel SelectionSingle++ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw treeView+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic++ box <- vBoxNew False 2+ boxPackStart box scopebox PackNatural 0+ boxPackStart box sw PackGrow 0+ boxPackEnd box modebox PackNatural 0+ stringRef <- newIORef ""+ scopeRef <- newIORef scope+ modeRef <- newIORef mode+ let search = IDESearch sw treeView listStore stringRef scopeRef modeRef box+ notebookInsertOrdered nb box (paneName search) Nothing+ widgetShowAll box++ cid1 <- treeView `afterFocusIn`+ (\_ -> do reflectIDE (makeActive search) ideR session; return True)+ rb1 `onToggled` (reflectIDE (scopeSelection Local) ideR session)+ rb2 `onToggled` (reflectIDE (scopeSelection Package) ideR session)+ rb3 `onToggled` (reflectIDE (scopeSelection System) ideR session)+ mb1 `onToggled` do+ widgetSetSensitivity mb4 False+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelection (Exact active)) ideR session)+ mb2 `onToggled`do+ widgetSetSensitivity mb4 True+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelection (Prefix active)) ideR session)+ mb3 `onToggled` do+ widgetSetSensitivity mb4 True+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelection (Regex active)) ideR session)+ mb4 `onToggled` do+ active <- toggleButtonGetActive mb4+ (reflectIDE (modeSelectionCase active) ideR session)+ treeView `onButtonPress` (listViewPopup ideR session listStore treeView)+ sel `New.onSelectionChanged` do+ fillInfo treeView listStore ideR session+ return ()+ return (search,[ConnectC cid1])+ addPaneAdmin buf cids panePath+ liftIO $widgetGrabFocus (scrolledView buf)++getScope :: IDESearch -> IO Scope+getScope search = readIORef (searchScopeRef search)++getMode :: IDESearch -> IO SearchMode+getMode search = readIORef (searchModeRef search)++scopeSelection :: Scope -> IDEAction+scopeSelection scope = do+ search <- getSearch+ liftIO $ writeIORef (searchScopeRef search) scope+ text <- liftIO $ readIORef (searchStringRef search)+ searchMetaGUI text++modeSelection :: SearchMode -> IDEAction+modeSelection mode = do+ search <- getSearch+ liftIO $ writeIORef (searchModeRef search) mode+ text <- liftIO $ readIORef (searchStringRef search)+ searchMetaGUI text++modeSelectionCase :: Bool -> IDEAction+modeSelectionCase caseSense = do+ search <- getSearch+ oldMode <- liftIO $ readIORef (searchModeRef search)+ liftIO $ writeIORef (searchModeRef search) oldMode{caseSense = caseSense}+ text <- liftIO $ readIORef (searchStringRef search)+ searchMetaGUI text++searchMetaGUI :: String -> IDEAction+searchMetaGUI str = do+ search <- getSearch+ liftIO $ writeIORef (searchStringRef search) str+ scope <- liftIO $ getScope search+ mode <- liftIO $ getMode search+ let mode' = if length str > 2 then mode else Exact (caseSense mode)+ descrs <- if null str+ then return []+ else searchMeta scope str mode'+ liftIO $do+ New.listStoreClear (searchStore search)+ mapM_ (New.listStoreAppend (searchStore search)) descrs+ bringPaneToFront search++listViewPopup :: IDERef+ -> Session+ -> New.ListStore Descr+ -> New.TreeView+ -> Event+ -> IO (Bool)+listViewPopup ideR session store descrView (Button _ click _ _ _ _ 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 session+ otherwise -> sysMessage Normal "no selection"+ 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 session >> return ()+ otherwise -> sysMessage Normal "no selection"+ return True+ else do+ mbPane :: Maybe IDEInfo <- reflectIDE getPane ideR session+ when (isJust mbPane) $ bringPaneToFront (fromJust mbPane)+ return False+listViewPopup _ _ _ _ _ = throwIDE "listViewPopup wrong event type"++getSelectionDescr :: New.TreeView+ -> New.ListStore Descr+ -> IO (Maybe Descr)+getSelectionDescr treeView listStore = do+ treeSelection <- New.treeViewGetSelection treeView+ paths <- New.treeSelectionGetSelectedRows treeSelection+ case paths of+ [a]:r -> do+ val <- New.listStoreGetValue listStore a+ return (Just val)+ _ -> return Nothing++fillInfo :: New.TreeView+ -> New.ListStore Descr+ -> IDERef+ -> Session+ -> IO ()+fillInfo treeView listStore ideR session = do+ sel <- getSelectionDescr treeView listStore+ case sel of+ Just descr -> reflectIDE (setInfo descr) ideR session+ otherwise -> sysMessage Normal "no selection"++setChoices :: [Descr] -> IDEAction+setChoices descrs = do+ search <- getSearch+ liftIO $ do+ New.listStoreClear (searchStore search)+ mapM_ (New.listStoreAppend (searchStore search)) descrs+ bringPaneToFront search+ writeIORef (searchStringRef search) ""++
+ src/IDE/Pane/SourceBuffer.hs view
@@ -0,0 +1,1036 @@+{-# OPTIONS_GHC -XDeriveDataTypeable -XMultiParamTypeClasses -XTypeSynonymInstances #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Pane.SourceBuffer+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | The source editor part of Leksah+--+-----------------------------------------------------------------------------------++module IDE.Pane.SourceBuffer (+ IDEBuffer(..)+, BufferState(..)+++, allBuffers+, maybeActiveBuf+, standardSourcePanePath+, selectSourceBuf+, goToSourceDefinition+, goToDefinition++, newTextBuffer++, fileNew+, fileOpenThis+, fileOpen+, fileRevert+, fileClose+, fileCloseAll+, fileCloseAllButPackage+, fileSave+, editUndo+, editRedo+, editCut+, editCopy+, editPaste+, editDelete+, editSelectAll++, editComment+, editUncomment+, editShiftRight+, editShiftLeft++, editToCandy+, editFromCandy+, editKeystrokeCandy+, editCandy++, markErrorInSourceBuf+, inBufContext'+, inBufContext++, align+) where++import Graphics.UI.Gtk hiding (afterToggleOverwrite)+import Graphics.UI.Gtk.SourceView+import Graphics.UI.Gtk.Multiline.TextView+import Control.Monad.Reader+--import Data.IORef+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.Maybe+import Data.Typeable+import System.Time+--import GHC.Conc+--import Debug.Trace++import IDE.Core.State+import Control.Event+import IDE.FileUtils+import IDE.SourceCandy+import qualified System.IO.UTF8 as UTF8+import Graphics.UI.Gtk.Gdk.Enums (Modifier(..))+import qualified Graphics.UI.Gtk.Gdk.Events as G (Event(..))++--+-- | A text editor pane description+--+data IDEBuffer = IDEBuffer {+ fileName :: Maybe FilePath+, bufferName :: String+, addedIndex :: Int+, sourceView :: SourceView+, scrolledWindow :: ScrolledWindow+, modTime :: Maybe (ClockTime)+, language :: Maybe String+} deriving (Typeable)++data BufferState = BufferState FilePath 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 buf = do+ (PaneC pane) <- paneFromName (paneName buf)+ let mbActbuf = cast pane+ if isJust mbActbuf+ then do+ let actbuf = fromJust mbActbuf+ ideR <- ask+ sbLC <- getStatusbarLC+ sbIO <- getStatusbarIO+ infos <- readIDE accessibleInfo+ let sv = sourceView actbuf+ (cids) <- reifyIDE $ \ideR session -> do+ gtkBuf <- textViewGetBuffer sv+ bringPaneToFront actbuf+ writeCursorPositionInStatusbar sv sbLC+ writeOverwriteInStatusbar sv sbIO+ id1 <- gtkBuf `afterModifiedChanged` reflectIDE (markLabelAsChanged) ideR session+ 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 session+ return False)+ id6 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv sbIO+ return [ConnectC id2,ConnectC id6,ConnectC id1,ConnectC id3]+ activatePane actbuf cids+ liftIO $+ idleAdd (do+ widgetQueueDraw sv -- Patch for problem on one machine ##+ return False) priorityDefaultIdle+ modifyIDE_ (\ide -> return (ide{lastActiveBufferPane = Just (paneName buf)}))+ triggerEvent ideR (Sensitivity [(SensitivityEditor, True)])+ checkModTime actbuf+ else return ()+ close pane = do makeActive pane+ fileClose+ return ()++controlIsPressed :: G.Event -> Bool+controlIsPressed (G.Button _ _ _ _ _ mods _ _ _) | Control `elem` mods = True+controlIsPressed _ = False++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+ case fileName p of+ Nothing -> return Nothing+ Just fn -> return (Just (BufferState fn offset))+ recoverState pp (BufferState n i) = do+ exists <- liftIO $doesFileExist n+ when exists $ do+ buf <- newTextBuffer pp (takeFileName n) (Just n)+ 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))+ return False) priorityDefaultIdle+ return ()++selectSourceBuf :: FilePath -> IDEM (Maybe IDEBuffer)+selectSourceBuf fp = do+ fpc <- liftIO $ canonicalizePath fp+ buffers <- allBuffers+ let buf = filter (\b -> case fileName b of+ Just fn -> equalFilePath fn fpc+ Nothing -> False) buffers+ case buf of+ hdb:tl -> do+ makeActive hdb+ return (Just hdb)+ otherwise -> do+ fe <- liftIO $ doesFileExist fpc+ if fe+ then do+ path <- standardSourcePanePath+ nbuf <- newTextBuffer path (takeFileName fpc) (Just fpc)+ return (Just nbuf)+ else 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"++goToSourceDefinition :: FilePath -> Maybe Location -> IDEAction+goToSourceDefinition fp mbLocation = do+ mbBuf <- selectSourceBuf fp+ when (isJust mbBuf && isJust mbLocation) $+ inBufContext () $ \_ gtkbuf buf _ -> do+ let location = fromJust mbLocation+ lines <- textBufferGetLineCount gtkbuf+ iter <- textBufferGetIterAtLine gtkbuf (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)+ ((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+ -- ### we had a problem before using this idleAdd thing+ idleAdd (do+ textViewScrollToIter (sourceView buf) iter 0.0 (Just (0.3,0.3))+ return False) priorityDefaultIdle+ return ()+++markErrorInSourceBuf :: Int -> Int -> String -> IDEAction+markErrorInSourceBuf line column string =+ inBufContext () $ \_ gtkbuf buf _ -> do+ i1 <- textBufferGetStartIter gtkbuf+ i2 <- textBufferGetEndIter gtkbuf+ textBufferRemoveTagByName gtkbuf "activeErr" i1 i2++ lines <- textBufferGetLineCount gtkbuf+ iter <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) (line-1)))+ chars <- textIterGetCharsInLine iter+ textIterSetLineOffset iter (max 0 (min (chars-1) column))+ iter2 <- textIterCopy iter+ textIterForwardWordEnd iter2+ textBufferApplyTagByName gtkbuf "activeErr" iter iter2+ textBufferPlaceCursor gtkbuf iter+ mark <- textBufferGetInsert gtkbuf+ idleAdd (do+ textViewScrollToMark (sourceView buf) mark 0.3 Nothing+ return False) priorityDefaultIdle+ return ()++allBuffers :: IDEM [IDEBuffer]+allBuffers = getPanes++maybeActiveBuf :: IDEM (Maybe IDEBuffer)+maybeActiveBuf = do+ mbPane <- readIDE lastActiveBufferPane+ case mbPane of+ Nothing -> return Nothing+ Just paneName -> do+ (PaneC pane) <- paneFromName paneName+ let mbActbuf = cast pane+ return mbActbuf++standardSourcePanePath :: IDEM PanePath+standardSourcePanePath = do+ layout <- readIDE layout+ prefs <- readIDE prefs+ return (getStandardPanePath (sourcePanePath prefs) layout)++newTextBuffer :: PanePath -> String -> Maybe FilePath -> IDEM IDEBuffer+newTextBuffer panePath bn mbfn = do+ -- create the appropriate language+ nb <- getNotebook panePath+ panes <- readIDE panes+ paneMap <- readIDE paneMap+ prefs <- readIDE prefs+ bs <- getCandyState+ ct <- readIDE candy+ let (ind,rbn) = figureOutPaneName panes bn 0+ (buf,cids) <- reifyIDE $ \ideR session -> 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+ activeErrtag <- textTagNew (Just "activeErr")+ set activeErrtag[textTagUnderline := UnderlineError]+ textTagTableAdd tagTable activeErrtag++ -- load up and display a file+ (fileContents,modTime) <- case mbfn of+ Just fn -> do+ fc <- UTF8.readFile fn+ mt <- getModificationTime fn+ return (fc,Just mt)+ Nothing -> return ("\n\n\n\n\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++ -- create a new SourceView Widget+ sv <- sourceViewNewWithBuffer buffer+ set sv [sourceViewHighlightCurrentLine := True]+ fd <- case textviewFont prefs of+ Just str -> do+ fontDescriptionFromString str+ Nothing -> do+ f <- fontDescriptionNew+ fontDescriptionSetFamily f "Monospace"+ return f+ widgetModifyFont sv (Just fd)+ 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++ -- put it in a scrolled window+ sw <- scrolledWindowNew Nothing Nothing+ containerAdd sw sv+ scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic+ scrolledWindowSetShadowType sw ShadowIn++ let buf = IDEBuffer mbfn bn ind sv sw modTime mbLanguage+ notebookInsertOrdered nb sw rbn Nothing+ -- events+ cid <- sv `afterFocusIn`+ (\_ -> do reflectIDE (makeActive buf) ideR session; return False)+ return (buf,[cid])+ addPaneAdmin buf (map ConnectC cids) panePath+ liftIO $widgetShowAll (scrolledWindow buf)+ liftIO $widgetGrabFocus (sourceView buf)+ return buf++checkModTime :: IDEBuffer -> IDEAction+checkModTime buf = do+ isShuttingDown' <- readIDE isShuttingDown+ if isShuttingDown'+ then return ()+ else do+ panes <- readIDE panes+ let name = paneName buf+ case fileName buf of+ Just fn -> do+ exists <- liftIO $doesFileExist fn+ if exists+ then do+ nmt <- liftIO $getModificationTime fn+ case modTime buf of+ Nothing -> throwIDE $"checkModTime: time not set " ++ show (fileName buf)+ Just mt -> do+ --message $"checkModTime " ++ name ++ " " ++ show mt ++ " " ++ show nmt+ if nmt /= mt+ then do+ md <- liftIO $messageDialogNew+ Nothing []+ MessageQuestion+ ButtonsYesNo+ ("File has changed on disk " ++ name ++ " Revert?")+ resp <- liftIO $dialogRun md+ case resp of+ ResponseYes -> do+ revert buf+ liftIO $widgetHide md+ ResponseNo -> do+ let newPanes = Map.adjust (\(PaneC b) ->+ let mbActbuf = cast b+ in if isJust mbActbuf+ then PaneC ((fromJust mbActbuf)+ {modTime = (Just nmt)})+ else PaneC b)+ name panes+ modifyIDE_ (\ide -> return (ide{panes = newPanes}))+ liftIO $widgetHide md+ _ -> do return ()+ else return ()+ else return ()+ Nothing -> return ()++setModTime :: IDEBuffer -> IDEAction+setModTime buf = do+ panes <- readIDE panes+ let name = paneName buf+ case fileName buf of+ Nothing -> return ()+ Just fn -> do+ nmt <- liftIO $getModificationTime fn+ let newPanes = Map.adjust (\(PaneC b) ->+ let mbActbuf = cast b+ in if isJust mbActbuf+ then PaneC ((fromJust mbActbuf){modTime = (Just nmt)})+ else PaneC b)+ name panes+ modifyIDE_ (\ide -> return (ide{panes = newPanes}))++fileRevert :: IDEAction+fileRevert = inBufContext' () $ \ _ _ currentBuffer _ -> do+ revert currentBuffer++revert :: IDEBuffer -> IDEAction+revert buf = do+ useCandy <- getCandyState+ ct <- readIDE candy+ panes <- readIDE panes+ let name = paneName buf+ case fileName buf of+ Nothing -> return ()+ Just fn -> do+ mt <- liftIO $do+ buffer' <- textViewGetBuffer (sourceView buf)+ let buffer = castToSourceBuffer buffer'+ fc <- UTF8.readFile fn+ mt <- getModificationTime fn+ sourceBufferBeginNotUndoableAction buffer+ textBufferSetText buffer fc+ if useCandy+ then transformToCandy ct (castToTextBuffer buffer)+ else return ()+ sourceBufferEndNotUndoableAction buffer+ textBufferSetModified buffer False+ return mt+ let newPanes = Map.adjust (\(PaneC b) ->+ let mbActbuf = cast b+ in if isJust mbActbuf+ then PaneC ((fromJust mbActbuf){modTime = (Just mt)})+ else (PaneC b))+ name panes+ modifyIDE_ (\ide -> return (ide{panes = newPanes}))++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)+ return ()++writeOverwriteInStatusbar :: SourceView -> Statusbar -> IO()+writeOverwriteInStatusbar sv sb = do+ modi <- textViewGetOverwrite sv+ statusbarPop sb 1+ statusbarPush sb 1 $ if modi then "OVR" else "INS"+ return ()+++showInfo :: SourceView -> IDERef -> Session -> IO ()+showInfo sv ideR session = do+ buf <- textViewGetBuffer sv+ (l,r) <- textBufferGetSelectionBounds buf+ symbol <- textBufferGetText buf l r True+ reflectIDE (triggerEvent ideR (SelectInfo symbol)) ideR session+ return ()++markLabelAsChanged :: IDEAction+markLabelAsChanged = do+ mbPath <- getActivePanePath+ case mbPath of+ Nothing -> return ()+ Just path -> do+ nb <- getNotebook path+ mbBS <- maybeActiveBuf+ case mbBS of+ Nothing -> return ()+ Just buf -> liftIO $do+ gtkbuf <- textViewGetBuffer (sourceView buf)+ modified <- textBufferGetModified gtkbuf+ mbText <- notebookGetTabLabelText nb (scrolledWindow buf)+ label <- labelNew Nothing+ labelSetUseMarkup label True+ case mbText of+ Nothing -> return ()+ Just text -> labelSetMarkup label+ (if modified+ then "<span foreground=\"red\">" ++ text ++ "</span>"+ else text)+ notebookSetTabLabel nb (scrolledWindow buf) label++inBufContext' :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha ) -> IDEM alpha+inBufContext' def f = do+ mbBuf <- maybeActiveBuf+ case mbBuf of+ Nothing -> return def+ Just ideBuf -> do+ (pane,_) <- guiPropertiesFromName (paneName ideBuf)+ nb <- getNotebook pane+ mbI <- liftIO $notebookPageNum nb (scrolledWindow ideBuf)+ case mbI of+ Nothing -> liftIO $ do+ sysMessage Normal $ bufferName ideBuf ++ " notebook page not found: unexpected"+ return def+ Just i -> do+ gtkbuf <- liftIO $ textViewGetBuffer (sourceView ideBuf)+ f nb gtkbuf ideBuf i++inBufContext :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IO alpha ) -> IDEM alpha+inBufContext def f = inBufContext' def (\ a b c d -> liftIO $ f a b c d)++fileSave :: Bool -> IDEAction+fileSave query = inBufContext' () $ \ nb _ currentBuffer i -> do+ ideR <- ask+ window <- readIDE window+ bufs <- readIDE panes+ prefs <- readIDE prefs+ paneMap <- readIDE paneMap+ bs <- getCandyState+ candy <- readIDE candy+ (panePath,connects)+ <- guiPropertiesFromName (paneName currentBuffer)+ mbnbufsPm <- do+ let mbfn = fileName currentBuffer+ mbpage <- liftIO $notebookGetNthPage nb i+ case mbpage of+ Nothing -> throwIDE "fileSave: Page not found"+ Just page ->+ if isJust mbfn && query == False+ then do checkModTime currentBuffer+ liftIO $fileSave' (forceLineEnds prefs) (removeTBlanks prefs) currentBuffer bs candy $fromJust mbfn+ setModTime currentBuffer+ return Nothing+ else reifyIDE $ \ideR session -> do+ dialog <- fileChooserDialogNew+ (Just $ "Save File")+ (Just window)+ FileChooserActionSave+ [("gtk-cancel" --buttons to display+ ,ResponseCancel) --you can use stock buttons+ ,("gtk-save"+ , ResponseAccept)]+ widgetShow dialog+ response <- dialogRun dialog+ mbFileName <- case response of+ ResponseAccept -> fileChooserGetFilename dialog+ ResponseCancel -> return Nothing+ ResponseDeleteEvent-> return Nothing+ _ -> return Nothing+ widgetDestroy dialog+ case mbFileName of+ Nothing -> return Nothing+ Just fn -> do+ dfe <- doesFileExist fn+ resp <- if dfe+ then do md <- messageDialogNew (Just window) []+ MessageQuestion+ ButtonsYesNo+ "File already exist. Overwrite?"+ resp <- dialogRun md+ widgetHide md+ return resp+ else return ResponseYes+ case resp of+ ResponseYes -> do+ fileSave' (forceLineEnds prefs) (removeTBlanks prefs) currentBuffer bs candy fn+ modT <- getModificationTime fn+ let bn = takeFileName fn+ let bufs1 = Map.delete (paneName currentBuffer) bufs+ let (ind,rbn) = figureOutPaneName bufs1 bn 0+ cfn <- canonicalizePath fn+ let newBuffer = currentBuffer {fileName = Just cfn,+ bufferName = bn, addedIndex = ind, modTime = Just modT}+ let newBufs = Map.insert rbn (PaneC newBuffer) bufs1+ signalDisconnectAll connects+ cid1 <- (sourceView currentBuffer) `afterFocusIn`+ (\_ -> do reflectIDE (makeActive newBuffer) ideR session+ return True)+ let paneMap1 = Map.delete rbn paneMap+ let newPaneMap = Map.insert rbn+ (panePath,[ConnectC cid1]) paneMap+ label <- labelNew (Just rbn)+ notebookSetTabLabel nb page label+ return (Just (newBufs,newPaneMap))+ ResponseNo -> return Nothing+ _ -> return Nothing+ case mbnbufsPm of+ Just (nbufs,pm) -> modifyIDE_+ (\ide -> return (ide{panes = nbufs, paneMap = pm}))+ Nothing -> return ()+ where+ fileSave' :: Bool -> Bool -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IO()+ fileSave' forceLineEnds removeTBlanks ideBuf bs ct fn = do+ buf <- textViewGetBuffer $ 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)+ (\e -> do+ sysMessage Normal (show e)+ return False)+ textBufferSetModified buf (not succ)+ removeTrailingBlanks :: String -> String+ removeTrailingBlanks = reverse . dropWhile (\c -> c == ' ') . reverse++fileNew :: IDEAction+fileNew = do+ prefs <- readIDE prefs+ pp <- getActivePanePathOrStandard (sourcePanePath prefs)+ newTextBuffer pp "Unnamed" Nothing+ return ()++fileClose :: IDEM Bool+fileClose = inBufContext' True $ fileClose'++fileClose' :: Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool+fileClose' nb gtkbuf currentBuffer i = do+ window <- readIDE window+ bufs <- readIDE panes+ paneMap <- readIDE paneMap+ cancel <- reifyIDE $ \ideR session -> do+ modified <- textBufferGetModified gtkbuf+ if modified+ then do+ md <- messageDialogNew (Just window) []+ MessageQuestion+ ButtonsNone+ ("Save changes to document: "+ ++ paneName currentBuffer+ ++ "?")+ dialogAddButton md "_Save" ResponseYes+ dialogAddButton md "_Don't Save" ResponseNo+ dialogAddButton md "_Cancel" ResponseCancel+ resp <- dialogRun md+ widgetDestroy md+ case resp of+ ResponseYes -> do+ reflectIDE (fileSave False) ideR session+ return False+ ResponseCancel -> return True+ ResponseNo -> return False+ _ -> return False+ else return False+ if cancel+ then return False+ else do+ deactivatePane+ removePaneAdmin currentBuffer+ liftIO $ do+ notebookRemovePage nb i+ widgetDestroy (getTopWidget currentBuffer)+ return True+++fileCloseAll :: IDEM Bool+fileCloseAll = do+ bufs <- allBuffers+ if null bufs+ then return True+ else do+ makeActive (head bufs)+ r <- fileClose+ if r+ then fileCloseAll+ else return False+++fileCloseAllButPackage :: IDEAction+fileCloseAllButPackage = do+ mbActivePack <- readIDE activePack+ bufs <- allBuffers+ when (not (null bufs) && isJust mbActivePack) $ do+ mapM_ (close' (fromJust mbActivePack)) bufs+ where+ close' activePack 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+ gtkbuf <- liftIO $ textViewGetBuffer (sourceView buf)+ let dir = dropFileName $ cabalFile activePack+ when (isJust (fileName buf)) $ do+ modified <- liftIO $ textBufferGetModified gtkbuf+ when (not modified && not (isSubPath dir (fromJust (fileName buf))))+ $ do fileClose' nb gtkbuf buf i; return ()++fileOpen :: IDEAction+fileOpen = do+ window <- readIDE window+ prefs <- readIDE prefs+ mbFileName <- liftIO $ do+ dialog <- fileChooserDialogNew+ (Just $ "Open File")+ (Just window)+ FileChooserActionOpen+ [("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 ()+ Just fp -> fileOpenThis fp+++fileOpenThis :: FilePath -> IDEAction+fileOpenThis fp = do+ prefs <- readIDE prefs+ fpc <- liftIO $canonicalizePath fp+ buffers <- allBuffers+ let buf = filter (\b -> case fileName b of+ Just fn -> equalFilePath fn fpc+ Nothing -> False) buffers+ case buf of+ hdb:tl -> do+ md <- liftIO $messageDialogNew+ Nothing []+ MessageQuestion+ ButtonsYesNo+ ("Buffer already open. " +++ "Make active instead of opening a second time?")+ resp <- liftIO $dialogRun md+ liftIO $ widgetDestroy md+ case resp of+ ResponseNo -> reallyOpen prefs fpc+ _ -> makeActive hdb+ [] -> reallyOpen prefs fpc+ where+ reallyOpen prefs fpc = do+ pp <- standardSourcePanePath+ newTextBuffer pp (takeFileName fpc) (Just fpc)+ return ()++editUndo :: IDEAction+editUndo = inBufContext () $ \_ gtkbuf _ _ ->+ let sb = castToSourceBuffer gtkbuf in+ do canUndo <- sourceBufferGetCanUndo sb+ if canUndo+ then sourceBufferUndo sb+ else return ()++editRedo :: IDEAction+editRedo = inBufContext () $ \_ gtkbuf _ _ ->+ let sb = castToSourceBuffer gtkbuf in+ do canRedo <- sourceBufferGetCanRedo sb+ if canRedo+ then sourceBufferRedo sb+ else return ()++editDelete :: IDEAction+editDelete = inBufContext () $ \_ gtkbuf _ _ -> do+ textBufferDeleteSelection gtkbuf True True+ return ()++editSelectAll :: IDEAction+editSelectAll = inBufContext () $ \_ gtkbuf _ _ -> do+ start <- textBufferGetStartIter gtkbuf+ end <- textBufferGetEndIter gtkbuf+ textBufferSelectRange gtkbuf start end++editCut :: IDEAction+editCut = inBufContext () $ \_ gtkbuf _ _ -> do+ cb <- atomNew "GDK_SELECTION_CLIPBOARD"+ clip <- clipboardGet cb+ textBufferCutClipboard gtkbuf clip True++editCopy :: IDEAction+editCopy = inBufContext () $ \_ gtkbuf _ _ -> do+ cb <- atomNew "GDK_SELECTION_CLIPBOARD"+ clip <- clipboardGet cb+ textBufferCopyClipboard gtkbuf clip++editPaste :: IDEAction+editPaste = inBufContext () $ \_ gtkbuf _ _ -> do+ cb <- atomNew "GDK_SELECTION_CLIPBOARD"+ mark <- textBufferGetInsert gtkbuf+ iter <- textBufferGetIterAtMark gtkbuf mark+ clip <- clipboardGet cb+ textBufferPasteClipboard gtkbuf 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+ 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'+ return (startLine',endLineReal)++doForSelectedLines :: [a] -> (TextBuffer -> TextIter -> Int -> IO a) -> IDEM [a]+doForSelectedLines d f = inBufContext' d $ \_ gtkbuf currentBuffer _ -> liftIO $do+ (start,end) <- getStartAndEndLineOfSelection gtkbuf+ iter <- textBufferGetStartIter gtkbuf+ mapM (f gtkbuf iter) [start .. end]++editComment :: IDEAction+editComment = do+ doForSelectedLines [] $ \gtkbuf iter lineNr -> do+ textIterSetLine iter lineNr+ textBufferInsert gtkbuf iter "--"+ return ()++editUncomment :: IDEAction+editUncomment = do+ doForSelectedLines [] $ \gtkbuf iter lineNr -> do+ textIterSetLine iter lineNr+ iter2 <- textIterCopy iter+ textIterForwardChars iter 2+ str <- textIterGetText iter iter2+ if str == "--"+ then do textBufferDelete gtkbuf iter iter2+ else return ()+ return ()++editShiftLeft :: IDEAction+editShiftLeft = do+ prefs <- readIDE prefs+ let str = map (\_->' ') [1 .. (tabWidth prefs)]+ 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+ 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+ return (str1 == str)+ return (foldl' (&&) True boolList)+++editShiftRight :: IDEAction+editShiftRight = do+ prefs <- readIDE prefs+ let str = map (\_->' ') [1 .. (tabWidth prefs)]+ doForSelectedLines [] $ \gtkbuf iter lineNr -> do+ textIterSetLine iter lineNr+ textBufferInsert gtkbuf iter str+ return ()++editToCandy :: IDEAction+editToCandy = do+ ct <- readIDE candy+ inBufContext () $ \_ gtkbuf _ _ -> do+ transformToCandy ct gtkbuf++editFromCandy :: IDEAction+editFromCandy = do+ ct <- readIDE candy+ inBufContext () $ \_ gtkbuf _ _ -> do+ transformFromCandy ct gtkbuf++editKeystrokeCandy :: Maybe Char -> IDEAction+editKeystrokeCandy c = do+ ct <- readIDE candy+ inBufContext () $ \_ gtkbuf _ _ -> do+ keystrokeCandy ct c gtkbuf++editCandy :: IDEAction+editCandy = do+ ct <- readIDE candy+ buffers <- allBuffers+ gtkbufs <- liftIO $mapM (\ b -> textViewGetBuffer (sourceView b)) buffers+ bs <- getCandyState+ if bs+ then liftIO $mapM_ (transformToCandy ct) gtkbufs+ else liftIO $mapM_ (transformFromCandy ct) gtkbufs++alignChar :: Char -> IDEAction+alignChar char = do+ positions <- positionsOfChar+ let alignTo = foldl' max 0 (catMaybes (map snd positions))+ if (alignTo > 0)+ then alignChar (Map.fromList positions) alignTo+ 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+ return (lineNr, elemIndex char line)+ alignChar :: Map Int (Maybe Int) -> Int -> IDEM ()+ alignChar positions alignTo = do+ doForSelectedLines [] $ \gtkbuf iter lineNr -> do+ case lineNr `Map.lookup` positions of+ Just (Just n) -> do+ textIterSetLine iter lineNr+ textIterForwardChars iter n+ textBufferInsert gtkbuf iter (replicate (alignTo - n) ' ')+ _ -> return ()+ return ()++transChar :: Char -> Char+transChar ':' = toEnum 0x2237 --PROPORTION+transChar '>' = toEnum 0x2192 --RIGHTWARDS ARROW+transChar '<' = toEnum (toEnum 0x2190) --LEFTWARDS ARROW+transChar c = c++align :: Char -> IDEAction+align = alignChar . transChar++--+--alignEqual :: IDEAction+--alignEqual = alignChar '='+--+--alignRightArrow :: IDEAction+--alignRightArrow = alignChar (toEnum 0x2192) --RIGHTWARDS ARROW+--+--alignLeftArrow :: IDEAction+--alignLeftArrow = alignChar (toEnum 0x2190) --LEFTWARDS ARROW+--+--alignTypeOf :: IDEAction+--alignTypeOf = alignChar (toEnum 0x2237) --PROPORTION++--guessLanguage :: Maybe FilePath -> Maybe String+--guessLanguage Nothing = Just "Haskell"+--guessLanguage (Just fp) =+-- case takeExtension fp of+-- ".c" -> Just "C"+-- ".hs" -> Just "Haskell"+-- ".chs" -> Just "Haskell"+-- ".hsc" -> Just "Haskell"+-- ".lhs" -> Just "Literate Haskell"+-- ".haddock" -> Just "Haddock"+-- _ -> Nothing++{--+sourceLanguageForFilename :: SourceLanguageManager -> Maybe String -> IO (Maybe String, Maybe SourceLanguage)+sourceLanguageForFilename lm Nothing =+ liftM (\l -> (Just "haskell", Just l)) ()+sourceLanguageForFilename lm (Just filename) =+ let extension = takeExtension filename in do+ ids <- sourceLanguageManagerGetLanguageIds lm+ relevant <- filterM (\id -> do+ lang <- sourceLanguageManagerGetLanguage lm id+ globs <- sourceLanguageGetGlobs lang+ return (match extension globs)) ids+ case relevant of+ [] -> return (Nothing,Nothing)+ hd:_ -> liftM (\l -> (Just hd, Just l)) (sourceLanguageManagerGetLanguage lm hd)+ where+ match :: String -> [String] -> Bool+ match ext = not . null . filter (== ext) . map (drop 1)+--}+++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)+++++
− src/IDE/Preferences.hs
@@ -1,350 +0,0 @@------------------------------------------------------------------------------------ Module : IDE.Preferences--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable--------- | Module for saving, restoring and editing preferences----------------------------------------------------------------------------------------module IDE.Preferences (- readPrefs-, writePrefs-, defaultPrefs-, prefsDescription-, editPrefs-) where--import Graphics.UI.Gtk.SourceView-import Graphics.UI.Gtk-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--import IDE.Core.State-import IDE.Framework.ViewFrame-import IDE.Framework.SimpleEditors-import IDE.Framework.CompositeEditors-import IDE.Framework.Parameters-import IDE.Framework.MakeEditor hiding (fieldEditor,parameters)-import IDE.DescriptionPP-import IDE.PrinterParser hiding (fieldParser,parameters)-import IDE.SourceEditor-import IDE.Log-import IDE.SpecialEditors-import IDE.Utils.Default-import IDE.Utils.File---prefsDescription :: [(String,[FieldDescriptionPP Prefs])]-prefsDescription = [- ("Editor", [- mkFieldPP- (paraName <<<- ParaName "Show line numbers"- $ paraSynopsis <<<- ParaSynopsis "(True/False)" $ emptyParams)- (PP.text . show)- boolParser- showLineNumbers- (\ b a -> a{showLineNumbers = b})- boolEditor- (\b -> do- buffers <- allBuffers- mapM_ (\buf -> lift$sourceViewSetShowLineNumbers (sourceView buf) b) buffers)- , mkFieldPP- (paraName <<<- ParaName "TextView Font" $ emptyParams)- (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))- (do str <- stringParser- return (if null str then Nothing else Just (str)))- textviewFont- (\ b a -> a{textviewFont = b})- fontEditor- (\mbs -> do- buffers <- allBuffers- fdesc <- lift $fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "")- lift $mapM_ (\buf -> widgetModifyFont (castToWidget $sourceView buf) (Just fdesc)) buffers)- , mkFieldPP- (paraName <<<- ParaName "Right margin"- $ paraSynopsis <<<- ParaSynopsis "Size or 0 for no right margin"- $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)- (\a -> (PP.text . show) (case a of Nothing -> 0; Just i -> i))- (do i <- intParser- return (if i == 0 then Nothing else Just i))- rightMargin- (\b a -> a{rightMargin = b})- (maybeEditor (intEditor (1.0, 200.0, 5.0), paraName <<<- ParaName "Position"- $ emptyParams)- True "Show it ?")- (\b -> do- buffers <- allBuffers- mapM_ (\buf -> case b of- Just n -> do- lift $sourceViewSetMargin (sourceView buf) n- lift $sourceViewSetShowMargin (sourceView buf) True- Nothing -> lift $sourceViewSetShowMargin (sourceView buf) False)- buffers)- , mkFieldPP- (paraName <<<- ParaName "Tab width" $ emptyParams)- (PP.text . show)- intParser- tabWidth- (\b a -> a{tabWidth = b})- (intEditor (1.0, 20.0, 1.0))- (\i -> do- buffers <- allBuffers- mapM_ (\buf -> lift $sourceViewSetTabsWidth (sourceView buf) i) buffers)- , mkFieldPP- (paraName <<<- ParaName "Use standard line ends even on windows" $ emptyParams)- (PP.text . show)- boolParser- forceLineEnds- (\b a -> a{forceLineEnds = b})- boolEditor- (\i -> return ())- , mkFieldPP- (paraName <<<- ParaName "Source candy"- $ paraSynopsis <<<- ParaSynopsis- "Empty for do not use or the name of a candy file in a config dir"- $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)- (\a -> PP.text (case a of Nothing -> ""; Just s -> s))- (do id <- identifier- return (if null id then Nothing else Just (id)))- sourceCandy (\b a -> a{sourceCandy = b})- (maybeEditor (stringEditor, paraName <<<- ParaName "Candy specification"- $ emptyParams)- True "Use it ?")- (\cs -> case cs of- Nothing -> do- setCandyState False- editCandy- Just name -> do- setCandyState True- editCandy)- , mkFieldPP- (paraName <<<- ParaName "Name of the keymap"- $ paraSynopsis <<<- ParaSynopsis- "The name of a keymap file in a config dir"- $ paraDirection <<<- ParaDirection Horizontal $ emptyParams)- PP.text- identifier- keymapName- (\b a -> a{keymapName = b})- stringEditor- (\ a -> return ())- ]),- ("Other", [- mkFieldPP- (paraName <<<- ParaName "LogView Font" $ emptyParams)- (\a -> PP.text (case a of Nothing -> show ""; Just s -> show s))- (do str <- stringParser- return (if null str then Nothing else Just (str)))- logviewFont- (\ b a -> a{logviewFont = b})- fontEditor- (\mbs -> do- buffer <- getLog- fdesc <- lift $fontDescriptionFromString (case mbs of Just str -> str; Nothing -> "")- lift $widgetModifyFont (castToWidget $textView buffer) (Just fdesc))- , mkFieldPP- (paraName <<<- ParaName "Window default size"- $ paraSynopsis <<<- ParaSynopsis- "Default size of the main ide window specified as pair (int,int)"- $ paraShadow <<<- ParaShadow ShadowIn $ emptyParams)- (PP.text.show)- (pairParser intParser)- defaultSize (\(c,d) a -> a{defaultSize = (c,d)})- (pairEditor ((intEditor (0.0, 3000.0, 25.0)),- paraName <<<- ParaName "X" $ emptyParams)- ((intEditor (0.0, 3000.0, 25.0)),- paraName <<<- ParaName "Y" $ emptyParams))- (\a -> return ())- , mkFieldPP- (paraName <<<- ParaName "Browser" $ emptyParams)- (PP.text . show)- stringParser- browser- (\b a -> a{browser = b})- stringEditor- (\i -> return ())- , mkFieldPP- (paraName <<<- ParaName "Standard source editor path" $ emptyParams)- (PP.text . show)- readParser- sourcePanePath- (\b a -> a{sourcePanePath = b})- panePathEditor- (\i -> return ())- , mkFieldPP- (paraName <<<- ParaName- "Paths under which haskell sources for packages may be found" $ emptyParams)- (PP.text . show)- readParser- sourceDirectories- (\b a -> a{sourceDirectories = b})- (filesEditor Nothing FileChooserActionSelectFolder "Select folder")- (\i -> return ())- , mkFieldPP- (paraName <<<- ParaName- "Packages which are excluded from the modules pane" $ emptyParams)- (PP.text . show)- readParser- packageBlacklist- (\b a -> a{packageBlacklist = b})- dependenciesEditor- (\i -> return ())- ])]--instance Default PackageIdentifier where- getDefault = case toPackageIdentifier "unknown-0" of- Nothing -> throwIDE "Preferences.getDefault: Can't parse Package Identifier"- Just it -> it--defaultPrefs = Prefs {- showLineNumbers = True- , rightMargin = Just 100- , tabWidth = 4- , sourceCandy = Just("Default")- , keymapName = "Default"- , forceLineEnds = True- , textviewFont = Nothing- , logviewFont = Nothing- , defaultSize = (1024,800)- , browser = "firefox"- , sourcePanePath = LeftTop- , logPanePath = RightBottom- , infoPanePath = RightBottom- , modulesPanePath = RightTop- , controlPanePath = RightTop- , sourceDirectories = ["C:/ghc","C:/cygwin/home/Nicklisch-Franken/collect"]- , packageBlacklist = []- }---- --------------------------------------------------------------- * Parsing--- --------------------------------------------------------------readPrefs :: FilePath -> IO Prefs-readPrefs fn = do- res <- P.parseFromFile (prefsParser defaultPrefs (concatMap snd prefsDescription)) fn- case res of- Left pe -> throwIDE $"Error reading prefs file " ++ show fn ++ " " ++ show pe- Right r -> return r--prefsParser :: a -> [FieldDescriptionPP a] -> P.CharParser () a-prefsParser def descriptions =- let parsersF = map fieldParser descriptions in do- whiteSpace- res <- applyFieldParsers def parsersF- return res- P.<?> "prefs parser"---- --------------------------------------------------------------- * Printing--- --------------------------------------------------------------writePrefs :: FilePath -> Prefs -> IO ()-writePrefs fpath prefs = writeFile fpath (showPrefs prefs (concatMap snd prefsDescription))--showPrefs :: a -> [FieldDescriptionPP a] -> String-showPrefs prefs prefsDesc = PP.render $- foldl (\ doc (FDPP _ printer _ _ _) -> doc PP.$+$ printer prefs) PP.empty prefsDesc----- --------------------------------------------------------------- * Editing--- --------------------------------------------------------------editPrefs :: IDEAction-editPrefs = do- ideR <- ask- p <- readIDE prefs- lift $editPrefs' p prefsDescription ideR---editPrefs' :: Prefs -> [(String,[FieldDescriptionPP Prefs])] -> IDERef -> IO ()-editPrefs' prefs prefsDesc ideR = do- let flatPrefsDesc = concatMap snd prefsDesc- lastAppliedPrefsRef <- newIORef prefs- dialog <- windowNew- vb <- vBoxNew False 0- bb <- hButtonBoxNew- apply <- buttonNewFromStock "gtk-apply"- restore <- buttonNewFromStock "Restore"- ok <- buttonNewFromStock "gtk-ok"- cancel <- buttonNewFromStock "gtk-cancel"- boxPackStart bb apply PackNatural 0- boxPackStart bb restore PackNatural 0- boxPackStart bb ok PackNatural 0- boxPackStart bb cancel PackNatural 0- nb <- newNotebook- notebookSetTabPos nb PosTop- res <- mapM- (\ (tabLabel, partPrefsDesc) -> do- resList <- mapM (\ fd -> (fieldEditor fd) prefs) partPrefsDesc- let (widgetsP, setInjsP, getExtsP,notifiersP) = unzip4 resList- nbbox <- vBoxNew False 0- mapM_ (\ w -> boxPackStart nbbox w PackNatural 0) widgetsP- sw <- scrolledWindowNew Nothing Nothing- scrolledWindowAddWithViewport sw nbbox- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- notebookAppendPage nb sw tabLabel- return (widgetsP, setInjsP, getExtsP, notifiersP))- prefsDesc- let (widgets, setInjs, getExts, notifiers) =- foldl (\ (w,i,e,n) (w2,i2,e2,n2) -> (w ++ w2, i ++ i2, e ++ e2, n ++ n2)) ([],[],[],[]) res- let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of- Just s -> s- Nothing -> "Unnamed") flatPrefsDesc- ok `onClicked` (do- mbNewPrefs <- extractAndValidate prefs getExts fieldNames- case mbNewPrefs of- Nothing -> return ()- Just newPrefs -> do- lastAppliedPrefs <- readIORef lastAppliedPrefsRef- mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF newPrefs lastAppliedPrefs) ideR) flatPrefsDesc- fp <- getConfigFilePathForSave "Default.prefs"- writePrefs fp newPrefs- runReaderT (modifyIDE_ (\ide -> return (ide{prefs = newPrefs}))) ideR- widgetDestroy dialog- mainQuit)- apply `onClicked` (do- mbNewPrefs <- extractAndValidate prefs getExts fieldNames- case mbNewPrefs of- Nothing -> return ()- Just newPrefs -> do- lastAppliedPrefs <- readIORef lastAppliedPrefsRef- mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF newPrefs lastAppliedPrefs) ideR) flatPrefsDesc- writeIORef lastAppliedPrefsRef newPrefs)- restore `onClicked` (do- lastAppliedPrefs <- readIORef lastAppliedPrefsRef- mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF prefs lastAppliedPrefs) ideR) flatPrefsDesc- mapM_ (\ setInj -> setInj prefs) setInjs- writeIORef lastAppliedPrefsRef prefs)- cancel `onClicked` (do- lastAppliedPrefs <- readIORef lastAppliedPrefsRef- mapM_ (\ (FDPP _ _ _ _ applyF) -> runReaderT (applyF prefs lastAppliedPrefs) ideR) flatPrefsDesc- widgetDestroy dialog- mainQuit)- dialog `onDelete` (\_ -> do- widgetDestroy dialog- mainQuit- return True)- boxPackStart vb nb PackGrow 7- boxPackEnd vb bb PackNatural 7- containerAdd dialog vb- widgetSetSizeRequest dialog 500 700- widgetShowAll dialog- mainGUI- return ()---
src/IDE/PrinterParser.hs view
@@ -28,14 +28,15 @@ ) where -import Graphics.UI.Gtk() -- Instances only 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 IDE.Framework.Parameters-import IDE.Framework.EditorBasics+import Graphics.UI.Editor.Parameters+import Graphics.UI.Editor.Basics+import System.IO.Unsafe (unsafePerformIO)+import Control.Monad (liftM) type Printer beta = beta -> PP.Doc@@ -79,13 +80,13 @@ 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- <|> do- eof- return (prefs) <?> "field parser" boolParser :: CharParser () Bool@@ -100,7 +101,13 @@ readParser :: Read a => CharParser () a readParser = do str <- many (noneOf ['\n'])- return (read str)+ if null str+ then unexpected "read parser on empty string"+ else case unsafePerformIO+ (catch (liftM Just (readIO str))+ (\e -> return Nothing)) of+ Nothing -> unexpected $ "read parser no parse " ++ str+ Just r -> return r <?> "read parser" pairParser :: CharParser () alpha -> CharParser () (alpha,alpha)
− src/IDE/RecoverPanes.hs
@@ -1,36 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.RecoverPanes--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ |------------------------------------------------------------------------------------module IDE.RecoverPanes (- paneStateToIDEState-) where--import IDE.Core.State-import IDE.Log()-import IDE.SourceEditor()-import IDE.ModulesPane()-import IDE.InfoPane()-import IDE.ToolbarPane()-import IDE.FindPane()-import IDE.ReplacePane()--paneStateToIDEState :: PaneState -> IDEState-paneStateToIDEState (BufferSt st) = StateC st-paneStateToIDEState (LogSt st) = StateC st-paneStateToIDEState (InfoSt st) = StateC st-paneStateToIDEState (ModulesSt st) = StateC st-paneStateToIDEState (CallersSt st) = StateC st-paneStateToIDEState (ToolbarSt st) = StateC st-paneStateToIDEState (FindSt st) = StateC st-paneStateToIDEState (ReplaceSt st) = StateC st
− src/IDE/ReplacePane.hs
@@ -1,247 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.ReplacePane--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | The pane of ide for replacing text in a text buffer-------------------------------------------------------------------------------------module IDE.ReplacePane (- ReplaceAction(..)-) where--import Graphics.UI.Gtk hiding (get)-import Data.Maybe-import Control.Monad.Reader-import Data.List-import Data.Char(toUpper)--import IDE.Core.State-import IDE.Framework.ViewFrame-import IDE.Framework.MakeEditor-import IDE.SourceEditor-import IDE.Framework.Parameters-import IDE.Framework.SimpleEditors-import IDE.Framework.EditorBasics-import IDE.FindPane---------------------------------------------------------------------------------------- * Interface---------- | The Replace Pane-----class ReplaceAction alpha where- doReplace :: alpha--instance ReplaceAction IDEAction where- doReplace = doReplace'--instance IDEObject IDEReplace--instance CastablePane IDEReplace where- casting _ = ReplaceCasting- downCast _ (PaneC a) = case casting a of- ReplaceCasting -> Just a- _ -> Nothing---instance Recoverable ReplaceState where- toPaneState a = ReplaceSt a--instance Pane IDEReplace- where- primPaneName _ = "Replace"- getAddedIndex _ = 0- getTopWidget = castToWidget . replaceBox- paneId b = "*Replace"- makeActive p = throwIDE "don't activate replace bar"- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- lift $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> lift $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- lift $notebookRemovePage nb i- removePaneAdmin pane--instance RecoverablePane IDEReplace ReplaceState where- saveState p = do- mbFind <- getPane ReplaceCasting- case mbFind of- Nothing -> return Nothing- Just p -> return Nothing- --lift $ do- --return (Just (StateC ReplaceState))- recoverState pp st = do- nb <- getNotebook pp- initReplace pp nb st---------------------------------------------------------------------------------------- * Implementation-----emptyReplaceState = ReplaceState "" "" False False False--doReplace' :: IDEAction-doReplace' = do- replace <- getReplace- lift $ bringPaneToFront replace- lift $ widgetGrabFocus (replaceBox replace)--getReplace :: IDEM IDEReplace-getReplace = do- mbReplace <- getPane ReplaceCasting- case mbReplace of- Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (controlPanePath prefs) layout- nb <- getNotebook pp- initReplace pp nb emptyReplaceState- mbReplace <- getPane ReplaceCasting- case mbReplace of- Nothing -> throwIDE "Can't init replace pane"- Just m -> return m- Just m -> return m--initReplace :: PanePath -> Notebook -> ReplaceState -> IDEAction-initReplace panePath nb replace = do- ideR <- ask- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- currentInfo <- readIDE currentInfo- (buf,cids) <- lift $ do- vb <- vBoxNew False 0- hb <- hBoxNew False 0- bb <- hButtonBoxNew-- replAll <- buttonNewWithMnemonic "Replace _all"- replB <- buttonNewWithMnemonic "_Replace"- find <- buttonNewWithMnemonic "_Find"-- boxPackStart bb find PackNatural 0- boxPackStart bb replB PackNatural 0- boxPackStart bb replAll PackNatural 0-- resList <- mapM (\ fd -> (fieldEditor fd) replace) replaceDescription- let (widgetsP, setInjsP, getExtsP, notifiersP) = unzip4 resList- mapM_ (\ w -> boxPackStart hb w PackNatural 0) widgetsP- let fieldNames = map (\fd -> case getParameterPrim paraName (parameters fd) of- Just s -> s- Nothing -> "Unnamed") replaceDescription- find `onClicked` do- findOrSearch editFind getExtsP fieldNames replB replAll ideR-- replB `onClicked` do- findOrSearch editReplace getExtsP fieldNames replB replAll ideR-- replAll `onClicked` do- findOrSearch editReplaceAll getExtsP fieldNames replB replAll ideR-- boxPackStart vb hb PackNatural 0- boxPackStart vb bb PackNatural 0-- let replace = IDEReplace vb- notebookInsertOrdered nb vb (paneName replace)- widgetShowAll vb- return (replace,[])- addPaneAdmin buf (BufConnections [] [] []) panePath- lift $widgetGrabFocus (replaceBox buf)- where- findOrSearch :: (Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool)- -> [ReplaceState -> Extractor ReplaceState] -> [String] -> Button ->- Button -> IDERef -> IO()- findOrSearch f getExtsP fieldNames replB replAll ideR= do- mbReplaceState <- extractAndValidate replace getExtsP fieldNames- case mbReplaceState of- Nothing -> return ()- Just rs -> do- let hint = if searchBackwards rs then Backward else Forward- found <- runReaderT (f (matchEntire rs) (matchCase rs) False- (searchFor rs) (replaceWith rs) hint) ideR- widgetSetSensitivity replB found- widgetSetSensitivity replAll found- return ()--replaceDescription :: [FieldDescription ReplaceState]-replaceDescription = [- mkField- (paraName <<<- ParaName "Search for" $ emptyParams)- searchFor- (\ b a -> a{searchFor = b})- stringEditor- , mkField- (paraName <<<- ParaName "Replace with" $ emptyParams)- replaceWith- (\ b a -> a{replaceWith = b})- stringEditor- , mkField- (paraName <<<- ParaName "Match case" $ emptyParams)- matchCase- (\ b a -> a{matchCase = b})- boolEditor- , mkField- (paraName <<<- ParaName "Entire word" $ emptyParams)- matchEntire- (\ b a -> a{matchEntire = b})- boolEditor- , mkField- (paraName <<<- ParaName "Back" $ emptyParams)- searchBackwards- (\ b a -> a{searchBackwards = b})- boolEditor]--editReplace :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool-editReplace entireWord caseSensitive wrapAround search replace hint =- editReplace' entireWord caseSensitive wrapAround search replace hint True--editReplace' :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> Bool -> IDEM Bool-editReplace' entireWord caseSensitive wrapAround search replace hint mayRepeat =- inBufContext' False $ \_ gtkbuf currentBuffer _ -> do- startMark <- lift $textBufferGetInsert gtkbuf- iter <- lift $textBufferGetIterAtMark gtkbuf startMark- iter2 <- lift $textIterCopy iter- lift $textIterForwardChars iter2 (length search)- str1 <- lift $textIterGetText iter iter2- if compare str1 search caseSensitive- then do- lift $textBufferDelete gtkbuf iter iter2- lift $textBufferInsert gtkbuf iter replace- editFind entireWord caseSensitive wrapAround search "" hint- else do- r <- editFind entireWord caseSensitive wrapAround search "" hint- if r- then editReplace' entireWord caseSensitive wrapAround search- replace hint False- else return False- where- compare s1 s2 True = s1 == s2- compare s1 s2 False = map toUpper s1 == map toUpper s2--editReplaceAll :: Bool -> Bool -> Bool -> String -> String -> SearchHint -> IDEM Bool-editReplaceAll entireWord caseSensitive wrapAround search replace hint = do- res <- editReplace' entireWord caseSensitive wrapAround search replace hint True- if res- then editReplaceAll entireWord caseSensitive wrapAround search replace hint- else return False---
src/IDE/SaveSession.hs view
@@ -1,11 +1,11 @@-{-# OPTIONS_GHC -fglasgow-exts #-}+{-# OPTIONS_GHC -XTypeSynonymInstances #-} ----------------------------------------------------------------------------- -- -- Module : IDE.SaveSession -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL ----- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org> -- Stability : experimental -- Portability : portable --@@ -16,7 +16,14 @@ module IDE.SaveSession (- SaveSessionAction(..)+ saveSession+, saveSessionAs+, saveSessionAsPrompt+, recoverSession+, sessionClosePane+, loadSession+, loadSessionPrompt+, standardSessionFilename ) where import Graphics.UI.Gtk hiding (showLayout)@@ -25,62 +32,119 @@ import System.FilePath import qualified Data.Map as Map import Data.Maybe+import Data.Typeable --import GHC.Exception (catch)+--import Debug.Trace import IDE.Core.State-import IDE.Framework.ViewFrame-import IDE.Utils.File+import IDE.FileUtils import IDE.PrinterParser import qualified Text.PrettyPrint.HughesPJ as PP-import IDE.Framework.Parameters-import IDE.Package-import IDE.RecoverPanes+import Graphics.UI.Editor.Parameters+--import IDE.Package+import IDE.Pane.Modules+import IDE.Pane.SourceBuffer+import IDE.Pane.Info+import IDE.Pane.Callers+import IDE.Pane.Log+import IDE.Pane.Preferences+import IDE.Pane.PackageFlags+import IDE.Pane.Search+import IDE.Find+import System.Time (getClockTime)+import IDE.Package (activatePackage,deactivatePackage)+import Data.List (foldl') +-- ---------------------------------------------------------------------+-- All pane types must be in here !+-- -instance IDEObject IDEAction+data PaneState = BufferSt BufferState+ | LogSt LogState+ | InfoSt InfoState+ | ModulesSt ModulesState+ | CallersSt CallersState+ | PrefsSt PrefsState+ | FlagsSt FlagsState+ | SearchSt SearchState+ deriving(Eq,Ord,Read,Show) -class IDEObject o => SaveSessionAction o where- saveSession :: o- recoverSession :: o- sessionClosePane :: o+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 CallersState) = CallersSt (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 = error "SaveSession>>asPaneState incomplete cast" -instance SaveSessionAction IDEAction where- saveSession = saveSession'- recoverSession = recoverSession'- sessionClosePane = sessionClosePane'+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 (CallersSt 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 +-- ---------------------------------------------------------------------++standardSessionFilename = "Current.session"+ -- | *Implementation -sessionClosePane' :: IDEAction-sessionClosePane' = do+sessionClosePane :: IDEAction+sessionClosePane = do activePane' <- readIDE activePane case activePane' of Nothing -> return () Just (pn,_) -> do- p <- paneFromName pn+ (PaneC p) <- paneFromName pn close p -sessionFilename = "Current.session"- data SessionState = SessionState {- layoutS :: PaneLayout+ saveTime :: String+ , layoutS :: PaneLayout , population :: [(Maybe PaneState,PanePath)] , windowSize :: (Int,Int) , activePackage :: Maybe FilePath , activePaneN :: Maybe String+ , toolbarVisibleS :: Bool+ , findbarState :: (Bool,FindState) } deriving() defaultLayout = SessionState {- layoutS = TerminalP (Just TopP) (-1)+ saveTime = ""+ , layoutS = TerminalP (Just TopP) (-1) , population = [] , windowSize = (1024,768) , activePackage = Nothing- , activePaneN = Nothing}+ , activePaneN = Nothing+ , toolbarVisibleS = True+ , findbarState = (False,FindState{+ entryStr = ""+ , entryHist = []+ , replaceStr = ""+ , replaceHist = []+ , caseSensitive = False+ , entireWord = False+ , wrapAround = True+ , backward = False+ , lineNr = 1})} 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@@ -109,32 +173,145 @@ (PP.text . show) readParser activePaneN- (\fp a -> a{activePaneN = fp})]+ (\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})] -- -- | Get and save the current layout ---saveSession' :: IDEAction-saveSession' = do- ideMessage Normal "Now saving session"- wdw <- readIDE window- layout <- getLayout- population <- getPopulation- layoutPath <- lift $getConfigFilePathForSave sessionFilename- size <- lift $windowGetSize wdw- active <- getActive- activePane' <- readIDE activePane- let activeP = case activePane' of- Nothing -> Nothing- Just (s,_) -> Just s- lift $writeLayout layoutPath $SessionState layout population size active activeP+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+ ideMessage Normal "Now saving session"+ wdw <- readIDE window+ layout <- getLayout+ population <- getPopulation+ size <- liftIO $windowGetSize wdw+ active <- getActive+ activePane' <- readIDE activePane+ let activeP = case activePane' of+ Nothing -> Nothing+ Just (s,_) -> Just s+ toolbarVisible <- readIDE toolbarVisible+ findState <- getFindState+ timeNow <- liftIO getClockTime+ liftIO $ writeLayout sessionPath (SessionState {+ saveTime = show timeNow+ , layoutS = layout+ , population = population+ , windowSize = size+ , activePackage = active+ , activePaneN = activeP+ , toolbarVisibleS = toolbarVisible+ , findbarState = (False,findState)})++saveSessionAsPrompt :: IDEAction+saveSessionAsPrompt = do+ window' <- readIDE window+ 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' <- readIDE window+ 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+ b <- fileCloseAll+ if b+ then do+ paneCloseAll+ viewCollapseAll+ recoverSession sessionPath+ return ()+ else return ()++paneCloseAll :: IDEAction+paneCloseAll = do+ panes' <- readIDE panes+ mapM_ (\ (PaneC p) -> close p) (Map.elems panes')++viewCollapseAll :: IDEAction+viewCollapseAll = do+ layout' <- readIDE layout+ case layout' of+ TerminalP _ _ -> return ()+ VerticalP _ _ _ -> viewCollapse' [LeftP]+ HorizontalP _ _ _ -> viewCollapse' [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+ foldl' (\ doc (FDS _ printer _) -> doc PP.$+$ printer prefs) PP.empty prefsDesc getLayout :: IDEM(PaneLayout) getLayout = do@@ -145,19 +322,19 @@ l2 <- getLayout' l (pp ++ [TopP]) r2 <- getLayout' r (pp ++ [BottomP]) pane <- getPaned pp- pos <- lift $ panedGetPosition pane+ pos <- liftIO $ panedGetPosition pane return (HorizontalP l2 r2 pos) getLayout' (VerticalP l r _) pp = do l2 <- getLayout' l (pp ++ [LeftP]) r2 <- getLayout' r (pp ++ [RightP]) pane <- getPaned pp- pos <- lift $ panedGetPosition pane+ pos <- liftIO $ panedGetPosition pane return (VerticalP l2 r2 pos) getLayout' (TerminalP _ _) pp = do nb <- getNotebook pp- showTabs <- lift $ notebookGetShowTabs nb- pos <- lift $ notebookGetTabPos nb- current <- lift $ notebookGetCurrentPage nb+ showTabs <- liftIO $ notebookGetShowTabs nb+ pos <- liftIO $ notebookGetTabPos nb+ current <- liftIO $ notebookGetCurrentPage nb return (TerminalP (if showTabs then Just (posTypeToPaneDirection pos) else Nothing) current)@@ -166,12 +343,11 @@ getPopulation = do paneMap <- readIDE paneMap mapM (\ (pn,v) -> do- p <- paneFromName pn+ (PaneC p) <- paneFromName pn mbSt <- saveState p- let st = case mbSt of- Nothing -> Nothing- Just s -> Just (toPaneState s)- return (st, fst v))+ case mbSt of+ Nothing -> return (Nothing, fst v)+ Just st -> return (Just (asPaneState st), fst v)) $Map.toList paneMap getActive :: IDEM(Maybe String)@@ -189,11 +365,11 @@ -- | Read and apply the saved layout -- -recoverSession' :: IDEAction-recoverSession' = do+recoverSession :: FilePath -> IDEM (Bool,Bool)+recoverSession sessionPath = do wdw <- readIDE window- layoutSt <- lift$ readLayout- lift $windowSetDefaultSize wdw (fst (windowSize layoutSt))(snd (windowSize layoutSt))+ layoutSt <- liftIO$ readLayout sessionPath+ liftIO $windowSetDefaultSize wdw (fst (windowSize layoutSt))(snd (windowSize layoutSt)) applyLayout (layoutS layoutSt) case activePackage layoutSt of Just fp -> activatePackage fp >> return ()@@ -202,15 +378,23 @@ setCurrentPages (layoutS layoutSt) when (isJust (activePaneN layoutSt)) $ do mbPane <- mbPaneFromName (fromJust (activePaneN layoutSt))- when (isJust mbPane) $- makeActive (fromJust mbPane)+ case mbPane of+ Nothing -> return ()+ Just (PaneC p) -> makeActive p+ setFindState ((snd . findbarState) layoutSt)+ if toolbarVisibleS layoutSt+ then showToolbar+ else hideToolbar+ if (fst . findbarState) layoutSt+ then showFindbar+ else hideFindbar+ return (toolbarVisibleS layoutSt, (fst . findbarState) layoutSt) -readLayout :: IO SessionState-readLayout = do- layoutPath <- getConfigFilePathForLoad sessionFilename- res <- parseFromFile (prefsParser defaultLayout layoutDescr) layoutPath+readLayout :: FilePath -> IO SessionState+readLayout sessionPath = do+ res <- parseFromFile (prefsParser defaultLayout layoutDescr) sessionPath case res of- Left pe -> throwIDE $"Error reading prefs file " ++ show layoutPath ++ " " ++ show pe+ Left pe -> throwIDE $"Error reading session file " ++ show sessionPath ++ " " ++ show pe Right r -> return r prefsParser :: a -> [FieldDescriptionS a] -> CharParser () a@@ -229,21 +413,21 @@ where applyLayout' (TerminalP Nothing _) pp = do nb <- getNotebook pp- lift $notebookSetShowTabs nb False+ liftIO $notebookSetShowTabs nb False applyLayout' (TerminalP (Just p) _) pp = do nb <- getNotebook pp- lift $notebookSetShowTabs nb True- lift $notebookSetTabPos nb (paneDirectionToPosType p)+ liftIO $notebookSetShowTabs nb True+ liftIO $notebookSetTabPos nb (paneDirectionToPosType p) applyLayout' (VerticalP l r pos) pp = do viewSplit' pp Vertical pane <- getPaned pp- lift $panedSetPosition pane pos+ liftIO $panedSetPosition pane pos applyLayout' l (pp ++ [LeftP]) applyLayout' r (pp ++ [RightP]) applyLayout' (HorizontalP t b pos) pp = do viewSplit' pp Horizontal pane <- getPaned pp- lift $panedSetPosition pane pos+ liftIO $panedSetPosition pane pos applyLayout' t (pp ++ [TopP]) applyLayout' b (pp ++ [BottomP]) @@ -251,7 +435,7 @@ populate = mapM_ (\ (mbPs,pp) -> case mbPs of Nothing -> return ()- Just s -> recoverState pp (paneStateToIDEState s))+ Just s -> recover pp s) setCurrentPages :: PaneLayout -> IDEAction setCurrentPages layout = setCurrentPages' layout []@@ -262,7 +446,7 @@ setCurrentPages' r (RightP : p) setCurrentPages' (TerminalP _ ind) p = when (ind > 0) $ do nb <- getNotebook (reverse p)- lift $ notebookSetCurrentPage nb ind+ liftIO $ notebookSetCurrentPage nb ind
src/IDE/SourceCandy.hs view
@@ -4,7 +4,7 @@ -- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro) -- License : GNU-GPL ----- Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>+-- Maintainer : Juergen Nicklisch-Franken <info at leksah.org> -- Stability : experimental -- Portability : portable --@@ -14,7 +14,11 @@ --------------------------------------------------------------------------------- module IDE.SourceCandy (- SourceCandy(..)+ parseCandy -- :: FilePath -> IO alpha+, transformToCandy -- :: alpha -> TextBuffer -> IO ()+, transformFromCandy -- :: alpha -> TextBuffer -> IO ()+, keystrokeCandy -- :: alpha -> Maybe Char -> TextBuffer -> IO ()+, getCandylessText -- :: alpha -> TextBuffer -> IO String ) where import Data.Char(chr)@@ -30,35 +34,16 @@ import IDE.Core.State ------------------------------------------------------------------------------------ * Interface--class IDEObject alpha => SourceCandy alpha where- parseCandy :: FilePath -> IO alpha- transformToCandy :: alpha -> TextBuffer -> IO ()- transformFromCandy :: alpha -> TextBuffer -> IO ()- keystrokeCandy :: alpha -> Maybe Char -> TextBuffer -> IO ()- getCandylessText :: alpha -> TextBuffer -> IO String--instance IDEObject CandyTable--instance SourceCandy CandyTable where- parseCandy = parseCandy'- transformToCandy = transformToCandy'- transformFromCandy = transformFromCandy'- keystrokeCandy = keystrokeCandy'- getCandylessText = getCandylessText'----------------------------------------------------------------------------------- -- * Implementation notBeforeId = Set.fromList $['a'..'z'] ++ ['A'..'Z'] ++ ['_'] notAfterId = Set.fromList $['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['_'] notBeforeOp = Set.fromList $['!','#','$','%','&','*','+','.','/','<','=','>','?','@','\\',- '^','|','-','~','\'','"']+ '^','|','-','~','\'','"','\n'] notAfterOp = notBeforeOp -keystrokeCandy' :: CandyTable -> Maybe Char -> TextBuffer -> IO ()-keystrokeCandy' (CT(transformTable,_)) mbc gtkbuf = do+keystrokeCandy :: CandyTable -> Maybe Char -> TextBuffer -> IO ()+keystrokeCandy (CT(transformTable,_)) mbc gtkbuf = do cursorMark <- textBufferGetInsert gtkbuf endIter <- textBufferGetIterAtMark gtkbuf cursorMark offset <- textIterGetOffset endIter@@ -68,15 +53,10 @@ mbc2 <- case mbc of Just c -> return (Just c) Nothing -> do- isEnd <- textIterIsEnd endIter- if isEnd- then (return Nothing)- else do- textIterForwardChar endIter- textIterGetChar endIter+ textIterGetChar endIter replace mbc2 cursorMark slice offset transformTable where- replace :: Maybe Char -> TextMark -> String -> Int -> [(Bool,String,String)] -> IO ()+ replace :: Maybe Char -> TextMark -> String -> Int -> [(Bool,String,String)] -> IO () replace mbAfterChar cursorMark match offset list = replace' list where replace' [] = return ()@@ -88,7 +68,7 @@ afterOk = case mbAfterChar of Nothing -> True Just afterChar ->- not $if isOp+ not $if isOp then Set.member afterChar notAfterOp else Set.member afterChar notAfterId in if isSuffixOf from match && beforeOk && afterOk@@ -102,8 +82,8 @@ sourceBufferEndNotUndoableAction (castToSourceBuffer gtkbuf) else replace mbAfterChar cursorMark match offset rest -transformToCandy' :: CandyTable -> TextBuffer -> IO ()-transformToCandy' (CT(transformTable,_)) gtkbuf = do+transformToCandy :: CandyTable -> TextBuffer -> IO ()+transformToCandy (CT(transformTable,_)) gtkbuf = do textBufferBeginUserAction gtkbuf modified <- textBufferGetModified gtkbuf mapM_ (\tbl -> replaceTo gtkbuf tbl 0) transformTable@@ -154,26 +134,26 @@ return () replaceTo' (stOff + 1) -transformFromCandy' :: CandyTable -> TextBuffer -> IO ()-transformFromCandy' (CT(_,transformTableBack)) gtkbuf = do+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 -getCandylessText' :: CandyTable -> TextBuffer -> IO (String)-getCandylessText' (CT(_,transformTableBack)) gtkbuf = do+getCandylessText :: CandyTable -> TextBuffer -> IO (String)+getCandylessText (CT(_,transformTableBack)) gtkbuf = do workBuffer <- textBufferNew Nothing i1 <- textBufferGetStartIter gtkbuf i2 <- textBufferGetEndIter gtkbuf- text <- textBufferGetText gtkbuf i1 i2 True- textBufferSetText workBuffer text+ text1 <- textBufferGetText gtkbuf i1 i2 True+ textBufferSetText workBuffer text1 mapM_ (\tbl -> replaceFrom workBuffer tbl 0) transformTableBack i1 <- textBufferGetStartIter workBuffer i2 <- textBufferGetEndIter workBuffer- text <- textBufferGetText workBuffer i1 i2 True- return text+ text2 <- textBufferGetText workBuffer i1 i2 True+ return text2 replaceFrom :: TextBuffer -> (String,String,Int) -> Int -> IO () replaceFrom buf (to,from,spaces) offset = replaceFrom' offset@@ -211,7 +191,7 @@ let isOp = not (Set.member (head str) notBeforeId) from = str trailingBlanks = replicate (if noTrimming then 0 else length str - 1) ' '- to = [chr] ++ trailingBlanks+ to = chr : trailingBlanks in (isOp,from,to) backFromTable :: CandyTableI -> CandyTableBack@@ -236,8 +216,8 @@ hexadecimal = P.hexadecimal lexer symbol = P.symbol lexer -parseCandy' :: FilePath -> IO CandyTable-parseCandy' fn = do+parseCandy :: FilePath -> IO CandyTable+parseCandy fn = do res <- parseFromFile candyParser fn case res of Left pe -> throwIDE $"Error reading keymap file " ++ show fn ++ " " ++ show pe
− src/IDE/SourceEditor.hs
@@ -1,894 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.SourceEditor--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | The source editor part of Leksah-----------------------------------------------------------------------------------------module IDE.SourceEditor (- allBuffers-, maybeActiveBuf-, standardSourcePanePath-, selectSourceBuf-, goToSourceDefinition-, goToDefinition--, newTextBuffer--, fileNew-, fileOpen-, fileRevert-, fileClose-, fileCloseAll-, fileCloseAllButPackage-, fileSave-, editUndo-, editRedo-, editCut-, editCopy-, editPaste-, editDelete-, editSelectAll--, editComment-, editUncomment-, editShiftRight-, editShiftLeft--, editToCandy-, editFromCandy-, editKeystrokeCandy-, editCandy--, markErrorInSourceBuf-, inBufContext'-, inBufContext-) where--import Graphics.UI.Gtk hiding (afterToggleOverwrite)-import Graphics.UI.Gtk.SourceView-import Graphics.UI.Gtk.Multiline.TextView-import Control.Monad.Reader---import Data.IORef-import System.IO-import System.FilePath-import System.Directory-import Text.Printf-import qualified Data.Map as Map-import Data.List-import Data.Maybe--import IDE.Core.State-import IDE.Utils.File-import IDE.Framework.ViewFrame-import IDE.SourceCandy--instance IDEObject IDEBuffer-instance Pane IDEBuffer- where- primPaneName = bufferName- getAddedIndex = addedIndex- getTopWidget = castToWidget . scrolledWindow- paneId b = case fileName b of- Just s -> s- Nothing -> "?" ++ bufferName b- makeActive buf = do- pane <- paneFromName (paneName buf)- if isIt BufferCasting pane- then do- let actbuf = fromJust $ downCast BufferCasting pane- ideR <- ask- sbLC <- getStatusbarLC- sbIO <- getStatusbarIO- infos <- readIDE accessibleInfo- let sv = sourceView actbuf- (tl,tm,tr) <- lift $do- gtkBuf <- textViewGetBuffer sv- bringPaneToFront actbuf- writeCursorPositionInStatusbar sv sbLC- writeOverwriteInStatusbar sv sbIO- id1 <- gtkBuf `afterModifiedChanged` runReaderT (markLabelAsChanged) ideR- id2 <- sv `afterMoveCursor`- (\_ _ _ -> writeCursorPositionInStatusbar sv sbLC)- id3 <- gtkBuf `afterEndUserAction` writeCursorPositionInStatusbar sv sbLC- sv `widgetAddEvents` [ButtonReleaseMask]- id4 <- sv `onButtonRelease` (\ _ -> do- writeCursorPositionInStatusbar sv sbLC- return False)- id5 <- sv `onButtonRelease` (\ e -> do- showInfo sv ideR- return False)- id6 <- sv `afterToggleOverwrite` writeOverwriteInStatusbar sv sbIO- return ([id2,id4,id6],[id1,id3],[])- activatePane actbuf (BufConnections tl tm tr)- checkModTime actbuf- else return ()- close pane = do makeActive pane- fileClose- return ()--instance RecoverablePane IDEBuffer BufferState where- saveState p = do buf <- lift $ textViewGetBuffer (sourceView p)- ins <- lift $ textBufferGetInsert buf- iter <- lift $ textBufferGetIterAtMark buf ins- offset <- lift $ textIterGetOffset iter- case fileName p of- Nothing -> return Nothing- Just fn -> return (Just (StateC (BufferState fn offset)))- recoverState pp (BufferState n i) = do- exists <- lift $doesFileExist n- when exists $ do- buf <- newTextBuffer pp (takeFileName n) (Just n)- lift $ do- gtkBuf <- textViewGetBuffer (sourceView buf)- iter <- textBufferGetIterAtOffset gtkBuf i- textBufferPlaceCursor gtkBuf iter- mark <- textBufferGetInsert gtkBuf- textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3))- return ()--selectSourceBuf :: FilePath -> IDEM Bool-selectSourceBuf fp = do- fpc <- lift $canonicalizePath fp- buffers <- allBuffers- let buf = filter (\b -> case fileName b of- Just fn -> equalFilePath fn fpc- Nothing -> False) buffers- case buf of- hdb:tl -> do- makeActive hdb- return True- otherwise -> do- fe <- lift $doesFileExist fpc- if fe- then do- path <- standardSourcePanePath- newTextBuffer path (takeFileName fpc) (Just fpc)- return True- else return False--goToDefinition :: IdentifierDescr -> IDEAction-goToDefinition idDescr = do- mbAccesibleInfo <- readIDE accessibleInfo- mbCurrentInfo <- readIDE currentInfo- if isJust mbAccesibleInfo && isJust mbCurrentInfo- then do- let packageId = pack $ moduleIdID 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 == moduleIdID idDescr)- (exposedModulesPD pack) of- [mod] -> if isJust (mbSourcePathMD mod)- then goToSourceDefinition- (fromJust $ mbSourcePathMD mod)- (mbLocation idDescr)- else return ()- _ -> ideMessage Normal "not just one module"- Nothing -> do ideMessage Normal "no package"- else ideMessage Normal "no infos"--goToSourceDefinition :: FilePath -> Maybe Location -> IDEAction-goToSourceDefinition fp mbLocation = do- success <- selectSourceBuf fp- when (success && isJust mbLocation) $- inBufContext () $ \_ gtkbuf buf _ -> do- let location = fromJust mbLocation- lines <- textBufferGetLineCount gtkbuf- iter <- textBufferGetIterAtLine gtkbuf (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)- ((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-- imark <- textBufferGetInsert gtkbuf- -- ### we have a problem here that this does not work for a frsh opened buffer- textViewScrollToMark (sourceView buf) imark 0.0 (Just (0.3,0.3))---markErrorInSourceBuf :: Int -> Int -> String -> IDEAction-markErrorInSourceBuf line column string =- inBufContext () $ \_ gtkbuf buf _ -> do- i1 <- textBufferGetStartIter gtkbuf- i2 <- textBufferGetEndIter gtkbuf- textBufferRemoveTagByName gtkbuf "activeErr" i1 i2-- lines <- textBufferGetLineCount gtkbuf- iter <- textBufferGetIterAtLine gtkbuf (max 0 (min (lines-1) (line-1)))- chars <- textIterGetCharsInLine iter- textIterSetLineOffset iter (max 0 (min (chars-1) column))- iter2 <- textIterCopy iter- textIterForwardWordEnd iter2- textBufferApplyTagByName gtkbuf "activeErr" iter iter2- textBufferPlaceCursor gtkbuf iter- mark <- textBufferGetInsert gtkbuf- textViewScrollToMark (sourceView buf) mark 0.0 (Just (0.3,0.3))---allBuffers :: IDEM [IDEBuffer]-allBuffers = do- panesST <- readIDE panes- return (catMaybes $ map (downCast BufferCasting) $ Map.elems panesST)--maybeActiveBuf :: IDEM (Maybe (IDEBuffer,Connections))-maybeActiveBuf = do- mbPane <- readIDE activePane- case mbPane of- Nothing -> return Nothing- Just (paneName,signals) -> do- pane <- paneFromName paneName- if isIt BufferCasting pane- then return (Just (fromJust $ downCast BufferCasting pane,signals))- else return Nothing--standardSourcePanePath :: IDEM PanePath-standardSourcePanePath = do- layout <- readIDE layout- prefs <- readIDE prefs- return (getStandardPanePath (sourcePanePath prefs) layout)--newTextBuffer :: PanePath -> String -> Maybe FilePath -> IDEM IDEBuffer-newTextBuffer panePath bn mbfn = do- -- create the appropriate language- ideR <- ask- nb <- getNotebook panePath- panes <- readIDE panes- paneMap <- readIDE paneMap- prefs <- readIDE prefs- bs <- getCandyState- ct <- readIDE candy- let (ind,rbn) = figureOutPaneName panes bn 0- (buf,cids) <- lift $ do- lm <- sourceLanguagesManagerNew- langM <- sourceLanguagesManagerGetLanguageFromMimeType lm "text/x-haskell"- lang <- case langM of- (Just lang) -> return lang- Nothing -> do- langDirs <- sourceLanguagesManagerGetLangFilesDirs lm- throwIDE ("please copy haskell.lang to one of the following"- ++ "directories:\n"- ++ unlines langDirs)-- -- create a new SourceBuffer object- buffer <- sourceBufferNewWithLanguage lang- tagTable <- textBufferGetTagTable buffer- foundTag <- textTagNew (Just "found")- set foundTag [textTagBackground := "yellow"]- textTagTableAdd tagTable foundTag- activeErrtag <- textTagNew (Just "activeErr")- set activeErrtag[textTagUnderline := UnderlineError]- textTagTableAdd tagTable activeErrtag-- -- load up and display a file- (fileContents,modTime) <- case mbfn of- Just fn -> do- fc <- readFile fn- mt <- getModificationTime fn- return (fc,Just mt)- Nothing -> return ("\n\n\n\n\n",Nothing)- sourceBufferBeginNotUndoableAction buffer- textBufferSetText buffer fileContents- if bs- then transformToCandy ct (castToTextBuffer buffer)- else return ()- sourceBufferEndNotUndoableAction buffer- textBufferSetModified buffer False- siter <- textBufferGetStartIter buffer- textBufferPlaceCursor buffer siter- sourceBufferSetHighlight buffer True- iter <- textBufferGetEndIter buffer- textBufferCreateMark buffer (Just "end") iter True-- -- 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)- sourceViewSetShowLineNumbers sv (showLineNumbers prefs)- case rightMargin prefs of- Just n -> do- sourceViewSetMargin sv n- sourceViewSetShowMargin sv True- Nothing -> sourceViewSetShowMargin sv True- sourceViewSetInsertSpacesInsteadOfTabs sv True- sourceViewSetTabsWidth sv (tabWidth prefs)- sourceViewSetSmartHomeEnd sv True- --sourceViewSetShowLineMarkers sv True-- -- put it in a scrolled window- sw <- scrolledWindowNew Nothing Nothing- containerAdd sw sv- scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic- scrolledWindowSetShadowType sw ShadowIn-- let buf = IDEBuffer mbfn bn ind sv sw modTime- notebookInsertOrdered nb sw rbn- -- events- cid <- sv `afterFocusIn`- (\_ -> do runReaderT (makeActive buf) ideR; return True)- return (buf,[cid])- addPaneAdmin buf (BufConnections cids [] []) panePath- lift $widgetShowAll (scrolledWindow buf)- lift $widgetGrabFocus (sourceView buf)- return buf--checkModTime :: IDEBuffer -> IDEAction-checkModTime buf = do- panes <- readIDE panes- let name = paneName buf- case fileName buf of- Just fn -> do- exists <- lift $doesFileExist fn- if exists- then do- nmt <- lift $getModificationTime fn- case modTime buf of- Nothing -> throwIDE $"checkModTime: time not set " ++ show (fileName buf)- Just mt -> do- --message $"checkModTime " ++ name ++ " " ++ show mt ++ " " ++ show nmt- if nmt /= mt- then do- md <- lift $messageDialogNew- Nothing []- MessageQuestion- ButtonsYesNo- ("File has changed on disk " ++ name ++ " Revert?")- resp <- lift $dialogRun md- case resp of- ResponseYes -> do- revert buf- lift $widgetHide md- ResponseNo -> do- let newPanes = Map.adjust (\b ->- if isIt BufferCasting b- then PaneC ((fromJust $- downCast BufferCasting b)- {modTime = (Just nmt)})- else b) name panes- modifyIDE_ (\ide -> return (ide{panes = newPanes}))- lift $widgetHide md- _ -> do return ()- else return ()- else return ()- Nothing -> return ()--setModTime :: IDEBuffer -> IDEAction-setModTime buf = do- panes <- readIDE panes- let name = paneName buf- case fileName buf of- Nothing -> return ()- Just fn -> do- nmt <- lift $getModificationTime fn- let newPanes = Map.adjust (- \b -> if isIt BufferCasting b- then- PaneC ((fromJust $ downCast BufferCasting b)- {modTime = (Just nmt)})- else b) name panes- modifyIDE_ (\ide -> return (ide{panes = newPanes}))--fileRevert :: IDEAction-fileRevert = inBufContext' () $ \ _ _ currentBuffer _ -> do- revert currentBuffer--revert :: IDEBuffer -> IDEAction-revert buf = do- useCandy <- getCandyState- ct <- readIDE candy- panes <- readIDE panes- let name = paneName buf- case fileName buf of- Nothing -> return ()- Just fn -> do- mt <- lift $do- buffer' <- textViewGetBuffer (sourceView buf)- let buffer = castToSourceBuffer buffer'- fc <- readFile fn- mt <- getModificationTime fn- sourceBufferBeginNotUndoableAction buffer- textBufferSetText buffer fc- if useCandy- then transformToCandy ct (castToTextBuffer buffer)- else return ()- sourceBufferEndNotUndoableAction buffer- textBufferSetModified buffer False- return mt- let newPanes = Map.adjust (\b -> if isIt BufferCasting b- then- PaneC ((fromJust $ downCast BufferCasting b)- {modTime = (Just mt)})- else b) name panes- modifyIDE_ (\ide -> return (ide{panes = newPanes}))--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)- return ()--writeOverwriteInStatusbar :: SourceView -> Statusbar -> IO()-writeOverwriteInStatusbar sv sb = do- modi <- textViewGetOverwrite sv- statusbarPop sb 1- statusbarPush sb 1 $ if modi then "OVR" else "INS"- return ()---showInfo :: SourceView -> IDERef -> IO ()-showInfo sv ideR = do- buf <- textViewGetBuffer sv- (l,r) <- textBufferGetSelectionBounds buf- symbol <- textBufferGetText buf l r True- runReaderT (triggerEvent ideR (SelectInfo symbol)) ideR- return ()--markLabelAsChanged :: IDEAction-markLabelAsChanged = do- mbPath <- getActivePanePath- case mbPath of- Nothing -> return ()- Just path -> do- nb <- getNotebook path- mbBS <- maybeActiveBuf- case mbBS of- Nothing -> return ()- Just (buf,_) -> lift $do- gtkbuf <- textViewGetBuffer (sourceView buf)- modified <- textBufferGetModified gtkbuf- (Just text) <- notebookGetTabLabelText nb (scrolledWindow buf)- label <- labelNew Nothing- labelSetUseMarkup label True- labelSetMarkup label- (if modified- then "<span foreground=\"red\">" ++ text ++ "</span>"- else text)- notebookSetTabLabel nb (scrolledWindow buf) label--inBufContext' :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM alpha ) -> IDEM alpha-inBufContext' def f = do- mbBuf <- maybeActiveBuf- case mbBuf of- Nothing -> return def- Just (ideBuf,_) -> do- (pane,_) <- guiPropertiesFromName (paneName ideBuf)- nb <- getNotebook pane- mbI <- lift $notebookPageNum nb (scrolledWindow ideBuf)- case mbI of- Nothing -> lift $ do- sysMessage Normal "notebook page not found: unexpected"- return def- Just i -> do- gtkbuf <- lift $ textViewGetBuffer (sourceView ideBuf)- f nb gtkbuf ideBuf i--inBufContext :: alpha -> (Notebook -> TextBuffer -> IDEBuffer -> Int -> IO alpha ) -> IDEM alpha-inBufContext def f = inBufContext' def (\ a b c d -> lift $ f a b c d)--fileSave :: Bool -> IDEAction-fileSave query = inBufContext' () $ \ nb _ currentBuffer i -> do- ideR <- ask- window <- readIDE window- bufs <- readIDE panes- prefs <- readIDE prefs- paneMap <- readIDE paneMap- bs <- getCandyState- candy <- readIDE candy- (panePath,BufConnections s1 s2 s3)- <- guiPropertiesFromName (paneName currentBuffer)- mbnbufsPm <- do- let mbfn = fileName currentBuffer- mbpage <- lift $notebookGetNthPage nb i- case mbpage of- Nothing -> throwIDE "fileSave: Page not found"- Just page ->- if isJust mbfn && query == False- then do checkModTime currentBuffer- lift $fileSave' (forceLineEnds prefs) currentBuffer bs candy $fromJust mbfn- setModTime currentBuffer- return Nothing- else lift $do- dialog <- fileChooserDialogNew- (Just $ "Save File")- (Just window)- FileChooserActionSave- [("gtk-cancel" --buttons to display- ,ResponseCancel) --you can use stock buttons- ,("gtk-save"- , ResponseAccept)]- widgetShow dialog- response <- dialogRun dialog- mbFileName <- case response of- ResponseAccept -> fileChooserGetFilename dialog- ResponseCancel -> return Nothing- ResponseDeleteEvent-> return Nothing- _ -> return Nothing- widgetDestroy dialog- case mbFileName of- Nothing -> return Nothing- Just fn -> do- dfe <- doesFileExist fn- resp <- if dfe- then do md <- messageDialogNew (Just window) []- MessageQuestion- ButtonsYesNo- "File already exist. Overwrite?"- resp <- dialogRun md- widgetHide md- return resp- else return ResponseYes- case resp of- ResponseYes -> do- fileSave' (forceLineEnds prefs) currentBuffer bs candy fn- modT <- getModificationTime fn- let bn = takeFileName fn- let bufs1 = Map.delete (paneName currentBuffer) bufs- let (ind,rbn) = figureOutPaneName bufs1 bn 0- cfn <- canonicalizePath fn- let newBuffer = currentBuffer {fileName = Just cfn,- bufferName = bn, addedIndex = ind, modTime = Just modT}- let newBufs = Map.insert rbn (PaneC newBuffer) bufs1- mapM_ signalDisconnect s1- mapM_ signalDisconnect s2- mapM_ signalDisconnect s3- cid1 <- (sourceView currentBuffer) `afterFocusIn`- (\_ -> do runReaderT (makeActive newBuffer) ideR- return True)- let paneMap1 = Map.delete rbn paneMap- let newPaneMap = Map.insert rbn- (panePath,BufConnections [cid1] [] []) paneMap- label <- labelNew (Just rbn)- notebookSetTabLabel nb page label- return (Just (newBufs,newPaneMap))- ResponseNo -> return Nothing- _ -> return Nothing- case mbnbufsPm of- Just (nbufs,pm) -> modifyIDE_- (\ide -> return (ide{panes = nbufs, paneMap = pm}))- Nothing -> return ()- where- fileSave' :: Bool -> IDEBuffer -> Bool -> CandyTable -> FilePath -> IO()- fileSave' forceLineEnds ideBuf bs ct fn = do- buf <- textViewGetBuffer $ sourceView ideBuf- text <- getCandylessText ct buf- let text' = unlines $map removeTrailingBlanks $lines text- if forceLineEnds- then do- file <- openBinaryFile fn WriteMode- hPutStr file text'- hClose file- else- writeFile fn text'- textBufferSetModified buf False- removeTrailingBlanks :: String -> String- removeTrailingBlanks = reverse . dropWhile (\c -> c == ' ') . reverse--fileNew :: IDEAction-fileNew = do- prefs <- readIDE prefs- pp <- getActivePanePathOrStandard (sourcePanePath prefs)- newTextBuffer pp "Unnamed" Nothing- return ()--fileClose :: IDEM Bool-fileClose = inBufContext' True $ fileClose'--fileClose' :: Notebook -> TextBuffer -> IDEBuffer -> Int -> IDEM Bool-fileClose' nb gtkbuf currentBuffer i = do- ideRef <- ask- window <- readIDE window- bufs <- readIDE panes- paneMap <- readIDE paneMap- cancel <- lift $ do- modified <- textBufferGetModified gtkbuf- if modified- then do- md <- messageDialogNew (Just window) []- MessageQuestion- ButtonsNone- ("Save changes to document: "- ++ paneName currentBuffer- ++ "?")- dialogAddButton md "_Save" ResponseYes- dialogAddButton md "_Don't Save" ResponseNo- dialogAddButton md "_Cancel" ResponseCancel- resp <- dialogRun md- widgetDestroy md- case resp of- ResponseYes -> do- runReaderT (fileSave False) ideRef- return False- ResponseCancel -> return True- ResponseNo -> return False- _ -> return False- else return False- if cancel- then return False- else do- deactivatePane- lift $notebookRemovePage nb i- removePaneAdmin currentBuffer- return True---fileCloseAll :: IDEM Bool-fileCloseAll = do- bufs <- allBuffers- if null bufs- then return True- else do- makeActive (head bufs)- r <- fileClose- if r- then fileCloseAll- else return False---fileCloseAllButPackage :: IDEAction-fileCloseAllButPackage = do- mbActivePack <- readIDE activePack- bufs <- allBuffers- when (not (null bufs) && isJust mbActivePack) $ do- mapM_ (close' (fromJust mbActivePack)) bufs- where- close' activePack buf = do- (pane,_) <- guiPropertiesFromName (paneName buf)- nb <- getNotebook pane- mbI <- lift $notebookPageNum nb (scrolledWindow buf)- case mbI of- Nothing -> throwIDE "notebook page not found: unexpected"- Just i -> do- gtkbuf <- lift $ textViewGetBuffer (sourceView buf)- let dir = dropFileName $ cabalFile activePack- when (isJust (fileName buf)) $ do- modified <- lift $ textBufferGetModified gtkbuf- when (not modified && not (isSubPath dir (fromJust (fileName buf))))- $ do fileClose' nb gtkbuf buf i; return ()--fileOpen :: IDEAction-fileOpen = do- window <- readIDE window- prefs <- readIDE prefs- mbFileName <- lift $ do- dialog <- fileChooserDialogNew- (Just $ "Open File")- (Just window)- FileChooserActionOpen- [("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 ()- Just fp -> do- fpc <- lift $canonicalizePath fp- buffers <- allBuffers- let buf = filter (\b -> case fileName b of- Just fn -> equalFilePath fn fpc- Nothing -> False) buffers- case buf of- hdb:tl -> do- md <- lift $messageDialogNew- Nothing []- MessageQuestion- ButtonsYesNo- ("Buffer already open. " ++- "Make active instead of opening a second time?")- resp <- lift $dialogRun md- lift $ widgetDestroy md- case resp of- ResponseNo -> reallyOpen prefs fpc- _ -> makeActive hdb- [] -> reallyOpen prefs fpc- where- reallyOpen prefs fpc = do- pp <- getActivePanePathOrStandard (sourcePanePath prefs)- newTextBuffer pp (takeFileName fpc) (Just fpc)- return ()--editUndo :: IDEAction-editUndo = inBufContext () $ \_ gtkbuf _ _ ->- let sb = castToSourceBuffer gtkbuf in- do canUndo <- sourceBufferCanUndo sb- if canUndo- then sourceBufferUndo sb- else return ()--editRedo :: IDEAction-editRedo = inBufContext () $ \_ gtkbuf _ _ ->- let sb = castToSourceBuffer gtkbuf in- do canRedo <- sourceBufferCanUndo sb- if canRedo- then sourceBufferRedo sb- else return ()--editDelete :: IDEAction-editDelete = inBufContext () $ \_ gtkbuf _ _ -> do- textBufferDeleteSelection gtkbuf True True- return ()--editSelectAll :: IDEAction-editSelectAll = inBufContext () $ \_ gtkbuf _ _ -> do- start <- textBufferGetStartIter gtkbuf- end <- textBufferGetEndIter gtkbuf- textBufferSelectRange gtkbuf start end--editCut :: IDEAction-#ifdef _Newgtk-editCut = inBufContext () $ \_ gtkbuf _ _ -> do- clip <- clipboardGet ClipClipboard- textBufferCutClipboard gtkbuf clip True-#else-editCut = return ()-#endif--editCopy :: IDEAction-#ifdef _Newgtk-editCopy = inBufContext () $ \_ gtkbuf _ _ -> do- clip <- clipboardGet ClipClipboard- textBufferCopyClipboard gtkbuf clip-#else-editCopy = return ()-#endif--editPaste :: IDEAction-#ifdef _Newgtk-editPaste = inBufContext () $ \_ gtkbuf _ _ -> do- mark <- textBufferGetInsert gtkbuf- iter <- textBufferGetIterAtMark gtkbuf mark- clip <- clipboardGet ClipClipboard- textBufferPasteClipboard gtkbuf clip iter True-#else-editPaste = return ()-#endif---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- 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'- return (startLine',endLineReal)--doForSelectedLines :: [a] -> (TextBuffer -> TextIter -> Int -> IO a) -> IDEM [a]-doForSelectedLines d f = inBufContext' d $ \_ gtkbuf currentBuffer _ -> lift $do- (start,end) <- getStartAndEndLineOfSelection gtkbuf- iter <- textBufferGetStartIter gtkbuf- mapM (f gtkbuf iter) [start .. end]--editComment :: IDEAction-editComment = do- doForSelectedLines [] $ \gtkbuf iter lineNr -> do- textIterSetLine iter lineNr- textBufferInsert gtkbuf iter "--"- return ()--editUncomment :: IDEAction-editUncomment = do- doForSelectedLines [] $ \gtkbuf iter lineNr -> do- textIterSetLine iter lineNr- iter2 <- textIterCopy iter- textIterForwardChars iter 2- str <- textIterGetText iter iter2- if str == "--"- then do textBufferDelete gtkbuf iter iter2- else return ()- return ()--editShiftLeft :: IDEAction-editShiftLeft = do- prefs <- readIDE prefs- let str = map (\_->' ') [1 .. (tabWidth prefs)]- 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- 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- return (str1 == str)- return (foldl (&&) True boolList)---editShiftRight :: IDEAction-editShiftRight = do- prefs <- readIDE prefs- let str = map (\_->' ') [1 .. (tabWidth prefs)]- doForSelectedLines [] $ \gtkbuf iter lineNr -> do- textIterSetLine iter lineNr- textBufferInsert gtkbuf iter str- return ()--editToCandy :: IDEAction-editToCandy = do- ct <- readIDE candy- inBufContext () $ \_ gtkbuf _ _ -> do- transformToCandy ct gtkbuf--editFromCandy :: IDEAction-editFromCandy = do- ct <- readIDE candy- inBufContext () $ \_ gtkbuf _ _ -> do- transformFromCandy ct gtkbuf--editKeystrokeCandy :: Maybe Char -> IDEAction-editKeystrokeCandy c = do- ct <- readIDE candy- inBufContext () $ \_ gtkbuf _ _ -> do- keystrokeCandy ct c gtkbuf--editCandy = do- ct <- readIDE candy- buffers <- allBuffers- gtkbufs <- lift $mapM (\ b -> textViewGetBuffer (sourceView b)) buffers- bs <- getCandyState- if bs- then lift $mapM_ (transformToCandy ct) gtkbufs- else lift $mapM_ (transformFromCandy ct) gtkbufs--------
src/IDE/SpecialEditors.hs view
@@ -14,35 +14,45 @@ , stringsEditor , extensionsEditor , panePathEditor+, libraryEditor+, executablesEditor+, modulesEditor+, styleEditor+, Library'(..)+, Executable'(..) ) where +import Graphics.UI.Editor.Simple (intEditor,genericEditor,staticListEditor,comboSelectionEditor,stringEditor,fileEditor) import Graphics.UI.Gtk import Graphics.UI.Gtk.ModelView as New+import Graphics.UI.Gtk.SourceView (sourceStyleSchemeManagerGetSchemeIds)+import Graphics.UI.Gtk.SourceView (sourceStyleSchemeManagerNew)+import Distribution.ModuleName (ModuleName(..))+import Data.List (sort)+import Distribution.Text (simpleParse,display) import Control.Monad.Reader import Distribution.PackageDescription import Distribution.Package-import Data.List(filter) import Distribution.Compiler import Distribution.Version-import Text.ParserCombinators.ReadP(readP_to_S) import Language.Haskell.Extension -import IDE.Core.State-import IDE.Framework.EditorBasics-import IDE.Framework.SimpleEditors-import IDE.Framework.CompositeEditors-import IDE.Framework.Parameters-import IDE.Utils.Default+import IDE.Core.State hiding (packageId)+import Graphics.UI.Editor.Basics+import Graphics.UI.Editor.Composite+import Graphics.UI.Editor.Parameters+import Default+import MyMissing packageEditor :: Editor PackageIdentifier-packageEditor para = do- (wid,inj,ext,notif) <- pairEditor- (stringEditor, paraName <<<- ParaName "Name" $ emptyParams)+packageEditor para noti = do+ (wid,inj,ext) <- pairEditor+ (stringEditor (\s -> not (null s)), paraName <<<- ParaName "Name" $ emptyParams) (versionEditor, paraName <<<- ParaName "Version" $ emptyParams) (paraDirection <<<- ParaDirection Horizontal $ paraShadow <<<- ParaShadow ShadowIn- $ para)- let pinj (PackageIdentifier n v) = inj (n,v)+ $ para) noti+ let pinj (PackageIdentifier (PackageName n) v) = inj (n,v) let pext = do mbp <- ext case mbp of@@ -50,14 +60,14 @@ Just (n,v) -> do if null n then return Nothing- else return (Just $PackageIdentifier n v)- return (wid,pinj,pext,notif)+ else return (Just $PackageIdentifier (PackageName n) v)+ return (wid,pinj,pext) testedWidthEditor :: Editor [(CompilerFlavor, VersionRange)] testedWidthEditor para = do multisetEditor- (ColumnDescr False [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv])- ,("Version Range",\(_,vr) -> [New.cellText := showVersionRange vr])])+ (ColumnDescr True [("Compiler Flavor",\(cv,_) -> [New.cellText := show cv])+ ,("Version Range",\(_,vr) -> [New.cellText := display vr])]) (pairEditor (compilerFlavorEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams) (versionRangeEditor, paraShadow <<<- (ParaShadow ShadowNone) $ emptyParams),@@ -65,12 +75,15 @@ para compilerFlavorEditor :: Editor CompilerFlavor-compilerFlavorEditor para = do- (wid,inj,ext,notif) <- eitherOrEditor- (staticSelectionEditor flavors, paraName <<<- (ParaName "Select compiler") $ emptyParams)- (stringEditor, paraName <<<- (ParaName "Specify compiler") $ emptyParams)+compilerFlavorEditor para noti = do+ noti2 <- emptyNotifier+ noti3 <- emptyNotifier+ (wid,inj,ext) <- eitherOrEditor+ (comboSelectionEditor flavors , paraName <<<- (ParaName "Select compiler") $ emptyParams)+ (stringEditor (\s -> not (null s)), paraName <<<- (ParaName "Specify compiler") $ emptyParams) "Other" (paraName <<<- ParaName "Select" $ para)+ noti let cfinj comp = case comp of (OtherCompiler str) -> inj (Right "") other -> inj (Left other)@@ -80,33 +93,44 @@ Nothing -> return Nothing Just (Right s) -> return (Just $OtherCompiler s) Just (Left other) -> return (Just other)- return (wid,cfinj,cfext,notif)+ return (wid,cfinj,cfext) where flavors = [GHC, NHC, Hugs, HBC, Helium, JHC] versionRangeEditor :: Editor VersionRange-versionRangeEditor para = do- (wid,inj,ext,notif) <-+versionRangeEditor para noti = do+ (wid,inj,ext) <- maybeEditor (eitherOrEditor (pairEditor- (staticSelectionEditor v1, emptyParams)+ (comboSelectionEditor v1, emptyParams) (versionEditor, paraName <<<- ParaName "Enter Version" $ emptyParams), (paraDirection <<<- ParaDirection Vertical)- $ paraName <<<- ParaName "Simple Version Range"- $ emptyParams)+ $ 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) (pairEditor- (staticSelectionEditor v2, emptyParams)+ (comboSelectionEditor v2, emptyParams) (pairEditor (versionRangeEditor, paraShadow <<<- ParaShadow ShadowIn $ emptyParams) (versionRangeEditor, paraShadow <<<- ParaShadow ShadowIn $ emptyParams), paraDirection <<<- ParaDirection Vertical $ emptyParams), paraDirection <<<- ParaDirection Vertical- $ paraName <<<- ParaName "Complex Version Range"- $ emptyParams)+ $ 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 ) "Complex",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) 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)))@@ -136,7 +160,7 @@ -> return (Just (UnionVersionRanges v1 v2)) Just (Just (Right (IntersectVersionRangesS,(v1,v2)))) -> return (Just (IntersectVersionRanges v1 v2))- return (wid,vrinj,vrext,notif)+ return (wid,vrinj,vrext) where v1 = [ThisVersionS,LaterVersionS,ThisOrLaterVersionS,EarlierVersionS,ThisOrEarlierVersionS] v2 = [UnionVersionRangesS,IntersectVersionRangesS]@@ -157,65 +181,82 @@ show IntersectVersionRangesS = "Intersect Version Ranges" versionEditor :: Editor Version-versionEditor para = do- (wid,inj,ext,notiRef) <- stringEditor para- let pinj v = inj (showVersion v)+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 -> do- let l = filter (\(h,t) -> null t) (readP_to_S parseVersion s)- if null l then- return Nothing- else return (Just (fst $head l))- return (wid, pinj, pext, notiRef)+ Just s -> return (simpleParse s)+ return (wid, pinj, pext) -dependencyEditor :: Editor Dependency-dependencyEditor para = do- (wid,inj,ext,notif) <- pairEditor- (stringEditor,paraName <<<- ParaName "Package Name" $ emptyParams)+dependencyEditor :: [PackageIdentifier] -> Editor Dependency+dependencyEditor packages para noti = do+ (wid,inj,ext) <- pairEditor+ (comboSelectionEditor (sort (map (display . pkgName) packages))+ , paraName <<<- ParaName "Package Name" $ emptyParams) (versionRangeEditor,paraName <<<- ParaName "Version" $ emptyParams) (paraDirection <<<- ParaDirection Vertical $ para)- let pinj (Dependency s v) = inj (s,v)+ noti+ let pinj (Dependency (PackageName s) v) = inj (s,v) let pext = do mbp <- ext case mbp of Nothing -> return Nothing Just ("",v) -> return Nothing- Just (s,v) -> return (Just $Dependency s v)- return (wid,pinj,pext,notif)+ Just (s,v) -> return (Just $Dependency (PackageName s) v)+ return (wid,pinj,pext) -dependenciesEditor :: Editor [Dependency]-dependenciesEditor p =+dependenciesEditor :: [PackageIdentifier] -> Editor [Dependency]+dependenciesEditor packages p noti = multisetEditor- (ColumnDescr True [("Package",\(Dependency str _) -> [New.cellText := str])- ,("Version",\(Dependency _ vers) -> [New.cellText := showVersionRange vers])])- (dependencyEditor,emptyParams)- (paraShadow <<<- ParaShadow ShadowIn $ p)+ (ColumnDescr True [("Package",\(Dependency (PackageName str) _) -> [New.cellText := str])+ ,("Version",\(Dependency _ vers) -> [New.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)+ (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 filesEditor :: Maybe FilePath -> FileChooserAction -> String -> Editor [FilePath] filesEditor fp act label p = multisetEditor (ColumnDescr False [("",(\row -> [New.cellText := row]))]) (fileEditor fp act label, emptyParams)- (paraShadow <<<- ParaShadow ShadowIn $ p)+ (paraShadow <<<- ParaShadow ShadowIn $+ paraDirection <<<- ParaDirection Vertical $ p) -stringsEditor :: Editor [String]-stringsEditor p =+stringsEditor :: (String -> Bool) -> Editor [String]+stringsEditor validation p = multisetEditor (ColumnDescr False [("",(\row -> [New.cellText := row]))])- (stringEditor, emptyParams)+ (stringEditor validation, emptyParams) (paraShadow <<<- ParaShadow ShadowIn $ p) panePathEditor :: Editor StandardPath-panePathEditor = staticSelectionEditor [LeftTop,LeftBottom,RightTop,RightBottom]+panePathEditor = genericEditor extensionsEditor :: Editor [Extension]-extensionsEditor = staticMultiselectionEditor extensionsL+extensionsEditor p = staticListEditor extensionsL (paraMultiSel <<<- ParaMultiSel True $ p) +styleEditor :: Editor (Maybe String)+styleEditor p n = do+ styleManager <- sourceStyleSchemeManagerNew+ ids <- sourceStyleSchemeManagerGetSchemeIds styleManager+ maybeEditor (comboSelectionEditor ids, p) True "Select a special style?" p n++ extensionsL :: [Extension]-extensionsL = [+extensionsL = knownExtensions++{--[ OverlappingInstances , UndecidableInstances , IncoherentInstances@@ -246,9 +287,113 @@ , GeneralizedNewtypeDeriving , ExtensibleRecords , RestrictedTypeSynonyms- , HereDocuments]+ , HereDocuments]--} -- ------------------------------------------------------------+-- * BuildInfos+-- ------------------------------------------------------------++data Library' = Library'{+ exposedModules' :: [ModuleName]+, libExposed' :: Bool+, libBuildInfoIdx :: Int}+ deriving (Show, Eq)++data Executable' = Executable'{+ exeName' :: String+, modulePath' :: FilePath+, buildInfoIdx :: Int}+ deriving (Show, Eq)++instance Default Library'+ where getDefault = Library' [] getDefault getDefault++instance Default Executable'+ where getDefault = Executable' getDefault getDefault getDefault+++libraryEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Library'+libraryEditor fp modules numBuildInfos para noti = do+ (wid,inj,ext) <-+ pairEditor+ (modulesEditor modules,+ paraName <<<- ParaName "Exposed Modules"+ $ paraPack <<<- ParaPack PackGrow+ $ paraMinSize <<<- ParaMinSize (-1,500)+ $ para)+ (buildInfoEditorP numBuildInfos, paraName <<<- ParaName "Build Info"+ $ paraPack <<<- ParaPack PackNatural+ $ para)+ (paraDirection <<<- ParaDirection Vertical+ $ paraPack <<<- ParaPack PackGrow+ $ emptyParams)+ noti+ let pinj (Library' em True bi) = inj (map display em,bi)+ pinj _ = throwIDE "SpecialEditors>>libraryEditor: No Library"+ let pext = do+ mbp <- ext+ case mbp of+ Nothing -> return Nothing+ Just (em,bi) -> return (Just $Library' (map (\s -> forceJust (simpleParse s)+ "SpecialEditor >> libraryEditor: no parse for moduile name") em) True bi)+ return (wid,pinj,pext)++moduleEditor :: [ModuleName] -> Editor String+moduleEditor modules = comboSelectionEditor (map display modules)++modulesEditor :: [ModuleName] -> Editor [String]+modulesEditor modules = staticListEditor (map display modules)++executablesEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor [Executable']+executablesEditor fp modules countBuildInfo p =+ multisetEditor+ (ColumnDescr True [("Executable Name",\(Executable' exeName _ _) -> [New.cellText := exeName])+ ,("Module Path",\(Executable' _ mp _) -> [New.cellText := mp])++ ,("Build info index",\(Executable' _ _ bii) -> [New.cellText := show (bii + 1)])])+ (executableEditor fp modules countBuildInfo,emptyParams)+ (paraShadow <<<- ParaShadow ShadowIn $ p)++executableEditor :: Maybe FilePath -> [ModuleName] -> Int -> Editor Executable'+executableEditor fp modules countBuildInfo para noti = do+ (wid,inj,ext) <- pairEditor+ (pairEditor+ (stringEditor (\s -> not (null s)),+ paraName <<<- ParaName "Executable Name"+ $ emptyParams)+ (stringEditor (\s -> not (null s)),+ paraDirection <<<- ParaDirection Vertical+ $ paraName <<<- ParaName "File with main function"+ $ emptyParams), para)+ (buildInfoEditorP countBuildInfo, paraName <<<- ParaName "Build Info"+ $ paraOuterAlignment <<<- ParaOuterAlignment (0.0, 0.0, 0.0, 0.0)+ $ paraOuterPadding <<<- ParaOuterPadding (0, 0, 0, 0)+ $ paraInnerAlignment <<<- ParaInnerAlignment (0.0, 0.0, 0.0, 0.0)+ $ paraInnerPadding <<<- ParaInnerPadding (0, 0, 0, 0)+ $ emptyParams)+ (paraDirection <<<- ParaDirection Vertical $ para)+ noti+ let pinj (Executable' s f bi) = inj ((s,f),bi)+ let pext = do+ mbp <- ext+ case mbp of+ Nothing -> return Nothing+ Just ((s,f),bi) -> return (Just $Executable' s f bi)+ return (wid,pinj,pext)++buildInfoEditorP :: Int -> Editor Int+buildInfoEditorP numberOfBuildInfos para noti = do+ (wid,inj,ext) <- intEditor (1.0,fromIntegral numberOfBuildInfos,1.0)+ (paraName <<<- ParaName "Build Info" $para) noti+ let pinj i = inj (i + 1)+ let pext = do+ mbV <- ext+ case mbV of+ Nothing -> return Nothing+ Just i -> return (Just (i - 1))+ return (wid,pinj,pext)++-- ------------------------------------------------------------ -- * (Boring) default values -- ------------------------------------------------------------ @@ -259,11 +404,7 @@ where getDefault = UnionVersionRangesS instance Default Version- where getDefault = let version = (let l = (readP_to_S parseVersion) "0"- in if null l- then throwIDE "verion parser failed"- else fst $head l)- in version+ where getDefault = forceJust (simpleParse "0") "SpecialEditors>>default version" instance Default VersionRange where getDefault = AnyVersion@@ -275,7 +416,7 @@ where getDefault = emptyBuildInfo instance Default Library- where getDefault = Library [] getDefault+ where getDefault = Library [] getDefault getDefault instance Default Dependency where getDefault = Dependency getDefault getDefault@@ -283,7 +424,8 @@ instance Default Executable where getDefault = Executable getDefault getDefault getDefault -+instance Default PackageName+ where getDefault = PackageName getDefault
− src/IDE/ToolbarPane.hs
@@ -1,94 +0,0 @@-{-# OPTIONS_GHC -fglasgow-exts #-}------------------------------------------------------------------------------------ Module : IDE.ToolbarPane--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | The pane of ide where modules are presented in tree form with their--- packages and exports-------------------------------------------------------------------------------------module IDE.ToolbarPane (- getToolbar-) where--import Graphics.UI.Gtk hiding (get)-import Data.Maybe-import Control.Monad.Reader--import IDE.Core.State-import IDE.Framework.ViewFrame--instance IDEObject IDEToolbar-instance Pane IDEToolbar- where- primPaneName _ = "Toolbar"- getTopWidget = castToWidget . toolbar- paneId b = "*Toolbar"- makeActive p = throwIDE "don't activate toolbar"- close pane = do- (panePath,_) <- guiPropertiesFromName (paneName pane)- nb <- getNotebook panePath- mbI <- lift $notebookPageNum nb (getTopWidget pane)- case mbI of- Nothing -> lift $ do- sysMessage Normal "notebook page not found: unexpected"- return ()- Just i -> do- deactivatePaneIfActive pane- lift $notebookRemovePage nb i- removePaneAdmin pane---instance RecoverablePane IDEToolbar ToolbarState where- saveState p = do- mbToolbar <- getPane ToolbarCasting- case mbToolbar of- Nothing -> return Nothing- Just p -> lift $ do- return (Just (StateC ToolbarState))- recoverState pp ToolbarState = do- nb <- getNotebook pp- initToolbar pp nb--getToolbar :: IDEM IDEToolbar-getToolbar = do- mbToolbar <- getPane ToolbarCasting- case mbToolbar of- Nothing -> do- prefs <- readIDE prefs- layout <- readIDE layout- let pp = getStandardPanePath (controlPanePath prefs) layout- nb <- getNotebook pp- initToolbar pp nb- mbToolbar <- getPane ToolbarCasting- case mbToolbar of- Nothing -> throwIDE "Can't init control pane"- Just m -> return m- Just m -> return m--initToolbar :: PanePath -> Notebook -> IDEAction-initToolbar panePath nb = do- ideR <- ask- currentInfo <- readIDE currentInfo- res <- triggerEvent ideR (GetToolbar [])- let (tb1,tb2) = case res of- GetToolbar (_:t1:t2:_) -> (t1,t2)- _ -> throwIDE "Failed to build toolbar"- (buf,cids) <- lift $ do- vb <- vBoxNew False 0- boxPackStart vb tb1 PackNatural 0- boxPackStart vb tb2 PackNatural 0- let toolbar' = IDEToolbar vb- notebookInsertOrdered nb vb (paneName toolbar')- widgetShowAll vb- return (toolbar',[])- addPaneAdmin buf (BufConnections [] [] []) panePath- lift $widgetGrabFocus (toolbar buf)-
− src/IDE/Utils/DeepSeq.hs
@@ -1,60 +0,0 @@-module IDE.Utils.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) y = deepSeq a $ deepSeq b y--instance (DeepSeq a,DeepSeq b,DeepSeq c) => DeepSeq (a,b,c) where- deepSeq (a,b,c) y = deepSeq a $ deepSeq b $ deepSeq c y--instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d) => DeepSeq (a,b,c,d) where- deepSeq (a,b,c,d) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d y--instance (DeepSeq a,DeepSeq b,DeepSeq c,DeepSeq d,DeepSeq e) => DeepSeq (a,b,c,d,e) where- deepSeq (a,b,c,d,e) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e y--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) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f y--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) y = deepSeq a $ deepSeq b $ deepSeq c $ deepSeq d $ deepSeq e $ deepSeq f $ deepSeq g y-----
− src/IDE/Utils/Default.hs
@@ -1,40 +0,0 @@------------------------------------------------------------------------------------- Module : IDE.Utils.Default--- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)--- License : GNU-GPL------ Maintainer : Juergen Nicklisch-Franken <jnf at arcor.de>--- Stability : experimental--- Portability : portable------ | Module for default values of a data type------------------------------------------------------------------------------------module IDE.Utils.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] where- getDefault = []--instance Default (Maybe alpha) where- getDefault = Nothing-
− src/IDE/Utils/File.hs
@@ -1,252 +0,0 @@-module IDE.Utils.File (- allModules-, allHiFiles-, allHaskellSourceFiles-, cabalFileName-, allCabalFiles-, getConfigFilePathForLoad-, hasConfigDir-, getConfigFilePathForSave-, getCollectorPath-, getSysLibDir-, moduleNameFromFilePath-, findKnownPackages-, isSubPath-, findSourceFile--) where--import System.FilePath-import System.Directory-import System.IO-import Data.Char-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 qualified Data.List as List-import qualified Data.Set as Set-import Data.Set (Set)-import Data.List(isSuffixOf, isPrefixOf)--import Paths_leksah-import IDE.Core.State---- | 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]- -> ModuleIdentifier- -> IO (Maybe FilePath)-findSourceFile directories exts modId =- let modulePath = dots_to_slashes 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) = do- exists <- doesFileExist h- if exists- then return (Just h)- else find' t--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--hasConfigDir :: IO Bool-hasConfigDir = do- d <- getHomeDirectory- let filePath = d </> ".leksah"- doesDirectoryExist filePath---getConfigFilePathForLoad :: String -> IO FilePath-getConfigFilePathForLoad fn = do- cd <- getConfigDir- ex <- doesFileExist (cd </> fn)- if ex- then return (cd </> fn)- else 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 [String]-allModules filePath = 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 []--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 -> IO [FilePath]-allFilesWithExtensions extensions recurseFurther filePath = 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- otherFiles <-- if recurseFurther || (not recurseFurther && null choosenFiles)- then mapM (allFilesWithExtensions extensions recurseFurther) dirs- else return []- return (choosenFiles ++ concat otherFiles)- else return []----moduleNameFromFilePath :: FilePath -> IO (Maybe String)-moduleNameFromFilePath fp = do- exists <- doesFileExist fp- if exists- then do- str <- readFile fp- let str' = if takeExtension fp == ".lhs"- then unlit fp str- else str- let parseRes = parse moduleNameParser fp str'- case parseRes of- Left err -> do- sysMessage Normal $show err- return Nothing- Right str -> do- return (Just str)- else return Nothing--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--- skipMany anyChar--- eof- 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 = do- paths <- getDirectoryContents filePath- let nameList = map dropExtension $filter (\s -> ".pack" `isSuffixOf` s) paths- return (Set.fromList nameList)--cabalFileName :: FilePath -> IO (Maybe String)-cabalFileName filePath = 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--getCollectorPath :: String -> IO FilePath-getCollectorPath version = 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 = do- (_, out, _, pid) <- runInteractiveProcess "ghc" ["--print-libdir"] Nothing Nothing- libDir <- hGetLine out- let libDir2 = if ord (last libDir) == 13- then take (length libDir - 1) libDir- else libDir- waitForProcess pid- return (normalise libDir2)-----
src/Main.hs view
@@ -1,4 +1,22 @@-import IDE.Leksah+-----------------------------------------------------------------------------+--+-- 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 view
@@ -0,0 +1,68 @@+{-# OPTIONS_GHC -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : MyMissing+-- Copyright : (c) Juergen Nicklisch-Franken (aka Jutaro)+-- License : GNU-GPL+--+-- Maintainer : Juergen Nicklisch-Franken <info@leksah.org>+-- Stability : experimental+-- Portability : portable+--+-- | Module for missing base functions+--+------------------------------------------------------------------------------++module MyMissing (+ allOf+, forceJust+, forceHead+, split+, replace+) where++import Data.List (unfoldr)++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