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
import Data.List (isPrefixOf)
import Data.Char (toUpper)
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"
getDeclsFromPrefix :: String -> Maybe DbPackageIdentifier -> SqlPersist IO [(DbPackageIdentifier, DbModule, DbCompleteDecl)]
getDeclsFromPrefix prefix 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, "
++ "DbModule.name, DbPackage.name, DbPackage.version"
++ " FROM DbDecl, DbModule, DbPackage"
++ " WHERE DbDecl.moduleId = DbModule.id AND DbModule.packageId = DbPackage.id"
++ " AND (DbDecl.name LIKE '"
++ prefix ++ "%' or DbDecl.id in (select DbConstructor.declId from DbConstructor where DbConstructor.name LIKE '"
++ prefix ++ "%'))"
++ pkg
let args = case pkgId of
Nothing -> []
Just (DbPackageIdentifier pkgName pkgVersion) -> [pkgName, pkgVersion]
elts <- queryDb sql args action
completeElts <- mapM (\(dclId, dcl, p,m) -> do cs <- consts dclId
let dclAll=DbCompleteDecl dcl [] [] [] cs
return (p,m, dclAll)) elts
return completeElts
where action :: [PersistValue] -> (DbDeclId, DbDecl, DbPackageIdentifier, DbModule)
action [declId@(PersistInt64 _), PersistText declType, PersistText name
, doc, kind, signature, equals, modId@(PersistInt64 _)
, PersistText modName, 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)
, DbModule (T.unpack modName) Nothing (Key modId)
)
action _ = error "This should not happen"
consts declId=do
consts' <- selectList [ DbConstructorDeclId ==. declId] []
return $ filter (\(DbConstructor name _ _)->isPrefixOf (map toUpper prefix) (map toUpper name)) $ map entityVal consts'
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,String)]
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,DbDecl.name"
++ " 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,String)
action [PersistText name, doc, pkgId@(PersistInt64 _),PersistText decl] = (DbModule (T.unpack name) (fromDbText doc) (Key pkgId),T.unpack decl)
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