{-# LANGUAGE OverloadedStrings, FlexibleContexts, TypeOperators, TypeApplications #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module HsDev.Client.Commands (
runClient, runCommand
) where
import Control.Arrow (second)
import Control.Concurrent.MVar
import Control.Exception (displayException)
import Control.Lens hiding ((.=), (<.>))
import Control.Monad
import Control.Monad.Morph
import Control.Monad.Except
import Control.Monad.Reader
import qualified Control.Monad.State as State
import Control.Monad.Catch (try, catch, bracket, SomeException(..))
import Data.Aeson hiding (Result, Error)
import Data.List
import Data.Maybe
import qualified Data.Map.Strict as M
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T (append, null)
import System.Directory
import System.FilePath
import qualified System.Log.Simple as Log
import qualified System.Log.Simple.Base as Log
import Text.Read (readMaybe)
import Data.Maybe.JustIf
import qualified System.Directory.Watcher as W
import System.Directory.Paths
import Text.Format
import HsDev.Error
import HsDev.Database.SQLite as SQLite
import HsDev.Inspect (preload, asModule)
import HsDev.Scan (upToDate, getFileContents)
import HsDev.Server.Message as M
import HsDev.Server.Types
import HsDev.Sandbox hiding (findSandbox)
import qualified HsDev.Sandbox as S (findSandbox)
import HsDev.Symbols
import qualified HsDev.Tools.AutoFix as AutoFix
import qualified HsDev.Tools.Cabal as Cabal
import HsDev.Tools.Ghc.Session
import HsDev.Tools.Ghc.Worker (clearTargets)
import qualified HsDev.Tools.Ghc.Compat as Compat
import qualified HsDev.Tools.Ghc.Check as Check
import qualified HsDev.Tools.Ghc.Types as Types
import qualified HsDev.Tools.Hayoo as Hayoo
import qualified HsDev.Tools.HDocs as HDocs
import qualified HsDev.Tools.HLint as HLint
import qualified HsDev.Tools.Types as Tools
import HsDev.Util
import HsDev.Watcher
import qualified HsDev.Database.Update as Update
runClient :: (ToJSON a, ServerMonadBase m) => CommandOptions -> ClientM m a -> ServerM m Result
runClient copts = mapServerM toResult . runClientM where
toResult :: (ToJSON a, ServerMonadBase m) => ReaderT CommandOptions m a -> m Result
toResult act = liftM errorToResult $ runReaderT (try (try act)) copts
mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b
mapServerM f = ServerM . mapReaderT f . runServerM
errorToResult :: ToJSON a => Either SomeException (Either HsDevError a) -> Result
errorToResult = either (Error . UnhandledError . displayException) (either Error (Result . toJSON))
toValue :: (ToJSON a, Monad m) => m a -> m Value
toValue = fmap toJSON
runCommand :: ServerMonadBase m => Command -> ClientM m Value
runCommand Ping = toValue $ return $ object ["message" .= ("pong" :: String)]
runCommand (Listen (Just l)) = case Log.level (pack l) of
Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l
Just lev -> bracket (serverSetLogLevel lev) serverSetLogLevel $ \_ -> runCommand (Listen Nothing)
runCommand (Listen Nothing) = toValue $ do
serverListen >>= mapM_ (commandNotify . Notification . toJSON)
runCommand (SetLogLevel l) = case Log.level (pack l) of
Nothing -> hsdevError $ OtherError $ "invalid log level: {}" ~~ l
Just lev -> toValue $ do
lev' <- serverSetLogLevel lev
Log.sendLog Log.Debug $ "log level changed from '{}' to '{}'" ~~ show lev' ~~ show lev
Log.sendLog Log.Info $ "log level updated to: {}" ~~ show lev
runCommand (Scan projs cabal sboxes fs paths' btool ghcs' docs' infer') = toValue $ do
sboxes' <- getSandboxes sboxes
updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [
[Update.scanCabal ghcs' | cabal],
map (Update.scanSandbox ghcs') sboxes',
[Update.scanFiles (zip fs (repeat ghcs'))],
map (Update.scanProject ghcs' btool) projs,
map (Update.scanDirectory ghcs') paths']
runCommand (ScanProject proj tool deps) = toValue $ updateProcess def [
(if deps then Update.scanProjectStack else Update.scanProject) [] tool proj]
runCommand (ScanFile fpath tool scanProj deps) = toValue $ updateProcess def [
Update.scanFile [] fpath tool scanProj deps]
runCommand (ScanPackageDbs pdbs) = toValue $ updateProcess def [
Update.scanPackageDbStack [] pdbs]
runCommand (SetFileContents f mcts) = toValue $ serverSetFileContents f mcts
runCommand (RefineDocs projs fs)
| HDocs.hdocsSupported = toValue $ do
projects <- traverse findProject projs
mods <- do
projMods <- liftM concat $ forM projects $ \proj -> do
ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.docs') is null"
(Only $ proj ^. projectCabal)
p <- SQLite.loadProject (proj ^. projectCabal)
return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms
fileMods <- liftM concat $ forM fs $ \f ->
loadModules "select id from modules where file == ? and json_extract(tags, '$.docs') is null"
(Only f)
return $ projMods ++ fileMods
updateProcess def [Update.scanDocs mods]
| otherwise = hsdevError $ OtherError "docs not supported"
runCommand (InferTypes projs fs) = toValue $ do
projects <- traverse findProject projs
mods <- do
projMods <- liftM concat $ forM projects $ \proj -> do
ms <- loadModules "select id from modules where cabal == ? and json_extract(tags, '$.types') is null"
(Only $ proj ^. projectCabal)
p <- SQLite.loadProject (proj ^. projectCabal)
return $ set (each . moduleId . moduleLocation . moduleProject) (Just p) ms
fileMods <- liftM concat $ forM fs $ \f ->
loadModules "select id from modules where file == ? and json_extract(tags, '$.types') is null"
(Only f)
return $ projMods ++ fileMods
updateProcess def [Update.inferModTypes mods]
runCommand (Remove projs cabal sboxes files) = toValue $ withSqlConnection $ SQLite.transaction_ SQLite.Immediate $ do
let
canRemove pdbs = do
from' <- State.get
return $ null $ filter (pdbs `isSubStack`) $ delete pdbs from'
removePackageDb' pdbs = do
can <- canRemove pdbs
when can $ do
State.modify (delete pdbs)
ms <- liftM (map fromOnly) $ query_
"select m.id from modules as m, package_dbs as ps where m.package_name == ps.package_name and m.package_version == ps.package_version;"
removePackageDb (topPackageDb pdbs)
mapM_ SQLite.removeModule ms
whenJustM (askSession sessionWatcher) $ \w ->
liftIO $ unwatchPackageDb w $ topPackageDb pdbs
removePackageDbStack = mapM_ removePackageDb' . packageDbStacks
projects <- traverse findProject projs
sboxes' <- getSandboxes sboxes
forM_ projects $ \proj -> do
ms <- liftM (map fromOnly) $ query "select id from modules where cabal == ?;" (Only $ proj ^. projectCabal)
SQLite.removeProject proj
mapM_ SQLite.removeModule ms
whenJustM (askSession sessionWatcher) $ \w ->
liftIO $ unwatchProject w proj
allPdbs <- liftM (map fromOnly) $ query_ @(Only PackageDb) "select package_db from package_dbs;"
dbPDbs <- inSessionGhc $ mapM restorePackageDbStack allPdbs
flip State.evalStateT dbPDbs $ do
when cabal $ removePackageDbStack userDb
forM_ sboxes' $ \sbox -> do
pdbs <- lift $ inSessionGhc $ sandboxPackageDbStack sbox
removePackageDbStack pdbs
forM_ files $ \file -> do
ms <- query @_ @(ModuleId :. Only Int)
(toQuery $ mconcat [
qModuleId,
select_ ["mu.id"],
where_ ["mu.file == ?"]])
(Only file)
forM_ ms $ \(m :. Only i) -> do
SQLite.removeModule i
whenJustM (askSession sessionWatcher) $ \w ->
liftIO . unwatchModule w $ (m ^. moduleLocation)
runCommand RemoveAll = toValue $ do
SQLite.purge
whenJustM (askSession sessionWatcher) $ \w -> do
wdirs <- liftIO $ readMVar (W.watcherDirs w)
liftIO $ forM_ (M.toList wdirs) $ \(dir, (isTree, _)) -> (if isTree then W.unwatchTree else W.unwatchDir) w dir
runCommand InfoPackages = toValue $
query_ @ModulePackage "select package_name, package_version from package_dbs;"
runCommand InfoProjects = toValue $ do
ps <- query_ @(Only Path) "select cabal from projects;"
mapM (SQLite.loadProject . fromOnly) ps
runCommand InfoSandboxes = toValue $ do
rs <- query_ @(Only PackageDb) "select distinct package_db from package_dbs;"
return [pdb | Only pdb <- rs]
runCommand (InfoSymbol sq filters True _) = toValue $ do
let
(conds, params) = targetFilters "m" (Just "s") filters
queryNamed @SymbolId
(toQuery $ mconcat [
qSymbolId,
where_ ["s.name like :pattern escape '\\'"],
where_ conds])
([":pattern" := likePattern sq] ++ params)
runCommand (InfoSymbol sq filters False _) = toValue $ do
let
(conds, params) = targetFilters "m" (Just "s") filters
queryNamed @Symbol
(toQuery $ mconcat [
qSymbol,
where_ ["s.name like :pattern escape '\\'"],
where_ conds])
([":pattern" := likePattern sq] ++ params)
runCommand (InfoModule sq filters h _) = toValue $ do
let
(conds, params) = targetFilters "mu" Nothing filters
rs <- queryNamed @(Only Int :. ModuleId)
(toQuery $ mconcat [
select_ ["mu.id"],
qModuleId,
where_ ["mu.name like :pattern escape '\\'"],
where_ conds])
([":pattern" := likePattern sq] ++ params)
if h
then return (toJSON $ map (\(_ :. m) -> m) rs)
else liftM toJSON $ forM rs $ \(Only mid :. mheader) -> do
[(docs, fixities)] <- query @_ @(Maybe Text, Maybe Value) "select m.docs, m.fixities from modules as m where (m.id == ?);"
(Only mid)
let
fixities' = fromMaybe [] (fixities >>= fromJSON')
imports' <- query @_ @Import (toQuery $ mconcat [
qImport "i",
where_ ["i.module_id = ?"]])
(Only mid)
exports' <- query @_ @Symbol (toQuery $ mconcat [
qSymbol,
from_ ["exports as e"],
where_ ["e.module_id == ?", "e.symbol_id == s.id"]])
(Only mid)
return $ Module mheader docs imports' exports' fixities' mempty Nothing
runCommand (InfoProject (Left projName)) = toValue $ findProject projName
runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject (view path projPath)
runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandboxes sandbox'
runCommand (Lookup nm fpath) = toValue $
fmap (map (\(s :. m) -> ImportedSymbol s m)) $ query @_ @(Symbol :. ModuleId) (toQuery $ mconcat [
qSymbol,
qModuleId,
from_ ["projects_modules_scope as pms", "modules as srcm", "exports as e"],
where_ [
"pms.cabal is srcm.cabal",
"srcm.file = ?",
"pms.module_id = e.module_id",
"m.id = s.module_id",
"s.id = e.symbol_id",
"e.module_id = mu.id",
"s.name = ?"]])
(fpath ^. path, nm)
runCommand (Whois nm fpath) = toValue $ do
let
q = nameModule $ toName nm
ident = nameIdent $ toName nm
query @_ @Symbol (toQuery $ mconcat [
qSymbol,
from_ ["modules as srcm", "scopes as sc"],
where_ [
"srcm.id == sc.module_id",
"s.id == sc.symbol_id",
"srcm.file == ?",
"sc.qualifier is ?",
"sc.name == ?"]])
(fpath ^. path, q, ident)
runCommand (Whoat l c fpath) = toValue $ do
rs <- query @_ @Symbol (toQuery $ mconcat [
qSymbol,
from_ ["names as n", "modules as srcm"],
where_ [
"srcm.id == n.module_id",
"m.name == n.resolved_module",
"s.name == n.resolved_name",
"s.what == n.resolved_what",
"s.id == n.symbol_id",
"srcm.file == ?",
"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]])
(fpath ^. path, l, c)
locals <- do
defs <- query @_ @(ModuleId :. (Text, Int, Int, Maybe Text)) (toQuery $ mconcat [
qModuleId,
select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type"],
from_ ["names as n"],
where_ [
"mu.id == n.module_id",
"n.def_line is not null",
"n.def_column is not null",
"mu.file == ?",
"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)"]])
(fpath ^. path, l, c)
return [
Symbol {
_symbolId = SymbolId nm mid,
_symbolDocs = Nothing,
_symbolPosition = Just (Position defLine defColumn),
_symbolInfo = Function ftype
} | (mid :. (nm, defLine, defColumn, ftype)) <- defs]
return $ rs ++ locals
runCommand (ResolveScopeModules sq fpath) = toValue $ do
pids <- query @_ @(Only (Maybe Path)) "select m.cabal from modules as m where (m.file == ?);"
(Only $ fpath ^. path)
case pids of
[] -> hsdevError $ OtherError $ "module at {} not found" ~~ fpath
[Only proj] -> query @_ @ModuleId (toQuery $ mconcat [
qModuleId,
from_ ["projects_modules_scope as msc"],
where_ [
"msc.module_id == mu.id",
"msc.cabal is ?",
"mu.name like ? escape '\\'"]])
(proj, likePattern sq)
_ -> fail "Impossible happened: several projects for one module"
runCommand (ResolveScope sq fpath) = toValue $
query @_ @(Scoped SymbolId) (toQuery $ mconcat [
qSymbolId,
select_ ["sc.qualifier"],
from_ ["scopes as sc", "modules as srcm"],
where_ [
"srcm.id == sc.module_id",
"sc.symbol_id == s.id",
"srcm.file == ?",
"s.name like ? escape '\\'"]])
(fpath ^. path, likePattern sq)
runCommand (FindUsages l c fpath) = toValue $ do
us <- do
sids <- query @_ @(Only (Maybe Int)) (toQuery $ mconcat [
select_ ["n.symbol_id"],
from_ ["names as n", "modules as srcm"],
where_ [
"n.module_id == srcm.id",
"(?, ?) between (n.line, n.column) and (n.line_to, n.column_to)",
"srcm.file = ?"]])
(l, c, fpath)
when (length sids > 1) $ Log.sendLog Log.Warning $ "multiple symbols found at location {0}:{1}:{2}" ~~ fpath ~~ l ~~ c
let
msid = join $ fmap fromOnly $ listToMaybe sids
query @_ @SymbolUsage (toQuery $ mconcat [
qSymbol,
select_ ["n.qualifier"],
qModuleId,
select_ ["n.line", "n.column", "n.line_to", "n.column_to"],
from_ ["names as n"],
where_ [
"n.symbol_id == ?",
"s.id == n.symbol_id",
"mu.id == n.module_id"]])
(Only msid)
locals <- do
defs <- query @_ @(ModuleId :. Only Text :. Position :. Only (Maybe Text) :. Region) (toQuery $ mconcat [
qModuleId,
select_ ["n.name", "n.def_line", "n.def_column", "n.inferred_type", "n.line", "n.column", "n.line_to", "n.column_to"],
from_ ["names as n", "names as defn"],
where_ [
"n.module_id = mu.id",
"n.def_line = defn.def_line",
"n.def_column = defn.def_column",
"defn.module_id = mu.id",
"(?, ?) between (defn.line, defn.column) and (defn.line_to, defn.column_to)",
"mu.file = ?"]])
(l, c, fpath ^. path)
return $ do
(mid :. Only nm :. defPos :. Only ftype :. useRgn) <- defs
let
sym = Symbol {
_symbolId = SymbolId nm mid,
_symbolDocs = Nothing,
_symbolPosition = Just defPos,
_symbolInfo = Function ftype }
return $ SymbolUsage sym Nothing mid useRgn
return $ us ++ locals
runCommand (Complete input True fpath) = toValue $
query @_ @Symbol (toQuery $ mconcat [
qSymbol,
from_ ["modules as srcm", "exports as e"],
where_ [
"e.module_id in (select srcm.id union select module_id from projects_modules_scope where (((cabal is null) and (srcm.cabal is null)) or (cabal == srcm.cabal)))",
"s.id == e.symbol_id",
"msrc.file == ?",
"s.name like ? escape '\\'"]])
(fpath ^. path, likePattern (SearchQuery input SearchPrefix))
runCommand (Complete input False fpath) = toValue $
query @_ @(Scoped Symbol) (toQuery $ mconcat [
qSymbol,
select_ ["c.qualifier"],
from_ ["completions as c", "modules as srcm"],
where_ [
"c.module_id == srcm.id",
"c.symbol_id == s.id",
"srcm.file == ?",
"c.completion like ? escape '\\'"]])
(fpath ^. path, likePattern (SearchQuery input SearchPrefix))
runCommand (Hayoo hq p ps) = do
m <- askSession sessionHTTPManager
toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM
(mapMaybe Hayoo.hayooAsSymbol . Hayoo.resultResult) $
liftIO $ hsdevLift $ Hayoo.hayoo m hq (Just i)
runCommand (CabalList packages') = toValue $ liftIO $ hsdevLift $ Cabal.cabalList $ map unpack packages'
runCommand (UnresolvedSymbols fs) = toValue $ liftM concat $ forM fs $ \f -> do
rs <- query @_ @(Maybe String, String, Int, Int) "select n.qualifier, n.name, n.line, n.column from modules as m, names as n where (m.id == n.module_id) and (m.file == ?) and (n.resolve_error is not null);"
(Only $ f ^. path)
return $ map (\(m, nm, line, column) -> object [
"qualifier" .= m,
"name" .= nm,
"line" .= line,
"column" .= column]) rs
runCommand (Lint fs lints) = toValue $ liftM concat $ forM fs $ \fsrc -> do
FileSource f c <- getUpdateFileContents fsrc
liftIO $ hsdevLift $ HLint.hlint lints (view path f) c
runCommand (Check fs ghcs' clear) = toValue $ Log.scope "check" $
liftM concat $ mapM (runCheck ghcs' clear) fs
runCommand (CheckLint fs ghcs' lints clear) = toValue $ do
fs' <- mapM getUpdateFileContents fs
checkMsgs <- liftM concat $ mapM (runCheck ghcs' clear) fs'
lintMsgs <- liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint lints (view path f) c) fs'
return $ checkMsgs ++ lintMsgs
runCommand (Types fs ghcs' clear) = toValue $ do
liftM concat $ forM fs $ \fsrc@(FileSource file msrc) -> do
mcached' <- getCached file msrc
FileSource _ msrc' <- getUpdateFileContents fsrc
maybe (updateTypes file msrc') return mcached'
where
getCached :: ServerMonadBase m => Path -> Maybe Text -> ClientM m (Maybe [Tools.Note Types.TypedExpr])
getCached _ (Just _) = return Nothing
getCached file' Nothing = do
actual' <- sourceUpToDate file'
mid <- query @_ @((Bool, Int) :. ModuleId)
(toQuery $ mconcat [
select_ ["json_extract(tags, '$.types') is 1", "mu.id"],
qModuleId,
where_ ["mu.file = ?"]])
(Only file')
when (length mid > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ file'
when (null mid) $ hsdevError $ NotInspected $ FileModule file' Nothing
let
[(hasTypes', mid') :. modId] = mid
if actual' && hasTypes'
then do
types' <- query @_ @(Region :. Types.TypedExpr) "select line, column, line_to, column_to, expr, type from types where module_id = ?;" (Only mid')
liftM Just $ forM types' $ \(rgn :. texpr) -> return Tools.Note {
Tools._noteSource = modId ^. moduleLocation,
Tools._noteRegion = rgn,
Tools._noteLevel = Nothing,
Tools._note = set Types.typedExpr Nothing texpr }
else return Nothing
updateTypes file msrc = do
sess <- getSession
m <- setFileSourceSession ghcs' file
types' <- inSessionGhc $ do
when clear clearTargets
Update.cacheGhcWarnings sess [m ^. moduleId . moduleLocation] $
Types.fileTypes m msrc
updateProcess def [Update.setModTypes (m ^. moduleId) types']
return $ set (each . Tools.note . Types.typedExpr) Nothing types'
runCommand (AutoFix ns) = toValue $ return $ AutoFix.corrections ns
runCommand (Refactor ns rest isPure) = toValue $ do
files <- liftM (ordNub . sort) $ mapM findPath $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns
let
runFix file = do
unless isPure $ do
liftIO $ readFileUtf8 (view path file) >>= writeFileUtf8 (view path file) . AutoFix.refact fixRefacts'
return newCorrs'
where
findCorrs :: Path -> [Tools.Note AutoFix.Refact] -> [Tools.Note AutoFix.Refact]
findCorrs f = filter ((== Just f) . preview (Tools.noteSource . moduleFile))
fixCorrs' = findCorrs file ns
upCorrs' = findCorrs file rest
fixRefacts' = fixCorrs' ^.. each . Tools.note
newCorrs' = AutoFix.update fixRefacts' upCorrs'
liftM concat $ mapM runFix files
runCommand (Rename nm newName mloc fpath) = toValue $ do
m <- refineSourceModule fpath
let
mname = m ^. moduleId . moduleName
makeNote loc r = Tools.Note {
Tools._noteSource = loc,
Tools._noteRegion = r,
Tools._noteLevel = Nothing,
Tools._note = AutoFix.Refact "rename" (AutoFix.replace (AutoFix.fromRegion r) newName) }
msum [
do
topRegions <- query @_ @Region "select n.line, n.column, n.line_to, n.column_to from names as n, modules as m where m.id == n.module_id and m.name == ? and n.name == ? and ((n.def_line is not null and n.def_column is not null) or (n.def_line == ? and n.def_column == ?)) and n.symbol_id is not null;" (
mname,
nm,
fmap fst mloc,
fmap snd mloc)
guard (not $ null topRegions)
let
defRenames = map (makeNote (m ^. moduleId . moduleLocation)) topRegions
usageRenames <- do
usageRegions <- query @_ @(Only Path :. Region) "select m.file, n.line, n.column, n.line_to, n.column_to from names as n, modules as m where n.module_id == m.id and m.file is not null and n.resolved_module == ? and n.resolved_name == ?;" (
mname,
nm)
return $ map (\(Only p :. r) -> makeNote (FileModule p Nothing) r) usageRegions
return $ ordNub (defRenames ++ usageRenames),
do
localRegions <- query @_ @Region "select n.line, n.column, n.line_to, n.column_to from names as n, modules as m where m.id == n.module_id and m.name == ? and n.name == ? and n.def_line == ? and n.def_column == ? and n.symbol_id is null;" (
mname,
nm,
fmap fst mloc,
fmap snd mloc)
return $ map (makeNote (m ^. moduleId . moduleLocation)) localRegions]
runCommand (GhcEval exprs mfile) = toValue $ do
mfile' <- traverse getUpdateFileContents mfile
case mfile' of
Nothing -> inSessionGhc ghciSession
Just (FileSource f mcts) -> do
m <- setFileSourceSession [] f
inSessionGhc $ interpretModule m mcts
inSessionGhc $ mapM (tryRepl . evaluate) exprs
runCommand (GhcType exprs mfile) = toValue $ do
mfile' <- traverse getUpdateFileContents mfile
case mfile' of
Nothing -> inSessionGhc ghciSession
Just (FileSource f mcts) -> do
m <- setFileSourceSession [] f
inSessionGhc $ interpretModule m mcts
inSessionGhc $ mapM (tryRepl . expressionType) exprs
runCommand Langs = toValue $ return Compat.languages
runCommand Flags = toValue $ return ["-f" ++ prefix ++ f |
f <- Compat.flags,
prefix <- ["", "no-"]]
runCommand (Link hold) = toValue $ commandLink >> when hold commandHold
runCommand StopGhc = toValue $ do
inSessionGhc $ do
ms <- findSessionBy (const True)
forM_ ms $ \s -> do
Log.sendLog Log.Trace $ "stopping session: {}" ~~ view sessionKey s
deleteSession $ view sessionKey s
runCommand Exit = toValue serverExit
targetFilter :: Text -> Maybe Text -> TargetFilter -> (Text, [NamedParam])
targetFilter mtable _ (TargetProject proj) = (
"{t}.cabal in (select cabal from projects where name == :project or cabal == :project)" ~~ ("t" ~% mtable),
[":project" := proj])
targetFilter mtable _ (TargetFile f) = ("{t}.file == :file" ~~ ("t" ~% mtable), [":file" := f])
targetFilter mtable Nothing (TargetModule nm) = ("{t}.name == :module_name" ~~ ("t" ~% mtable), [":module_name" := nm])
targetFilter mtable (Just stable) (TargetModule nm) = (
"({t}.name == :module_name) or ({s}.id in (select e.symbol_id from exports as e, modules as em where e.module_id == em.id and em.name == :module_name))"
~~ ("t" ~% mtable)
~~ ("s" ~% stable),
[":module_name" := nm])
targetFilter mtable _ (TargetPackage p) = (tpl ~~ ("t" ~% mtable), params) where
pkg = fromMaybe (mkPackage p) (readMaybe (unpack p))
tpl
| T.null (pkg ^. packageVersion) = "{t}.package_name == :package_name"
| otherwise = "{t}.package_name == :package_name and {t}.package_version == :package_version"
params
| T.null (pkg ^. packageVersion) = [pname]
| otherwise = [pname, pver]
pname = ":package_name" := (pkg ^. packageName)
pver = ":package_version" := (pkg ^. packageVersion)
targetFilter mtable _ TargetInstalled = ("{t}.package_name is not null" ~~ ("t" ~% mtable), [])
targetFilter mtable _ TargetSourced = ("{t}.file is not null" ~~ ("t" ~% mtable), [])
targetFilter mtable _ TargetStandalone = ("{t}.file is not null and {t}.cabal is null" ~~ ("t" ~% mtable), [])
targetFilters :: Text -> Maybe Text -> [TargetFilter] -> ([Text], [NamedParam])
targetFilters mtable stable = second concat . unzip . map (targetFilter mtable stable)
likePattern :: SearchQuery -> Text
likePattern (SearchQuery input stype) = case stype of
SearchExact -> escapedInput
SearchPrefix -> escapedInput `T.append` "%"
SearchInfix -> "%" `T.append` escapedInput `T.append` "%"
SearchSuffix -> "%" `T.append` escapedInput
where
escapedInput = escapeLike input
instance ToJSON Log.Message where
toJSON m = object [
"time" .= Log.messageTime m,
"level" .= show (Log.messageLevel m),
"component" .= show (Log.messageComponent m),
"scope" .= show (Log.messageScope m),
"text" .= Log.messageText m]
instance FromJSON Log.Message where
parseJSON = withObject "log-message" $ \v -> Log.Message <$>
(v .:: "time") <*>
((v .:: "level") >>= maybe (fail "invalid level") return . readMaybe) <*>
(read <$> (v .:: "component")) <*>
(read <$> (v .:: "scope")) <*>
(v .:: "text")
runCheck :: CommandMonad m => [String] -> Bool -> FileSource -> m [Tools.Note Tools.OutputMessage]
runCheck ghcs' clear = getUpdateFileContents >=> check' where
check' (FileSource file mcts) = Log.scope "run-check" $ do
Log.sendLog Log.Trace $ "setting file source session for {}" ~~ file
sess <- getSession
m <- setFileSourceSession ghcs' file
Log.sendLog Log.Trace "file source session set"
ns <- inSessionGhc $ do
when clear clearTargets
Update.cacheGhcWarnings sess [m ^. moduleId . moduleLocation] $
Check.check m mcts
if null ns
then do
inSessionUpdater $ return ()
ns' <- Update.cachedWarnings [m ^. moduleId . moduleLocation]
unless (null ns') $
Log.sendLog Log.Trace $ "returning {} cached warnings for {}" ~~ length ns' ~~ file
return ns'
else return ns
findPath :: (CommandMonad m, Paths a) => a -> m a
findPath = paths findPath' where
findPath' :: CommandMonad m => FilePath -> m FilePath
findPath' f = do
r <- commandRoot
liftIO $ canonicalizePath (normalise $ if isRelative f then r </> f else f)
findSandbox :: CommandMonad m => Path -> m Sandbox
findSandbox fpath = do
fpath' <- findPath fpath
sbox <- liftIO $ S.findSandbox fpath'
maybe (hsdevError $ FileNotFound fpath') return sbox
sourceUpToDate :: CommandMonad m => Path -> m Bool
sourceUpToDate fpath = do
fpath' <- findPath fpath
insps <- query @_ @Inspection "select inspection_time, inspection_opts from modules where file = ?;" (Only fpath')
when (length insps > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath'
maybe
(return False)
(upToDate (FileModule fpath' Nothing) [])
(listToMaybe insps)
refineSourceModule :: CommandMonad m => Path -> m Module
refineSourceModule fpath = do
fpath' <- findPath fpath
ids <- query "select id, cabal from modules where file == ?;" (Only fpath')
case ids of
[] -> hsdevError (NotInspected $ FileModule fpath' Nothing)
((i, mcabal):_) -> do
when (length ids > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath'
m <- SQLite.loadModule i
case mcabal of
Nothing -> do
[insp] <- query @_ @Inspection "select inspection_time, inspection_opts from modules where id = ?;" (Only i)
fresh' <- upToDate (m ^. moduleId . moduleLocation) [] insp
if fresh'
then return m
else do
defs <- askSession sessionDefines
mcts <- fmap (fmap snd) $ getFileContents fpath'
ip' <- runInspect (m ^. moduleId . moduleLocation) $ preload (m ^. moduleId . moduleName) defs [] mcts
case ip' ^? inspected of
Just p' -> return $ set moduleImports (p' ^. asModule . moduleImports) m
Nothing -> return m
Just cabal' -> do
proj' <- SQLite.loadProject cabal'
return $ set (moduleId . moduleLocation . moduleProject) (Just proj') m
getUpdateFileContents :: CommandMonad m => FileSource -> m FileSource
getUpdateFileContents (FileSource fpath Nothing) = fmap (FileSource fpath . fmap snd) (getFileContents fpath)
getUpdateFileContents fcts@(FileSource fpath mcts) = do
serverSetFileContents fpath mcts
return fcts
setFileSourceSession :: CommandMonad m => [String] -> Path -> m Module
setFileSourceSession opts fpath = do
m <- refineSourceModule fpath
inSessionGhc $ targetSession opts m
return m
getSandboxes :: CommandMonad m => [Path] -> m [Sandbox]
getSandboxes = traverse (findPath >=> findSandbox)
findProject :: CommandMonad m => Text -> m Project
findProject proj = do
proj' <- liftM addCabal $ findPath proj
ps <- liftM (map fromOnly) $ query "select cabal from projects where (cabal == ?) or (name == ?);" (view path proj', proj)
case ps of
[] -> hsdevError $ ProjectNotFound proj
_ -> SQLite.loadProject (head ps)
where
addCabal p
| takeExtension (view path p) == ".cabal" = p
| otherwise = over path (\p' -> p' </> (takeBaseName p' <.> "cabal")) p
updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM IO ()] -> ClientM m ()
updateProcess uopts acts = hoist liftIO $ do
copts <- getOptions
inSessionUpdater $ hoist (flip runReaderT copts) $ runClientM $ mapM_ (Update.runUpdate uopts . runAct) acts
where
runAct act = catch act onError
onError e = Log.sendLog Log.Error $ "{}" ~~ (e :: HsDevError)