hdevtools (empty) → 0.1.0.2
raw patch · 12 files changed
+773/−0 lines, 12 filesdep +basedep +cmdargsdep +directorysetup-changed
Dependencies added: base, cmdargs, directory, ghc, ghc-paths, ghc-syb-utils, network, syb, time, unix
Files
- LICENSE +19/−0
- Setup.hs +2/−0
- hdevtools.cabal +44/−0
- src/Client.hs +70/−0
- src/CommandArgs.hs +129/−0
- src/CommandLoop.hs +124/−0
- src/Daemonize.hs +30/−0
- src/Info.hs +175/−0
- src/Main.hs +61/−0
- src/Server.hs +83/−0
- src/Types.hs +26/−0
- src/Util.hs +10/−0
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (C) 2012 The hdevtools Authors (see AUTHORS file)++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hdevtools.cabal view
@@ -0,0 +1,44 @@+name: hdevtools+version: 0.1.0.2+synopsis: Persistent GHC powered background server for FAST haskell development tools+-- description: +license: MIT+license-file: LICENSE+author: Bit Connor+maintainer: mutantlemon@gmail.com+copyright: See AUTHORS file+category: Development+homepage: https://github.com/bitc/hdevtools/+bug-reports: https://github.com/bitc/hdevtools/issues/+build-type: Simple+cabal-version: >=1.8++source-repository head+ type: git+ location: git://github.com/bitc/hdevtools.git++executable hdevtools+ hs-source-dirs: src+ ghc-options: -Wall+ cpp-options: -DCABAL+ main-is: Main.hs+ other-modules: Client,+ CommandArgs,+ CommandLoop,+ Daemonize,+ Info,+ Main,+ Server,+ Types,+ Util,+ Paths_hdevtools+ build-depends: base == 4.*,+ cmdargs,+ directory,+ ghc,+ ghc-paths,+ ghc-syb-utils,+ syb,+ network,+ time,+ unix
+ src/Client.hs view
@@ -0,0 +1,70 @@+module Client+ ( getServerStatus+ , stopServer+ , serverCommand+ ) where++import Control.Exception (tryJust)+import Control.Monad (guard)+import Network (PortID(UnixSocket), connectTo)+import System.Exit (exitFailure, exitWith)+import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn, stderr)+import System.IO.Error (isDoesNotExistError)++import Daemonize (daemonize)+import Server (createListenSocket, startServer)+import Types (ClientDirective(..), Command(..), ServerDirective(..))+import Util (readMaybe)++connect :: FilePath -> IO Handle+connect sock = do+ connectTo "" (UnixSocket sock)++getServerStatus :: FilePath -> IO ()+getServerStatus sock = do+ h <- connect sock+ hPutStrLn h $ show SrvStatus+ hFlush h+ startClientReadLoop h++stopServer :: FilePath -> IO ()+stopServer sock = do+ h <- connect sock+ hPutStrLn h $ show SrvExit+ hFlush h+ startClientReadLoop h++serverCommand :: FilePath -> Command -> [String] -> IO ()+serverCommand sock cmd ghcOpts = do+ r <- tryJust (guard . isDoesNotExistError) (connect sock)+ case r of+ Right h -> do+ hPutStrLn h $ show (SrvCommand cmd ghcOpts)+ hFlush h+ startClientReadLoop h+ Left _ -> do+ s <- createListenSocket sock+ daemonize False $ startServer sock (Just s)+ serverCommand sock cmd ghcOpts++startClientReadLoop :: Handle -> IO ()+startClientReadLoop h = do+ msg <- hGetLine h+ let clientDirective = readMaybe msg+ case clientDirective of+ Just (ClientStdout out) -> putStrLn out >> startClientReadLoop h+ Just (ClientStderr err) -> hPutStrLn stderr err >> startClientReadLoop h+ Just (ClientExit exitCode) -> hClose h >> exitWith exitCode+ Just (ClientUnexpectedError err) -> hClose h >> unexpectedError err+ Nothing -> do+ hClose h+ unexpectedError $+ "The server sent an invalid message to the client: " ++ show msg++unexpectedError :: String -> IO ()+unexpectedError err = do+ hPutStrLn stderr banner+ hPutStrLn stderr err+ hPutStrLn stderr banner+ exitFailure+ where banner = replicate 78 '*'
+ src/CommandArgs.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP #-}+module CommandArgs+ ( HDevTools(..)+ , loadHDevTools+ )+where++import System.Console.CmdArgs.Implicit+import System.Environment (getProgName)++#ifdef CABAL+import Data.Version (showVersion)+import Paths_hdevtools (version)+#endif++programVersion :: String+programVersion =+#ifdef CABAL+ "version " ++ showVersion version+#else+ "unknown-version (not built with cabal)"+#endif++data HDevTools+ = Admin+ { socket :: Maybe FilePath+ , start_server :: Bool+ , noDaemon :: Bool+ , status :: Bool+ , stop_server :: Bool+ }+ | Check+ { socket :: Maybe FilePath+ , ghcOpts :: [String]+ , file :: String+ }+ | Info+ { socket :: Maybe FilePath+ , ghcOpts :: [String]+ , file :: String+ , identifier :: String+ }+ | Type+ { socket :: Maybe FilePath+ , ghcOpts :: [String]+ , file :: String+ , line :: Int+ , col :: Int+ }+ deriving (Show, Data, Typeable)++dummyAdmin :: HDevTools+dummyAdmin = Admin+ { socket = Nothing+ , start_server = False+ , noDaemon = False+ , status = False+ , stop_server = False+ }++dummyCheck :: HDevTools+dummyCheck = Check+ { socket = Nothing+ , ghcOpts = []+ , file = ""+ }++dummyInfo :: HDevTools+dummyInfo = Info+ { socket = Nothing+ , ghcOpts = []+ , file = ""+ , identifier = ""+ }++dummyType :: HDevTools+dummyType = Type+ { socket = Nothing+ , ghcOpts = []+ , file = ""+ , line = 0+ , col = 0+ }++admin :: Annotate Ann+admin = record dummyAdmin+ [ socket := def += typFile += help "socket file to use"+ , start_server := def += help "start server"+ , noDaemon := def += help "do not daemonize (only if --start-server)"+ , status := def += help "show status of server"+ , stop_server := def += help "shutdown the server"+ ] += help "Interactions with the server"++check :: Annotate Ann+check = record dummyCheck+ [ socket := def += typFile += help "socket file to use"+ , ghcOpts := def += typ "OPTION" += help "ghc options"+ , file := def += typFile += argPos 0 += opt ""+ ] += help "Check a haskell source file for errors and warnings"++info :: Annotate Ann+info = record dummyInfo+ [ socket := def += typFile += help "socket file to use"+ , ghcOpts := def += typ "OPTION" += help "ghc options"+ , file := def += typFile += argPos 0 += opt ""+ , identifier := def += typ "IDENTIFIER" += argPos 1+ ] += help "Get info from GHC about the specified identifier"++type_ :: Annotate Ann+type_ = record dummyType+ [ socket := def += typFile += help "socket file to use"+ , ghcOpts := def += typ "OPTION" += help "ghc options"+ , file := def += typFile += argPos 0 += opt ""+ , line := def += typ "LINE" += argPos 1+ , col := def += typ "COLUMN" += argPos 2+ ] += help "Get the type of the expression at the specified line and column"++full :: String -> Annotate Ann+full progName = modes_ [admin += auto, check, info, type_]+ += helpArg [name "h", groupname "Help"]+ += versionArg [groupname "Help"]+ += program progName+ += summary (progName ++ ": " ++ programVersion)++loadHDevTools :: IO HDevTools+loadHDevTools = do+ progName <- getProgName+ (cmdArgs_ (full progName) :: IO HDevTools)
+ src/CommandLoop.hs view
@@ -0,0 +1,124 @@+module CommandLoop+ ( startCommandLoop+ ) where++import ErrUtils (Message, mkLocMessage)+import GHC (Ghc, GhcException, GhcLink(NoLink), HscTarget(HscInterpreted), LoadHowMuch(LoadAllTargets), Severity, SrcSpan, SuccessFlag(Succeeded, Failed), gcatch, getSessionDynFlags, ghcLink, guessTarget, handleSourceError, hscTarget, load, log_action, noLoc, parseDynamicFlags, printException, runGhc, setSessionDynFlags, setTargets, showGhcException)+import GHC.Paths (libdir)+import MonadUtils (MonadIO, liftIO)+import Outputable (PprStyle, renderWithStyle)+import System.Exit (ExitCode(ExitFailure, ExitSuccess))++import Types (ClientDirective(..), Command(..))+import Info (getIdentifierInfo, getType)++type CommandObj = (Command, [String])++type ClientSend = ClientDirective -> IO ()++startCommandLoop :: ClientSend -> IO (Maybe CommandObj) -> [String] -> Maybe Command -> IO ()+startCommandLoop clientSend getNextCommand initialGhcOpts mbInitial = do+ continue <- runGhc (Just libdir) $ do+ configOk <- gcatch (configSession clientSend initialGhcOpts >> return True)+ handleConfigError+ if configOk+ then do+ doMaybe mbInitial $ \cmd -> sendErrors (runCommand clientSend cmd)+ processNextCommand False+ else processNextCommand True++ case continue of+ Nothing ->+ -- Exit+ return ()+ Just (cmd, ghcOpts) -> startCommandLoop clientSend getNextCommand ghcOpts (Just cmd)+ where+ processNextCommand :: Bool -> Ghc (Maybe CommandObj)+ processNextCommand forceReconfig = do+ mbNextCmd <- liftIO getNextCommand+ case mbNextCmd of+ Nothing ->+ -- Exit+ return Nothing+ Just (cmd, ghcOpts) ->+ if forceReconfig || (ghcOpts /= initialGhcOpts)+ then return (Just (cmd, ghcOpts))+ else sendErrors (runCommand clientSend cmd) >> processNextCommand False++ sendErrors :: Ghc () -> Ghc ()+ sendErrors action = gcatch action (\x -> handleConfigError x >> return ())++ handleConfigError :: GhcException -> Ghc Bool+ handleConfigError e = do+ liftIO $ mapM_ clientSend+ [ ClientStderr (showGhcException e "")+ , ClientExit (ExitFailure 1)+ ]+ return False++doMaybe :: Monad m => Maybe a -> (a -> m ()) -> m ()+doMaybe Nothing _ = return ()+doMaybe (Just x) f = f x++configSession :: ClientSend -> [String] -> Ghc ()+configSession clientSend ghcOpts = do+ initialDynFlags <- getSessionDynFlags+ let updatedDynFlags = initialDynFlags+ { log_action = logAction clientSend+ , ghcLink = NoLink+ , hscTarget = HscInterpreted+ }+ (finalDynFlags, _, _) <- parseDynamicFlags updatedDynFlags (map noLoc ghcOpts)+ _ <- setSessionDynFlags finalDynFlags+ return ()++runCommand :: ClientSend -> Command -> Ghc ()+runCommand clientSend (CmdCheck file) = do+ let noPhase = Nothing+ target <- guessTarget file noPhase+ setTargets [target]+ let handler err = printException err >> return Failed+ flag <- handleSourceError handler (load LoadAllTargets)+ liftIO $ case flag of+ Succeeded -> clientSend (ClientExit ExitSuccess)+ Failed -> clientSend (ClientExit (ExitFailure 1))+runCommand clientSend (CmdInfo file identifier) = do+ result <- getIdentifierInfo file identifier+ case result of+ Left err ->+ liftIO $ mapM_ clientSend+ [ ClientStderr err+ , ClientExit (ExitFailure 1)+ ]+ Right info -> liftIO $ mapM_ clientSend+ [ ClientStdout info+ , ClientExit ExitSuccess+ ]+runCommand clientSend (CmdType file (line, col)) = do+ result <- getType file (line, col)+ case result of+ Left err ->+ liftIO $ mapM_ clientSend+ [ ClientStderr err+ , ClientExit (ExitFailure 1)+ ]+ Right types -> liftIO $ do+ mapM_ (clientSend . ClientStdout . formatType) types+ clientSend (ClientExit ExitSuccess)+ where+ formatType :: ((Int, Int, Int, Int), String) -> String+ formatType ((startLine, startCol, endLine, endCol), t) =+ concat+ [ show startLine , " "+ , show startCol , " "+ , show endLine , " "+ , show endCol , " "+ , "\"", t, "\""+ ]++logAction :: ClientSend -> Severity -> SrcSpan -> PprStyle -> Message -> IO ()+logAction clientSend severity srcspan style msg =+ let out = renderWithStyle fullMsg style+ _ = severity+ in clientSend (ClientStdout out)+ where fullMsg = mkLocMessage srcspan msg
+ src/Daemonize.hs view
@@ -0,0 +1,30 @@+module Daemonize+ ( daemonize+ ) where++import Control.Monad (when)+import System.Exit (ExitCode(ExitSuccess))+import System.Posix.Process (exitImmediately, createSession, forkProcess)+import System.Posix.IO++-- | This goes against the common daemon guidelines and does not change the+-- current working directory!+--+-- We need the daemon to stay in the current directory for the GHC API to work+daemonize :: Bool -> IO () -> IO ()+daemonize exit program = do+ _ <- forkProcess child1+ when exit $ exitImmediately ExitSuccess++ where+ child1 = do+ _ <- createSession+ _ <- forkProcess child2+ exitImmediately ExitSuccess++ child2 = do+ mapM_ closeFd [stdInput, stdOutput, stdError]+ nullFd <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags+ mapM_ (dupTo nullFd) [stdInput, stdOutput, stdError]+ closeFd nullFd+ program
+ src/Info.hs view
@@ -0,0 +1,175 @@+module Info+ ( getIdentifierInfo+ , getType+ ) where++import Control.Monad (liftM)+import Data.Generics (GenericQ, mkQ)+import Data.List (find, sortBy, intersperse)+import Data.Maybe (catMaybes, fromMaybe)+import Data.Typeable (Typeable)+import GHC.SYB.Utils (everythingStaged, Stage(TypeChecker))+import MonadUtils (liftIO)+import qualified CoreUtils+import qualified Desugar+import qualified GHC+import qualified HscTypes+import qualified NameSet+import qualified Outputable+import qualified PprTyThing+import qualified Pretty+import qualified TcHsSyn+import qualified TcRnTypes++getIdentifierInfo :: FilePath -> String -> GHC.Ghc (Either String String)+getIdentifierInfo file identifier =+ withModSummary file $ \m -> do+ GHC.setContext [GHC.IIModule (GHC.ms_mod m)]+ GHC.handleSourceError (return . Left . show) $+ liftM Right (infoThing identifier)++getType :: FilePath -> (Int, Int) -> GHC.Ghc (Either String [((Int, Int, Int, Int), String)])+getType file (line, col) =+ withModSummary file $ \m -> do+ p <- GHC.parseModule m+ typechecked <- GHC.typecheckModule p+ types <- processTypeCheckedModule typechecked (line, col)+ return (Right types)++withModSummary :: String -> (HscTypes.ModSummary -> GHC.Ghc (Either String a)) -> GHC.Ghc (Either String a)+withModSummary file action = do+ let noPhase = Nothing+ target <- GHC.guessTarget file noPhase+ GHC.setTargets [target]++ let handler err = GHC.printException err >> return GHC.Failed+ flag <- GHC.handleSourceError handler (GHC.load GHC.LoadAllTargets)+ case flag of+ GHC.Failed -> return (Left "Error loading targets")+ GHC.Succeeded -> do+ modSummary <- getModuleSummary file+ case modSummary of+ Nothing -> return (Left "Module not found in module graph")+ Just m -> action m++getModuleSummary :: FilePath -> GHC.Ghc (Maybe GHC.ModSummary)+getModuleSummary file = do+ moduleGraph <- GHC.getModuleGraph+ case find (moduleSummaryMatchesFilePath file) moduleGraph of+ Nothing -> return Nothing+ Just moduleSummary -> return (Just moduleSummary)++moduleSummaryMatchesFilePath :: FilePath -> GHC.ModSummary -> Bool+moduleSummaryMatchesFilePath file moduleSummary =+ let location = GHC.ms_location moduleSummary+ location_file = GHC.ml_hs_file location+ in case location_file of+ Just f -> f == file+ Nothing -> False++------------------------------------------------------------------------------+-- Most of the following code was taken from the source code of 'ghc-mod' (with+-- some stylistic changes)+--+-- ghc-mod:+-- http://www.mew.org/~kazu/proj/ghc-mod/+-- https://github.com/kazu-yamamoto/ghc-mod/++processTypeCheckedModule :: GHC.TypecheckedModule -> (Int, Int) -> GHC.Ghc [((Int, Int, Int, Int), String)]+processTypeCheckedModule tcm (line, col) = do+ let tcs = GHC.tm_typechecked_source tcm+ bs = listifySpans tcs (line, col) :: [GHC.LHsBind GHC.Id]+ es = listifySpans tcs (line, col) :: [GHC.LHsExpr GHC.Id]+ ps = listifySpans tcs (line, col) :: [GHC.LPat GHC.Id]+ bts <- mapM (getTypeLHsBind tcm) bs+ ets <- mapM (getTypeLHsExpr tcm) es+ pts <- mapM (getTypeLPat tcm) ps+ return $ map toTup $ sortBy cmp $ catMaybes $ concat [ets, bts, pts]+ where+ cmp (a, _) (b, _)+ | a `GHC.isSubspanOf` b = LT+ | b `GHC.isSubspanOf` a = GT+ | otherwise = EQ++toTup :: (GHC.SrcSpan, GHC.Type) -> ((Int, Int, Int, Int), String)+toTup (spn, typ) = (fourInts spn, pretty typ)++fourInts :: GHC.SrcSpan -> (Int, Int, Int, Int)+fourInts = fromMaybe (0, 0, 0, 0) . getSrcSpan++getSrcSpan :: GHC.SrcSpan -> Maybe (Int, Int, Int, Int)+getSrcSpan (GHC.RealSrcSpan spn) =+ Just (GHC.srcSpanStartLine spn+ , GHC.srcSpanStartCol spn+ , GHC.srcSpanEndLine spn+ , GHC.srcSpanEndCol spn)+getSrcSpan _ = Nothing++getTypeLHsBind :: GHC.TypecheckedModule -> GHC.LHsBind GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type))+getTypeLHsBind _ (GHC.L spn GHC.FunBind{GHC.fun_matches = GHC.MatchGroup _ typ}) = return $ Just (spn, typ)+getTypeLHsBind _ _ = return Nothing++getTypeLHsExpr :: GHC.TypecheckedModule -> GHC.LHsExpr GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type))+getTypeLHsExpr tcm e = do+ hs_env <- GHC.getSession+ (_, mbe) <- liftIO $ Desugar.deSugarExpr hs_env modu rn_env ty_env e+ return ()+ case mbe of+ Nothing -> return Nothing+ Just expr -> return $ Just (GHC.getLoc e, CoreUtils.exprType expr)+ where+ modu = GHC.ms_mod $ GHC.pm_mod_summary $ GHC.tm_parsed_module tcm+ rn_env = TcRnTypes.tcg_rdr_env $ fst $ GHC.tm_internals_ tcm+ ty_env = TcRnTypes.tcg_type_env $ fst $ GHC.tm_internals_ tcm++getTypeLPat :: GHC.TypecheckedModule -> GHC.LPat GHC.Id -> GHC.Ghc (Maybe (GHC.SrcSpan, GHC.Type))+getTypeLPat _ (GHC.L spn pat) = return $ Just (spn, TcHsSyn.hsPatType pat)++listifySpans :: Typeable a => GHC.TypecheckedSource -> (Int, Int) -> [GHC.Located a]+listifySpans tcs lc = listifyStaged TypeChecker p tcs+ where+ p (GHC.L spn _) = GHC.isGoodSrcSpan spn && spn `GHC.spans` lc++listifyStaged :: Typeable r => Stage -> (r -> Bool) -> GenericQ [r]+listifyStaged s p = everythingStaged s (++) [] ([] `mkQ` (\x -> [x | p x]))++pretty :: GHC.Type -> String+pretty =+ Pretty.showDocWith Pretty.OneLineMode+ . Outputable.withPprStyleDoc (Outputable.mkUserStyle Outputable.neverQualify Outputable.AllTheWay)+ . PprTyThing.pprTypeForUser False++------------------------------------------------------------------------------+-- The following code was taken from GHC's ghc/InteractiveUI.hs (with some+-- stylistic changes)++infoThing :: String -> GHC.Ghc String+infoThing str = do+ names <- GHC.parseName str+ mb_stuffs <- mapM GHC.getInfo names+ let filtered = filterOutChildren (\(t,_f,_i) -> t) (catMaybes mb_stuffs)+ unqual <- GHC.getPrintUnqual+ return $ Outputable.showSDocForUser unqual $+ Outputable.vcat (intersperse (Outputable.text "") $ map (pprInfo False) filtered)++ -- Filter out names whose parent is also there Good+ -- example is '[]', which is both a type and data+ -- constructor in the same type+filterOutChildren :: (a -> HscTypes.TyThing) -> [a] -> [a]+filterOutChildren get_thing xs+ = filter (not . has_parent) xs+ where+ all_names = NameSet.mkNameSet (map (GHC.getName . get_thing) xs)+ has_parent x = case HscTypes.tyThingParent_maybe (get_thing x) of+ Just p -> GHC.getName p `NameSet.elemNameSet` all_names+ Nothing -> False++pprInfo :: PprTyThing.PrintExplicitForalls -> (HscTypes.TyThing, GHC.Fixity, [GHC.Instance]) -> Outputable.SDoc+pprInfo pefas (thing, fixity, insts) =+ PprTyThing.pprTyThingInContextLoc pefas thing+ Outputable.$$ show_fixity fixity+ Outputable.$$ Outputable.vcat (map GHC.pprInstance insts)+ where+ show_fixity fix+ | fix == GHC.defaultFixity = Outputable.empty+ | otherwise = Outputable.ppr fix Outputable.<+> Outputable.ppr (GHC.getName thing)
+ src/Main.hs view
@@ -0,0 +1,61 @@+module Main where++import System.Environment (getProgName)+import System.IO (hPutStrLn, stderr)++import Client (getServerStatus, serverCommand, stopServer)+import CommandArgs+import Daemonize (daemonize)+import Server (startServer, createListenSocket)+import Types (Command(..))++defaultSocketFilename :: FilePath+defaultSocketFilename = ".hdevtools.sock"++getSocketFilename :: Maybe FilePath -> FilePath+getSocketFilename Nothing = defaultSocketFilename+getSocketFilename (Just f) = f++main :: IO ()+main = do+ args <- loadHDevTools+ let sock = getSocketFilename (socket args)+ case args of+ Admin {} -> doAdmin sock args+ Check {} -> doCheck sock args+ Info {} -> doInfo sock args+ Type {} -> doType sock args++doAdmin :: FilePath -> HDevTools -> IO ()+doAdmin sock args+ | start_server args =+ if noDaemon args then startServer sock Nothing+ else do+ s <- createListenSocket sock+ daemonize True $ startServer sock (Just s)+ | status args = getServerStatus sock+ | stop_server args = stopServer sock+ | otherwise = do+ progName <- getProgName+ hPutStrLn stderr "You must provide a command. See:"+ hPutStrLn stderr $ progName ++ " --help"++doFileCommand :: String -> (HDevTools -> Command) -> FilePath -> HDevTools -> IO ()+doFileCommand cmdName cmd sock args+ | null (file args) = do+ progName <- getProgName+ hPutStrLn stderr "You must provide a haskell source file. See:"+ hPutStrLn stderr $ progName ++ " " ++ cmdName ++ " --help"+ | otherwise = serverCommand sock (cmd args) (ghcOpts args)++doCheck :: FilePath -> HDevTools -> IO ()+doCheck = doFileCommand "check" $+ \args -> CmdCheck (file args)++doInfo :: FilePath -> HDevTools -> IO ()+doInfo = doFileCommand "info" $+ \args -> CmdInfo (file args) (identifier args)++doType :: FilePath -> HDevTools -> IO ()+doType = doFileCommand "type" $+ \args -> CmdType (file args) (line args, col args)
+ src/Server.hs view
@@ -0,0 +1,83 @@+module Server where++import Control.Exception (bracket, finally, tryJust)+import Control.Monad (guard)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Network (PortID(UnixSocket), Socket, accept, listenOn, sClose)+import System.Directory (removeFile)+import System.Exit (ExitCode(ExitSuccess))+import System.IO (Handle, hClose, hFlush, hGetLine, hPutStrLn)+import System.IO.Error (isDoesNotExistError)++import CommandLoop (startCommandLoop)+import Types (ClientDirective(..), Command, ServerDirective(..))+import Util (readMaybe)++createListenSocket :: FilePath -> IO Socket+createListenSocket socketPath =+ listenOn (UnixSocket socketPath)++startServer :: FilePath -> Maybe Socket -> IO ()+startServer socketPath mbSock = do+ case mbSock of+ Nothing -> bracket (createListenSocket socketPath) cleanup go+ Just sock -> (go sock) `finally` (cleanup sock)+ where+ cleanup :: Socket -> IO ()+ cleanup sock = do+ sClose sock+ removeSocketFile++ go :: Socket -> IO ()+ go sock = do+ currentClient <- newIORef Nothing+ startCommandLoop (clientSend currentClient) (getNextCommand currentClient sock) [] Nothing++ removeSocketFile :: IO ()+ removeSocketFile = do+ -- Ignore possible error if socket file does not exist+ _ <- tryJust (guard . isDoesNotExistError) $ removeFile socketPath+ return ()++clientSend :: IORef (Maybe Handle) -> ClientDirective -> IO ()+clientSend currentClient clientDirective = do+ mbH <- readIORef currentClient+ case mbH of+ Just h -> do+ -- TODO catch exception+ hPutStrLn h (show clientDirective)+ hFlush h+ Nothing -> error "This is impossible"++getNextCommand :: IORef (Maybe Handle) -> Socket -> IO (Maybe (Command, [String]))+getNextCommand currentClient sock = do+ checkCurrent <- readIORef currentClient+ case checkCurrent of+ Just h -> hClose h+ Nothing -> return ()+ (h, _, _) <- accept sock+ writeIORef currentClient (Just h)+ msg <- hGetLine h -- TODO catch exception+ let serverDirective = readMaybe msg+ case serverDirective of+ Nothing -> do+ clientSend currentClient $ ClientUnexpectedError $+ "The client sent an invalid message to the server: " ++ show msg+ getNextCommand currentClient sock+ Just (SrvCommand cmd ghcOpts) -> do+ return $ Just (cmd, ghcOpts)+ Just SrvStatus -> do+ mapM_ (clientSend currentClient) $+ [ ClientStdout "Server is running."+ , ClientExit ExitSuccess+ ]+ getNextCommand currentClient sock+ Just SrvExit -> do+ mapM_ (clientSend currentClient) $+ [ ClientStdout "Shutting down server."+ , ClientExit ExitSuccess+ ]+ -- Must close the handle here because we are exiting the loop so it+ -- won't be closed in the code above+ hClose h+ return Nothing
+ src/Types.hs view
@@ -0,0 +1,26 @@+module Types+ ( ServerDirective(..)+ , ClientDirective(..)+ , Command(..)+ ) where++import System.Exit (ExitCode)++data ServerDirective+ = SrvCommand Command [String]+ | SrvStatus+ | SrvExit+ deriving (Read, Show)++data ClientDirective+ = ClientStdout String+ | ClientStderr String+ | ClientExit ExitCode+ | ClientUnexpectedError String -- ^ For unexpected errors that should not happen+ deriving (Read, Show)++data Command+ = CmdCheck FilePath+ | CmdInfo FilePath String+ | CmdType FilePath (Int, Int)+ deriving (Read, Show)
+ src/Util.hs view
@@ -0,0 +1,10 @@+module Util+ ( readMaybe+ ) where++-- Taken from:+-- http://stackoverflow.com/questions/8066850/why-doesnt-haskells-prelude-read-return-a-maybe/8080084#8080084+readMaybe :: (Read a) => String -> Maybe a+readMaybe s = case [x | (x,t) <- reads s, ("","") <- lex t] of+ [x] -> Just x+ _ -> Nothing