module HsDev.Client.Commands (
runClient, runCommand
) where
import Control.Applicative
import Control.Arrow
import Control.Concurrent.MVar
import Control.Exception (displayException)
import Control.Lens (view, preview, _Just)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import qualified Control.Monad.State as State
import Control.Monad.Catch (try, 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 (unpack)
import qualified Data.Text as T (isInfixOf, isPrefixOf, isSuffixOf)
import Data.Text.Lens (packed)
import System.Directory
import System.FilePath
import qualified System.Log.Simple 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 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.Stack
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.Worker
import qualified HsDev.Tools.Ghc.Check as Check
import qualified HsDev.Tools.Ghc.Types as Types
import qualified HsDev.Tools.GhcMod as GhcMod
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.Scan as Scan
import qualified HsDev.Scan.Browse as Scan
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) => ExceptT CommandError (ReaderT CommandOptions m) a -> m Result
toResult act = liftM asResult $ runReaderT (runExceptT act) copts
asResult :: ToJSON a => Either CommandError a -> Result
asResult (Left (CommandError e ds)) = Error e $ M.fromList $ map (first unpack) ds
asResult (Right r') = Result $ toJSON r'
mapServerM :: (Monad m, Monad n) => (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 = toValue $ do
serverListen >>= mapM_ (\msg -> commandNotify (Notification $ object ["message" .= msg]))
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' fcts ghcs' docs' infer') = toValue $ do
sboxes' <- getSandboxes sboxes
updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [
map (\(FileContents f cts) -> Update.scanFileContents ghcs' f (Just cts)) fcts,
map (Update.scanProject ghcs') projs,
map (Update.scanFile ghcs') fs,
map (Update.scanDirectory ghcs') paths',
if cabal then [Update.scanCabal ghcs'] else [],
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 <- liftIO $ mapM restorePackageDbStack $ databasePackageDbs dbval
flip State.evalStateT dbPDbs $ do
when cabal $ removePackageDbStack userDb
forM_ sboxes' $ \sbox -> do
pdbs <- lift $ mapCommandIO $ 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 $ filter (checkModule filter') $ allDeclarations 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
case lookupFile fpath dbval of
Nothing -> commandError "File not found" []
Just m -> 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
mapCommandIO $ lookupSymbol dbval fpath nm
runCommand (Whois nm fpath) = toValue $ do
dbval <- getSDb fpath
mapCommandIO $ whois dbval fpath nm
runCommand (ResolveScopeModules sq fpath) = toValue $ do
dbval <- getSDb fpath
liftM (filterMatch sq . map (view moduleId)) $ mapCommandIO $ scopeModules dbval fpath
runCommand (ResolveScope sq global fpath) = toValue $ do
dbval <- getSDb fpath
liftM (filterMatch sq) $ mapCommandIO $ scope dbval fpath global
runCommand (Complete input wide fpath) = toValue $ do
dbval <- getSDb fpath
mapCommandIO $ 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) $
mapCommandIO $ Hayoo.hayoo hq (Just i)
runCommand (CabalList packages) = toValue $ mapCommandIO $ Cabal.cabalList packages
runCommand (Lint fs fcts) = toValue $ do
mapCommandIO $ liftM2 (++)
(liftM concat $ mapM HLint.hlintFile fs)
(liftM concat $ mapM (\(FileContents f c) -> HLint.hlintSource f c) fcts)
runCommand (Check fs fcts ghcs') = toValue $ Log.scope "check" $ do
dbval <- getDb
ghc <- askSession sessionGhc
liftIO $ restartWorker ghc
let
checkSome file fn = Log.scope "checkSome" $ do
pdbs <- liftIO $ searchPackageDbStack file
m <- maybe
(commandError_ $ "File '{}' not found" ~~ file)
return
(lookupFile file dbval)
notes <- inWorkerWith (commandError_ . show) ghc
(runExceptT $ fn pdbs m)
either commandError_ return notes
liftM concat $ mapM (uncurry checkSome) $
[(f, Check.checkFile ghcs') | f <- fs] ++
[(f, \pdbs m -> Check.checkSource ghcs' pdbs m src) | FileContents f src <- fcts]
runCommand (CheckLint fs fcts ghcs') = toValue $ do
dbval <- getDb
ghc <- askSession sessionGhc
liftIO $ restartWorker ghc
let
checkSome file fn = do
pdbs <- liftIO $ searchPackageDbStack file
m <- maybe
(commandError_ $ "File '" ++ file ++ "' not found")
return
(lookupFile file dbval)
notes <- inWorkerWith (commandError_ . show) ghc
(runExceptT $ fn pdbs m)
either commandError_ return notes
checkMsgs <- liftM concat $ mapM (uncurry checkSome) $
[(f, Check.checkFile ghcs') | f <- fs] ++
[(f, \pdbs m -> Check.checkSource ghcs' pdbs m src) | FileContents f src <- fcts]
lintMsgs <- mapCommandIO $ liftM2 (++)
(liftM concat $ mapM HLint.hlintFile fs)
(liftM concat $ mapM (\(FileContents f src) -> HLint.hlintSource f src) fcts)
return $ checkMsgs ++ lintMsgs
runCommand (Types fs fcts ghcs') = toValue $ do
dbval <- getDb
ghc <- askSession sessionGhc
let
cts = [(f, Nothing) | f <- fs] ++ [(f, Just src) | FileContents f src <- fcts]
liftM concat $ forM cts $ \(file, msrc) -> do
pdbs <- liftIO $ searchPackageDbStack file
m <- maybe
(commandError_ $ "File '" ++ file ++ "' not found")
return
(lookupFile file dbval)
notes <- inWorkerWith (commandError_ . show) ghc
(runExceptT $ Types.fileTypes ghcs' pdbs m msrc)
either commandError_ return notes
runCommand (GhcMod GhcModLang) = toValue $ mapCommandIO $ GhcMod.langs
runCommand (GhcMod GhcModFlags) = toValue $ mapCommandIO $ GhcMod.flags
runCommand (GhcMod (GhcModType (Position line column) fpath ghcs')) = toValue $ do
ghcmod <- askSession sessionGhcMod
dbval <- getDb
pdbs <- liftIO $ searchPackageDbStack fpath
pkgs <- mapCommandIO $ Scan.browsePackages ghcs' pdbs
(fpath', m', _) <- mapCommandIO $ fileCtx dbval fpath
mapCommandIO $ GhcMod.waitMultiGhcMod ghcmod fpath' $
GhcMod.typeOf (ghcs' ++ moduleOpts pkgs m') pdbs fpath' line column
runCommand (GhcMod (GhcModLint fs hlints')) = toValue $ do
ghcmod <- askSession sessionGhcMod
mapCommandIO $ liftM concat $ forM fs $ \file ->
GhcMod.waitMultiGhcMod ghcmod file $
GhcMod.lint hlints' file
runCommand (GhcMod (GhcModCheck fs ghcs')) = toValue $ do
ghcmod <- askSession sessionGhcMod
dbval <- getDb
mapCommandIO $ liftM concat $ forM fs $ \file -> do
mproj <- liftIO $ locateProject file
pdbs <- liftIO $ searchPackageDbStack file
pkgs <- Scan.browsePackages ghcs' pdbs
(_, m', _) <- fileCtx dbval file
GhcMod.waitMultiGhcMod ghcmod file $
GhcMod.check (ghcs' ++ moduleOpts pkgs m') pdbs [file] mproj
runCommand (GhcMod (GhcModCheckLint fs ghcs' hlints')) = toValue $ do
ghcmod <- askSession sessionGhcMod
dbval <- getDb
mapCommandIO $ liftM concat $ forM fs $ \file -> do
mproj <- liftIO $ locateProject file
pdbs <- liftIO $ searchPackageDbStack file
pkgs <- Scan.browsePackages ghcs' pdbs
(_, m', _) <- fileCtx dbval file
GhcMod.waitMultiGhcMod ghcmod file $ do
checked <- GhcMod.check (ghcs' ++ moduleOpts pkgs m') pdbs [file] mproj
linted <- GhcMod.lint hlints' file
return $ checked ++ linted
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 -> String -> ([Tools.Note AutoFix.Correction], String)
doFix file cts = AutoFix.edit cts fUpCorrs $ do
AutoFix.autoFix fCorrs
State.gets (view AutoFix.regions)
where
findCorrs :: FilePath -> [Tools.Note AutoFix.Correction] -> [Tools.Note AutoFix.Correction]
findCorrs f = filter ((== Just f) . preview (Tools.noteSource . moduleFile))
fCorrs = map (view Tools.note) $ findCorrs file ns
fUpCorrs = findCorrs file rest
runFix file
| isPure = return $ fst $ doFix file ""
| otherwise = do
(corrs', cts') <- liftM (doFix file) $ liftE $ readFileUtf8 file
liftE $ writeFileUtf8 file cts'
return corrs'
mapCommandIO $ liftM concat $ mapM runFix files
runCommand (GhcEval exprs) = toValue $ do
ghci <- askSession sessionGhci
async' <- liftIO $ pushTask ghci $ 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 (commandError_ . displayException) return
toValue' :: ToJSON a => Either SomeException a -> Value
toValue' (Left (SomeException e)) = object ["fail" .= show e]
toValue' (Right s) = toJSON s
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 -> return $ inFile 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 >>= mapCommandIO . sandboxPackageDbStack
TargetPackage pack -> return $ inPackage pack
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, Functor m) => FilePath -> m Sandbox
findSandbox fpath = do
fpath' <- findPath fpath
sbox <- liftIO $ S.findSandbox fpath'
maybe
(commandError ("Sandbox {} not found" ~~ fpath') ["sandbox" .= fpath'])
return
sbox
getSandboxes :: (CommandMonad m, Functor 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 (commandError_ $ "Project {} not found" ~~ 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 (commandError_ $ "Project {} not found" ~~ depName) return p
r <- liftIO $ runExceptT $ loadProject p'
either commandError_ return r,
findProject depName]
let
src
| takeExtension depPath == ".hs" = Just depPath
| otherwise = Nothing
pdbs <- liftIO $ 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 <- liftIO $ searchPackageDbStack fpath
return $ filterDB (restrictPackageDbStack pdbs) (const True) dbval
mapCommandErrorStr :: CommandMonad m => ExceptT String m a -> m a
mapCommandErrorStr act = runExceptT act >>= either commandError_ return
mapCommandIO :: CommandMonad m => ExceptT String IO a -> m a
mapCommandIO act = liftIO (runExceptT act) >>= either commandError_ return
updateProcess :: ServerMonadBase m => Update.UpdateOptions -> [Update.UpdateM m ()] -> ClientM m ()
updateProcess uopts acts = Update.runUpdate uopts $ sequence_ [act `catchError` (Log.log Log.Error . view (commandErrorMsg . packed)) | act <- acts]
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