module Scion.PersistentBrowser.Query where
import qualified Data.Text as T
import Database.Persist
import Database.Persist.Sql
import Scion.PersistentBrowser.DbTypes
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.List (isPrefixOf)
import Data.Char (toUpper)
allPackageIds :: Maybe DbPackageIdentifier -> SQL [DbPackageIdentifier]
allPackageIds pkgs = do packages <- allPackages pkgs
return $ map dbPackageToIdentifier packages
allPackages :: Maybe DbPackageIdentifier -> SQL [DbPackage]
allPackages _ = do packages <- selectList ([] :: [Filter DbPackage]) []
return $ map entityVal packages
packagesByName :: String -> Maybe DbPackageIdentifier -> SQL [DbPackage]
packagesByName name _ = do packages <- selectList [ DbPackageName ==. name ] []
return $ map entityVal packages
getPackage :: DbPackageIdentifier -> SQL (Maybe DbPackage)
getPackage (DbPackageIdentifier name version) = do package <- selectFirst [ DbPackageName ==. name, DbPackageVersion ==. version ] []
return $ fmap entityVal package
modulesByName :: String -> Maybe DbPackageIdentifier -> SQL [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 -> SQL [DbModule]
getSubmodules "" Nothing =
do let sql = "SELECT DISTINCT name, doc, packageId FROM DbModule"
queryDb sql [] moduleAction
getSubmodules "" (Just (DbPackageIdentifier pkgName pkgVersion)) =
do let sql = "SELECT DISTINCT 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 DISTINCT name, doc, packageId FROM DbModule WHERE name LIKE ?"
queryDb sql [modName ++ ".%"] moduleAction
getSubmodules modName (Just (DbPackageIdentifier pkgName pkgVersion)) =
do let sql = "SELECT DISTINCT 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 -> 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"
++ " 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 :: SQL ()
createIndexes=do
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 -> rawExecute x []) idxs
rawExecute "analyze" []
getDeclsInModule :: String -> Maybe DbPackageIdentifier -> SQL [(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 -> SQL [(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"
++ (if null prefix then "" else (" 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) -> SQL 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 -> SQL [DbConstructor]
constructorsByName name = do consts <- selectList [ DbConstructorName ==. name ] []
return $ map entityVal consts
getModulesWhereDeclarationIs :: String -> SQL [(DbModule,String,String)]
getModulesWhereDeclarationIs declName =
do let sqlDecl = "SELECT DbModule.name, DbModule.doc, DbModule.packageId,'',DbPackage.name"
++ " FROM DbDecl, DbModule, DbPackage"
++ " WHERE DbDecl.moduleId = DbModule.id AND DbDecl.name = ? AND DbPackage.id=DbModule.packageId"
sqlCons = "SELECT DbModule.name, DbModule.doc, DbModule.packageId,DbDecl.name,DbPackage.name"
++ " FROM DbConstructor, DbDecl, DbModule, DbPackage"
++ " WHERE DbConstructor.declId = DbDecl.id AND DbDecl.moduleId = DbModule.id"
++ " AND DbConstructor.name = ? AND DbPackage.id=DbModule.packageId"
decls <- queryDb sqlDecl [declName] action
cons <- queryDb sqlCons [declName] action
return (decls ++ cons)
where action :: [PersistValue] -> (DbModule,String,String)
action [PersistText name, doc, pkgId@(PersistInt64 _),PersistText decl,PersistText pkgName] = (DbModule (T.unpack name) (fromDbText doc) (Key pkgId),T.unpack decl,T.unpack pkgName)
action _ = error "This should not happen"
queryDb :: String -> [String] -> ([PersistValue] -> a) -> SQL [a]
queryDb sql params action = rawQuery (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 -> SQL DbPackage
instance HasDbPackage DbPackage where
getDbPackage = return
instance HasDbPackage DbModule where
getDbPackage (DbModule _ _ pkgId) = getJust pkgId
instance HasDbPackage DbDecl where
getDbPackage (DbDecl _ _ _ _ _ _ modId) = do md <- getJust modId
getDbPackage md
class HasDbModule d where
getDbModule :: d -> SQL DbModule
instance HasDbModule DbModule where
getDbModule = return
instance HasDbModule DbDecl where
getDbModule (DbDecl _ _ _ _ _ _ modId) = getJust modId
instance HasDbModule DbConstructor where
getDbModule (DbConstructor _ _ declId) = do
dc <- getJust declId
getDbModule dc