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.15.0.9 +version: 0.15.2.0 cabal-version: >= 1.10.2 build-type: Simple license: GPL @@ -37,13 +37,13 @@ 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.5, ghc >=7.0.4 && <7.11, - ltk >=0.15.0.1 && <0.16, parsec >=2.1.0.1 && <3.2, + ltk >=0.15.0.1 && <0.16, parsec >=3.0.0.0 && <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.14, + 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, process >= 1.1 && <1.3 + HTTP >=4000.1.2 && <4000.4, process >= 1.1 && <1.3 if (impl(ghc >= 7.10)) build-depends: haddock-api >=2.16 && <2.17, haddock-library >=1.2.0 && <1.3, bin-package-db else @@ -95,13 +95,13 @@ 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.5, ghc >=7.0.4 && <7.11, - ltk >=0.15.0.1 && <0.16, parsec >=2.1.0.1 && <3.2, + ltk >=0.15.0.1 && <0.16, parsec >=3.0.0.0 && <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.14, + 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, process >= 1.1 && <1.3, leksah-server ==0.15.0.9 + HTTP >=4000.1.2 && <4000.4, process >= 1.1 && <1.3, leksah-server ==0.15.2.0 if (impl(ghc >= 7.10)) build-depends: haddock-api >=2.16 && <2.17, haddock-library >=1.2.0 && <1.3, bin-package-db else @@ -155,9 +155,9 @@ 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.14, + attoparsec >=0.10.0.3 && <0.14, transformers >=0.2.2.0 && <0.5, text >=0.11.3.1 && <1.3, - process >= 1.1 && <1.3, leksah-server ==0.15.0.9 + process >= 1.1 && <1.3, leksah-server ==0.15.2.0 if !os(windows) build-depends: unix >=2.3.1.0 && <2.8 @@ -183,8 +183,8 @@ hs-source-dirs: tests main-is: TestTool.hs build-depends: base >= 4.0.0.0 && <4.9, hslogger >= 1.0.7 && <1.3, - leksah-server == 0.15.0.9, - HUnit >=1.2 && <1.3, transformers >=0.2.2.0 && <0.5, conduit >= 1.0.8 && <1.3, + leksah-server == 0.15.2.0, + HUnit >=1.2 && <1.4, transformers >=0.2.2.0 && <0.5, conduit >= 1.0.8 && <1.3, conduit-extra >=1.0.0.1 && <1.2, resourcet, process >= 1.1 && <1.3 diff --git a/main/Collector.hs b/main/Collector.hs --- a/main/Collector.hs +++ b/main/Collector.hs @@ -1,5 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} ----------------------------------------------------------------------------- -- @@ -25,7 +27,7 @@ import System.Console.GetOpt (ArgDescr(..), usageInfo, ArgOrder(..), getOpt, OptDescr(..)) import System.Environment (getArgs) -import Control.Monad (when) +import Control.Monad (when, forM) import Data.Version (showVersion) import IDE.Utils.FileUtils import IDE.Utils.Utils @@ -39,6 +41,7 @@ #endif import Control.Monad (liftM) import qualified Data.Set as Set (member) +import qualified Data.Map as Map (toList, fromListWith) import IDE.Core.CTypes hiding (Extension) import IDE.Metainfo.SourceDB (buildSourceForPackageDB, getDataDir, version) import Data.Time @@ -54,9 +57,8 @@ import IDE.Utils.Server import System.IO (Handle, hPutStrLn, hGetLine, hFlush, hClose) import IDE.HeaderParser(parseTheHeader) -import System.Exit (ExitCode(..)) import Data.IORef -import Control.Concurrent (throwTo, ThreadId, myThreadId) +import Control.Concurrent (MVar,putMVar) import IDE.Metainfo.PackageCollector(collectPackage) import Data.List (delete) import System.Directory @@ -67,6 +69,7 @@ import qualified Data.Text as T (strip, pack, unpack) import Data.Text (Text) import Data.Monoid ((<>)) +import Distribution.Package (PackageIdentifier) -- -------------------------------------------------------------------- -- Command line options @@ -167,7 +170,6 @@ prefs <- readStrippedPrefs prefsPath debugM "leksah-server" $ "prefs " ++ show prefs connRef <- newIORef [] - threadId <- myThreadId localServerAddr <- inet_addr "127.0.0.1" if elem VersionF o @@ -192,33 +194,33 @@ if elem CollectSystem o then do debugM "leksah-server" "collectSystem" - collectSystem prefs debug rebuild sources + collectSystem prefs debug rebuild sources [] else case servers of (Nothing:_) -> do running <- serveOne Nothing (server (fromIntegral - (serverPort prefs)) newPrefs connRef threadId localServerAddr) + (serverPort prefs)) newPrefs connRef localServerAddr) waitFor running return () (Just ps:_) -> do let port = read $ T.unpack ps running <- serveOne Nothing (server - (fromIntegral port) newPrefs connRef threadId localServerAddr) + (fromIntegral port) newPrefs connRef localServerAddr) waitFor running return () _ -> return () - server port prefs connRef threadId hostAddr = Server (SockAddrInet port hostAddr) Stream - (doCommands prefs connRef threadId) + server port prefs connRef hostAddr = Server (SockAddrInet port hostAddr) Stream + (doCommands prefs connRef) -doCommands :: Prefs -> IORef [Handle] -> ThreadId -> (Handle, t1, t2) -> IO () -doCommands prefs connRef threadId (h,n,p) = do +doCommands :: Prefs -> IORef [Handle] -> (Handle, t1, t2) -> MVar ()-> IO () +doCommands prefs connRef (h,n,p) mvar = do atomicModifyIORef connRef (\ list -> (h : list, ())) - doCommands' prefs connRef threadId (h,n,p) + doCommands' prefs connRef (h,n,p) mvar -doCommands' :: Prefs -> IORef [Handle] -> ThreadId -> (Handle, t1, t2) -> IO () -doCommands' prefs connRef threadId (h,n,p) = do +doCommands' :: Prefs -> IORef [Handle] -> (Handle, t1, t2) -> MVar () -> IO () +doCommands' prefs connRef (h,n,p) mvar = do debugM "leksah-server" $ "***wait" mbLine <- catch (liftM Just (hGetLine h)) (\ (_e :: SomeException) -> do @@ -228,20 +230,22 @@ handles <- readIORef connRef case handles of [] -> do - when (endWithLastConn prefs) $ do - infoM "leksah-server" $ "***lost last connection - exiting" - throwTo threadId ExitSuccess - --exitSuccess - infoM "leksah-server" $ "***lost last connection - waiting" + if (endWithLastConn prefs) + then do + infoM "leksah-server" $ "***lost last connection - exiting" + -- we're waiting on that mvar before exiting + putMVar mvar () + else do + infoM "leksah-server" $ "***lost last connection - waiting" return Nothing _ -> return Nothing) case mbLine of Nothing -> return () Just line -> do case read line of - SystemCommand rebuild sources _extract -> --the extract arg is not used + SystemCommand rebuild sources _extract dbs -> --the extract arg is not used catch (do - collectSystem prefs False rebuild sources + collectSystem prefs False rebuild sources dbs hPutStrLn h (show ServerOK) hFlush h) (\ (e :: SomeException) -> do @@ -263,10 +267,10 @@ (\ (e :: SomeException) -> do hPutStrLn h (show (ServerFailed (T.pack $ show e))) hFlush h) - doCommands' prefs connRef threadId (h,n,p) + doCommands' prefs connRef (h,n,p) mvar -collectSystem :: Prefs -> Bool -> Bool -> Bool -> IO() -collectSystem prefs writeAscii forceRebuild findSources = do +collectSystem :: Prefs -> Bool -> Bool -> Bool -> [[FilePath]] -> IO() +collectSystem prefs writeAscii forceRebuild findSources dbLists = do collectorPath <- getCollectorPath when forceRebuild $ do exists <- doesDirectoryExist collectorPath @@ -277,11 +281,10 @@ return () knownPackages <- findKnownPackages collectorPath debugM "leksah-server" $ "collectSystem knownPackages= " ++ show knownPackages - packageInfos <- inGhcIO [] [] $ \ _ -> getInstalledPackageInfos - debugM "leksah-server" $ "collectSystem packageInfos= " ++ show (map (packId . getThisPackage) packageInfos) - let newPackages = filter (\pid -> not $Set.member (packageIdentifierToString . packId $ getThisPackage pid) - knownPackages) - packageInfos + packageInfos <- concat <$> forM dbLists (\dbs -> inGhcIO [] [] dbs $ \ _ -> map (,dbs) <$> getInstalledPackageInfos) + debugM "leksah-server" $ "collectSystem packageInfos= " ++ show (map (packId . getThisPackage . fst) packageInfos) + let newPackages = filter (\pi -> not $ Set.member (packageIdentifierToString . packId . getThisPackage $ fst pi) knownPackages) + packageInfos if null newPackages then do infoM "leksah-server" "Metadata collector has nothing to do" @@ -305,7 +308,7 @@ summary = "\nSuccess with = " ++ T.unpack packs ++ "\nPackages total = " ++ show packagesTotal ++ "\nPackages with source = " ++ show packagesWithSource ++ - "\nPackages retreived = " ++ show packagesRetreived ++ + "\nPackages retrieved = " ++ show packagesRetreived ++ "\nModules total = " ++ show modulesTotal' ++ "\nModules with source = " ++ show modulesWithSource ++ "\nPercentage source = " ++ show percentageWithSource 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 @@ -21,6 +21,10 @@ module IDE.Core.CTypes ( PackageDescr(..) +, ModuleKey(..) +, displayModuleKey +, parseModuleKey +, moduleKeyToName , ModuleDescr(..) , Descr(..) , RealDescr(..) @@ -68,6 +72,8 @@ ) where +import Control.Applicative ((<$>)) +import Prelude import Data.Typeable (Typeable) import Data.Map (Map) import Data.Set (Set) @@ -81,7 +87,7 @@ import Distribution.Package (PackageIdentifier(..),PackageName(..)) #endif -import Distribution.ModuleName (components, ModuleName) +import Distribution.ModuleName (main, components, ModuleName) import Data.ByteString.Char8 (ByteString) #if !MIN_VERSION_bytestring(0,10,0) import Data.Version (Version(..)) @@ -142,14 +148,15 @@ data ServerCommand = SystemCommand { - scRebuild :: Bool, - scSources :: Bool, - scExtract :: Bool} + scRebuild :: Bool, + scSources :: Bool, + scExtract :: Bool, + scPackageDBs :: [[FilePath]]} | WorkspaceCommand { - wcRebuild :: Bool, - wcPackage :: PackageIdentifier, - wcPath :: FilePath, - wcModList :: [(Text,FilePath)]} + wcRebuild :: Bool, + wcPackage :: PackageIdentifier, + wcPath :: FilePath, + wcModList :: [(Text,FilePath)]} | ParseHeaderCommand { hcFilePath :: FilePath} deriving (Eq,Ord,Show,Read) @@ -202,6 +209,25 @@ instance Ord PackageDescr where (<=) a b = pdPackage a <= pdPackage b +-- | Key we use to identify a module in the metadata. +-- But for "Main" modules we need to know the source file path. +data ModuleKey = LibModule ModuleName | MainModule FilePath deriving (Show, Eq, Ord) + +-- | Display a the module key +displayModuleKey :: ModuleKey -> String +displayModuleKey (LibModule m) = display m +displayModuleKey (MainModule f) = "Main (" ++ f ++ ")" + +-- | Parse a module key from the name of the module and the source file path. +parseModuleKey :: String -> FilePath -> Maybe ModuleKey +parseModuleKey "Main" sourcePath = Just $ MainModule sourcePath +parseModuleKey s _ = LibModule <$> simpleParse s + +-- | Extract the module name from the module key +moduleKeyToName :: ModuleKey -> ModuleName +moduleKeyToName (LibModule m) = m +moduleKeyToName (MainModule _) = main + data ModuleDescr = ModuleDescr { mdModuleId :: PackModule , mdMbSourcePath :: Maybe FilePath -- unqualified @@ -216,10 +242,20 @@ show (Present md) = (show . mdModuleId) md instance Eq ModuleDescr where - (== ) a b = mdModuleId a == mdModuleId b + (== ) a b = let + idEq = mdModuleId a == mdModuleId b + -- Main modules are only the same if they use the same file + in if idEq && ["Main"] == components (modu (mdModuleId a)) + then mdMbSourcePath a == mdMbSourcePath b + else idEq instance Ord ModuleDescr where - (<=) a b = mdModuleId a <= mdModuleId b + (<=) a b = let + idEq = mdModuleId a == mdModuleId b + -- use source files for main modules + in if idEq && ["Main"] == components (modu (mdModuleId a)) + then mdMbSourcePath a <= mdMbSourcePath b + else mdModuleId a <= mdModuleId b data Descr = Real RealDescr | Reexported ReexportedDescr deriving (Show,Read,Typeable,Eq,Ord) 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 @@ -87,8 +87,8 @@ showSDocUnqual _ = O.showSDocUnqual #endif -collectPackageFromHI :: PackageConfig -> IO PackageDescr -collectPackageFromHI packageConfig = inGhcIO [] [] $ \ dflags -> do +collectPackageFromHI :: PackageConfig -> [FilePath] -> IO PackageDescr +collectPackageFromHI packageConfig dbs = inGhcIO [] [] dbs $ \ dflags -> do let pIdAndKey = getThisPackage packageConfig Hs.liftIO . debugM "leksah-server" $ "collectPackageFromHI" session <- getSession 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 @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} ----------------------------------------------------------------------------- -- -- Module : IDE.Metainfo.PackageCollector @@ -29,8 +30,8 @@ import System.Log.Logger (errorM, debugM, infoM) import IDE.Metainfo.InterfaceCollector (collectPackageFromHI) import IDE.Core.CTypes - (metadataVersion, PackageDescr(..), leksahVersion, getThisPackage, - PackageIdAndKey(..), packageIdentifierToString) + (metadataVersion, PackageDescr(..), leksahVersion, + packageIdentifierToString, getThisPackage, packId) import IDE.Utils.FileUtils (getCollectorPath) import System.Directory (doesDirectoryExist, setCurrentDirectory) import IDE.Utils.Utils @@ -43,7 +44,7 @@ import qualified Control.Exception as E (SomeException, catch) import IDE.Utils.Tool (runTool') import Data.Monoid ((<>)) -import qualified Data.Text as T (unpack) +import qualified Data.Text as T (unpack, pack) import Data.Text (Text) import Network.HTTP.Proxy (Proxy(..), fetchProxy) import Network.Browser @@ -59,83 +60,52 @@ import Distribution.System (buildArch, buildOS) import Control.Monad (unless) -collectPackage :: Bool -> Prefs -> Int -> (PackageConfig,Int) -> IO PackageCollectStats -collectPackage writeAscii prefs numPackages (packageConfig, packageIndex) = do +collectPackage :: Bool -> Prefs -> Int -> ((PackageConfig, [FilePath]), Int) -> IO PackageCollectStats +collectPackage writeAscii prefs numPackages ((packageConfig, dbs), packageIndex) = do infoM "leksah-server" ("update_toolbar " ++ show ((fromIntegral packageIndex / fromIntegral numPackages) :: Double)) - let packageName = packageIdentifierToString (packId $ getThisPackage packageConfig) - let stat = PackageCollectStats packageName Nothing False False Nothing - eitherStrFp <- findSourceForPackage prefs (packId $ getThisPackage packageConfig) + eitherStrFp <- findSourceForPackage prefs pid case eitherStrFp of Left message -> do debugM "leksah-server" . T.unpack $ message <> " : " <> packageName - packageDescrHi <- collectPackageFromHI packageConfig + packageDescrHi <- collectPackageFromHI packageConfig dbs writeExtractedPackage False packageDescrHi return stat {packageString = message, modulesTotal = Just (length (pdModules packageDescrHi))} Right fpSource -> case retrieveStrategy prefs of - RetrieveThenBuild -> do - success <- retrieve packageName - if success - then do - debugM "leksah-server" . T.unpack $ "collectPackage: retreived = " <> packageName - liftIO $ writePackagePath (dropFileName fpSource) packageName - return (stat {withSource=True, retrieved= True, mbError=Nothing}) - else do - debugM "leksah-server" . T.unpack $ "collectPackage: Can't retreive = " <> packageName - runCabalConfigure fpSource - mbPackageDescrPair <- packageFromSource fpSource packageConfig - case mbPackageDescrPair of - (Just packageDescrS, bstat) -> do - 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))} + RetrieveThenBuild -> + retrieve fpSource >>= \case + Just stats -> return stats + Nothing -> buildOnly fpSource 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 - writePackageDesc packageDescrS fpSource packageName - return bstat{modulesTotal = Just (length (pdModules packageDescrS))} - (Nothing,bstat) -> do - success <- retrieve packageName - if success - then do - debugM "leksah-server" . T.unpack $ "collectPackage: retreived = " <> packageName - liftIO $ writePackagePath (dropFileName fpSource) packageName - return (stat {withSource=True, retrieved= True, mbError=Nothing}) - else do - packageDescrHi <- collectPackageFromHI packageConfig - writeExtractedPackage False packageDescrHi - return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} - NeverRetrieve -> do - debugM "leksah-server" $ "Build " <> T.unpack packageName <> " in " <> fpSource - runCabalConfigure fpSource - mbPackageDescrPair <- packageFromSource fpSource packageConfig - case mbPackageDescrPair of - (Just packageDescrS,bstat) -> do - writePackageDesc packageDescrS fpSource packageName - return bstat{modulesTotal = Just (length (pdModules packageDescrS))} - (Nothing,bstat) -> do - packageDescrHi <- collectPackageFromHI packageConfig + debugM "leksah-server" $ "Build (then retrieve) " <> T.unpack packageName <> " in " <> fpSource + build fpSource >>= \case + (True, bstat) -> return bstat + (False, bstat) -> + retrieve fpSource >>= \case + Just stats -> return stats + Nothing -> do + packageDescrHi <- collectPackageFromHI packageConfig dbs writeExtractedPackage False packageDescrHi return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} + NeverRetrieve -> do + debugM "leksah-server" $ "Build " <> T.unpack packageName <> " in " <> fpSource + buildOnly fpSource where - retrieve :: Text -> IO Bool - retrieve packString = do + pid = packId $ getThisPackage packageConfig + packageName = packageIdentifierToString pid + stat = PackageCollectStats packageName Nothing False False Nothing + retrieve :: FilePath -> IO (Maybe PackageCollectStats) + retrieve fpSource = do collectorPath <- liftIO getCollectorPath setCurrentDirectory collectorPath - let fullUrl = T.unpack (retrieveURL prefs) <> "/metadata-" <> leksahVersion <> "/" <> T.unpack packString <> leksahMetadataSystemFileExtension - filePath = collectorPath T.unpack packString <.> leksahMetadataSystemFileExtension + let fullUrl = T.unpack (retrieveURL prefs) <> "/metadata-" <> leksahVersion <> "/" <> T.unpack packageName <> leksahMetadataSystemFileExtension + filePath = collectorPath T.unpack packageName <.> leksahMetadataSystemFileExtension case parseURI fullUrl of Nothing -> do errorM "leksah-server" $ "collectPackage: invalid URI = " <> fullUrl - return False + return Nothing Just uri -> do debugM "leksah-server" $ "collectPackage: before retreiving = " <> fullUrl proxy <- filterEmptyProxy . trimProxyUri <$> fetchProxy True @@ -151,9 +121,32 @@ if rspCode rsp == (2,0,0) then do BS.writeFile filePath $ rspBody rsp - return True - else return False + debugM "leksah-server" . T.unpack $ "collectPackage: retreived = " <> packageName + liftIO $ writePackagePath (dropFileName fpSource) packageName + return (Just stat {withSource=True, retrieved= True, mbError=Nothing}) + else do + debugM "leksah-server" . T.unpack $ "collectPackage: Can't retreive = " <> packageName + return Nothing + build :: FilePath -> IO (Bool, PackageCollectStats) + build fpSource = do + runCabalConfigure fpSource + mbPackageDescrPair <- packageFromSource fpSource packageConfig + case mbPackageDescrPair of + (Just packageDescrS, bstat) -> do + writePackageDesc packageDescrS fpSource + return (True, bstat{modulesTotal = Just (length (pdModules packageDescrS))}) + (Nothing, bstat) -> return (False, bstat) + + buildOnly :: FilePath -> IO PackageCollectStats + buildOnly fpSource = + build fpSource >>= \case + (True, bstat) -> return bstat + (False, bstat) -> do + packageDescrHi <- collectPackageFromHI packageConfig dbs + writeExtractedPackage False packageDescrHi + return bstat{modulesTotal = Just (length (pdModules packageDescrHi))} + trimProxyUri (Proxy uri auth) = Proxy (trim uri) auth trimProxyUri p = p filterEmptyProxy (Proxy "" _) = NoProxy @@ -162,20 +155,20 @@ userAgent = concat [ "leksah-server/", display Paths_leksah_server.version , " (", display buildOS, "; ", display buildArch, ")" ] - writePackageDesc packageDescr fpSource packageName = do + writePackageDesc packageDescr fpSource = do liftIO $ writeExtractedPackage writeAscii packageDescr liftIO $ writePackagePath (dropFileName fpSource) packageName runCabalConfigure fpSource = do let dirPath = dropFileName fpSource - packageName = takeBaseName fpSource + packageName' = takeBaseName fpSource flagsFor "base" = ["-finteger-gmp2"] flagsFor _ = [] - flags = flagsFor packageName + flags = flagsFor packageName' distExists <- doesDirectoryExist $ dirPath "dist" unless distExists $ do setCurrentDirectory dirPath E.catch (do runTool' "cabal" ["clean"] Nothing - runTool' "cabal" ("configure":"--user":flags) Nothing + runTool' "cabal" ("configure":flags ++ map (("--package-db"<>) .T.pack) dbs) Nothing return ()) (\ (_e :: E.SomeException) -> do debugM "leksah-server" "Can't configure" 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 @@ -151,7 +151,7 @@ warningM "leksah-server" ("Ghc failed to process: " ++ show e ++ " (" ++ cabalPath ++ ")") return (Nothing, PackageCollectStats packageName Nothing False False (Just ("Ghc failed to process: " <> T.pack (show e) <> " (" <> T.pack cabalPath <> ")"))) - inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] $ \ dflags -> do + inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] [] $ \ dflags -> do (interfaces,_) <- processModules verbose (exportedMods ++ hiddenMods) [] [] liftIO $ print (length interfaces) let mods = map (interfaceToModuleDescr dflags dirPath (packId $ getThisPackage packageConfig)) interfaces 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 @@ -55,7 +55,6 @@ import System.Directory import Distribution.Package hiding (PackageId) import Distribution.ModuleName -import Distribution.Text (simpleParse) import System.FilePath import qualified Data.ByteString.Char8 as BS import Data.Binary.Shared @@ -114,7 +113,7 @@ showRdrName dflags r = T.pack . showSDoc dflags $ ppr r -- | Test -collectWorkspace :: PackageIdentifier -> [(Text,FilePath)] -> Bool -> Bool -> FilePath -> IO() +collectWorkspace :: PackageIdentifier -> [(Text,FilePath)] -> Bool -> Bool -> FilePath -> IO() collectWorkspace pid moduleList forceRebuild writeAscii dir = do debugM "leksah-server" $ "collectWorkspace called with modules " ++ show moduleList ++ " in folder " ++ dir collectorPath <- liftIO $ getCollectorPath @@ -139,31 +138,30 @@ collectModule :: FilePath -> Bool -> PackageIdentifier -> [Text] -> (Text,FilePath) -> IO() collectModule collectorPackagePath writeAscii pid opts (modId,sourcePath) = do - existCollectorFile <- doesFileExist collectorModulePath - existSourceFile <- doesFileExist sourcePath - case mbModuleName of + case parseModuleKey (T.unpack modId) sourcePath of Nothing -> errorM "leksah-server" (T.unpack $ "Can't parse module name " <> modId) - Just moduleName' -> + Just modKey -> do + let collectorModulePath = collectorPackagePath (moduleCollectorFileName modKey) <.> leksahMetadataWorkspaceFileExtension + moduleName' = moduleKeyToName modKey + existCollectorFile <- doesFileExist collectorModulePath + existSourceFile <- doesFileExist sourcePath if existSourceFile - then do - if not existCollectorFile - then collectModule' sourcePath collectorModulePath writeAscii pid opts moduleName' - else do - sourceModTime <- getModificationTime sourcePath - collModTime <- getModificationTime collectorModulePath - if sourceModTime > collModTime - then collectModule' sourcePath collectorModulePath writeAscii pid - opts moduleName' - else return () - else errorM "leksah-server" ("source file not found " ++ sourcePath) - where - collectorModulePath = collectorPackagePath T.unpack modId <.> leksahMetadataWorkspaceFileExtension - mbModuleName = simpleParse $ T.unpack modId + then do + if not existCollectorFile + then collectModule' sourcePath collectorModulePath writeAscii pid opts moduleName' + else do + sourceModTime <- getModificationTime sourcePath + collModTime <- getModificationTime collectorModulePath + if sourceModTime > collModTime + then collectModule' sourcePath collectorModulePath writeAscii pid + opts moduleName' + else return () + else errorM "leksah-server" ("source file not found " ++ sourcePath) collectModule' :: FilePath -> FilePath -> Bool -> PackageIdentifier -> [Text] -> ModuleName -> IO() collectModule' sourcePath destPath writeAscii pid opts moduleName' = gcatch ( - inGhcIO (opts++["-cpp"]) [Opt_Haddock] $ \ dynFlags -> do + inGhcIO (opts++["-cpp"]) [Opt_Haddock] [] $ \ dynFlags -> do session <- getSession #if MIN_VERSION_ghc(7,2,0) (dynFlags3,fp') <- liftIO $ preprocess session (sourcePath,Nothing) 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} @@ -31,6 +30,7 @@ , getSysLibDir , moduleNameFromFilePath , moduleNameFromFilePath' +, moduleCollectorFileName , findKnownPackages , isSubPath , findSourceFile @@ -41,6 +41,7 @@ , autoExtractTarFiles , getInstalledPackageIds , getInstalledPackageIds' +, getPackageDBs , figureOutGhcOpts , figureOutHaddockOpts , allFilesWithExtensions @@ -51,9 +52,9 @@ import Prelude hiding (readFile) import System.FilePath (splitFileName, dropExtension, takeExtension, - combine, addExtension, (), normalise, splitPath, takeFileName) + combine, addExtension, (), normalise, splitPath, takeFileName,takeDirectory) import Distribution.ModuleName (toFilePath, ModuleName) -import Control.Monad (when, foldM, filterM) +import Control.Monad (when, foldM, filterM, forM) import Data.Maybe (mapMaybe, catMaybes) import Distribution.Simple.PreProcess.Unlit (unlit) import System.Directory @@ -61,26 +62,21 @@ setCurrentDirectory, getCurrentDirectory, getDirectoryContents, createDirectory, getHomeDirectory) import Text.ParserCombinators.Parsec.Language (haskellDef, haskell) -#if MIN_VERSION_parsec(3,0,0) import qualified Text.ParserCombinators.Parsec.Token as P (GenTokenParser(..), TokenParser, identStart) -#else -import qualified Text.ParserCombinators.Parsec.Token as P - (TokenParser(..), identStart) -#endif import Text.ParserCombinators.Parsec (GenParser, parse, oneOf, alphaNum, noneOf, char, try, (), CharParser) import Data.Set (Set) import Data.List - (isPrefixOf, isSuffixOf, stripPrefix) + (isPrefixOf, isSuffixOf, stripPrefix, nub) import qualified Data.Set as Set (empty, fromList) import Distribution.Package (PackageIdentifier) import Data.Char (ord) -import Distribution.Text (simpleParse) +import Distribution.Text (simpleParse, display) import IDE.Utils.Utils -import IDE.Core.CTypes(configDirName) +import IDE.Core.CTypes(configDirName, ModuleKey(..)) import qualified Distribution.Text as T (simpleParse) import System.Log.Logger(errorM,warningM,debugM) import IDE.Utils.Tool @@ -89,7 +85,7 @@ import System.IO.Strict (readFile) import qualified Data.Text as T (pack, stripPrefix, isSuffixOf, take, length, unpack, init, - last, words) + last, words, splitOn) import Data.Monoid ((<>)) import Data.Text (Text) import Control.DeepSeq (deepseq) @@ -138,7 +134,7 @@ find' (h:t) = E.catch (do exists <- doesFileExist h if exists - then return (Just h) + then Just <$> canonicalizePath h else find' t) $ \ (_ :: SomeException) -> return Nothing @@ -268,6 +264,15 @@ Left _ -> return Nothing Right str'' -> return (Just str'') +-- | Get the file name to use for the module collector results +-- we want to store the file name for Main module since there can be several in one package +moduleCollectorFileName + :: ModuleKey -- ^ The module key + -> String -- ^ The name to use for the collector file (without extension) +moduleCollectorFileName (LibModule name) = display name +moduleCollectorFileName (MainModule sourcePath) = + "Main_" ++ "_" ++ takeFileName (takeDirectory sourcePath) ++ dropExtension (takeFileName sourcePath) + lexer :: P.TokenParser st lexer = haskell @@ -404,17 +409,42 @@ output `deepseq` return $ normalise $ T.unpack libDir2 ) $ \ (e :: SomeException) -> error ("FileUtils>>getSysLibDir failed with " ++ show e) -getInstalledPackageIds :: IO [PackageIdentifier] -getInstalledPackageIds = either (const []) id <$> getInstalledPackageIds' +getInstalledPackageIds :: [FilePath] -> IO [PackageIdentifier] +getInstalledPackageIds dirs = either (const []) id <$> getInstalledPackageIds' dirs -getInstalledPackageIds' :: IO (Either Text [PackageIdentifier]) -getInstalledPackageIds' = E.catch (do +getInstalledPackageIds' :: [FilePath] -> IO (Either Text [PackageIdentifier]) +getInstalledPackageIds' dirs = E.catch (do (!output, _) <- runTool' "ghc-pkg" ["list", "--simple-output"] Nothing - output `deepseq` return $ Right $ concatMap names output + pids <- output `deepseq` return $ concatMap names output + -- Do our best to get the stack package ids + stackPids <- forM dirs $ \dir -> E.catch (do + useStack <- liftIO . doesFileExist $ dir "stack.yaml" + if useStack + then do + (!output', _) <- runTool' "stack" ["--stack-yaml", T.pack (dir "stack.yaml"), "exec", "ghc-pkg", "--", "list", "--simple-output"] Nothing + output' `deepseq` return $ concatMap names output' + else return [] + ) $ \ (_ :: SomeException) -> return [] + return . Right . nub $ pids ++ concat stackPids ) $ \ (e :: SomeException) -> return . Left . T.pack $ show e where names (ToolOutput n) = mapMaybe (T.simpleParse . T.unpack) (T.words n) names _ = [] + +getPackageDBs :: [FilePath] -> IO [[FilePath]] +getPackageDBs dirs = do + dbs <- forM dirs $ \dir -> E.catch (do + useStack <- liftIO . doesFileExist $ dir "stack.yaml" + if useStack + then do + (!output, _) <- runTool' "stack" ["--stack-yaml", T.pack (dir "stack.yaml"), "path", "--ghc-package-path"] Nothing + filterM doesDirectoryExist $ concatMap paths output + else return [] + ) $ \ (_ :: SomeException) -> return [] + return $ nub dbs + where + paths (ToolOutput n) = map T.unpack (T.splitOn ":" n) + paths _ = [] figureOutHaddockOpts :: IO [Text] figureOutHaddockOpts = do 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 @@ -61,9 +61,9 @@ #endif import IDE.Utils.FileUtils (getSysLibDir) #if MIN_VERSION_ghc(7,7,0) -import DynFlags (DumpFlag(..), gopt_set) +import DynFlags (DumpFlag(..), gopt_set, PkgConfRef(..)) #else -import DynFlags (dopt_set) +import DynFlags (dopt_set, PkgConfRef(..)) #endif import System.Log.Logger(debugM) import Control.Monad.IO.Class (MonadIO(..)) @@ -79,11 +79,11 @@ #endif #if MIN_VERSION_ghc(7,7,0) -inGhcIO :: [Text] -> [GeneralFlag] -> (DynFlags -> Ghc a) -> IO a +inGhcIO :: [Text] -> [GeneralFlag] -> [FilePath] -> (DynFlags -> Ghc a) -> IO a #else -inGhcIO :: [Text] -> [DynFlag] -> (DynFlags -> Ghc a) -> IO a +inGhcIO :: [Text] -> [DynFlag] -> [FilePath] -> (DynFlags -> Ghc a) -> IO a #endif -inGhcIO flags' udynFlags ghcAct = do +inGhcIO flags' udynFlags dbs ghcAct = do debugM "leksah-server" $ "inGhcIO called with: " ++ show flags' libDir <- getSysLibDir -- (restFlags, _) <- parseStaticFlags (map noLoc flags') @@ -97,7 +97,8 @@ let dynflags'' = dynflags' { hscTarget = HscNothing, ghcMode = CompManager, - ghcLink = NoLink + ghcLink = NoLink, + extraPkgConfs = (map PkgConfFile dbs++) . extraPkgConfs dynflags' } dynflags''' <- parseGhcFlags dynflags'' (map (noLoc . T.unpack) flags') flags' res <- defaultCleanupHandler dynflags''' $ do @@ -212,7 +213,7 @@ }} myParseHeader :: FilePath -> String -> [Text] -> IO (Either Text (DynFlags, HsModule RdrName)) -myParseHeader fp _str opts = inGhcIO (opts++["-cpp"]) [] $ \ _dynFlags -> do +myParseHeader fp _str opts = inGhcIO (opts++["-cpp"]) [] [] $ \ _dynFlags -> do session <- getSession #if MIN_VERSION_ghc(7,2,0) (dynFlags',fp') <- liftIO $ preprocess session (fp,Nothing) 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 @@ -47,7 +47,7 @@ ipAddress (a, b, c, d) = fromIntegral a + 0x100 * fromIntegral b + 0x10000 * fromIntegral c + 0x1000000 * fromIntegral d -- | the functionality of a server -type ServerRoutine = (Handle, HostName, PortNumber) -> IO () +type ServerRoutine = (Handle, HostName, PortNumber) -> MVar () -> IO () serverSocket' :: Server -> IO Socket serverSocket' (Server (SockAddrInet _ _) t _) = socket AF_INET t defaultProtocol @@ -71,7 +71,7 @@ startAccepting :: (Socket, Server) -> IO (ThreadId, MVar ()) startAccepting (sock, server) = do mvar <- newEmptyMVar - threadId <- forkIO (acceptance sock (serverRoutine server) `finally` putMVar mvar ()) + threadId <- forkIO (acceptance sock mvar (serverRoutine server) `finally` putMVar mvar ()) return (threadId, mvar) serveMany :: Maybe UserAndGroup -> [Server] -> IO [(ThreadId, MVar ())] @@ -98,12 +98,13 @@ instance WaitFor (ThreadId, MVar ()) where waitFor (_, mvar) = waitFor mvar -acceptance :: Socket -> ServerRoutine -> IO () -acceptance sock action = E.catch (do +acceptance :: Socket -> MVar () -> ServerRoutine -> IO () +acceptance sock mvar action = E.catch (do dta <- accept sock - void . forkIO $ action dta) + void . forkIO $ action dta mvar) (\(e :: SomeException) -> print e) >> - acceptance sock action + acceptance sock mvar 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 @@ -70,6 +70,8 @@ import System.Exit (ExitCode(..)) import System.IO (hClose, hFlush, Handle, hSetBuffering, BufferMode(..)) +import System.Directory (doesFileExist) +import System.FilePath (()) import Data.Conduit as C ((=$), ($$), ($=)) import qualified Data.Conduit as C @@ -511,7 +513,8 @@ tool <- newToolState writeChan (toolCommands tool) $ ToolCommand (":set " <> T.unwords interactiveFlags <> "\n:set prompt " <> ghciPrompt) "" startupOutputHandler - runInteractiveTool tool ghciCommandLineReader "cabal" + useStack <- doesFileExist $ dir "stack.yaml" + runInteractiveTool tool ghciCommandLineReader (if useStack then "stack" else "cabal") ("repl" : maybeToList mbExe) (Just dir) return tool