diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,14 @@ Changelog for GHCiD +0.4 + #33, make Ctrl-C more robust + #31, add an outputfile feature + #32, make newer warnings first (save a file, view its warnings) + #28, fix issues on VIM file saves + #29, support running a quick test on each save + Add a --directory flag to change directory first + #26, use fs-notify to avoid excessive wakeups + #25, detect console size just before using it 0.3.6 #24, don't error out if error/putStrLn are not imported 0.3.5 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.3.6 +version: 0.4 license: BSD3 license-file: LICENSE category: Development @@ -13,7 +13,7 @@ Either \"GHCi as a daemon\" or \"GHC + a bit of an IDE\". A very simple Haskell development tool which shows you the errors in your project and updates them whenever you save. Run @ghcid --topmost --command=ghci@, where @--topmost@ makes the window on top of all others (Windows only) and @--command@ is the command to start GHCi on your project (defaults to @ghci@ if you have a @.ghci@ file, or else to @cabal repl@). homepage: https://github.com/ndmitchell/ghcid#readme bug-reports: https://github.com/ndmitchell/ghcid/issues -tested-with: GHC==7.10.1, GHC==7.8.3, GHC==7.6.3 +tested-with: GHC==7.10.1, GHC==7.8.4, GHC==7.6.3 extra-source-files: CHANGES.txt README.md @@ -32,9 +32,8 @@ directory, extra >= 1.1, process >= 1.1, - cmdargs >= 0.10 - if !os(windows) - build-depends: terminal-size >= 0.2.1 + cmdargs >= 0.10, + terminal-size >= 0.3 other-modules: Paths_ghcid, Language.Haskell.Ghcid.Types, @@ -46,13 +45,15 @@ executable ghcid hs-source-dirs: src default-language: Haskell2010 - ghc-options: -main-is Ghcid.main + ghc-options: -main-is Ghcid.main -threaded main-is: Ghcid.hs build-depends: base == 4.*, filepath, time, directory, + containers, + fsnotify, extra >= 1.1, process >= 1.1, cmdargs >= 0.10, @@ -63,11 +64,12 @@ Language.Haskell.Ghcid.Parser, Language.Haskell.Ghcid.Terminal, Language.Haskell.Ghcid.Util, - Language.Haskell.Ghcid + Language.Haskell.Ghcid, + Wait test-suite ghcid_test type: exitcode-stdio-1.0 - ghc-options: -rtsopts -main-is Test.main + ghc-options: -rtsopts -main-is Test.main -threaded default-language: Haskell2010 build-depends: base >= 4, @@ -75,17 +77,18 @@ time, directory, process, + containers, + fsnotify, extra >= 1.1, ansi-terminal, + terminal-size >= 0.3, cmdargs, tasty, tasty-hunit - if !os(windows) - build-depends: terminal-size >= 0.2.1 - hs-source-dirs: test, src + hs-source-dirs: src main-is: Test.hs other-modules: - Language.Haskell.Ghcid.ParserTest, - Language.Haskell.Ghcid.HighLevelTests, - Language.Haskell.Ghcid.UtilTest, - Language.Haskell.Ghcid.PollingTest + Test.Parser, + Test.HighLevel, + Test.Util, + Test.Polling diff --git a/src/Ghcid.hs b/src/Ghcid.hs --- a/src/Ghcid.hs +++ b/src/Ghcid.hs @@ -1,49 +1,57 @@ -{-# LANGUAGE RecordWildCards, DeriveDataTypeable, CPP, ScopedTypeVariables, TupleSections #-} -{-# OPTIONS_GHC -O2 #-} -- only here to test ticket #11 +{-# LANGUAGE RecordWildCards, DeriveDataTypeable, CPP, TupleSections #-} +{-# OPTIONS_GHC -O2 -fno-cse #-} -- only here to test ticket #11 -- | The application entry point module Ghcid(main, runGhcid) where -import Control.Exception +import Control.Applicative import Control.Monad.Extra +import Control.Concurrent.Extra +import Control.Exception import Data.List.Extra import Data.Maybe -import Data.Time.Clock import Data.Tuple.Extra import Data.Version import qualified System.Console.Terminal.Size as Term import System.Console.CmdArgs import System.Console.ANSI -import System.Directory +import System.Directory.Extra import System.Exit import System.FilePath import System.IO -import System.IO.Error -import System.Time.Extra 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 Prelude -- | Command line options data Options = Options {command :: String + ,test :: Maybe String ,height :: Maybe Int ,width :: Maybe Int ,topmost :: Bool ,restart :: [FilePath] + ,directory :: FilePath + ,outputfile :: [FilePath] } deriving (Data,Typeable,Show) options :: Mode (CmdArgs Options) options = cmdArgsMode $ Options {command = "" &= typ "COMMAND" &= help "Command to run (defaults to ghci or cabal repl)" + ,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)" ,topmost = False &= name "t" &= help "Set window topmost (Windows only)" - ,restart = [] &= help "Restart the command if any of these files change (defaults to .ghci or .cabal)" + ,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" } &= verbosity &= program "ghcid" &= summary ("Auto reloading GHCi daemon v" ++ showVersion version) @@ -59,98 +67,120 @@ else return o{command="cabal repl", restart=cabal} +ctrlC :: IO () -> IO () +ctrlC act = do + bar <- newBarrier + forkFinally act $ signalBarrier bar + either throwIO return =<< waitBarrier bar + + main :: IO () -main = do - opts@Options{..} <- autoOptions =<< cmdArgsRun options - when topmost terminalTopmost - height <- return $ case (width, height) of - (Just w, Just h) -> return (w,h) - _ -> do - term <- fmap (fmap $ Term.width &&& Term.height) Term.size - let f user def sel = fromMaybe (maybe def sel term) user - -- if we write to the end 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) - runGhcid restart command height $ \xs -> do - outWith $ forM_ (groupOn fst xs) $ \x@((b,_):_) -> do - when b $ setSGR [SetConsoleIntensity BoldIntensity] - putStr $ concatMap ((:) '\n' . snd) x - when b $ setSGR [] - hFlush stdout -- must flush, since we don't finish with a newline +main = ctrlC $ do + opts <- cmdArgsRun options + withCurrentDirectory (directory opts) $ do + opts@Options{..} <- autoOptions opts + when topmost terminalTopmost + height <- return $ case (width, height) 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 + -- 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 $ \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 :: [FilePath] -> String -> IO (Int,Int) -> ([(Bool,String)] -> IO ()) -> IO () -runGhcid restart command size output = do - restartTimes <- mapM mtime restart - do (_,height) <- size; output $ map (False,) $ "Loading..." : replicate (height - 1) "" - (ghci,initLoad) <- startGhci command Nothing - curdir <- getCurrentDirectory - let fire load warnings = do - load <- return $ filter (not . whitelist) load +data Style = Plain | Bold deriving Eq + + +runGhcid :: Waiter -> [FilePath] -> String -> [FilePath] -> Maybe String -> IO (Int,Int) -> ([(Style,String)] -> IO ()) -> IO () +runGhcid waiter restart command outputfiles test size output = do + let outputFill :: Maybe [Load] -> [String] -> IO () + outputFill load msg = do (width, height) <- size - start <- getCurrentTime - modsActive <- fmap (map snd) $ showModules ghci - let modsLoad = nubOrd $ map loadFile load + let n = height - length msg + load <- return $ take (if isJust load then n else 0) $ prettyOutput n + [ m{loadMessage = concatMap (chunksOfWord width (width `div` 5)) $ loadMessage m} + | m@Message{} <- fromMaybe [] load] + output $ load ++ map (Plain,) msg ++ replicate (height - (length load + length msg)) (Plain,"") + + restartTimes <- mapM getModTime restart + outputFill Nothing ["Loading..."] + nextWait <- waitFiles waiter + (ghci,messages) <- startGhci command Nothing + curdir <- getCurrentDirectory + + -- fire, given a waiter, the messages, and the warnings from last time + let fire nextWait messages warnings = do + messages <- return $ filter (not . whitelist) messages + + loaded <- map snd <$> showModules ghci + let reloaded = nubOrd $ map loadFile messages + -- some may have reloaded, but caused an error, and thus not be in the loaded set whenLoud $ do - outStrLn $ "%ACTIVE: " ++ show modsActive - outStrLn $ "%LOAD: " ++ show load - let warn = [w | w <- warnings, loadFile w `elem` modsActive, loadFile w `notElem` modsLoad] - let outFill msg = output $ take height $ msg ++ map (False,) (replicate height "") - outFill $ prettyOutput height - [m{loadMessage = concatMap (chunksOfWord width (width `div` 5)) $ loadMessage m} | m@Message{} <- load ++ warn] - setTitle $ - let (errs, warns) = both sum $ unzip [if loadSeverity m == Error then (1,0) else (0,1) | m@Message{} <- load ++ warn] - f n msg = if n == 0 then "" else show n ++ " " ++ msg ++ ['s' | n > 1] - in (if errs == 0 && warns == 0 then "All good" else f errs "error" ++ - (if errs > 0 && warns > 0 then ", " else "") ++ f warns "warning") ++ - " - " ++ takeFileName curdir - let wait = nubOrd $ modsLoad ++ modsActive + outStrLn $ "%MESSAGES: " ++ show messages + outStrLn $ "%LOADED: " ++ show loaded + + -- only keep old warnings from files that are still loaded, but did not reload + let validWarn w = loadFile w `elem` loaded && loadFile w `notElem` reloaded + -- newest warnings always go first, so the file you hit save on most recently has warnings first + messages <- return $ messages ++ filter validWarn warnings + 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 + + let updateTitle extra = 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] + forM_ outputfiles $ \file -> + writeFile file $ unlines $ map snd $ prettyOutput 1000000 $ filter isMessage messages + whenJust test $ \test -> do + res <- exec ghci test + outputFill (Just messages) $ fromMaybe res $ stripSuffix ["*** Exception: ExitSuccess"] res + updateTitle "" + + let wait = nubOrd $ loaded ++ reloaded when (null wait) $ do putStrLn $ "No files loaded, probably did not start GHCi.\nCommand: " ++ command exitFailure - reason <- awaitFiles start $ restart ++ wait - outFill $ map (False,) $ "Reloading..." : map (" " ++) reason - restartTimes2 <- mapM mtime restart + reason <- nextWait $ restart ++ wait + outputFill Nothing $ "Reloading..." : map (" " ++) reason + restartTimes2 <- mapM getModTime restart if restartTimes == restartTimes2 then do - load2 <- reload ghci - fire load2 [m | m@Message{..} <- warn ++ load, loadSeverity == Warning] - else do + nextWait <- waitFiles waiter + let warnings = [m | m@Message{..} <- messages, loadSeverity == Warning] + messages <- reload ghci + fire nextWait messages warnings + else do stopGhci ghci - runGhcid restart command size output - fire initLoad [] + runGhcid waiter restart command outputfiles test size output + fire nextWait messages [] + +-- | Ignore messages that GHC shouldn't really generate. whitelist :: Load -> Bool whitelist Message{loadSeverity=Warning, loadMessage=[_,x]} = x `elem` [" -O conflicts with --interactive; -O ignored."] whitelist _ = False -prettyOutput :: Int -> [Load] -> [(Bool,String)] -prettyOutput _ [] = [(False,allGoodMessage)] +-- | 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 where (err, warn) = partition ((==) Error . loadSeverity) xs - msg1:msgs = map (map (True,) . loadMessage) err ++ map (map (False,) . loadMessage) warn - - --- | return a message about why you are continuing (usually a file name) -awaitFiles :: UTCTime -> [FilePath] -> IO [String] -awaitFiles base files = handle (\(e :: IOError) -> do sleep 0.1; return [show e]) $ do - whenLoud $ outStrLn $ "%WAITING: " ++ unwords files - new <- mapM mtime files - case [x | (x,Just t) <- zip files new, t > base] of - [] -> recheck files new - xs -> return xs - where - recheck files' old = do - sleep 0.1 - new <- mapM mtime files' - case [x | (x,t1,t2) <- zip3 files' old new, t1 /= t2] of - [] -> recheck files' new - xs -> return xs - -mtime :: FilePath -> IO (Maybe UTCTime) -mtime file = handleJust - (\e -> if isDoesNotExistError e then Just () else Nothing) - (\_ -> return Nothing) - (fmap Just $ getModificationTime file) + 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 @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables #-} + -- | The entry point of the library module Language.Haskell.Ghcid ( T.Ghci @@ -14,18 +14,21 @@ where import System.IO +import System.IO.Error import System.Process import Control.Concurrent -import Control.Exception +import Control.Exception.Extra import Control.Monad import Data.Function import Data.List +import Control.Applicative import System.Console.CmdArgs.Verbosity import Language.Haskell.Ghcid.Parser import Language.Haskell.Ghcid.Types as T 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]) @@ -46,9 +49,9 @@ result <- newEmptyMVar -- the end result buffer <- newMVar [] -- the things to go in result forkIO $ fix $ \rec -> do - el <- try $ hGetLine h + el <- tryBool isEOFError $ hGetLine h case el of - Left (_ :: SomeException) -> putMVar result Nothing + Left _ -> putMVar result Nothing Right l -> do whenLoud $ outStrLn $ "%" ++ name ++ ": " ++ l if finish `isInfixOf` l @@ -69,23 +72,23 @@ outC <- takeMVar outs errC <- takeMVar errs case liftM2 (++) outC errC of - Nothing -> throwIO $ UnexpectedExit cmd s + Nothing -> throwIO $ UnexpectedExit cmd s Just msg -> return msg - r <- fmap parseLoad $ f "" + r <- parseLoad <$> f "" return (Ghci f,r) -- | Show modules showModules :: Ghci -> IO [(String,FilePath)] -showModules ghci = fmap parseShowModules $ exec ghci ":show modules" +showModules ghci = parseShowModules <$> exec ghci ":show modules" -- | reload modules reload :: Ghci -> IO [Load] -reload ghci = fmap parseLoad $ exec ghci ":reload" +reload ghci = parseLoad <$> exec ghci ":reload" -- | Stop GHCi stopGhci :: Ghci -> IO () -stopGhci ghci = handle (\UnexpectedExit {} -> return ()) $ void $ exec ghci ":quit" +stopGhci ghci = handle (\UnexpectedExit{} -> return ()) $ void $ exec ghci ":quit" -- | Send a command, get lines of result exec :: Ghci -> String -> IO [String] diff --git a/src/Language/Haskell/Ghcid/Parser.hs b/src/Language/Haskell/Ghcid/Parser.hs --- a/src/Language/Haskell/Ghcid/Parser.hs +++ b/src/Language/Haskell/Ghcid/Parser.hs @@ -38,7 +38,7 @@ , [p1,p2] <- map read $ words $ map (\c -> if c == ':' then ' ' else c) pos , (msg,las) <- span (isPrefixOf " ") xs , rest3 <- trimStart rest2 - , sev <- if "Warning:" `isPrefixOf` rest3 then Warning else Error + , sev <- if "warning:" `isPrefixOf` lower rest3 then Warning else Error = Message sev file (p1,p2) (x:msg) : parseLoad las parseLoad' (x:xs) | Just file <- stripPrefix ": can't find file: " x diff --git a/src/Language/Haskell/Ghcid/Types.hs b/src/Language/Haskell/Ghcid/Types.hs --- a/src/Language/Haskell/Ghcid/Types.hs +++ b/src/Language/Haskell/Ghcid/Types.hs @@ -9,7 +9,7 @@ -- | A GHCi session. Created with 'startGhci'. newtype Ghci = Ghci (String -> IO [String]) --- | GHCi shut down +-- | GHCi shut down data GhciError = UnexpectedExit String String deriving (Show,Eq,Ord,Typeable) diff --git a/src/Language/Haskell/Ghcid/Util.hs b/src/Language/Haskell/Ghcid/Util.hs --- a/src/Language/Haskell/Ghcid/Util.hs +++ b/src/Language/Haskell/Ghcid/Util.hs @@ -7,12 +7,19 @@ , outStrLn , outStr , allGoodMessage + , getModTime ) where import Control.Concurrent.Extra import System.IO.Unsafe import Data.List.Extra import Data.Char +import Data.Time.Clock +import System.IO.Error +import System.Directory +import Control.Exception +import Control.Applicative +import Prelude -- | Drop a prefix from a list, no matter how many times that prefix is present @@ -36,7 +43,7 @@ -- | The message to show when no errors have been reported -allGoodMessage :: String +allGoodMessage :: String allGoodMessage = "All good" -- | Like chunksOf, but deal with words up to some gap. @@ -47,3 +54,10 @@ if null b then (a, []) else let (a1,a2) = breakEnd isSpace a in if length a2 <= gap then (a1, a2 ++ b) else (a, dropWhile isSpace b) + +-- | Given a 'FilePath' return either 'Nothing' (file does not exist) or 'Just' (the modification time) +getModTime :: FilePath -> IO (Maybe UTCTime) +getModTime file = handleJust + (\e -> if isDoesNotExistError e then Just () else Nothing) + (\_ -> return Nothing) + (Just <$> getModificationTime file) diff --git a/src/Test.hs b/src/Test.hs new file mode 100644 --- /dev/null +++ b/src/Test.hs @@ -0,0 +1,19 @@ + +module Test(main) where + +import Test.Tasty +import Test.Parser (parserTests) +import Test.HighLevel (highLevelTests) +import Test.Util (utilsTests) +import Test.Polling (pollingTest) + +main :: IO() +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Tests" + [ utilsTests + , parserTests + , highLevelTests + , pollingTest + ] diff --git a/src/Test/HighLevel.hs b/src/Test/HighLevel.hs new file mode 100644 --- /dev/null +++ b/src/Test/HighLevel.hs @@ -0,0 +1,116 @@ +-- | Test the high level library API +module Test.HighLevel + ( + highLevelTests + ) where + +import System.Directory +import System.FilePath +import Control.Monad (when) + +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" $ + do + root <- createTestProject + (ghci,load) <- startGhci "cabal repl" (Just root) + stopGhci ghci + load @?= [ Loading "B.C" (normalise "src/B/C.hs") + , Loading "A" (normalise "src/A.hs") + ] + +testShowModules :: TestTree +testShowModules = testCase "Show Modules" $ + do + root <- createTestProject + (ghci,_) <- startGhci "cabal repl" (Just root) + mods <- showModules ghci + stopGhci ghci + mods @?= [("A",normalise "src/A.hs"),("B.C",normalise "src/B/C.hs")] + +testProjectName :: String +testProjectName="BWTest" + +testCabalContents :: String +testCabalContents = unlines ["name: "++testProjectName, + "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", + "" + ] + +testCabalFile :: FilePath -> FilePath +testCabalFile root =root (last (splitDirectories root) <.> ".cabal") + +testAContents :: String +testAContents=unlines ["module A where","fA=undefined"] +testCContents :: String +testCContents=unlines ["module B.C where","fC=undefined"] +testDContents :: String +testDContents=unlines ["module B.D where","fD=undefined"] +testMainContents :: String +testMainContents=unlines ["module Main where","main=undefined"] +testMainTestContents :: String +testMainTestContents=unlines ["module Main where","main=undefined"] +testTestAContents :: String +testTestAContents=unlines ["module TestA where","fTA=undefined"] + +testSetupContents ::String +testSetupContents = unlines ["#!/usr/bin/env runhaskell", + "import Distribution.Simple", + "main :: IO ()", + "main = defaultMain"] + +createTestProject :: IO FilePath +createTestProject = do + temp<-getTemporaryDirectory + let root=temp testProjectName + ex<-doesDirectoryExist root + when ex (removeDirectoryRecursive root) + createDirectory root + writeFile (testCabalFile root) testCabalContents + writeFile (root "Setup.hs") testSetupContents + let srcF=root "src" + createDirectory srcF + writeFile (srcF "A.hs") testAContents + let b=srcF "B" + createDirectory b + writeFile (b "C.hs") testCContents + writeFile (b "D.hs") testDContents + writeFile (srcF "Main.hs") testMainContents + let testF=root "test" + createDirectory testF + writeFile (testF "Main.hs") testMainTestContents + writeFile (testF "TestA.hs") testTestAContents + return root diff --git a/src/Test/Parser.hs b/src/Test/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Test/Parser.hs @@ -0,0 +1,50 @@ +-- | Test the message parser +module Test.Parser + ( parserTests + )where + +import Test.Tasty +import Test.Tasty.HUnit + +import Language.Haskell.Ghcid.Parser +import Language.Haskell.Ghcid.Types + + +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")] + + +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 = "GHCi.hs", loadFilePos = (82,1), loadMessage = ["GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217"]} + ] + ] + +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'" + , "GHCi.hs:82:1: warning: Defined but not used: \8216foo\8217" -- GHC 7.12 uses lowercase + ] diff --git a/src/Test/Polling.hs b/src/Test/Polling.hs new file mode 100644 --- /dev/null +++ b/src/Test/Polling.hs @@ -0,0 +1,126 @@ +{-# 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 Data.Maybe +import System.FilePath +import System.Directory.Extra +import System.IO +import System.Process +import System.Console.CmdArgs +import System.Time.Extra + +import Test.Tasty +import Test.Tasty.HUnit + +import Ghcid +import Wait +import Language.Haskell.Ghcid.Util + +pollingTest :: TestTree +pollingTest = testCase "Scripted Test" $ do + setVerbosity Loud + hSetBuffering stdout NoBuffering + 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" + + withWaiterPoll $ \waiter -> bracket ( + forkIO $ runGhcid waiter [] "ghci" [] Nothing (return (100, 50)) $ \msg -> + unless (isLoading $ map snd msg) $ putMVarNow ref $ map snd msg + ) killThread $ \_ -> do + require requireAllGood + testScript require + outStrLn "\nSuccess" + +isLoading :: [String] -> Bool +isLoading xs = listToMaybe xs `elem` [Just "Reloading...",Just "Loading..."] + +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 = 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 "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 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 diff --git a/src/Test/Util.hs b/src/Test/Util.hs new file mode 100644 --- /dev/null +++ b/src/Test/Util.hs @@ -0,0 +1,29 @@ +-- | Test utility functions +module Test.Util + ( utilsTests + ) where + +import Test.Tasty +import Test.Tasty.HUnit + +import Language.Haskell.Ghcid.Util + +utilsTests :: TestTree +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" + ] + +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"] + ] diff --git a/src/Wait.hs b/src/Wait.hs new file mode 100644 --- /dev/null +++ b/src/Wait.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Wait(Waiter, withWaiterPoll, withWaiterNotify, waitFiles) where + +import Control.Concurrent.Extra +import qualified Data.Map as Map +import qualified Data.Set as Set +import Control.Monad +import Data.List.Extra +import System.FilePath +import Control.Exception.Extra +import System.Directory +import Data.Time.Clock +import Data.String +import Data.Maybe +import System.Console.CmdArgs +import System.Time.Extra +import System.FSNotify +import Language.Haskell.Ghcid.Util + + +data Waiter = WaiterPoll + | WaiterNotify WatchManager (MVar ()) (Var (Map.Map FilePath StopListening)) + +withWaiterPoll :: (Waiter -> IO a) -> IO a +withWaiterPoll f = f WaiterPoll + +withWaiterNotify :: (Waiter -> IO a) -> IO a +withWaiterNotify f = withManagerConf defaultConfig{confDebounce=NoDebounce} $ \manager -> do + mvar <- newEmptyMVar + var <- newVar Map.empty + f $ WaiterNotify manager mvar var + + +-- | Return a message about why you are continuing (usually a file name). +-- Reports any changes between the first +waitFiles :: Waiter -> IO ([FilePath] -> IO [String]) +waitFiles waiter = do + base <- getCurrentTime + return $ \files -> handle (\(e :: IOError) -> do sleep 0.1; return [show e]) $ do + whenLoud $ outStrLn $ "%WAITING: " ++ unwords files + case waiter of + WaiterPoll -> return () + WaiterNotify manager kick mp -> do + dirs <- fmap Set.fromList $ mapM canonicalizePathSafe $ nubOrd $ map takeDirectory files + modifyVar_ mp $ \mp -> do + let (keep,del) = Map.partitionWithKey (\k v -> k `Set.member` dirs) mp + sequence_ $ Map.elems del + new <- forM (Set.toList $ dirs `Set.difference` Map.keysSet keep) $ \dir -> do + can <- watchDir manager (fromString dir) (const True) $ \event -> do + whenLoud $ outStrLn $ "%NOTIFY: " ++ show event + void $ tryPutMVar kick () + return (dir, can) + let mp2 = keep `Map.union` Map.fromList new + whenLoud $ outStrLn $ "%WAITING: " ++ unwords (Map.keys mp2) + return mp2 + void $ tryTakeMVar kick + new <- mapM getModTime files + case [x | (x,Just t) <- zip files new, t > base] of + [] -> recheck files new + xs -> return xs + where + recheck files old = do + sleep 0.1 + case waiter of + WaiterPoll -> return () + WaiterNotify _ kick _ -> do + takeMVar kick + whenLoud $ outStrLn "%WAITING: Notify signaled" + new <- mapM getModTime files + case [x | (x,t1,t2) <- zip3 files old new, t1 /= t2] of + [] -> recheck files new + xs -> do + when (or $ zipWith (\o n -> isJust o && isNothing n) old new) $ do + -- if someone is deleting a needed file, give them some space to put the file back + -- typically caused by VIM + whenLoud $ outStrLn "%WAITING: Extra wait due to file removal" + sleep 1 + return xs + + +canonicalizePathSafe :: FilePath -> IO FilePath +canonicalizePathSafe x = canonicalizePath x `catch_` const (return x) diff --git a/test/Language/Haskell/Ghcid/HighLevelTests.hs b/test/Language/Haskell/Ghcid/HighLevelTests.hs deleted file mode 100644 --- a/test/Language/Haskell/Ghcid/HighLevelTests.hs +++ /dev/null @@ -1,116 +0,0 @@ --- | Test the high level library API -module Language.Haskell.Ghcid.HighLevelTests - ( - highLevelTests - ) where - -import System.Directory -import System.FilePath -import Control.Monad (when) - -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" $ - do - root <- createTestProject - (ghci,load) <- startGhci "cabal repl" (Just root) - stopGhci ghci - load @?= [ Loading "B.C" (normalise "src/B/C.hs") - , Loading "A" (normalise "src/A.hs") - ] - -testShowModules :: TestTree -testShowModules = testCase "Show Modules" $ - do - root <- createTestProject - (ghci,_) <- startGhci "cabal repl" (Just root) - mods <- showModules ghci - stopGhci ghci - mods @?= [("A",normalise "src/A.hs"),("B.C",normalise "src/B/C.hs")] - -testProjectName :: String -testProjectName="BWTest" - -testCabalContents :: String -testCabalContents = unlines ["name: "++testProjectName, - "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", - "" - ] - -testCabalFile :: FilePath -> FilePath -testCabalFile root =root (last (splitDirectories root) <.> ".cabal") - -testAContents :: String -testAContents=unlines ["module A where","fA=undefined"] -testCContents :: String -testCContents=unlines ["module B.C where","fC=undefined"] -testDContents :: String -testDContents=unlines ["module B.D where","fD=undefined"] -testMainContents :: String -testMainContents=unlines ["module Main where","main=undefined"] -testMainTestContents :: String -testMainTestContents=unlines ["module Main where","main=undefined"] -testTestAContents :: String -testTestAContents=unlines ["module TestA where","fTA=undefined"] - -testSetupContents ::String -testSetupContents = unlines ["#!/usr/bin/env runhaskell", - "import Distribution.Simple", - "main :: IO ()", - "main = defaultMain"] - -createTestProject :: IO FilePath -createTestProject = do - temp<-getTemporaryDirectory - let root=temp testProjectName - ex<-doesDirectoryExist root - when ex (removeDirectoryRecursive root) - createDirectory root - writeFile (testCabalFile root) testCabalContents - writeFile (root "Setup.hs") testSetupContents - let srcF=root "src" - createDirectory srcF - writeFile (srcF "A.hs") testAContents - let b=srcF "B" - createDirectory b - writeFile (b "C.hs") testCContents - writeFile (b "D.hs") testDContents - writeFile (srcF "Main.hs") testMainContents - let testF=root "test" - createDirectory testF - writeFile (testF "Main.hs") testMainTestContents - writeFile (testF "TestA.hs") testTestAContents - return root diff --git a/test/Language/Haskell/Ghcid/ParserTest.hs b/test/Language/Haskell/Ghcid/ParserTest.hs deleted file mode 100644 --- a/test/Language/Haskell/Ghcid/ParserTest.hs +++ /dev/null @@ -1,48 +0,0 @@ --- | Test the message parser -module Language.Haskell.Ghcid.ParserTest - ( parserTests - )where - -import Test.Tasty -import Test.Tasty.HUnit - -import Language.Haskell.Ghcid.Parser -import Language.Haskell.Ghcid.Types - - -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")] - - -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'"]} - ] - ] - -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'" - ] diff --git a/test/Language/Haskell/Ghcid/PollingTest.hs b/test/Language/Haskell/Ghcid/PollingTest.hs deleted file mode 100644 --- a/test/Language/Haskell/Ghcid/PollingTest.hs +++ /dev/null @@ -1,125 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} - --- | Test behavior of the executable, polling files for changes -module Language.Haskell.Ghcid.PollingTest (pollingTest) where - -import Control.Concurrent -import Control.Exception.Extra -import Control.Monad -import Data.Char -import Data.List -import Data.Maybe -import System.FilePath -import System.Directory.Extra -import System.IO -import System.Process -import System.Console.CmdArgs -import System.Time.Extra - -import Test.Tasty -import Test.Tasty.HUnit - -import Ghcid -import Language.Haskell.Ghcid.Util - -pollingTest :: TestTree -pollingTest = testCase "Scripted Test" $ do - setVerbosity Loud - hSetBuffering stdout NoBuffering - 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" - - bracket ( - forkIO $ runGhcid [] "ghci" (return (100, 50)) $ \msg -> - unless (isLoading $ map snd msg) $ putMVarNow ref $ map snd msg - ) killThread $ \_ -> do - require requireAllGood - testScript require - outStrLn "\nSuccess" - -isLoading :: [String] -> Bool -isLoading xs = listToMaybe xs `elem` [Just "Reloading...",Just "Loading..."] - -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 = 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 = filter (\x->isLetter x || isDigit x || x==':') - ---------------------------------------------------------------------- --- ACTUAL TEST SUITE - -testScript :: (([String] -> IO ()) -> IO ()) -> IO () -testScript require = do - 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 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 diff --git a/test/Language/Haskell/Ghcid/UtilTest.hs b/test/Language/Haskell/Ghcid/UtilTest.hs deleted file mode 100644 --- a/test/Language/Haskell/Ghcid/UtilTest.hs +++ /dev/null @@ -1,29 +0,0 @@ --- | Test utility functions -module Language.Haskell.Ghcid.UtilTest - ( utilsTests - ) where - -import Test.Tasty -import Test.Tasty.HUnit - -import Language.Haskell.Ghcid.Util - -utilsTests :: TestTree -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" - ] - -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"] - ] diff --git a/test/Test.hs b/test/Test.hs deleted file mode 100644 --- a/test/Test.hs +++ /dev/null @@ -1,19 +0,0 @@ - -module Test(main) where - -import Test.Tasty -import Language.Haskell.Ghcid.ParserTest (parserTests) -import Language.Haskell.Ghcid.HighLevelTests (highLevelTests) -import Language.Haskell.Ghcid.UtilTest (utilsTests) -import Language.Haskell.Ghcid.PollingTest (pollingTest) - -main :: IO() -main = defaultMain tests - -tests :: TestTree -tests = testGroup "Tests" - [ utilsTests - , parserTests - , highLevelTests - , pollingTest - ]