Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
compile with conduit 0.5.5 and persistent 1.1
  • Loading branch information
JPMoresmau committed Dec 5, 2012
1 parent 2b40e35 commit 4033b83
Show file tree
Hide file tree
Showing 7 changed files with 267 additions and 259 deletions.
2 changes: 1 addition & 1 deletion 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
Expand Down
7 changes: 4 additions & 3 deletions src/Scion/PersistentBrowser/Build.hs
Expand Up @@ -32,6 +32,7 @@ import Text.ParserCombinators.Parsec.Error (newErrorMessage, Message(..))
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"
Expand Down Expand Up @@ -65,7 +66,7 @@ saveHackageDatabase file = withTemporaryDirectory (saveHackageDatabaseWithTmp fi

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
Expand Down Expand Up @@ -104,9 +105,9 @@ createHackageDatabase tmp =

-- | 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
Expand Down
123 changes: 63 additions & 60 deletions src/Scion/PersistentBrowser/DbTypes.hs
@@ -1,60 +1,63 @@
{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls #-}

module Scion.PersistentBrowser.DbTypes where

import Database.Persist
-- import Database.Persist.Base
import Database.Persist.Sqlite
import Database.Persist.TH

data DbDeclType = DbData | DbNewType | DbClass | DbInstance | DbSignature | DbType
deriving (Show, Read, Eq)
derivePersistField "DbDeclType"

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|
DbPackage
name String
version String
doc String Maybe
UniqueVersion name version
DbModule
name String
doc String Maybe
packageId DbPackageId
DbDecl
declType DbDeclType
name String
doc String Maybe
-- Depending on the type of decl,
-- it will have some of these
kind String Maybe
signature String Maybe
equals String Maybe
moduleId DbModuleId
DbTyVar
name String
declId DbDeclId
DbFunDep
name String
declId DbDeclId
DbContext
shown String
declId DbDeclId
DbConstructor
name String
-- Called 'type' in Json output
signature String
declId DbDeclId
|]

-- |Information needed to search a package.
data DbPackageIdentifier = DbPackageIdentifier String String -- name, version
deriving Eq

dbPackageToIdentifier :: DbPackage -> DbPackageIdentifier
dbPackageToIdentifier (DbPackage name version _) = DbPackageIdentifier name version

-- |Complete information for a declaration.
-- Look at its ToJSON instance to know which one is used in each kind of declaration.
data DbCompleteDecl = DbCompleteDecl DbDecl [DbContext] [DbTyVar] [DbFunDep] [DbConstructor]

{-# LANGUAGE QuasiQuotes, TemplateHaskell, TypeFamilies, OverloadedStrings, GADTs, FlexibleContexts, EmptyDataDecls #-}

module Scion.PersistentBrowser.DbTypes where

import Database.Persist
-- 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)
derivePersistField "DbDeclType"

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persist|
DbPackage
name String
version String
doc String Maybe
UniqueVersion name version
DbModule
name String
doc String Maybe
packageId DbPackageId
DbDecl
declType DbDeclType
name String
doc String Maybe
-- Depending on the type of decl,
-- it will have some of these
kind String Maybe
signature String Maybe
equals String Maybe
moduleId DbModuleId
DbTyVar
name String
declId DbDeclId
DbFunDep
name String
declId DbDeclId
DbContext
shown String
declId DbDeclId
DbConstructor
name String
-- Called 'type' in Json output
signature String
declId DbDeclId
|]

-- |Information needed to search a package.
data DbPackageIdentifier = DbPackageIdentifier String String -- name, version
deriving Eq

dbPackageToIdentifier :: DbPackage -> DbPackageIdentifier
dbPackageToIdentifier (DbPackage name version _) = DbPackageIdentifier name version

-- |Complete information for a declaration.
-- Look at its ToJSON instance to know which one is used in each kind of declaration.
data DbCompleteDecl = DbCompleteDecl DbDecl [DbContext] [DbTyVar] [DbFunDep] [DbConstructor]

41 changes: 21 additions & 20 deletions src/Scion/PersistentBrowser/Query.hs
Expand Up @@ -15,27 +15,27 @@ import Data.List (isPrefixOf)
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)) =
Expand All @@ -48,7 +48,7 @@ modulesByName name (Just (DbPackageIdentifier pkgName pkgVersion)) =

-- |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
Expand All @@ -74,7 +74,7 @@ moduleAction [PersistText name, doc, pkgId@(PersistInt64 _)] = DbModule (T.unpac
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"
Expand All @@ -97,7 +97,7 @@ declAction [PersistText declType, PersistText name , doc, kind, signature, equal
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)"
Expand All @@ -114,7 +114,7 @@ createIndexes=do

-- |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 -> ""
Expand Down Expand Up @@ -146,7 +146,7 @@ getDeclsInModule modName pkgId =

-- | 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 -> ""
Expand Down Expand Up @@ -184,7 +184,7 @@ getDeclsFromPrefix prefix pkgId =
-- 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'
Expand All @@ -197,12 +197,12 @@ getAllDeclInfo (declId, decl) =
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"
Expand All @@ -219,7 +219,7 @@ getModulesWhereDeclarationIs declName =
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.
Expand All @@ -230,31 +230,32 @@ fromDbText _ = error "This should not happen"

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

3 changes: 2 additions & 1 deletion src/Scion/PersistentHoogle.hs
Expand Up @@ -10,6 +10,7 @@ import Control.Monad.IO.Class (liftIO)
import Database.Persist.Sqlite
import Scion.PersistentBrowser ()
import Scion.PersistentBrowser.Util
import Scion.PersistentBrowser.DbTypes

import Scion.PersistentHoogle.Types
import Scion.PersistentHoogle.Instances.Json ()
Expand All @@ -19,7 +20,7 @@ import System.Exit (ExitCode(..))
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 []
Expand Down

0 comments on commit 4033b83

Please sign in to comment.