module Scion.PersistentBrowser.Query where
import qualified Data.Text as T
import Database.Persist
import Database.Persist.Sqlite
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
allPackageIds :: Maybe DbPackageIdentifier -> SqlPersist IO [DbPackageIdentifier]
allPackageIds pkgs = do packages <- allPackages pkgs
return $ map dbPackageToIdentifier packages
allPackages :: Maybe DbPackageIdentifier -> SqlPersist IO [DbPackage]
allPackages _ = do packages <- selectList ([] :: [Filter DbPackage]) []
return $ map entityVal packages
packagesByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbPackage]
packagesByName name _ = do packages <- selectList [ DbPackageName ==. name ] []
return $ map entityVal packages
getPackage :: DbPackageIdentifier -> SqlPersist IO (Maybe (DbPackage))
getPackage (DbPackageIdentifier name version) = do package <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. version ] []
return $ fmap entityVal package
modulesByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbModule]
modulesByName name Nothing = do mods <- selectList [ DbModuleName ==. name ] []
return $ map entityVal mods
modulesByName name (Just (DbPackageIdentifier pkgName pkgVersion)) =
do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage"
++ " WHERE DbModule.packageId = DbPackage.id "
++ " AND DbModule.name = ?"
++ " AND DbPackage.name = ?"
++ " AND DbPackage.version = ?"
queryDb sql [name, pkgName, pkgVersion] moduleAction
getSubmodules :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [DbModule]
getSubmodules "" Nothing =
do let sql = "SELECT name, doc, packageId FROM DbModule"
queryDb sql [] moduleAction
getSubmodules "" (Just (DbPackageIdentifier pkgName pkgVersion)) =
do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage"
++ " WHERE DbModule.packageId = DbPackage.id "
++ " AND DbPackage.name = ?"
++ " AND DbPackage.version = ?"
queryDb sql [pkgName, pkgVersion] moduleAction
getSubmodules modName Nothing =
do let sql = "SELECT name, doc, packageId FROM DbModule WHERE name LIKE ?"
queryDb sql [modName ++ ".%"] moduleAction
getSubmodules modName (Just (DbPackageIdentifier pkgName pkgVersion)) =
do let sql = "SELECT DbModule.name, DbModule.doc, DbModule.packageId FROM DbModule, DbPackage"
++ " WHERE name LIKE ?"
++ " AND DbModule.packageId = DbPackage.id "
++ " AND DbPackage.name = ?"
++ " AND DbPackage.version = ?"
queryDb sql [modName ++ ".%", pkgName, pkgVersion] moduleAction
moduleAction :: [PersistValue] -> DbModule
moduleAction [PersistText name, doc, pkgId@(PersistInt64 _)] = DbModule (T.unpack name) (fromDbText doc) (Key pkgId)
moduleAction _ = error "This should not happen"
declsByName :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [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"
++ " WHERE DbModule.name = ?"
queryDb sql [name] declAction
declsByName name (Just (DbPackageIdentifier pkgName pkgVersion)) =
do let sql = "SELECT DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId"
++ " FROM DbDecl, DbModule, DbPackage"
++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id"
++ " AND DbModule.name = ?"
++ " AND DbPackage.name = ?"
++ " AND DbPackage.version = ?"
queryDb sql [name, pkgName, pkgVersion] declAction
declAction :: [PersistValue] -> DbDecl
declAction [PersistText declType, PersistText name , doc, kind, signature, equals, modId@(PersistInt64 _)] =
DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc)
(fromDbText kind) (fromDbText signature) (fromDbText equals)
(Key modId)
declAction _ = error "This should not happen"
createIndexes :: SqlPersist IO()
createIndexes=do
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)"
, "create index if not exists cons_name on DbConstructor (name)"
, "create index if not exists cons_declid on DbConstructor (declId)"
, "create index if not exists tyvar_declid on DbTyVar (declId)"
, "create index if not exists fundep_declid on DbFunDep (declId)"
, "create index if not exists context_declid on DbContext (declId)"
]
mapM_ (\x -> execute x []) idxs
execute "analyze" []
getDeclsInModule :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [(DbPackageIdentifier, DbCompleteDecl)]
getDeclsInModule modName pkgId =
do let pkg = case pkgId of
Nothing -> ""
Just _ -> " AND DbPackage.name = ? AND DbPackage.version = ?"
let sql = "SELECT DbDecl.id, DbDecl.declType, DbDecl.name, DbDecl.doc, DbDecl.kind, DbDecl.signature, DbDecl.equals, DbDecl.moduleId"
++ ", DbPackage.name, DbPackage.version"
++ " FROM DbDecl, DbModule, DbPackage"
++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id"
++ " AND DbModule.name = ?"
++ pkg
let args = case pkgId of
Nothing -> [modName]
Just (DbPackageIdentifier pkgName pkgVersion) -> [modName, pkgName, pkgVersion]
elts <- queryDb sql args action
completeElts <- mapM (\(dclId, dcl, p) -> do dclAll <- getAllDeclInfo (dclId, dcl)
return (p, dclAll)) elts
return completeElts
where action :: [PersistValue] -> (DbDeclId, DbDecl, DbPackageIdentifier)
action [declId@(PersistInt64 _), PersistText declType, PersistText name
, doc, kind, signature, equals, modId@(PersistInt64 _)
, PersistText pkgName, PersistText pkgVersion] =
( Key declId
, DbDecl (read (T.unpack declType)) (T.unpack name) (fromDbText doc)
(fromDbText kind) (fromDbText signature) (fromDbText equals)
(Key modId)
, DbPackageIdentifier (T.unpack pkgName) (T.unpack pkgVersion)
)
action _ = error "This should not happen"
getAllDeclInfo :: (DbDeclId, DbDecl) -> SqlPersist IO DbCompleteDecl
getAllDeclInfo (declId, decl) =
do ctxs' <- selectList [ DbContextDeclId ==. declId] []
let ctxs = map entityVal ctxs'
tyvars' <- selectList [ DbTyVarDeclId ==. declId] []
let tyvars = map entityVal tyvars'
fundeps' <- selectList [ DbFunDepDeclId ==. declId] []
let fundeps = map entityVal fundeps'
consts' <- selectList [ DbConstructorDeclId ==. declId] []
let consts = map entityVal consts'
return $ DbCompleteDecl decl ctxs tyvars fundeps consts
constructorsByName :: String -> SqlPersist IO [DbConstructor]
constructorsByName name = do consts <- selectList [ DbConstructorName ==. name ] []
return $ map entityVal consts
getModulesWhereDeclarationIs :: String -> SqlPersist IO [DbModule]
getModulesWhereDeclarationIs declName =
do let sqlDecl = "SELECT DbModule.name, DbModule.doc, DbModule.packageId"
++ " FROM DbDecl, DbModule"
++ " WHERE DbDecl.moduleId = DbModule.id AND DbDecl.name = ?"
sqlCons = "SELECT DbModule.name, DbModule.doc, DbModule.packageId"
++ " FROM DbConstructor, DbDecl, DbModule"
++ " WHERE DbConstructor.declId = DbDecl.id AND DbDecl.moduleId = DbModule.id"
++ " AND DbConstructor.name = ?"
decls <- queryDb sqlDecl [declName] action
cons <- queryDb sqlCons [declName] action
return (decls ++ cons)
where action :: [PersistValue] -> DbModule
action [PersistText name, doc, pkgId@(PersistInt64 _)] = DbModule (T.unpack name) (fromDbText doc) (Key pkgId)
action _ = error "This should not happen"
queryDb :: String -> [String] -> ([PersistValue] -> a) -> SqlPersist IO [a]
queryDb sql params action = runResourceT (withStmt (T.pack sql) (map toPersistValue params) $= CL.map action $$ CL.consume)
fromDbText :: PersistValue -> Maybe String
fromDbText (PersistText value) = Just (T.unpack value)
fromDbText PersistNull = Nothing
fromDbText _ = error "This should not happen"
class HasDbPackage d where
getDbPackage :: d -> SqlPersist IO DbPackage
instance HasDbPackage DbPackage where
getDbPackage = return
instance HasDbPackage DbModule where
getDbPackage (DbModule _ _ pkgId) = do Just pkg <- get pkgId
return pkg
instance HasDbPackage DbDecl where
getDbPackage (DbDecl _ _ _ _ _ _ modId) = do Just md <- get modId
getDbPackage md
class HasDbModule d where
getDbModule :: d -> SqlPersist IO DbModule
instance HasDbModule DbModule where
getDbModule = return
instance HasDbModule DbDecl where
getDbModule (DbDecl _ _ _ _ _ _ modId) = do Just md <- get modId
return md
instance HasDbModule DbConstructor where
getDbModule (DbConstructor _ _ declId) = do Just dc <- get declId
getDbModule dc