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.12 +version: 0.2.13 cabal-version: >= 1.8 build-type: Simple license: BSD3 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 @@ -32,6 +32,7 @@ import Text.ParserCombinators.Parsec.Pos (newPos) import Text.ParserCombinators.ReadP import Control.Monad (when) +import Data.Conduit (runResourceT) baseDbUrl :: String baseDbUrl = "http://haskell.org/hoogle/base.txt" @@ -65,7 +66,7 @@ saveHackageDatabaseWithTmp :: FilePath -> FilePath -> IO () saveHackageDatabaseWithTmp file tmp = do (db, _) <- createHackageDatabase tmp - withSqliteConn (T.pack file) (runSqlConn (mapM_ savePackageToDb db)) + runResourceT $ withSqliteConn (T.pack file) (runSqlConn (mapM_ savePackageToDb db)) --mapM_ (\pkg -> withSqliteConn (T.pack file) (runSqlConn (savePackageToDb pkg))) db -- | Downloads the information for the entire Hackage database @@ -104,9 +105,9 @@ -- | Updates a database with changes in the installed package base. updateDatabase :: FilePath -> [InstalledPackageInfo] -> IO () -updateDatabase file pkgInfo = withSqliteConn (T.pack file) $ runSqlConn $ updateDatabase' pkgInfo +updateDatabase file pkgInfo = runResourceT $ withSqliteConn (T.pack file) $ runSqlConn $ updateDatabase' pkgInfo -updateDatabase' :: [InstalledPackageInfo] -> SqlPersist IO () +updateDatabase' :: [InstalledPackageInfo] -> SQL () updateDatabase' pkgInfo = do dbPersistent <- selectList ([] :: [Filter DbPackage]) [] let dbList = map (fromDbToPackageIdentifier . entityVal) dbPersistent diff --git a/src/Scion/PersistentBrowser/DbTypes.hs b/src/Scion/PersistentBrowser/DbTypes.hs --- a/src/Scion/PersistentBrowser/DbTypes.hs +++ b/src/Scion/PersistentBrowser/DbTypes.hs @@ -6,6 +6,9 @@ -- import Database.Persist.Base import Database.Persist.Sqlite import Database.Persist.TH +import Data.Conduit (ResourceT) + +type SQL a= SqlPersist (ResourceT IO) a data DbDeclType = DbData | DbNewType | DbClass | DbInstance | DbSignature | DbType deriving (Show, Read, Eq) 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 @@ -15,27 +15,27 @@ import Data.Char (toUpper) -- |Get the identifiers of all packages in the database. -allPackageIds :: Maybe DbPackageIdentifier -> SqlPersist IO [DbPackageIdentifier] +allPackageIds :: Maybe DbPackageIdentifier -> SQL [DbPackageIdentifier] allPackageIds pkgs = do packages <- allPackages pkgs return $ map dbPackageToIdentifier packages -- |Get information of all packages in the database. -allPackages :: Maybe DbPackageIdentifier -> SqlPersist IO [DbPackage] +allPackages :: Maybe DbPackageIdentifier -> SQL [DbPackage] allPackages _ = do packages <- selectList ([] :: [Filter DbPackage]) [] return $ map entityVal packages -- |Get information of all versions of the package with that name. -packagesByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbPackage] +packagesByName :: String -> Maybe DbPackageIdentifier -> SQL [DbPackage] packagesByName name _ = do packages <- selectList [ DbPackageName ==. name ] [] return $ map entityVal packages -- |Get information about a package in the database. -getPackage :: DbPackageIdentifier -> SqlPersist IO (Maybe (DbPackage)) +getPackage :: DbPackageIdentifier -> SQL (Maybe (DbPackage)) getPackage (DbPackageIdentifier name version) = do package <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. version ] [] return $ fmap entityVal package -- |Get information about all modules with that name. -modulesByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbModule] +modulesByName :: String -> Maybe DbPackageIdentifier -> SQL [DbModule] modulesByName name Nothing = do mods <- selectList [ DbModuleName ==. name ] [] return $ map entityVal mods modulesByName name (Just (DbPackageIdentifier pkgName pkgVersion)) = @@ -48,7 +48,7 @@ -- |Get all the modules hierarchically inside the specified one. -- For getting the entire list of modules modules, use "" as initial name. -getSubmodules :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbModule] +getSubmodules :: String -> Maybe DbPackageIdentifier -> SQL [DbModule] getSubmodules "" Nothing = do let sql = "SELECT name, doc, packageId FROM DbModule" queryDb sql [] moduleAction @@ -74,7 +74,7 @@ moduleAction _ = error "This should not happen" -- |Get information about all declaration with that name. -declsByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbDecl] +declsByName :: String -> Maybe DbPackageIdentifier -> SQL [DbDecl] declsByName name Nothing = do let sql = "SELECT DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId" ++ " FROM DbDecl, DbModule" @@ -97,7 +97,7 @@ declAction _ = error "This should not happen" -createIndexes :: SqlPersist IO() +createIndexes :: SQL () createIndexes=do -- liftIO $ logToStdout "creating indexes" let idxs = [ "create index if not exists module_pkgid_name on DbModule (packageId,name)" @@ -114,7 +114,7 @@ -- |Gets the declarations inside some module, -- along with information about which package it lives. -getDeclsInModule :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [(DbPackageIdentifier, DbCompleteDecl)] +getDeclsInModule :: String -> Maybe DbPackageIdentifier -> SQL [(DbPackageIdentifier, DbCompleteDecl)] getDeclsInModule modName pkgId = do let pkg = case pkgId of Nothing -> "" @@ -146,7 +146,7 @@ -- | list declarations matching the given prefix, useful for content assist -- the prefix either matches the declaration itself or any constructor -getDeclsFromPrefix :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [(DbPackageIdentifier, DbModule, DbCompleteDecl)] +getDeclsFromPrefix :: String -> Maybe DbPackageIdentifier -> SQL [(DbPackageIdentifier, DbModule, DbCompleteDecl)] getDeclsFromPrefix prefix pkgId = do let pkg = case pkgId of Nothing -> "" @@ -184,7 +184,7 @@ -- we do case insensitive match here to be consistent with LIKE above return $ filter (\(DbConstructor name _ _)->isPrefixOf (map toUpper prefix) (map toUpper name)) $ map entityVal consts' -getAllDeclInfo :: (DbDeclId, DbDecl) -> SqlPersist IO DbCompleteDecl +getAllDeclInfo :: (DbDeclId, DbDecl) -> SQL DbCompleteDecl getAllDeclInfo (declId, decl) = do ctxs' <- selectList [ DbContextDeclId ==. declId] [] let ctxs = map entityVal ctxs' @@ -197,12 +197,12 @@ return $ DbCompleteDecl decl ctxs tyvars fundeps consts -- |Get information about all constructors with that name. -constructorsByName :: String -> SqlPersist IO [DbConstructor] +constructorsByName :: String -> SQL [DbConstructor] constructorsByName name = do consts <- selectList [ DbConstructorName ==. name ] [] return $ map entityVal consts -- | Gets a list of modules where a declaration may live -getModulesWhereDeclarationIs :: String -> SqlPersist IO [(DbModule,String)] +getModulesWhereDeclarationIs :: String -> SQL [(DbModule,String)] getModulesWhereDeclarationIs declName = do let sqlDecl = "SELECT DbModule.name, DbModule.doc, DbModule.packageId,''" ++ " FROM DbDecl, DbModule" @@ -219,7 +219,7 @@ action _ = error "This should not happen" -- |Executes a query. -queryDb :: String -> [String] -> ([PersistValue] -> a) -> SqlPersist IO [a] +queryDb :: String -> [String] -> ([PersistValue] -> a) -> SQL [a] queryDb sql params action = runResourceT (withStmt (T.pack sql) (map toPersistValue params) $= CL.map action $$ CL.consume) -- |Gets information from a text value. @@ -230,31 +230,32 @@ -- |Things that reside on a package. class HasDbPackage d where - getDbPackage :: d -> SqlPersist IO DbPackage + getDbPackage :: d -> SQL DbPackage instance HasDbPackage DbPackage where getDbPackage = return instance HasDbPackage DbModule where - getDbPackage (DbModule _ _ pkgId) = do Just pkg <- get pkgId + getDbPackage (DbModule _ _ pkgId) = do pkg <- getJust pkgId return pkg instance HasDbPackage DbDecl where - getDbPackage (DbDecl _ _ _ _ _ _ modId) = do Just md <- get modId + getDbPackage (DbDecl _ _ _ _ _ _ modId) = do md <- getJust modId getDbPackage md -- |Things that reside on a module. class HasDbModule d where - getDbModule :: d -> SqlPersist IO DbModule + getDbModule :: d -> SQL DbModule instance HasDbModule DbModule where getDbModule = return instance HasDbModule DbDecl where - getDbModule (DbDecl _ _ _ _ _ _ modId) = do Just md <- get modId + getDbModule (DbDecl _ _ _ _ _ _ modId) = do md <- getJust modId return md instance HasDbModule DbConstructor where - getDbModule (DbConstructor _ _ declId) = do Just dc <- get declId + getDbModule (DbConstructor _ _ declId) = do + dc <- getJust declId getDbModule dc diff --git a/src/Scion/PersistentHoogle.hs b/src/Scion/PersistentHoogle.hs --- a/src/Scion/PersistentHoogle.hs +++ b/src/Scion/PersistentHoogle.hs @@ -10,6 +10,7 @@ import Database.Persist.Sqlite import Scion.PersistentBrowser () import Scion.PersistentBrowser.Util +import Scion.PersistentBrowser.DbTypes import Scion.PersistentHoogle.Types import Scion.PersistentHoogle.Instances.Json () @@ -19,7 +20,7 @@ import System.Process import Text.Parsec.Prim (runP) -query :: Maybe String -> String -> SqlPersist IO [Result] +query :: Maybe String -> String -> SQL [Result] query p q = do mpath <- liftIO $ findHoogleBinPath p case mpath of Nothing -> return [] diff --git a/src/Scion/PersistentHoogle/Parser.hs b/src/Scion/PersistentHoogle/Parser.hs --- a/src/Scion/PersistentHoogle/Parser.hs +++ b/src/Scion/PersistentHoogle/Parser.hs @@ -24,7 +24,7 @@ | HalfGadtDecl String (Documented GadtDecl) | HalfKeyword String -hoogleElements :: BSParser (SqlPersist IO [Result]) +hoogleElements :: BSParser (SQL [Result]) hoogleElements = do elts <- hoogleElements' let results = catMaybesM $ map convertHalfToResult elts return results @@ -92,7 +92,7 @@ spaces0 return name -convertHalfToResult :: HalfResult -> SqlPersist IO (Maybe Result) +convertHalfToResult :: HalfResult -> SQL (Maybe Result) convertHalfToResult (HalfKeyword kw) = return $ Just (RKeyword kw) convertHalfToResult (HalfPackage pname) = diff --git a/src/Server/PersistentCommands.hs b/src/Server/PersistentCommands.hs --- a/src/Server/PersistentCommands.hs +++ b/src/Server/PersistentCommands.hs @@ -12,11 +12,13 @@ import Database.Persist.Sqlite hiding (get) import Scion.PersistentBrowser import Scion.PersistentBrowser.Build +import Scion.PersistentBrowser.DbTypes import Scion.PersistentBrowser.Query import Scion.PersistentBrowser.Util (logToStdout) import qualified Scion.PersistentHoogle as H import Scion.Packages import System.Directory +import Data.Conduit (runResourceT) data Command = LoadLocalDatabase FilePath Bool | LoadHackageDatabase FilePath Bool @@ -58,7 +60,7 @@ filterPackage (APackage pkgId)=Just pkgId filterPackage _ = Nothing -runWithState :: BrowserState -> CurrentDatabase -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> IO [a] +runWithState :: BrowserState -> CurrentDatabase -> (Maybe DbPackageIdentifier -> SQL [a]) -> IO [a] runWithState (BrowserState lDb hDb _) cdb action = do let filterPkg=filterPackage cdb @@ -66,13 +68,13 @@ hackageThings <- runWithState' (useHackage cdb) hDb (action filterPkg) return $ localThings ++ hackageThings -runWithState' :: Bool -> Maybe FilePath -> SqlPersist IO [a] -> IO [a] +runWithState' :: Bool -> Maybe FilePath -> SQL[a] -> IO [ a] runWithState' use mpath action = if use && isJust mpath then do let path = fromJust mpath - withSqliteConn (T.pack path) $ runSqlConn action + runResourceT $ withSqliteConn (T.pack path) $ runSqlConn action else return [] -runDb :: CurrentDatabase -> (Maybe DbPackageIdentifier -> SqlPersist IO [a]) -> BrowserM [a] +runDb :: CurrentDatabase -> (Maybe DbPackageIdentifier -> SQL [a]) -> BrowserM [a] runDb cdb action = do st <- get @@ -85,7 +87,7 @@ do fileExists <- lift $ doesFileExist path let fileExists' = fileExists `seq` fileExists when rebuild $ - lift $ do withSqliteConn (T.pack path) $ runSqlConn $ do + lift $ do runResourceT $ withSqliteConn (T.pack path) $ runSqlConn $ do runMigration migrateAll createIndexes pkgInfos' <- getPkgInfos @@ -102,7 +104,7 @@ when (not fileExists' || rebuild) $ lift $ do when fileExists' (removeFile path) logToStdout "Rebuilding Hackage database" - withSqliteConn (T.pack path) $ runSqlConn $ do + runResourceT $ withSqliteConn (T.pack path) $ runSqlConn $ do runMigration migrateAll createIndexes saveHackageDatabase path