diff --git a/scion-browser.cabal b/scion-browser.cabal --- a/scion-browser.cabal +++ b/scion-browser.cabal @@ -1,5 +1,5 @@ name: scion-browser -version: 0.2.10 +version: 0.2.11 cabal-version: >= 1.8 build-type: Simple license: BSD3 @@ -49,7 +49,7 @@ if impl(ghc >= 7.0) build-depends: - containers >= 0.2 && < 0.5, + containers >= 0.2, directory >= 1.1, filepath >= 1.2, bytestring, @@ -96,7 +96,7 @@ hs-source-dirs: src main-is: Main.hs build-depends: - haskeline >= 0.6 && < 0.7, + haskeline >= 0.7, attoparsec >= 0.10, base == 4.*, mtl >= 2, @@ -128,7 +128,7 @@ if impl(ghc >= 7.0) build-depends: - containers >= 0.2 && < 0.5, + containers >= 0.2, directory >= 1.1, filepath >= 1.2, bytestring, diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -3,7 +3,7 @@ module Main where import qualified Codec.Compression.Zlib as Zlib -import Control.Monad.State +import Control.Monad.State.Strict import Data.Aeson import qualified Data.Aeson.Types as T import qualified Data.Attoparsec.ByteString as Atto diff --git a/src/Scion/Packages.hs b/src/Scion/Packages.hs --- a/src/Scion/Packages.hs +++ b/src/Scion/Packages.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} -- | -- Module : Scion.Packages -- Author : Thiago Arrais @@ -25,13 +25,20 @@ import System.Environment (getEnv) import System.FilePath import System.IO -import System.IO.Error +import qualified Control.Exception as Exc import GHC.Paths import qualified Control.Exception as Exception --- This was borrowed from the ghc-pkg source: +#if __GLASGOW_HASKELL__ < 702 +catchIOError :: IO a -> (IOError -> IO a) -> IO a +catchIOError = catch +#else +import System.IO.Error (catchIOError) +#endif + +-- this was borrowed from the ghc-pkg source: type InstalledPackageInfoString = InstalledPackageInfo_ String -- | Types of cabal package databases @@ -86,10 +93,10 @@ Just pkgs -> return $ pkgs -- Get the user package configuration database - e_appdir <- try $ getAppUserDataDirectory "ghc" + e_appdir <- Exc.try $ getAppUserDataDirectory "ghc" user_conf <- do case e_appdir of - Left _ -> return [] + Left (_::Exc.IOException) -> return [] Right appdir -> do let subdir = currentArch ++ '-':currentOS ++ '-':ghcVersion dir = appdir subdir @@ -99,10 +106,10 @@ Just pkgs -> return pkgs -- Process GHC_PACKAGE_PATH, if present: - e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") + e_pkg_path <- Exc.try $ getEnv "GHC_PACKAGE_PATH" env_stack <- do case e_pkg_path of - Left _ -> return [] + Left (_::Exc.IOException) -> return [] Right path -> do pkgs <- mapM readContents [(PkgDirectory pkg) | pkg <- splitSearchPath path] return $ concat pkgs @@ -135,7 +142,7 @@ #if __GLASGOW_HASKELL__ >= 612 -- fix the encoding to UTF-8 hSetEncoding h utf8 - catch (hGetContents h) (\_ -> do + catchIOError (hGetContents h) (\_ -> do -- logInfo $ ioeGetErrorString err hClose h h' <- openFile file ReadMode @@ -169,7 +176,7 @@ pkgInfoReader :: FilePath -> IO [InstalledPackageInfo] pkgInfoReader f = - catch ( + catchIOError ( do pkgStr <- readUTF8File f let pkgInfo = parseInstalledPackageInfo pkgStr diff --git a/src/Scion/PersistentBrowser/Build.hs b/src/Scion/PersistentBrowser/Build.hs --- a/src/Scion/PersistentBrowser/Build.hs +++ b/src/Scion/PersistentBrowser/Build.hs @@ -9,7 +9,6 @@ ) where import Control.Concurrent.ParallelIO.Local -import Control.Exception as E (catch, SomeException) import Control.Monad.IO.Class (liftIO) import Data.Either (rights) import Data.List ((\\), nub) @@ -32,9 +31,7 @@ import Text.ParserCombinators.Parsec.Error (newErrorMessage, Message(..)) import Text.ParserCombinators.Parsec.Pos (newPos) import Text.ParserCombinators.ReadP -import Network.Browser -import Network.HTTP -import Network.HTTP.Proxy +import Control.Monad (when) baseDbUrl :: String baseDbUrl = "http://haskell.org/hoogle/base.txt" @@ -116,13 +113,16 @@ installedList = nub $ removeSmallVersions $ map sourcePackageId pkgInfo toRemove = dbList \\ installedList toAdd = installedList \\ dbList - liftIO $ logToStdout $ "Removing " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toRemove) + when (not $ null toRemove) (do + liftIO $ logToStdout $ "Removing " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toRemove)) mapM_ deletePackageByInfo toRemove - liftIO $ logToStdout $ "Adding " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toAdd) + when (not $ null toAdd) (do + liftIO $ logToStdout $ "Adding " ++ show (map (\(PackageIdentifier (PackageName name) _) -> name) toAdd)) let ghcVersion = getGhcInstalledVersion installedList (addedDb, errors) <- liftIO $ createCabalDatabase' ghcVersion toAdd True mapM_ savePackageToDb addedDb - liftIO $ logToStdout $ show errors + when (not $ null errors) (do + liftIO $ logToStdout $ show errors) fromDbToPackageIdentifier :: DbPackage -> PackageIdentifier fromDbToPackageIdentifier (DbPackage name version _) = PackageIdentifier (PackageName name) diff --git a/src/Scion/PersistentBrowser/Parser.hs b/src/Scion/PersistentBrowser/Parser.hs --- a/src/Scion/PersistentBrowser/Parser.hs +++ b/src/Scion/PersistentBrowser/Parser.hs @@ -1,83 +1,91 @@ -{-# LANGUAGE ScopedTypeVariables #-} - -module Scion.PersistentBrowser.Parser -( parseHoogleString -, parseHoogleFile -, parseDirectory -) where - -import Control.Concurrent.ParallelIO.Local -import Control.Monad -import qualified Data.ByteString as BS -import qualified Data.ByteString.UTF8 as BSU -import Data.Either (rights) -import Scion.PersistentBrowser.Types -import Scion.PersistentBrowser.Parser.Internal (hoogleParser) -import Scion.PersistentBrowser.FileUtil -import Scion.PersistentBrowser.Util -import System.Directory -import System.FilePath (()) -import System.IO -import Text.Parsec.Error (Message(..), newErrorMessage) -import Text.Parsec.Prim (runP) --- import Text.Parsec.ByteString as BS -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Pos (newPos) - --- | Parses the contents of a string containing the --- Hoogle file contents. -parseHoogleString :: String -> BS.ByteString -> Either ParseError (Documented Package) -parseHoogleString name contents = runP hoogleParser () name (BSU.toString contents) - --- | Parses a file in Hoogle documentation format, returning --- the documentation of the entire package, or the corresponding --- error during the parsing. -parseHoogleFile :: FilePath -> IO (Either ParseError (Documented Package)) -parseHoogleFile fname = (withFile fname ReadMode $ - \hnd -> do c <- BS.hGetContents hnd - return $ parseHoogleString fname c - ) - `catch` - (\_ -> return $ Left (newErrorMessage (Message "error reading file") - (newPos fname 0 0))) - --- | Parses a entire directory of Hoogle documentation files --- which must be following the format of the Hackage --- Hoogle library, specifically: --- --- --- / package-name --- / version --- /doc/html/package-name.txt --- -parseDirectory :: FilePath -> FilePath -> IO ([Documented Package], [(FilePath, ParseError)]) -parseDirectory dir tmpdir = - do contents' <- getDirectoryContents dir - let contents = map (\d -> dir d) (filterDots contents') - dirs <- filterM doesDirectoryExist contents - vDirs <- mapM getVersionDirectory dirs - let innerDirs = map (\d -> d "doc" "html") (concat vDirs) - -- Parse directories recursively - let toExecute = map (\innerDir -> parseDirectoryFiles innerDir tmpdir) innerDirs - eitherDPackages <- withThreaded $ \pool -> parallelInterleavedE pool toExecute - let dPackages = rights eitherDPackages - dbs = concat $ map fst dPackages - errors = concat $ map snd dPackages - return (dbs, errors) - -getVersionDirectory :: FilePath -> IO [FilePath] -getVersionDirectory dir = do contents' <- getDirectoryContents dir - let contents = map (\d -> dir d) (filterDots contents') - filterM doesDirectoryExist contents - -parseDirectoryFiles :: FilePath -> FilePath -> IO ([Documented Package], [(FilePath, ParseError)]) -parseDirectoryFiles dir _ = - do contents' <- getDirectoryContents dir - let contents = map (\d -> dir d) (filterDots contents') - files <- filterM doesFileExist contents - fPackages <- mapM (\fname -> do hPutChar stderr '.' >> hFlush stderr - p <- parseHoogleFile fname - return (fname, p) ) - files - return $ partitionPackages fPackages - +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} + +module Scion.PersistentBrowser.Parser +( parseHoogleString +, parseHoogleFile +, parseDirectory +) where + +import Control.Concurrent.ParallelIO.Local +import Control.Monad +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as BSU +import Data.Either (rights) +import Scion.PersistentBrowser.Types +import Scion.PersistentBrowser.Parser.Internal (hoogleParser) +import Scion.PersistentBrowser.FileUtil +import Scion.PersistentBrowser.Util +import System.Directory +import System.FilePath (()) +import System.IO +import Text.Parsec.Error (Message(..), newErrorMessage) +import Text.Parsec.Prim (runP) +-- import Text.Parsec.ByteString as BS +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Pos (newPos) + +#if __GLASGOW_HASKELL__ < 702 +catchIOError :: IO a -> (IOError -> IO a) -> IO a +catchIOError = catch +#else +import System.IO.Error (catchIOError) +#endif + +-- | Parses the contents of a string containing the +-- Hoogle file contents. +parseHoogleString :: String -> BS.ByteString -> Either ParseError (Documented Package) +parseHoogleString name contents = runP hoogleParser () name (BSU.toString contents) + +-- | Parses a file in Hoogle documentation format, returning +-- the documentation of the entire package, or the corresponding +-- error during the parsing. +parseHoogleFile :: FilePath -> IO (Either ParseError (Documented Package)) +parseHoogleFile fname = (withFile fname ReadMode $ + \hnd -> do c <- BS.hGetContents hnd + return $ parseHoogleString fname c + ) + `catchIOError` + (\_ -> return $ Left (newErrorMessage (Message "error reading file") + (newPos fname 0 0))) + +-- | Parses a entire directory of Hoogle documentation files +-- which must be following the format of the Hackage +-- Hoogle library, specifically: +-- +-- +-- / package-name +-- / version +-- /doc/html/package-name.txt +-- +parseDirectory :: FilePath -> FilePath -> IO ([Documented Package], [(FilePath, ParseError)]) +parseDirectory dir tmpdir = + do contents' <- getDirectoryContents dir + let contents = map (\d -> dir d) (filterDots contents') + dirs <- filterM doesDirectoryExist contents + vDirs <- mapM getVersionDirectory dirs + let innerDirs = map (\d -> d "doc" "html") (concat vDirs) + -- Parse directories recursively + let toExecute = map (\innerDir -> parseDirectoryFiles innerDir tmpdir) innerDirs + eitherDPackages <- withThreaded $ \pool -> parallelInterleavedE pool toExecute + let dPackages = rights eitherDPackages + dbs = concat $ map fst dPackages + errors = concat $ map snd dPackages + return (dbs, errors) + +getVersionDirectory :: FilePath -> IO [FilePath] +getVersionDirectory dir = do contents' <- getDirectoryContents dir + let contents = map (\d -> dir d) (filterDots contents') + filterM doesDirectoryExist contents + +parseDirectoryFiles :: FilePath -> FilePath -> IO ([Documented Package], [(FilePath, ParseError)]) +parseDirectoryFiles dir _ = + do contents' <- getDirectoryContents dir + let contents = map (\d -> dir d) (filterDots contents') + files <- filterM doesFileExist contents + fPackages <- mapM (\fname -> do hPutChar stderr '.' >> hFlush stderr + p <- parseHoogleFile fname + return (fname, p) ) + files + return $ partitionPackages fPackages + diff --git a/src/Scion/PersistentBrowser/Query.hs b/src/Scion/PersistentBrowser/Query.hs --- a/src/Scion/PersistentBrowser/Query.hs +++ b/src/Scion/PersistentBrowser/Query.hs @@ -9,8 +9,6 @@ import Database.Persist.Store import Database.Persist.GenericSql.Raw (withStmt, execute) import Scion.PersistentBrowser.DbTypes -import Scion.PersistentBrowser.Util (logToStdout) -import Control.Monad.IO.Class (liftIO) import Data.Conduit import qualified Data.Conduit.List as CL import Data.List (isPrefixOf) @@ -101,7 +99,7 @@ createIndexes :: SqlPersist IO() createIndexes=do - liftIO $ logToStdout "creating indexes" + -- liftIO $ logToStdout "creating indexes" let idxs = [ "create index if not exists module_pkgid_name on DbModule (packageId,name)" , "create index if not exists decl_modid on DbDecl (moduleId)" , "create index if not exists decl_name on DbDecl (name)" diff --git a/src/Scion/PersistentBrowser/TempFile.hs b/src/Scion/PersistentBrowser/TempFile.hs --- a/src/Scion/PersistentBrowser/TempFile.hs +++ b/src/Scion/PersistentBrowser/TempFile.hs @@ -3,7 +3,7 @@ {-# OPTIONS -cpp #-} -- OPTIONS required for ghc-6.4.x compat, and must appear first -{-# LANGUAGE CPP #-} +{-# LANGUAGE CPP, ScopedTypeVariables #-} {-# OPTIONS_GHC -cpp #-} {-# OPTIONS_NHC98 -cpp #-} {-# OPTIONS_JHC -fcpp #-} @@ -24,13 +24,15 @@ Handle, IOMode(ReadWriteMode)) import System.Directory (doesFileExist) import System.FilePath ((<.>), splitExtension) -import System.IO.Error (try, isAlreadyExistsError) +import System.IO.Error (isAlreadyExistsError) #else import System.IO (Handle, openTempFile, openBinaryTempFile) import Data.Bits ((.|.)) import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR, o_BINARY, o_NONBLOCK, o_NOCTTY) -import System.IO.Error (try, isAlreadyExistsError) + +import qualified Control.Exception as Exc +import qualified GHC.IO.Exception as Exc #if __GLASGOW_HASKELL__ >= 611 import System.Posix.Internals (withFilePath) #else @@ -206,10 +208,10 @@ where findTempName x = do let dirpath = dir template ++ show x - r <- try $ mkPrivateDir dirpath + r <- Exc.try $ mkPrivateDir dirpath case r of Right _ -> return dirpath - Left e | isAlreadyExistsError e -> findTempName (x+1) + Left (e::Exc.IOException) | Exc.AlreadyExists == (Exc.ioe_type e) -> findTempName (x+1) | otherwise -> ioError e mkPrivateDir :: String -> IO () diff --git a/src/Scion/PersistentHoogle.hs b/src/Scion/PersistentHoogle.hs --- a/src/Scion/PersistentHoogle.hs +++ b/src/Scion/PersistentHoogle.hs @@ -44,7 +44,9 @@ Nothing -> return Missing Just path -> do logToStdout "Downloading hoogle data..." (ec, _, err) <- readProcessWithExitCode path ["data"] "" - when (ec/= ExitSuccess) (putStrLn err) + when (ec/= ExitSuccess) (do + logToStdout path + logToStdout err) return $ case ec of ExitSuccess->OK _-> Error @@ -53,8 +55,11 @@ checkDatabase p = do mpath <- findHoogleBinPath p case mpath of Nothing -> return Missing - Just path -> do (ec, _, _) <- readProcessWithExitCode path ["fmap"] "" + Just path -> do (ec, _, err) <- readProcessWithExitCode path ["fmap"] "" + when (ec/= ExitSuccess) (do + logToStdout path + logToStdout err) return $ case ec of - ExitSuccess->OK - _-> Error + ExitSuccess->OK + _-> Error diff --git a/src/Server/PersistentCommands.hs b/src/Server/PersistentCommands.hs --- a/src/Server/PersistentCommands.hs +++ b/src/Server/PersistentCommands.hs @@ -4,7 +4,7 @@ import Control.Applicative import Control.Monad -import Control.Monad.State +import Control.Monad.State.Strict import Data.Aeson import qualified Data.HashMap.Lazy as M import Data.Maybe (isJust, fromJust)