diff --git a/data/prefscoll.lkshp b/data/prefscoll.lkshp --- a/data/prefscoll.lkshp +++ b/data/prefscoll.lkshp @@ -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: diff --git a/leksah-server.cabal b/leksah-server.cabal --- a/leksah-server.cabal +++ b/leksah-server.cabal @@ -1,5 +1,5 @@ name: leksah-server -version: 0.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 diff --git a/src/IDE/Core/CTypes.hs b/src/IDE/Core/CTypes.hs --- a/src/IDE/Core/CTypes.hs +++ b/src/IDE/Core/CTypes.hs @@ -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 diff --git a/src/IDE/Metainfo/Collector.hs b/src/IDE/Metainfo/Collector.hs --- a/src/IDE/Metainfo/Collector.hs +++ b/src/IDE/Metainfo/Collector.hs @@ -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 - diff --git a/src/IDE/Metainfo/InterfaceCollector.hs b/src/IDE/Metainfo/InterfaceCollector.hs --- a/src/IDE/Metainfo/InterfaceCollector.hs +++ b/src/IDE/Metainfo/InterfaceCollector.hs @@ -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 diff --git a/src/IDE/Metainfo/PackageCollector.hs b/src/IDE/Metainfo/PackageCollector.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Metainfo/PackageCollector.hs @@ -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 + + + + diff --git a/src/IDE/Metainfo/SourceCollectorH.hs b/src/IDE/Metainfo/SourceCollectorH.hs --- a/src/IDE/Metainfo/SourceCollectorH.hs +++ b/src/IDE/Metainfo/SourceCollectorH.hs @@ -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 diff --git a/src/IDE/Metainfo/WorkspaceCollector.hs b/src/IDE/Metainfo/WorkspaceCollector.hs --- a/src/IDE/Metainfo/WorkspaceCollector.hs +++ b/src/IDE/Metainfo/WorkspaceCollector.hs @@ -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') diff --git a/src/IDE/StrippedPrefs.hs b/src/IDE/StrippedPrefs.hs --- a/src/IDE/StrippedPrefs.hs +++ b/src/IDE/StrippedPrefs.hs @@ -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) diff --git a/src/IDE/Utils/FileUtils.hs b/src/IDE/Utils/FileUtils.hs --- a/src/IDE/Utils/FileUtils.hs +++ b/src/IDE/Utils/FileUtils.hs @@ -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 diff --git a/src/IDE/Utils/Server.hs b/src/IDE/Utils/Server.hs --- a/src/IDE/Utils/Server.hs +++ b/src/IDE/Utils/Server.hs @@ -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) diff --git a/src/IDE/Utils/Tool.hs b/src/IDE/Utils/Tool.hs --- a/src/IDE/Utils/Tool.hs +++ b/src/IDE/Utils/Tool.hs @@ -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: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: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 diff --git a/src/IDE/Utils/VersionUtils.hs b/src/IDE/Utils/VersionUtils.hs new file mode 100644 --- /dev/null +++ b/src/IDE/Utils/VersionUtils.hs @@ -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") + + + diff --git a/src/LeksahEcho.hs b/src/LeksahEcho.hs --- a/src/LeksahEcho.hs +++ b/src/LeksahEcho.hs @@ -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