doctest 0.7.0 → 0.8.0
raw patch · 10 files changed
+175/−130 lines, 10 filesdep +QuickCheckdep +hspecdep −hspec-discoverdep −hspec-shouldbePVP ok
version bump matches the API change (PVP)
Dependencies added: QuickCheck, hspec
Dependencies removed: hspec-discover, hspec-shouldbe
API changes (from Hackage documentation)
Files
- doctest.cabal +5/−4
- src/Extract.hs +55/−10
- src/GhcUtil.hs +14/−10
- src/Help.hs +25/−0
- src/Interpreter.hs +6/−2
- src/Options.hs +0/−74
- src/Parse.hs +3/−6
- src/Report.hs +3/−3
- src/Run.hs +59/−16
- test/doctests.hs +5/−5
doctest.cabal view
@@ -1,5 +1,5 @@ name: doctest-version: 0.7.0+version: 0.8.0 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python@@ -34,7 +34,7 @@ , GhcUtil , Interpreter , Location- , Options+ , Help , Parse , Paths_doctest , Property@@ -48,6 +48,7 @@ , syb , deepseq , directory+ , filepath , process , ghc-paths == 0.1.* , transformers@@ -84,8 +85,8 @@ , ghc-paths == 0.1.* , transformers , HUnit == 1.2.*- , hspec-discover- , hspec-shouldbe+ , hspec >= 1.3+ , QuickCheck , stringbuilder , silently , filepath
src/Extract.hs view
@@ -10,11 +10,17 @@ import Data.Generics import GHC hiding (flags, Module, Located)+import MonadUtils (liftIO, MonadIO)+import Exception (ExceptionMonad)+import System.Directory+import System.FilePath import NameSet (NameSet) import Coercion (Coercion) import FastString (unpackFS) import Digraph (flattenSCCs) +import System.Posix.Internals (c_getpid)+ import GhcUtil (withGhc) import Location hiding (unLoc) @@ -54,24 +60,63 @@ rnf (Module name docs) = name `deepseq` docs `deepseq` () -- | Parse a list of modules.-parse :: [String] -- ^ flags- -> [String] -- ^ files/modules- -> IO [TypecheckedModule]-parse flags modules = withGhc flags $ do+parse :: [String] -> IO [TypecheckedModule]+parse args = withGhc args $ \modules -> withTempOutputDir $ do mapM (`guessTarget` Nothing) modules >>= setTargets mods <- depanal [] False- let sortedMods = flattenSCCs (topSortModuleGraph False mods Nothing)++ mods' <- if needsTemplateHaskell mods then enableCompilation mods else return mods++ let sortedMods = flattenSCCs (topSortModuleGraph False mods' Nothing) reverse <$> mapM (parseModule >=> typecheckModule >=> loadModule) sortedMods+ where+ -- copied from Haddock/Interface.hs+ enableCompilation :: ModuleGraph -> Ghc ModuleGraph+ enableCompilation modGraph = do+ let enableComp d = d { hscTarget = defaultObjectTarget }+ modifySessionDynFlags enableComp+ -- We need to update the DynFlags of the ModSummaries as well.+ let upd m = m { ms_hspp_opts = enableComp (ms_hspp_opts m) }+ let modGraph' = map upd modGraph+ return modGraph' + -- copied Haddock/GhcUtils.hs+ modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc ()+ modifySessionDynFlags f = do+ dflags <- getSessionDynFlags+ _ <- setSessionDynFlags (f dflags)+ return ()++ withTempOutputDir :: Ghc a -> Ghc a+ withTempOutputDir action = do+ tmp <- liftIO getTemporaryDirectory+ x <- liftIO c_getpid+ let dir = tmp </> ".doctest-" ++ show x+ modifySessionDynFlags (setOutputDir dir)+ gbracket_+ (liftIO $ createDirectory dir)+ (liftIO $ removeDirectoryRecursive dir)+ action++ -- | A variant of 'gbracket' where the return value from the first computation+ -- is not required.+ gbracket_ :: ExceptionMonad m => m a -> m b -> m c -> m c+ gbracket_ before_ after thing = gbracket before_ (const after) (const thing)++ setOutputDir f d = d {+ objectDir = Just f+ , hiDir = Just f+ , stubDir = Just f+ , includePaths = f : includePaths d+ }+ -- | Extract all docstrings from given list of files/modules. -- -- This includes the docstrings of all local modules that are imported from -- those modules (possibly indirect).-extract :: [String] -- ^ flags- -> [String] -- ^ files/modules- -> IO [Module (Located String)]-extract flags modules = do- mods <- parse flags modules+extract :: [String] -> IO [Module (Located String)]+extract args = do+ mods <- parse args let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule . tm_parsed_module) mods (docs `deepseq` return docs) `catches` [
src/GhcUtil.hs view
@@ -2,11 +2,10 @@ module GhcUtil (withGhc) where import Control.Exception-import Control.Monad (void)- import GHC.Paths (libdir) import GHC hiding (flags) import DynFlags (dopt_set)+import Panic (ghcError) import MonadUtils (liftIO) import System.Exit (exitFailure)@@ -40,23 +39,28 @@ liftIO exitFailure -- | Run a GHC action in Haddock mode-withGhc :: [String] -> Ghc a -> IO a+withGhc :: [String] -> ([String] -> Ghc a) -> IO a withGhc flags action = bracketStaticFlags $ do flags_ <- handleStaticFlags flags runGhc (Just libdir) $ do- handleDynamicFlags flags_- handleSrcErrors action+ handleDynamicFlags flags_ >>= handleSrcErrors . action handleStaticFlags :: [String] -> IO [Located String] handleStaticFlags flags = fst `fmap` parseStaticFlags (map noLoc flags) -handleDynamicFlags :: GhcMonad m => [Located String] -> m ()+handleDynamicFlags :: GhcMonad m => [Located String] -> m [String] handleDynamicFlags flags = do- (dynflags, rest, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= flip parseDynamicFlags flags- case rest of- x : _ -> error ("Unrecognized GHC option: " ++ unLoc x)- _ -> void (setSessionDynFlags dynflags)+ (dynflags, locSrcs, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= flip parseDynamicFlags flags+ _ <- setSessionDynFlags dynflags++ -- We basically do the same thing as `ghc/Main.hs` to distinguish+ -- "unrecognised flags" from source files.+ let srcs = map unLoc locSrcs+ unknown_opts = [ f | f@('-':_) <- srcs ]+ case unknown_opts of+ opt : _ -> ghcError (UsageError ("unrecognized option `"++ opt ++ "'"))+ _ -> return srcs setHaddockMode :: DynFlags -> DynFlags setHaddockMode dynflags = (dopt_set dynflags Opt_Haddock) {
+ src/Help.hs view
@@ -0,0 +1,25 @@+module Help (+ usage+, printVersion+) where++import Paths_doctest (version)+import Data.Version (showVersion)+import Config as GHC++usage :: String+usage = unlines [+ "Usage:"+ , " doctest [ GHC OPTION | MODULE ]..."+ , " doctest --help"+ , " doctest --version"+ , ""+ , "Options:"+ , " --help display this help and exit"+ , " --version output version information and exit"+ ]++printVersion :: IO ()+printVersion = do+ putStrLn ("doctest version " ++ showVersion version)+ putStrLn ("using version " ++ GHC.cProjectVersion ++ " of the GHC API")
src/Interpreter.hs view
@@ -39,10 +39,14 @@ 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}+ (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc ghc myFlags) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit} setMode stdin_ setMode stdout_- return Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle}+ let interpreter = Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle}+ _ <- eval interpreter "import System.IO"+ _ <- eval interpreter "import GHC.IO.Handle"+ _ <- eval interpreter "hDuplicateTo stdout stderr"+ return interpreter where myFlags = ["-v0", "--interactive", "-ignore-dot-ghci"] ++ flags
− src/Options.hs
@@ -1,74 +0,0 @@-module Options (- Option(..)-, parseOptions-, ghcOptions-) where--import Control.Monad (when, unless)-import System.Exit (exitSuccess, exitFailure)-import System.IO (hPutStr, stderr)--import System.Console.GetOpt--import Paths_doctest (version)-import Data.Version (showVersion)-import Config as GHC--data Option = Help- | Version- | Verbose- | GhcOption String- | DumpOnly- deriving (Show, Eq)---documentedOptions :: [OptDescr Option]-documentedOptions = [- Option [] ["help"] (NoArg Help) "display this help and exit"- , Option [] ["version"] (NoArg Version) "output version information and exit"- , Option ['v'] ["verbose"] (NoArg Verbose) "explain what is being done, enable Haddock warnings"- , Option [] ["optghc"] (ReqArg GhcOption "OPTION") "option to be forwarded to GHC"- ]--undocumentedOptions :: [OptDescr Option]-undocumentedOptions = [- Option [] ["dump-only"] (NoArg DumpOnly) "dump extracted test cases to stdout"- ]---parseOptions :: [String] -> IO ([Option], [String])-parseOptions args = do- let (options, modules, errors) = getOpt Permute (documentedOptions ++ undocumentedOptions) args-- when (Help `elem` options) $ do- putStr usage- exitSuccess-- when (Version `elem` options) $ do- putStrLn ("doctest version " ++ showVersion version)- putStrLn ("using version " ++ GHC.cProjectVersion ++ " of the GHC API")- exitSuccess-- unless (null errors) $ do- tryHelp $ head errors-- when (null modules) $ do- tryHelp "no input files\n"-- return (options, modules)- where- usage = usageInfo "Usage: doctest [OPTION]... MODULE...\n" documentedOptions-- tryHelp message = do- hPutStr stderr $ "doctest: " ++ message ++ "Try `doctest --help' for more information.\n"- exitFailure----- | Extract all ghc options from given list of options.------ Example:------ >>> ghcOptions [Help, GhcOption "-foo", Verbose, GhcOption "-bar"]--- ["-foo","-bar"]-ghcOptions :: [Option] -> [String]-ghcOptions opts = [ option | GhcOption option <- opts ]
src/Parse.hs view
@@ -30,12 +30,9 @@ -- | -- 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 [Module DocTest] -- ^ Extracted 'DocTest's-getDocTests flags modules = do- mods <- extract flags modules+getDocTests :: [String] -> IO [Module DocTest] -- ^ Extracted 'DocTest's+getDocTests args = do+ mods <- extract args return (filter (not . null . moduleContent) $ map parseModule mods) -- | Convert documentation to `Example`s.
src/Report.hs view
@@ -37,7 +37,7 @@ , sTried :: Int , sErrors :: Int , sFailures :: Int-}+} deriving Eq -- | Format a summary. instance Show Summary where@@ -52,7 +52,7 @@ -- | -- Run all examples from given modules, return true if there were -- errors/failures.-runModules :: Int -> Interpreter -> [Module DocTest] -> IO Bool+runModules :: Int -> Interpreter -> [Module DocTest] -> IO Summary runModules exampleCount repl modules = do isInteractive <- hIsTerminalDevice stderr ReportState _ _ s <- (`execStateT` ReportState 0 isInteractive mempty {sExamples = exampleCount}) $ do@@ -61,7 +61,7 @@ -- report final summary gets (show . reportStateSummary) >>= report - return (sErrors s /= 0 || sFailures s /= 0)+ return s -- | A monad for generating test reports. type Report = StateT ReportState IO
src/Run.hs view
@@ -1,46 +1,89 @@-module Run (doctest) where+{-# LANGUAGE CPP #-}+module Run (+ doctest+#ifdef TEST+, doctest_+, Summary+, stripOptGhc+#endif+) where++import Prelude hiding (catch) import Data.Monoid+import Data.List import Control.Monad (when) import System.Exit (exitFailure) import System.IO +import Control.Exception+import Panic+ import Parse-import Options+import Help import Report import qualified Interpreter -doctest :: [String] -> IO () -- | Run doctest with given list of arguments. -- -- Example: ----- >>> doctest ["--optghc=-iexample/src", "example/src/Example.hs"]+-- >>> doctest ["-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 :: [String] -> IO () doctest args = do- (options, files) <- parseOptions args- let ghciArgs = ghcOptions options ++ files+ case args of+ ["--help"] -> do+ putStr usage+ ["--version"] ->+ printVersion+ _ -> do+ let (f, args_) = stripOptGhc args+ when f $ do+ hPutStrLn stderr "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly."+ hFlush stderr+ r <- doctest_ args_ `catch` \e -> do+ case fromException e of+ Just (UsageError err) -> do+ hPutStrLn stderr ("doctest: " ++ err)+ hPutStrLn stderr "Try `doctest --help' for more information."+ exitFailure+ _ -> throw e+ when (not $ isSuccess r) exitFailure +-- |+-- Strip --optghc from GHC options. This is for backward compatibility with+-- previous versions of doctest.+--+-- A boolean is returned with the stripped arguments. It is True if striping+-- occurred.+stripOptGhc :: [String] -> (Bool, [String])+stripOptGhc = go+ where+ go args = case args of+ [] -> (False, [])+ "--optghc" : opt : rest -> (True, opt : snd (go rest))+ opt : rest -> maybe (fmap (opt :)) (\x (_, xs) -> (True, x :xs)) (stripPrefix "--optghc=" opt) (go rest)++doctest_ :: [String] -> IO Summary+doctest_ args = do+ -- get examples from Haddock comments- modules <- getDocTests (ghcOptions options) files+ modules <- getDocTests args 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+ Interpreter.withInterpreter args $ \repl -> do+ runModules (exampleCount c) repl modules where exampleCount (Count n _) = n++isSuccess :: Summary -> Bool+isSuccess s = sErrors s == 0 && sFailures s == 0 -- | Number of examples and interactions. data Count = Count Int {- example count -} Int {- interaction count -}
test/doctests.hs view
@@ -4,10 +4,10 @@ main :: IO () main = doctest [- "--optghc=-packageghc"- , "--optghc=-isrc"- , "--optghc=-idist/build/autogen/"- , "--optghc=-optP-include"- , "--optghc=-optPdist/build/autogen/cabal_macros.h"+ "-packageghc"+ , "-isrc"+ , "-idist/build/autogen/"+ , "-optP-include"+ , "-optPdist/build/autogen/cabal_macros.h" , "src/Run.hs" ]