diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,8 @@ # ghcid [![Hackage version](https://img.shields.io/hackage/v/ghcid.svg?style=flat)](http://hackage.haskell.org/package/ghcid) [![Build Status](http://img.shields.io/travis/ndmitchell/ghcid.svg?style=flat)](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** diff --git a/ghcid.cabal b/ghcid.cabal --- a/ghcid.cabal +++ b/ghcid.cabal @@ -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 +author: Neil Mitchell , jpmoresmau maintainer: Neil Mitchell 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 diff --git a/src/GHCi.hs b/src/GHCi.hs deleted file mode 100644 --- a/src/GHCi.hs +++ /dev/null @@ -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 [] = [] diff --git a/src/Language/Haskell/Ghcid.hs b/src/Language/Haskell/Ghcid.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Ghcid.hs @@ -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 diff --git a/src/Language/Haskell/Ghcid/Parser.hs b/src/Language/Haskell/Ghcid/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Ghcid/Parser.hs @@ -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' [] = [] diff --git a/src/Language/Haskell/Ghcid/Types.hs b/src/Language/Haskell/Ghcid/Types.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Ghcid/Types.hs @@ -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 diff --git a/src/Language/Haskell/Ghcid/Util.hs b/src/Language/Haskell/Ghcid/Util.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/Ghcid/Util.hs @@ -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 diff --git a/src/Language/Haskell/GhcidProgram.hs b/src/Language/Haskell/GhcidProgram.hs new file mode 100644 --- /dev/null +++ b/src/Language/Haskell/GhcidProgram.hs @@ -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) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -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) diff --git a/src/Test.hs b/src/Test.hs deleted file mode 100644 --- a/src/Test.hs +++ /dev/null @@ -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 diff --git a/src/Util.hs b/src/Util.hs deleted file mode 100644 --- a/src/Util.hs +++ /dev/null @@ -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 diff --git a/test/Language/Haskell/Ghcid/HighLevelTests.hs b/test/Language/Haskell/Ghcid/HighLevelTests.hs new file mode 100644 --- /dev/null +++ b/test/Language/Haskell/Ghcid/HighLevelTests.hs @@ -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 diff --git a/test/Language/Haskell/Ghcid/ParserTest.hs b/test/Language/Haskell/Ghcid/ParserTest.hs new file mode 100644 --- /dev/null +++ b/test/Language/Haskell/Ghcid/ParserTest.hs @@ -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'" + ] diff --git a/test/Language/Haskell/Ghcid/PollingTest.hs b/test/Language/Haskell/Ghcid/PollingTest.hs new file mode 100644 --- /dev/null +++ b/test/Language/Haskell/Ghcid/PollingTest.hs @@ -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 diff --git a/test/Language/Haskell/Ghcid/UtilTest.hs b/test/Language/Haskell/Ghcid/UtilTest.hs new file mode 100644 --- /dev/null +++ b/test/Language/Haskell/Ghcid/UtilTest.hs @@ -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" + ] diff --git a/test/ghcid_test.hs b/test/ghcid_test.hs new file mode 100644 --- /dev/null +++ b/test/ghcid_test.hs @@ -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 + ]