ghcid 0.2 → 0.3
raw patch · 13 files changed
+358/−304 lines, 13 filesdep +extradep +terminal-sizedep ~directoryPVP ok
version bump matches the API change (PVP)
Dependencies added: extra, terminal-size
Dependency ranges changed: directory
API changes (from Hackage documentation)
Files
- CHANGES.txt +6/−0
- ghcid.cabal +18/−8
- src/Ghcid.hs +113/−0
- src/Language/Haskell/Ghcid.hs +1/−2
- src/Language/Haskell/Ghcid/Terminal.hs +74/−0
- src/Language/Haskell/Ghcid/Util.hs +14/−47
- src/Language/Haskell/GhcidProgram.hs +0/−88
- src/Main.hs +0/−31
- test/Language/Haskell/Ghcid/HighLevelTests.hs +3/−3
- test/Language/Haskell/Ghcid/PollingTest.hs +106/−103
- test/Language/Haskell/Ghcid/UtilTest.hs +4/−4
- test/Test.hs +19/−0
- test/ghcid_test.hs +0/−18
CHANGES.txt view
@@ -1,5 +1,11 @@ Changelog for GHCiD +0.3+ #11, ignore certain GHCi-only warnings+ #13, fix version printing+ #8, display Loading... when starting+ Require the extra library+ #14, figure out the terminal height automatically 0.2 #6, rewrite as a library Remove duplicate error messages from cabal repl
ghcid.cabal view
@@ -1,7 +1,7 @@ cabal-version: >= 1.10 build-type: Simple name: ghcid-version: 0.2+version: 0.3 license: BSD3 license-file: LICENSE category: Development@@ -30,36 +30,44 @@ filepath, time, directory,+ extra >= 0.4, process >= 1.1, cmdargs >= 0.10- ghc-options: -Wall+ if !os(windows)+ build-depends: terminal-size >= 0.2.1 other-modules: + Paths_ghcid, Language.Haskell.Ghcid.Types, Language.Haskell.Ghcid.Parser,+ Language.Haskell.Ghcid.Terminal, Language.Haskell.Ghcid.Util exposed-modules: Language.Haskell.Ghcid executable ghcid hs-source-dirs: src default-language: Haskell2010- main-is: Main.hs+ ghc-options: -main-is Ghcid.main+ main-is: Ghcid.hs build-depends: base == 4.*, filepath, time, directory,+ extra >= 0.4, process >= 1.1, cmdargs >= 0.10+ if !os(windows)+ build-depends: terminal-size >= 0.2.1 other-modules: Language.Haskell.Ghcid.Types, Language.Haskell.Ghcid.Parser,+ Language.Haskell.Ghcid.Terminal, Language.Haskell.Ghcid.Util,- Language.Haskell.Ghcid,- Language.Haskell.GhcidProgram+ Language.Haskell.Ghcid test-suite ghcid_test type: exitcode-stdio-1.0- ghc-options: -Wall -rtsopts+ ghc-options: -rtsopts -main-is Test.main default-language: Haskell2010 build-depends: base >= 4,@@ -67,14 +75,16 @@ time, directory, process,+ extra >= 0.4, cmdargs, tasty, tasty-hunit+ if !os(windows)+ build-depends: terminal-size >= 0.2.1 hs-source-dirs: test, src- main-is: ghcid_test.hs+ main-is: Test.hs other-modules: Language.Haskell.Ghcid.ParserTest, Language.Haskell.Ghcid.HighLevelTests, Language.Haskell.Ghcid.UtilTest,- Language.Haskell.GhcidProgram, Language.Haskell.Ghcid.PollingTest
+ src/Ghcid.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable, CPP, ScopedTypeVariables #-}+{-# OPTIONS_GHC -O2 #-} -- only here to test ticket #11++-- | The application entry point+module Ghcid(main, runGhcid) where++import Control.Applicative+import Control.Exception+import Control.Monad.Extra+import Data.List+import Data.Time.Clock+import Data.Version+import System.Console.CmdArgs+import System.Directory+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.Types+import Language.Haskell.Ghcid.Util+++-- | Command line options+data Options = Options+ {command :: String+ ,height :: Maybe Int+ ,topmost :: Bool+ }+ deriving (Data,Typeable,Show)++options :: Mode (CmdArgs Options)+options = cmdArgsMode $ Options+ {command = "" &= typ "COMMAND" &= help "Command to run (defaults to ghci or cabal repl)"+ ,height = Nothing &= help "Number of lines to show (defaults to console height)"+ ,topmost = False &= name "t" &= help "Set window topmost (Windows only)"+ } &= verbosity &=+ program "ghcid" &= summary ("Auto reloading GHCi daemon v" ++ showVersion version)+++main :: IO ()+main = do+ opts@Options{..} <- cmdArgsRun options+ when topmost terminalTopmost+ height <- return $ case height of+ Nothing -> maybe 8 snd <$> terminalSize+ Just h -> return h+ command <- if command /= "" then return command else+ ifM (doesFileExist ".ghci") (return "ghci") (return "cabal repl")+ runGhcid command height $ \xs -> do+ outStr $ concatMap ('\n':) xs+ hFlush stdout -- must flush, since we don't finish with a newline+++runGhcid :: String -> IO Int -> ([String] -> IO ()) -> IO ()+runGhcid command height output = do+ do height <- height; output $ "Loading..." : replicate (height - 1) ""+ (ghci,initLoad) <- startGhci command Nothing+ let fire load warnings = do+ load <- return $ filter (not . whitelist) load+ height <- height+ start <- getCurrentTime+ modsActive <- fmap (map snd) $ showModules ghci+ let modsLoad = nub $ map loadFile load+ 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 ++ replicate height ""+ outFill $ prettyOutput height $ filter isMessage load ++ warn+ reason <- awaitFiles start $ nub $ modsLoad ++ modsActive+ outFill $ "Reloading..." : map (" " ++) reason+ load2 <- reload ghci+ fire load2 [m | m@Message{..} <- warn ++ load, loadSeverity == Warning]+ fire initLoad []+++whitelist :: Load -> Bool+whitelist Message{loadSeverity=Warning, loadMessage=[_,x]}+ = x `elem` [" -O conflicts with --interactive; -O ignored."]+whitelist _ = False+++prettyOutput :: Int -> [Load] -> [String]+prettyOutput _ [] = [allGoodMessage]+prettyOutput height xs = take (height - (length msgs * 2)) msg1 ++ concatMap (take 2) msgs+ where (err, warn) = partition ((==) Error . loadSeverity) xs+ msg1:msgs = map loadMessage err ++ map 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)
src/Language/Haskell/Ghcid.hs view
@@ -1,4 +1,3 @@-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-} {-# LANGUAGE ScopedTypeVariables #-} -- | The entry point of the library module Language.Haskell.Ghcid@@ -57,7 +56,7 @@ buf <- modifyMVar buffer $ \old -> return ([], reverse old) putMVar result $ Just buf else- modifyMVar_ buffer $ return . (dropPrefix prefix l:)+ modifyMVar_ buffer $ return . (dropPrefixRepeatedly prefix l:) rec return result
+ src/Language/Haskell/Ghcid/Terminal.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE CPP #-}+module Language.Haskell.Ghcid.Terminal(+ terminalSize, terminalTopmost+ ) where++#if !defined(mingw32_HOST_OS)+import qualified System.Console.Terminal.Size as Terminal+import System.IO (stdout)+import Data.Tuple.Extra+#endif++#if defined(mingw32_HOST_OS)+import Control.Monad+import Data.Word+import Data.Bits+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc++type HANDLE = Ptr ()+type HWND = Ptr ()++data CONSOLE_SCREEN_BUFFER_INFO+sizeCONSOLE_SCREEN_BUFFER_INFO = 22+posCONSOLE_SCREEN_BUFFER_INFO_srWindow = 10 -- 4 x Word16 Left,Top,Right,Bottom++c_SWP_NOSIZE = 1 :: Word32+c_SWP_NOMOVE = 2 :: Word32+c_HWND_TOPMOST = -1 :: Int+c_STD_OUTPUT_HANDLE = -11 :: Word32++foreign import stdcall unsafe "windows.h GetConsoleWindow"+ c_GetConsoleWindow :: IO HWND++foreign import stdcall unsafe "windows.h SetWindowPos"+ c_SetWindowPos :: HWND -> Int -> Int -> Int -> Int -> Int -> Word32 -> IO Bool++foreign import stdcall unsafe "windows.h GetConsoleScreenBufferInfo"+ c_GetConsoleScreenBufferInfo :: HANDLE -> Ptr CONSOLE_SCREEN_BUFFER_INFO -> IO Bool++foreign import stdcall unsafe "windows.h GetStdHandle"+ c_GetStdHandle :: Word32 -> IO HANDLE+#endif+++-- | Figure out the size of the current terminal, @(width,height)@, or return 'Nothing'.+terminalSize :: IO (Maybe (Int, Int))+#if defined(mingw32_HOST_OS)+terminalSize = do+ hdl <- c_GetStdHandle c_STD_OUTPUT_HANDLE+ allocaBytes sizeCONSOLE_SCREEN_BUFFER_INFO $ \p -> do+ b <- c_GetConsoleScreenBufferInfo hdl p+ if not b then return Nothing else do+ [left,top,right,bottom] <- forM [0..3] $ \i -> do+ v <- peekByteOff p ((i*2) + posCONSOLE_SCREEN_BUFFER_INFO_srWindow)+ return $ fromIntegral (v :: Word16)+ return $ Just (1+right-left, 1+bottom-top)+#else+terminalSize = do+ s <- Terminal.hSize stdout+ return $ fmap (Terminal.width &&& Terminal.height) s+#endif+++-- | Raise the current terminal on top of all other screens, if you can.+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)+ return ()+#else+terminalTopmost = return ()+#endif
src/Language/Haskell/Ghcid/Util.hs view
@@ -1,67 +1,34 @@ -- | Utility functions -- Copyright Neil Mitchell 2014. module Language.Haskell.Ghcid.Util- ( dropPrefix+ ( dropPrefixRepeatedly , outStrLn , outStr- , withTempDirectory- , withCurrentDirectory- , sleep- , partitionM- , try_- )where+ , allGoodMessage+ ) where -import Control.Concurrent+import Control.Concurrent.Extra import System.IO.Unsafe-import System.Directory-import Control.Exception-import System.FilePath-import Data.List (stripPrefix)+import Data.List -- | Drop a prefix from a list, no matter how many times that prefix is present-dropPrefix :: Eq a => [a] -> [a] -> [a]-dropPrefix [] s = s-dropPrefix pre s = maybe s (dropPrefix pre) $ stripPrefix pre s--+dropPrefixRepeatedly :: Eq a => [a] -> [a] -> [a]+dropPrefixRepeatedly [] s = s+dropPrefixRepeatedly pre s = maybe s (dropPrefixRepeatedly pre) $ stripPrefix pre s {-# NOINLINE lock #-}-lock :: MVar ()-lock = unsafePerformIO $ newMVar ()+lock :: Lock+lock = unsafePerformIO newLock outStr :: String -> IO ()-outStr = withMVar lock . const . putStr+outStr = withLock lock . putStr outStrLn :: String -> IO () outStrLn s = outStr $ s ++ "\n" -withTempDirectory :: (FilePath -> IO a) -> IO a-withTempDirectory act = do- tdir <- fmap (</> ".ghcid") getTemporaryDirectory- bracket_- (createDirectoryIfMissing True tdir)- (removeDirectoryRecursive tdir)- $ act tdir---withCurrentDirectory :: FilePath -> IO a -> IO a-withCurrentDirectory dir act =- bracket getCurrentDirectory setCurrentDirectory $ const $ do- setCurrentDirectory dir; act---sleep :: Double -> IO ()-sleep x = threadDelay $ ceiling $ x * 1000000---partitionM :: Monad m => (a -> m Bool) -> [a] -> m ([a], [a])-partitionM _ [] = return ([], [])-partitionM f (x:xs) = do- t <- f x- (a,b) <- partitionM f xs- return $ if t then (x:a,b) else (a,x:b)+-- | The message to show when no errors have been reported+allGoodMessage :: String +allGoodMessage = "All good" -try_ :: IO a -> IO (Either SomeException a)-try_ = try
− src/Language/Haskell/GhcidProgram.hs
@@ -1,88 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-{-# LANGUAGE RecordWildCards, DeriveDataTypeable, ScopedTypeVariables #-}--- | This is the meat of the executable. It's not in Main so it can be called by the test suite.-module Language.Haskell.GhcidProgram where--import Data.List-import Data.Time.Clock--import System.Directory-import System.Console.CmdArgs-import System.IO.Error-import Control.Exception--import Language.Haskell.Ghcid-import Language.Haskell.Ghcid.Types-import Language.Haskell.Ghcid.Util---- | Command line options-data Options = Options- {command :: String- ,height :: Int- ,topmost :: Bool- }- deriving (Data,Typeable,Show)--options :: Mode (CmdArgs Options)-options = cmdArgsMode $ Options- {command = "" &= typ "COMMAND" &= help "Command to run (defaults to ghci or cabal repl)"- ,height = 8 &= help "Number of lines to show"- ,topmost = False &= name "t" &= help "Set window topmost (Windows only)"- } &= verbosity &=- program "ghcid" &= summary "Auto :reload'ing GHCi daemon"- ---- | Run the polling of files and dump reload message via output function-runGhcid :: forall b a. String -> Int -> ([String] -> IO a) -> IO b-runGhcid command height output = do- dotGhci <- doesFileExist ".ghci"- (ghci,initLoad) <- startGhci (if command /= "" then command- else if dotGhci then "ghci" else "cabal repl") Nothing- let fire load warnings = do- start <- getCurrentTime- modsActive <- fmap (map snd) $ showModules ghci- let modsLoad = nub $ map loadFile load- 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 ++ replicate height ""- outFill $ prettyOutput height $ filter isMessage load ++ warn- reason <- awaitFiles start $ nub $ modsLoad ++ modsActive- outFill $ "Reloading..." : map (" " ++) reason- load2 <- reload ghci- fire load2 [m | m@Message{..} <- warn ++ load, loadSeverity == Warning]- fire initLoad []- --- | The message to show when no errors have been reported-allGoodMessage :: String -allGoodMessage = "All Good" - -prettyOutput :: Int -> [Load] -> [String]-prettyOutput _ [] = [allGoodMessage]-prettyOutput height xs = take (height - (length msgs * 2)) msg1 ++ concatMap (take 2) msgs- where (err, warn) = partition ((==) Error . loadSeverity) xs- msg1:msgs = map loadMessage err ++ map 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)
− src/Main.hs
@@ -1,31 +0,0 @@-{-# LANGUAGE RecordWildCards, DeriveDataTypeable, CPP, ScopedTypeVariables #-} --- | The application entry point -module Main(main) where - -import Control.Monad -import System.Console.CmdArgs -import Language.Haskell.GhcidProgram -import Language.Haskell.Ghcid.Util - - - -#if defined(mingw32_HOST_OS) -foreign import stdcall unsafe "windows.h GetConsoleWindow" - c_GetConsoleWindow :: IO Int - -foreign import stdcall unsafe "windows.h SetWindowPos" - c_SetWindowPos :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> IO Int - -c_HWND_TOPMOST = -1 -#endif - -main :: IO () -main = do - Options{..} <- cmdArgsRun options -#if defined(mingw32_HOST_OS) - when topmost $ do - wnd <- c_GetConsoleWindow - c_SetWindowPos wnd c_HWND_TOPMOST 0 0 0 0 3 - return () -#endif - runGhcid command height (outStr . unlines)
test/Language/Haskell/Ghcid/HighLevelTests.hs view
@@ -26,8 +26,8 @@ root <- createTestProject (ghci,load) <- startGhci "cabal repl" (Just root) stopGhci ghci- load @?= [ Loading "B.C" "src/B/C.hs"- , Loading "A" "src/A.hs"+ load @?= [ Loading "B.C" (normalise "src/B/C.hs")+ , Loading "A" (normalise "src/A.hs") ] testShowModules :: TestTree@@ -37,7 +37,7 @@ (ghci,_) <- startGhci "cabal repl" (Just root) mods <- showModules ghci stopGhci ghci- mods @?= [("A","src/A.hs"),("B.C","src/B/C.hs")] + mods @?= [("A",normalise "src/A.hs"),("B.C",normalise "src/B/C.hs")] testProjectName :: String testProjectName="BWTest"
test/Language/Haskell/Ghcid/PollingTest.hs view
@@ -1,81 +1,84 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-{-# LANGUAGE ScopedTypeVariables #-} --- | Test behavior of the executable, polling files for changes -module Language.Haskell.Ghcid.PollingTest (pollingTest) where - -import Control.Concurrent -import Control.Exception -import Control.Monad -import Data.Char -import Data.List -import System.FilePath -import System.Directory -import System.IO -import System.Process ++-- | 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 Language.Haskell.GhcidProgram -import Language.Haskell.Ghcid.Util - -pollingTest :: TestTree +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" + 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" 50 $ \msg -> unless (["Reloading..."] `isPrefixOf` msg) $- putMVarNow ref msg+ forkIO $ runGhcid "ghci" (return 50) $ \msg ->+ unless (isLoading msg) $ putMVarNow ref msg ) killThread $ \_ -> do - require requireAllGood - testScript require - outStrLn "\nSuccess" + require requireAllGood+ testScript require+ outStrLn "\nSuccess" - - -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 +isLoading :: [String] -> Bool+isLoading xs = listToMaybe xs `elem` [Just "Reloading...",Just "Loading..."] --- | 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 +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@@ -84,39 +87,39 @@ -- | 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 +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
test/Language/Haskell/Ghcid/UtilTest.hs view
@@ -15,8 +15,8 @@ dropPrefixTests :: TestTree dropPrefixTests = testGroup "dropPrefix"- [ testCase "Prefix not found" $ dropPrefix "prefix" "string" @?= "string"- , testCase "Empty prefix" $ dropPrefix "" "string" @?= "string"- , testCase "Prefix found once" $ dropPrefix "str" "string" @?= "ing"- , testCase "Prefix found twice" $ dropPrefix "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" ]
+ test/Test.hs view
@@ -0,0 +1,19 @@++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+ ]
− test/ghcid_test.hs
@@ -1,18 +0,0 @@-module 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- ]