hsdev 0.3.3.2 → 0.3.3.3

raw patch · 11 files changed

+90/−49 lines, 11 filesdep ~Cabaldep ~hdocsdep ~lensPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: Cabal, hdocs, lens

API changes (from Hackage documentation)

Files

• hsdev.cabal +5/−5
• src/HsDev/Client/Commands.hs +13/−10
• src/HsDev/Database/Update.hs +15/−14
• src/HsDev/Inspect.hs +9/−3
• src/HsDev/PackageDb.hs +15/−8
• src/HsDev/Project.hs +11/−2
• src/HsDev/Project/Compat.hs +6/−1
• src/HsDev/Stack.hs +2/−1
• src/HsDev/Tools/Ghc/Base.hs +1/−1
• src/HsDev/Tools/Ghc/System.hs +3/−2
• src/HsDev/Util.hs +10/−2

@@ -1,5 +1,5 @@ name:                hsdev
-version:             0.3.3.2
+version:             0.3.3.3
 synopsis:            Haskell development library
 description:
   Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.
@@ -134,7 +134,7 @@   if impl(ghc >= 8.6) && impl(ghc < 8.7)
     build-depends:
       ghc   == 8.6.*,
-      Cabal == 2.4.*
+      Cabal >= 2.4 && < 3.1
 
   if impl(ghc >= 8.4) && impl(ghc < 8.5)
     build-depends:
@@ -153,7 +153,7 @@ 
   if flag(docs)
     build-depends:
-      hdocs >= 0.5.2,
+      hdocs >= 0.5.3,
       haddock-api >= 2.17.4,
       haddock-library >= 1.4.3 && < 1.8
 
@@ -187,7 +187,7 @@     hformat                           >= 0.1.0.1 && < 0.4,
     hlint                             >= 2.0.11 && < 2.2,
     http-client                    >= 0.5 && < 0.7,
-    lens                              >= 4.14 && < 4.18,
+    lens                              >= 4.14 && < 4.19,
     lifted-base                       >= 0.2.3.10 && < 0.3,
     mmorph                            >= 1.0.9 && < 1.2,
     monad-control                     >= 1.0.1.0 && < 1.1,
@@ -256,6 +256,6 @@     filepath                          >= 1.4.1.0 && < 1.5,
     hformat                           >= 0.1.0.1 && < 0.4,
     hspec                             >= 2.2.4,
-    lens                              >= 4.14 && < 4.18,
+    lens                              >= 4.14 && < 4.19,
     mtl                               >= 2.2.1 && < 2.3,
     text                              >= 1.2.2.2 && < 1.3

@@ -403,19 +403,19 @@ 		"line" .= line,
 		"column" .= column]) rs
 runCommand (Lint fs lints) = toValue $ liftM concat $ forM fs $ \fsrc -> do
-	FileSource f c <- actualFileContents fsrc
+	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 actualFileContents fs
+	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' <- actualFileContents fsrc
+		FileSource _ msrc' <- getUpdateFileContents fsrc
 		maybe (updateTypes file msrc') return mcached'
 	where
 		getCached :: ServerMonadBase m => Path -> Maybe Text -> ClientM m (Maybe [Tools.Note Types.TypedExpr])
@@ -501,7 +501,7 @@ 				fmap snd mloc)
 			return $ map (makeNote (m ^. moduleId . moduleLocation)) localRegions]
 runCommand (GhcEval exprs mfile) = toValue $ do
-	mfile' <- traverse actualFileContents mfile
+	mfile' <- traverse getUpdateFileContents mfile
 	case mfile' of
 		Nothing -> inSessionGhc ghciSession
 		Just (FileSource f mcts) -> do
@@ -509,7 +509,7 @@ 			inSessionGhc $ interpretModule m mcts
 	inSessionGhc $ mapM (tryRepl . evaluate) exprs
 runCommand (GhcType exprs mfile) = toValue $ do
-	mfile' <- traverse actualFileContents mfile
+	mfile' <- traverse getUpdateFileContents mfile
 	case mfile' of
 		Nothing -> inSessionGhc ghciSession
 		Just (FileSource f mcts) -> do
@@ -586,7 +586,7 @@ 
 -- | Run check
 runCheck :: CommandMonad m => [String] -> Bool -> FileSource -> m [Tools.Note Tools.OutputMessage]
-runCheck ghcs' clear = actualFileContents >=> check' where
+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
@@ -598,6 +598,7 @@ 				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
@@ -670,10 +671,12 @@ 					proj' <- SQLite.loadProject cabal'
 					return $ set (moduleId . moduleLocation . moduleProject) (Just proj') m
 
--- | Get file contents
-actualFileContents :: CommandMonad m => FileSource -> m FileSource
-actualFileContents (FileSource fpath Nothing) = fmap (FileSource fpath . fmap snd) (getFileContents fpath)
-actualFileContents fcts = return fcts
+-- | 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

@@ -637,20 +637,26 @@ 			where
 				initTemp :: SessionMonad m => m ()
 				initTemp = do
-					SQLite.execute_ "create temporary table updating_ids (id integer not null unique);"
+					SQLite.execute_ "create temporary table updating_files (file text not null, mtime real not null);"
+					SQLite.execute_ "create index updating_files_index on updating_files (file);"
+					SQLite.execute_ "create temporary table updating_ids (id integer not null unique, mtime real);"
 					SQLite.execute_ "create temporary table updating_messages as select * from messages where 0;"
 					SQLite.execute_ "create index update_messages_module_id_index on updating_messages (module_id);"
 
 				dropTemp :: SessionMonad m => m ()
 				dropTemp = do
+					SQLite.execute_ "drop table if exists updating_files;"
 					SQLite.execute_ "drop table if exists updating_ids;"
 					SQLite.execute_ "drop table if exists updating_messages;"
 
 				fillTemp :: SessionMonad m => m ()
 				fillTemp = do
-					SQLite.executeMany "insert into updating_ids select distinct m.id from modules as m where (m.file = ?);" $ (map SQLite.Only $ mlocs' ^.. each . moduleFile)
+					mtimes <- forM (mlocs' ^.. each . moduleFile) $ \file' -> (,) <$> pure file' <*> liftIO (fileMTime file')
+					SQLite.executeMany "insert into updating_files values (?, ?);" mtimes
+					SQLite.execute_ "update updating_files set mtime = coalesce(max(mtime, (select c.mtime from file_contents as c where c.file == updating_files.file)), mtime);"
+					SQLite.execute_ "insert into updating_ids select distinct m.id, coalesce(max(u.mtime, m.inspection_time), u.mtime) from modules as m, updating_files as u where m.file = u.file;"
 					SQLite.executeMany "insert into updating_messages select (select m.id from modules as m where (m.file = ?)), ?, ?, ?, ?, ?, ?, ?;" msgs'
-					SQLite.execute_ "insert into updating_ids select distinct umsgs.module_id from updating_messages as umsgs where umsgs.module_id not in (select id from updating_ids);"
+					SQLite.execute_ "insert into updating_ids select distinct umsgs.module_id, m.inspection_time from updating_messages as umsgs, modules as m where umsgs.module_id = m.id and umsgs.module_id not in (select id from updating_ids);"
 
 				removeOutdated :: SessionMonad m => m ()
 				removeOutdated = SQLite.execute_ $ fromString $ unlines [
@@ -658,18 +664,13 @@ 					"where",
 					" module_id in (",
 					"  select um.id",
-					"  from",
-					"   updating_ids as um, modules as m",
-					"  left outer join",
-					"   load_times as lt",
-					"  on",
-					"   lt.module_id = um.id",
+					"  from updating_ids as um",
+					"  left outer join load_times as lt",
+					"  on lt.module_id = um.id",
 					"  where",
-					"   um.id = m.id and (",
-					"    lt.load_time is null or",
-					"    lt.load_time <= m.inspection_time or",
-					"    um.id in (select distinct umsgs.module_id from updating_messages as umsgs)",
-					"   )",
+					"   lt.load_time is null or",
+					"   lt.load_time <= um.mtime or",
+					"   um.id in (select distinct umsgs.module_id from updating_messages as umsgs)",
 					" );"]
 
 				insertMessages :: SessionMonad m => m ()

@@ -6,7 +6,7 @@ 	analyzeResolve, analyzePreloaded,
 	inspectDocs, inspectDocsGhc,
 	inspectContents, contentsInspection,
-	inspectFile, sourceInspection, fileInspection, fileContentsInspection, fileContentsInspection_, installedInspection, moduleInspection,
+	inspectFile, sourceInspection, fileMTime, fileInspection, fileContentsInspection, fileContentsInspection_, installedInspection, moduleInspection,
 	projectDirs, projectSources,
 	getDefines,
 	preprocess, preprocess_,
@@ -238,11 +238,17 @@ sourceInspection f Nothing = fileInspection f
 sourceInspection _ (Just _) = fileContentsInspection
 
+-- | File modification time as posix time
+fileMTime :: Path -> IO POSIXTime
+fileMTime f = do
+	tm <- Dir.getModificationTime (view path f)
+	return $ utcTimeToPOSIXSeconds tm
+
 -- | File inspection data
 fileInspection :: Path -> [String] -> IO Inspection
 fileInspection f opts = do
-	tm <- Dir.getModificationTime (view path f)
-	return $ InspectionAt (utcTimeToPOSIXSeconds tm) $ map fromString $ sort $ ordNub opts
+	mtime <- fileMTime f
+	return $ InspectionAt mtime $ map fromString $ sort $ ordNub opts
 
 -- | File contents inspection data
 fileContentsInspection :: [String] -> IO Inspection

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings, CPP #-}
 
 module HsDev.PackageDb (
 		module HsDev.PackageDb.Types,
@@ -14,7 +14,7 @@ import Data.Traversable
 import Distribution.InstalledPackageInfo
 import Distribution.Package
-import Distribution.Text (disp)
+import Distribution.Text (display)
 import System.FilePath
 
 import GHC.Paths
@@ -52,18 +52,25 @@ 		confs <- fmap (filter isConf) $ directoryContents (p ^. path)
 		fmap M.unions $ forM confs $ \conf -> do
 				cts <- readFileUtf8 conf
-				case parseInstalledPackageInfo (unpack cts) of
-						ParseFailed _ -> return M.empty  -- FIXME: Should log as warning
-						ParseOk _ res -> mapM (mapM canonicalize) $
+				case parseResult (parseInstalledPackageInfo (unpack cts)) of
+						Left _ -> return M.empty  -- FIXME: Should log as warning
+						Right (_, res) -> mapM (mapM canonicalize) $
 							over (each . each . moduleInstallDirs . each) (subst mlibdir) $ listMods res
 		where
+#if MIN_VERSION_Cabal(3,0,0)
+				parseResult = id
+#else
+				parseResult (ParseFailed e) = Left [show e]
+				parseResult (ParseOk ws res) = Right (map show ws, res)
+#endif
+
 				isConf f = takeExtension f == ".conf"
 				listMods pinfo = M.singleton pname pmods where
 						pname = ModulePackage
-								(pack . show . disp . pkgName $ sourcePackageId pinfo)
-								(pack . show . disp . pkgVersion $ sourcePackageId pinfo)
+								(pack . display . pkgName $ sourcePackageId pinfo)
+								(pack . display . pkgVersion $ sourcePackageId pinfo)
 						pmods = [InstalledModule (map fromFilePath $ libraryDirs pinfo) pname nm exposed' | (nm, exposed') <- names]
-						names = zip (map (pack . show . disp) (exposedModules pinfo)) (repeat True) ++ zip (map (pack . show . disp) (hiddenModules pinfo)) (repeat False)
+						names = zip (map (pack . display) (exposedModules pinfo)) (repeat True) ++ zip (map (pack . display) (hiddenModules pinfo)) (repeat False)
 				subst Nothing f = f
 				subst (Just libdir') f = case splitPaths f of
 						("$topdir":rest) -> joinPaths (fromFilePath libdir' : rest)

@@ -25,6 +25,9 @@ import qualified Data.Text as T (intercalate)
 import Data.Text.Lens (unpacked)
 import Distribution.Compiler (CompilerFlavor(GHC))
+#if MIN_VERSION_Cabal(3,0,0)
+import Distribution.Compiler (perCompilerFlavorToList)
+#endif
 import qualified Distribution.Package as P
 import qualified Distribution.PackageDescription as PD
 import qualified Distribution.ModuleName as PD (toFilePath)
@@ -95,12 +98,18 @@ 			_infoDepends = map pkgName (PD.targetBuildDepends info),
 			_infoLanguage = PD.defaultLanguage info,
 			_infoExtensions = PD.defaultExtensions info ++ PD.otherExtensions info ++ PD.oldExtensions info,
-			_infoGHCOptions = maybe [] (map pack) $ lookup GHC (PD.options info),
+			_infoGHCOptions = maybe [] (map pack) $ lookup GHC (pkgOptions info),
 			_infoSourceDirs = map pack $ PD.hsSourceDirs info,
 			_infoOtherModules = map (map pack . components) (PD.otherModules info) }
 
+#if MIN_VERSION_Cabal(3,0,0)
+		pkgOptions = perCompilerFlavorToList . PD.options
+#else
+		pkgOptions = PD.options
+#endif
+
 		pkgName :: P.Dependency -> Text
-		pkgName (P.Dependency dep _) = pack $ P.unPackageName dep
+		pkgName = pack . P.unPackageName . P.depPkgName
 
 		flattenDescr :: PD.GenericPackageDescription -> PD.PackageDescription
 		flattenDescr gpkg = pkg {

@@ -14,8 +14,13 @@ 
 #if MIN_VERSION_Cabal(2,2,0)
 import Distribution.PackageDescription.Parsec
-import Distribution.Parsec.Common (showPError)
 import qualified Data.ByteString.Char8 as C8 (pack)
+#endif
+
+#if MIN_VERSION_Cabal(3,0,0)
+import Distribution.Parsec (showPError)
+#elif MIN_VERSION_Cabal(2,2,0)
+import Distribution.Parsec.Common (showPError)
 #else
 import Distribution.PackageDescription.Parse
 #endif

@@ -21,6 +21,7 @@ import Data.Char
 import Data.Maybe
 import Data.Map.Strict (Map)
+import Data.Version (showVersion)
 import qualified Data.Map.Strict as M
 import Distribution.Compiler
 import Distribution.System
@@ -54,7 +55,7 @@ 			Compat.pkgDatabase $ df
 		compiler = T.display buildCompilerFlavor
 		CompilerId _ version' = buildCompilerId
-		ver = maybe (T.display version') T.display $ lookup compiler res
+		ver = maybe (T.display version') showVersion $ lookup compiler res
 	return $ compiler ++ "-" ++ ver
 
 -- | Get arch for stack

@@ -149,7 +149,7 @@ withCurrentDirectory dir act = gbracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $
 	const (liftIO (setCurrentDirectory dir) >> act)
 
--- | Log  ghc warnings and errors as to chan
+-- | Log ghc warnings and errors as to chan
 -- You may have to apply recalcTabs on result notes
 logToChan :: Chan (Note OutputMessage) -> LogAction
 logToChan ch fs sev src msg

@@ -10,8 +10,9 @@ import Control.Arrow
 import qualified Data.Map as M
 import Data.Maybe
-import Distribution.Text (display)
+import Data.Version (showVersion)
 import Distribution.System (buildOS)
+import Distribution.Text (display)
 import qualified System.Info as Sys
 import Text.Format
 
@@ -34,7 +35,7 @@ 
 examineCompilerVersion :: DynFlags -> String
 examineCompilerVersion =
-	display .
+	showVersion .
 	fromMaybe Sys.compilerVersion .
 	M.lookup Sys.compilerName .
 	M.fromList .

@@ -62,7 +62,11 @@ import qualified Data.Text.Lazy.Encoding as T
 import Data.Time.Clock.POSIX
 import Distribution.Text (simpleParse)
-import qualified Distribution.Text (Text)
+#if MIN_VERSION_Cabal(3,0,0)
+import qualified Distribution.Parsec as DT
+#else
+import qualified Distribution.Text as DT
+#endif
 import Options.Applicative
 import qualified System.Directory as Dir
 import System.FilePath
@@ -303,7 +307,11 @@ version = mapM readMaybe $ split (== '.') $cabalVersion
 
 -- | Parse Distribution.Text
-parseDT :: (Monad m, Distribution.Text.Text a) => String -> String -> m a
+#if MIN_VERSION_Cabal(3,0,0)
+parseDT :: (Monad m, DT.Parsec a) => String -> String -> m a
+#else
+parseDT :: (Monad m, DT.Text a) => String -> String -> m a
+#endif
 parseDT typeName v = maybe err return (simpleParse v) where
 	err = fail $ "Can't parse {}: {}" ~~ typeName ~~ v