leksah-server 0.15.0.7 → 0.15.0.8

raw patch · 9 files changed

+410/−411 lines, 9 filesdep ~leksah-serverPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependency ranges changed: leksah-server

API changes (from Hackage documentation)

Files

• leksah-server.cabal +12/−16
• main/Collector.hs +325/−0
• main/LeksahEcho.hs +38/−0
• main/LeksahTrue.hs +20/−0
• src/IDE/Metainfo/Collector.hs +0/−325
• src/IDE/Utils/Tool.hs +11/−8
• src/LeksahEcho.hs +0/−38
• src/LeksahTrue.hs +0/−20
• tests/TestTool.hs +4/−4

@@ -1,5 +1,5 @@ name: leksah-server-version: 0.15.0.7+version: 0.15.0.8 cabal-version: >= 1.10.2 build-type: Simple license: GPL@@ -78,14 +78,15 @@     exposed-modules: IDE.Utils.GHCUtils IDE.Utils.Utils IDE.Utils.Tool         IDE.Utils.FileUtils IDE.Core.CTypes IDE.Core.Serializable IDE.StrippedPrefs         IDE.Utils.Server IDE.Metainfo.PackageCollector IDE.Utils.VersionUtils+        IDE.Metainfo.WorkspaceCollector IDE.Metainfo.SourceDB+        IDE.HeaderParser IDE.Metainfo.SourceCollectorH     exposed: True     buildable: True     default-extensions: CPP     hs-source-dirs: src     other-modules:-        IDE.Metainfo.WorkspaceCollector IDE.Metainfo.InterfaceCollector-        IDE.Metainfo.SourceCollectorH-        IDE.Metainfo.SourceDB Paths_leksah_server+        IDE.Metainfo.InterfaceCollector+        Paths_leksah_server     ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans  executable leksah-server@@ -100,7 +101,7 @@                conduit-extra >=1.0.0.1 && <1.2, resourcet,                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, process >= 1.1 && <1.3+               HTTP >=4000.1.2 && <4000.3, process >= 1.1 && <1.3, leksah-server ==0.15.0.8     if (impl(ghc >= 7.10))        build-depends: haddock-api >=2.16 && <2.17, haddock-library >=1.2.0 && <1.3, bin-package-db     else@@ -135,15 +136,10 @@     if os(osx)         ghc-options: -optl-headerpad_max_install_names -    main-is: IDE/Metainfo/Collector.hs+    main-is: Collector.hs     buildable: True     default-extensions: CPP-    hs-source-dirs: src-    other-modules: IDE.StrippedPrefs IDE.Utils.GHCUtils IDE.Utils.Utils-        IDE.Core.CTypes IDE.Core.Serializable-        IDE.Metainfo.WorkspaceCollector IDE.Metainfo.InterfaceCollector-        IDE.Metainfo.SourceCollectorH IDE.Metainfo.SourceDB IDE.Utils.Tool-        IDE.HeaderParser IDE.Metainfo.PackageCollector+    hs-source-dirs: main      if flag(threaded)         ghc-options: -threaded@@ -155,13 +151,13 @@     main-is: LeksahEcho.hs     buildable: True     default-extensions: CPP-    hs-source-dirs: src+    hs-source-dirs: main     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,                transformers >=0.2.2.0 && <0.5, text >=0.11.3.1 && <1.3,-               process >= 1.1 && <1.3+               process >= 1.1 && <1.3, leksah-server ==0.15.0.8      if !os(windows)         build-depends: unix >=2.3.1.0 && <2.8@@ -175,7 +171,7 @@     default-language: Haskell98     main-is: LeksahTrue.hs     buildable: True-    hs-source-dirs: src+    hs-source-dirs: main     build-depends:  base >= 4.0.0.0 && <4.9  test-suite test-tool@@ -184,7 +180,7 @@     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.7,+               leksah-server == 0.15.0.8,                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,                process >= 1.1 && <1.3

@@ -0,0 +1,325 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+-----------------------------------------------------------------------------+--+-- Module      :  Main+-- Copyright   :  2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License     :  GPL+--+-- Maintainer  :  maintainer@leksah.org+-- Stability   :  provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module Main (+    main+,   collectPackage+) where++import Control.Applicative+import Prelude+import System.Console.GetOpt+    (ArgDescr(..), usageInfo, ArgOrder(..), getOpt, OptDescr(..))+import System.Environment (getArgs)+import Control.Monad (when)+import Data.Version (showVersion)+import IDE.Utils.FileUtils+import IDE.Utils.Utils+import IDE.Utils.GHCUtils+import IDE.StrippedPrefs+import IDE.Metainfo.WorkspaceCollector+import Data.Maybe(catMaybes, fromJust, mapMaybe, isJust)+#if MIN_VERSION_ghc(7,8,0)+#else+import Prelude hiding(catch)+#endif+import Control.Monad (liftM)+import qualified Data.Set as Set (member)+import IDE.Core.CTypes hiding (Extension)+import IDE.Metainfo.SourceDB (buildSourceForPackageDB, getDataDir, version)+import Data.Time+import Control.Exception+       (catch, SomeException)+import System.Log+import System.Log.Logger(updateGlobalLogger,rootLoggerName,addHandler,debugM,infoM,errorM,+    setLevel)+import System.Log.Handler.Simple(fileHandler)+import Network(withSocketsDo)+import Network.Socket+       (inet_addr, SocketType(..), SockAddr(..))+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 IDE.Metainfo.PackageCollector(collectPackage)+import Data.List (delete)+import System.Directory+       (removeFile, doesFileExist, removeDirectoryRecursive,+        doesDirectoryExist)+import IDE.Metainfo.SourceCollectorH (PackageCollectStats(..))+import Control.Monad.IO.Class (MonadIO(..))+import qualified Data.Text as T (strip, pack, unpack)+import Data.Text (Text)+import Data.Monoid ((<>))++-- --------------------------------------------------------------------+-- Command line options+--+++data Flag =    CollectSystem++             | ServerCommand (Maybe Text)+             --modifiers+             | Rebuild+             | Sources+             -- | Directory FilePath+             --others+             | VersionF+             | Help+             | Debug+             | Verbosity Text+             | LogFile Text+             | Forever+             | EndWithLast+       deriving (Show,Eq)++options :: [OptDescr Flag]++options =   [+-- main functions+             Option ['s'] ["system"] (NoArg CollectSystem)+                "Collects new information for installed packages"+         ,   Option ['r'] ["server"] (OptArg (ServerCommand . (T.pack <$>)) "Maybe Port")+                "Start as server."+         ,   Option ['b'] ["rebuild"] (NoArg Rebuild)+                "Modifier for -s and -p: Rebuild metadata"+         ,   Option ['o'] ["sources"] (NoArg Sources)+                "Modifier for -s: Gather info about pathes to sources"+         ,   Option ['v'] ["version"] (NoArg VersionF)+                "Show the version number of ide"+         ,   Option ['h'] ["help"] (NoArg Help)+                "Display command line options"+         ,   Option ['d'] ["debug"] (NoArg Debug)+                "Write ascii pack files"+         ,   Option ['e'] ["verbosity"] (ReqArg (Verbosity . T.pack) "Verbosity")+                "One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"+         ,   Option ['l'] ["logfile"] (ReqArg (LogFile . T.pack) "LogFile")+                "File path for logging messages"+         ,   Option ['f'] ["forever"] (NoArg Forever)+                "Don't end the server when last connection ends"+         ,   Option ['c'] ["endWithLast"] (NoArg EndWithLast)+                "End the server when last connection ends"++    ]++header :: String+header = "Usage: leksah-server [OPTION...] files..."++ideOpts :: [String] -> IO ([Flag], [String])+ideOpts argv =+    case getOpt Permute options argv of+          (o,n,[]  ) -> return (o,n)+          (_,_,errs) -> ioError $ userError $ concat errs ++ usageInfo header options++-- ---------------------------------------------------------------------+-- | Main function+--++main :: IO ()+main =  withSocketsDo $ catch inner handler+    where+        handler (e :: SomeException) = do+            putStrLn $ "leksah-server: " ++ (show e)+            errorM "leksah-server" (show e)+            return ()+        inner = do+            args            <- getArgs+            (o,_)           <- ideOpts args+            let verbosity'   =  catMaybes $+                                    map (\x -> case x of+                                        Verbosity s -> Just s+                                        _           -> Nothing) o+            let verbosity    =  case verbosity' of+                                    [] -> INFO+                                    h:_ -> read $ T.unpack h+            let logFile'     =  catMaybes $+                                    map (\x -> case x of+                                        LogFile s   -> Just s+                                        _           -> Nothing) o+            let logFile     =  case logFile' of+                                    [] -> Nothing+                                    h:_ -> Just h+            updateGlobalLogger rootLoggerName (\ l -> setLevel verbosity l)+            when (isJust logFile) $  do+                handler' <- fileHandler (T.unpack $ fromJust logFile) verbosity+                updateGlobalLogger rootLoggerName (\ l -> addHandler handler' l)+            infoM "leksah-server" $ "***server start"+            debugM "leksah-server" $ "args: " ++ show args+            dataDir         <- getDataDir+            prefsPath       <- getConfigFilePathForLoad strippedPreferencesFilename Nothing dataDir+            prefs           <- readStrippedPrefs prefsPath+            debugM "leksah-server" $ "prefs " ++ show prefs+            connRef  <- newIORef []+            threadId <- myThreadId+            localServerAddr <- inet_addr "127.0.0.1"++            if elem VersionF o+                then putStrLn $ "Leksah Haskell IDE (server), version " ++ showVersion version+                else if elem Help o+                    then putStrLn $ "Leksah Haskell IDE (server) " ++ usageInfo header options+                    else do+                        let servers     =   catMaybes $+                                                map (\x -> case x of+                                                                ServerCommand s -> Just s+                                                                _        -> Nothing) o+                        let sources     =   elem Sources o+                        let rebuild     =   elem Rebuild o+                        let debug       =   elem Debug o+                        let forever     =   elem Forever o+                        let endWithLast =   elem EndWithLast o+                        let newPrefs    =   if forever && not endWithLast+                                                then prefs{endWithLastConn = False}+                                                else if  not forever && endWithLast+                                                        then prefs{endWithLastConn = True}+                                                        else prefs+                        if elem CollectSystem o+                            then do+                                debugM "leksah-server" "collectSystem"+                                collectSystem prefs debug rebuild sources+                            else+                                case servers of+                                    (Nothing:_)  -> do+                                        running <- serveOne Nothing (server (fromIntegral+                                            (serverPort prefs)) newPrefs connRef threadId localServerAddr)+                                        waitFor running+                                        return ()+                                    (Just ps:_)  -> do+                                        let port = read $ T.unpack ps+                                        running <- serveOne Nothing (server+                                            (fromIntegral port) newPrefs connRef threadId localServerAddr)+                                        waitFor running+                                        return ()+                                    _ -> return ()++        server port prefs connRef threadId hostAddr = Server (SockAddrInet port hostAddr) Stream+                                        (doCommands prefs connRef threadId)++doCommands :: Prefs -> IORef [Handle] -> ThreadId -> (Handle, t1, t2) -> IO ()+doCommands prefs connRef threadId (h,n,p) = do+    atomicModifyIORef connRef (\ list -> (h : list, ()))+    doCommands' prefs connRef threadId (h,n,p)+++doCommands' :: Prefs -> IORef [Handle] -> ThreadId -> (Handle, t1, t2) -> IO ()+doCommands' prefs connRef threadId (h,n,p) = do+    debugM "leksah-server" $ "***wait"+    mbLine <- catch (liftM Just (hGetLine h))+                (\ (_e :: SomeException) -> do+                    infoM "leksah-server" $ "***lost connection"+                    hClose h+                    atomicModifyIORef connRef (\ list -> (delete h list,()))+                    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"+                                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+                        catch (do+                            collectSystem prefs False rebuild sources+                            hPutStrLn h (show ServerOK)+                            hFlush h)+                        (\ (e :: SomeException) -> do+                            hPutStrLn h (show (ServerFailed (T.pack $ show e)))+                            hFlush h)+                    WorkspaceCommand rebuild package path modList ->+                        catch (do+                            collectWorkspace package modList rebuild False path+                            hPutStrLn h (show ServerOK)+                            hFlush h)+                        (\ (e :: SomeException) -> do+                            hPutStrLn h (show (ServerFailed (T.pack $ show e)))+                            hFlush h)+                    ParseHeaderCommand filePath ->+                        catch (do+                            res <- parseTheHeader filePath+                            hPutStrLn h (show res)+                            hFlush h)+                        (\ (e :: SomeException) -> do+                            hPutStrLn h (show (ServerFailed (T.pack $ show e)))+                            hFlush h)+            doCommands' prefs connRef threadId (h,n,p)++collectSystem :: Prefs -> Bool -> Bool -> Bool -> IO()+collectSystem prefs writeAscii forceRebuild findSources = do+    collectorPath       <- getCollectorPath+    when forceRebuild $ do+        exists           <- doesDirectoryExist collectorPath+        when exists $ removeDirectoryRecursive collectorPath+        reportPath       <-  getConfigFilePathForSave "collectSystem.report"+        exists'          <- doesFileExist reportPath+        when exists' (removeFile reportPath)+        return ()+    knownPackages       <-  findKnownPackages collectorPath+    debugM "leksah-server" $ "collectSystem knownPackages= " ++ show knownPackages+    packageInfos        <-  inGhcIO [] [] $  \ _ -> getInstalledPackageInfos+    debugM "leksah-server" $ "collectSystem packageInfos= " ++ show (map (packId . getThisPackage) packageInfos)+    let newPackages     =   filter (\pid -> not $Set.member (packageIdentifierToString . packId $ getThisPackage pid)+                                                         knownPackages)+                                    packageInfos+    if null newPackages+        then do+            infoM "leksah-server" "Metadata collector has nothing to do"+        else do+            when findSources $ liftIO $ buildSourceForPackageDB prefs+            infoM "leksah-server" "update_toolbar 0.0"+            stats <- mapM (collectPackage writeAscii prefs (length newPackages))+                            (zip newPackages [1 .. length newPackages])+            writeStats stats+    infoM "leksah-server" "Metadata collection has finished"++writeStats :: [PackageCollectStats] -> IO ()+writeStats stats = do+    reportPath       <-  getConfigFilePathForSave "collectSystem.report"+    time             <-  getCurrentTime+    appendFile reportPath (report time)+    where+        report time = "\n++++++++++++++++++++++++++++++\n" ++ show time ++ "\n++++++++++++++++++++++++++++++\n"+                        ++ header' time ++ summary ++ T.unpack details+        header' _time = "\nLeksah system metadata collection "+        summary = "\nSuccess with         = " ++ T.unpack packs +++                  "\nPackages total       = " ++ show packagesTotal +++                  "\nPackages with source = " ++ show packagesWithSource +++                  "\nPackages retreived   = " ++ show packagesRetreived +++                  "\nModules total        = " ++ show modulesTotal' +++                  "\nModules with source  = " ++ show modulesWithSource +++                  "\nPercentage source    = " ++ show percentageWithSource+        packagesTotal        = length stats+        packagesWithSource   = length (filter withSource stats)+        packagesRetreived    = length (filter retrieved stats)+        modulesTotal'        = sum (mapMaybe modulesTotal stats)+        modulesWithSource    = sum (mapMaybe modulesTotal (filter withSource stats))+        percentageWithSource = (fromIntegral modulesWithSource) * 100.0 /+                                    (fromIntegral modulesTotal')+        details              = foldr detail "" (filter (isJust . mbError) stats)+        detail stat string   = string <> "\n" <> packageString stat <> " " <> (T.strip . fromJust $ mbError stat)+        packs                = foldr (\stat string -> string <> packageString stat <> " ")+                                        "" (take 10 (filter withSource stats))+                                        <> if packagesWithSource > 10 then "..." else ""++

@@ -0,0 +1,38 @@+-----------------------------------------------------------------------------+--+-- 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 echo executable (so --with-ghc=echo fails)+--+-----------------------------------------------------------------------------++module Main (+main+) where++import System.Environment (getArgs)+import IDE.Utils.VersionUtils (getHaddockVersion, getGhcVersion, getGhcInfo)+import qualified Data.Text as T (unpack)+import Control.Applicative+import Prelude++main :: IO ()+main = do+    args <- getArgs+--    appendFile "/Users/hamish/lecho.log" $ show args ++ "/n"+    if elem  "--version" args+        then putStrLn =<< T.unpack <$> getHaddockVersion+        else if elem  "--ghc-version" args+                then putStrLn =<<  getGhcVersion+                else if elem  "--info" args+                        then putStrLn =<< T.unpack <$> getGhcInfo+                        else if elem  "--numeric-version" args+                                then putStrLn =<<  getGhcVersion+                                else putStrLn $ unwords args+

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

@@ -1,325 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}-{-# OPTIONS_GHC -fno-warn-type-defaults #-}------------------------------------------------------------------------------------ Module      :  Main--- Copyright   :  2007-2011 Juergen Nicklisch-Franken, Hamish Mackenzie--- License     :  GPL------ Maintainer  :  maintainer@leksah.org--- Stability   :  provisional--- Portability :------ |-----------------------------------------------------------------------------------module Main (-    main-,   collectPackage-) where--import Control.Applicative-import Prelude-import System.Console.GetOpt-    (ArgDescr(..), usageInfo, ArgOrder(..), getOpt, OptDescr(..))-import System.Environment (getArgs)-import Control.Monad (when)-import Data.Version (showVersion)-import IDE.Utils.FileUtils-import IDE.Utils.Utils-import IDE.Utils.GHCUtils-import IDE.StrippedPrefs-import IDE.Metainfo.WorkspaceCollector-import Data.Maybe(catMaybes, fromJust, mapMaybe, isJust)-#if MIN_VERSION_ghc(7,8,0)-#else-import Prelude hiding(catch)-#endif-import Control.Monad (liftM)-import qualified Data.Set as Set (member)-import IDE.Core.CTypes hiding (Extension)-import IDE.Metainfo.SourceDB (buildSourceForPackageDB, getDataDir, version)-import Data.Time-import Control.Exception-       (catch, SomeException)-import System.Log-import System.Log.Logger(updateGlobalLogger,rootLoggerName,addHandler,debugM,infoM,errorM,-    setLevel)-import System.Log.Handler.Simple(fileHandler)-import Network(withSocketsDo)-import Network.Socket-       (inet_addr, SocketType(..), SockAddr(..))-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 IDE.Metainfo.PackageCollector(collectPackage)-import Data.List (delete)-import System.Directory-       (removeFile, doesFileExist, removeDirectoryRecursive,-        doesDirectoryExist)-import IDE.Metainfo.SourceCollectorH (PackageCollectStats(..))-import Control.Monad.IO.Class (MonadIO(..))-import qualified Data.Text as T (strip, pack, unpack)-import Data.Text (Text)-import Data.Monoid ((<>))---- ----------------------------------------------------------------------- Command line options------data Flag =    CollectSystem--             | ServerCommand (Maybe Text)-             --modifiers-             | Rebuild-             | Sources-             -- | Directory FilePath-             --others-             | VersionF-             | Help-             | Debug-             | Verbosity Text-             | LogFile Text-             | Forever-             | EndWithLast-       deriving (Show,Eq)--options :: [OptDescr Flag]--options =   [--- main functions-             Option ['s'] ["system"] (NoArg CollectSystem)-                "Collects new information for installed packages"-         ,   Option ['r'] ["server"] (OptArg (ServerCommand . (T.pack <$>)) "Maybe Port")-                "Start as server."-         ,   Option ['b'] ["rebuild"] (NoArg Rebuild)-                "Modifier for -s and -p: Rebuild metadata"-         ,   Option ['o'] ["sources"] (NoArg Sources)-                "Modifier for -s: Gather info about pathes to sources"-         ,   Option ['v'] ["version"] (NoArg VersionF)-                "Show the version number of ide"-         ,   Option ['h'] ["help"] (NoArg Help)-                "Display command line options"-         ,   Option ['d'] ["debug"] (NoArg Debug)-                "Write ascii pack files"-         ,   Option ['e'] ["verbosity"] (ReqArg (Verbosity . T.pack) "Verbosity")-                "One of DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY"-         ,   Option ['l'] ["logfile"] (ReqArg (LogFile . T.pack) "LogFile")-                "File path for logging messages"-         ,   Option ['f'] ["forever"] (NoArg Forever)-                "Don't end the server when last connection ends"-         ,   Option ['c'] ["endWithLast"] (NoArg EndWithLast)-                "End the server when last connection ends"--    ]--header :: String-header = "Usage: leksah-server [OPTION...] files..."--ideOpts :: [String] -> IO ([Flag], [String])-ideOpts argv =-    case getOpt Permute options argv of-          (o,n,[]  ) -> return (o,n)-          (_,_,errs) -> ioError $ userError $ concat errs ++ usageInfo header options---- ------------------------------------------------------------------------ | Main function-----main :: IO ()-main =  withSocketsDo $ catch inner handler-    where-        handler (e :: SomeException) = do-            putStrLn $ "leksah-server: " ++ (show e)-            errorM "leksah-server" (show e)-            return ()-        inner = do-            args            <- getArgs-            (o,_)           <- ideOpts args-            let verbosity'   =  catMaybes $-                                    map (\x -> case x of-                                        Verbosity s -> Just s-                                        _           -> Nothing) o-            let verbosity    =  case verbosity' of-                                    [] -> INFO-                                    h:_ -> read $ T.unpack h-            let logFile'     =  catMaybes $-                                    map (\x -> case x of-                                        LogFile s   -> Just s-                                        _           -> Nothing) o-            let logFile     =  case logFile' of-                                    [] -> Nothing-                                    h:_ -> Just h-            updateGlobalLogger rootLoggerName (\ l -> setLevel verbosity l)-            when (isJust logFile) $  do-                handler' <- fileHandler (T.unpack $ fromJust logFile) verbosity-                updateGlobalLogger rootLoggerName (\ l -> addHandler handler' l)-            infoM "leksah-server" $ "***server start"-            debugM "leksah-server" $ "args: " ++ show args-            dataDir         <- getDataDir-            prefsPath       <- getConfigFilePathForLoad strippedPreferencesFilename Nothing dataDir-            prefs           <- readStrippedPrefs prefsPath-            debugM "leksah-server" $ "prefs " ++ show prefs-            connRef  <- newIORef []-            threadId <- myThreadId-            localServerAddr <- inet_addr "127.0.0.1"--            if elem VersionF o-                then putStrLn $ "Leksah Haskell IDE (server), version " ++ showVersion version-                else if elem Help o-                    then putStrLn $ "Leksah Haskell IDE (server) " ++ usageInfo header options-                    else do-                        let servers     =   catMaybes $-                                                map (\x -> case x of-                                                                ServerCommand s -> Just s-                                                                _        -> Nothing) o-                        let sources     =   elem Sources o-                        let rebuild     =   elem Rebuild o-                        let debug       =   elem Debug o-                        let forever     =   elem Forever o-                        let endWithLast =   elem EndWithLast o-                        let newPrefs    =   if forever && not endWithLast-                                                then prefs{endWithLastConn = False}-                                                else if  not forever && endWithLast-                                                        then prefs{endWithLastConn = True}-                                                        else prefs-                        if elem CollectSystem o-                            then do-                                debugM "leksah-server" "collectSystem"-                                collectSystem prefs debug rebuild sources-                            else-                                case servers of-                                    (Nothing:_)  -> do-                                        running <- serveOne Nothing (server (fromIntegral-                                            (serverPort prefs)) newPrefs connRef threadId localServerAddr)-                                        waitFor running-                                        return ()-                                    (Just ps:_)  -> do-                                        let port = read $ T.unpack ps-                                        running <- serveOne Nothing (server-                                            (fromIntegral port) newPrefs connRef threadId localServerAddr)-                                        waitFor running-                                        return ()-                                    _ -> return ()--        server port prefs connRef threadId hostAddr = Server (SockAddrInet port hostAddr) Stream-                                        (doCommands prefs connRef threadId)--doCommands :: Prefs -> IORef [Handle] -> ThreadId -> (Handle, t1, t2) -> IO ()-doCommands prefs connRef threadId (h,n,p) = do-    atomicModifyIORef connRef (\ list -> (h : list, ()))-    doCommands' prefs connRef threadId (h,n,p)---doCommands' :: Prefs -> IORef [Handle] -> ThreadId -> (Handle, t1, t2) -> IO ()-doCommands' prefs connRef threadId (h,n,p) = do-    debugM "leksah-server" $ "***wait"-    mbLine <- catch (liftM Just (hGetLine h))-                (\ (_e :: SomeException) -> do-                    infoM "leksah-server" $ "***lost connection"-                    hClose h-                    atomicModifyIORef connRef (\ list -> (delete h list,()))-                    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"-                                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-                        catch (do-                            collectSystem prefs False rebuild sources-                            hPutStrLn h (show ServerOK)-                            hFlush h)-                        (\ (e :: SomeException) -> do-                            hPutStrLn h (show (ServerFailed (T.pack $ show e)))-                            hFlush h)-                    WorkspaceCommand rebuild package path modList ->-                        catch (do-                            collectWorkspace package modList rebuild False path-                            hPutStrLn h (show ServerOK)-                            hFlush h)-                        (\ (e :: SomeException) -> do-                            hPutStrLn h (show (ServerFailed (T.pack $ show e)))-                            hFlush h)-                    ParseHeaderCommand filePath ->-                        catch (do-                            res <- parseTheHeader filePath-                            hPutStrLn h (show res)-                            hFlush h)-                        (\ (e :: SomeException) -> do-                            hPutStrLn h (show (ServerFailed (T.pack $ show e)))-                            hFlush h)-            doCommands' prefs connRef threadId (h,n,p)--collectSystem :: Prefs -> Bool -> Bool -> Bool -> IO()-collectSystem prefs writeAscii forceRebuild findSources = do-    collectorPath       <- getCollectorPath-    when forceRebuild $ do-        exists           <- doesDirectoryExist collectorPath-        when exists $ removeDirectoryRecursive collectorPath-        reportPath       <-  getConfigFilePathForSave "collectSystem.report"-        exists'          <- doesFileExist reportPath-        when exists' (removeFile reportPath)-        return ()-    knownPackages       <-  findKnownPackages collectorPath-    debugM "leksah-server" $ "collectSystem knownPackages= " ++ show knownPackages-    packageInfos        <-  inGhcIO [] [] $  \ _ -> getInstalledPackageInfos-    debugM "leksah-server" $ "collectSystem packageInfos= " ++ show (map (packId . getThisPackage) packageInfos)-    let newPackages     =   filter (\pid -> not $Set.member (packageIdentifierToString . packId $ getThisPackage pid)-                                                         knownPackages)-                                    packageInfos-    if null newPackages-        then do-            infoM "leksah-server" "Metadata collector has nothing to do"-        else do-            when findSources $ liftIO $ buildSourceForPackageDB prefs-            infoM "leksah-server" "update_toolbar 0.0"-            stats <- mapM (collectPackage writeAscii prefs (length newPackages))-                            (zip newPackages [1 .. length newPackages])-            writeStats stats-    infoM "leksah-server" "Metadata collection has finished"--writeStats :: [PackageCollectStats] -> IO ()-writeStats stats = do-    reportPath       <-  getConfigFilePathForSave "collectSystem.report"-    time             <-  getCurrentTime-    appendFile reportPath (report time)-    where-        report time = "\n++++++++++++++++++++++++++++++\n" ++ show time ++ "\n++++++++++++++++++++++++++++++\n"-                        ++ header' time ++ summary ++ T.unpack details-        header' _time = "\nLeksah system metadata collection "-        summary = "\nSuccess with         = " ++ T.unpack packs ++-                  "\nPackages total       = " ++ show packagesTotal ++-                  "\nPackages with source = " ++ show packagesWithSource ++-                  "\nPackages retreived   = " ++ show packagesRetreived ++-                  "\nModules total        = " ++ show modulesTotal' ++-                  "\nModules with source  = " ++ show modulesWithSource ++-                  "\nPercentage source    = " ++ show percentageWithSource-        packagesTotal        = length stats-        packagesWithSource   = length (filter withSource stats)-        packagesRetreived    = length (filter retrieved stats)-        modulesTotal'        = sum (mapMaybe modulesTotal stats)-        modulesWithSource    = sum (mapMaybe modulesTotal (filter withSource stats))-        percentageWithSource = (fromIntegral modulesWithSource) * 100.0 /-                                    (fromIntegral modulesTotal')-        details              = foldr detail "" (filter (isJust . mbError) stats)-        detail stat string   = string <> "\n" <> packageString stat <> " " <> (T.strip . fromJust $ mbError stat)-        packs                = foldr (\stat string -> string <> packageString stat <> " ")-                                        "" (take 10 (filter withSource stats))-                                        <> if packagesWithSource > 10 then "..." else ""--

@@ -80,7 +80,7 @@ import qualified Data.Conduit.Binary as CB import Data.Conduit.Attoparsec (sinkParser) import qualified Data.Attoparsec.Text as AP-       (endOfInput, takeWhile, satisfy, skipWhile, string, Parser,+       (endOfInput, takeWhile, satisfy, string, Parser,         endOfLine, digit, manyTill, takeWhile1, char) import Data.Attoparsec.Text ((<?>)) import Data.Char (isDigit)@@ -210,6 +210,9 @@     output <- getOutput clr inp out err pid      forkIO $ do+        case initialCommand clr of+            Just cmd -> hPutStrLn inp cmd >> hFlush inp+            Nothing  -> return ()         commands <- getChanContents (toolCommandsRead tool)         output $= outputSequence inp $$ processCommand commands inp         return ()@@ -274,6 +277,7 @@ ghciPrompt = "3KM2KWR7LZZbHdXfHUOA5YBBsJVYoCQnKX"  data CommandLineReader = CommandLineReader {+    initialCommand :: Maybe Text,     parseInitialPrompt :: AP.Parser Text,     parseFollowingPrompt :: AP.Parser Text,     errorSyncCommand :: Maybe (Int -> Text),@@ -283,11 +287,8 @@     }  ghciParseInitialPrompt :: AP.Parser Text-ghciParseInitialPrompt = (do-        AP.string "Prelude" <|> AP.string "*" <|> AP.string ">"-        AP.skipWhile (\c -> c /= '>' && c/= '\n')-        AP.string "> "-        return "")+ghciParseInitialPrompt = (+        T.pack <$> AP.satisfy (/= '\n') `AP.manyTill` AP.string ghciPrompt)     <?> "ghciParseInitialPrompt"  ghciParseFollowingPrompt :: AP.Parser Text@@ -349,16 +350,18 @@  ghciCommandLineReader :: CommandLineReader ghciCommandLineReader    = CommandLineReader {+    initialCommand       = Just $ ":set prompt " <> ghciPrompt,     parseInitialPrompt   = ghciParseInitialPrompt,     parseFollowingPrompt = ghciParseFollowingPrompt,-    errorSyncCommand     = Just $ \n -> marker n,+    errorSyncCommand     = Just $ \count -> marker count,     parseExpectedError   = ghciParseExpectedError,-    outputSyncCommand    = Just $ \n -> ":set prompt \"" <> marker n <> "\\n\"\n:set prompt " <> ghciPrompt,+    outputSyncCommand    = Just $ \count -> ":set prompt \"" <> marker count <> "\\n\"\n:set prompt " <> ghciPrompt,     isExpectedOutput     = ghciIsExpectedOutput     }  noInputCommandLineReader :: CommandLineReader noInputCommandLineReader = CommandLineReader {+    initialCommand = Nothing,     parseInitialPrompt = fail "No Prompt Expected",     parseFollowingPrompt = fail "No Prompt Expected",     errorSyncCommand = Nothing,

@@ -1,38 +0,0 @@------------------------------------------------------------------------------------ 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 echo executable (so --with-ghc=echo fails)-----------------------------------------------------------------------------------module Main (-main-) where--import System.Environment (getArgs)-import IDE.Utils.VersionUtils (getHaddockVersion, getGhcVersion, getGhcInfo)-import qualified Data.Text as T (unpack)-import Control.Applicative-import Prelude--main :: IO ()-main = do-    args <- getArgs---    appendFile "/Users/hamish/lecho.log" $ show args ++ "/n"-    if elem  "--version" args-        then putStrLn =<< T.unpack <$> getHaddockVersion-        else if elem  "--ghc-version" args-                then putStrLn =<<  getGhcVersion-                else if elem  "--info" args-                        then putStrLn =<< T.unpack <$> getGhcInfo-                        else if elem  "--numeric-version" args-                                then putStrLn =<<  getGhcVersion-                                else putStrLn $ unwords args-

@@ -1,20 +0,0 @@------------------------------------------------------------------------------------ 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 ()

@@ -136,9 +136,9 @@                 ToolInput "jfkdfjdkl",                 ToolError "", #if __GLASGOW_HASKELL__ > 706-                ToolError "<interactive>:22:1: Not in scope: ‘jfkdfjdkl’",+                ToolError "<interactive>:23:1: Not in scope: ‘jfkdfjdkl’", #elif __GLASGOW_HASKELL__ > 702-                ToolError "<interactive>:22:1: Not in scope: `jfkdfjdkl'",+                ToolError "<interactive>:23:1: Not in scope: `jfkdfjdkl'", #else                 ToolError "<interactive>:1:1: Not in scope: `jfkdfjdkl'", #endif@@ -162,9 +162,9 @@                 ToolInput "jfkdfjdkl",                 ToolError "", #if __GLASGOW_HASKELL__ > 706-                ToolError "<interactive>:35:1: Not in scope: ‘jfkdfjdkl’",+                ToolError "<interactive>:36:1: Not in scope: ‘jfkdfjdkl’", #elif __GLASGOW_HASKELL__ > 702-                ToolError "<interactive>:37:1: Not in scope: `jfkdfjdkl'",+                ToolError "<interactive>:38:1: Not in scope: `jfkdfjdkl'", #else                 ToolError "<interactive>:1:1: Not in scope: `jfkdfjdkl'", #endif