ghcid 0.1.3 → 0.2
raw patch · 17 files changed
+717/−377 lines, 17 filesdep +tastydep +tasty-hunitdep ~basedep ~cmdargsdep ~directory
Dependencies added: tasty, tasty-hunit
Dependency ranges changed: base, cmdargs, directory, process
Files
- CHANGES.txt +3/−0
- README.md +3/−1
- ghcid.cabal +52/−12
- src/GHCi.hs +0/−130
- src/Language/Haskell/Ghcid.hs +93/−0
- src/Language/Haskell/Ghcid/Parser.hs +43/−0
- src/Language/Haskell/Ghcid/Types.hs +37/−0
- src/Language/Haskell/Ghcid/Util.hs +67/−0
- src/Language/Haskell/GhcidProgram.hs +88/−0
- src/Main.hs +5/−74
- src/Test.hs +0/−105
- src/Util.hs +0/−55
- test/Language/Haskell/Ghcid/HighLevelTests.hs +116/−0
- test/Language/Haskell/Ghcid/ParserTest.hs +48/−0
- test/Language/Haskell/Ghcid/PollingTest.hs +122/−0
- test/Language/Haskell/Ghcid/UtilTest.hs +22/−0
- test/ghcid_test.hs +18/−0
CHANGES.txt view
@@ -1,5 +1,8 @@ Changelog for GHCiD +0.2+ #6, rewrite as a library+ Remove duplicate error messages from cabal repl 0.1.3 #2, handle files that get deleted while loaded #3, flesh out the test suite
README.md view
@@ -1,6 +1,8 @@ # ghcid [](http://hackage.haskell.org/package/ghcid) [](https://travis-ci.org/ndmitchell/ghcid) -Either "GHCi as a daemon" or "GHC + a bit of an IDE". Unlike other Haskell development tools, `ghcid` is intended to be _incredibly simple_. In particular, it doesn't integrate with any editors, doesn't depend on GHC the library and doesn't start web servers.+Either "GHCi as a daemon" or "GHC + a bit of an IDE". To a first approximation, it opens `ghci` and runs `:reload` whenever your source code changes, formatting the output to fit a fixed height console. Unlike other Haskell development tools, `ghcid` is intended to be _incredibly simple_. In particular, it doesn't integrate with any editors, doesn't depend on GHC the library and doesn't start web servers.++_Acknowledgements:_ This project incorporates significant work from [JPMoresmau](https://github.com/JPMoresmau), who is listed as a co-author. **Using it**
ghcid.cabal view
@@ -1,11 +1,11 @@ cabal-version: >= 1.10 build-type: Simple name: ghcid-version: 0.1.3+version: 0.2 license: BSD3 license-file: LICENSE category: Development-author: Neil Mitchell <ndmitchell@gmail.com>+author: Neil Mitchell <ndmitchell@gmail.com>, jpmoresmau maintainer: Neil Mitchell <ndmitchell@gmail.com> copyright: Neil Mitchell 2014 synopsis: GHCi based bare bones IDE@@ -22,19 +22,59 @@ type: git location: https://github.com/ndmitchell/ghcid.git -executable ghcid- hs-source-dirs: src- default-language: Haskell2010- main-is: Main.hs- build-depends:- base == 4.*,+library+ hs-source-dirs: src+ default-language: Haskell2010 + build-depends: + base >= 4, filepath, time, directory, process >= 1.1, cmdargs >= 0.10+ ghc-options: -Wall+ other-modules: + Language.Haskell.Ghcid.Types,+ Language.Haskell.Ghcid.Parser,+ Language.Haskell.Ghcid.Util+ exposed-modules: Language.Haskell.Ghcid - other-modules:- GHCi- Util- Test+executable ghcid+ hs-source-dirs: src+ default-language: Haskell2010+ main-is: Main.hs+ build-depends:+ base == 4.*,+ filepath,+ time,+ directory,+ process >= 1.1,+ cmdargs >= 0.10+ other-modules: + Language.Haskell.Ghcid.Types,+ Language.Haskell.Ghcid.Parser,+ Language.Haskell.Ghcid.Util,+ Language.Haskell.Ghcid,+ Language.Haskell.GhcidProgram++test-suite ghcid_test+ type: exitcode-stdio-1.0+ ghc-options: -Wall -rtsopts+ default-language: Haskell2010 + build-depends: + base >= 4,+ filepath,+ time,+ directory,+ process,+ cmdargs,+ tasty,+ tasty-hunit+ hs-source-dirs: test, src+ main-is: ghcid_test.hs+ other-modules: + Language.Haskell.Ghcid.ParserTest,+ Language.Haskell.Ghcid.HighLevelTests,+ Language.Haskell.Ghcid.UtilTest,+ Language.Haskell.GhcidProgram,+ Language.Haskell.Ghcid.PollingTest
− src/GHCi.hs
@@ -1,130 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-} - -module GHCi( - ghci, - parseShowModules, - Severity(..), Load(..), isMessage, parseLoad - ) where - -import System.IO -import System.Process -import Control.Concurrent -import Control.Exception -import Control.Monad -import Data.Char -import Data.Function -import Data.List -import System.FilePath -import System.Console.CmdArgs.Verbosity -import System.Exit -import Util - - ---------------------------------------------------------------------- --- IO INTERACTION WITH GHCI - -ghci :: String -> IO (String -> IO [String]) -ghci cmd = do - (Just inp, Just out, Just err, pid) <- - createProcess (shell cmd){std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe} - hSetBuffering out LineBuffering - hSetBuffering err LineBuffering - hSetBuffering inp LineBuffering - - lock <- newMVar () -- ensure only one person talks to ghci at a time - let prefix = "#~GHCID-IGNORE~#" - let finish = "#~GHCID-FINISH~#" - hPutStrLn inp $ ":set prompt " ++ prefix - - -- consume from a handle, produce an MVar with either Just and a message, or Nothing (stream closed) - let consume h name = do - result <- newEmptyMVar -- the end result - buffer <- newMVar [] -- the things to go in result - forkIO $ fix $ \rec -> do - s <- try $ hGetLine h - case s of - Left (_ :: SomeException) -> putMVar result Nothing - Right s -> do - whenLoud $ outStrLn $ "%" ++ name ++ ": " ++ s - if finish `isInfixOf` s then do - buf <- modifyMVar buffer $ \old -> return ([], reverse old) - putMVar result $ Just buf - else - modifyMVar_ buffer $ return . (dropPrefix prefix s:) - rec - return result - - outs <- consume out "GHCOUT" - errs <- consume err "GHCERR" - firstTime <- newMVar True - - return $ \s -> withMVar lock $ const $ do - whenLoud $ outStrLn $ "%GHCINP: " ++ s - hPutStrLn inp $ s ++ "\nputStrLn " ++ show finish ++ "\nerror " ++ show finish - out <- takeMVar outs - err <- takeMVar errs - case liftM2 (++) out err of - Nothing -> do - firstTime <- readMVar firstTime - outStrLn $ if firstTime - then "GHCi exited, did you run the right command? You ran:\n " ++ cmd - else "GHCi exited" - exitFailure - Just msg -> do - modifyMVar_ firstTime $ const $ return False - return msg - - -dropPrefix :: Eq a => [a] -> [a] -> [a] -dropPrefix pre s = maybe s (dropPrefix pre) $ stripPrefix pre s - ---------------------------------------------------------------------- --- PARSING THE OUTPUT - --- Main ( Main.hs, interpreted ) --- GHCi ( GHCi.hs, interpreted ) -parseShowModules :: [String] -> [(String, FilePath)] -parseShowModules xs = - [ (takeWhile (not . isSpace) $ dropWhile isSpace a, takeWhile (/= ',') b) - | x <- xs, (a,'(':' ':b) <- [break (== '(') x]] - -data Severity = Warning | Error deriving (Show,Eq) - -data Load - = Loading {loadModule :: String, loadFile :: FilePath} - | Message - {loadSeverity :: Severity - ,loadFile :: FilePath - ,loadFilePos :: (Int,Int) - ,loadMessage :: [String] - } - deriving Show - -isMessage Message{} = True; isMessage _ = False - --- [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' -parseLoad :: [String] -> [Load] -parseLoad (('[':xs):rest) = - map (uncurry Loading) (parseShowModules [drop 11 $ dropWhile (/= ']') xs]) ++ - parseLoad rest -parseLoad (x:xs) - | not $ " " `isPrefixOf` x - , (file,':':rest) <- break (== ':') x - , takeExtension file `elem` [".hs",".lhs"] - , (pos,rest) <- span (\x -> x == ':' || isDigit x) rest - , [p1,p2] <- map read $ words $ map (\x -> if x == ':' then ' ' else x) pos - , (msg,xs) <- span (isPrefixOf " ") xs - , rest <- dropWhile isSpace rest - , sev <- if "Warning:" `isPrefixOf` rest then Warning else Error - = Message sev file (p1,p2) (x:msg) : parseLoad xs -parseLoad (x:xs) = parseLoad xs -parseLoad [] = []
+ src/Language/Haskell/Ghcid.hs view
@@ -0,0 +1,93 @@+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | The entry point of the library+module Language.Haskell.Ghcid+ ( T.Ghci+ , T.GhciError (..)+ , T.Severity (..)+ , T.Load (..)+ , startGhci+ , showModules+ , reload+ , exec+ , stopGhci+ )+where++import System.IO+import System.Process+import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.Function+import Data.List++import System.Console.CmdArgs.Verbosity++import Language.Haskell.Ghcid.Parser+import Language.Haskell.Ghcid.Types as T+import Language.Haskell.Ghcid.Util++-- | Start GHCi, returning a function to perform further operation, as well as the result of the initial loading+startGhci :: String -> Maybe FilePath -> IO (Ghci, [Load])+startGhci cmd directory = do+ (Just inp, Just out, Just err, _) <-+ createProcess (shell cmd){std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe, cwd = directory}+ hSetBuffering out LineBuffering+ hSetBuffering err LineBuffering+ hSetBuffering inp LineBuffering++ lock <- newMVar () -- ensure only one person talks to ghci at a time+ let prefix = "#~GHCID-START~#"+ let finish = "#~GHCID-FINISH~#"+ hPutStrLn inp $ ":set prompt " ++ prefix++ -- consume from a handle, produce an MVar with either Just and a message, or Nothing (stream closed)+ let consume h name = do+ result <- newEmptyMVar -- the end result+ buffer <- newMVar [] -- the things to go in result+ forkIO $ fix $ \rec -> do+ el <- try $ hGetLine h+ case el of+ Left (_ :: SomeException) -> putMVar result Nothing+ Right l -> do+ whenLoud $ outStrLn $ "%" ++ name ++ ": " ++ l+ if finish `isInfixOf` l+ then do+ buf <- modifyMVar buffer $ \old -> return ([], reverse old)+ putMVar result $ Just buf+ else+ modifyMVar_ buffer $ return . (dropPrefix prefix l:)+ rec+ return result++ outs <- consume out "GHCOUT"+ errs <- consume err "GHCERR"++ let f s = withMVar lock $ const $ do+ whenLoud $ outStrLn $ "%GHCINP: " ++ s+ hPutStrLn inp $ s ++ "\nputStrLn " ++ show finish ++ "\nerror " ++ show finish+ outC <- takeMVar outs+ errC <- takeMVar errs+ case liftM2 (++) outC errC of+ Nothing -> throwIO $ UnexpectedExit cmd s + Just msg -> return msg+ r <- fmap parseLoad $ f ""+ return (Ghci f,r)+++-- | Show modules+showModules :: Ghci -> IO [(String,FilePath)]+showModules ghci = fmap parseShowModules $ exec ghci ":show modules"++-- | reload modules+reload :: Ghci -> IO [Load]+reload ghci = fmap parseLoad $ exec ghci ":reload"++-- | Stop GHCi+stopGhci :: Ghci -> IO ()+stopGhci ghci = handle (\UnexpectedExit {} -> return ()) $ void $ exec ghci ":quit"++-- | Send a command, get lines of result+exec :: Ghci -> String -> IO [String]+exec (Ghci x) = x
+ src/Language/Haskell/Ghcid/Parser.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE PatternGuards #-}+-- | Parses the output from GHCi+-- Copyright Neil Mitchell 2014.+module Language.Haskell.Ghcid.Parser + ( parseShowModules+ , parseLoad+ )+ where++import System.FilePath+import Data.Char+import Data.List++import Language.Haskell.Ghcid.Types++-- | Parse messages from show modules command+parseShowModules :: [String] -> [(String, FilePath)]+parseShowModules xs =+ [ (takeWhile (not . isSpace) $ dropWhile isSpace a, takeWhile (/= ',') b)+ | x <- xs, (a,'(':' ':b) <- [break (== '(') x]]++-- | Parse messages given on reload+-- nub, because cabal repl sometimes does two reloads at the start+parseLoad :: [String] -> [Load]+parseLoad = nub . parseLoad' ++-- | Parse messages given on reload+parseLoad' :: [String] -> [Load]+parseLoad' (('[':xs):rest) =+ map (uncurry Loading) (parseShowModules [drop 11 $ dropWhile (/= ']') xs]) +++ parseLoad rest+parseLoad' (x:xs)+ | not $ " " `isPrefixOf` x+ , (file,':':rest) <- break (== ':') 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 + , (msg,las) <- span (isPrefixOf " ") xs+ , rest3 <- dropWhile isSpace rest2+ , sev <- if "Warning:" `isPrefixOf` rest3 then Warning else Error+ = Message sev file (p1,p2) (x:msg) : parseLoad las+parseLoad' (_:xs) = parseLoad xs+parseLoad' [] = []
+ src/Language/Haskell/Ghcid/Types.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DeriveDataTypeable #-}+-- | The types we use+-- Copyright Neil Mitchell 2014.+module Language.Haskell.Ghcid.Types where++import Data.Typeable+import Control.Exception.Base (Exception)++-- | A GHCi session. Created with 'startGhci'.+newtype Ghci = Ghci (String -> IO [String])++-- | GHCi shut down+data GhciError = UnexpectedExit String String+ deriving (Show,Eq,Ord,Typeable)++-- | Make GhciError an exception+instance Exception GhciError++-- | Severity of messages+data Severity = Warning | Error + deriving (Show,Eq,Ord,Bounded,Enum,Typeable)++-- | Load messages+data Load+ = Loading {loadModule :: String, loadFile :: FilePath}+ | Message+ {loadSeverity :: Severity+ ,loadFile :: FilePath+ ,loadFilePos :: (Int,Int)+ ,loadMessage :: [String]+ }+ deriving (Show,Eq)+ +-- | Is a Load a message with severity?+isMessage :: Load -> Bool+isMessage Message{} = True+isMessage _ = False
+ src/Language/Haskell/Ghcid/Util.hs view
@@ -0,0 +1,67 @@+-- | Utility functions+-- Copyright Neil Mitchell 2014.+module Language.Haskell.Ghcid.Util+ ( dropPrefix+ , outStrLn+ , outStr+ , withTempDirectory+ , withCurrentDirectory+ , sleep+ , partitionM+ , try_+ )where++import Control.Concurrent+import System.IO.Unsafe+import System.Directory+import Control.Exception+import System.FilePath+import Data.List (stripPrefix)++-- | 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+++++{-# NOINLINE lock #-}+lock :: MVar ()+lock = unsafePerformIO $ newMVar ()++outStr :: String -> IO ()+outStr = withMVar lock . const . 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)++try_ :: IO a -> IO (Either SomeException a)+try_ = try
+ src/Language/Haskell/GhcidProgram.hs view
@@ -0,0 +1,88 @@+{-# 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 view
@@ -1,35 +1,14 @@ {-# LANGUAGE RecordWildCards, DeriveDataTypeable, CPP, ScopedTypeVariables #-} - +-- | The application entry point module Main(main) where import Control.Monad -import System.Directory -import Data.Time.Clock -import Data.List -import GHCi -import Util -import Test import System.Console.CmdArgs -import System.IO.Error -import Control.Exception +import Language.Haskell.GhcidProgram +import Language.Haskell.Ghcid.Util -data Options = Options - {command :: String - ,height :: Int - ,topmost :: Bool - ,test :: Bool - } - deriving (Data,Typeable,Show) -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)" - ,test = False &= help "Run the test suite" - } &= verbosity &= - program "ghcid" &= summary "Auto :reload'ing GHCi daemon" - #if defined(mingw32_HOST_OS) foreign import stdcall unsafe "windows.h GetConsoleWindow" c_GetConsoleWindow :: IO Int @@ -44,57 +23,9 @@ main = do Options{..} <- cmdArgsRun options #if defined(mingw32_HOST_OS) - when ((not test) && topmost) $ do + when topmost $ do wnd <- c_GetConsoleWindow c_SetWindowPos wnd c_HWND_TOPMOST 0 0 0 0 3 return () #endif - runTest test $ \output -> do - dotGhci <- doesFileExist ".ghci" - ghci <- ghci $ if command /= "" then command - else if dotGhci then "ghci" else "cabal repl" - let fire msg warnings = do - start <- getCurrentTime - load <- fmap parseLoad $ ghci msg - modsActive <- fmap (map snd . parseShowModules) $ ghci ":show modules" - modsLoad <- return $ nub $ map loadFile load - whenLoud $ do - outStrLn $ "%ACTIVE: " ++ show modsActive - outStrLn $ "%LOAD: " ++ show load - warn <- return [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 - fire ":reload" [m | m@Message{..} <- warn ++ load, loadSeverity == Warning] - fire "" [] - - -prettyOutput :: Int -> [Load] -> [String] -prettyOutput height [] = ["All good"] -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) + runGhcid command height (outStr . unlines)
− src/Test.hs
@@ -1,105 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-} - -module Test(runTest) where - -import Util -import Control.Concurrent -import Control.Exception -import Control.Monad -import Data.Char -import Data.List -import System.FilePath -import System.Directory -import System.Exit -import System.IO -import System.Process - - -runTest :: Bool -> (([String] -> IO ()) -> IO a) -> IO a -runTest False f = f $ outStr . unlines -runTest True f = do - hSetBuffering stdout NoBuffering - tdir <- fmap (</> ".ghcid") getTemporaryDirectory - try_ $ removeDirectoryRecursive tdir - createDirectoryIfMissing True tdir - withCurrentDirectory tdir $ do - ref <- newEmptyMVar - let require pred = do - res <- takeMVarDelay ref 5 - pred 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" - forkIO $ handle (\(e :: SomeException) -> throwTo t e) $ do - require requireAllGood - testScript require - outStrLn "\nSuccess" - throwTo t ExitSuccess - f $ \msg -> unless (["Reloading..."] `isPrefixOf` msg) $ - putMVarNow ref msg - -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 x 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 - -requireAllGood :: [String] -> IO () -requireAllGood got = filter (not . null) got === ["All good"] - -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 - - ---------------------------------------------------------------------- --- ACTUAL TEST SUITE - -testScript :: (([String] -> IO ()) -> IO ()) -> IO () -testScript require = do - writeFile "Main.hs" "x" - require $ requireNonIndents ["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 $ requireNonIndents ["Util.hs:2:1: Parse error: naked expression at top level"] - writeFile "Util.hs" "module Util() where\nx = 1" - require $ requireNonIndents ["Util.hs:2:1: Warning: Defined but not used: `x'"] - - -- check warnings persist properly - writeFile "Main.hs" "import Util\nx" - require $ requireNonIndents ["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 $ requireNonIndents ["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 $ requireNonIndents ["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 $ \s -> do requirePrefix ["Main.hs:1:8:"," Could not find module `Util'"] s - requireNonIndents ["Main.hs:1:8:"] s - renameFile "Util2.hs" "Util.hs" - require requireAllGood
− src/Util.hs
@@ -1,55 +0,0 @@- -module Util( - outStrLn, outStr, - withTempDirectory, withCurrentDirectory, - sleep, - partitionM, - try_ - ) where - -import Control.Concurrent -import System.IO.Unsafe -import System.Directory -import Control.Exception -import System.FilePath - - -{-# NOINLINE lock #-} -lock :: MVar () -lock = unsafePerformIO $ newMVar () - -outStr :: String -> IO () -outStr = withMVar lock . const . 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 f [] = 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) - -try_ :: IO a -> IO (Either SomeException a) -try_ = try
+ test/Language/Haskell/Ghcid/HighLevelTests.hs view
@@ -0,0 +1,116 @@+-- | 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" "src/B/C.hs"+ , Loading "A" "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","src/A.hs"),("B.C","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
+ test/Language/Haskell/Ghcid/ParserTest.hs view
@@ -0,0 +1,48 @@+-- | 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'"+ ]
+ test/Language/Haskell/Ghcid/PollingTest.hs view
@@ -0,0 +1,122 @@+{-# 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 +import System.Console.CmdArgs++import Test.Tasty+import Test.Tasty.HUnit + +import Language.Haskell.GhcidProgram +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" 50 $ \msg -> unless (["Reloading..."] `isPrefixOf` msg) $+ putMVarNow ref msg+ ) killThread $ \_ -> do + 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 ++-- | 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
+ test/Language/Haskell/Ghcid/UtilTest.hs view
@@ -0,0 +1,22 @@+-- | 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+ ]+ +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"+ ]
+ test/ghcid_test.hs view
@@ -0,0 +1,18 @@+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+ ]