{-# 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
                -- We can safely remove package-db from db iff doesn't used by some of other package-dbs
                -- For example, we can't remove global-db if there are any other package-dbs, because all of them uses global-db
                -- We also can't remove stack snapshot package-db if there are some local package-db not yet removed
                canRemove pdbs = do
                        from' <- State.get
                        return $ null $ filter (pdbs `isSubStack`) $ delete pdbs from'
                -- Remove top of package-db stack if possible
                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
                -- Remove package-db stack when possible
                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")


-- | Run check
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 () -- wait until cache updated
                                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

-- Helper functions

-- | Canonicalize paths
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)

-- | Find sandbox by path
findSandbox :: CommandMonad m => Path -> m Sandbox
findSandbox fpath = do
        fpath' <- findPath fpath
        sbox <- liftIO $ S.findSandbox fpath'
        maybe (hsdevError $ FileNotFound fpath') return sbox

-- | Check if source file up to date
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)

-- | Get source file
-- refineSourceFile :: CommandMonad m => Path -> m Path
-- refineSourceFile fpath = do
-- 	fpath' <- findPath fpath
-- 	fs <- liftM (map fromOnly) $ query "select file from modules where file == ?;" (Only fpath')
-- 	case fs of
-- 		[] -> hsdevError (NotInspected $ FileModule fpath' Nothing)
-- 		(f:_) -> do
-- 			when (length fs > 1) $ Log.sendLog Log.Warning $ "multiple modules with same file = {}" ~~ fpath'
-- 			return f

-- | Get module by source
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

-- | Get update file contents
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

-- | Set session by source
setFileSourceSession :: CommandMonad m => [String] -> Path -> m Module
setFileSourceSession opts fpath = do
        m <- refineSourceModule fpath
        inSessionGhc $ targetSession opts m
        return m

-- | Ensure package exists
-- refinePackage :: CommandMonad m => Text -> m Text
-- refinePackage pkg = do
-- 	[(Only exists)] <- query "select count(*) > 0 from package_dbs where package_name == ?;" (Only pkg)
-- 	when (not exists) $ hsdevError (PackageNotFound pkg)
-- 	return pkg

-- | Get list of enumerated sandboxes
getSandboxes :: CommandMonad m => [Path] -> m [Sandbox]
getSandboxes = traverse (findPath >=> findSandbox)

-- | Find project by name or path
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

-- | Run DB update action
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)