diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. + + + Copyright (C) + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License along + with this program; if not, write to the Free Software Foundation, Inc., + 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) year name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the appropriate +parts of the General Public License. Of course, the commands you use may +be called something other than `show w' and `show c'; they could even be +mouse-clicks or menu items--whatever suits your program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here is a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the program + `Gnomovision' (which makes passes at compilers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +This General Public License does not permit incorporating your program into +proprietary programs. If your program is a subroutine library, you may +consider it more useful to permit linking proprietary applications with the +library. If this is what you want to do, use the GNU Lesser General +Public License instead of this License. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/data/prefscoll.lkshp b/data/prefscoll.lkshp new file mode 100644 --- /dev/null +++ b/data/prefscoll.lkshp @@ -0,0 +1,4 @@ +Paths under which haskell sources for packages may be found: + ["~/Develop"] +Maybe a directory for unpacking cabal packages: + Just "~/Haskell" diff --git a/leksah-server.cabal b/leksah-server.cabal new file mode 100644 --- /dev/null +++ b/leksah-server.cabal @@ -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 + + diff --git a/src/IDE/Core/CTypes.hs b/src/IDE/Core/CTypes.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Core/CTypes.hs @@ -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 + + + diff --git a/src/IDE/Core/Serializable.hs b/src/IDE/Core/Serializable.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Core/Serializable.hs @@ -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 +-- 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 + + + diff --git a/src/IDE/HeaderParser.hs b/src/IDE/HeaderParser.hs new file mode 100644 --- /dev/null +++ b/src/IDE/HeaderParser.hs @@ -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') diff --git a/src/IDE/Metainfo/Collector.hs b/src/IDE/Metainfo/Collector.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/Collector.hs @@ -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 + + + diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -0,0 +1,298 @@ +{-# OPTIONS_GHC -XScopedTypeVariables -XFlexibleContexts#-} +----------------------------------------------------------------------------- +-- +-- Module : IDE.Metainfo.InterfaceCollector +-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie +-- License : GNU-GPL +-- +-- Maintainer : +-- Stability : provisional +-- Portability : portable +-- +-- | This modulle extracts information from .hi files for installed packages +-- +------------------------------------------------------------------------------- + +module IDE.Metainfo.InterfaceCollector ( + collectPackageFromHI +, extractExportedDescrH +, extractExportedDescrR +) where + +import MyMissing (nonEmptyLines) +import Module hiding (PackageId,ModuleName) +import qualified Module as Module (ModuleName) +import qualified Maybes as M +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' [] = [] + + + diff --git a/src/IDE/Metainfo/SourceCollectorH.hs b/src/IDE/Metainfo/SourceCollectorH.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/SourceCollectorH.hs @@ -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 diff --git a/src/IDE/Metainfo/SourceDB.hs b/src/IDE/Metainfo/SourceDB.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/SourceDB.hs @@ -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" + + + diff --git a/src/IDE/Metainfo/WorkspaceCollector.hs b/src/IDE/Metainfo/WorkspaceCollector.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/WorkspaceCollector.hs @@ -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') + + + diff --git a/src/IDE/StrippedPrefs.hs b/src/IDE/StrippedPrefs.hs new file mode 100644 --- /dev/null +++ b/src/IDE/StrippedPrefs.hs @@ -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 diff --git a/src/IDE/Utils/FileUtils.hs b/src/IDE/Utils/FileUtils.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/FileUtils.hs @@ -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 diff --git a/src/IDE/Utils/GHCUtils.hs b/src/IDE/Utils/GHCUtils.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/GHCUtils.hs @@ -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 +-- 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. + }} + diff --git a/src/IDE/Utils/Server.hs b/src/IDE/Utils/Server.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/Server.hs @@ -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 + + + diff --git a/src/IDE/Utils/Tool.hs b/src/IDE/Utils/Tool.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/Tool.hs @@ -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 : +-- 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: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 ()) + diff --git a/src/IDE/Utils/Utils.hs b/src/IDE/Utils/Utils.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/Utils.hs @@ -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 + + + + diff --git a/src/LeksahEcho.hs b/src/LeksahEcho.hs new file mode 100644 --- /dev/null +++ b/src/LeksahEcho.hs @@ -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 +