Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

search decls and constructors from prefix

  • Loading branch information...
commit 9496914b4a7fcaef1fb416e93403a09112fb3681 1 parent 19239b2
@JPMoresmau authored
View
2  scion-browser.cabal
@@ -1,5 +1,5 @@
name: scion-browser
-version: 0.2.7
+version: 0.2.8
cabal-version: >= 1.8
build-type: Simple
license: BSD3
View
10 src/Main.hs
@@ -6,10 +6,9 @@ import qualified Codec.Compression.Zlib as Zlib
import Control.Monad.State
import Data.Aeson
import qualified Data.Aeson.Types as T
-import qualified Data.Attoparsec.Char8 as Atto
-import qualified Data.Attoparsec.Types as Atto
-import qualified Data.ByteString.Char8 as BS
+import qualified Data.Attoparsec.ByteString as Atto
import qualified Data.ByteString.Lazy.Char8 as LBS
+import qualified Data.ByteString.UTF8 as BSU(fromString)
import Server.PersistentCommands
import System.Console.Haskeline
import System.IO (hFlush, stdout, stderr)
@@ -28,11 +27,12 @@ main = do args <- getArgs
return ()
loop :: InputT BrowserM ()
-loop = do maybeLine <- getInputLine ""
+loop = do
+ maybeLine <- getInputLine ""
case maybeLine of
Nothing -> return () -- ctrl+D or EOF
Just line -> do
- case Atto.parse json (BS.pack line) of
+ case Atto.parse json (BSU.fromString line) of
Atto.Fail _ _ e -> (liftIO $ logToStdout ("error in command: " ++ e)) >> loop
Atto.Partial _ -> (liftIO $ logToStdout ("incomplete data error in command: ")) >> loop
Atto.Done _ value -> case T.parse parseJSON value of
View
42 src/Scion/PersistentBrowser/Query.hs
@@ -13,6 +13,8 @@ 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)
-- |Get the identifiers of all packages in the database.
allPackageIds :: Maybe DbPackageIdentifier -> SqlPersist IO [DbPackageIdentifier]
@@ -144,6 +146,46 @@ getDeclsInModule modName pkgId =
)
action _ = error "This should not happen"
+-- | 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 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] []
+ -- 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 (declId, decl) =
do ctxs' <- selectList [ DbContextDeclId ==. declId] []
View
5 src/Scion/PersistentHoogle.hs
@@ -26,7 +26,10 @@ query p q = do mpath <- liftIO $ findHoogleBinPath p
Nothing -> return []
Just path -> do (exitCode, output, err) <- liftIO $ readProcessWithExitCode path [q] ""
case exitCode of
- ExitSuccess -> do let search = runP hoogleElements () "hoogle-output" (output)
+ ExitSuccess -> do
+ liftIO $ logToStdout q
+ liftIO $ logToStdout output
+ let search = runP hoogleElements () "hoogle-output" (output)
case search of
Right result -> do dbResult <- result
return dbResult
View
6 src/Server/PersistentCommands.hs
@@ -28,6 +28,7 @@ data Command = LoadLocalDatabase FilePath Bool
| HoogleCheckDatabase
| GetDeclarationModules CurrentDatabase String
| SetExtraHooglePath String
+ | GetDeclarationsFromPrefix CurrentDatabase String
| Quit
data CurrentDatabase = AllPackages
@@ -118,6 +119,9 @@ executeCommand (GetModules cdb mname) =
executeCommand (GetDeclarations cdb mname) =
do decls <- runDb cdb (getDeclsInModule mname)
return (toJSON decls, True)
+executeCommand (GetDeclarationsFromPrefix cdb prefix) =
+ do decls <- runDb cdb (getDeclsFromPrefix prefix)
+ return (toJSON decls, True)
executeCommand (HoogleQuery cdb query) =
do extraH <- fmap extraHooglePath get
results <- runDb cdb (\_ -> H.query extraH query)
@@ -149,6 +153,8 @@ instance FromJSON Command where
<*> v .: "module"
"get-declarations" -> GetDeclarations <$>v .: "db"
<*> v .: "module"
+ "get-decl-prefix" -> GetDeclarationsFromPrefix <$>v .: "db"
+ <*> v .: "prefix"
"hoogle-query" -> HoogleQuery <$> v .: "db"
<*> v .: "query"
"hoogle-data" -> pure HoogleDownloadData
Please sign in to comment.
Something went wrong with that request. Please try again.