leksah-server 0.8.0.5 → 0.8.0.6
raw patch · 14 files changed
+652/−385 lines, 14 filesdep +curldep +process-leksahdep −process
Dependencies added: curl, process-leksah
Dependencies removed: process
Files
- data/prefscoll.lkshp +4/−2
- leksah-server.cabal +27/−5
- src/IDE/Core/CTypes.hs +36/−10
- src/IDE/Metainfo/Collector.hs +8/−206
- src/IDE/Metainfo/InterfaceCollector.hs +0/−6
- src/IDE/Metainfo/PackageCollector.hs +282/−0
- src/IDE/Metainfo/SourceCollectorH.hs +32/−37
- src/IDE/Metainfo/WorkspaceCollector.hs +7/−4
- src/IDE/StrippedPrefs.hs +15/−5
- src/IDE/Utils/FileUtils.hs +2/−24
- src/IDE/Utils/Server.hs +3/−3
- src/IDE/Utils/Tool.hs +187/−82
- src/IDE/Utils/VersionUtils.hs +48/−0
- src/LeksahEcho.hs +1/−1
data/prefscoll.lkshp view
@@ -2,8 +2,10 @@ [] Maybe a directory for unpacking cabal packages: Just "~/.leksah-0.8/packageSources"-Maybe an URL to load prebuild metadata :- Just "http://www.leksah.org"+An URL to load prebuild metadata:+ "http://www.leksah.org"+A strategy for downloading prebuild metadata:+ RetrieveThenBuild Port number for server connection: 11111 End the server with last connection:
leksah-server.cabal view
@@ -1,5 +1,5 @@ name: leksah-server-version: 0.8.0.5+version: 0.8.0.6 cabal-version: >= 1.2 build-type: Simple license: GPL@@ -18,12 +18,20 @@ tested-with: GHC ==6.10 || ==6.12 data-files: data/prefscoll.lkshp+flag curl+ Default: False+ Description: Use runs curl instead of wget (curl is the default on OSX)++flag libcurl+ Default: False+ Description: Use libcurl instead of running wget+ library build-depends: Cabal >=1.6.0.1, base >= 4.0.0.0 && <= 5, binary >=0.5.0.0, binary-shared >=0.8, bytestring >=0.9.0.1, containers >=0.2.0.0, directory >=1.0.0.2, filepath >=1.1.0.1, ghc >=6.10.1, ltk >=0.8 && <= 0.9, mtl >=1.1.0.2, parsec >=2.1.0.1,- pretty >=1.0.1.0, process >=1.0.1.0, time >= 1.1, deepseq >= 1.1,+ pretty >=1.0.1.0, process-leksah >=1.0.1.3, time >= 1.1, deepseq >= 1.1, hslogger >= 1.0.7, network >= 2.2 && <= 3.0 if (impl(ghc >= 6.12)) build-depends: haddock >= 2.7.2@@ -35,9 +43,16 @@ else build-depends: unix >=2.3.1.0 + if flag(curl) || os(osx)+ cpp-options: -DUSE_CURL++ if flag(libcurl)+ build-depends: curl >=1.3.5+ cpp-options: -DUSE_LIBCURL+ 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.Utils.Server IDE.Metainfo.PackageCollector IDE.Utils.VersionUtils exposed: True buildable: True extensions: CPP@@ -57,7 +72,7 @@ binary-shared >=0.8, bytestring >=0.9.0.1, containers >=0.2.0.0, directory >=1.0.0.2, filepath >=1.1.0.1, ghc >=6.10.1, ltk >=0.8 && <= 0.9, mtl >=1.1.0.2, parsec >=2.1.0.1,- pretty >=1.0.1.0, process >=1.0.1.0, deepseq >= 1.1, network >= 2.2 && <= 3.0+ pretty >=1.0.1.0, process-leksah >=1.0.1.3, deepseq >= 1.1, network >= 2.2 && <= 3.0 if (impl(ghc >= 6.12)) build-depends: haddock >= 2.7.2 else@@ -69,6 +84,13 @@ else build-depends: unix >=2.3.1.0 + if flag(curl) || os(osx)+ cpp-options: -DUSE_CURL++ if flag(libcurl)+ build-depends: curl >=1.3.5+ cpp-options: -DUSE_LIBCURL+ main-is: IDE/Metainfo/Collector.hs buildable: True extensions: CPP@@ -77,7 +99,7 @@ IDE.Core.CTypes IDE.Core.Serializable IDE.Metainfo.WorkspaceCollector IDE.Metainfo.InterfaceCollector IDE.Metainfo.SourceCollectorH IDE.Metainfo.SourceDB IDE.Utils.Tool- IDE.HeaderParser+ IDE.HeaderParser IDE.Metainfo.PackageCollector if (impl(ghc >= 6.12)) ghc-options: -Wall -fno-warn-unused-do-bind -ferror-spans -threaded -O2 else
src/IDE/Core/CTypes.hs view
@@ -58,6 +58,9 @@ , ImportSpecList(..) , ImportSpec(..) +, getThisPackage+, RetrieveStrategy(..)+ ) where import Data.Typeable (Typeable(..))@@ -69,7 +72,7 @@ (PackageName(..), PackageIdentifier(..)) import Distribution.ModuleName (components, ModuleName) import Data.ByteString.Char8 (ByteString)-import Distribution.Text (simpleParse, display)+import Distribution.Text (Text(..), simpleParse, display) import qualified Data.ByteString.Char8 as BS (unpack, empty) import qualified Data.Map as Map (lookup,keysSet,splitLookup, insertWith,empty,elems,union) import Text.PrettyPrint as PP@@ -78,6 +81,8 @@ import Control.DeepSeq (NFData(..)) import qualified Data.ByteString.Char8 as BS (ByteString) import Data.Version (Version(..))+import PackageConfig (PackageConfig)+import qualified Distribution.InstalledPackageInfo as IPI -- --------------------------------------------------------------------- -- | Information about the system, extraced from .hi and source files@@ -90,6 +95,16 @@ metadataVersion :: Integer metadataVersion = 7 +getThisPackage :: PackageConfig -> PackageIdentifier+#if MIN_VERSION_Cabal(1,8,0)+getThisPackage = IPI.sourcePackageId+#else+getThisPackage = IPI.package+#endif++data RetrieveStrategy = RetrieveThenBuild | BuildThenRetrieve | NeverRetrieve+ deriving (Show, Read, Eq, Ord, Enum, Bounded)+ data ServerCommand = SystemCommand { scRebuild :: Bool,@@ -140,6 +155,9 @@ , pdBuildDepends :: [PackageIdentifier] } deriving (Show,Typeable) +instance Default PackageDescr where+ getDefault = PackageDescr getDefault getDefault getDefault getDefault+ newtype Present alpha = Present alpha instance Show (Present PackageDescr) where@@ -158,6 +176,9 @@ , mdIdDescriptions :: [Descr] } deriving (Show,Typeable) +instance Default ModuleDescr where+ getDefault = ModuleDescr getDefault getDefault Map.empty getDefault+ instance Show (Present ModuleDescr) where show (Present md) = (show . mdModuleId) md @@ -338,15 +359,20 @@ instance Default PackModule where getDefault = parsePackModule "unknow-0:Undefined" --- | A portion of the source, spanning one or more lines and zero or more columns. -data SrcSpan = SrcSpan - { srcSpanFilename :: String - , srcSpanStartLine :: Int - , srcSpanStartColumn :: Int - , srcSpanEndLine :: Int - , srcSpanEndColumn :: Int - } - deriving (Eq,Ord,Show) +instance Default PackageIdentifier where+ getDefault = case packageIdentifierFromString "unknown-0" of+ Nothing -> error "CTypes.getDefault: Can't parse Package Identifier"+ Just it -> it++-- | A portion of the source, spanning one or more lines and zero or more columns.+data SrcSpan = SrcSpan+ { srcSpanFilename :: String+ , srcSpanStartLine :: Int+ , srcSpanStartColumn :: Int+ , srcSpanEndLine :: Int+ , srcSpanEndColumn :: Int+ }+ deriving (Eq,Ord,Show) data Location = Location { locationSLine :: Int
src/IDE/Metainfo/Collector.hs view
@@ -15,6 +15,7 @@ module Main ( main+, collectPackage ) where import System.Console.GetOpt@@ -23,28 +24,16 @@ import Control.Monad (when) import Data.Version (showVersion) import Paths_leksah_server (getDataDir, version)-import qualified Data.Map as Map-import Data.List(nub,delete) import IDE.Utils.FileUtils import IDE.Utils.Utils-import IDE.Metainfo.InterfaceCollector import IDE.Utils.GHCUtils import IDE.StrippedPrefs import IDE.Metainfo.WorkspaceCollector import Data.Maybe(catMaybes, fromJust, mapMaybe, isJust)-import Distribution.Text (display) import Prelude hiding(catch) import Control.Monad (liftM)-import System.Directory (removeDirectoryRecursive, doesFileExist, removeFile, doesDirectoryExist, setCurrentDirectory) import qualified Data.Set as Set (member) import IDE.Core.CTypes hiding (Extension)-import qualified Distribution.InstalledPackageInfo as IPI-import PackageConfig (PackageConfig)-import TcRnMonad (MonadIO(..))-import System.FilePath ((<.>), (</>))-import IDE.Metainfo.SourceCollectorH- (PackageCollectStats(..), collectPackageFromSource)-import Data.Binary.Shared (encodeFileSer) import IDE.Metainfo.SourceDB (buildSourceForPackageDB) import Data.Time import Control.Exception@@ -60,25 +49,22 @@ import IDE.Utils.Server import System.IO (Handle, hPutStrLn, hGetLine, hFlush, hClose) import IDE.HeaderParser(parseTheHeader)-import System.Process (system) import System.Exit (ExitCode(..))-import Distribution.Package (PackageIdentifier(..)) 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.Trans (liftIO) -- -------------------------------------------------------------------- -- Command line options -- --getThisPackage :: PackageConfig -> PackageIdentifier-#if MIN_VERSION_Cabal(1,8,0)-getThisPackage = IPI.sourcePackageId-#else-getThisPackage = IPI.package-#endif- data Flag = CollectSystem | ServerCommand (Maybe String)@@ -327,189 +313,5 @@ packs = foldr (\stat string -> string ++ packageString stat ++ " ") "" (take 10 (filter withSource stats)) ++ if packagesWithSource > 10 then "..." else ""---collectPackage :: Bool -> Prefs -> Int -> (PackageConfig,Int) -> IO PackageCollectStats-collectPackage writeAscii prefs numPackages (packageConfig, packageIndex) = do- infoM "leksah-server" ("update_toolbar " ++ show- ((fromIntegral packageIndex / fromIntegral numPackages) :: Double))- packageDescrHI <- collectPackageFromHI packageConfig- let packString = packageIdentifierToString (pdPackage packageDescrHI)- mbPackageDescrPair <- collectPackageFromSource prefs packageConfig- case mbPackageDescrPair of- (Nothing,stat, Just fp) -> do- -- Try to retreive prebuild package- case retreiveURL prefs of- Just url -> do- collectorPath <- liftIO $ getCollectorPath- setCurrentDirectory collectorPath- let fullUrl = url ++ "/metadata-" ++ leksahVersion ++ "/" ++ packString ++ leksahMetadataSystemFileExtension- debugM "leksah-server" $ "collectPackage: before retreiving = " ++ fullUrl- catch (system $ "wget " ++ fullUrl)- (\(e :: SomeException) -> do- debugM "leksah-server" $ "collectPackage: Error when calling wget " ++ show e- return (ExitFailure 1))- debugM "leksah-server" $ "collectPackage: after retreiving = " ++ packString -- ++ " result = " ++ res- let filePath = collectorPath </> packString <.> leksahMetadataSystemFileExtension- exist <- doesFileExist filePath- if exist- then do- debugM "leksah-server" $ "collectPackage: retreived = " ++ packString- liftIO $ writePackagePath fp packageDescrHI- return (stat {modulesTotal = Just (length (pdModules packageDescrHI)),- withSource=True, retrieved= True, mbError=Nothing})- else do- debugM "leksah-server" $ "collectPackage: Can't retreive = " ++ packString- liftIO $ writeExtractedPackage False packageDescrHI- return (stat {modulesTotal = Just (length (pdModules packageDescrHI))})- Nothing -> do- liftIO $ writeExtractedPackage False packageDescrHI- return (stat {modulesTotal = Just (length (pdModules packageDescrHI))})- (Just packageDescrS,stat, Just fp) -> do- let mergedPackageDescr = mergePackageDescrs packageDescrHI packageDescrS- liftIO $ writeExtractedPackage writeAscii mergedPackageDescr- liftIO $ writePackagePath fp mergedPackageDescr- return (stat)- (Nothing,stat,Nothing) -> do- liftIO $ writeExtractedPackage False packageDescrHI- return (stat {modulesTotal = Just (length (pdModules packageDescrHI))})- _ -> fail "Unexpected error in collectPackage"--writeExtractedPackage :: MonadIO m => Bool -> PackageDescr -> m ()-writeExtractedPackage writeAscii pd = do- collectorPath <- liftIO $ getCollectorPath- let filePath = collectorPath </> packageIdentifierToString (pdPackage pd) <.>- leksahMetadataSystemFileExtension- if writeAscii- then liftIO $ writeFile (filePath ++ "dpg") (show pd)- else liftIO $ encodeFileSer filePath (metadataVersion, pd)--writePackagePath :: MonadIO m => FilePath -> PackageDescr -> m ()-writePackagePath fp pd = do- collectorPath <- liftIO $ getCollectorPath- let filePath = collectorPath </> packageIdentifierToString (pdPackage pd) <.>- leksahMetadataPathFileExtension- liftIO $ writeFile filePath fp----------------Merging of .hi and .hs parsing / parsing and typechecking results--mergePackageDescrs :: PackageDescr -> PackageDescr -> PackageDescr-mergePackageDescrs packageDescrHI packageDescrS = PackageDescr {- pdPackage = pdPackage packageDescrHI- , pdMbSourcePath = pdMbSourcePath packageDescrS- , pdModules = mergeModuleDescrs (pdModules packageDescrHI) (pdModules packageDescrS)- , pdBuildDepends = pdBuildDepends packageDescrHI}--mergeModuleDescrs :: [ModuleDescr] -> [ModuleDescr] -> [ModuleDescr]-mergeModuleDescrs hiList srcList = map mergeIt allNames- where- mergeIt :: String -> ModuleDescr- mergeIt str = case (Map.lookup str hiDict, Map.lookup str srcDict) of- (Just mdhi, Nothing) -> mdhi- (Nothing, Just mdsrc) -> mdsrc- (Just mdhi, Just mdsrc) -> mergeModuleDescr mdhi mdsrc- (Nothing, Nothing) -> error "Collector>>mergeModuleDescrs: impossible"- allNames = nub $ Map.keys hiDict ++ Map.keys srcDict- hiDict = Map.fromList $ zip ((map (display . modu . mdModuleId)) hiList) hiList- srcDict = Map.fromList $ zip ((map (display . modu . mdModuleId)) srcList) srcList--mergeModuleDescr :: ModuleDescr -> ModuleDescr -> ModuleDescr-mergeModuleDescr hiDescr srcDescr = ModuleDescr {- mdModuleId = mdModuleId hiDescr- , mdMbSourcePath = mdMbSourcePath srcDescr- , mdReferences = mdReferences hiDescr- , mdIdDescriptions = mergeDescrs (mdIdDescriptions hiDescr) (mdIdDescriptions srcDescr)}--mergeDescrs :: [Descr] -> [Descr] -> [Descr]-mergeDescrs hiList srcList = concatMap mergeIt allNames- where- mergeIt :: String -> [Descr]- mergeIt pm = case (Map.lookup pm hiDict, Map.lookup pm srcDict) of- (Just mdhi, Nothing) -> mdhi- (Nothing, Just mdsrc) -> mdsrc- (Just mdhi, Just mdsrc) -> map (\ (a,b) -> mergeDescr a b) $ makePairs mdhi mdsrc- (Nothing, Nothing) -> error "Collector>>mergeModuleDescrs: impossible"- allNames = nub $ Map.keys hiDict ++ Map.keys srcDict- hiDict = Map.fromListWith (++) $ zip ((map dscName) hiList) (map (\ e -> [e]) hiList)- srcDict = Map.fromListWith (++) $ zip ((map dscName) srcList)(map (\ e -> [e]) srcList)--makePairs :: [Descr] -> [Descr] -> [(Maybe Descr,Maybe Descr)]-makePairs (hd:tl) srcList = (Just hd, theMatching)- : makePairs tl (case theMatching of- Just tm -> delete tm srcList- Nothing -> srcList)- where- theMatching = findMatching hd srcList- findMatching ele (hd':tail')- | matches ele hd' = Just hd'- | otherwise = findMatching ele tail'- findMatching _ele [] = Nothing- matches :: Descr -> Descr -> Bool- matches d1 d2 = (descrType . dscTypeHint) d1 == (descrType . dscTypeHint) d2-makePairs [] rest = map (\ a -> (Nothing, Just a)) rest--mergeDescr :: Maybe Descr -> Maybe Descr -> Descr-mergeDescr (Just descr) Nothing = descr-mergeDescr Nothing (Just descr) = descr-mergeDescr (Just (Real rdhi)) (Just (Real rdsrc)) =- Real RealDescr {- dscName' = dscName' rdhi- , dscMbTypeStr' = dscMbTypeStr' rdhi- , dscMbModu' = dscMbModu' rdsrc- , dscMbLocation' = dscMbLocation' rdsrc- , dscMbComment' = dscMbComment' rdsrc- , dscTypeHint' = mergeTypeDescr (dscTypeHint' rdhi) (dscTypeHint' rdsrc)- , dscExported' = True- }-mergeDescr (Just (Reexported rdhi)) (Just rdsrc) =- Reexported $ ReexportedDescr {- dsrMbModu = dsrMbModu rdhi- , dsrDescr = mergeDescr (Just (dsrDescr rdhi)) (Just rdsrc)- }-mergeDescr _ _ = error "Collector>>mergeDescr: impossible"----mergeTypeHint :: Maybe TypeDescr -> Maybe TypeDescr -> Maybe TypeDescr---mergeTypeHint Nothing Nothing = Nothing---mergeTypeHint Nothing jtd = jtd---mergeTypeHint jtd Nothing = jtd---mergeTypeHint (Just tdhi) (Just tdhs) = Just (mergeTypeDescr tdhi tdhs)--mergeTypeDescr :: TypeDescr -> TypeDescr -> TypeDescr-mergeTypeDescr (DataDescr constrListHi fieldListHi) (DataDescr constrListSrc fieldListSrc) =- DataDescr (mergeSimpleDescrs constrListHi constrListSrc) (mergeSimpleDescrs fieldListHi fieldListSrc)-mergeTypeDescr (NewtypeDescr constrHi mbFieldHi) (NewtypeDescr constrSrc mbFieldSrc) =- NewtypeDescr (mergeSimpleDescr constrHi constrSrc) (mergeMbDescr mbFieldHi mbFieldSrc)-mergeTypeDescr (ClassDescr superHi methodsHi) (ClassDescr _superSrc methodsSrc) =- ClassDescr superHi (mergeSimpleDescrs methodsHi methodsSrc)-mergeTypeDescr (InstanceDescr _bindsHi) (InstanceDescr bindsSrc) =- InstanceDescr bindsSrc-mergeTypeDescr descrHi _ =- descrHi--mergeSimpleDescrs :: [SimpleDescr] -> [SimpleDescr] -> [SimpleDescr]-mergeSimpleDescrs hiList srcList = map mergeIt allNames- where- mergeIt :: String -> SimpleDescr- mergeIt pm = case mergeMbDescr (Map.lookup pm hiDict) (Map.lookup pm srcDict) of- Just mdhi -> mdhi- Nothing -> error "Collector>>mergeSimpleDescrs: impossible"- allNames = nub $ Map.keys hiDict ++ Map.keys srcDict- hiDict = Map.fromList $ zip ((map sdName) hiList) hiList- srcDict = Map.fromList $ zip ((map sdName) srcList) srcList--mergeSimpleDescr :: SimpleDescr -> SimpleDescr -> SimpleDescr-mergeSimpleDescr sdHi sdSrc = SimpleDescr {- sdName = sdName sdHi,- sdType = sdType sdHi,- sdLocation = sdLocation sdSrc,- sdComment = sdComment sdSrc,- sdExported = sdExported sdSrc}--mergeMbDescr :: Maybe SimpleDescr -> Maybe SimpleDescr -> Maybe SimpleDescr-mergeMbDescr (Just mdhi) Nothing = Just mdhi-mergeMbDescr Nothing (Just mdsrc) = Just mdsrc-mergeMbDescr (Just mdhi) (Just mdsrc) = Just (mergeSimpleDescr mdhi mdsrc)-mergeMbDescr Nothing Nothing = Nothing-
src/IDE/Metainfo/InterfaceCollector.hs view
@@ -55,12 +55,6 @@ import IDE.Utils.GHCUtils import Control.DeepSeq(deepseq) -getThisPackage :: PackageConfig -> PackageIdentifier-#if MIN_VERSION_Cabal(1,8,0)-getThisPackage = IPI.sourcePackageId-#else-getThisPackage = IPI.package-#endif collectPackageFromHI :: PackageConfig -> IO PackageDescr collectPackageFromHI packageConfig = inGhcIO [] [] $ \ _ -> do
+ src/IDE/Metainfo/PackageCollector.hs view
@@ -0,0 +1,282 @@+{-# OPTIONS_GHC -XScopedTypeVariables -fno-warn-type-defaults #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Metainfo.PackageCollector+-- Copyright : 2007-2009 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL Nothing+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Metainfo.PackageCollector (++ collectPackage++) where++import IDE.StrippedPrefs (RetrieveStrategy(..), Prefs(..))+import PackageConfig (PackageConfig)+import IDE.Metainfo.SourceCollectorH+ (findSourceForPackage, packageFromSource, PackageCollectStats(..))+import System.Log.Logger (debugM, infoM)+import IDE.Metainfo.InterfaceCollector (collectPackageFromHI)+import IDE.Core.CTypes+ (getThisPackage, SimpleDescr(..), TypeDescr(..),+ ReexportedDescr(..), Descr(..), RealDescr(..), dscTypeHint,+ descrType, dscName, Descr, ModuleDescr(..), PackModule(..),+ PackageDescr(..), metadataVersion, leksahVersion,+ packageIdentifierToString)+import Control.Monad.Trans (MonadIO, MonadIO(..))+import IDE.Utils.FileUtils (getCollectorPath)+import System.Directory (doesFileExist, setCurrentDirectory)+import IDE.Utils.Utils+ (leksahMetadataPathFileExtension,+ leksahMetadataSystemFileExtension)+import System.FilePath (dropFileName, (<.>), (</>))+import Data.Binary.Shared (encodeFileSer)+import qualified Data.Map as Map+ (fromListWith, fromList, keys, lookup)+import Data.List (delete, nub)+import Distribution.Text (display)+import Control.Exception (SomeException,catch)+#if defined(USE_LIBCURL)+import Network.Curl (curlGetString, CurlCode(..))+import Control.Monad (when)+import System.IO (withBinaryFile, IOMode(..), hPutStr)+#else+import IDE.System.Process (system)+#endif+import Prelude hiding(catch)++collectPackage :: Bool -> Prefs -> Int -> (PackageConfig,Int) -> IO PackageCollectStats+collectPackage writeAscii prefs numPackages (packageConfig, packageIndex) = do+ infoM "leksah-server" ("update_toolbar " ++ show+ ((fromIntegral packageIndex / fromIntegral numPackages) :: Double))+ let packageName = packageIdentifierToString (getThisPackage packageConfig)+ let stat = PackageCollectStats packageName Nothing False False Nothing+ eitherStrFp <- findSourceForPackage prefs packageConfig+ case eitherStrFp of+ Left message -> do+ packageDescrHi <- collectPackageFromHI packageConfig+ 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" $ "collectPackage: retreived = " ++ packageName+ liftIO $ writePackagePath (dropFileName fpSource) packageName+ return (stat {withSource=True, retrieved= True, mbError=Nothing})+ else do+ debugM "leksah-server" $ "collectPackage: Can't retreive = " ++ packageName+ packageDescrHi <- collectPackageFromHI packageConfig+ mbPackageDescrPair <- packageFromSource fpSource packageConfig+ case mbPackageDescrPair of+ (Just packageDescrS, bstat) -> do+ writeMerged packageDescrS packageDescrHi fpSource packageName+ return bstat{modulesTotal = Just (length (pdModules packageDescrHi))}+ (Nothing,bstat) -> do+ writeExtractedPackage False packageDescrHi+ return bstat{modulesTotal = Just (length (pdModules packageDescrHi))}+ BuildThenRetrieve -> do+ mbPackageDescrPair <- packageFromSource fpSource packageConfig+ case mbPackageDescrPair of+ (Just packageDescrS,bstat) -> do+ packageDescrHi <- collectPackageFromHI packageConfig+ writeMerged packageDescrS packageDescrHi fpSource packageName+ return bstat{modulesTotal = Just (length (pdModules packageDescrHi))}+ (Nothing,bstat) -> do+ success <- retrieve packageName+ if success+ then do+ debugM "leksah-server" $ "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+ packageDescrHi <- collectPackageFromHI packageConfig+ mbPackageDescrPair <- packageFromSource fpSource packageConfig+ case mbPackageDescrPair of+ (Just packageDescrS,bstat) -> do+ writeMerged packageDescrS packageDescrHi fpSource packageName+ return bstat{modulesTotal = Just (length (pdModules packageDescrHi))}+ (Nothing,bstat) -> do+ writeExtractedPackage False packageDescrHi+ return bstat{modulesTotal = Just (length (pdModules packageDescrHi))}+ where+ retrieve :: String -> IO Bool+ retrieve packString = do+ collectorPath <- liftIO $ getCollectorPath+ setCurrentDirectory collectorPath+ let fullUrl = retrieveURL prefs ++ "/metadata-" ++ leksahVersion ++ "/" ++ packString ++ leksahMetadataSystemFileExtension+ filePath = collectorPath </> packString <.> leksahMetadataSystemFileExtension+ debugM "leksah-server" $ "collectPackage: before retreiving = " ++ fullUrl+#if defined(USE_LIBCURL)+ catch (do+ (code, string) <- curlGetString fullUrl []+ when (code == CurlOK) $+ withBinaryFile filePath WriteMode $ \ file -> do+ hPutStr file string)+#elif defined(USE_CURL)+ catch ((system $ "curl -OL " ++ fullUrl) >> return ())+#else+ catch ((system $ "wget " ++ fullUrl) >> return ())+#endif+ (\(e :: SomeException) ->+ debugM "leksah-server" $ "collectPackage: Error when calling wget " ++ show e)+ debugM "leksah-server" $ "collectPackage: after retreiving = " ++ packString -- ++ " result = " ++ res+ exist <- doesFileExist filePath+ return exist+ writeMerged packageDescrS packageDescrHi fpSource packageName = do+ let mergedPackageDescr = mergePackageDescrs packageDescrHi packageDescrS+ liftIO $ writeExtractedPackage writeAscii mergedPackageDescr+ liftIO $ writePackagePath (dropFileName fpSource) packageName++writeExtractedPackage :: MonadIO m => Bool -> PackageDescr -> m ()+writeExtractedPackage writeAscii pd = do+ collectorPath <- liftIO $ getCollectorPath+ let filePath = collectorPath </> packageIdentifierToString (pdPackage pd) <.>+ leksahMetadataSystemFileExtension+ if writeAscii+ then liftIO $ writeFile (filePath ++ "dpg") (show pd)+ else liftIO $ encodeFileSer filePath (metadataVersion, pd)++writePackagePath :: MonadIO m => FilePath -> String -> m ()+writePackagePath fp packageName = do+ collectorPath <- liftIO $ getCollectorPath+ let filePath = collectorPath </> packageName <.> leksahMetadataPathFileExtension+ liftIO $ writeFile filePath fp++--------------Merging of .hi and .hs parsing / parsing and typechecking results++mergePackageDescrs :: PackageDescr -> PackageDescr -> PackageDescr+mergePackageDescrs packageDescrHI packageDescrS = PackageDescr {+ pdPackage = pdPackage packageDescrHI+ , pdMbSourcePath = pdMbSourcePath packageDescrS+ , pdModules = mergeModuleDescrs (pdModules packageDescrHI) (pdModules packageDescrS)+ , pdBuildDepends = pdBuildDepends packageDescrHI}++mergeModuleDescrs :: [ModuleDescr] -> [ModuleDescr] -> [ModuleDescr]+mergeModuleDescrs hiList srcList = map mergeIt allNames+ where+ mergeIt :: String -> ModuleDescr+ mergeIt str = case (Map.lookup str hiDict, Map.lookup str srcDict) of+ (Just mdhi, Nothing) -> mdhi+ (Nothing, Just mdsrc) -> mdsrc+ (Just mdhi, Just mdsrc) -> mergeModuleDescr mdhi mdsrc+ (Nothing, Nothing) -> error "Collector>>mergeModuleDescrs: impossible"+ allNames = nub $ Map.keys hiDict ++ Map.keys srcDict+ hiDict = Map.fromList $ zip ((map (display . modu . mdModuleId)) hiList) hiList+ srcDict = Map.fromList $ zip ((map (display . modu . mdModuleId)) srcList) srcList++mergeModuleDescr :: ModuleDescr -> ModuleDescr -> ModuleDescr+mergeModuleDescr hiDescr srcDescr = ModuleDescr {+ mdModuleId = mdModuleId hiDescr+ , mdMbSourcePath = mdMbSourcePath srcDescr+ , mdReferences = mdReferences hiDescr+ , mdIdDescriptions = mergeDescrs (mdIdDescriptions hiDescr) (mdIdDescriptions srcDescr)}++mergeDescrs :: [Descr] -> [Descr] -> [Descr]+mergeDescrs hiList srcList = concatMap mergeIt allNames+ where+ mergeIt :: String -> [Descr]+ mergeIt pm = case (Map.lookup pm hiDict, Map.lookup pm srcDict) of+ (Just mdhi, Nothing) -> mdhi+ (Nothing, Just mdsrc) -> mdsrc+ (Just mdhi, Just mdsrc) -> map (\ (a,b) -> mergeDescr a b) $ makePairs mdhi mdsrc+ (Nothing, Nothing) -> error "Collector>>mergeModuleDescrs: impossible"+ allNames = nub $ Map.keys hiDict ++ Map.keys srcDict+ hiDict = Map.fromListWith (++) $ zip ((map dscName) hiList) (map (\ e -> [e]) hiList)+ srcDict = Map.fromListWith (++) $ zip ((map dscName) srcList)(map (\ e -> [e]) srcList)++makePairs :: [Descr] -> [Descr] -> [(Maybe Descr,Maybe Descr)]+makePairs (hd:tl) srcList = (Just hd, theMatching)+ : makePairs tl (case theMatching of+ Just tm -> delete tm srcList+ Nothing -> srcList)+ where+ theMatching = findMatching hd srcList+ findMatching ele (hd':tail')+ | matches ele hd' = Just hd'+ | otherwise = findMatching ele tail'+ findMatching _ele [] = Nothing+ matches :: Descr -> Descr -> Bool+ matches d1 d2 = (descrType . dscTypeHint) d1 == (descrType . dscTypeHint) d2+makePairs [] rest = map (\ a -> (Nothing, Just a)) rest++mergeDescr :: Maybe Descr -> Maybe Descr -> Descr+mergeDescr (Just descr) Nothing = descr+mergeDescr Nothing (Just descr) = descr+mergeDescr (Just (Real rdhi)) (Just (Real rdsrc)) =+ Real RealDescr {+ dscName' = dscName' rdhi+ , dscMbTypeStr' = dscMbTypeStr' rdhi+ , dscMbModu' = dscMbModu' rdsrc+ , dscMbLocation' = dscMbLocation' rdsrc+ , dscMbComment' = dscMbComment' rdsrc+ , dscTypeHint' = mergeTypeDescr (dscTypeHint' rdhi) (dscTypeHint' rdsrc)+ , dscExported' = True+ }+mergeDescr (Just (Reexported rdhi)) (Just rdsrc) =+ Reexported $ ReexportedDescr {+ dsrMbModu = dsrMbModu rdhi+ , dsrDescr = mergeDescr (Just (dsrDescr rdhi)) (Just rdsrc)+ }+mergeDescr _ _ = error "Collector>>mergeDescr: impossible"++--mergeTypeHint :: Maybe TypeDescr -> Maybe TypeDescr -> Maybe TypeDescr+--mergeTypeHint Nothing Nothing = Nothing+--mergeTypeHint Nothing jtd = jtd+--mergeTypeHint jtd Nothing = jtd+--mergeTypeHint (Just tdhi) (Just tdhs) = Just (mergeTypeDescr tdhi tdhs)++mergeTypeDescr :: TypeDescr -> TypeDescr -> TypeDescr+mergeTypeDescr (DataDescr constrListHi fieldListHi) (DataDescr constrListSrc fieldListSrc) =+ DataDescr (mergeSimpleDescrs constrListHi constrListSrc) (mergeSimpleDescrs fieldListHi fieldListSrc)+mergeTypeDescr (NewtypeDescr constrHi mbFieldHi) (NewtypeDescr constrSrc mbFieldSrc) =+ NewtypeDescr (mergeSimpleDescr constrHi constrSrc) (mergeMbDescr mbFieldHi mbFieldSrc)+mergeTypeDescr (ClassDescr superHi methodsHi) (ClassDescr _superSrc methodsSrc) =+ ClassDescr superHi (mergeSimpleDescrs methodsHi methodsSrc)+mergeTypeDescr (InstanceDescr _bindsHi) (InstanceDescr bindsSrc) =+ InstanceDescr bindsSrc+mergeTypeDescr descrHi _ =+ descrHi++mergeSimpleDescrs :: [SimpleDescr] -> [SimpleDescr] -> [SimpleDescr]+mergeSimpleDescrs hiList srcList = map mergeIt allNames+ where+ mergeIt :: String -> SimpleDescr+ mergeIt pm = case mergeMbDescr (Map.lookup pm hiDict) (Map.lookup pm srcDict) of+ Just mdhi -> mdhi+ Nothing -> error "Collector>>mergeSimpleDescrs: impossible"+ allNames = nub $ Map.keys hiDict ++ Map.keys srcDict+ hiDict = Map.fromList $ zip ((map sdName) hiList) hiList+ srcDict = Map.fromList $ zip ((map sdName) srcList) srcList++mergeSimpleDescr :: SimpleDescr -> SimpleDescr -> SimpleDescr+mergeSimpleDescr sdHi sdSrc = SimpleDescr {+ sdName = sdName sdHi,+ sdType = sdType sdHi,+ sdLocation = sdLocation sdSrc,+ sdComment = sdComment sdSrc,+ sdExported = sdExported sdSrc}++mergeMbDescr :: Maybe SimpleDescr -> Maybe SimpleDescr -> Maybe SimpleDescr+mergeMbDescr (Just mdhi) Nothing = Just mdhi+mergeMbDescr Nothing (Just mdsrc) = Just mdsrc+mergeMbDescr (Just mdhi) (Just mdsrc) = Just (mergeSimpleDescr mdhi mdsrc)+mergeMbDescr Nothing Nothing = Nothing++++
src/IDE/Metainfo/SourceCollectorH.hs view
@@ -14,14 +14,17 @@ ----------------------------------------------------------------------------- module IDE.Metainfo.SourceCollectorH (- collectPackageFromSource+-- collectPackageFromSource+ findSourceForPackage+, packageFromSource , interfaceToModuleDescr , PackageCollectStats(..) ) where import IDE.Core.CTypes- (PackageDescr(..), TypeDescr(..), RealDescr(..), Descr(..),- ModuleDescr(..), PackModule(..), SimpleDescr(..), packageIdentifierToString)+ (getThisPackage, PackageDescr(..), TypeDescr(..), RealDescr(..),+ Descr(..), ModuleDescr(..), PackModule(..), SimpleDescr(..),+ packageIdentifierToString) #ifdef MIN_VERSION_haddock_leksah import Haddock.Types@@ -54,9 +57,8 @@ import IDE.StrippedPrefs (getUnpackDirectory, Prefs(..)) import IDE.Metainfo.SourceDB (sourceForPackage, getSourcesMap) import MonadUtils (liftIO)-import Debug.Trace (trace) import System.Directory (setCurrentDirectory, doesDirectoryExist,createDirectory,canonicalizePath)-import System.FilePath (dropFileName,(</>),(<.>))+import System.FilePath ((<.>), dropFileName, (</>)) import Data.Maybe(mapMaybe) import IDE.Utils.GHCUtils (inGhcIO) import qualified Control.Exception as NewException (SomeException, catch)@@ -71,13 +73,6 @@ import Outputable hiding (trace) import GHC.Show(showSpace) -getThisPackage :: PackageConfig -> PackageIdentifier-#if MIN_VERSION_Cabal(1,8,0)-getThisPackage = IPI.sourcePackageId-#else-getThisPackage = IPI.package-#endif- #ifdef MIN_VERSION_haddock_leksah #else type HsDoc = Doc@@ -105,52 +100,52 @@ retrieved :: Bool, mbError :: Maybe String} --- Hell--collectPackageFromSource :: Prefs -> PackageConfig -> IO (Maybe PackageDescr, PackageCollectStats, Maybe FilePath)-collectPackageFromSource prefs packageConfig = do+findSourceForPackage :: Prefs -> PackageConfig -> IO (Either String FilePath)+findSourceForPackage prefs packageConfig = do sourceMap <- liftIO $ getSourcesMap prefs case sourceForPackage (getThisPackage packageConfig) sourceMap of- Just fp -> do- let dirPath = dropFileName fp+ Just fpSource -> do+ let dirPath = dropFileName fpSource setCurrentDirectory dirPath runTool' "cabal" (["configure","--user"]) Nothing- packageFromSource fp packageConfig+ return (Right fpSource) Nothing -> do unpackDir <- getUnpackDirectory prefs case unpackDir of- Nothing -> return (Nothing, PackageCollectStats packageName Nothing False False- (Just ("No source found. Prefs don't allow for retreiving")), Nothing)- Just fp -> do- exists <- doesDirectoryExist fp- unless exists $ createDirectory fp- setCurrentDirectory fp+ Nothing -> return (Left "No source found. Prefs don't allow for retreiving")+ Just fpUnpack -> do+ exists <- doesDirectoryExist fpUnpack+ unless exists $ createDirectory fpUnpack+ setCurrentDirectory fpUnpack runTool' "cabal" (["unpack",packageName]) Nothing- success <- doesDirectoryExist (fp </> packageName)+ success <- doesDirectoryExist (fpUnpack </> packageName) if not success- then return (Nothing, PackageCollectStats packageName Nothing False False- (Just ("Failed to download and unpack source")), Nothing)+ then return (Left "Failed to download and unpack source") else do- setCurrentDirectory (fp </> packageName)- runTool' "cabal" (["configure","--user"]) Nothing- packageFromSource (fp </> packageName </> packageName <.> "cabal")- packageConfig+ setCurrentDirectory (fpUnpack </> packageName)+ NewException.catch (runTool' "cabal" (["configure","--user"]) Nothing >> return ())+ (\ (_e :: NewException.SomeException) -> do+ debugM "leksah-server" "Can't configure"+ return ())+ return (Right (fpUnpack </> packageName </> takeWhile (/= '-') packageName <.> "cabal")) where packageName = packageIdentifierToString (getThisPackage packageConfig) -packageFromSource :: FilePath -> PackageConfig -> IO (Maybe PackageDescr, PackageCollectStats, Maybe FilePath)++packageFromSource :: FilePath -> PackageConfig -> IO (Maybe PackageDescr, PackageCollectStats) packageFromSource cabalPath packageConfig = do setCurrentDirectory dirPath ghcFlags <- figureOutHaddockOpts debugM "leksah-server" ("ghcFlags: " ++ show ghcFlags) NewException.catch (inner ghcFlags) handler where- _handler' (_e :: NewException.SomeException) =- trace "would block" $ return ([])+ _handler' (_e :: NewException.SomeException) = do+ debugM "leksah-server" "would block"+ return ([]) handler (e :: NewException.SomeException) = do warningM "leksah-server" ("Ghc failed to process: " ++ show e) return (Nothing, PackageCollectStats packageName Nothing False False- (Just ("Ghc failed to process: " ++ show e)), Just dirPath)+ (Just ("Ghc failed to process: " ++ show e))) inner ghcFlags = inGhcIO ghcFlags [Opt_Haddock] $ \ _flags -> do (interfaces,_) <- createInterfaces verbose (exportedMods ++ hiddenMods) [] [] liftIO $ print (length interfaces)@@ -162,7 +157,7 @@ , pdBuildDepends = [] -- TODO depends packageConfig , pdMbSourcePath = Just sp} let stat = PackageCollectStats packageName (Just (length mods)) True False Nothing- liftIO $ deepseq pd $ return (Just pd, stat, Just dirPath)+ liftIO $ deepseq pd $ return (Just pd, stat) exportedMods = map moduleNameString $ IPI.exposedModules packageConfig hiddenMods = map moduleNameString $ IPI.hiddenModules packageConfig dirPath = dropFileName cabalPath
src/IDE/Metainfo/WorkspaceCollector.hs view
@@ -35,7 +35,6 @@ import HscTypes hiding (liftIO) import Outputable hiding(trace) import ErrUtils-import Debug.Trace import qualified Data.Map as Map import Data.Map(Map) import System.Directory@@ -610,12 +609,16 @@ mayGetInterfaceDescription pid mn = do mbIf <- mayGetInterfaceFile pid mn case mbIf of- Nothing -> trace ("no interface file for " ++ show mn) $ return Nothing+ Nothing -> do+ liftIO $ infoM "leksah-server" ("no interface file for " ++ show mn)+ return Nothing Just (mif,_) -> let allDescrs = extractExportedDescrH pid mif mod' = extractExportedDescrR pid allDescrs mif- in trace ("interface file for " ++ show mn ++ " descrs: " ++ show (length (mdIdDescriptions mod')))- $ return (Just mod')+ in do+ liftIO $ debugM "leksah-server" ("interface file for " ++ show mn ++ " descrs: " +++ show (length (mdIdDescriptions mod')))+ return (Just mod')
src/IDE/StrippedPrefs.hs view
@@ -15,6 +15,7 @@ module IDE.StrippedPrefs ( Prefs(..)+, RetrieveStrategy(..) , readStrippedPrefs , writeStrippedPrefs , getSourceDirectories@@ -29,6 +30,7 @@ (joinPath, (</>), dropTrailingPathSeparator, splitPath) import System.Directory (getHomeDirectory) import Control.Monad (liftM)+import IDE.Core.CTypes (RetrieveStrategy(..)) -- -- | Preferences is a data structure to hold configuration data@@ -36,7 +38,8 @@ data Prefs = Prefs { sourceDirectories :: [FilePath] , unpackDirectory :: Maybe FilePath- , retreiveURL :: Maybe String+ , retrieveURL :: String+ , retrieveStrategy :: RetrieveStrategy , serverPort :: Int , endWithLastConn :: Bool } deriving(Eq,Show)@@ -45,7 +48,8 @@ defaultPrefs = Prefs { sourceDirectories = [] , unpackDirectory = Nothing- , retreiveURL = Just "http://www.leksah.org/"+ , retrieveURL = "http://www.leksah.org/"+ , retrieveStrategy = RetrieveThenBuild , serverPort = 11111 , endWithLastConn = True }@@ -77,11 +81,17 @@ unpackDirectory (\b a -> a{unpackDirectory = b}) , mkFieldS- (paraName <<<- ParaName "Maybe an URL to load prebuild metadata " $ emptyParams)+ (paraName <<<- ParaName "An URL to load prebuild metadata" $ emptyParams) (PP.text . show)+ stringParser+ retrieveURL+ (\b a -> a{retrieveURL = b})+ , mkFieldS+ (paraName <<<- ParaName "A strategy for downloading prebuild metadata" $ emptyParams)+ (PP.text . show) readParser- retreiveURL- (\b a -> a{retreiveURL = b})+ retrieveStrategy+ (\b a -> a{retrieveStrategy = b}) , mkFieldS (paraName <<<- ParaName "Port number for server connection" $ emptyParams) (PP.text . show)
src/IDE/Utils/FileUtils.hs view
@@ -25,8 +25,6 @@ , getConfigFilePathForSave , getCollectorPath , getSysLibDir-, getHaddockVersion-, getGhcVersion , moduleNameFromFilePath , moduleNameFromFilePath' , findKnownPackages@@ -40,6 +38,7 @@ , getInstalledPackageIds , figureOutGhcOpts , figureOutHaddockOpts+, allFilesWithExtensions ) where import System.FilePath@@ -75,7 +74,7 @@ import qualified Data.Set as Set (empty, fromList) import Control.Monad.Trans (MonadIO(..)) import Distribution.Package (PackageIdentifier)-import System.Process+import IDE.System.Process (waitForProcess, runCommand) import Data.Char (ord) import Distribution.Text (simpleParse)@@ -376,27 +375,6 @@ else do createDirectory filePath return filePath--getGhcVersion :: IO FilePath-getGhcVersion = catch (do- (!output,_) <- runTool' "ghc" ["--numeric-version"] Nothing- let vers = toolline $ head output- vers2 = if ord (last vers) == 13- then List.init vers- else vers- debugM "leksah-server" $ "Got GHC Version " ++ vers2- return vers2- ) $ \ _ -> error ("FileUtils>>getGhcVersion failed")--getHaddockVersion :: IO String-getHaddockVersion = catch (do- (!output,_) <- runTool' "haddock" ["--version"] Nothing- let vers = toolline $ head output- vers2 = if ord (last vers) == 13- then List.init vers- else vers- return vers2- ) $ \ _ -> error ("FileUtils>>getHaddockVersion failed") getSysLibDir :: IO FilePath getSysLibDir = catch (do
src/IDE/Utils/Server.hs view
@@ -31,7 +31,7 @@ import Control.Exception hiding (catch) import Data.Word-import Debug.Trace (trace)+import System.Log.Logger (infoM) data UserAndGroup = UserAndGroup String String | UserWithDefaultGroup String @@ -56,8 +56,8 @@ sock <- serverSocket' server setSocketOption sock ReuseAddr 1 bindSocket sock (serverAddr server)- trace ("Bind " ++ show (serverAddr server)) $- listen sock maxListenQueue+ infoM "leksah-server" $ ("Bind " ++ show (serverAddr server))+ listen sock maxListenQueue return (sock, server)
src/IDE/Utils/Tool.hs view
@@ -19,6 +19,7 @@ toolline, ToolCommand(..), ToolState(..),+ toolProcess, newToolState, runTool, runTool',@@ -35,31 +36,26 @@ ) where import Control.Concurrent- (takeMVar,- putMVar,- newEmptyMVar,- forkIO,- newChan,- MVar,- Chan,- writeChan,- getChanContents,- dupChan)-import Control.Monad (when)+ (readMVar, takeMVar, putMVar, newEmptyMVar, forkIO, newChan, MVar,+ Chan, writeChan, getChanContents, dupChan)+import Control.Monad (unless, when) import Data.List (stripPrefix) import Data.Maybe (isJust, catMaybes)-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)-import System.Posix (sigQUIT, sigINT, installHandler)-import System.Posix.Signals (Handler(..))-#endif-import System.Process- (waitForProcess, ProcessHandle, runInteractiveProcess)+import IDE.System.Process+ (proc, waitForProcess, ProcessHandle, createProcess, CreateProcess(..))+import IDE.System.Process.Internals (StdStream(..)) import Control.DeepSeq import System.Log.Logger (debugM, criticalM) import System.Exit (ExitCode(..)) import System.IO (hGetContents, hFlush, hPutStrLn, Handle)+import Control.Applicative ((<$>))+import Data.Char (isNumber) -data ToolOutput = ToolInput String | ToolError String | ToolOutput String | ToolExit ExitCode deriving(Eq, Show)+data ToolOutput = ToolInput String+ | ToolError String+ | ToolOutput String+ | ToolPrompt+ | ToolExit ExitCode deriving(Eq, Show) instance NFData ExitCode where rnf ExitSuccess = rnf ()@@ -69,19 +65,21 @@ rnf (ToolInput s) = rnf s rnf (ToolError s) = rnf s rnf (ToolOutput s) = rnf s+ rnf (ToolPrompt) = rnf () rnf (ToolExit code) = rnf code - data ToolCommand = ToolCommand String ([ToolOutput] -> IO ()) data ToolState = ToolState {- toolProcess :: MVar ProcessHandle,+ toolProcessMVar :: MVar ProcessHandle, outputClosed :: MVar Bool, toolCommands :: Chan ToolCommand, toolCommandsRead :: Chan ToolCommand, currentToolCommand :: MVar ToolCommand} +toolProcess :: ToolState -> IO ProcessHandle+toolProcess = readMVar . toolProcessMVar+ data RawToolOutput = RawToolOutput ToolOutput- | ToolPrompt | ToolOutClosed | ToolErrClosed | ToolClosed deriving(Eq, Show)@@ -90,7 +88,8 @@ toolline (ToolInput l) = l toolline (ToolOutput l) = l toolline (ToolError l) = l-toolline (ToolExit _code) = []+toolline (ToolPrompt) = ""+toolline (ToolExit _code) = "" quoteArg :: String -> String quoteArg s | ' ' `elem` s = "\"" ++ (escapeQuotes s) ++ "\""@@ -109,60 +108,114 @@ runTool :: FilePath -> [String] -> Maybe FilePath -> IO ([ToolOutput], ProcessHandle) runTool executable arguments mbDir = do-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)- installHandler sigINT Ignore Nothing- installHandler sigQUIT Ignore Nothing-#endif- (inp,out,err,pid) <- runInteractiveProcess executable arguments mbDir Nothing+ (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments)+ { std_in = CreatePipe,+ std_out = CreatePipe,+ std_err = CreatePipe,+ cwd = mbDir,+ new_group = True } output <- getOutputNoPrompt inp out err pid return (output, pid) newToolState :: IO ToolState newToolState = do- toolProcess <- newEmptyMVar+ toolProcessMVar <- newEmptyMVar outputClosed <- newEmptyMVar toolCommands <- newChan toolCommandsRead <- dupChan toolCommands currentToolCommand <- newEmptyMVar return ToolState{..} -runInteractiveTool :: ToolState -> (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ()-runInteractiveTool tool getOutput' executable arguments = do-#if !defined(mingw32_HOST_OS) && !defined(__MINGW32__)- installHandler sigINT Ignore Nothing- installHandler sigQUIT Ignore Nothing-#endif-- (inp,out,err,pid) <- runInteractiveProcess executable arguments Nothing Nothing- putMVar (toolProcess tool) pid- output <- getOutput' inp out err pid+runInteractiveTool ::+ ToolState ->+ CommandLineReader ->+ FilePath ->+ [String] ->+ IO ()+runInteractiveTool tool clr executable arguments = do+ (Just inp,Just out,Just err,pid) <- createProcess (proc executable arguments)+ { std_in = CreatePipe,+ std_out = CreatePipe,+ std_err = CreatePipe,+ new_group = True }+ putMVar (toolProcessMVar tool) pid+ output <- getOutput clr inp out err pid -- This is handy to show the processed output -- forkIO $ forM_ output (putStrLn.show) forkIO $ do commands <- getChanContents (toolCommandsRead tool)- processCommand commands inp output+ processCommand 0 commands inp output return () where- processCommand [] _ _ = return ()- processCommand ((command@(ToolCommand commandString handler)):remainingCommands) inp allOutput = do+ processCommand _ [] _ _ = do+ debugM "leksah-server" $ "No More Commands"+ return ()+ processCommand n ((command@(ToolCommand commandString handler)):remainingCommands)+ inp allOutput = do putMVar (currentToolCommand tool) command hPutStrLn inp commandString hFlush inp- let (output, remainingOutputWithPrompt) = span (/= ToolPrompt) allOutput- debugM "leksah-server" $ "Start Processing Tool Output for " ++ commandString- handler $ (map ToolInput (lines commandString)) ++ fromRawOutput output- debugM "leksah-server" $ "Done Processing Tool Output for " ++ commandString+ outputChan <- newChan+ outputChan' <- dupChan outputChan++ done <- newEmptyMVar+ forkIO $ do+ output <- fromRawOutput <$> getChanContents outputChan'+ debugM "leksah-server" $ "Start Processing Tool Output for " ++ commandString+ handler $ (map ToolInput (lines commandString)) ++ output+ debugM "leksah-server" $ "Done Processing Tool Output for " ++ commandString+ putMVar done True+ return ()++ remainingOutputWithPrompt <- writeCommandOutput outputChan inp allOutput False False (outputSyncCommand clr) n+ takeMVar done+ takeMVar (currentToolCommand tool)+ case remainingOutputWithPrompt of- (ToolPrompt:remainingOutput) -> do- debugM "leksah-server" $ "Prompt"- processCommand remainingCommands inp remainingOutput+ (RawToolOutput ToolPrompt:remainingOutput) -> do+ debugM "leksah-server" $ "Ready For Next Command"+ processCommand (n+1) remainingCommands inp remainingOutput [] -> do debugM "leksah-server" $ "Tool Output Closed" putMVar (outputClosed tool) True _ -> do criticalM "leksah-server" $ "This should never happen in Tool.hs" + writeCommandOutput _ _ [] _ _ _ _ = do+ criticalM "leksah-server" $ "ToolExit not found"+ return []++ writeCommandOutput out inp (RawToolOutput ToolPrompt:remainingOutput) False False (Just outSyncCmd) n = do+ debugM "leksah-server" $ "Pre Sync Prompt"+ hPutStrLn inp $ outSyncCmd n+ hFlush inp+ writeCommandOutput out inp remainingOutput True False (Just outSyncCmd) n++ writeCommandOutput out inp (RawToolOutput ToolPrompt:remainingOutput) True False (Just outSyncCmd) n = do+ debugM "leksah-server" $ "Unsynced Prompt"+ writeCommandOutput out inp remainingOutput True False (Just outSyncCmd) n++ writeCommandOutput out inp (o@(RawToolOutput (ToolOutput line)):remainingOutput) True False (Just outSyncCmd) n = do+ let synced = (isExpectedOutput clr n line)+ unless synced $ writeChan out o+ when synced $ debugM "leksah-server" $ "Output Sync Found"+ writeCommandOutput out inp remainingOutput True synced (Just outSyncCmd) n++ writeCommandOutput out _ remainingOutput@(RawToolOutput ToolPrompt:_) _ _ _ _ = do+ debugM "leksah-server" $ "Synced Prompt"+ writeChan out $ RawToolOutput ToolPrompt+ return remainingOutput++ writeCommandOutput out _ (o@(RawToolOutput (ToolExit _)):_) _ _ _ _ = do+ debugM "leksah-server" $ "Tool Exit"+ writeChan out o+ return []++ writeCommandOutput out inp (o:remainingOutput) synching synched syncCmd n = do+ writeChan out o+ writeCommandOutput out inp remainingOutput synching synched syncCmd n+ {- newInteractiveTool :: (Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]) -> FilePath -> [String] -> IO ToolState newInteractiveTool getOutput' executable arguments = do@@ -177,8 +230,10 @@ data CommandLineReader = CommandLineReader { stripInitialPrompt :: String -> Maybe String, stripFollowingPrompt :: String -> Maybe String,- errorSyncCommand :: Maybe String,- stripExpectedError :: String -> Maybe String+ errorSyncCommand :: Maybe (Int -> String),+ stripExpectedError :: String -> Maybe (Int, String),+ outputSyncCommand :: Maybe (Int -> String),+ isExpectedOutput :: Int -> String -> Bool } ghciStripInitialPrompt :: String -> Maybe String@@ -193,19 +248,65 @@ ghciStripFollowingPrompt :: String -> Maybe String ghciStripFollowingPrompt = stripPrefix ghciPrompt -ghciStripExpectedError :: String -> Maybe String-ghciStripExpectedError output = case stripPrefix "\n<interactive>:1:0" output of- Just rest ->- stripPrefix ": Not in scope: `kM2KWR7LZZbHdXfHUOA5YBBsJVYoC'\n"- (maybe rest id (stripPrefix "-28" rest))- Nothing -> Nothing+{-+stripMarker $ marker 0 ++ "dfskfjdkl"+-} +marker :: Int -> String+marker n =+ take (29 - length num) "kMAKWRALZZbHdXfHUOAAYBBsJVYoC" ++ num+ where num = show n++stripMarker :: String -> Maybe (Int, String)+stripMarker s =+ case strip "kMAKWRALZZbHdXfHUOAAYBBsJVYoC" s of+ Just (nums, rest) -> Just (read nums, rest)+ Nothing -> Nothing+ where+ strip :: String -> String -> Maybe (String, String)+ strip letters@(a:as) input@(b:bs)+ | a == b = strip as bs+ | otherwise = numbers letters input+ strip _ _ = Nothing+ numbers :: String -> String -> Maybe (String, String)+ numbers (_:as) (n:ns)+ | isNumber n = case numbers as ns of+ Just (nums, rest) -> Just (n:nums, rest)+ _ -> Nothing+ | otherwise = Nothing+ numbers [] input = Just ([], input)+ numbers _ _ = Nothing++++ghciStripExpectedError :: String -> Maybe (Int, String)+ghciStripExpectedError output =+ case stripPrefix "\n<interactive>:1:0" output of+ Just rest ->+ case stripPrefix ": Not in scope: `"+ (maybe rest id (stripPrefix "-28" rest)) of+ Just rest2 ->+ case stripMarker rest2 of+ Just (n, rest3) ->+ case stripPrefix "'\n" rest3 of+ Just rest4 -> Just (n, rest4)+ Nothing -> Nothing+ Nothing -> Nothing+ Nothing -> Nothing+ Nothing -> Nothing++ghciIsExpectedOutput :: Int -> String -> Bool+ghciIsExpectedOutput n =+ (==) (marker n)+ ghciCommandLineReader :: CommandLineReader ghciCommandLineReader = CommandLineReader { stripInitialPrompt = ghciStripInitialPrompt, stripFollowingPrompt = ghciStripFollowingPrompt,- errorSyncCommand = Just "kM2KWR7LZZbHdXfHUOA5YBBsJVYoC",- stripExpectedError = ghciStripExpectedError+ errorSyncCommand = Just $ \n -> marker n,+ stripExpectedError = ghciStripExpectedError,+ outputSyncCommand = Just $ \n -> ":set prompt " ++ marker n ++ "\n:set prompt " ++ ghciPrompt,+ isExpectedOutput = ghciIsExpectedOutput } noInputCommandLineReader :: CommandLineReader@@ -213,7 +314,9 @@ stripInitialPrompt = const Nothing, stripFollowingPrompt = const Nothing, errorSyncCommand = Nothing,- stripExpectedError = const Nothing+ stripExpectedError = \_ -> Nothing,+ outputSyncCommand = Nothing,+ isExpectedOutput = \_ _ -> False } --waitTillEmpty :: Handle -> IO () --waitTillEmpty handle = do@@ -241,7 +344,7 @@ forkIO $ do output <- hGetContents out -- forkIO $ putStr output- readOutput chan (filter (/= '\r') output) True foundExpectedError False+ readOutput chan (filter (/= '\r') output) 0 foundExpectedError False writeChan chan ToolOutClosed forkIO $ do output <- getChanContents testClosed@@ -254,8 +357,8 @@ where readError chan errors foundExpectedError = do case stripExpectedError clr errors of- Just unexpectedErrors -> do- putMVar foundExpectedError True+ Just (counter, unexpectedErrors) -> do+ putMVar foundExpectedError counter readError chan unexpectedErrors foundExpectedError Nothing -> do let (line, remaining) = break (== '\n') errors@@ -265,8 +368,8 @@ writeChan chan $ RawToolOutput $ ToolError line readError chan remainingLines foundExpectedError - readOutput chan output initial foundExpectedError synced = do- let stripPrompt = (if initial then (stripInitialPrompt clr) else (stripFollowingPrompt clr))+ readOutput chan output counter foundExpectedError errSynced = do+ let stripPrompt = (if counter==0 then (stripInitialPrompt clr) else (stripFollowingPrompt clr)) let line = getOutputLine stripPrompt output let remaining = drop (length line) output case remaining of@@ -274,41 +377,43 @@ when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line '\n':remainingLines -> do writeChan chan $ RawToolOutput $ ToolOutput line- readOutput chan remainingLines initial foundExpectedError synced+ readOutput chan remainingLines counter foundExpectedError errSynced _ -> do when (line /= "") $ writeChan chan $ RawToolOutput $ ToolOutput line case stripPrompt remaining of Just afterPrompt -> do- case (initial, synced, errorSyncCommand clr) of- (True, _, _) -> do- readOutput chan afterPrompt False foundExpectedError synced- (False, _, Nothing) -> do- writeChan chan ToolPrompt- readOutput chan afterPrompt False foundExpectedError synced- (False, False, Just syncCmd) -> do- hPutStrLn inp syncCmd+ case (counter, errSynced, errorSyncCommand clr) of+ (0, _, _) -> do+ readOutput chan afterPrompt (counter+1) foundExpectedError errSynced++ (_, False, Just syncCmd) -> do+ hPutStrLn inp $ syncCmd counter hFlush inp- takeMVar foundExpectedError- readOutput chan afterPrompt False foundExpectedError True- (False, True, Just _) -> do- writeChan chan ToolPrompt- readOutput chan afterPrompt False foundExpectedError False+ waitForError counter foundExpectedError+ readOutput chan afterPrompt (counter+1) foundExpectedError True++ _ -> do+ writeChan chan $ RawToolOutput ToolPrompt+ readOutput chan afterPrompt (counter+1) foundExpectedError False+ _ -> return () -- Should never happen getOutputLine _ [] = [] getOutputLine _ ('\n':_) = [] getOutputLine stripPrompt output@(x:xs) | isJust (stripPrompt output) = [] | otherwise = x : (getOutputLine stripPrompt xs)+ waitForError counter foundExpectedError = do+ foundCount <- takeMVar foundExpectedError+ when (foundCount < counter) $ waitForError counter foundExpectedError + fromRawOutput :: [RawToolOutput] -> [ToolOutput] fromRawOutput [] = []+fromRawOutput (RawToolOutput (ToolPrompt):_) = [ToolPrompt] fromRawOutput (RawToolOutput (ToolExit code):_) = [ToolExit code] fromRawOutput (RawToolOutput output:xs) = output : (fromRawOutput xs) fromRawOutput (_:xs) = fromRawOutput xs -getGhciOutput :: Handle -> Handle -> Handle -> ProcessHandle -> IO [RawToolOutput]-getGhciOutput = getOutput ghciCommandLineReader- getOutputNoPrompt :: Handle -> Handle -> Handle -> ProcessHandle -> IO [ToolOutput] getOutputNoPrompt inp out err pid = fmap fromRawOutput $ getOutput noInputCommandLineReader inp out err pid @@ -326,7 +431,7 @@ debugM "leksah-server" $ newOptions debugM "leksah-server" $ "Starting GHCi" debugM "leksah-server" $ unwords (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags)- runInteractiveTool tool getGhciOutput "ghci"+ runInteractiveTool tool ghciCommandLineReader "ghci" (words newOptions ++ ["-fforce-recomp"] ++ interactiveFlags) _ -> do startupOutputHandler output
+ src/IDE/Utils/VersionUtils.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE ScopedTypeVariables, BangPatterns #-}+-----------------------------------------------------------------------------+--+-- Module : IDE.Utils.VersionUtils+-- Copyright : 2007-2010 Juergen Nicklisch-Franken, Hamish Mackenzie+-- License : GPL Nothing+--+-- Maintainer : maintainer@leksah.org+-- Stability : provisional+-- Portability :+--+-- |+--+-----------------------------------------------------------------------------++module IDE.Utils.VersionUtils (+ getHaddockVersion+, getGhcVersion+) where++import IDE.Utils.Tool (toolline, runTool')+import Data.Char (ord)+import qualified Data.List as List (init)+import System.Log.Logger (debugM)++getGhcVersion :: IO FilePath+getGhcVersion = catch (do+ (!output,_) <- runTool' "ghc" ["--numeric-version"] Nothing+ let vers = toolline $ head output+ vers2 = if ord (last vers) == 13+ then List.init vers+ else vers+ debugM "leksah-server" $ "Got GHC Version " ++ vers2+ return vers2+ ) $ \ _ -> error ("FileUtils>>getGhcVersion failed")++getHaddockVersion :: IO String+getHaddockVersion = catch (do+ (!output,_) <- runTool' "haddock" ["--version"] Nothing+ let vers = toolline $ head output+ vers2 = if ord (last vers) == 13+ then List.init vers+ else vers+ return vers2+ ) $ \ _ -> error ("FileUtils>>getHaddockVersion failed")+++
src/LeksahEcho.hs view
@@ -17,7 +17,7 @@ ) where import System.Environment (getArgs)-import IDE.Utils.FileUtils (getHaddockVersion, getGhcVersion)+import IDE.Utils.VersionUtils (getHaddockVersion, getGhcVersion) main :: IO () main = do