diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -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 diff --git a/src/Extract.hs b/src/Extract.hs --- a/src/Extract.hs +++ b/src/Extract.hs @@ -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` [ diff --git a/src/GhcUtil.hs b/src/GhcUtil.hs --- a/src/GhcUtil.hs +++ b/src/GhcUtil.hs @@ -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) { diff --git a/src/Help.hs b/src/Help.hs new file mode 100644 --- /dev/null +++ b/src/Help.hs @@ -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") diff --git a/src/Interpreter.hs b/src/Interpreter.hs --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -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 diff --git a/src/Options.hs b/src/Options.hs deleted file mode 100644 --- a/src/Options.hs +++ /dev/null @@ -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 ] diff --git a/src/Parse.hs b/src/Parse.hs --- a/src/Parse.hs +++ b/src/Parse.hs @@ -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. diff --git a/src/Report.hs b/src/Report.hs --- a/src/Report.hs +++ b/src/Report.hs @@ -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 diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -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 -} diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -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" ]