packages feed

ghcid 0.6.4 → 0.6.5

raw patch · 15 files changed

+465/−364 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

CHANGES.txt view
@@ -1,5 +1,13 @@ Changelog for ghcid +0.6.5+    #82, properly deal with warning messages including spans+    #78, support boot files better+    Better support for dealing with GHC 8.0 call stack messages+    #79, support multiple --test flags+    #71, improve multi-project stack support+    #74, make sure Cygwin terminals flush output properly+    If the test exits then exit ghcid 0.6.4     #69, fix up for stack project with file arguments 0.6.3
README.md view
@@ -35,4 +35,7 @@  * _This isn't as good as full IDE._ I've gone for simplicity over features. It's a point in the design space, but not necessarily the best point in the design space for you. For "real" IDEs see [the Haskell wiki](http://www.haskell.org/haskellwiki/IDEs). * _If I delete a file and put it back it gets stuck._ Yes, that's a [bug in GHCi](https://ghc.haskell.org/trac/ghc/ticket/9648). If you see GHCi getting confused just kill `ghcid` and start it again.-* _I want to run arbitrary commands when arbitrary files change._ This project reloads `ghci` when files loaded by `ghci` change. If you want a more general mechanism something like [Steel Overseer](https://github.com/steeloverseer/steeloverseer) will probably work better.+* _I want to run my tests when files change._ You can pass any `ghci` expression with the `--test` flag, e.g. `--test=:main`, which will be run whenever the code is warning free (or pass `--warnings` for when the code is merely error free).+* _I want to run arbitrary commands when arbitrary files change._ This project reloads `ghci` when files loaded by `ghci` change. If you want a more general mechanism something like [Steel Overseer](https://github.com/schell/steeloverseer) will probably work better.+* _I want syntax highlighting in the error messages._ One option is to use Neovim or Emacs and run the terminal in a buffer whose file type is set to Haskell.+* _I'm not seeing pattern matching warnings._ Ghcid automatically appends `-fno-code` to the command line, which makes the reload cycle about twice as fast. Unfortunately GHC 8.0 suffers from [bug 10600](https://ghc.haskell.org/trac/ghc/ticket/10600) which means `-fno-code` also disables pattern matching warnings. Until that GHC bug is fixed either accept no pattern match warnings or use `-c` to specify a command line to start `ghci` that doesn't include `-fno-code`.
ghcid.cabal view
@@ -1,7 +1,7 @@ cabal-version:      >= 1.10 build-type:         Simple name:               ghcid-version:            0.6.4+version:            0.6.5 license:            BSD3 license-file:       LICENSE category:           Development@@ -70,12 +70,12 @@     else         build-depends: unix     other-modules:-        Language.Haskell.Ghcid.Types,-        Language.Haskell.Ghcid.Parser,-        Language.Haskell.Ghcid.Terminal,-        Language.Haskell.Ghcid.Util,-        Language.Haskell.Ghcid,-        Session,+        Language.Haskell.Ghcid.Types+        Language.Haskell.Ghcid.Parser+        Language.Haskell.Ghcid.Terminal+        Language.Haskell.Ghcid.Util+        Language.Haskell.Ghcid+        Session         Wait  test-suite ghcid_test@@ -103,7 +103,7 @@     else         build-depends: unix     other-modules:-        Test.Parser,-        Test.HighLevel,-        Test.Util,-        Test.Polling+        Test.Parser+        Test.API+        Test.Util+        Test.Ghcid
src/Ghcid.hs view
@@ -2,7 +2,7 @@ {-# OPTIONS_GHC -fno-cse #-}  -- | The application entry point-module Ghcid(main, runGhcid) where+module Ghcid(main, mainWithTerminal) where  import Control.Exception import System.IO.Error@@ -19,21 +19,22 @@ import System.Exit import System.FilePath import System.IO-import System.IO.Unsafe  import Paths_ghcid-import Language.Haskell.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 :: Maybe String+    ,test :: [String]     ,warnings :: Bool     ,nostatus :: Bool     ,height :: Maybe Int@@ -51,7 +52,7 @@ 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"+    ,test = [] &= name "T" &= typ "EXPR" &= help "Command to run after successful loading"     ,warnings = False &= name "W" &= help "Allow tests to run even with warnings"     ,nostatus = False &= name "S" &= explicit &= name "no-status" &= help "Suppress status messages"     ,height = Nothing &= help "Number of lines to use (defaults to console height)"@@ -96,13 +97,14 @@         files <- getDirectoryContents "."          -- use unsafePerformIO to get nicer pattern matching for logic (read-only operations)-        let isStack dir = unsafePerformIO $ flip catchIOError (const $ return False) $+        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" | isNothing test]+        let opts = ["-fno-code" | null test]         return $ case () of-            _ | cabal /= [], isStack "." || isStack ".." -> -- stack file might be parent, see #62+            _ | stack ->                 let flags = if null arguments then                                 "stack ghci --test" :                                 ["--no-load" | ".ghci" `elem` files] ++@@ -121,45 +123,58 @@                  | otherwise = x  -main :: IO ()-main = withWindowIcon $ withSession $ \session -> do+-- | 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@Options{..} <- autoOptions opts-        when topmost terminalTopmost-        height <- return $ case (width, height) of+        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)-            _ -> do-                term <- fmap (fmap $ Term.width &&& Term.height) Term.size-                whenLoud $ do-                    outStrLn $ "%CONSOLE: width = " ++ maybe "?" (show . fst) term ++ ", height = " ++ maybe "?" (show . snd) term-                let f user def sel = fromMaybe (maybe def sel term) user-                -- if we write to the end of the window then it wraps automatically+            (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 (f width 80 (pred . fst), f height 8 snd)+                return (fromMaybe (pred $ fst term) w, fromMaybe (snd term) h)+         withWaiterNotify $ \waiter ->             handle (\(UnexpectedExit cmd _) -> putStrLn $ "Command \"" ++ cmd ++ "\" exited unexpectedly") $-                runGhcid session waiter (nubOrd restart) (nubOrd reload) command outputfile test warnings nostatus height (not notitle) $ \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+                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 -> [FilePath] -> [FilePath] -> String -> [FilePath] -> Maybe String -> Bool -> Bool -> IO (Int,Int) -> Bool -> ([(Style,String)] -> IO ()) -> IO ()-runGhcid session waiter restart reload command outputfiles test warnings nostatus size titles output = do+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) <- size+            (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]-            output $ load ++ map (Plain,) msg ++ replicate (height - (length load + length msg)) (Plain,"")+            termOutput $ load ++ map (Plain,) msg ++ replicate (height - (length load + length msg)) (Plain,"")      restartTimes <- mapM getModTime restart     curdir <- getCurrentDirectory@@ -173,20 +188,22 @@              let (countErrors, countWarnings) = both sum $ unzip                     [if loadSeverity == Error then (1,0) else (0,1) | m@Message{..} <- messages, loadMessage /= []]-            test <- return $ if countErrors == 0 && (warnings || countWarnings == 0) then test else Nothing+            test <- return $+                if null test || countErrors /= 0 || (countWarnings /= 0 && not warnings) then Nothing+                else Just $ intercalate "\n" test -            when titles $ setWindowIcon $+            unless notitle $ setWindowIcon $                 if countErrors > 0 then IconError else if countWarnings > 0 then IconWarning else IconOK -            let updateTitle extra = when titles $ setTitle $+            let updateTitle extra = unless notitle $ 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 /= ""] ++ "- " ++ takeFileName curdir -            updateTitle $ if isJust test then "(running test) " else ""+            updateTitle $ if isJust test then "(running test)" else ""             outputFill (Just (loadedCount, messages)) ["Running test..." | isJust test]-            forM_ outputfiles $ \file ->+            forM_ outputfile $ \file ->                 writeFile file $ unlines $ map snd $ prettyOutput loadedCount $ filter isMessage messages             when (null loaded) $ do                 putStrLn $ "No files loaded, nothing to wait for. Fix the last error and restart."@@ -195,6 +212,7 @@                 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@@ -208,7 +226,7 @@                 nextWait <- waitFiles waiter                 fire nextWait =<< sessionReload session             else do-                runGhcid session waiter restart reload command outputfiles test warnings nostatus size titles output+                runGhcid session waiter termSize termOutput opts      nextWait <- waitFiles waiter     (messages, loaded) <- sessionStart session command
src/Language/Haskell/Ghcid.hs view
@@ -71,7 +71,8 @@     let syncReplay = do             i <- readVar syncCount             let msg = "#~GHCID-FINISH-" ++ show i ++ "~#"-            writeInp $ "Prelude.putStrLn " ++ show msg ++ "\nPrelude.error " ++ show msg+            writeInp $ "INTERNAL_GHCID.putStrLn " ++ show msg ++ "\n" +++                       "INTERNAL_GHCID.hPutStrLn INTERNAL_GHCID.stderr " ++ show msg             return $ isInfixOf msg     let syncFresh = do             modifyVar_ syncCount $ return . succ@@ -150,9 +151,10 @@                 -- the thing before me may have done its own Haskell compiling                 writeIORef stdout []                 writeIORef stderr []-                writeIORef sync =<< syncFresh+                writeInp "import qualified System.IO as INTERNAL_GHCID"                 writeInp $ ":set prompt " ++ ghcid_prefix                 writeInp ":set -fno-break-on-exception -fno-break-on-error" -- see #43+                writeIORef sync =<< syncFresh             echo0 strm s             return Nothing     r <- parseLoad . reverse <$> ((++) <$> readIORef stderr <*> readIORef stdout)@@ -206,9 +208,8 @@ quit ghci =  do     interrupt ghci     handle (\UnexpectedExit{} -> return ()) $ void $ exec ghci ":quit"-    -- Add ignore because sometimes I get a message about an invalid handle,-    -- and I've got no idea why - but exceptions here probably mean the thing already died.-    -- Windows only, and Appveyor only.+    -- Be aware that waitForProcess has a race condition, see https://github.com/haskell/process/issues/46.+    -- Therefore just ignore the exception anyway, its probably already terminated.     ignore $         void $ waitForProcess $ process ghci @@ -217,9 +218,8 @@ --   within 5 seconds it just terminates the process. stopGhci :: Ghci -> IO () stopGhci ghci = do-    forkIO $ quit ghci     forkIO $ do         -- if nicely doesn't work, kill ghci as the process level         sleep 5         terminateProcess $ process ghci-    void $ waitForProcess $ process ghci+    quit ghci
src/Language/Haskell/Ghcid/Parser.hs view
@@ -35,12 +35,14 @@         f (x:xs)             | not $ " " `isPrefixOf` x             , Just (file,rest) <- breakFileColon x-            , takeExtension file `elem` [".hs",".lhs"]-            , (pos,rest2) <- span (\c -> c == ':' || isDigit c) rest-            , [p1,p2] <- map read $ words $ map (\c -> if c == ':' then ' ' else c) pos+            , takeExtension file `elem` [".hs",".lhs",".hs-boot",".lhs-boot"]+             -- take position, including span if present+            , (pos,rest) <- span (\c -> c == ':' || c == '-' || isSpan c || isDigit c) rest+            -- separate line and column, ignoring span (we want the start point only)+            , [p1,p2] <- map read $ wordsBy (\c -> c == ':' || isSpan c) $ takeWhile (\c->c /= '-') pos              , (msg,las) <- span (isPrefixOf " ") xs-            , rest3 <- trimStart rest2-            , sev <- if "warning:" `isPrefixOf` lower rest3 then Warning else Error+            , rest <- trimStart $ unwords $ rest : xs+            , sev <- if "warning:" `isPrefixOf` lower rest then Warning else Error             = Message sev file (p1,p2) (x:msg) : f las         f (x:xs)             | Just file <- stripPrefix "<no location info>: can't find file: " x@@ -54,7 +56,7 @@               [Message Error m (0,0) [] | m <- nubOrd ms] ++ f rest         f (_:xs) = f xs         f [] = []-+        isSpan c = c== ',' || c == '(' || c == ')'  -- A filename, followed by a colon - be careful to handle Windows drive letters, see #61 breakFileColon :: String -> Maybe (FilePath, String)
src/Language/Haskell/Ghcid/Util.hs view
@@ -5,17 +5,21 @@     chunksOfWord,     outWith, outStrLn, outStr,     allGoodMessage,-    getModTime+    getModTime, getModTimeResolution     ) where  import Control.Concurrent.Extra+import System.Time.Extra import System.IO.Unsafe+import System.IO.Extra+import System.FilePath import Data.List.Extra import Data.Char import Data.Time.Clock import System.IO.Error import System.Directory import Control.Exception+import Control.Monad.Extra import Control.Applicative import Prelude @@ -59,3 +63,28 @@     (\e -> if isDoesNotExistError e then Just () else Nothing)     (\_ -> return Nothing)     (Just <$> getModificationTime file)++++-- | Get the smallest difference that can be reported by two modification times+getModTimeResolution :: IO Seconds+getModTimeResolution = return getModTimeResolutionCache++{-# NOINLINE getModTimeResolutionCache #-}+-- Cache the result so only computed once per run+getModTimeResolutionCache :: Seconds+getModTimeResolutionCache = unsafePerformIO $ withTempDir $ \dir -> do+    let file = dir </> "calibrate.txt"++    -- with 10 measurements can get a bit slow, see Shake issue tracker #451+    -- if it rounds to a second then 1st will be a fraction, but 2nd will be full second+    mtime <- fmap maximum $ forM [1..3] $ \i -> fmap fst $ duration $ do+        writeFile file $ show i+        t1 <- getModificationTime file+        flip loopM 0 $ \j -> do+            writeFile file $ show (i,j)+            t2 <- getModificationTime file+            return $ if t1 == t2 then Left $ j+1 else Right ()+    putStrLn $ "Longest file modification time lag was " ++ show (ceiling (mtime * 1000)) ++ "ms"+    -- add a little bit of safety, but if it's really quick, don't make it that much slower+    return $ mtime + min 0.1 mtime
src/Session.hs view
@@ -31,8 +31,9 @@   -- | Ensure an action runs off the main thread, so can't get hit with Ctrl-C exceptions.+--   Disabled because it plays havoc with tests and cleaning up quickly enough. ctrlC :: IO a -> IO a-ctrlC = join . onceFork+ctrlC = id -- join . onceFork   -- | The function 'withSession' expects to be run on the main thread,@@ -44,7 +45,7 @@     command <- newIORef Nothing     warnings <- newIORef []     running <- newVar False-    ctrlC (f $ Session{..}) `finally` do+    ctrlC (f Session{..}) `finally` do         modifyVar_ running $ const $ return False         whenJustM (readIORef ghci) $ \v -> do             writeIORef ghci Nothing@@ -118,7 +119,8 @@     Just ghci <- readIORef ghci     stderr <- newIORef ""     modifyVar_ running $ const $ return True-    void $ forkIO $ do+    caller <- myThreadId+    void $ flip forkFinally (either (throwTo caller) (const $ return ())) $ do         execStream ghci cmd $ \strm msg ->             when (msg /= "*** Exception: ExitSuccess") $ do                 when (strm == Stderr) $ writeIORef stderr msg
src/Test.hs view
@@ -2,21 +2,24 @@ module Test(main) where  import Test.Tasty-import Test.Parser-import Test.HighLevel-import Test.Util-import Test.Polling import System.IO+import System.Console.CmdArgs +import Test.Util+import Test.Parser+import Test.API+import Test.Ghcid+ main :: IO () main = do     hSetBuffering stdout NoBuffering+    setVerbosity Loud     defaultMain tests  tests :: TestTree tests = testGroup "Tests"     [utilsTests     ,parserTests-    ,pollingTest-    ,highLevelTests+    ,apiTests+    ,ghcidTest     ]
+ src/Test/API.hs view
@@ -0,0 +1,36 @@+-- | Test the high level library API+module Test.API(apiTests) where++import Test.Tasty+import Test.Tasty.HUnit+import System.FilePath+import System.IO.Extra+import System.Time.Extra+import Language.Haskell.Ghcid+import Language.Haskell.Ghcid.Util+++apiTests :: TestTree+apiTests = testGroup "API test"+    [testCase "No files" $ withTempDir $ \dir -> do+        (ghci,load) <- startGhci "ghci" (Just dir) $ const putStrLn+        load @?= []+        showModules ghci >>= (@?= [])+        exec ghci "import Data.List"+        exec ghci "nub \"test\"" >>= (@?= ["\"tes\""])+        stopGhci ghci++    ,testCase "Load file" $ withTempDir $ \dir -> do+        writeFile (dir </> "File.hs") "module A where\na = 123"+        (ghci, load) <- startGhci "ghci File.hs" (Just dir) $ const putStrLn+        load @?= [Loading "A" "File.hs"]+        exec ghci "a + 1" >>= (@?= ["124"])+        reload ghci >>= (@?= [])++        sleep =<< getModTimeResolution+        writeFile (dir </> "File.hs") "module A where\na = 456"+        exec ghci "a + 1" >>= (@?= ["124"])+        reload ghci >>= (@?= [Loading "A" "File.hs"])+        exec ghci "a + 1" >>= (@?= ["457"])+        stopGhci ghci+    ]
+ src/Test/Ghcid.hs view
@@ -0,0 +1,208 @@++-- | Test behavior of the executable, polling files for changes+module Test.Ghcid(ghcidTest) where++import Control.Concurrent.Extra+import Control.Exception.Extra+import Control.Monad.Extra+import Data.Char+import Data.List.Extra+import System.Directory.Extra+import System.IO.Extra+import System.Time.Extra+import Data.Version.Extra+import System.Environment+import System.Process.Extra+import System.FilePath+import System.Exit++import Test.Tasty+import Test.Tasty.HUnit++import Ghcid+import Language.Haskell.Ghcid.Util+import Data.Functor+import Prelude+++ghcidTest :: TestTree+ghcidTest = testGroup "Ghcid test"+    [basicTest+    ,dotGhciTest+    ,cabalTest+    ,stackTest+    ]+++freshDir :: IO a -> IO a+freshDir act = withTempDir $ \tdir -> withCurrentDirectory tdir act++copyDir :: FilePath -> IO a -> IO ()+copyDir dir act = do+    b <- doesDirectoryExist dir+    if not b then putStrLn $ "Couldn't run test because test source is missing, " ++ dir else void $ do+        withTempDir $ \tdir -> do+            xs <- withCurrentDirectory dir $ listFilesRecursive "."+            forM_ xs $ \x -> do+                createDirectoryIfMissing True $ takeDirectory $ tdir </> x+                copyFile (dir </> x) (tdir </> x)+            withCurrentDirectory tdir act+++whenStack :: IO a -> IO ()+whenStack act = do+    v <- findExecutable "stack"+    case v of+        Nothing -> putStrLn "Couldn't run test because stack is missing"+        Just _ -> void act+++withGhcid :: [String] -> (([String] -> IO ()) -> IO a) -> IO a+withGhcid args script = do+    chan <- newChan+    let require want = do+            t <- timeout 30 $ readChan chan+            case t of+                Nothing -> fail $ "Require failed to produce results in time, expected: " ++ show want+                Just got -> assertApproxInfix want got+            sleep =<< getModTimeResolution++    let output = writeChan chan . filter (/= "") . map snd+    done <- newBarrier+    res <- bracket+        (flip forkFinally (const $ signalBarrier done ()) $+            withArgs (["--notitle","--no-status"]++args) $+                mainWithTerminal (return (100, 50)) output)+        killThread $ \_ -> script require+    waitBarrier done+    return res+++-- | Since different versions of GHCi give different messages, we only try to find what+--   we require anywhere in the obtained messages, ignoring weird characters.+assertApproxInfix :: [String] -> [String] -> IO ()+assertApproxInfix want got = do+    -- Spacing and quotes tend to be different on different GHCi versions+    let simple = lower . filter (\x -> isLetter x || isDigit x || x == ':')+        got2 = simple $ unwords got+    all (`isInfixOf` got2) (map simple want) @?+        "Expected " ++ show want ++ ", got " ++ show got+++write :: FilePath -> String -> IO ()+write file x = do+    print ("writeFile",file,x)+    writeFile file x++append :: FilePath -> String -> IO ()+append file x = do+    print ("appendFile",file,x)+    appendFile file x++rename :: FilePath -> FilePath -> IO ()+rename from to = do+    print ("renameFile",from,to)+    renameFile from to++++---------------------------------------------------------------------+-- ACTUAL TEST SUITE++basicTest :: TestTree+basicTest = testCase "Ghcid basic" $ freshDir $ do+    write "Main.hs" "main = print 1"+    withGhcid ["-cghci -fwarn-unused-binds Main.hs"] $ \require -> do+        require [allGoodMessage]+        write "Main.hs" "x"+        require ["Main.hs:1:1"," Parse error:"]+        write "Util.hs" "module Util where"+        write "Main.hs" "import Util\nmain = print 1"+        require [allGoodMessage]+        write "Util.hs" "module Util where\nx"+        require ["Util.hs:2:1","Parse error:"]+        write "Util.hs" "module Util() where\nx = 1"+        require ["Util.hs:2:1","Warning:","Defined but not used: `x'"]++        -- check warnings persist properly+        write "Main.hs" "import Util\nx"+        require ["Main.hs:2:1","Parse error:"+                ,"Util.hs:2:1","Warning:","Defined but not used: `x'"]+        write "Main.hs" "import Util\nmain = print 2"+        require ["Util.hs:2:1","Warning:","Defined but not used: `x'"]+        write "Main.hs" "main = print 3"+        require [allGoodMessage]+        write "Main.hs" "import Util\nmain = print 4"+        require ["Util.hs:2:1","Warning:","Defined but not used: `x'"]+        write "Util.hs" "module Util where"+        require [allGoodMessage]++        -- check recursive modules work+        write "Util.hs" "module Util where\nimport Main"+        require ["imports form a cycle","Main.hs","Util.hs"]+        write "Util.hs" "module Util where"+        require [allGoodMessage]++        ghcVer <- readVersion <$> systemOutput_ "ghc --numeric-version"++        -- check renaming files works+        when (ghcVer < makeVersion [8]) $ do+            -- note that due to GHC bug #9648 and #11596 this doesn't work with newer GHC+            -- see https://ghc.haskell.org/trac/ghc/ticket/11596+            rename "Util.hs" "Util2.hs"+            require ["Main.hs:1:8:","Could not find module `Util'"]+            rename "Util2.hs" "Util.hs"+            require [allGoodMessage]++        -- after this point GHC bugs mean nothing really works too much+++dotGhciTest :: TestTree+dotGhciTest = testCase "Ghcid .ghci" $ copyDir "test/foo" $ do+    write "test.txt" ""+    ignore $ void $ system "chmod go-w .ghci"+    withGhcid ["--test=:test"] $ \require -> do+        require [allGoodMessage]+        sleep 1 -- time to write out the test+        readFile "test.txt" >>= (@?= "X") -- the test writes out X+        append "Test.hs" "\n"+        require [allGoodMessage]+        sleep 1 -- time to write out the test+        readFile "test.txt" >>= (@?= "XX")+        print =<< readFile ".ghci"+        write ".ghci" ":set -fwarn-unused-imports\n:load Root Paths.hs Test"+        require ["The import of Paths_foo is redundant"]+        sleep 1 -- time to write out the test+        readFile "test.txt" >>= (@?= "XX") -- but shouldn't run on warning+++cabalTest :: TestTree+cabalTest = testCase "Ghcid Cabal" $ copyDir "test/bar" $ do+    env <- getEnvironment+    let db = ["--package-db=" ++ x | x <- maybe [] splitSearchPath $ lookup "GHC_PACKAGE_PATH" env]+    (_, _, _, pid) <- createProcess $+         (proc "cabal" $ "configure":db){env = Just $ filter ((/=) "GHC_PACKAGE_PATH" . fst) env}+    ExitSuccess <- waitForProcess pid++    withGhcid [] $ \require -> do+        require [allGoodMessage]+        orig <- readFile' "src/Literate.lhs"+        append "src/Literate.lhs" "> x"+        require ["src/Literate.lhs:5:3","Parse error:"]+        write "src/Literate.lhs" orig+        require [allGoodMessage]++stackTest :: TestTree+stackTest = testCase "Ghcid Stack" $ copyDir "test/bar" $ whenStack $ do+    system_ "stack init"+    createDirectoryIfMissing True ".stack-work"++    withGhcid [] $ \require -> do+        require [allGoodMessage]+        append "src/Literate.lhs" "> x"+        require ["src/Literate.lhs:5:3","Parse error:"]++    withGhcid ["src/Boot.hs"] $ \require -> do+        require [allGoodMessage]+        writeFile "src/Boot.hs" "X"+        require ["src/Boot.hs:1:1","Parse error:"]
− src/Test/HighLevel.hs 
@@ -1,106 +0,0 @@--- | Test the high level library API-module Test.HighLevel(highLevelTests) where--import System.Directory-import System.IO.Extra-import System.Exit-import System.FilePath-import System.Environment-import Control.Monad-import System.Process--import Test.Tasty-import Test.Tasty.HUnit--import Language.Haskell.Ghcid---highLevelTests :: TestTree-highLevelTests = testGroup "High Level tests"-    [testStartRepl-    ,testShowModules-    ]--testStartRepl :: TestTree-testStartRepl = testCase "Start cabal repl" $-    withTestProject $ \root -> do-        (ghci,load) <- startGhci "cabal repl" (Just root) $ const putStrLn-        stopGhci ghci-        load @?=  [ Loading "B.C" (normalise "src/B/C.hs")-                  , Loading "A" (normalise "src/A.hs")-                  ]--testShowModules :: TestTree-testShowModules = testCase "Show Modules" $-    withTestProject $ \root -> do-        (ghci,_) <- startGhci "cabal repl" (Just root) $ const putStrLn-        mods <- showModules ghci-        stopGhci ghci-        mods @?= [("A",normalise "src/A.hs"),("B.C",normalise "src/B/C.hs")]---testFiles :: [(FilePath, [String])]-testFiles =-    [(projectName <.> "cabal",-        ["name: " ++ projectName-        ,"version:0.1"-        ,"cabal-version:  >= 1.8"-        ,"build-type:     Simple"-        ,""-        ,"library"-        ,"  hs-source-dirs:  src"-        ,"  exposed-modules: A"-        ,"  other-modules:  B.C"-        ,"  build-depends:  base"-        ,""-        ,"executable BWTest"-        ,"  hs-source-dirs:  src"-        ,"  main-is:         Main.hs"-        ,"  other-modules:  B.D"-        ,"  build-depends:  base"-        ,"  ghc-options: -dynamic"-        ,""-        ,"test-suite BWTest-test"-        ,"  type:            exitcode-stdio-1.0"-        ,"  hs-source-dirs:  test"-        ,"  main-is:         Main.hs"-        ,"  other-modules:  TestA"-        ,"  build-depends:  base"])-    ,("Setup.hs",-        ["#!/usr/bin/env runhaskell"-        ,"import Distribution.Simple"-        ,"main :: IO ()"-        ,"main = defaultMain"])-    ,("src/A.hs",-        ["module A where"-        ,"fA = undefined"])-    ,("src/B/C.hs",-        ["module B.C where"-        ,"fC = undefined"])-    ,("src/B/D.hs",-        ["module B.D where"-        ,"fD = undefined"])-    ,("src/Main.hs",-        ["module Main where"-        ,"main = undefined"])-    ,("test/Main.hs",-        ["module Main where"-        ,"main = undefined"])-    ,("test/TestA.hs",-        ["module TestA where"-        ,"fTA = undefined"])-    ]--projectName = "BWTest"--withTestProject :: (FilePath -> IO a) -> IO a-withTestProject act = withTempDir $ \dir -> do-    forM_ testFiles $ \(name,contents) -> do-        createDirectoryIfMissing True $ takeDirectory $ dir </> name-        writeFile (dir </> name) $ unlines contents-    env <- getEnvironment-    let db = ["--package-db=" ++ x | x <- maybe [] splitSearchPath $ lookup "GHC_PACKAGE_PATH" env]-    (_, _, _, pid) <- createProcess $-        (proc "cabal" $ "configure":db){env = Just $ filter ((/=) "GHC_PACKAGE_PATH" . fst) env, cwd = Just dir}-    ExitSuccess <- waitForProcess pid-    act dir
src/Test/Parser.hs view
@@ -1,7 +1,5 @@ -- | Test the message parser-module Test.Parser-  ( parserTests-  )where+module Test.Parser(parserTests) where  import Test.Tasty import Test.Tasty.HUnit@@ -11,40 +9,79 @@   parserTests :: TestTree-parserTests=testGroup "Parser tests"-  [ testShowModules-  , testParseLoad-  ]--testShowModules :: TestTree-testShowModules =  testCase "Show Modules" $ parseShowModules [-    "Main             ( src/Main.hs, interpreted )",-    "AI.Neural.WiscDigit ( src/AI/Neural/WiscDigit.hs, interpreted )"-    ] @?= [("Main","src/Main.hs"),("AI.Neural.WiscDigit","src/AI/Neural/WiscDigit.hs")]+parserTests = testGroup "Parser tests"+    [testParseShowModules+    ,testParseLoad+    ,testParseLoadSpans+    ] +testParseShowModules :: TestTree+testParseShowModules = testCase "Show Modules" $ parseShowModules+    ["Main             ( src/Main.hs, interpreted )"+    ,"AI.Neural.WiscDigit ( src/AI/Neural/WiscDigit.hs, interpreted )"+    ] @?=+    [("Main","src/Main.hs")+    ,("AI.Neural.WiscDigit","src/AI/Neural/WiscDigit.hs")+    ]  testParseLoad :: TestTree-testParseLoad = testGroup "Load Parsing"-  [ testCase "output1" $ parseLoad output1 @?=-    [ Loading "GHCi" "GHCi.hs"-    , Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (70,1), loadMessage = ["GHCi.hs:70:1: Parse error: naked expression at top level"]}-    , Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (72,13), loadMessage = ["GHCi.hs:72:13:","    No instance for (Num ([String] -> [String]))","      arising from the literal `1'","    Possible fix:","      add an instance declaration for (Num ([String] -> [String]))","    In the expression: 1","    In an equation for `parseLoad': parseLoad = 1"]}-    , Message {loadSeverity = Warning, loadFile = "GHCi.hs", loadFilePos = (81,1), loadMessage = ["GHCi.hs:81:1: Warning: Defined but not used: `foo'"]}-    , Message {loadSeverity = Warning, loadFile = "C:\\GHCi.hs", loadFilePos = (82,1), loadMessage = ["C:\\GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217"]}+testParseLoad = testCase "Load Parsing" $ parseLoad+    ["[1 of 2] Compiling GHCi             ( GHCi.hs, interpreted )"+    ,"GHCi.hs:70:1: Parse error: naked expression at top level"+    ,"GHCi.hs:72:13:"+    ,"    No instance for (Num ([String] -> [String]))"+    ,"      arising from the literal `1'"+    ,"    Possible fix:"+    ,"      add an instance declaration for (Num ([String] -> [String]))"+    ,"    In the expression: 1"+    ,"    In an equation for `parseLoad': parseLoad = 1"+    ,"GHCi.hs:81:1: Warning: Defined but not used: `foo'"+    ,"C:\\GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217" -- GHC 7.12 uses lowercase+    ,"src\\Haskell.hs:4:23:"+    ,"    Warning: {-# SOURCE #-} unnecessary in import of  `Boot'"+    ,"src\\Boot.hs-boot:2:8:"+    ,"    File name does not match module name:"+    ,"    Saw: `BootX'"+    ,"    Expected: `Boot'"+    ] @?=+    [Loading "GHCi" "GHCi.hs"+    ,Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (70,1), loadMessage = ["GHCi.hs:70:1: Parse error: naked expression at top level"]}+    ,Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (72,13), loadMessage = ["GHCi.hs:72:13:","    No instance for (Num ([String] -> [String]))","      arising from the literal `1'","    Possible fix:","      add an instance declaration for (Num ([String] -> [String]))","    In the expression: 1","    In an equation for `parseLoad': parseLoad = 1"]}+    ,Message {loadSeverity = Warning, loadFile = "GHCi.hs", loadFilePos = (81,1), loadMessage = ["GHCi.hs:81:1: Warning: Defined but not used: `foo'"]}+    ,Message {loadSeverity = Warning, loadFile = "C:\\GHCi.hs", loadFilePos = (82,1), loadMessage = ["C:\\GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217"]}+    ,Message {loadSeverity = Warning, loadFile = "src\\Haskell.hs", loadFilePos = (4,23), loadMessage = ["src\\Haskell.hs:4:23:","    Warning: {-# SOURCE #-} unnecessary in import of  `Boot'"]}+    ,Message {loadSeverity = Error, loadFile = "src\\Boot.hs-boot", loadFilePos = (2,8), loadMessage = ["src\\Boot.hs-boot:2:8:","    File name does not match module name:","    Saw: `BootX'","    Expected: `Boot'"]}     ]-  ] -output1 :: [String]-output1=-  [ "[1 of 2] Compiling GHCi             ( GHCi.hs, interpreted )"-  , "GHCi.hs:70:1: Parse error: naked expression at top level"-  , "GHCi.hs:72:13:"-  , "    No instance for (Num ([String] -> [String]))"-  , "      arising from the literal `1'"-  , "    Possible fix:"-  , "      add an instance declaration for (Num ([String] -> [String]))"-  , "    In the expression: 1"-  , "    In an equation for `parseLoad': parseLoad = 1"-  , "GHCi.hs:81:1: Warning: Defined but not used: `foo'"-  , "C:\\GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217" -- GHC 7.12 uses lowercase-  ]+-- | Test when error messages include spans (-ferror-spans)+testParseLoadSpans :: TestTree+testParseLoadSpans = testCase "Load Parsing when -ferror-spans is enabled" $ parseLoad+    ["[1 of 2] Compiling GHCi             ( GHCi.hs, interpreted )"+    ,"GHCi.hs:70:1-2: Parse error: naked expression at top level"+    ,"GHCi.hs:72:13-14:"+    ,"    No instance for (Num ([String] -> [String]))"+    ,"      arising from the literal `1'"+    ,"    Possible fix:"+    ,"      add an instance declaration for (Num ([String] -> [String]))"+    ,"    In the expression: 1"+    ,"    In an equation for `parseLoad': parseLoad = 1"+    ,"GHCi.hs:81:1-15: Warning: Defined but not used: `foo'"+    ,"C:\\GHCi.hs:82:1-17: warning: Defined but not used: \8216foo\8217" -- GHC 7.12 uses lowercase+    ,"src\\Haskell.hs:4:23-24:"+    ,"    Warning: {-# SOURCE #-} unnecessary in import of  `Boot'"+    ,"src\\Boot.hs-boot:2:8-5:"+    ,"    File name does not match module name:"+    ,"    Saw: `BootX'"+    ,"    Expected: `Boot'"+    ,"/src/TrieSpec.hs:(192,7)-(193,76): Warning:"+    ,"    A do-notation statement discarded a result of type ‘[()]’"+    ] @?=+    [Loading "GHCi" "GHCi.hs"+    ,Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (70,1), loadMessage = ["GHCi.hs:70:1-2: Parse error: naked expression at top level"]}+    ,Message {loadSeverity = Error, loadFile = "GHCi.hs", loadFilePos = (72,13), loadMessage = ["GHCi.hs:72:13-14:","    No instance for (Num ([String] -> [String]))","      arising from the literal `1'","    Possible fix:","      add an instance declaration for (Num ([String] -> [String]))","    In the expression: 1","    In an equation for `parseLoad': parseLoad = 1"]}+    ,Message {loadSeverity = Warning, loadFile = "GHCi.hs", loadFilePos = (81,1), loadMessage = ["GHCi.hs:81:1-15: Warning: Defined but not used: `foo'"]}+    ,Message {loadSeverity = Warning, loadFile = "C:\\GHCi.hs", loadFilePos = (82,1), loadMessage = ["C:\\GHCi.hs:82:1-17: warning: Defined but not used: \8216foo\8217"]}+    ,Message {loadSeverity = Warning, loadFile = "src\\Haskell.hs", loadFilePos = (4,23), loadMessage = ["src\\Haskell.hs:4:23-24:","    Warning: {-# SOURCE #-} unnecessary in import of  `Boot'"]}+    ,Message {loadSeverity = Error, loadFile = "src\\Boot.hs-boot", loadFilePos = (2,8), loadMessage = ["src\\Boot.hs-boot:2:8-5:","    File name does not match module name:","    Saw: `BootX'","    Expected: `Boot'"]}+    ,Message {loadSeverity = Warning, loadFile = "/src/TrieSpec.hs", loadFilePos = (192,7), loadMessage = ["/src/TrieSpec.hs:(192,7)-(193,76): Warning:","    A do-notation statement discarded a result of type ‘[()]’"]}+    ]
− src/Test/Polling.hs 
@@ -1,137 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}---- | Test behavior of the executable, polling files for changes-module Test.Polling(pollingTest) where--import Control.Concurrent-import Control.Exception.Extra-import Control.Monad-import Data.Char-import Data.List.Extra-import System.FilePath-import System.Directory.Extra-import System.Process-import System.Console.CmdArgs-import System.Time.Extra--import Test.Tasty-import Test.Tasty.HUnit--import Ghcid-import Session-import Wait-import Language.Haskell.Ghcid.Util--pollingTest :: TestTree-pollingTest  = testCase "Scripted Test" $ do-    setVerbosity Loud-    tdir <- fmap (</> ".ghcid") getTemporaryDirectory-    try_ $ removeDirectoryRecursive tdir-    createDirectoryIfMissing True tdir-    withCurrentDirectory tdir $ do-        ref <- newEmptyMVar-        let require predi = do-                res <- takeMVarDelay ref 5-                predi res-                outStr "."-                sleep 1-        -- t <- myThreadId-        writeFile "Main.hs" "main = print 1"-        writeFile ".ghci" ":set -fwarn-unused-binds \n:load Main"-        -- otherwise GHC warns about .ghci being accessible by others-        try_ $ system "chmod og-w . .ghci"--        withSession $ \session -> withWaiterPoll $ \waiter -> bracket (-          forkIO $ runGhcid session waiter [] [] "ghci" [] Nothing False False (return (100, 50)) False $ \msg ->-            unless (isLoading $ map snd msg) $ putMVarNow ref $ map snd msg-          ) killThread $ \_ -> do-            require requireAllGood-            testScript require-            outStrLn "\nSuccess"--isLoading :: [String] -> Bool-isLoading ("Reloading...":_) = True-isLoading (x:_) | "Loading" `isPrefixOf` x && "..." `isSuffixOf` x = True-isLoading _ = False--putMVarNow :: MVar a -> a -> IO ()-putMVarNow ref x = do-    b <- tryPutMVar ref x-    unless b $ error "Had a message and a new one arrived"--takeMVarDelay :: MVar a -> Double -> IO a-takeMVarDelay _ i | i <= 0 = error "timed out"-takeMVarDelay x i = do-    b <- tryTakeMVar x-    case b of-        Nothing -> sleep 0.1 >> takeMVarDelay x (i-0.1)-        Just v -> return v----(===) :: (Eq a, Show a) => a -> a -> IO ()---(===) a b = unless (a == b) $ error $ "Mismatch\nLHS: " ++ show a ++ "\nRHS: " ++ show b---- | The all good message-requireAllGood :: [String] -> IO ()-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------requirePrefix :: [String] -> [String] -> IO ()---requirePrefix want got = take (length want) got @?= want---- | Since different versions of GHCi give different messages, we only try to find what we require anywhere in the obtained messages-requireSimilar :: [String] -> [String] -> IO ()-requireSimilar want got = let-  allGot = ignoreSpacesAndWeird $ concat got-  in all (`isInfixOf` allGot) (map ignoreSpacesAndWeird want) @? (show (filter (not . null) got) ++ " does not contain " ++ show want)---- | Spacing and quotes tend to be different on different GHCi versions-ignoreSpacesAndWeird :: String -> String-ignoreSpacesAndWeird = lower . filter (\x -> isLetter x || isDigit x || x == ':')-------------------------------------------------------------------------- ACTUAL TEST SUITE--testScript :: (([String] -> IO ()) -> IO ()) -> IO ()-testScript require = do-    writeFile <- return $ \name x -> do print ("writeFile",name,x); writeFile name x-    renameFile <- return $ \from to -> do print ("renameFile",from,to); renameFile from to--    writeFile "Main.hs" "x"-    require $ requireSimilar ["Main.hs:1:1"," Parse error: naked expression at top level"]-    writeFile "Util.hs" "module Util where"-    writeFile "Main.hs" "import Util\nmain = print 1"-    require requireAllGood-    writeFile "Util.hs" "module Util where\nx"-    require $ requireSimilar ["Util.hs:2:1","Parse error: naked expression at top level"]-    writeFile "Util.hs" "module Util() where\nx = 1"-    require $ requireSimilar ["Util.hs:2:1","Warning: Defined but not used: `x'"]--    -- check warnings persist properly-    writeFile "Main.hs" "import Util\nx"-    require $ requireSimilar ["Main.hs:2:1","Parse error: naked expression at top level"-                             ,"Util.hs:2:1","Warning: Defined but not used: `x'"]-    writeFile "Main.hs" "import Util\nmain = print 2"-    require $ requireSimilar ["Util.hs:2:1","Warning: Defined but not used: `x'"]-    writeFile "Main.hs" "main = print 3"-    require requireAllGood-    writeFile "Main.hs" "import Util\nmain = print 4"-    require $ requireSimilar ["Util.hs:2:1","Warning: Defined but not used: `x'"]-    writeFile "Util.hs" "module Util where"-    require requireAllGood--    -- check recursive modules work-    writeFile "Util.hs" "module Util where\nimport Main"-    require $ requireSimilar ["imports form a cycle","Main.hs","Util.hs"]-    writeFile "Util.hs" "module Util where"-    require requireAllGood--    -- check renaming files works-    -- note that due to GHC bug #9648 we can't save down a new file-    renameFile "Util.hs" "Util2.hs"-    require $ requireSimilar ["Main.hs:1:8:","Could not find module `Util'"]-    renameFile "Util2.hs" "Util.hs"-    require requireAllGood-    -- after this point GHC bugs mean nothing really works too much-
src/Test/Util.hs view
@@ -1,7 +1,5 @@ -- | Test utility functions-module Test.Util-  ( utilsTests-  ) where+module Test.Util(utilsTests) where  import Test.Tasty import Test.Tasty.HUnit@@ -9,21 +7,21 @@ import Language.Haskell.Ghcid.Util  utilsTests :: TestTree-utilsTests=testGroup "Utility tests"-  [ dropPrefixTests-  , chunksOfWordTests-  ]+utilsTests = testGroup "Utility tests"+    [dropPrefixTests+    ,chunksOfWordTests+    ]  dropPrefixTests :: TestTree dropPrefixTests = testGroup "dropPrefix"-  [ testCase "Prefix not found" $ dropPrefixRepeatedly "prefix" "string"  @?= "string"-  , testCase "Empty prefix" $ dropPrefixRepeatedly "" "string" @?= "string"-  , testCase "Prefix found once" $ dropPrefixRepeatedly "str" "string" @?= "ing"-  , testCase "Prefix found twice" $ dropPrefixRepeatedly "str" "strstring" @?= "ing"-  ]+    [testCase "Prefix not found" $ dropPrefixRepeatedly "prefix" "string"  @?= "string"+    ,testCase "Empty prefix" $ dropPrefixRepeatedly "" "string" @?= "string"+    ,testCase "Prefix found once" $ dropPrefixRepeatedly "str" "string" @?= "ing"+    ,testCase "Prefix found twice" $ dropPrefixRepeatedly "str" "strstring" @?= "ing"+    ]  chunksOfWordTests :: TestTree chunksOfWordTests = testGroup "chunksOfWord"-  [ testCase "Max 0" $ chunksOfWord 4 0 "ab cd efgh" @?= ["ab c","d ef","gh"]-  , testCase "Max 2" $ chunksOfWord 4 2 "ab cd efgh" @?= ["ab ","cd ","efgh"]-  ]+    [testCase "Max 0" $ chunksOfWord 4 0 "ab cd efgh" @?= ["ab c","d ef","gh"]+    ,testCase "Max 2" $ chunksOfWord 4 2 "ab cd efgh" @?= ["ab ","cd ","efgh"]+    ]