ghcid 0.4.2 → 0.5

raw patch · 7 files changed

+140/−44 lines, 7 filesdep +Win32dep ~directoryPVP ok

version bump matches the API change (PVP)

Dependencies added: Win32

Dependency ranges changed: directory

API changes (from Hackage documentation)

Files

• CHANGES.txt +6/−0
• ghcid.cabal +7/−1
• src/Ghcid.hs +58/−26
• src/Language/Haskell/Ghcid.hs +11/−4
• src/Language/Haskell/Ghcid/Terminal.hs +55/−10
• src/Test/HighLevel.hs +2/−2
• src/Test/Polling.hs +1/−1

@@ -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

@@ -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:   

@@ -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

@@ -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)  

@@ -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

@@ -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")] 

@@ -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