ghcid 0.5 → 0.5.1
raw patch · 14 files changed
+271/−236 lines, 14 filesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- Language.Haskell.Ghcid: loadFile :: Load -> FilePath
- Language.Haskell.Ghcid: loadFilePos :: Load -> (Int, Int)
- Language.Haskell.Ghcid: loadMessage :: Load -> [String]
- Language.Haskell.Ghcid: loadModule :: Load -> String
- Language.Haskell.Ghcid: loadSeverity :: Load -> Severity
+ Language.Haskell.Ghcid: [loadFilePos] :: Load -> (Int, Int)
+ Language.Haskell.Ghcid: [loadFile] :: Load -> FilePath
+ Language.Haskell.Ghcid: [loadMessage] :: Load -> [String]
+ Language.Haskell.Ghcid: [loadModule] :: Load -> String
+ Language.Haskell.Ghcid: [loadSeverity] :: Load -> Severity
Files
- CHANGES.txt +8/−0
- LICENSE +1/−1
- README.md +2/−1
- ghcid.cabal +12/−12
- src/Ghcid.hs +51/−33
- src/Language/Haskell/Ghcid.hs +15/−20
- src/Language/Haskell/Ghcid/Parser.hs +37/−31
- src/Language/Haskell/Ghcid/Terminal.hs +3/−1
- src/Language/Haskell/Ghcid/Types.hs +15/−9
- src/Language/Haskell/Ghcid/Util.hs +7/−10
- src/Test.hs +14/−11
- src/Test/HighLevel.hs +86/−96
- src/Test/Parser.hs +7/−7
- src/Test/Polling.hs +13/−4
CHANGES.txt view
@@ -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
LICENSE view
@@ -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
README.md view
@@ -1,4 +1,4 @@-# ghcid [](https://hackage.haskell.org/package/ghcid) [](https://travis-ci.org/ndmitchell/ghcid)+# ghcid [](https://hackage.haskell.org/package/ghcid) [](https://www.stackage.org/package/ghcid) [](https://travis-ci.org/ndmitchell/ghcid) [](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).
ghcid.cabal view
@@ -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 <ndmitchell@gmail.com>, jpmoresmau maintainer: Neil Mitchell <ndmitchell@gmail.com>-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,
src/Ghcid.hs view
@@ -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
src/Language/Haskell/Ghcid.hs view
@@ -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)
src/Language/Haskell/Ghcid/Parser.hs view
@@ -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 "<no location info>: 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 "<no location info>: 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 [] = []
src/Language/Haskell/Ghcid/Terminal.hs view
@@ -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
src/Language/Haskell/Ghcid/Types.hs view
@@ -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
src/Language/Haskell/Ghcid/Util.hs view
@@ -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
src/Test.hs view
@@ -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+ ]
src/Test/HighLevel.hs view
@@ -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
src/Test/Parser.hs view
@@ -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:"
src/Test/Polling.hs view
@@ -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+