Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

initial after split

Ignore-this: 2b303b3bfe39b17b0f53fc2457477c82

darcs-hash:20100202230958-e153b-3d2db06017e15a971ec1dc961d75ea33f7a35497.gz
  • Loading branch information...
commit 1e9f1f7bb6fcb2181a7c17b9c9ea1ae82a2de106 0 parents
jutaro authored
339 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.
+
+ <one line to give the program's name and a brief idea of what it does.>
+ Copyright (C) <year> <name of author>
+
+ This program is free software; you can redistribute it and/or modify
+ it under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2 of the License, or
+ (at your option) any later version.
+
+ This program is distributed in the hope that it will be useful,
+ but WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License along
+ with this program; if not, write to the Free Software Foundation, Inc.,
+ 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
+
+Also add information on how to contact you by electronic and paper mail.
+
+If the program is interactive, make it output a short notice like this
+when it starts in an interactive mode:
+
+ Gnomovision version 69, Copyright (C) year name of author
+ Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
+ This is free software, and you are welcome to redistribute it
+ under certain conditions; type `show c' for details.
+
+The hypothetical commands `show w' and `show c' should show the appropriate
+parts of the General Public License. Of course, the commands you use may
+be called something other than `show w' and `show c'; they could even be
+mouse-clicks or menu items--whatever suits your program.
+
+You should also get your employer (if you work as a programmer) or your
+school, if any, to sign a "copyright disclaimer" for the program, if
+necessary. Here is a sample; alter the names:
+
+ Yoyodyne, Inc., hereby disclaims all copyright interest in the program
+ `Gnomovision' (which makes passes at compilers) written by James Hacker.
+
+ <signature of Ty Coon>, 1 April 1989
+ Ty Coon, President of Vice
+
+This General Public License does not permit incorporating your program into
+proprietary programs. If your program is a subroutine library, you may
+consider it more useful to permit linking proprietary applications with the
+library. If this is what you want to do, use the GNU Lesser General
+Public License instead of this License.
6 Setup.lhs
@@ -0,0 +1,6 @@
+#!/usr/bin/runhaskell
+> module Main where
+> import Distribution.Simple
+> main :: IO ()
+> main = defaultMain
+
79 leksah-server.cabal
@@ -0,0 +1,79 @@
+name: leksah-server
+version: 0.7
+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 Nicklisch-Franken, Hamish Mackenzie
+data-dir: ""
+
+library
+ build-depends: Cabal >=1.6.0.1, base -any, binary >=0.5.0.0,
+ binary-shared >=0.0.1, bytestring >=0.9.0.1, containers >=0.2.0.0,
+ directory >=1.0.0.2, filepath >=1.1.0.1, ghc >=6.10.1,
+ haddock-leksah -any, ltk ==0.7, 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 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
+ ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans -O2
+
+executable leksah-server
+ build-depends: Cabal >=1.6.0.1, base -any, binary >=0.5.0.0,
+ binary-shared >=0.0.1, bytestring >=0.9.0.1, containers >=0.2.0.0,
+ directory >=1.0.0.2, filepath >=1.1.0.1, ghc >=6.10.1,
+ haddock-leksah -any, ltk ==0.7, 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 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
+ ghc-options:-threaded
+
+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
+ ghc-options: -fwarn-unused-imports -fwarn-missing-fields -fwarn-incomplete-patterns -ferror-spans
+
+
404 src/IDE/Core/CTypes.hs
@@ -0,0 +1,404 @@
+{-# OPTIONS_GHC -XFlexibleInstances -XDeriveDataTypeable -XExistentialQuantification
+ -XMultiParamTypeClasses -XFlexibleContexts #-}
+-----------------------------------------------------------------------------
+--
+-- Module : IDE.Core.CTypes
+-- Copyright : 2007-2009 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(..)
+
+, configDirName
+, metadataVersion
+, standardPort
+
+, ImportDecl(..)
+, ImportSpecList(..)
+, ImportSpec(..)
+
+) where
+
+-- import GHC.ConsoleHandler (Handler(..))
+import Data.Typeable (Typeable(..))
+import Data.Map (Map(..))
+import Data.Set (Set(..))
+import Default (Default(..))
+import MyMissing (nonEmptyLines)
+import Distribution.Package (PackageIdentifier(..))
+import Distribution.ModuleName (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)
+
+-- ---------------------------------------------------------------------
+-- | Information about the system, extraced from .hi and source files
+--
+
+configDirName = ".leksah-0.7"
+
+metadataVersion :: Integer
+metadataVersion = 7
+
+standardPort = 80
+
+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 (Maybe [ImportDecl])
+ deriving (Eq,Ord,Show,Read)
+
+data ImportDecls = ImportDecls
+ 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 map = case str `Map.lookup` map 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
+
+dscMbModu :: Descr -> Maybe PackModule
+dscMbModu (Reexported d) = dscMbModu (dsrDescr d)
+dscMbModu (Real d) = dscMbModu' d
+
+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 d) = 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 dscMbModu 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 lines - 1] lines
+ where lines = 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)
+
+-- | 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)
+
242 src/IDE/Core/Serializable.hs
@@ -0,0 +1,242 @@
+{-# OPTIONS_GHC
+ -XScopedTypeVariables
+ -XStandaloneDeriving
+ -XDeriveDataTypeable #-}
+
+-----------------------------------------------------------------------------
+--
+-- Module : IDE.Core.Serializable
+-- Copyright : 2007-2009 Jürgen Nicklisch-Franken
+-- License : GPL
+--
+-- Maintainer : Jutaro <jutaro@leksah.org>
+-- Stability : provisional
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module IDE.Core.Serializable (
+
+
+) where
+
+import Distribution.Text (simpleParse,display)
+import Control.Monad (liftM)
+import Data.Maybe (fromJust)
+import Data.Binary.Shared (BinaryShared(..))
+import Data.Typeable (Typeable(..))
+import Distribution.Package (PackageName(..),PackageIdentifier(..))
+import Data.Version (Version(..))
+import Distribution.ModuleName (ModuleName(..))
+
+import IDE.Core.CTypes
+
+deriving instance Typeable PackageIdentifier
+deriving instance Typeable ModuleName
+deriving instance Typeable PackageName
+-----------------------------------------------------------
+
+instance BinaryShared PackModule where
+ put = putShared (\ (PM pack' modu') -> do
+ (put pack')
+ (put modu'))
+ get = getShared (do
+ pack' <- get
+ modu' <- get
+ return (PM pack' modu'))
+
+
+instance BinaryShared PackageIdentifier where
+ put = putShared (\ (PackageIdentifier name' version') -> do
+ put name'
+ put version')
+ get = getShared (do
+ name' <- get
+ version' <- get
+ return (PackageIdentifier name' version'))
+
+instance BinaryShared Version where
+ put = putShared (\ (Version branch' tags') -> do
+ put branch'
+ put tags')
+ get = getShared (do
+ branch' <- get
+ tags' <- get
+ return (Version branch' tags'))
+
+instance BinaryShared PackageDescr where
+ put = putShared (\ (PackageDescr packagePD' exposedModulesPD' buildDependsPD'
+ mbSourcePathPD') -> do
+ put packagePD'
+ put exposedModulesPD'
+ put buildDependsPD'
+ put mbSourcePathPD')
+ get = getShared (do
+ packagePD' <- get
+ exposedModulesPD' <- get
+ buildDependsPD' <- get
+ mbSourcePathPD' <- get
+ return (PackageDescr packagePD' exposedModulesPD' buildDependsPD'
+ mbSourcePathPD'))
+
+instance BinaryShared ModuleDescr where
+ put = putShared (\ (ModuleDescr moduleIdMD' mbSourcePathMD' usagesMD'
+ idDescriptionsMD') -> do
+ put moduleIdMD'
+ put mbSourcePathMD'
+ put usagesMD'
+ put idDescriptionsMD')
+ get = getShared (do
+ moduleIdMD' <- get
+ mbSourcePathMD' <- get
+ usagesMD' <- get
+ idDescriptionsMD' <- get
+ return (ModuleDescr moduleIdMD' mbSourcePathMD'
+ usagesMD' idDescriptionsMD'))
+
+instance BinaryShared Descr where
+ put (Real (RealDescr descrName2 typeInfo2 descrModu2 mbLocation2 mbComment2 details2 isExp))
+ = do put (1:: Int)
+ put descrName2
+ put typeInfo2
+ put descrModu2
+ put mbLocation2
+ put mbComment2
+ put details2
+ put isExp
+ put (Reexported (ReexportedDescr reexpModu' impDescr'))
+ = do put (2:: Int)
+ put reexpModu'
+ put impDescr'
+ get = do (typeHint :: Int) <- get
+ case typeHint of
+ 1 -> do
+ descrName2 <- get
+ typeInfo2 <- get
+ descrModu2 <- get
+ mbLocation2 <- get
+ mbComment2 <- get
+ details2 <- get
+ isExp2 <- get
+ return (Real (RealDescr descrName2 typeInfo2 descrModu2 mbLocation2
+ mbComment2 details2 isExp2))
+ 2 -> do
+ reexpModu' <- get
+ impDescr' <- get
+ return (Reexported (ReexportedDescr reexpModu' impDescr'))
+ _ -> error "Impossible in Binary Descr get"
+
+instance BinaryShared TypeDescr where
+ put VariableDescr
+ = do put (1:: Int)
+ put (FieldDescr typeDescrF')
+ = do put (2:: Int)
+ put typeDescrF'
+ put (ConstructorDescr typeDescrC')
+ = do put (3:: Int)
+ put typeDescrC'
+ put (DataDescr constructors' fields')
+ = do put (4:: Int)
+ put constructors'
+ put fields'
+ put TypeDescr
+ = do put (5:: Int)
+ put (NewtypeDescr constructor' mbField')
+ = do put (6:: Int)
+ put constructor'
+ put mbField'
+ put (ClassDescr super' methods')
+ = do put (7:: Int)
+ put super'
+ put methods'
+ put (MethodDescr classDescrM')
+ = do put (8:: Int)
+ put classDescrM'
+ put (InstanceDescr binds')
+ = do put (9:: Int)
+ put binds'
+ put KeywordDescr
+ = do put (10:: Int)
+ put ExtensionDescr
+ = do put (11:: Int)
+ put ModNameDescr
+ = do put (12:: Int)
+ put QualModNameDescr
+ = do put (13:: Int)
+ put ErrorDescr
+ = do put (14:: Int)
+
+ get = do (typeHint :: Int) <- get
+ case typeHint of
+ 1 -> return VariableDescr
+ 2 -> do
+ typeDescrF' <- get
+ return (FieldDescr typeDescrF')
+ 3 -> do
+ typeDescrC' <- get
+ return (ConstructorDescr typeDescrC')
+ 4 -> do
+ constructors' <- get
+ fields' <- get
+ return (DataDescr constructors' fields')
+ 5 -> return TypeDescr
+ 6 -> do
+ constructor' <- get
+ mbField' <- get
+ return (NewtypeDescr constructor' mbField')
+ 7 -> do
+ super' <- get
+ methods' <- get
+ return (ClassDescr super' methods')
+ 8 -> do
+ classDescrM' <- get
+ return (MethodDescr classDescrM')
+ 9 -> do
+ binds' <- get
+ return (InstanceDescr binds')
+ 10 -> return KeywordDescr
+ 11 -> return ExtensionDescr
+ 12 -> return ModNameDescr
+ 13 -> return QualModNameDescr
+ 14 -> return ErrorDescr
+ _ -> error "Impossible in Binary SpDescr get"
+
+instance BinaryShared SimpleDescr where
+ put (SimpleDescr sdName' sdType' sdLocation' sdComment' sdExported')
+ = do put sdName'
+ put sdType'
+ put sdLocation'
+ put sdComment'
+ put sdExported'
+ get = do sdName' <- get
+ sdType' <- get
+ sdLocation' <- get
+ sdComment' <- get
+ sdExported' <- get
+ return (SimpleDescr sdName' sdType' sdLocation' sdComment' sdExported')
+
+instance BinaryShared Location where
+ put (Location locationSLine' locationSCol' locationELine' locationECol')
+ = do put locationSLine'
+ put locationSCol'
+ put locationELine'
+ put locationECol'
+ get = do locationSLine' <- get
+ locationSCol' <- get
+ locationELine' <- get
+ locationECol' <- get
+ return (Location locationSLine' locationSCol' locationELine' locationECol')
+
+
+instance BinaryShared ModuleName where
+ put = put . display
+ get = liftM (fromJust . simpleParse) get
+
+instance BinaryShared PackageName where
+ put (PackageName pn) = put pn
+ get = liftM PackageName get
+
+
+
102 src/IDE/HeaderParser.hs
@@ -0,0 +1,102 @@
+-----------------------------------------------------------------------------
+--
+-- Module : IDE.HeaderParser
+-- Copyright : 2007-2009 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)
+
+parseTheHeader :: FilePath -> IO ServerAnswer
+parseTheHeader filePath = do
+ text <- readFile filePath
+ parseResult <- liftIO $ myParseHeader filePath text
+ case parseResult of
+ Left str -> return (ServerFailed str)
+ Right (pr@HsModule{ hsmodImports = imports }) -> return (ServerHeader (Just
+ (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 (showRdrName 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)
+
+-- | A single Haskell @import@ declaration.
+{--
+type LImportDecl name = Located (ImportDecl name)
+data ImportDecl name
+ = ImportDecl {
+ ideclName :: Located ModuleName, -- ^ Module name.
+ ideclPkgQual :: Maybe FastString, -- ^ Package qualifier.
+ ideclSource :: Bool, -- ^ True <=> {-# SOURCE #-} import
+ ideclQualified :: Bool, -- ^ True => qualified
+ ideclAs :: Maybe ModuleName, -- ^ as Module
+ ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names)
+ }
+type LIE name = Located (IE name)
+
+-- | Imported or exported entity.
+data IE name
+ = IEVar name
+ | IEThingAbs name -- ^ Class/Type (can't tell)
+ | IEThingAll name -- ^ Class/Type plus all methods/constructors
+ | IEThingWith name [name] -- ^ Class/Type plus some methods/constructors
+ | IEModuleContents ModuleName -- ^ (Export Only)
+ | IEGroup Int (HsDoc name) -- ^ Doc section heading
+ | IEDoc (HsDoc name) -- ^ Some documentation
+ | IEDocNamed String -- ^ Reference to named doc
+--}
386 src/IDE/Metainfo/Collector.hs
@@ -0,0 +1,386 @@
+{-# OPTIONS_GHC -XScopedTypeVariables #-}
+-----------------------------------------------------------------------------
+--
+-- Module : Main
+-- Copyright : 2007-2009 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, simpleParse)
+import MyMissing(split)
+import Prelude hiding(catch)
+import Debug.Trace
+-- import Control.Monad.Trans (liftIO)
+import System.Directory (removeDirectoryRecursive, doesFileExist, removeFile, doesDirectoryExist)
+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 qualified Control.Exception as NewException
+ (Handler(..), catches, SomeException)
+import MyMissing(trim)
+import System.Log
+import System.Log.Logger(updateGlobalLogger,rootLoggerName,addHandler,debugM,infoM,warningM,errorM,
+ getRootLogger, saveGlobalLogger, 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 (hPutStrLn, hGetLine, hFlush)
+import IDE.HeaderParser(parseTheHeader)
+
+-- --------------------------------------------------------------------
+-- Command line options
+--
+
+#if MIN_VERSION_Cabal(1,8,0)
+getThisPackage = IPI.sourcePackageId
+#else
+getThisPackage = IPI.package
+#endif
+
+data Flag = CollectSystem
+
+ | ServerCommand (Maybe String)
+ --modifiers
+ | Rebuild
+ | Sources
+ | ExtractTars
+ | Directory FilePath
+ --others
+ | VersionF
+ | Help
+ | Debug
+ 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"
+ ]
+
+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 = withSocketsDo $ NewException.catches inner [NewException.Handler handler]
+ where
+ handler (e :: NewException.SomeException) = do
+ putStrLn $ "leksah-server: " ++ (show e)
+ errorM "leksah-server" (show e)
+ return ()
+ inner = do
+ args <- getArgs
+ (o,_) <- ideOpts args
+ fp <- getConfigFilePathForSave "collectorl.lkslo"
+ handler <- fileHandler fp DEBUG
+ updateGlobalLogger rootLoggerName (\ l -> setLevel DEBUG (addHandler handler l))
+ debugM "leksah-server" $ "*** server called " ++ 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 extract = elem ExtractTars o
+ let sources = elem Sources o
+ let rebuild = elem Rebuild o
+ let debug = elem Debug o
+ when (elem CollectSystem o) $ do
+ debugM "leksah-server" "collectSystem"
+ collectSystem prefs debug rebuild sources extract
+
+ case servers of
+ (Nothing:_) -> do
+ running <- serveOne Nothing (server (PortNum (fromIntegral standardPort)) 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 (h,n,p) = do
+ line <- hGetLine h
+ case read line of
+ SystemCommand rebuild sources extract -> do
+ collectSystem prefs False rebuild sources extract
+ hPutStrLn h (show ServerOK)
+ hFlush h
+ WorkspaceCommand rebuild package path modList -> do
+ collectWorkspace package modList rebuild False path
+ hPutStrLn h (show ServerOK)
+ hFlush h
+ ParseHeaderCommand filePath -> do
+ res <- parseTheHeader filePath
+ hPutStrLn h (show res)
+ hFlush h
+
+
+collectSystem :: Prefs -> Bool -> Bool -> Bool -> Bool -> IO()
+collectSystem prefs writeAscii forceRebuild findSources extractTars = 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 IPI.package packageInfos)
+ let newPackages = filter (\pi -> not $Set.member (packageIdentifierToString $ getThisPackage pi)
+ knownPackages)
+ packageInfos
+ if null newPackages
+ then do
+ infoM "leksah-server" "Metadata collector has nothing to do"
+ else do
+ 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 ++
+ "\nModules total = " ++ show modulesTotal' ++
+ "\nModules with source = " ++ show modulesWithSource ++
+ "\nPercentage source = " ++ show percentageWithSource
+ packagesTotal = length stats
+ packagesWithSource = length (filter withSource 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 = trace ("collectPackage " ++ display (getThisPackage packageConfig))
+ $ do
+ packageDescrHI <- collectPackageFromHI packageConfig
+ mbPackageDescrPair <- collectPackageFromSource prefs packageConfig
+ case mbPackageDescrPair of
+ (Nothing,stat) -> do
+ liftIO $ writeExtractedPackage False packageDescrHI
+ return (stat {modulesTotal = Just (length (pdModules packageDescrHI))})
+ (Just packageDescrS,stat) -> do
+ let mergedPackageDescr = mergePackageDescrs packageDescrHI packageDescrS
+ liftIO $ writeExtractedPackage writeAscii mergedPackageDescr
+ return (stat)
+
+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)
+
+--------------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 = trace ("mergeModuleDescrs allNames" ++ show allNames)
+ $ 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
+
+
+
304 src/IDE/Metainfo/InterfaceCollector.hs
@@ -0,0 +1,304 @@
+{-# OPTIONS_GHC -XScopedTypeVariables -XFlexibleContexts#-}
+-----------------------------------------------------------------------------
+--
+-- Module : IDE.Metainfo.InterfaceCollector
+-- Copyright : (c) Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GNU-GPL
+--
+-- Maintainer : <maintainer at leksah.org>
+-- Stability : provisional
+-- Portability : portable
+--
+-- | This modulle extracts information from .hi files for installed packages
+--
+-------------------------------------------------------------------------------
+
+module IDE.Metainfo.InterfaceCollector (
+ collectPackageFromHI
+, extractExportedDescrH
+, extractExportedDescrR
+) where
+
+import MyMissing (nonEmptyLines)
+import Module hiding (PackageId,ModuleName)
+import qualified Module as Module (ModuleName)
+import qualified Maybes as M
+import HscTypes hiding (liftIO)
+import qualified HscTypes as Hs (liftIO)
+import LoadIface
+import Outputable hiding(trace)
+import IfaceSyn
+import FastString
+import Name
+import PrelNames
+#if MIN_VERSION_ghc(6,12,1)
+import PackageConfig
+ (PackageConfig(..), mkPackageId, packageConfigToInstalledPackageInfo)
+#else
+import PackageConfig
+ (PackageConfig(..), mkPackageId)
+#endif
+import qualified PackageConfig as DP
+import TcRnTypes
+import qualified FastString as FS
+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 (display, simpleParse)
+import Control.Monad.Reader
+import Data.Maybe
+import System.FilePath
+import qualified Data.ByteString.Char8 as BS
+import IDE.Core.Serializable ()
+import IDE.Core.CTypes
+import Data.ByteString.Char8 (ByteString(..))
+import TcRnMonad (initTcRnIf)
+import Debug.Trace (trace)
+import IDE.Utils.GHCUtils
+
+#if MIN_VERSION_Cabal(1,8,0)
+getThisPackage = IPI.sourcePackageId
+#else
+getThisPackage = IPI.package
+#endif
+
+collectPackageFromHI :: PackageConfig -> IO PackageDescr
+collectPackageFromHI packageConfig = trace ("collectPackageFromHI " ++ display (getThisPackage packageConfig))
+ $ inGhcIO [] [] $ \ _ -> do
+ session <- getSession
+ exportedIfaceInfos <- getIFaceInfos (getThisPackage packageConfig)
+ (IPI.exposedModules packageConfig) session
+ hiddenIfaceInfos <- getIFaceInfos (getThisPackage packageConfig)
+ (IPI.hiddenModules packageConfig) session
+ return (extractInfo exportedIfaceInfos hiddenIfaceInfos
+ (getThisPackage packageConfig)
+#if MIN_VERSION_Cabal(1,8,0)
+ []) -- TODO 6.12 (IPI.depends $ packageConfigToInstalledPackageInfo packageConfig))
+#else
+ (depends packageConfig))
+#endif
+
+
+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 pi depends =
+ let allDescrs = concatMap (extractExportedDescrH pi)
+ (map fst (ifacesHid ++ ifacesExp))
+ mods = map (extractExportedDescrR pi allDescrs) (map fst ifacesExp)
+ in PackageDescr {
+ pdPackage = pi
+ , pdModules = mods
+ , pdBuildDepends = depends
+ , 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' [] = []
+
+
+
346 src/IDE/Metainfo/SourceCollectorH.hs
@@ -0,0 +1,346 @@
+{-# OPTIONS_GHC -XScopedTypeVariables -XBangPatterns #-}
+-----------------------------------------------------------------------------
+--
+-- Module : IDE.Metainfo.SourceCollectorH
+-- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie
+-- License : GPL
+--
+-- Maintainer : maintainer@leksah.org
+-- Stability : provisional
+-- Portability :
+--
+-- |
+--
+-----------------------------------------------------------------------------
+
+module IDE.Metainfo.SourceCollectorH (
+ collectPackageFromSource
+, packageFromSource
+, interfaceToModuleDescr
+, PackageCollectStats(..)
+) where
+
+import IDE.Core.CTypes
+ (PackageDescr(..), TypeDescr(..), RealDescr(..), Descr(..),
+ ModuleDescr(..), PackModule(..), SimpleDescr(..), packageIdentifierToString)
+import Module
+ (packageIdString, moduleName, modulePackageId)
+import Haddock.Types
+ (Doc(..), Decl(..), ExportItem(..), DeclInfo(..),
+ Interface(..))
+import Distribution.Text (display, simpleParse)
+import InstEnv (Instance(..))
+import MyMissing
+import Data.Map (Map(..))
+import qualified Data.Map as Map (empty)
+
+import Outputable (ppr, showSDocUnqual, OutputableBndr)
+import Data.List (nub)
+import qualified Data.ByteString.Char8 as BS (pack)
+import IDE.Metainfo.WorkspaceCollector
+ (uncommentData, toComment, srcSpanToLocation, printHsDoc,
+ attachComments, uncommentDecl)
+import Name (getOccString,getSrcSpan)
+import PackageConfig (PackageConfig(..))
+import Haddock.Interface (createInterfaces)
+import Distribution.Verbosity (verbose)
+import qualified Distribution.InstalledPackageInfo as IPI
+import Distribution.InstalledPackageInfo (depends)
+import IDE.StrippedPrefs (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)
+
+#if MIN_VERSION_Cabal(1,8,0)
+getThisPackage = IPI.sourcePackageId
+#else
+getThisPackage = IPI.package
+#endif
+
+data PackageCollectStats = PackageCollectStats {
+ packageString :: String,
+ modulesTotal :: Maybe Int,
+ withSource :: Bool,
+ mbError :: Maybe String}
+
+-- Hell
+
+collectPackageFromSource :: Prefs -> PackageConfig -> IO (Maybe PackageDescr, PackageCollectStats)
+collectPackageFromSource prefs packageConfig = trace ("collectPackageFromSource " ++ display (getThisPackage packageConfig))
+ $ do
+ sourceMap <- liftIO $ getSourcesMap prefs
+ case sourceForPackage (getThisPackage packageConfig) sourceMap of
+ Just fp -> packageFromSource fp packageConfig
+ Nothing ->
+ case unpackDirectory prefs of
+ Nothing -> return (Nothing, PackageCollectStats packageName Nothing False
+ (Just ("No source found. Prefs don't allow for retreiving")))
+ Just fp -> do
+ exists <- doesDirectoryExist fp
+ unless exists $ createDirectory fp
+ setCurrentDirectory fp
+ (output, pid) <- runTool' "cabal" (["unpack",packageName]) Nothing
+ success <- doesDirectoryExist (fp </> packageName)
+ if not success
+ then return (Nothing, PackageCollectStats packageName Nothing False
+ (Just ("Failed to download and unpack source")))
+ else do
+ setCurrentDirectory (fp </> packageName)
+ output <- runTool' "cabal" (["configure","--user"]) Nothing
+ -- TODO check for success
+ if True
+ then packageFromSource (fp </> packageName </> packageName <.> "cabal")
+ packageConfig
+ else return (Nothing, PackageCollectStats packageName Nothing False
+ (Just ("Failed to configure")))
+ where
+ packageName = packageIdentifierToString (getThisPackage packageConfig)
+
+packageFromSource :: FilePath -> PackageConfig -> IO (Maybe PackageDescr, PackageCollectStats)
+packageFromSource cabalPath packageConfig = trace ("packageFromSource " ++ cabalPath)
+ $ do
+ setCurrentDirectory dirPath
+ ghcFlags <- figureOutHaddockOpts
+ --NewException.catches (figureOutGhcOpts) [NewException.Handler handler']
+ trace ("ghcFlags: " ++ show ghcFlags)
+ NewException.catch (inner ghcFlags) handler
+ where
+ handler' (e :: NewException.SomeException) =
+ trace "would block" $ return ([])
+ handler (e :: NewException.SomeException) = do
+ return (Nothing, PackageCollectStats packageName Nothing False
+ (Just ("Ghc failed to process: " ++ show e)))
+ inner ghcFlags = trace ("before inGhcIO ") $
+ 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 = depends packageConfig
+ , pdMbSourcePath = Just sp}
+ let stat = PackageCollectStats packageName (Just (length mods)) True Nothing
+ liftIO $ return (Just pd, stat)
+ exportedMods = map moduleNameString $ IPI.exposedModules packageConfig
+ hiddenMods = map moduleNameString $ IPI.hiddenModules packageConfig
+ dirPath = dropFileName cabalPath
+ packageName = packageIdentifierToString (getThisPackage packageConfig)
+
+-- Heaven
+
+interfaceToModuleDescr :: FilePath -> PackageIdentifier -> Interface -> ModuleDescr
+interfaceToModuleDescr dirPath pid interface = trace ("interfaceToModuleDescr " ++ show modName ++ " " ++ show filepath)
+ ModuleDescr {
+ mdModuleId = PM pid modName
+ , mdMbSourcePath = Just (dirPath </> 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
+
+extractDescrs :: PackModule -> Map Name DeclInfo -> [ExportItem Name] -> [Instance] -> [Name] -> [Descr]
+extractDescrs pm ifaceDeclMap ifaceExportItems ifaceInstances ifaceLocals =
+ transformToDescrs pm exportedDeclInfo ++ map (toDescrInst pm) ifaceInstances
+ where
+ transformed = transformToDescrs pm exportedDeclInfo
+ ++ map (toDescrInst pm) ifaceInstances
+ 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
+
+
+-- transformToDescrs :: PackModule -> [(Decl, Maybe Doc, [(Name, Maybe Doc)])] -> [Descr]
+transformToDescrs pm = concatMap transformToDescr
+ where
+-- transformToDescr :: (Decl, Maybe Doc, [(Name, Maybe Doc)]) -> [Descr]
+ 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' = Just (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' = Just (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' = Just (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' = Just (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' = Just (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' = Just (srcSpanToLocation (getSrcSpan inst))
+ , dscMbComment' = Nothing
+ , dscTypeHint' = InstanceDescr (map (showSDocUnqual . ppr) is_tys)
+ , dscExported' = True}
+
+#if MIN_VERSION_Cabal(1,8,0)
+type MaybeDocStrings = [HsDocString]
+
+
+extractMethods :: (OutputableBndr alpha, NamedThing alpha) => [LSig alpha] -> [LDocDecl ] -> [SimpleDescr]
+extractMethods sigs docs =
+ let pairs = attachComments sigs docs
+ in mapMaybe extractMethod pairs
+
+extractMethod :: (OutputableBndr alpha, NamedThing alpha) => (LHsDecl alpha, MaybeDocStrings) -> Maybe SimpleDescr
+extractMethod ((L loc (SigD ts@(TypeSig name typ))), mbDoc) =
+ Just $ SimpleDescr
+ (getOccString (unLoc name))
+ (Just (BS.pack (showSDocUnqual $ ppr ts)))
+ (Just (srcSpanToLocation loc))
+ (toComment mbDoc [])
+extractMethod (_, mbDoc) = Nothing
+
+extractConstructor decl@(L loc (ConDecl name _ _ _ _ _ doc _)) =
+ SimpleDescr
+ (getOccString (unLoc name))
+ (Just (BS.pack (showSDocUnqual $ppr (uncommentDecl decl))))
+ (Just (srcSpanToLocation loc))
+ (case doc of
+ Nothing -> Nothing
+ Just (L _ d) -> Just (BS.pack (printHsDoc d)))
+
+
+extractRecordFields (L _ decl@(ConDecl _ _ _ _ (RecCon flds) _ _ _)) =
+ map extractRecordFields' flds
+ where
+ extractRecordFields' field@(ConDeclField (L loc name) typ doc) =
+ SimpleDescr
+ (getOccString name)
+ (Just (BS.pack (showSDocUnqual $ ppr typ)))
+ (Just (srcSpanToLocation loc))
+ (case doc of
+ Nothing -> Nothing
+ Just (L _ d) -> Just (BS.pack (printHsDoc d)))
+ True
+extractRecordFields _ = []
+
+#else
+extractMethods :: (OutputableBndr alpha, NamedThing alpha) => [LSig alpha] -> [LDocDecl alpha] -> [SimpleDescr]
+extractMethods sigs docs =
+ let pairs = attachComments sigs docs
+ in mapMaybe extractMethod pairs
+
+extractMethod :: (OutputableBndr alpha, NamedThing alpha) => (LHsDecl alpha, Maybe (HsDoc alpha)) -> Maybe SimpleDescr
+extractMethod ((L loc (SigD ts@(TypeSig name typ))), mbDoc) =
+ Just $ SimpleDescr
+ (getOccString (unLoc name))
+ (Just (BS.pack (showSDocUnqual $ ppr ts)))
+ (Just (srcSpanToLocation loc))
+ (toComment mbDoc [])
+ True
+extractMethod (_, mbDoc) = Nothing
+
+extractConstructor decl@(L loc (ConDecl name _ _ _ _ _ doc)) =
+ SimpleDescr
+ (getOccString (unLoc name))
+ (Just (BS.pack (showSDocUnqual $ppr (uncommentDecl decl))))
+ (Just (srcSpanToLocation loc))
+ (case doc of
+ Nothing -> Nothing
+ Just (L _ d) -> Just (BS.pack (printHsDoc d)))
+ True
+
+
+extractRecordFields (L _ decl@(ConDecl _ _ _ _ (RecCon flds) _ _)) =
+ map extractRecordFields' flds
+ where
+ extractRecordFields' field@(ConDeclField (L loc name) typ doc) =
+ SimpleDescr
+ (getOccString name)
+ (Just (BS.pack (showSDocUnqual $ ppr typ)))
+ (Just (srcSpanToLocation loc))
+ (case doc of
+ Nothing -> Nothing
+ Just (L _ d) -> Just (BS.pack (printHsDoc d)))
+ True
+extractRecordFields _ = []
+#endif
+
+
216 src/IDE/Metainfo/SourceDB.hs
@@ -0,0 +1,216 @@
+
+-----------------------------------------------------------------------------
+--
+-- Module : IDE.Metainfo.SourceDB
+-- Copyright : 2007-2009 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 (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)
+import qualified Text.ParserCombinators.Parsec.Token as P
+ (symbol, whiteSpace, makeTokenParser, commentLine, commentEnd,
+ commentStart,LanguageDef)
+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 id map =
+ case id `Map.lookup` map of
+ Just (h:_) -> Just h
+ _ -> Nothing
+
+buildSourceForPackageDB :: Prefs -> IO ()
+buildSourceForPackageDB prefs = do
+ let sourceDirs = sourceDirectories prefs
+ let dirs = case unpackDirectory prefs 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.makeTokenParser packageStyle
+whiteSpace = P.whiteSpace lexer
+symbol = P.symbol lexer
+
+sourceForPackageParser :: CharParser () (Map PackageIdentifier [FilePath])
+sourceForPackageParser = do
+ whiteSpace
+ ls <- many onePackageParser
+ whiteSpace
+ eof
+ return (Map.fromList (catMaybes ls))
+ <?> "sourceForPackageParser"
+
+onePackageParser :: CharParser () (Maybe (PackageIdentifier,[FilePath]))
+onePackageParser = do
+ mbPd <- packageDescriptionParser
+ filePaths <- many filePathParser
+ case mbPd of
+ Nothing -> return Nothing
+ Just pd -> return (Just (pd,filePaths))
+ <?> "onePackageParser"
+
+packageDescriptionParser :: CharParser () (Maybe PackageIdentifier)
+packageDescriptionParser = try (do
+ whiteSpace
+ str <- many (noneOf ":")
+ char ':'
+ return (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
+