diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,11 @@ Changelog for GHCiD +0.5 + Add an extra boolean argument to startGhci + Add the number of modules loaded after All good + Print out messages until the prompt comes up + #23, add arguments and change what commands get invoked + #35, change the titlebar icon on Windows 0.4.2 Fix a GHC 7.6 warning 0.4.1 diff --git a/ghcid.cabal b/ghcid.cabal --- a/ghcid.cabal +++ b/ghcid.cabal @@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: ghcid -version: 0.4.2 +version: 0.5 license: BSD3 license-file: LICENSE category: Development @@ -34,6 +34,8 @@ process >= 1.1, cmdargs >= 0.10, terminal-size >= 0.3 + if os(windows) + build-depends: Win32 other-modules: Paths_ghcid, Language.Haskell.Ghcid.Types, @@ -59,6 +61,8 @@ cmdargs >= 0.10, ansi-terminal, terminal-size >= 0.3 + if os(windows) + build-depends: Win32 other-modules: Language.Haskell.Ghcid.Types, Language.Haskell.Ghcid.Parser, @@ -85,6 +89,8 @@ cmdargs, tasty, tasty-hunit + if os(windows) + build-depends: Win32 hs-source-dirs: src main-is: Test.hs other-modules: diff --git a/src/Ghcid.hs b/src/Ghcid.hs --- a/src/Ghcid.hs +++ b/src/Ghcid.hs @@ -31,6 +31,7 @@ -- | Command line options data Options = Options {command :: String + ,arguments :: [String] ,test :: Maybe String ,height :: Maybe Int ,width :: Maybe Int @@ -45,11 +46,12 @@ 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 = Nothing &= name "T" &= typ "EXPR" &= help "Command to run after successful loading" - ,height = Nothing &= help "Number of lines to show (defaults to console height)" - ,width = Nothing &= help "Number of columns to show (defaults to console width)" + ,height = Nothing &= help "Number of lines to use (defaults to console height)" + ,width = Nothing &= help "Number of columns to use (defaults to console width)" ,topmost = False &= name "t" &= help "Set window topmost (Windows only)" - ,notitle = False &= help "Don't update the shell title" + ,notitle = False &= help "Don't update the shell title/icon" ,restart = [] &= typFile &= help "Restart the command if any of these files change (defaults to .ghci or .cabal)" ,directory = "." &= typDir &= name "C" &= help "Set the current directory" ,outputfile = [] &= typFile &= name "o" &= help "File to write the full output to" @@ -57,29 +59,55 @@ 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 ... - never anything 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 ... - never anything 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 - | command o /= "" = return o +autoOptions o@Options{..} + | command /= "" = return $ f command [] | otherwise = do files <- getDirectoryContents "." let cabal = filter ((==) ".cabal" . takeExtension) files - let useGhci = o{command="ghci", restart=[".ghci"]} - let useCabal = o{command="cabal repl", restart=cabal} - let useStack = o{command="stack ghci", restart=cabal ++ ["stack.yaml"]} return $ case () of - _ | ".ghci" `elem` files -> useGhci - | "stack.yaml" `elem` files, False -> useStack -- see #130 - | cabal /= [] -> useCabal - | otherwise -> useGhci + _ | ".ghci" `elem` files -> f "ghci" [".ghci"] + | "stack.yaml" `elem` files, False -> f "stack ghci" ["stack.yaml"] -- see #130 + | cabal /= [] -> f (if arguments == [] then "cabal repl" else "cabal exec ghci") cabal + | otherwise -> f "ghci" [] + 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 + -- ensure the action runs off the main thread ctrlC :: IO () -> IO () ctrlC = join . onceFork main :: IO () -main = ctrlC $ do +main = withWindowIcon $ ctrlC $ do opts <- cmdArgsRun options withCurrentDirectory (directory opts) $ do opts@Options{..} <- autoOptions opts @@ -95,7 +123,7 @@ -- so putStrLn width 'x' uses up two lines return (f width 80 (pred . fst), f height 8 snd) withWaiterNotify $ \waiter -> - runGhcid waiter restart command outputfile test height (not notitle) $ \xs -> do + runGhcid waiter (nubOrd restart) command outputfile test height (not notitle) $ \xs -> do outWith $ forM_ (groupOn fst xs) $ \x@((s,_):_) -> do when (s == Bold) $ setSGR [SetConsoleIntensity BoldIntensity] putStr $ concatMap ((:) '\n' . snd) x @@ -108,19 +136,19 @@ runGhcid :: Waiter -> [FilePath] -> String -> [FilePath] -> Maybe String -> IO (Int,Int) -> Bool -> ([(Style,String)] -> IO ()) -> IO () runGhcid waiter restart command outputfiles test size titles output = do - let outputFill :: Maybe [Load] -> [String] -> IO () + let outputFill :: Maybe (Int, [Load]) -> [String] -> IO () outputFill load msg = do (width, height) <- size let n = height - length msg - load <- return $ take (if isJust load then n else 0) $ prettyOutput n + load <- return $ take (if isJust load then n else 0) $ prettyOutput n (maybe 0 fst load) [ m{loadMessage = concatMap (chunksOfWord width (width `div` 5)) $ loadMessage m} - | m@Message{} <- fromMaybe [] load] + | m@Message{} <- maybe [] snd load] output $ load ++ map (Plain,) msg ++ replicate (height - (length load + length msg)) (Plain,"") restartTimes <- mapM getModTime restart - outputFill Nothing ["Loading " ++ command ++ "..."] + outStrLn $ "Loading " ++ command ++ "..." nextWait <- waitFiles waiter - (ghci,messages) <- startGhci command Nothing + (ghci,messages) <- startGhci command Nothing True curdir <- getCurrentDirectory -- fire, given a waiter, the messages, and the warnings from last time @@ -128,6 +156,7 @@ messages <- return $ filter (not . whitelist) messages loaded <- map snd <$> showModules ghci + let loadedCount = length loaded let reloaded = nubOrd $ map loadFile messages -- some may have reloaded, but caused an error, and thus not be in the loaded set whenLoud $ do @@ -141,19 +170,22 @@ let (countErrors, countWarnings) = both sum $ unzip [if loadSeverity m == Error then (1,0) else (0,1) | m@Message{} <- messages] test <- return $ if countErrors == 0 then test else Nothing + when titles $ changeWindowIcon $ + if countErrors > 0 then IconError else if countWarnings > 0 then IconWarning else IconOK + let updateTitle extra = when titles $ 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 ++ "- " ++ takeFileName curdir - + updateTitle $ if isJust test then "(running test) " else "" - outputFill (Just messages) ["Running test..." | isJust test] + outputFill (Just (loadedCount, messages)) ["Running test..." | isJust test] forM_ outputfiles $ \file -> - writeFile file $ unlines $ map snd $ prettyOutput 1000000 $ filter isMessage messages + writeFile file $ unlines $ map snd $ prettyOutput 1000000 loadedCount $ filter isMessage messages whenJust test $ \test -> do res <- exec ghci test - outputFill (Just messages) $ fromMaybe res $ stripSuffix ["*** Exception: ExitSuccess"] res + outputFill (Just (loadedCount, messages)) $ fromMaybe res $ stripSuffix ["*** Exception: ExitSuccess"] res updateTitle "" let wait = nubOrd $ loaded ++ reloaded @@ -183,8 +215,8 @@ -- | Given an available height, and a set of messages to display, show them as best you can. -prettyOutput :: Int -> [Load] -> [(Style,String)] -prettyOutput height [] = [(Plain,allGoodMessage)] -prettyOutput height xs = take (max 3 $ height - (length msgs * 2)) msg1 ++ concatMap (take 2) msgs +prettyOutput :: Int -> Int -> [Load] -> [(Style,String)] +prettyOutput height loaded [] = [(Plain,allGoodMessage ++ " (" ++ show loaded ++ " module" ++ ['s' | loaded /= 1] ++ ")")] +prettyOutput loaded height xs = take (max 3 $ height - (length msgs * 2)) msg1 ++ concatMap (take 2) msgs where (err, warn) = partition ((==) Error . loadSeverity) xs msg1:msgs = map (map (Bold,) . loadMessage) err ++ map (map (Plain,) . loadMessage) warn diff --git a/src/Language/Haskell/Ghcid.hs b/src/Language/Haskell/Ghcid.hs --- a/src/Language/Haskell/Ghcid.hs +++ b/src/Language/Haskell/Ghcid.hs @@ -18,9 +18,10 @@ import System.Process import Control.Concurrent import Control.Exception.Extra -import Control.Monad +import Control.Monad.Extra import Data.Function import Data.List +import Data.IORef import Control.Applicative import System.Console.CmdArgs.Verbosity @@ -30,9 +31,11 @@ import Language.Haskell.Ghcid.Util import Prelude --- | Start GHCi, returning a function to perform further operation, as well as the result of the initial loading -startGhci :: String -> Maybe FilePath -> IO (Ghci, [Load]) -startGhci cmd directory = do +-- | Start GHCi, returning a function to perform further operation, as well as the result of the initial loading. +-- Pass True to write out messages produced while loading, useful if invoking something like "cabal repl" +-- which might compile dependent packages before really loading. +startGhci :: String -> Maybe FilePath -> Bool -> IO (Ghci, [Load]) +startGhci cmd directory echo = do (Just inp, Just out, Just err, _) <- createProcess (shell cmd){std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe, cwd = directory} hSetBuffering out LineBuffering @@ -43,6 +46,7 @@ let prefix = "#~GHCID-START~#" let finish = "#~GHCID-FINISH~#" hPutStrLn inp $ ":set prompt " ++ prefix + echo <- newIORef echo -- consume from a handle, produce an MVar with either Just and a message, or Nothing (stream closed) let consume h name = do @@ -54,6 +58,8 @@ Left _ -> putMVar result Nothing Right l -> do whenLoud $ outStrLn $ "%" ++ name ++ ": " ++ l + whenM (readIORef echo) $ + unless (any (`isInfixOf` l) [prefix, finish]) $ outStrLn l if finish `isInfixOf` l then do buf <- modifyMVar buffer $ \old -> return ([], reverse old) @@ -75,6 +81,7 @@ Nothing -> throwIO $ UnexpectedExit cmd s Just msg -> return msg r <- parseLoad <$> f "" + writeIORef echo False return (Ghci f,r) diff --git a/src/Language/Haskell/Ghcid/Terminal.hs b/src/Language/Haskell/Ghcid/Terminal.hs --- a/src/Language/Haskell/Ghcid/Terminal.hs +++ b/src/Language/Haskell/Ghcid/Terminal.hs @@ -1,24 +1,33 @@ {-# LANGUAGE CPP #-} module Language.Haskell.Ghcid.Terminal( - terminalTopmost + terminalTopmost, + withWindowIcon, WindowIcon(..), changeWindowIcon ) where #if defined(mingw32_HOST_OS) import Data.Word import Data.Bits -import Foreign.Ptr +import Control.Exception -type HWND = Ptr () +import Graphics.Win32.Misc +import Graphics.Win32.Window +import Graphics.Win32.Message +import Graphics.Win32.GDI.Types +import System.Win32.Types -c_SWP_NOSIZE = 1 :: Word32 -c_SWP_NOMOVE = 2 :: Word32 -c_HWND_TOPMOST = -1 :: Int +wM_SETICON = 0x0080 :: WindowMessage +wM_GETICON = 0x007F :: WindowMessage + +iCON_BIG = 1 +iCON_SMALL = 0 + + foreign import stdcall unsafe "windows.h GetConsoleWindow" - c_GetConsoleWindow :: IO HWND + getConsoleWindow :: IO HWND foreign import stdcall unsafe "windows.h SetWindowPos" - c_SetWindowPos :: HWND -> Int -> Int -> Int -> Int -> Int -> Word32 -> IO Bool + setWindowPos :: HWND -> HWND -> Int -> Int -> Int -> Int -> Word32 -> IO Bool #endif @@ -26,9 +35,45 @@ terminalTopmost :: IO () #if defined(mingw32_HOST_OS) terminalTopmost = do - wnd <- c_GetConsoleWindow - c_SetWindowPos wnd c_HWND_TOPMOST 0 0 0 0 (c_SWP_NOMOVE .|. c_SWP_NOSIZE) + wnd <- getConsoleWindow + setWindowPos wnd hWND_TOPMOST 0 0 0 0 (sWP_NOMOVE .|. sWP_NOSIZE) return () #else terminalTopmost = return () +#endif + + +data WindowIcon = IconOK | IconWarning | IconError + +-- | Change the window icon to green, yellow or red depending on whether the file was errorless, contained only warnings or contained at least one error. +changeWindowIcon :: WindowIcon -> IO () +#if defined(mingw32_HOST_OS) +changeWindowIcon x = do + ico <- return $ case x of + IconOK -> iDI_ASTERISK + IconWarning -> iDI_EXCLAMATION + IconError -> iDI_HAND + icon <- loadIcon Nothing ico + wnd <- getConsoleWindow + -- SMALL is the system tray, BIG is the taskbar and Alt-Tab screen + sendMessage wnd wM_SETICON iCON_SMALL $ fromIntegral $ castPtrToUINTPtr icon + sendMessage wnd wM_SETICON iCON_BIG $ fromIntegral $ castPtrToUINTPtr icon + return () +#else +changeWindowIcon _ = return () +#endif + + +withWindowIcon :: IO a -> IO a +#if defined(mingw32_HOST_OS) +withWindowIcon act = do + wnd <- getConsoleWindow + icoBig <- sendMessage wnd wM_GETICON iCON_BIG 0 + icoSmall <- sendMessage wnd wM_GETICON iCON_SMALL 0 + act `finally` do + sendMessage wnd wM_SETICON iCON_BIG icoBig + sendMessage wnd wM_SETICON iCON_SMALL icoSmall + return () +#else +withWindowIcon act = act #endif diff --git a/src/Test/HighLevel.hs b/src/Test/HighLevel.hs --- a/src/Test/HighLevel.hs +++ b/src/Test/HighLevel.hs @@ -24,7 +24,7 @@ testStartRepl = testCase "Start cabal repl" $ do root <- createTestProject - (ghci,load) <- startGhci "cabal repl" (Just root) + (ghci,load) <- startGhci "cabal repl" (Just root) False stopGhci ghci load @?= [ Loading "B.C" (normalise "src/B/C.hs") , Loading "A" (normalise "src/A.hs") @@ -34,7 +34,7 @@ testShowModules = testCase "Show Modules" $ do root <- createTestProject - (ghci,_) <- startGhci "cabal repl" (Just root) + (ghci,_) <- startGhci "cabal repl" (Just root) False mods <- showModules ghci stopGhci ghci mods @?= [("A",normalise "src/A.hs"),("B.C",normalise "src/B/C.hs")] diff --git a/src/Test/Polling.hs b/src/Test/Polling.hs --- a/src/Test/Polling.hs +++ b/src/Test/Polling.hs @@ -73,7 +73,7 @@ -- | The all good message requireAllGood :: [String] -> IO () -requireAllGood got = filter (not . null) got @?= [allGoodMessage] +requireAllGood got = map (take (length allGoodMessage)) (filter (not . null) got) @?= [allGoodMessage] --requireNonIndents :: [String] -> [String] -> IO () --requireNonIndents want got = [x | x@(c:_) <- got, not $ isSpace c] @?= want