hsdev 0.1.6.5 → 0.1.6.6

raw patch · 5 files changed

+65/−15 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• hsdev.cabal +1/−1
• src/HsDev/Client/Commands.hs +26/−1
• src/HsDev/Inspect.hs +11/−8
• src/HsDev/Server/Types.hs +7/−5
• src/HsDev/Watcher.hs +20/−0

@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/
 
 name:                hsdev
-version:             0.1.6.5
+version:             0.1.6.6
 synopsis:            Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references etc.
 description:
   Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.

@@ -6,6 +6,7 @@ 
 import Control.Applicative
 import Control.Arrow
+import Control.Concurrent.MVar
 import Control.Exception (displayException)
 import Control.Lens (view, preview, _Just)
 import Control.Monad
@@ -27,6 +28,8 @@ 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
@@ -47,6 +50,7 @@ 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
 
@@ -99,7 +103,28 @@ 			map inModule ms]
 		mods = selectModules (filters . view moduleId) dbval
 	updateProcess (Update.UpdateOptions [] [] False False) [Update.inferModTypes $ map (getInspected dbval) mods]
-runCommand (Remove _ _ _ _) = toValue $ return $ object ["message" .= ("not implemented" :: String)]
+runCommand (Remove projs cabals files) = toValue $ do
+	db <- askSession sessionDatabase
+	dbval <- getDb
+	w <- askSession sessionWatcher
+	projects <- traverse findProject projs
+	forM_ projects $ \proj -> do
+		DB.clear db (return $ projectDB proj dbval)
+		liftIO $ unwatchProject w proj
+	forM_ cabals $ \cabal -> do
+		DB.clear db (return $ cabalDB cabal dbval)
+		liftIO $ unwatchSandbox w cabal
+	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
+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

@@ -164,10 +164,14 @@ 		mergeInfos (Function ln ld lr) (Function rn rd rr) = Function (ln `mplus` rn) (ld ++ rd) (lr `mplus` rr) 		mergeInfos l _ = l --- | Get definitions-getBinds :: Maybe H.Binds -> [Declaration]-getBinds (Just (H.BDecls decls)) = getDecls decls-getBinds _ = []+-- | Get local binds+getLocalDecls :: H.Decl -> [Declaration]+getLocalDecls decl' = concatMap getDecls' binds' where+	binds' :: [H.Binds]+	binds' = universeBi decl'+	getDecls' :: H.Binds -> [Declaration]+	getDecls' (H.BDecls decls) = getDecls decls+	getDecls' _ = []  -- | Get declaration and child declarations getDecl :: H.Decl -> [Declaration]@@ -222,10 +226,9 @@ -- | Get definitions getDef :: H.Decl -> [Declaration] getDef (H.FunBind []) = []-getDef (H.FunBind matches@(H.Match loc n _ _ _ _ : _)) = [setPosition loc $ decl (identOfName n) fun] where-	fun = Function Nothing (concatMap (getBinds . matchBinds) matches) Nothing-	matchBinds (H.Match _ _ _ _ _ binds) = binds-getDef (H.PatBind loc pat _ binds) = map (\name -> setPosition loc (decl (identOfName name) (Function Nothing (getBinds binds) Nothing))) (names pat) where+getDef d@(H.FunBind (H.Match loc n _ _ _ _ : _)) = [setPosition loc $ decl (identOfName n) fun] where+	fun = Function Nothing (getLocalDecls d) Nothing+getDef d@(H.PatBind loc pat _ _) = map (\name -> setPosition loc (decl (identOfName name) (Function Nothing (getLocalDecls d) Nothing))) (names pat) where 	names :: H.Pat -> [H.Name] 	names (H.PVar n) = [n] 	names (H.PNPlusK n _) = [n]

@@ -344,9 +344,9 @@ 		inferModules :: [String] } |
 	Remove {
 		removeProjects :: [FilePath],
-		removePackages :: [String],
 		removeSandboxes :: [Cabal],
 		removeFiles :: [FilePath] } |
+	RemoveAll |
 	InfoModules [TargetFilter] |
 	InfoPackages |
 	InfoProjects |
@@ -436,7 +436,8 @@ 		pure infer
 	paths f (RefineDocs projs fs ms) = RefineDocs <$> each f projs <*> each f fs <*> pure ms
 	paths f (InferTypes projs fs ms) = InferTypes <$> each f projs <*> each f fs <*> pure ms
-	paths f (Remove projs ps cs fs) = Remove <$> each f projs <*> pure ps <*> (each . paths) f cs <*> each f fs
+	paths f (Remove projs cs fs) = Remove <$> each f projs <*> (each . paths) f cs <*> each f fs
+	paths _ RemoveAll = pure RemoveAll
 	paths f (InfoModules t) = InfoModules <$> paths f t
 	paths f (InfoSymbol q t l) = InfoSymbol <$> pure q <*> paths f t <*> pure l
 	paths f (InfoModule q t) = InfoModule <$> pure q <*> paths f t
@@ -491,9 +492,9 @@ 		cmd "infer" "infer types" $ InferTypes <$> many projectArg <*> many fileArg <*> many moduleArg,
 		cmd "remove" "remove modules info" $ Remove <$>
 			many projectArg <*>
-			many packageArg <*>
 			many cabalArg <*>
 			many fileArg,
+		cmd "remove-all" "remove all data" (pure RemoveAll),
 		cmd "modules" "list modules" (InfoModules <$> many cmdP),
 		cmd "packages" "list packages" (pure InfoPackages),
 		cmd "projects" "list projects" (pure InfoProjects),
@@ -614,7 +615,8 @@ 		"infer" .= infer']
 	toJSON (RefineDocs projs fs ms) = cmdJson "docs" ["projects" .= projs, "files" .= fs, "modules" .= ms]
 	toJSON (InferTypes projs fs ms) = cmdJson "infer" ["projects" .= projs, "files" .= fs, "modules" .= ms]
-	toJSON (Remove projs packages cabals fs) = cmdJson "remove" ["projects" .= projs, "packages" .= packages, "sandboxes" .= cabals, "files" .= fs]
+	toJSON (Remove projs cabals fs) = cmdJson "remove" ["projects" .= projs, "sandboxes" .= cabals, "files" .= fs]
+	toJSON RemoveAll = cmdJson "remove-all" []
 	toJSON (InfoModules tf) = cmdJson "modules" ["filters" .= tf]
 	toJSON InfoPackages = cmdJson "packages" []
 	toJSON InfoProjects = cmdJson "projects" []
@@ -659,9 +661,9 @@ 		guardCmd "infer" v *> (InferTypes <$> v .::?! "projects" <*> v .::?! "files" <*> v .::?! "modules"),
 		guardCmd "remove" v *> (Remove <$>
 			v .::?! "projects" <*>
-			v .::?! "packages" <*>
 			v .::?! "sandboxes" <*>
 			v .::?! "files"),
+		guardCmd "remove-all" v *> pure RemoveAll,
 		guardCmd "modules" v *> (InfoModules <$> v .::?! "filters"),
 		guardCmd "packages" v *> pure InfoPackages,
 		guardCmd "projects" v *> pure InfoProjects,

@@ -1,5 +1,6 @@ module HsDev.Watcher (
 	watchProject, watchModule, watchSandbox,
+	unwatchProject, unwatchModule, unwatchSandbox,
 	isSource, isCabal, isConf,
 
 	module System.Directory.Watcher,
@@ -7,6 +8,7 @@ 	) where
 
 import Control.Lens (view)
+import Control.Monad (void)
 import System.FilePath (takeDirectory, takeExtension, (</>))
 
 import System.Directory.Watcher hiding (Watcher)
@@ -34,6 +36,24 @@ watchSandbox :: Watcher -> Cabal -> [String] -> IO ()
 watchSandbox _ Cabal _ = return ()
 watchSandbox w (Sandbox f) opts = watchTree w f isConf (WatchedSandbox (Sandbox f) opts)
+
+unwatchProject :: Watcher -> Project -> IO ()
+unwatchProject w proj = do
+	mapM_ (unwatchTree w) dirs
+	void $ unwatchDir w projDir
+	where
+		dirs = map ((projDir </>) . view entity) $ maybe [] sourceDirs $ view projectDescription proj
+		projDir = view projectPath proj
+
+unwatchModule :: Watcher -> ModuleLocation -> IO ()
+unwatchModule w (FileModule f Nothing) = void $ unwatchDir w (takeDirectory f)
+unwatchModule _ (FileModule _ (Just _)) = return ()
+unwatchModule _ (CabalModule _ _ _) = return ()
+unwatchModule _ _ = return ()
+
+unwatchSandbox :: Watcher -> Cabal -> IO ()
+unwatchSandbox _ Cabal = return ()
+unwatchSandbox w (Sandbox f) = void $ unwatchTree w f
 
 isSource :: Event -> Bool
 isSource (Event _ f _) = takeExtension f == ".hs"