diff --git a/CHANGES.txt b/CHANGES.txt --- a/CHANGES.txt +++ b/CHANGES.txt @@ -1,5 +1,13 @@ Changelog for GHCiD +0.5.1 + #17, deal with recursive modules errors properly + #50, use -fno-code when not running tests (about twice as fast) + #44, abbreviate the redundant module import error + #45, add an extra space before the ... message + #42, always show the first error in full + #43, work even if people use break-on-exception flags + #42, make the first error a minimum of 5 lines 0.5 Add an extra boolean argument to startGhci Add the number of modules loaded after All good diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Neil Mitchell 2014-2015. +Copyright Neil Mitchell 2014-2016. All rights reserved. Redistribution and use in source and binary forms, with or without diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,4 @@ -# ghcid [![Hackage version](https://img.shields.io/hackage/v/ghcid.svg?style=flat)](https://hackage.haskell.org/package/ghcid) [![Build Status](https://img.shields.io/travis/ndmitchell/ghcid.svg?style=flat)](https://travis-ci.org/ndmitchell/ghcid) +# ghcid [![Hackage version](https://img.shields.io/hackage/v/ghcid.svg?label=Hackage)](https://hackage.haskell.org/package/ghcid) [![Stackage version](https://www.stackage.org/package/ghcid/badge/lts?label=Stackage)](https://www.stackage.org/package/ghcid) [![Linux Build Status](https://img.shields.io/travis/ndmitchell/ghcid.svg?label=Linux%20build)](https://travis-ci.org/ndmitchell/ghcid) [![Windows Build Status](https://img.shields.io/appveyor/ci/ndmitchell/ghcid.svg?label=Windows%20build)](https://ci.appveyor.com/project/ndmitchell/ghcid) 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. @@ -35,3 +35,4 @@ * _This isn't as good as full IDE._ I've gone for simplicity over features. It's a point in the design space, but not necessarily the best point in the design space for you. For "real" IDEs see [the Haskell wiki](http://www.haskell.org/haskellwiki/IDEs). * _If I delete a file and put it back it gets stuck._ Yes, that's a [bug in GHCi](https://ghc.haskell.org/trac/ghc/ticket/9648). If you see GHCi getting confused just kill `ghcid` and start it again. +* _It doesn't work with Stack._ Pass `-c "stack ghci"`. Work is ongoing to improve the Stack integration (mostly waiting on features/changes/fixes on the Stack side). diff --git a/ghcid.cabal b/ghcid.cabal --- a/ghcid.cabal +++ b/ghcid.cabal @@ -1,20 +1,20 @@ cabal-version: >= 1.10 build-type: Simple name: ghcid -version: 0.5 +version: 0.5.1 license: BSD3 license-file: LICENSE category: Development author: Neil Mitchell , jpmoresmau maintainer: Neil Mitchell -copyright: Neil Mitchell 2014-2015 +copyright: Neil Mitchell 2014-2016 synopsis: GHCi based bare bones IDE description: Either \"GHCi as a daemon\" or \"GHC + a bit of an IDE\". A very simple Haskell development tool which shows you the errors in your project and updates them whenever you save. Run @ghcid --topmost --command=ghci@, where @--topmost@ makes the window on top of all others (Windows only) and @--command@ is the command to start GHCi on your project (defaults to @ghci@ if you have a @.ghci@ file, or else to @cabal repl@). homepage: https://github.com/ndmitchell/ghcid#readme bug-reports: https://github.com/ndmitchell/ghcid/issues -tested-with: GHC==7.10.1, GHC==7.8.4, GHC==7.6.3 -extra-source-files: +tested-with: GHC==8.0.1, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 +extra-doc-files: CHANGES.txt README.md @@ -24,8 +24,8 @@ library hs-source-dirs: src - default-language: Haskell2010 - build-depends: + default-language: Haskell2010 + build-depends: base >= 4, filepath, time, @@ -36,7 +36,7 @@ terminal-size >= 0.3 if os(windows) build-depends: Win32 - other-modules: + other-modules: Paths_ghcid, Language.Haskell.Ghcid.Types, Language.Haskell.Ghcid.Parser, @@ -63,7 +63,7 @@ terminal-size >= 0.3 if os(windows) build-depends: Win32 - other-modules: + other-modules: Language.Haskell.Ghcid.Types, Language.Haskell.Ghcid.Parser, Language.Haskell.Ghcid.Terminal, @@ -73,9 +73,9 @@ test-suite ghcid_test type: exitcode-stdio-1.0 - ghc-options: -rtsopts -main-is Test.main -threaded - default-language: Haskell2010 - build-depends: + ghc-options: -rtsopts -main-is Test.main -threaded -with-rtsopts=-K1K + default-language: Haskell2010 + build-depends: base >= 4, filepath, time, @@ -93,7 +93,7 @@ build-depends: Win32 hs-source-dirs: src main-is: Test.hs - other-modules: + other-modules: Test.Parser, Test.HighLevel, Test.Util, diff --git a/src/Ghcid.hs b/src/Ghcid.hs --- a/src/Ghcid.hs +++ b/src/Ghcid.hs @@ -1,10 +1,11 @@ {-# LANGUAGE RecordWildCards, DeriveDataTypeable, CPP, TupleSections #-} -{-# OPTIONS_GHC -O2 -fno-cse #-} -- only here to test ticket #11 +{-# OPTIONS_GHC -fno-cse #-} -- | The application entry point module Ghcid(main, runGhcid) where import Control.Applicative +import Control.Exception import Control.Monad.Extra import Control.Concurrent.Extra import Data.List.Extra @@ -67,14 +68,14 @@ - cabal exec ghci Sample.hs - prompt with Sample.hs loaded - ghci - prompt with nothing loaded - ghci Sample.hs - prompt with Sample.hs loaded -- stack ... - never anything loaded +- stack ghci - prompt with all libraries and Main loaded Hlint with a .ghci file: - cabal repl - loads everything twice, prompt with Language.Haskell.HLint loaded - cabal exec ghci Sample.hs - loads everything first, then prompt with Sample.hs loaded - ghci - prompt with everything - ghci Sample.hs - loads everything first, then prompt with Sample.hs loaded -- stack ... - never anything loaded +- stack ghci - loads everything first, then prompt with libraries and Main loaded Warnings: - cabal repl won't pull in any C files (e.g. hoogle) @@ -84,17 +85,18 @@ -} autoOptions :: Options -> IO Options autoOptions o@Options{..} - | command /= "" = return $ f command [] + | command /= "" = return $ f [command] [] | otherwise = do files <- getDirectoryContents "." let cabal = filter ((==) ".cabal" . takeExtension) files + let opts = ["-fno-code" | isNothing test] return $ case () of - _ | ".ghci" `elem` files -> f "ghci" [".ghci"] - | "stack.yaml" `elem` files, False -> f "stack ghci" ["stack.yaml"] -- see #130 - | cabal /= [] -> f (if arguments == [] then "cabal repl" else "cabal exec ghci") cabal - | otherwise -> f "ghci" [] + _ | ".ghci" `elem` files -> f ("ghci":opts) [".ghci"] + | "stack.yaml" `elem` files, False -> f ("stack ghci":map ("--ghci-options=" ++) opts) ["stack.yaml"] -- see #130 + | cabal /= [] -> f (if arguments == [] then "cabal repl":map ("--ghc-options=" ++) opts else "cabal exec -- ghci":opts) cabal + | otherwise -> f ("ghci":opts) [] where - f c r = o{command = unwords $ c : map escape arguments, arguments = [], restart = restart ++ r} + f c r = o{command = unwords $ c ++ map escape arguments, arguments = [], restart = restart ++ r} -- in practice we're not expecting many arguments to have anything funky in them escape x | ' ' `elem` x = "\"" ++ x ++ "\"" @@ -123,12 +125,13 @@ -- so putStrLn width 'x' uses up two lines return (f width 80 (pred . fst), f height 8 snd) withWaiterNotify $ \waiter -> - runGhcid waiter (nubOrd restart) command outputfile test height (not notitle) $ \xs -> do - outWith $ forM_ (groupOn fst xs) $ \x@((s,_):_) -> do - when (s == Bold) $ setSGR [SetConsoleIntensity BoldIntensity] - putStr $ concatMap ((:) '\n' . snd) x - when (s == Bold) $ setSGR [] - hFlush stdout -- must flush, since we don't finish with a newline + handle (\(UnexpectedExit cmd _) -> putStrLn $ "Command \"" ++ cmd ++ "\" exited unexpectedly") $ + runGhcid waiter (nubOrd restart) command outputfile test height (not notitle) $ \xs -> do + outWith $ forM_ (groupOn fst xs) $ \x@((s,_):_) -> do + when (s == Bold) $ setSGR [SetConsoleIntensity BoldIntensity] + putStr $ concatMap ((:) '\n' . snd) x + when (s == Bold) $ setSGR [] + hFlush stdout -- must flush, since we don't finish with a newline data Style = Plain | Bold deriving Eq @@ -140,34 +143,43 @@ outputFill load msg = do (width, height) <- size let n = height - length msg - load <- return $ take (if isJust load then n else 0) $ prettyOutput n (maybe 0 fst load) + load <- return $ take (if isJust load then n else 0) $ prettyOutput (maybe 0 fst load) [ m{loadMessage = concatMap (chunksOfWord width (width `div` 5)) $ loadMessage m} | m@Message{} <- maybe [] snd load] output $ load ++ map (Plain,) msg ++ replicate (height - (length load + length msg)) (Plain,"") restartTimes <- mapM getModTime restart - outStrLn $ "Loading " ++ command ++ "..." + outStrLn $ "Loading " ++ command ++ " ..." nextWait <- waitFiles waiter (ghci,messages) <- startGhci command Nothing True curdir <- getCurrentDirectory -- fire, given a waiter, the messages, and the warnings from last time let fire nextWait messages warnings = do - messages <- return $ filter (not . whitelist) messages + let f m@Message{} = m{loadMessage = filter (not . ignoreMessageLine) $ loadMessage m} + f x = x + messages <- return $ map f $ filter (not . ignoreMessage) messages loaded <- map snd <$> showModules ghci let loadedCount = length loaded - let reloaded = nubOrd $ map loadFile messages -- some may have reloaded, but caused an error, and thus not be in the loaded set + let reloaded = nubOrd $ filter (/= "") $ map loadFile messages + + let wait = nubOrd $ loaded ++ reloaded whenLoud $ do outStrLn $ "%MESSAGES: " ++ show messages outStrLn $ "%LOADED: " ++ show loaded + when (null wait && isNothing warnings) $ do + putStrLn $ "\nNo files loaded, did not start GHCi properly.\nCommand: " ++ command + exitFailure + -- only keep old warnings from files that are still loaded, but did not reload let validWarn w = loadFile w `elem` loaded && loadFile w `notElem` reloaded -- newest warnings always go first, so the file you hit save on most recently has warnings first - messages <- return $ messages ++ filter validWarn warnings - let (countErrors, countWarnings) = both sum $ unzip [if loadSeverity m == Error then (1,0) else (0,1) | m@Message{} <- messages] + messages <- return $ messages ++ filter validWarn (fromMaybe [] warnings) + let (countErrors, countWarnings) = both sum $ unzip + [if loadSeverity == Error then (1,0) else (0,1) | m@Message{..} <- messages, loadMessage /= []] test <- return $ if countErrors == 0 then test else Nothing when titles $ changeWindowIcon $ @@ -178,19 +190,18 @@ in (if countErrors == 0 && countWarnings == 0 then allGoodMessage else f countErrors "error" ++ (if countErrors > 0 && countWarnings > 0 then ", " else "") ++ f countWarnings "warning") ++ " " ++ extra ++ "- " ++ takeFileName curdir - + updateTitle $ if isJust test then "(running test) " else "" outputFill (Just (loadedCount, messages)) ["Running test..." | isJust test] forM_ outputfiles $ \file -> - writeFile file $ unlines $ map snd $ prettyOutput 1000000 loadedCount $ filter isMessage messages + writeFile file $ unlines $ map snd $ prettyOutput loadedCount $ filter isMessage messages whenJust test $ \test -> do res <- exec ghci test outputFill (Just (loadedCount, messages)) $ fromMaybe res $ stripSuffix ["*** Exception: ExitSuccess"] res updateTitle "" - let wait = nubOrd $ loaded ++ reloaded when (null wait) $ do - putStrLn $ "No files loaded, probably did not start GHCi.\nCommand: " ++ command + putStrLn $ "No files loaded, nothing to wait for. Fix the last error and restart." exitFailure reason <- nextWait $ restart ++ wait outputFill Nothing $ "Reloading..." : map (" " ++) reason @@ -199,24 +210,31 @@ nextWait <- waitFiles waiter let warnings = [m | m@Message{..} <- messages, loadSeverity == Warning] messages <- reload ghci - fire nextWait messages warnings + fire nextWait messages $ Just warnings else do stopGhci ghci runGhcid waiter restart command outputfiles test size titles output - fire nextWait messages [] + fire nextWait messages Nothing -- | Ignore messages that GHC shouldn't really generate. -whitelist :: Load -> Bool -whitelist Message{loadSeverity=Warning, loadMessage=[_,x]} +ignoreMessage :: Load -> Bool +ignoreMessage Message{loadSeverity=Warning, loadMessage=[_,x]} = x `elem` [" -O conflicts with --interactive; -O ignored."] -whitelist _ = False +ignoreMessage _ = False +-- | Ignore lines in messages that are pointless. +ignoreMessageLine :: String -> Bool +ignoreMessageLine x = any (`isPrefixOf` x) xs + where + xs = [" except perhaps to import instances from" + ," To import instances alone, use: import "] + -- | Given an available height, and a set of messages to display, show them as best you can. -prettyOutput :: Int -> Int -> [Load] -> [(Style,String)] -prettyOutput height loaded [] = [(Plain,allGoodMessage ++ " (" ++ show loaded ++ " module" ++ ['s' | loaded /= 1] ++ ")")] -prettyOutput loaded height xs = take (max 3 $ height - (length msgs * 2)) msg1 ++ concatMap (take 2) msgs +prettyOutput :: Int -> [Load] -> [(Style,String)] +prettyOutput loaded [] = [(Plain,allGoodMessage ++ " (" ++ show loaded ++ " module" ++ ['s' | loaded /= 1] ++ ")")] +prettyOutput loaded xs = concat $ msg1:msgs where (err, warn) = partition ((==) Error . loadSeverity) xs msg1:msgs = map (map (Bold,) . loadMessage) err ++ map (map (Plain,) . loadMessage) warn diff --git a/src/Language/Haskell/Ghcid.hs b/src/Language/Haskell/Ghcid.hs --- a/src/Language/Haskell/Ghcid.hs +++ b/src/Language/Haskell/Ghcid.hs @@ -1,22 +1,16 @@ -- | The entry point of the library -module Language.Haskell.Ghcid - ( T.Ghci - , T.GhciError (..) - , T.Severity (..) - , T.Load (..) - , startGhci - , showModules - , reload - , exec - , stopGhci - ) -where +module Language.Haskell.Ghcid( + Ghci, GhciError(..), + Load(..), Severity(..), + startGhci, stopGhci, + showModules, reload, exec + ) where import System.IO import System.IO.Error import System.Process -import Control.Concurrent +import Control.Concurrent.Extra import Control.Exception.Extra import Control.Monad.Extra import Data.Function @@ -37,21 +31,22 @@ startGhci :: String -> Maybe FilePath -> Bool -> IO (Ghci, [Load]) startGhci cmd directory echo = do (Just inp, Just out, Just err, _) <- - createProcess (shell cmd){std_in=CreatePipe, std_out=CreatePipe, std_err=CreatePipe, cwd = directory} + 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 + lock <- newLock -- ensure only one person talks to ghci at a time let prefix = "#~GHCID-START~#" let finish = "#~GHCID-FINISH~#" hPutStrLn inp $ ":set prompt " ++ prefix + hPutStrLn inp ":set -fno-break-on-exception -fno-break-on-error" -- see #43 echo <- newIORef echo -- 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 + buffer <- newVar [] -- the things to go in result forkIO $ fix $ \rec -> do el <- tryBool isEOFError $ hGetLine h case el of @@ -62,24 +57,24 @@ unless (any (`isInfixOf` l) [prefix, finish]) $ outStrLn l if finish `isInfixOf` l then do - buf <- modifyMVar buffer $ \old -> return ([], reverse old) + buf <- modifyVar buffer $ \old -> return ([], reverse old) putMVar result $ Just buf else - modifyMVar_ buffer $ return . (dropPrefixRepeatedly prefix l:) + modifyVar_ buffer $ return . (dropPrefixRepeatedly prefix l:) rec return result outs <- consume out "GHCOUT" errs <- consume err "GHCERR" - let f s = withMVar lock $ const $ do + let f s = withLock lock $ do whenLoud $ outStrLn $ "%GHCINP: " ++ s hPutStrLn inp $ s ++ "\nPrelude.putStrLn " ++ show finish ++ "\nPrelude.error " ++ show finish outC <- takeMVar outs errC <- takeMVar errs case liftM2 (++) outC errC of Nothing -> throwIO $ UnexpectedExit cmd s - Just msg -> return msg + Just msg -> return msg r <- parseLoad <$> f "" writeIORef echo False return (Ghci f,r) diff --git a/src/Language/Haskell/Ghcid/Parser.hs b/src/Language/Haskell/Ghcid/Parser.hs --- a/src/Language/Haskell/Ghcid/Parser.hs +++ b/src/Language/Haskell/Ghcid/Parser.hs @@ -1,11 +1,9 @@ {-# LANGUAGE PatternGuards #-} + -- | Parses the output from GHCi --- Copyright Neil Mitchell 2014. -module Language.Haskell.Ghcid.Parser - ( parseShowModules - , parseLoad - ) - where +module Language.Haskell.Ghcid.Parser( + parseShowModules, parseLoad + ) where import System.FilePath import Data.Char @@ -14,34 +12,42 @@ import Language.Haskell.Ghcid.Types --- | Parse messages from show modules command +-- | Parse messages from show modules command. Given the parsed lines +-- return a list of (module name, file). parseShowModules :: [String] -> [(String, FilePath)] parseShowModules xs = [ (takeWhile (not . isSpace) $ trimStart 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 = nubOrd . 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 <- trimStart rest2 - , sev <- if "warning:" `isPrefixOf` lower rest3 then Warning else Error - = Message sev file (p1,p2) (x:msg) : parseLoad las -parseLoad' (x:xs) - | Just file <- stripPrefix ": can't find file: " x - = Message Error file (0,0) [file ++ ": Can't find file"] : parseLoad xs -parseLoad' (_:xs) = parseLoad xs -parseLoad' [] = [] +-- | Parse messages given on reload. +parseLoad :: [String] -> [Load] +-- nub, because cabal repl sometimes does two reloads at the start +parseLoad = nubOrd . f + where + f :: [String] -> [Load] + f (('[':xs):rest) = + map (uncurry Loading) (parseShowModules [drop 11 $ dropWhile (/= ']') xs]) ++ + f rest + f (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 <- trimStart rest2 + , sev <- if "warning:" `isPrefixOf` lower rest3 then Warning else Error + = Message sev file (p1,p2) (x:msg) : f las + f (x:xs) + | Just file <- stripPrefix ": can't find file: " x + = Message Error file (0,0) [file ++ ": Can't find file"] : f xs + f (x:xs) + | x == "Module imports form a cycle:" + , (xs,rest) <- span (isPrefixOf " ") xs + , let ms = [takeWhile (/= ')') x | x <- xs, '(':x <- [dropWhile (/= '(') x]] + = Message Error "" (0,0) (x:xs) : + -- need to label the modules in the import cycle so I can find them + [Message Error m (0,0) [] | m <- nubOrd ms] ++ f rest + f (_:xs) = f xs + f [] = [] diff --git a/src/Language/Haskell/Ghcid/Terminal.hs b/src/Language/Haskell/Ghcid/Terminal.hs --- a/src/Language/Haskell/Ghcid/Terminal.hs +++ b/src/Language/Haskell/Ghcid/Terminal.hs @@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-} + +-- | Cross-platform operations for manipulating terminal console windows. module Language.Haskell.Ghcid.Terminal( terminalTopmost, withWindowIcon, WindowIcon(..), changeWindowIcon @@ -10,7 +12,7 @@ import Control.Exception import Graphics.Win32.Misc -import Graphics.Win32.Window +import Graphics.Win32.Window import Graphics.Win32.Message import Graphics.Win32.GDI.Types import System.Win32.Types diff --git a/src/Language/Haskell/Ghcid/Types.hs b/src/Language/Haskell/Ghcid/Types.hs --- a/src/Language/Haskell/Ghcid/Types.hs +++ b/src/Language/Haskell/Ghcid/Types.hs @@ -1,8 +1,11 @@ {-# LANGUAGE DeriveDataTypeable #-} --- | The types we use --- Copyright Neil Mitchell 2014. -module Language.Haskell.Ghcid.Types where +-- | The types types that we use in Ghcid +module Language.Haskell.Ghcid.Types( + Ghci(..), GhciError(..), + Load(..), Severity(..), isMessage + ) where + import Data.Typeable import Control.Exception.Base (Exception) @@ -11,26 +14,29 @@ -- | GHCi shut down data GhciError = UnexpectedExit String String - deriving (Show,Eq,Ord,Typeable) + 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) +data Severity = Warning | Error + deriving (Show,Eq,Ord,Bounded,Enum,Typeable) -- | Load messages data Load - = Loading {loadModule :: String, loadFile :: FilePath} + = Loading + {loadModule :: String + ,loadFile :: FilePath + } | Message {loadSeverity :: Severity ,loadFile :: FilePath ,loadFilePos :: (Int,Int) ,loadMessage :: [String] } - deriving (Show, Eq, Ord) - + deriving (Show, Eq, Ord) + -- | Is a Load a message with severity? isMessage :: Load -> Bool isMessage Message{} = True diff --git a/src/Language/Haskell/Ghcid/Util.hs b/src/Language/Haskell/Ghcid/Util.hs --- a/src/Language/Haskell/Ghcid/Util.hs +++ b/src/Language/Haskell/Ghcid/Util.hs @@ -1,14 +1,11 @@ -- | Utility functions --- Copyright Neil Mitchell 2014. -module Language.Haskell.Ghcid.Util - ( dropPrefixRepeatedly - , chunksOfWord - , outWith - , outStrLn - , outStr - , allGoodMessage - , getModTime - ) where +module Language.Haskell.Ghcid.Util( + dropPrefixRepeatedly, + chunksOfWord, + outWith, outStrLn, outStr, + allGoodMessage, + getModTime + ) where import Control.Concurrent.Extra import System.IO.Unsafe diff --git a/src/Test.hs b/src/Test.hs --- a/src/Test.hs +++ b/src/Test.hs @@ -2,18 +2,21 @@ module Test(main) where import Test.Tasty -import Test.Parser (parserTests) -import Test.HighLevel (highLevelTests) -import Test.Util (utilsTests) -import Test.Polling (pollingTest) +import Test.Parser +import Test.HighLevel +import Test.Util +import Test.Polling +import System.IO -main :: IO() -main = defaultMain tests +main :: IO () +main = do + hSetBuffering stdout NoBuffering + defaultMain tests tests :: TestTree tests = testGroup "Tests" - [ utilsTests - , parserTests - , highLevelTests - , pollingTest - ] + [utilsTests + ,parserTests + ,pollingTest + ,highLevelTests + ] diff --git a/src/Test/HighLevel.hs b/src/Test/HighLevel.hs --- a/src/Test/HighLevel.hs +++ b/src/Test/HighLevel.hs @@ -1,12 +1,13 @@ -- | Test the high level library API -module Test.HighLevel - ( - highLevelTests - ) where +module Test.HighLevel(highLevelTests) where import System.Directory +import System.IO.Extra +import System.Exit import System.FilePath -import Control.Monad (when) +import System.Environment +import Control.Monad +import System.Process import Test.Tasty import Test.Tasty.HUnit @@ -15,102 +16,91 @@ highLevelTests :: TestTree -highLevelTests=testGroup "High Level tests" - [ testStartRepl - , testShowModules - ] +highLevelTests = testGroup "High Level tests" + [testStartRepl + ,testShowModules + ] testStartRepl :: TestTree testStartRepl = testCase "Start cabal repl" $ - do - root <- createTestProject - (ghci,load) <- startGhci "cabal repl" (Just root) False - stopGhci ghci - load @?= [ Loading "B.C" (normalise "src/B/C.hs") - , Loading "A" (normalise "src/A.hs") - ] + withTestProject $ \root -> do + (ghci,load) <- startGhci "cabal repl" (Just root) True + stopGhci ghci + load @?= [ Loading "B.C" (normalise "src/B/C.hs") + , Loading "A" (normalise "src/A.hs") + ] testShowModules :: TestTree testShowModules = testCase "Show Modules" $ - do - root <- createTestProject - (ghci,_) <- startGhci "cabal repl" (Just root) False - mods <- showModules ghci - stopGhci ghci - mods @?= [("A",normalise "src/A.hs"),("B.C",normalise "src/B/C.hs")] + withTestProject $ \root -> do + (ghci,_) <- startGhci "cabal repl" (Just root) True + mods <- showModules ghci + stopGhci ghci + mods @?= [("A",normalise "src/A.hs"),("B.C",normalise "src/B/C.hs")] -testProjectName :: String -testProjectName="BWTest" -testCabalContents :: String -testCabalContents = unlines ["name: "++testProjectName, - "version:0.1", - "cabal-version: >= 1.8", - "build-type: Simple", - "", - "library", - " hs-source-dirs: src", - " exposed-modules: A", - " other-modules: B.C", - " build-depends: base", - "", - "executable BWTest", - " hs-source-dirs: src", - " main-is: Main.hs", - " other-modules: B.D", - " build-depends: base", - " ghc-options: -dynamic", - "", - "test-suite BWTest-test", - " type: exitcode-stdio-1.0", - " hs-source-dirs: test", - " main-is: Main.hs", - " other-modules: TestA", - " build-depends: base", - "" - ] - -testCabalFile :: FilePath -> FilePath -testCabalFile root =root (last (splitDirectories root) <.> ".cabal") - -testAContents :: String -testAContents=unlines ["module A where","fA=undefined"] -testCContents :: String -testCContents=unlines ["module B.C where","fC=undefined"] -testDContents :: String -testDContents=unlines ["module B.D where","fD=undefined"] -testMainContents :: String -testMainContents=unlines ["module Main where","main=undefined"] -testMainTestContents :: String -testMainTestContents=unlines ["module Main where","main=undefined"] -testTestAContents :: String -testTestAContents=unlines ["module TestA where","fTA=undefined"] - -testSetupContents ::String -testSetupContents = unlines ["#!/usr/bin/env runhaskell", - "import Distribution.Simple", - "main :: IO ()", - "main = defaultMain"] - -createTestProject :: IO FilePath -createTestProject = do - temp<-getTemporaryDirectory - let root=temp testProjectName - ex<-doesDirectoryExist root - when ex (removeDirectoryRecursive root) - createDirectory root - writeFile (testCabalFile root) testCabalContents - writeFile (root "Setup.hs") testSetupContents - let srcF=root "src" - createDirectory srcF - writeFile (srcF "A.hs") testAContents - let b=srcF "B" - createDirectory b - writeFile (b "C.hs") testCContents - writeFile (b "D.hs") testDContents - writeFile (srcF "Main.hs") testMainContents - let testF=root "test" - createDirectory testF - writeFile (testF "Main.hs") testMainTestContents - writeFile (testF "TestA.hs") testTestAContents - return root +testFiles :: [(FilePath, [String])] +testFiles = + [(projectName <.> "cabal", + ["name: " ++ projectName + ,"version:0.1" + ,"cabal-version: >= 1.8" + ,"build-type: Simple" + ,"" + ,"library" + ," hs-source-dirs: src" + ," exposed-modules: A" + ," other-modules: B.C" + ," build-depends: base" + ,"" + ,"executable BWTest" + ," hs-source-dirs: src" + ," main-is: Main.hs" + ," other-modules: B.D" + ," build-depends: base" + ," ghc-options: -dynamic" + ,"" + ,"test-suite BWTest-test" + ," type: exitcode-stdio-1.0" + ," hs-source-dirs: test" + ," main-is: Main.hs" + ," other-modules: TestA" + ," build-depends: base"]) + ,("Setup.hs", + ["#!/usr/bin/env runhaskell" + ,"import Distribution.Simple" + ,"main :: IO ()" + ,"main = defaultMain"]) + ,("src/A.hs", + ["module A where" + ,"fA = undefined"]) + ,("src/B/C.hs", + ["module B.C where" + ,"fC = undefined"]) + ,("src/B/D.hs", + ["module B.D where" + ,"fD = undefined"]) + ,("src/Main.hs", + ["module Main where" + ,"main = undefined"]) + ,("test/Main.hs", + ["module Main where" + ,"main = undefined"]) + ,("test/TestA.hs", + ["module TestA where" + ,"fTA = undefined"]) + ] + +projectName = "BWTest" + +withTestProject :: (FilePath -> IO a) -> IO a +withTestProject act = withTempDir $ \dir -> do + forM_ testFiles $ \(name,contents) -> do + createDirectoryIfMissing True $ takeDirectory $ dir name + writeFile (dir name) $ unlines contents + env <- getEnvironment + let db = ["--package-db=" ++ x | x <- maybe [] splitSearchPath $ lookup "GHC_PACKAGE_PATH" env] + (_, _, _, pid) <- createProcess $ + (proc "cabal" $ "configure":db){env = Just $ filter ((/=) "GHC_PACKAGE_PATH" . fst) env, cwd = Just dir} + ExitSuccess <- waitForProcess pid + act dir diff --git a/src/Test/Parser.hs b/src/Test/Parser.hs --- a/src/Test/Parser.hs +++ b/src/Test/Parser.hs @@ -1,5 +1,5 @@ -- | Test the message parser -module Test.Parser +module Test.Parser ( parserTests )where @@ -12,20 +12,20 @@ parserTests :: TestTree parserTests=testGroup "Parser tests" - [ testShowModules + [ 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 @?= + [ 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"]} @@ -35,7 +35,7 @@ ] output1 :: [String] -output1= +output1= [ "[1 of 2] Compiling GHCi ( GHCi.hs, interpreted )" , "GHCi.hs:70:1: Parse error: naked expression at top level" , "GHCi.hs:72:13:" diff --git a/src/Test/Polling.hs b/src/Test/Polling.hs --- a/src/Test/Polling.hs +++ b/src/Test/Polling.hs @@ -1,7 +1,7 @@ {-# OPTIONS_GHC -fno-warn-unused-do-bind #-} -- | Test behavior of the executable, polling files for changes -module Test.Polling (pollingTest) where +module Test.Polling(pollingTest) where import Control.Concurrent import Control.Exception.Extra @@ -10,7 +10,6 @@ import Data.List.Extra import System.FilePath import System.Directory.Extra -import System.IO import System.Process import System.Console.CmdArgs import System.Time.Extra @@ -25,7 +24,6 @@ pollingTest :: TestTree pollingTest = testCase "Scripted Test" $ do setVerbosity Loud - hSetBuffering stdout NoBuffering tdir <- fmap ( ".ghcid") getTemporaryDirectory try_ $ removeDirectoryRecursive tdir createDirectoryIfMissing True tdir @@ -96,6 +94,9 @@ testScript :: (([String] -> IO ()) -> IO ()) -> IO () testScript require = do + writeFile <- return $ \name x -> do print ("writeFile",name,x); writeFile name x + renameFile <- return $ \from to -> do print ("renameFile",from,to); renameFile from to + writeFile "Main.hs" "x" require $ requireSimilar ["Main.hs:1:1"," Parse error: naked expression at top level"] writeFile "Util.hs" "module Util where" @@ -109,7 +110,7 @@ -- 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'"] + ,"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" @@ -119,9 +120,17 @@ writeFile "Util.hs" "module Util where" require requireAllGood + -- check recursive modules work + writeFile "Util.hs" "module Util where\nimport Main" + require $ requireSimilar ["imports form a cycle","Main.hs","Util.hs"] + writeFile "Util.hs" "module Util where" + require requireAllGood + -- check renaming files works -- note that due to GHC bug #9648 we can't save down a new file renameFile "Util.hs" "Util2.hs" require $ requireSimilar ["Main.hs:1:8:","Could not find module `Util'"] renameFile "Util2.hs" "Util.hs" require requireAllGood + -- after this point GHC bugs mean nothing really works too much +