leksah-server 0.15.0.9 → 0.15.2.0

raw patch · 11 files changed

+239/−174 lines, 11 filesdep −attoparsec-conduitdep ~HTTPdep ~HUnitdep ~leksah-serverPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies removed: attoparsec-conduit

Dependency ranges changed: HTTP, HUnit, leksah-server, parsec

API changes (from Hackage documentation)

Files

• leksah-server.cabal +11/−11
• main/Collector.hs +33/−30
• src/IDE/Core/CTypes.hs +46/−10
• src/IDE/Metainfo/InterfaceCollector.hs +2/−2
• src/IDE/Metainfo/PackageCollector.hs +60/−67
• src/IDE/Metainfo/SourceCollectorH.hs +1/−1
• src/IDE/Metainfo/WorkspaceCollector.hs +19/−21
• src/IDE/Utils/FileUtils.hs +48/−18
• src/IDE/Utils/GHCUtils.hs +8/−7
• src/IDE/Utils/Server.hs +7/−6
• src/IDE/Utils/Tool.hs +4/−1

@@ -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 

@@ -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

@@ -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)

@@ -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

@@ -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"

@@ -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

@@ -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)

@@ -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

@@ -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)

@@ -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+   

@@ -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