leksah-server (empty) → 0.8
raw patch · 19 files changed
+4674/−0 lines, 19 filesdep +Cabaldep +Win32dep +basesetup-changed
Dependencies added: Cabal, Win32, base, binary, binary-shared, bytestring, containers, deepseq, directory, filepath, ghc, haddock-leksah, hslogger, ltk, mtl, network, parsec, pretty, process, time, unix
Files
- LICENSE +339/−0
- Setup.lhs +6/−0
- data/prefscoll.lkshp +4/−0
- leksah-server.cabal +99/−0
- src/IDE/Core/CTypes.hs +525/−0
- src/IDE/Core/Serializable.hs +243/−0
- src/IDE/HeaderParser.hs +87/−0
- src/IDE/Metainfo/Collector.hs +471/−0
- src/IDE/Metainfo/InterfaceCollector.hs +298/−0
- src/IDE/Metainfo/SourceCollectorH.hs +421/−0
- src/IDE/Metainfo/SourceDB.hs +229/−0
- src/IDE/Metainfo/WorkspaceCollector.hs +620/−0
- src/IDE/StrippedPrefs.hs +107/−0
- src/IDE/Utils/FileUtils.hs +441/−0
- src/IDE/Utils/GHCUtils.hs +210/−0
- src/IDE/Utils/Server.hs +107/−0
- src/IDE/Utils/Tool.hs +393/−0
- src/IDE/Utils/Utils.hs +42/−0
- src/LeksahEcho.hs +32/−0
+ LICENSE view
@@ -0,0 +1,339 @@+ GNU GENERAL PUBLIC LICENSE+ Version 2, June 1991++ Copyright (C) 1989, 1991 Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++ Preamble++ The licenses for most software are designed to take away your+freedom to share and change it. By contrast, the GNU General Public+License is intended to guarantee your freedom to share and change free+software--to make sure the software is free for all its users. This+General Public License applies to most of the Free Software+Foundation's software and to any other program whose authors commit to+using it. (Some other Free Software Foundation software is covered by+the GNU Lesser General Public License instead.) You can apply it to+your programs, too.++ When we speak of free software, we are referring to freedom, not+price. Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+this service if you wish), that you receive source code or can get it+if you want it, that you can change the software or use pieces of it+in new free programs; and that you know you can do these things.++ To protect your rights, we need to make restrictions that forbid+anyone to deny you these rights or to ask you to surrender the rights.+These restrictions translate to certain responsibilities for you if you+distribute copies of the software, or if you modify it.++ For example, if you distribute copies of such a program, whether+gratis or for a fee, you must give the recipients all the rights that+you have. You must make sure that they, too, receive or can get the+source code. And you must show them these terms so they know their+rights.++ We protect your rights with two steps: (1) copyright the software, and+(2) offer you this license which gives you legal permission to copy,+distribute and/or modify the software.++ Also, for each author's protection and ours, we want to make certain+that everyone understands that there is no warranty for this free+software. If the software is modified by someone else and passed on, we+want its recipients to know that what they have is not the original, so+that any problems introduced by others will not reflect on the original+authors' reputations.++ Finally, any free program is threatened constantly by software+patents. We wish to avoid the danger that redistributors of a free+program will individually obtain patent licenses, in effect making the+program proprietary. To prevent this, we have made it clear that any+patent must be licensed for everyone's free use or not licensed at all.++ The precise terms and conditions for copying, distribution and+modification follow.++ GNU GENERAL PUBLIC LICENSE+ TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION++ 0. This License applies to any program or other work which contains+a notice placed by the copyright holder saying it may be distributed+under the terms of this General Public License. The "Program", below,+refers to any such program or work, and a "work based on the Program"+means either the Program or any derivative work under copyright law:+that is to say, a work containing the Program or a portion of it,+either verbatim or with modifications and/or translated into another+language. (Hereinafter, translation is included without limitation in+the term "modification".) Each licensee is addressed as "you".++Activities other than copying, distribution and modification are not+covered by this License; they are outside its scope. The act of+running the Program is not restricted, and the output from the Program+is covered only if its contents constitute a work based on the+Program (independent of having been made by running the Program).+Whether that is true depends on what the Program does.++ 1. You may copy and distribute verbatim copies of the Program's+source code as you receive it, in any medium, provided that you+conspicuously and appropriately publish on each copy an appropriate+copyright notice and disclaimer of warranty; keep intact all the+notices that refer to this License and to the absence of any warranty;+and give any other recipients of the Program a copy of this License+along with the Program.++You may charge a fee for the physical act of transferring a copy, and+you may at your option offer warranty protection in exchange for a fee.++ 2. You may modify your copy or copies of the Program or any portion+of it, thus forming a work based on the Program, and copy and+distribute such modifications or work under the terms of Section 1+above, provided that you also meet all of these conditions:++ a) You must cause the modified files to carry prominent notices+ stating that you changed the files and the date of any change.++ b) You must cause any work that you distribute or publish, that in+ whole or in part contains or is derived from the Program or any+ part thereof, to be licensed as a whole at no charge to all third+ parties under the terms of this License.++ c) If the modified program normally reads commands interactively+ when run, you must cause it, when started running for such+ interactive use in the most ordinary way, to print or display an+ announcement including an appropriate copyright notice and a+ notice that there is no warranty (or else, saying that you provide+ a warranty) and that users may redistribute the program under+ these conditions, and telling the user how to view a copy of this+ License. (Exception: if the Program itself is interactive but+ does not normally print such an announcement, your work based on+ the Program is not required to print an announcement.)++These requirements apply to the modified work as a whole. If+identifiable sections of that work are not derived from the Program,+and can be reasonably considered independent and separate works in+themselves, then this License, and its terms, do not apply to those+sections when you distribute them as separate works. But when you+distribute the same sections as part of a whole which is a work based+on the Program, the distribution of the whole must be on the terms of+this License, whose permissions for other licensees extend to the+entire whole, and thus to each and every part regardless of who wrote it.++Thus, it is not the intent of this section to claim rights or contest+your rights to work written entirely by you; rather, the intent is to+exercise the right to control the distribution of derivative or+collective works based on the Program.++In addition, mere aggregation of another work not based on the Program+with the Program (or with a work based on the Program) on a volume of+a storage or distribution medium does not bring the other work under+the scope of this License.++ 3. You may copy and distribute the Program (or a work based on it,+under Section 2) in object code or executable form under the terms of+Sections 1 and 2 above provided that you also do one of the following:++ a) Accompany it with the complete corresponding machine-readable+ source code, which must be distributed under the terms of Sections+ 1 and 2 above on a medium customarily used for software interchange; or,++ b) Accompany it with a written offer, valid for at least three+ years, to give any third party, for a charge no more than your+ cost of physically performing source distribution, a complete+ machine-readable copy of the corresponding source code, to be+ distributed under the terms of Sections 1 and 2 above on a medium+ customarily used for software interchange; or,++ c) Accompany it with the information you received as to the offer+ to distribute corresponding source code. (This alternative is+ allowed only for noncommercial distribution and only if you+ received the program in object code or executable form with such+ an offer, in accord with Subsection b above.)++The source code for a work means the preferred form of the work for+making modifications to it. For an executable work, complete source+code means all the source code for all modules it contains, plus any+associated interface definition files, plus the scripts used to+control compilation and installation of the executable. However, as a+special exception, the source code distributed need not include+anything that is normally distributed (in either source or binary+form) with the major components (compiler, kernel, and so on) of the+operating system on which the executable runs, unless that component+itself accompanies the executable.++If distribution of executable or object code is made by offering+access to copy from a designated place, then offering equivalent+access to copy the source code from the same place counts as+distribution of the source code, even though third parties are not+compelled to copy the source along with the object code.++ 4. You may not copy, modify, sublicense, or distribute the Program+except as expressly provided under this License. Any attempt+otherwise to copy, modify, sublicense or distribute the Program is+void, and will automatically terminate your rights under this License.+However, parties who have received copies, or rights, from you under+this License will not have their licenses terminated so long as such+parties remain in full compliance.++ 5. You are not required to accept this License, since you have not+signed it. However, nothing else grants you permission to modify or+distribute the Program or its derivative works. These actions are+prohibited by law if you do not accept this License. Therefore, by+modifying or distributing the Program (or any work based on the+Program), you indicate your acceptance of this License to do so, and+all its terms and conditions for copying, distributing or modifying+the Program or works based on it.++ 6. Each time you redistribute the Program (or any work based on the+Program), the recipient automatically receives a license from the+original licensor to copy, distribute or modify the Program subject to+these terms and conditions. You may not impose any further+restrictions on the recipients' exercise of the rights granted herein.+You are not responsible for enforcing compliance by third parties to+this License.++ 7. If, as a consequence of a court judgment or allegation of patent+infringement or for any other reason (not limited to patent issues),+conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License. If you cannot+distribute so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you+may not distribute the Program at all. For example, if a patent+license would not permit royalty-free redistribution of the Program by+all those who receive copies directly or indirectly through you, then+the only way you could satisfy both it and this License would be to+refrain entirely from distribution of the Program.++If any portion of this section is held invalid or unenforceable under+any particular circumstance, the balance of the section is intended to+apply and the section as a whole is intended to apply in other+circumstances.++It is not the purpose of this section to induce you to infringe any+patents or other property right claims or to contest validity of any+such claims; this section has the sole purpose of protecting the+integrity of the free software distribution system, which is+implemented by public license practices. Many people have made+generous contributions to the wide range of software distributed+through that system in reliance on consistent application of that+system; it is up to the author/donor to decide if he or she is willing+to distribute software through any other system and a licensee cannot+impose that choice.++This section is intended to make thoroughly clear what is believed to+be a consequence of the rest of this License.++ 8. If the distribution and/or use of the Program is restricted in+certain countries either by patents or by copyrighted interfaces, the+original copyright holder who places the Program under this License+may add an explicit geographical distribution limitation excluding+those countries, so that distribution is permitted only in or among+countries not thus excluded. In such case, this License incorporates+the limitation as if written in the body of this License.++ 9. The Free Software Foundation may publish revised and/or new versions+of the General Public License from time to time. Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++Each version is given a distinguishing version number. If the Program+specifies a version number of this License which applies to it and "any+later version", you have the option of following the terms and conditions+either of that version or of any later version published by the Free+Software Foundation. If the Program does not specify a version number of+this License, you may choose any version ever published by the Free Software+Foundation.++ 10. If you wish to incorporate parts of the Program into other free+programs whose distribution conditions are different, write to the author+to ask for permission. For software which is copyrighted by the Free+Software Foundation, write to the Free Software Foundation; we sometimes+make exceptions for this. Our decision will be guided by the two goals+of preserving the free status of all derivatives of our free software and+of promoting the sharing and reuse of software generally.++ NO WARRANTY++ 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY+FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN+OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES+PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED+OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS+TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE+PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,+REPAIR OR CORRECTION.++ 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR+REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,+INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING+OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED+TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY+YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER+PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE+POSSIBILITY OF SUCH DAMAGES.++ END OF TERMS AND CONDITIONS++ How to Apply These Terms to Your New Programs++ If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++ To do so, attach the following notices to the program. It is safest+to attach them to the start of each source file to most effectively+convey the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++ <one line to give the program's name and a brief idea of what it does.>+ Copyright (C) <year> <name of author>++ This program is free software; you can redistribute it and/or modify+ it under the terms of the GNU General Public License as published by+ the Free Software Foundation; either version 2 of the License, or+ (at your option) any later version.++ This program is distributed in the hope that it will be useful,+ but WITHOUT ANY WARRANTY; without even the implied warranty of+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+ GNU General Public License for more details.++ You should have received a copy of the GNU General Public License along+ with this program; if not, write to the Free Software Foundation, Inc.,+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.++Also add information on how to contact you by electronic and paper mail.++If the program is interactive, make it output a short notice like this+when it starts in an interactive mode:++ Gnomovision version 69, Copyright (C) year name of author+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+ This is free software, and you are welcome to redistribute it+ under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License. Of course, the commands you use may+be called something other than `show w' and `show c'; they could even be+mouse-clicks or menu items--whatever suits your program.++You should also get your employer (if you work as a programmer) or your+school, if any, to sign a "copyright disclaimer" for the program, if+necessary. Here is a sample; alter the names:++ Yoyodyne, Inc., hereby disclaims all copyright interest in the program+ `Gnomovision' (which makes passes at compilers) written by James Hacker.++ <signature of Ty Coon>, 1 April 1989+ Ty Coon, President of Vice++This General Public License does not permit incorporating your program into+proprietary programs. If your program is a subroutine library, you may+consider it more useful to permit linking proprietary applications with the+library. If this is what you want to do, use the GNU Lesser General+Public License instead of this License.
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain +
+ data/prefscoll.lkshp view
@@ -0,0 +1,4 @@+Paths under which haskell sources for packages may be found:+ ["~/Develop"]+Maybe a directory for unpacking cabal packages:+ Just "~/Haskell"
+ leksah-server.cabal view
@@ -0,0 +1,99 @@+name: leksah-server+version: 0.8+cabal-version: >= 1.2+build-type: Simple+license: GPL+license-file: LICENSE+copyright: 2007-2009 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+data-files:+ data/prefscoll.lkshp+library+ build-depends: Cabal >=1.6.0.1, base >= 4.0.0.0 && <= 5, binary >=0.5.0.0,+ binary-shared >=0.8, bytestring >=0.9.0.1, containers >=0.2.0.0,+ directory >=1.0.0.2, filepath >=1.1.0.1, ghc >=6.10.1,+ ltk >=0.8 && <= 0.9, mtl >=1.1.0.2, parsec >=2.1.0.1,+ pretty >=1.0.1.0, process >=1.0.1.0, time >= 1.1, deepseq >= 1.1,+ hslogger >= 1.0.7, network >= 2.2 && <= 3.0+ if (impl(ghc >= 6.12))+ build-depends: haddock-leksah == 2.6.0+ else+ build-depends: haddock-leksah == 2.5.0+ if os(windows)+ build-depends: Win32 >=2.2.0.0+ extra-libraries: kernel32+ else+ build-depends: unix >=2.3.1.0++ 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+ exposed: True+ buildable: True+ 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 -O2+ else+ ghc-options: -Wall -ferror-spans -O2+ ghc-prof-options: -auto-all -prof++executable leksah-server+ build-depends: Cabal >=1.6.0.1, base >= 4.0.0.0 && <= 5, binary >=0.5.0.0,+ binary-shared >=0.8, bytestring >=0.9.0.1, containers >=0.2.0.0,+ directory >=1.0.0.2, filepath >=1.1.0.1, ghc >=6.10.1,+ ltk >=0.8 && <= 0.9, mtl >=1.1.0.2, parsec >=2.1.0.1,+ pretty >=1.0.1.0, process >=1.0.1.0, deepseq >= 1.1, network >= 2.2 && <= 3.0+ if (impl(ghc >= 6.12))+ build-depends: haddock-leksah == 2.6.0+ else+ build-depends: haddock-leksah == 2.5.0++ if os(windows)+ build-depends: Win32 >=2.2.0.0+ extra-libraries: kernel32+ else+ build-depends: unix >=2.3.1.0++ main-is: IDE/Metainfo/Collector.hs+ buildable: True+ 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+ if (impl(ghc >= 6.12))+ ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans -threaded -O2+ else+ ghc-options: -Wall -ferror-spans -threaded -O2+ ghc-prof-options: -auto-all -prof++executable leksahecho+ main-is: LeksahEcho.hs+ buildable: True+ extensions: CPP+ hs-source-dirs: src+ ghc-prof-options: -auto-all -prof+ ghc-shared-options: -auto-all -prof+ if (impl(ghc >= 6.12))+ ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans -threaded -O2+ else+ ghc-options: -Wall -ferror-spans -threaded -O2++
+ src/IDE/Core/CTypes.hs view
@@ -0,0 +1,525 @@+{-# OPTIONS_GHC -XFlexibleInstances -XDeriveDataTypeable -XExistentialQuantification+ -XMultiParamTypeClasses -XFlexibleContexts -fno-warn-orphans #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Core.CTypes+-- Copyright : 2007-2010 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(..)++) 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)+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(..))++-- ---------------------------------------------------------------------+-- | Information about the system, extraced from .hi and source files+--++leksahVersion, configDirName :: String+leksahVersion = "0.8"+configDirName = ".leksah-" ++ leksahVersion++metadataVersion :: Integer+metadataVersion = 7++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)++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 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"++-- | 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+--+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 ()++instance NFData Version where rnf v = seq v ()++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+++
+ src/IDE/Core/Serializable.hs view
@@ -0,0 +1,243 @@+{-# OPTIONS_GHC+ -XScopedTypeVariables+ -XStandaloneDeriving+ -XDeriveDataTypeable+ -fno-warn-orphans #-}++-----------------------------------------------------------------------------+--+-- Module : IDE.Core.Serializable+-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : Jutaro <jutaro@leksah.org>+-- 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 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 (fromJust . simpleParse) get++instance BinaryShared PackageName where+ put (PackageName pn) = put pn+ get = liftM PackageName get+++
+ src/IDE/HeaderParser.hs view
@@ -0,0 +1,87 @@+-----------------------------------------------------------------------------+--+-- Module : IDE.HeaderParser+-- Copyright : 2007-2010 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 Control.Monad.Trans (liftIO)+import Data.Maybe (mapMaybe)+import Outputable(pprHsVar,showSDoc)+import IDE.Utils.FileUtils (figureOutGhcOpts)++parseTheHeader :: FilePath -> IO ServerAnswer+parseTheHeader filePath = do+ text <- readFile filePath+ opts <- figureOutGhcOpts+ 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+transformEntity (L _ (IEVar name)) = Just (IVar (showSDoc (pprHsVar name)))+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++srcSpanToLocation :: SrcSpan -> Location+srcSpanToLocation span' | not (isGoodSrcSpan span')+ = error "srcSpanToLocation: unhelpful span"+srcSpanToLocation span'+ = Location (srcSpanStartLine span') (srcSpanStartCol span')+ (srcSpanEndLine span') (srcSpanEndCol span')
+ src/IDE/Metainfo/Collector.hs view
@@ -0,0 +1,471 @@+{-# OPTIONS_GHC -XScopedTypeVariables -fno-warn-type-defaults #-}+-----------------------------------------------------------------------------+--+-- Module : Main+-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Main (+ main+) 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 qualified Data.Map as Map+import Data.List(nub,delete)+import IDE.Utils.FileUtils+import IDE.Utils.Utils+import IDE.Metainfo.InterfaceCollector+import IDE.Utils.GHCUtils+import IDE.StrippedPrefs+import IDE.Metainfo.WorkspaceCollector+import Data.Maybe(catMaybes, fromJust, mapMaybe, isJust)+import Distribution.Text (display)+import Prelude hiding(catch)+import Control.Monad (liftM)+import System.Directory (removeDirectoryRecursive, doesFileExist, removeFile, doesDirectoryExist, setCurrentDirectory)+import qualified Data.Set as Set (member)+import IDE.Core.CTypes hiding (Extension)+import qualified Distribution.InstalledPackageInfo as IPI+import PackageConfig (PackageConfig)+import TcRnMonad (MonadIO(..))+import System.FilePath ((<.>), (</>))+import IDE.Metainfo.SourceCollectorH+ (PackageCollectStats(..), collectPackageFromSource)+import Data.Binary.Shared (encodeFileSer)+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 (SocketType(..), iNADDR_ANY, SockAddr(..),PortNumber(..))+import IDE.Utils.Server+import System.IO (Handle, hPutStrLn, hGetLine, hFlush, hClose)+import IDE.HeaderParser(parseTheHeader)+import System.Process (system)+import System.Exit (ExitCode(..))+import Distribution.Package (PackageIdentifier(..))++-- --------------------------------------------------------------------+-- Command line options+--++getThisPackage :: PackageConfig -> PackageIdentifier+#if MIN_VERSION_Cabal(1,8,0)+getThisPackage = IPI.sourcePackageId+#else+getThisPackage = IPI.package+#endif++data Flag = CollectSystem++ | ServerCommand (Maybe String)+ --modifiers+ | Rebuild+ | Sources+ -- | Directory FilePath+ --others+ | VersionF+ | Help+ | Debug+ | Verbosity String+ | LogFile String+ 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"+ ]++header :: String+header = "Usage: leksah-collector [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+ _fp <- getConfigFilePathForSave "collectorl.lkslo"+ 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++ 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+ 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))) prefs)+ waitFor running+ return ()+ (Just ps:_) -> do+ let port = read ps+ running <- serveOne Nothing (server (PortNum (fromIntegral port)) prefs)+ waitFor running+ return ()+ _ -> return ()++ server port prefs = Server (SockAddrInet port iNADDR_ANY) Stream (doCommands prefs)++doCommands :: Prefs -> (Handle, t1, t2) -> IO ()+doCommands prefs (h,n,p) = do+ debugM "leksah-server" $ "***wait"+ mbLine <- catch (liftM Just (hGetLine h))+ (\ (_e :: SomeException) -> do+ infoM "leksah-server" $ "***lost connection"+ hClose h+ 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 (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+ stats <- mapM (collectPackage writeAscii prefs) 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 ""+++collectPackage :: Bool -> Prefs -> PackageConfig -> IO PackageCollectStats+collectPackage writeAscii prefs packageConfig = do+ packageDescrHI <- collectPackageFromHI packageConfig+ let packString = packageIdentifierToString (pdPackage packageDescrHI)+ mbPackageDescrPair <- collectPackageFromSource prefs packageConfig+ case mbPackageDescrPair of+ (Nothing,stat, Just fp) -> do+ -- Try to retreive prebuild package+ case retreiveURL prefs of+ Just url -> do+ collectorPath <- liftIO $ getCollectorPath+ setCurrentDirectory collectorPath+ let fullUrl = url ++ "/metadata-" ++ leksahVersion ++ "/" ++ packString ++ leksahMetadataSystemFileExtension+ debugM "leksah-server" $ "collectPackage: before retreiving = " ++ fullUrl+ catch (system $ "wget " ++ fullUrl)+ (\(e :: SomeException) -> do+ debugM "leksah-server" $ "collectPackage: Error when calling wget " ++ show e+ return (ExitFailure 1))+ debugM "leksah-server" $ "collectPackage: after retreiving = " ++ packString -- ++ " result = " ++ res+ let filePath = collectorPath </> packString <.> leksahMetadataSystemFileExtension+ exist <- doesFileExist filePath+ if exist+ then do+ debugM "leksah-server" $ "collectPackage: retreived = " ++ packString+ liftIO $ writePackagePath fp packageDescrHI+ return (stat {modulesTotal = Just (length (pdModules packageDescrHI)),+ withSource=True, retrieved= True, mbError=Nothing})+ else do+ debugM "leksah-server" $ "collectPackage: Can't retreive = " ++ packString+ liftIO $ writeExtractedPackage False packageDescrHI+ return (stat {modulesTotal = Just (length (pdModules packageDescrHI))})+ Nothing -> do+ liftIO $ writeExtractedPackage False packageDescrHI+ return (stat {modulesTotal = Just (length (pdModules packageDescrHI))})+ (Just packageDescrS,stat, Just fp) -> do+ let mergedPackageDescr = mergePackageDescrs packageDescrHI packageDescrS+ liftIO $ writeExtractedPackage writeAscii mergedPackageDescr+ liftIO $ writePackagePath fp mergedPackageDescr+ return (stat)+ (Nothing,stat,Nothing) -> do+ liftIO $ writeExtractedPackage False packageDescrHI+ return (stat {modulesTotal = Just (length (pdModules packageDescrHI))})+ _ -> fail "Unexpected error in collectPackage"++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 -> PackageDescr -> m ()+writePackagePath fp pd = do+ collectorPath <- liftIO $ getCollectorPath+ let filePath = collectorPath </> packageIdentifierToString (pdPackage pd) <.>+ 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+++
+ src/IDE/Metainfo/InterfaceCollector.hs view
@@ -0,0 +1,298 @@+{-# OPTIONS_GHC -XScopedTypeVariables -XFlexibleContexts#-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Metainfo.InterfaceCollector+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GNU-GPL+--+-- Maintainer : <maintainer at leksah.org>+-- Stability : provisional+-- Portability : portable+--+-- | This modulle extracts information from .hi files for installed packages+--+-------------------------------------------------------------------------------++module IDE.Metainfo.InterfaceCollector (+ collectPackageFromHI+, extractExportedDescrH+, extractExportedDescrR+) where++import MyMissing (nonEmptyLines)+import Module hiding (PackageId,ModuleName)+import qualified Module as Module (ModuleName)+import qualified Maybes as M+import HscTypes hiding (liftIO)+import qualified HscTypes as Hs (liftIO)+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)++getThisPackage :: PackageConfig -> PackageIdentifier+#if MIN_VERSION_Cabal(1,8,0)+getThisPackage = IPI.sourcePackageId+#else+getThisPackage = IPI.package+#endif++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+ $ map occNameString+ $ concatMap availNames+ $ concatMap snd (mi_exports iface)+ exportedDecls = filter (\ ifdecl -> (occNameString $ ifName ifdecl)+ `Set.member` exportedNames)+ (map snd (mi_decls iface))+ in concatMap (extractIdentifierDescr pid [mid]) exportedDecls+++extractExportedDescrR :: PackageIdentifier+ -> [Descr]+ -> ModIface+ -> ModuleDescr+extractExportedDescrR pid hidden iface =+ let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface)+ exportedNames = Set.fromList+ $map occNameString+ $concatMap availNames+ $concatMap snd (mi_exports iface)+ exportedDecls = filter (\ ifdecl -> (occNameString $ifName ifdecl)+ `Set.member` exportedNames)+ (map snd (mi_decls iface))+ ownDecls = concatMap (extractIdentifierDescr pid [mid]) exportedDecls+ otherDecls = exportedNames `Set.difference` (Set.fromList (map 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 $ map extractUsages (mi_usages iface)+ declsWithExp = map (\ (Real decl) -> Real $ decl{dscExported' =+ Set.member (dscName' decl) exportedNames}) ownDecls+ 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]+ (IfaceData name _ _ ifCons' _ _ _ _)+ -> 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+ IfAbstractTyCon -> DataDescr [] []+ 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]+ eq_ctxt decl = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty)+ | (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 extractSuperClassName (IfaceClassP name _) =+ Just (unpackFS $occNameFS $ nameOccName name)+ extractSuperClassName _ = Nothing++extractInstances :: PackModule -> IfaceInst -> [Descr]+extractInstances pm ifaceInst =+ let className = showSDocUnqual $ ppr $ ifInstCls ifaceInst+ dataNames = map (\iftc -> showSDocUnqual $ ppr iftc)+ $ map fromJust+ $ filter isJust+ $ ifInstTys ifaceInst+ in [Real (RealDescr+ { dscName' = className+ , dscMbTypeStr' = Nothing+ , dscMbModu' = Just pm+ , dscMbLocation' = Nothing+ , dscMbComment' = Nothing+ , dscTypeHint' = InstanceDescr dataNames+ , dscExported' = False})]+++extractUsages :: Usage -> (ModuleName, Set String)+extractUsages (UsagePackageModule usg_mod' _ ) =+ let name = (fromJust . simpleParse . moduleNameString) (moduleName usg_mod')+ in (name, Set.fromList [])+extractUsages (UsageHomeModule usg_mod_name' _ usg_entities' _) =+ let name = (fromJust . simpleParse . moduleNameString) usg_mod_name'+ ids = map (showSDocUnqual . ppr . fst) usg_entities'+ in (name, Set.fromList ids)++filterExtras, filterExtras' :: String -> String+filterExtras ('{':'-':r) = filterExtras' r+filterExtras ('R':'e':'c':'F':'l':'a':'g':r)+ = filterExtras (skipNextWord r)+filterExtras ('G':'e':'n':'e':'r':'i':'c':'s':':':r)+ = filterExtras (skipNextWord r)+filterExtras ('F':'a':'m':'i':'l':'y':'I':'n':'s':'t':'a':'n':'c':'e':':':r)+ = filterExtras (skipNextWord r)+filterExtras (c:r) = c : filterExtras r+filterExtras [] = []++filterExtras' ('-':'}':r) = filterExtras r+filterExtras' (_:r) = filterExtras' r+filterExtras' [] = []++skipNextWord, skipNextWord' :: String -> String+skipNextWord (a:r)+ | isSpace a = skipNextWord r+ | otherwise = skipNextWord' r+skipNextWord [] = []++skipNextWord'(a:r)+ | a == '\n' = r+ | isSpace a = a:r+ | otherwise = skipNextWord' r+skipNextWord' [] = []+++
+ src/IDE/Metainfo/SourceCollectorH.hs view
@@ -0,0 +1,421 @@+{-# OPTIONS_GHC -XScopedTypeVariables -XBangPatterns #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Metainfo.SourceCollectorH+-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Metainfo.SourceCollectorH (+ collectPackageFromSource+, interfaceToModuleDescr+, PackageCollectStats(..)+) where++import IDE.Core.CTypes+ (PackageDescr(..), TypeDescr(..), RealDescr(..), Descr(..),+ ModuleDescr(..), PackModule(..), SimpleDescr(..), packageIdentifierToString)++#if MIN_VERSION_haddock_leksah(2,6,0)+import Haddock.Types+ (ExportItem(..), DeclInfo,+ Interface(..),HsDoc(..))+#else+import Haddock.Types+ (ExportItem(..), DeclInfo,+ Interface(..))+#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 Haddock.Interface (createInterfaces)+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 Debug.Trace (trace)+import System.Directory (setCurrentDirectory, doesDirectoryExist,createDirectory,canonicalizePath)+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(figureOutHaddockOpts)+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)++getThisPackage :: PackageConfig -> PackageIdentifier+#if MIN_VERSION_Cabal(1,8,0)+getThisPackage = IPI.sourcePackageId+#else+getThisPackage = IPI.package+#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}++-- Hell++collectPackageFromSource :: Prefs -> PackageConfig -> IO (Maybe PackageDescr, PackageCollectStats, Maybe FilePath)+collectPackageFromSource prefs packageConfig = do+ sourceMap <- liftIO $ getSourcesMap prefs+ case sourceForPackage (getThisPackage packageConfig) sourceMap of+ Just fp -> do+ let dirPath = dropFileName fp+ setCurrentDirectory dirPath+ runTool' "cabal" (["configure","--user"]) Nothing+ packageFromSource fp packageConfig+ Nothing -> do+ unpackDir <- getUnpackDirectory prefs+ case unpackDir of+ Nothing -> return (Nothing, PackageCollectStats packageName Nothing False False+ (Just ("No source found. Prefs don't allow for retreiving")), Nothing)+ Just fp -> do+ exists <- doesDirectoryExist fp+ unless exists $ createDirectory fp+ setCurrentDirectory fp+ runTool' "cabal" (["unpack",packageName]) Nothing+ success <- doesDirectoryExist (fp </> packageName)+ if not success+ then return (Nothing, PackageCollectStats packageName Nothing False False+ (Just ("Failed to download and unpack source")), Nothing)+ else do+ setCurrentDirectory (fp </> packageName)+ runTool' "cabal" (["configure","--user"]) Nothing+ packageFromSource (fp </> packageName </> packageName <.> "cabal")+ packageConfig+ where+ packageName = packageIdentifierToString (getThisPackage packageConfig)++packageFromSource :: FilePath -> PackageConfig -> IO (Maybe PackageDescr, PackageCollectStats, Maybe FilePath)+packageFromSource cabalPath packageConfig = do+ setCurrentDirectory dirPath+ ghcFlags <- figureOutHaddockOpts+ debugM "leksah-server" ("ghcFlags: " ++ show ghcFlags)+ NewException.catch (inner ghcFlags) handler+ where+ _handler' (_e :: NewException.SomeException) =+ trace "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)), Just dirPath)+ inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] $ \ _flags -> do+ (interfaces,_) <- createInterfaces verbose (exportedMods ++ hiddenMods) [] []+ liftIO $ print (length interfaces)+ let mods = map (interfaceToModuleDescr dirPath (getThisPackage packageConfig)) interfaces+ sp <- liftIO $ canonicalizePath 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, Just dirPath)+ 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(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+ transformToDescr ((L loc (SigD (TypeSig name typ))), mbComment,_subCommentList) =+ [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' _ _ tcdSigs' _ _ 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+extractMethod ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) =+ 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
+ src/IDE/Metainfo/SourceDB.hs view
@@ -0,0 +1,229 @@++-----------------------------------------------------------------------------+--+-- Module : IDE.Metainfo.SourceDB+-- Copyright : 2007-2010 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+ (getConfigFilePathForLoad, getConfigFilePathForSave, allCabalFiles)+import System.Directory (doesFileExist, canonicalizePath)+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,+ parseFromFile, (<?>), (<|>))+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)++-- ---------------------------------------------------------------------+-- 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 canonicalizePath $ concat cabalFiles+ mbPackages <- mapM (\fp -> parseCabal fp) fCabalFiles+ let pdToFiles = Map.fromListWith (++)+ $ map (\(Just p,o ) -> (p,o))+ $ filter (\(mb, _) -> case mb of+ Nothing -> False+ _ -> True )+ $ zip mbPackages (map (\a -> [a]) fCabalFiles)+ filePath <- getConfigFilePathForSave 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++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"+++
+ src/IDE/Metainfo/WorkspaceCollector.hs view
@@ -0,0 +1,620 @@+{-# OPTIONS_GHC -XScopedTypeVariables #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Metainfo.WorkspaceCollector+-- Copyright : 2007-2010 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)+import HscTypes hiding (liftIO)+import Outputable hiding(trace)+import ErrUtils+import Debug.Trace+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 Control.Monad.Reader+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 hiding (liftIO,MonadIO,LIE)+import qualified Maybes as M+import IDE.Metainfo.InterfaceCollector+import Data.Maybe+ (isJust, fromJust, 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)+#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)++collectWorkspace :: PackageIdentifier -> [(String,FilePath)] -> Bool -> Bool -> FilePath -> IO()+collectWorkspace packId moduleList forceRebuild writeAscii dir = do+ debugM "leksah-server" $ "collectWorkspace called with " ++ show moduleList+ 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+ opts <- figureOutGhcOpts+ debugM "leksah-server" $ "before collect modules"+ mapM_ (collectModule packageCollectorPath writeAscii packId opts) 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 [Opt_Haddock,Opt_Cpp] $ \ _dynFlags -> do+ session <- getSession+ (dynFlags3,fp') <- preprocess session (sourcePath,Nothing)+ 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++attachSignatures :: [(NDecl, (Maybe NDoc))] -> [(NDecl,Maybe NDoc)]+ -> [(NDecl, (Maybe NDoc), [(NSig,Maybe NDoc)])]+attachSignatures signatures = map (attachSignature signaturesMap)+ where+ signaturesMap = Map.fromListWith (++)+ $ map (\ (L loc (SigD sig),c) -> (fromJust $ sigNameNoLoc sig, [(L loc sig,c)]))+ signatures+ 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' _ _ tcdSigs' _ _ 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+extractMethod ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) =+ 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+srcSpanToLocation span' | not (isGoodSrcSpan span')+ = Nothing+srcSpanToLocation span'+ = Just (Location (srcSpanStartLine span') (srcSpanStartCol span')+ (srcSpanEndLine span') (srcSpanEndCol span'))++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 d = showSDoc $ ppr_mbDoc (Just (noLoc d))++#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 -> trace ("no interface file for " ++ show mn) $ return Nothing+ Just (mif,_) ->+ let allDescrs = extractExportedDescrH pid mif+ mod' = extractExportedDescrR pid allDescrs mif+ in trace ("interface file for " ++ show mn ++ " descrs: " ++ show (length (mdIdDescriptions mod')))+ $ return (Just mod')+++
+ src/IDE/StrippedPrefs.hs view
@@ -0,0 +1,107 @@+-----------------------------------------------------------------------------+--+-- Module : IDE.StrippedPrefs+-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.StrippedPrefs (++ Prefs(..)+, 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)++--+-- | Preferences is a data structure to hold configuration data+--+data Prefs = Prefs {+ sourceDirectories :: [FilePath]+ , unpackDirectory :: Maybe FilePath+ , retreiveURL :: Maybe String+ , serverPort :: Int+} deriving(Eq,Show)++defaultPrefs :: Prefs+defaultPrefs = Prefs {+ sourceDirectories = []+ , unpackDirectory = Nothing+ , retreiveURL = Just "http://www.leksah.org/"+ , serverPort = 11111+ }++-- ------------------------------------------------------------+-- * 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 "Maybe an URL to load prebuild metadata " $ emptyParams)+ (PP.text . show)+ readParser+ retreiveURL+ (\b a -> a{retreiveURL = b})+ , mkFieldS+ (paraName <<<- ParaName "Port number for server connection" $ emptyParams)+ (PP.text . show)+ intParser+ serverPort+ (\b a -> a{serverPort = 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
+ src/IDE/Utils/FileUtils.hs view
@@ -0,0 +1,441 @@+{-# OPTIONS_GHC -XScopedTypeVariables -XBangPatterns #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Utils.FileUtils+-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Utils.FileUtils (+ allModules+, allHiFiles+, allHaskellSourceFiles+, cabalFileName+, allCabalFiles+, getConfigFilePathForLoad+, hasConfigDir+, getConfigDir+, getConfigFilePathForSave+, getCollectorPath+, getSysLibDir+, getHaddockVersion+, getGhcVersion+, moduleNameFromFilePath+, moduleNameFromFilePath'+, findKnownPackages+, isSubPath+, findSourceFile+, findSourceFile'+, haskellSrcExts+, getCabalUserPackageDir+, autoExtractCabalTarFiles+, autoExtractTarFiles+, getInstalledPackageIds+, figureOutGhcOpts+, figureOutHaddockOpts+) where++import System.FilePath+ (splitFileName, dropExtension, takeExtension,+ combine, addExtension, (</>), normalise, splitPath)+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+ (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 Control.Monad.Trans (MonadIO(..))+import Distribution.Package (PackageIdentifier)+import System.Process+ (waitForProcess, runCommand)+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++haskellSrcExts :: [String]+haskellSrcExts = ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp","hsc"]++-- | 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++hasConfigDir :: IO Bool+hasConfigDir = do+ d <- getHomeDirectory+ let filePath = d </> configDirName+ doesDirectoryExist filePath+++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)++cabalFileName :: FilePath -> IO (Maybe String)+cabalFileName filePath = catch (do+ exists <- doesDirectoryExist filePath+ if exists+ then do+ filesAndDirs <- getDirectoryContents filePath+ files <- filterM (\f -> doesFileExist f) filesAndDirs+ let cabalFiles = filter (\f -> let ext = takeExtension f in ext == ".cabal") files+ if null cabalFiles+ then return Nothing+ else if length cabalFiles == 1+ then return (Just $head cabalFiles)+ else do+ 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++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")++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+ return (filterOptGhc opts)+ 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' "runhaskell" ["Setup","build","--with-ghc=leksahecho"] Nothing+ case catMaybes $ map (findMake . toolline) output of+ options:_ -> return (words options)+ _ -> return []+ where+ findMake [] = Nothing+ findMake line@(_:xs) =+ case stripPrefix " --make " line of+ Nothing -> findMake xs+ s -> s
+ src/IDE/Utils/GHCUtils.hs view
@@ -0,0 +1,210 @@+{-# OPTIONS_GHC -XCPP -fno-warn-orphans #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Utils.GHCUtils+-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : Jutaro <jutaro@leksah.org>+-- 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)+import ErrUtils (dumpIfSet_dyn,printErrorsAndWarnings,mkPlainErrMsg,showPass,ErrMsg(..))+import PackageConfig (PackageConfig)+import Data.Foldable (maximumBy)+import qualified Parser as P (parseModule,parseHeader)+import HscStats (ppSourceStats)+import Control.Monad.Trans+import HscTypes (Ghc(..))+import IDE.Utils.FileUtils (getSysLibDir)+import DynFlags (dopt_set)+import System.Log.Logger(warningM, debugM)++-- 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 $ warningM "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 dflags1{flags = Opt_ReadUserPackageConf : (flags dflags1)}+ 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++ let loc = mkSrcLoc (mkFastString src_filename) 1 0++ case unP P.parseModule (mkPState buf' loc dflags) of {++ PFailed span' err -> return (Left (mkPlainErrMsg span' err));++ POk pst rdr_module -> do {++ let {ms = getMessages pst};+ printErrorsAndWarnings dflags ms;+ -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1);++ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;++ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"+ (ppSourceStats False rdr_module) ;++ return (Right rdr_module)+ -- ToDo: free the string buffer later.+ }}++myParseHeader :: FilePath -> String -> [String] -> IO (Either String (HsModule RdrName))+myParseHeader fp _str opts = inGhcIO opts [Opt_Cpp] $ \ _dynFlags -> do+ session <- getSession+ (dynFlags',fp') <- preprocess session (fp,Nothing)+ 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++ let loc = mkSrcLoc (mkFastString src_filename) 1 0++ case unP P.parseHeader (mkPState buf' loc dflags) of {++ PFailed span' err -> return (Left (mkPlainErrMsg span' err));++ POk pst rdr_module -> do {++ let {ms = getMessages pst};+ printErrorsAndWarnings dflags ms;+ -- when (errorsFound dflags ms) $ exitWith (ExitFailure 1);++ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ;++ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"+ (ppSourceStats False rdr_module) ;++ return (Right rdr_module)+ -- ToDo: free the string buffer later.+ }}+
+ src/IDE/Utils/Server.hs view
@@ -0,0 +1,107 @@+{-# OPTIONS_GHC -XFlexibleInstances #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Utils.Server+-- Copyright : 2007-2010 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 Debug.Trace (trace)++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)+ trace ("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+++
+ src/IDE/Utils/Tool.hs view
@@ -0,0 +1,393 @@+{-# OPTIONS_GHC -XRecordWildCards -XCPP -XBangPatterns -fno-warn-orphans #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Utils.Tool+-- Copyright : (c) Hamish Mackenzie, Juergen Nicklisch-Franken+-- License : GPL+--+-- Maintainer : <maintainer@leksah.org>+-- Stability : provisional+-- Portability :+--+-- | Support for running external tools. Written mainly for GHCi but with+-- | support for others in mind.+--+-----------------------------------------------------------------------------++module IDE.Utils.Tool (+ ToolOutput(..),+ toolline,+ ToolCommand(..),+ ToolState(..),+ newToolState,+ runTool,+ runTool',+ runInteractiveTool,+ newGhci,+ executeCommand,+ executeGhciCommand,+ quoteArg,+ escapeQuotes,++-- waitForChildren,+-- forkChild++) where++import Control.Concurrent+ (takeMVar,+ putMVar,+ newEmptyMVar,+ forkIO,+ newChan,+ MVar,+ Chan,+ writeChan,+ getChanContents,+ dupChan)+import Control.Monad (when)+import Data.List (stripPrefix)+import Data.Maybe (isJust, catMaybes)+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+import System.Posix (sigQUIT, sigINT, installHandler)+import System.Posix.Signals (Handler(..))+#endif+import System.Process+ (waitForProcess, ProcessHandle, runInteractiveProcess)+import Control.DeepSeq+import System.Log.Logger (debugM, criticalM)+import System.Exit (ExitCode(..))+import System.IO (hGetContents, hFlush, hPutStrLn, Handle)++data ToolOutput = ToolInput String | ToolError String | ToolOutput 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 (ToolExit code) = rnf code+++data ToolCommand = ToolCommand String ([ToolOutput] -> IO ())+data ToolState = ToolState {+ toolProcess :: MVar ProcessHandle,+ outputClosed :: MVar Bool,+ toolCommands :: Chan ToolCommand,+ toolCommandsRead :: Chan ToolCommand,+ currentToolCommand :: MVar ToolCommand}++data RawToolOutput = RawToolOutput ToolOutput+ | ToolPrompt+ | ToolOutClosed+ | ToolErrClosed+ | ToolClosed deriving(Eq, Show)++toolline :: ToolOutput -> String+toolline (ToolInput l) = l+toolline (ToolOutput l) = l+toolline (ToolError l) = l+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) ""++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+ deepseq out $ waitForProcess pid+ debugM "leksah-server" $ "End: " ++ show (fp, args)+ return (out,pid)++runTool :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle)+runTool executable arguments mbDir = do+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+ installHandler sigINT Ignore Nothing+ installHandler sigQUIT Ignore Nothing+#endif+ (inp,out,err,pid) <- runInteractiveProcess executable arguments mbDir Nothing+ output <- getOutputNoPrompt inp out err pid+ return (output, pid)++newToolState :: IO ToolState+newToolState = do+ toolProcess <- newEmptyMVar+ outputClosed <- newEmptyMVar+ toolCommands <- newChan+ toolCommandsRead <- dupChan toolCommands+ currentToolCommand <- newEmptyMVar+ return ToolState{..}++runInteractiveTool :: ToolState -> (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ()+runInteractiveTool tool getOutput' executable arguments = do+#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)+ installHandler sigINT Ignore Nothing+ installHandler sigQUIT Ignore Nothing+#endif++ (inp,out,err,pid) <- runInteractiveProcess executable arguments Nothing Nothing+ putMVar (toolProcess tool) pid+ output <- getOutput' inp out err pid+ -- This is handy to show the processed output+ -- forkIO $ forM_ output (putStrLn.show)+ forkIO $ do+ commands <- getChanContents (toolCommandsRead tool)+ processCommand commands inp output+ return ()+ where+ processCommand [] _ _ = return ()+ processCommand ((command@(ToolCommand commandString handler)):remainingCommands) inp allOutput = do+ putMVar (currentToolCommand tool) command+ hPutStrLn inp commandString+ hFlush inp+ let (output, remainingOutputWithPrompt) = span (/= ToolPrompt) allOutput+ debugM "leksah-server" $ "Start Processing Tool Output for " ++ commandString+ handler $ (map ToolInput (lines commandString)) ++ fromRawOutput output+ debugM "leksah-server" $ "Done Processing Tool Output for " ++ commandString+ takeMVar (currentToolCommand tool)+ case remainingOutputWithPrompt of+ (ToolPrompt:remainingOutput) -> do+ debugM "leksah-server" $ "Prompt"+ processCommand remainingCommands inp remainingOutput+ [] -> do+ debugM "leksah-server" $ "Tool Output Closed"+ putMVar (outputClosed tool) True+ _ -> do+ criticalM "leksah-server" $ "This should never happen in Tool.hs"++{-+newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ToolState+newInteractiveTool getOutput' executable arguments = do+ tool <- newToolState+ runInteractiveTool tool getOutput' executable arguments+ return tool+-}++ghciPrompt :: String+ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX"++data CommandLineReader = CommandLineReader {+ stripInitialPrompt :: String -> Maybe String,+ stripFollowingPrompt :: String -> Maybe String,+ errorSyncCommand :: Maybe String,+ stripExpectedError :: String -> Maybe String+ }++ghciStripInitialPrompt :: String -> Maybe String+ghciStripInitialPrompt output =+ case catMaybes [stripPrefix "Prelude" output, stripPrefix "*" output] of+ remaining:_ ->+ case dropWhile (/= '>') remaining of+ '>':' ':next -> Just next+ _ -> Nothing+ _ -> Nothing++ghciStripFollowingPrompt :: String -> Maybe String+ghciStripFollowingPrompt = stripPrefix ghciPrompt++ghciStripExpectedError :: String -> Maybe String+ghciStripExpectedError output = case stripPrefix "\n<interactive>:1:0" output of+ Just rest ->+ stripPrefix ": Not in scope: `kM2KWR7LZZbHdXfHUOA5YBBsJVYoC'\n"+ (maybe rest id (stripPrefix "-28" rest))+ Nothing -> Nothing++ghciCommandLineReader :: CommandLineReader+ghciCommandLineReader = CommandLineReader {+ stripInitialPrompt = ghciStripInitialPrompt,+ stripFollowingPrompt = ghciStripFollowingPrompt,+ errorSyncCommand = Just "kM2KWR7LZZbHdXfHUOA5YBBsJVYoC",+ stripExpectedError = ghciStripExpectedError+ }++noInputCommandLineReader :: CommandLineReader+noInputCommandLineReader = CommandLineReader {+ stripInitialPrompt = const Nothing,+ stripFollowingPrompt = const Nothing,+ errorSyncCommand = Nothing,+ stripExpectedError = const Nothing+ }+--waitTillEmpty :: Handle -> IO ()+--waitTillEmpty handle = do+-- ready <- hReady handle+-- when ready $ do+-- yield+-- threadDelay 100+-- yield+-- waitTillEmpty handle++getOutput :: CommandLineReader -> Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]+getOutput clr inp out err pid = do+ chan <- newChan+ testClosed <- dupChan chan+ -- hSetBuffering out NoBuffering+ -- hSetBuffering err NoBuffering+ foundExpectedError <- newEmptyMVar+ -- Use this and the too putStr threads bellow if you want to see the raw output+ -- hSetBuffering stdout NoBuffering+ forkIO $ do+ errors <- hGetContents err+ -- forkIO $ putStr errors+ readError chan (filter (/= '\r') errors) foundExpectedError+ writeChan chan ToolErrClosed+ forkIO $ do+ output <- hGetContents out+ -- forkIO $ putStr output+ readOutput chan (filter (/= '\r') output) True foundExpectedError False+ writeChan chan ToolOutClosed+ forkIO $ do+ output <- getChanContents testClosed+ when ((ToolOutClosed `elem` output) && (ToolErrClosed `elem` output)) $ do+ exitCode <- waitForProcess pid+ writeChan chan (RawToolOutput (ToolExit exitCode))+ writeChan chan ToolClosed+ debugM "leksah-server" $ "Tool Exited " ++ show exitCode+ fmap (takeWhile ((/=) ToolClosed)) $ getChanContents chan+ where+ readError chan errors foundExpectedError = do+ case stripExpectedError clr errors of+ Just unexpectedErrors -> do+ putMVar foundExpectedError True+ readError chan unexpectedErrors foundExpectedError+ Nothing -> do+ let (line, remaining) = break (== '\n') errors+ case remaining of+ [] -> return ()+ _:remainingLines -> do+ writeChan chan $ RawToolOutput $ ToolError line+ readError chan remainingLines foundExpectedError++ readOutput chan output initial foundExpectedError synced = do+ let stripPrompt = (if initial then (stripInitialPrompt clr) else (stripFollowingPrompt clr))+ let line = getOutputLine stripPrompt output+ let remaining = drop (length line) output+ case remaining of+ [] -> do+ when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line+ '\n':remainingLines -> do+ writeChan chan $ RawToolOutput $ ToolOutput line+ readOutput chan remainingLines initial foundExpectedError synced+ _ -> do+ when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line+ case stripPrompt remaining of+ Just afterPrompt -> do+ case (initial, synced, errorSyncCommand clr) of+ (True, _, _) -> do+ readOutput chan afterPrompt False foundExpectedError synced+ (False, _, Nothing) -> do+ writeChan chan ToolPrompt+ readOutput chan afterPrompt False foundExpectedError synced+ (False, False, Just syncCmd) -> do+ hPutStrLn inp syncCmd+ hFlush inp+ takeMVar foundExpectedError+ readOutput chan afterPrompt False foundExpectedError True+ (False, True, Just _) -> do+ writeChan chan ToolPrompt+ readOutput chan afterPrompt False foundExpectedError False+ _ -> return () -- Should never happen+ getOutputLine _ [] = []+ getOutputLine _ ('\n':_) = []+ getOutputLine stripPrompt output@(x:xs)+ | isJust (stripPrompt output) = []+ | otherwise = x : (getOutputLine stripPrompt xs)++fromRawOutput :: [RawToolOutput] -> [ToolOutput]+fromRawOutput [] = []+fromRawOutput (RawToolOutput (ToolExit code):_) = [ToolExit code]+fromRawOutput (RawToolOutput output:xs) = output : (fromRawOutput xs)+fromRawOutput (_:xs) = fromRawOutput xs++getGhciOutput :: Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]+getGhciOutput = getOutput ghciCommandLineReader++getOutputNoPrompt :: Handle -> Handle -> Handle -> ProcessHandle -> IO [ToolOutput]+getOutputNoPrompt inp out err pid = fmap fromRawOutput $ getOutput noInputCommandLineReader inp out err pid++newGhci :: [String] -> [String] -> ([ToolOutput] -> IO ()) -> IO ToolState+newGhci buildFlags interactiveFlags startupOutputHandler = do+ tool <- newToolState+ writeChan (toolCommands tool) $+ ToolCommand (":set prompt " ++ ghciPrompt) startupOutputHandler+ debugM "leksah-server" $ "Working out GHCi options"+ forkIO $ do+ (output, _) <- runTool "runhaskell" (["Setup","build","--with-ghc=leksahecho"] ++ buildFlags) Nothing+ 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 getGhciOutput "ghci"+ (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags)+ _ -> do+ startupOutputHandler output+ 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 -> ([ToolOutput] -> IO ()) -> IO ()+executeCommand tool command handler = do+ writeChan (toolCommands tool) $ ToolCommand command handler++executeGhciCommand :: ToolState -> String -> ([ToolOutput] -> IO ()) -> IO ()+executeGhciCommand tool command handler = do+ if '\n' `elem` command+ then executeCommand tool safeCommand $ \output -> do+ handler $ fixInput $ fixOutput output+ else executeCommand tool command handler+ where+ filteredLines = (filter safeLine (lines command))+ promptCount = (length filteredLines)+1+ safeCommand = (unlines ([":{"] ++ filteredLines)) ++ ":}"+ safeLine ":{" = False+ safeLine ":}" = False+ safeLine _ = True+ fixOutput ((ToolOutput line):xs) = (ToolOutput (removePrompts line line promptCount)):xs+ fixOutput (x:xs) = x:(fixOutput xs)+ fixOutput [] = []+ fixInput = filter (\x -> (x /= ToolInput ":{") && (x /= ToolInput ":}"))+ removePrompts _fullLine line 0 = line+ removePrompts fullLine line n = case dropWhile ((/=) '|') line of+ '|':' ':xs -> removePrompts fullLine xs (n-1)+ _ -> fullLine++--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 ())+
+ src/IDE/Utils/Utils.hs view
@@ -0,0 +1,42 @@+{-# OPTIONS_GHC -XDeriveDataTypeable -fno-warn-missing-signatures #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Utils.Utils+-- Copyright : 2007-2010 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+packageSessionFilename = "leksah" ++ leksahSessionFileExtension+standardKeymapFilename = "keymap" ++ leksahKeymapFileExtension+standardCandyFilename = "candy" ++ leksahCandyFileExtension+standardPreferencesFilename = "prefs" ++ leksahPreferencesFileExtension+strippedPreferencesFilename = "prefscoll" ++ leksahPreferencesFileExtension+standardSourcesFilename = "sources" ++ leksahSourcesFileExtension+standardModuleTemplateFilename = "module" ++ leksahTemplateFileExtension++++
+ src/LeksahEcho.hs view
@@ -0,0 +1,32 @@+-----------------------------------------------------------------------------+--+-- Module : Main+-- Copyright : 2007-2010 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.FileUtils (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+