diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hdevtools.cabal b/hdevtools.cabal new file mode 100644 --- /dev/null +++ b/hdevtools.cabal @@ -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 diff --git a/src/Client.hs b/src/Client.hs new file mode 100644 --- /dev/null +++ b/src/Client.hs @@ -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 '*' diff --git a/src/CommandArgs.hs b/src/CommandArgs.hs new file mode 100644 --- /dev/null +++ b/src/CommandArgs.hs @@ -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) diff --git a/src/CommandLoop.hs b/src/CommandLoop.hs new file mode 100644 --- /dev/null +++ b/src/CommandLoop.hs @@ -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 diff --git a/src/Daemonize.hs b/src/Daemonize.hs new file mode 100644 --- /dev/null +++ b/src/Daemonize.hs @@ -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 diff --git a/src/Info.hs b/src/Info.hs new file mode 100644 --- /dev/null +++ b/src/Info.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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) diff --git a/src/Server.hs b/src/Server.hs new file mode 100644 --- /dev/null +++ b/src/Server.hs @@ -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 diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 --- /dev/null +++ b/src/Types.hs @@ -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) diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -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