diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2009 Simon Hengel +Copyright (c) 2009, 2010, 2011 Simon Hengel Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -1,14 +1,14 @@ name: doctest -version: 0.3.0 +version: 0.4.0 stability: experimental synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python (). . - Documentation is at . + Documentation is at . category: Testing -homepage: http://haskell.org/haskellwiki/DocTest +homepage: https://github.com/sol/doctest-haskell#readme license: MIT license-file: LICENSE copyright: (c) 2009-2011 Simon Hengel @@ -21,6 +21,26 @@ type: git location: git://github.com/sol/doctest-haskell.git +library + ghc-options: -Wall + hs-source-dirs: src + exposed-modules: Test.DocTest + other-modules: + Interpreter + , Options + , HaddockBackend.Api + , HaddockBackend.Markup + , DocTest + + build-depends: + base >= 4.0 && < 4.4 + , containers >= 0.3 && < 0.5 + , haddock >= 2.8 && < 2.10 + , ghc >= 6.12 && < 7.2 + , ghc-paths == 0.1.* + , HUnit == 1.2.* + , process == 1.0.* + executable doctest ghc-options: -Wall hs-source-dirs: src @@ -30,6 +50,7 @@ , Options , HaddockBackend.Api , HaddockBackend.Markup + , DocTest build-depends: base >= 4.0 && < 4.4 diff --git a/src/DocTest.hs b/src/DocTest.hs new file mode 100644 --- /dev/null +++ b/src/DocTest.hs @@ -0,0 +1,44 @@ +module DocTest ( + getDocTests + , DocTest(..) + , Interaction(..) + , toTestCase + , toAssertion + ) where + +import Test.HUnit (Test(..), assertEqual, Assertion) +import qualified Interpreter +import HaddockBackend.Api + + +toTestCase :: Interpreter.Interpreter -> DocTest -> Test +toTestCase repl test = TestLabel sourceFile $ TestCase $ toAssertion repl test + where + sourceFile = source 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 $ ":m *" ++ moduleName + _ <- Interpreter.eval repl $ ":reload" + mapM_ interactionToAssertion $ interactions test + where + moduleName = module_ test + 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/HaddockBackend/Api.hs b/src/HaddockBackend/Api.hs --- a/src/HaddockBackend/Api.hs +++ b/src/HaddockBackend/Api.hs @@ -20,19 +20,24 @@ source :: String -- ^ source file , module_ :: String -- ^ originating module , interactions :: [Interaction] -} deriving (Eq, Show, Read) +} deriving (Show) data Interaction = Interaction { expression :: String -- ^ example expression , result :: [String] -- ^ expected result -} deriving (Eq, Show, Read) +} deriving (Show) --- | Extract 'DocTest's -getDocTests :: [Flag] -- ^ list of Haddock command-line flags - -> [String] -- ^ file or module names - -> IO [DocTest] -- ^ extracted 'DocTest's +-- | +-- Extract 'DocTest's from all given modules and all modules included by the +-- given modules. +-- +-- Note that this function can be called only once during process lifetime, so +-- use it wisely. +getDocTests :: [Flag] -- ^ List of Haddock flags + -> [String] -- ^ File or module names + -> IO [DocTest] -- ^ Extracted 'DocTest's getDocTests flags modules = do interfaces <- createInterfaces flags modules return $ concat $ map docTestsFromInterface interfaces diff --git a/src/Interpreter.hs b/src/Interpreter.hs --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -6,6 +6,8 @@ import System.IO import System.Process +import System.Exit +import Control.Monad(when) import Control.Exception (bracket) import Data.Char import Data.List @@ -23,14 +25,15 @@ data Interpreter = Interpreter { hIn :: Handle , hOut :: Handle + , process :: ProcessHandle } newInterpreter :: [String] -> IO Interpreter newInterpreter flags = do - (Just stdin_, Just stdout_, Nothing, _) <- createProcess $ (proc ghc myFlags) {std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle stdout} + (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc ghc myFlags) {std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle stdout} setMode stdin_ setMode stdout_ - return Interpreter {hIn = stdin_, hOut = stdout_} + return Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle} where myFlags = ["-v0", "--interactive", "-ignore-dot-ghci"] ++ flags @@ -56,8 +59,17 @@ closeInterpreter :: Interpreter -> IO () closeInterpreter repl = do hClose $ hIn repl + + -- It is crucial not to close `hOut` before calling `waitForProcess`, + -- otherwise ghci may not cleanly terminate on SIGINT (ctrl-c) and hang + -- around consuming 100% CPU. This happens when ghci tries to print + -- something to stdout in its signal handler (e.g. when it is blocked in + -- threadDelay it writes "Interrupted." on SIGINT). + e <- waitForProcess $ process repl hClose $ hOut repl + when (e /= ExitSuccess) $ error $ "Interpreter exited with an error: " ++ show e + return () putExpression :: Interpreter -> String -> IO () putExpression repl e = do diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,9 +1,10 @@ module Main where -import Test.HUnit (runTestTT, Test(..), assertEqual) +import Test.HUnit (runTestTT, Test(..)) import HaddockBackend.Api import Options +import DocTest import qualified Interpreter @@ -26,25 +27,3 @@ let tests = TestList $ map (toTestCase repl) docTests _ <- runTestTT tests return () - -toTestCase :: Interpreter.Interpreter -> DocTest -> Test -toTestCase repl test = TestLabel sourceFile $ TestCase $ do - -- bring module into scope before running tests.. - _ <- Interpreter.eval repl $ ":m *" ++ moduleName - _ <- Interpreter.eval repl $ ":reload" - mapM_ interactionToAssertion $ interactions test - where - moduleName = module_ test - sourceFile = source test - 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/Test/DocTest.hs b/src/Test/DocTest.hs new file mode 100644 --- /dev/null +++ b/src/Test/DocTest.hs @@ -0,0 +1,33 @@ +-- | +-- 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 HaddockBackend.Api +import DocTest +import Interpreter (Interpreter) +import qualified Interpreter + +sourcePath :: DocTest -> FilePath +sourcePath = source + +firstExpression :: DocTest -> String +firstExpression test = expression $ head $ interactions test + +withInterpreter + :: [String] -- ^ List of flags, passed to GHC + -> (Interpreter -> IO a) -- ^ Action to run + -> IO a -- ^ Result of action +withInterpreter = Interpreter.withInterpreter