hsdev 0.2.0.0 → 0.2.1.0

raw patch · 30 files changed

+720/−368 lines, 30 filesdep ~haskell-src-extsdep ~optparse-applicativedep ~simple-log

Dependency ranges changed: haskell-src-exts, optparse-applicative, simple-log

Files

hsdev.cabal +6/−4
src/HsDev/Client/Commands.hs +42/−40
src/HsDev/Database/Update.hs +32/−34
src/HsDev/Inspect.hs +110/−95
src/HsDev/Project/Types.hs +31/−1
src/HsDev/Sandbox.hs +19/−3
src/HsDev/Scan.hs +4/−4
src/HsDev/Scan/Browse.hs +10/−8
src/HsDev/Server/Base.hs +1/−3
src/HsDev/Server/Commands.hs +20/−18
src/HsDev/Server/Types.hs +53/−53
src/HsDev/Stack.hs +7/−11
src/HsDev/Symbols.hs +1/−11
src/HsDev/Symbols/Location.hs +6/−0
src/HsDev/Symbols/Resolve.hs +8/−3
src/HsDev/Symbols/Types.hs +1/−1
src/HsDev/Tools/ClearImports.hs +2/−1
src/HsDev/Tools/Ghc/Check.hs +11/−18
src/HsDev/Tools/Ghc/Compat.hs +9/−2
src/HsDev/Tools/Ghc/MGhc.hs +207/−0
src/HsDev/Tools/Ghc/Session.hs +49/−0
src/HsDev/Tools/Ghc/Types.hs +5/−11
src/HsDev/Tools/Ghc/Worker.hs +62/−38
src/HsDev/Tools/Types.hs +0/−1
src/HsDev/Util.hs +4/−1
src/System/Directory/Paths.hs +12/−1
tests/Test.hs +1/−1
tools/Tool.hs +2/−0
tools/hsdev.hs +2/−3
tools/hsinspect.hs +3/−2

hsdev.cabal view

@@ -1,5 +1,5 @@ name:                hsdev
-version:             0.2.0.0
+version:             0.2.1.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.
@@ -70,9 +70,11 @@     HsDev.Tools.ClearImports
     HsDev.Tools.Ghc.Check
     HsDev.Tools.Ghc.Compat
+    HsDev.Tools.Ghc.MGhc
     HsDev.Tools.Ghc.Prelude
     HsDev.Tools.Ghc.Types
     HsDev.Tools.Ghc.Worker
+    HsDev.Tools.Ghc.Session
     HsDev.Tools.Hayoo
     HsDev.Tools.HDocs
     HsDev.Tools.HLint
@@ -126,7 +128,7 @@     fsnotify >= 0.2.1,
     ghc-paths >= 0.1.0,
     ghc-syb-utils >= 0.2.3,
-    haskell-src-exts >= 1.17.0 && < 1.18.0,
+    haskell-src-exts >= 1.18.0 && < 1.19.0,
     hdocs >= 0.5.0,
     hformat >= 0.1,
     hlint >= 1.9.13 && < 2.0.0,
@@ -141,7 +143,7 @@     process >= 1.2.0,
     regex-pcre-builtin >= 0.94,
     scientific >= 0.3,
-    simple-log >= 0.4.0,
+    simple-log >= 0.5.0,
     syb >= 0.5.1,
     template-haskell,
     text >= 1.2.0,
@@ -215,7 +217,7 @@     containers >= 0.5.0,
     data-default >= 0.5.0,
     directory >= 1.2.0,
-    haskell-src-exts >= 1.17.0 && < 1.18.0,
+    haskell-src-exts >= 1.18.0 && < 1.19.0,
     lens >= 4.8,
     mtl >= 2.2.0,
     optparse-applicative >= 0.11,

src/HsDev/Client/Commands.hs view

@@ -43,7 +43,7 @@ import HsDev.Symbols.Util
 import qualified HsDev.Tools.AutoFix as AutoFix
 import qualified HsDev.Tools.Cabal as Cabal
-import HsDev.Tools.Ghc.Worker
+import HsDev.Tools.Ghc.Session
 import qualified HsDev.Tools.Ghc.Compat as Compat
 import qualified HsDev.Tools.Ghc.Check as Check
 import qualified HsDev.Tools.Ghc.Types as Types
@@ -78,12 +78,11 @@ 	updateData (AddedDatabase db) = toValue $ serverUpdateDB db
 	updateData (AddedModule m) = toValue $ serverUpdateDB $ fromModule m
 	updateData (AddedProject p) = toValue $ serverUpdateDB $ fromProject p
-runCommand (Scan projs cabal sboxes fs paths' fcts ghcs' docs' infer') = toValue $ do
+runCommand (Scan projs cabal sboxes fs paths' ghcs' docs' infer') = toValue $ do
 	sboxes' <- getSandboxes sboxes
 	updateProcess (Update.UpdateOptions [] ghcs' docs' infer') $ concat [
-		map (\(FileContents f cts) -> Update.scanFileContents ghcs' f (Just cts)) fcts,
+		map (\(FileSource f mcts) -> Update.scanFileContents ghcs' f mcts) fs,
 		map (Update.scanProject ghcs') projs,
-		map (Update.scanFile ghcs') fs,
 		map (Update.scanDirectory ghcs') paths',
 		[Update.scanCabal ghcs' | cabal],
 		map (Update.scanSandbox ghcs') sboxes']
@@ -198,44 +197,29 @@ 	(mapMaybe Hayoo.hayooAsDeclaration . Hayoo.resultResult) $
 	liftIO $ hsdevLift $ Hayoo.hayoo hq (Just i)
 runCommand (CabalList packages) = toValue $ liftIO $ hsdevLift $ Cabal.cabalList packages
-runCommand (Lint fs fcts) = toValue $ do
-	liftIO $ hsdevLift $ liftM2 (++)
-		(liftM concat $ mapM HLint.hlintFile fs)
-		(liftM concat $ mapM (\(FileContents f c) -> HLint.hlintSource f c) fcts)
-runCommand (Check fs fcts ghcs') = toValue $ Log.scope "check" $ do
-	ghc <- askSession sessionGhc
-	liftIO $ restartWorker ghc
+runCommand (Lint fs) = toValue $ do
+	liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint f c) fs
+runCommand (Check fs ghcs') = toValue $ Log.scope "check" $ do
+	ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs
 	let
 		checkSome file fn = Log.scope "checkSome" $ do
-			pdbs <- searchPackageDbStack file
-			m <- refineSourceModule file
-			inWorkerWith (hsdevError . GhcError . displayException) ghc (fn pdbs m)
-	liftM concat $ mapM (uncurry checkSome) $
-		[(f, Check.checkFile ghcs') | f <- fs] ++
-		[(f, \pdbs m -> Check.checkSource ghcs' pdbs m src) | FileContents f src <- fcts]
-runCommand (CheckLint fs fcts ghcs') = toValue $ do
-	ghc <- askSession sessionGhc
-	liftIO $ restartWorker ghc
+			m <- setFileSourceSession ghcs' file
+			inSessionGhc $ fn m
+	liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check ghcs' m c)) fs
+runCommand (CheckLint fs ghcs') = toValue $ do
+	ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs
 	let
 		checkSome file fn = do
-			pdbs <- searchPackageDbStack file
-			m <- refineSourceModule file
-			inWorkerWith (hsdevError . GhcError . displayException) ghc (fn pdbs m)
-	checkMsgs <- liftM concat $ mapM (uncurry checkSome) $
-		[(f, Check.checkFile ghcs') | f <- fs] ++
-		[(f, \pdbs m -> Check.checkSource ghcs' pdbs m src) | FileContents f src <- fcts]
-	lintMsgs <- liftIO $ hsdevLift $ liftM2 (++)
-		(liftM concat $ mapM HLint.hlintFile fs)
-		(liftM concat $ mapM (\(FileContents f src) -> HLint.hlintSource f src) fcts)
+			m <- setFileSourceSession ghcs' file
+			inSessionGhc $ fn m
+	checkMsgs <- liftM concat $ mapM (\(FileSource f c) -> checkSome f (\m -> Check.check ghcs' m c)) fs
+	lintMsgs <- liftIO $ hsdevLift $ liftM concat $ mapM (\(FileSource f c) -> HLint.hlint f c) fs
 	return $ checkMsgs ++ lintMsgs
-runCommand (Types fs fcts ghcs') = toValue $ do
-	ghc <- askSession sessionGhc
-	let
-		cts = [(f, Nothing) | f <- fs] ++ [(f, Just src) | FileContents f src <- fcts]
-	liftM concat $ forM cts $ \(file, msrc) -> do
-		pdbs <- searchPackageDbStack file
-		m <- refineSourceModule file
-		inWorkerWith (hsdevError . GhcError . displayException) ghc (Types.fileTypes ghcs' pdbs m msrc)
+runCommand (Types fs ghcs') = toValue $ do
+	ensureUpToDate (Update.UpdateOptions [] ghcs' False False) fs
+	liftM concat $ forM fs $ \(FileSource file msrc) -> do
+		m <- setFileSourceSession ghcs' file
+		inSessionGhc $ Types.fileTypes ghcs' m msrc
 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
@@ -256,9 +240,16 @@ 				liftIO $ writeFileUtf8 file cts'
 				return corrs'
 	liftM concat $ mapM runFix files
-runCommand (GhcEval exprs) = toValue $ do
-	ghci <- askSession sessionGhci
-	async' <- liftIO $ pushTask ghci $ mapM (try . evaluate) exprs
+runCommand (GhcEval exprs mfile) = toValue $ do
+	ensureUpToDate (Update.UpdateOptions [] [] False False) (maybeToList mfile)
+	ghcw <- askSession sessionGhc
+	case mfile of
+		Nothing -> inSessionGhc ghciSession
+		Just (FileSource f mcts) -> do
+			m <- setFileSourceSession [] f
+			inSessionGhc $ interpretModule m mcts
+	async' <- liftIO $ pushTask ghcw $ do
+		mapM (try . evaluate) exprs
 	res <- waitAsync async'
 	return $ map toValue' res
 	where
@@ -325,6 +316,13 @@ 	db' <- getDb
 	maybe (hsdevError (NotInspected $ FileModule fpath' Nothing)) return $ lookupFile fpath' db'
 
+-- | Set session by source
+setFileSourceSession :: CommandMonad m => [String] -> FilePath -> m Module
+setFileSourceSession opts fpath = do
+	m <- refineSourceModule fpath
+	inSessionGhc $ targetSession opts m
+	return m
+
 -- | Ensure package exists
 refinePackage :: CommandMonad m => String -> m String
 refinePackage pack = do
@@ -398,6 +396,10 @@ updateProcess uopts acts = Update.runUpdate uopts $ mapM_ runAct acts where
 	runAct act = catch act onError
 	onError e = Log.log Log.Error $ "{}" ~~ (e :: HsDevError)
+
+-- | Ensure file is up to date
+ensureUpToDate :: ServerMonadBase m => Update.UpdateOptions -> [FileSource] -> ClientM m ()
+ensureUpToDate uopts fs = updateProcess uopts [Update.scanFileContents (view Update.updateGhcOpts uopts) f mcts | FileSource f mcts <- fs]
 
 -- | Filter declarations with prefix and infix
 filterMatch :: Symbol a => SearchQuery -> [a] -> [a]

src/HsDev/Database/Update.hs view

@@ -8,8 +8,6 @@ 	UpdateM(..),
 	runUpdate,
 
-	UpdateMonad,
-
 	postStatus, waiter, updater, loadCache, getCache, runTask, runTasks,
 	readDB,
 
@@ -18,6 +16,8 @@ 	scan,
 	updateEvent, processEvent,
 
+	module HsDev.Database.Update.Types,
+
 	module HsDev.Watcher,
 
 	module Control.Monad.Except
@@ -42,7 +42,6 @@ import System.FilePath
 import qualified System.Log.Simple as Log
 
-import Control.Concurrent.Worker (inWorker, restartWorker)
 import HsDev.Error
 import qualified HsDev.Cache.Structured as Cache
 import HsDev.Database
@@ -53,12 +52,13 @@ import HsDev.Sandbox
 import HsDev.Stack
 import HsDev.Symbols
-import HsDev.Tools.Ghc.Worker (setCmdOpts, liftGhc)
+import HsDev.Tools.Ghc.Session hiding (wait)
 import HsDev.Tools.Ghc.Types (inferTypes)
 import HsDev.Tools.HDocs
 import qualified HsDev.Scan as S
 import HsDev.Scan.Browse
 import HsDev.Util (isParent, ordNub)
+import qualified HsDev.Util as Util (withCurrentDirectory)
 import HsDev.Server.Types (commandNotify, serverWriteCache, serverReadCache)
 import HsDev.Server.Message
 import HsDev.Database.Update.Types
@@ -111,17 +111,19 @@ 		scanDocs_ :: UpdateMonad m => InspectedModule -> m ()
 		scanDocs_ im = do
 			im' <- (S.scanModify (\opts _ -> liftIO . inspectDocs opts) im) <|> return im
-			updater $ return $ fromModule im'
+			updater $ fromModule im'
 		inferModTypes_ :: UpdateMonad m => InspectedModule -> m ()
 		inferModTypes_ im = do
 			-- TODO: locate sandbox
 			s <- getSession
 			im' <- (S.scanModify (infer' s) im) <|> return im
-			updater $ return $ fromModule im'
+			updater $ fromModule im'
 		infer' :: UpdateMonad m => Session -> [String] -> PackageDbStack -> Module -> m Module
-		infer' s opts pdbs m = case preview (moduleLocation . moduleFile) m of
+		infer' s opts _ m = case preview (moduleLocation . moduleFile) m of
 			Nothing -> return m
-			Just _ -> liftIO $ inWorker (sessionGhc s) $ inferTypes opts pdbs m Nothing
+			Just _ -> liftIO $ inWorker (sessionGhc s) $ do
+				targetSession opts m
+				inferTypes opts m Nothing
 
 -- | Post status
 postStatus :: UpdateMonad m => Task -> m ()
@@ -135,10 +137,9 @@ 	wait db
 
 -- | Update task result to database
-updater :: UpdateMonad m => m Database -> m ()
-updater act = do
+updater :: UpdateMonad m => Database -> m ()
+updater db' = do
 	db <- askSession sessionDatabase
-	db' <- act
 	update db $ return $!! db'
 	tell $!! map (view moduleLocation) $ allModules db'
 
@@ -162,7 +163,7 @@ 	if nullDatabase dbval
 		then do
 			db <- loadCache act
-			waiter $ updater $ return db
+			waiter $ updater db
 			return db
 		else
 			return dbval
@@ -201,7 +202,7 @@ scanModule opts mloc mcts = runTask "scanning" mloc $ Log.scope "module" $ do
 	defs <- askSession sessionDefines
 	im <- S.scanModule defs opts mloc mcts
-	updater $ return $ fromModule im
+	updater $ fromModule im
 	_ <- return $ view inspectionResult im
 	return ()
 
@@ -258,10 +259,10 @@ -- | Prepare sandbox for scanning. This is used for stack project to build & configure.
 prepareSandbox :: UpdateMonad m => Sandbox -> m ()
 prepareSandbox sbox@(Sandbox StackWork fpath) = Log.scope "prepare" $ runTasks [
-	runTask "building dependencies" sbox $ void $ buildDeps myaml,
-	runTask "configuring" sbox $ void $ configure myaml]
+	runTask "building dependencies" sbox $ void $ Util.withCurrentDirectory dir $ buildDeps Nothing,
+	runTask "configuring" sbox $ void $ Util.withCurrentDirectory dir $ configure Nothing]
 	where
-		myaml = Just $ takeDirectory fpath </> "stack.yaml"
+		dir = takeDirectory fpath
 prepareSandbox _ = return ()
 
 -- | Scan sandbox modules, doesn't rescan if already scanned
@@ -287,14 +288,17 @@ 	scan (Cache.loadPackageDb (topPackageDb pdbs)) (packageDbDB (topPackageDb pdbs)) ((,,) <$> mlocs <*> pure [] <*> pure Nothing) opts $ \mlocs' -> do
 		ms <- browseModules opts pdbs (mlocs' ^.. each . _1)
 		docs <- liftIO $ hsdevLiftWith (ToolError "hdocs") $ hdocsCabal pdbs opts
-		updater $ return $ mconcat $ map (fromModule . fmap (setDocs' docs)) ms
+		updater $ mconcat $ map (fromModule . fmap (setDocs' docs)) ms
 	where
 		setDocs' :: Map String (Map String String) -> Module -> Module
 		setDocs' docs m = maybe m (`setDocs` m) $ M.lookup (T.unpack $ view moduleName m) docs
 
 -- | Scan project file
 scanProjectFile :: UpdateMonad m => [String] -> FilePath -> m Project
-scanProjectFile opts cabal = runTask "scanning" cabal $ S.scanProjectFile opts cabal
+scanProjectFile opts cabal = runTask "scanning" cabal $ do
+	proj <- S.scanProjectFile opts cabal
+	updater $ fromProject proj
+	return proj
 
 -- | Scan project and related package-db stack
 scanProjectStack :: UpdateMonad m => [String] -> FilePath -> m ()
@@ -310,9 +314,7 @@ 	proj <- scanProjectFile opts cabal
 	watch (\w -> watchProject w proj opts)
 	S.ScanContents _ [(_, sources)] _ <- S.enumProject proj
-	scan (Cache.loadProject $ view projectCabal proj) (projectDB proj) sources opts $ \ms -> do
-		scanModules opts ms
-		updater $ return $ fromProject proj
+	scan (Cache.loadProject $ view projectCabal proj) (projectDB proj) sources opts $ scanModules opts
 
 -- | Scan directory for source files and projects
 scanDirectory :: UpdateMonad m => [String] -> FilePath -> m ()
@@ -347,8 +349,7 @@ scanDocs :: UpdateMonad m => [InspectedModule] -> m ()
 scanDocs ims = do
 	-- w <- liftIO $ ghcWorker ["-haddock"] (return ())
-	w <- askSession sessionGhc
-	liftIO $ restartWorker w
+	-- w <- askSession sessionGhc
 	runTasks $ map scanDocs' ims
 	where
 		scanDocs' im
@@ -359,18 +360,14 @@ 				Log.log Log.Trace $ "Docs for {} updated: documented {} declarations" ~~
 					view inspectedId im' ~~
 					length (im' ^.. inspectionResult . _Right . moduleDeclarations . each . declarationDocs . _Just)
-				updater $ return $ fromModule im'
+				updater $ fromModule im'
 			| otherwise = Log.log Log.Trace $ "Docs for {} already scanned" ~~ view inspectedId im
-		doScan opts _ m = do
+		doScan _ _ m = do
 			w <- askSession sessionGhc
-			pdbs <- case view moduleLocation m of
-				FileModule fpath _ -> searchPackageDbStack fpath
-				InstalledModule pdb _ _ -> restorePackageDbStack pdb
-				ModuleSource _ -> return userDb
-			pkgs <- browsePackages opts pdbs
 			liftIO $ inWorker w $ do
-				setCmdOpts ("-haddock" : (opts ++ moduleOpts pkgs m))
-				liftGhc $ inspectDocsGhc (opts ++ moduleOpts pkgs m) m
+				opts' <- getModuleOpts [] m
+				haddockSession opts'
+				liftGhc $ inspectDocsGhc opts' m
 
 inferModTypes :: UpdateMonad m => [InspectedModule] -> m ()
 inferModTypes = runTasks . map inferModTypes' where
@@ -378,10 +375,11 @@ 		| not $ hasTag InferredTypesTag im = runTask "inferring types" (view inspectedId im) $ Log.scope "docs" $ do
 			w <- askSession sessionGhc
 			Log.log Log.Trace $ "Inferring types for {}" ~~ view inspectedId im
-			im' <- (liftM (setTag InferredTypesTag) $ S.scanModify (\opts cabal m -> liftIO (inWorker w (inferTypes opts cabal m Nothing))) im)
+			im' <- (liftM (setTag InferredTypesTag) $
+				S.scanModify (\opts _ m -> liftIO (inWorker w (targetSession opts m >> inferTypes opts m Nothing))) im)
 				<|> return im
 			Log.log Log.Trace $ "Types for {} inferred" ~~ view inspectedId im
-			updater $ return $ fromModule im'
+			updater $ fromModule im'
 		| otherwise = Log.log Log.Trace $ "Types for {} already inferred" ~~ view inspectedId im
 
 -- | Generic scan function. Reads cache only if data is not already loaded, removes obsolete modules and rescans changed modules.

src/HsDev/Inspect.hs view

@@ -49,18 +49,20 @@ analyzeModule :: [String] -> Maybe FilePath -> String -> Either String Module analyzeModule exts file source = case H.parseFileContentsWithMode (parseMode file exts) source' of 	H.ParseFailed loc reason -> Left $ "Parse failed at " ++ show loc ++ ": " ++ reason-	H.ParseOk (H.Module _ (H.ModuleName mname) _ _ mexports imports declarations) -> Right Module {+	H.ParseOk (H.Module _ (Just (H.ModuleHead _ (H.ModuleName _ mname) _ mexports)) _ imports declarations) -> Right Module { 		_moduleName = fromString mname, 		_moduleDocs =  Nothing, 		_moduleLocation = ModuleSource Nothing,-		_moduleExports = fmap (concatMap getExports) mexports,+		_moduleExports = fmap (concatMap getExports . getSpec) mexports, 		_moduleImports = map getImport imports, 		_moduleDeclarations = sortDeclarations $ getDecls declarations }+	_ -> Left "Unknown module" 	where 		-- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces 		source' = map untab source 		untab '\t' = ' ' 		untab ch = ch+		getSpec (H.ExportSpecList _ es) = es  -- | Analize source contents analyzeModule_ :: [String] -> Maybe FilePath -> String -> Either String Module@@ -71,8 +73,9 @@ 		_moduleDocs = Nothing, 		_moduleLocation = ModuleSource Nothing, 		_moduleExports = do-			H.PragmasAndModuleHead _ (_, _, mexports) <- parseModuleHead' source'-			exports <- mexports+			H.PragmasAndModuleHead _ _ mhead <- parseModuleHead' source'+			H.ModuleHead _ _ _ mexports <- mhead+			H.ExportSpecList _ exports <- mexports 			return $ concatMap getExports exports, 		_moduleImports = map getImport $ mapMaybe (uncurry parseImport') parts, 		_moduleDeclarations = sortDeclarations $ getDecls $ mapMaybe (uncurry parseDecl') parts }@@ -91,23 +94,23 @@ 			g <- matchRx "^module\\s+([\\w\\.]+)" cts 			g 1 -		parseDecl' :: Int -> String -> Maybe H.Decl+		parseDecl' :: Int -> String -> Maybe (H.Decl H.SrcSpanInfo) 		parseDecl' offset cts = maybeResult $ fmap (transformBi $ addOffset offset) $ 			H.parseDeclWithMode (parseMode file exts) cts -		parseImport' :: Int -> String -> Maybe H.ImportDecl+		parseImport' :: Int -> String -> Maybe (H.ImportDecl H.SrcSpanInfo) 		parseImport' offset cts = maybeResult $ fmap (transformBi $ addOffset offset) $ 			H.parseImportDeclWithMode (parseMode file exts) cts -		parseModuleHead' :: String -> Maybe H.PragmasAndModuleHead+		parseModuleHead' :: String -> Maybe (H.PragmasAndModuleHead H.SrcSpanInfo) 		parseModuleHead' = maybeResult . fmap H.unNonGreedy . H.parseWithMode (parseMode file exts)  		maybeResult :: H.ParseResult a -> Maybe a 		maybeResult (H.ParseFailed _ _) = Nothing 		maybeResult (H.ParseOk r) = Just r -		addOffset :: Int -> H.SrcLoc -> H.SrcLoc-		addOffset offset src = src { H.srcLine = H.srcLine src + offset }+		addOffset :: Int -> H.SrcSpan -> H.SrcSpan+		addOffset offset src = src { H.srcSpanStartLine = H.srcSpanStartLine src + offset, H.srcSpanEndLine = H.srcSpanEndLine src + offset }  		-- Replace all tabs to spaces to make SrcLoc valid, otherwise it treats tab as 8 spaces 		source' = map untab source@@ -122,34 +125,33 @@ 	H.fixities = Just H.baseFixities }  -- | Get exports-getExports :: H.ExportSpec -> [Export]-getExports (H.EModuleContents (H.ModuleName m)) = [ExportModule $ fromString m]-getExports (H.EVar n) = [uncurry ExportName (identOfQName n) ThingNothing]-getExports (H.EAbs _ n) = [uncurry ExportName (identOfQName n) ThingNothing]-getExports (H.EThingAll n) = [uncurry ExportName (identOfQName n) ThingAll]-getExports (H.EThingWith n ns) = [uncurry ExportName (identOfQName n) $ ThingWith (map toStr ns)] where-	toStr :: H.CName -> Text-	toStr (H.VarName cn) = identOfName cn-	toStr (H.ConName cn) = identOfName cn+getExports :: H.ExportSpec H.SrcSpanInfo -> [Export]+getExports (H.EModuleContents _ (H.ModuleName _ m)) = [ExportModule $ fromString m]+getExports (H.EVar _ n) = [uncurry ExportName (identOfQName n) ThingNothing]+getExports (H.EAbs _ _ n) = [uncurry ExportName (identOfQName n) ThingNothing]+getExports (H.EThingWith _ _ n ns) = [uncurry ExportName (identOfQName n) $ ThingWith (map toStr ns)] where+	toStr :: H.CName H.SrcSpanInfo -> Text+	toStr (H.VarName _ cn) = identOfName cn+	toStr (H.ConName _ cn) = identOfName cn  -- | Get import-getImport :: H.ImportDecl -> Import+getImport :: H.ImportDecl H.SrcSpanInfo -> Import getImport d = Import 	(mname (H.importModule d)) 	(H.importQualified d) 	(mname <$> H.importAs d) 	(importLst <$> H.importSpecs d)-	(Just $ toPosition $ H.importLoc d)+	(Just $ toPosition $ H.ann d) 	where-		mname (H.ModuleName n) = fromString n-		importLst (hiding, specs) = ImportList hiding $ map impSpec specs-		impSpec (H.IVar n) = ImportSpec (identOfName n) ThingNothing-		impSpec (H.IAbs _ n) = ImportSpec (identOfName n) ThingNothing-		impSpec (H.IThingAll n) = ImportSpec (identOfName n) ThingAll-		impSpec (H.IThingWith n ns) = ImportSpec (identOfName n) $ ThingWith $ map identOfName (concatMap childrenBi ns :: [H.Name])+		mname (H.ModuleName _ n) = fromString n+		importLst (H.ImportSpecList _ hiding specs) = ImportList hiding $ map impSpec specs+		impSpec (H.IVar _ n) = ImportSpec (identOfName n) ThingNothing+		impSpec (H.IAbs _ _ n) = ImportSpec (identOfName n) ThingNothing+		impSpec (H.IThingAll _ n) = ImportSpec (identOfName n) ThingAll+		impSpec (H.IThingWith _ n ns) = ImportSpec (identOfName n) $ ThingWith $ map identOfName (concatMap childrenBi ns :: [H.Name H.SrcSpanInfo])  -- | Decl declarations-getDecls :: [H.Decl] -> [Declaration]+getDecls :: [H.Decl H.SrcSpanInfo] -> [Declaration] getDecls decls = 	map mergeDecls . 	groupBy ((==) `on` view declarationName) .@@ -171,117 +173,130 @@ 		mergeInfos l _ = l  -- | Get local binds-getLocalDecls :: H.Decl -> [Declaration]+getLocalDecls :: H.Decl H.SrcSpanInfo -> [Declaration] getLocalDecls decl' = concatMap getDecls' binds' where-	binds' :: [H.Binds]+	binds' :: [H.Binds H.SrcSpanInfo] 	binds' = universeBi decl'-	getDecls' :: H.Binds -> [Declaration]-	getDecls' (H.BDecls decls) = getDecls decls+	getDecls' :: H.Binds H.SrcSpanInfo -> [Declaration]+	getDecls' (H.BDecls _ decls) = getDecls decls 	getDecls' _ = []  -- | Get declaration and child declarations-getDecl :: H.Decl -> [Declaration]+getDecl :: H.Decl H.SrcSpanInfo -> [Declaration] getDecl decl' = case decl' of 	H.TypeSig loc names typeSignature -> [mkFun loc n (Function (Just $ oneLinePrint typeSignature) [] Nothing) | n <- names]-	H.TypeDecl loc n args _ -> [mkType loc n Type args `withDef` decl']-	H.DataDecl loc dataOrNew ctx n args cons _ -> (mkType loc n (ctor dataOrNew `withCtx` ctx) args `withDef` decl') : concatMap (map (addRel n) . getConDecl n args) cons-	H.GDataDecl loc dataOrNew ctx n args _ gcons _ -> (mkType loc n (ctor dataOrNew `withCtx` ctx) args `withDef` decl') : concatMap (map (addRel n) . getGConDecl) gcons-	H.ClassDecl loc ctx n args _ _ -> [mkType loc n (Class `withCtx` ctx) args `withDef` decl']+	H.TypeDecl loc h _ -> [mkType loc (tyName h) Type (tyArgs h) `withDef` decl']+	H.DataDecl loc dataOrNew mctx h cons _ -> (mkType loc (tyName h) (ctor dataOrNew `withCtx` mctx) (tyArgs h) `withDef` decl') : concatMap (map (addRel $ tyName h) . getConDecl (tyName h) (tyArgs h)) cons+	H.GDataDecl loc dataOrNew mctx h _ gcons _ -> (mkType loc (tyName h) (ctor dataOrNew `withCtx` mctx) (tyArgs h) `withDef` decl') : concatMap (map (addRel $ tyName h) . getGConDecl) gcons+	H.ClassDecl loc ctx h _ _ -> [mkType loc (tyName h) (Class `withCtx` ctx) (tyArgs h) `withDef` decl'] 	_ -> [] 	where-		mkType :: H.SrcLoc -> H.Name -> (TypeInfo -> DeclarationInfo) -> [H.TyVarBind] -> Declaration+		mkType :: H.SrcSpanInfo -> H.Name H.SrcSpanInfo -> (TypeInfo -> DeclarationInfo) -> [H.TyVarBind H.SrcSpanInfo] -> Declaration 		mkType loc n ctor' args = setPosition loc $ decl (identOfName n) $ ctor' $ TypeInfo Nothing (map oneLinePrint args) Nothing []  		withDef :: H.Pretty a => Declaration -> a -> Declaration 		withDef tyDecl' tyDef = set (declaration . typeInfo . typeInfoDefinition) (Just $ prettyPrint tyDef) tyDecl' -		withCtx :: (TypeInfo -> DeclarationInfo) -> H.Context -> TypeInfo -> DeclarationInfo-		withCtx ctor' ctx = ctor' . set typeInfoContext (makeCtx ctx)+		withCtx :: (TypeInfo -> DeclarationInfo) -> Maybe (H.Context H.SrcSpanInfo) -> TypeInfo -> DeclarationInfo+		withCtx ctor' mctx = ctor' . set typeInfoContext (fmap makeCtx mctx) -		ctor :: H.DataOrNew -> TypeInfo -> DeclarationInfo-		ctor H.DataType = Data-		ctor H.NewType = NewType+		ctor :: H.DataOrNew H.SrcSpanInfo -> TypeInfo -> DeclarationInfo+		ctor (H.DataType _) = Data+		ctor (H.NewType _) = NewType -		makeCtx [] = Nothing-		makeCtx ctx = Just $ fromString $ intercalate ", " $ map oneLinePrint ctx+		makeCtx ctx = fromString $ oneLinePrint ctx -		addRel :: H.Name -> Declaration -> Declaration+		addRel :: H.Name H.SrcSpanInfo -> Declaration -> Declaration 		addRel n = set (declaration . related) (Just $ identOfName n) +		tyName :: H.DeclHead H.SrcSpanInfo -> H.Name H.SrcSpanInfo+		tyName (H.DHead _ n) = n+		tyName (H.DHInfix _ _ n) = n+		tyName (H.DHParen _ h) = tyName h+		tyName (H.DHApp _ h _) = tyName h++		tyArgs :: H.DeclHead H.SrcSpanInfo -> [H.TyVarBind H.SrcSpanInfo]+		tyArgs = universeBi+ -- | Get constructor and record fields declarations-getConDecl :: H.Name -> [H.TyVarBind] -> H.QualConDecl -> [Declaration]+getConDecl :: H.Name H.SrcSpanInfo -> [H.TyVarBind H.SrcSpanInfo] -> H.QualConDecl H.SrcSpanInfo -> [Declaration] getConDecl t as (H.QualConDecl loc _ _ cdecl) = case cdecl of-	H.ConDecl n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ cts `tyFun` dataRes) [] Nothing)]-	H.InfixConDecl ct n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ (ct : [cts]) `tyFun` dataRes) [] Nothing)]-	H.RecDecl n fields -> mkFun loc n (Function (Just $ oneLinePrint $ map snd fields `tyFun` dataRes) [] Nothing) : concatMap (uncurry (getRec loc dataRes)) fields+	H.ConDecl _ n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ cts `tyFun` dataRes) [] Nothing)]+	H.InfixConDecl _ ct n cts -> [mkFun loc n (Function (Just $ oneLinePrint $ (ct : [cts]) `tyFun` dataRes) [] Nothing)]+	H.RecDecl _ n fields -> mkFun loc n (Function (Just $ oneLinePrint $ map tyField fields `tyFun` dataRes) [] Nothing) : concatMap (getRec loc dataRes) fields 	where-		dataRes :: H.Type-		dataRes = foldr (H.TyApp . H.TyVar . nameOf) (H.TyCon (H.UnQual t)) as where-			nameOf :: H.TyVarBind -> H.Name-			nameOf (H.KindedVar n' _) = n'-			nameOf (H.UnkindedVar n') = n'+		dataRes :: H.Type H.SrcSpanInfo+		dataRes = foldr (H.TyApp loc . H.TyVar loc . nameOf) (H.TyCon loc (H.UnQual loc t)) as where+			nameOf :: H.TyVarBind H.SrcSpanInfo -> H.Name H.SrcSpanInfo+			nameOf (H.KindedVar _ n' _) = n'+			nameOf (H.UnkindedVar _ n') = n' +tyField :: H.FieldDecl H.SrcSpanInfo -> H.Type H.SrcSpanInfo+tyField (H.FieldDecl _ _ t) = t+ -- | Get GADT constructor and record fields declarations-getGConDecl :: H.GadtDecl -> [Declaration]-getGConDecl (H.GadtDecl loc n fields r) = mkFun loc n (Function (Just $ oneLinePrint $ map snd fields `tyFun` r) [] Nothing) : concatMap (uncurry (getRec loc r)) fields+getGConDecl :: H.GadtDecl H.SrcSpanInfo -> [Declaration]+getGConDecl (H.GadtDecl loc n mfields r) = mkFun loc n (Function (Just $ oneLinePrint $ map tyField (fromMaybe [] mfields) `tyFun` r) [] Nothing) : concatMap (getRec loc r) (fromMaybe [] mfields)  -- | Get record field declaration-getRec :: H.SrcLoc -> H.Type -> [H.Name] -> H.Type -> [Declaration]-getRec loc t ns rt = [mkFun loc n (Function (Just $ oneLinePrint $ t `H.TyFun` rt) [] Nothing) | n <- ns]+getRec :: H.SrcSpanInfo -> H.Type H.SrcSpanInfo -> H.FieldDecl H.SrcSpanInfo -> [Declaration]+getRec loc t (H.FieldDecl _ ns rt) = [mkFun loc n (Function (Just $ oneLinePrint $ H.TyFun loc t rt) [] Nothing) | n <- ns]  -- | Get definitions-getDef :: H.Decl -> [Declaration]-getDef (H.FunBind []) = []-getDef d@(H.FunBind (H.Match loc n _ _ _ _ : _)) = [setPosition loc $ decl (identOfName n) fun] where+getDef :: H.Decl H.SrcSpanInfo -> [Declaration]+getDef (H.FunBind _ []) = []+getDef d@(H.FunBind _ (m : _)) = [setPosition (H.ann m) $ decl (identOfName $ identOfMatch m) fun] where+	identOfMatch (H.Match _ n _ _ _) = n+	identOfMatch (H.InfixMatch _ _ n _ _ _) = n 	fun = Function Nothing (getLocalDecls d) Nothing getDef d@(H.PatBind loc pat _ _) = map (\name -> setPosition loc (decl (identOfName name) (Function Nothing (getLocalDecls d) Nothing))) (names pat) where-	names :: H.Pat -> [H.Name]-	names (H.PVar n) = [n]-	names (H.PNPlusK n _) = [n]-	names (H.PInfixApp l _ r) = names l ++ names r-	names (H.PApp _ ns) = concatMap names ns-	names (H.PTuple _ ns) = concatMap names ns-	names (H.PList ns) = concatMap names ns-	names (H.PParen n) = names n-	names (H.PRec _ pf) = concatMap fieldNames pf-	names (H.PAsPat n ns) = n : names ns-	names H.PWildCard = []-	names (H.PIrrPat n) = names n+	names :: H.Pat H.SrcSpanInfo -> [H.Name H.SrcSpanInfo]+	names (H.PVar _ n) = [n]+	names (H.PNPlusK _ n _) = [n]+	names (H.PInfixApp _ l _ r) = names l ++ names r+	names (H.PApp _ _ ns) = concatMap names ns+	names (H.PTuple _ _ ns) = concatMap names ns+	names (H.PList _ ns) = concatMap names ns+	names (H.PParen _ n) = names n+	names (H.PRec _ _ pf) = concatMap fieldNames pf+	names (H.PAsPat _ n ns) = n : names ns+	names (H.PWildCard _) = []+	names (H.PIrrPat _ n) = names n 	names (H.PatTypeSig _ n _) = names n-	names (H.PViewPat _ n) = names n-	names (H.PBangPat n) = names n+	names (H.PViewPat _ _ n) = names n+	names (H.PBangPat _ n) = names n 	names _ = [] -	fieldNames :: H.PatField -> [H.Name]-	fieldNames (H.PFieldPat _ n) = names n-	fieldNames (H.PFieldPun n) = case n of-		H.Qual _ n' -> [n']-		H.UnQual n' -> [n']+	fieldNames :: H.PatField H.SrcSpanInfo -> [H.Name H.SrcSpanInfo]+	fieldNames (H.PFieldPat _ _ n) = names n+	fieldNames (H.PFieldPun _ n) = case n of+		H.Qual _ _ n' -> [n']+		H.UnQual _ n' -> [n'] 		_ -> []-	fieldNames H.PFieldWildcard = []+	fieldNames (H.PFieldWildcard _) = [] getDef _ = []  -- | Make function declaration by location, name and function type-mkFun :: H.SrcLoc -> H.Name -> DeclarationInfo -> Declaration+mkFun :: H.SrcSpanInfo -> H.Name H.SrcSpanInfo -> DeclarationInfo -> Declaration mkFun loc n = setPosition loc . decl (identOfName n)  -- | Make function from arguments and result -- -- @[a, b, c...] `tyFun` r == a `TyFun` b `TyFun` c ... `TyFun` r@-tyFun :: [H.Type] -> H.Type -> H.Type-tyFun as' r' = foldr H.TyFun r' as'+tyFun :: [H.Type H.SrcSpanInfo] -> H.Type H.SrcSpanInfo -> H.Type H.SrcSpanInfo+tyFun as' r' = foldr (H.TyFun H.noSrcSpan) r' as'  -- | Get name of qualified name-identOfQName :: H.QName -> (Maybe Text, Text)-identOfQName (H.Qual (H.ModuleName mname) name) = (Just $ fromString mname, identOfName name)-identOfQName (H.UnQual name) = (Nothing, identOfName name)-identOfQName (H.Special sname) = (Nothing, fromString $ H.prettyPrint sname)+identOfQName :: H.QName H.SrcSpanInfo -> (Maybe Text, Text)+identOfQName (H.Qual _ (H.ModuleName _ mname) name) = (Just $ fromString mname, identOfName name)+identOfQName (H.UnQual _ name) = (Nothing, identOfName name)+identOfQName (H.Special _ sname) = (Nothing, fromString $ H.prettyPrint sname)  -- | Get name of @H.Name@-identOfName :: H.Name -> Text+identOfName :: H.Name H.SrcSpanInfo -> Text identOfName name = fromString $ case name of-	H.Ident s -> s-	H.Symbol s -> s+	H.Ident _ s -> s+	H.Symbol _ s -> s  -- | Print something in one line oneLinePrint :: (H.Pretty a, IsString s) => a -> s@@ -302,12 +317,12 @@ 		H.layout = H.PPOffsideRule, 		H.linePragmas = False } --- | Convert @H.SrcLoc@ to @Position-toPosition :: H.SrcLoc -> Position-toPosition (H.SrcLoc _ l c) = Position l c+-- | Convert @H.SrcSpanInfo@ to @Position+toPosition :: H.SrcSpanInfo -> Position+toPosition s = Position (H.startLine s) (H.startColumn s)  -- | Set @Declaration@ position-setPosition :: H.SrcLoc -> Declaration -> Declaration+setPosition :: H.SrcSpanInfo -> Declaration -> Declaration setPosition loc = set declarationPosition (Just $ toPosition loc)  -- | Adds documentation to declaration

src/HsDev/Project/Types.hs view

@@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
 
 module HsDev.Project.Types (
-	Project(..), projectName, projectPath, projectCabal, projectDescription, project,
+	Project(..), projectName, projectPath, projectCabal, projectDescription, project, absolutiseProjectPaths, relativiseProjectPaths,
 	ProjectDescription(..), projectVersion, projectLibrary, projectExecutables, projectTests,
 	Target(..),
 	Library(..), libraryModules, libraryBuildInfo,
@@ -26,6 +26,7 @@ import Text.Format
 import System.FilePath
 
+import System.Directory.Paths
 import HsDev.Util
 
 -- | Cabal project
@@ -65,6 +66,9 @@ 		v .:: "cabal" <*>
 		v .:: "description"
 
+instance Paths Project where
+	paths f (Project nm p c desc) = Project nm <$> f p <*> f c <*> traverse (paths f) desc
+
 -- | Make project by .cabal file
 project :: FilePath -> Project
 project file = Project {
@@ -78,6 +82,14 @@ 			| takeExtension file' == ".cabal" = file'
 			| otherwise = file' </> (takeBaseName file' <.> "cabal")
 
+-- | Make paths absolute, not relative
+absolutiseProjectPaths :: Project -> Project
+absolutiseProjectPaths proj = absolutise (_projectPath proj) proj
+
+-- | Make paths relative
+relativiseProjectPaths :: Project -> Project
+relativiseProjectPaths proj = relativise (_projectPath proj) proj
+
 data ProjectDescription = ProjectDescription {
 	_projectVersion :: String,
 	_projectLibrary :: Maybe Library,
@@ -105,6 +117,9 @@ 		v .:: "executables" <*>
 		v .:: "tests"
 
+instance Paths ProjectDescription where
+	paths f (ProjectDescription v lib exes tests) = ProjectDescription v <$> traverse (paths f) lib <*> traverse (paths f) exes <*> traverse (paths f) tests
+
 class Target a where
 	buildInfo :: a -> Info
 
@@ -133,6 +148,9 @@ 		splitModule :: String -> [String]
 		splitModule = takeWhile (not . null) . unfoldr (Just . second (drop 1) . break (== '.'))
 
+instance Paths Library where
+	paths f (Library ms info) = Library ms <$> paths f info
+
 -- | Executable
 data Executable = Executable {
 	_executableName :: String,
@@ -160,6 +178,9 @@ 		v .:: "path" <*>
 		v .:: "info"
 
+instance Paths Executable where
+	paths f (Executable n p info) = Executable n <$> f p <*> paths f info
+
 -- | Test
 data Test = Test {
 	_testName :: String,
@@ -187,6 +208,9 @@ 		v .:: "enabled" <*>
 		v .:: "info"
 
+instance Paths Test where
+	paths f (Test n e info) = Test n e <$> paths f info
+
 -- | Build info
 data Info = Info {
 	_infoDepends :: [String],
@@ -205,6 +229,9 @@ 		(_infoGHCOptions l ++ _infoGHCOptions r)
 		(ordNub $ _infoSourceDirs l ++ _infoSourceDirs r)
 
+instance Ord Info where
+	compare l r = compare (_infoSourceDirs l, _infoDepends l, _infoGHCOptions l) (_infoSourceDirs r, _infoDepends r, _infoGHCOptions r)
+
 instance Show Info where
 	show i = unlines $ lang ++ exts ++ opts ++ sources where
 		lang = maybe [] (\l -> ["default-language: " ++ display l]) $ _infoLanguage i
@@ -235,6 +262,9 @@ 			parseDT :: Distribution.Text.Text a => String -> String -> Parser a
 			parseDT typeName v = maybe err return (simpleParse v) where
 				err = fail $ "Can't parse {}: {}" ~~ typeName ~~ v
+
+instance Paths Info where
+	paths f (Info deps lang exts opts dirs) = Info deps lang exts opts <$> traverse f dirs
 
 -- | Entity with project extensions
 data Extensions a = Extensions {

src/HsDev/Sandbox.hs view

@@ -6,8 +6,9 @@ 	findSandbox, searchSandbox, sandboxPackageDbStack, searchPackageDbStack, restorePackageDbStack,
 
 	-- * cabal-sandbox util
-	cabalSandboxLib, cabalSandboxPackageDb
-	-- * stack-work util
+	cabalSandboxLib, cabalSandboxPackageDb,
+
+	getModuleOpts
 	) where
 
 import Control.Arrow
@@ -28,8 +29,10 @@ 
 import System.Directory.Paths
 import HsDev.PackageDb
-import HsDev.Scan.Browse (withPackages)
+import HsDev.Scan.Browse (withPackages, browsePackages)
 import HsDev.Stack
+import HsDev.Symbols (moduleOpts)
+import HsDev.Symbols.Types (Module(..), ModuleLocation(..), moduleLocation)
 import HsDev.Tools.Ghc.Compat as Compat
 import HsDev.Util (searchPath)
 
@@ -133,3 +136,16 @@ -- | Get sandbox package-db: <arch>-<platform>-<compiler>-<version>-packages.conf.d
 cabalSandboxPackageDb :: MonadLog m => m FilePath
 cabalSandboxPackageDb = liftM (++ "-packages.conf.d") cabalSandboxLib
+
+-- | Options for GHC for module and project
+getModuleOpts :: MonadLog m => [String] -> Module -> m [String]
+getModuleOpts opts m = do
+	pdbs <- case view moduleLocation m of
+		FileModule fpath _ -> searchPackageDbStack fpath
+		InstalledModule pdb _ _ -> restorePackageDbStack pdb
+		ModuleSource _ -> return userDb
+	pkgs <- browsePackages opts pdbs
+	return $ concat [
+		packageDbStackOpts pdbs,
+		moduleOpts pkgs m,
+		opts]

src/HsDev/Scan.hs view

@@ -26,7 +26,7 @@ 
 import HsDev.Error
 import HsDev.Scan.Browse (browsePackages, browseModules)
-import HsDev.Server.Types (FileContents(..), CommandMonad(..))
+import HsDev.Server.Types (FileSource(..), CommandMonad(..))
 import HsDev.Sandbox
 import HsDev.Symbols
 import HsDev.Symbols.Types
@@ -100,11 +100,11 @@ 					return $ ScanContents (filter ((== Just f) . preview (_1 . moduleFile)) mods) [] []
 		| otherwise = enumDirectory f
 
-instance EnumContents FileContents where
-	enumContents (FileContents f cts)
+instance EnumContents FileSource where
+	enumContents (FileSource f mcts)
 		| haskellSource f = do
 			ScanContents [(m, opts, _)] _ _ <- enumContents f
-			return $ ScanContents [(m, opts, Just cts)] [] []
+			return $ ScanContents [(m, opts, mcts)] [] []
 		| otherwise = return mempty
 
 -- | Enum project sources

src/HsDev/Scan/Browse.hs view

@@ -29,7 +29,7 @@ import HsDev.Symbols
 import HsDev.Error
 import HsDev.Tools.Base (inspect)
-import HsDev.Tools.Ghc.Worker (GhcM(..), runGhcM)
+import HsDev.Tools.Ghc.Worker (GhcM, runGhcM, SessionTarget(..), workerSession)
 import HsDev.Tools.Ghc.Compat as Compat
 import HsDev.Util (ordNub)
 
@@ -89,23 +89,24 @@ 
 browseModule :: PackageDb -> GHC.PackageConfig -> GHC.Module -> GhcM Module
 browseModule pdb package' m = do
+	df <- GHC.getSessionDynFlags
 	mi <- GHC.getModuleInfo m >>= maybe (hsdevError $ BrowseNoModuleInfo thisModule) return
-	ds <- mapM (toDecl mi) (GHC.modInfoExports mi)
+	ds <- mapM (toDecl df mi) (GHC.modInfoExports mi)
 	return Module {
 		_moduleName = fromString thisModule,
 		_moduleDocs = Nothing,
-		_moduleLocation = thisLoc,
+		_moduleLocation = thisLoc df,
 		_moduleExports = Just [ExportName Nothing (view declarationName d) ThingNothing | d <- ds],
 		_moduleImports = [import_ iname | iname <- ordNub (mapMaybe (preview definedModule) ds), iname /= fromString thisModule],
 		_moduleDeclarations = sortDeclarations ds }
 	where
 		thisModule = GHC.moduleNameString (GHC.moduleName m)
-		thisLoc = view moduleIdLocation $ mloc m
-		mloc m' = ModuleId (fromString mname') $
-			ghcModuleLocation pdb package' m'
+		thisLoc df = view moduleIdLocation $ mloc df m
+		mloc df m' = ModuleId (fromString mname') $
+			ghcModuleLocation pdb (fromMaybe package' $ GHC.lookupPackage df (moduleUnitId m')) m'
 			where
 				mname' = GHC.moduleNameString $ GHC.moduleName m'
-		toDecl minfo n = do
+		toDecl df minfo n = do
 			tyInfo <- GHC.modInfoLookupName minfo n
 			tyResult <- maybe (inModuleSource n) (return . Just) tyInfo
 			dflag <- GHC.getSessionDynFlags
@@ -113,7 +114,7 @@ 				decl' = decl (fromString $ GHC.getOccString n) $ fromMaybe
 					(Function Nothing [] Nothing)
 					(tyResult >>= showResult dflag)
-			return $ decl' `definedIn` mloc (GHC.nameModule n)
+			return $ decl' `definedIn` mloc df (GHC.nameModule n)
 		definedModule = declarationDefined . _Just . moduleIdName
 		showResult :: GHC.DynFlags -> GHC.TyThing -> Maybe DeclarationInfo
 		showResult dflags (GHC.AnId i) = Just $ Function (Just $ fromString $ formatType dflags GHC.varType i) [] Nothing
@@ -131,6 +132,7 @@ 
 withInitializedPackages :: MonadLog m => [String] -> (GHC.DynFlags -> GhcM a) -> m a
 withInitializedPackages ghcOpts cont = runGhcM (Just GHC.libdir) $ do
+	workerSession $ SessionGhc ghcOpts
 	fs <- GHC.getSessionDynFlags
 	cleanupHandler fs $ do
 		(fs', _, _) <- GHC.parseDynamicFlags fs (map GHC.noLoc ghcOpts)

src/HsDev/Server/Base.hs view

@@ -102,8 +102,7 @@ #if mingw32_HOST_OS
 	mmapPool <- Just <$> createPool "hsdev"
 #endif
-	ghcw <- withLog (sessionLogger slog) $ ghcWorker [] (return ())
-	ghciw <- withLog (sessionLogger slog) ghciWorker
+	ghcw <- withLog (sessionLogger slog) $ ghcWorker
 	defs <- getDefines
 	let
 		session = Session
@@ -116,7 +115,6 @@ 			mmapPool
 #endif
 			ghcw
-			ghciw
 			(do
 				outputStr Log.Trace "stopping server"
 				signalQSem waitSem)

src/HsDev/Server/Commands.hs view

@@ -163,7 +163,8 @@ 		bracket (liftIO $ makeSocket (serverPort sopts)) (liftIO . close) $ \s -> do
 			liftIO $ do
 				setSocketOption s ReuseAddr 1
-				bind s $ sockAddr (serverPort sopts) iNADDR_ANY
+				addr' <- inet_addr "127.0.0.1"
+				bind s (sockAddr (serverPort sopts) addr')
 				listen s maxListenQueue
 			forever $ logAsync (Log.log Log.Fatal . fromString) $ logIO "exception: " (Log.log Log.Error . fromString) $ do
 				Log.log Log.Trace "accepting connection"
@@ -315,23 +316,24 @@ 				Left em -> do
 					Log.log Log.Warning $ "Invalid request {}" ~~ fromUtf8 req'
 					answer $ set msg (Message Nothing $ responseError $ RequestError "invalid request" $ fromUtf8 req') em
-				Right m -> Log.scope (T.pack $ fromMaybe "_" (view (msg . messageId) m)) $ do
-					resp' <- flip (traverseOf (msg . message)) m $ \(Request c cdir noFile tm silent) -> do
-						let
-							onNotify n
-								| silent = return ()
-								| otherwise = traverseOf (msg . message) (const $ mmap' noFile (Response $ Left n)) m >>= answer
-						Log.log Log.Trace $ "{} >> {}" ~~ name ~~ fromUtf8 (encode c)
-						resp <- liftIO $ fmap (Response . Right) $ handleTimeout tm $ hsdevLiftIO $ withSession s $
-							processRequest
-								CommandOptions {
-									commandOptionsRoot = cdir,
-									commandOptionsNotify = withSession s . onNotify,
-									commandOptionsLink = void (swapMVar linkVar exit),
-									commandOptionsHold = forever (F.getChan rchan) }
-								c
-						mmap' noFile resp
-					answer resp'
+				Right m -> void $ liftIO $ forkIO $ withSession s $
+					Log.scope (T.pack $ fromMaybe "_" (view (msg . messageId) m)) $ do
+						resp' <- flip (traverseOf (msg . message)) m $ \(Request c cdir noFile tm silent) -> do
+							let
+								onNotify n
+									| silent = return ()
+									| otherwise = traverseOf (msg . message) (const $ mmap' noFile (Response $ Left n)) m >>= answer
+							Log.log Log.Trace $ "{} >> {}" ~~ name ~~ fromUtf8 (encode c)
+							resp <- liftIO $ fmap (Response . Right) $ handleTimeout tm $ hsdevLiftIO $ withSession s $
+								processRequest
+									CommandOptions {
+										commandOptionsRoot = cdir,
+										commandOptionsNotify = withSession s . onNotify,
+										commandOptionsLink = void (swapMVar linkVar exit),
+										commandOptionsHold = forever (F.getChan rchan) }
+									c
+							mmap' noFile resp
+						answer resp'
 	where
 		handleTimeout :: Int -> IO Result -> IO Result
 		handleTimeout 0 = id

src/HsDev/Server/Types.hs view

@@ -1,21 +1,22 @@-{-# LANGUAGE OverloadedStrings, CPP, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, ConstraintKinds, TemplateHaskell #-}
+{-# LANGUAGE OverloadedStrings, CPP, TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, FlexibleContexts, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, ConstraintKinds #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module HsDev.Server.Types (
 	ServerMonadBase,
 	SessionLog(..), Session(..), SessionMonad(..), askSession, ServerM(..),
 	CommandOptions(..), CommandMonad(..), askOptions, ClientM(..),
-	withSession, serverListen, serverSetLogRules, serverWait, serverUpdateDB, serverWriteCache, serverReadCache, serverExit, commandRoot, commandNotify, commandLink, commandHold,
+	withSession, serverListen, serverSetLogRules, serverWait, serverUpdateDB, serverWriteCache, serverReadCache, inSessionGhc, serverExit, commandRoot, commandNotify, commandLink, commandHold,
 	ServerCommand(..), ConnectionPort(..), ServerOpts(..), silentOpts, ClientOpts(..), serverOptsArgs, Request(..),
 
 	Command(..), AddedContents(..),
 	AutoFixCommand(..),
-	FileContents(..), TargetFilter(..), SearchQuery(..), SearchType(..),
+	FileSource(..), TargetFilter(..), SearchQuery(..), SearchType(..),
 	FromCmd(..),
 	) where
 
 import Control.Applicative
 import Control.Concurrent.MVar (MVar, swapMVar)
+import Control.Concurrent.Worker
 import Control.Lens (each)
 import Control.Monad.Base
 import Control.Monad.Catch
@@ -36,13 +37,15 @@ 
 import HsDev.Database
 import qualified HsDev.Database.Async as DB
+import HsDev.Error (hsdevError)
 import HsDev.Project
 import HsDev.Symbols
 import HsDev.Server.Message
 import HsDev.Watcher.Types (Watcher)
-import HsDev.Tools.Ghc.Worker (Worker, GhcM)
+import HsDev.Tools.Ghc.Worker (GhcWorker, GhcM)
 import HsDev.Tools.Types (Note, OutputMessage)
 import HsDev.Tools.AutoFix (Correction)
+import HsDev.Types (HsDevError(..))
 import HsDev.Util
 
 #if mingw32_HOST_OS
@@ -66,8 +69,7 @@ #if mingw32_HOST_OS
 	sessionMmapPool :: Maybe Pool,
 #endif
-	sessionGhc :: Worker GhcM,
-	sessionGhci :: Worker GhcM,
+	sessionGhc :: GhcWorker,
 	sessionExit :: IO (),
 	sessionWait :: IO (),
 	sessionDefines :: [(String, String)] }
@@ -169,6 +171,12 @@ 	read' <- askSession sessionReadCache
 	liftIO $ withSession s $ read' act
 
+-- | In ghc session
+inSessionGhc :: SessionMonad m => GhcM a -> m a
+inSessionGhc act = do
+	ghcw <- askSession sessionGhc
+	inWorkerWith (hsdevError . GhcError . displayException) ghcw act
+
 -- | Exit session
 serverExit :: SessionMonad m => m ()
 serverExit = join . liftM liftIO $ askSession sessionExit
@@ -342,9 +350,8 @@ 		scanProjects :: [FilePath],
 		scanCabal :: Bool,
 		scanSandboxes :: [FilePath],
-		scanFiles :: [FilePath],
+		scanFiles :: [FileSource],
 		scanPaths :: [FilePath],
-		scanContents :: [FileContents],
 		scanGhcOpts :: [String],
 		scanDocs :: Bool,
 		scanInferTypes :: Bool } |
@@ -382,22 +389,18 @@ 		hayooPages :: Int } |
 	CabalList { cabalListPackages :: [String] } |
 	Lint {
-		lintFiles :: [FilePath],
-		lintContents :: [FileContents] } |
+		lintFiles :: [FileSource] } |
 	Check {
-		checkFiles :: [FilePath],
-		checkContents :: [FileContents],
+		checkFiles :: [FileSource],
 		checkGhcOpts :: [String] } |
 	CheckLint {
-		checkLintFiles :: [FilePath],
-		checkLintContents :: [FileContents],
+		checkLintFiles :: [FileSource],
 		checkLintGhcOpts :: [String] } |
 	Types {
-		typesFiles :: [FilePath],
-		typesContents :: [FileContents],
+		typesFiles :: [FileSource],
 		typesGhcOpts :: [String] } |
 	AutoFix { autoFixCommand :: AutoFixCommand } |
-	GhcEval { ghcEvalExpressions :: [String] } |
+	GhcEval { ghcEvalExpressions :: [String], ghcEvalSource :: Maybe FileSource } |
 	Langs |
 	Flags |
 	Link { linkHold :: Bool } |
@@ -417,7 +420,7 @@ 	AutoFixFix [Note Correction] [Note Correction] Bool
 		deriving (Show)
 
-data FileContents = FileContents FilePath String deriving (Show)
+data FileSource = FileSource { fileSource :: FilePath, fileContents :: Maybe String } deriving (Show)
 data TargetFilter =
 	TargetProject String |
 	TargetFile FilePath |
@@ -434,13 +437,12 @@ data SearchType = SearchExact | SearchPrefix | SearchInfix | SearchSuffix | SearchRegex deriving (Show)
 
 instance Paths Command where
-	paths f (Scan projs c cs fs ps fcts ghcs docs infer) = Scan <$>
+	paths f (Scan projs c cs fs ps ghcs docs infer) = Scan <$>
 		each f projs <*>
 		pure c <*>
 		(each . paths) f cs <*>
-		each f fs <*>
+		(each . paths) f fs <*>
 		each f ps <*>
-		(each . paths) f fcts <*>
 		pure ghcs <*>
 		pure docs <*>
 		pure infer
@@ -459,14 +461,15 @@ 	paths f (ResolveScopeModules q fpath) = ResolveScopeModules q <$> f fpath
 	paths f (ResolveScope q g fpath) = ResolveScope q g <$> f fpath
 	paths f (Complete n g fpath) = Complete n g <$> f fpath
-	paths f (Lint fs fcts) = Lint <$> each f fs <*> (each . paths) f fcts
-	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 (Lint fs) = Lint <$> (each . paths) f fs
+	paths f (Check fs ghcs) = Check <$> (each . paths) f fs <*> pure ghcs
+	paths f (CheckLint fs ghcs) = CheckLint <$> (each . paths) f fs <*> pure ghcs
+	paths f (Types fs ghcs) = Types <$> (each . paths) f fs <*> pure ghcs
+	paths f (GhcEval e mf) = GhcEval e <$> traverse (paths f) mf
 	paths _ c = pure c
 
-instance Paths FileContents where
-	paths f (FileContents fpath cts) = FileContents <$> f fpath <*> pure cts
+instance Paths FileSource where
+	paths f (FileSource fpath mcts) = FileSource <$> f fpath <*> pure mcts
 
 instance Paths TargetFilter where
 	paths f (TargetFile fpath) = TargetFile <$> f fpath
@@ -487,9 +490,8 @@ 			many projectArg <*>
 			cabalFlag <*>
 			many sandboxArg <*>
-			many fileArg <*>
-			many (pathArg $ help "path") <*>
 			many cmdP <*>
+			many (pathArg $ help "path") <*>
 			ghcOpts <*>
 			docsFlag <*>
 			inferFlag,
@@ -518,12 +520,12 @@ 		cmd "complete" "show completions for input" (Complete <$> strArgument idm <*> wideFlag <*> ctx),
 		cmd "hayoo" "find declarations online via Hayoo" (Hayoo <$> strArgument idm <*> hayooPageArg <*> hayooPagesArg),
 		cmd "cabal" "cabal commands" (subparser $ cmd "list" "list cabal packages" (CabalList <$> many (strArgument idm))),
-		cmd "lint" "lint source files or file contents" (Lint <$> many fileArg <*> many cmdP),
-		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 "lint" "lint source files or file contents" (Lint <$> many cmdP),
+		cmd "check" "check source files or file contents" (Check <$> many cmdP <*> ghcOpts),
+		cmd "check-lint" "check and lint source files or file contents" (CheckLint <$> many cmdP <*> ghcOpts),
+		cmd "types" "get types for file expressions" (Types <$> many cmdP <*> ghcOpts),
 		cmd "autofix" "autofix commands" (AutoFix <$> cmdP),
-		cmd "ghc" "ghc commands" (subparser $ cmd "eval" "evaluate expression" (GhcEval <$> many (strArgument idm))),
+		cmd "ghc" "ghc commands" (subparser $ cmd "eval" "evaluate expression" (GhcEval <$> many (strArgument idm) <*> optional cmdP)),
 		cmd "langs" "ghc language options" (pure Langs),
 		cmd "flags" "ghc flags" (pure Flags),
 		cmd "link" "link to server" (Link <$> holdFlag),
@@ -537,8 +539,8 @@ 			option readJSON (long "rest" <> metavar "correction" <> short 'r' <> help "update corrections") <*>
 			pureFlag)]
 
-instance FromCmd FileContents where
-	cmdP = option readJSON (long "contents")
+instance FromCmd FileSource where
+	cmdP = option readJSON (long "contents") <|> (FileSource <$> fileArg <*> pure Nothing)
 
 instance FromCmd TargetFilter where
 	cmdP = asum [
@@ -618,13 +620,12 @@ 	toJSON (Listen r) = cmdJson "listen" ["rule" .= r]
 	toJSON (SetLogConfig rs) = cmdJson "set-log" ["rules" .= rs]
 	toJSON (AddData cts) = cmdJson "add" ["data" .= cts]
-	toJSON (Scan projs cabal sboxes fs ps contents ghcs docs' infer') = cmdJson "scan" [
+	toJSON (Scan projs cabal sboxes fs ps ghcs docs' infer') = cmdJson "scan" [
 		"projects" .= projs,
 		"cabal" .= cabal,
 		"sandboxes" .= sboxes,
 		"files" .= fs,
 		"paths" .= ps,
-		"contents" .= contents,
 		"ghc-opts" .= ghcs,
 		"docs" .= docs',
 		"infer" .= infer']
@@ -648,12 +649,12 @@ 	toJSON (Complete q w f) = cmdJson "complete" ["prefix" .= q, "wide" .= w, "file" .= f]
 	toJSON (Hayoo q p ps) = cmdJson "hayoo" ["query" .= q, "page" .= p, "pages" .= ps]
 	toJSON (CabalList ps) = cmdJson "cabal list" ["packages" .= ps]
-	toJSON (Lint fs cs) = cmdJson "lint" ["files" .= fs, "contents" .= cs]
-	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 (Lint fs) = cmdJson "lint" ["files" .= fs]
+	toJSON (Check fs ghcs) = cmdJson "check" ["files" .= fs, "ghc-opts" .= ghcs]
+	toJSON (CheckLint fs ghcs) = cmdJson "check-lint" ["files" .= fs, "ghc-opts" .= ghcs]
+	toJSON (Types fs ghcs) = cmdJson "types" ["files" .= fs, "ghc-opts" .= ghcs]
 	toJSON (AutoFix acmd) = toJSON acmd
-	toJSON (GhcEval exprs) = cmdJson "ghc eval" ["exprs" .= exprs]
+	toJSON (GhcEval exprs f) = cmdJson "ghc eval" ["exprs" .= exprs, "file" .= f]
 	toJSON Langs = cmdJson "langs" []
 	toJSON Flags = cmdJson "flags" []
 	toJSON (Link h) = cmdJson "link" ["hold" .= h]
@@ -671,7 +672,6 @@ 			v .::?! "sandboxes" <*>
 			v .::?! "files" <*>
 			v .::?! "paths" <*>
-			v .::?! "contents" <*>
 			v .::?! "ghc-opts" <*>
 			(v .:: "docs" <|> pure False) <*>
 			(v .:: "infer" <|> pure False)),
@@ -699,12 +699,12 @@ 		guardCmd "complete" v *> (Complete <$> v .:: "prefix" <*> (v .:: "wide" <|> pure False) <*> v .:: "file"),
 		guardCmd "hayoo" v *> (Hayoo <$> v .:: "query" <*> (v .:: "page" <|> pure 0) <*> (v .:: "pages" <|> pure 1)),
 		guardCmd "cabal list" v *> (CabalList <$> v .::?! "packages"),
-		guardCmd "lint" v *> (Lint <$> v .::?! "files" <*> v .::?! "contents"),
-		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"),
+		guardCmd "lint" v *> (Lint <$> v .::?! "files"),
+		guardCmd "check" v *> (Check <$> v .::?! "files" <*> v .::?! "ghc-opts"),
+		guardCmd "check-lint" v *> (CheckLint <$> v .::?! "files" <*> v .::?! "ghc-opts"),
+		guardCmd "types" v *> (Types <$> v .::?! "files" <*> v .::?! "ghc-opts"),
 		AutoFix <$> parseJSON (Object v),
-		guardCmd "ghc eval" v *> (GhcEval <$> v .::?! "exprs"),
+		guardCmd "ghc eval" v *> (GhcEval <$> v .::?! "exprs" <*> v .::? "file"),
 		guardCmd "langs" v *> pure Langs,
 		guardCmd "flags" v *> pure Flags,
 		guardCmd "link" v *> (Link <$> (v .:: "hold" <|> pure False)),
@@ -730,11 +730,11 @@ 		guardCmd "autofix show" v *> (AutoFixShow <$> v .:: "messages"),
 		guardCmd "autofix fix" v *> (AutoFixFix <$> v .:: "messages" <*> v .::?! "rest" <*> (v .:: "pure" <|> pure True))]
 
-instance ToJSON FileContents where
-	toJSON (FileContents fpath cts) = object ["file" .= fpath, "contents" .= cts]
+instance ToJSON FileSource where
+	toJSON (FileSource fpath mcts) = object ["file" .= fpath, "contents" .= mcts]
 
-instance FromJSON FileContents where
-	parseJSON = withObject "file-contents" $ \v -> FileContents <$> v .:: "file" <*> v .:: "contents"
+instance FromJSON FileSource where
+	parseJSON = withObject "file-contents" $ \v -> FileSource <$> v .:: "file" <*> v .::? "contents"
 
 instance ToJSON TargetFilter where
 	toJSON (TargetProject pname) = object ["project" .= pname]

src/HsDev/Stack.hs view

@@ -61,10 +61,10 @@ stack :: MonadLog m => [String] -> m String
 stack cmd' = hsdevLiftIO $ do
 	curExe <- liftIO getExecutablePath
-	Util.withCurrentDirectory (takeDirectory curExe) $ do
-		stackExe <- liftIO (findExecutable "stack") >>= maybe (hsdevError $ ToolNotFound "stack") return
-		comp <- stackCompiler
-		liftIO $ readProcess stackExe (cmd' ++ ["--compiler", comp, "--arch", stackArch]) ""
+	stackExe <- Util.withCurrentDirectory (takeDirectory curExe) $
+		liftIO (findExecutable "stack") >>= maybe (hsdevError $ ToolNotFound "stack") return
+	comp <- stackCompiler
+	liftIO $ readProcess stackExe (cmd' ++ ["--compiler", comp, "--arch", stackArch]) ""
 
 -- | Make yaml opts
 yaml :: Maybe FilePath -> [String]
@@ -116,13 +116,9 @@ 
 -- | Projects paths
 projectEnv :: MonadLog m => FilePath -> m StackEnv
-projectEnv p = hsdevLiftIO $ do
-	hasConfig <- liftIO $ doesFileExist yaml'
-	unless hasConfig $ hsdevError $ FileNotFound yaml'
-	paths' <- path (Just yaml')
-	maybe (hsdevError $ ToolError "stack" "can't get paths") return $ getStackEnv paths'
-	where
-		yaml' = p </> "stack.yaml"
+projectEnv p = hsdevLiftIO $ Util.withCurrentDirectory p $ do
+	paths' <- path Nothing
+	maybe (hsdevError $ ToolError "stack" ("can't get paths for " ++ p)) return $ getStackEnv paths'
 
 -- | Get package-db stack for stack environment
 stackPackageDbStack :: Lens' StackEnv PackageDbStack

src/HsDev/Symbols.hs view

@@ -55,8 +55,6 @@ import System.Directory
 import System.FilePath
 
-import System.Directory.Paths
-
 import HsDev.Symbols.Types
 import HsDev.Symbols.Class
 import HsDev.Symbols.Documented (Documented(..))
@@ -198,14 +196,6 @@ 		merge' [] = error "mergeExported: impossible"
 		merge' ds@(d:_) = ExportedDeclaration (map (view declarationModuleId) ds) (view moduleDeclaration d)
 
-instance Paths Project where
-	paths f (Project nm p c desc) = Project nm <$> f p <*> f c <*> pure desc
-
-instance Paths ModuleLocation where
-	paths f (FileModule fpath p) = FileModule <$> f fpath <*> traverse (paths f) p
-	paths f (InstalledModule c p n) = InstalledModule <$> paths f c <*> pure p <*> pure n
-	paths _ (ModuleSource m) = pure $ ModuleSource m
-
 -- | Find project file is related to
 locateProject :: FilePath -> IO (Maybe Project)
 locateProject file = do
@@ -237,7 +227,7 @@ -- | Make `Info` for standalone `Module`
 standaloneInfo :: [PackageConfig] -> Module -> Info
 standaloneInfo pkgs m = mempty { _infoDepends = pkgDeps ^.. each . package . packageName } where
-	pkgDeps = catMaybes [M.lookup mdep pkgMap >>= listToMaybe | mdep <- m ^.. moduleImports . each . importModuleName]
+	pkgDeps = catMaybes [M.lookup mdep pkgMap >>= listToMaybe | mdep <- "Prelude" : (m ^.. moduleImports . each . importModuleName)]
 	pkgMap = M.unionsWith mergePkgs [M.singleton m' [p] | p <- pkgs, m' <- view packageModules p]
 	mergePkgs ls rs = if null es then hs else es where
 		(es, hs) = partition (view packageExposed) $ uniqueBy (view package) (ls ++ rs)

src/HsDev/Symbols/Location.hs view

@@ -33,6 +33,7 @@ import System.FilePath
 import Text.Read (readMaybe)
 
+import System.Directory.Paths
 import HsDev.PackageDb
 import HsDev.Project.Types
 import HsDev.Util ((.::), (.::?), (.::?!), objectUnion)
@@ -131,6 +132,11 @@ 		(FileModule <$> v .:: "file" <*> (fmap project <$> (v .:: "project"))) <|>
 		(InstalledModule <$> v .:: "db" <*> fmap (join . fmap readMaybe) (v .:: "package") <*> v .:: "name") <|>
 		(ModuleSource <$> v .::? "source")
+
+instance Paths ModuleLocation where
+	paths f (FileModule fpath p) = FileModule <$> f fpath <*> traverse (paths f) p
+	paths f (InstalledModule c p n) = InstalledModule <$> paths f c <*> pure p <*> pure n
+	paths _ (ModuleSource m) = pure $ ModuleSource m
 
 noLocation :: ModuleLocation
 noLocation = ModuleSource Nothing

src/HsDev/Symbols/Resolve.hs view

@@ -7,8 +7,9 @@ 	mergeImported
 	) where
 
+import Control.Applicative ((<|>))
 import Control.Arrow
-import Control.Lens (makeLenses, view, preview, set, _Just)
+import Control.Lens (makeLenses, view, preview, set, _Just, over, each)
 import Control.Monad.Reader
 import Control.Monad.State
 import Data.Function (on)
@@ -76,8 +77,8 @@ 	resolveModule' = save $ case view moduleLocation m of
 		InstalledModule {} -> return ResolvedModule {
 			_resolvedModule = m,
-			_resolvedScope = view moduleDeclarations m,
-			_resolvedExports = view moduleDeclarations m }
+			_resolvedScope = map setSelfDefined $ view moduleDeclarations m,
+			_resolvedExports = map setSelfDefined $ view moduleDeclarations m }
 		_ -> do
 			scope' <-
 				liftM (thisDecls ++) .
@@ -91,6 +92,10 @@ 			return $ ResolvedModule m (sortDeclarations scope') (sortDeclarations exported')
 	thisDecls :: [Declaration]
 	thisDecls = map (selfDefined . selfImport) $ view moduleDeclarations m
+	setSelfDefined :: Declaration -> Declaration
+	setSelfDefined =
+		over (declaration . localDeclarations . each . declarationDefined) (<|> Just (view moduleId m)) .
+		over declarationDefined (<|> Just (view moduleId m))
 	selfDefined :: Declaration -> Declaration
 	selfDefined = set declarationDefined (Just $ view moduleId m)
 	selfImport :: Declaration -> Declaration

src/HsDev/Symbols/Types.hs view

@@ -304,7 +304,7 @@ 
 -- | Common info for type, newtype, data and class
 data TypeInfo = TypeInfo {
-	_typeInfoContext :: Maybe Text,
+	_typeInfoContext :: Maybe Text, -- FIXME: Why not list of contexts?
 	_typeInfoArgs :: [Text],
 	_typeInfoDefinition :: Maybe Text,
 	_typeInfoFunctions :: [Text] }

src/HsDev/Tools/ClearImports.hs view

@@ -35,7 +35,8 @@ 		Exts.ParseFailed loc err -> throwError $
 			"Failed to parse file at " ++
 			Exts.prettyPrint loc ++ ":" ++ err
-		Exts.ParseOk (Exts.Module _ (Exts.ModuleName mname) _ _ _ _ _) -> return mname
+		Exts.ParseOk (Exts.Module _ (Just (Exts.ModuleHead _ (Exts.ModuleName _ mname) _ _)) _ _ _) -> return mname
+		_ -> throwError "Error"
 
 	void $ liftE $ runGhc (Just libdir) $ do
 		df <- getSessionDynFlags

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

@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards, OverloadedStrings #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module HsDev.Tools.Ghc.Check (
 	checkFiles, check, checkFile, checkSource,
@@ -25,8 +25,6 @@ import Control.Concurrent.FiniteChan
 import HsDev.Error
 import HsDev.PackageDb
-import HsDev.Scan.Browse (browsePackages)
-import HsDev.Symbols (moduleOpts)
 import HsDev.Symbols.Location
 import HsDev.Symbols.Types
 import HsDev.Tools.Base
@@ -36,34 +34,29 @@ import HsDev.Util (readFileUtf8, ordNub)
 
 -- | Check files and collect warnings and errors
-checkFiles :: (MonadLog m, GhcMonad m) => [String] -> PackageDbStack -> [FilePath] -> Maybe Project -> m [Note OutputMessage]
-checkFiles opts pdbs files _ = scope "check-files" $ do
+checkFiles :: (MonadLog m, GhcMonad m) => [String] -> [FilePath] -> Maybe Project -> m [Note OutputMessage]
+checkFiles opts files _ = scope "check-files" $ do
 	ch <- liftIO newChan
 	withFlags $ do
 		modifyFlags $ setLogAction $ logToChan ch
-		_ <- setCmdOpts ("-Wall" : (packageDbStackOpts pdbs ++ opts))
+		addCmdOpts opts
 		clearTargets
 		mapM (`makeTarget` Nothing) files >>= loadTargets
 	notes <- liftIO $ stopChan ch
 	liftIO $ recalcNotesTabs notes
 
 -- | Check module source
-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
+check :: (MonadLog m, GhcMonad m) => [String] -> Module -> Maybe String -> m [Note OutputMessage]
+check opts m msrc = scope "check" $ case view moduleLocation m of
 	FileModule file proj -> do
 		ch <- liftIO newChan
-		pkgs <- browsePackages opts pdbs
 		let
 			dir = fromMaybe
 				(sourceModuleRoot (view moduleName m) file) $
 				preview (_Just . projectPath) proj
 		dirExist <- liftIO $ doesDirectoryExist dir
 		withFlags $ (if dirExist then withCurrentDirectory dir else id) $ do
-			_ <- setCmdOpts $ concat [
-				["-Wall"],
-				packageDbStackOpts pdbs,
-				moduleOpts pkgs m,
-				opts]
+			addCmdOpts opts
 			modifyFlags $ setLogAction $ logToChan ch
 			clearTargets
 			target <- makeTarget (makeRelative dir file) msrc
@@ -73,12 +66,12 @@ 	_ -> scope "check" $ hsdevError $ ModuleNotSource (view moduleLocation m)
 
 -- | Check module and collect warnings and errors
-checkFile :: (MonadLog m, GhcMonad m) => [String] -> PackageDbStack -> Module -> m [Note OutputMessage]
-checkFile opts pdbs m = check opts pdbs m Nothing
+checkFile :: (MonadLog m, GhcMonad m) => [String] -> Module -> m [Note OutputMessage]
+checkFile opts m = check opts m Nothing
 
 -- | Check module and collect warnings and errors
-checkSource :: (MonadLog m, GhcMonad m) => [String] -> PackageDbStack -> Module -> String -> m [Note OutputMessage]
-checkSource opts pdbs m src = check opts pdbs m (Just src)
+checkSource :: (MonadLog m, GhcMonad m) => [String] -> Module -> String -> m [Note OutputMessage]
+checkSource opts m src = check opts m (Just src)
 
 -- Recalc tabs for notes
 recalcNotesTabs :: [Note OutputMessage] -> IO [Note OutputMessage]

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

@@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module HsDev.Tools.Ghc.Compat (
-	pkgDatabase, UnitId, unitId, depends, getPackageDetails, patSynType, cleanupHandler, renderStyle,
+	pkgDatabase, UnitId, unitId, moduleUnitId, depends, getPackageDetails, patSynType, cleanupHandler, renderStyle,
 	LogAction, setLogAction,
 	languages, flags
 	) where
@@ -40,6 +40,13 @@ unitId = GHC.packageKey
 #endif
 
+moduleUnitId :: GHC.Module -> UnitId
+#if __GLASGOW_HASKELL__ == 800
+moduleUnitId = GHC.moduleUnitId
+#elif __GLASGOW_HASKELL__ == 710
+moduleUnitId = GHC.modulePackageKey
+#endif
+
 depends :: GHC.DynFlags -> GHC.PackageConfig -> [UnitId]
 #if __GLASGOW_HASKELL__ == 800
 depends _ = GHC.depends
@@ -88,7 +95,7 @@ #if __GLASGOW_HASKELL__ >= 800
 flags = concat [
 	[option | (GHC.FlagSpec option _ _ _) <- GHC.fFlags],
-	[option | (GHC.FlagSpec option _ _ _) <- GHC.wWarningFlags],
+	["warn-" ++ option | (GHC.FlagSpec option _ _ _) <- GHC.wWarningFlags],
 	[option | (GHC.FlagSpec option _ _ _) <- GHC.fLangFlags]]
 #elif __GLASGOW_HASKELL__ >= 710
 flags = concat [

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

@@ -0,0 +1,207 @@+{-# LANGUAGE UnicodeSyntax, GeneralizedNewtypeDeriving, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses, UndecidableInstances #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Tools.Ghc.MGhc (
+	SessionState(..), sessionActive, sessionMap,
+	MGhcT(..), runMGhcT, liftGhc,
+	hasSession, findSession, findSessionBy, saveSession,
+	initSession, newSession,
+	switchSession, switchSession_,
+	deleteSession, restoreSession, usingSession
+	) where
+
+import Control.Lens
+import Control.Monad.Catch
+import Control.Monad.Reader
+import Control.Monad.State
+import Data.Default
+import Data.IORef
+import Data.List (find)
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Maybe (fromMaybe, isJust)
+import System.Log.Simple
+
+import DynFlags
+import Exception hiding (catch, mask, uninterruptibleMask, bracket)
+import GHC
+import GhcMonad
+import HscTypes
+import Outputable
+import Packages
+import SysTools
+
+data SessionState s = SessionState {
+	_sessionActive :: Maybe s,
+	_sessionMap :: Map s HscEnv }
+
+instance Default (SessionState s) where
+	def = SessionState Nothing M.empty
+
+sessionActive :: Lens' (SessionState s) (Maybe s)
+sessionActive = lens g s where
+	g = _sessionActive
+	s st nm = st { _sessionActive = nm }
+
+sessionMap :: Lens' (SessionState s) (Map s HscEnv)
+sessionMap = lens g s where
+	g = _sessionMap
+	s st m = st { _sessionMap = m }
+
+instance ExceptionMonad m => ExceptionMonad (StateT s m) where
+	gcatch act onError = StateT $ \st -> gcatch (runStateT act st) (\e -> runStateT (onError e) st)
+	gmask f = StateT $ gmask . f' where
+		f' st' act' = runStateT (f act) st' where
+			act st = StateT $ act' . runStateT st
+
+instance ExceptionMonad m => ExceptionMonad (ReaderT r m) where
+	gcatch act onError = ReaderT $ \v -> gcatch (runReaderT act v) (\e -> runReaderT (onError e) v)
+	gmask f = ReaderT $ gmask . f' where
+		f' v' act' = runReaderT (f act) v' where
+			act v = ReaderT $ act' . runReaderT v
+
+-- | Multi-session ghc monad
+newtype MGhcT s m a = MGhcT { unMGhcT :: GhcT (ReaderT (Maybe FilePath) (StateT (SessionState s) m)) a }
+	deriving (Functor, Applicative, Monad, MonadIO, ExceptionMonad, HasDynFlags, GhcMonad, MonadState (SessionState s), MonadReader (Maybe FilePath), MonadThrow, MonadCatch, MonadMask, MonadLog)
+
+instance MonadTrans GhcT where
+	lift = liftGhcT
+
+instance MonadState st m => MonadState st (GhcT m) where
+	get = lift get
+	put = lift . put
+	state = lift . state
+
+instance MonadReader r m => MonadReader r (GhcT m) where
+	ask = lift ask
+	local f act = GhcT $ local f . unGhcT act
+
+instance MonadThrow m => MonadThrow (GhcT m) where
+	throwM = lift . throwM
+
+instance MonadCatch m => MonadCatch (GhcT m) where
+	catch act onError = GhcT $ \sess -> catch (unGhcT act sess) (flip unGhcT sess . onError)
+
+instance MonadMask m => MonadMask (GhcT m) where
+	mask f = GhcT $ \s -> mask $ \g -> unGhcT (f $ q g) s where
+		q g' act = GhcT $ g' . unGhcT act
+	uninterruptibleMask f = GhcT $ \s -> uninterruptibleMask $ \g -> unGhcT (f $ q g) s where
+		q g' act = GhcT $ g' . unGhcT act
+
+instance MonadLog m => MonadLog (GhcT m) where
+	askLog = lift askLog
+
+-- | Run multi-session ghc
+runMGhcT :: (MonadIO m, ExceptionMonad m, Ord s) => Maybe FilePath -> MGhcT s m a -> m a
+runMGhcT lib act = do
+	ref <- liftIO $ newIORef (panic "empty session")
+	let
+		session = Session ref
+	flip evalStateT def $ flip runReaderT lib $ flip unGhcT session $ unMGhcT $ act `gfinally` cleanup
+	where
+		cleanup :: (MonadIO m, ExceptionMonad m, Ord s) => MGhcT s m ()
+		cleanup = do
+			void saveSession
+			sessions <- gets (M.elems . view sessionMap)
+			liftIO $ mapM_ cleanupSession sessions
+			modify (set sessionMap M.empty)
+
+-- | Lift `Ghc` monad onto `MGhc`
+liftGhc :: MonadIO m => Ghc a -> MGhcT s m a
+liftGhc (Ghc act) = MGhcT $ GhcT $ liftIO . act
+
+-- | Does session exist
+hasSession :: (MonadIO m, Ord s) => s -> MGhcT s m Bool
+hasSession key = do
+	msess <- gets (preview (sessionMap . ix key))
+	return $ isJust msess
+
+-- | Find session
+findSession :: (MonadIO m, Ord s) => s -> MGhcT s m (Maybe s)
+findSession key = do
+	mkeys <- gets (M.keys . view sessionMap)
+	return $ find (== key) mkeys
+
+-- | Find session by
+findSessionBy :: MonadIO m => (s -> Bool) -> MGhcT s m [s]
+findSessionBy p = do
+	mkeys <- gets (M.keys . view sessionMap)
+	return $ filter p mkeys
+
+-- | Save current session
+saveSession :: (MonadIO m, ExceptionMonad m, Ord s) => MGhcT s m (Maybe s)
+saveSession = do
+	key <- gets (view sessionActive)
+	case key of
+		Just key' -> do
+			sess <- getSession
+			modify (set (sessionMap . at key') (Just sess))
+		Nothing -> return ()
+	return key
+
+-- | Initialize new session
+initSession :: (MonadIO m, ExceptionMonad m, Ord s) => MGhcT s m ()
+initSession = do
+	lib <- ask
+	initGhcMonad lib
+	fs <- getSessionDynFlags
+	void $ setSessionDynFlags fs
+	void $ liftIO $ initPackages fs
+	void saveSession
+
+activateSession :: (MonadIO m, ExceptionMonad m, Ord s) => s -> MGhcT s m (Maybe HscEnv)
+activateSession key = do
+	void saveSession
+	modify (set sessionActive $ Just key)
+	gets (view (sessionMap . at key))
+
+-- | Create new named session, deleting existing session
+newSession :: (MonadIO m, ExceptionMonad m, Ord s) => s -> MGhcT s m ()
+newSession key = do
+	msess <- activateSession key
+	maybe (return ()) (liftIO . cleanupSession) msess
+	initSession
+
+-- | Switch to session, creating if not exist, returns True if session was created
+switchSession :: (MonadIO m, ExceptionMonad m, Ord s) => s -> MGhcT s m Bool
+switchSession key = do
+	msess <- activateSession key
+	case msess of
+		Nothing -> initSession >> return True
+		Just sess -> setSession sess >> return False
+
+-- | Switch to session, creating if not exist and initializing with passed function
+switchSession_ :: (MonadIO m, ExceptionMonad m, Ord s) => s -> Maybe (MGhcT s m ()) -> MGhcT s m ()
+switchSession_ key f = do
+	new <- switchSession key
+	when new $ fromMaybe (return ()) f
+
+-- | Delete existing session
+deleteSession :: (MonadIO m, ExceptionMonad m, Ord s) => s -> MGhcT s m ()
+deleteSession key = do
+	cur <- saveSession
+	when (cur == Just key) $
+		modify (set sessionActive Nothing)
+	msess <- gets (view (sessionMap . at key))
+	modify (set (sessionMap . at key) Nothing)
+	case msess of
+		Nothing -> return ()
+		Just sess -> liftIO $ cleanupSession sess
+
+-- | Save and restore session
+restoreSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s) => MGhcT s m a -> MGhcT s m a
+restoreSession act = bracket saveSession (maybe (return ()) (void . switchSession)) $ const act
+
+-- | Run action using session, restoring session back
+usingSession :: (MonadIO m, MonadMask m, ExceptionMonad m, Ord s) => s -> MGhcT s m a -> MGhcT s m a
+usingSession key act = restoreSession $ do
+	void $ switchSession key
+	act
+
+-- | Cleanup session
+cleanupSession :: HscEnv -> IO ()
+cleanupSession env = do
+	cleanTempFiles df
+	cleanTempDirs df
+	where
+		df = hsc_dflags env

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

@@ -0,0 +1,49 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module HsDev.Tools.Ghc.Session (
+	ghcSession, ghciSession, haddockSession, targetSession, interpretModule,
+
+	module HsDev.Tools.Ghc.Worker
+	) where
+
+import Control.Lens
+import Data.Text (unpack)
+import System.FilePath
+
+import Control.Concurrent.Worker
+import HsDev.Symbols.Types
+import HsDev.Sandbox (getModuleOpts)
+import HsDev.Tools.Ghc.Worker
+
+import qualified GHC
+
+-- | Get ghc session
+ghcSession :: [String] -> GhcM ()
+ghcSession = workerSession . SessionGhc
+
+-- | Get ghci session
+ghciSession :: GhcM ()
+ghciSession = workerSession SessionGhci
+
+-- | Get haddock session with flags
+haddockSession :: [String] -> GhcM ()
+haddockSession opts = ghcSession ("-haddock" : opts)
+
+-- | Session for module
+targetSession :: [String] -> Module -> GhcM ()
+targetSession opts m = do
+	opts' <- getModuleOpts opts m
+	ghcSession ("-Wall" : opts')
+
+-- | Interpret file
+interpretModule :: Module -> Maybe String -> GhcM ()
+interpretModule m mcts = do
+	targetSession [] m
+	let
+		f = preview (moduleLocation . moduleFile) m
+	case f of
+		Nothing -> return ()
+		Just f' -> withCurrentDirectory (takeDirectory f') $ do
+			t <- makeTarget (takeFileName f') mcts
+			loadTargets [t]
+			GHC.setContext [GHC.IIModule $ GHC.mkModuleName $ unpack $ view moduleName m]

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

@@ -31,8 +31,6 @@ 
 import System.Directory.Paths (canonicalize)
 import HsDev.Error
-import HsDev.Scan.Browse (browsePackages)
-import HsDev.PackageDb
 import HsDev.Symbols
 import HsDev.Tools.Ghc.Worker as Ghc
 import HsDev.Tools.Ghc.Compat
@@ -101,22 +99,18 @@ 		v .:: "type"
 
 -- | Get all types in module
-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
+fileTypes :: (MonadLog m, GhcMonad m) => [String] -> Module -> Maybe String -> m [Note TypedExpr]
+fileTypes opts m msrc = scope "types" $ case view moduleLocation m of
 	FileModule file proj -> do
 		file' <- liftIO $ canonicalize file
 		cts <- maybe (liftIO $ readFileUtf8 file') return msrc
-		pkgs <- browsePackages opts pdbs
 		let
 			dir = fromMaybe
 				(sourceModuleRoot (view moduleName m) file') $
 				preview (_Just . projectPath) proj
 		dirExist <- liftIO $ doesDirectoryExist dir
 		withFlags $ (if dirExist then Ghc.withCurrentDirectory dir else id) $ do
-			_ <- setCmdOpts $ concat [
-				packageDbStackOpts pdbs,
-				moduleOpts pkgs m,
-				opts]
+			addCmdOpts opts
 			target <- makeTarget (makeRelative dir file') msrc
 			loadTargets [target]
 			ts <- moduleTypes file'
@@ -147,5 +141,5 @@ 		return $ set (declaration . functionType) (Just $ fromString $ view (note . typedType) tnote) d
 
 -- | Infer types in 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
+inferTypes :: (MonadLog m, GhcMonad m) => [String] -> Module -> Maybe String -> m Module
+inferTypes opts m msrc = scope "infer" $ liftM (`setModuleTypes` m) $ fileTypes opts m msrc

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

@@ -1,10 +1,13 @@-{-# LANGUAGE PatternGuards, OverloadedStrings, GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE PatternGuards, OverloadedStrings #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module HsDev.Tools.Ghc.Worker (
 	-- * Workers
-	GhcM(..), runGhcM, liftGhc,
-	ghcWorker, ghciWorker,
+	SessionTarget(..),
+	GhcM, GhcWorker, MGhcT(..), runGhcM,
+	ghcWorker,
+	workerSession,
+
 	-- * Initializers and actions
 	ghcRun,
 	withFlags, modifyFlags, addCmdOpts, setCmdOpts,
@@ -17,33 +20,34 @@ 	logToChan, logToNull,
 
 	Ghc,
+	LogT(..),
 
+	module HsDev.Tools.Ghc.MGhc,
 	module Control.Concurrent.Worker
 	) where
 
 import Control.Monad
-import Control.Monad.Catch
 import Control.Monad.Except
 import Control.Monad.Reader
+import Control.Monad.Catch
 import Data.Dynamic
+import Data.List (intercalate)
 import Data.Maybe
 import Data.Time.Clock (getCurrentTime)
 import Data.Version (showVersion)
-import Packages
-import StringBuffer
 import System.Directory (getCurrentDirectory, setCurrentDirectory)
 import qualified  System.Log.Simple as Log
-import System.Log.Simple.Monad (MonadLog(..))
+import System.Log.Simple.Monad (MonadLog(..), LogT(..), withLog)
 import Text.Read (readMaybe)
 import Text.Format
 
 import Exception (ExceptionMonad(..))
 import GHC hiding (Warning, Module, moduleName, pkgDatabase)
-import GhcMonad (Ghc(..))
 import GHC.Paths
-import DynFlags (HasDynFlags(..))
 import Outputable
 import FastString (unpackFS)
+import Packages
+import StringBuffer
 
 import Control.Concurrent.FiniteChan
 import Control.Concurrent.Worker
@@ -51,51 +55,70 @@ import HsDev.Symbols.Location (Position(..), Region(..), region, ModulePackage, ModuleLocation(..))
 import HsDev.Tools.Types
 import HsDev.Tools.Ghc.Compat
+import HsDev.Tools.Ghc.MGhc
 
-instance MonadThrow Ghc where
-	throwM = liftIO . throwM
+data SessionTarget =
+	SessionGhci |
+	SessionGhc [String]
 
-instance MonadCatch Ghc where
-	catch = gcatch
+instance Show SessionTarget where
+	show SessionGhci = "ghci"
+	show (SessionGhc opts) = "ghc " ++ intercalate ", " opts
 
-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 FormatBuild SessionTarget
 
-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 Eq SessionTarget where
+	SessionGhci == SessionGhci = True
+	SessionGhc lopts == SessionGhc ropts = lopts == ropts
+	_ == _ = False
 
+instance Ord SessionTarget where
+	compare l r = compare (isGhci l) (isGhci r) where
+		isGhci SessionGhci = True
+		isGhci _ = False
+
+type GhcM a = MGhcT SessionTarget (LogT IO) a
+
+type GhcWorker = Worker (MGhcT SessionTarget (LogT IO))
+
 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, MonadMask, MonadThrow, MonadCatch, ExceptionMonad, HasDynFlags, MonadLog, GhcMonad)
+instance ExceptionMonad m => ExceptionMonad (LogT m) where
+	gcatch act onError = LogT $ gcatch (runLogT act) (runLogT . onError)
+	gmask f = LogT $ gmask f' where
+		f' g' = runLogT $ f (LogT . g' . runLogT)
 
+instance MonadThrow Ghc where
+	throwM = liftIO . throwM
+
 runGhcM :: MonadLog m => Maybe FilePath -> GhcM a -> m a
 runGhcM dir act = do
 	l <- askLog
-	liftIO $ runGhc dir (runReaderT (unGhcM act) l)
-
-liftGhc :: Ghc a -> GhcM a
-liftGhc = GhcM . lift
+	liftIO $ withLog l $ runMGhcT dir act
 
--- | Ghc worker. Pass options and initializer action
-ghcWorker :: MonadLog m => [String] -> GhcM () -> m (Worker GhcM)
-ghcWorker opts initialize = do
+-- | Multi-session ghc worker
+ghcWorker :: MonadLog m => m GhcWorker
+ghcWorker = do
 	l <- askLog
-	liftIO $ startWorker (flip runReaderT l . runGhcM (Just libdir)) (ghcRun opts . (initialize >>)) (Log.scope "ghc")
+	liftIO $ startWorker (withLog l . runGhcM (Just libdir)) id (Log.scope "ghc")
 
--- | Interpreter worker is worker with @preludeModules@ loaded
-ghciWorker :: MonadLog m => m (Worker GhcM)
-ghciWorker = do
-	l <- askLog
-	liftIO $ startWorker (flip runReaderT l . runGhcM (Just libdir)) (ghcRun [] . (importModules preludeModules >>)) (Log.scope "ghc")
+-- | Create session with options
+workerSession :: SessionTarget -> GhcM ()
+workerSession SessionGhci = do
+	Log.log Log.Trace $ "session: {}" ~~ SessionGhci
+	switchSession_ SessionGhci $ Just $ ghcRun [] (importModules preludeModules)
+workerSession s@(SessionGhc opts) = do
+	ms <- findSessionBy isGhcSession
+	forM_ ms $ \s'@(SessionGhc opts') -> when (opts /= opts') $ do
+		Log.log Log.Trace $ "killing session: {}" ~~ s'
+		deleteSession s'
+	Log.log Log.Trace $ "session: {}" ~~ s
+	switchSession_ s $ Just $ ghcRun opts (return ())
+	where
+		isGhcSession (SessionGhc _) = True
+		isGhcSession _ = False
 
 -- | Run ghc
 ghcRun :: GhcMonad m => [String] -> m a -> m a
@@ -110,6 +133,7 @@ 			-- ghcLink = NoLink,
 			-- hscTarget = HscNothing }
 		void $ setSessionDynFlags fs''
+		modifyFlags $ setLogAction logToNull
 		f
 
 -- | Alter @DynFlags@ temporary

src/HsDev/Tools/Types.hs view

@@ -12,7 +12,6 @@ import Data.Aeson hiding (Error)
 
 import System.Directory.Paths
-import HsDev.Symbols ()
 import HsDev.Symbols.Location
 import HsDev.Util ((.::), (.::?))

src/HsDev/Util.hs view

@@ -48,6 +48,7 @@ import Data.List (isPrefixOf, unfoldr, intercalate)
 import qualified Data.Map as M
 import Data.Maybe (catMaybes, fromMaybe)
+import Data.Monoid ((<>))
 import qualified Data.Set as Set
 import qualified Data.HashMap.Strict as HM (HashMap, toList, union)
 import qualified Data.ByteString.Char8 as B
@@ -152,9 +153,11 @@ (.::) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser a
 v .:: name = maybe (fail $ "key " ++ show name ++ " not present") parseJSON $ lookup name $ HM.toList v
 
+-- | Returns @Nothing@ when key doesn't exist or value is @Null@
 (.::?) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser (Maybe a)
-v .::? name = traverse parseJSON $ lookup name $ HM.toList v
+v .::? name = fmap join $ traverse parseJSON $ lookup name $ HM.toList v
 
+-- | Same as @.::?@ for list, returns empty list for non-existant key or @Null@ value
 (.::?!) :: FromJSON a => HM.HashMap Text Value -> Text -> A.Parser [a]
 v .::?! name = fromMaybe [] <$> (v .::? name)

src/System/Directory/Paths.hs view

@@ -2,11 +2,14 @@ 
 module System.Directory.Paths (
 	Paths(..),
-	canonicalize
+	canonicalize,
+	absolutise,
+	relativise
 	) where
 
 import Control.Lens
 import System.Directory
+import System.FilePath
 
 -- | Something with paths inside
 class Paths a where
@@ -18,3 +21,11 @@ -- | Canonicalize all paths
 canonicalize :: Paths a => a -> IO a
 canonicalize = paths canonicalizePath
+
+-- | Absolutise paths
+absolutise :: Paths a => FilePath -> a -> a
+absolutise parent = over paths (parent </>)
+
+-- | Relativise paths
+relativise :: Paths a => FilePath -> a -> a
+relativise parent = over paths (makeRelative parent)

tests/Test.hs view

@@ -32,7 +32,7 @@ 		it "should scan project" $ do
 			dir <- getCurrentDirectory
 			s <- startServer (def { serverSilent = True })
-			_ <- call s $ Scan [dir </> "tests/test-package"] False [] [] [] [] [] False False
+			_ <- call s $ Scan [dir </> "tests/test-package"] False [] [] [] [] False False
 			one <- call s $ InfoResolve (dir </> "tests/test-package/ModuleOne.hs") True
 			when (["test", "forkIO", "f"] /= exports one) $
 				expectationFailure "invalid exports of ModuleOne.hs"

tools/Tool.hs view

@@ -8,6 +8,7 @@ 
 	toJSON, Value,
 	module Options.Applicative,
+	module Data.Monoid,
 	module HsDev.Util
 	) where
 
@@ -17,6 +18,7 @@ import Data.Aeson
 import qualified Data.ByteString.Lazy.Char8 as L (putStrLn)
 import Data.Default
+import Data.Monoid
 import Options.Applicative
 import System.Environment
 import System.IO

tools/hsdev.hs view

@@ -7,7 +7,6 @@ import Network.Socket (withSocketsDo)
 import Options.Applicative
 import System.Environment (getArgs)
-import System.Exit
 import System.IO
 
 import HsDev.Server.Commands (runServerCommand)
@@ -20,7 +19,7 @@ 	hSetEncoding stdout utf8
 	as <- prepareArgs
 	case parseArgs "hsdev" (info cmdP (progDesc "hsdev tool")) as of
-		Left e -> putStrLn e >> exitFailure
+		Left e -> putStrLn e
 		Right scmd -> runServerCommand scmd
 	where
 		logErr' (SomeException e) = putStrLn $ "exception " ++ show e
@@ -29,7 +28,7 @@ prepareArgs :: IO [String]
 prepareArgs = getArgs >>= prepare where
 	prepare [] = return []
-	prepare ("head" : as) = prepare $ as ++ ["-?"]
+	prepare ("help" : as) = prepare $ as ++ ["-?"]
 	prepare as
 		| "--stdin" `elem` as = do
 			input <- getContents

tools/hsinspect.hs view

@@ -17,6 +17,7 @@ import HsDev.Symbols.Location (ModuleLocation(..))
 import HsDev.Tools.Ghc.Types (inferTypes)
 import HsDev.Tools.Ghc.Worker
+import HsDev.Tools.Ghc.Session (ghcSession)
 
 import Tool
 
@@ -38,11 +39,11 @@ 		fname' <- liftIO $ canonicalizePath fname
 		defs <- liftIO getDefines
 		im <- scanModule defs ghcs (FileModule fname' Nothing) Nothing
-		ghc <- ghcWorker ghcs (return ())
+		ghc <- ghcWorker	
 		let
 			scanAdditional =
 				scanModify' (\opts' _ -> liftIO . inspectDocs opts') >=>
-				scanModify' (\opts' pdbs m -> liftIO (inWorker ghc (inferTypes opts' pdbs m Nothing)))
+				scanModify' (\opts' _ m -> liftIO (inWorker ghc (ghcSession opts' >> inferTypes opts' m Nothing)))
 		toJSON <$> scanAdditional im
 	inspect' (Opts (Just fcabal@(takeExtension -> ".cabal")) _) = do
 		fcabal' <- liftIO $ canonicalizePath fcabal