ghcid-0.6.7: src/Ghcid.hs
{-# LANGUAGE RecordWildCards, DeriveDataTypeable, TupleSections #-}
{-# OPTIONS_GHC -fno-cse #-}
-- | The application entry point
module Ghcid(main, mainWithTerminal) where
import Control.Exception
import System.IO.Error
import Control.Monad.Extra
import Data.List.Extra
import Data.Maybe
import Data.Tuple.Extra
import Data.Version
import Session
import qualified System.Console.Terminal.Size as Term
import System.Console.CmdArgs
import System.Console.ANSI
import System.Directory.Extra
import System.Exit
import System.FilePath
import System.IO
import Paths_ghcid
import Language.Haskell.Ghcid.Terminal
import Language.Haskell.Ghcid.Util
import Language.Haskell.Ghcid.Types
import Wait
import Data.Functor
import Prelude
-- | Command line options
data Options = Options
{command :: String
,arguments :: [String]
,test :: [String]
,warnings :: Bool
,no_status :: Bool
,height :: Maybe Int
,width :: Maybe Int
,topmost :: Bool
,no_title :: Bool
,project :: String
,reload :: [FilePath]
,restart :: [FilePath]
,directory :: FilePath
,outputfile :: [FilePath]
,ignoreLoaded :: Bool
}
deriving (Data,Typeable,Show)
options :: Mode (CmdArgs Options)
options = cmdArgsMode $ Options
{command = "" &= typ "COMMAND" &= help "Command to run (defaults to ghci or cabal repl)"
,arguments = [] &= args &= typ "MODULE"
,test = [] &= name "T" &= typ "EXPR" &= help "Command to run after successful loading"
,warnings = False &= name "W" &= help "Allow tests to run even with warnings"
,no_status = False &= name "S" &= help "Suppress status messages"
,height = Nothing &= help "Number of lines to use (defaults to console height)"
,width = Nothing &= name "w" &= help "Number of columns to use (defaults to console width)"
,topmost = False &= name "t" &= help "Set window topmost (Windows only)"
,no_title = False &= help "Don't update the shell title/icon"
,project = "" &= typ "NAME" &= help "Name of the project, defaults to current directory"
,restart = [] &= typ "PATH" &= help "Restart the command when the given file or directory contents change (defaults to .ghci and any .cabal file)"
,reload = [] &= typ "PATH" &= help "Reload when the given file or directory contents change (defaults to none)"
,directory = "." &= typDir &= name "C" &= help "Set the current directory"
,outputfile = [] &= typFile &= name "o" &= help "File to write the full output to"
,ignoreLoaded = False &= explicit &= name "ignore-loaded" &= help "Keep going if no files are loaded. Requires --reload to be set."
} &= verbosity &=
program "ghcid" &= summary ("Auto reloading GHCi daemon v" ++ showVersion version)
{-
What happens on various command lines:
Hlint with no .ghci file:
- cabal repl - prompt with Language.Haskell.HLint loaded
- cabal exec ghci Sample.hs - prompt with Sample.hs loaded
- ghci - prompt with nothing loaded
- ghci Sample.hs - prompt with Sample.hs loaded
- stack ghci - prompt with all libraries and Main loaded
Hlint with a .ghci file:
- cabal repl - loads everything twice, prompt with Language.Haskell.HLint loaded
- cabal exec ghci Sample.hs - loads everything first, then prompt with Sample.hs loaded
- ghci - prompt with everything
- ghci Sample.hs - loads everything first, then prompt with Sample.hs loaded
- stack ghci - loads everything first, then prompt with libraries and Main loaded
Warnings:
- cabal repl won't pull in any C files (e.g. hoogle)
- cabal exec ghci won't work with modules that import an autogen Paths module
As a result, we prefer to give users full control with a .ghci file, if available
-}
autoOptions :: Options -> IO Options
autoOptions o@Options{..}
| command /= "" = return $ f [command] []
| otherwise = do
files <- getDirectoryContents "."
-- use unsafePerformIO to get nicer pattern matching for logic (read-only operations)
let isStack dir = flip catchIOError (const $ return False) $
doesFileExist (dir </> "stack.yaml") &&^ doesDirectoryExist (dir </> ".stack-work")
stack <- isStack "." ||^ isStack ".." -- stack file might be parent, see #62
let cabal = filter ((==) ".cabal" . takeExtension) files
let opts = ["-fno-code" | null test]
return $ case () of
_ | stack ->
let flags = if null arguments then
"stack ghci --test" :
["--no-load" | ".ghci" `elem` files] ++
map ("--ghci-options=" ++) opts
else
"stack exec --test -- ghci" : opts
in f flags $ "stack.yaml":cabal
| ".ghci" `elem` files -> f ("ghci":opts) [".ghci"]
| cabal /= [] -> f (if null arguments then "cabal repl":map ("--ghc-options=" ++) opts else "cabal exec -- ghci":opts) cabal
| otherwise -> f ("ghci":opts) []
where
f c r = o{command = unwords $ c ++ map escape arguments, arguments = [], restart = restart ++ r}
-- in practice we're not expecting many arguments to have anything funky in them
escape x | ' ' `elem` x = "\"" ++ x ++ "\""
| otherwise = x
-- | Like 'main', but run with a fake terminal for testing
mainWithTerminal :: IO (Int,Int) -> ([(Style,String)] -> IO ()) -> IO ()
mainWithTerminal termSize termOutput = withWindowIcon $ withSession $ \session -> do
-- On certain Cygwin terminals stdout defaults to BlockBuffering
hSetBuffering stdout LineBuffering
hSetBuffering stderr NoBuffering
opts <- cmdArgsRun options
withCurrentDirectory (directory opts) $ do
opts <- autoOptions opts
opts <- return $ opts{restart = nubOrd $ restart opts, reload = nubOrd $ reload opts}
when (topmost opts) terminalTopmost
termSize <- return $ case (width opts, height opts) of
(Just w, Just h) -> return (w,h)
(w, h) -> do
term <- termSize
-- if we write to the final column of the window then it wraps automatically
-- so putStrLn width 'x' uses up two lines
return (fromMaybe (pred $ fst term) w, fromMaybe (snd term) h)
withWaiterNotify $ \waiter ->
handle (\(UnexpectedExit cmd _) -> putStrLn $ "Command \"" ++ cmd ++ "\" exited unexpectedly") $
runGhcid session waiter termSize termOutput opts
main :: IO ()
main = mainWithTerminal termSize termOutput
where
termSize = maybe (80, 8) (Term.width &&& Term.height) <$> Term.size
termOutput xs = do
outWith $ forM_ (groupOn fst xs) $ \x@((s,_):_) -> do
when (s == Bold) $ setSGR [SetConsoleIntensity BoldIntensity]
putStr $ concatMap ((:) '\n' . snd) x
when (s == Bold) $ setSGR []
hFlush stdout -- must flush, since we don't finish with a newline
data Style = Plain | Bold deriving Eq
runGhcid :: Session -> Waiter -> IO (Int,Int) -> ([(Style,String)] -> IO ()) -> Options -> IO ()
runGhcid session waiter termSize termOutput opts@Options{..} = do
let outputFill :: Maybe (Int, [Load]) -> [String] -> IO ()
outputFill load msg = do
(width, height) <- termSize
let n = height - length msg
load <- return $ take (if isJust load then n else 0) $ prettyOutput (maybe 0 fst load)
[ m{loadMessage = concatMap (chunksOfWord width (width `div` 5)) $ loadMessage m}
| m@Message{} <- maybe [] snd load]
termOutput $ load ++ map (Plain,) msg ++ replicate (height - (length load + length msg)) (Plain,"")
when (ignoreLoaded && null reload) $ do
putStrLn "--reload must be set when using --ignore-loaded"
exitFailure
restartTimes <- mapM getModTime restart
curdir <- getCurrentDirectory
-- fire, given a waiter, the messages/loaded
let fire nextWait (messages, loaded) = do
let loadedCount = length loaded
whenLoud $ do
outStrLn $ "%MESSAGES: " ++ show messages
outStrLn $ "%LOADED: " ++ show loaded
let (countErrors, countWarnings) = both sum $ unzip
[if loadSeverity == Error then (1,0) else (0,1) | m@Message{..} <- messages, loadMessage /= []]
test <- return $
if null test || countErrors /= 0 || (countWarnings /= 0 && not warnings) then Nothing
else Just $ intercalate "\n" test
unless no_title $ setWindowIcon $
if countErrors > 0 then IconError else if countWarnings > 0 then IconWarning else IconOK
let updateTitle extra = unless no_title $ setTitle $
let f n msg = if n == 0 then "" else show n ++ " " ++ msg ++ ['s' | n > 1]
in (if countErrors == 0 && countWarnings == 0 then allGoodMessage else f countErrors "error" ++
(if countErrors > 0 && countWarnings > 0 then ", " else "") ++ f countWarnings "warning") ++
" " ++ extra ++ [' ' | extra /= ""] ++ "- " ++
(if null project then takeFileName curdir else project)
updateTitle $ if isJust test then "(running test)" else ""
outputFill (Just (loadedCount, messages)) ["Running test..." | isJust test]
forM_ outputfile $ \file ->
writeFile file $ unlines $ map snd $ prettyOutput loadedCount $ filter isMessage messages
when (null loaded && not ignoreLoaded) $ do
putStrLn "No files loaded, nothing to wait for. Fix the last error and restart."
exitFailure
whenJust test $ \t -> do
whenLoud $ outStrLn $ "%TESTING: " ++ t
sessionExecAsync session t $ \stderr -> do
whenLoud $ outStrLn "%TESTING: Completed"
hFlush stdout -- may not have been a terminating newline from test output
if "*** Exception: " `isPrefixOf` stderr then do
updateTitle "(test failed)"
setWindowIcon IconError
else
updateTitle "(test done)"
reason <- nextWait $ restart ++ reload ++ loaded
unless no_status $ outputFill Nothing $ "Reloading..." : map (" " ++) reason
restartTimes2 <- mapM getModTime restart
if restartTimes == restartTimes2 then do
nextWait <- waitFiles waiter
fire nextWait =<< sessionReload session
else
runGhcid session waiter termSize termOutput opts
nextWait <- waitFiles waiter
(messages, loaded) <- sessionStart session command
when (null loaded && not ignoreLoaded) $ do
putStrLn $ "\nNo files loaded, GHCi is not working properly.\nCommand: " ++ command
exitFailure
fire nextWait (messages, loaded)
-- | Given an available height, and a set of messages to display, show them as best you can.
prettyOutput :: Int -> [Load] -> [(Style,String)]
prettyOutput loaded [] = [(Plain,allGoodMessage ++ " (" ++ show loaded ++ " module" ++ ['s' | loaded /= 1] ++ ")")]
prettyOutput loaded xs = concat $ msg1:msgs
where (err, warn) = partition ((==) Error . loadSeverity) xs
msg1:msgs = map (map (Bold,) . loadMessage) err ++ map (map (Plain,) . loadMessage) warn