scion-browser 0.2.10 → 0.2.11

raw patch · 9 files changed

+137/−117 lines, 9 filesdep ~containersdep ~haskeline

Dependency ranges changed: containers, haskeline

Files

scion-browser.cabal +4/−4
src/Main.hs +1/−1
src/Scion/Packages.hs +16/−9
src/Scion/PersistentBrowser/Build.hs +7/−7
src/Scion/PersistentBrowser/Parser.hs +91/−83
src/Scion/PersistentBrowser/Query.hs +1/−3
src/Scion/PersistentBrowser/TempFile.hs +7/−5
src/Scion/PersistentHoogle.hs +9/−4
src/Server/PersistentCommands.hs +1/−1

scion-browser.cabal view

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

src/Main.hs view

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

src/Scion/Packages.hs view

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

src/Scion/PersistentBrowser/Build.hs view

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

src/Scion/PersistentBrowser/Parser.hs view

@@ -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:
---   
---   <root>
---     / 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:+--   +--   <root>+--     / 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+

src/Scion/PersistentBrowser/Query.hs view

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

src/Scion/PersistentBrowser/TempFile.hs view

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

src/Scion/PersistentHoogle.hs view

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

src/Server/PersistentCommands.hs view

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