leksah-server-0.12.1.2/0000755000000000000000000000000011770163231012675 5ustar0000000000000000leksah-server-0.12.1.2/leksah-server.cabal0000644000000000000000000001566011770163231016444 0ustar0000000000000000name: leksah-server version: 0.12.1.2 cabal-version: >= 1.10.2 build-type: Simple license: GPL license-file: LICENSE copyright: 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie maintainer: maintainer@leksah.org stability: provisional homepage: http://leksah.org package-url: http://code.haskell.org/leksah-collector bug-reports: http://code.google.com/p/leksah/issues/list synopsis: Metadata collection for leksah description: The interface to GHC-API for leksah category: IDE author: Juergen "jutaro" Nicklisch-Franken, Hamish Mackenzie data-dir: "" tested-with: GHC ==6.10 || ==6.12 || ==7.0 data-files: data/prefscoll.lkshp flag curl Default: False Description: Use runs curl instead of wget (curl is the default on OSX) flag libcurl Default: False Description: Use libcurl instead of running wget flag threaded default: True description: Build with support for multithreaded execution library default-language: Haskell98 build-depends: Cabal >=1.6.0.1 && <1.15, base >= 4.0.0.0 && <4.6, binary >=0.5.0.0 && <0.6, binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.10, containers >=0.2.0.0 && <0.5, directory >=1.0.0.2 && <1.2, filepath >=1.1.0.1 && <1.4, ghc >=6.10.1 && <7.5, ltk >=0.12.1.0 && <0.13, parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.5, deepseq >=1.1 && <1.4, hslogger >= 1.0.7 && <1.2, network >=2.2 && <3.0, enumerator >=0.4.14 && < 0.5, attoparsec-enumerator >=0.3 && <0.4, attoparsec >=0.10.0.3 && <0.11, transformers >=0.2.2.0 && <0.4, strict >=0.3.2 && <0.4 if (impl(ghc >= 7.2)) binary-shared >=0.8.2 if (impl(ghc >= 7.4)) build-depends: haddock >= 2.7.2 && <2.11 else if (impl(ghc >= 7.2)) build-depends: haddock >= 2.7.2 && <2.10 else if (impl(ghc >= 7.0)) build-depends: haddock >= 2.7.2 && <2.9.3 else if (impl(ghc >= 6.12)) build-depends: haddock >= 2.7.2 && <2.9 else build-depends: haddock-leksah == 2.5.0 if (impl(ghc >= 7.2)) build-depends: process >= 1.1 && <1.2 else build-depends: process-leksah >=1.0.1.3 && <1.1 if os(windows) build-depends: Win32 >=2.2.0.0 && <2.3 extra-libraries: kernel32 pango-1.0 glib-2.0 else build-depends: unix >=2.3.1.0 && <2.6 if flag(curl) || os(osx) cpp-options: -DUSE_CURL if flag(libcurl) build-depends: curl >=1.3.5 && <1.4 cpp-options: -DUSE_LIBCURL exposed-modules: IDE.Utils.GHCUtils IDE.Utils.Utils IDE.Utils.Tool IDE.Utils.FileUtils IDE.Core.CTypes IDE.Core.Serializable IDE.StrippedPrefs IDE.Utils.Server IDE.Metainfo.PackageCollector IDE.Utils.VersionUtils exposed: True buildable: True default-extensions: CPP hs-source-dirs: src other-modules: IDE.Metainfo.WorkspaceCollector IDE.Metainfo.InterfaceCollector IDE.Metainfo.SourceCollectorH IDE.Metainfo.SourceDB Paths_leksah_server if (impl(ghc >= 6.12)) ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans else ghc-options: -Wall -ferror-spans ghc-prof-options: -auto-all -prof executable leksah-server default-language: Haskell98 build-depends: Cabal >=1.6.0.1 && <1.15, base >= 4.0.0.0 && <4.6, binary >=0.5.0.0 && <0.6, binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.10, containers >=0.2.0.0 && <0.5, directory >=1.0.0.2 && <1.2, filepath >=1.1.0.1 && <1.6, ghc >=6.10.1 && <7.5, ltk >=0.12.1.0 && <0.13, parsec >=2.1.0.1 && <3.2, pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.5, deepseq >=1.1 && <1.4, hslogger >= 1.0.7 && <1.2, network >=2.2 && <3.0, enumerator >= 0.4.14 && <0.5, attoparsec-enumerator >=0.3 && <0.4, attoparsec >=0.10.0.3 && <0.11, transformers >=0.2.2.0 && <0.4, strict >=0.3.2 && <0.4 if (impl(ghc >= 7.4)) build-depends: haddock >= 2.7.2 && <2.11 else if (impl(ghc >= 7.2)) build-depends: haddock >= 2.7.2 && <2.10 else if (impl(ghc >= 7.0)) build-depends: haddock >= 2.7.2 && <2.9.3 else if (impl(ghc >= 6.12)) build-depends: haddock >= 2.7.2 && <2.9 else build-depends: haddock-leksah == 2.5.0 if (impl(ghc >= 7.2)) build-depends: process >= 1.1 && <1.2 else build-depends: process-leksah >=1.0.1.3 && <1.1 if os(windows) build-depends: Win32 >=2.2.0.0 && <2.3 extra-libraries: kernel32 pango-1.0 glib-2.0 else build-depends: unix >=2.3.1.0 && <2.6 if flag(curl) || os(osx) cpp-options: -DUSE_CURL if flag(libcurl) build-depends: curl >=1.3.5 && <1.4 cpp-options: -DUSE_LIBCURL main-is: IDE/Metainfo/Collector.hs buildable: True default-extensions: CPP hs-source-dirs: src other-modules: IDE.StrippedPrefs IDE.Utils.GHCUtils IDE.Utils.Utils IDE.Core.CTypes IDE.Core.Serializable IDE.Metainfo.WorkspaceCollector IDE.Metainfo.InterfaceCollector IDE.Metainfo.SourceCollectorH IDE.Metainfo.SourceDB IDE.Utils.Tool IDE.HeaderParser IDE.Metainfo.PackageCollector if flag(threaded) ghc-options: -threaded if impl(ghc >= 7.0) ghc-options: -rtsopts if impl(ghc >= 6.12) ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans else ghc-options: -Wall -ferror-spans ghc-prof-options: -auto-all -prof executable leksahecho default-language: Haskell98 main-is: LeksahEcho.hs buildable: True default-extensions: CPP hs-source-dirs: src ghc-prof-options: -auto-all -prof -- ghc-shared-options: -auto-all -prof build-depends: base >= 4.0.0.0 && <4.6, hslogger >= 1.0.7 && <1.2, deepseq >=1.1 && <1.4, bytestring >=0.9.0.1 && <0.10, enumerator >= 0.4.14 && <0.5, attoparsec-enumerator >=0.3 && <0.4, attoparsec >=0.10.0.3 && <0.11, transformers >=0.2.2.0 && <0.4 if (impl(ghc >= 7.2)) build-depends: process >= 1.1 && <1.2 else build-depends: process-leksah >=1.0.1.3 && <1.1 if flag(threaded) ghc-options: -threaded if (impl(ghc >= 6.12)) ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans else ghc-options: -Wall -ferror-spans test-suite test-tool default-language: Haskell98 type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: TestTool.hs build-depends: base >= 4.0.0.0 && <4.6, hslogger >= 1.0.7 && <1.3, leksah-server, HUnit >=1.2 && <1.3, transformers >=0.2.2.0 && <0.4, enumerator >=0.4.14 && <0.5 if (impl(ghc >= 7.2)) build-depends: process >= 1.1 && <1.2 else build-depends: process-leksah >=1.0.1.3 && <1.1 leksah-server-0.12.1.2/LICENSE0000644000000000000000000004310311770163230013702 0ustar0000000000000000 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. Copyright (C) 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. , 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. leksah-server-0.12.1.2/Setup.lhs0000644000000000000000000000016411770163231014506 0ustar0000000000000000#!/usr/bin/runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain leksah-server-0.12.1.2/tests/0000755000000000000000000000000011770163230014036 5ustar0000000000000000leksah-server-0.12.1.2/tests/TestTool.hs0000644000000000000000000002116311770163230016152 0ustar0000000000000000{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- -- Module : Main -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | Windows systems do not often have a real echo executable (so --with-ghc=echo fails) -- ----------------------------------------------------------------------------- module Main ( main ) where import System.Environment (getArgs) import System.Exit (exitWith, exitSuccess, exitFailure, ExitCode(..)) import IDE.Utils.Tool (toolProcess, executeGhciCommand, ToolOutput(..), runTool', newGhci') #ifdef MIN_VERSION_process_leksah import IDE.System.Process (interruptProcessGroup, getProcessExitCode) #else import System.Process (interruptProcessGroupOf, getProcessExitCode) #endif import Test.HUnit ((@=?), (@?=), putTextToHandle, Counts(..), runTestTT, assertBool, runTestText, (~:), Testable(..), Test(..)) import System.IO (hPutStr, stdout, hPutStrLn, stderr) import qualified Data.Enumerator.List as EL (consume) import Control.Concurrent (threadDelay, forkIO, takeMVar, putMVar, newEmptyMVar) import Control.Monad.IO.Class (liftIO) import Control.Monad (forM_) import System.Log.Logger (setLevel, rootLoggerName, updateGlobalLogger) import System.Log (Priority(..)) runSelf' args = runTool' "dist/build/test-tool/test-tool" args Nothing -- stderr and stdout may not be in sync check output expected = do checkFiltered notOut checkFiltered notErr where checkFiltered f = filter f output @?= filter f expected notErr (ToolError _) = False notErr _ = True notOut (ToolOutput _) = False notOut _ = True runTests testMVar = loop where loop = do mbTest <- takeMVar testMVar case mbTest of Just test -> do test loop Nothing -> return () sendTest testMVar test = do liftIO $ putMVar testMVar $ Just test doneTesting testMVar = do liftIO $ putMVar testMVar $ Nothing tests = test [ "Exit Success" ~: do (output, _) <- runSelf' ["ExitSuccess"] output `check` [ToolExit ExitSuccess], "Exit Failure" ~: do (output, _) <- runSelf' ["Exit42"] output `check` [ToolExit (ExitFailure 42)], "Single Blank Out Line" ~: do (output, _) <- runSelf' ["BlankLine", "StdOut"] output `check` [ToolOutput "", ToolExit ExitSuccess], "Single Blank Err Line" ~: do (output, _) <- runSelf' ["BlankLine", "StdErr"] output `check` [ToolError "", ToolExit ExitSuccess], "Hello Out" ~: do (output, _) <- runSelf' ["Hello", "StdOut"] output `check` [ToolOutput "Hello World", ToolExit ExitSuccess], "Hello Err" ~: do (output, _) <- runSelf' ["Hello", "StdErr"] output `check` [ToolError "Hello World", ToolExit ExitSuccess], "Both" ~: do (output, _) <- runSelf' ["ErrAndOut"] output `check` [ToolError "Error", ToolOutput "Output", ToolExit ExitSuccess], "Unterminated Out" ~: do (output, _) <- runSelf' ["Unterminated", "StdOut"] output `check` [ToolOutput "Unterminated", ToolExit ExitSuccess], "Unterminated Err" ~: do (output, _) <- runSelf' ["Unterminated", "StdErr"] output `check` [ToolError "Unterminated", ToolExit ExitSuccess], "GHCi Failed Sart" ~: do t <- newEmptyMVar tool <- newGhci' ["MissingFile.hs"] $ do output <- EL.consume sendTest t $ last output @?= (ToolPrompt "") executeGhciCommand tool ":quit" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput ":quit", ToolOutput "Leaving GHCi.", ToolExit ExitSuccess], "GHCi" ~: do t <- newEmptyMVar tool <- newGhci' [] $ do output <- EL.consume sendTest t $ last output @?= (ToolPrompt "") executeGhciCommand tool ":m +System.IO" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput ":m +System.IO", ToolPrompt ""] executeGhciCommand tool "hPutStr stderr \"Test\"" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput "hPutStr stderr \"Test\"", ToolError "Test", ToolPrompt ""] executeGhciCommand tool "1+1" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput "1+1", ToolOutput "2", ToolPrompt ""] executeGhciCommand tool "jfkdfjdkl" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput "jfkdfjdkl", ToolError "", #if __GLASGOW_HASKELL__ > 702 ToolError ":22:1: Not in scope: `jfkdfjdkl'", #else ToolError ":1:1: Not in scope: `jfkdfjdkl'", #endif ToolPrompt ""] executeGhciCommand tool "\n1+1" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput "", ToolInput "1+1", ToolOutput "2", ToolPrompt ""] executeGhciCommand tool ":m + Prelude" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput ":m + Prelude", ToolPrompt ""] executeGhciCommand tool "\njfkdfjdkl" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput "", ToolInput "jfkdfjdkl", ToolError "", #if __GLASGOW_HASKELL__ > 702 ToolError ":37:1: Not in scope: `jfkdfjdkl'", #else ToolError ":1:1: Not in scope: `jfkdfjdkl'", #endif ToolPrompt ""] executeGhciCommand tool "do\n putStrLn \"1\"\n putStrLn \"2\"\n putStrLn \"3\"\n putStrLn \"4\"\n putStrLn \"5\"\n" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput "do", ToolInput " putStrLn \"1\"", ToolInput " putStrLn \"2\"", ToolInput " putStrLn \"3\"", ToolInput " putStrLn \"4\"", ToolInput " putStrLn \"5\"", ToolOutput "1", ToolOutput "2", ToolOutput "3", ToolOutput "4", ToolOutput "5", ToolPrompt ""] executeGhciCommand tool "do\n putStrLn \"| 1\"\n putStrLn \"| 2\"\n putStrLn \"| 3\"\n putStrLn \"| 4\"\n putStrLn \"| 5\"\n" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput "do", ToolInput " putStrLn \"| 1\"", ToolInput " putStrLn \"| 2\"", ToolInput " putStrLn \"| 3\"", ToolInput " putStrLn \"| 4\"", ToolInput " putStrLn \"| 5\"", ToolOutput "| 1", ToolOutput "| 2", ToolOutput "| 3", ToolOutput "| 4", ToolOutput "| 5", ToolPrompt ""] executeGhciCommand tool "putStr \"ABC\"" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput "putStr \"ABC\"", ToolPrompt "ABC"] executeGhciCommand tool ":m +Data.List" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput ":m +Data.List", ToolPrompt ""] executeGhciCommand tool ":quit" $ do output <- EL.consume sendTest t $ output `check` [ ToolInput ":quit", ToolOutput "Leaving GHCi.", ToolExit ExitSuccess] runTests t] main :: IO () main = do args <- getArgs case args of [] -> do updateGlobalLogger rootLoggerName (\ l -> setLevel DEBUG l) (Counts{failures=failures}, _) <- runTestText (putTextToHandle stderr False) tests if failures == 0 then exitSuccess else exitFailure ["ExitSuccess"] -> exitSuccess ["Exit42"] -> exitWith (ExitFailure 42) ["BlankLine", o] -> hPutStrLn (h o) "" ["Hello", o] -> hPutStrLn (h o) "Hello World" ["ErrAndOut"] -> hPutStrLn stderr "Error" >> hPutStrLn stdout "Output" ["Unterminated", o] -> hPutStr (h o) "Unterminated" _ -> exitFailure where h "StdErr" = stderr h _ = stdout leksah-server-0.12.1.2/data/0000755000000000000000000000000011770163230013605 5ustar0000000000000000leksah-server-0.12.1.2/data/prefscoll.lkshp0000644000000000000000000000067411770163230016650 0ustar0000000000000000Paths under which haskell sources for packages may be found: [] Maybe a directory for unpacking cabal packages: Just "~/.leksah-0.12/packageSources" An URL to load prebuild metadata: "http://www.leksah.org" A strategy for downloading prebuild metadata: RetrieveThenBuild Port number for server connection: 11111 End the server with last connection: True leksah-server-0.12.1.2/src/0000755000000000000000000000000011770163230013463 5ustar0000000000000000leksah-server-0.12.1.2/src/LeksahEcho.hs0000644000000000000000000000171111770163230016025 0ustar0000000000000000----------------------------------------------------------------------------- -- -- Module : Main -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | Windows systems do not often have a real echo executable (so --with-ghc=echo fails) -- ----------------------------------------------------------------------------- module Main ( main ) where import System.Environment (getArgs) import IDE.Utils.VersionUtils (getHaddockVersion, getGhcVersion) main :: IO () main = do args <- getArgs if elem "--version" args then putStrLn =<< getHaddockVersion else if elem "--ghc-version" args then putStrLn =<< getGhcVersion else if elem "--numeric-version" args then putStrLn =<< getGhcVersion else putStrLn $ unwords args leksah-server-0.12.1.2/src/IDE/0000755000000000000000000000000011770163230014064 5ustar0000000000000000leksah-server-0.12.1.2/src/IDE/HeaderParser.hs0000644000000000000000000001107311770163230016767 0ustar0000000000000000----------------------------------------------------------------------------- -- -- Module : IDE.HeaderParser -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.HeaderParser ( parseTheHeader ) where import IDE.Core.CTypes hiding(SrcSpan(..)) import GHC hiding (ImportDecl) import FastString(unpackFS) import RdrName(showRdrName) import IDE.Utils.GHCUtils import Data.Maybe (mapMaybe) #if MIN_VERSION_ghc(7,4,1) import Outputable(pprPrefixOcc,showSDoc) #else import Outputable(pprHsVar,showSDoc) #endif import IDE.Utils.FileUtils (figureOutHaddockOpts) import Control.Monad.IO.Class (MonadIO(..)) parseTheHeader :: FilePath -> IO ServerAnswer parseTheHeader filePath = do text <- readFile filePath opts <- figureOutHaddockOpts parseResult <- liftIO $ myParseHeader filePath text opts case parseResult of Left str -> return (ServerFailed str) Right (pr@HsModule{ hsmodImports = []}) -> do let i = case hsmodDecls pr of decls@(_hd:_tl) -> (foldl (\ a b -> min a (srcSpanStartLine' (getLoc b))) 0 decls) - 1 [] -> case hsmodExports pr of Just list -> (foldl (\ a b -> max a (srcSpanEndLine' (getLoc b))) 0 list) + 1 Nothing -> case hsmodName pr of Nothing -> 0 Just mn -> srcSpanEndLine' (getLoc mn) + 2 return (ServerHeader (Right i)) Right (_pr@HsModule{ hsmodImports = imports }) -> return (ServerHeader (Left (transformImports imports))) transformImports :: [LImportDecl RdrName] -> [ImportDecl] transformImports = map transformImport transformImport :: LImportDecl RdrName -> ImportDecl transformImport (L srcSpan importDecl) = ImportDecl { importLoc = srcSpanToLocation srcSpan, importModule = modName, importQualified = ideclQualified importDecl, importSrc = ideclSource importDecl, importPkg = pkgQual, importAs = impAs, importSpecs = specs} where modName = moduleNameString $ unLoc $ ideclName importDecl pkgQual = case ideclPkgQual importDecl of Nothing -> Nothing Just fs -> Just (unpackFS fs) impAs = case ideclAs importDecl of Nothing -> Nothing Just mn -> Just (moduleNameString mn) specs = case ideclHiding importDecl of Nothing -> Nothing Just (hide, list) -> Just (ImportSpecList hide (mapMaybe transformEntity list)) transformEntity :: LIE RdrName -> Maybe ImportSpec #if MIN_VERSION_ghc(7,2,0) transformEntity (L _ (IEVar name)) = Just (IVar (showSDoc (pprPrefixOcc name))) #else transformEntity (L _ (IEVar name)) = Just (IVar (showSDoc (pprHsVar name))) #endif transformEntity (L _ (IEThingAbs name)) = Just (IAbs (showRdrName name)) transformEntity (L _ (IEThingAll name)) = Just (IThingAll (showRdrName name)) transformEntity (L _ (IEThingWith name list)) = Just (IThingWith (showRdrName name) (map showRdrName list)) transformEntity _ = Nothing #if MIN_VERSION_ghc(7,2,0) srcSpanToLocation :: SrcSpan -> Location srcSpanToLocation (RealSrcSpan span') = Location (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span') srcSpanToLocation _ = error "srcSpanToLocation: unhelpful span" srcSpanStartLine' :: SrcSpan -> Int srcSpanStartLine' (RealSrcSpan span) = srcSpanStartLine span srcSpanStartLine' _ = error "srcSpanStartLine': unhelpful span" srcSpanEndLine' :: SrcSpan -> Int srcSpanEndLine' (RealSrcSpan span) = srcSpanEndLine span srcSpanEndLine' _ = error "srcSpanEndLine': unhelpful span" #else srcSpanToLocation :: SrcSpan -> Location srcSpanToLocation span' | not (isGoodSrcSpan span') = error "srcSpanToLocation: unhelpful span" srcSpanToLocation span' = Location (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span') srcSpanStartLine' :: SrcSpan -> Int srcSpanStartLine' = srcSpanStartLine srcSpanEndLine' :: SrcSpan -> Int srcSpanEndLine' = srcSpanEndLine #endif leksah-server-0.12.1.2/src/IDE/StrippedPrefs.hs0000644000000000000000000001017211770163230017213 0ustar0000000000000000----------------------------------------------------------------------------- -- -- Module : IDE.StrippedPrefs -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.StrippedPrefs ( Prefs(..) , RetrieveStrategy(..) , readStrippedPrefs , writeStrippedPrefs , getSourceDirectories , getUnpackDirectory ) where import Text.PrinterParser import Graphics.UI.Editor.Parameters (emptyParams, Parameter(..), (<<<-), paraName) import qualified Text.PrettyPrint as PP (text) import System.FilePath (joinPath, (), dropTrailingPathSeparator, splitPath) import System.Directory (getHomeDirectory) import Control.Monad (liftM) import IDE.Core.CTypes (RetrieveStrategy(..)) -- -- | Preferences is a data structure to hold configuration data -- data Prefs = Prefs { sourceDirectories :: [FilePath] , unpackDirectory :: Maybe FilePath , retrieveURL :: String , retrieveStrategy :: RetrieveStrategy , serverPort :: Int , endWithLastConn :: Bool } deriving(Eq,Show) defaultPrefs :: Prefs defaultPrefs = Prefs { sourceDirectories = [] , unpackDirectory = Nothing , retrieveURL = "http://www.leksah.org/" , retrieveStrategy = RetrieveThenBuild , serverPort = 11111 , endWithLastConn = True } -- ------------------------------------------------------------ -- * Parsing -- ------------------------------------------------------------ readStrippedPrefs :: FilePath -> IO Prefs readStrippedPrefs fn = readFields fn prefsDescription defaultPrefs writeStrippedPrefs :: FilePath -> Prefs -> IO () writeStrippedPrefs fpath prefs = writeFields fpath prefs prefsDescription prefsDescription :: [FieldDescriptionS Prefs] prefsDescription = [ mkFieldS (paraName <<<- ParaName "Paths under which haskell sources for packages may be found" $ emptyParams) (PP.text . show) readParser sourceDirectories (\b a -> a{sourceDirectories = b}) , mkFieldS (paraName <<<- ParaName "Maybe a directory for unpacking cabal packages" $ emptyParams) (PP.text . show) readParser unpackDirectory (\b a -> a{unpackDirectory = b}) , mkFieldS (paraName <<<- ParaName "An URL to load prebuild metadata" $ emptyParams) (PP.text . show) stringParser retrieveURL (\b a -> a{retrieveURL = b}) , mkFieldS (paraName <<<- ParaName "A strategy for downloading prebuild metadata" $ emptyParams) (PP.text . show) readParser retrieveStrategy (\b a -> a{retrieveStrategy = b}) , mkFieldS (paraName <<<- ParaName "Port number for server connection" $ emptyParams) (PP.text . show) intParser serverPort (\b a -> a{serverPort = b}) , mkFieldS (paraName <<<- ParaName "End the server with last connection" $ emptyParams) (PP.text . show) boolParser endWithLastConn (\b a -> a{endWithLastConn = b}) ] -- ------------------------------------------------------------ -- * Cross platform support for "~" at the start of paths -- ------------------------------------------------------------ -- | Expand the users home folder into paths such as "~/x" expandHomePath :: FilePath -> IO FilePath expandHomePath p = case splitPath p of h : rest | dropTrailingPathSeparator h == "~" -> do home <- getHomeDirectory return $ home joinPath rest _ -> return p getSourceDirectories :: Prefs -> IO [FilePath] getSourceDirectories = (mapM expandHomePath) . sourceDirectories getUnpackDirectory :: Prefs -> IO (Maybe FilePath) getUnpackDirectory = maybe (return Nothing) (liftM Just . expandHomePath) . unpackDirectory leksah-server-0.12.1.2/src/IDE/Utils/0000755000000000000000000000000011770163230015164 5ustar0000000000000000leksah-server-0.12.1.2/src/IDE/Utils/VersionUtils.hs0000644000000000000000000000262611770163230020174 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.VersionUtils -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL Nothing -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Utils.VersionUtils ( getHaddockVersion , getGhcVersion ) where import IDE.Utils.Tool (toolline, runTool') import Data.Char (ord) import qualified Data.List as List (init) import System.Log.Logger (debugM) getGhcVersion :: IO FilePath getGhcVersion = catch (do (!output,_) <- runTool' "ghc" ["--numeric-version"] Nothing let vers = toolline $ head output vers2 = if ord (last vers) == 13 then List.init vers else vers debugM "leksah-server" $ "Got GHC Version " ++ vers2 return vers2 ) $ \ _ -> error ("FileUtils>>getGhcVersion failed") getHaddockVersion :: IO String getHaddockVersion = catch (do (!output,_) <- runTool' "haddock" ["--version"] Nothing let vers = toolline $ head output vers2 = if ord (last vers) == 13 then List.init vers else vers return vers2 ) $ \ _ -> error ("FileUtils>>getHaddockVersion failed") leksah-server-0.12.1.2/src/IDE/Utils/Tool.hs0000644000000000000000000006141211770163230016441 0ustar0000000000000000{-# OPTIONS_GHC -XRecordWildCards -XCPP -XBangPatterns -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.Tool -- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken -- License : GPL -- -- Maintainer : -- Stability : provisional -- Portability : -- -- | Support for running external tools. Written mainly for GHCi but with -- | support for others in mind. -- ----------------------------------------------------------------------------- module IDE.Utils.Tool ( ToolOutput(..), toolline, ToolCommand(..), ToolState(..), toolProcess, newToolState, runTool, runTool', runInteractiveTool, newGhci, newGhci', executeCommand, executeGhciCommand, quoteArg, escapeQuotes, runCommand, waitForProcess, interruptProcessGroupOf, ProcessHandle, getProcessExitCode, runInteractiveProcess, runProcess -- waitForChildren, -- forkChild ) where import Control.Concurrent (tryTakeMVar, readMVar, takeMVar, putMVar, newEmptyMVar, forkIO, newChan, MVar, Chan, writeChan, getChanContents, dupChan) import Control.Monad (forM_, when, unless) import Control.Monad.IO.Class (liftIO, MonadIO) import Data.List (stripPrefix) import Data.Maybe (catMaybes) #ifdef MIN_VERSION_process_leksah import IDE.System.Process (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..), interruptProcessGroup, runCommand, getProcessExitCode, runProcess, runInteractiveProcess) import IDE.System.Process.Internals (StdStream(..)) #else import System.Process (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..), interruptProcessGroupOf, runCommand, getProcessExitCode, runProcess, runInteractiveProcess) import System.Process.Internals (StdStream(..)) #endif #if MIN_VERSION_base(4,3,0) import System.IO (hGetBufSome) import qualified Data.ByteString.Internal as B (createAndTrim) #else import System.IO (hWaitForInput, hIsEOF) import qualified Data.ByteString as B (hGetNonBlocking) #endif import Control.DeepSeq import System.Log.Logger (debugM) import System.Exit (ExitCode(..)) import System.IO (hFlush, hPutStrLn, Handle, hSetBuffering, BufferMode(..)) import Control.Applicative ((<|>), Alternative, liftA2, liftA) --import Data.Enumerator.Binary as E (enumHandle) import Data.Enumerator as E (continue, tryIO, checkContinue0, (=$), (>>==), Stream(..), Enumeratee, Enumerator, run, ($$), ($=), (>==>)) import qualified Data.Enumerator as E (enumList, returnI, Step(..), isEOF, checkDone, yield, Iteratee(..), sequence, run_) import qualified Data.Enumerator.Binary as EB (filter) import Data.Attoparsec.Enumerator (iterParser) import qualified Data.Attoparsec.Char8 as AP (endOfInput, takeWhile, satisfy, skipWhile, string, Parser, endOfLine, digit, manyTill, takeWhile1) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B (unpack, pack) import Data.Attoparsec (()) import qualified Data.Enumerator.List as EL (consume, concatMap, concatMapAccumM) import Data.Char (isDigit) import qualified System.IO as IO (Handle) import qualified Data.ByteString as B (empty, null, ByteString) import System.IO.Error (mkIOError, illegalOperationErrorType) data ToolOutput = ToolInput String | ToolError String | ToolOutput String | ToolPrompt String | ToolExit ExitCode deriving(Eq, Show) instance NFData ExitCode where rnf ExitSuccess = rnf () rnf (ExitFailure failureCode) = rnf failureCode instance NFData ToolOutput where rnf (ToolInput s) = rnf s rnf (ToolError s) = rnf s rnf (ToolOutput s) = rnf s rnf (ToolPrompt s) = rnf s rnf (ToolExit code) = rnf code data ToolCommand = ToolCommand String String (E.Iteratee ToolOutput IO ()) data ToolState = ToolState { toolProcessMVar :: MVar ProcessHandle, outputClosed :: MVar Bool, toolCommands :: Chan ToolCommand, toolCommandsRead :: Chan ToolCommand, currentToolCommand :: MVar ToolCommand} toolProcess :: ToolState -> IO ProcessHandle toolProcess = readMVar . toolProcessMVar data RawToolOutput = RawToolOutput ToolOutput | ToolOutClosed | ToolErrClosed | ToolClosed deriving(Eq, Show) toolline :: ToolOutput -> String toolline (ToolInput l) = l toolline (ToolOutput l) = l toolline (ToolError l) = l toolline (ToolPrompt l) = l toolline (ToolExit _code) = "" quoteArg :: String -> String quoteArg s | ' ' `elem` s = "\"" ++ (escapeQuotes s) ++ "\"" quoteArg s = s escapeQuotes :: String -> String escapeQuotes = foldr (\c s -> if c == '"' then '\\':c:s else c:s) "" #ifdef MIN_VERSION_process_leksah interruptProcessGroupOf :: ProcessHandle -> IO () interruptProcessGroupOf = interruptProcessGroup #endif runTool' :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle) runTool' fp args mbDir = do debugM "leksah-server" $ "Start: " ++ show (fp, args) (out,pid) <- runTool fp args mbDir output <- E.run_ $ out $$ EL.consume waitForProcess pid debugM "leksah-server" $ "End: " ++ show (fp, args) return (output,pid) runTool :: MonadIO m => FilePath -> [String] -> Maybe FilePath -> IO (Enumerator ToolOutput m b, ProcessHandle) runTool executable arguments mbDir = do (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, cwd = mbDir, #ifdef MIN_VERSION_process_leksah new_group = True } #else create_group = True } #endif output <- getOutputNoPrompt inp out err pid return (output, pid) newToolState :: IO ToolState newToolState = do toolProcessMVar <- newEmptyMVar outputClosed <- newEmptyMVar toolCommands <- newChan toolCommandsRead <- dupChan toolCommands currentToolCommand <- newEmptyMVar return ToolState{..} dropToFirst :: Monad m => (a -> Bool) -> E.Iteratee a m () dropToFirst p = E.continue loop where loop (Chunks xs) = case dropWhile p xs of [] -> E.continue loop _:xs' -> E.yield () (Chunks xs') loop EOF = E.yield () EOF isolateToFirst :: Monad m => (a -> Bool) -> Enumeratee a a m b isolateToFirst p (E.Continue k) = E.continue loop where loop (Chunks []) = E.continue loop loop (Chunks xs) = case span p xs of (_, []) -> k (Chunks xs) >>== isolateToFirst p (s1, t:s2) -> k (Chunks (s1++[t])) >>== (\step -> E.yield step (Chunks s2)) loop EOF = k EOF >>== (\step -> E.yield step EOF) isolateToFirst p step = dropToFirst p >> return step runInteractiveTool :: ToolState -> CommandLineReader -> FilePath -> [String] -> IO () runInteractiveTool tool clr executable arguments = do (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments) { std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe, #ifdef MIN_VERSION_process_leksah new_group = True } #else create_group = True } #endif putMVar (toolProcessMVar tool) pid output <- getOutput clr inp out err pid forkIO $ do commands <- getChanContents (toolCommandsRead tool) E.run_ $ output $$ outputSequence inp $$ processCommand commands inp return () return () where isEndOfCommandOutput (ToolPrompt _) = True isEndOfCommandOutput (ToolExit _) = True isEndOfCommandOutput _ = False isolateCommandOutput = isolateToFirst (not . isEndOfCommandOutput) processCommand [] _ = do liftIO $ debugM "leksah-server" $ "No More Commands" return () processCommand ((command@(ToolCommand commandString rawCommandString handler)):remainingCommands) inp = do liftIO $ putMVar (currentToolCommand tool) command liftIO $ hPutStrLn inp commandString liftIO $ hFlush inp (E.enumList 1 (map ToolInput (lines rawCommandString)) >==> isolateCommandOutput) =$ handler processCommand remainingCommands inp outputSequence :: Handle -> E.Enumeratee RawToolOutput ToolOutput IO b outputSequence inp = EL.concatMapAccumM writeCommandOutput (False, False, (outputSyncCommand clr), 0, "") where writeCommandOutput (False, False, (Just outSyncCmd), n, _) (RawToolOutput (ToolPrompt line)) = do debugM "leksah-server" $ "Pre Sync Prompt" hPutStrLn inp $ outSyncCmd n hFlush inp return ((True, False, (Just outSyncCmd), n, line), []) writeCommandOutput (True, False, mbSyncCmd, n, promptLine) (RawToolOutput (ToolPrompt _)) = do debugM "leksah-server" $ "Unsynced Prompt" return ((True, False, mbSyncCmd, n, promptLine), []) writeCommandOutput (True, False, mbSyncCmd, n, promptLine) (RawToolOutput o@(ToolOutput line)) = do let synced = (isExpectedOutput clr n line) when synced $ debugM "leksah-server" $ "Output Sync Found" return ((True, synced, mbSyncCmd, n, promptLine), if synced then [] else [o]) writeCommandOutput (_, _, mbSyncCmd, n, promptLine) (RawToolOutput (ToolPrompt _)) = do debugM "leksah-server" $ "Synced Prompt - Ready For Next Command" tryTakeMVar (currentToolCommand tool) return ((False, False, mbSyncCmd, n+1, promptLine), [ToolPrompt promptLine]) writeCommandOutput s (RawToolOutput o@(ToolExit _)) = do debugM "leksah-server" $ "Tool Exit" putMVar (outputClosed tool) True return (s, [o]) writeCommandOutput s (RawToolOutput o) = do return (s, [o]) writeCommandOutput s x = do debugM "leksah-server" $ "Unexpected output " ++ show x return (s, []) {- newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ToolState newInteractiveTool getOutput' executable arguments = do tool <- newToolState runInteractiveTool tool getOutput' executable arguments return tool -} ghciPrompt :: String ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX" data CommandLineReader = CommandLineReader { parseInitialPrompt :: AP.Parser String, parseFollowingPrompt :: AP.Parser String, errorSyncCommand :: Maybe (Int -> String), parseExpectedError :: AP.Parser (String, Int), outputSyncCommand :: Maybe (Int -> String), isExpectedOutput :: Int -> String -> Bool } ghciParseInitialPrompt :: AP.Parser String ghciParseInitialPrompt = (do ((AP.string $ B.pack "Prelude") <|> (AP.string $ B.pack "*")) AP.skipWhile (\c -> c /= '>' && c/= '\n') AP.string $ B.pack "> " return "") "ghciParseInitialPrompt" ghciParseFollowingPrompt :: AP.Parser String ghciParseFollowingPrompt = (do AP.satisfy (/='\n') `AP.manyTill` (AP.string $ B.pack $ ghciPrompt)) "ghciParseFollowingPrompt" marker :: Int -> String marker n = "kMAKWRALZZbHdXfHUOAAYBB" ++ show n parseMarker :: AP.Parser Int parseMarker = (do AP.string $ B.pack "kMAKWRALZZbHdXfHUOAAYBB" nums <- AP.takeWhile isDigit return . read $ B.unpack nums) "parseMarker" ghciParseExpectedErrorCols :: AP.Parser () ghciParseExpectedErrorCols = (do AP.string $ B.pack "0-" AP.digit AP.digit return ()) <|> (do AP.string $ B.pack "1-" AP.digit AP.digit return ()) <|> (do AP.string $ B.pack "0" return ()) <|> (do AP.string $ B.pack "1" return ()) "ghciParseExpectedErrorCols" manyTill' :: Alternative f => f a -> f b -> f ([a], b) manyTill' p end = scan where scan = liftA (\b -> ([], b)) end <|> liftA2 (\a (as, b) -> (a:as, b)) p scan ghciParseExpectedError :: AP.Parser (String, Int) ghciParseExpectedError = (do AP.satisfy (/='\n') `manyTill'` (do AP.string $ B.pack "\n:" AP.takeWhile1 isDigit AP.string $ B.pack ":" ghciParseExpectedErrorCols AP.string $ B.pack ": Not in scope: `" result <- parseMarker AP.string $ B.pack "'\n" return result)) "ghciParseExpectedError" ghciIsExpectedOutput :: Int -> String -> Bool ghciIsExpectedOutput n = (==) (marker n) ghciCommandLineReader :: CommandLineReader ghciCommandLineReader = CommandLineReader { parseInitialPrompt = ghciParseInitialPrompt, parseFollowingPrompt = ghciParseFollowingPrompt, errorSyncCommand = Just $ \n -> marker n, parseExpectedError = ghciParseExpectedError, outputSyncCommand = Just $ \n -> ":set prompt \"" ++ marker n ++ "\\n\"\n:set prompt " ++ ghciPrompt, isExpectedOutput = ghciIsExpectedOutput } noInputCommandLineReader :: CommandLineReader noInputCommandLineReader = CommandLineReader { parseInitialPrompt = fail "No Prompt Expected", parseFollowingPrompt = fail "No Prompt Expected", errorSyncCommand = Nothing, parseExpectedError = fail "No Expected Errors", outputSyncCommand = Nothing, isExpectedOutput = \_ _ -> False } parseError :: AP.Parser (String, Int) -> AP.Parser (Either (String, Int) ByteString) parseError expectedErrorParser = (do expected <- expectedErrorParser return $ Left expected) <|> (do line <- AP.takeWhile (/= '\n') (AP.endOfInput <|> AP.endOfLine) return $ Right line) "parseError" -- From enumerator but using hGetSome (to fix Win32) enumHandle :: MonadIO m => Integer -- ^ Buffer size -> IO.Handle -> Enumerator B.ByteString m b enumHandle bufferSize h = checkContinue0 $ \loop k -> do let intSize = fromInteger bufferSize bytes <- tryIO (hGetSome h intSize) if B.null bytes then continue k else k (Chunks [bytes]) >>== loop -- From byteString (for GHC 6.12.3 support) hGetSome :: Handle -> Int -> IO ByteString hGetSome hh i #if MIN_VERSION_base(4,3,0) | i > 0 = B.createAndTrim i $ \p -> hGetBufSome hh p i #else | i > 0 = let loop = do s <- B.hGetNonBlocking hh i if not (B.null s) then return s else do eof <- hIsEOF hh if eof then return s else hWaitForInput hh (-1) >> loop -- for this to work correctly, the -- Handle should be in binary mode -- (see GHC ticket #3808) in loop #endif | i == 0 = return B.empty | otherwise = illegalBufferSize hh "hGetSome" i illegalBufferSize :: Handle -> String -> Int -> IO a illegalBufferSize handle fn sz = ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing) --TODO: System.IO uses InvalidArgument here, but it's not exported :-( where msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz [] getOutput :: MonadIO m => CommandLineReader -> Handle -> Handle -> Handle -> ProcessHandle -> IO (Enumerator RawToolOutput m b) getOutput clr inp out err pid = do hSetBuffering out NoBuffering hSetBuffering err NoBuffering mvar <- newEmptyMVar foundExpectedError <- liftIO $ newEmptyMVar forkIO $ do readError mvar err foundExpectedError putMVar mvar ToolErrClosed forkIO $ do readOutput mvar out foundExpectedError putMVar mvar ToolOutClosed return $ enumOutput mvar where enumOutput :: MonadIO m => MVar RawToolOutput -> Enumerator RawToolOutput m b enumOutput = loop (0::Int) where loop closed mvar (E.Continue k) | closed < 2 = do v <- liftIO $ takeMVar mvar let (nowClosed, chunk) = if (v == ToolOutClosed) || (v == ToolErrClosed) then (closed + 1, []) else (closed, [v]) if nowClosed == 2 then do exitCode <- liftIO $ waitForProcess pid k (Chunks [RawToolOutput (ToolExit exitCode)]) >>== loop nowClosed mvar else k (Chunks chunk) >>== loop nowClosed mvar loop _ _ step = E.returnI step readError :: MVar RawToolOutput -> Handle -> MVar Int -> IO () readError mvar errors foundExpectedError = do result <- E.run $ (enumHandle 2048 errors $= EB.filter (/= 13)) $$ (E.sequence (iterParser $ parseError (parseExpectedError clr))) $$ sendErrors case result of Left e -> putStrLn $ show e Right _ -> return () return () where sendErrors = E.continue loop where loop (E.Chunks xs) = do forM_ xs $ \x -> liftIO $ do debugM "leksah-server" $ show x case x of Left (line, counter) -> do unless (null line) $ putMVar mvar $ RawToolOutput $ ToolError line putMVar foundExpectedError counter Right line -> putMVar mvar $ RawToolOutput $ ToolError (B.unpack line) E.continue loop loop E.EOF = E.yield () E.EOF outputSequence :: E.Iteratee ao IO ToolOutput -> E.Iteratee ao IO ToolOutput -> E.Enumeratee ao ToolOutput IO b outputSequence i1 i2 = loop i1 where loop i = E.checkDone check where check k = E.isEOF >>= \f -> if f then E.yield (E.Continue k) EOF else step k step k = i >>= \v -> case v of ToolPrompt _ -> k (Chunks [v]) >>== loop i2 _ -> k (Chunks [v]) >>== loop i readOutput :: MVar RawToolOutput -> Handle -> MVar Int -> IO () readOutput mvar output foundExpectedError = do let parseLines parsePrompt = (do lineSoFar <- parsePrompt return $ ToolPrompt lineSoFar) <|> (do line <- AP.takeWhile (/= '\n') (AP.endOfInput <|> AP.endOfLine) return . ToolOutput $ B.unpack line) "parseLines" parseInitialLines = parseLines (parseInitialPrompt clr) parseFollowinglines = parseLines (parseFollowingPrompt clr) E.run_ $ (enumHandle 2048 output $= EB.filter (/= 13)) $$ outputSequence (iterParser parseInitialLines) (iterParser parseFollowinglines) $$ sendErrors return () where sendErrors = E.continue (loop 0 False "") where loop counter errSynced promptLine (E.Chunks xs) = do forM_ xs $ \x -> do liftIO $ debugM "leksah-server" $ show x case x of ToolPrompt line -> do case (counter, errSynced, errorSyncCommand clr) of (0, _, _) -> do E.continue (loop (counter+1) errSynced line) (_, False, Just syncCmd) -> do liftIO $ do debugM "leksah-server" $ "sendErrors - Sync " ++ show counter hPutStrLn inp $ syncCmd counter hFlush inp waitForError counter debugM "leksah-server" $ "sendErrors - Synced " ++ show counter E.continue (loop (counter+1) True line) (_, True, Just _) -> do liftIO $ putMVar mvar $ RawToolOutput (ToolPrompt promptLine) E.continue (loop (counter+1) False promptLine) _ -> do liftIO $ putMVar mvar $ RawToolOutput x E.continue (loop (counter+1) False promptLine) _ -> do liftIO . putMVar mvar $ RawToolOutput x E.continue (loop counter errSynced promptLine) loop _ _ _ E.EOF = E.yield () E.EOF waitForError counter = do foundCount <- takeMVar foundExpectedError debugM "leksah-server" $ "waitForError - Found " ++ show foundCount when (foundCount < counter) $ waitForError counter fromRawOutput :: RawToolOutput -> [ToolOutput] fromRawOutput (RawToolOutput output) = [output] fromRawOutput (_) = [] getOutputNoPrompt :: MonadIO m => Handle -> Handle -> Handle -> ProcessHandle -> IO (Enumerator ToolOutput m b) getOutputNoPrompt inp out err pid = do output <- getOutput noInputCommandLineReader inp out err pid return $ output $= EL.concatMap fromRawOutput newGhci' :: [String] -> (E.Iteratee ToolOutput IO ()) -> IO ToolState newGhci' flags startupOutputHandler = do tool <- newToolState writeChan (toolCommands tool) $ ToolCommand (":set prompt " ++ ghciPrompt) "" startupOutputHandler runInteractiveTool tool ghciCommandLineReader "ghci" flags return tool newGhci :: [String] -> [String] -> (E.Iteratee ToolOutput IO ()) -> IO ToolState newGhci buildFlags interactiveFlags startupOutputHandler = do tool <- newToolState writeChan (toolCommands tool) $ ToolCommand (":set prompt " ++ ghciPrompt) "" startupOutputHandler debugM "leksah-server" $ "Working out GHCi options" forkIO $ do (out, _) <- runTool "cabal" (["build","--with-ghc=leksahecho"] ++ buildFlags) Nothing output <- E.run_ $ out $$ EL.consume case catMaybes $ map (findMake . toolline) output of options:_ -> do let newOptions = filterUnwanted options debugM "leksah-server" $ newOptions debugM "leksah-server" $ "Starting GHCi" debugM "leksah-server" $ unwords (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags) runInteractiveTool tool ghciCommandLineReader "ghci" (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags) _ -> do E.run $ E.enumList 1 output $$ startupOutputHandler putMVar (outputClosed tool) True return tool where findMake [] = Nothing findMake line@(_:xs) = case stripPrefix "--make " line of Nothing -> findMake xs s -> s filterUnwanted [] = [] filterUnwanted line@(x:xs) = case stripPrefix "-O " line of Nothing -> x: filterUnwanted xs Just s -> filterUnwanted s executeCommand :: ToolState -> String -> String -> E.Iteratee ToolOutput IO () -> IO () executeCommand tool command rawCommand handler = do writeChan (toolCommands tool) $ ToolCommand command rawCommand handler executeGhciCommand :: ToolState -> String -> E.Iteratee ToolOutput IO () -> IO () executeGhciCommand tool command handler = do if '\n' `elem` command then executeCommand tool safeCommand command handler else executeCommand tool command command handler where filteredLines = (filter safeLine (lines command)) safeCommand = ":cmd (return " ++ show (":{\n" ++ unlines filteredLines ++ "\n:}") ++ ")" safeLine ":{" = False safeLine ":}" = False safeLine _ = True --children :: MVar [MVar ()] --children = unsafePerformIO (newMVar []) -- --waitForChildren :: IO () --waitForChildren = do -- cs <- takeMVar children -- case cs of -- [] -> return () -- m:ms -> do -- putMVar children ms -- takeMVar m -- waitForChildren -- --forkChild :: IO () -> IO ThreadId --forkChild io = do -- mvar <- newEmptyMVar -- childs <- takeMVar children -- putMVar children (mvar:childs) -- forkIO (io `finally` putMVar mvar ()) leksah-server-0.12.1.2/src/IDE/Utils/GHCUtils.hs0000644000000000000000000002103111770163230017137 0ustar0000000000000000{-# OPTIONS_GHC -XCPP -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.GHCUtils -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : Jutaro -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Utils.GHCUtils ( inGhcIO , getInstalledPackageInfos , findFittingPackages , myParseModule , myParseHeader ) where #if MIN_VERSION_Cabal(1,8,0) #else import UniqFM (eltsUFM) #endif import Distribution.Simple (withinRange,PackageIdentifier(..),Dependency(..)) #if MIN_VERSION_Cabal(1,8,0) import qualified Distribution.InstalledPackageInfo as IPI (sourcePackageId) #else import qualified Distribution.InstalledPackageInfo as IPI (package) #endif import GHC import DriverPipeline(preprocess) import StringBuffer (StringBuffer(..),hGetStringBuffer) import FastString (mkFastString) import Lexer (mkPState,ParseResult(..),getMessages,unP) import Outputable (ppr) #if MIN_VERSION_ghc(7,2,0) import ErrUtils (dumpIfSet_dyn,printBagOfErrors,printBagOfWarnings,errorsFound,mkPlainErrMsg,showPass,ErrMsg(..)) import Control.Monad (unless) #else import ErrUtils (dumpIfSet_dyn,printErrorsAndWarnings,mkPlainErrMsg,showPass,ErrMsg(..)) #endif import PackageConfig (PackageConfig) import Data.Foldable (maximumBy) import qualified Parser as P (parseModule,parseHeader) import HscStats (ppSourceStats) #if MIN_VERSION_ghc(7,2,0) import GhcMonad (Ghc(..)) import SrcLoc (mkRealSrcLoc) #else import HscTypes (Ghc(..)) #endif import IDE.Utils.FileUtils (getSysLibDir) import DynFlags (dopt_set) import System.Log.Logger(debugM) import Control.Monad.IO.Class (MonadIO(..), MonadIO) -- this should not be repeated here, why is it necessary? instance MonadIO Ghc where liftIO ioA = Ghc $ \_ -> ioA inGhcIO :: [String] -> [DynFlag] -> (DynFlags -> Ghc a) -> IO a inGhcIO flags' udynFlags ghcAct = do debugM "leksah-server" $ "inGhcIO called with: " ++ show flags' libDir <- getSysLibDir -- (restFlags, _) <- parseStaticFlags (map noLoc flags') runGhc (Just libDir) $ do dynflags <- getSessionDynFlags let dynflags' = foldl (\ flags'' flag' -> dopt_set flags'' flag') dynflags udynFlags let dynflags'' = dynflags' { hscTarget = HscNothing, ghcMode = CompManager, ghcLink = NoLink } dynflags''' <- parseGhcFlags dynflags'' (map noLoc flags') flags' res <- defaultCleanupHandler dynflags''' $ do setSessionDynFlags dynflags''' ghcAct dynflags''' unload return res where parseGhcFlags :: DynFlags -> [Located String] -> [String] -> Ghc DynFlags parseGhcFlags dynflags flags_ _origFlags = do (dynflags', rest, _) <- parseDynamicFlags dynflags flags_ if not (null rest) then do liftIO $ debugM "leksah-server" ("No dynamic GHC options: " ++ (unwords (map unLoc rest))) return dynflags' else return dynflags' -- | Unload whatever is currently loaded. unload :: Ghc () unload = do setTargets [] load LoadAllTargets return () getInstalledPackageInfos :: Ghc [PackageConfig] getInstalledPackageInfos = do dflags1 <- getSessionDynFlags setSessionDynFlags $ dopt_set dflags1 Opt_ReadUserPackageConf pkgInfos <- case pkgDatabase dflags1 of Nothing -> return [] #if MIN_VERSION_Cabal(1,8,0) Just fm -> return fm #else Just fm -> return (eltsUFM fm) #endif return pkgInfos findFittingPackages :: [Dependency] -> Ghc [PackageIdentifier] findFittingPackages dependencyList = do knownPackages <- getInstalledPackageInfos #if MIN_VERSION_Cabal(1,8,0) let packages = map IPI.sourcePackageId knownPackages #else let packages = map IPI.package knownPackages #endif 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 --------------------------------------------------------------------- -- | 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 #if MIN_VERSION_ghc(7,2,0) let loc = mkRealSrcLoc (mkFastString src_filename) 1 0 #else let loc = mkSrcLoc (mkFastString src_filename) 1 0 #endif #if MIN_VERSION_ghc(7,0,1) case unP P.parseModule (mkPState dflags buf' loc) of { #else case unP P.parseModule (mkPState buf' loc dflags) of { #endif PFailed span' err -> return (Left (mkPlainErrMsg span' err)); POk pst rdr_module -> do { #if MIN_VERSION_ghc(7,2,0) let {ms@(warnings, errors) = getMessages pst}; printBagOfErrors dflags errors; unless (errorsFound dflags ms) $ printBagOfWarnings dflags warnings; #else let {ms = getMessages pst}; printErrorsAndWarnings dflags ms; #endif -- 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. }} myParseHeader :: FilePath -> String -> [String] -> IO (Either String (HsModule RdrName)) myParseHeader fp _str opts = inGhcIO (opts++["-cpp"]) [] $ \ _dynFlags -> do session <- getSession #if MIN_VERSION_ghc(7,2,0) (dynFlags',fp') <- liftIO $ preprocess session (fp,Nothing) #else (dynFlags',fp') <- preprocess session (fp,Nothing) #endif liftIO $ do stringBuffer <- hGetStringBuffer fp' parseResult <- myParseModuleHeader dynFlags' fp (Just stringBuffer) case parseResult of Right (L _ mod') -> return (Right mod') Left errMsg -> do let str = "Failed to parse " ++ show errMsg return (Left str) --------------------------------------------------------------------- -- | Parser function copied here, because it is not exported myParseModuleHeader :: DynFlags -> FilePath -> Maybe StringBuffer -> IO (Either ErrMsg (Located (HsModule RdrName))) myParseModuleHeader dflags src_filename maybe_src_buf = -------------------------- Parser ---------------- showPass dflags "Parser" >> {-# SCC "Parser" #-} do -- sometimes we already have the buffer in memory, perhaps -- because we needed to parse the imports out of it, or get the -- module name. buf' <- case maybe_src_buf of Just b -> return b Nothing -> hGetStringBuffer src_filename #if MIN_VERSION_ghc(7,2,0) let loc = mkRealSrcLoc (mkFastString src_filename) 1 0 #else let loc = mkSrcLoc (mkFastString src_filename) 1 0 #endif #if MIN_VERSION_ghc(7,0,1) case unP P.parseHeader (mkPState dflags buf' loc) of { #else case unP P.parseHeader (mkPState buf' loc dflags) of { #endif PFailed span' err -> return (Left (mkPlainErrMsg span' err)); POk pst rdr_module -> do { #if MIN_VERSION_ghc(7,2,0) let {ms@(warnings, errors) = getMessages pst}; printBagOfErrors dflags errors; unless (errorsFound dflags ms) $ printBagOfWarnings dflags warnings; #else let {ms = getMessages pst}; printErrorsAndWarnings dflags ms; #endif -- 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. }} leksah-server-0.12.1.2/src/IDE/Utils/FileUtils.hs0000644000000000000000000003641111770163230017425 0ustar0000000000000000{-# OPTIONS_GHC -XScopedTypeVariables -XBangPatterns #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.FileUtils -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Utils.FileUtils ( allModules , allHiFiles , allHaskellSourceFiles , isEmptyDirectory , cabalFileName , allCabalFiles , getConfigFilePathForLoad , hasSavedConfigFile , getConfigDir , getConfigFilePathForSave , getCollectorPath , getSysLibDir , moduleNameFromFilePath , moduleNameFromFilePath' , findKnownPackages , isSubPath , findSourceFile , findSourceFile' , haskellSrcExts , getCabalUserPackageDir , autoExtractCabalTarFiles , autoExtractTarFiles , getInstalledPackageIds , figureOutGhcOpts , figureOutHaddockOpts , allFilesWithExtensions , myCanonicalizePath ) where import System.FilePath (splitFileName, dropExtension, takeExtension, combine, addExtension, (), normalise, splitPath, takeFileName) import Distribution.ModuleName (toFilePath, ModuleName) import Control.Monad (foldM, filterM) import Data.Maybe (catMaybes) import qualified Data.List as List (init, elem) import Distribution.Simple.PreProcess.Unlit (unlit) import System.Directory (canonicalizePath, doesDirectoryExist, doesFileExist, setCurrentDirectory, getCurrentDirectory, getDirectoryContents, createDirectory, getHomeDirectory) import Text.ParserCombinators.Parsec.Language (haskellDef, haskell) #if MIN_VERSION_parsec(3,0,0) import qualified Text.ParserCombinators.Parsec.Token as P (GenTokenParser(..), TokenParser, identStart) #else import qualified Text.ParserCombinators.Parsec.Token as P (TokenParser(..), identStart) #endif import Text.ParserCombinators.Parsec (GenParser, parse, oneOf, (<|>), alphaNum, noneOf, char, try, (), many, CharParser) import Data.Set (Set) import Data.List (isPrefixOf, isSuffixOf, stripPrefix) import qualified Data.Set as Set (empty, fromList) import Distribution.Package (PackageIdentifier) import Data.Char (ord) import Distribution.Text (simpleParse) import IDE.Utils.Utils import IDE.Core.CTypes(configDirName) import qualified Distribution.Text as T (simpleParse) import System.Log.Logger(errorM,warningM,debugM) import IDE.Utils.Tool import Control.Monad.IO.Class (MonadIO(..), MonadIO) haskellSrcExts :: [String] haskellSrcExts = ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp","hsc"] -- | canonicalizePath without crashing myCanonicalizePath :: String -> IO String myCanonicalizePath fp = do exists <- doesFileExist fp if exists then canonicalizePath fp else return fp -- | 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 findSourceFile' :: [FilePath] -> String -> IO (Maybe FilePath) findSourceFile' directories modulePath = let allPathes = map (\ d -> d modulePath) directories in find' allPathes find' :: [FilePath] -> IO (Maybe FilePath) find' [] = return Nothing find' (h:t) = catch (do exists <- doesFileExist h if exists then return (Just h) else find' t) $ \ _ -> return Nothing -- | The directory where config files reside -- getConfigDir :: IO FilePath getConfigDir = do d <- getHomeDirectory let filePath = d configDirName exists <- doesDirectoryExist filePath if exists then return filePath else do createDirectory filePath return filePath getConfigDirForLoad :: IO (Maybe FilePath) getConfigDirForLoad = do d <- getHomeDirectory let filePath = d configDirName exists <- doesDirectoryExist filePath if exists then return (Just filePath) else return Nothing hasSavedConfigFile :: String -> IO Bool hasSavedConfigFile fn = do savedConfigFile <- getConfigFilePathForSave fn doesFileExist savedConfigFile getConfigFilePathForLoad :: String -> Maybe FilePath -> FilePath -> IO FilePath getConfigFilePathForLoad fn mbFilePath dataDir = do mbCd <- case mbFilePath of Just p -> return (Just p) Nothing -> getConfigDirForLoad case mbCd of Nothing -> getFromData Just cd -> do ex <- doesFileExist (cd fn) if ex then return (cd fn) else getFromData where getFromData = do ex <- doesFileExist (dataDir "data" fn) if ex then return (dataDir "data" fn) else error $"Config file not found: " ++ fn getConfigFilePathForSave :: String -> IO FilePath getConfigFilePathForSave fn = do cd <- getConfigDir return (cd fn) allModules :: FilePath -> IO [ModuleName] allModules filePath = catch (do exists <- doesDirectoryExist filePath if exists then do filesAndDirs <- getDirectoryContents filePath let filesAndDirs' = map (\s -> combine filePath s) $filter (\s -> s /= "." && s /= ".." && s /= "_darcs" && s /= "dist" && s /= "Setup.lhs") filesAndDirs dirs <- filterM (\f -> doesDirectoryExist f) filesAndDirs' files <- filterM (\f -> doesFileExist f) filesAndDirs' let hsFiles = filter (\f -> let ext = takeExtension f in ext == ".hs" || ext == ".lhs") files mbModuleStrs <- mapM moduleNameFromFilePath hsFiles let mbModuleNames = catMaybes $ map (\n -> case n of Nothing -> Nothing Just s -> simpleParse s) mbModuleStrs otherModules <- mapM allModules dirs return (mbModuleNames ++ concat otherModules) else return []) $ \ _ -> return [] allHiFiles :: FilePath -> IO [FilePath] allHiFiles = allFilesWithExtensions [".hi"] True [] allCabalFiles :: FilePath -> IO [FilePath] allCabalFiles = allFilesWithExtensions [".cabal"] False [] allHaskellSourceFiles :: FilePath -> IO [FilePath] allHaskellSourceFiles = allFilesWithExtensions [".hs",".lhs"] True [] allFilesWithExtensions :: [String] -> Bool -> [FilePath] -> FilePath -> IO [FilePath] allFilesWithExtensions extensions recurseFurther collecting filePath = catch (do exists <- doesDirectoryExist filePath if exists then do filesAndDirs <- getDirectoryContents filePath let filesAndDirs' = map (\s -> combine filePath s) $filter (\s -> s /= "." && s /= ".." && s /= "_darcs") filesAndDirs dirs <- filterM (\f -> doesDirectoryExist f) filesAndDirs' files <- filterM (\f -> doesFileExist f) filesAndDirs' let choosenFiles = filter (\f -> let ext = takeExtension f in List.elem ext extensions) files allFiles <- if recurseFurther || (not recurseFurther && null choosenFiles) then foldM (allFilesWithExtensions extensions recurseFurther) (choosenFiles ++ collecting) dirs else return (choosenFiles ++ collecting) return (allFiles) else return collecting) $ \ _ -> return collecting moduleNameFromFilePath :: FilePath -> IO (Maybe String) moduleNameFromFilePath fp = catch (do exists <- doesFileExist fp if exists then do str <- readFile fp moduleNameFromFilePath' fp str else return Nothing) $ \ _ -> return Nothing moduleNameFromFilePath' :: FilePath -> String -> IO (Maybe String) moduleNameFromFilePath' fp str = do let unlitRes = if takeExtension fp == ".lhs" then unlit fp str else Left str case unlitRes of Right err -> do errorM "leksah-server" (show err) return Nothing Left str' -> do let parseRes = parse moduleNameParser fp str' case parseRes of Left _ -> do return Nothing Right str'' -> return (Just str'') lexer :: P.TokenParser st lexer = haskell lexeme :: CharParser st a -> CharParser st a lexeme = P.lexeme lexer whiteSpace :: CharParser st () whiteSpace = P.whiteSpace lexer symbol :: String -> CharParser st String symbol = P.symbol lexer moduleNameParser :: CharParser () String moduleNameParser = do whiteSpace many skipPreproc whiteSpace symbol "module" str <- lexeme mident return str "module identifier" skipPreproc :: CharParser () () skipPreproc = do try (do whiteSpace char '#' many (noneOf "\n") return ()) "preproc" mident :: GenParser Char st String mident = do{ c <- P.identStart haskellDef ; cs <- many (alphaNum <|> oneOf "_'.") ; return (c:cs) } "midentifier" findKnownPackages :: FilePath -> IO (Set String) findKnownPackages filePath = catch (do paths <- getDirectoryContents filePath let nameList = map dropExtension $filter (\s -> leksahMetadataSystemFileExtension `isSuffixOf` s) paths return (Set.fromList nameList)) $ \ _ -> return (Set.empty) isEmptyDirectory :: FilePath -> IO Bool isEmptyDirectory filePath = catch (do exists <- doesDirectoryExist filePath if exists then do filesAndDirs <- getDirectoryContents filePath return . null $ filter (not . ("." `isPrefixOf`) . takeFileName) filesAndDirs else return False) (\_ -> return False) cabalFileName :: FilePath -> IO (Maybe FilePath) cabalFileName filePath = catch (do exists <- doesDirectoryExist filePath if exists then do filesAndDirs <- getDirectoryContents filePath files <- filterM (\f -> doesFileExist f) filesAndDirs let cabalFiles = filter (\f -> let ext = takeExtension f in ext == ".cabal") files if null cabalFiles then return Nothing else if length cabalFiles == 1 then return (Just $head cabalFiles) else do warningM "leksah-server" "Multiple cabal files" return Nothing else return Nothing) (\_ -> return Nothing) getCabalUserPackageDir :: IO (Maybe FilePath) getCabalUserPackageDir = do (!output,_) <- runTool' "cabal" ["help"] Nothing case stripPrefix " " (toolline $ last output) of Just s | "config" `isSuffixOf` s -> return $ Just $ take (length s - 6) s ++ "packages" _ -> return Nothing autoExtractCabalTarFiles :: FilePath -> IO () autoExtractCabalTarFiles filePath = do dir <- getCurrentDirectory autoExtractTarFiles' filePath setCurrentDirectory dir autoExtractTarFiles :: FilePath -> IO () autoExtractTarFiles filePath = do dir <- getCurrentDirectory autoExtractTarFiles' filePath setCurrentDirectory dir autoExtractTarFiles' :: FilePath -> IO () autoExtractTarFiles' filePath = catch (do exists <- doesDirectoryExist filePath if exists then do filesAndDirs <- getDirectoryContents filePath let filesAndDirs' = map (\s -> combine filePath s) $ filter (\s -> s /= "." && s /= ".." && not (isPrefixOf "00-index" s)) filesAndDirs dirs <- filterM (\f -> doesDirectoryExist f) filesAndDirs' files <- filterM (\f -> doesFileExist f) filesAndDirs' let choosenFiles = filter (\f -> isSuffixOf ".tar.gz" f) files let decompressionTargets = filter (\f -> (dropExtension . dropExtension) f `notElem` dirs) choosenFiles mapM_ (\f -> let (dir,fn) = splitFileName f command = "tar -zxf " ++ fn in do setCurrentDirectory dir handle <- runCommand command waitForProcess handle return ()) decompressionTargets mapM_ autoExtractTarFiles' dirs return () else return () ) $ \ _ -> return () getCollectorPath :: MonadIO m => m FilePath getCollectorPath = liftIO $ do configDir <- getConfigDir let filePath = configDir "metadata" exists <- doesDirectoryExist filePath if exists then return filePath else do createDirectory filePath return filePath getSysLibDir :: IO FilePath getSysLibDir = catch (do (!output,_) <- runTool' "ghc" ["--print-libdir"] Nothing let libDir = toolline $ head output libDir2 = if ord (last libDir) == 13 then List.init libDir else libDir return (normalise libDir2) ) $ \ _ -> error ("FileUtils>>getSysLibDir failed") getInstalledPackageIds :: IO [PackageIdentifier] getInstalledPackageIds = catch (do (!output, _) <- runTool' "ghc-pkg" ["list", "--simple-output"] Nothing let names = toolline $ head output return (catMaybes (map T.simpleParse (words names))) ) $ \ _ -> error ("FileUtils>>getInstalledPackageIds failed") figureOutHaddockOpts :: IO [String] figureOutHaddockOpts = do (!output,_) <- runTool' "cabal" (["haddock","--with-haddock=leksahecho","--executables"]) Nothing let opts = concatMap (words . toolline) output let res = filterOptGhc opts debugM "leksah-server" ("figureOutHaddockOpts " ++ show res) return res where filterOptGhc [] = [] filterOptGhc (s:r) = case stripPrefix "--optghc=" s of Nothing -> filterOptGhc r Just s' -> s' : filterOptGhc r figureOutGhcOpts :: IO [String] figureOutGhcOpts = do debugM "leksah-server" "figureOutGhcOpts" (!output,_) <- runTool' "cabal" ["build","--with-ghc=leksahecho"] Nothing let res = case catMaybes $ map (findMake . toolline) output of options:_ -> words options _ -> [] debugM "leksah-server" $ ("figureOutGhcOpts " ++ show res) return res where findMake [] = Nothing findMake line@(_:xs) = case stripPrefix "--make " line of Nothing -> findMake xs s -> s leksah-server-0.12.1.2/src/IDE/Utils/Server.hs0000644000000000000000000000603611770163230016773 0ustar0000000000000000{-# OPTIONS_GHC -XFlexibleInstances #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.Server -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ------------------------------------------------------------------------------ module IDE.Utils.Server ( ipAddress , Server (..) , serveOne , serveMany , ServerRoutine , UserAndGroup (..) , WaitFor (waitFor)) where import Network import Network.Socket hiding (accept) import System.IO import Control.Concurrent import Control.Exception hiding (catch) import Data.Word import System.Log.Logger (infoM) data UserAndGroup = UserAndGroup String String | UserWithDefaultGroup String -- | Set the user and group for the process. If the group is Nothing, then use the users default group. -- This is especially useful when you are root and want to become a user. setUserAndGroup :: UserAndGroup -> IO () setUserAndGroup _ = return () -- | make an IP Address: (127,0,0,1) is the localhost ipAddress :: (Word8, Word8, Word8, Word8) -> HostAddress ipAddress (a, b, c, d) = fromIntegral a + 0x100 * fromIntegral b + 0x10000 * fromIntegral c + 0x1000000 * fromIntegral d -- | the functionality of a server type ServerRoutine = (Handle, HostName, PortNumber) -> IO () serverSocket' :: Server -> IO Socket serverSocket' (Server (SockAddrInet _ _) t _) = socket AF_INET t defaultProtocol serverSocket' _ = fail "Unexpected Socket Address Type" serverSocket :: Server -> IO (Socket, Server) serverSocket server = do sock <- serverSocket' server setSocketOption sock ReuseAddr 1 bindSocket sock (serverAddr server) infoM "leksah-server" $ ("Bind " ++ show (serverAddr server)) listen sock maxListenQueue return (sock, server) -- |the specification of a serving process data Server = Server { serverAddr :: SockAddr, serverTyp :: SocketType, serverRoutine :: ServerRoutine} startAccepting :: (Socket, Server) -> IO (ThreadId, MVar ()) startAccepting (sock, server) = do mvar <- newEmptyMVar threadId <- forkIO (acceptance sock (serverRoutine server) `finally` putMVar mvar ()) return (threadId, mvar) serveMany :: Maybe UserAndGroup -> [Server] -> IO [(ThreadId, MVar ())] serveMany (Just userAndGroup) l = do ready <- mapM serverSocket l setUserAndGroup userAndGroup mapM startAccepting ready serveMany Nothing l = mapM serverSocket l >>= mapM startAccepting serveOne :: Maybe UserAndGroup -> Server -> IO (ThreadId, MVar ()) serveOne ug s = do l <- serveMany ug [s] return (head l) class WaitFor a where waitFor :: a -> IO () instance WaitFor (MVar a) where waitFor mvar = readMVar mvar >> return () instance WaitFor a => WaitFor [a] where waitFor = mapM_ waitFor instance WaitFor (ThreadId, MVar ()) where waitFor (_, mvar) = waitFor mvar acceptance :: Socket -> ServerRoutine -> IO () acceptance sock action = catch (do dta <- accept sock forkIO (action dta) >> return ()) print >> acceptance sock action leksah-server-0.12.1.2/src/IDE/Utils/Utils.hs0000644000000000000000000000340611770163230016623 0ustar0000000000000000{-# OPTIONS_GHC -XDeriveDataTypeable -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Utils.Utils -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Utils.Utils where leksahSessionFileExtension = ".lkshs" leksahWorkspaceFileExtension = ".lkshw" leksahPreferencesFileExtension = ".lkshp" leksahCandyFileExtension = ".lkshc" leksahKeymapFileExtension = ".lkshk" leksahSourcesFileExtension = ".lksho" leksahMetadataSystemFileExtension = ".lkshm" leksahMetadataPathFileExtension = ".lkshp" leksahMetadataWorkspaceFileExtension = ".lkshe" leksahMetadataDebugExtension = ".lkshd" leksahTemplateFileExtension = ".lksht" leksahFlagFileExtension = ".lkshf" standardSessionFilename = "current" ++ leksahSessionFileExtension emptySessionFilename = "empty" ++ leksahSessionFileExtension packageSessionFilename = "leksah" ++ leksahSessionFileExtension standardKeymapFilename = "keymap" ++ leksahKeymapFileExtension standardCandyFilename = "candy" ++ leksahCandyFileExtension standardPreferencesFilename = "prefs" ++ leksahPreferencesFileExtension strippedPreferencesFilename = "prefscoll" ++ leksahPreferencesFileExtension standardSourcesFilename = "sources" ++ leksahSourcesFileExtension standardModuleTemplateFilename = "module" ++ leksahTemplateFileExtension leksah-server-0.12.1.2/src/IDE/Metainfo/0000755000000000000000000000000011770163230015626 5ustar0000000000000000leksah-server-0.12.1.2/src/IDE/Metainfo/WorkspaceCollector.hs0000644000000000000000000007220311770163230021773 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables, PatternGuards #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.WorkspaceCollector -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Metainfo.WorkspaceCollector ( collectWorkspace , sortByLoc , attachComments , uncommentData , uncommentDecl , printHsDoc , toComment , srcSpanToLocation , sigToByteString ) where import IDE.Utils.Utils import IDE.Utils.GHCUtils import GHC hiding(Id,Failed,Succeeded,ModuleName) #if !MIN_VERSION_ghc(7,2,0) import HscTypes hiding (liftIO) #endif import Outputable hiding(trace) import ErrUtils import qualified Data.Map as Map import Data.Map(Map) import System.Directory import Distribution.Package hiding (PackageId) import Distribution.ModuleName import Distribution.Text (simpleParse) import System.FilePath import qualified Data.ByteString.Char8 as BS import Data.Binary.Shared import IDE.Utils.FileUtils import IDE.Core.Serializable () import IDE.Core.CTypes hiding (SrcSpan(..)) import Data.ByteString.Char8 (ByteString) import DriverPipeline (preprocess) import StringBuffer(hGetStringBuffer) import Data.List(partition,sortBy,nub,find) import Data.Ord(comparing) import RdrName (showRdrName) import GHC.Exception import MyMissing(forceHead) import LoadIface(findAndReadIface) import Distribution.Text(display) import TcRnMonad (initTcRnIf, IfGblEnv(..)) import qualified Maybes as M import IDE.Metainfo.InterfaceCollector import Data.Maybe (isJust, catMaybes, mapMaybe, isNothing) import Module (stringToPackageId) import PrelNames import System.Log.Logger import Control.DeepSeq (deepseq) #if MIN_VERSION_ghc(6,12,1) import FastString(mkFastString,appendFS,nullFS,unpackFS) import Control.Monad.IO.Class (MonadIO, MonadIO(..)) import Control.Monad (when) #else import GHC.Show(showSpace) #endif type NDecl = LHsDecl RdrName myDocEmpty :: NDoc myDocAppend :: NDoc -> NDoc -> NDoc isEmptyDoc :: NDoc -> Bool #if MIN_VERSION_ghc(6,12,1) type NDoc = HsDocString type MyLDocDecl = LDocDecl myDocEmpty=HsDocString(mkFastString "") myDocAppend (HsDocString l) (HsDocString r) = HsDocString (appendFS l r) isEmptyDoc (HsDocString fs) = nullFS fs #else type NDoc = HsDoc RdrName type MyLDocDecl = LDocDecl RdrName myDocEmpty = DocEmpty myDocAppend = docAppend isEmptyDoc DocEmpty = True isEmptyDoc _ = False #endif type NSig = Located (Sig RdrName) -- | Test collectWorkspace :: PackageIdentifier -> [(String,FilePath)] -> Bool -> Bool -> FilePath -> IO() collectWorkspace packId moduleList forceRebuild writeAscii dir = do debugM "leksah-server" $ "collectWorkspace called with modules " ++ show moduleList ++ " in folder " ++ dir collectorPath <- liftIO $ getCollectorPath let packageCollectorPath = collectorPath packageIdentifierToString packId when forceRebuild $ do exists <- doesDirectoryExist packageCollectorPath when exists $ removeDirectoryRecursive packageCollectorPath -- Construct directory liftIO $ createDirectoryIfMissing True packageCollectorPath setCurrentDirectory dir opts1 <- figureOutGhcOpts opts2 <- figureOutHaddockOpts debugM "leksah-server" $ ("before collect modules" ++ "\n\nopts1: " ++ show opts1 ++ "\n\n opt2: " ++ show opts2) mapM_ (collectModule packageCollectorPath writeAscii packId opts1) moduleList debugM "leksah-server" $ "after collect modules" collectModule :: FilePath -> Bool -> PackageIdentifier -> [String] -> (String,FilePath) -> IO() collectModule collectorPackagePath writeAscii packId opts (modId,sourcePath) = do existCollectorFile <- doesFileExist collectorModulePath existSourceFile <- doesFileExist sourcePath case mbModuleName of Nothing -> errorM "leksah-server" ("Can't parse module name " ++ modId) Just moduleName' -> if existSourceFile then do if not existCollectorFile then collectModule' sourcePath collectorModulePath writeAscii packId opts moduleName' else do sourceModTime <- getModificationTime sourcePath collModTime <- getModificationTime collectorModulePath if sourceModTime > collModTime then collectModule' sourcePath collectorModulePath writeAscii packId opts moduleName' else return () else errorM "leksah-server" ("source file not found " ++ sourcePath) where collectorModulePath = collectorPackagePath modId <.> leksahMetadataWorkspaceFileExtension mbModuleName = simpleParse modId collectModule' :: FilePath -> FilePath -> Bool -> PackageIdentifier -> [String] -> ModuleName -> IO() collectModule' sourcePath destPath writeAscii packId opts moduleName' = gcatch ( inGhcIO (opts++["-cpp"]) [Opt_Haddock] $ \ _dynFlags -> do session <- getSession #if MIN_VERSION_ghc(7,2,0) (dynFlags3,fp') <- liftIO $ preprocess session (sourcePath,Nothing) #else (dynFlags3,fp') <- preprocess session (sourcePath,Nothing) #endif mbInterfaceDescr <- mayGetInterfaceDescription packId moduleName' liftIO $ do stringBuffer <- hGetStringBuffer fp' parseResult <- myParseModule dynFlags3 sourcePath (Just stringBuffer) case parseResult of Right (L _ hsMod@(HsModule{})) -> do let moduleDescr = extractModDescr packId moduleName' sourcePath hsMod let moduleDescr' = case mbInterfaceDescr of Nothing -> moduleDescr Just md -> mergeWithInterfaceDescr moduleDescr md catch (writeExtractedModule destPath writeAscii moduleDescr') (\ _ -> errorM "leksah-server" ("Can't write extracted package " ++ destPath)) Left errMsg -> do errorM "leksah-server" $ "Failed to parse " ++ sourcePath ++ " " ++ show errMsg let moduleDescr = ModuleDescr { mdModuleId = PM packId moduleName' , mdMbSourcePath = Just sourcePath , mdReferences = Map.empty -- imports , mdIdDescriptions = [Real $ RealDescr { dscName' = "Parse Error" , dscMbTypeStr' = Nothing , dscMbModu' = Just (PM packId moduleName') , dscMbLocation' = case errMsgSpans errMsg of (sp:_) -> srcSpanToLocation sp [] -> Nothing , dscMbComment' = Just (BS.pack $ show errMsg) , dscTypeHint' = ErrorDescr , dscExported' = False}]} catch (deepseq moduleDescr $ writeExtractedModule destPath writeAscii moduleDescr) (\ _ -> errorM "leksah-server" ("Can't write extracted module " ++ destPath)) ) (\ (e :: SomeException) -> errorM "leksah-server" ("Can't extract module " ++ destPath ++ " " ++ show e)) writeExtractedModule :: MonadIO m => FilePath -> Bool -> ModuleDescr -> m () writeExtractedModule filePath writeAscii md = if writeAscii then liftIO $ writeFile (filePath ++ "dpg") (show md) else liftIO $ encodeFileSer filePath (metadataVersion, md) ----------------------------------------------------------------------------------- -- Format conversion extractModDescr :: PackageIdentifier -> ModuleName -> FilePath -> HsModule RdrName -> ModuleDescr extractModDescr packId moduleName' sourcePath hsMod = ModuleDescr { mdModuleId = PM packId moduleName' , mdMbSourcePath = Just sourcePath , mdReferences = Map.empty -- imports , mdIdDescriptions = descrs'} where descrs = extractDescrs (PM packId moduleName') (hsmodDecls hsMod) descrs' = fixExports (hsmodExports hsMod) descrs ----------------------------------------------------------------------------------- -- Add exported hint fixExports :: Maybe [LIE RdrName] -> [Descr] -> [Descr] fixExports Nothing descrs = descrs fixExports (Just iel) descrs = map (fixDescr (map unLoc iel)) descrs where fixDescr :: [IE RdrName] -> Descr -> Descr fixDescr _ d@(Reexported _) = d fixDescr list (Real rd) = Real rd' where rd' = case dscTypeHint' rd of VariableDescr -> rd{dscExported' = isJust findVar} InstanceDescr _ -> rd _ -> case findThing of Nothing -> nothingExported rd Just (IEThingAll _) -> allExported rd Just (IEThingAbs _) -> someExported rd [] Just (IEThingWith _ l) -> someExported rd (map showRdrName l) _ -> allExported rd findVar = find (\ a -> case a of IEVar r | showRdrName r == dscName' rd -> True _ -> False) list findThing = find (\ a -> case a of IEThingAbs r | showRdrName r == dscName' rd -> True IEThingAll r | showRdrName r == dscName' rd -> True IEThingWith r _list | showRdrName r == dscName' rd -> True _ -> False) list allExported rd = rd nothingExported rd = rd{dscExported' = False, dscTypeHint' = nothingExportedS (dscTypeHint' rd)} nothingExportedS (DataDescr lsd1 lsd2) = DataDescr (map (setExportedSD False) lsd1) (map (setExportedSD False) lsd2) nothingExportedS (NewtypeDescr sd1 Nothing) = NewtypeDescr (setExportedSD False sd1) Nothing nothingExportedS (NewtypeDescr sd1 (Just _sd2)) = NewtypeDescr (setExportedSD False sd1) (Just (setExportedSD False sd1)) nothingExportedS (ClassDescr n lsd2) = ClassDescr n (map (setExportedSD False) lsd2) nothingExportedS other = other someExported rd l = rd{dscExported' = True, dscTypeHint' = someExportedS (dscTypeHint' rd) l} someExportedS (DataDescr lsd1 lsd2) l = DataDescr (map (maySetExportedSD l) lsd1) (map (maySetExportedSD l) lsd2) someExportedS (NewtypeDescr sd1 Nothing) l = NewtypeDescr (maySetExportedSD l sd1) Nothing someExportedS (NewtypeDescr sd1 (Just _sd2)) l = NewtypeDescr (maySetExportedSD l sd1) (Just (maySetExportedSD l sd1)) someExportedS (ClassDescr n lsd2) l = ClassDescr n (map (maySetExportedSD l) lsd2) someExportedS other _ = other setExportedSD bool sd = sd{sdExported = bool} maySetExportedSD list sd = sd{sdExported = elem (sdName sd) list} extractDescrs :: PackModule -> [NDecl] -> [Descr] extractDescrs pm decls = transformToDescrs pm tripleWithSigs where sortedDecls = sortByLoc decls pairedWithDocs = collectDocs sortedDecls filteredDecls = filterUninteresting pairedWithDocs (withoutSignatures,signatures) = partitionSignatures filteredDecls tripleWithSigs = attachSignatures signatures withoutSignatures -- | Sort by source location sortByLoc :: [Located a] -> [Located a] sortByLoc = sortBy (comparing getLoc) filterUninteresting :: [(NDecl,Maybe NDoc)] -> [(NDecl,Maybe NDoc)] filterUninteresting = filter filterSignature where filterSignature ((L _srcDecl (SpliceD _)),_) = False filterSignature ((L _srcDecl (RuleD _)),_) = False filterSignature ((L _srcDecl (WarningD _)),_) = False filterSignature ((L _srcDecl (ForD _)),_) = False filterSignature ((L _srcDecl (DefD _)),_) = False filterSignature _ = True partitionSignatures :: [(NDecl,Maybe NDoc)] -> ([(NDecl,Maybe NDoc)],[(NDecl,Maybe NDoc)]) partitionSignatures = partition filterSignature where filterSignature ((L _srcDecl (SigD _)),_) = False filterSignature _ = True --partitionInstances :: [(NDecl,Maybe NDoc)] -> ([(NDecl,Maybe NDoc)],[(NDecl,Maybe NDoc)]) --partitionInstances i = (i,[]) --partition filterInstances -- where -- filterInstances ((L srcDecl (InstD _)),_) = False -- filterInstances _ = True -- | Collect the docs and attach them to the right declaration. collectDocs :: [LHsDecl RdrName] -> [(LHsDecl RdrName, (Maybe NDoc))] collectDocs = collect Nothing myDocEmpty collect :: Maybe (LHsDecl RdrName) -> NDoc -> [LHsDecl RdrName] -> [(LHsDecl RdrName, (Maybe (NDoc)))] collect d doc_so_far [] = case d of Nothing -> [] Just d0 -> finishedDoc d0 doc_so_far [] collect d doc_so_far (e:es) = case e of L _ (DocD (DocCommentNext str)) -> case d of Nothing -> collect d (myDocAppend doc_so_far str) es Just d0 -> finishedDoc d0 doc_so_far (collect Nothing str es) L _ (DocD (DocCommentPrev str)) -> collect d (myDocAppend doc_so_far str) es _ -> case d of Nothing -> collect (Just e) doc_so_far es Just d0 -> finishedDoc d0 doc_so_far (collect (Just e) myDocEmpty es) finishedDoc :: LHsDecl RdrName -> NDoc -> [(LHsDecl RdrName, (Maybe NDoc))] -> [(LHsDecl RdrName, (Maybe NDoc))] finishedDoc d doc rest | isEmptyDoc doc = (d, Nothing) : rest finishedDoc d doc rest | notDocDecl d = (d, Just doc) : rest where notDocDecl (L _ (DocD _)) = False notDocDecl _ = True finishedDoc _ _ rest = rest sigNameNoLoc' :: Sig name -> [name] #if MIN_VERSION_ghc(7,2,0) sigNameNoLoc' (TypeSig ns _) = map unLoc ns sigNameNoLoc' (SpecSig n _ _) = [unLoc n] sigNameNoLoc' (InlineSig n _) = [unLoc n] sigNameNoLoc' (FixSig (FixitySig n _)) = [unLoc n] sigNameNoLoc' _ = [] #else sigNameNoLoc' = maybe [] (:[]) . sigNameNoLoc #endif attachSignatures :: [(NDecl, (Maybe NDoc))] -> [(NDecl,Maybe NDoc)] -> [(NDecl, (Maybe NDoc), [(NSig,Maybe NDoc)])] attachSignatures signatures = map (attachSignature signaturesMap) where signaturesMap = Map.fromListWith (++) $ concatMap sigMap signatures sigMap (L loc (SigD sig),c) | nameList <- sigNameNoLoc' sig = map (\n -> (n, [(L loc sig,c)])) nameList sigMap v = error ("Unexpected location type" ++ (showSDoc . ppr) v) attachSignature :: Map RdrName [(NSig,Maybe NDoc)] -> (NDecl, (Maybe NDoc)) -> (NDecl, (Maybe NDoc), [(NSig,Maybe NDoc)]) attachSignature signaturesMap' (decl,mbDoc) = case declName (unLoc decl) of Nothing -> (decl,mbDoc, []) Just name -> case name `Map.lookup` signaturesMap' of Just sigList -> (decl,mbDoc, sigList) Nothing -> (decl, mbDoc, []) declName _t@(TyClD x) = Just (tcdName x) declName _t@(ValD (FunBind fun_id' _ _ _ _ _ )) = Just (unLoc fun_id') declName _ = Nothing transformToDescrs :: PackModule -> [(NDecl, (Maybe NDoc), [(NSig, Maybe NDoc)])] -> [Descr] transformToDescrs pm = concatMap transformToDescr where transformToDescr :: (NDecl, (Maybe NDoc), [(NSig, Maybe NDoc)]) -> [Descr] transformToDescr ((L loc (ValD (FunBind lid _ _ _ _ _))), mbComment,sigList) = [Real $ RealDescr { dscName' = showRdrName (unLoc lid) , dscMbTypeStr' = sigToByteString sigList , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment (catMaybes (map snd sigList)) , dscTypeHint' = VariableDescr , dscExported' = True}] transformToDescr ((L loc (TyClD typ@(TySynonym lid _ _ _ ))), mbComment,_sigList) = [Real $ RealDescr { dscName' = showRdrName (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = TypeDescr , dscExported' = True}] transformToDescr ((L loc (TyClD typ@(TyData DataType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_sigList) = [Real $ RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = DataDescr constructors fields , dscExported' = True}] ++ derivings tcdDerivs' where constructors = map extractConstructor lConDecl fields = nub $ concatMap extractRecordFields lConDecl name = showRdrName (unLoc tcdLName') derivings Nothing = [] derivings (Just l) = map (extractDeriving pm name) l transformToDescr ((L loc (TyClD typ@(TyData NewType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_sigList) = [Real $ RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = NewtypeDescr constructor mbField , dscExported' = True}] ++ derivings tcdDerivs' where constructor = forceHead (map extractConstructor lConDecl) "WorkspaceCollector>>transformToDescr: no constructor for newtype" mbField = case concatMap extractRecordFields lConDecl of [] -> Nothing a:_ -> Just a name = showRdrName (unLoc tcdLName') derivings Nothing = [] derivings (Just l) = map (extractDeriving pm name) l transformToDescr ((L loc (TyClD cl@(ClassDecl{tcdLName=tcdLName', tcdSigs=tcdSigs', tcdDocs=docs}))), mbComment,_sigList) = [Real $ RealDescr { dscName' = showRdrName (unLoc tcdLName') , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr cl{tcdMeths = emptyLHsBinds})) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = ClassDescr super methods , dscExported' = True }] where methods = extractMethods tcdSigs' docs super = [] transformToDescr ((L loc (InstD _inst@(InstDecl typ _ _ _))), mbComment, _sigList) = [Real $ RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack ("instance " ++ (showSDocUnqual $ppr typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = InstanceDescr other , dscExported' = True}] where (name,other) = case words (showSDocUnqual $ppr typ) of [] -> ("",[]) hd:tl -> (hd,tl) transformToDescr (_, _mbComment, _sigList) = [] uncommentData :: TyClDecl a -> TyClDecl a uncommentData td@(TyData {tcdCons = conDecls}) = td{tcdCons = map uncommentDecl conDecls} uncommentData other = other uncommentDecl :: LConDecl a -> LConDecl a uncommentDecl (L l cd) = L l cd{con_details= uncommentDetails (con_details cd)} uncommentDetails :: HsConDeclDetails a -> HsConDeclDetails a uncommentDetails (RecCon flds) = RecCon (map uncommentField flds) where uncommentField (ConDeclField a1 a2 _doc) = ConDeclField a1 a2 Nothing uncommentDetails other = other mergeWithInterfaceDescr :: ModuleDescr -> ModuleDescr -> ModuleDescr mergeWithInterfaceDescr md imd = md { mdReferences = mdReferences imd, mdIdDescriptions = mergeIdDescrs (mdIdDescriptions md) (mdIdDescriptions imd)} mergeIdDescrs :: [Descr] -> [Descr] -> [Descr] mergeIdDescrs d1 d2 = dres ++ reexported where (reexported,real) = partition isReexported d2 lm = Map.fromList $ zip (map (\d -> (dscName d,dscTypeHint d)) real) real dres = map (addType lm) d1 addType lm' (Real d1') | isNothing (dscMbTypeStr' d1') = Real $ d1'{dscMbTypeStr' = case (dscName' d1', dscTypeHint' d1') `Map.lookup` lm' of Nothing -> Nothing Just d -> dscMbTypeStr d} addType _ d = d extractDeriving :: OutputableBndr alpha => PackModule -> String -> LHsType alpha -> Descr extractDeriving pm name (L loc typ) = Real $ RealDescr { dscName' = className , dscMbTypeStr' = Just (BS.pack ("instance " ++ (className ++ " " ++ name))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment (Nothing :: Maybe NDoc) [] , dscTypeHint' = InstanceDescr (words name) , dscExported' = True} where className = showSDocUnqual $ ppr typ extractMethods :: [LSig RdrName] -> [MyLDocDecl] -> [SimpleDescr] extractMethods sigs docs = let pairs = attachComments sigs docs in mapMaybe extractMethod pairs extractMethod :: OutputableBndr alpha => (LHsDecl alpha, Maybe (NDoc)) -> Maybe SimpleDescr #if MIN_VERSION_ghc(7,2,0) extractMethod ((L loc (SigD ts@(TypeSig [name] _typ))), mbDoc) = #else extractMethod ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) = #endif Just $ SimpleDescr ((showSDoc . ppr) (unLoc name)) (Just (BS.pack (showSDocUnqual $ ppr ts))) (srcSpanToLocation loc) (toComment mbDoc []) True extractMethod (_, _mbDoc) = Nothing extractConstructor :: Located (ConDecl RdrName) -> SimpleDescr extractConstructor decl@(L loc (ConDecl {con_name = name, con_doc = doc})) = SimpleDescr ((showSDoc . ppr) (unLoc name)) (Just (BS.pack (showSDocUnqual $ppr (uncommentDecl decl)))) (srcSpanToLocation loc) (case doc of Nothing -> Nothing Just (L _ d) -> Just (BS.pack (printHsDoc d))) True extractRecordFields :: Located (ConDecl RdrName) -> [SimpleDescr] extractRecordFields (L _ _decl@(ConDecl {con_details = RecCon flds})) = map extractRecordFields' flds where extractRecordFields' _field@(ConDeclField (L loc name) typ doc) = SimpleDescr ((showSDoc . ppr) name) (Just (BS.pack (showSDocUnqual $ ppr typ))) (srcSpanToLocation loc) (case doc of Nothing -> Nothing Just (L _ d) -> Just (BS.pack (printHsDoc d))) True extractRecordFields _ = [] attachComments :: [LSig RdrName] -> [MyLDocDecl] -> [(LHsDecl RdrName, Maybe (NDoc))] attachComments sigs docs = collectDocs $ sortByLoc $ ((map (\ (L l i) -> L l (SigD i)) sigs) ++ (map (\ (L l i) -> L l (DocD i)) docs)) sigToByteString :: [(NSig, Maybe NDoc)] -> Maybe ByteString sigToByteString [] = Nothing sigToByteString [(sig,_)] = Just (BS.pack (showSDocUnqual $ppr sig)) sigToByteString ((sig,_):_) = Just (BS.pack (showSDocUnqual $ppr sig)) srcSpanToLocation :: SrcSpan -> Maybe Location #if MIN_VERSION_ghc(7,2,0) srcSpanToLocation (RealSrcSpan span') = Just (Location (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span')) srcSpanToLocation _ = Nothing #else srcSpanToLocation span' | not (isGoodSrcSpan span') = Nothing srcSpanToLocation span' = Just (Location (srcSpanStartLine span') (srcSpanStartCol span') (srcSpanEndLine span') (srcSpanEndCol span')) #endif toComment :: Maybe (NDoc) -> [NDoc] -> Maybe ByteString toComment (Just c) _ = Just (BS.pack (printHsDoc c)) toComment Nothing (c:_) = Just (BS.pack (printHsDoc c)) toComment Nothing [] = Nothing {-- = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Data] [] collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TyFamily _ lid _ _)))), mbComment') = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [] [] collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (ClassDecl _ lid _ _ _ _ _ _ )))), mbComment') = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Class] [] --} #if MIN_VERSION_ghc(6,12,1) printHsDoc :: NDoc -> String printHsDoc (HsDocString fs) = unpackFS fs #else printHsDoc :: NDoc -> String printHsDoc d = show (PPDoc d) -- Okay, I need to reconstruct the document comments, but for now: --instance Outputable (DocDecl name) where -- ppr _ = text "<**>" newtype PPDoc alpha = PPDoc (HsDoc alpha) instance Outputable alpha => Show (PPDoc alpha) where showsPrec _ (PPDoc DocEmpty) = id showsPrec _ (PPDoc (DocAppend l r)) = shows (PPDoc l) . shows (PPDoc r) showsPrec _ (PPDoc (DocString str)) = showString str showsPrec _ (PPDoc (DocParagraph d)) = shows (PPDoc d) . showChar '\n' showsPrec _ (PPDoc (DocIdentifier l)) = foldr (\i _f -> showChar '\'' . ((showString . showSDoc . ppr) i) . showChar '\'') id l showsPrec _ (PPDoc (DocModule str)) = showChar '"' . showString str . showChar '"' showsPrec _ (PPDoc (DocEmphasis doc)) = showChar '/' . shows (PPDoc doc) . showChar '/' showsPrec _ (PPDoc (DocMonospaced doc)) = showChar '@' . shows (PPDoc doc) . showChar '@' showsPrec _ (PPDoc (DocUnorderedList l)) = foldr (\s r -> showString "* " . shows (PPDoc s) . showChar '\n' . r) id l showsPrec _ (PPDoc (DocOrderedList l)) = foldr (\(i,n) _f -> shows n . showSpace . shows (PPDoc i)) id (zip l [1 .. length l]) showsPrec _ (PPDoc (DocDefList li)) = foldr (\(l,r) f -> showString "[@" . shows (PPDoc l) . showString "[@ " . shows (PPDoc r) . f) id li showsPrec _ (PPDoc (DocCodeBlock doc)) = showChar '@' . shows (PPDoc doc) . showChar '@' showsPrec _ (PPDoc (DocURL str)) = showChar '<' . showString str . showChar '>' showsPrec _ (PPDoc (DocAName str)) = showChar '#' . showString str . showChar '#' showsPrec _ (PPDoc _) = id #endif --------------------------------------------------------------------------------- -- Now the interface file stuff mayGetInterfaceFile :: PackageIdentifier -> ModuleName -> Ghc (Maybe (ModIface,FilePath)) mayGetInterfaceFile pid mn = let isBase = pkgName pid == (PackageName "base") mn' = mkModuleName (display mn) pid' = stringToPackageId (display pid) iface = findAndReadIface empty (if isBase then mkBaseModule_ mn' else mkModule pid' mn') False gblEnv = IfGblEnv { if_rec_types = Nothing } in do hscEnv <- getSession maybe' <- liftIO $ initTcRnIf 'i' hscEnv gblEnv () iface case maybe' of M.Succeeded val -> return (Just val) _ -> return Nothing mayGetInterfaceDescription :: PackageIdentifier -> ModuleName -> Ghc (Maybe ModuleDescr) mayGetInterfaceDescription pid mn = do mbIf <- mayGetInterfaceFile pid mn case mbIf of Nothing -> do liftIO $ debugM "leksah-server" ("no interface file for " ++ show mn) return Nothing Just (mif,_) -> let allDescrs = extractExportedDescrH pid mif mod' = extractExportedDescrR pid allDescrs mif in do liftIO $ debugM "leksah-server" ("interface file for " ++ show mn ++ " descrs: " ++ show (length (mdIdDescriptions mod'))) return (Just mod') leksah-server-0.12.1.2/src/IDE/Metainfo/SourceCollectorH.hs0000644000000000000000000004430411770163230021406 0ustar0000000000000000{-# OPTIONS_GHC -XScopedTypeVariables -XBangPatterns #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.SourceCollectorH -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Metainfo.SourceCollectorH ( -- collectPackageFromSource findSourceForPackage , packageFromSource , interfaceToModuleDescr , PackageCollectStats(..) ) where import IDE.Core.CTypes (getThisPackage, PackageDescr(..), TypeDescr(..), RealDescr(..), Descr(..), ModuleDescr(..), PackModule(..), SimpleDescr(..), packageIdentifierToString) #ifdef MIN_VERSION_haddock_leksah import Haddock.Types (ExportItem(..), DeclInfo, Interface(..)) import Haddock.Interface #else import Documentation.Haddock #endif import Distribution.Text (simpleParse) import InstEnv (Instance(..)) import MyMissing import Data.Map (Map) import qualified Data.Map as Map (empty) import Data.List (nub) import qualified Data.ByteString.Char8 as BS (pack) #if MIN_VERSION_ghc(6,12,1) import IDE.Metainfo.WorkspaceCollector (srcSpanToLocation, uncommentDecl, uncommentData, printHsDoc, sortByLoc) #else import IDE.Metainfo.WorkspaceCollector (srcSpanToLocation, uncommentDecl, uncommentData, sortByLoc) #endif import Name (getOccString,getSrcSpan) import PackageConfig (PackageConfig) import Distribution.Verbosity (verbose) import qualified Distribution.InstalledPackageInfo as IPI import IDE.StrippedPrefs (getUnpackDirectory, Prefs(..)) import IDE.Metainfo.SourceDB (sourceForPackage, getSourcesMap) import MonadUtils (liftIO) import System.Directory (setCurrentDirectory, doesDirectoryExist,createDirectory) import System.FilePath ((<.>), dropFileName, ()) import Data.Maybe(mapMaybe) import IDE.Utils.GHCUtils (inGhcIO) import qualified Control.Exception as NewException (SomeException, catch) import IDE.Utils.Tool import Control.Monad (unless) import IDE.Utils.FileUtils (figureOutGhcOpts, myCanonicalizePath) import Distribution.Package(PackageIdentifier) import GHC hiding(Id,Failed,Succeeded,ModuleName) import System.Log.Logger (warningM, debugM) import Control.DeepSeq (deepseq) import Data.ByteString.Char8 (ByteString) import Outputable hiding (trace) import GHC.Show(showSpace) #ifdef MIN_VERSION_haddock_leksah #else type HsDoc = Doc #endif type NDoc = HsDoc Name isEmptyDoc :: NDoc -> Bool isEmptyDoc DocEmpty = True isEmptyDoc _ = False show' :: Outputable alpha => alpha -> String #if MIN_VERSION_ghc(6,12,1) type MyLDocDecl = LDocDecl show' = showSDoc . ppr #else type MyLDocDecl = LDocDecl Name show' = showSDoc . ppr #endif data PackageCollectStats = PackageCollectStats { packageString :: String, modulesTotal :: Maybe Int, withSource :: Bool, retrieved :: Bool, mbError :: Maybe String} findSourceForPackage :: Prefs -> PackageConfig -> IO (Either String FilePath) findSourceForPackage prefs packageConfig = do sourceMap <- liftIO $ getSourcesMap prefs case sourceForPackage (getThisPackage packageConfig) sourceMap of Just fpSource -> return (Right fpSource) Nothing -> do unpackDir <- getUnpackDirectory prefs case unpackDir of Nothing -> return (Left "No source found. Prefs don't allow for retreiving") Just fpUnpack -> do exists <- doesDirectoryExist fpUnpack unless exists $ createDirectory fpUnpack setCurrentDirectory fpUnpack runTool' "cabal" (["unpack",packageName]) Nothing success <- doesDirectoryExist (fpUnpack packageName) if not success then return (Left "Failed to download and unpack source") else return (Right (fpUnpack packageName takeWhile (/= '-') packageName <.> "cabal")) where packageName = packageIdentifierToString (getThisPackage packageConfig) packageFromSource :: FilePath -> PackageConfig -> IO (Maybe PackageDescr, PackageCollectStats) packageFromSource cabalPath packageConfig = do setCurrentDirectory dirPath ghcFlags <- figureOutGhcOpts debugM "leksah-server" ("ghcFlags: " ++ show ghcFlags) NewException.catch (inner ghcFlags) handler where _handler' (_e :: NewException.SomeException) = do debugM "leksah-server" "would block" return ([]) handler (e :: NewException.SomeException) = do warningM "leksah-server" ("Ghc failed to process: " ++ show e) return (Nothing, PackageCollectStats packageName Nothing False False (Just ("Ghc failed to process: " ++ show e))) inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] $ \ _flags -> do #if MIN_VERSION_haddock(2,8,0) (interfaces,_) <- processModules verbose (exportedMods ++ hiddenMods) [] [] #else (interfaces,_) <- createInterfaces verbose (exportedMods ++ hiddenMods) [] [] #endif liftIO $ print (length interfaces) let mods = map (interfaceToModuleDescr dirPath (getThisPackage packageConfig)) interfaces sp <- liftIO $ myCanonicalizePath dirPath let pd = PackageDescr { pdPackage = getThisPackage packageConfig , pdModules = mods , pdBuildDepends = [] -- TODO depends packageConfig , pdMbSourcePath = Just sp} let stat = PackageCollectStats packageName (Just (length mods)) True False Nothing liftIO $ deepseq pd $ return (Just pd, stat) exportedMods = map moduleNameString $ IPI.exposedModules packageConfig hiddenMods = map moduleNameString $ IPI.hiddenModules packageConfig dirPath = dropFileName cabalPath packageName = packageIdentifierToString (getThisPackage packageConfig) -- Heaven interfaceToModuleDescr :: FilePath -> PackageIdentifier -> Interface -> ModuleDescr interfaceToModuleDescr _dirPath pid interface = ModuleDescr { mdModuleId = PM pid modName , mdMbSourcePath = Just filepath , mdReferences = imports , mdIdDescriptions = descrs} where filepath = ifaceOrigFilename interface modName = forceJust ((simpleParse . moduleNameString . moduleName . ifaceMod) interface) "Can't parse module name" descrs = extractDescrs (PM pid modName) (ifaceDeclMap interface) (ifaceExportItems interface) (ifaceInstances interface) [] --(ifaceLocals interface) imports = Map.empty --TODO #if MIN_VERSION_ghc(7,4,1) type DeclInfo = [LHsDecl Name] #endif #if MIN_VERSION_ghc(6,12,1) extractDescrs :: PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [Instance] -> [Name] -> [Descr] extractDescrs pm _ifaceDeclMap ifaceExportItems' ifaceInstances' _ifaceLocals = transformToDescrs pm exportedDeclInfo ++ map (toDescrInst pm) ifaceInstances' where exportedDeclInfo = mapMaybe toDeclInfo ifaceExportItems' toDeclInfo (ExportDecl decl mbDoc subDocs _) = Just(decl,fst mbDoc,map (\ (a,b) -> (a,fst b)) subDocs) toDeclInfo (ExportNoDecl _ _) = Nothing toDeclInfo (ExportGroup _ _ _) = Nothing toDeclInfo (ExportDoc _) = Nothing toDeclInfo (ExportModule _) = Nothing #else extractDescrs :: PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [Instance] -> [Name] -> [Descr] extractDescrs pm _ifaceDeclMap ifaceExportItems' ifaceInstances' _ifaceLocals = transformToDescrs pm exportedDeclInfo ++ map (toDescrInst pm) ifaceInstances' where exportedDeclInfo = mapMaybe toDeclInfo ifaceExportItems' toDeclInfo (ExportDecl decl mbDoc subDocs _) = Just(decl,mbDoc,subDocs) toDeclInfo (ExportNoDecl _ _) = Nothing toDeclInfo (ExportGroup _ _ _) = Nothing toDeclInfo (ExportDoc _) = Nothing toDeclInfo (ExportModule _) = Nothing #endif transformToDescrs :: PackModule -> [(LHsDecl Name, Maybe NDoc, [(Name, Maybe NDoc)])] -> [Descr] transformToDescrs pm = concatMap transformToDescr where #if MIN_VERSION_ghc(7,2,0) transformToDescr ((L loc (SigD (TypeSig [name] typ))), mbComment,_subCommentList) = #else transformToDescr ((L loc (SigD (TypeSig name typ))), mbComment,_subCommentList) = #endif [Real $ RealDescr { dscName' = getOccString (unLoc name) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = VariableDescr , dscExported' = True}] transformToDescr ((L _loc (SigD _)), _mbComment, _subCommentList) = [] transformToDescr ((L loc (TyClD typ@(TySynonym lid _ _ _ ))), mbComment, _subCommentList) = [Real $ RealDescr { dscName' = getOccString (unLoc lid) , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr typ)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = TypeDescr , dscExported' = True}] transformToDescr ((L loc (TyClD typ@(TyData DataType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_subCommentList) = [Real $ RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = DataDescr constructors fields , dscExported' = True}] ++ derivings tcdDerivs' where constructors = map extractConstructor lConDecl fields = nub $ concatMap extractRecordFields lConDecl name = getOccString (unLoc tcdLName') derivings Nothing = [] derivings (Just _l) = [] transformToDescr ((L loc (TyClD typ@(TyData NewType _ tcdLName' _ _ _ lConDecl tcdDerivs'))), mbComment,_subCommentList) = [Real $ RealDescr { dscName' = name , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr (uncommentData typ))) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = NewtypeDescr constructor mbField , dscExported' = True}] ++ derivings tcdDerivs' where constructor = forceHead (map extractConstructor lConDecl) "WorkspaceCollector>>transformToDescr: no constructor for newtype" mbField = case concatMap extractRecordFields lConDecl of [] -> Nothing a:_ -> Just a name = getOccString (unLoc tcdLName') derivings Nothing = [] derivings (Just _l) = [] transformToDescr ((L loc (TyClD cl@(ClassDecl{tcdLName=tcdLName', tcdSigs=tcdSigs', tcdDocs=docs}))), mbComment,_subCommentList) = [Real $ RealDescr { dscName' = getOccString (unLoc tcdLName') , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr cl{tcdMeths = emptyLHsBinds})) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment [] , dscTypeHint' = ClassDescr super methods , dscExported' = True }] where methods = extractMethods tcdSigs' docs super = [] transformToDescr (_, _mbComment, _sigList) = [] toDescrInst :: PackModule -> Instance -> Descr toDescrInst pm inst@(Instance is_cls' _is_tcs _is_tvs is_tys' _is_dfun _is_flag) = Real $ RealDescr { dscName' = getOccString is_cls' , dscMbTypeStr' = Just (BS.pack (showSDocUnqual $ppr inst)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation (getSrcSpan inst) , dscMbComment' = Nothing , dscTypeHint' = InstanceDescr (map (showSDocUnqual . ppr) is_tys') , dscExported' = True} extractMethods :: [LSig Name] -> [MyLDocDecl] -> [SimpleDescr] extractMethods sigs docs = let pairs = attachComments' sigs docs in mapMaybe extractMethod pairs extractMethod :: (LHsDecl Name, Maybe NDoc) -> Maybe SimpleDescr #if MIN_VERSION_ghc(7,2,0) extractMethod ((L loc (SigD ts@(TypeSig [name] _typ))), mbDoc) = #else extractMethod ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) = #endif Just $ SimpleDescr (getOccString (unLoc name)) (Just (BS.pack (showSDocUnqual $ ppr ts))) (srcSpanToLocation loc) (toComment mbDoc []) True extractMethod (_, _mbDoc) = Nothing extractConstructor :: LConDecl Name -> SimpleDescr extractConstructor decl@(L loc (ConDecl {con_name = name, con_doc = doc})) = SimpleDescr (getOccString (unLoc name)) (Just (BS.pack (showSDocUnqual $ppr (uncommentDecl decl)))) (srcSpanToLocation loc) (case doc of Nothing -> Nothing Just (L _ d) -> Just (BS.pack (printHsDoc'' d))) True extractRecordFields :: LConDecl Name -> [SimpleDescr] extractRecordFields (L _ _decl@(ConDecl {con_details=(RecCon flds)})) = map extractRecordFields' flds where extractRecordFields' _field@(ConDeclField (L loc name) typ doc) = SimpleDescr (getOccString name) (Just (BS.pack (showSDocUnqual $ ppr typ))) (srcSpanToLocation loc) (case doc of Nothing -> Nothing Just (L _ d) -> Just (BS.pack (printHsDoc'' d))) True extractRecordFields _ = [] toComment :: Maybe NDoc -> [NDoc] -> Maybe ByteString toComment (Just c) _ = Just (BS.pack (printHsDoc' c)) toComment Nothing (c:_) = Just (BS.pack (printHsDoc' c)) toComment Nothing [] = Nothing {-- = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Data] [] collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (TyFamily _ lid _ _)))), mbComment') = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [] [] collectParseInfoForDecl (l,st) ((Just (L loc (TyClD (ClassDecl _ lid _ _ _ _ _ _ )))), mbComment') = addLocationAndComment (l,st) (unLoc lid) loc mbComment' [Class] [] --} printHsDoc' :: HsDoc Name -> String printHsDoc' d = show (PPDoc d) #if MIN_VERSION_ghc(6,12,1) printHsDoc'' :: HsDocString -> String printHsDoc'' = printHsDoc #else printHsDoc'' :: HsDoc Name -> String printHsDoc'' = printHsDoc' #endif newtype PPDoc alpha = PPDoc (HsDoc alpha) instance Outputable alpha => Show (PPDoc alpha) where showsPrec _ (PPDoc DocEmpty) = id showsPrec _ (PPDoc (DocAppend l r)) = shows (PPDoc l) . shows (PPDoc r) showsPrec _ (PPDoc (DocString str)) = showString str showsPrec _ (PPDoc (DocParagraph d)) = shows (PPDoc d) . showChar '\n' showsPrec _ (PPDoc (DocIdentifier l)) = foldr (\i _f -> showChar '\'' . ((showString . showSDoc . ppr) i) . showChar '\'') id [l] showsPrec _ (PPDoc (DocModule str)) = showChar '"' . showString str . showChar '"' showsPrec _ (PPDoc (DocEmphasis doc)) = showChar '/' . shows (PPDoc doc) . showChar '/' showsPrec _ (PPDoc (DocMonospaced doc)) = showChar '@' . shows (PPDoc doc) . showChar '@' showsPrec _ (PPDoc (DocUnorderedList l)) = foldr (\s r -> showString "* " . shows (PPDoc s) . showChar '\n' . r) id l showsPrec _ (PPDoc (DocOrderedList l)) = foldr (\(i,n) _f -> shows n . showSpace . shows (PPDoc i)) id (zip l [1 .. length l]) showsPrec _ (PPDoc (DocDefList li)) = foldr (\(l,r) f -> showString "[@" . shows (PPDoc l) . showString "[@ " . shows (PPDoc r) . f) id li showsPrec _ (PPDoc (DocCodeBlock doc)) = showChar '@' . shows (PPDoc doc) . showChar '@' showsPrec _ (PPDoc (DocURL str)) = showChar '<' . showString str . showChar '>' showsPrec _ (PPDoc (DocAName str)) = showChar '#' . showString str . showChar '#' showsPrec _ (PPDoc _) = id attachComments' :: [LSig Name] -> [MyLDocDecl] -> [(LHsDecl Name, Maybe (HsDoc Name))] attachComments' sigs docs = collectDocs' $ sortByLoc $ ((map (\ (L l i) -> L l (SigD i)) sigs) ++ (map (\ (L l i) -> L l (DocD i)) docs)) -- | Collect the docs and attach them to the right declaration. collectDocs' :: [LHsDecl Name] -> [(LHsDecl Name, (Maybe (HsDoc Name)))] collectDocs' = collect' Nothing DocEmpty collect' :: Maybe (LHsDecl Name) -> HsDoc Name -> [LHsDecl Name] -> [(LHsDecl Name, (Maybe (HsDoc Name)))] collect' d doc_so_far [] = case d of Nothing -> [] Just d0 -> finishedDoc' d0 doc_so_far [] collect' d doc_so_far (e:es) = case e of L _ (DocD (DocCommentNext str)) -> case d of Nothing -> collect' d (DocAppend doc_so_far (DocString (show' str))) es Just d0 -> finishedDoc' d0 doc_so_far (collect' Nothing (DocString (show' str)) es) L _ (DocD (DocCommentPrev str)) -> collect' d (DocAppend doc_so_far (DocString (show' str))) es _ -> case d of Nothing -> collect' (Just e) doc_so_far es Just d0 -> finishedDoc' d0 doc_so_far (collect' (Just e) DocEmpty es) finishedDoc' :: LHsDecl alpha -> NDoc -> [(LHsDecl alpha, (Maybe ((HsDoc Name))))] -> [(LHsDecl alpha, (Maybe ((HsDoc Name))))] finishedDoc' d doc rest | isEmptyDoc doc = (d, Nothing) : rest finishedDoc' d doc rest | notDocDecl d = (d, Just doc) : rest where notDocDecl (L _ (DocD _)) = False notDocDecl _ = True finishedDoc' _ _ rest = rest leksah-server-0.12.1.2/src/IDE/Metainfo/PackageCollector.hs0000644000000000000000000003643511770163230021377 0ustar0000000000000000{-# OPTIONS_GHC -XScopedTypeVariables -fno-warn-type-defaults #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.PackageCollector -- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL Nothing -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Metainfo.PackageCollector ( collectPackage ) where import IDE.StrippedPrefs (RetrieveStrategy(..), Prefs(..)) import PackageConfig (PackageConfig) import IDE.Metainfo.SourceCollectorH (findSourceForPackage, packageFromSource, PackageCollectStats(..)) import System.Log.Logger (debugM, infoM) import IDE.Metainfo.InterfaceCollector (collectPackageFromHI) import IDE.Core.CTypes (getThisPackage, SimpleDescr(..), TypeDescr(..), ReexportedDescr(..), Descr(..), RealDescr(..), dscTypeHint, descrType, dscName, Descr, ModuleDescr(..), PackModule(..), PackageDescr(..), metadataVersion, leksahVersion, packageIdentifierToString) import IDE.Utils.FileUtils (getCollectorPath) import System.Directory (doesFileExist, setCurrentDirectory) import IDE.Utils.Utils (leksahMetadataPathFileExtension, leksahMetadataSystemFileExtension) import System.FilePath (dropFileName, (<.>), ()) import Data.Binary.Shared (encodeFileSer) import qualified Data.Map as Map (fromListWith, fromList, keys, lookup) import Data.List (delete, nub) import Distribution.Text (display) import Control.Exception (SomeException,catch) #if defined(USE_LIBCURL) import Network.Curl (curlGetString_, CurlCode(..)) import Control.Monad (when) import System.IO (withBinaryFile, IOMode(..)) import Data.ByteString (hPutStr) #else #ifdef MIN_VERSION_process_leksah import IDE.System.Process (system) #else import System.Process (system) #endif #endif import Prelude hiding(catch) import Control.Monad.IO.Class (MonadIO, MonadIO(..)) import qualified Control.Exception as NewException (SomeException, catch) import IDE.Utils.Tool (runTool') collectPackage :: Bool -> Prefs -> Int -> (PackageConfig,Int) -> IO PackageCollectStats collectPackage writeAscii prefs numPackages (packageConfig, packageIndex) = do infoM "leksah-server" ("update_toolbar " ++ show ((fromIntegral packageIndex / fromIntegral numPackages) :: Double)) let packageName = packageIdentifierToString (getThisPackage packageConfig) let stat = PackageCollectStats packageName Nothing False False Nothing eitherStrFp <- findSourceForPackage prefs packageConfig case eitherStrFp of Left message -> do packageDescrHi <- collectPackageFromHI packageConfig writeExtractedPackage False packageDescrHi return stat {packageString = message, modulesTotal = Just (length (pdModules packageDescrHi))} Right fpSource -> case retrieveStrategy prefs of RetrieveThenBuild -> do success <- retrieve packageName if success then do debugM "leksah-server" $ "collectPackage: retreived = " ++ packageName liftIO $ writePackagePath (dropFileName fpSource) packageName return (stat {withSource=True, retrieved= True, mbError=Nothing}) else do debugM "leksah-server" $ "collectPackage: Can't retreive = " ++ packageName runCabalConfigure fpSource packageDescrHi <- collectPackageFromHI packageConfig mbPackageDescrPair <- packageFromSource fpSource packageConfig case mbPackageDescrPair of (Just packageDescrS, bstat) -> do writeMerged packageDescrS packageDescrHi fpSource packageName return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} (Nothing,bstat) -> do writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} BuildThenRetrieve -> do runCabalConfigure fpSource mbPackageDescrPair <- packageFromSource fpSource packageConfig case mbPackageDescrPair of (Just packageDescrS,bstat) -> do packageDescrHi <- collectPackageFromHI packageConfig writeMerged packageDescrS packageDescrHi fpSource packageName return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} (Nothing,bstat) -> do success <- retrieve packageName if success then do debugM "leksah-server" $ "collectPackage: retreived = " ++ packageName liftIO $ writePackagePath (dropFileName fpSource) packageName return (stat {withSource=True, retrieved= True, mbError=Nothing}) else do packageDescrHi <- collectPackageFromHI packageConfig writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} NeverRetrieve -> do runCabalConfigure fpSource packageDescrHi <- collectPackageFromHI packageConfig mbPackageDescrPair <- packageFromSource fpSource packageConfig case mbPackageDescrPair of (Just packageDescrS,bstat) -> do writeMerged packageDescrS packageDescrHi fpSource packageName return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} (Nothing,bstat) -> do writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} where retrieve :: String -> IO Bool retrieve packString = do collectorPath <- liftIO $ getCollectorPath setCurrentDirectory collectorPath let fullUrl = retrieveURL prefs ++ "/metadata-" ++ leksahVersion ++ "/" ++ packString ++ leksahMetadataSystemFileExtension filePath = collectorPath packString <.> leksahMetadataSystemFileExtension debugM "leksah-server" $ "collectPackage: before retreiving = " ++ fullUrl #if defined(USE_LIBCURL) catch (do (code, string) <- curlGetString_ fullUrl [] when (code == CurlOK) $ withBinaryFile filePath WriteMode $ \ file -> do hPutStr file string) #elif defined(USE_CURL) catch ((system $ "curl -OL --fail " ++ fullUrl) >> return ()) #else catch ((system $ "wget " ++ fullUrl) >> return ()) #endif (\(e :: SomeException) -> debugM "leksah-server" $ "collectPackage: Error when calling wget " ++ show e) debugM "leksah-server" $ "collectPackage: after retreiving = " ++ packString -- ++ " result = " ++ res exist <- doesFileExist filePath return exist writeMerged packageDescrS packageDescrHi fpSource packageName = do let mergedPackageDescr = mergePackageDescrs packageDescrHi packageDescrS liftIO $ writeExtractedPackage writeAscii mergedPackageDescr liftIO $ writePackagePath (dropFileName fpSource) packageName runCabalConfigure fpSource = do let dirPath = dropFileName fpSource setCurrentDirectory dirPath NewException.catch (runTool' "cabal" (["configure","--user"]) Nothing >> return ()) (\ (_e :: NewException.SomeException) -> do debugM "leksah-server" "Can't configure" return ()) writeExtractedPackage :: MonadIO m => Bool -> PackageDescr -> m () writeExtractedPackage writeAscii pd = do collectorPath <- liftIO $ getCollectorPath let filePath = collectorPath packageIdentifierToString (pdPackage pd) <.> leksahMetadataSystemFileExtension if writeAscii then liftIO $ writeFile (filePath ++ "dpg") (show pd) else liftIO $ encodeFileSer filePath (metadataVersion, pd) writePackagePath :: MonadIO m => FilePath -> String -> m () writePackagePath fp packageName = do collectorPath <- liftIO $ getCollectorPath let filePath = collectorPath packageName <.> leksahMetadataPathFileExtension liftIO $ writeFile filePath fp --------------Merging of .hi and .hs parsing / parsing and typechecking results mergePackageDescrs :: PackageDescr -> PackageDescr -> PackageDescr mergePackageDescrs packageDescrHI packageDescrS = PackageDescr { pdPackage = pdPackage packageDescrHI , pdMbSourcePath = pdMbSourcePath packageDescrS , pdModules = mergeModuleDescrs (pdModules packageDescrHI) (pdModules packageDescrS) , pdBuildDepends = pdBuildDepends packageDescrHI} mergeModuleDescrs :: [ModuleDescr] -> [ModuleDescr] -> [ModuleDescr] mergeModuleDescrs hiList srcList = map mergeIt allNames where mergeIt :: String -> ModuleDescr mergeIt str = case (Map.lookup str hiDict, Map.lookup str srcDict) of (Just mdhi, Nothing) -> mdhi (Nothing, Just mdsrc) -> mdsrc (Just mdhi, Just mdsrc) -> mergeModuleDescr mdhi mdsrc (Nothing, Nothing) -> error "Collector>>mergeModuleDescrs: impossible" allNames = nub $ Map.keys hiDict ++ Map.keys srcDict hiDict = Map.fromList $ zip ((map (display . modu . mdModuleId)) hiList) hiList srcDict = Map.fromList $ zip ((map (display . modu . mdModuleId)) srcList) srcList mergeModuleDescr :: ModuleDescr -> ModuleDescr -> ModuleDescr mergeModuleDescr hiDescr srcDescr = ModuleDescr { mdModuleId = mdModuleId hiDescr , mdMbSourcePath = mdMbSourcePath srcDescr , mdReferences = mdReferences hiDescr , mdIdDescriptions = mergeDescrs (mdIdDescriptions hiDescr) (mdIdDescriptions srcDescr)} mergeDescrs :: [Descr] -> [Descr] -> [Descr] mergeDescrs hiList srcList = concatMap mergeIt allNames where mergeIt :: String -> [Descr] mergeIt pm = case (Map.lookup pm hiDict, Map.lookup pm srcDict) of (Just mdhi, Nothing) -> mdhi (Nothing, Just mdsrc) -> mdsrc (Just mdhi, Just mdsrc) -> map (\ (a,b) -> mergeDescr a b) $ makePairs mdhi mdsrc (Nothing, Nothing) -> error "Collector>>mergeModuleDescrs: impossible" allNames = nub $ Map.keys hiDict ++ Map.keys srcDict hiDict = Map.fromListWith (++) $ zip ((map dscName) hiList) (map (\ e -> [e]) hiList) srcDict = Map.fromListWith (++) $ zip ((map dscName) srcList)(map (\ e -> [e]) srcList) makePairs :: [Descr] -> [Descr] -> [(Maybe Descr,Maybe Descr)] makePairs (hd:tl) srcList = (Just hd, theMatching) : makePairs tl (case theMatching of Just tm -> delete tm srcList Nothing -> srcList) where theMatching = findMatching hd srcList findMatching ele (hd':tail') | matches ele hd' = Just hd' | otherwise = findMatching ele tail' findMatching _ele [] = Nothing matches :: Descr -> Descr -> Bool matches d1 d2 = (descrType . dscTypeHint) d1 == (descrType . dscTypeHint) d2 makePairs [] rest = map (\ a -> (Nothing, Just a)) rest mergeDescr :: Maybe Descr -> Maybe Descr -> Descr mergeDescr (Just descr) Nothing = descr mergeDescr Nothing (Just descr) = descr mergeDescr (Just (Real rdhi)) (Just (Real rdsrc)) = Real RealDescr { dscName' = dscName' rdhi , dscMbTypeStr' = dscMbTypeStr' rdhi , dscMbModu' = dscMbModu' rdsrc , dscMbLocation' = dscMbLocation' rdsrc , dscMbComment' = dscMbComment' rdsrc , dscTypeHint' = mergeTypeDescr (dscTypeHint' rdhi) (dscTypeHint' rdsrc) , dscExported' = True } mergeDescr (Just (Reexported rdhi)) (Just rdsrc) = Reexported $ ReexportedDescr { dsrMbModu = dsrMbModu rdhi , dsrDescr = mergeDescr (Just (dsrDescr rdhi)) (Just rdsrc) } mergeDescr _ _ = error "Collector>>mergeDescr: impossible" --mergeTypeHint :: Maybe TypeDescr -> Maybe TypeDescr -> Maybe TypeDescr --mergeTypeHint Nothing Nothing = Nothing --mergeTypeHint Nothing jtd = jtd --mergeTypeHint jtd Nothing = jtd --mergeTypeHint (Just tdhi) (Just tdhs) = Just (mergeTypeDescr tdhi tdhs) mergeTypeDescr :: TypeDescr -> TypeDescr -> TypeDescr mergeTypeDescr (DataDescr constrListHi fieldListHi) (DataDescr constrListSrc fieldListSrc) = DataDescr (mergeSimpleDescrs constrListHi constrListSrc) (mergeSimpleDescrs fieldListHi fieldListSrc) mergeTypeDescr (NewtypeDescr constrHi mbFieldHi) (NewtypeDescr constrSrc mbFieldSrc) = NewtypeDescr (mergeSimpleDescr constrHi constrSrc) (mergeMbDescr mbFieldHi mbFieldSrc) mergeTypeDescr (ClassDescr superHi methodsHi) (ClassDescr _superSrc methodsSrc) = ClassDescr superHi (mergeSimpleDescrs methodsHi methodsSrc) mergeTypeDescr (InstanceDescr _bindsHi) (InstanceDescr bindsSrc) = InstanceDescr bindsSrc mergeTypeDescr descrHi _ = descrHi mergeSimpleDescrs :: [SimpleDescr] -> [SimpleDescr] -> [SimpleDescr] mergeSimpleDescrs hiList srcList = map mergeIt allNames where mergeIt :: String -> SimpleDescr mergeIt pm = case mergeMbDescr (Map.lookup pm hiDict) (Map.lookup pm srcDict) of Just mdhi -> mdhi Nothing -> error "Collector>>mergeSimpleDescrs: impossible" allNames = nub $ Map.keys hiDict ++ Map.keys srcDict hiDict = Map.fromList $ zip ((map sdName) hiList) hiList srcDict = Map.fromList $ zip ((map sdName) srcList) srcList mergeSimpleDescr :: SimpleDescr -> SimpleDescr -> SimpleDescr mergeSimpleDescr sdHi sdSrc = SimpleDescr { sdName = sdName sdHi, sdType = sdType sdHi, sdLocation = sdLocation sdSrc, sdComment = sdComment sdSrc, sdExported = sdExported sdSrc} mergeMbDescr :: Maybe SimpleDescr -> Maybe SimpleDescr -> Maybe SimpleDescr mergeMbDescr (Just mdhi) Nothing = Just mdhi mergeMbDescr Nothing (Just mdsrc) = Just mdsrc mergeMbDescr (Just mdhi) (Just mdsrc) = Just (mergeSimpleDescr mdhi mdsrc) mergeMbDescr Nothing Nothing = Nothing leksah-server-0.12.1.2/src/IDE/Metainfo/InterfaceCollector.hs0000644000000000000000000003660011770163230021736 0ustar0000000000000000{-# OPTIONS_GHC -XScopedTypeVariables -XFlexibleContexts#-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.InterfaceCollector -- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GNU-GPL -- -- Maintainer : -- Stability : provisional -- Portability : portable -- -- | This modulle extracts information from .hi files for installed packages -- ------------------------------------------------------------------------------- module IDE.Metainfo.InterfaceCollector ( collectPackageFromHI , extractExportedDescrH , extractExportedDescrR ) where import MyMissing (nonEmptyLines) import Module hiding (PackageId,ModuleName) import qualified Module as Module (ModuleName) import qualified Maybes as M #if MIN_VERSION_ghc(7,2,0) import HscTypes import GhcMonad hiding (liftIO) import qualified GhcMonad as Hs (liftIO) #else import HscTypes hiding (liftIO) import qualified HscTypes as Hs (liftIO) #endif #if MIN_VERSION_ghc(7,3,0) import Avail import TysWiredIn ( eqTyConName ) #endif import LoadIface import Outputable hiding(trace) import IfaceSyn import FastString import Name import PrelNames #if MIN_VERSION_ghc(6,12,1) import PackageConfig (PackageConfig, mkPackageId) #else import PackageConfig (PackageConfig, mkPackageId) #endif import TcRnTypes import Data.Char (isSpace) import qualified Data.Map as Map import Data.Maybe import qualified Data.Set as Set import Data.Set (Set) import qualified Distribution.InstalledPackageInfo as IPI import Distribution.Package hiding (PackageId) import Distribution.ModuleName import Distribution.Text (simpleParse) import qualified Data.ByteString.Char8 as BS import IDE.Core.Serializable () import IDE.Core.CTypes import Data.ByteString.Char8 (ByteString) import TcRnMonad (initTcRnIf) import IDE.Utils.GHCUtils import Control.DeepSeq(deepseq) collectPackageFromHI :: PackageConfig -> IO PackageDescr collectPackageFromHI packageConfig = inGhcIO [] [] $ \ _ -> do session <- getSession exportedIfaceInfos <- getIFaceInfos (getThisPackage packageConfig) (IPI.exposedModules packageConfig) session hiddenIfaceInfos <- getIFaceInfos (getThisPackage packageConfig) (IPI.hiddenModules packageConfig) session let pd = extractInfo exportedIfaceInfos hiddenIfaceInfos (getThisPackage packageConfig) #if MIN_VERSION_Cabal(1,8,0) [] -- TODO 6.12 (IPI.depends $ packageConfigToInstalledPackageInfo packageConfig)) #else (depends packageConfig) #endif deepseq pd (return pd) getIFaceInfos :: PackageIdentifier -> [Module.ModuleName] -> HscEnv -> Ghc [(ModIface, FilePath)] getIFaceInfos pid modules _session = do let isBase = pkgName pid == (PackageName "base") let ifaces = mapM (\ mn -> findAndReadIface empty (if isBase then mkBaseModule_ mn else mkModule (mkPackageId pid) mn) False) modules hscEnv <- getSession let gblEnv = IfGblEnv { if_rec_types = Nothing } maybes <- Hs.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 ------------------------------------------------------------------------- extractInfo :: [(ModIface, FilePath)] -> [(ModIface, FilePath)] -> PackageIdentifier -> [PackageIdentifier] -> PackageDescr extractInfo ifacesExp ifacesHid pid buildDepends = let allDescrs = concatMap (extractExportedDescrH pid) (map fst (ifacesHid ++ ifacesExp)) mods = map (extractExportedDescrR pid allDescrs) (map fst ifacesExp) in PackageDescr { pdPackage = pid , pdModules = mods , pdBuildDepends = buildDepends , pdMbSourcePath = Nothing} extractExportedDescrH :: PackageIdentifier -> ModIface -> [Descr] extractExportedDescrH pid iface = let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) exportedNames = Set.fromList #if MIN_VERSION_Cabal(1,11,0) $ map (occNameString . nameOccName) $ concatMap availNames $ mi_exports iface #else $ map occNameString $ concatMap availNames $ concatMap snd (mi_exports iface) #endif exportedDecls = filter (\ ifdecl -> (occNameString $ ifName ifdecl) `Set.member` exportedNames) (map snd (mi_decls iface)) in concatMap (extractIdentifierDescr pid [mid]) exportedDecls extractExportedDescrR :: PackageIdentifier -> [Descr] -> ModIface -> ModuleDescr extractExportedDescrR pid hidden iface = let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) exportedNames = Set.fromList #if MIN_VERSION_Cabal(1,11,0) $ map (occNameString . nameOccName) $ concatMap availNames $ mi_exports iface #else $ map occNameString $ concatMap availNames $ concatMap snd (mi_exports iface) #endif exportedDecls = filter (\ ifdecl -> (occNameString $ifName ifdecl) `Set.member` exportedNames) (map snd (mi_decls iface)) ownDecls = concatMap (extractIdentifierDescr pid [mid]) exportedDecls otherDecls = exportedNames `Set.difference` (Set.fromList (map dscName ownDecls)) reexported = map (\d -> Reexported (ReexportedDescr (Just (PM pid mid)) d)) $ filter (\k -> (dscName k) `Set.member` otherDecls) hidden inst = concatMap (extractInstances (PM pid mid)) (mi_insts iface) uses = Map.fromList . catMaybes $ map extractUsages (mi_usages iface) declsWithExp = map withExp ownDecls withExp (Real d) = Real $ d{dscExported' = Set.member (dscName' d) exportedNames} withExp _ = error "Unexpected Reexported" in ModuleDescr { mdModuleId = PM pid mid , mdMbSourcePath = Nothing , mdReferences = uses , mdIdDescriptions = declsWithExp ++ inst ++ reexported} extractIdentifierDescr :: PackageIdentifier -> [ModuleName] -> IfaceDecl -> [Descr] extractIdentifierDescr package modules decl = if null modules then [] else let descr = RealDescr{ dscName' = unpackFS $occNameFS (ifName decl) , dscMbTypeStr' = Just (BS.pack $ unlines $ nonEmptyLines $ filterExtras $ showSDocUnqual $ppr decl) , dscMbModu' = Just (PM package (last modules)) , dscMbLocation' = Nothing , dscMbComment' = Nothing , dscTypeHint' = VariableDescr , dscExported' = True } in case decl of #if MIN_VERSION_Cabal(1,8,0) (IfaceId _ _ _ _) #else (IfaceId _ _ _) #endif -> map Real [descr] #if MIN_VERSION_Cabal(1,11,0) (IfaceData name _ _ ifCons' _ _ _) #else (IfaceData name _ _ ifCons' _ _ _ _) #endif -> let d = case ifCons' of IfDataTyCon _decls -> let fieldNames = concatMap extractFields (visibleIfConDecls ifCons') constructors' = extractConstructors name (visibleIfConDecls ifCons') in DataDescr constructors' fieldNames 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 #if MIN_VERSION_ghc(7,3,0) IfAbstractTyCon _ -> DataDescr [] [] #else IfAbstractTyCon -> DataDescr [] [] #endif IfOpenDataTyCon -> DataDescr [] [] in [Real (descr{dscTypeHint' = d})] (IfaceClass context _ _ _ _ ifSigs' _ ) -> let classOpsID = map extractClassOp ifSigs' superclasses = extractSuperClassNames context in [Real $ descr{dscTypeHint' = ClassDescr superclasses classOpsID}] (IfaceSyn _ _ _ _ _ ) -> [Real $ descr{dscTypeHint' = TypeDescr}] (IfaceForeign _ _) -> [Real $ descr] extractConstructors :: OccName -> [IfaceConDecl] -> [SimpleDescr] extractConstructors name decls = map (\decl -> SimpleDescr (unpackFS $occNameFS (ifConOcc decl)) (Just (BS.pack $ filterExtras $ showSDocUnqual $ pprIfaceForAllPart (ifConUnivTvs decl ++ ifConExTvs decl) (eq_ctxt decl ++ ifConCtxt decl) (pp_tau decl))) Nothing Nothing True) 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] #if MIN_VERSION_ghc(7,3,0) eq_ctxt decl = [IfaceTyConApp (IfaceTc eqTyConName) [(IfaceTyVar (occNameFS tv)), ty] #else eq_ctxt decl = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) #endif | (tv,ty) <- ifConEqSpec decl] extractFields :: IfaceConDecl -> [SimpleDescr] extractFields decl = map (\ (n, t) -> SimpleDescr n t Nothing Nothing True) $ zip (map extractFieldNames (ifConFields decl)) (map extractType (ifConArgTys decl)) extractType :: IfaceType -> Maybe ByteString extractType it = Just ((BS.pack . filterExtras . showSDocUnqual . ppr) it) extractFieldNames :: OccName -> String extractFieldNames occName = unpackFS $occNameFS occName extractClassOp :: IfaceClassOp -> SimpleDescr extractClassOp (IfaceClassOp occName _dm ty) = SimpleDescr (unpackFS $occNameFS occName) (Just (BS.pack $ showSDocUnqual (ppr ty))) Nothing Nothing True extractSuperClassNames :: [IfacePredType] -> [String] extractSuperClassNames l = catMaybes $ map extractSuperClassName l where #if !MIN_VERSION_ghc(7,3,0) extractSuperClassName (IfaceClassP name _) = Just (unpackFS $occNameFS $ nameOccName name) #endif 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 [Real (RealDescr { dscName' = className , dscMbTypeStr' = Nothing , dscMbModu' = Just pm , dscMbLocation' = Nothing , dscMbComment' = Nothing , dscTypeHint' = InstanceDescr dataNames , dscExported' = False})] extractUsages :: Usage -> Maybe (ModuleName, Set String) #if MIN_VERSION_Cabal(1,11,0) extractUsages (UsagePackageModule usg_mod' _ _) = #else extractUsages (UsagePackageModule usg_mod' _ ) = #endif let name = (fromJust . simpleParse . moduleNameString) (moduleName usg_mod') in Just (name, Set.fromList []) #if MIN_VERSION_Cabal(1,11,0) extractUsages (UsageHomeModule usg_mod_name' _ usg_entities' _ _) = #else extractUsages (UsageHomeModule usg_mod_name' _ usg_entities' _) = #endif let name = (fromJust . simpleParse . moduleNameString) usg_mod_name' ids = map (showSDocUnqual . ppr . fst) usg_entities' in Just (name, Set.fromList ids) #if MIN_VERSION_ghc(7,4,0) extractUsages (UsageFile _ _) = Nothing #endif filterExtras, filterExtras' :: String -> String filterExtras ('{':'-':r) = filterExtras' r filterExtras ('R':'e':'c':'F':'l':'a':'g':r) = filterExtras (skipNextWord r) filterExtras ('G':'e':'n':'e':'r':'i':'c':'s':':':r) = filterExtras (skipNextWord r) filterExtras ('F':'a':'m':'i':'l':'y':'I':'n':'s':'t':'a':'n':'c':'e':':':r) = filterExtras (skipNextWord r) filterExtras (c:r) = c : filterExtras r filterExtras [] = [] filterExtras' ('-':'}':r) = filterExtras r filterExtras' (_:r) = filterExtras' r filterExtras' [] = [] skipNextWord, skipNextWord' :: String -> String skipNextWord (a:r) | isSpace a = skipNextWord r | otherwise = skipNextWord' r skipNextWord [] = [] skipNextWord'(a:r) | a == '\n' = r | isSpace a = a:r | otherwise = skipNextWord' r skipNextWord' [] = [] leksah-server-0.12.1.2/src/IDE/Metainfo/SourceDB.hs0000644000000000000000000001747511770163230017646 0ustar0000000000000000 ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.SourceDB -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Metainfo.SourceDB ( buildSourceForPackageDB , sourceForPackage , parseSourceForPackageDB , getSourcesMap ) where import IDE.StrippedPrefs (getUnpackDirectory, getSourceDirectories, Prefs(..)) import Data.Map (Map) import Distribution.Package (PackageIdentifier(..)) import IDE.Utils.Utils (standardSourcesFilename) import qualified Data.Map as Map (fromList, toList, fromListWith, lookup) import IDE.Utils.FileUtils (myCanonicalizePath, getConfigFilePathForLoad, getConfigFilePathForSave, allCabalFiles) import System.Directory (doesFileExist) import Data.List (foldl') import qualified Text.PrettyPrint as PP (colon, (<>), text, ($$), vcat, Doc, render, char) import Text.ParserCombinators.Parsec (try, char, unexpected, noneOf, eof, many, CharParser, Parser, (), (<|>)) import Text.ParserCombinators.Parsec.Prim (parse) import Text.ParserCombinators.Parsec.Error (ParseError) import Text.ParserCombinators.Parsec.Language (emptyDef) #if MIN_VERSION_parsec(3,0,0) import qualified Text.ParserCombinators.Parsec.Token as P (GenTokenParser(..), TokenParser, makeTokenParser, commentLine, commentEnd, commentStart, LanguageDef) #else import qualified Text.ParserCombinators.Parsec.Token as P (TokenParser(..), makeTokenParser, commentLine, commentEnd, commentStart, LanguageDef) #endif import Data.Maybe (catMaybes) import IDE.Core.CTypes (packageIdentifierFromString) import Paths_leksah_server import System.Log.Logger(errorM,debugM) import System.IO.Strict as S (readFile) -- --------------------------------------------------------------------- -- Function to map packages to file paths -- getSourcesMap :: Prefs -> IO (Map PackageIdentifier [FilePath]) getSourcesMap prefs = do mbSources <- parseSourceForPackageDB case mbSources of Just map' -> return map' Nothing -> do buildSourceForPackageDB prefs mbSources' <- parseSourceForPackageDB case mbSources' of Just map'' -> do return map'' Nothing -> error "can't build/open source for package file" sourceForPackage :: PackageIdentifier -> (Map PackageIdentifier [FilePath]) -> Maybe FilePath sourceForPackage pid pmap = case pid `Map.lookup` pmap of Just (h:_) -> Just h _ -> Nothing buildSourceForPackageDB :: Prefs -> IO () buildSourceForPackageDB prefs = do sourceDirs <- getSourceDirectories prefs unpackDir <- getUnpackDirectory prefs let dirs = case unpackDir of Just dir -> dir : sourceDirs Nothing -> sourceDirs cabalFiles <- mapM allCabalFiles dirs fCabalFiles <- mapM myCanonicalizePath $ concat cabalFiles mbPackAndFiles <- mapM (\fp -> do mb <- parseCabal fp case mb of Just s -> return $ Just (s, [fp]) Nothing -> return Nothing) fCabalFiles let pdToFiles = Map.fromListWith (++) $ catMaybes mbPackAndFiles filePath <- getConfigFilePathForSave standardSourcesFilename writeFile filePath (PP.render (showSourceForPackageDB pdToFiles)) showSourceForPackageDB :: Map String [FilePath] -> PP.Doc showSourceForPackageDB aMap = PP.vcat (map showIt (Map.toList aMap)) where showIt :: (String,[FilePath]) -> PP.Doc showIt (pd,list) = (foldl' (\l n -> l PP.$$ (PP.text $ show n)) label list) PP.<> PP.char '\n' where label = PP.text pd PP.<> PP.colon -- Strict version parseFromFile :: Parser a -> String -> IO (Either ParseError a) parseFromFile p f = do input <- S.readFile f return $ parse p f input parseSourceForPackageDB :: IO (Maybe (Map PackageIdentifier [FilePath])) parseSourceForPackageDB = do dataDir <- getDataDir filePath <- getConfigFilePathForLoad standardSourcesFilename Nothing dataDir exists <- doesFileExist filePath if exists then do res <- parseFromFile sourceForPackageParser filePath case res of Left pe -> do errorM "leksah-server" $ "Error reading source packages file " ++ filePath ++ " " ++ show pe return Nothing Right r -> return (Just r) else do errorM "leksah-server" $" No source packages file found: " ++ filePath return Nothing -- -- --------------------------------------------------------------------- -- | Parser for Package DB -- packageStyle :: P.LanguageDef st packageStyle = emptyDef { P.commentStart = "{-" , P.commentLine = "--" , P.commentEnd = "-}" } lexer :: P.TokenParser st lexer = P.makeTokenParser packageStyle whiteSpace :: CharParser st () whiteSpace = P.whiteSpace lexer symbol :: String -> CharParser st String symbol = P.symbol lexer sourceForPackageParser :: CharParser () (Map PackageIdentifier [FilePath]) sourceForPackageParser = do whiteSpace ls <- many onePackageParser whiteSpace eof return (Map.fromList (catMaybes ls)) "sourceForPackageParser" onePackageParser :: CharParser () (Maybe (PackageIdentifier,[FilePath])) onePackageParser = do mbPd <- packageDescriptionParser filePaths <- many filePathParser case mbPd of Nothing -> return Nothing Just pd -> return (Just (pd,filePaths)) "onePackageParser" packageDescriptionParser :: CharParser () (Maybe PackageIdentifier) packageDescriptionParser = try (do whiteSpace str <- many (noneOf ":") char ':' return (packageIdentifierFromString str)) "packageDescriptionParser" filePathParser :: CharParser () FilePath filePathParser = try (do whiteSpace char '"' str <- many (noneOf ['"']) char '"' return (str)) "filePathParser" parseCabal :: FilePath -> IO (Maybe String) parseCabal fn = do --putStrLn $ "Now parsing minimal " ++ fn res <- parseFromFile cabalMinimalParser fn case res of Left pe -> do errorM "leksah-server" $"Error reading cabal file " ++ show fn ++ " " ++ show pe return Nothing Right r -> do debugM "leksah-server" r return (Just r) cabalMinimalParser :: CharParser () String cabalMinimalParser = do r1 <- cabalMinimalP r2 <- cabalMinimalP case r1 of Left v -> do case r2 of Right n -> return (n ++ "-" ++ v) Left _ -> unexpected "Illegal cabal" Right n -> do case r2 of Left v -> return (n ++ "-" ++ v) Right _ -> unexpected "Illegal cabal" cabalMinimalP :: CharParser () (Either String String) cabalMinimalP = do try $(symbol "name:" <|> symbol "Name:") whiteSpace name <- (many $noneOf " \n") (many $noneOf "\n") char '\n' return (Right name) <|> do try $(symbol "version:" <|> symbol "Version:") whiteSpace versionString <- (many $noneOf " \n") (many $noneOf "\n") char '\n' return (Left versionString) <|> do many $noneOf "\n" char '\n' cabalMinimalP "cabal minimal" leksah-server-0.12.1.2/src/IDE/Metainfo/Collector.hs0000644000000000000000000003502011770163230020110 0ustar0000000000000000{-# OPTIONS_GHC -XScopedTypeVariables -fno-warn-type-defaults #-} ----------------------------------------------------------------------------- -- -- Module : Main -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module Main ( main , collectPackage ) where import System.Console.GetOpt (ArgDescr(..), usageInfo, ArgOrder(..), getOpt, OptDescr(..)) import System.Environment (getArgs) import Control.Monad (when) import Data.Version (showVersion) import Paths_leksah_server (getDataDir, version) import IDE.Utils.FileUtils import IDE.Utils.Utils import IDE.Utils.GHCUtils import IDE.StrippedPrefs import IDE.Metainfo.WorkspaceCollector import Data.Maybe(catMaybes, fromJust, mapMaybe, isJust) import Prelude hiding(catch) import Control.Monad (liftM) import qualified Data.Set as Set (member) import IDE.Core.CTypes hiding (Extension) import IDE.Metainfo.SourceDB (buildSourceForPackageDB) import Data.Time import Control.Exception (catch, SomeException) import MyMissing(trim) import System.Log import System.Log.Logger(updateGlobalLogger,rootLoggerName,addHandler,debugM,infoM,errorM, setLevel) import System.Log.Handler.Simple(fileHandler) import Network(withSocketsDo) import Network.Socket (inet_addr, SocketType(..), SockAddr(..), PortNumber(..)) import IDE.Utils.Server import System.IO (Handle, hPutStrLn, hGetLine, hFlush, hClose) import IDE.HeaderParser(parseTheHeader) import System.Exit (ExitCode(..)) import Data.IORef import Control.Concurrent (throwTo, ThreadId, myThreadId) import IDE.Metainfo.PackageCollector(collectPackage) import Data.List (delete) import System.Directory (removeFile, doesFileExist, removeDirectoryRecursive, doesDirectoryExist) import IDE.Metainfo.SourceCollectorH (PackageCollectStats(..)) import Control.Monad.IO.Class (MonadIO(..)) -- -------------------------------------------------------------------- -- Command line options -- data Flag = CollectSystem | ServerCommand (Maybe String) --modifiers | Rebuild | Sources -- | Directory FilePath --others | VersionF | Help | Debug | Verbosity String | LogFile String | Forever | EndWithLast deriving (Show,Eq) options :: [OptDescr Flag] options = [ -- main functions Option ['s'] ["system"] (NoArg CollectSystem) "Collects new information for installed packages" , Option ['r'] ["server"] (OptArg ServerCommand "Maybe Port") "Start as server." , Option ['b'] ["rebuild"] (NoArg Rebuild) "Modifier for -s and -p: Rebuild metadata" , Option ['o'] ["sources"] (NoArg Sources) "Modifier for -s: Gather info about pathes to sources" , Option ['v'] ["version"] (NoArg VersionF) "Show the version number of ide" , Option ['h'] ["help"] (NoArg Help) "Display command line options" , Option ['d'] ["debug"] (NoArg Debug) "Write ascii pack files" , Option ['e'] ["verbosity"] (ReqArg Verbosity "Verbosity") "One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY" , Option ['l'] ["logfile"] (ReqArg LogFile "LogFile") "File path for logging messages" , Option ['f'] ["forever"] (NoArg Forever) "Don't end the server when last connection ends" , Option ['c'] ["endWithLast"] (NoArg EndWithLast) "End the server when last connection ends" ] header :: String header = "Usage: leksah-server [OPTION...] files..." ideOpts :: [String] -> IO ([Flag], [String]) ideOpts argv = case getOpt Permute options argv of (o,n,[] ) -> return (o,n) (_,_,errs) -> ioError $ userError $ concat errs ++ usageInfo header options -- --------------------------------------------------------------------- -- | Main function -- main :: IO () main = withSocketsDo $ catch inner handler where handler (e :: SomeException) = do putStrLn $ "leksah-server: " ++ (show e) errorM "leksah-server" (show e) return () inner = do args <- getArgs (o,_) <- ideOpts args let verbosity' = catMaybes $ map (\x -> case x of Verbosity s -> Just s _ -> Nothing) o let verbosity = case verbosity' of [] -> INFO h:_ -> read h let logFile' = catMaybes $ map (\x -> case x of LogFile s -> Just s _ -> Nothing) o let logFile = case logFile' of [] -> Nothing h:_ -> Just h updateGlobalLogger rootLoggerName (\ l -> setLevel verbosity l) when (isJust logFile) $ do handler' <- fileHandler (fromJust logFile) verbosity updateGlobalLogger rootLoggerName (\ l -> addHandler handler' l) infoM "leksah-server" $ "***server start" debugM "leksah-server" $ "args: " ++ show args dataDir <- getDataDir prefsPath <- getConfigFilePathForLoad strippedPreferencesFilename Nothing dataDir prefs <- readStrippedPrefs prefsPath debugM "leksah-server" $ "prefs " ++ show prefs connRef <- newIORef [] threadId <- myThreadId localServerAddr <- inet_addr "127.0.0.1" if elem VersionF o then putStrLn $ "Leksah Haskell IDE (server), version " ++ showVersion version else if elem Help o then putStrLn $ "Leksah Haskell IDE (server) " ++ usageInfo header options else do let servers = catMaybes $ map (\x -> case x of ServerCommand s -> Just s _ -> Nothing) o let sources = elem Sources o let rebuild = elem Rebuild o let debug = elem Debug o let forever = elem Forever o let endWithLast = elem EndWithLast o let newPrefs = if forever && not endWithLast then prefs{endWithLastConn = False} else if not forever && endWithLast then prefs{endWithLastConn = True} else prefs if elem CollectSystem o then do debugM "leksah-server" "collectSystem" collectSystem prefs debug rebuild sources else case servers of (Nothing:_) -> do running <- serveOne Nothing (server (PortNum (fromIntegral (serverPort prefs))) newPrefs connRef threadId localServerAddr) waitFor running return () (Just ps:_) -> do let port = read ps running <- serveOne Nothing (server (PortNum (fromIntegral port)) newPrefs connRef threadId localServerAddr) waitFor running return () _ -> return () server port prefs connRef threadId hostAddr = Server (SockAddrInet port hostAddr) Stream (doCommands prefs connRef threadId) doCommands :: Prefs -> IORef [Handle] -> ThreadId -> (Handle, t1, t2) -> IO () doCommands prefs connRef threadId (h,n,p) = do atomicModifyIORef connRef (\ list -> (h : list, ())) doCommands' prefs connRef threadId (h,n,p) doCommands' :: Prefs -> IORef [Handle] -> ThreadId -> (Handle, t1, t2) -> IO () doCommands' prefs connRef threadId (h,n,p) = do debugM "leksah-server" $ "***wait" mbLine <- catch (liftM Just (hGetLine h)) (\ (_e :: SomeException) -> do infoM "leksah-server" $ "***lost connection" hClose h atomicModifyIORef connRef (\ list -> (delete h list,())) handles <- readIORef connRef case handles of [] -> do when (endWithLastConn prefs) $ do infoM "leksah-server" $ "***lost last connection - exiting" throwTo threadId ExitSuccess --exitSuccess infoM "leksah-server" $ "***lost last connection - waiting" return Nothing _ -> return Nothing) case mbLine of Nothing -> return () Just line -> do case read line of SystemCommand rebuild sources _extract -> --the extract arg is not used catch (do collectSystem prefs False rebuild sources hPutStrLn h (show ServerOK) hFlush h) (\ (e :: SomeException) -> do hPutStrLn h (show (ServerFailed (show e))) hFlush h) WorkspaceCommand rebuild package path modList -> catch (do collectWorkspace package modList rebuild False path hPutStrLn h (show ServerOK) hFlush h) (\ (e :: SomeException) -> do hPutStrLn h (show (ServerFailed (show e))) hFlush h) ParseHeaderCommand filePath -> catch (do res <- parseTheHeader filePath hPutStrLn h (show res) hFlush h) (\ (e :: SomeException) -> do hPutStrLn h (show (ServerFailed (show e))) hFlush h) doCommands' prefs connRef threadId (h,n,p) collectSystem :: Prefs -> Bool -> Bool -> Bool -> IO() collectSystem prefs writeAscii forceRebuild findSources = do collectorPath <- getCollectorPath when forceRebuild $ do exists <- doesDirectoryExist collectorPath when exists $ removeDirectoryRecursive collectorPath reportPath <- getConfigFilePathForSave "collectSystem.report" exists' <- doesFileExist reportPath when exists' (removeFile reportPath) return () knownPackages <- findKnownPackages collectorPath debugM "leksah-server" $ "collectSystem knownPackages= " ++ show knownPackages packageInfos <- inGhcIO [] [] $ \ _ -> getInstalledPackageInfos debugM "leksah-server" $ "collectSystem packageInfos= " ++ show (map getThisPackage packageInfos) let newPackages = filter (\pid -> not $Set.member (packageIdentifierToString $ getThisPackage pid) knownPackages) packageInfos if null newPackages then do infoM "leksah-server" "Metadata collector has nothing to do" else do when findSources $ liftIO $ buildSourceForPackageDB prefs infoM "leksah-server" "update_toolbar 0.0" stats <- mapM (collectPackage writeAscii prefs (length newPackages)) (zip newPackages [1 .. length newPackages]) writeStats stats infoM "leksah-server" "Metadata collection has finished" writeStats :: [PackageCollectStats] -> IO () writeStats stats = do reportPath <- getConfigFilePathForSave "collectSystem.report" time <- getCurrentTime appendFile reportPath (report time) where report time = "\n++++++++++++++++++++++++++++++\n" ++ show time ++ "\n++++++++++++++++++++++++++++++\n" ++ header' time ++ summary ++ details header' _time = "\nLeksah system metadata collection " summary = "\nSuccess with = " ++ packs ++ "\nPackages total = " ++ show packagesTotal ++ "\nPackages with source = " ++ show packagesWithSource ++ "\nPackages retreived = " ++ show packagesRetreived ++ "\nModules total = " ++ show modulesTotal' ++ "\nModules with source = " ++ show modulesWithSource ++ "\nPercentage source = " ++ show percentageWithSource packagesTotal = length stats packagesWithSource = length (filter withSource stats) packagesRetreived = length (filter retrieved stats) modulesTotal' = sum (mapMaybe modulesTotal stats) modulesWithSource = sum (mapMaybe modulesTotal (filter withSource stats)) percentageWithSource = (fromIntegral modulesWithSource) * 100.0 / (fromIntegral modulesTotal') details = foldr detail "" (filter (isJust . mbError) stats) detail stat string = string ++ "\n" ++ packageString stat ++ " " ++ trim (fromJust (mbError stat)) packs = foldr (\stat string -> string ++ packageString stat ++ " ") "" (take 10 (filter withSource stats)) ++ if packagesWithSource > 10 then "..." else "" leksah-server-0.12.1.2/src/IDE/Core/0000755000000000000000000000000011770163230014754 5ustar0000000000000000leksah-server-0.12.1.2/src/IDE/Core/CTypes.hs0000644000000000000000000004762311770163230016533 0ustar0000000000000000{-# OPTIONS_GHC -XFlexibleInstances -XDeriveDataTypeable -XExistentialQuantification -XMultiParamTypeClasses -XFlexibleContexts -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.CTypes -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : maintainer@leksah.org -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Core.CTypes ( PackageDescr(..) , ModuleDescr(..) , Descr(..) , RealDescr(..) , ReexportedDescr(..) , Present(..) , TypeDescr(..) , DescrType(..) , SimpleDescr(..) , GenScope(..) , dscName , dscMbTypeStr , dscMbModu , dsMbModu , dscMbLocation , dscMbComment , dscTypeHint , dscExported , descrType , isReexported , PackScope(..) , SymbolTable(..) , PackModule(..) , parsePackModule , showPackModule , packageIdentifierToString , packageIdentifierFromString , Location(..) , SrcSpan(..) , Scope(..) , ServerCommand(..) , ServerAnswer(..) , leksahVersion , configDirName , metadataVersion , ImportDecl(..) , ImportSpecList(..) , ImportSpec(..) , getThisPackage , RetrieveStrategy(..) ) where import Data.Typeable (Typeable(..)) import Data.Map (Map) import Data.Set (Set) import Default (Default(..)) import MyMissing (nonEmptyLines) import Distribution.Package (PackageName(..), PackageIdentifier(..)) import Distribution.ModuleName (components, ModuleName) import Data.ByteString.Char8 (ByteString) import Distribution.Text (simpleParse, display) import qualified Data.ByteString.Char8 as BS (unpack, empty) import qualified Data.Map as Map (lookup,keysSet,splitLookup, insertWith,empty,elems,union,toList) import qualified Data.Set as Set (toList) import Text.PrettyPrint as PP import Text.PrinterParser import Data.Char (isAlpha) import Control.DeepSeq (NFData(..)) import qualified Data.ByteString.Char8 as BS (ByteString) import Data.Version (Version(..)) import PackageConfig (PackageConfig) import qualified Distribution.InstalledPackageInfo as IPI -- --------------------------------------------------------------------- -- | Information about the system, extraced from .hi and source files -- leksahVersion, configDirName :: String leksahVersion = "0.12" configDirName = ".leksah-" ++ leksahVersion metadataVersion :: Integer metadataVersion = 7 getThisPackage :: PackageConfig -> PackageIdentifier #if MIN_VERSION_Cabal(1,8,0) getThisPackage = IPI.sourcePackageId #else getThisPackage = IPI.package #endif data RetrieveStrategy = RetrieveThenBuild | BuildThenRetrieve | NeverRetrieve deriving (Show, Read, Eq, Ord, Enum, Bounded) data ServerCommand = SystemCommand { scRebuild :: Bool, scSources :: Bool, scExtract :: Bool} | WorkspaceCommand { wcRebuild :: Bool, wcPackage :: PackageIdentifier, wcPath :: FilePath, wcModList :: [(String,FilePath)]} | ParseHeaderCommand { hcFilePath :: FilePath} deriving (Eq,Ord,Show,Read) data ServerAnswer = ServerOK | ServerFailed String | ServerHeader (Either [ImportDecl] Int) deriving (Eq,Ord,Show,Read) data PackScope alpha = SymbolTable alpha => PackScope (Map PackageIdentifier PackageDescr) alpha data GenScope = forall alpha. SymbolTable alpha => GenScopeC (PackScope alpha) class SymbolTable alpha where symLookup :: String -> alpha -> [Descr] symbols :: alpha -> Set String symSplitLookup :: String -> alpha -> (alpha , Maybe [Descr], alpha) symInsert :: String -> [Descr] -> alpha -> alpha symEmpty :: alpha symElems :: alpha -> [[Descr]] symUnion :: alpha -> alpha -> alpha instance SymbolTable (Map String [Descr]) where symLookup str smap = case str `Map.lookup` smap of Just dl -> dl Nothing -> [] symbols = Map.keysSet symSplitLookup = Map.splitLookup symInsert = Map.insertWith (++) symEmpty = Map.empty symElems = Map.elems symUnion = Map.union data PackageDescr = PackageDescr { pdPackage :: PackageIdentifier , pdMbSourcePath :: (Maybe FilePath) , pdModules :: [ModuleDescr] , pdBuildDepends :: [PackageIdentifier] } deriving (Show,Typeable) instance Default PackageDescr where getDefault = PackageDescr getDefault getDefault getDefault getDefault newtype Present alpha = Present alpha instance Show (Present PackageDescr) where show (Present pd) = (packageIdentifierToString . pdPackage) pd instance Eq PackageDescr where (== ) a b = pdPackage a == pdPackage b instance Ord PackageDescr where (<=) a b = pdPackage a <= pdPackage b data ModuleDescr = ModuleDescr { mdModuleId :: PackModule , mdMbSourcePath :: (Maybe FilePath) -- unqualified , mdReferences :: (Map ModuleName (Set String)) -- imports , mdIdDescriptions :: [Descr] } deriving (Show,Typeable) instance Default ModuleDescr where getDefault = ModuleDescr getDefault getDefault Map.empty getDefault instance Show (Present ModuleDescr) where show (Present md) = (show . mdModuleId) md instance Eq ModuleDescr where (== ) a b = mdModuleId a == mdModuleId b instance Ord ModuleDescr where (<=) a b = mdModuleId a <= mdModuleId b data Descr = Real RealDescr | Reexported ReexportedDescr deriving (Show,Read,Typeable,Eq,Ord) data RealDescr = RealDescr { dscName' :: String , dscMbTypeStr' :: Maybe ByteString , dscMbModu' :: Maybe PackModule , dscMbLocation' :: Maybe Location , dscMbComment' :: Maybe ByteString , dscTypeHint' :: TypeDescr , dscExported' :: Bool } deriving (Show,Read,Typeable) data ReexportedDescr = ReexportedDescr { dsrMbModu :: Maybe PackModule , dsrDescr :: Descr} deriving (Show,Read,Typeable) -- Metadata accessors isReexported :: Descr -> Bool isReexported (Reexported _) = True isReexported _ = False dscName :: Descr -> String dscName (Reexported d) = dscName (dsrDescr d) dscName (Real d) = dscName' d dscMbTypeStr :: Descr -> Maybe ByteString dscMbTypeStr (Reexported d) = dscMbTypeStr (dsrDescr d) dscMbTypeStr (Real d) = dscMbTypeStr' d -- | The definition module dscMbModu :: Descr -> Maybe PackModule dscMbModu (Reexported d) = dscMbModu (dsrDescr d) dscMbModu (Real d) = dscMbModu' d -- | The exporting module dsMbModu :: Descr -> Maybe PackModule dsMbModu (Reexported d) = dsrMbModu d dsMbModu (Real d) = dscMbModu' d dscMbLocation :: Descr -> Maybe Location dscMbLocation (Reexported d) = dscMbLocation (dsrDescr d) dscMbLocation (Real d) = dscMbLocation' d dscMbComment :: Descr -> Maybe ByteString dscMbComment (Reexported d) = dscMbComment (dsrDescr d) dscMbComment (Real d) = dscMbComment' d dscTypeHint :: Descr -> TypeDescr dscTypeHint (Reexported d) = dscTypeHint (dsrDescr d) dscTypeHint (Real d) = dscTypeHint' d dscExported :: Descr -> Bool dscExported (Reexported _) = True dscExported (Real d) = dscExported' d data TypeDescr = VariableDescr | FieldDescr Descr | ConstructorDescr Descr | DataDescr [SimpleDescr] [SimpleDescr] -- ^ first constructors, then fields | TypeDescr | NewtypeDescr SimpleDescr (Maybe SimpleDescr) -- ^ first constructors, then maybe field | ClassDescr [String] [SimpleDescr] -- ^ first super, then methods | MethodDescr Descr -- ^ classDescr | InstanceDescr [String] -- ^ binds | KeywordDescr | ExtensionDescr | ModNameDescr | QualModNameDescr | ErrorDescr --the descrName is the type Konstructor? deriving (Show,Read,Eq,Ord,Typeable) data DescrType = Variable | Field | Constructor | Data | Type | Newtype | Class | Method | Instance | Keyword | Extension | ModName | QualModName | Error deriving (Show, Eq, Ord, Bounded, Enum, Read) instance Default DescrType where getDefault = Variable data SimpleDescr = SimpleDescr { sdName :: String, sdType :: Maybe ByteString, sdLocation :: Maybe Location, sdComment :: Maybe ByteString, sdExported :: Bool} deriving (Show,Read,Eq,Ord,Typeable) descrType :: TypeDescr -> 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 descrType KeywordDescr = Keyword descrType ExtensionDescr = Extension descrType ModNameDescr = ModName descrType QualModNameDescr = QualModName descrType ErrorDescr = Error data PackModule = PM { pack :: PackageIdentifier , modu :: ModuleName} deriving (Eq, Ord,Read,Show,Typeable) instance Show (Present PackModule) where showsPrec _ (Present pd) = showString ((packageIdentifierToString . pack) pd) . showChar ':' . showString (display (modu pd)) parsePackModule :: String -> PackModule parsePackModule str = let (pack',mod') = span (\c -> c /= ':') str in case packageIdentifierFromString $ 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 = error $ "cannot parse PackModule from " ++ s showPackModule :: PackModule -> String showPackModule = show. Present packageIdentifierToString :: PackageIdentifier -> String packageIdentifierToString = display packageIdentifierFromString :: String -> Maybe PackageIdentifier packageIdentifierFromString = simpleParse instance Show (Present Descr) where showsPrec _ (Present descr) = case dscMbComment descr of Just comment -> p . showChar '\n' . c comment . t Nothing -> p . showChar '\n' . showChar '\n' . t where p = case dsMbModu descr of Just ds -> showString "-- " . shows (Present ds) Nothing -> id c com = showString $ unlines $ map (\(i,l) -> if i == 0 then "-- | " ++ l else "-- " ++ l) $ zip [0 .. length nelines - 1] nelines where nelines = nonEmptyLines (BS.unpack com) t = case dscMbTypeStr descr of Just ti -> showString $ BS.unpack ti Nothing -> id instance Eq RealDescr where (== ) a b = dscName' a == dscName' b && dscTypeHint' a == dscTypeHint' b instance Ord RealDescr where (<=) a b = if dscName' a == dscName' b then dscTypeHint' a <= dscTypeHint' b else dscName' a < dscName' b instance Eq ReexportedDescr where (== ) a b = dscName (Reexported a) == dscName (Reexported b) && dscTypeHint (Reexported a) == dscTypeHint (Reexported b) instance Ord ReexportedDescr where (<=) a b = if dscName (Reexported a) == dscName (Reexported b) then dscTypeHint (Reexported a) <= dscTypeHint (Reexported b) else dscName (Reexported a) < dscName (Reexported b) instance Default PackModule where getDefault = parsePackModule "unknow-0:Undefined" instance Default PackageIdentifier where getDefault = case packageIdentifierFromString "unknown-0" of Nothing -> error "CTypes.getDefault: Can't parse Package Identifier" Just it -> it -- | A portion of the source, spanning one or more lines and zero or more columns. data SrcSpan = SrcSpan { srcSpanFilename :: String , srcSpanStartLine :: Int , srcSpanStartColumn :: Int , srcSpanEndLine :: Int , srcSpanEndColumn :: Int } deriving (Eq,Ord,Show) data Location = Location { locationSLine :: Int , locationSCol :: Int , locationELine :: Int , locationECol :: Int } deriving (Show,Eq,Ord,Read,Typeable) instance Default ByteString where getDefault = BS.empty data Scope = PackageScope Bool | WorkspaceScope Bool | SystemScope -- True -> with imports, False -> without imports deriving (Show, Eq, Read) instance Ord Scope where _ <= SystemScope = True WorkspaceScope False <= WorkspaceScope True = True WorkspaceScope False <= PackageScope True = True PackageScope True <= WorkspaceScope True = True PackageScope False <= PackageScope True = True _ <= _ = False -- | An import declaration. data ImportDecl = ImportDecl { importLoc :: Location , importModule :: String -- ^ name of the module imported. , importQualified :: Bool -- ^ imported @qualified@? , importSrc :: Bool -- ^ imported with @{-\# SOURCE \#-}@? , importPkg :: Maybe String -- ^ imported with explicit package name , importAs :: Maybe String -- ^ optional alias name in an @as@ clause. , importSpecs :: Maybe ImportSpecList -- ^ optional list of import specifications. } deriving (Eq,Ord,Read,Show) instance Pretty ImportDecl where pretty (ImportDecl _ mod' qual _ _ mbName mbSpecs) = mySep [text "import", if qual then text "qualified" else empty, pretty mod', maybePP (\m' -> text "as" <+> pretty m') mbName, maybePP exports mbSpecs] where exports (ImportSpecList b specList) = if b then text "hiding" <+> specs else specs where specs = parenList . map pretty $ specList parenList :: [Doc] -> Doc parenList = PP.parens . fsep . PP.punctuate PP.comma mySep :: [Doc] -> Doc mySep [x] = x mySep (x:xs) = x <+> fsep xs mySep [] = error "Internal error: mySep" -- | An explicit import specification list. data ImportSpecList = ImportSpecList Bool [ImportSpec] -- A list of import specifications. -- The 'Bool' is 'True' if the names are excluded -- by @hiding@. deriving (Eq,Ord,Read,Show) -- | An import specification, representing a single explicit item imported -- (or hidden) from a module. data ImportSpec = IVar String -- ^ variable | IAbs String -- ^ @T@: -- the name of a class, datatype or type synonym. | IThingAll String -- ^ @T(..)@: -- a class imported with all of its methods, or -- a datatype imported with all of its constructors. | IThingWith String [String] -- ^ @T(C_1,...,C_n)@: -- a class imported with some of its methods, or -- a datatype imported with some of its constructors. deriving (Eq,Ord,Read,Show) newtype VName = VName String instance Pretty ImportSpec where pretty (IVar name) = pretty (VName name) pretty (IAbs name) = pretty name pretty (IThingAll name) = pretty name <> text "(..)" pretty (IThingWith name nameList) = pretty name <> (parenList (map (pretty.VName) nameList)) instance Pretty VName where pretty (VName str) = if isOperator str then PP.parens (PP.text str) else (PP.text str) isOperator :: String -> Bool isOperator ('(':_) = False -- (), (,) etc isOperator ('[':_) = False -- [] isOperator ('$':c:_) = not (isAlpha c) -- Don't treat $d as an operator isOperator (':':c:_) = not (isAlpha c) -- Don't treat :T as an operator isOperator ('_':_) = False -- Not an operator isOperator (c:_) = not (isAlpha c) -- Starts with non-alpha isOperator _ = False -- --------------------------------------------------------------------- -- NFData instances for forcing evaluation -- #if MIN_VERSION_deepseq(1,2,0) && !MIN_VERSION_containers(0,4,2) instance (NFData k, NFData a) => NFData (Map k a) where rnf = rnf . Map.toList instance NFData a => NFData (Set a) where rnf = rnf . Set.toList #endif instance NFData Location where rnf pd = rnf (locationSLine pd) `seq` rnf (locationSCol pd) `seq` rnf (locationELine pd) `seq` rnf (locationECol pd) instance NFData PackageDescr where rnf pd = rnf (pdPackage pd) `seq` rnf (pdMbSourcePath pd) `seq` rnf (pdModules pd) `seq` rnf (pdBuildDepends pd) instance NFData ModuleDescr where rnf pd = rnf (mdModuleId pd) `seq` rnf (mdMbSourcePath pd) `seq` rnf (mdReferences pd) `seq` rnf (mdIdDescriptions pd) instance NFData Descr where rnf (Real (RealDescr dscName'' dscMbTypeStr'' dscMbModu'' dscMbLocation'' dscMbComment'' dscTypeHint'' dscExported'')) = rnf dscName'' `seq` rnf dscMbTypeStr'' `seq` rnf dscMbModu'' `seq` rnf dscMbLocation'' `seq` rnf dscMbComment'' `seq` rnf dscTypeHint'' `seq` rnf dscExported'' rnf (Reexported (ReexportedDescr reexpModu' impDescr')) = rnf reexpModu' `seq` rnf impDescr' instance NFData TypeDescr where rnf (FieldDescr typeDescrF') = rnf typeDescrF' rnf (ConstructorDescr typeDescrC') = rnf typeDescrC' rnf (DataDescr constructors' fields') = constructors' `seq` rnf fields' rnf (NewtypeDescr constructor' mbField') = rnf constructor' `seq` rnf mbField' rnf (ClassDescr super' methods') = rnf super' `seq` rnf methods' rnf (MethodDescr classDescrM') = rnf classDescrM' rnf (InstanceDescr binds') = rnf binds' rnf a = seq a () instance NFData SimpleDescr where rnf pd = rnf (sdName pd) `seq` rnf (sdType pd) `seq` rnf (sdLocation pd) `seq` rnf (sdComment pd) `seq` rnf (sdExported pd) instance NFData PackageIdentifier where rnf pd = rnf (pkgName pd) `seq` rnf (pkgVersion pd) instance NFData DescrType where rnf a = seq a () instance NFData BS.ByteString where rnf b = seq b () #if !MIN_VERSION_deepseq(1,3,0) instance NFData Version where rnf v = seq v () #endif instance NFData PackModule where rnf pd = rnf (pack pd) `seq` rnf (modu pd) instance NFData ModuleName where rnf = rnf . components instance NFData PackageName where rnf (PackageName s) = rnf s leksah-server-0.12.1.2/src/IDE/Core/Serializable.hs0000644000000000000000000002137511770163230017726 0ustar0000000000000000{-# OPTIONS_GHC -XScopedTypeVariables -XStandaloneDeriving -XDeriveDataTypeable -fno-warn-orphans #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Core.Serializable -- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie -- License : GPL -- -- Maintainer : Jutaro -- Stability : provisional -- Portability : -- -- | -- ----------------------------------------------------------------------------- module IDE.Core.Serializable ( ) where import Distribution.Text (simpleParse,display) import Control.Monad (liftM) import Data.Maybe (fromJust) import Data.Binary.Shared (BinaryShared(..)) import Data.Typeable (Typeable(..)) import Distribution.Package (PackageName(..),PackageIdentifier(..)) import Data.Version (Version(..)) import Distribution.ModuleName (ModuleName) import MyMissing (forceJust) import IDE.Core.CTypes deriving instance Typeable PackageIdentifier deriving instance Typeable ModuleName deriving instance Typeable PackageName ----------------------------------------------------------- instance BinaryShared PackModule where put = putShared (\ (PM pack' modu') -> do (put pack') (put modu')) get = getShared (do pack' <- get modu' <- get return (PM pack' modu')) instance BinaryShared PackageIdentifier where put = putShared (\ (PackageIdentifier name' version') -> do put name' put version') get = getShared (do name' <- get version' <- get return (PackageIdentifier name' version')) instance BinaryShared Version where put = putShared (\ (Version branch' tags') -> do put branch' put tags') get = getShared (do branch' <- get tags' <- get return (Version branch' tags')) instance BinaryShared PackageDescr where put = putShared (\ (PackageDescr packagePD' exposedModulesPD' buildDependsPD' mbSourcePathPD') -> do put packagePD' put exposedModulesPD' put buildDependsPD' put mbSourcePathPD') get = getShared (do packagePD' <- get exposedModulesPD' <- get buildDependsPD' <- get mbSourcePathPD' <- get return (PackageDescr packagePD' exposedModulesPD' buildDependsPD' mbSourcePathPD')) instance BinaryShared ModuleDescr where put = putShared (\ (ModuleDescr moduleIdMD' mbSourcePathMD' usagesMD' idDescriptionsMD') -> do put moduleIdMD' put mbSourcePathMD' put usagesMD' put idDescriptionsMD') get = getShared (do moduleIdMD' <- get mbSourcePathMD' <- get usagesMD' <- get idDescriptionsMD' <- get return (ModuleDescr moduleIdMD' mbSourcePathMD' usagesMD' idDescriptionsMD')) instance BinaryShared Descr where put (Real (RealDescr descrName2 typeInfo2 descrModu2 mbLocation2 mbComment2 details2 isExp)) = do put (1:: Int) put descrName2 put typeInfo2 put descrModu2 put mbLocation2 put mbComment2 put details2 put isExp put (Reexported (ReexportedDescr reexpModu' impDescr')) = do put (2:: Int) put reexpModu' put impDescr' get = do (typeHint :: Int) <- get case typeHint of 1 -> do descrName2 <- get typeInfo2 <- get descrModu2 <- get mbLocation2 <- get mbComment2 <- get details2 <- get isExp2 <- get return (Real (RealDescr descrName2 typeInfo2 descrModu2 mbLocation2 mbComment2 details2 isExp2)) 2 -> do reexpModu' <- get impDescr' <- get return (Reexported (ReexportedDescr reexpModu' impDescr')) _ -> error "Impossible in Binary Descr get" instance BinaryShared TypeDescr 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' put KeywordDescr = do put (10:: Int) put ExtensionDescr = do put (11:: Int) put ModNameDescr = do put (12:: Int) put QualModNameDescr = do put (13:: Int) put ErrorDescr = do put (14:: Int) 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') 10 -> return KeywordDescr 11 -> return ExtensionDescr 12 -> return ModNameDescr 13 -> return QualModNameDescr 14 -> return ErrorDescr _ -> error "Impossible in Binary SpDescr get" instance BinaryShared SimpleDescr where put (SimpleDescr sdName' sdType' sdLocation' sdComment' sdExported') = do put sdName' put sdType' put sdLocation' put sdComment' put sdExported' get = do sdName' <- get sdType' <- get sdLocation' <- get sdComment' <- get sdExported' <- get return (SimpleDescr sdName' sdType' sdLocation' sdComment' sdExported') instance BinaryShared Location where put (Location locationSLine' locationSCol' locationELine' locationECol') = do put locationSLine' put locationSCol' put locationELine' put locationECol' get = do locationSLine' <- get locationSCol' <- get locationELine' <- get locationECol' <- get return (Location locationSLine' locationSCol' locationELine' locationECol') instance BinaryShared ModuleName where put = put . display get = liftM (flip forceJust "BinaryShared>>get(ModuleName)" . simpleParse) get instance BinaryShared PackageName where put (PackageName pn) = put pn get = liftM PackageName get