hsdev 0.1.2.0 → 0.1.2.1

raw patch · 32 files changed

+593/−270 lines, 32 filesdep +scientificdep ~ghc-moddep ~haskell-src-exts

Dependencies added: scientific

Dependency ranges changed: ghc-mod, haskell-src-exts

Files

hsdev.cabal +8/−4
src/Control/Apply/Util.hs +0/−2
src/Control/Concurrent/Worker.hs +38/−0
src/Data/Async.hs +1/−1
src/Data/Lisp.hs +127/−0
src/HsDev/Cabal.hs +17/−5
src/HsDev/Cache/Structured.hs +2/−3
src/HsDev/Client/Commands.hs +31/−27
src/HsDev/Commands.hs +7/−1
src/HsDev/Database/Update.hs +5/−12
src/HsDev/Inspect.hs +19/−15
src/HsDev/Project.hs +5/−5
src/HsDev/Scan.hs +6/−9
src/HsDev/Scan/Browse.hs +3/−6
src/HsDev/Server/Commands.hs +125/−98
src/HsDev/Server/Message.hs +5/−1
src/HsDev/Server/Types.hs +5/−3
src/HsDev/Symbols.hs +1/−1
src/HsDev/Symbols/Util.hs +0/−1
src/HsDev/Tools/ClearImports.hs +1/−1
src/HsDev/Tools/Ghc/Prelude.hs +15/−0
src/HsDev/Tools/Ghc/Worker.hs +15/−19
src/HsDev/Tools/GhcMod.hs +121/−29
src/HsDev/Tools/GhcMod/InferType.hs +6/−5
src/HsDev/Tools/Hayoo.hs +0/−2
src/HsDev/Util.hs +7/−2
src/System/Console/Cmd.hs +7/−7
src/System/Win32/FileMapping/NamePool.hs +1/−1
src/System/Win32/PowerShell.hs +1/−1
tools/Tool.hs +12/−3
tools/hsclearimports.hs +0/−2
tools/hsdev.hs +2/−4

hsdev.cabal view

@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/
 
 name:                hsdev
-version:             0.1.2.0
+version:             0.1.2.1
 synopsis:            Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references etc.
 description:
   Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.
@@ -22,10 +22,12 @@   exposed-modules:
     Control.Apply.Util
     Control.Concurrent.FiniteChan
+    Control.Concurrent.Worker
     Control.Concurrent.Util
     Data.Async
     Data.Group
     Data.Help
+    Data.Lisp
     HsDev
     HsDev.Cabal
     HsDev.Cache
@@ -51,6 +53,7 @@     HsDev.Tools.Base
     HsDev.Tools.Cabal
     HsDev.Tools.ClearImports
+    HsDev.Tools.Ghc.Prelude
     HsDev.Tools.Ghc.Worker
     HsDev.Tools.GhcMod
     HsDev.Tools.GhcMod.InferType
@@ -85,10 +88,10 @@     directory >= 1.2.0,
     filepath >= 1.3.0,
     ghc >= 7.8.1,
-    ghc-mod >= 5.0.0.0 && < 5.1.0.0,
+    ghc-mod >= 5.1.0.0 && < 5.2.0.0,
     ghc-paths >= 0.1.0,
     haddock-api >= 2.15.0,
-    haskell-src-exts >= 1.14.0,
+    haskell-src-exts >= 1.16.0,
     hdocs >= 0.4.0,
     HTTP >= 4000.2.0,
     MonadCatchIO-transformers >= 0.3.0,
@@ -99,6 +102,7 @@     process >= 1.2.0,
     regexpr >= 0.5.0,
     regex-posix >= 0.95,
+    scientific >= 0.3,
     time >= 1.4.0,
     attoparsec >= 0.11.0,
     template-haskell,
@@ -162,7 +166,7 @@     aeson-pretty >= 0.7.0,
     directory >= 1.2.0,
     ghc >= 7.8.1,
-    haskell-src-exts >= 1.14.0,
+    haskell-src-exts >= 1.16.0,
     containers >= 0.5.0,
     mtl >= 2.1.0,
     text >= 1.1.0,

src/Control/Apply/Util.hs view

@@ -2,8 +2,6 @@ 	(&), chain, with
 	) where
 
-import Data.List (foldr)
-
 (&) :: a -> (a -> b) -> b
 (&) = flip ($)

+ src/Control/Concurrent/Worker.hs view

@@ -0,0 +1,38 @@+module Control.Concurrent.Worker (
+	Worker(..),
+	worker_, worker,
+	stopWorker,
+	ignoreException
+	) where
+
+import Control.Exception (SomeException)
+import Control.Monad (void)
+import Control.Monad.IO.Class
+import Control.Monad.CatchIO
+
+import Control.Concurrent (forkIO)
+import Control.Concurrent.FiniteChan
+
+data Worker a = Worker {
+	sendWork :: a -> IO (),
+	workerChan :: Chan a }
+
+worker_ :: MonadIO m => (m () -> IO ()) -> (m () -> m ()) -> (a -> m b) -> IO (Worker a)
+worker_ run initialize work = worker run initialize' work' where
+	initialize' f = initialize $ f ()
+	work' _ = work
+
+worker :: MonadIO m => (m () -> IO ()) -> ((s -> m ()) -> m ()) -> (s -> a -> m b) -> IO (Worker a)
+worker run initialize work = do
+	ch <- newChan
+	void $ forkIO $ run $ initialize $ \s ->
+		liftIO (readChan ch) >>= mapM_ (work s)
+	return $ Worker (putChan ch) ch
+
+stopWorker :: Worker a -> IO ()
+stopWorker = closeChan . workerChan
+
+ignoreException :: MonadCatchIO m => m () -> m ()
+ignoreException act = catch act onError where
+	onError :: MonadCatchIO m => SomeException -> m ()
+	onError _ = return ()

src/Data/Async.hs view

@@ -30,7 +30,7 @@ newAsync = do
 	var <- newMVar zero
 	events <- newChan
-	forkIO $ do
+	_ <- forkIO $ do
 		evs <- getChanContents events
 		forM_ evs $ \e -> modifyMVar_ var $ \val -> do
 			x' <- event e val

+ src/Data/Lisp.hs view

@@ -0,0 +1,127 @@+module Data.Lisp (
+	Lisp(..),
+	lisp,
+	encodeLisp, decodeLisp
+	) where
+
+import Prelude hiding (String, Bool)
+import qualified Prelude as P (String, Bool)
+
+import Control.Applicative
+import Data.Aeson (ToJSON(..), FromJSON(..), (.=))
+import qualified Data.Aeson as A
+import Data.Aeson.Types (parseMaybe, parseEither)
+import Data.ByteString.Lazy (ByteString)
+import Data.Char (isAlpha, isDigit)
+import Data.Either (partitionEithers)
+import qualified Data.HashMap.Strict as HM
+import Data.List (unfoldr)
+import Data.Scientific
+import Data.String (fromString)
+import qualified Data.Text as T (unpack)
+import qualified Data.Text.Lazy as LT (pack, unpack)
+import qualified Data.Text.Lazy.Encoding as LT (encodeUtf8, decodeUtf8)
+import qualified Text.ParserCombinators.ReadP as R
+import Text.Read (readMaybe)
+import qualified Data.Vector as V
+
+data Lisp =
+	Null |
+	Bool P.Bool |
+	Symbol P.String |
+	String P.String |
+	Number Scientific |
+	List [Lisp]
+		deriving (Eq)
+
+readable :: Read a => Int -> R.ReadP a
+readable = R.readS_to_P . readsPrec
+
+lisp :: Int -> R.ReadP Lisp
+lisp n = R.choice [
+	do
+		s <- symbol
+		return $ case s of
+			"null" -> Null
+			"true" -> Bool True
+			"false" -> Bool False
+			_ -> Symbol s,
+	fmap String string,
+	fmap Number number,
+	fmap List list]
+	where
+		symbol :: R.ReadP P.String
+		symbol = concat <$> sequence [
+			R.option [] (pure <$> R.char ':'),
+			pure <$> R.satisfy isAlpha,
+			R.munch (\ch -> isAlpha ch || isDigit ch || ch == '-')]
+
+		string :: R.ReadP P.String
+		string = (R.<++ R.pfail) $ do
+			('"':_) <- R.look
+			readable n
+
+		number :: R.ReadP Scientific
+		number = do
+			s <- R.munch1 (\ch -> isDigit ch || ch `elem` ['e', 'E', '.', '+', '-'])
+			maybe R.pfail return $ readMaybe s
+
+		list :: R.ReadP [Lisp]
+		list = R.between (R.char '(') (R.char ')') $ R.sepBy (lisp n) R.skipSpaces
+
+instance Read Lisp where
+	readsPrec = R.readP_to_S . lisp
+
+instance Show Lisp where
+	show Null = "null"
+	show (Bool b)
+		| b = "true"
+		| otherwise = "false"
+	show (Symbol s) = s
+	show (String s) = show s
+	show (Number n) = either show show (floatingOrInteger n :: Either Double Integer)
+	show (List vs) = "(" ++ unwords (map show vs) ++ ")"
+
+instance ToJSON Lisp where
+	toJSON Null = toJSON A.Null
+	toJSON (Bool b) = toJSON b
+	toJSON (Symbol s) = toJSON s
+	toJSON (String s) = toJSON s
+	toJSON (Number n) = toJSON n
+	toJSON (List vs)
+		| null keywords = toJSON $ map toJSON vals
+		| null vals = keywordsObject
+		| otherwise = toJSON $ map toJSON vals ++ [keywordsObject]
+		where
+			(vals, keywords) = partitionEithers $ unfoldr cutKeyword vs
+			keywordsObject = A.object [fromString (dropColon k) .= v | (k, v) <- keywords]
+
+			dropColon :: P.String -> P.String
+			dropColon (':' : s) = s
+			dropColon s = s
+
+			cutKeyword :: [Lisp] -> Maybe (Either Lisp (P.String, Lisp), [Lisp])
+			cutKeyword [] = Nothing
+			cutKeyword (Symbol s : []) = Just (Right (s, Null), [])
+			cutKeyword (Symbol s : Symbol h : hs) = Just (Right (s, Null), Symbol h : hs)
+			cutKeyword (Symbol s : h : hs) = Just (Right (s, h), hs)
+			cutKeyword (h : hs) = Just (Left h, hs)
+
+instance FromJSON Lisp where
+	parseJSON A.Null = return Null
+	parseJSON (A.Bool b) = return $ Bool b
+	parseJSON (A.String s) = return $ String $ T.unpack s
+	parseJSON (A.Number n) = return $ Number n
+	parseJSON (A.Array vs) = fmap List $ mapM parseJSON $ V.toList vs
+	parseJSON (A.Object obj) = fmap (List . concat) $ mapM (\(k, v) -> sequence [pure $ Symbol (':' : T.unpack k), parseJSON v]) $ HM.toList obj
+
+decodeLisp :: FromJSON a => ByteString -> Either P.String a
+decodeLisp str = do
+	sexp <- maybe (Left "Not a s-exp") Right . readMaybe . LT.unpack . LT.decodeUtf8 $ str
+	parseEither parseJSON $ toJSON (sexp :: Lisp)
+
+encodeLisp :: ToJSON a => a -> ByteString
+encodeLisp r = LT.encodeUtf8 . LT.pack $ maybe
+	"(:error \"can't convert to s-exp\")"
+	(show :: Lisp -> P.String)
+	(parseMaybe parseJSON (toJSON r))

src/HsDev/Cabal.hs view

@@ -2,7 +2,7 @@ 
 module HsDev.Cabal (
 	Cabal(..), sandbox,
-	findPackageDb, locateSandbox,
+	findPackageDb, locateSandbox, getSandbox,
 	cabalOpt
 	) where
 
@@ -12,7 +12,7 @@ import Data.Aeson
 import Data.List
 import System.Directory
-import System.FilePath ((</>))
+import System.FilePath
 
 -- | Cabal or sandbox
 data Cabal = Cabal | Sandbox FilePath deriving (Eq, Ord)
@@ -46,10 +46,18 @@ -- | Find -package-db path for sandbox
 findPackageDb :: FilePath -> IO (Maybe FilePath)
 findPackageDb sand = do
-	cts <- getDirectoryContents sand
-	return $ fmap (sand </>) $
-		find cabalDev cts <|> find cabalSandbox cts
+	sand' <- canonicalizePath sand
+	isDir <- doesDirectoryExist sand'
+	if isDir then locateHere sand' else locateParent (takeDirectory sand')
 	where
+		locateHere path = do
+			cts <- filter (not . null . takeBaseName) <$> getDirectoryContents path
+			return $ fmap (path </>) $ find cabalDev cts <|> find cabalSandbox cts
+		locateParent dir = do
+			cts <- filter (not . null . takeBaseName) <$> getDirectoryContents dir
+			case find cabalDev cts <|> find cabalSandbox cts of
+				Nothing -> if isDrive dir then return Nothing else locateParent (takeDirectory dir)
+				Just packagef -> return $ Just (dir </> packagef)
 		cabalDev p = "packages-" `isPrefixOf` p && ".conf" `isSuffixOf` p
 		cabalSandbox p = "-packages.conf.d" `isSuffixOf` p
 
@@ -58,6 +66,10 @@ locateSandbox p = liftIO (findPackageDb p) >>= maybe
 	(throwError $ "Can't locate package-db in sandbox: " ++ p)
 	(return . Sandbox)
+
+-- | Try find sandbox by parent directory
+getSandbox :: FilePath -> IO Cabal
+getSandbox = liftM (either (const Cabal) id) . runErrorT . locateSandbox
 
 -- | Cabal ghc option
 cabalOpt :: Cabal -> [String]

src/HsDev/Cache/Structured.hs view

@@ -13,7 +13,6 @@ 
 import Data.Group (Group(zero))
 import qualified HsDev.Cache as Cache
-import HsDev.Cabal (Cabal)
 import HsDev.Database
 import HsDev.Symbols
 import HsDev.Project (project)
@@ -41,10 +40,10 @@ 
 -- | Load all cache
 load :: FilePath -> IO (Either String Structured)
-load dir = runErrorT $ join $ either throwError return <$> (structured <$> loadCabals <*> loadProjects <*> loadFiles) where
+load dir = runErrorT $ join $ either throwError return <$> (structured <$> loadCabals <*> loadProjects <*> loadStandaloneFiles) where
 	loadCabals = loadDir (dir </> "cabal")
 	loadProjects = loadDir (dir </> "projects")
-	loadFiles = ErrorT $ Cache.load (dir </> Cache.standaloneCache)
+	loadStandaloneFiles = ErrorT $ Cache.load (dir </> Cache.standaloneCache)
 
 	loadDir p = do
 		fs <- liftIO $ liftM (filter ((== ".json") . takeExtension)) $ directoryContents p

src/HsDev/Client/Commands.hs view

@@ -15,7 +15,6 @@ import Data.List
 import Data.Maybe
 import Data.Monoid
-import Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.Map as M
 import Data.Text (unpack)
 import Data.Traversable (traverse)
@@ -50,6 +49,7 @@ commands = [
 	-- Ping command
 	cmd' "ping" [] [] "ping server" ping',
+	cmd' "listen" [] [] "listen server log" listen',
 	-- Database commands
 	cmd' "add" [] [dataArg] "add info to database" add',
 	cmd' "scan" [] (sandboxes ++ [
@@ -114,7 +114,7 @@ 	cmd' "hayoo" ["query"] [] "find declarations online via Hayoo" hayoo',
 	cmd' "cabal list" ["packages..."] [] "list cabal packages" cabalList',
 	cmd' "ghc-mod type" ["line", "column"] (ctx ++ [ghcOpts]) "infer type with 'ghc-mod type'" ghcmodType',
-	cmd' "ghc-mod check" ["files..."] [sandbox, ghcOpts] "check source files" ghcmodCheck',
+	cmd' "ghc-mod check" ["files..."] [sandboxArg, ghcOpts] "check source files" ghcmodCheck',
 	cmd' "ghc-mod lint" ["file"] [hlintOpts] "lint source file" ghcmodLint',
 	-- Ghc commands
 	cmd' "ghc eval" ["expr..."] [] "evaluate expression" ghcEval',
@@ -138,13 +138,13 @@ 				r <- runErrorT (act args os copts)
 				case r of
 					Left (CommandError e ds) -> return $ Error e $ M.fromList $ map (first unpack) ds
-					Right r -> return $ Result $ toJSON r
+					Right r' -> return $ Result $ toJSON r'
 
 		-- Command arguments and flags
 		allFlag d = flag "all" `short` ['a'] `desc` d
 		cacheDir = pathArg `desc` "cache path"
 		cacheFile = fileArg `desc` "cache file"
-		ctx = [fileArg `desc` "source file", sandbox]
+		ctx = [fileArg `desc` "source file", sandboxArg]
 		dataArg = req "data" "contents" `desc` "data to pass to command"
 		fileArg = req "file" "path" `short` ['f']
 		findArg = req "find" "query" `desc` "infix match"
@@ -161,8 +161,8 @@ 		prefixArg = req "prefix" "prefix" `desc` "prefix match"
 		projectArg = req "project" "project"
 		packageVersionArg = req "version" "id" `short` ['v'] `desc` "package version"
-		sandbox = req "sandbox" "path" `desc` "path to cabal sandbox"
-		sandboxList = manyReq sandbox
+		sandboxArg = req "sandbox" "path" `desc` "path to cabal sandbox"
+		sandboxList = manyReq sandboxArg
 		sandboxes = [
 			flag "cabal" `desc` "cabal",
 			sandboxList]
@@ -173,6 +173,11 @@ 		ping' :: [String] -> Opts String -> CommandActionT Value
 		ping' _ _ _ = return $ object ["message" .= ("pong" :: String)]
 
+		-- | Listen server log
+		listen' :: [String] -> Opts String -> CommandActionT ()
+		listen' _ _ copts = liftIO $ commandListenLog copts $
+			mapM_ (\msg -> commandNotify copts (Notification $ object ["message" .= msg]))
+
 		-- | Add data
 		add' :: [String] -> Opts String -> CommandActionT ()
 		add' _ as copts = do
@@ -186,6 +191,7 @@ 				eitherDecode $ toUtf8 jsonData
 
 			let
+				updateData (ResultDatabase db) = DB.update (dbVar copts) $ return db
 				updateData (ResultDeclaration d) = commandError "Can't insert declaration" ["declaration" .= d]
 				updateData (ResultModuleDeclaration md) = do
 					let
@@ -206,8 +212,8 @@ 				updateData (ResultProject p) = DB.update (dbVar copts) $ return $ fromProject p
 				updateData (ResultList l) = mapM_ updateData l
 				updateData (ResultMap m) = mapM_ updateData $ M.elems m
-				updateData (ResultString _) = commandError "Can't insert string" []
 				updateData ResultNone = return ()
+				updateData _ = commandError "Invalid data" []
 			updateData decodedData
 
 		-- | Scan sources and installed packages
@@ -421,15 +427,15 @@ 
 		-- | Hayoo
 		hayoo' :: [String] -> Opts String -> CommandActionT [ModuleDeclaration]
-		hayoo' [] _ copts = commandError "Query not specified" []
-		hayoo' [query] as copts = liftM
+		hayoo' [] _ _ = commandError "Query not specified" []
+		hayoo' [query] _ _ = liftM
 				(map Hayoo.hayooAsDeclaration . Hayoo.hayooFunctions) $
 				mapErrorStr $ Hayoo.hayoo query
 		hayoo' _ _ _ = commandError "Too much arguments" []
 
 		-- | Cabal list
 		cabalList' :: [String] -> Opts String -> CommandActionT [Cabal.CabalPackage]
-		cabalList' qs as copts = mapErrorStr $ Cabal.cabalList qs
+		cabalList' qs _ _ = mapErrorStr $ Cabal.cabalList qs
 
 		-- | Ghc-mod type
 		ghcmodType' :: [String] -> Opts String -> CommandActionT [GhcMod.TypedRegion]
@@ -440,31 +446,35 @@ 			dbval <- getDb copts
 			(srcFile, cabal) <- getCtx copts as
 			(srcFile', m, mproj) <- mapErrorStr $ fileCtx dbval srcFile
-			mapErrorStr $ GhcMod.typeOf (listArg "ghc" as) cabal srcFile' mproj (moduleName m) line' column'
-		ghcmodType' [] _ copts = commandError "Specify line" []
+			mapErrorStr $ GhcMod.waitMultiGhcMod (commandGhcMod copts) srcFile' $
+				GhcMod.typeOf (listArg "ghc" as) cabal srcFile' mproj (moduleName m) line' column'
+		ghcmodType' [] _ _ = commandError "Specify line" []
 		ghcmodType' _ _ _ = commandError "Too much arguments" []
 
 		-- | Ghc-mod check
 		ghcmodCheck' :: [String] -> Opts String -> CommandActionT [GhcMod.OutputMessage]
-		ghcmodCheck' [] _ copts = commandError "Specify at least one file" []
+		ghcmodCheck' [] _ _ = commandError "Specify at least one file" []
 		ghcmodCheck' files as copts = do
 			files' <- mapM (findPath copts) files
 			mproj <- (listToMaybe . catMaybes) <$> liftIO (mapM (locateProject) files')
 			cabal <- getCabal copts as
-			mapErrorStr $ GhcMod.check (listArg "ghc" as) cabal files' mproj
+			mapErrorStr $ liftM concat $ forM files' $ \file' ->
+				GhcMod.waitMultiGhcMod (commandGhcMod copts) file' $
+					GhcMod.check (listArg "ghc" as) cabal [file'] mproj
 
 		-- | Ghc-mod lint
 		ghcmodLint' :: [String] -> Opts String -> CommandActionT [GhcMod.OutputMessage]
-		ghcmodLint' [] _ copts = commandError "Specify file to hlint" []
+		ghcmodLint' [] _ _ = commandError "Specify file to hlint" []
 		ghcmodLint' [file] as copts = do
 			file' <- findPath copts file
-			mapErrorStr $ GhcMod.lint (listArg "hlint" as) file'
-		ghcmodLint' fs _ copts = commandError "Too much files specified" []
+			mapErrorStr $ GhcMod.waitMultiGhcMod (commandGhcMod copts) file' $
+				GhcMod.lint (listArg "hlint" as) file'
+		ghcmodLint' _ _ _ = commandError "Too much files specified" []
 
 		-- | Evaluate expression
 		ghcEval' :: [String] -> Opts String -> CommandActionT [Value]
 		ghcEval' exprs _ copts = mapErrorStr $ liftM (map toValue) $
-			waitWork (commandGhc copts) $ mapM (try . evaluate) exprs
+			waitGhc (commandGhc copts) $ mapM (try . evaluate) exprs
 			where
 				toValue :: Either String String -> Value
 				toValue (Left e) = object ["fail" .= e]
@@ -527,7 +537,7 @@ -- | Check positional args count
 checkPosArgs :: Cmd a -> Cmd a
 checkPosArgs c = validateArgs pos' c where
-	pos' (Args args os) = case cmdArgs c of
+	pos' (Args args _) = case cmdArgs c of
 		[ellipsis]
 			| "..." `isSuffixOf` ellipsis -> return ()
 		_ -> mplus
@@ -581,10 +591,10 @@ 	db' <- getDb copts
 	proj' <- liftM addCabal $ findPath copts proj
 	let
-		result =
+		resultProj =
 			M.lookup proj' (databaseProjects db') <|>
 			find ((== proj) . projectName) (M.elems $ databaseProjects db')
-	maybe (throwError $ strMsg $ "Projects " ++ proj ++ " not found") return result
+	maybe (throwError $ strMsg $ "Projects " ++ proj ++ " not found") return resultProj
 	where
 		addCabal p
 			| takeExtension p == ".cabal" = p
@@ -594,12 +604,6 @@ toPair :: Module -> Maybe (FilePath, Module)
 toPair m = case moduleLocation m of
 	FileModule f _ -> Just (f, m)
-	_ -> Nothing
-
--- | Module sandbox
-modCabal :: Module -> Maybe Cabal
-modCabal m = case moduleLocation m of
-	CabalModule c _ _ -> Just c
 	_ -> Nothing
 
 -- | Wait for DB to complete update

src/HsDev/Commands.hs view

@@ -34,7 +34,13 @@ 
 -- | Find declaration by name
 findDeclaration :: Database -> String -> ErrorT String IO [ModuleDeclaration]
-findDeclaration db ident = return $ selectDeclarations ((== ident) . declarationName . moduleDeclaration) db
+findDeclaration db ident = return $ selectDeclarations checkName db where
+	checkName :: ModuleDeclaration -> Bool
+	checkName m =
+		(declarationName (moduleDeclaration m) == iname) &&
+		(maybe True (moduleIdName (declarationModuleId m) ==) qname)
+
+	(qname, iname) = splitIdentifier ident
 
 -- | Find module by name
 findModule :: Database -> String -> ErrorT String IO [Module]

src/HsDev/Database/Update.hs view

@@ -28,7 +28,6 @@ import qualified Data.Map as M
 import Data.Maybe (mapMaybe, isJust)
 import Data.Monoid
-import Data.Traversable (traverse)
 import System.Directory (canonicalizePath)
 
 import qualified HsDev.Cache.Structured as Cache
@@ -172,13 +171,12 @@ scanModule opts mloc = runTask "scanning" (subject mloc ["module" .= mloc]) $ do
 	im <- liftErrorT $ S.scanModule opts mloc
 	updater $ return $ fromModule im
-	ErrorT $ return $ inspectionResult im
+	_ <- ErrorT $ return $ inspectionResult im
 	return ()
 
 -- | Scan modules
 scanModules :: MonadCatchIO m => [String] -> [S.ModuleToScan] -> ErrorT String (UpdateDB m) ()
 scanModules opts ms = do
-	db <- asks database
 	dbval <- readDB
 	ms' <- liftErrorT $ filterM (S.changedModule dbval opts . fst) ms
 	runTasks $
@@ -202,13 +200,13 @@ 
 -- | Scan cabal modules
 scanCabal :: MonadCatchIO m => [String] -> Cabal -> ErrorT String (UpdateDB m) ()
-scanCabal opts sandbox = runTask "scanning" (subject sandbox ["sandbox" .= sandbox]) $ do
-	loadCache $ Cache.loadCabal sandbox
+scanCabal opts cabalSandbox = runTask "scanning" (subject cabalSandbox ["sandbox" .= cabalSandbox]) $ do
+	loadCache $ Cache.loadCabal cabalSandbox
 	dbval <- readDB
 	ms <- runTask "loading modules" [] $
-		liftErrorT $ browseFilter opts sandbox (S.changedModule dbval opts)
+		liftErrorT $ browseFilter opts cabalSandbox (S.changedModule dbval opts)
 	docs <- runTask "loading docs" [] $
-		liftErrorT $ hdocsCabal sandbox opts
+		liftErrorT $ hdocsCabal cabalSandbox opts
 	updater $ return $ mconcat $ map (fromModule . fmap (setDocs' docs)) ms
 	where
 		setDocs' :: Map String (Map String String) -> Module -> Module
@@ -241,11 +239,6 @@ -- | Lift errors
 liftErrorT :: MonadIO m => ErrorT String IO a -> ErrorT String m a
 liftErrorT = mapErrorT liftIO
-
--- | Merge two JSON object
-union :: Value -> Value -> Value
-union (Object l) (Object r) = Object $ HM.union l r
-union _ _ = error "Commands.union: impossible happened"
 
 subject :: Display a => a -> [Pair] -> [Pair]
 subject x ps = ["name" .= display x, "type" .= displayType x] ++ ps

src/HsDev/Inspect.hs view

@@ -21,7 +21,6 @@ import Data.Traversable (traverse, sequenceA)
 import qualified Data.Map as M
 import qualified Language.Haskell.Exts as H
-import qualified Language.Haskell.Exts.Extension as H
 import qualified Documentation.Haddock as Doc
 import qualified System.Directory as Dir
 import System.IO
@@ -67,15 +66,15 @@ 	mname (H.ModuleName n) = n
 
 getDecls :: [H.Decl] -> [Declaration]
-getDecls decls = map addLocals infos ++ filter noInfo defs where
-	infos = concatMap getDecl decls
+getDecls decls = map addLocals declInfos ++ filter noInfo defs where
+	declInfos = concatMap getDecl decls
 	addLocals :: Declaration -> Declaration
 	addLocals decl = decl `where_` maybe [] locals def where
 		def = find (\d -> declarationName d == declarationName decl) defs
 	defs = concatMap getDef decls
 	noInfo :: Declaration -> Bool
 	noInfo d = declarationName d `notElem` names
-	names = map declarationName infos
+	names = map declarationName declInfos
 
 getBinds :: H.Binds -> [Declaration]
 getBinds (H.BDecls decls) = getDecls decls
@@ -107,10 +106,9 @@ getDef (H.FunBind matches@(H.Match loc n _ _ _ _ : _)) = [setPosition loc $ Declaration (identOfName n) Nothing Nothing fun] where
 	fun = Function Nothing $ concatMap (getBinds . matchBinds) matches
 	matchBinds (H.Match _ _ _ _ _ binds) = binds
-getDef (H.PatBind loc pat _ _ binds) = map (\name -> setPosition loc (Declaration (identOfName name) Nothing Nothing (Function Nothing $ getBinds binds))) (names pat) where
+getDef (H.PatBind loc pat _ binds) = map (\name -> setPosition loc (Declaration (identOfName name) Nothing Nothing (Function Nothing $ getBinds binds))) (names pat) where
 	names :: H.Pat -> [H.Name]
 	names (H.PVar n) = [n]
-	names (H.PNeg n) = names n
 	names (H.PNPlusK n _) = [n]
 	names (H.PInfixApp l _ r) = names l ++ names r
 	names (H.PApp _ ns) = concatMap names ns
@@ -128,7 +126,10 @@ 
 	fieldNames :: H.PatField -> [H.Name]
 	fieldNames (H.PFieldPat _ n) = names n
-	fieldNames (H.PFieldPun n) = [n]
+	fieldNames (H.PFieldPun n) = case n of
+		H.Qual _ n' -> [n']
+		H.UnQual n' -> [n']
+		_ -> []
 	fieldNames H.PFieldWildcard = []
 getDef _ = []
 
@@ -183,7 +184,7 @@ 		printDoc (Doc.DocHyperlink link) = fromMaybe (Doc.hyperlinkUrl link) (Doc.hyperlinkLabel link)
 		printDoc (Doc.DocProperty prop) = prop
 		-- Catch all unsupported ones
-		-- printDoc _ = "[unsupported-by-extractDocs]" -- TODO
+		printDoc _ = "[unsupported-by-extractDocs]" -- TODO
 
 	locatedName :: Loc.Located Name.Name -> String
 	locatedName (Loc.L _ nm) = Name.getOccString nm
@@ -207,7 +208,7 @@ 		exts = mapMaybe flagExtension opts
 
 contentsInspection :: String -> [String] -> ErrorT String IO Inspection
-contentsInspection cts opts = return InspectionNone -- crc or smth
+contentsInspection _ _ = return InspectionNone -- crc or smth
 
 -- | Inspect file
 inspectFile :: [String] -> FilePath -> ErrorT String IO InspectedModule
@@ -215,15 +216,18 @@ 	let
 		noReturn :: E.SomeException -> IO [Doc.Interface]
 		noReturn _ = return []
+
+		hdocsWorkaround = True
 	proj <- liftIO $ locateProject file
 	absFilename <- liftIO $ Dir.canonicalizePath file
 	inspect (FileModule absFilename proj) (fileInspection absFilename opts) $ do
-		docsMap <- liftIO $ hdocsProcess absFilename opts
-		--docsMap <- liftIO $ fmap (fmap documentationMap . lookup absFilename) $ do
-		--	is <- E.catch (Doc.createInterfaces ([Doc.Flag_Verbosity "0", Doc.Flag_NoWarnings] ++ map Doc.Flag_OptGhc opts) [absFilename]) noReturn
-		--	forM is $ \i -> do
-		--		mfile <- Dir.canonicalizePath $ Doc.ifaceOrigFilename i
-		--		return (mfile, i)
+		docsMap <- case hdocsWorkaround of
+			True -> liftIO $ hdocsProcess absFilename opts
+			False -> liftIO $ fmap (fmap documentationMap . lookup absFilename) $ do
+				is <- E.catch (Doc.createInterfaces ([Doc.Flag_Verbosity "0", Doc.Flag_NoWarnings] ++ map Doc.Flag_OptGhc opts) [absFilename]) noReturn
+				forM is $ \i -> do
+					mfile <- Dir.canonicalizePath $ Doc.ifaceOrigFilename i
+					return (mfile, i)
 		forced <- ErrorT $ E.handle onError $ do
 			analyzed <- liftM (analyzeModule exts (Just absFilename)) $ readFileUtf8 absFilename
 			force analyzed `deepseq` return analyzed

src/HsDev/Project.hs view

@@ -234,16 +234,16 @@ 		flattenDescr :: PD.GenericPackageDescription -> PD.PackageDescription
 		flattenDescr (PD.GenericPackageDescription pkg _ mlib mexes mtests _) = pkg {
 			PD.library = flip fmap mlib $ flattenTree
-				(insert PD.libBuildInfo (\i l -> l { PD.libBuildInfo = i })),
+				(insertInfo PD.libBuildInfo (\i l -> l { PD.libBuildInfo = i })),
 			PD.executables = flip fmap mexes $
-				second (flattenTree (insert PD.buildInfo (\i l -> l { PD.buildInfo = i }))) >>>
+				second (flattenTree (insertInfo PD.buildInfo (\i l -> l { PD.buildInfo = i }))) >>>
 				(\(n, e) -> e { PD.exeName = n }),
 			PD.testSuites = flip fmap mtests $
-				second (flattenTree (insert PD.testBuildInfo (\i l -> l { PD.testBuildInfo = i }))) >>>
+				second (flattenTree (insertInfo PD.testBuildInfo (\i l -> l { PD.testBuildInfo = i }))) >>>
 				(\(n, t) -> t { PD.testName = n }) }
 			where
-				insert :: (a -> PD.BuildInfo) -> (PD.BuildInfo -> a -> a) -> [P.Dependency] -> a -> a
-				insert f s deps x = s ((f x) { PD.targetBuildDepends = deps }) x
+				insertInfo :: (a -> PD.BuildInfo) -> (PD.BuildInfo -> a -> a) -> [P.Dependency] -> a -> a
+				insertInfo f s deps x = s ((f x) { PD.targetBuildDepends = deps }) x
 
 		flattenTree :: Monoid a => (c -> a -> a) -> PD.CondTree v c a -> a
 		flattenTree f (PD.CondNode x cs cmps) = f cs x `mappend` mconcat (concatMap flattenBranch cmps) where

src/HsDev/Scan.hs view

@@ -9,16 +9,14 @@ 	) where
 
 import Control.Monad.Error
-import Data.List
 import qualified Data.Map as M
-import Data.Maybe (mapMaybe)
 import Data.Traversable (traverse)
+import Language.Haskell.GhcMod (defaultOptions)
 
 import HsDev.Symbols
 import HsDev.Database
 import HsDev.Tools.GhcMod
 import HsDev.Tools.GhcMod.InferType (inferTypes)
-import HsDev.Tools.HDocs
 import HsDev.Inspect
 import HsDev.Project
 import HsDev.Util
@@ -51,27 +49,26 @@ 	projs <- mapM (enumProject . project) projects
 	let
 		projPaths = map (projectPath . fst) projs
-		projSources = concatMap (mapMaybe (moduleSource . fst) . snd) projs
 		standalone = map (\f -> FileModule f Nothing) $ filter (\s -> not (any (`isParent` s) projPaths)) sources
 	return (projs,  [(s, []) | s <- standalone])
 
 -- | Scan project file
 scanProjectFile :: [String] -> FilePath -> ErrorT String IO Project
-scanProjectFile opts f = do
+scanProjectFile _ f = do
 	proj <- (liftIO $ locateProject f) >>= maybe (throwError "Can't locate project") return
 	loadProject proj
 
 -- | Scan module
 scanModule :: [String] -> ModuleLocation -> ErrorT String IO InspectedModule
-scanModule opts (FileModule f p) = inspectFile opts f >>= traverse (inferTypes opts Cabal)
+scanModule opts (FileModule f _) = inspectFile opts f >>= traverse (runGhcMod defaultOptions . inferTypes opts Cabal)
 scanModule opts (CabalModule c p n) = browse opts c n p
-scanModule opts (ModuleSource _) = throwError "Can inspect only modules in file or cabal"
+scanModule _ (ModuleSource _) = throwError "Can inspect only modules in file or cabal"
 
 -- | Is inspected module up to date?
 upToDate :: [String] -> InspectedModule -> ErrorT String IO Bool
 upToDate opts (Inspected insp m _) = case m of
-	FileModule f p -> liftM (== insp) $ fileInspection f opts
-	CabalModule c p n -> return $ insp == browseInspection opts
+	FileModule f _ -> liftM (== insp) $ fileInspection f opts
+	CabalModule _ _ _ -> return $ insp == browseInspection opts
 	_ -> return False
 
 -- | Rescan inspected module

src/HsDev/Scan/Browse.hs view

@@ -6,7 +6,6 @@ import Control.Arrow
 import Control.Monad.Error
 import Data.Maybe
-import Data.Either
 import qualified Data.Map as M
 import Text.Read (readMaybe)
 
@@ -17,14 +16,11 @@ import qualified ConLike as GHC
 import qualified DataCon as GHC
 import qualified DynFlags as GHC
-import qualified Exception as GHC
-import qualified FastString as GHC
 import qualified GHC
 import qualified GhcMonad as GHC (liftIO)
 import qualified GHC.Paths as GHC
-import qualified Module as GHC
 import qualified Name as GHC
-import qualified Name as GHC
+import qualified Module as GHC
 import qualified Outputable as GHC
 import qualified Packages as GHC
 import qualified PatSyn as GHC
@@ -84,13 +80,14 @@ 				| GHC.isClassTyCon t = Class
 				| GHC.isSynTyCon t = Type
 				| otherwise = Type
+		showResult _ _ = Nothing
 
 withInitializedPackages :: [String] -> (GHC.DynFlags -> GHC.Ghc a) -> IO a
 withInitializedPackages ghcOpts cont = GHC.runGhc (Just GHC.libdir) $ do
 		fs <- GHC.getSessionDynFlags
 		GHC.defaultCleanupHandler fs $ do
 			(fs', _, _) <- GHC.parseDynamicFlags fs (map GHC.noLoc ghcOpts)
-			GHC.setSessionDynFlags fs'
+			_ <- GHC.setSessionDynFlags fs'
 			(result, _) <- GHC.liftIO $ GHC.initPackages fs'
 			cont result

src/HsDev/Server/Commands.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, CPP #-}
+{-# LANGUAGE OverloadedStrings, CPP, PatternGuards #-}
 
 module HsDev.Server.Commands (
 	commands,
@@ -14,18 +14,16 @@ 	) where
 
 import Control.Applicative
+import Control.Arrow (second)
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
 import Control.Monad.Error
 import Data.Aeson hiding (Result, Error)
 import Data.Aeson.Encode.Pretty
-import Data.Aeson.Types hiding (Result, Error)
 import Data.ByteString.Lazy.Char8 (ByteString)
 import qualified Data.ByteString.Lazy.Char8 as L
-import Data.Char
 import Data.Either (isLeft)
-import Data.List
 import qualified Data.Map as M
 import Data.Maybe
 import Data.Monoid
@@ -33,15 +31,14 @@ import Network.Socket hiding (connect)
 import qualified Network.Socket as Net
 import System.Directory
-import System.Environment
 import System.Exit
 import System.IO
-import System.Process
 import Text.Read (readMaybe)
 
 import Control.Apply.Util
 import Control.Concurrent.Util
 import qualified Control.Concurrent.FiniteChan as F
+import Data.Lisp
 import System.Console.Cmd hiding (run)
 
 import qualified HsDev.Cache.Structured as SC
@@ -49,11 +46,17 @@ import HsDev.Database
 import qualified HsDev.Database.Async as DB
 import HsDev.Tools.Ghc.Worker
+import HsDev.Tools.GhcMod (ghcModMultiWorker)
 import HsDev.Server.Message as M
 import HsDev.Server.Types
 import HsDev.Util
 
 #if mingw32_HOST_OS
+import Data.Aeson.Types hiding (Result, Error)
+import Data.Char
+import Data.List
+import System.Environment
+import System.Process
 import System.Win32.FileMapping.Memory (withMapFile, readMapFile)
 import System.Win32.FileMapping.NamePool
 import System.Win32.PowerShell (translateArg)
@@ -102,8 +105,8 @@ 
 				proxy :: IO ()
 				proxy = do
-					createSession
-					forkProcess serverAction
+					_ <- createSession
+					_ <- forkProcess serverAction
 					exitImmediately ExitSuccess
 
 				serverAction :: IO ()
@@ -115,15 +118,15 @@ 					run' (Args [] sopts)
 
 			handle forkError $ do
-				forkProcess proxy
-				putStrLn $ "Server started at port " ++ (fromJust $ arg "port" sopts)
+				_ <- forkProcess proxy
+				putStrLn $ "Server started at port " ++ fromJust (arg "port" sopts)
 #endif
 
 		-- | Run server
 		run' :: Args -> IO ()
 		run' (Args _ sopts)
 			| flagSet "as-client" sopts = runServer sopts $ \copts -> do
-				commandLog copts $ "Server started as client connecting at port " ++ (fromJust $ arg "port" sopts)
+				commandLog copts $ "Server started as client connecting at port " ++ fromJust (arg "port" sopts)
 				me <- myThreadId
 				s <- socket AF_INET Stream defaultProtocol
 				addr' <- inet_addr "127.0.0.1"
@@ -132,7 +135,7 @@ 					processClientHandle s h (copts {
 						commandExit = killThread me })
 			| otherwise = runServer sopts $ \copts -> do
-				commandLog copts $ "Server started at port " ++ (fromJust $ arg "port" sopts)
+				commandLog copts $ "Server started at port " ++ fromJust (arg "port" sopts)
 
 				waitListen <- newEmptyMVar
 				clientChan <- F.newChan
@@ -152,23 +155,23 @@ 					forever $ logIO "accept client exception: " (commandLog copts) $ do
 						s' <- fst <$> accept s
 						void $ forkIO $ logIO (show s' ++ " exception: ") (commandLog copts) $
-							bracket (socketToHandle s' ReadWriteMode) hClose $ \h -> do
-								bracket newEmptyMVar (`putMVar` ()) $ \done -> do
-									me <- myThreadId
-									let
-										timeoutWait = do
-											notDone <- isEmptyMVar done
-											when notDone $ do
-												void $ forkIO $ do
-													threadDelay 1000000
-													void $ tryPutMVar done ()
-													killThread me
-												takeMVar done
-										waitForever = forever $ hGetLineBS h
-									F.putChan clientChan timeoutWait
-									processClientHandle s' h (copts {
-										commandHold = waitForever,
-										commandExit = serverStop })
+							bracket (socketToHandle s' ReadWriteMode) hClose $ \h ->
+							bracket newEmptyMVar (`putMVar` ()) $ \done -> do
+								me <- myThreadId
+								let
+									timeoutWait = do
+										notDone <- isEmptyMVar done
+										when notDone $ do
+											void $ forkIO $ do
+												threadDelay 1000000
+												void $ tryPutMVar done ()
+												killThread me
+											takeMVar done
+									waitForever = forever $ hGetLineBS h
+								F.putChan clientChan timeoutWait
+								processClientHandle s' h (copts {
+									commandHold = waitForever,
+									commandExit = serverStop })
 
 				takeMVar waitListen
 				DB.readAsync (commandDatabase copts) >>= writeCache sopts (commandLog copts)
@@ -188,18 +191,20 @@ 			s <- socket AF_INET Stream defaultProtocol
 			addr' <- inet_addr "127.0.0.1"
 			Net.connect s (SockAddrInet (fromIntegral $ fromJust $ iarg "port" copts) addr')
-			bracket (socketToHandle s ReadWriteMode) hClose $ \h -> forM_ [1..] $ \i -> ignoreIO $ do
+			bracket (socketToHandle s ReadWriteMode) hClose $ \h -> forM_ [(1 :: Integer)..] $ \i -> ignoreIO $ do
 				input' <- hGetLineBS stdin
-				case eitherDecode input' of
-					Left _ -> L.putStrLn $ encodeValue $ object ["error" .= ("invalid command" :: String)]
-					Right req' -> do
-						L.hPutStrLn h $ encode $ Message (Just $ show i) $
+				case decodeLispOrJSON input' of
+					Left _ -> L.putStrLn $ encodeValue False $ object ["error" .= ("invalid command" :: String)]
+					Right (isLisp, req') -> do
+						L.hPutStrLn h $ encodeLispOrJSON isLisp $ Message (Just $ show i) $
 							req' `M.withOpts` ["current-directory" %-- curDir]
 						waitResp h
 			where
 				pretty = flagSet "pretty" copts
-				encodeValue :: ToJSON a => a -> L.ByteString
-				encodeValue
+
+				encodeValue :: ToJSON a => Bool -> a -> L.ByteString
+				encodeValue True = encodeLisp
+				encodeValue False
 					| pretty = encodePretty
 					| otherwise = encode
 
@@ -207,11 +212,11 @@ 					resp <- hGetLineBS h
 					parseResp h resp
 
-				parseResp h str = case eitherDecode str of
+				parseResp h str = case decodeLispOrJSON str of
 					Left e -> putStrLn $ "Can't decode response: " ++ e
-					Right (Message i r) -> do
+					Right (isLisp, Message i r) -> do
 						r' <- unMmap r
-						putStrLn $ fromMaybe "_" i ++ ":" ++ fromUtf8 (encodeValue r')
+						putStrLn $ fromMaybe "_" i ++ ":" ++ fromUtf8 (encodeValue isLisp r')
 						case r of
 							Left _ -> waitResp h
 							_ -> return ()
@@ -251,65 +256,73 @@ 
 -- | Send command to server
 sendCmd :: String -> Args -> IO ()
-sendCmd name (Args args opts) = ignoreIO sendReceive where
-	(copts, opts') = splitOpts clientOpts opts
-	reqCall = Request name args opts'
-	pretty = flagSet "pretty" copts
-	encodeValue :: ToJSON a => a -> L.ByteString
-	encodeValue
-		| pretty = encodePretty
-		| otherwise = encode
-	sendReceive = do
-		curDir <- getCurrentDirectory
-		stdinData <- if flagSet "data" copts
-			then do
-				cdata <- liftM (eitherDecode :: L.ByteString -> Either String Value) L.getContents
-				case cdata of
-					Left cdataErr -> do
-						putStrLn $ "Invalid data: " ++ cdataErr
-						exitFailure
-					Right dataValue -> return $ Just dataValue
-			else return Nothing
+sendCmd name (Args args opts) = do
+	var <- newEmptyMVar
+	thId <- forkIO $ ignoreIO sendReceive >> putMVar var ()
+	handle (\(SomeException _) -> killThread thId) $ takeMVar var
+	where
+		(copts, opts') = splitOpts clientOpts opts
+		reqCall = Request name args opts'
+		pretty = flagSet "pretty" copts
+		encodeValue :: ToJSON a => a -> L.ByteString
+		encodeValue
+			| pretty = encodePretty
+			| otherwise = encode
+		sendReceive = do
+			curDir <- getCurrentDirectory
+			stdinData <- if flagSet "data" copts
+				then do
+					cdata <- liftM (eitherDecode :: L.ByteString -> Either String Value) L.getContents
+					case cdata of
+						Left cdataErr -> do
+							putStrLn $ "Invalid data: " ++ cdataErr
+							exitFailure
+						Right dataValue -> return $ Just dataValue
+				else return Nothing
 
-		s <- socket AF_INET Stream defaultProtocol
-		addr' <- inet_addr "127.0.0.1"
-		Net.connect s (SockAddrInet (fromIntegral $ fromJust $ iarg "port" copts) addr')
-		h <- socketToHandle s ReadWriteMode
-		L.hPutStrLn h $ encode $ Message Nothing $ reqCall `M.withOpts` [
-			"current-directory" %-- curDir,
-			"data" %-? (fromUtf8 . encode <$> stdinData),
-			"timeout" %-? (iarg "timeout" copts :: Maybe Integer),
-			if flagSet "silent" copts then hoist "silent" else mempty]
-		hFlush h
-		peekResponse h
+			s <- socket AF_INET Stream defaultProtocol
+			addr' <- inet_addr "127.0.0.1"
+			Net.connect s (SockAddrInet (fromIntegral $ fromJust $ iarg "port" copts) addr')
+			h <- socketToHandle s ReadWriteMode
+			L.hPutStrLn h $ encode $ Message Nothing $ reqCall `M.withOpts` [
+				"current-directory" %-- curDir,
+				"data" %-? (fromUtf8 . encode <$> stdinData),
+				"timeout" %-? (iarg "timeout" copts :: Maybe Integer),
+				if flagSet "silent" copts then hoist "silent" else mempty]
+			hFlush h
+			peekResponse h
 
-	peekResponse h = do
-		resp <- hGetLineBS h
-		parseResponse h resp
+		peekResponse h = do
+			resp <- hGetLineBS h
+			parseResponse h resp
 
-	parseResponse h str = case eitherDecode str of
-		Left e -> putStrLn $ "Can't decode response: " ++ e
-		Right (Message _ r) -> do
-			r' <- unMmap r
-			L.putStrLn $ case r' of
-				Left n -> encodeValue n
-				Right (Result v) -> encodeValue v
-				Right e -> encodeValue e
-			when (isLeft r') $ peekResponse h
+		parseResponse h str = case decodeLispOrJSON str of
+			Left e -> putStrLn $ "Can't decode response: " ++ e
+			Right (_, Message _ r) -> do
+				r' <- unMmap r
+				L.putStrLn $ case r' of
+					Left n -> encodeValue n
+					Right (Result v) -> encodeValue v
+					Right e -> encodeValue e
+				when (isLeft r') $ peekResponse h
 
 -- | Inits log chan and returns functions (print message, wait channel)
-initLog :: Opts String -> IO (String -> IO (), IO ())
+initLog :: Opts String -> IO (String -> IO (), ([String] -> IO ()) -> IO (), IO ())
 initLog sopts = do
 	msgs <- F.newChan
 	outputDone <- newEmptyMVar
-	forkIO $ finally
+	void $ forkIO $ finally
 		(F.readChan msgs >>= mapM_ (logMsg sopts))
 		(putMVar outputDone ())
-	return (F.putChan msgs, F.closeChan msgs >> takeMVar outputDone)
+	let
+		listenLog f = logException "listen log" (F.putChan msgs) $ do
+			msgs' <- F.dupChan msgs
+			F.readChan msgs' >>= f
+	return (F.putChan msgs, listenLog, F.closeChan msgs >> takeMVar outputDone)
 
 -- | Run server
 runServer :: Opts String -> (CommandOptions -> IO ()) -> IO ()
-runServer sopts act = bracket (initLog sopts) snd $ \(outputStr, waitOutput) -> do
+runServer sopts act = bracket (initLog sopts) (\(_, _, x) -> x) $ \(outputStr, listenLog, waitOutput) -> do
 	db <- DB.newAsync
 	when (flagSet "load" sopts) $ withCache sopts () $ \cdir -> do
 		outputStr $ "Loading cache from " ++ cdir
@@ -320,23 +333,35 @@ #if mingw32_HOST_OS
 	mmapPool <- Just <$> createPool "hsdev"
 #endif
-	worker <- startWorker
+	ghcw <- ghcWorker
+	ghcmodw <- ghcModMultiWorker
 	act $ CommandOptions
 		db
 		(writeCache sopts outputStr)
 		(readCache sopts outputStr)
 		"."
 		outputStr
+		listenLog
 		waitOutput
 #if mingw32_HOST_OS
 		mmapPool
 #endif
-		worker
+		ghcw
+		ghcmodw
 		(const $ return ())
 		(return ())
 		(return ())
 		(return ())
 
+decodeLispOrJSON :: FromJSON a => ByteString -> Either String (Bool, a)
+decodeLispOrJSON str =
+	((,) <$> pure False <*> eitherDecode str) <|>
+	((,) <$> pure True <*> decodeLisp str)
+
+encodeLispOrJSON :: ToJSON a => Bool -> a -> ByteString
+encodeLispOrJSON True = encodeLisp
+encodeLispOrJSON False = encode
+
 -- | Process request, notifications can be sent during processing
 processRequest :: CommandOptions -> (Notification -> IO ()) -> Request -> IO Result
 processRequest copts onNotify req' =
@@ -361,26 +386,27 @@ 	respChan <- newChan
 	void $ forkIO $ do
 		responses <- getChanContents respChan
-		mapM_ (send' . encode) responses
+		mapM_ (send' . uncurry encodeLispOrJSON) responses
 	linkVar <- newMVar $ return ()
 	let
-		answer :: Message Response -> IO ()
-		answer m@(Message i r) = do
-			commandLog copts $ name ++ " << " ++ fromMaybe "_" i ++ ":" ++ fromUtf8 (encode r)
-			writeChan respChan m
+		answer :: Bool -> Message Response -> IO ()
+		answer isLisp m@(Message i r) = do
+			when (not $ isNotification r) $
+				commandLog copts $ name ++ " << " ++ fromMaybe "_" i ++ ":" ++ fromUtf8 (encode r)
+			writeChan respChan (isLisp, m)
 	flip finally (disconnected linkVar) $ forever $ do
 		req' <- receive
-		case fmap extractMeta <$> eitherDecode req' of
+		case second (fmap extractMeta) <$> decodeLispOrJSON req' of
 			Left _ -> do
 				commandLog copts $ name ++ " >> #: " ++ fromUtf8 req'
-				answer $ Message Nothing $ responseError "Invalid request" [
+				answer False $ Message Nothing $ responseError "Invalid request" [
 					"request" .= fromUtf8 req']
-			Right m -> do
+			Right (isLisp, m) -> do
 				resp' <- flip traverse m $ \(cdir, noFile, silent, tm, reqArgs) -> do
 					let
 						onNotify n
 							| silent = return ()
-							| otherwise = traverse (const $ mmap' noFile (Left n)) m >>= answer
+							| otherwise = traverse (const $ mmap' noFile (Left n)) m >>= answer isLisp
 					commandLog copts $ name ++ " >> " ++ fromMaybe "_" (messageId m) ++ ":" ++ fromUtf8 (encode reqArgs)
 					resp <- fmap Right $ handleTimeout tm $ handleError $
 						processRequest
@@ -390,7 +416,7 @@ 							onNotify
 							reqArgs
 					mmap' noFile resp
-				answer resp'
+				answer isLisp resp'
 	where
 		extractMeta :: Request -> (FilePath, Bool, Bool, Maybe Int, Request)
 		extractMeta c = (cdir, noFile, silent, tm, c { requestOpts = opts' }) where
@@ -398,11 +424,12 @@ 			noFile = flagSet "no-file" metaOpts
 			silent = flagSet "silent" metaOpts
 			tm = join $ fmap readMaybe $ arg "timeout" metaOpts
-			(metaOpts, opts') = flip splitOpts (requestOpts c) [
+			(metaOpts, opts') = splitOpts [
 				req "current-directory" "path",
 				flag "no-file",
 				flag "silent",
 				req "timeout" "ms"]
+				(requestOpts c)
 
 		handleTimeout :: Maybe Int -> IO Result -> IO Result
 		handleTimeout Nothing = id

src/HsDev/Server/Message.hs view

@@ -6,7 +6,7 @@ 	Request(..), requestToArgs,
 	withOpts, withoutOpts,
 	Notification(..), Result(..),
-	Response, notification, result, responseError,
+	Response, isNotification, notification, result, responseError,
 	groupResponses, responsesById
 	) where
 
@@ -112,6 +112,9 @@ 
 type Response = Either Notification Result
 
+isNotification :: Response -> Bool
+isNotification = either (const True) (const False)
+
 notification :: ToJSON a => a -> Response
 notification = Left . Notification . toJSON
 
@@ -137,6 +140,7 @@ 		r = case cs' of
 			(Right r' : _) -> r'
 			[] -> Error "groupResponses: no result" mempty
+			_ -> error "groupResponses: impossible happened"
 
 responsesById :: Maybe String -> [Message Response] -> [([Notification], Result)]
 responsesById i = groupResponses . messagesById i

src/HsDev/Server/Types.hs view

@@ -18,8 +18,8 @@ import HsDev.Project
 import HsDev.Symbols
 import HsDev.Server.Message
-import HsDev.Tools.GhcMod (OutputMessage, TypedRegion)
-import HsDev.Tools.Ghc.Worker (Worker)
+import HsDev.Tools.GhcMod (OutputMessage, TypedRegion, GhcModT)
+import HsDev.Tools.Ghc.Worker (Worker, Ghc)
 
 #if mingw32_HOST_OS
 import System.Win32.FileMapping.NamePool (Pool)
@@ -31,11 +31,13 @@ 	commandReadCache :: (FilePath -> ErrorT String IO Structured) -> IO (Maybe Database),
 	commandRoot :: FilePath,
 	commandLog :: String -> IO (),
+	commandListenLog :: ([String] -> IO ()) -> IO (),
 	commandLogWait :: IO (),
 #if mingw32_HOST_OS
 	commandMmapPool :: Maybe Pool,
 #endif
-	commandGhc :: Worker,
+	commandGhc :: Worker (Ghc ()),
+	commandGhcMod :: Worker (FilePath, GhcModT IO ()),
 	commandNotify :: Notification -> IO (),
 	commandLink :: IO (),
 	commandHold :: IO (),

src/HsDev/Symbols.hs view

@@ -341,7 +341,7 @@ declarationTypeCtor "newtype" = NewType
 declarationTypeCtor "data" = Data
 declarationTypeCtor "class" = Class
-declarationTypeCtor "" = error "Invalid type constructor name"
+declarationTypeCtor _ = error "Invalid type constructor name"
 
 declarationTypeName :: DeclarationInfo -> Maybe String
 declarationTypeName (Type _) = Just "type"

src/HsDev/Symbols/Util.hs view

@@ -8,7 +8,6 @@ 	) where
 
 import Control.Arrow ((***), (&&&), second)
-import Control.Monad (join)
 import Data.Function (on)
 import Data.Maybe
 import Data.List (maximumBy, groupBy, sortBy, partition)

src/HsDev/Tools/ClearImports.hs view

@@ -42,7 +42,7 @@ 				objectDir = Just cur,
 				hiDir = Just cur }
 		(df'', _, _) <- parseDynamicFlags df' (map noLoc ("-ddump-minimal-imports" : opts))
-		setSessionDynFlags df''
+		_ <- setSessionDynFlags df''
 		defaultCleanupHandler df'' $ do
 			t <- guessTarget file Nothing
 			setTargets [t]

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

@@ -0,0 +1,15 @@+module HsDev.Tools.Ghc.Prelude (
+	reduce, one, trim
+	) where
+
+import Data.Char (isSpace)
+
+reduce :: ([a] -> a) -> [a] -> [a]
+reduce = (return .)
+
+one :: a -> [a]
+one = return
+
+trim :: String -> String
+trim = p . p where
+	p = reverse . dropWhile isSpace

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

@@ -1,11 +1,12 @@ module HsDev.Tools.Ghc.Worker (
-	Worker(..),
-	startWorker,
-	waitWork,
+	ghcWorker,
+	waitGhc,
 	evaluate,
 	try,
 
-	Ghc
+	Ghc,
+
+	module Control.Concurrent.Worker
 	) where
 
 import Control.Arrow (left)
@@ -19,14 +20,11 @@ import GHC.Paths
 import Packages
 
-data Worker = Worker {
-	ghcSendWork :: Ghc () -> IO (),
-	ghcWorkerChan :: Chan (Ghc ()) }
+import Control.Concurrent.Worker
 
-startWorker :: IO Worker
-startWorker = do
-	ch <- newChan
-	void $ forkIO $ runGhc (Just libdir) $ do
+ghcWorker :: IO (Worker (Ghc ()))
+ghcWorker = worker_ (runGhc (Just libdir)) ghcInit try where
+	ghcInit f = do
 		fs <- getSessionDynFlags
 		defaultCleanupHandler fs $ do
 			(fs', _, _) <- parseDynamicFlags fs (map noLoc [])
@@ -37,16 +35,14 @@ 			_ <- setSessionDynFlags fs''
 			_ <- liftIO $ initPackages fs''
 			mapM parseImportDecl ["import " ++ m | m <- startMods] >>= setContext . map IIDecl
-			liftIO (getChanContents ch) >>= mapM_ try
-	return $ Worker (writeChan ch) ch
-	where
-		startMods :: [String]
-		startMods = ["Prelude", "Data.List", "Control.Monad"]
+			f
+	startMods :: [String]
+	startMods = ["Prelude", "Data.List", "Control.Monad", "HsDev.Tools.Ghc.Prelude"]
 
-waitWork :: Worker -> Ghc a -> ErrorT String IO a
-waitWork w act = ErrorT $ do
+waitGhc :: Worker (Ghc ()) -> Ghc a -> ErrorT String IO a
+waitGhc w act = ErrorT $ do
 	var <- newEmptyMVar
-	ghcSendWork w $ try act >>= liftIO . putMVar var
+	sendWork w $ try act >>= liftIO . putMVar var
 	takeMVar var
 
 evaluate :: String -> Ghc String

src/HsDev/Tools/GhcMod.hs view

@@ -1,4 +1,4 @@-{-# LANGUAGE OverloadedStrings, ConstraintKinds, FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings, ConstraintKinds, FlexibleContexts, LambdaCase #-}
 
 module HsDev.Tools.GhcMod (
 	list,
@@ -10,34 +10,45 @@ 	check,
 	lint,
 
-	runGhcMod
+	runGhcMod,
+
+	locateGhcModEnv, ghcModEnvPath,
+	ghcModWorker,
+	ghcModMultiWorker,
+	waitGhcMod,
+	waitMultiGhcMod,
+
+	GhcModT,
+	module Control.Concurrent.Worker
 	) where
 
 import Control.Applicative
 import Control.Arrow
+import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, newMVar, modifyMVar_)
 import Control.DeepSeq
-import Control.Exception
+import Control.Exception (SomeException, bracket)
 import Control.Monad.Error
 import Control.Monad.CatchIO (MonadCatchIO)
 import Data.Aeson
 import Data.Char
 import Data.Maybe
-import Data.List (sort, nub)
 import qualified Data.Map as M
-import Exception (ghandle)
-import GHC (Ghc, runGhc, getSessionDynFlags, defaultCleanupHandler)
-import GHC.Paths (libdir)
+import Exception (gtry)
+import GHC (getSessionDynFlags, defaultCleanupHandler)
+import System.Directory
+import System.FilePath (normalise)
 import Text.Read (readMaybe)
-import System.Directory (getCurrentDirectory)
 
+import Language.Haskell.GhcMod (GhcModT, runGhcModT, withOptions)
 import qualified Language.Haskell.GhcMod as GhcMod
+import qualified Language.Haskell.GhcMod.Internal as GhcMod
 
+import Control.Concurrent.Worker
 import HsDev.Cabal
 import HsDev.Project
 import HsDev.Symbols
-import HsDev.Symbols.Location
 import HsDev.Tools.Base
-import HsDev.Util ((.::), liftException, liftIOErrors)
+import HsDev.Util ((.::), liftIOErrors)
 
 list :: [String] -> Cabal -> ErrorT String IO [ModuleLocation]
 list opts cabal = runGhcMod (GhcMod.defaultOptions { GhcMod.ghcUserOptions = opts }) $ do
@@ -75,13 +86,13 @@ browseInspection :: [String] -> Inspection
 browseInspection = InspectionAt 0
 
-info :: [String] -> Cabal -> FilePath -> Maybe Project -> String -> String -> ErrorT String IO Declaration
-info opts cabal file mproj mname sname = do
-	rs <- runGhcMod (GhcMod.defaultOptions { GhcMod.ghcUserOptions = cabalOpt cabal ++ opts }) $
+info :: [String] -> Cabal -> FilePath -> Maybe Project -> String -> String -> GhcModT IO Declaration
+info opts cabal file _ _ sname = do
+	rs <- withOptions (\o -> o { GhcMod.ghcUserOptions = cabalOpt cabal ++ opts }) $
 		GhcMod.info file sname
 	toDecl rs
 	where
-		toDecl s = maybe (throwError $ "Can't parse info: '" ++ s ++ "'") return $ parseData s `mplus` parseFunction s
+		toDecl s = maybe (throwError $ strMsg $ "Can't parse info: '" ++ s ++ "'") return $ parseData s `mplus` parseFunction s
 		parseFunction s = do
 			groups <- match (sname ++ "\\s+::\\s+(.*?)(\\s+--(.*))?$") s
 			return $ Declaration sname Nothing Nothing (Function (Just $ groups `at` 1) [])
@@ -116,8 +127,8 @@ 		v .:: "expr" <*>
 		v .:: "type"
 
-typeOf :: [String] -> Cabal -> FilePath -> Maybe Project -> String -> Int -> Int -> ErrorT String IO [TypedRegion]
-typeOf opts cabal file mproj mname line col = runGhcMod (GhcMod.defaultOptions { GhcMod.ghcUserOptions = cabalOpt cabal ++ opts }) $ do
+typeOf :: [String] -> Cabal -> FilePath -> Maybe Project -> String -> Int -> Int -> GhcModT IO [TypedRegion]
+typeOf opts cabal file _ _ line col = withOptions (\o -> o { GhcMod.ghcUserOptions = cabalOpt cabal ++ opts }) $ do
 	fileCts <- liftIO $ readFile file
 	ts <- lines <$> GhcMod.types file line col
 	return $ mapMaybe (toRegionType fileCts) ts
@@ -131,9 +142,25 @@ 		parsePosition :: ReadM Position
 		parsePosition = Position <$> readParse <*> readParse
 
+data OutputMessageLevel = WarningMessage | ErrorMessage deriving (Eq, Ord, Bounded, Enum, Read, Show)
+
+instance NFData OutputMessageLevel where
+
+instance ToJSON OutputMessageLevel where
+	toJSON WarningMessage = toJSON ("warning" :: String)
+	toJSON ErrorMessage = toJSON ("error" :: String)
+
+instance FromJSON OutputMessageLevel where
+	parseJSON v = do
+		s <- parseJSON v
+		msum [
+			guard (s == ("warning" :: String)) >> return WarningMessage,
+			guard (s == ("error" :: String)) >> return ErrorMessage,
+			fail "Invalid output message level"]
+
 data OutputMessage = OutputMessage {
 	errorLocation :: Location,
-	errorWarning :: Bool,
+	errorLevel :: OutputMessageLevel,
 	errorMessage :: String }
 		deriving (Eq, Show)
 
@@ -143,34 +170,99 @@ instance ToJSON OutputMessage where
 	toJSON (OutputMessage l w m) = object [
 		"location" .= l,
-		"warning" .= w,
+		"level" .= w,
 		"message" .= m]
 
 instance FromJSON OutputMessage where
 	parseJSON = withObject "error message" $ \v -> OutputMessage <$>
 		v .:: "location" <*>
-		v .:: "warning" <*>
+		v .:: "level" <*>
 		v .:: "message"
 
 parseOutputMessage :: String -> Maybe OutputMessage
 parseOutputMessage s = do
-	groups <- match "^(.+):(\\d+):(\\d+):(\\s*Warning:)?\\s*(.*)$" s
+	groups <- match "^(.+):(\\d+):(\\d+):(\\s*(Warning|Error):)?\\s*(.*)$" s
 	return $ OutputMessage {
 		errorLocation = Location {
-			locationModule = FileModule (groups `at` 1) Nothing,
+			locationModule = FileModule (normalise (groups `at` 1)) Nothing,
 			locationPosition = Position <$> readMaybe (groups `at` 2) <*> readMaybe (groups `at` 3) },
-		errorWarning = isJust (groups 4),
-		errorMessage = groups `at` 5 }
+		errorLevel = if groups 5 == Just "Warning" then WarningMessage else ErrorMessage,
+		errorMessage = map nullToNL (groups `at` 6) }
+	where
+		nullToNL = \case
+			'\0' -> '\n'
+			ch -> ch
 
-check :: [String] -> Cabal -> [FilePath] -> Maybe Project -> ErrorT String IO [OutputMessage]
-check opts cabal files mproj = runGhcMod (GhcMod.defaultOptions { GhcMod.ghcUserOptions = cabalOpt cabal ++ opts }) $ do
+check :: [String] -> Cabal -> [FilePath] -> Maybe Project -> GhcModT IO [OutputMessage]
+check opts cabal files _ = withOptions (\o -> o { GhcMod.ghcUserOptions = cabalOpt cabal ++ opts }) $ do
 	msgs <- lines <$> GhcMod.checkSyntax files
 	return $ mapMaybe parseOutputMessage msgs
 
-lint :: [String] -> FilePath -> ErrorT String IO [OutputMessage]
-lint opts file = runGhcMod (GhcMod.defaultOptions { GhcMod.hlintOpts = opts }) $ do
+lint :: [String] -> FilePath -> GhcModT IO [OutputMessage]
+lint opts file = withOptions (\o -> o { GhcMod.hlintOpts = opts }) $ do
 	msgs <- lines <$> GhcMod.lint file
 	return $ mapMaybe parseOutputMessage msgs
 
-runGhcMod :: (GhcMod.IOish m, MonadCatchIO m) => GhcMod.Options -> GhcMod.GhcModT m a -> ErrorT String m a
-runGhcMod opts act = liftIOErrors $ ErrorT $ liftM (left show . fst) $ GhcMod.runGhcModT opts act
+runGhcMod :: (GhcMod.IOish m, MonadCatchIO m) => GhcMod.Options -> GhcModT m a -> ErrorT String m a
+runGhcMod opts act = liftIOErrors $ ErrorT $ liftM (left show . fst) $ runGhcModT opts act
+
+locateGhcModEnv :: FilePath -> IO (Either Project Cabal)
+locateGhcModEnv f = do
+	mproj <- locateProject f
+	maybe (liftM Right $ getSandbox f) (return . Left) mproj
+
+ghcModEnvPath :: FilePath -> Either Project Cabal -> FilePath
+ghcModEnvPath defaultPath = either projectPath (fromMaybe defaultPath . sandbox)
+
+-- | Create ghc-mod worker for project or for sandbox
+ghcModWorker :: Either Project Cabal -> IO (Worker (GhcModT IO ()))
+ghcModWorker p = do
+	home <- getHomeDirectory
+	worker_ (runGhcModT'' $ ghcModEnvPath home p) id try
+	where
+		makeEnv :: FilePath -> IO GhcMod.GhcModEnv
+		makeEnv = GhcMod.newGhcModEnv GhcMod.defaultOptions
+		functionNotExported = True
+		runGhcModT'' :: FilePath -> GhcModT IO () -> IO ()
+		runGhcModT'' cur act
+			| functionNotExported = withCurrentDirectory cur
+				(void . runGhcModT GhcMod.defaultOptions $ act)
+			| otherwise = do
+				env' <- makeEnv cur
+				void $ GhcMod.runGhcModT' env' GhcMod.defaultState $ do
+					dflags <- getSessionDynFlags
+					defaultCleanupHandler dflags $ do
+						--GhcMod.initializeFlagsWithCradle GhcMod.defaultOptions (GhcMod.gmCradle env')
+						act
+		withCurrentDirectory :: FilePath -> IO a -> IO a
+		withCurrentDirectory cur act = bracket getCurrentDirectory setCurrentDirectory $
+			const (setCurrentDirectory cur >> act)
+
+-- | Manage many ghc-mod workers for each project/sandbox
+ghcModMultiWorker :: IO (Worker (FilePath, GhcModT IO ()))
+ghcModMultiWorker = worker id initMultiGhcMod multiWork where
+	initMultiGhcMod f = newMVar M.empty >>= f
+	multiWork ghcMods (file, act) = do
+		home <- getHomeDirectory
+		env' <- locateGhcModEnv file
+		let
+			envPath' = ghcModEnvPath home env'
+		modifyMVar_ ghcMods $ \ghcModsMap -> do
+			w <- maybe (ghcModWorker env') return $ M.lookup envPath' ghcModsMap
+			sendWork w act
+			return $ M.insert envPath' w ghcModsMap
+
+waitGhcMod :: Worker (GhcModT IO ()) -> GhcModT IO a -> ErrorT String IO a
+waitGhcMod w act = ErrorT $ do
+	var <- newEmptyMVar
+	sendWork w $ try act >>= liftIO . putMVar var
+	takeMVar var
+
+waitMultiGhcMod :: Worker (FilePath, GhcModT IO ()) -> FilePath -> GhcModT IO a -> ErrorT String IO a
+waitMultiGhcMod w f act = ErrorT $ do
+	var <- newEmptyMVar
+	sendWork w (f, try act >>= liftIO . putMVar var)
+	takeMVar var
+
+try :: GhcModT IO a -> GhcModT IO (Either String a)
+try = liftM (left (show :: SomeException -> String)) . gtry

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

@@ -1,5 +1,6 @@ module HsDev.Tools.GhcMod.InferType (
-	untyped, inferType, inferTypes
+	untyped, inferType, inferTypes,
+	GhcModT
 	) where
 
 import Control.Monad.Error
@@ -16,7 +17,7 @@ untyped _ = False
 
 -- | Infer type of declaration
-inferType :: [String] -> Cabal -> FilePath -> Maybe Project -> String -> Declaration -> ErrorT String IO Declaration
+inferType :: [String] -> Cabal -> FilePath -> Maybe Project -> String -> Declaration -> GhcModT IO Declaration
 inferType opts cabal src mproj mname decl
 	| untyped (declaration decl) = infer
 	| otherwise = return decl
@@ -28,16 +29,16 @@ 
 		setType :: DeclarationInfo -> Maybe String -> DeclarationInfo
 		setType (Function _ ds) newType = Function newType ds
-		setType info _ = info
+		setType dinfo _ = dinfo
 
 		getType :: DeclarationInfo -> Maybe String
 		getType (Function fType _) = fType
 		getType _ = Nothing
 
 -- | Infer types for module
-inferTypes :: [String] -> Cabal -> Module -> ErrorT String IO Module
+inferTypes :: [String] -> Cabal -> Module -> GhcModT IO Module
 inferTypes opts cabal m = case moduleLocation m of
 	FileModule src p -> do
 		inferredDecls <- traverse (inferType opts cabal src p (moduleName m)) $ moduleDeclarations m
 		return m { moduleDeclarations = inferredDecls }
-	_ -> throwError "Type infer works only for source files"
+	_ -> throwError $ strMsg "Type infer works only for source files"

src/HsDev/Tools/Hayoo.hs view

@@ -16,8 +16,6 @@ 
 import Data.Aeson
 import qualified Data.ByteString.Lazy.Char8 as L
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.Encoding as T
 import Network.HTTP
 import Text.RegexPR (gsubRegexPR)

src/HsDev/Util.hs view

@@ -14,7 +14,7 @@ 	-- * UTF-8
 	fromUtf8, toUtf8,
 	-- * IO
-	hGetLineBS, logIO, ignoreIO
+	hGetLineBS, logException, logIO, ignoreIO
 	) where
 
 import Control.Arrow (second)
@@ -132,8 +132,13 @@ hGetLineBS :: Handle -> IO ByteString
 hGetLineBS = fmap L.fromStrict . B.hGetLine
 
+logException :: String -> (String -> IO ()) -> IO () -> IO ()
+logException pre out = handle onErr where
+	onErr :: SomeException -> IO ()
+	onErr e = out $ pre ++ show e
+
 logIO :: String -> (String -> IO ()) -> IO () -> IO ()
-logIO pre out act = handle onIO act where
+logIO pre out = handle onIO where
 	onIO :: IOException -> IO ()
 	onIO e = out $ pre ++ show e

src/System/Console/Cmd.hs view

@@ -67,7 +67,7 @@ --
 -- > cutName >=> cmdAct act
 cutName :: String -> Args -> CmdAction Args
-cutName name args@(Args as os) = case stripPrefix (words name) as of
+cutName name (Args as os) = case stripPrefix (words name) as of
 	Just as' -> return (Args as' os)
 	Nothing -> notMatch
 
@@ -75,11 +75,11 @@ verifyOpts os = ErrorT . Just . verify os
 
 cmda :: String -> [String] -> [Opt] -> String -> (Args -> CmdAction a) -> Cmd a
-cmda name as os desc act = Cmd {
+cmda name as os cdesc act = Cmd {
 	cmdName = name,
 	cmdArgs = as,
 	cmdOpts = os,
-	cmdDesc = desc,
+	cmdDesc = cdesc,
 	cmdGetArgs = cut',
 	cmdAction = verifyOpts os >=> act }
 	where
@@ -88,19 +88,19 @@ 			| otherwise = cutName name
 
 cmda_ :: String -> [Opt] -> String -> (Opts String -> CmdAction a) -> Cmd a
-cmda_ name os desc act = validateArgs noPos $ cmda name [] os desc (act . namedArgs) where
+cmda_ name os cdesc act = validateArgs noPos $ cmda name [] os cdesc (act . namedArgs) where
 	noPos (Args [] _) = return ()
 	noPos (Args _ _) = failMatch "No positional argument expected"
 
 cmd :: String -> [String] -> [Opt] -> String -> (Args -> a) -> Cmd a
-cmd name as os desc act = cmda name as os desc (cmdAct act)
+cmd name as os cdesc act = cmda name as os cdesc (cmdAct act)
 
 cmd_ :: String -> [Opt] -> String -> (Opts String -> a) -> Cmd a
-cmd_ name os desc act = cmda_ name os desc (cmdAct act)
+cmd_ name os cdesc act = cmda_ name os cdesc (cmdAct act)
 
 -- | Unnamed command
 defCmd :: [String] -> [Opt] -> String -> (Args -> a) -> Cmd a
-defCmd as os desc act = cmda "" as os desc (cmdAct act)
+defCmd as os cdesc act = cmda "" as os cdesc (cmdAct act)
 
 data CmdHelp =
 	HelpUsage [String] |

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

@@ -18,7 +18,7 @@ createPool baseName = liftM2 Pool (newMVar []) mkNewName where
 	mkNewName :: IO (IO String)
 	mkNewName = do
-		num <- newMVar 0
+		num <- newMVar (0 :: Integer)
 		return $ modifyMVar num $ \n -> do
 			return (succ n, baseName ++ show n)

src/System/Win32/PowerShell.hs view

@@ -185,7 +185,7 @@ 	escape '"' (_, s') = (True, '\\' : '"' : s')
 	escape '\\' (True, s') = (True, '\\' : '\\' : s')
 	escape '\\' (False, s') = (False, '\\' : s')
-	escape c (b, s') = (False, c : s')
+	escape c (_, s') = (False, c : s')
 
 translateArg :: String -> String
 translateArg s

tools/Tool.hs view

@@ -8,18 +8,19 @@ 	-- * Errors
 	toolError,
 	-- * Options
-	prettyOpt, isPretty,
+	prettyOpt, isPretty, lispOpt, isLisp,
 
 	module System.Console.Cmd
 	) where
 
-import Control.Monad.Error (ErrorT, runErrorT, throwError)
+import Control.Monad.Error (runErrorT, throwError)
 import Data.Aeson
 import Data.Aeson.Encode.Pretty (encodePretty)
 import qualified Data.ByteString.Lazy.Char8 as L (ByteString, putStrLn)
 import System.Environment
 import System.IO
 
+import Data.Lisp (encodeLisp)
 import HsDev.Tools.Base (ToolM)
 
 import System.Console.Cmd
@@ -29,6 +30,7 @@ toolMain name commands = do
 	hSetBuffering stdout LineBuffering
 	hSetEncoding stdout utf8
+	hSetEncoding stdin utf8
 	as <- getArgs
 	case as of
 		[] -> usage name toolCmds
@@ -48,12 +50,13 @@ 
 -- | Command with JSONable result
 jsonCmd :: ToJSON a => String -> [String] -> [Opt] -> String -> (Args -> ToolM a) -> Cmd (IO ())
-jsonCmd name pos os descr act = cmd name pos (prettyOpt : os) descr $ \(Args as opts) -> do
+jsonCmd name pos os descr act = cmd name pos ([prettyOpt, lispOpt] ++ os) descr $ \(Args as opts) -> do
 	r <- runErrorT $ act (Args as opts)
 	L.putStrLn $ either (toStr opts . errorStr) (toStr opts) r
 	where
 		toStr :: ToJSON a => Opts String -> a -> L.ByteString
 		toStr opts
+			| isLisp opts = encodeLisp
 			| isPretty opts = encodePretty
 			| otherwise = encode
 
@@ -73,3 +76,9 @@ 
 isPretty :: Opts String -> Bool
 isPretty = flagSet "pretty"
+
+lispOpt :: Opt
+lispOpt = flag "lisp" `desc` "s-exp output" `short` ['l']
+
+isLisp :: Opts String -> Bool
+isLisp = flagSet "lisp"

tools/hsclearimports.hs view

@@ -3,11 +3,9 @@ 	) where
 
 import Control.Exception (finally)
-import Control.Monad (void)
 import Control.Monad.Error
 import System.Directory
 import System.Environment (getArgs)
-import Text.Read (readMaybe)
 
 import HsDev.Tools.ClearImports (clearImports)
 import HsDev.Symbols (locateSourceDir)

tools/hsdev.hs view

@@ -4,10 +4,8 @@ 	main
 	) where
 
+import Control.Applicative
 import Control.Monad
-import Data.List
-import Data.Char
-import Data.Maybe (listToMaybe, mapMaybe)
 import Network.Socket (withSocketsDo)
 import System.Environment (getArgs)
 import System.Exit
@@ -58,7 +56,7 @@ -- | Check that specified options are numbers
 validateNums :: [String] -> Cmd a -> Cmd a
 validateNums ns = validateArgs (check . namedArgs) where
-	check os = forM_ ns $ \n -> case fmap (readMaybe :: String -> Maybe Int) $ arg n os of
+	check os = forM_ ns $ \n -> case (readMaybe :: String -> Maybe Int) <$> arg n os of
 		Just Nothing -> failMatch "Must be a number"
 		_ -> return ()