diff --git a/data/prefscoll.lkshp b/data/prefscoll.lkshp --- a/data/prefscoll.lkshp +++ b/data/prefscoll.lkshp @@ -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 diff --git a/leksah-server.cabal b/leksah-server.cabal --- a/leksah-server.cabal +++ b/leksah-server.cabal @@ -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 diff --git a/src/IDE/Core/CTypes.hs b/src/IDE/Core/CTypes.hs --- a/src/IDE/Core/CTypes.hs +++ b/src/IDE/Core/CTypes.hs @@ -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 diff --git a/src/IDE/Core/Serializable.hs b/src/IDE/Core/Serializable.hs --- a/src/IDE/Core/Serializable.hs +++ b/src/IDE/Core/Serializable.hs @@ -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) diff --git a/src/IDE/HeaderParser.hs b/src/IDE/HeaderParser.hs --- a/src/IDE/HeaderParser.hs +++ b/src/IDE/HeaderParser.hs @@ -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) diff --git a/src/IDE/Metainfo/Collector.hs b/src/IDE/Metainfo/Collector.hs --- a/src/IDE/Metainfo/Collector.hs +++ b/src/IDE/Metainfo/Collector.hs @@ -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 diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -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) diff --git a/src/IDE/Metainfo/PackageCollector.hs b/src/IDE/Metainfo/PackageCollector.hs --- a/src/IDE/Metainfo/PackageCollector.hs +++ b/src/IDE/Metainfo/PackageCollector.hs @@ -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 - - - diff --git a/src/IDE/Metainfo/SourceCollectorH.hs b/src/IDE/Metainfo/SourceCollectorH.hs --- a/src/IDE/Metainfo/SourceCollectorH.hs +++ b/src/IDE/Metainfo/SourceCollectorH.hs @@ -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) diff --git a/src/IDE/Metainfo/SourceDB.hs b/src/IDE/Metainfo/SourceDB.hs --- a/src/IDE/Metainfo/SourceDB.hs +++ b/src/IDE/Metainfo/SourceDB.hs @@ -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 ((<>)) -- --------------------------------------------------------------------- diff --git a/src/IDE/Metainfo/WorkspaceCollector.hs b/src/IDE/Metainfo/WorkspaceCollector.hs --- a/src/IDE/Metainfo/WorkspaceCollector.hs +++ b/src/IDE/Metainfo/WorkspaceCollector.hs @@ -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 diff --git a/src/IDE/StrippedPrefs.hs b/src/IDE/StrippedPrefs.hs --- a/src/IDE/StrippedPrefs.hs +++ b/src/IDE/StrippedPrefs.hs @@ -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 diff --git a/src/IDE/Utils/FileUtils.hs b/src/IDE/Utils/FileUtils.hs --- a/src/IDE/Utils/FileUtils.hs +++ b/src/IDE/Utils/FileUtils.hs @@ -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 diff --git a/src/IDE/Utils/GHCUtils.hs b/src/IDE/Utils/GHCUtils.hs --- a/src/IDE/Utils/GHCUtils.hs +++ b/src/IDE/Utils/GHCUtils.hs @@ -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. }} diff --git a/src/IDE/Utils/Server.hs b/src/IDE/Utils/Server.hs --- a/src/IDE/Utils/Server.hs +++ b/src/IDE/Utils/Server.hs @@ -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 diff --git a/src/IDE/Utils/Tool.hs b/src/IDE/Utils/Tool.hs --- a/src/IDE/Utils/Tool.hs +++ b/src/IDE/Utils/Tool.hs @@ -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" diff --git a/src/IDE/Utils/VersionUtils.hs b/src/IDE/Utils/VersionUtils.hs --- a/src/IDE/Utils/VersionUtils.hs +++ b/src/IDE/Utils/VersionUtils.hs @@ -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 diff --git a/src/LeksahEcho.hs b/src/LeksahEcho.hs --- a/src/LeksahEcho.hs +++ b/src/LeksahEcho.hs @@ -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 diff --git a/src/LeksahTrue.hs b/src/LeksahTrue.hs new file mode 100644 --- /dev/null +++ b/src/LeksahTrue.hs @@ -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 ()