hsdev 0.1.6.2 → 0.1.6.3

raw patch · 11 files changed

+77/−68 lines, 11 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 +16/−33
• src/HsDev/Database/Update.hs +1/−3
• src/HsDev/Server/Base.hs +1/−0
• src/HsDev/Server/Commands.hs +2/−6
• src/HsDev/Server/Types.hs +33/−0
• src/HsDev/Tools/AutoFix.hs +1/−1
• src/System/Directory/Watcher.hs +20/−16
• src/System/Win32/FileMapping/Memory.hs +0/−1
• tools/hshayoo.hs +1/−4
• tools/hsinspect.hs +1/−3

@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/
 
 name:                hsdev
-version:             0.1.6.2
+version:             0.1.6.3
 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,7 +6,7 @@ 
 import Control.Applicative
 import Control.Arrow
-import Control.Lens (view, preview, _Just, from, each)
+import Control.Lens (view, preview, _Just)
 import Control.Monad
 import Control.Monad.Except
 import Control.Monad.State (gets)
@@ -18,7 +18,6 @@ import qualified Data.Map as M
 import Data.String (fromString)
 import Data.Text (unpack)
-import Data.Text.Lens (packed)
 import qualified Data.Text as T (isInfixOf, isPrefixOf, isSuffixOf)
 import System.Directory
 import System.FilePath
@@ -54,20 +53,20 @@ 
 -- | Run command
 runCommand :: CommandOptions -> Command -> IO Result
-runCommand copts Ping = runCommandM $ return $ object ["message" .= ("pong" :: String)]
+runCommand _ Ping = runCommandM $ return $ object ["message" .= ("pong" :: String)]
 runCommand copts Listen = runCommandM $ liftIO $ commandListenLog copts $
 	mapM_ (\msg -> commandNotify copts (Notification $ object ["message" .= msg]))
 runCommand copts (AddData cts) = runCommandM $ mapM_ updateData cts where
 	updateData (AddedDatabase db) = DB.update (dbVar copts) $ return db
 	updateData (AddedModule m) = DB.update (dbVar copts) $ return $ fromModule m
 	updateData (AddedProject p) = DB.update (dbVar copts) $ return $ fromProject p
-runCommand copts (Scan projs cabals fs paths fcts ghcs' docs' infer') = runCommandM $ do
+runCommand copts (Scan projs cabals fs paths' fcts ghcs' docs' infer') = runCommandM $ do
 	sboxes <- getSandboxes copts cabals
 	updateProcess copts 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,
+		map (Update.scanDirectory ghcs') paths',
 		map (Update.scanCabal ghcs') sboxes]
 runCommand copts (RefineDocs projs fs ms) = runCommandM $ do
 	projects <- traverse (findProject copts) projs
@@ -89,7 +88,7 @@ 			map inModule ms]
 		mods = selectModules (filters . view moduleId) dbval
 	updateProcess copts [] False False [Update.inferModTypes $ map (getInspected dbval) mods]
-runCommand copts (Remove projs packages cabals fs) = runCommandM $ return $ object ["message" .= ("not implemented" :: String)]
+runCommand _ (Remove _ _ _ _) = runCommandM $ return $ object ["message" .= ("not implemented" :: String)]
 runCommand copts (InfoModules fs) = runCommandM $ do
 	dbval <- getDb copts
 	filter' <- targetFilters copts fs
@@ -99,8 +98,8 @@ runCommand copts InfoProjects = runCommandM $ (toList . databaseProjects) <$> getDb copts
 runCommand copts InfoSandboxes = runCommandM $
 	(ordNub . sort . mapMaybe (cabalOf . view moduleId) . allModules) <$> getDb copts
-runCommand copts (InfoSymbol sq fs locals) = runCommandM $ do
-	dbval <- liftM (localsDatabase locals) $ getDb copts
+runCommand copts (InfoSymbol sq fs locals') = runCommandM $ do
+	dbval <- liftM (localsDatabase locals') $ getDb copts
 	filter' <- targetFilters copts fs
 	return $ newestPackage $ filterMatch sq $ filter (checkModule filter') $ allDeclarations dbval
 runCommand copts (InfoModule sq fs) = runCommandM $ do
@@ -119,8 +118,8 @@ 		Nothing -> commandError "File not found" []
 		Just m -> return $ getScope $ resolveOne cabaldb m
 runCommand copts (InfoProject (Left projName)) = runCommandM $ findProject copts projName
-runCommand copts (InfoProject (Right projPath)) = runCommandM $ liftIO $ searchProject projPath
-runCommand copts (InfoSandbox sandbox) = runCommandM $ liftIO $ searchSandbox sandbox
+runCommand _ (InfoProject (Right projPath)) = runCommandM $ liftIO $ searchProject projPath
+runCommand _ (InfoSandbox sandbox') = runCommandM $ liftIO $ searchSandbox sandbox'
 runCommand copts (Lookup nm fpath) = runCommandM $ do
 	dbval <- getDb copts
 	cabal <- liftIO $ getSandbox fpath
@@ -141,11 +140,11 @@ 	dbval <- getDb copts
 	cabal <- liftIO $ getSandbox fpath
 	mapCommandErrorStr $ completions dbval cabal fpath input wide
-runCommand copts (Hayoo hq p ps) = runCommandM $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM
+runCommand _ (Hayoo hq p ps) = runCommandM $ liftM concat $ forM [p .. p + pred ps] $ \i -> liftM
 	(mapMaybe Hayoo.hayooAsDeclaration . Hayoo.resultResult) $
 	mapCommandErrorStr $ Hayoo.hayoo hq (Just i)
-runCommand copts (CabalList packages) = runCommandM $ mapCommandErrorStr $ Cabal.cabalList packages
-runCommand copts (Lint fs fcts) = runCommandM $ do
+runCommand _ (CabalList packages) = runCommandM $ mapCommandErrorStr $ Cabal.cabalList packages
+runCommand _ (Lint fs fcts) = runCommandM $ do
 	mapCommandErrorStr $ liftM2 (++)
 		(liftM concat $ mapM HLint.hlintFile fs)
 		(liftM concat $ mapM (\(FileContents f c) -> HLint.hlintSource f c) fcts)
@@ -196,8 +195,8 @@ 		notes <- inWorkerWith (commandError_ . show) (commandGhc copts)
 			(runExceptT $ Types.fileTypes ghcs' cabal m msrc)
 		either commandError_ return notes
-runCommand copts (GhcMod GhcModLang) = runCommandM $ mapCommandErrorStr GhcMod.langs
-runCommand copts (GhcMod GhcModFlags) = runCommandM $ mapCommandErrorStr GhcMod.flags
+runCommand _ (GhcMod GhcModLang) = runCommandM $ mapCommandErrorStr GhcMod.langs
+runCommand _ (GhcMod GhcModFlags) = runCommandM $ mapCommandErrorStr GhcMod.flags
 runCommand copts (GhcMod (GhcModType (Position line column) fpath ghcs')) = runCommandM $ do
 	dbval <- getDb copts
 	cabal <- liftIO $ getSandbox fpath
@@ -226,7 +225,7 @@ 			checked <- GhcMod.check (ghcs' ++ moduleOpts (allPackages dbval) m') cabal [file] mproj
 			linted <- GhcMod.lint hlints' file
 			return $ checked ++ linted
-runCommand copts (AutoFix (AutoFixShow ns)) = runCommandM $ return $ AutoFix.corrections ns
+runCommand _ (AutoFix (AutoFixShow ns)) = runCommandM $ return $ AutoFix.corrections ns
 runCommand copts (AutoFix (AutoFixFix ns rest isPure)) = runCommandM $ do
 	files <- liftM (ordNub . sort) $ mapM (findPath copts) $ mapMaybe (preview $ Tools.noteSource . moduleFile) ns
 	let
@@ -278,7 +277,7 @@ 
 -- | Find sandbox by path
 findSandbox :: MonadIO m => CommandOptions -> Cabal -> ExceptT CommandError m Cabal
-findSandbox copts Cabal = return Cabal
+findSandbox _ Cabal = return Cabal
 findSandbox copts (Sandbox f) = (findPath copts >=> mapCommandErrorStr . liftIO . getSandbox) f
 
 -- | Canonicalize paths
@@ -333,26 +332,10 @@ 		Nothing -> inDepsOfProject proj
 		Just src' -> inDepsOfFile proj src'
 
-cacheLoad :: CommandOptions -> IO (Either String Database) -> CommandM ()
-cacheLoad copts act = liftIO $ do
-	db' <- act
-	case db' of
-		Left e -> commandLog copts Log.Error e
-		Right database -> DB.update (dbVar copts) (return database)
-
 -- | Bring locals to top scope to search within them if 'locals' flag set
 localsDatabase :: Bool -> Database -> Database
 localsDatabase True = databaseLocals
 localsDatabase False = id
-
--- | Select newest packages if 'no-last' flag not set
-newest :: Symbol a => Bool -> [a] -> [a]
-newest True = newestPackage
-newest False = id
-
--- | Convert from just of throw
-forceJust :: MonadIO m => String -> ExceptT CommandError m (Maybe a) -> ExceptT CommandError m a
-forceJust msg act = act >>= maybe (throwError $ commandStrMsg msg) return
 
 -- | Get actual DB state
 getDb :: MonadIO m => CommandOptions -> m Database

@@ -41,20 +41,18 @@ import qualified Data.Text as T (unpack)
 import System.Directory (canonicalizePath, doesFileExist)
 import qualified System.Log.Simple as Log
-import qualified System.Log.Simple.Base as Log (scopeLog)
 
 import Control.Concurrent.Worker (inWorker)
 import qualified HsDev.Cache.Structured as Cache
 import HsDev.Database
 import HsDev.Database.Async hiding (Event)
 import HsDev.Display
-import HsDev.Inspect (inspectDocs, inspectDocsGhc, getDefines)
+import HsDev.Inspect (inspectDocs, inspectDocsGhc)
 import HsDev.Project
 import HsDev.Symbols
 import HsDev.Tools.Ghc.Worker (ghcWorker)
 import HsDev.Tools.Ghc.Types (inferTypes)
 import HsDev.Tools.HDocs
-import qualified HsDev.Tools.GhcMod as GhcMod
 import qualified HsDev.Scan as S
 import HsDev.Scan.Browse
 import HsDev.Util (liftEIO, isParent, ordNub)

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP, OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module HsDev.Server.Base (
 	initLog, runServer, Server, startServer, inServer,

@@ -68,10 +68,6 @@ 		Left e -> return $ Error (show e) $ M.fromList []
 		Right r -> return r
 	where
-		encodeValue :: ToJSON a => a -> L.ByteString
-		encodeValue
-			| clientPretty copts = encodePretty
-			| otherwise = encode
 		sendReceive = do
 			curDir <- getCurrentDirectory
 			input <- if clientStdin copts
@@ -82,7 +78,7 @@ 				parseData cts = case eitherDecode cts of
 					Left err -> putStrLn ("Invalid data: " ++ err) >> exitFailure
 					Right v -> return v
-			dat <- traverse parseData input -- FIXME: Not used!
+			_ <- traverse parseData input -- FIXME: Not used!
 
 			s <- socket AF_INET Stream defaultProtocol
 			addr' <- inet_addr "127.0.0.1"
@@ -359,7 +355,7 @@ 	| otherwise = do
 		rvar <- newEmptyMVar
 		_ <- forkIO $ flip finally (tryPutMVar rvar r) $ void $ withName mmapPool $ \mmapName -> runExceptT $ flip catchError
-			(\e -> liftIO $ void $ tryPutMVar rvar r)
+			(\_ -> liftIO $ void $ tryPutMVar rvar r)
 			(withMapFile mmapName (L.toStrict msg) $ liftIO $ do
 				_ <- tryPutMVar rvar $ result $ MmapFile mmapName
 				-- give 10 seconds for client to read data

@@ -140,6 +140,17 @@ 		(timeoutArg <|> pure (clientTimeout def)) <*>
 		silentFlag
 
+portArg :: Parser Int
+timeoutArg :: Parser Int
+logArg :: Parser FilePath
+logConfigArg :: Parser String
+cacheArg :: Parser FilePath
+noFileFlag :: Parser Bool
+loadFlag :: Parser Bool
+prettyFlag :: Parser Bool
+stdinFlag :: Parser Bool
+silentFlag :: Parser Bool
+
 portArg = option auto (long "port" <> metavar "number" <> help "connection port")
 timeoutArg = option auto (long "timeout" <> metavar "msec" <> help "query timeout")
 logArg = strOption (long "log" <> short 'l' <> metavar "file" <> help "log file")
@@ -416,6 +427,28 @@ 
 readJSON :: FromJSON a => ReadM a
 readJSON = str >>= maybe (readerError "Can't parse JSON argument") return . decode . L.pack
+
+cabalArg :: Parser Cabal
+ctx :: Parser FilePath
+depsArg :: Parser String
+docsFlag :: Parser Bool
+exportsFlag :: Parser Bool
+fileArg :: Parser FilePath
+ghcOpts :: Parser [String]
+globalFlag :: Parser Bool
+hayooPageArg :: Parser Int
+hayooPagesArg :: Parser Int
+hlintOpts :: Parser [String]
+holdFlag :: Parser Bool
+inferFlag :: Parser Bool
+localsFlag :: Parser Bool
+moduleArg :: Parser String
+packageArg :: Parser String
+pathArg :: Mod OptionFields String -> Parser FilePath
+projectArg :: Parser String
+pureFlag :: Parser Bool
+sandboxArg :: Parser String
+wideFlag :: Parser Bool
 
 cabalArg = flag' Cabal (long "cabal") <|> (Sandbox <$> sandboxArg)
 ctx = fileArg

@@ -75,7 +75,7 @@ 
 correctors :: [CorrectorMatch]
 correctors = [
-	match "^The (?:qualified )?import of `([\\w\\.]+)' is redundant" $ \_ rgn -> Correction
+	match "^The (?:qualified )?import of .([\\w\\.]+). is redundant" $ \_ rgn -> Correction -- There are different quotes in Windows/Linux
 		"Redundant import"
 		(cut
 			(expandLines rgn)),

@@ -75,18 +75,12 @@ 	maybe (return ()) snd stop
 	return $ isJust stop
 
--- | Check if dir is watching
+-- | Check if we are watching dir
 isWatchingDir :: Watcher a -> FilePath -> IO Bool
 isWatchingDir w f = do
 	f' <- canonicalizePath f
 	dirs <- readMVar (watcherDirs w)
-	return $ isWatchingDir' dirs f'
-	where
-		isWatchingDir' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool
-		isWatchingDir' m dir
-			| Just (_, _) <- M.lookup dir m = True
-			| isDrive dir = False
-			| otherwise = isWatchingDir' m (takeDirectory dir)
+	return $ isWatchingDir' dirs f' || isWatchingParents' dirs f'
 
 -- | Watch directory tree
 watchTree :: Watcher a -> FilePath -> (Event -> Bool) -> a -> IO ()
@@ -114,18 +108,12 @@ 	maybe (return ()) snd stop
 	return $ isJust stop
 
--- | Check if tree is watching
+-- | Check if we are watching tree
 isWatchingTree :: Watcher a -> FilePath -> IO Bool
 isWatchingTree w f = do
 	f' <- canonicalizePath f
 	dirs <- readMVar (watcherDirs w)
-	return $ isWatchingTree' dirs f'
-	where
-		isWatchingTree' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool
-		isWatchingTree' m dir
-			| Just (True, _) <- M.lookup dir m = True
-			| isDrive dir = False
-			| otherwise = isWatchingTree' m (takeDirectory dir)
+	return $ isWatchingTree' dirs f' || isWatchingParents' dirs f'
 
 -- | Read next event
 readEvent :: Watcher a -> IO (a, Event)
@@ -145,3 +133,19 @@ 		FS.Added _ _ -> Added
 		FS.Modified _ _ -> Modified
 		FS.Removed _ _ -> Removed
+
+isWatchingDir' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool
+isWatchingDir' m dir
+	| Just (_, _) <- M.lookup dir m = True
+	| isDrive dir = False
+	| otherwise = isWatchingDir' m (takeDirectory dir)
+
+isWatchingTree' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool
+isWatchingTree' m dir
+	| Just (True, _) <- M.lookup dir m = True
+	| isDrive dir = False
+	| otherwise = isWatchingTree' m (takeDirectory dir)
+
+isWatchingParents' :: Map FilePath (Bool, IO ()) -> FilePath -> Bool
+isWatchingParents' m dir = or (map (isWatchingTree' m) parents) where
+	parents = takeWhile (not . isDrive) $ iterate takeDirectory dir

@@ -3,7 +3,6 @@ 	withMapFile, readMapFile
 	) where
 
-import Control.Concurrent
 import Control.Monad.Catch
 import Control.Monad.Cont
 import Control.Monad.Except

@@ -8,10 +8,7 @@ 
 import Tool
 
-data HayooOpts = HayooOpts {
-	optsQuery :: String,
-	optsPage :: Int,
-	optsPages :: Int }
+data HayooOpts = HayooOpts String Int Int
 
 hayooOpts :: Parser HayooOpts
 hayooOpts = HayooOpts <$>

@@ -18,9 +18,7 @@ 
 import Tool
 
-data Opts = Opts {
-	optsWhat :: Maybe String,
-	optsGHC :: [String] }
+data Opts = Opts (Maybe String) [String]
 
 opts :: Parser Opts
 opts = Opts <$>