hsdev 0.1.8.2 → 0.2.0.0

raw patch · 28 files changed

+279/−618 lines, 28 filesdep +ghc-bootdep −MonadCatchIO-transformersdep −ghc-moddep ~ghcdep ~haddock-apidep ~hdocs

Dependencies added: ghc-boot

Dependencies removed: MonadCatchIO-transformers, ghc-mod

Dependency ranges changed: ghc, haddock-api, hdocs, hformat, optparse-applicative, simple-log

Files

hsdev.cabal +21/−19
src/Control/Concurrent/Util.hs +1/−1
src/Control/Concurrent/Worker.hs +2/−2
src/Data/Deps.hs +4/−4
src/HsDev/Client/Commands.hs +12/−47
src/HsDev/Database.hs +1/−1
src/HsDev/Database/Update/Types.hs +2/−3
src/HsDev/Error.hs +1/−1
src/HsDev/Sandbox.hs +5/−6
src/HsDev/Scan.hs +1/−6
src/HsDev/Scan/Browse.hs +9/−9
src/HsDev/Server/Base.hs +0/−3
src/HsDev/Server/Commands.hs +1/−2
src/HsDev/Server/Types.hs +14/−59
src/HsDev/Stack.hs +15/−16
src/HsDev/Symbols/Resolve.hs +1/−1
src/HsDev/Symbols/Types.hs +1/−1
src/HsDev/Symbols/Util.hs +1/−1
src/HsDev/Tools/ClearImports.hs +2/−1
src/HsDev/Tools/Ghc/Check.hs +6/−6
src/HsDev/Tools/Ghc/Compat.hs +106/−0
src/HsDev/Tools/Ghc/Types.hs +8/−8
src/HsDev/Tools/Ghc/Worker.hs +16/−17
src/HsDev/Tools/GhcMod.hs +0/−320
src/HsDev/Tools/GhcMod/InferType.hs +0/−54
src/HsDev/Util.hs +19/−26
src/System/Win32/FileMapping/Memory.hs +1/−1
tools/hsautofix.hs +29/−3

hsdev.cabal view

@@ -1,9 +1,6 @@--- Initial hsdev.cabal generated by cabal init.  For further documentation,
---  see http://haskell.org/cabal/users-guide/
-
 name:                hsdev
-version:             0.1.8.2
-synopsis:            Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references etc.
+version:             0.2.0.0
+synopsis:            Haskell development library
 description:
   Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.
 homepage:            https://github.com/mvoidex/hsdev
@@ -19,6 +16,10 @@     tests/test-package/*.hs
     tests/test-package/test-package.cabal
 
+source-repository head
+  type: git
+  location: git://github.com/mvoidex/hsdev.git
+
 library
   hs-source-dirs: src
   ghc-options: -Wall -fno-warn-tabs
@@ -68,11 +69,10 @@     HsDev.Tools.Cabal
     HsDev.Tools.ClearImports
     HsDev.Tools.Ghc.Check
+    HsDev.Tools.Ghc.Compat
     HsDev.Tools.Ghc.Prelude
     HsDev.Tools.Ghc.Types
     HsDev.Tools.Ghc.Worker
-    HsDev.Tools.GhcMod
-    HsDev.Tools.GhcMod.InferType
     HsDev.Tools.Hayoo
     HsDev.Tools.HDocs
     HsDev.Tools.HLint
@@ -96,6 +96,17 @@     build-depends:
       unix >= 2.7.0
 
+  if impl(ghc >= 8.0)
+    build-depends:
+      haddock-api >= 2.17.0 && < 2.18.0,
+      ghc >= 8.0.0 && < 8.1.0,
+      ghc-boot
+  if impl(ghc < 8.0)
+    build-depends:
+      haddock-api >= 2.16.0 && < 2.17.0,
+      ghc >= 7.10.0 && < 7.11.0,
+      bin-package-db
+
   build-depends:
     base >= 4.7 && < 5,
     aeson >= 0.7.0,
@@ -103,7 +114,6 @@     array >= 0.5.0,
     async >= 2.0,
     attoparsec >= 0.11.0,
-    bin-package-db,
     bytestring >= 0.10.0,
     Cabal >= 1.22.0,
     containers >= 0.5.0,
@@ -114,13 +124,10 @@     exceptions >= 0.6.0,
     filepath >= 1.4.0,
     fsnotify >= 0.2.1,
-    ghc >= 7.10.0 && < 7.11.0,
-    ghc-mod >= 5.5.0.0 && < 5.6.0.0,
     ghc-paths >= 0.1.0,
     ghc-syb-utils >= 0.2.3,
-    haddock-api >= 2.16.0 && < 2.17.0,
     haskell-src-exts >= 1.17.0 && < 1.18.0,
-    hdocs >= 0.4.4,
+    hdocs >= 0.5.0,
     hformat >= 0.1,
     hlint >= 1.9.13 && < 2.0.0,
     HTTP >= 4000.2.0,
@@ -129,13 +136,12 @@     monad-control >= 1.0,
     monad-loops >= 0.4,
     mtl >= 2.2.0,
-    MonadCatchIO-transformers >= 0.3.1,
     network >= 2.6.0,
     optparse-applicative >= 0.11,
     process >= 1.2.0,
     regex-pcre-builtin >= 0.94,
     scientific >= 0.3,
-    simple-log >= 0.3.4,
+    simple-log >= 0.4.0,
     syb >= 0.5.1,
     template-haskell,
     text >= 1.2.0,
@@ -209,7 +215,6 @@     containers >= 0.5.0,
     data-default >= 0.5.0,
     directory >= 1.2.0,
-    ghc >= 7.10.0 && < 7.11.0,
     haskell-src-exts >= 1.17.0 && < 1.18.0,
     lens >= 4.8,
     mtl >= 2.2.0,
@@ -272,6 +277,7 @@     bytestring >= 0.10.0,
     data-default >= 0.5.0,
     directory >= 1.2.0,
+    filepath >= 1.4.0,
     lens >= 4.8,
     mtl >= 2.2.0,
     optparse-applicative >= 0.11,
@@ -298,7 +304,3 @@     lens >= 4.8,
     mtl >= 2.2.0,
     text >= 1.2.0
-
-source-repository head
-  type: git
-  location: git://github.com/mvoidex/hsdev

src/Control/Concurrent/Util.hs view

@@ -7,7 +7,7 @@ import Control.Monad
 import Control.Monad.IO.Class
 
-fork :: (MonadIO m, Functor m) => IO () -> m ()
+fork :: MonadIO m => IO () -> m ()
 fork = liftIO . void . forkIO
 
 timeout :: Int -> IO a -> IO (Maybe a)

src/Control/Concurrent/Worker.hs view

@@ -50,7 +50,7 @@ 				when stopped (start >>= void . swapMVar taskVar)
 	return $ Worker ch wrap taskVar restart
 
-workerDone :: MonadIO m => Worker m -> IO Bool
+workerDone :: Worker m -> IO Bool
 workerDone = doneChan . workerChan
 
 sendTask :: (MonadCatch m, MonadIO m) => Worker m -> m a -> IO (Async a)
@@ -58,7 +58,7 @@ 	var <- newEmptyMVar
 	let
 		act' = (workerWrap w act >>= liftIO . putMVar var . Right) `catch` onError
-		onError :: (MonadCatch m, MonadIO m) => SomeException -> m ()
+		onError :: MonadIO m => SomeException -> m ()
 		onError = liftIO . putMVar var . Left
 		f = do
 			p <- sendChan (workerChan w) (void async', void act')

src/Data/Deps.hs view

@@ -18,7 +18,7 @@ data Deps a = Deps {
 	_depsMap :: Map a [a] }
 
-depsMap :: (Ord a, Ord b) => Lens (Deps a) (Deps b) (Map a [a]) (Map b [b])
+depsMap :: Lens (Deps a) (Deps b) (Map a [a]) (Map b [b])
 depsMap = lens _depsMap (const Deps)
 
 instance Ord a => Monoid (Deps a) where
@@ -34,15 +34,15 @@ instance Ord a => At (Deps a) where
 	at k = depsMap . at k
 
-mapDeps :: (Ord a, Ord b) => (a -> b) -> Deps a -> Deps b
+mapDeps :: Ord b => (a -> b) -> Deps a -> Deps b
 mapDeps f = Deps . M.mapKeys f . M.map (map f) . _depsMap
 
 -- | Make single dependency
-dep :: Ord a => a -> a -> Deps a
+dep :: a -> a -> Deps a
 dep x y = deps x [y]
 
 -- | Make dependency for one target, note that order of dependencies is matter
-deps :: Ord a => a -> [a] -> Deps a
+deps :: a -> [a] -> Deps a
 deps x ys = Deps $ M.singleton x ys
 
 -- | Inverse dependencies, i.e. make map where keys are dependencies and elements are targets depends on it

src/HsDev/Client/Commands.hs view

@@ -12,8 +12,7 @@ import Control.Monad.Except
 import Control.Monad.Reader
 import qualified Control.Monad.State as State
-import Control.Monad.Catch (try, catch, SomeException(..))
-import Control.Monad.CatchIO (bracket)
+import Control.Monad.Catch (try, catch, bracket, SomeException(..))
 import Data.Aeson hiding (Result, Error)
 import Data.List
 import Data.Foldable (toList)
@@ -45,23 +44,22 @@ import qualified HsDev.Tools.AutoFix as AutoFix
 import qualified HsDev.Tools.Cabal as Cabal
 import HsDev.Tools.Ghc.Worker
+import qualified HsDev.Tools.Ghc.Compat as Compat
 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.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) => ReaderT CommandOptions m a -> m Result
 	toResult act = liftM (either Error (Result . toJSON)) $ runReaderT (try act) copts
-	mapServerM :: (Monad m, Monad n) => (m a -> n b) -> ServerM m a -> ServerM n b
+	mapServerM :: (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
@@ -238,43 +236,6 @@ 		pdbs <- searchPackageDbStack file
 		m <- refineSourceModule file
 		inWorkerWith (hsdevError . GhcError . displayException) ghc (Types.fileTypes ghcs' pdbs m msrc)
-runCommand (GhcMod GhcModLang) = toValue $ liftIO $ hsdevLift GhcMod.langs
-runCommand (GhcMod GhcModFlags) = toValue $ liftIO $ hsdevLift GhcMod.flags
-runCommand (GhcMod (GhcModType (Position line column) fpath ghcs')) = toValue $ do
-	ghcmod <- askSession sessionGhcMod
-	dbval <- getDb
-	pdbs <- searchPackageDbStack fpath
-	pkgs <- Scan.browsePackages ghcs' pdbs
-	(fpath', m', _) <- liftIO $ hsdevLift $ fileCtx dbval fpath
-	liftIO $ GhcMod.waitMultiGhcMod ghcmod fpath' $
-		GhcMod.typeOf (ghcs' ++ moduleOpts pkgs m') pdbs fpath' line column
-runCommand (GhcMod (GhcModLint fs hlints')) = toValue $ do
-	ghcmod <- askSession sessionGhcMod
-	liftIO $ 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
-	liftM concat $ forM fs $ \file -> do
-		mproj <- liftIO $ locateProject file
-		pdbs <- searchPackageDbStack file
-		pkgs <- Scan.browsePackages ghcs' pdbs
-		(_, m', _) <- liftIO $ hsdevLift $ fileCtx dbval file
-		liftIO $ 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
-	liftM concat $ forM fs $ \file -> do
-		mproj <- liftIO $ locateProject file
-		pdbs <- searchPackageDbStack file
-		pkgs <- Scan.browsePackages ghcs' pdbs
-		(_, m', _) <- liftIO $ hsdevLift $ fileCtx dbval file
-		liftIO $ 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
@@ -306,6 +267,10 @@ 		toValue' :: ToJSON a => Either SomeException a -> Value
 		toValue' (Left (SomeException e)) = object ["fail" .= show e]
 		toValue' (Right s) = toJSON s
+runCommand Langs = toValue $ return $ Compat.languages
+runCommand Flags = toValue $ return ["-f" ++ prefix ++ f |
+	f <- Compat.flags,
+	prefix <- ["", "no-"]]
 runCommand (Link hold) = toValue $ commandLink >> when hold commandHold
 runCommand Exit = toValue serverExit
 
@@ -338,14 +303,14 @@ 		liftIO $ canonicalizePath (normalise $ if isRelative f then r </> f else f)
 
 -- | Find sandbox by path
-findSandbox :: (CommandMonad m, Functor m) => FilePath -> m Sandbox
+findSandbox :: CommandMonad m => FilePath -> m Sandbox
 findSandbox fpath = do
 	fpath' <- findPath fpath
 	sbox <- liftIO $ S.findSandbox fpath'
 	maybe (hsdevError $ FileNotFound fpath') return sbox
 
 -- | Get source file
-refineSourceFile :: (CommandMonad m, Functor m) => FilePath -> m FilePath
+refineSourceFile :: CommandMonad m => FilePath -> m FilePath
 refineSourceFile fpath = do
 	fpath' <- findPath fpath
 	db' <- getDb
@@ -354,14 +319,14 @@ 		preview (moduleLocation . moduleFile) m'
 
 -- | Get module by source
-refineSourceModule :: (CommandMonad m, Functor m) => FilePath -> m Module
+refineSourceModule :: CommandMonad m => FilePath -> m Module
 refineSourceModule fpath = do
 	fpath' <- findPath fpath
 	db' <- getDb
 	maybe (hsdevError (NotInspected $ FileModule fpath' Nothing)) return $ lookupFile fpath' db'
 
 -- | Ensure package exists
-refinePackage :: (CommandMonad m, Functor m) => String -> m String
+refinePackage :: CommandMonad m => String -> m String
 refinePackage pack = do
 	db' <- getDb
 	if pack `elem` (allPackages db' ^.. each . packageName)
@@ -369,7 +334,7 @@ 		else hsdevError (PackageNotFound pack)
 
 -- | Get list of enumerated sandboxes
-getSandboxes :: (CommandMonad m, Functor m) => [FilePath] -> m [Sandbox]
+getSandboxes :: CommandMonad m => [FilePath] -> m [Sandbox]
 getSandboxes = traverse (findPath >=> findSandbox)
 
 -- | Find project by name or path

src/HsDev/Database.hs view

@@ -232,7 +232,7 @@ 		"Different module projects"
 		(return (databaseProjects db ^.. each . projectCabal))
 	-- Check that list results in one element
-	unique :: (Eq a) => String -> String -> Either String [a] -> Either String a
+	unique :: String -> String -> Either String [a] -> Either String a
 	unique _ _ (Left e) = Left e
 	unique no _ (Right []) = Left no
 	unique _ _ (Right [x]) = Right x

src/HsDev/Database/Update/Types.hs view

@@ -11,7 +11,6 @@ import Control.Lens (makeLenses)
 import Control.Monad.Base
 import Control.Monad.Catch
-import Control.Monad.CatchIO
 import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.Writer
@@ -90,12 +89,12 @@ type UpdateMonad m = (CommandMonad m, MonadReader UpdateOptions m, MonadWriter [ModuleLocation] m)
 
 newtype UpdateM m a = UpdateM { runUpdateM :: ReaderT UpdateOptions (WriterT [ModuleLocation] (ClientM m)) a }
-	deriving (Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadCatchIO, Functor, MonadReader UpdateOptions, MonadWriter [ModuleLocation])
+	deriving (Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask, Functor, MonadReader UpdateOptions, MonadWriter [ModuleLocation])
 
 instance MonadTrans UpdateM where
 	lift = UpdateM . lift . lift . lift
 
-instance MonadCatchIO m => Log.MonadLog (UpdateM m) where
+instance (MonadIO m, MonadMask m) => Log.MonadLog (UpdateM m) where
 	askLog = UpdateM $ lift $ lift Log.askLog
 
 instance ServerMonadBase m => SessionMonad (UpdateM m) where

src/HsDev/Error.hs view

@@ -56,6 +56,6 @@ hsdevHandle h act = hsdevCatch act >>= either h return
 
 -- | Log hsdev exception and rethrow
-hsdevLog :: (MonadLog m, MonadCatch m) => Level -> m a -> m a
+hsdevLog :: MonadLog m => Level -> m a -> m a
 hsdevLog lev act = hsdevCatch act >>= either logError return where
 	logError e = log lev (fromString $ show e) >> hsdevError e

src/HsDev/Sandbox.hs view

@@ -12,7 +12,6 @@ 
 import Control.Arrow
 import Control.DeepSeq (NFData(..))
-import Control.Monad.Catch (MonadCatch(..))
 import Control.Monad.Trans.Maybe
 import Control.Monad.Except
 import Control.Lens (view, makeLenses)
@@ -31,9 +30,9 @@ import HsDev.PackageDb
 import HsDev.Scan.Browse (withPackages)
 import HsDev.Stack
+import HsDev.Tools.Ghc.Compat as Compat
 import HsDev.Util (searchPath)
 
-import qualified GHC
 import qualified Packages as GHC
 
 data SandboxType = CabalSandbox | StackWork deriving (Eq, Ord, Read, Show, Enum, Bounded)
@@ -95,14 +94,14 @@ searchSandbox p = runMaybeT $ searchPath p (MaybeT . findSandbox)
 
 -- | Get package-db stack for sandbox
-sandboxPackageDbStack :: (MonadLog m, MonadCatch m) => Sandbox -> m PackageDbStack
+sandboxPackageDbStack :: MonadLog m => Sandbox -> m PackageDbStack
 sandboxPackageDbStack (Sandbox CabalSandbox fpath) = do
 	dir <- cabalSandboxPackageDb
 	return $ PackageDbStack [PackageDb $ fpath </> dir]
 sandboxPackageDbStack (Sandbox StackWork fpath) = liftM (view stackPackageDbStack) $ projectEnv $ takeDirectory fpath
 
 -- | Search package-db stack with user-db as default
-searchPackageDbStack :: (MonadLog m, MonadCatch m) => FilePath -> m PackageDbStack
+searchPackageDbStack :: MonadLog m => FilePath -> m PackageDbStack
 searchPackageDbStack p = do
 	mbox <- liftIO $ searchSandbox p
 	case mbox of
@@ -110,7 +109,7 @@ 		Just sbox -> sandboxPackageDbStack sbox
 
 -- | Restore package-db stack by package-db
-restorePackageDbStack :: (MonadLog m, MonadCatch m) => PackageDb -> m PackageDbStack
+restorePackageDbStack :: MonadLog m => PackageDb -> m PackageDbStack
 restorePackageDbStack GlobalDb = return globalDb
 restorePackageDbStack UserDb = return userDb
 restorePackageDbStack (PackageDb p) = liftM (fromMaybe $ fromPackageDb p) $ runMaybeT $ do
@@ -124,7 +123,7 @@ 		return .
 		map (GHC.packageNameString &&& GHC.packageVersion) .
 		fromMaybe [] .
-		GHC.pkgDatabase
+		Compat.pkgDatabase
 	let
 		compiler = T.display buildCompilerFlavor
 		CompilerId _ version = buildCompilerId

src/HsDev/Scan.hs view

@@ -32,7 +32,6 @@ import HsDev.Symbols.Types
 import HsDev.Database
 import HsDev.Display
-import HsDev.Tools.GhcMod
 import HsDev.Inspect
 import HsDev.Util
 
@@ -163,10 +162,6 @@ 	setProj =
 		set (inspectedId . moduleProject) p .
 		set (inspectionResult . _Right . moduleLocation . moduleProject) p
--- scanModule opts (FileModule f _) = inspectFile opts f >>= traverse infer' where
--- 	infer' m = tryInfer <|> return m where
--- 		tryInfer = mapExceptT (withCurrentDirectory (sourceModuleRoot (moduleName m) f)) $
--- 			runGhcMod defaultOptions $ inferTypes opts Cabal m
 scanModule _ opts mloc@(InstalledModule c _ n) _ = hsdevLiftIO $ do
 	pdbs <- getDbs c
 	ims <- browseModules opts pdbs [mloc]
@@ -191,7 +186,7 @@ upToDate :: [String] -> InspectedModule -> IO Bool
 upToDate opts im = case view inspectedId im of
 	FileModule f _ -> liftM (== view inspection im) $ fileInspection f opts
-	InstalledModule _ _ _ -> return $ view inspection im == browseInspection opts
+	InstalledModule _ _ _ -> return $ view inspection im == InspectionAt 0 opts
 	_ -> return False
 
 -- | Rescan inspected module

src/HsDev/Scan/Browse.hs view

@@ -30,6 +30,7 @@ import HsDev.Error
 import HsDev.Tools.Base (inspect)
 import HsDev.Tools.Ghc.Worker (GhcM(..), runGhcM)
+import HsDev.Tools.Ghc.Compat as Compat
 import HsDev.Util (ordNub)
 
 import qualified ConLike as GHC
@@ -43,11 +44,10 @@ import qualified Name as GHC
 import qualified Outputable as GHC
 import qualified Packages as GHC
-import qualified PatSyn as GHC
 import qualified TyCon as GHC
 import qualified Type as GHC
 import qualified Var as GHC
-import Pretty
+import qualified Pretty
 
 -- | Browse packages
 browsePackages :: MonadLog m => [String] -> PackageDbStack -> m [PackageConfig]
@@ -59,9 +59,9 @@ browsePackagesDeps opts dbs = withPackages (packageDbStackOpts dbs ++ opts) $ \df -> do
 	cfgs <- packageConfigs
 	return $ mapDeps (toPkg df) $ mconcat $ map (uncurry deps) $
-		map (GHC.installedPackageId &&& GHC.depends) cfgs
+		map (Compat.unitId &&& Compat.depends df) cfgs
 	where
-		toPkg df' = readPackageConfig . GHC.getPackageDetails df' . GHC.resolveInstalledPackageId df'
+		toPkg df' = readPackageConfig . getPackageDetails df'
 
 listModules :: MonadLog m => [String] -> PackageDbStack -> m [ModuleLocation]
 listModules opts dbs = withPackages_ (packageDbStackOpts dbs ++ opts) $ do
@@ -119,7 +119,7 @@ 		showResult dflags (GHC.AnId i) = Just $ Function (Just $ fromString $ formatType dflags GHC.varType i) [] Nothing
 		showResult dflags (GHC.AConLike c) = case c of
 			GHC.RealDataCon d -> Just $ Function (Just $ fromString $ formatType dflags GHC.dataConRepType d) [] Nothing
-			GHC.PatSynCon p -> Just $ Function (Just $ fromString $ formatType dflags GHC.patSynType p) [] Nothing
+			GHC.PatSynCon p -> Just $ Function (Just $ fromString $ formatType dflags patSynType p) [] Nothing
 		showResult _ (GHC.ATyCon t) = Just $ tcon $ TypeInfo Nothing (map (fromString . GHC.getOccString) $ GHC.tyConTyVars t) Nothing [] where
 			tcon
 				| GHC.isAlgTyCon t && not (GHC.isNewTyCon t) && not (GHC.isClassTyCon t) = Data
@@ -132,7 +132,7 @@ withInitializedPackages :: MonadLog m => [String] -> (GHC.DynFlags -> GhcM a) -> m a
 withInitializedPackages ghcOpts cont = runGhcM (Just GHC.libdir) $ do
 	fs <- GHC.getSessionDynFlags
-	GHC.defaultCleanupHandler fs $ do
+	cleanupHandler fs $ do
 		(fs', _, _) <- GHC.parseDynamicFlags fs (map GHC.noLoc ghcOpts)
 		_ <- GHC.setSessionDynFlags fs'
 		(result, _) <- GHC.liftIO $ GHC.initPackages fs'
@@ -147,7 +147,7 @@ inModuleSource :: GhcMonad m => GHC.Name -> m (Maybe GHC.TyThing)
 inModuleSource nm = GHC.getModuleInfo (GHC.nameModule nm) >> GHC.lookupGlobalName nm
 
-formatType :: GHC.NamedThing a => GHC.DynFlags -> (a -> GHC.Type) -> a -> String
+formatType :: GHC.DynFlags -> (a -> GHC.Type) -> a -> String
 formatType dflag f x = showOutputable dflag (removeForAlls $ f x)
 
 removeForAlls :: GHC.Type -> GHC.Type
@@ -165,7 +165,7 @@ showOutputable dflag = unwords . lines . showUnqualifiedPage dflag . GHC.ppr
 
 showUnqualifiedPage :: GHC.DynFlags -> GHC.SDoc -> String
-showUnqualifiedPage dflag = Pretty.showDoc Pretty.LeftMode 0 . GHC.withPprStyleDoc dflag styleUnqualified
+showUnqualifiedPage dflag = renderStyle Pretty.LeftMode 0 . GHC.withPprStyleDoc dflag styleUnqualified
 
 styleUnqualified :: GHC.PprStyle
 styleUnqualified = GHC.mkUserStyle GHC.neverQualify GHC.AllTheWay
@@ -229,7 +229,7 @@ packageDbCandidate_ = packageDbCandidate >=> maybe (return GlobalDb) return
 
 packageConfigs :: GhcM [GHC.PackageConfig]
-packageConfigs = liftM (fromMaybe [] . GHC.pkgDatabase) GHC.getSessionDynFlags
+packageConfigs = liftM (fromMaybe [] . pkgDatabase) GHC.getSessionDynFlags
 
 packageDbModules :: GhcM [(GHC.PackageConfig, GHC.Module)]
 packageDbModules = do

src/HsDev/Server/Base.hs view

@@ -40,7 +40,6 @@ import qualified HsDev.Database.Update as Update
 import HsDev.Inspect (getDefines)
 import HsDev.Tools.Ghc.Worker
-import HsDev.Tools.GhcMod (ghcModMultiWorker)
 import HsDev.Server.Types
 import HsDev.Server.Message
 import HsDev.Util
@@ -105,7 +104,6 @@ #endif
 	ghcw <- withLog (sessionLogger slog) $ ghcWorker [] (return ())
 	ghciw <- withLog (sessionLogger slog) ghciWorker
-	ghcmodw <- ghcModMultiWorker
 	defs <- getDefines
 	let
 		session = Session
@@ -119,7 +117,6 @@ #endif
 			ghcw
 			ghciw
-			ghcmodw
 			(do
 				outputStr Log.Trace "stopping server"
 				signalQSem waitSem)

src/HsDev/Server/Commands.hs view

@@ -16,8 +16,7 @@ import Control.Concurrent.Async
 import Control.Lens (set, traverseOf, view, over, Lens', Lens, _1, _2, _Left)
 import Control.Monad
-import Control.Monad.CatchIO
-import Control.Monad.Except
+import Control.Monad.Catch (bracket, finally)
 import Data.Aeson hiding (Result, Error)
 import Data.Aeson.Encode.Pretty
 import qualified Data.ByteString.Char8 as BS

src/HsDev/Server/Types.hs view

@@ -9,7 +9,6 @@ 	ServerCommand(..), ConnectionPort(..), ServerOpts(..), silentOpts, ClientOpts(..), serverOptsArgs, Request(..),
 
 	Command(..), AddedContents(..),
-	GhcModCommand(..),
 	AutoFixCommand(..),
 	FileContents(..), TargetFilter(..), SearchQuery(..), SearchType(..),
 	FromCmd(..),
@@ -20,7 +19,6 @@ import Control.Lens (each)
 import Control.Monad.Base
 import Control.Monad.Catch
-import Control.Monad.CatchIO
 import Control.Monad.Except
 import Control.Monad.Reader
 import Control.Monad.Trans.Control
@@ -42,9 +40,8 @@ import HsDev.Symbols
 import HsDev.Server.Message
 import HsDev.Watcher.Types (Watcher)
-import HsDev.Tools.GhcMod (OutputMessage, WorkerMap)
 import HsDev.Tools.Ghc.Worker (Worker, GhcM)
-import HsDev.Tools.Types (Note)
+import HsDev.Tools.Types (Note, OutputMessage)
 import HsDev.Tools.AutoFix (Correction)
 import HsDev.Util
 
@@ -52,7 +49,7 @@ import System.Win32.FileMapping.NamePool (Pool)
 #endif
 
-type ServerMonadBase m = (MonadThrow m, MonadCatch m, MonadCatchIO m, MonadBaseControl IO m, Alternative m, MonadPlus m)
+type ServerMonadBase m = (MonadIO m, MonadMask m, MonadBaseControl IO m, Alternative m, MonadPlus m)
 
 data SessionLog = SessionLog {
 	sessionLogger :: Log,
@@ -71,7 +68,6 @@ #endif
 	sessionGhc :: Worker GhcM,
 	sessionGhci :: Worker GhcM,
-	sessionGhcMod :: Worker (ReaderT WorkerMap IO),
 	sessionExit :: IO (),
 	sessionWait :: IO (),
 	sessionDefines :: [(String, String)] }
@@ -83,9 +79,9 @@ askSession f = liftM f getSession
 
 newtype ServerM m a = ServerM { runServerM :: ReaderT Session m a }
-	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadCatchIO, MonadReader Session, MonadTrans, MonadThrow, MonadCatch)
+	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadReader Session, MonadTrans, MonadThrow, MonadCatch, MonadMask)
 
-instance MonadCatchIO m => MonadLog (ServerM m) where
+instance (MonadIO m, MonadMask m) => MonadLog (ServerM m) where
 	askLog = ServerM $ asks (sessionLogger . sessionLog)
 
 instance ServerMonadBase m => SessionMonad (ServerM m) where
@@ -115,12 +111,12 @@ askOptions f = liftM f getOptions
 
 newtype ClientM m a = ClientM { runClientM :: ServerM (ReaderT CommandOptions m) a }
-	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadCatchIO, MonadThrow, MonadCatch)
+	deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadThrow, MonadCatch, MonadMask)
 
 instance MonadTrans ClientM where
 	lift = ClientM . lift . lift
 
-instance MonadCatchIO m => MonadLog (ClientM m) where
+instance (MonadIO m, MonadMask m) => MonadLog (ClientM m) where
 	askLog = ClientM askLog
 
 instance ServerMonadBase m => SessionMonad (ClientM m) where
@@ -400,9 +396,10 @@ 		typesFiles :: [FilePath],
 		typesContents :: [FileContents],
 		typesGhcOpts :: [String] } |
-	GhcMod { ghcModCommand :: GhcModCommand } |
 	AutoFix { autoFixCommand :: AutoFixCommand } |
 	GhcEval { ghcEvalExpressions :: [String] } |
+	Langs |
+	Flags |
 	Link { linkHold :: Bool } |
 	Exit
 		deriving (Show)
@@ -415,15 +412,6 @@ instance Show AddedContents where
 	show = L.unpack . encode
 
-data GhcModCommand =
-	GhcModLang |
-	GhcModFlags |
-	GhcModType Position FilePath [String] |
-	GhcModLint [FilePath] [String] |
-	GhcModCheck [FilePath] [String] |
-	GhcModCheckLint [FilePath] [String] [String]
-		deriving (Show)
-
 data AutoFixCommand =
 	AutoFixShow [Note OutputMessage] |
 	AutoFixFix [Note Correction] [Note Correction] Bool
@@ -475,16 +463,8 @@ 	paths f (Check fs fcts ghcs) = Check <$> each f fs <*> (each . paths) f fcts <*> pure ghcs
 	paths f (CheckLint fs fcts ghcs) = CheckLint <$> each f fs <*> (each . paths) f fcts <*> pure ghcs
 	paths f (Types fs fcts ghcs) = Types <$> each f fs <*> (each . paths) f fcts <*> pure ghcs
-	paths f (GhcMod g) = GhcMod <$> paths f g
 	paths _ c = pure c
 
-instance Paths GhcModCommand where
-	paths f (GhcModType pos fpath opts) = GhcModType <$> pure pos <*> f fpath <*> pure opts
-	paths f (GhcModLint fs hlints) = GhcModLint <$> traverse f fs <*> pure hlints
-	paths f (GhcModCheck fs ghcs) = GhcModCheck <$> traverse f fs <*> pure ghcs
-	paths f (GhcModCheckLint fs ghcs hlints) = GhcModCheckLint <$> traverse f fs <*> pure ghcs <*> pure hlints
-	paths _ g = pure g
-
 instance Paths FileContents where
 	paths f (FileContents fpath cts) = FileContents <$> f fpath <*> pure cts
 
@@ -542,21 +522,13 @@ 		cmd "check" "check source files or file contents" (Check <$> many fileArg <*> many cmdP <*> ghcOpts),
 		cmd "check-lint" "check and lint source files or file contents" (CheckLint <$> many fileArg <*> many cmdP <*> ghcOpts),
 		cmd "types" "get types for file expressions" (Types <$> many fileArg <*> many cmdP <*> ghcOpts),
-		cmd "ghc-mod" "ghc-mod commands" (GhcMod <$> cmdP),
 		cmd "autofix" "autofix commands" (AutoFix <$> cmdP),
 		cmd "ghc" "ghc commands" (subparser $ cmd "eval" "evaluate expression" (GhcEval <$> many (strArgument idm))),
+		cmd "langs" "ghc language options" (pure Langs),
+		cmd "flags" "ghc flags" (pure Flags),
 		cmd "link" "link to server" (Link <$> holdFlag),
 		cmd "exit" "exit" (pure Exit)]
 
-instance FromCmd GhcModCommand where
-	cmdP = subparser $ mconcat [
-		cmd "lang" "get LANGUAGE pragmas" (pure GhcModLang),
-		cmd "flags" "get OPTIONS_GHC pragmas" (pure GhcModFlags),
-		cmd "type" "infer type with 'ghc-mod type'" (GhcModType <$> (Position <$> argument auto idm <*> argument auto idm) <*> fileArg <*> ghcOpts),
-		cmd "lint" "lint source files" (GhcModLint <$> many (strArgument idm) <*> hlintOpts),
-		cmd "check" "check source files" (GhcModCheck <$> many (strArgument idm) <*> ghcOpts),
-		cmd "check-lint" "check & lint source files" (GhcModCheckLint <$> many (strArgument idm) <*> ghcOpts <*> hlintOpts)]
-
 instance FromCmd AutoFixCommand where
 	cmdP = subparser $ mconcat [
 		cmd "show" "generate corrections for check & lint messages" (AutoFixShow <$> option readJSON (long "data" <> metavar "message" <> help "messages to make fixes for")),
@@ -602,7 +574,6 @@ globalFlag :: Parser Bool
 hayooPageArg :: Parser Int
 hayooPagesArg :: Parser Int
-hlintOpts :: Parser [String]
 holdFlag :: Parser Bool
 inferFlag :: Parser Bool
 localsFlag :: Parser Bool
@@ -626,7 +597,6 @@ globalFlag = switch (long "global" <> help "scope of project")
 hayooPageArg = option auto (long "page" <> metavar "n" <> short 'p' <> help "page number (0 by default)" <> value 0)
 hayooPagesArg = option auto (long "pages" <> metavar "count" <> short 'n' <> help "pages count (1 by default)" <> value 1)
-hlintOpts = many (strOption (long "hlint" <> metavar "option" <> short 'h' <> help "options to pass to hlint"))
 holdFlag = switch (long "hold" <> short 'h' <> help "don't return any response")
 inferFlag = switch (long "infer" <> help "infer types")
 localsFlag = switch (long "locals" <> short 'l' <> help "look in local declarations")
@@ -682,9 +652,10 @@ 	toJSON (Check fs cs ghcs) = cmdJson "check" ["files" .= fs, "contents" .= cs, "ghc-opts" .= ghcs]
 	toJSON (CheckLint fs cs ghcs) = cmdJson "check-lint" ["files" .= fs, "contents" .= cs, "ghc-opts" .= ghcs]
 	toJSON (Types fs cs ghcs) = cmdJson "types" ["files" .= fs, "contents" .= cs, "ghc-opts" .= ghcs]
-	toJSON (GhcMod gcmd) = toJSON gcmd
 	toJSON (AutoFix acmd) = toJSON acmd
 	toJSON (GhcEval exprs) = cmdJson "ghc eval" ["exprs" .= exprs]
+	toJSON Langs = cmdJson "langs" []
+	toJSON Flags = cmdJson "flags" []
 	toJSON (Link h) = cmdJson "link" ["hold" .= h]
 	toJSON Exit = cmdJson "exit" []
 
@@ -732,9 +703,10 @@ 		guardCmd "check" v *> (Check <$> v .::?! "files" <*> v .::?! "contents" <*> v .::?! "ghc-opts"),
 		guardCmd "check-lint" v *> (CheckLint <$> v .::?! "files" <*> v .::?! "contents" <*> v .::?! "ghc-opts"),
 		guardCmd "types" v *> (Types <$> v .::?! "files" <*> v .::?! "contents" <*> v .::?! "ghc-opts"),
-		GhcMod <$> parseJSON (Object v),
 		AutoFix <$> parseJSON (Object v),
 		guardCmd "ghc eval" v *> (GhcEval <$> v .::?! "exprs"),
+		guardCmd "langs" v *> pure Langs,
+		guardCmd "flags" v *> pure Flags,
 		guardCmd "link" v *> (Link <$> (v .:: "hold" <|> pure False)),
 		guardCmd "exit" v *> pure Exit]
 
@@ -748,23 +720,6 @@ 		AddedDatabase <$> v .:: "database",
 		AddedModule <$> v .:: "module",
 		AddedProject <$> v .:: "project"]
-
-instance ToJSON GhcModCommand where
-	toJSON GhcModLang = cmdJson "ghc-mod lang" []
-	toJSON GhcModFlags = cmdJson "ghc-mod flags" []
-	toJSON (GhcModType pos f ghcs) = cmdJson "ghc-mod type" ["position" .= pos, "file" .= f, "ghc-opts" .= ghcs]
-	toJSON (GhcModLint fs lints) = cmdJson "ghc-mod lint" ["files" .= fs, "hlint-opts" .= lints]
-	toJSON (GhcModCheck fs ghcs) = cmdJson "ghc-mod check" ["files" .= fs, "ghc-opts" .= ghcs]
-	toJSON (GhcModCheckLint fs ghcs lints) = cmdJson "ghc-mod check-lint" ["files" .= fs, "ghc-opts" .= ghcs, "hlint-opts" .= lints]
-
-instance FromJSON GhcModCommand where
-	parseJSON = withObject "ghc-mod-command" $ \v -> asum [
-		guardCmd "ghc-mod lang" v *> pure GhcModLang,
-		guardCmd "ghc-mod flags" v *> pure GhcModFlags,
-		guardCmd "ghc-mod type" v *> (GhcModType <$> v .:: "position" <*> v .:: "file" <*> v .::?! "ghc-opts"),
-		guardCmd "ghc-mod lint" v *> (GhcModLint <$> v .:: "files" <*> v .::?! "hlint-opts"),
-		guardCmd "ghc-mod check" v *> (GhcModCheck <$> v .:: "files" <*> v .::?! "ghc-opts"),
-		guardCmd "ghc-mod check-lint" v *> (GhcModCheckLint <$> v .:: "files" <*> v .::?! "ghc-opts" <*> v .::?! "hlint-opts")]
 
 instance ToJSON AutoFixCommand where
 	toJSON (AutoFixShow ns) = cmdJson "autofix show" ["messages" .= ns]

src/HsDev/Stack.hs view

@@ -16,7 +16,6 @@ import Control.Arrow
 import Control.Lens (makeLenses, Lens', at, ix, lens, (^?), (^.))
 import Control.Monad
-import Control.Monad.Catch (MonadCatch(..))
 import Control.Monad.Trans.Maybe
 import Control.Monad.IO.Class
 import Data.Char
@@ -32,13 +31,13 @@ import System.Process
 import System.Log.Simple (MonadLog(..))
 
-import qualified GHC
 import qualified Packages as GHC
 
 import HsDev.Error
 import HsDev.PackageDb
+import qualified HsDev.Tools.Ghc.Compat as Compat
 import HsDev.Scan.Browse (withPackages)
-import HsDev.Util (withCurrentDirectory)
+import HsDev.Util as Util
 
 -- | Get compiler version
 stackCompiler :: MonadLog m => m String
@@ -47,11 +46,11 @@ 		return .
 		map (GHC.packageNameString &&& GHC.packageVersion) .
 		fromMaybe [] .
-		GHC.pkgDatabase
+		Compat.pkgDatabase
 	let
 		compiler = T.display buildCompilerFlavor
-		CompilerId _ version = buildCompilerId
-		ver = maybe (T.display version) T.display $ lookup compiler res
+		CompilerId _ version' = buildCompilerId
+		ver = maybe (T.display version') T.display $ lookup compiler res
 	return $ compiler ++ "-" ++ ver
 
 -- | Get arch for stack
@@ -59,13 +58,13 @@ stackArch = T.display buildArch
 
 -- | Invoke stack command, we are trying to get actual stack near current hsdev executable
-stack :: (MonadLog m, MonadCatch m) => [String] -> m String
-stack cmd = hsdevLiftIO $ do
+stack :: MonadLog m => [String] -> m String
+stack cmd' = hsdevLiftIO $ do
 	curExe <- liftIO getExecutablePath
-	withCurrentDirectory (takeDirectory curExe) $ do
+	Util.withCurrentDirectory (takeDirectory curExe) $ do
 		stackExe <- liftIO (findExecutable "stack") >>= maybe (hsdevError $ ToolNotFound "stack") return
 		comp <- stackCompiler
-		liftIO $ readProcess stackExe (cmd ++ ["--compiler", comp, "--arch", stackArch]) ""
+		liftIO $ readProcess stackExe (cmd' ++ ["--compiler", comp, "--arch", stackArch]) ""
 
 -- | Make yaml opts
 yaml :: Maybe FilePath -> [String]
@@ -75,7 +74,7 @@ type Paths = Map String FilePath
 
 -- | Stack path
-path :: (MonadLog m, MonadCatch m) => Maybe FilePath -> m Paths
+path :: MonadLog m => Maybe FilePath -> m Paths
 path mcfg = liftM (M.fromList . map breakPath . lines) $ stack ("path" : yaml mcfg) where
 	breakPath :: String -> (String, FilePath)
 	breakPath = second (dropWhile isSpace . drop 1) . break (== ':')
@@ -85,15 +84,15 @@ pathOf = at
 
 -- | Build stack project
-build :: (MonadLog m, MonadCatch m) => [String] -> Maybe FilePath -> m ()
+build :: MonadLog m => [String] -> Maybe FilePath -> m ()
 build opts mcfg = void $ stack $ "build" : (opts ++ yaml mcfg)
 
 -- | Build only dependencies
-buildDeps :: (MonadLog m, MonadCatch m) => Maybe FilePath -> m ()
+buildDeps :: MonadLog m => Maybe FilePath -> m ()
 buildDeps = build ["--only-dependencies"]
 
 -- | Configure project
-configure :: (MonadLog m, MonadCatch m) => Maybe FilePath -> m ()
+configure :: MonadLog m => Maybe FilePath -> m ()
 configure = build ["--only-configure"]
 
 data StackEnv = StackEnv {
@@ -108,7 +107,7 @@ 
 getStackEnv :: Paths -> Maybe StackEnv
 getStackEnv p = StackEnv <$>
-	(p ^. pathOf "global-stack-root") <*>
+	(p ^. pathOf "stack-root") <*>
 	(p ^. pathOf "project-root") <*>
 	(p ^. pathOf "config-location") <*>
 	(p ^. pathOf "ghc-paths") <*>
@@ -116,7 +115,7 @@ 	(p ^. pathOf "local-pkg-db")
 
 -- | Projects paths
-projectEnv :: (MonadLog m, MonadCatch m) => FilePath -> m StackEnv
+projectEnv :: MonadLog m => FilePath -> m StackEnv
 projectEnv p = hsdevLiftIO $ do
 	hasConfig <- liftIO $ doesFileExist yaml'
 	unless hasConfig $ hsdevError $ FileNotFound yaml'

src/HsDev/Symbols/Resolve.hs view

@@ -59,7 +59,7 @@ 	isTop = any (not . view importIsQualified) . fromMaybe [] . view declarationImported
 
 -- | Resolve modules, function is not IO, so all file names must be canonicalized
-resolve :: (Traversable t, Foldable t) => Database -> t Module -> t ResolvedModule
+resolve :: Traversable t => Database -> t Module -> t ResolvedModule
 resolve db = flip evalState M.empty . flip runReaderT (db, m) . runResolveM . traverse resolveModule where
 	m :: ModuleMap
 	m = M.fromList $ map ((view moduleName . head) &&& id) $

src/HsDev/Symbols/Types.hs view

@@ -511,7 +511,7 @@ 	rnf (Inspected t i ts r) = rnf t `seq` rnf i `seq` rnf ts `seq` rnf r
 
 -- | Empty tags
-noTags :: Ord t => Set t
+noTags :: Set t
 noTags = S.empty
 
 data ModuleTag = InferredTypesTag | RefinedDocsTag deriving (Eq, Ord, Read, Show, Enum, Bounded)

src/HsDev/Symbols/Util.hs view

@@ -152,7 +152,7 @@ 		mpackage _ = Nothing
 		pname = fmap (view packageName) . fst
 		pver = fmap (view packageVersion) . fst
-		groupPackages :: Symbol a => [(Maybe ModulePackage, a)] -> [(Maybe ModulePackage, [a])]
+		groupPackages :: [(Maybe ModulePackage, a)] -> [(Maybe ModulePackage, [a])]
 		groupPackages = map (first head . unzip) . groupBy ((==) `on` fst) . sortBy (comparing fst)
 		selectNewest :: [(Maybe ModulePackage, [a])] -> [a]
 		selectNewest =

src/HsDev/Tools/ClearImports.hs view

@@ -22,6 +22,7 @@ import GHC.Paths (libdir)
 
 import HsDev.Util
+import HsDev.Tools.Ghc.Compat
 
 -- | Dump minimal imports
 dumpMinimalImports :: [String] -> FilePath -> ExceptT String IO String
@@ -48,7 +49,7 @@ 				hiDir = Just cur }
 		(df'', _, _) <- parseDynamicFlags df' (map noLoc ("-ddump-minimal-imports" : opts))
 		_ <- setSessionDynFlags df''
-		defaultCleanupHandler df'' $ do
+		cleanupHandler df'' $ do
 			t <- guessTarget file Nothing
 			setTargets [t]
 			load LoadAllTargets

src/HsDev/Tools/Ghc/Check.hs view

@@ -15,7 +15,6 @@ 
 import Control.Lens (preview, view, each, _Just, (^..))
 import Control.Monad.Except
-import Control.Monad.Catch (MonadThrow(..))
 import Data.Maybe (fromMaybe)
 import System.FilePath (makeRelative)
 import System.Directory (doesDirectoryExist)
@@ -32,6 +31,7 @@ import HsDev.Symbols.Types
 import HsDev.Tools.Base
 import HsDev.Tools.Ghc.Worker
+import HsDev.Tools.Ghc.Compat
 import HsDev.Tools.Types
 import HsDev.Util (readFileUtf8, ordNub)
 
@@ -40,7 +40,7 @@ checkFiles opts pdbs files _ = scope "check-files" $ do
 	ch <- liftIO newChan
 	withFlags $ do
-		modifyFlags (\fs -> fs { log_action = logToChan ch })
+		modifyFlags $ setLogAction $ logToChan ch
 		_ <- setCmdOpts ("-Wall" : (packageDbStackOpts pdbs ++ opts))
 		clearTargets
 		mapM (`makeTarget` Nothing) files >>= loadTargets
@@ -48,7 +48,7 @@ 	liftIO $ recalcNotesTabs notes
 
 -- | Check module source
-check :: (MonadLog m, GhcMonad m, MonadThrow m) => [String] -> PackageDbStack -> Module -> Maybe String -> m [Note OutputMessage]
+check :: (MonadLog m, GhcMonad m) => [String] -> PackageDbStack -> Module -> Maybe String -> m [Note OutputMessage]
 check opts pdbs m msrc = scope "check" $ case view moduleLocation m of
 	FileModule file proj -> do
 		ch <- liftIO newChan
@@ -64,7 +64,7 @@ 				packageDbStackOpts pdbs,
 				moduleOpts pkgs m,
 				opts]
-			modifyFlags (\fs -> fs { log_action = logToChan ch })
+			modifyFlags $ setLogAction $ logToChan ch
 			clearTargets
 			target <- makeTarget (makeRelative dir file) msrc
 			loadTargets [target]
@@ -73,11 +73,11 @@ 	_ -> scope "check" $ hsdevError $ ModuleNotSource (view moduleLocation m)
 
 -- | Check module and collect warnings and errors
-checkFile :: (MonadLog m, GhcMonad m, MonadThrow m) => [String] -> PackageDbStack -> Module -> m [Note OutputMessage]
+checkFile :: (MonadLog m, GhcMonad m) => [String] -> PackageDbStack -> Module -> m [Note OutputMessage]
 checkFile opts pdbs m = check opts pdbs m Nothing
 
 -- | Check module and collect warnings and errors
-checkSource :: (MonadLog m, GhcMonad m, MonadThrow m) => [String] -> PackageDbStack -> Module -> String -> m [Note OutputMessage]
+checkSource :: (MonadLog m, GhcMonad m) => [String] -> PackageDbStack -> Module -> String -> m [Note OutputMessage]
 checkSource opts pdbs m src = check opts pdbs m (Just src)
 
 -- Recalc tabs for notes

+ src/HsDev/Tools/Ghc/Compat.hs view

@@ -0,0 +1,106 @@+{-# LANGUAGE CPP #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Tools.Ghc.Compat (
+	pkgDatabase, UnitId, unitId, depends, getPackageDetails, patSynType, cleanupHandler, renderStyle,
+	LogAction, setLogAction,
+	languages, flags
+	) where
+
+import qualified DynFlags as GHC
+import qualified ErrUtils
+import qualified GHC
+import qualified Module
+import qualified Packages as GHC
+import qualified PatSyn as GHC
+import qualified Pretty
+
+#if __GLASGOW_HASKELL__ == 710
+import Exception (ExceptionMonad)
+import Control.Monad.Reader
+#endif
+
+pkgDatabase :: GHC.DynFlags -> Maybe [GHC.PackageConfig]
+#if __GLASGOW_HASKELL__ == 800
+pkgDatabase = fmap (concatMap snd) . GHC.pkgDatabase
+#elif __GLASGOW_HASKELL__ == 710
+pkgDatabase = GHC.pkgDatabase
+#endif
+
+#if __GLASGOW_HASKELL__ == 800
+type UnitId = Module.UnitId
+#elif __GLASGOW_HASKELL__ == 710
+type UnitId = Module.PackageKey
+#endif
+
+unitId :: GHC.PackageConfig -> UnitId
+#if __GLASGOW_HASKELL__ == 800
+unitId = GHC.unitId
+#elif __GLASGOW_HASKELL__ == 710
+unitId = GHC.packageKey
+#endif
+
+depends :: GHC.DynFlags -> GHC.PackageConfig -> [UnitId]
+#if __GLASGOW_HASKELL__ == 800
+depends _ = GHC.depends
+#elif __GLASGOW_HASKELL__ == 710
+depends df = map (GHC.resolveInstalledPackageId df) . GHC.depends
+#endif
+
+getPackageDetails :: GHC.DynFlags -> UnitId -> GHC.PackageConfig
+getPackageDetails = GHC.getPackageDetails
+
+patSynType :: GHC.PatSyn -> GHC.Type
+patSynType p = GHC.patSynInstResTy p (GHC.patSynArgs p)
+
+#if __GLASGOW_HASKELL__ == 800
+cleanupHandler :: GHC.DynFlags -> m a -> m a
+cleanupHandler _ = id
+#elif __GLASGOW_HASKELL__ == 710
+cleanupHandler :: (ExceptionMonad m) => GHC.DynFlags -> m a -> m a
+cleanupHandler = GHC.defaultCleanupHandler
+#endif
+
+renderStyle :: Pretty.Mode -> Int -> Pretty.Doc -> String
+#if __GLASGOW_HASKELL__ == 800
+renderStyle m cols = Pretty.renderStyle (Pretty.Style m cols 1.5)
+#elif __GLASGOW_HASKELL__ == 710
+renderStyle = Pretty.showDoc
+#endif
+
+type LogAction = GHC.DynFlags -> GHC.Severity -> GHC.SrcSpan -> ErrUtils.MsgDoc -> IO ()
+
+setLogAction :: LogAction -> GHC.DynFlags -> GHC.DynFlags
+setLogAction act fs = fs { GHC.log_action = act' } where
+	act' :: GHC.LogAction
+#if __GLASGOW_HASKELL__ == 800
+	act' df _ sev src _ msg = act df sev src msg
+#elif __GLASGOW_HASKELL__ == 710
+	act' df sev src _ msg = act df sev src msg
+#endif
+
+#if __GLASGOW_HASKELL__ == 710
+instance (Monad m, GHC.HasDynFlags m) => GHC.HasDynFlags (ReaderT r m) where
+	getDynFlags = lift GHC.getDynFlags
+#endif
+
+flags :: [String]
+#if __GLASGOW_HASKELL__ >= 800
+flags = concat [
+	[option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags],
+	[option | (GHC.FlagSpec option _ _ _) <- GHC.wWarningFlags],
+	[option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]]
+#elif __GLASGOW_HASKELL__ >= 710
+flags = concat [
+	[option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags],
+	[option | (GHC.FlagSpec option _ _ _) <- GHC.fWarningFlags],
+	[option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]]
+#elif __GLASGOW_HASKELL__ >= 704
+flags = concat [
+	[option | (option, _, _) <- GHC.fFlags],
+	[option | (option, _, _) <- GHC.fWarningFlags],
+	[option | (option, _, _) <- GHC.fLangFlags]]
+#endif
+
+languages :: [String]
+languages = GHC.supportedLanguagesAndExtensions

src/HsDev/Tools/Ghc/Types.hs view

@@ -9,7 +9,6 @@ import Control.DeepSeq
 import Control.Lens (over, view, set, each, preview, makeLenses, _Just)
 import Control.Monad
-import Control.Monad.Catch (MonadThrow(..))
 import Control.Monad.IO.Class
 import Data.Aeson
 import Data.Generics
@@ -28,16 +27,17 @@ import TcHsSyn (hsPatType)
 import Outputable
 import PprTyThing
-import Pretty
+import qualified Pretty
 
 import System.Directory.Paths (canonicalize)
 import HsDev.Error
 import HsDev.Scan.Browse (browsePackages)
 import HsDev.PackageDb
 import HsDev.Symbols
-import HsDev.Tools.Ghc.Worker
+import HsDev.Tools.Ghc.Worker as Ghc
+import HsDev.Tools.Ghc.Compat
 import HsDev.Tools.Types
-import HsDev.Util hiding (withCurrentDirectory)
+import HsDev.Util
 
 class HasType a where
 	getType :: GhcMonad m => TypecheckedModule -> a -> m (Maybe (SrcSpan, Type))
@@ -101,7 +101,7 @@ 		v .:: "type"
 
 -- | Get all types in module
-fileTypes :: (MonadLog m, GhcMonad m, MonadThrow m) => [String] -> PackageDbStack -> Module -> Maybe String -> m [Note TypedExpr]
+fileTypes :: (MonadLog m, GhcMonad m) => [String] -> PackageDbStack -> Module -> Maybe String -> m [Note TypedExpr]
 fileTypes opts pdbs m msrc = scope "types" $ case view moduleLocation m of
 	FileModule file proj -> do
 		file' <- liftIO $ canonicalize file
@@ -112,7 +112,7 @@ 				(sourceModuleRoot (view moduleName m) file') $
 				preview (_Just . projectPath) proj
 		dirExist <- liftIO $ doesDirectoryExist dir
-		withFlags $ (if dirExist then withCurrentDirectory dir else id) $ do
+		withFlags $ (if dirExist then Ghc.withCurrentDirectory dir else id) $ do
 			_ <- setCmdOpts $ concat [
 				packageDbStackOpts pdbs,
 				moduleOpts pkgs m,
@@ -133,7 +133,7 @@ 		setExpr :: String -> Note String -> Note TypedExpr
 		setExpr cts n = over note (TypedExpr (regionStr (view noteRegion n) cts)) n
 		showType :: DynFlags -> Type -> String
-		showType df = showDoc OneLineMode 80 . withPprStyleDoc df unqualStyle . pprTypeForUser
+		showType df = renderStyle Pretty.OneLineMode 80 . withPprStyleDoc df unqualStyle . pprTypeForUser
 		unqualStyle :: PprStyle
 		unqualStyle = mkUserStyle neverQualify AllTheWay
 
@@ -147,5 +147,5 @@ 		return $ set (declaration . functionType) (Just $ fromString $ view (note . typedType) tnote) d
 
 -- | Infer types in module
-inferTypes :: (MonadLog m, GhcMonad m, MonadThrow m) => [String] -> PackageDbStack -> Module -> Maybe String -> m Module
+inferTypes :: (MonadLog m, GhcMonad m) => [String] -> PackageDbStack -> Module -> Maybe String -> m Module
 inferTypes opts pdbs m msrc = scope "infer" $ liftM (`setModuleTypes` m) $ fileTypes opts pdbs m msrc

src/HsDev/Tools/Ghc/Worker.hs view

@@ -23,7 +23,6 @@ 
 import Control.Monad
 import Control.Monad.Catch
-import Control.Monad.CatchIO
 import Control.Monad.Except
 import Control.Monad.Reader
 import Data.Dynamic
@@ -39,12 +38,11 @@ import Text.Format
 
 import Exception (ExceptionMonad(..))
-import GHC hiding (Warning, Module, moduleName)
+import GHC hiding (Warning, Module, moduleName, pkgDatabase)
 import GhcMonad (Ghc(..))
 import GHC.Paths
 import DynFlags (HasDynFlags(..))
 import Outputable
-import qualified ErrUtils as E
 import FastString (unpackFS)
 
 import Control.Concurrent.FiniteChan
@@ -52,6 +50,7 @@ import System.Directory.Paths
 import HsDev.Symbols.Location (Position(..), Region(..), region, ModulePackage, ModuleLocation(..))
 import HsDev.Tools.Types
+import HsDev.Tools.Ghc.Compat
 
 instance MonadThrow Ghc where
 	throwM = liftIO . throwM
@@ -59,24 +58,24 @@ instance MonadCatch Ghc where
 	catch = gcatch
 
-instance MonadCatchIO Ghc where
-	catch = gcatch
-	block act = Ghc $ block . unGhc act
-	unblock act = Ghc $ unblock . unGhc act
+instance MonadMask Ghc where
+	mask f = Ghc $ \s -> mask $ \g -> unGhc (f $ q g) s where
+		q :: (IO a -> IO a) -> Ghc a -> Ghc a
+		q g' act = Ghc $ g' . unGhc act
+	uninterruptibleMask f = Ghc $ \s -> uninterruptibleMask $ \g -> unGhc (f $ q g) s where
+		q :: (IO a -> IO a) -> Ghc a -> Ghc a
+		q g' act = Ghc $ g' . unGhc act
 
 instance ExceptionMonad m => ExceptionMonad (ReaderT r m) where
 	gcatch act onError = ReaderT $ \v -> gcatch (runReaderT act v) (flip runReaderT v . onError)
 	gmask f = ReaderT $ \v -> gmask (\h -> flip runReaderT v (f $ \act -> ReaderT (\v' -> h (runReaderT act v'))))
 
-instance (Monad m, HasDynFlags m) => HasDynFlags (ReaderT r m) where
-	getDynFlags = lift getDynFlags
-
 instance (Monad m, GhcMonad m) => GhcMonad (ReaderT r m) where
 	getSession = lift getSession
 	setSession = lift . setSession
 
 newtype GhcM a = GhcM { unGhcM :: ReaderT Log.Log Ghc a }
-	deriving (Functor, Applicative, Monad, MonadIO, MonadCatchIO, MonadThrow, MonadCatch, ExceptionMonad, HasDynFlags, MonadLog, GhcMonad)
+	deriving (Functor, Applicative, Monad, MonadIO, MonadMask, MonadThrow, MonadCatch, ExceptionMonad, HasDynFlags, MonadLog, GhcMonad)
 
 runGhcM :: MonadLog m => Maybe FilePath -> GhcM a -> m a
 runGhcM dir act = do
@@ -102,7 +101,7 @@ ghcRun :: GhcMonad m => [String] -> m a -> m a
 ghcRun opts f = do
 	fs <- getSessionDynFlags
-	defaultCleanupHandler fs $ do
+	cleanupHandler fs $ do
 		(fs', _, _) <- parseDynamicFlags fs (map noLoc opts)
 		let fs'' = fs' {
 			ghcMode = CompManager,
@@ -147,7 +146,7 @@ 	Log.log Log.Trace $ "restarting ghc session with: {}" ~~ unwords opts
 	initGhcMonad (Just libdir)
 	addCmdOpts opts
-	modifyFlags (\fs -> fs { log_action = logToNull })
+	modifyFlags $ setLogAction logToNull
 
 -- | Import some modules
 importModules :: GhcMonad m => [String] -> m ()
@@ -197,8 +196,8 @@ 
 -- | Log  ghc warnings and errors as to chan
 -- You may have to apply recalcTabs on result notes
-logToChan :: Chan (Note OutputMessage) -> DynFlags -> E.Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
-logToChan ch fs sev src _ msg
+logToChan :: Chan (Note OutputMessage) -> LogAction
+logToChan ch fs sev src msg
 	| Just sev' <- checkSev sev = do
 		src' <- canonicalize srcMod
 		putChan ch $ Note {
@@ -219,7 +218,7 @@ 			_ -> ModuleSource Nothing
 
 -- | Don't log ghc warnings and errors
-logToNull :: DynFlags -> E.Severity -> SrcSpan -> PprStyle -> SDoc -> IO ()
-logToNull _ _ _ _ _ = return ()
+logToNull :: LogAction
+logToNull _ _ _ _ = return ()
 
 -- TODO: Load target by @ModuleLocation@, which may cause updating @DynFlags@

− src/HsDev/Tools/GhcMod.hs

@@ -1,320 +0,0 @@-{-# LANGUAGE OverloadedStrings, ConstraintKinds, FlexibleContexts, LambdaCase, FlexibleInstances #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module HsDev.Tools.GhcMod (
-	list,
-	browse, browseInspection,
-	langs, flags,
-	info,
-	TypedRegion(..),
-	typeOf,
-	OutputMessage(..),
-	parseOutputMessages, parseOutputMessage,
-	check,
-	lint,
-
-	runGhcMod,
-
-	locateGhcModEnv, ghcModEnvPath,
-	ghcModWorker,
-	WorkerMap,
-	ghcModMultiWorker, dispatch,
-	waitMultiGhcMod,
-
-	GhcModT,
-	module Control.Concurrent.Worker,
-
-	module Control.Monad.Except,
-	module HsDev.Tools.Types
-	) where
-
-import Control.Applicative
-import Control.Arrow
-import Control.Concurrent
-import Control.DeepSeq
-import Control.Exception (SomeException(..), displayException)
-import Control.Lens (view, preview, _Just, over)
-import Control.Monad.Except
-import Control.Monad.Catch (MonadThrow(..), MonadCatch(..))
-import Control.Monad.Reader
-import Data.Aeson hiding (Error)
-import Data.Char
-import Data.List (sort)
-import Data.Maybe
-import qualified Data.Map as M
-import Data.String (fromString)
-import Exception (gcatch)
-import System.Directory
-import System.FilePath (normalise)
-import System.Log.Simple (withNoLog)
-import Text.Read (readMaybe)
-
-import Language.Haskell.GhcMod (GhcModT, withOptions)
-import qualified Language.Haskell.GhcMod as GhcMod
-import qualified Language.Haskell.GhcMod.Monad as GhcMod
-import qualified Language.Haskell.GhcMod.Types as GhcMod
-
-import Control.Concurrent.Worker
-import HsDev.Error
-import HsDev.PackageDb
-import HsDev.Project
-import HsDev.Sandbox (searchPackageDbStack)
-import HsDev.Symbols
-import HsDev.Tools.Base
-import HsDev.Tools.Types
-import HsDev.Util ((.::), liftIOErrors, liftThrow, readFileUtf8, ordNub)
-
--- FIXME: Pass package-db stack options to ghc-mod
-list :: [String] -> PackageDbStack -> ExceptT String IO [ModuleLocation]
-list opts pdbs = runGhcMod (GhcMod.defaultOptions { GhcMod.optGhcUserOptions = opts }) $ do
-	ms <- (map splitPackage . lines) <$> GhcMod.modules True
-	return [InstalledModule (topPackageDb pdbs) (readMaybe p) m | (m, p) <- ms]
-	where
-		splitPackage :: String -> (String, String)
-		splitPackage = second (drop 1) . break isSpace
-
--- FIXME: Pass package-db stack options to ghc-mod
-browse :: [String] -> PackageDbStack -> String -> Maybe ModulePackage -> ExceptT String IO InspectedModule
-browse opts pdbs mname mpackage = inspect thisLoc (return $ browseInspection opts) $ runGhcMod
-	(GhcMod.defaultOptions { GhcMod.optGhcUserOptions = packageOpt mpackage ++ opts }) $ do
-		ds <- (mapMaybe parseDecl . lines) <$> GhcMod.browse
-			(GhcMod.defaultBrowseOpts {
-				GhcMod.optBrowseDetailed = True,
-				GhcMod.optBrowseQualified = True })
-			mpkgname
-		return Module {
-			_moduleName = fromString mname,
-			_moduleDocs = Nothing,
-			_moduleLocation = thisLoc,
-			_moduleExports = Just [ExportName Nothing (view declarationName d) ThingNothing | d <- ds],
-			_moduleImports = [import_ iname |
-				iname <- ordNub (mapMaybe (preview definedModule) ds),
-				iname /= fromString mname],
-			_moduleDeclarations = sortDeclarations ds }
-	where
-		mpkgname = maybe mname (\p -> view packageName p ++ ":" ++ mname) mpackage
-		thisLoc = view moduleIdLocation $ mloc mname
-		mloc mname' = ModuleId (fromString mname') $ InstalledModule (topPackageDb pdbs) Nothing mname'
-		parseDecl s = do
-			groups <- matchRx rx s
-			let
-				rdecl = decl (fromString $ groups `at` 3) $ case groups 5 of
-					Nothing -> Function (Just $ fromString $ groups `at` 4) [] Nothing
-					Just k -> declarationTypeCtor k $
-						TypeInfo Nothing (maybe [] (map fromString . words) $ groups 7) Nothing []
-			return $ rdecl `definedIn` mloc (init $ groups `at` 1)
-		definedModule = declarationDefined . _Just . moduleIdName
-		-- groups:
-		-- 1: "<module>."
-		-- 3: "<name>"
-		-- 4: "<type>" or "<rest>"
-		-- 5: "<kind>" (class, type, data or newtype)
-		-- 6: "<name>"
-		-- 7: " <args>"
-		rx = "^((\\w+\\.)*)(\\w+)\\s+::\\s+((class|type|data|newtype)\\s+(\\w+)((\\s+\\w+)*)?|.*)$"
-
-browseInspection :: [String] -> Inspection
-browseInspection = InspectionAt 0 . sort . ordNub
-
-langs :: ExceptT String IO [String]
-langs = runGhcMod GhcMod.defaultOptions $ (lines . nullToNL) <$> GhcMod.languages
-
-flags :: ExceptT String IO [String]
-flags = runGhcMod GhcMod.defaultOptions $ (lines . nullToNL) <$> GhcMod.flags
-
--- FIXME: Detect actual package-db for module
-info :: [String] -> PackageDbStack -> FilePath -> String -> GhcModT IO Declaration
-info opts pdbs file sname = do
-	fileCts <- liftIO $ readFileUtf8 file
-	rs <- withOptions (\o -> o { GhcMod.optGhcUserOptions = packageDbStackOpts pdbs ++ opts }) $
-		liftM nullToNL $ GhcMod.info file (GhcMod.Expression sname)
-	toDecl fileCts rs
-	where
-		toDecl fstr s =
-			liftM (recalcDeclTabs fstr) .
-			maybe (throwError $ GhcMod.GMEString $ "Can't parse info: '" ++ sname ++ "'") return $
-			parseData s `mplus` parseFunction s
-		recalcDeclTabs :: String -> Declaration -> Declaration
-		recalcDeclTabs fstr = over (declarationPosition . _Just) (recalcTabs fstr 8)
-		parseFunction s = do
-			groups <- matchRx (sname ++ "\\s+::\\s+(.*?)(\\s+-- Defined (at (.*)|in `(.*)'))?$") s
-			return (decl (fromString sname) (Function (Just $ fromString $ groups `at` 1) [] Nothing)) {
-				_declarationDefined = unnamedModuleId <$>
-					((groups 4 >>= parseSrc) <|> (mkMod <$> groups 5)),
-				_declarationPosition = groups 4 >>= parsePos }
-		parseData s = do
-			groups <- matchRx "(newtype|type|data)\\s+((.*)=>\\s+)?(\\S+)\\s+((\\w+\\s+)*)=(\\s*(.*)\\s+-- Defined (at (.*)|in `(.*)'))?" s
-			let
-				args = maybe [] (map fromString . words) $ groups 5
-				ctx = fmap (fromString . trim) $ groups 3
-				def = fmap fromString $ groups 8
-			return (decl (fromString sname) (declarationTypeCtor (groups `at` 1) $ TypeInfo ctx args def [])) {
-				_declarationDefined = unnamedModuleId <$>
-					((groups 10 >>= parseSrc) <|> (mkMod <$> groups 11)),
-				_declarationPosition = groups 10 >>= parsePos }
-		parseSrc src = case splitRx ":(?=\\d)" src of
-			[srcFile, _, _] -> Just $ FileModule srcFile Nothing
-			_ -> Nothing
-		parsePos src = case splitRx ":(?=\\d)" src of
-			[_, line, column] ->  Position <$> readMaybe line <*> readMaybe column
-			_ -> Nothing
-		mkMod = InstalledModule (topPackageDb pdbs) Nothing
-		trim = p . p where
-			p = reverse . dropWhile isSpace
-
-data TypedRegion = TypedRegion {
-	typedRegion :: Region,
-	typedExpr :: String,
-	typedType :: String }
-		deriving (Eq, Ord, Read, Show)
-
-instance NFData TypedRegion where
-	rnf (TypedRegion r e t) = rnf r `seq` rnf e `seq` rnf t
-
-instance ToJSON TypedRegion where
-	toJSON (TypedRegion r e t) = object [
-		"region" .= r,
-		"expr" .= e,
-		"type" .= t]
-
-instance FromJSON TypedRegion where
-	parseJSON = withObject "typed region" $ \v -> TypedRegion <$>
-		v .:: "region" <*>
-		v .:: "expr" <*>
-		v .:: "type"
-
-typeOf :: [String] -> PackageDbStack -> FilePath -> Int -> Int -> GhcModT IO [TypedRegion]
-typeOf opts pdbs file line col = withOptions (\o -> o { GhcMod.optGhcUserOptions = packageDbStackOpts pdbs ++ opts }) $ do
-	fileCts <- liftIO $ readFileUtf8 file
-	let
-		Position line' col' = calcTabs fileCts 8 (Position line col)
-	ts <- lines <$> GhcMod.types file line' col'
-	return $ mapMaybe (toRegionType fileCts) ts
-	where
-		toRegionType :: String -> String -> Maybe TypedRegion
-		toRegionType fstr s = do
-			(r, tp) <- parseRead s $ (,) <$> parseRegion fstr <*> readParse
-			return $ TypedRegion r (regionStr r fstr) tp
-		parseRegion :: String -> ReadM Region
-		parseRegion fstr = Region <$> parsePosition fstr <*> parsePosition fstr
-		parsePosition :: String -> ReadM Position
-		parsePosition fstr = recalcTabs fstr 8 <$> (Position <$> readParse <*> readParse)
-
-parseOutputMessages :: String -> [Note OutputMessage]
-parseOutputMessages = mapMaybe parseOutputMessage . lines
-
-parseOutputMessage :: String -> Maybe (Note OutputMessage)
-parseOutputMessage s = do
-	groups <- matchRx "^(.+):(\\d+):(\\d+):(\\s*(Warning|Error):)?\\s*(.*)$" s
-	l <- readMaybe (groups `at` 2)
-	c <- readMaybe (groups `at` 3)
-	return Note {
-		_noteSource = FileModule (normalise (groups `at` 1)) Nothing,
-		_noteRegion = regionAt (Position l c),
-		_noteLevel = Just $ if groups 5 == Just "Warning" then Warning else Error,
-		_note = outputMessage $ nullToNL (groups `at` 6) }
-
-recalcOutputMessageTabs :: [(FilePath, String)] -> Note OutputMessage -> Note OutputMessage
-recalcOutputMessageTabs fileCts n = fromMaybe n $ do
-	src <- preview (noteSource . moduleFile) n
-	cts <- lookup src fileCts
-	return $ recalcTabs cts 8 n
-
--- | Replace NULL with newline
-nullToNL :: String -> String
-nullToNL = map $ \case
-	'\0' -> '\n'
-	ch -> ch
-
-check :: [String] -> PackageDbStack -> [FilePath] -> Maybe Project -> GhcModT IO [Note OutputMessage]
-check opts pdbs files _ = do
-	cts <- liftIO $ mapM readFileUtf8 files
-	withOptions (\o -> o { GhcMod.optGhcUserOptions = packageDbStackOpts pdbs ++ opts }) $ do
-		res <- GhcMod.checkSyntax files
-		return $ map (recalcOutputMessageTabs (zip files cts)) $ parseOutputMessages res
-
-lint :: [String] -> FilePath -> GhcModT IO [Note OutputMessage]
-lint opts file = do
-	cts <- liftIO $ readFileUtf8 file
-	res <- GhcMod.lint (GhcMod.defaultLintOpts { GhcMod.optLintHlintOpts = opts }) file
-	return $ map (recalcOutputMessageTabs [(file, cts)]) $ parseOutputMessages res
-
-gmOut :: IO GhcMod.GhcModOut
-gmOut = do
-	ch <- newChan
-	return GhcMod.GhcModOut {
-		GhcMod.gmoOptions = GhcMod.OutputOpts {
-			GhcMod.ooptLogLevel = GhcMod.GmSilent,
-			GhcMod.ooptStyle = GhcMod.PlainStyle,
-			GhcMod.ooptLineSeparator = GhcMod.LineSeparator "\0",
-			GhcMod.ooptLinePrefix = Nothing },
-		GhcMod.gmoChan = ch }
-
-runGhcMod :: (GhcMod.IOish m, MonadCatch m) => GhcMod.Options -> GhcModT m a -> ExceptT String m a
-runGhcMod opts act = do
-	out <- liftIO gmOut
-	cur <- liftIO getCurrentDirectory
-	liftIOErrors $ ExceptT $ liftM (left show . right fst . fst) $ flip runReaderT out $ GhcMod.unGmOutT $
-		GhcMod.withGhcModEnv cur opts $ \(env, _) ->
-			GhcMod.runGhcModT' env GhcMod.defaultGhcModState act
-
-locateGhcModEnv :: FilePath -> IO (Either Project PackageDbStack)
-locateGhcModEnv f = do
-	mproj <- locateProject f
-	maybe (liftM Right $ withNoLog $ searchPackageDbStack f) (return . Left) mproj
-
-ghcModEnvPath :: FilePath -> Either Project PackageDbStack -> FilePath
-ghcModEnvPath defaultPath = either (view projectPath) (fromMaybe defaultPath . preview packageDb . topPackageDb)
-
--- | Create ghc-mod worker for project or for sandbox
-ghcModWorker :: Either Project PackageDbStack -> IO (Worker (GhcModT IO))
-ghcModWorker p = do
-	home <- getHomeDirectory
-	startWorker (runGhcModT'' $ ghcModEnvPath home p) id liftThrow
-	where
-		runGhcModT'' :: FilePath -> GhcModT IO () -> IO ()
-		runGhcModT'' cur act = void $ do
-			out <- gmOut
-			flip runReaderT out $
-				GhcMod.unGmOutT $
-				GhcMod.withGhcModEnv cur GhcMod.defaultOptions $ \(env, _) ->
-					GhcMod.runGhcModT' env GhcMod.defaultGhcModState (act `catchError` (void . return))
-
-type WorkerMap = MVar (M.Map FilePath (Worker (GhcModT IO)))
-
--- | Manage many ghc-mod workers for each project/sandbox
-ghcModMultiWorker :: IO (Worker (ReaderT WorkerMap IO))
-ghcModMultiWorker = newMVar M.empty >>= \m -> startWorker (`runReaderT` m) id id
-
-instance MonadThrow (GhcMod.GmOutT IO) where
-	throwM = lift . throwM
-
-instance MonadCatch (GhcMod.GmOutT IO) where
-	catch = gcatch
-
-instance MonadThrow (GhcModT IO) where
-	throwM = lift . throwM
-
-instance MonadCatch (GhcModT IO) where
-	catch = gcatch
-
-dispatch :: FilePath -> GhcModT IO a -> ReaderT WorkerMap IO (Async a)
-dispatch file act = do
-	mvar <- ask
-	home <- liftIO getHomeDirectory
-	env' <- liftIO $ locateGhcModEnv file
-	let
-		envPath' = ghcModEnvPath home env'
-	liftIO $ modifyMVar mvar $ \wmap -> do
-		w <- maybe (ghcModWorker env') return $ M.lookup envPath' wmap
-		t <- pushTask w act
-		return (M.insert envPath' w wmap, t)
-
-waitMultiGhcMod :: Worker (ReaderT WorkerMap IO) -> FilePath -> GhcModT IO a -> IO a
-waitMultiGhcMod w f =
-	liftIO . pushTask w . dispatch f >=>
-	asExceptT . waitCatch >=>
-	asExceptT . waitCatch
-	where
-		asExceptT :: IO (Either SomeException a) -> IO a
-		asExceptT act = act >>= either (hsdevError . ToolError "ghc-mod" . displayException) return

− src/HsDev/Tools/GhcMod/InferType.hs

@@ -1,54 +0,0 @@-module HsDev.Tools.GhcMod.InferType (
-	untyped, inferType, inferTypes,
-	GhcModT,
-	infer
-	) where
-
-import Control.Applicative
-import Control.Lens (view, preview, set, _Just)
-import Control.Monad.Except
-import Data.Maybe (listToMaybe)
-import Data.String (fromString)
-import qualified Data.Text as T (unpack)
-import qualified Language.Haskell.GhcMod as GhcMod
-
-import HsDev.PackageDb
-import HsDev.Symbols
-import HsDev.Tools.GhcMod
-import HsDev.Util (withCurrentDirectory)
-
--- | Is declaration untyped
-untyped :: DeclarationInfo -> Bool
-untyped (Function Nothing _ _) = True
-untyped _ = False
-
--- | Infer type of declaration
-inferType :: [String] -> PackageDbStack -> FilePath -> Declaration -> GhcModT IO Declaration
-inferType opts pdbs src decl'
-	| untyped (view declaration decl') = doInfer
-	| otherwise = return decl'
-	where
-		doInfer = do
-			inferred <- ((preview $ declaration . functionType . _Just) <$> byInfo) <|> (fmap fromString <$> byTypeOf)
-			return $ set (declaration . functionType) inferred decl'
-
-		byInfo = info opts pdbs src (T.unpack $ view declarationName decl')
-		byTypeOf = case view declarationPosition decl' of
-			Nothing -> fail "No position"
-			Just (Position l c) -> (fmap typedType . listToMaybe) <$> typeOf opts pdbs src l c
-
--- | Infer types for module
-inferTypes :: [String] -> PackageDbStack -> Module -> GhcModT IO Module
-inferTypes opts pdbs m = case view moduleLocation m of
-	FileModule src _ -> do
-		inferredDecls <- traverse (\d -> inferType opts pdbs src d <|> return d) $
-			view moduleDeclarations m
-		return $ set moduleDeclarations inferredDecls m
-	_ -> fail "Type infer works only for source files"
-
--- | Infer type in module
-infer :: [String] -> PackageDbStack -> Module -> ExceptT String IO Module
-infer opts pdbs m = case view moduleLocation m of
-	FileModule src _ -> mapExceptT (withCurrentDirectory (sourceModuleRoot (view moduleName m) src)) $
-		runGhcMod GhcMod.defaultOptions $ inferTypes opts pdbs m
-	_ -> throwError "Type infer works only for source files"

src/HsDev/Util.hs view

@@ -42,7 +42,6 @@ import Control.Monad
 import Control.Monad.Except
 import qualified Control.Monad.Catch as C
-import qualified Control.Monad.CatchIO as CatchIO
 import Data.Aeson hiding (Result(..), Error)
 import qualified Data.Aeson.Types as A
 import Data.Char (isSpace)
@@ -58,25 +57,24 @@ import qualified Data.Text.Lazy as T
 import qualified Data.Text.Lazy.Encoding as T
 import Options.Applicative
-import System.Directory
+import qualified System.Directory as Dir
 import System.FilePath
 import System.IO
-import qualified System.Log.Simple as Log
 import Text.Read (readMaybe)
 
 import HsDev.Version
 
 -- | Run action with current directory set
-withCurrentDirectory :: CatchIO.MonadCatchIO m => FilePath -> m a -> m a
-withCurrentDirectory cur act = CatchIO.bracket (liftIO getCurrentDirectory) (liftIO . setCurrentDirectory) $
-	const (liftIO (setCurrentDirectory cur) >> act)
+withCurrentDirectory :: (MonadIO m, C.MonadMask m) => FilePath -> m a -> m a
+withCurrentDirectory cur act = C.bracket (liftIO Dir.getCurrentDirectory) (liftIO . Dir.setCurrentDirectory) $
+	const (liftIO (Dir.setCurrentDirectory cur) >> act)
 
 -- | Get directory contents safely
 directoryContents :: FilePath -> IO [FilePath]
 directoryContents p = handle ignore $ do
-	b <- doesDirectoryExist p
+	b <- Dir.doesDirectoryExist p
 	if b
-		then liftM (map (p </>) . filter (`notElem` [".", ".."])) (getDirectoryContents p)
+		then liftM (map (p </>) . filter (`notElem` [".", ".."])) (Dir.getDirectoryContents p)
 		else return []
 	where
 		ignore :: SomeException -> IO [FilePath]
@@ -87,7 +85,7 @@ traverseDirectory path = handle onError $ do
 	cts <- directoryContents path
 	liftM concat $ forM cts $ \c -> do
-		isDir <- doesDirectoryExist c
+		isDir <- Dir.doesDirectoryExist c
 		if isDir
 			then (c :) <$> traverseDirectory c
 			else return [c]
@@ -98,8 +96,8 @@ -- | Search something up
 searchPath :: (MonadIO m, MonadPlus m) => FilePath -> (FilePath -> m a) -> m a
 searchPath path f = do
-	path' <- liftIO $ canonicalizePath path
-	isDir <- liftIO $ doesDirectoryExist path'
+	path' <- liftIO $ Dir.canonicalizePath path
+	isDir <- liftIO $ Dir.doesDirectoryExist path'
 	search' (if isDir then path' else takeDirectory path')
 	where
 		search' dir
@@ -205,7 +203,7 @@ liftIOErrors :: C.MonadCatch m => ExceptT String m a -> ExceptT String m a
 liftIOErrors act = liftException (runExceptT act) >>= either throwError return
 
-eitherT :: (Monad m, MonadError String m) => Either String a -> m a
+eitherT :: MonadError String m => Either String a -> m a
 eitherT = either throwError return
 
 -- | Throw error as exception
@@ -238,15 +236,15 @@ 	onErr :: SomeException -> IO ()
 	onErr e = out $ pre ++ displayException e
 
-logIO :: CatchIO.MonadCatchIO m => String -> (String -> m ()) -> m () -> m ()
-logIO pre out = flip CatchIO.catch (onIO out) where
-	onIO :: CatchIO.MonadCatchIO m => (String -> m ()) -> IOException -> m ()
+logIO :: C.MonadCatch m => String -> (String -> m ()) -> m () -> m ()
+logIO pre out = flip C.catch (onIO out) where
+	onIO :: (String -> a) -> IOException -> a
 	onIO out' e = out' $ pre ++ displayException e
 
-logAsync :: CatchIO.MonadCatchIO m => (String -> m ()) -> m () -> m ()
-logAsync out = flip CatchIO.catch (onAsync out) where
-	onAsync :: CatchIO.MonadCatchIO m => (String -> m ()) -> AsyncException -> m ()
-	onAsync out' e = out' (displayException e) >> CatchIO.throw e
+logAsync :: (MonadIO m, C.MonadCatch m) => (String -> m ()) -> m () -> m ()
+logAsync out = flip C.catch (onAsync out) where
+	onAsync :: (MonadIO m, C.MonadThrow m) => (String -> m ()) -> AsyncException -> m ()
+	onAsync out' e = out' (displayException e) >> C.throwM e
 
 ignoreIO :: IO () -> IO ()
 ignoreIO = handle (const (return ()) :: IOException -> IO ())
@@ -285,13 +283,8 @@ 	handle' (Failure f) = Left $ fst $ renderFailure f nm
 	handle' _ = Left "error: completion invoked result"
 
-instance CatchIO.MonadCatchIO m => CatchIO.MonadCatchIO (ExceptT e m) where
-	catch act onError = ExceptT $ CatchIO.catch (runExceptT act) (runExceptT . onError)
-	block = ExceptT . CatchIO.block . runExceptT
-	unblock = ExceptT . CatchIO.unblock . runExceptT
-
-instance Log.MonadLog m => Log.MonadLog (ExceptT e m) where
-	askLog = lift Log.askLog
+-- instance Log.MonadLog m => Log.MonadLog (ExceptT e m) where
+-- 	askLog = lift Log.askLog
 
 -- | Get hsdev version as list of integers
 version :: Maybe [Int]

src/System/Win32/FileMapping/Memory.hs view

@@ -47,7 +47,7 @@ 	ptr <- mapExceptT lift $ mapFile h fILE_MAP_ALL_ACCESS 0 0
 	liftIO $ BS.packCString ptr
 
-verify :: (Eq a, Monad m) => (a -> Bool) -> String -> m a -> ExceptT String m a
+verify :: Monad m => (a -> Bool) -> String -> m a -> ExceptT String m a
 verify p str act = do
 	x <- lift act
 	if p x then return x else throwError str

tools/hsautofix.hs view

@@ -1,3 +1,5 @@+{-# LANGUAGE LambdaCase #-}
+
 module Main (
 	main
 	) where
@@ -5,24 +7,48 @@ import Control.Lens (view, preview)
 import Control.Arrow ((***))
 import Control.Monad (liftM)
+import Control.Monad.IO.Class (liftIO)
 import Control.Monad.State (gets)
 import Control.Monad.Except (throwError)
-import Data.Aeson
+import Data.Aeson hiding (Error)
 import Data.List (partition, sort)
 import Data.Maybe (mapMaybe)
+import System.FilePath (normalise)
 import System.Directory (canonicalizePath)
+import Text.Read (readMaybe)
 
 import System.Directory.Paths (canonicalize)
 import HsDev.Symbols (moduleFile)
+import HsDev.Symbols.Location (ModuleLocation(..), regionAt, Position(..))
 import HsDev.Tools.Base
+import HsDev.Tools.Ghc.Check (recalcNotesTabs)
 import HsDev.Tools.AutoFix
-import HsDev.Tools.GhcMod (parseOutputMessages)
 import HsDev.Util (toUtf8, liftE, readFileUtf8, writeFileUtf8, ordNub)
 
 import Tool
 
 data FixCmd = ShowCmd Bool | FixCmd [Int] Bool
 
+parseOutputMessages :: String -> [Note OutputMessage]
+parseOutputMessages = mapMaybe parseOutputMessage . lines
+
+parseOutputMessage :: String -> Maybe (Note OutputMessage)
+parseOutputMessage s = do
+	groups <- matchRx "^(.+):(\\d+):(\\d+):(\\s*(Warning|Error):)?\\s*(.*)$" s
+	l <- readMaybe (groups `at` 2)
+	c <- readMaybe (groups `at` 3)
+	return Note {
+		_noteSource = FileModule (normalise (groups `at` 1)) Nothing,
+		_noteRegion = regionAt (Position l c),
+		_noteLevel = Just $ if groups 5 == Just "Warning" then Warning else Error,
+		_note = outputMessage $ nullToNL (groups `at` 6) }
+
+-- | Replace NULL with newline
+nullToNL :: String -> String
+nullToNL = map $ \case
+	'\0' -> '\n'
+	ch -> ch
+
 fixP :: Parser FixCmd
 fixP = subparser $ mconcat [
 	cmd "show" "show what can be auto-fixed" (ShowCmd <$> switch (long "json" <> help "output messages in JSON format")),
@@ -36,7 +62,7 @@ 		input <- liftE getContents
 		msgs <- if isJson
 			then maybe (throwError "Can't parse messages") return $ decode (toUtf8 input)
-			else return $ parseOutputMessages input
+			else liftIO $ recalcNotesTabs (parseOutputMessages input)
 		mapM (liftE . canonicalize) $ corrections msgs
 	go (FixCmd ns pure') = do
 		input <- liftE getContents