hsdev 0.3.3.4 → 0.3.3.5

raw patch · 8 files changed

+78/−45 lines, 8 filesdep ~Cabaldep ~ghcdep ~ghc-bootPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: Cabal, ghc, ghc-boot, haddock-library, hlint, lens-aeson, network, regex-pcre-builtin, template-haskell, time

API changes (from Hackage documentation)

Files

• hsdev.cabal +16/−11
• src/HsDev/Database/SQLite/Instances.hs +16/−17
• src/HsDev/Database/Update/Types.hs +1/−2
• src/HsDev/Scan/Browse.hs +2/−10
• src/HsDev/Tools/Ghc/Compat.hs +12/−0
• src/HsDev/Tools/Ghc/Repl.hs +5/−2
• src/HsDev/Tools/Ghc/Types.hs +22/−3
• src/HsDev/Util.hs +4/−0

@@ -1,5 +1,5 @@ name:                hsdev
-version:             0.3.3.4
+version:             0.3.3.5
 synopsis:            Haskell development library
 description:
   Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.
@@ -131,6 +131,11 @@     build-depends:
       unix                              >= 2.7.2.0 && < 2.8
 
+  if impl(ghc >= 8.8) && impl(ghc < 8.9)
+    build-depends:
+      ghc   == 8.8.*,
+      Cabal >= 3.0 && < 3.1
+
   if impl(ghc >= 8.6) && impl(ghc < 8.7)
     build-depends:
       ghc   == 8.6.*,
@@ -155,11 +160,11 @@     build-depends:
       hdocs >= 0.5.3,
       haddock-api >= 2.17.4,
-      haddock-library >= 1.4.3 && < 1.8
+      haddock-library >= 1.4.3 && < 1.9
 
   if flag(hlint)
     build-depends:
-      hlint >= 2.0.11 && < 2.2
+      hlint >= 2.0.11 && < 2.3
 
   -- Build dependency lower bound is set for GHC 8.0.1.
   -- Upper bound is set for GHC 8.4
@@ -180,12 +185,12 @@     exceptions                        >= 0.8.3 && < 0.11,
     filepath                          >= 1.4.1.0 && < 1.5,
     fsnotify                          >= 0.2.1 && < 0.4,
-    ghc-boot                          >= 8.0.1 && < 8.7,
+    ghc-boot                          >= 8.0.1 && < 8.9,
     ghc-paths                         >= 0.1.0.9 && < 0.2,
     haskell-names                     >= 0.9.1 && < 0.10.0,
     haskell-src-exts                  >= 1.19.1 && < 1.22.0,
     hformat                           >= 0.1.0.1 && < 0.4,
-    hlint                             >= 2.0.11 && < 2.2,
+    hlint                             >= 2.0.11 && < 2.3,
     http-client                    >= 0.5 && < 0.7,
     lens                              >= 4.14 && < 4.19,
     lifted-base                       >= 0.2.3.10 && < 0.3,
@@ -193,20 +198,20 @@     monad-control                     >= 1.0.1.0 && < 1.1,
     monad-loops                       >= 0.4.3 && < 0.5,
     mtl                               >= 2.2.1 && < 2.3,
-    network                           >= 2.8 && < 3.1,
+    network                           >= 2.8 && < 3.2,
     network-uri                      >= 2.6 && < 2.7,
     optparse-applicative              >= 0.12.1.0 && < 0.16,
     process                           >= 1.4.2.0 && < 1.7,
-    regex-pcre-builtin                >= 0.94.4 && < 0.95,
+    regex-pcre-builtin                >= 0.94.4 && < 0.96,
     scientific                        >= 0.3.4.9 && < 0.4,
     simple-log                        >= 0.9.9 && < 0.10,
     sqlite-simple                     >= 0.4.13.0 && < 0.5,
     stm                               >= 2.4 && < 2.6,
     syb                               >= 0.6 && < 0.8,
-    template-haskell                  >= 2.11.0 && < 2.15,
+    template-haskell                  >= 2.11.0 && < 2.16,
     text                              >= 1.2.2.2 && < 1.3,
     text-region                       >= 0.1.0.1 && < 0.4,
-    time                              >= 1.6.0.1 && < 1.9,
+    time                              >= 1.6.0.1 && < 1.10,
     transformers                      >= 0.5.2.0 && < 0.6,
     transformers-base                 >= 0.4.4 && < 0.5,
     uniplate                          >= 1.6.12 && < 1.7,
@@ -231,7 +236,7 @@     filepath                          >= 1.4.1.0 && < 1.5,
     monad-loops                       >= 0.4.3 && < 0.5,
     mtl                               >= 2.2.1 && < 2.3,
-    network                           >= 2.8 && < 3.1,
+    network                           >= 2.8 && < 3.2,
     optparse-applicative              >= 0.12.1.0 && < 0.16,
     process                           >= 1.4.2.0 && < 1.7,
     text                              >= 1.2.2.2 && < 1.3,
@@ -247,7 +252,7 @@     hsdev,
     base                              >= 4.9 && < 5,
     aeson                             >= 1.2.4.0 && < 1.5,
-    lens-aeson                        >= 1.0 && < 1.1,
+    lens-aeson                        >= 1.0 && < 1.2,
     async                             >= 2.1.1.1 && < 2.3,
     containers                        >= 0.5.7.1 && < 0.7,
     data-default                      >= 0.7.1.1 && < 0.8,

@@ -80,7 +80,7 @@ 		iexposed <- field
 		other <- field
 
-		maybe (fail $ "Can't parse module location: {}" ~~ show (file, cabal, dirs, pname, pver, iname, iexposed, other)) return $ msum [
+		maybe mzero return $ msum [
 			FileModule <$> file <*> pure (project <$> cabal),
 			InstalledModule <$> maybe (pure []) fromJSON' dirs <*> (ModulePackage <$> pname <*> pver) <*> iname <*> iexposed,
 			OtherLocation <$> other,
@@ -126,7 +126,7 @@ 		assoc <- field
 		patTy <- field
 		patCtor <- field
-		maybe (fail $ "Can't parse symbol info: {}" ~~ show (what, ty, parent, ctors, args, ctx, assoc, patTy, patCtor)) return $ case what of
+		maybe mzero return $ case what of
 			"function" -> return $ Function ty
 			"method" -> Method <$> pure ty <*> parent
 			"selector" -> Selector <$> pure ty <*> parent <*> (fromJSON' =<< ctors)
@@ -181,7 +181,7 @@ 	fromField = fromField @String >=> fromStr where
 		fromStr "cabal" = return CabalTool
 		fromStr "stack" = return StackTool
-		fromStr s = fail $ "Error parsing build tool: {}" ~~ s
+		fromStr _ = mzero
 
 instance ToRow Sandbox where
 	toRow (Sandbox t p) = [toField t, toField p]
@@ -203,7 +203,7 @@ 
 instance FromRow Library where
 	fromRow = do
-		mods <- field >>= maybe (fail "Error parsing library modules") return . fromJSON'
+		mods <- field >>= maybe mzero return . fromJSON'
 		binfo <- fromRow
 		return $ Library mods binfo
 
@@ -215,17 +215,17 @@ 
 instance FromRow Info where
 	fromRow = Info <$>
-		(field >>= maybe (fail "Error parsing depends") return . fromJSON') <*>
+		(field >>= maybe mzero return . fromJSON') <*>
 		field <*>
-		(field >>= maybe (fail "Error parsing extensions") return . fromJSON') <*>
-		(field >>= maybe (fail "Error parsing ghc-options") return . fromJSON') <*>
-		(field >>= maybe (fail "Error parsing source-dirs") return . fromJSON') <*>
-		(field >>= maybe (fail "Error parsing other-modules") return . fromJSON')
+		(field >>= maybe mzero return . fromJSON') <*>
+		(field >>= maybe mzero return . fromJSON') <*>
+		(field >>= maybe mzero return . fromJSON') <*>
+		(field >>= maybe mzero return . fromJSON')
 
 instance FromField Language where
 	fromField fld = case fieldData fld of
 		SQLText txt -> parseDT "Language" (T.unpack txt)
-		_ -> fail "Can't parse language, invalid type"
+		_ -> mzero
 
 instance ToField PackageDb where
 	toField GlobalDb = toField ("global-db" :: String)
@@ -240,13 +240,13 @@ 			"user-db" -> return UserDb
 			_ -> case T.stripPrefix "package-db:" s of
 				Just p' -> return $ PackageDb p'
-				Nothing -> fail $ "Can't parse package-db, invalid string: " ++ T.unpack s
+				Nothing -> mzero
 
 instance ToField PackageDbStack where
 	toField = toField . toJSON . packageDbs
 
 instance FromField PackageDbStack where
-	fromField = fromField >=> maybe (fail "Error parsing package-db-stack") (return . mkPackageDbStack) . fromJSON'
+	fromField = fromField >=> maybe mzero (return . mkPackageDbStack) . fromJSON'
 
 instance FromRow SymbolUsage where
 	fromRow = SymbolUsage <$> fromRow <*> field <*> fromRow <*> fromRow
@@ -264,8 +264,8 @@ 		case (tm, opts) of
 			(Nothing, Nothing) -> return InspectionNone
 			(_, Just opts') -> InspectionAt (fromMaybe 0 tm) <$>
-				maybe (fail "Error parsing inspection opts") return (fromJSON' opts')
-			(Just _, Nothing) -> fail "Error parsing inspection data, time is set, but flags are null"
+				maybe mzero return (fromJSON' opts')
+			(Just _, Nothing) -> mzero
 
 instance ToRow Inspection where
 	toRow InspectionNone = [SQLNull, SQLNull]
@@ -306,7 +306,7 @@ 		let
 			m = toModuleName_ mname
 			n = toName_ name
-		maybe (fail $ "Can't parse symbol: {}" ~~ show (what, mname, name, parent, ctors, assoc, patType, patCtor)) return $ case what of
+		maybe mzero return $ case what of
 			"function" -> return $ N.Value m n
 			"method" -> N.Method m n <$> parent
 			"selector" -> N.Selector m n <$> parent <*> ctors
@@ -346,8 +346,7 @@ 		msum [
 			guard (s == "error") >> return Error,
 			guard (s == "warning") >> return Warning,
-			guard (s == "hint") >> return Hint,
-			fail ("Unknown severity: {}" ~~ s)]
+			guard (s == "hint") >> return Hint]
 
 instance ToField Severity where
 	toField Error = toField @String "error"

@@ -42,8 +42,7 @@ 	parseJSON v = msum $ map ($ v) [
 		withText "status" $ \t -> guard (t == "working") $> StatusWorking,
 		withText "status" $ \t -> guard (t == "ok") $> StatusOk,
-		liftM StatusError . parseJSON,
-		fail "invalid status"]
+		liftM StatusError . parseJSON]
 
 data Progress = Progress {
 	progressCurrent :: Int,

@@ -7,7 +7,7 @@ 	-- * Helpers
 	uniqueModuleLocations,
 	readPackage, readPackageConfig, ghcModuleLocation,
-	packageConfigs, packageDbModules, lookupModule_,
+	packageConfigs, packageDbModules,
 	modulesPackages, modulesPackagesGroups, withEachPackage,
 
 	module Control.Monad.Except
@@ -204,15 +204,7 @@ 	return [(p, m, exposed') |
 		p <- pkgs,
 		(mn, exposed') <- zip (map Compat.exposedModuleName (GHC.exposedModules p)) (repeat True) ++ zip (GHC.hiddenModules p) (repeat False),
-		m <- lookupModule_ dflags mn]
-
--- Lookup module everywhere
-lookupModule_ :: GHC.DynFlags -> GHC.ModuleName -> [GHC.Module]
-lookupModule_ d mn = case GHC.lookupModuleWithSuggestions d mn Nothing of
-	GHC.LookupFound m' _ -> [m']
-	GHC.LookupMultiple ms -> map fst ms
-	GHC.LookupHidden ls rs -> map fst $ ls ++ rs
-	GHC.LookupNotFound _ -> []
+		m <- Compat.lookupModule dflags mn]
 
 -- | Get modules packages
 modulesPackages :: [ModuleLocation] -> [ModulePackage]

@@ -14,6 +14,7 @@ 	exposedModuleName,
 	exprType,
 	modSummaries,
+	lookupModule,
 	cleanTemps,
 	mgArgTys, mgResTy
 	) where
@@ -226,6 +227,17 @@ modSummaries = GHC.mgModSummaries
 #else
 modSummaries = id
+#endif
+
+-- Lookup module everywhere
+lookupModule :: GHC.DynFlags -> GHC.ModuleName -> [GHC.Module]
+lookupModule d mn = case GHC.lookupModuleWithSuggestions d mn Nothing of
+	GHC.LookupFound m' _ -> [m']
+	GHC.LookupMultiple ms -> map fst ms
+	GHC.LookupHidden ls rs -> map fst $ ls ++ rs
+	GHC.LookupNotFound _ -> []
+#if __GLASGOW_HASKELL__ >= 806
+	GHC.LookupUnusable _ -> []
 #endif
 
 cleanTemps :: GHC.DynFlags -> IO ()

@@ -10,6 +10,7 @@ 	) where
 
 import Control.Monad
+import Control.Monad.IO.Class
 import Control.Monad.Catch
 import Data.Aeson
 import Data.Dynamic
@@ -18,6 +19,7 @@ import GhcMonad
 import GHC
 
+import HsDev.Error
 import HsDev.Tools.Ghc.Base
 import qualified HsDev.Tools.Ghc.Compat as C
 import HsDev.Util
@@ -32,8 +34,9 @@ 
 -- | Evaluate expression
 evaluate :: GhcMonad m => String -> m String
-evaluate expr = liftM fromDynamic (dynCompileExpr $ "show ({})" ~~ expr) >>=
-	maybe (fail "evaluate fail") return
+evaluate expr = do
+	v <- liftM fromDynamic (dynCompileExpr $ "show ({})" ~~ expr)
+	maybe (liftIO $ hsdevError $ OtherError "evaluate fail") return v
 
 -- | Get expression type as string
 expressionType :: GhcMonad m => String -> m String

@@ -1,4 +1,4 @@-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes, TemplateHaskell, OverloadedStrings #-}
+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, RankNTypes, TemplateHaskell, OverloadedStrings, CPP #-}
 
 module HsDev.Tools.Ghc.Types (
 	TypedExpr(..), typedExpr, typedType,
@@ -27,6 +27,7 @@ import TcHsSyn (hsPatType)
 import Outputable
 import PprTyThing
+import qualified SrcLoc
 import qualified Pretty
 
 import System.Directory.Paths
@@ -56,7 +57,12 @@ 	getType _ = return Nothing
 
 instance HasType (LPat TcId) where
-	getType (L spn pat) = return $ Just (spn, hsPatType pat)
+#if __GLASGOW_HASKELL__ >= 808
+	getType = go . SrcLoc.decomposeSrcSpan where
+#else
+	getType = go where
+#endif
+		go (L spn pat) = return $ Just (spn, hsPatType pat)
 
 locatedTypes :: Typeable a => TypecheckedSource -> [Located a]
 locatedTypes = types' p where
@@ -64,6 +70,19 @@ 	types' p' = everythingTyped (++) [] ([] `mkQ` (\x -> [x | p' x]))
 	p (L spn _) = isGoodSrcSpan spn
 
+#if __GLASGOW_HASKELL__ >= 808
+typeableTypes :: Typeable a => TypecheckedSource -> [a]
+typeableTypes = types' (const True) where
+	types' :: Typeable r => (r -> Bool) -> GenericQ [r]
+	types' p' = everythingTyped (++) [] ([] `mkQ` (\x -> [x | p' x]))
+
+locatedPats :: TypecheckedSource -> [LPat TcId]
+locatedPats = typeableTypes
+#else
+locatedPats :: TypecheckedSource -> [LPat TcId]
+locatedPats = locatedTypes
+#endif
+
 everythingTyped :: (r -> r -> r) -> r -> GenericQ r -> GenericQ r
 everythingTyped k z f x
 	| (const False `extQ` nameSet) x = z
@@ -86,7 +105,7 @@ 	liftM (catMaybes . concat) $ sequence [
 		mapM getType (locatedTypes ts :: [LHsExpr TcId]),
 		mapM getType (locatedTypes ts :: [LHsBind TcId]),
-		mapM getType (locatedTypes ts :: [LPat TcId])]
+		mapM getType (locatedPats ts)]
 
 data TypedExpr = TypedExpr {
 	_typedExpr :: Maybe Text,

@@ -308,7 +308,11 @@ 
 -- | Parse Distribution.Text
 #if MIN_VERSION_Cabal(3,0,0)
+#if __GLASGOW_HASKELL__ >= 808
+parseDT :: (MonadFail m, Monad m, DT.Parsec a) => String -> String -> m a
+#else
 parseDT :: (Monad m, DT.Parsec a) => String -> String -> m a
+#endif
 #else
 parseDT :: (Monad m, DT.Text a) => String -> String -> m a
 #endif