module HsDev.Client.Commands (
runClient, runCommand
) where
import Control.Applicative
import Control.Concurrent.MVar
import Control.Exception (displayException)
import Control.Lens (view, preview, _Just, (^..), each)
import Control.Monad
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.Foldable (toList)
import Data.Maybe
import qualified Data.Map as M
import Data.String (fromString)
import Data.Text (pack, unpack)
import qualified Data.Text as T (isInfixOf, isPrefixOf, isSuffixOf)
import System.Directory
import System.FilePath
import qualified System.Log.Simple as Log
import qualified System.Log.Simple.Base as Log
import Text.Regex.PCRE ((=~))
import qualified System.Directory.Watcher as W
import qualified Data.Async as A
import System.Directory.Paths
import Text.Format
import HsDev.Cache
import HsDev.Commands
import HsDev.Error
import qualified HsDev.Database.Async as DB
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 HsDev.Symbols.Resolve (resolveOne, scopeModule, exportsModule)
import HsDev.Symbols.Util
import qualified HsDev.Tools.AutoFix as AutoFix
import qualified HsDev.Tools.Cabal as Cabal
import HsDev.Tools.Ghc.Session
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.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 (either Error (Result . toJSON)) $ runReaderT (try act) copts
mapServerM :: (m a -> n b) -> ServerM m a -> ServerM n b
mapServerM f = ServerM . mapReaderT f . runServerM
toValue :: (ToJSON a, Monad m) => m a -> m Value
toValue = liftM 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_ (\msg -> commandNotify (Notification $ object ["message" .= msg]))
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 (AddData cts) = toValue $ mapM_ updateData cts where
updateData (AddedDatabase db) = toValue $ serverUpdateDB db
updateData (AddedModule m) = toValue $ serverUpdateDB $ fromModule m
updateData (AddedProject p) = toValue $ serverUpdateDB $ fromProject p
runCommand (Scan projs cabal sboxes fs paths' ghcs' docs' infer') = toValue $ do
sboxes' <- getSandboxes sboxes
updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [
map (\(FileSource f mcts) -> Update.scanFileContents ghcs' f mcts) fs,
map (Update.scanProject ghcs') projs,
map (Update.scanDirectory ghcs') paths',
[Update.scanCabal ghcs' | cabal],
map (Update.scanSandbox ghcs') sboxes']
runCommand (RefineDocs projs fs ms) = toValue $ do
projects <- traverse findProject projs
dbval <- getDb
let
filters = anyOf $ concat [
map inProject projects,
map inFile fs,
map inModule ms]
mods = selectModules (filters . view moduleId) dbval
updateProcess (Update.UpdateOptions [] [] False False) [Update.scanDocs $ map (getInspected dbval) mods]
runCommand (InferTypes projs fs ms) = toValue $ do
projects <- traverse findProject projs
dbval <- getDb
let
filters = anyOf $ concat [
map inProject projects,
map inFile fs,
map inModule ms]
mods = selectModules (filters . view moduleId) dbval
updateProcess (Update.UpdateOptions [] [] False False) [Update.inferModTypes $ map (getInspected dbval) mods]
runCommand (Remove projs cabal sboxes files) = toValue $ do
db <- askSession sessionDatabase
dbval <- getDb
w <- askSession sessionWatcher
projects <- traverse findProject projs
sboxes' <- getSandboxes sboxes
forM_ projects $ \proj -> do
DB.clear db (return $ projectDB proj dbval)
liftIO $ unwatchProject w proj
dbPDbs <- mapM restorePackageDbStack $ databasePackageDbs dbval
flip State.evalStateT dbPDbs $ do
when cabal $ removePackageDbStack userDb
forM_ sboxes' $ \sbox -> do
pdbs <- lift $ sandboxPackageDbStack sbox
removePackageDbStack pdbs
forM_ files $ \file -> do
DB.clear db (return $ filterDB (inFile file) (const False) dbval)
let
mloc = fmap (view moduleLocation) $ lookupFile file dbval
maybe (return ()) (liftIO . unwatchModule w) mloc
where
canRemove pdbs = do
from <- State.get
return $ null $ filter (pdbs `isSubStack`) $ delete pdbs from
removePackageDb pdbs = do
db <- lift $ askSession sessionDatabase
dbval <- lift getDb
w <- lift $ askSession sessionWatcher
can <- canRemove pdbs
when can $ do
State.modify (delete pdbs)
DB.clear db (return $ packageDbDB (topPackageDb pdbs) dbval)
liftIO $ unwatchPackageDb w $ topPackageDb pdbs
removePackageDbStack = mapM_ removePackageDb . packageDbStacks
runCommand RemoveAll = toValue $ do
db <- askSession sessionDatabase
liftIO $ A.modifyAsync db A.Clear
w <- askSession sessionWatcher
wdirs <- liftIO $ readMVar (W.watcherDirs w)
liftIO $ forM_ (M.toList wdirs) $ \(dir, (isTree, _)) -> (if isTree then W.unwatchTree else W.unwatchDir) w dir
runCommand (InfoModules fs) = toValue $ do
dbval <- getDb
filter' <- targetFilters fs
return $ map (view moduleId) $ newestPackage $ selectModules (filter' . view moduleId) dbval
runCommand InfoPackages = toValue $ (ordNub . sort . mapMaybe (preview (moduleLocation . modulePackage . _Just)) . allModules) <$> getDb
runCommand InfoProjects = toValue $ (toList . databaseProjects) <$> getDb
runCommand InfoSandboxes = toValue $ databasePackageDbs <$> getDb
runCommand (InfoSymbol sq fs locals') = toValue $ do
dbval <- liftM (localsDatabase locals') $ getDb
filter' <- targetFilters fs
return $ newestPackage $ filterMatch sq $
concatMap moduleModuleDeclarations $ filter (filter' . view moduleId) $ allModules dbval
runCommand (InfoModule sq fs) = toValue $ do
dbval <- getDb
filter' <- targetFilters fs
return $ newestPackage $ filterMatch sq $ filter (filter' . view moduleId) $ allModules dbval
runCommand (InfoResolve fpath exports) = toValue $ do
dbval <- getSDb fpath
let
getScope
| exports = exportsModule
| otherwise = scopeModule
m <- refineSourceModule fpath
return $ getScope $ resolveOne dbval m
runCommand (InfoProject (Left projName)) = toValue $ findProject projName
runCommand (InfoProject (Right projPath)) = toValue $ liftIO $ searchProject projPath
runCommand (InfoSandbox sandbox') = toValue $ liftIO $ searchSandbox sandbox'
runCommand (Lookup nm fpath) = toValue $ do
dbval <- getSDb fpath
liftIO $ hsdevLift $ lookupSymbol dbval fpath nm
runCommand (Whois nm fpath) = toValue $ do
dbval <- getSDb fpath
liftIO $ hsdevLift $ whois dbval fpath nm
runCommand (ResolveScopeModules sq fpath) = toValue $ do
dbval <- getSDb fpath
liftM (filterMatch sq . map (view moduleId)) $ liftIO $ hsdevLift $ scopeModules dbval fpath
runCommand (ResolveScope sq global fpath) = toValue $ do
dbval <- getSDb fpath
liftM (filterMatch sq) $ liftIO $ hsdevLift $ scope dbval fpath global
runCommand (Complete input wide fpath) = toValue $ do
dbval <- getSDb fpath
liftIO $ hsdevLift $ completions dbval fpath input wide
runCommand (Hayoo hq p ps) = toValue $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM
(mapMaybe Hayoo.hayooAsDeclaration . Hayoo.resultResult) $
liftIO $ hsdevLift $ Hayoo.hayoo hq (Just i)
runCommand (CabalList packages) = toValue $ liftIO $ hsdevLift $ Cabal.cabalList packages
runCommand (Lint fs) = toValue $ do
liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint f c) fs
runCommand (Check fs ghcs') = toValue $ Log.scope "check" $ do
let
checkSome file fn = Log.scope "checkSome" $ do
m <- setFileSourceSession ghcs' file
inSessionGhc $ fn m
liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check ghcs' m c)) fs
runCommand (CheckLint fs ghcs') = toValue $ do
let
checkSome file fn = Log.scope "checkSome" $ do
m <- setFileSourceSession ghcs' file
inSessionGhc $ fn m
checkMsgs <- liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check ghcs' m c)) fs
lintMsgs <- liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint f c) fs
return $ checkMsgs ++ lintMsgs
runCommand (Types fs ghcs') = toValue $ do
liftM concat $ forM fs $ \(FileSource file msrc) -> do
m <- setFileSourceSession ghcs' file
inSessionGhc $ Types.fileTypes ghcs' m msrc
runCommand (AutoFix (AutoFixShow ns)) = toValue $ return $ AutoFix.corrections ns
runCommand (AutoFix (AutoFixFix ns rest isPure)) = toValue $ do
files <- liftM (ordNub . sort) $ mapM findPath $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns
let
doFix :: FilePath -> Maybe String -> ([Tools.Note AutoFix.Correction], Maybe String)
doFix file mcts = AutoFix.autoFix fCorrs (fUpCorrs, mcts) where
findCorrs :: FilePath -> [Tools.Note AutoFix.Correction] -> [Tools.Note AutoFix.Correction]
findCorrs f = filter ((== Just f) . preview (Tools.noteSource . moduleFile))
fCorrs = findCorrs file ns
fUpCorrs = findCorrs file rest
runFix file
| isPure = return $ fst $ doFix file Nothing
| otherwise = do
(corrs', Just cts') <- liftM (doFix file) $ liftIO $ Just <$> readFileUtf8 file
liftIO $ writeFileUtf8 file cts'
return corrs'
liftM concat $ mapM runFix files
runCommand (GhcEval exprs mfile) = toValue $ do
ghcw <- askSession sessionGhc
case mfile of
Nothing -> inSessionGhc ghciSession
Just (FileSource f mcts) -> do
m <- setFileSourceSession [] f
inSessionGhc $ interpretModule m mcts
async' <- liftIO $ pushTask ghcw $ do
mapM (try . evaluate) exprs
res <- waitAsync async'
return $ map toValue' res
where
waitAsync :: CommandMonad m => Async a -> m a
waitAsync a = liftIO (waitCatch a) >>= either (hsdevError . GhcError . displayException) return
toValue' :: ToJSON a => Either SomeException a -> Value
toValue' (Left (SomeException e)) = object ["fail" .= show e]
toValue' (Right s) = toJSON s
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 Exit = toValue serverExit
targetFilters :: CommandMonad m => [TargetFilter] -> m (ModuleId -> Bool)
targetFilters fs = do
fs_ <- mapM targetFilter fs
return $ foldr (liftM2 (&&)) (const True) fs_
targetFilter :: CommandMonad m => TargetFilter -> m (ModuleId -> Bool)
targetFilter f = case f of
TargetProject proj -> liftM inProject $ findProject proj
TargetFile file -> liftM inFile $ refineSourceFile file
TargetModule mname -> return $ inModule mname
TargetDepsOf dep -> liftM inDeps $ findDep dep
TargetPackageDb pdb -> return $ inPackageDb pdb
TargetCabal -> return $ inPackageDbStack userDb
TargetSandbox sbox -> liftM inPackageDbStack $ findSandbox sbox >>= sandboxPackageDbStack
TargetPackage pkg -> liftM inPackage $ refinePackage pkg
TargetSourced -> return byFile
TargetStandalone -> return standalone
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 => FilePath -> m Sandbox
findSandbox fpath = do
fpath' <- findPath fpath
sbox <- liftIO $ S.findSandbox fpath'
maybe (hsdevError $ FileNotFound fpath') return sbox
refineSourceFile :: CommandMonad m => FilePath -> m FilePath
refineSourceFile fpath = do
fpath' <- findPath fpath
db' <- getDb
maybe (hsdevError (NotInspected $ FileModule fpath' Nothing)) return $ do
m' <- lookupFile fpath' db'
preview (moduleLocation . moduleFile) m'
refineSourceModule :: CommandMonad m => FilePath -> m Module
refineSourceModule fpath = do
fpath' <- findPath fpath
db' <- getDb
maybe (hsdevError (NotInspected $ FileModule fpath' Nothing)) return $ lookupFile fpath' db'
setFileSourceSession :: CommandMonad m => [String] -> FilePath -> m Module
setFileSourceSession opts fpath = do
m <- refineSourceModule fpath
inSessionGhc $ targetSession opts m
return m
refinePackage :: CommandMonad m => String -> m String
refinePackage pkg = do
db' <- getDb
if pkg `elem` (allPackages db' ^.. each . packageName)
then return pkg
else hsdevError (PackageNotFound pkg)
getSandboxes :: CommandMonad m => [FilePath] -> m [Sandbox]
getSandboxes = traverse (findPath >=> findSandbox)
findProject :: CommandMonad m => String -> m Project
findProject proj = do
db' <- getDb
proj' <- liftM addCabal $ findPath proj
let
resultProj =
refineProject db' (project proj') <|>
find ((== proj) . view projectName) (databaseProjects db')
maybe (hsdevError $ ProjectNotFound proj) return resultProj
where
addCabal p
| takeExtension p == ".cabal" = p
| otherwise = p </> (takeBaseName p <.> "cabal")
findDep :: CommandMonad m => String -> m (Project, Maybe FilePath, PackageDbStack)
findDep depName = do
depPath <- findPath depName
proj <- msum [
do
p <- liftIO (locateProject depPath)
p' <- maybe (hsdevError $ ProjectNotFound depName) return p
liftIO $ loadProject p',
findProject depName]
let
src
| takeExtension depPath == ".hs" = Just depPath
| otherwise = Nothing
pdbs <- searchPackageDbStack $ view projectPath proj
return (proj, src, pdbs)
inDeps :: (Project, Maybe FilePath, PackageDbStack) -> ModuleId -> Bool
inDeps (proj, src, pdbs) = liftM2 (&&) (restrictPackageDbStack pdbs) deps' where
deps' = case src of
Nothing -> inDepsOfProject proj
Just src' -> inDepsOfFile proj src'
localsDatabase :: Bool -> Database -> Database
localsDatabase True = databaseLocals
localsDatabase False = id
getDb :: SessionMonad m => m Database
getDb = askSession sessionDatabase >>= liftIO . DB.readAsync
getSDb :: SessionMonad m => FilePath -> m Database
getSDb fpath = do
dbval <- getDb
pdbs <- searchPackageDbStack fpath
return $ filterDB (restrictPackageDbStack pdbs) (const True) dbval
updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM m ()] -> ClientM m ()
updateProcess uopts acts = Update.runUpdate uopts $ mapM_ runAct acts where
runAct act = catch act onError
onError e = Log.sendLog Log.Error $ "{}" ~~ (e :: HsDevError)
filterMatch :: Symbol a => SearchQuery -> [a] -> [a]
filterMatch (SearchQuery q st) = filter match' where
match' m = case st of
SearchExact -> fromString q == symbolName m
SearchPrefix -> fromString q `T.isPrefixOf` symbolName m
SearchInfix -> fromString q `T.isInfixOf` symbolName m
SearchSuffix -> fromString q `T.isSuffixOf` symbolName m
SearchRegex -> unpack (symbolName m) =~ q