diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -1,5 +1,5 @@ name: doctest -version: 0.6.1 +version: 0.7.0 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python @@ -30,13 +30,18 @@ hs-source-dirs: src other-modules: - Interpreter + Extract + , GhcUtil + , Interpreter + , Location , Options - , DocTest , Parse - , Extract - , GhcUtil , Paths_doctest + , Property + , Report + , Run + , Type + , Util build-depends: base >= 4.0 && < 4.6 , ghc >= 6.12 && < 7.6 @@ -45,7 +50,7 @@ , directory , process , ghc-paths == 0.1.* - , HUnit == 1.2.* + , transformers executable doctest main-is: @@ -53,32 +58,20 @@ ghc-options: -Wall -threaded hs-source-dirs: - src - other-modules: - Interpreter - , Options - , DocTest - , Parse - , Extract - , GhcUtil - , Paths_doctest + driver build-depends: base >= 4.0 && < 4.6 - , ghc >= 6.12 && < 7.6 - , syb - , deepseq - , directory - , process - , ghc-paths == 0.1.* - , HUnit == 1.2.* + , doctest test-suite spec - type: - exitcode-stdio-1.0 main-is: Spec.hs + type: + exitcode-stdio-1.0 ghc-options: -Wall -Werror -threaded + cpp-options: + -DTEST hs-source-dirs: src, test build-depends: @@ -89,8 +82,23 @@ , directory , process , ghc-paths == 0.1.* + , transformers , HUnit == 1.2.* + , hspec-discover , hspec-shouldbe - , transformers , stringbuilder + , silently , filepath + +test-suite doctests + main-is: + doctests.hs + type: + exitcode-stdio-1.0 + ghc-options: + -Wall -Werror -threaded + hs-source-dirs: + test + build-depends: + base + , doctest diff --git a/driver/Main.hs b/driver/Main.hs new file mode 100644 --- /dev/null +++ b/driver/Main.hs @@ -0,0 +1,6 @@ +module Main (main) where +import Test.DocTest +import System.Environment (getArgs) + +main :: IO () +main = getArgs >>= doctest diff --git a/src/DocTest.hs b/src/DocTest.hs deleted file mode 100644 --- a/src/DocTest.hs +++ /dev/null @@ -1,44 +0,0 @@ -module DocTest ( - getDocTests - , DocTest(..) - , Interaction(..) - , toTestCase - , toAssertion - ) where - -import Test.HUnit (Test(..), assertEqual, Assertion) -import qualified Interpreter -import Parse - - -toTestCase :: Interpreter.Interpreter -> DocTest -> Test -toTestCase repl test = TestLabel sourceFile $ TestCase $ toAssertion repl test - where - -- FIXME: use source location here - sourceFile = moduleName test - --- | --- Execute all expressions from given 'DocTest' in given --- 'Interpreter.Interpreter' and verify the output. --- --- The interpreter state is zeroed with @:reload@ before executing the --- expressions. This means that you can reuse the same --- 'Interpreter.Interpreter' for several calls to `toAssertion`. -toAssertion :: Interpreter.Interpreter -> DocTest -> Assertion -toAssertion repl test = do - _ <- Interpreter.eval repl $ ":reload" - _ <- Interpreter.eval repl $ ":m *" ++ moduleName test - mapM_ interactionToAssertion $ interactions test - where - interactionToAssertion x = do - result' <- Interpreter.eval repl exampleExpression - assertEqual ("expression `" ++ exampleExpression ++ "'") - exampleResult $ lines result' - where - exampleExpression = expression x - exampleResult = map subBlankLines $ result x - - -- interpret lines that only contain the string "" as an - -- empty line - subBlankLines "" = "" - subBlankLines line = line diff --git a/src/Extract.hs b/src/Extract.hs --- a/src/Extract.hs +++ b/src/Extract.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving, DeriveFunctor #-} module Extract (Module(..), extract) where import Prelude hiding (mod, catch) @@ -9,14 +9,17 @@ import Control.DeepSeq (deepseq, NFData(rnf)) import Data.Generics -import GHC hiding (flags, Module) +import GHC hiding (flags, Module, Located) import NameSet (NameSet) import Coercion (Coercion) import FastString (unpackFS) import Digraph (flattenSCCs) import GhcUtil (withGhc) +import Location hiding (unLoc) +import Util (convertDosLineEndings) + -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. newtype ExtractError = ExtractError SomeException deriving Typeable @@ -40,12 +43,14 @@ instance Exception ExtractError -- | Documentation for a module grouped together with the modules name. -data Module = Module { - moduleName :: String -, moduleDocumentation :: [String] -} deriving (Eq, Show) +data Module a = Module { + moduleName :: String +, moduleContent :: [a] +} deriving (Eq, Functor) -instance NFData Module where +deriving instance Show a => Show (Module a) + +instance NFData a => NFData (Module a) where rnf (Module name docs) = name `deepseq` docs `deepseq` () -- | Parse a list of modules. @@ -53,7 +58,7 @@ -> [String] -- ^ files/modules -> IO [TypecheckedModule] parse flags modules = withGhc flags $ do - mapM (flip guessTarget Nothing) modules >>= setTargets + mapM (`guessTarget` Nothing) modules >>= setTargets mods <- depanal [] False let sortedMods = flattenSCCs (topSortModuleGraph False mods Nothing) reverse <$> mapM (parseModule >=> typecheckModule >=> loadModule) sortedMods @@ -64,10 +69,10 @@ -- those modules (possibly indirect). extract :: [String] -- ^ flags -> [String] -- ^ files/modules - -> IO [Module] + -> IO [Module (Located String)] extract flags modules = do mods <- parse flags modules - let docs = map extractFromModule (map tm_parsed_module mods) + let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule . tm_parsed_module) mods (docs `deepseq` return docs) `catches` [ -- Re-throw AsyncException, otherwise execution will not terminate on @@ -79,15 +84,15 @@ ] -- | Extract all docstrings from given module and attach the modules name. -extractFromModule :: ParsedModule -> Module +extractFromModule :: ParsedModule -> Module (Located String) extractFromModule m = Module name docs where - docs = map unLoc (docStringsFromModule m) + docs = docStringsFromModule m name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m -- | Extract all docstrings from given module. docStringsFromModule :: ParsedModule -> [Located String] -docStringsFromModule mod = map (fmap unpackDocString) docs +docStringsFromModule mod = map (toLocated . fmap unpackDocString) docs where source = (unLoc . pm_parsed_source) mod diff --git a/src/GhcUtil.hs b/src/GhcUtil.hs --- a/src/GhcUtil.hs +++ b/src/GhcUtil.hs @@ -1,20 +1,21 @@ {-# LANGUAGE CPP #-} module GhcUtil (withGhc) where -import Control.Exception +import Control.Exception +import Control.Monad (void) -import GHC.Paths (libdir) -import GHC hiding (flags) -import DynFlags (dopt_set) +import GHC.Paths (libdir) +import GHC hiding (flags) +import DynFlags (dopt_set) -import MonadUtils (liftIO) -import System.Exit (exitFailure) +import MonadUtils (liftIO) +import System.Exit (exitFailure) #if __GLASGOW_HASKELL__ < 702 -import StaticFlags (v_opt_C_ready) -import Data.IORef (writeIORef) +import StaticFlags (v_opt_C_ready) +import Data.IORef (writeIORef) #else -import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) +import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) #endif @@ -55,7 +56,7 @@ (dynflags, rest, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= flip parseDynamicFlags flags case rest of x : _ -> error ("Unrecognized GHC option: " ++ unLoc x) - _ -> setSessionDynFlags dynflags >> return () + _ -> void (setSessionDynFlags dynflags) setHaddockMode :: DynFlags -> DynFlags setHaddockMode dynflags = (dopt_set dynflags Opt_Haddock) { diff --git a/src/Interpreter.hs b/src/Interpreter.hs --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,19 +1,20 @@ module Interpreter ( Interpreter , eval +, safeEval , withInterpreter ) where -import System.IO -import System.Process -import System.Exit -import System.Directory (getPermissions, executable) -import Control.Monad(when) -import Control.Exception (bracket) -import Data.Char -import Data.List +import System.IO +import System.Process +import System.Exit +import System.Directory (getPermissions, executable) +import Control.Monad (when, unless) +import Control.Exception hiding (handle) +import Data.Char +import Data.List -import GHC.Paths (ghc) +import GHC.Paths (ghc) -- | Truly random marker, used to separate expressions. -- @@ -35,7 +36,7 @@ -- in a perfect world this permission check should never fail, but I know of -- at least one case where it did.. x <- getPermissions ghc - when (not $ executable x) $ do + unless (executable x) $ do fail $ ghc ++ " is not executable!" (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc ghc myFlags) {std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle stdout} @@ -128,7 +129,7 @@ getResult :: Interpreter -> IO String getResult repl = do line <- hGetLine stdout_ - if isSuffixOf marker line + if marker `isSuffixOf` line then return $ stripMarker line else do @@ -146,3 +147,17 @@ eval repl expr = do putExpression repl expr getResult repl + +-- | Evaluate an expression; return a Left value on executions. +-- +-- Exceptions may e.g. be caused on unterminated multiline expressions. +safeEval :: Interpreter -> String -> IO (Either String String) +safeEval repl expression = (Right `fmap` Interpreter.eval repl expression) `catches` [ + -- Re-throw AsyncException, otherwise execution will not terminate on + -- SIGINT (ctrl-c). All AsyncExceptions are re-thrown (not just + -- UserInterrupt) because all of them indicate severe conditions and + -- should not occur during normal test runs. + Handler $ \e -> throw (e :: AsyncException), + + Handler $ \e -> (return . Left . show) (e :: SomeException) + ] diff --git a/src/Location.hs b/src/Location.hs new file mode 100644 --- /dev/null +++ b/src/Location.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE CPP, DeriveFunctor #-} +module Location where + +import Control.DeepSeq (deepseq, NFData(rnf)) +import SrcLoc hiding (Located) +import qualified SrcLoc as GHC +import FastString (unpackFS) + +#if __GLASGOW_HASKELL__ < 702 +import Outputable (showPpr) +#endif + +-- | A thing with a location attached. +data Located a = Located Location a + deriving (Eq, Show, Functor) + +instance NFData a => NFData (Located a) where + rnf (Located loc a) = loc `deepseq` a `deepseq` () + +-- | Convert a GHC located thing to a located thing. +toLocated :: GHC.Located a -> Located a +toLocated (L loc a) = Located (toLocation loc) a + +-- | Discard location information. +unLoc :: Located a -> a +unLoc (Located _ a) = a + +-- | Add dummy location information. +noLocation :: a -> Located a +noLocation = Located (UnhelpfulLocation "") + +-- | A line number. +type Line = Int + +-- | A combination of file name and line number. +data Location = UnhelpfulLocation String | Location FilePath Line + deriving Eq + +instance Show Location where + show (UnhelpfulLocation s) = s + show (Location file line) = file ++ ":" ++ show line + +instance NFData Location where + rnf (UnhelpfulLocation str) = str `deepseq` () + rnf (Location file line) = file `deepseq` line `deepseq` () + +-- | +-- Create a list from a location, by repeatedly increasing the line number by +-- one. +enumerate :: Location -> [Location] +enumerate loc = case loc of + UnhelpfulLocation _ -> repeat loc + Location file line -> map (Location file) [line ..] + +-- | Convert a GHC source span to a location. +toLocation :: SrcSpan -> Location +#if __GLASGOW_HASKELL__ < 702 +toLocation loc + | isGoodSrcLoc start = Location (unpackFS $ srcLocFile start) (srcLocLine start) + | otherwise = (UnhelpfulLocation . showPpr) start + where + start = srcSpanStart loc +#else +toLocation loc = case loc of + UnhelpfulSpan str -> UnhelpfulLocation (unpackFS str) + RealSrcSpan sp -> Location (unpackFS . srcSpanFile $ sp) (srcSpanStartLine sp) +#endif diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,41 +0,0 @@ -module Main where - -import Test.HUnit (runTestTT, Test(..), Counts(..)) -import System.Exit (exitSuccess, exitFailure) -import System.IO - -import Parse -import Options -import DocTest - -import qualified Interpreter - -main :: IO () -main = do - (options, files) <- getOptions - let ghciArgs = ghcOptions options ++ files - - -- get examples from Haddock comments - docTests <- getDocTests (ghcOptions options) files - - let (tCount, iCount) = (length docTests, length (concatMap interactions docTests)) - hPutStrLn stderr (formatTestAndInteractionCount tCount iCount) - - if DumpOnly `elem` options - then do - -- dump to stdout - print docTests - else do - -- map to unit tests - Interpreter.withInterpreter ghciArgs $ \repl -> do - let tests = TestList $ map (toTestCase repl) docTests - Counts _ _ errCount failCount <- runTestTT tests - if errCount == 0 && failCount == 0 - then exitSuccess - else exitFailure - - -formatTestAndInteractionCount :: Int -> Int -> String -formatTestAndInteractionCount 1 1 = "There is one test, with one single interaction." -formatTestAndInteractionCount 1 iCount = "There is one test, with " ++ show iCount ++ " interactions." -formatTestAndInteractionCount tCount iCount = "There are " ++ show tCount ++ " tests, with " ++ show iCount ++ " total interactions." diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -1,19 +1,18 @@ module Options ( Option(..) -, getOptions +, parseOptions , ghcOptions ) where -import Control.Monad (when) -import System.Environment (getArgs) -import System.Exit (exitSuccess, exitFailure) -import System.IO (hPutStr, stderr) +import Control.Monad (when, unless) +import System.Exit (exitSuccess, exitFailure) +import System.IO (hPutStr, stderr) -import System.Console.GetOpt +import System.Console.GetOpt -import Paths_doctest (version) -import Data.Version (showVersion) -import Config as GHC +import Paths_doctest (version) +import Data.Version (showVersion) +import Config as GHC data Option = Help | Version @@ -37,9 +36,8 @@ ] -getOptions :: IO ([Option], [String]) -getOptions = do - args <- getArgs +parseOptions :: [String] -> IO ([Option], [String]) +parseOptions args = do let (options, modules, errors) = getOpt Permute (documentedOptions ++ undocumentedOptions) args when (Help `elem` options) $ do @@ -51,7 +49,7 @@ putStrLn ("using version " ++ GHC.cProjectVersion ++ " of the GHC API") exitSuccess - when ((not . null) errors) $ do + unless (null errors) $ do tryHelp $ head errors when (null modules) $ do diff --git a/src/Parse.hs b/src/Parse.hs --- a/src/Parse.hs +++ b/src/Parse.hs @@ -1,10 +1,14 @@ module Parse ( - DocTest(..) -, Interaction(..) + Module (..) +, DocTest (..) +, Interaction (..) +, Expression +, ExpectedResult , getDocTests -- * exported for testing -, parse +, parseInteractions +, parseProperties ) where import Data.Char (isSpace) @@ -12,54 +16,73 @@ import Data.Maybe (fromMaybe) import Extract - -data DocTest = DocExample { - moduleName :: String -, interactions :: [Interaction] -} deriving (Eq, Show) +import Location +data DocTest = Example [Located Interaction] | Property (Located Expression) + deriving (Eq, Show) -data Interaction = Interaction { - expression :: String -- ^ example expression -, result :: [String] -- ^ expected result -} deriving (Eq, Show) +type Expression = String +type ExpectedResult = [String] +data Interaction = Interaction Expression ExpectedResult + deriving (Eq, Show) -- | -- Extract 'DocTest's from all given modules and all modules included by the -- given modules. -getDocTests :: [String] -- ^ List of GHC flags - -> [String] -- ^ File or module names - -> IO [DocTest] -- ^ Extracted 'DocTest's +getDocTests + :: [String] -- ^ List of GHC flags + -> [String] -- ^ File or module names + -> IO [Module DocTest] -- ^ Extracted 'DocTest's getDocTests flags modules = do mods <- extract flags modules - return (concatMap moduleToDocTest mods) + return (filter (not . null . moduleContent) $ map parseModule mods) --- | Convert a `Module` to a list of `DocTest`s. -moduleToDocTest :: Module -> [DocTest] -moduleToDocTest (Module name docs) = (map (DocExample name) . filter (not . null) . map parse) docs +-- | Convert documentation to `Example`s. +parseModule :: Module (Located String) -> Module DocTest +parseModule (Module name docs) = Module name (properties ++ examples) + where + examples = (map Example . filter (not . null) . map parseInteractions) docs + properties = [] -- (map Property . concatMap parseProperties) docs --- | Extract all interactions from given Haddock documentation. -parse :: String -> [Interaction] -parse input = go (map (reverse . dropWhile ((==) '\r') . reverse) $ lines input) +-- | Extract all properties from given Haddock comment. +parseProperties :: Located String -> [Located Expression] +parseProperties (Located loc input) = go $ zipWith Located (enumerate loc) (lines input) where - isPrompt = isPrefixOf ">>>" . dropWhile isSpace - isBlankLine = null . dropWhile isSpace + isPrompt :: Located String -> Bool + isPrompt = isPrefixOf "prop>" . dropWhile isSpace . unLoc + + go xs = case dropWhile (not . isPrompt) xs of + prop:rest -> stripPrompt `fmap` prop : go rest + [] -> [] + + stripPrompt = strip . drop 5 . dropWhile isSpace + +-- | Extract all interactions from given Haddock comment. +parseInteractions :: Located String -> [Located Interaction] +parseInteractions (Located loc input) = go $ zipWith Located (enumerate loc) (lines input) + where + isPrompt :: Located String -> Bool + isPrompt = isPrefixOf ">>>" . dropWhile isSpace . unLoc + + isBlankLine :: Located String -> Bool + isBlankLine = null . dropWhile isSpace . unLoc + + isEndOfInteraction :: Located String -> Bool isEndOfInteraction x = isPrompt x || isBlankLine x - go :: [String] -> [Interaction] - go xs = - case dropWhile (not . isPrompt) xs of - prompt:rest -> - let - (ys,zs) = break isEndOfInteraction rest - in - toInteraction prompt ys : go zs - _ -> [] + go :: [Located String] -> [Located Interaction] + go xs = case dropWhile (not . isPrompt) xs of + prompt:rest -> + let + (ys,zs) = break isEndOfInteraction rest + in + toInteraction prompt ys : go zs + [] -> [] -- | Create an `Interaction`, strip superfluous whitespace as appropriate. -toInteraction :: String -> [String] -> Interaction -toInteraction x xs = +toInteraction :: Located String -> [Located String] -> Located Interaction +toInteraction (Located loc x) xs = Located loc $ Interaction (strip $ drop 3 e) -- we do not care about leading and trailing -- whitespace in expressions, so drop them @@ -73,7 +96,7 @@ -- -- 3. interpret lines that only contain the string "" as an -- empty line - result_ = map (substituteBlankLine . tryStripPrefix prefix) xs + result_ = map (substituteBlankLine . tryStripPrefix prefix . unLoc) xs where tryStripPrefix pre ys = fromMaybe ys $ stripPrefix pre ys diff --git a/src/Property.hs b/src/Property.hs new file mode 100644 --- /dev/null +++ b/src/Property.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} +module Property ( + runProperty +#ifdef TEST +, freeVariables +, parseNotInScope +#endif +) where + +import Data.List + +import Util +import Interpreter (Interpreter) +import qualified Interpreter +import Type +import Location +import Parse + +runProperty :: Interpreter -> Located Expression -> IO DocTestResult +runProperty repl p@(Located _ expression) = do + _ <- Interpreter.eval repl "import Test.QuickCheck (quickCheck, (==>))" + r <- closeTerm expression >>= (Interpreter.safeEval repl . quickCheck) + case r of + Left err -> do + return (Error p err) + Right res + | "OK, passed" `isInfixOf` res -> return Success + | otherwise -> do + let msg = stripEnd (takeWhileEnd (/= '\b') res) + return (PropertyFailure p msg) + where + quickCheck term = "quickCheck (" ++ term ++ ")" + + -- | Find all free variables in given term, and close it by abstrating over + -- them. + closeTerm :: String -> IO String + closeTerm term = do + r <- freeVariables repl (quickCheck term) + case r of + [] -> return term + vars -> return ("\\" ++ unwords vars ++ "-> (" ++ term ++ ")") + +-- | Find all free variables in given term. +-- +-- GHCi is used to detect free variables. +freeVariables :: Interpreter -> String -> IO [String] +freeVariables repl term = do + r <- Interpreter.safeEval repl (":type " ++ term) + return (either (const []) (nub . parseNotInScope) r) + +-- | Parse and return all variables that are not in scope from a ghc error +-- message. +-- +-- >>> parseNotInScope ":4:1: Not in scope: `foo'" +-- ["foo"] +parseNotInScope :: String -> [String] +parseNotInScope = nub . map extractVariable . filter ("Not in scope: " `isInfixOf`) . lines + where + -- | Extract variable name from a "Not in scope"-error. + extractVariable :: String -> String + extractVariable = unquote . takeWhileEnd (/= ' ') + + -- | Remove quotes from given name, if any. + unquote ('`':xs) = init xs + unquote xs = xs diff --git a/src/Report.hs b/src/Report.hs new file mode 100644 --- /dev/null +++ b/src/Report.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE CPP #-} +module Report ( + runModules +, Summary(..) + +#ifdef TEST +, Report +, ReportState (..) +, report +, report_ +, reportFailure +, runProperty +, DocTestResult (..) +#endif +) where + +import Prelude hiding (putStr, putStrLn, error) +import Data.Monoid +import Control.Monad +import Text.Printf (printf) +import System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice) +import Data.Char + +import Control.Monad.Trans.State +import Control.Monad.IO.Class + +import Interpreter (Interpreter) +import qualified Interpreter +import Parse +import Location +import Type +import Property + +-- | Summary of a test run. +data Summary = Summary { + sExamples :: Int +, sTried :: Int +, sErrors :: Int +, sFailures :: Int +} + +-- | Format a summary. +instance Show Summary where + show (Summary examples tried errors failures) = + printf "Examples: %d Tried: %d Errors: %d Failures: %d" examples tried errors failures + +-- | Sum up summaries. +instance Monoid Summary where + mempty = Summary 0 0 0 0 + (Summary x1 x2 x3 x4) `mappend` (Summary y1 y2 y3 y4) = Summary (x1 + y1) (x2 + y2) (x3 + y3) (x4 + y4) + +-- | +-- Run all examples from given modules, return true if there were +-- errors/failures. +runModules :: Int -> Interpreter -> [Module DocTest] -> IO Bool +runModules exampleCount repl modules = do + isInteractive <- hIsTerminalDevice stderr + ReportState _ _ s <- (`execStateT` ReportState 0 isInteractive mempty {sExamples = exampleCount}) $ do + forM_ modules $ runModule repl + + -- report final summary + gets (show . reportStateSummary) >>= report + + return (sErrors s /= 0 || sFailures s /= 0) + +-- | A monad for generating test reports. +type Report = StateT ReportState IO + +data ReportState = ReportState { + reportStateCount :: Int -- ^ characters on the current line +, reportStateInteractive :: Bool -- ^ should intermediate results be printed? +, reportStateSummary :: Summary -- ^ test summary +} + +-- | Add output to the report. +report :: String -> Report () +report msg = do + overwrite msg + + -- add a newline, this makes the output permanent + liftIO $ hPutStrLn stderr "" + modify (\st -> st {reportStateCount = 0}) + +-- | Add intermediate output to the report. +-- +-- This will be overwritten by subsequent calls to `report`/`report_`. +-- Intermediate out may not contain any newlines. +report_ :: String -> Report () +report_ msg = do + f <- gets reportStateInteractive + when f $ do + overwrite msg + modify (\st -> st {reportStateCount = length msg}) + +-- | Add output to the report, overwrite any intermediate out. +overwrite :: String -> Report () +overwrite msg = do + n <- gets reportStateCount + let str | 0 < n = "\r" ++ msg ++ replicate (n - length msg) ' ' + | otherwise = msg + liftIO (hPutStr stderr str) + +-- | Run all examples from given module. +runModule :: Interpreter -> Module DocTest -> Report () +runModule repl (Module name examples) = do + forM_ examples $ \e -> do + + -- report intermediate summary + gets (show . reportStateSummary) >>= report_ + + r <- liftIO $ runDocTest repl name e + case r of + Success -> + success + Error (Located loc expression) err -> do + report (printf "### Error in %s: expression `%s'" (show loc) expression) + report err + error + InteractionFailure (Located loc (Interaction expression expected)) actual -> do + report (printf "### Failure in %s: expression `%s'" (show loc) expression) + reportFailure expected actual + failure + PropertyFailure (Located loc expression) msg -> do + report (printf "### Failure in %s: expression `%s'" (show loc) expression) + report msg + failure + where + success = updateSummary (Summary 0 1 0 0) + failure = updateSummary (Summary 0 1 0 1) + error = updateSummary (Summary 0 1 1 0) + + updateSummary summary = do + ReportState n f s <- get + put (ReportState n f $ s `mappend` summary) + +reportFailure :: [String] -> [String] -> Report () +reportFailure expected actual = do + outputLines "expected: " expected + outputLines " but got: " actual + where + + -- print quotes if any line ends with trailing whitespace + printQuotes = any isSpace (map last . filter (not . null) $ expected ++ actual) + + -- use show to escape special characters in output lines if any output line + -- contains any unsafe character + escapeOutput = any (not . isSafe) (concat $ expected ++ actual) + + isSafe :: Char -> Bool + isSafe c = c == ' ' || (isPrint c && (not . isSpace) c) + + outputLines message l_ = case l of + x:xs -> do + report (message ++ x) + let padding = replicate (length message) ' ' + forM_ xs $ \y -> report (padding ++ y) + [] -> + report message + where + l | printQuotes || escapeOutput = map show l_ + | otherwise = l_ + +runDocTest :: Interpreter -> String -> DocTest -> IO DocTestResult +runDocTest repl module_ docTest = do + _ <- Interpreter.eval repl ":reload" + _ <- Interpreter.eval repl $ ":m *" ++ module_ + case docTest of + Example xs -> runExample repl xs + Property p -> runProperty repl p + +-- | +-- Execute all expressions from given example in given +-- 'Interpreter' and verify the output. +-- +-- The interpreter state is zeroed with @:reload@ before executing the +-- expressions. This means that you can reuse the same +-- 'Interpreter' for several calls to `runExample`. +runExample :: Interpreter -> [Located Interaction] -> IO DocTestResult +runExample repl = go + where + go (i@(Located loc (Interaction expression expected)) : xs) = do + r <- fmap lines `fmap` Interpreter.safeEval repl expression + case r of + Left err -> do + return (Error (Located loc expression) err) + Right actual -> do + if expected /= actual + then + return (InteractionFailure i actual) + else + go xs + go [] = return Success diff --git a/src/Run.hs b/src/Run.hs new file mode 100644 --- /dev/null +++ b/src/Run.hs @@ -0,0 +1,63 @@ +module Run (doctest) where +import Data.Monoid +import Control.Monad (when) +import System.Exit (exitFailure) +import System.IO + +import Parse +import Options +import Report +import qualified Interpreter + +doctest :: [String] -> IO () +-- | Run doctest with given list of arguments. +-- +-- Example: +-- +-- >>> doctest ["--optghc=-iexample/src", "example/src/Example.hs"] +-- There are 2 tests, with 2 total interactions. +-- Examples: 2 Tried: 2 Errors: 0 Failures: 0 +-- +-- This can be used to create a Cabal test suite that runs doctest for your +-- project. +doctest args = do + (options, files) <- parseOptions args + let ghciArgs = ghcOptions options ++ files + + -- get examples from Haddock comments + modules <- getDocTests (ghcOptions options) files + + let c = (mconcat . map count) modules + hPrint stderr c + + if DumpOnly `elem` options + then do + -- dump to stdout + print modules + else do + -- run tests + Interpreter.withInterpreter ghciArgs $ \repl -> do + r <- runModules (exampleCount c) repl modules + when r exitFailure + where + exampleCount (Count n _) = n + +-- | Number of examples and interactions. +data Count = Count Int {- example count -} Int {- interaction count -} + +instance Monoid Count where + mempty = Count 0 0 + (Count x1 y1) `mappend` (Count x2 y2) = Count (x1 + x2) (y1 + y2) + +instance Show Count where + show (Count 1 1) = "There is one test, with one single interaction." + show (Count 1 iCount) = "There is one test, with " ++ show iCount ++ " interactions." + show (Count tCount iCount) = "There are " ++ show tCount ++ " tests, with " ++ show iCount ++ " total interactions." + +-- | Count number of examples and interactions in given module. +count :: Module DocTest -> Count +count (Module _ examples) = (mconcat . map f) examples + where + f :: DocTest -> Count + f (Example x) = Count 1 (length x) + f (Property _) = Count 1 1 diff --git a/src/Test/DocTest.hs b/src/Test/DocTest.hs --- a/src/Test/DocTest.hs +++ b/src/Test/DocTest.hs @@ -1,35 +1,5 @@ --- | --- An experimental API for extracting and executing `DocTest`s. --- --- Use 'getDocTests' to extract 'DocTest' examples from Haddock comments. To --- verify that the examples work turn them into 'Test.HUnit.Assertion's, using --- 'withInterpreter' and 'toAssertion'. After this just wrap the newly minted --- assertions into something suitable for your favorite test framework. module Test.DocTest ( - DocTest - , getDocTests - , sourcePath - , firstExpression - , toAssertion - , Interpreter - , withInterpreter - ) where - -import DocTest -import Interpreter (Interpreter) -import qualified Interpreter - --- | Instead of what the name suggests, this returns the module name, not the --- file name. -sourcePath :: DocTest -> FilePath -sourcePath = moduleName -{-# DEPRECATED sourcePath "this function will vanish in a future release" #-} - -firstExpression :: DocTest -> String -firstExpression test = expression $ head $ interactions test + doctest +) where -withInterpreter - :: [String] -- ^ List of flags, passed to GHC - -> (Interpreter -> IO a) -- ^ Action to run - -> IO a -- ^ Result of action -withInterpreter = Interpreter.withInterpreter +import Run diff --git a/src/Type.hs b/src/Type.hs new file mode 100644 --- /dev/null +++ b/src/Type.hs @@ -0,0 +1,12 @@ +module Type where + +import Location +import Parse + +-- | The result of evaluating an interaction. +data DocTestResult = + Success + | InteractionFailure (Located Interaction) [String] + | PropertyFailure (Located Expression) String + | Error (Located Expression) String + deriving (Eq, Show) diff --git a/src/Util.hs b/src/Util.hs new file mode 100644 --- /dev/null +++ b/src/Util.hs @@ -0,0 +1,26 @@ +module Util where +import Data.Char + +convertDosLineEndings :: String -> String +convertDosLineEndings = go + where + go input = case input of + '\r':'\n':xs -> '\n' : go xs + + -- Haddock comments from source files with dos line endings end with a + -- CR, so we strip that, too. + "\r" -> "" + + x:xs -> x : go xs + "" -> "" + +-- | Return the longest suffix of elements that satisfy a given predicate. +takeWhileEnd :: (a -> Bool) -> [a] -> [a] +takeWhileEnd p = reverse . takeWhile p . reverse + +-- | Remove trailing white space from a string. +-- +-- >>> stripEnd "foo " +-- "foo" +stripEnd :: String -> String +stripEnd = reverse . dropWhile isSpace . reverse diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,15 +1,1 @@ -module Main (main) where - -import Test.Hspec.ShouldBe - -import qualified ExtractSpec -import qualified ParseSpec -import qualified InterpreterSpec -import qualified MainSpec - -main :: IO () -main = hspecX $ do - describe "ExtractSpec" ExtractSpec.spec - describe "ParseSpec" ParseSpec.spec - describe "InterpreterSpec" InterpreterSpec.spec - describe "MainSpec" MainSpec.spec +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,13 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest [ + "--optghc=-packageghc" + , "--optghc=-isrc" + , "--optghc=-idist/build/autogen/" + , "--optghc=-optP-include" + , "--optghc=-optPdist/build/autogen/cabal_macros.h" + , "src/Run.hs" + ]