leksah-server 0.14.3.2 → 0.15.0.1
raw patch · 19 files changed
+529/−427 lines, 19 filesdep +bin-package-dbdep +haddock-librarydep ~Cabaldep ~attoparsecdep ~basenew-component:exe:leksahtruePVP ok
version bump matches the API change (PVP)
Dependencies added: bin-package-db, haddock-library
Dependency ranges changed: Cabal, attoparsec, base, deepseq, filepath, ghc, haddock-api, leksah-server, ltk, time
API changes (from Hackage documentation)
+ IDE.Core.CTypes: PackageIdAndKey :: PackageIdentifier -> PackageIdAndKey
+ IDE.Core.CTypes: data PackageIdAndKey
+ IDE.Core.CTypes: packId :: PackageIdAndKey -> PackageIdentifier
- IDE.Core.CTypes: getThisPackage :: PackageConfig -> PackageIdentifier
+ IDE.Core.CTypes: getThisPackage :: PackageConfig -> PackageIdAndKey
Files
- data/prefscoll.lkshp +6/−6
- leksah-server.cabal +61/−60
- src/IDE/Core/CTypes.hs +26/−6
- src/IDE/Core/Serializable.hs +2/−1
- src/IDE/HeaderParser.hs +22/−10
- src/IDE/Metainfo/Collector.hs +4/−3
- src/IDE/Metainfo/InterfaceCollector.hs +69/−25
- src/IDE/Metainfo/PackageCollector.hs +29/−147
- src/IDE/Metainfo/SourceCollectorH.hs +81/−37
- src/IDE/Metainfo/SourceDB.hs +4/−3
- src/IDE/Metainfo/WorkspaceCollector.hs +113/−55
- src/IDE/StrippedPrefs.hs +2/−2
- src/IDE/Utils/FileUtils.hs +15/−12
- src/IDE/Utils/GHCUtils.hs +27/−17
- src/IDE/Utils/Server.hs +33/−33
- src/IDE/Utils/Tool.hs +6/−3
- src/IDE/Utils/VersionUtils.hs +7/−6
- src/LeksahEcho.hs +2/−1
- src/LeksahTrue.hs +20/−0
data/prefscoll.lkshp view
@@ -1,12 +1,12 @@ Paths under which haskell sources for packages may be found: []-Maybe a directory for unpacking cabal packages:- Just "~/.leksah-0.13/packageSources"-An URL to load prebuild metadata:+Unpack source for cabal packages to:+ Just "~/.leksah-0.15/packageSources"+URL from which to download prebuilt metadata: "http://www.leksah.org"-A strategy for downloading prebuild metadata:+Strategy for downloading prebuilt metadata: RetrieveThenBuild-Port number for server connection:+Port number for leksah to comunicate with leksah-server: 11111-End the server with last connection:+Stop the leksah-server process when leksah disconnects: True
leksah-server.cabal view
@@ -1,5 +1,5 @@ name: leksah-server-version: 0.14.3.2+version: 0.15.0.1 cabal-version: >= 1.10.2 build-type: Simple license: GPL@@ -19,6 +19,10 @@ data-files: data/prefscoll.lkshp +source-repository head+ type: git+ location: https://github.com/leksah/leksah-server+ flag threaded default: True description: Build with support for multithreaded execution@@ -29,33 +33,36 @@ library default-language: Haskell98- build-depends: Cabal >=1.10.2.0 && <1.22, base >= 4.0.0.0 && <4.8, binary >=0.5.0.0 && <0.8,+ build-depends: Cabal >=1.10.2.0 && <1.23, base >= 4.0.0.0 && <4.9, binary >=0.5.0.0 && <0.8, binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.11, containers >=0.2.0.0 && <0.6, executable-path >=0.0.3 && <0.1,- directory >=1.0.0.2 && <1.3, filepath >=1.1.0.1 && <1.4, ghc >=7.0.4 && <7.9,- ltk >=0.14.0.0 && <0.15, parsec >=2.1.0.1 && <3.2,- pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.5, deepseq >=1.1 && <1.4,+ directory >=1.0.0.2 && <1.3, filepath >=1.1.0.1 && <1.5, ghc >=7.0.4 && <7.11,+ ltk >=0.15.0.1 && <0.16, parsec >=2.1.0.1 && <3.2,+ pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.6, deepseq >=1.1 && <1.5, hslogger >= 1.0.7 && <1.3, conduit >= 1.0.8 && <1.3, conduit-extra >=1.0.0.1 && <1.2, resourcet,- attoparsec-conduit >=1.0.1.2 && <1.2, attoparsec >=0.10.0.3 && <0.13,+ attoparsec-conduit >=1.0.1.2 && <1.2, attoparsec >=0.10.0.3 && <0.14, transformers >=0.2.2.0 && <0.5, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.3, HTTP >=4000.1.2 && <4000.3- if (impl(ghc >= 7.8))- build-depends: haddock-api >= 2.7.2 && <2.16+ if (impl(ghc >= 7.10))+ build-depends: haddock-api >=2.16 && <2.17, haddock-library >=1.2.0 && <1.3, bin-package-db else- if (impl(ghc >= 7.6))- build-depends: haddock >= 2.7.2 && <2.14+ if (impl(ghc >= 7.8))+ build-depends: haddock-api >= 2.7.2 && <2.16 else- if (impl(ghc >= 7.4.2))- build-depends: haddock >= 2.11.1 && <2.12- else- if (impl(ghc >= 7.4))- build-depends: haddock >= 2.7.2 && <2.11+ if (impl(ghc >= 7.6))+ build-depends: haddock >= 2.7.2 && <2.14 else- if (impl(ghc >= 7.2))- build-depends: haddock >= 2.7.2 && <2.10- else- build-depends: haddock >= 2.7.2 && <2.9.3+ if (impl(ghc >= 7.4.2))+ build-depends: haddock >= 2.11.1 && <2.12+ else+ if (impl(ghc >= 7.4))+ build-depends: haddock >= 2.7.2 && <2.11+ else+ if (impl(ghc >= 7.2))+ build-depends: haddock >= 2.7.2 && <2.10+ else+ build-depends: haddock >= 2.7.2 && <2.9.3 if (impl(ghc >= 7.2)) build-depends: process >= 1.1 && <1.3@@ -84,41 +91,40 @@ IDE.Metainfo.WorkspaceCollector IDE.Metainfo.InterfaceCollector IDE.Metainfo.SourceCollectorH IDE.Metainfo.SourceDB Paths_leksah_server- if (impl(ghc >= 6.12))- ghc-options: -O2 -Wall -fno-warn-unused-do-bind -ferror-spans- else- ghc-options: -O2 -Wall -ferror-spans- ghc-prof-options: -auto-all -prof+ ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans executable leksah-server default-language: Haskell98- build-depends: Cabal >=1.10.2.0 && <1.22, base >= 4.0.0.0 && <4.8, binary >=0.5.0.0 && <0.8,+ build-depends: Cabal >=1.10.2.0 && <1.23, base >= 4.0.0.0 && <4.9, binary >=0.5.0.0 && <0.8, binary-shared >=0.8 && <0.9, bytestring >=0.9.0.1 && <0.11, containers >=0.2.0.0 && <0.6, executable-path >=0.0.3 && <0.1,- directory >=1.0.0.2 && <1.3, filepath >=1.1.0.1 && <1.6, ghc >=7.0.4 && <7.9,- ltk >=0.14.0.0 && <0.15, parsec >=2.1.0.1 && <3.2,- pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.5, deepseq >=1.1 && <1.4,+ directory >=1.0.0.2 && <1.3, filepath >=1.1.0.1 && <1.5, ghc >=7.0.4 && <7.11,+ ltk >=0.15.0.1 && <0.16, parsec >=2.1.0.1 && <3.2,+ pretty >=1.0.1.0 && <1.2, time >=1.1 && <1.6, deepseq >=1.1 && <1.5, hslogger >= 1.0.7 && <1.3, conduit >= 1.0.8 && <1.3, conduit-extra >=1.0.0.1 && <1.2, resourcet,- attoparsec-conduit >=1.0.1.2 && <1.2, attoparsec >=0.10.0.3 && <0.13,+ attoparsec-conduit >=1.0.1.2 && <1.2, attoparsec >=0.10.0.3 && <0.14, transformers >=0.2.2.0 && <0.5, strict >=0.3.2 && <0.4, text >=0.11.3.1 && <1.3, HTTP >=4000.1.2 && <4000.3- if (impl(ghc >= 7.8))- build-depends: haddock-api >= 2.7.2 && <2.16+ if (impl(ghc >= 7.10))+ build-depends: haddock-api >=2.16 && <2.17, haddock-library >=1.2.0 && <1.3, bin-package-db else- if (impl(ghc >= 7.6))- build-depends: haddock >= 2.7.2 && <2.14+ if (impl(ghc >= 7.8))+ build-depends: haddock-api >= 2.7.2 && <2.16 else- if (impl(ghc >= 7.4.2))- build-depends: haddock >= 2.11.1 && <2.12- else- if (impl(ghc >= 7.4))- build-depends: haddock >= 2.7.2 && <2.11+ if (impl(ghc >= 7.6))+ build-depends: haddock >= 2.7.2 && <2.14 else- if (impl(ghc >= 7.2))- build-depends: haddock >= 2.7.2 && <2.10- else- build-depends: haddock >= 2.7.2 && <2.9.3+ if (impl(ghc >= 7.4.2))+ build-depends: haddock >= 2.11.1 && <2.12+ else+ if (impl(ghc >= 7.4))+ build-depends: haddock >= 2.7.2 && <2.11+ else+ if (impl(ghc >= 7.2))+ build-depends: haddock >= 2.7.2 && <2.10+ else+ build-depends: haddock >= 2.7.2 && <2.9.3 if (impl(ghc >= 7.2)) build-depends: process >= 1.1 && <1.3@@ -152,14 +158,7 @@ if flag(threaded) ghc-options: -threaded - if impl(ghc >= 7.0)- ghc-options: -rtsopts-- if impl(ghc >= 6.12)- ghc-options: -O2 -Wall -fno-warn-unused-do-bind -ferror-spans- else- ghc-options: -O2 -Wall -ferror-spans- ghc-prof-options: -auto-all -prof+ ghc-options: -rtsopts -Wall -fno-warn-unused-do-bind -ferror-spans executable leksahecho default-language: Haskell98@@ -167,12 +166,10 @@ buildable: True default-extensions: CPP hs-source-dirs: src- ghc-prof-options: -auto-all -prof--- ghc-shared-options: -auto-all -prof- build-depends: base >= 4.0.0.0 && <4.8, hslogger >= 1.0.7 && <1.3, deepseq >=1.1 && <1.4,+ build-depends: base >= 4.0.0.0 && <4.9, hslogger >= 1.0.7 && <1.3, deepseq >=1.1 && <1.5, bytestring >=0.9.0.1 && <0.11, conduit >= 1.0.8 && <1.3, conduit-extra >=1.0.0.1 && <1.2, resourcet,- attoparsec-conduit >=1.0.1.2 && <1.2, attoparsec >=0.10.0.3 && <0.13,+ attoparsec-conduit >=1.0.1.2 && <1.2, attoparsec >=0.10.0.3 && <0.14, transformers >=0.2.2.0 && <0.5, text >=0.11.3.1 && <1.3 if (impl(ghc >= 7.2))@@ -183,18 +180,22 @@ if flag(threaded) ghc-options: -threaded - if (impl(ghc >= 6.12))- ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans- else- ghc-options: -Wall -ferror-spans+ ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans +executable leksahtrue+ default-language: Haskell98+ main-is: LeksahTrue.hs+ buildable: True+ hs-source-dirs: src+ build-depends: base >= 4.0.0.0 && <4.9+ test-suite test-tool default-language: Haskell98 type: exitcode-stdio-1.0 hs-source-dirs: tests main-is: TestTool.hs- build-depends: base >= 4.0.0.0 && <4.8, hslogger >= 1.0.7 && <1.3,- leksah-server == 0.14.3.2,+ build-depends: base >= 4.0.0.0 && <4.9, hslogger >= 1.0.7 && <1.3,+ leksah-server == 0.15.0.1, HUnit >=1.2 && <1.3, transformers >=0.2.2.0 && <0.5, conduit >= 1.0.8 && <1.3, conduit-extra >=1.0.0.1 && <1.2, resourcet
src/IDE/Core/CTypes.hs view
@@ -63,6 +63,7 @@ , ImportSpec(..) , getThisPackage+, PackageIdAndKey(..) , RetrieveStrategy(..) ) where@@ -91,7 +92,13 @@ import Data.Char (isAlpha) import Control.DeepSeq (NFData(..)) import PackageConfig (PackageConfig)+#if MIN_VERSION_ghc(7,10,0)+import Module (PackageKey)+import PackageConfig (sourcePackageIdString, packageKey)+import Data.Maybe (fromJust)+#else import qualified Distribution.InstalledPackageInfo as IPI+#endif import Data.Text (Text) import Data.Monoid ((<>)) import Text.PrettyPrint (fsep, Doc, (<+>), empty, text)@@ -107,15 +114,28 @@ -- leksahVersion, configDirName :: FilePath-leksahVersion = "0.14"+leksahVersion = "0.15" configDirName = ".leksah-" <> leksahVersion metadataVersion :: Integer metadataVersion = 7 -getThisPackage :: PackageConfig -> PackageIdentifier-getThisPackage = IPI.sourcePackageId+data PackageIdAndKey = PackageIdAndKey {+ packId :: PackageIdentifier+#if MIN_VERSION_ghc(7,10,0)+ , packKey :: PackageKey+#endif+ } +getThisPackage :: PackageConfig -> PackageIdAndKey+getThisPackage p = PackageIdAndKey+#if MIN_VERSION_ghc(7,10,0)+ (fromJust . simpleParse $ sourcePackageIdString p)+ (packageKey p)+#else+ (IPI.sourcePackageId p)+#endif+ data RetrieveStrategy = RetrieveThenBuild | BuildThenRetrieve | NeverRetrieve deriving (Show, Read, Eq, Ord, Enum, Bounded) @@ -474,8 +494,8 @@ pretty (IAbs name) = pretty name pretty (IThingAll name) = pretty name <> text "(..)" pretty (IThingWith name nameList) =- pretty name <> (parenList (map (pretty.VName) nameList))- + pretty name <> (parenList (map (pretty.VName) nameList))+ instance Pretty VName where pretty (VName t) = let str = T.unpack t in if isOperator str then PP.parens (PP.text str) else PP.text str @@ -486,7 +506,7 @@ 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 +isOperator _ = False -- --------------------------------------------------------------------- -- NFData instances for forcing evaluation
src/IDE/Core/Serializable.hs view
@@ -25,6 +25,8 @@ ) where +import Control.Applicative+import Prelude import Distribution.Text (simpleParse,display) import Control.Monad (liftM) import Data.Maybe (fromJust)@@ -34,7 +36,6 @@ import Distribution.ModuleName (ModuleName) import IDE.Core.CTypes-import Control.Applicative ((<$>)) import Data.Text (Text) import qualified Data.Text as T (pack, unpack) #if !MIN_VERSION_ghc(7,7,0)
src/IDE/HeaderParser.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE CPP, OverloadedStrings #-} ----------------------------------------------------------------------------- -- -- Module : IDE.HeaderParser@@ -19,6 +19,7 @@ ) where +import Control.Applicative import Prelude hiding (readFile) import IDE.Core.CTypes hiding(SrcSpan(..)) import GHC hiding (ImportDecl)@@ -39,7 +40,6 @@ import Control.Monad.IO.Class (MonadIO(..)) import System.IO.Strict (readFile) import qualified Data.Text as T (pack)-import Control.Applicative ((<$>)) #if !MIN_VERSION_ghc(7,6,0) showSDoc :: DynFlags -> O.SDoc -> String@@ -48,6 +48,14 @@ showSDocUnqual _ = O.showSDocUnqual #endif +#if MIN_VERSION_ghc(7,10,0)+unLoc710 :: GenLocated l e -> e+unLoc710 = unLoc+#else+unLoc710 :: a -> a+unLoc710 = id+#endif+ showRdrName :: DynFlags -> RdrName -> String showRdrName dflags r = showSDoc dflags (ppr r) @@ -55,19 +63,23 @@ parseTheHeader filePath = do text <- readFile filePath opts <- figureOutHaddockOpts- parseResult <- liftIO $ myParseHeader filePath text opts+ parseResult <- liftIO $ myParseHeader filePath text (filterOpts 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+ Just list -> (foldl (\ a b -> max a (srcSpanEndLine' (getLoc b))) 0 (unLoc710 list)) + 1 Nothing -> case hsmodName pr of Nothing -> 0 Just mn -> srcSpanEndLine' (getLoc mn) + 2 return (ServerHeader (Right i)) Right (dflags, _pr@HsModule{ hsmodImports = imports }) -> return (ServerHeader (Left (transformImports dflags imports)))+ where+ filterOpts [] = []+ filterOpts (o:_:r) | o `elem` ["-link-js-lib", "-js-lib-outputdir", "-js-lib-src", "-package-id"] = filterOpts r+ filterOpts (o:r) = o:filterOpts r transformImports :: DynFlags -> [LImportDecl RdrName] -> [ImportDecl] transformImports dflags = map (transformImport dflags)@@ -92,18 +104,18 @@ Just mn -> Just (moduleNameString mn) specs = case ideclHiding importDecl of Nothing -> Nothing- Just (hide, list) -> Just (ImportSpecList hide (mapMaybe (transformEntity dflags) list))+ Just (hide, list) -> Just (ImportSpecList hide (mapMaybe (transformEntity dflags) (unLoc710 list))) transformEntity :: DynFlags -> LIE RdrName -> Maybe ImportSpec #if MIN_VERSION_ghc(7,2,0)-transformEntity dflags (L _ (IEVar name)) = Just (IVar (T.pack $ showSDoc dflags (pprPrefixOcc name)))+transformEntity dflags (L _ (IEVar name)) = Just (IVar (T.pack $ showSDoc dflags (pprPrefixOcc $ unLoc710 name))) #else transformEntity dflags (L _ (IEVar name)) = Just (IVar (T.pack $ showSDoc dflags (pprHsVar name))) #endif-transformEntity dflags (L _ (IEThingAbs name)) = Just (IAbs (T.pack $ showRdrName dflags name))-transformEntity dflags (L _ (IEThingAll name)) = Just (IThingAll (T.pack $ showRdrName dflags name)) -transformEntity dflags (L _ (IEThingWith name list)) = Just (IThingWith (T.pack $ showRdrName dflags name)- (map (T.pack . showRdrName dflags) list)) +transformEntity dflags (L _ (IEThingAbs name)) = Just (IAbs (T.pack . showRdrName dflags $ unLoc710 name))+transformEntity dflags (L _ (IEThingAll name)) = Just (IThingAll (T.pack . showRdrName dflags $ unLoc710 name))+transformEntity dflags (L _ (IEThingWith name list)) = Just (IThingWith (T.pack . showRdrName dflags $ unLoc710 name)+ (map (T.pack . showRdrName dflags . unLoc710) list)) transformEntity _ _ = Nothing #if MIN_VERSION_ghc(7,2,0)
src/IDE/Metainfo/Collector.hs view
@@ -20,6 +20,8 @@ , collectPackage ) where +import Control.Applicative+import Prelude import System.Console.GetOpt (ArgDescr(..), usageInfo, ArgOrder(..), getOpt, OptDescr(..)) import System.Environment (getArgs)@@ -64,7 +66,6 @@ import Control.Monad.IO.Class (MonadIO(..)) import qualified Data.Text as T (strip, pack, unpack) import Data.Text (Text)-import Control.Applicative ((<$>)) import Data.Monoid ((<>)) -- --------------------------------------------------------------------@@ -277,8 +278,8 @@ 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)+ debugM "leksah-server" $ "collectSystem packageInfos= " ++ show (map (packId . getThisPackage) packageInfos)+ let newPackages = filter (\pid -> not $Set.member (packageIdentifierToString . packId $ getThisPackage pid) knownPackages) packageInfos if null newPackages
src/IDE/Metainfo/InterfaceCollector.hs view
@@ -21,7 +21,11 @@ ) where import MyMissing (nonEmptyLines)-import Module hiding (PackageId,ModuleName)+#if MIN_VERSION_ghc(7,10,0)+import Module hiding (PackageKey, ModuleName)+#else+import Module hiding (PackageId, ModuleName)+#endif import qualified Module as Module (ModuleName) import qualified Maybes as M import DynFlags (DynFlags)@@ -48,14 +52,19 @@ import FastString import Name import PrelNames-import PackageConfig (PackageConfig, mkPackageId)+import PackageConfig (PackageConfig) 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)+#if MIN_VERSION_ghc(7,10,0)+import GHC.PackageDb (exposedModules, hiddenModules, exposedName)+#else+import PackageConfig (mkPackageId) import qualified Distribution.InstalledPackageInfo as IPI+#endif import Distribution.Package hiding (PackageId) import Distribution.ModuleName import Distribution.Text (simpleParse)@@ -68,6 +77,7 @@ import Control.DeepSeq(deepseq) import Data.Text (Text) import qualified Data.Text as T (pack)+import System.Log.Logger (debugM) #if !MIN_VERSION_ghc(7,6,0) showSDoc :: DynFlags -> SDoc -> Text@@ -78,23 +88,40 @@ collectPackageFromHI :: PackageConfig -> IO PackageDescr collectPackageFromHI packageConfig = inGhcIO [] [] $ \ dflags -> do+ let pIdAndKey = getThisPackage packageConfig+ Hs.liftIO . debugM "leksah-server" $ "collectPackageFromHI" session <- getSession- exportedIfaceInfos <- getIFaceInfos (getThisPackage packageConfig)+ exportedIfaceInfos <- getIFaceInfos pIdAndKey+#if MIN_VERSION_ghc(7,10,0)+ (map exposedName $ exposedModules packageConfig) session+#else (IPI.exposedModules packageConfig) session- hiddenIfaceInfos <- getIFaceInfos (getThisPackage packageConfig)+#endif+ hiddenIfaceInfos <- getIFaceInfos pIdAndKey+#if MIN_VERSION_ghc(7,10,0)+ (hiddenModules packageConfig) session+#else (IPI.hiddenModules packageConfig) session- let pd = extractInfo dflags exportedIfaceInfos hiddenIfaceInfos (getThisPackage packageConfig)+#endif+ let pd = extractInfo dflags exportedIfaceInfos hiddenIfaceInfos pIdAndKey [] -- TODO 6.12 (IPI.depends $ packageConfigToInstalledPackageInfo packageConfig)) 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+getIFaceInfos :: PackageIdAndKey -> [Module.ModuleName] -> HscEnv -> Ghc [(ModIface, FilePath)]+getIFaceInfos p modules _session = do+ let pid = packId p+ makeMod = mkModule+#if MIN_VERSION_ghc(7,10,0)+ (packKey p)+#else+ (mkPackageId pid)+#endif+ isBase = pkgName pid == (PackageName "base")+ ifaces = mapM (\ mn -> findAndReadIface empty (if isBase then mkBaseModule_ mn- else mkModule (mkPackageId pid) mn)+ else makeMod mn) False) modules hscEnv <- getSession let gblEnv = IfGblEnv { if_rec_types = Nothing }@@ -107,19 +134,19 @@ ------------------------------------------------------------------------- -extractInfo :: DynFlags -> [(ModIface, FilePath)] -> [(ModIface, FilePath)] -> PackageIdentifier ->+extractInfo :: DynFlags -> [(ModIface, FilePath)] -> [(ModIface, FilePath)] -> PackageIdAndKey -> [PackageIdentifier] -> PackageDescr extractInfo dflags ifacesExp ifacesHid pid buildDepends = let allDescrs = concatMap (extractExportedDescrH dflags pid) (map fst (ifacesHid ++ ifacesExp)) mods = map (extractExportedDescrR dflags pid allDescrs) (map fst ifacesExp) in PackageDescr {- pdPackage = pid+ pdPackage = packId pid , pdModules = mods , pdBuildDepends = buildDepends , pdMbSourcePath = Nothing} -extractExportedDescrH :: DynFlags -> PackageIdentifier -> ModIface -> [Descr]+extractExportedDescrH :: DynFlags -> PackageIdAndKey -> ModIface -> [Descr] extractExportedDescrH dflags pid iface = let mid = (fromJust . simpleParse . moduleNameString . moduleName) (mi_module iface) exportedNames = Set.fromList@@ -139,7 +166,7 @@ extractExportedDescrR :: DynFlags- -> PackageIdentifier+ -> PackageIdAndKey -> [Descr] -> ModIface -> ModuleDescr@@ -160,20 +187,20 @@ (map snd (mi_decls iface)) ownDecls = concatMap (extractIdentifierDescr dflags pid [mid]) exportedDecls otherDecls = exportedNames `Set.difference` (Set.fromList (map dscName ownDecls))- reexported = map (\d -> Reexported (ReexportedDescr (Just (PM pid mid)) d))+ reexported = map (\d -> Reexported (ReexportedDescr (Just (PM (packId pid) mid)) d)) $ filter (\k -> (dscName k) `Set.member` otherDecls) hidden- inst = concatMap (extractInstances dflags (PM pid mid)) (mi_insts iface)+ inst = concatMap (extractInstances dflags (PM (packId pid) mid)) (mi_insts iface) uses = Map.fromList . catMaybes $ map (extractUsages dflags) (mi_usages iface) declsWithExp = map withExp ownDecls withExp (Real d) = Real $ d{dscExported' = Set.member (dscName' d) exportedNames} withExp _ = error "Unexpected Reexported" in ModuleDescr {- mdModuleId = PM pid mid+ mdModuleId = PM (packId pid) mid , mdMbSourcePath = Nothing , mdReferences = uses , mdIdDescriptions = declsWithExp ++ inst ++ reexported} -extractIdentifierDescr :: DynFlags -> PackageIdentifier -> [ModuleName] -> IfaceDecl -> [Descr]+extractIdentifierDescr :: DynFlags -> PackageIdAndKey -> [ModuleName] -> IfaceDecl -> [Descr] extractIdentifierDescr dflags package modules decl = if null modules then []@@ -181,7 +208,7 @@ let descr = RealDescr{ dscName' = T.pack . unpackFS . occNameFS $ ifName decl , dscMbTypeStr' = Just . BS.pack . unlines . nonEmptyLines . filterExtras . showSDocUnqual dflags $ ppr decl- , dscMbModu' = Just (PM package (last modules))+ , dscMbModu' = Just (PM (packId package) (last modules)) , dscMbLocation' = Nothing , dscMbComment' = Nothing , dscTypeHint' = VariableDescr@@ -230,14 +257,21 @@ classOpsID = map (extractClassOp dflags) ifSigs' superclasses = extractSuperClassNames context in [Real $ descr{dscTypeHint' = ClassDescr superclasses classOpsID}]- (IfaceSyn {})- -> [Real $ descr{dscTypeHint' = TypeDescr}] #if MIN_VERSION_ghc(7,6,0) (IfaceAxiom {}) -> [Real $ descr] #endif+#if MIN_VERSION_ghc(7,10,0)+ (IfaceSynonym {})+ -> [Real $ descr{dscTypeHint' = TypeDescr}]+ (IfaceFamily {})+ -> [Real $ descr{dscTypeHint' = TypeDescr}]+#else+ (IfaceSyn {})+ -> [Real $ descr{dscTypeHint' = TypeDescr}] (IfaceForeign {}) -> [Real $ descr]+#endif #if MIN_VERSION_ghc(7,8,0) (IfacePatSyn {}) -> [Real $ descr]@@ -246,21 +280,31 @@ extractConstructors :: DynFlags -> OccName -> [IfaceConDecl] -> [SimpleDescr] extractConstructors dflags name decls = map (\decl -> SimpleDescr (T.pack . unpackFS $occNameFS (ifConOcc decl)) (Just (BS.pack $ filterExtras $ showSDocUnqual dflags $+#if MIN_VERSION_ghc(7,10,0)+ pprIfaceForAllPart (ifConExTvs decl)+#else pprIfaceForAllPart (ifConUnivTvs decl ++ ifConExTvs decl)+#endif (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"+ (t:ts) -> fsep (t : map (arrow <+>) ts)+ [] -> panic "pp_con_taus"+#if MIN_VERSION_ghc(7,10,0)+ pp_res_ty _decl = ppr name <+> fsep [] -- TODO figure out what to do here+#else pp_res_ty decl = ppr name <+> fsep [ppr tv | (tv,_) <- ifConUnivTvs decl]-#if MIN_VERSION_ghc(7,3,0)+#endif+#if MIN_VERSION_ghc(7,10,0)+ eq_ctxt decl = [IfaceTyConApp (IfaceTc eqTyConName) (ITC_Type (IfaceTyVar tv) (ITC_Type ty ITC_Nil))+#elif MIN_VERSION_ghc(7,3,0) eq_ctxt decl = [IfaceTyConApp (IfaceTc eqTyConName) [(IfaceTyVar (occNameFS tv)), ty] #else eq_ctxt decl = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) #endif- | (tv,ty) <- ifConEqSpec decl]+ | (tv,ty) <- ifConEqSpec decl] extractFields :: DynFlags -> IfaceConDecl -> [SimpleDescr] extractFields dflags decl = map (\ (n, t) -> SimpleDescr n t Nothing Nothing True)
src/IDE/Metainfo/PackageCollector.hs view
@@ -20,6 +20,8 @@ ) where +import Control.Applicative+import Prelude import IDE.StrippedPrefs (RetrieveStrategy(..), Prefs(..)) import PackageConfig (PackageConfig) import IDE.Metainfo.SourceCollectorH@@ -31,9 +33,9 @@ ReexportedDescr(..), Descr(..), RealDescr(..), dscTypeHint, descrType, dscName, Descr, ModuleDescr(..), PackModule(..), PackageDescr(..), metadataVersion, leksahVersion,- packageIdentifierToString)+ packageIdentifierToString, packId) import IDE.Utils.FileUtils (getCollectorPath)-import System.Directory (setCurrentDirectory)+import System.Directory (doesDirectoryExist, setCurrentDirectory) import IDE.Utils.Utils (leksahMetadataPathFileExtension, leksahMetadataSystemFileExtension)@@ -49,7 +51,6 @@ import Data.Monoid ((<>)) import qualified Data.Text as T (unpack) import Data.Text (Text)-import Control.Applicative ((<$>)) import Network.HTTP.Proxy (Proxy(..), fetchProxy) import Network.Browser (request, setAuthorityGen, setOutHandler, setErrHandler, setProxy,@@ -62,16 +63,18 @@ import qualified Data.ByteString as BS (writeFile, empty) import qualified Paths_leksah_server (version) import Distribution.System (buildArch, buildOS)+import Control.Monad (unless) collectPackage :: Bool -> Prefs -> Int -> (PackageConfig,Int) -> IO PackageCollectStats collectPackage writeAscii prefs numPackages (packageConfig, packageIndex) = do infoM "leksah-server" ("update_toolbar " ++ show ((fromIntegral packageIndex / fromIntegral numPackages) :: Double))- let packageName = packageIdentifierToString (getThisPackage packageConfig)+ let packageName = packageIdentifierToString (packId $ getThisPackage packageConfig) let stat = PackageCollectStats packageName Nothing False False Nothing- eitherStrFp <- findSourceForPackage prefs packageConfig+ eitherStrFp <- findSourceForPackage prefs (packId $ getThisPackage packageConfig) case eitherStrFp of Left message -> do+ debugM "leksah-server" . T.unpack $ message <> " : " <> packageName packageDescrHi <- collectPackageFromHI packageConfig writeExtractedPackage False packageDescrHi return stat {packageString = message, modulesTotal = Just (length (pdModules packageDescrHi))}@@ -87,23 +90,23 @@ else do debugM "leksah-server" . T.unpack $ "collectPackage: Can't retreive = " <> packageName runCabalConfigure fpSource- packageDescrHi <- collectPackageFromHI packageConfig mbPackageDescrPair <- packageFromSource fpSource packageConfig case mbPackageDescrPair of (Just packageDescrS, bstat) -> do- writeMerged packageDescrS packageDescrHi fpSource packageName- return bstat{modulesTotal = Just (length (pdModules packageDescrHi))}+ writePackageDesc packageDescrS fpSource packageName+ return bstat{modulesTotal = Just (length (pdModules packageDescrS))} (Nothing,bstat) -> do+ packageDescrHi <- collectPackageFromHI packageConfig writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} BuildThenRetrieve -> do+ debugM "leksah-server" $ "Build (then retrieve) " <> T.unpack packageName <> " in " <> fpSource runCabalConfigure fpSource mbPackageDescrPair <- packageFromSource fpSource packageConfig case mbPackageDescrPair of (Just packageDescrS,bstat) -> do- packageDescrHi <- collectPackageFromHI packageConfig- writeMerged packageDescrS packageDescrHi fpSource packageName- return bstat{modulesTotal = Just (length (pdModules packageDescrHi))}+ writePackageDesc packageDescrS fpSource packageName+ return bstat{modulesTotal = Just (length (pdModules packageDescrS))} (Nothing,bstat) -> do success <- retrieve packageName if success@@ -116,14 +119,15 @@ writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} NeverRetrieve -> do+ debugM "leksah-server" $ "Build " <> T.unpack packageName <> " in " <> fpSource runCabalConfigure fpSource- packageDescrHi <- collectPackageFromHI packageConfig mbPackageDescrPair <- packageFromSource fpSource packageConfig case mbPackageDescrPair of (Just packageDescrS,bstat) -> do- writeMerged packageDescrS packageDescrHi fpSource packageName- return bstat{modulesTotal = Just (length (pdModules packageDescrHi))}+ writePackageDesc packageDescrS fpSource packageName+ return bstat{modulesTotal = Just (length (pdModules packageDescrS))} (Nothing,bstat) -> do+ packageDescrHi <- collectPackageFromHI packageConfig writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} where@@ -164,19 +168,20 @@ userAgent = concat [ "leksah-server/", display Paths_leksah_server.version , " (", display buildOS, "; ", display buildArch, ")" ]- writeMerged packageDescrS packageDescrHi fpSource packageName = do- let mergedPackageDescr = mergePackageDescrs packageDescrHi packageDescrS- liftIO $ writeExtractedPackage writeAscii mergedPackageDescr+ writePackageDesc packageDescr fpSource packageName = do+ liftIO $ writeExtractedPackage writeAscii packageDescr liftIO $ writePackagePath (dropFileName fpSource) packageName runCabalConfigure fpSource = do let dirPath = dropFileName fpSource- setCurrentDirectory dirPath- E.catch (do runTool' "cabal" ["clean"] Nothing- runTool' "cabal" ["configure","--user"] Nothing- return ())- (\ (_e :: E.SomeException) -> do- debugM "leksah-server" "Can't configure"- return ())+ distExists <- doesDirectoryExist $ dirPath </> "dist"+ unless distExists $ do+ setCurrentDirectory dirPath+ E.catch (do runTool' "cabal" ["clean"] Nothing+ runTool' "cabal" ["configure","--user"] Nothing+ return ())+ (\ (_e :: E.SomeException) -> do+ debugM "leksah-server" "Can't configure"+ return ()) writeExtractedPackage :: MonadIO m => Bool -> PackageDescr -> m () writeExtractedPackage writeAscii pd = do@@ -192,127 +197,4 @@ collectorPath <- liftIO $ getCollectorPath let filePath = collectorPath </> T.unpack packageName <.> leksahMetadataPathFileExtension liftIO $ writeFile filePath fp----------------Merging of .hi and .hs parsing / parsing and typechecking results--mergePackageDescrs :: PackageDescr -> PackageDescr -> PackageDescr-mergePackageDescrs packageDescrHI packageDescrS = PackageDescr {- pdPackage = pdPackage packageDescrHI- , pdMbSourcePath = pdMbSourcePath packageDescrS- , pdModules = mergeModuleDescrs (pdModules packageDescrHI) (pdModules packageDescrS)- , pdBuildDepends = pdBuildDepends packageDescrHI}--mergeModuleDescrs :: [ModuleDescr] -> [ModuleDescr] -> [ModuleDescr]-mergeModuleDescrs hiList srcList = map mergeIt allNames- where- mergeIt :: String -> ModuleDescr- mergeIt str = case (Map.lookup str hiDict, Map.lookup str srcDict) of- (Just mdhi, Nothing) -> mdhi- (Nothing, Just mdsrc) -> mdsrc- (Just mdhi, Just mdsrc) -> mergeModuleDescr mdhi mdsrc- (Nothing, Nothing) -> error "Collector>>mergeModuleDescrs: impossible"- allNames = nub $ Map.keys hiDict ++ Map.keys srcDict- hiDict = Map.fromList $ zip ((map (display . modu . mdModuleId)) hiList) hiList- srcDict = Map.fromList $ zip ((map (display . modu . mdModuleId)) srcList) srcList--mergeModuleDescr :: ModuleDescr -> ModuleDescr -> ModuleDescr-mergeModuleDescr hiDescr srcDescr = ModuleDescr {- mdModuleId = mdModuleId hiDescr- , mdMbSourcePath = mdMbSourcePath srcDescr- , mdReferences = mdReferences hiDescr- , mdIdDescriptions = mergeDescrs (mdIdDescriptions hiDescr) (mdIdDescriptions srcDescr)}--mergeDescrs :: [Descr] -> [Descr] -> [Descr]-mergeDescrs hiList srcList = concatMap mergeIt allNames- where- mergeIt :: Text -> [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' rdsrc- , 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 :: Text -> SimpleDescr- mergeIt pm = case mergeMbDescr (Map.lookup pm hiDict) (Map.lookup pm srcDict) of- Just mdhi -> mdhi- Nothing -> error "Collector>>mergeSimpleDescrs: impossible"- allNames = nub $ Map.keys hiDict ++ Map.keys srcDict- hiDict = Map.fromList $ zip ((map sdName) hiList) hiList- srcDict = Map.fromList $ zip ((map sdName) srcList) srcList--mergeSimpleDescr :: SimpleDescr -> SimpleDescr -> SimpleDescr-mergeSimpleDescr sdHi sdSrc = SimpleDescr {- sdName = sdName sdHi,- sdType = sdType sdHi,- sdLocation = sdLocation sdSrc,- sdComment = sdComment sdSrc,- sdExported = sdExported sdSrc}--mergeMbDescr :: Maybe SimpleDescr -> Maybe SimpleDescr -> Maybe SimpleDescr-mergeMbDescr (Just mdhi) Nothing = Just mdhi-mergeMbDescr Nothing (Just mdsrc) = Just mdsrc-mergeMbDescr (Just mdhi) (Just mdsrc) = Just (mergeSimpleDescr mdhi mdsrc)-mergeMbDescr Nothing Nothing = Nothing---
src/IDE/Metainfo/SourceCollectorH.hs view
@@ -26,7 +26,7 @@ import IDE.Core.CTypes (getThisPackage, PackageDescr(..), TypeDescr(..), RealDescr(..), Descr(..), ModuleDescr(..), PackModule(..), SimpleDescr(..),- packageIdentifierToString, Location(..), RealDescr(..))+ packageIdentifierToString, Location(..), RealDescr(..), PackageIdAndKey(..)) #ifdef MIN_VERSION_haddock_leksah import Haddock.Types@@ -52,7 +52,12 @@ (srcSpanToLocation, uncommentDecl, uncommentData, printHsDoc, sortByLoc) import PackageConfig (PackageConfig) import Distribution.Verbosity (verbose)+#if MIN_VERSION_ghc(7,10,0)+import GHC.PackageDb (exposedModules, hiddenModules, exposedName)+import Documentation.Haddock.Types (_doc)+#else import qualified Distribution.InstalledPackageInfo as IPI+#endif import IDE.StrippedPrefs (getUnpackDirectory, Prefs(..)) import IDE.Metainfo.SourceDB (sourceForPackage, getSourcesMap) import MonadUtils (liftIO)@@ -109,10 +114,10 @@ retrieved :: Bool, mbError :: Maybe Text} -findSourceForPackage :: Prefs -> PackageConfig -> IO (Either Text FilePath)-findSourceForPackage prefs packageConfig = do+findSourceForPackage :: Prefs -> PackageIdentifier -> IO (Either Text FilePath)+findSourceForPackage prefs packageId = do sourceMap <- liftIO $ getSourcesMap prefs- case sourceForPackage (getThisPackage packageConfig) sourceMap of+ case sourceForPackage packageId sourceMap of Just fpSource -> return (Right fpSource) Nothing -> do unpackDir <- getUnpackDirectory prefs@@ -128,7 +133,7 @@ then return (Left "Failed to download and unpack source") else return (Right (fpUnpack </> packageName' </> takeWhile (/= '-') packageName' <.> "cabal")) where- packageName = packageIdentifierToString (getThisPackage packageConfig)+ packageName = packageIdentifierToString packageId packageName' = T.unpack packageName @@ -136,7 +141,7 @@ packageFromSource cabalPath packageConfig = do setCurrentDirectory dirPath ghcFlags <- figureOutGhcOpts- debugM "leksah-server" ("ghcFlags: " ++ show ghcFlags) + debugM "leksah-server" ("ghcFlags: " ++ show ghcFlags) NewException.catch (inner ghcFlags) handler where _handler' (_e :: NewException.SomeException) = do@@ -149,20 +154,24 @@ inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] $ \ dflags -> do (interfaces,_) <- processModules verbose (exportedMods ++ hiddenMods) [] [] liftIO $ print (length interfaces)- let mods = map (interfaceToModuleDescr dflags dirPath (getThisPackage packageConfig)) interfaces+ let mods = map (interfaceToModuleDescr dflags dirPath (packId $ getThisPackage packageConfig)) interfaces sp <- liftIO $ myCanonicalizePath dirPath let pd = PackageDescr {- pdPackage = getThisPackage packageConfig+ pdPackage = packId (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)+#if MIN_VERSION_ghc(7,10,0)+ exportedMods = map (moduleNameString . exposedName) $ exposedModules packageConfig+ hiddenMods = map moduleNameString $ hiddenModules packageConfig+#else exportedMods = map moduleNameString $ IPI.exposedModules packageConfig hiddenMods = map moduleNameString $ IPI.hiddenModules packageConfig+#endif dirPath = dropFileName cabalPath- packageName = packageIdentifierToString (getThisPackage packageConfig)-+ packageName = packageIdentifierToString (packId $ getThisPackage packageConfig) -- Heaven interfaceToModuleDescr :: DynFlags -> FilePath -> PackageIdentifier -> Interface -> ModuleDescr@@ -190,7 +199,11 @@ imports = Map.empty --TODO getDoc :: Documentation Name -> Maybe NDoc+#if MIN_VERSION_ghc(7,10,0)+getDoc = fmap _doc . documentationDoc+#else getDoc = documentationDoc+#endif #if MIN_VERSION_ghc(7,4,1) type DeclInfo = [LHsDecl Name]@@ -214,27 +227,30 @@ transformToDescrs :: DynFlags -> PackModule -> [(LHsDecl Name, Maybe NDoc, [(Name, Maybe NDoc)])] -> [Descr] transformToDescrs dflags pm = concatMap transformToDescr where-#if MIN_VERSION_ghc(7,2,0)- transformToDescr ((L loc (SigD (TypeSig [name] typ))), mbComment,_subCommentList) =+#if MIN_VERSION_ghc(7,10,0)+ transformToDescr ((L loc (SigD (TypeSig names typ _))), mbComment,_subCommentList) = map nameDescr names+#elif MIN_VERSION_ghc(7,2,0)+ transformToDescr ((L loc (SigD (TypeSig names typ))), mbComment,_subCommentList) = map nameDescr names #else- transformToDescr ((L loc (SigD (TypeSig name typ))), mbComment,_subCommentList) =+ transformToDescr ((L loc (SigD (TypeSig name' typ))), mbComment,_subCommentList) = [nameDescr name'] #endif- [Real $ RealDescr {- dscName' = T.pack . getOccString $ unLoc name- , dscMbTypeStr' = Just . BS.pack . showSDocUnqual dflags $ ppr typ- , dscMbModu' = Just pm- , dscMbLocation' = srcSpanToLocation loc- , dscMbComment' = toComment dflags mbComment []- , dscTypeHint' = VariableDescr- , dscExported' = True}]+ where+ nameDescr name = Real $ RealDescr {+ dscName' = T.pack . getOccString $ unLoc name+ , dscMbTypeStr' = Just . BS.pack $ getOccString (unLoc name) <> " :: " <> showSDocUnqual dflags (ppr typ)+ , dscMbModu' = Just pm+ , dscMbLocation' = srcSpanToLocation loc+ , dscMbComment' = toComment dflags mbComment []+ , dscTypeHint' = VariableDescr+ , dscExported' = True} transformToDescr ((L _loc (SigD _)), _mbComment, _subCommentList) = [] #if MIN_VERSION_ghc(7,6,0)- transformToDescr ((L loc (TyClD typ@(ForeignType {tcdLName = lid}))), mbComment,_sigList) =+ transformToDescr ((L loc for@(ForD (ForeignImport lid _ _ _))), mbComment,_sigList) = [Real $ RealDescr { dscName' = T.pack . getOccString $ unLoc lid- , dscMbTypeStr' = Just . BS.pack . showSDocUnqual dflags $ ppr typ+ , dscMbTypeStr' = Just . BS.pack . showSDocUnqual dflags $ ppr for , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment dflags mbComment []@@ -289,7 +305,7 @@ , dscExported' = True}] ++ derivings tcdDerivs' where- constructors = map (extractConstructor dflags) lConDecl+ constructors = concatMap (extractConstructor dflags) lConDecl fields = nub $ concatMap (extractRecordFields dflags) lConDecl name = getOccString (unLoc lid) derivings Nothing = []@@ -351,24 +367,36 @@ extractMethods :: DynFlags -> [LSig Name] -> [MyLDocDecl] -> [SimpleDescr] extractMethods dflags sigs docs = let pairs = attachComments' dflags sigs docs- in mapMaybe (extractMethod dflags) pairs+ in concatMap (extractMethod dflags) pairs -extractMethod :: DynFlags -> (LHsDecl Name, Maybe NDoc) -> Maybe SimpleDescr-#if MIN_VERSION_ghc(7,2,0)-extractMethod dflags ((L loc (SigD ts@(TypeSig [name] _typ))), mbDoc) =+extractMethod :: DynFlags -> (LHsDecl Name, Maybe NDoc) -> [SimpleDescr]+#if MIN_VERSION_ghc(7,10,0)+extractMethod dflags ((L loc (SigD ts@(TypeSig names _typ _))), mbDoc) = map extractName names+#elif MIN_VERSION_ghc(7,2,0)+extractMethod dflags ((L loc (SigD ts@(TypeSig names _typ))), mbDoc) = map extractName names #else-extractMethod dflags ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) =+extractMethod dflags ((L loc (SigD ts@(TypeSig name' _typ))), mbDoc) = [extractName name'] #endif- Just $ SimpleDescr+ where+ extractName name =+ SimpleDescr (T.pack . getOccString $ unLoc name) (Just . BS.pack . showSDocUnqual dflags $ ppr ts) (srcSpanToLocation loc) (toComment dflags mbDoc []) True-extractMethod _dflags (_, _mbDoc) = Nothing+extractMethod _dflags (_, _mbDoc) = [] -extractConstructor :: DynFlags -> LConDecl Name -> SimpleDescr-extractConstructor dflags decl@(L loc (ConDecl {con_name = name, con_doc = doc})) =+extractConstructor :: DynFlags -> LConDecl Name -> [SimpleDescr]+#if MIN_VERSION_ghc(7,10,0)+extractConstructor dflags decl@(L loc (ConDecl {con_names = names, con_doc = doc})) =+ map extractName names+#else+extractConstructor dflags decl@(L loc (ConDecl {con_name = name', con_doc = doc})) =+ [extractName name']+#endif+ where+ extractName name = SimpleDescr (T.pack . getOccString $ unLoc name) (Just . BS.pack . showSDocUnqual dflags . ppr $uncommentDecl decl)@@ -378,15 +406,31 @@ Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d) True +#if MIN_VERSION_ghc(7,10,0)+unLoc710 :: GenLocated l e -> e+unLoc710 = unLoc+#else+unLoc710 :: a -> a+unLoc710 = id+#endif+ extractRecordFields :: DynFlags -> LConDecl Name -> [SimpleDescr] extractRecordFields dflags (L _ _decl@(ConDecl {con_details=(RecCon flds)})) =- map extractRecordFields' flds+ concatMap extractRecordFields' (unLoc710 flds) where- extractRecordFields' _field@(ConDeclField (L loc name) typ doc) =+#if MIN_VERSION_ghc(7,10,0)+ extractRecordFields' :: LConDeclField Name -> [SimpleDescr]+ extractRecordFields' (L _ _field@(ConDeclField names typ doc)) = map extractName names+#else+ extractRecordFields' :: ConDeclField Name -> [SimpleDescr]+ extractRecordFields' _field@(ConDeclField name' typ doc) = [extractName name']+#endif+ where+ extractName name = SimpleDescr- (T.pack $ getOccString name)+ (T.pack . getOccString $ unLoc name) (Just (BS.pack (showSDocUnqual dflags $ ppr typ)))- (srcSpanToLocation loc)+ (srcSpanToLocation $ getLoc name) (case doc of Nothing -> Nothing Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d)
src/IDE/Metainfo/SourceDB.hs view
@@ -25,6 +25,8 @@ ) where +import Control.Applicative+import Prelude import IDE.StrippedPrefs (getUnpackDirectory, getSourceDirectories, Prefs(..)) import Data.Map (Map)@@ -40,8 +42,8 @@ import qualified Text.PrettyPrint as PP (colon, (<>), text, ($$), vcat, Doc, render, char) import Text.ParserCombinators.Parsec- (try, char, unexpected, noneOf, eof, many, CharParser,- Parser, (<?>), (<|>))+ (try, char, unexpected, noneOf, eof, CharParser,+ Parser, (<?>)) import Text.ParserCombinators.Parsec.Prim (parse) import Text.ParserCombinators.Parsec.Error (ParseError) import Text.ParserCombinators.Parsec.Language (emptyDef)@@ -65,7 +67,6 @@ import System.Directory (doesDirectoryExist) import Data.Text (Text) import qualified Data.Text as T (unpack, pack)-import Control.Applicative ((<$>)) import Data.Monoid ((<>)) -- ---------------------------------------------------------------------
src/IDE/Metainfo/WorkspaceCollector.hs view
@@ -30,9 +30,16 @@ ) where +import Control.Applicative hiding(empty)+import Prelude import IDE.Utils.Utils import IDE.Utils.GHCUtils+#if MIN_VERSION_ghc(7,10,0)+import GHC hiding(Id,Failed,Succeeded,ModuleName,PackageKey)+#else import GHC hiding(Id,Failed,Succeeded,ModuleName)+import PackageConfig (mkPackageId)+#endif #if !MIN_VERSION_ghc(7,2,0) import HscTypes hiding (liftIO) #endif@@ -70,8 +77,7 @@ import qualified Maybes as M import IDE.Metainfo.InterfaceCollector import Data.Maybe- (isJust, catMaybes, mapMaybe, isNothing)-import Module (stringToPackageId)+ (isJust, catMaybes, isNothing) import PrelNames import System.Log.Logger import Control.DeepSeq (deepseq)@@ -79,10 +85,8 @@ import Control.Monad.IO.Class (MonadIO, MonadIO(..)) import Control.Monad (when) import Control.Exception as E-import Control.Applicative ((<$>), (<|>))-import Debug.Trace (trace) import Data.Text (Text)-import qualified Data.Text as T (intercalate, words, unpack, pack)+import qualified Data.Text as T import Data.Monoid ((<>)) type NDecl = LHsDecl RdrName@@ -111,25 +115,30 @@ -- | Test collectWorkspace :: PackageIdentifier -> [(Text,FilePath)] -> Bool -> Bool -> FilePath -> IO()-collectWorkspace packId moduleList forceRebuild writeAscii dir = do+collectWorkspace pid moduleList forceRebuild writeAscii dir = do debugM "leksah-server" $ "collectWorkspace called with modules " ++ show moduleList ++ " in folder " ++ dir collectorPath <- liftIO $ getCollectorPath- let packageCollectorPath = collectorPath </> T.unpack (packageIdentifierToString packId)+ let packageCollectorPath = collectorPath </> T.unpack (packageIdentifierToString pid) when forceRebuild $ do exists <- doesDirectoryExist packageCollectorPath when exists $ removeDirectoryRecursive packageCollectorPath -- Construct directory liftIO $ createDirectoryIfMissing True packageCollectorPath setCurrentDirectory dir- opts1 <- figureOutGhcOpts+ opts1 <- filterOpts <$> figureOutGhcOpts opts2 <- figureOutHaddockOpts debugM "leksah-server" $ ("before collect modules" ++ "\n\nopts1: " ++ show opts1 ++ "\n\n opt2: " ++ show opts2)- mapM_ (collectModule packageCollectorPath writeAscii packId opts1) moduleList+ mapM_ (collectModule packageCollectorPath writeAscii pid opts1) moduleList debugM "leksah-server" $ "after collect modules"+ where+ filterOpts :: [Text] -> [Text]+ filterOpts [] = []+ filterOpts (o:_:r) | o `elem` ["-link-js-lib", "-js-lib-outputdir", "-js-lib-src", "-package-id"] = filterOpts r+ filterOpts (o:r) = o:filterOpts r collectModule :: FilePath -> Bool -> PackageIdentifier -> [Text] -> (Text,FilePath) -> IO()-collectModule collectorPackagePath writeAscii packId opts (modId,sourcePath) = do+collectModule collectorPackagePath writeAscii pid opts (modId,sourcePath) = do existCollectorFile <- doesFileExist collectorModulePath existSourceFile <- doesFileExist sourcePath case mbModuleName of@@ -138,12 +147,12 @@ if existSourceFile then do if not existCollectorFile- then collectModule' sourcePath collectorModulePath writeAscii packId opts moduleName'+ then collectModule' sourcePath collectorModulePath writeAscii pid opts moduleName' else do sourceModTime <- getModificationTime sourcePath collModTime <- getModificationTime collectorModulePath if sourceModTime > collModTime- then collectModule' sourcePath collectorModulePath writeAscii packId+ then collectModule' sourcePath collectorModulePath writeAscii pid opts moduleName' else return () else errorM "leksah-server" ("source file not found " ++ sourcePath)@@ -153,7 +162,7 @@ collectModule' :: FilePath -> FilePath -> Bool -> PackageIdentifier -> [Text] -> ModuleName -> IO()-collectModule' sourcePath destPath writeAscii packId opts moduleName' = gcatch (+collectModule' sourcePath destPath writeAscii pid opts moduleName' = gcatch ( inGhcIO (opts++["-cpp"]) [Opt_Haddock] $ \ dynFlags -> do session <- getSession #if MIN_VERSION_ghc(7,2,0)@@ -161,13 +170,17 @@ #else (dynFlags3,fp') <- preprocess session (sourcePath,Nothing) #endif- mbInterfaceDescr <- mayGetInterfaceDescription dynFlags packId moduleName'+ let packIdAndKey = PackageIdAndKey pid+#if MIN_VERSION_ghc(7,10,0)+ (thisPackage dynFlags3)+#endif+ mbInterfaceDescr <- mayGetInterfaceDescription dynFlags packIdAndKey moduleName' liftIO $ do stringBuffer <- hGetStringBuffer fp' parseResult <- myParseModule dynFlags3 sourcePath (Just stringBuffer) case parseResult of Right (L _ hsMod@(HsModule{})) -> do- let moduleDescr = extractModDescr dynFlags packId moduleName' sourcePath hsMod+ let moduleDescr = extractModDescr dynFlags pid moduleName' sourcePath hsMod let moduleDescr' = case mbInterfaceDescr of Nothing -> moduleDescr Just md -> mergeWithInterfaceDescr moduleDescr md@@ -176,13 +189,13 @@ Left errMsg -> do errorM "leksah-server" $ "Failed to parse " ++ sourcePath ++ " " ++ show errMsg let moduleDescr = ModuleDescr {- mdModuleId = PM packId moduleName'+ mdModuleId = PM pid moduleName' , mdMbSourcePath = Just sourcePath , mdReferences = Map.empty -- imports , mdIdDescriptions = [Real $ RealDescr { dscName' = "Parse Error" , dscMbTypeStr' = Nothing- , dscMbModu' = Just (PM packId moduleName')+ , dscMbModu' = Just (PM pid moduleName') #if MIN_VERSION_ghc(7,7,0) , dscMbLocation' = srcSpanToLocation $ errMsgSpan errMsg #else@@ -206,16 +219,23 @@ ----------------------------------------------------------------------------------- -- Format conversion+#if MIN_VERSION_ghc(7,10,0)+unLoc710 :: GenLocated l e -> e+unLoc710 = unLoc+#else+unLoc710 :: a -> a+unLoc710 = id+#endif extractModDescr :: DynFlags -> PackageIdentifier -> ModuleName -> FilePath -> HsModule RdrName -> ModuleDescr-extractModDescr dflags packId moduleName' sourcePath hsMod = ModuleDescr {- mdModuleId = PM packId moduleName'- , mdMbSourcePath = trace ("extractModDescr " ++ (show . modFile $ hsmodName hsMod)) $ modFile $ hsmodName hsMod+extractModDescr dflags pid moduleName' sourcePath hsMod = ModuleDescr {+ mdModuleId = PM pid moduleName'+ , mdMbSourcePath = modFile $ hsmodName hsMod , mdReferences = Map.empty -- imports , mdIdDescriptions = descrs'} where- descrs = extractDescrs dflags (PM packId moduleName') (hsmodDecls hsMod)- descrs' = fixExports dflags (hsmodExports hsMod) descrs+ descrs = extractDescrs dflags (PM pid moduleName') (hsmodDecls hsMod)+ descrs' = fixExports dflags (fmap unLoc710 $ hsmodExports hsMod) descrs modFile (Just (L loc _)) = (locationFile <$> srcSpanToLocation loc) <|> Just sourcePath modFile _ = Just sourcePath@@ -238,18 +258,18 @@ Nothing -> nothingExported rd Just (IEThingAll _) -> allExported rd Just (IEThingAbs _) -> someExported rd []- Just (IEThingWith _ l) -> someExported rd (map (showRdrName dflags) l)+ Just (IEThingWith _ l) -> someExported rd (map (showRdrName dflags . unLoc710) l) _ -> allExported rd findVar = find (\ a -> case a of- IEVar r | showRdrName dflags r == dscName' rd -> True+ IEVar r | showRdrName dflags (unLoc710 r) == dscName' rd -> True _ -> False) list findThing = find (\ a -> case a of- IEThingAbs r | showRdrName dflags r == dscName' rd -> True- IEThingAll r | showRdrName dflags r == dscName' rd -> True- IEThingWith r _list | showRdrName dflags r == dscName' rd -> True+ IEThingAbs r | showRdrName dflags (unLoc710 r) == dscName' rd -> True+ IEThingAll r | showRdrName dflags (unLoc710 r) == dscName' rd -> True+ IEThingWith r _list | showRdrName dflags (unLoc710 r) == dscName' rd -> True _ -> False) list allExported rd = rd@@ -349,11 +369,19 @@ sigNameNoLoc' :: Sig name -> [name] #if MIN_VERSION_ghc(7,2,0)-sigNameNoLoc' (TypeSig ns _) = map unLoc ns-sigNameNoLoc' (SpecSig n _ _) = [unLoc n]-sigNameNoLoc' (InlineSig n _) = [unLoc n]+#if MIN_VERSION_ghc(7,10,0)+sigNameNoLoc' (TypeSig ns _ _) = map unLoc ns+#else+sigNameNoLoc' (TypeSig ns _) = map unLoc ns+#endif+sigNameNoLoc' (SpecSig n _ _) = [unLoc n]+sigNameNoLoc' (InlineSig n _) = [unLoc n]+#if MIN_VERSION_ghc(7,10,0)+sigNameNoLoc' (FixSig (FixitySig ns _)) = map unLoc ns+#else sigNameNoLoc' (FixSig (FixitySig n _)) = [unLoc n]-sigNameNoLoc' _ = []+#endif+sigNameNoLoc' _ = [] #else sigNameNoLoc' = maybe [] (:[]) . sigNameNoLoc #endif@@ -396,10 +424,10 @@ , dscExported' = True}] #if MIN_VERSION_ghc(7,7,0)- transformToDescr ((L loc (TyClD typ@(ForeignType {tcdLName = lid}))), mbComment,_sigList) =+ transformToDescr ((L loc for@(ForD (ForeignImport lid _ _ _))), mbComment,_sigList) = [Real $ RealDescr { dscName' = showRdrName dflags (unLoc lid)- , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr typ))+ , dscMbTypeStr' = Just (BS.pack (showSDocUnqual dflags $ppr for)) , dscMbModu' = Just pm , dscMbLocation' = srcSpanToLocation loc , dscMbComment' = toComment mbComment []@@ -437,11 +465,11 @@ , dscExported' = True}] ++ derivings tcdDerivs' where- constructors = map (extractConstructor dflags) lConDecl+ constructors = concatMap (extractConstructor dflags) lConDecl fields = nub $ concatMap (extractRecordFields dflags) lConDecl name = showRdrName dflags (unLoc lid) derivings Nothing = []- derivings (Just l) = map (extractDeriving dflags pm name) l+ derivings (Just l) = map (extractDeriving dflags pm name) (unLoc710 l) #elif MIN_VERSION_ghc(7,6,0) transformToDescr ((L loc (TyClD typ@(ForeignType {tcdLName = lid}))), mbComment,_sigList) = [Real $ RealDescr {@@ -484,7 +512,7 @@ , dscExported' = True}] ++ derivings tcdDerivs' where- constructors = map (extractConstructor dflags) lConDecl+ constructors = concatMap (extractConstructor dflags) lConDecl fields = nub $ concatMap (extractRecordFields dflags) lConDecl name = showRdrName dflags (unLoc lid) derivings Nothing = []@@ -621,9 +649,15 @@ L l cd{con_details= uncommentDetails (con_details cd)} uncommentDetails :: HsConDeclDetails a -> HsConDeclDetails a+#if MIN_VERSION_ghc(7,10,0)+uncommentDetails (RecCon (L l flds)) = RecCon (L l (map uncommentField flds))+ where+ uncommentField (L l2 (ConDeclField a1 a2 _doc)) = L l2 (ConDeclField a1 a2 Nothing)+#else uncommentDetails (RecCon flds) = RecCon (map uncommentField flds) where uncommentField (ConDeclField a1 a2 _doc) = ConDeclField a1 a2 Nothing+#endif uncommentDetails other = other mergeWithInterfaceDescr :: ModuleDescr -> ModuleDescr -> ModuleDescr@@ -660,24 +694,36 @@ extractMethods :: DynFlags -> [LSig RdrName] -> [MyLDocDecl] -> [SimpleDescr] extractMethods dflags sigs docs = let pairs = attachComments sigs docs- in mapMaybe (extractMethod dflags) pairs+ in concatMap (extractMethod dflags) pairs -extractMethod :: OutputableBndr alpha => DynFlags -> (LHsDecl alpha, Maybe (NDoc)) -> Maybe SimpleDescr-#if MIN_VERSION_ghc(7,2,0)-extractMethod dflags ((L loc (SigD ts@(TypeSig [name] _typ))), mbDoc) =+extractMethod :: OutputableBndr alpha => DynFlags -> (LHsDecl alpha, Maybe (NDoc)) -> [SimpleDescr]+#if MIN_VERSION_ghc(7,10,0)+extractMethod dflags ((L loc (SigD ts@(TypeSig names _typ _))), mbDoc) = map extractName names+#elif MIN_VERSION_ghc(7,2,0)+extractMethod dflags ((L loc (SigD ts@(TypeSig names _typ))), mbDoc) = map extractName names #else-extractMethod dflags ((L loc (SigD ts@(TypeSig name _typ))), mbDoc) =+extractMethod dflags ((L loc (SigD ts@(TypeSig name' _typ))), mbDoc) = [extractName name'] #endif- Just $ SimpleDescr+ where+ extractName name =+ SimpleDescr (T.pack . showSDoc dflags . ppr $ unLoc name) (Just . BS.pack . showSDocUnqual dflags $ ppr ts) (srcSpanToLocation loc) (toComment mbDoc []) True-extractMethod _ (_, _mbDoc) = Nothing+extractMethod _ (_, _mbDoc) = [] -extractConstructor :: DynFlags -> Located (ConDecl RdrName) -> SimpleDescr-extractConstructor dflags decl@(L loc (ConDecl {con_name = name, con_doc = doc})) =+extractConstructor :: DynFlags -> Located (ConDecl RdrName) -> [SimpleDescr]+#if MIN_VERSION_ghc(7,10,0)+extractConstructor dflags decl@(L loc (ConDecl {con_names = names, con_doc = doc})) =+ map extractName names+#else+extractConstructor dflags decl@(L loc (ConDecl {con_name = name', con_doc = doc})) =+ [extractName name']+#endif+ where+ extractName name = SimpleDescr (T.pack . showSDoc dflags . ppr $ unLoc name) (Just . BS.pack . showSDocUnqual dflags . ppr $ uncommentDecl decl)@@ -689,13 +735,19 @@ extractRecordFields :: DynFlags -> Located (ConDecl RdrName) -> [SimpleDescr] extractRecordFields dflags (L _ _decl@(ConDecl {con_details = RecCon flds})) =- map extractRecordFields' flds+ concatMap extractRecordFields' (unLoc710 flds) where- extractRecordFields' _field@(ConDeclField (L loc name) typ doc) =+#if MIN_VERSION_ghc(7,10,0)+ extractRecordFields' (L _ _field@(ConDeclField names typ doc)) = map extractName names+#else+ extractRecordFields' _field@(ConDeclField name' typ doc) = [extractName name']+#endif+ where+ extractName name = SimpleDescr- (T.pack . showSDoc dflags $ ppr name)+ (T.pack . showSDoc dflags . ppr $ unLoc710 name) (Just . BS.pack . showSDocUnqual dflags $ ppr typ)- (srcSpanToLocation loc)+ (srcSpanToLocation $ getLoc name) (case doc of Nothing -> Nothing Just (L _ d) -> Just . BS.pack . T.unpack $ printHsDoc d)@@ -744,14 +796,20 @@ --------------------------------------------------------------------------------- -- Now the interface file stuff -mayGetInterfaceFile :: PackageIdentifier -> ModuleName -> Ghc (Maybe (ModIface,FilePath))-mayGetInterfaceFile pid mn =- let isBase = pkgName pid == (PackageName "base")+mayGetInterfaceFile :: PackageIdAndKey -> ModuleName -> Ghc (Maybe (ModIface,FilePath))+mayGetInterfaceFile p mn =+ let pid = packId p+ makeMod = mkModule+#if MIN_VERSION_ghc(7,10,0)+ (packKey p)+#else+ (mkPackageId pid)+#endif+ 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+ else makeMod mn') False gblEnv = IfGblEnv { if_rec_types = Nothing } in do hscEnv <- getSession@@ -760,7 +818,7 @@ M.Succeeded val -> return (Just val) _ -> return Nothing -mayGetInterfaceDescription :: DynFlags -> PackageIdentifier -> ModuleName -> Ghc (Maybe ModuleDescr)+mayGetInterfaceDescription :: DynFlags -> PackageIdAndKey -> ModuleName -> Ghc (Maybe ModuleDescr) mayGetInterfaceDescription dflags pid mn = do mbIf <- mayGetInterfaceFile pid mn case mbIf of
src/IDE/StrippedPrefs.hs view
@@ -31,7 +31,7 @@ (joinPath, (</>), dropTrailingPathSeparator, splitPath) import System.Directory (getHomeDirectory) import Control.Monad (liftM)-import IDE.Core.CTypes (RetrieveStrategy(..))+import IDE.Core.CTypes (RetrieveStrategy(..), configDirName) import Data.Text (Text) --@@ -49,7 +49,7 @@ defaultPrefs :: Prefs defaultPrefs = Prefs { sourceDirectories = []- , unpackDirectory = Nothing+ , unpackDirectory = Just ("~" </> configDirName </> "packageSources") , retrieveURL = "http://www.leksah.org/" , retrieveStrategy = RetrieveThenBuild , serverPort = 11111
src/IDE/Utils/FileUtils.hs view
@@ -47,6 +47,7 @@ , myCanonicalizePath ) where +import Control.Applicative import Prelude hiding (readFile) import System.FilePath (splitFileName, dropExtension, takeExtension,@@ -68,8 +69,8 @@ (TokenParser(..), identStart) #endif import Text.ParserCombinators.Parsec- (GenParser, parse, oneOf, (<|>), alphaNum, noneOf, char, try,- (<?>), many, CharParser)+ (GenParser, parse, oneOf, alphaNum, noneOf, char, try,+ (<?>), CharParser) import Data.Set (Set) import Data.List (isPrefixOf, isSuffixOf, stripPrefix)@@ -90,8 +91,8 @@ (pack, map, stripPrefix, isSuffixOf, take, length, unpack, init, last, words) import Data.Monoid ((<>))-import Control.Applicative ((<$>)) import Data.Text (Text)+import Control.DeepSeq (deepseq) haskellSrcExts :: [FilePath] haskellSrcExts = ["hs","lhs","chs","hs.pp","lhs.pp","chs.pp","hsc"]@@ -348,7 +349,7 @@ getCabalUserPackageDir :: IO (Maybe FilePath) getCabalUserPackageDir = do (!output,_) <- runTool' "cabal" ["help"] Nothing- case T.stripPrefix " " (toolline $ last output) of+ output `deepseq` case T.stripPrefix " " (toolline $ last output) of Just s | "config" `T.isSuffixOf` s -> return . Just . T.unpack $ T.take (T.length s - 6) s <> "packages" _ -> return Nothing @@ -408,14 +409,14 @@ libDir2 = if ord (T.last libDir) == 13 then T.init libDir else libDir- return . normalise $ T.unpack libDir2- ) $ \ (_ :: SomeException) -> error ("FileUtils>>getSysLibDir failed")+ output `deepseq` return $ normalise $ T.unpack libDir2+ ) $ \ (e :: SomeException) -> error ("FileUtils>>getSysLibDir failed with " ++ show e) getInstalledPackageIds :: IO [PackageIdentifier] getInstalledPackageIds = E.catch (do (!output, _) <- runTool' "ghc-pkg" ["list", "--simple-output"] Nothing- return $ concatMap names output- ) $ \ (_ :: SomeException) -> error ("FileUtils>>getInstalledPackageIds failed")+ output `deepseq` return $ concatMap names output+ ) $ \ (e :: SomeException) -> error ("FileUtils>>getInstalledPackageIds failed with " ++ show e) where names (ToolOutput n) = catMaybes (map (T.simpleParse . T.unpack) (T.words n)) names _ = []@@ -423,8 +424,8 @@ getSourcePackageIds :: IO [PackageIdentifier] getSourcePackageIds = E.catch (do (!output, _) <- runTool' "ghc-pkg" ["list", "--simple-output"] Nothing- return . catMaybes $ map names output- ) $ \ (_ :: SomeException) -> error ("FileUtils>>getInstalledPackageIds failed")+ output `deepseq` return $ catMaybes $ map names output+ ) $ \ (e :: SomeException) -> error ("FileUtils>>getInstalledPackageIds failed with " ++ show e) where names (ToolOutput n) = T.simpleParse . T.unpack $ T.map replaceSpace n names _ = Nothing@@ -437,8 +438,9 @@ let opts = concat [words $ T.unpack l | ToolOutput l <- output] let res = filterOptGhc opts debugM "leksah-server" ("figureOutHaddockOpts " ++ show res)- return $ map T.pack res+ output `deepseq` return $ map T.pack res where+ filterOptGhc :: [String] -> [String] filterOptGhc [] = [] filterOptGhc (s:r) = case stripPrefix "--optghc=" s of Nothing -> filterOptGhc r@@ -452,8 +454,9 @@ options:_ -> words options _ -> [] debugM "leksah-server" $ ("figureOutGhcOpts " ++ show res)- return $ map T.pack res+ output `deepseq` return $ map T.pack res where+ findMake :: String -> Maybe String findMake [] = Nothing findMake line@(_:xs) = case stripPrefix "--make " line of
src/IDE/Utils/GHCUtils.hs view
@@ -23,7 +23,13 @@ ) where import Distribution.Simple (withinRange,PackageIdentifier(..),Dependency(..))+#if MIN_VERSION_ghc(7,10,0)+import PackageConfig (sourcePackageIdString)+import Distribution.Text (simpleParse)+import Data.Maybe (fromJust)+#else import qualified Distribution.InstalledPackageInfo as IPI (sourcePackageId)+#endif import GHC import DriverPipeline(preprocess) import StringBuffer (StringBuffer(..),hGetStringBuffer)@@ -94,7 +100,7 @@ dynflags''' <- parseGhcFlags dynflags'' (map (noLoc . T.unpack) flags') flags' res <- defaultCleanupHandler dynflags''' $ do setSessionDynFlags dynflags'''- ghcAct dynflags'''+ getSessionDynFlags >>= ghcAct unload return res where@@ -129,7 +135,11 @@ findFittingPackages :: [Dependency] -> Ghc [PackageIdentifier] findFittingPackages dependencyList = do knownPackages <- getInstalledPackageInfos+#if MIN_VERSION_ghc(7,10,0)+ let packages = map (fromJust . simpleParse . sourcePackageIdString) knownPackages+#else let packages = map IPI.sourcePackageId knownPackages+#endif return (concatMap (fittingKnown packages) dependencyList) where fittingKnown packages (Dependency dname versionRange) =@@ -150,12 +160,12 @@ 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.+ -- 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+ Just b -> return b+ Nothing -> hGetStringBuffer src_filename #if MIN_VERSION_ghc(7,2,0) let loc = mkRealSrcLoc (mkFastString src_filename) 1 0@@ -171,7 +181,7 @@ PFailed span' err -> return (Left (mkPlainErrMsg span' err)); #endif - POk pst rdr_module -> do {+ POk pst rdr_module -> do { #if MIN_VERSION_ghc(7,2,0) let {ms@(warnings, errors) = getMessages pst};@@ -190,10 +200,10 @@ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"- (ppSourceStats False rdr_module) ;+ (ppSourceStats False rdr_module) ; return (Right rdr_module)- -- ToDo: free the string buffer later.+ -- ToDo: free the string buffer later. }} myParseHeader :: FilePath -> String -> [Text] -> IO (Either Text (DynFlags, HsModule RdrName))@@ -223,12 +233,12 @@ 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.+ -- 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+ Just b -> return b+ Nothing -> hGetStringBuffer src_filename #if MIN_VERSION_ghc(7,2,0) let loc = mkRealSrcLoc (mkFastString src_filename) 1 0@@ -248,7 +258,7 @@ PFailed span' err -> return (Left (mkPlainErrMsg span' err)); #endif - POk pst rdr_module -> do {+ POk pst rdr_module -> do { #if MIN_VERSION_ghc(7,2,0) let {ms@(warnings, errors) = getMessages pst};@@ -267,9 +277,9 @@ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics"- (ppSourceStats False rdr_module) ;+ (ppSourceStats False rdr_module) ; return (Right rdr_module)- -- ToDo: free the string buffer later.+ -- ToDo: free the string buffer later. }}
src/IDE/Utils/Server.hs view
@@ -14,13 +14,13 @@ ------------------------------------------------------------------------------ module IDE.Utils.Server- ( ipAddress- , Server (..)- , serveOne- , serveMany- , ServerRoutine- , UserAndGroup (..)- , WaitFor (waitFor))+ ( ipAddress+ , Server (..)+ , serveOne+ , serveMany+ , ServerRoutine+ , UserAndGroup (..)+ , WaitFor (waitFor)) where import Network@@ -41,7 +41,7 @@ -- 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@@ -55,55 +55,55 @@ serverSocket :: Server -> IO (Socket, Server) serverSocket server = do- sock <- serverSocket' server- setSocketOption sock ReuseAddr 1- bindSocket sock (serverAddr server)- infoM "leksah-server" $ "Bind " ++ show (serverAddr server)- listen sock maxListenQueue- return (sock, server)+ sock <- serverSocket' server+ setSocketOption sock ReuseAddr 1+ bindSocket sock (serverAddr server)+ infoM "leksah-server" $ "Bind " ++ show (serverAddr server)+ listen sock maxListenQueue+ return (sock, server) -- |the specification of a serving process data Server = Server {- serverAddr :: SockAddr,- serverTyp :: SocketType,- serverRoutine :: ServerRoutine}+ 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)+ 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+ 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)+ l <- serveMany ug [s]+ return (head l) class WaitFor a where- waitFor :: a -> IO ()+ waitFor :: a -> IO () instance WaitFor (MVar a) where- waitFor mvar = void (readMVar mvar)+ waitFor mvar = void (readMVar mvar) instance WaitFor a => WaitFor [a] where- waitFor = mapM_ waitFor+ waitFor = mapM_ waitFor instance WaitFor (ThreadId, MVar ()) where- waitFor (_, mvar) = waitFor mvar+ waitFor (_, mvar) = waitFor mvar acceptance :: Socket -> ServerRoutine -> IO () acceptance sock action = E.catch (do- dta <- accept sock- void . forkIO $ action dta)- (\(e :: SomeException) -> print e) >>- acceptance sock action+ dta <- accept sock+ void . forkIO $ action dta)+ (\(e :: SomeException) -> print e) >>+ acceptance sock action
src/IDE/Utils/Tool.hs view
@@ -46,6 +46,8 @@ ) where +import Control.Applicative+import Prelude import Control.Concurrent (tryTakeMVar, readMVar, takeMVar, putMVar, newEmptyMVar, forkIO, newChan, MVar, Chan, writeChan,@@ -75,8 +77,6 @@ import System.Exit (ExitCode(..)) import System.IO (hClose, hFlush, Handle, hSetBuffering, BufferMode(..))-import Control.Applicative- ((<$>), (<|>), Alternative, liftA2, liftA) import Data.Conduit as C ((=$), ($$), ($=)) import qualified Data.Conduit as C@@ -399,7 +399,10 @@ then return (closed + 1) else C.yield v >> return closed if nowClosed == 2- then (liftIO $ waitForProcess pid) >>= (C.yield . RawToolOutput . ToolExit)+ then do+ exitCode <- liftIO $ waitForProcess pid+ liftIO $ hClose inp+ C.yield . RawToolOutput $ ToolExit exitCode else loop nowClosed loop _ = error "Error in enumOutput"
src/IDE/Utils/VersionUtils.hs view
@@ -25,6 +25,7 @@ import Control.Exception as E (SomeException, catch) import qualified Data.Text as T (unlines, unpack, init, last) import Data.Text (Text)+import Control.DeepSeq (deepseq) getGhcVersion :: IO FilePath getGhcVersion = E.catch (do@@ -34,14 +35,14 @@ then T.init vers else vers debugM "leksah-server" $ "Got GHC Version " ++ T.unpack vers2- return $ T.unpack vers2- ) $ \ (_ :: SomeException) -> error "FileUtils>>getGhcVersion failed"+ output `deepseq` return $ T.unpack vers2+ ) $ \ (e :: SomeException) -> error $ "FileUtils>>getGhcVersion failed with " ++ show e getGhcInfo :: IO Text getGhcInfo = E.catch (do (!output,_) <- runTool' "ghc" ["--info"] Nothing- return . T.unlines $ [l | ToolOutput l <- output]- ) $ \ (_ :: SomeException) -> error "FileUtils>>getGhcInfo failed"+ output `deepseq` return $ T.unlines $ [l | ToolOutput l <- output]+ ) $ \ (e :: SomeException) -> error $ "FileUtils>>getGhcInfo failed with " ++ show e getHaddockVersion :: IO Text getHaddockVersion = E.catch (do@@ -50,8 +51,8 @@ vers2 = if ord (T.last vers) == 13 then T.init vers else vers- return vers2- ) $ \ (_ :: SomeException) -> error "FileUtils>>getHaddockVersion failed"+ output `deepseq` return vers2+ ) $ \ (e :: SomeException) -> error $ "FileUtils>>getHaddockVersion failed with " ++ show e
src/LeksahEcho.hs view
@@ -19,7 +19,8 @@ import System.Environment (getArgs) import IDE.Utils.VersionUtils (getHaddockVersion, getGhcVersion, getGhcInfo) import qualified Data.Text as T (unpack)-import Control.Applicative ((<$>))+import Control.Applicative+import Prelude main :: IO () main = do
+ src/LeksahTrue.hs view
@@ -0,0 +1,20 @@+-----------------------------------------------------------------------------+--+-- Module : Main+-- Copyright : 2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- | Windows systems do not often have a real true executable (so --with-ghc=true fails)+--+-----------------------------------------------------------------------------++module Main (+main+) where++main :: IO ()+main = return ()