doctest-0.9.10/0000755000000000000000000000000012242512204011426 5ustar0000000000000000doctest-0.9.10/LICENSE0000644000000000000000000000206712242512204012440 0ustar0000000000000000Copyright (c) 2009-2013 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 in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. doctest-0.9.10/doctest.cabal0000644000000000000000000000463412242512204014066 0ustar0000000000000000name: doctest version: 0.9.10 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 . category: Testing bug-reports: https://github.com/sol/doctest-haskell/issues homepage: https://github.com/sol/doctest-haskell#readme license: MIT license-file: LICENSE copyright: (c) 2009-2013 Simon Hengel author: Simon Hengel maintainer: Simon Hengel build-type: Simple cabal-version: >= 1.8 extra-source-files: example/example.cabal , example/src/Example.hs , example/test/doctests.hs source-repository head type: git location: https://github.com/sol/doctest-haskell library exposed-modules: Test.DocTest ghc-options: -Wall hs-source-dirs: src other-modules: Extract , GhcUtil , Interpreter , Location , Help , Parse , Paths_doctest , Property , Runner , Runner.Example , Run , Util , Sandbox build-depends: base == 4.* , ghc >= 7.0 && < 7.8 , syb >= 0.3 && < 0.5 , deepseq , directory , filepath , process , ghc-paths >= 0.1.0.9 , transformers executable doctest main-is: Main.hs ghc-options: -Wall -threaded hs-source-dirs: driver build-depends: base == 4.* , doctest test-suite spec main-is: Spec.hs type: exitcode-stdio-1.0 ghc-options: -Wall -Werror -threaded cpp-options: -DTEST hs-source-dirs: src, test c-sources: test/integration/with-cbits/foo.c build-depends: base , ghc , syb , deepseq , directory , filepath , process , ghc-paths , transformers , HUnit , hspec >= 1.5.1 , QuickCheck >= 2.5 , stringbuilder >= 0.4 , silently >= 1.2.4 , setenv 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 doctest-0.9.10/Setup.lhs0000644000000000000000000000011412242512204013232 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain doctest-0.9.10/test/0000755000000000000000000000000012242512204012405 5ustar0000000000000000doctest-0.9.10/test/doctests.hs0000644000000000000000000000034112242512204014567 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = doctest [ "-packageghc" , "-isrc" , "-idist/build/autogen/" , "-optP-include" , "-optPdist/build/autogen/cabal_macros.h" , "src/Run.hs" ] doctest-0.9.10/test/Spec.hs0000644000000000000000000000005412242512204013632 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} doctest-0.9.10/test/integration/0000755000000000000000000000000012242512204014730 5ustar0000000000000000doctest-0.9.10/test/integration/with-cbits/0000755000000000000000000000000012242512204017005 5ustar0000000000000000doctest-0.9.10/test/integration/with-cbits/foo.c0000644000000000000000000000003312242512204017730 0ustar0000000000000000int foo() { return 23; } doctest-0.9.10/example/0000755000000000000000000000000012242512204013061 5ustar0000000000000000doctest-0.9.10/example/example.cabal0000644000000000000000000000056612242512204015507 0ustar0000000000000000name: example version: 0.0.0 build-type: Simple cabal-version: >= 1.8 library hs-source-dirs: src exposed-modules: Example build-depends: base test-suite doctests type: exitcode-stdio-1.0 hs-source-dirs: test main-is: doctests.hs ghc-options: -threaded build-depends: base, doctest >= 0.8 doctest-0.9.10/example/test/0000755000000000000000000000000012242512204014040 5ustar0000000000000000doctest-0.9.10/example/test/doctests.hs0000644000000000000000000000015312242512204016223 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = doctest ["-isrc", "src/Example.hs"] doctest-0.9.10/example/src/0000755000000000000000000000000012242512204013650 5ustar0000000000000000doctest-0.9.10/example/src/Example.hs0000644000000000000000000000012512242512204015575 0ustar0000000000000000module Example where -- | -- >>> foo -- 23 foo = 23 -- | -- >>> bar -- 42 bar = 42 doctest-0.9.10/driver/0000755000000000000000000000000012242512204012721 5ustar0000000000000000doctest-0.9.10/driver/Main.hs0000644000000000000000000000021712242512204014141 0ustar0000000000000000module Main (main) where import Test.DocTest import System.Environment (getArgs) main :: IO () main = getArgs >>= doctest doctest-0.9.10/src/0000755000000000000000000000000012242512204012215 5ustar0000000000000000doctest-0.9.10/src/Help.hs0000644000000000000000000000131512242512204013441 0ustar0000000000000000module Help ( usage , printVersion ) where import Paths_doctest (version) import Data.Version (showVersion) import Config as GHC import Interpreter (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") putStrLn ("using " ++ ghc) doctest-0.9.10/src/Interpreter.hs0000644000000000000000000001373412242512204015064 0ustar0000000000000000module Interpreter ( Interpreter , eval , safeEval , withInterpreter , ghc , interpreterSupported -- exported for testing , ghcInfo , haveInterpreterKey ) where import System.IO import System.Process import System.Exit import System.Directory (getPermissions, executable) import Control.Monad (when, unless) import Control.Applicative import Control.Exception hiding (handle) import Data.Char import Data.List import GHC.Paths (ghc) import Sandbox (getSandboxArguments) -- | Truly random marker, used to separate expressions. -- -- IMPORTANT: This module relies upon the fact that this marker is unique. It -- has been obtained from random.org. Do not expect this module to work -- properly, if you reuse it for any purpose! marker :: String marker = show "dcbd2a1e20ae519a1c7714df2859f1890581d57fac96ba3f499412b2f5c928a1" data Interpreter = Interpreter { hIn :: Handle , hOut :: Handle , process :: ProcessHandle } haveInterpreterKey :: String haveInterpreterKey = "Have interpreter" ghcInfo :: IO [(String, String)] ghcInfo = read <$> readProcess ghc ["--info"] [] interpreterSupported :: IO Bool interpreterSupported = do -- in a perfect world this permission check should never fail, but I know of -- at least one case where it did.. x <- getPermissions ghc unless (executable x) $ do fail $ ghc ++ " is not executable!" maybe False (== "YES") . lookup haveInterpreterKey <$> ghcInfo newInterpreter :: [String] -> IO Interpreter newInterpreter flags = do sandboxFlags <- getSandboxArguments let myFlags = ghciFlags ++ flags ++ sandboxFlags -- get examples from Haddock comments (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc ghc myFlags) {std_in = CreatePipe, std_out = CreatePipe, std_err = Inherit} setMode stdin_ setMode stdout_ let interpreter = Interpreter {hIn = stdin_, hOut = stdout_, process = processHandle} _ <- eval interpreter "import System.IO" _ <- eval interpreter "import GHC.IO.Handle" -- The buffering of stdout and stderr is NoBuffering _ <- eval interpreter "hDuplicateTo stdout stderr" -- Now the buffering of stderr is BlockBuffering Nothing -- In this situation, GHC 7.7 does not flush the buffer even when -- error happens. _ <- eval interpreter "hSetBuffering stdout LineBuffering" _ <- eval interpreter "hSetBuffering stderr LineBuffering" -- this is required on systems that don't use utf8 as default encoding (e.g. -- Windows) _ <- eval interpreter "hSetEncoding stdout utf8" _ <- eval interpreter "hSetEncoding stderr utf8" return interpreter where ghciFlags = ["-v0", "--interactive", "-ignore-dot-ghci"] setMode handle = do hSetBinaryMode handle False hSetBuffering handle LineBuffering hSetEncoding handle utf8 -- | Run an interpreter session. -- -- Example: -- -- >>> withInterpreter [] $ \i -> eval i "23 + 42" -- "65\n" withInterpreter :: [String] -- ^ List of flags, passed to GHC -> (Interpreter -> IO a) -- ^ Action to run -> IO a -- ^ Result of action withInterpreter flags = bracket (newInterpreter flags) closeInterpreter 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 hPutStrLn stdin_ $ filterExpression e hPutStrLn stdin_ marker hFlush stdin_ return () where stdin_ = hIn repl -- | Fail on unterminated multiline commands. -- -- Examples: -- -- >>> filterExpression "" -- "" -- -- >>> filterExpression "foobar" -- "foobar" -- -- >>> filterExpression ":{" -- "*** Exception: unterminated multiline command -- -- >>> filterExpression " :{ " -- "*** Exception: unterminated multiline command -- -- >>> filterExpression " :{ \nfoobar" -- "*** Exception: unterminated multiline command -- -- >>> filterExpression " :{ \nfoobar \n :} " -- " :{ \nfoobar \n :} " -- filterExpression :: String -> String filterExpression e = case lines e of [] -> e l -> if firstLine == ":{" && lastLine /= ":}" then fail_ else e where firstLine = strip $ head l lastLine = strip $ last l fail_ = error "unterminated multiline command" where strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse getResult :: Interpreter -> IO String getResult repl = do line <- hGetLine stdout_ if marker `isSuffixOf` line then return $ stripMarker line else do result <- getResult repl return $ line ++ '\n' : result where stdout_ = hOut repl stripMarker l = take (length l - length marker) l -- | Evaluate an expresion eval :: Interpreter -> String -- Expression -> IO String -- Result eval repl expr = do putExpression repl expr getResult repl -- | Evaluate an expression; return a Left value on exceptions. -- -- An exception 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) ] doctest-0.9.10/src/Util.hs0000644000000000000000000000131312242512204013464 0ustar0000000000000000module 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 doctest-0.9.10/src/Run.hs0000644000000000000000000000575512242512204013331 0ustar0000000000000000{-# LANGUAGE CPP #-} module Run ( doctest #ifdef TEST , doctest_ , Summary , stripOptGhc #endif ) where import Data.List import Control.Monad (when, unless) import System.Exit (exitFailure, exitSuccess) import System.IO import System.Environment (getEnvironment) import Control.Applicative import qualified Control.Exception as E import Panic import Parse import Help import Runner import qualified Interpreter ghcPackageDbFlag :: String #if __GLASGOW_HASKELL__ >= 706 ghcPackageDbFlag = "-package-db" #else ghcPackageDbFlag = "-package-conf" #endif -- | Run doctest with given list of arguments. -- -- Example: -- -- >>> doctest ["-iexample/src", "example/src/Example.hs"] -- 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 | "--help" `elem` args = putStr usage | "--version" `elem` args = printVersion | otherwise = do -- Look up the HASKELL_PACKAGE_SANDBOX environment variable and, if -- present, add it to the list of package databases GHC searches. -- Intended to make testing from inside sandboxes such as cabal-dev -- simpler. packageConf <- lookup "HASKELL_PACKAGE_SANDBOX" <$> getEnvironment let addPackageConf = case packageConf of Nothing -> id Just p -> \rest -> ghcPackageDbFlag : p : rest i <- Interpreter.interpreterSupported unless i $ do hPutStrLn stderr "WARNING: GHC does not support --interactive, skipping tests" exitSuccess 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_ (addPackageConf args_) `E.catch` \e -> do case fromException e of Just (UsageError err) -> do hPutStrLn stderr ("doctest: " ++ err) hPutStrLn stderr "Try `doctest --help' for more information." exitFailure _ -> E.throwIO e when (not $ isSuccess r) exitFailure isSuccess :: Summary -> Bool isSuccess s = sErrors s == 0 && sFailures s == 0 -- | -- 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 args Interpreter.withInterpreter args $ \repl -> do runModules repl modules doctest-0.9.10/src/Property.hs0000644000000000000000000000423612242512204014402 0ustar0000000000000000{-# LANGUAGE CPP #-} module Property ( runProperty , PropertyResult (..) #ifdef TEST , freeVariables , parseNotInScope #endif ) where import Data.List import Util import Interpreter (Interpreter) import qualified Interpreter import Parse -- | The result of evaluating an interaction. data PropertyResult = Success | Failure String | Error String deriving (Eq, Show) runProperty :: Interpreter -> Expression -> IO PropertyResult runProperty repl expression = do _ <- Interpreter.eval repl "import Test.QuickCheck (quickCheck, (==>))" r <- closeTerm expression >>= (Interpreter.safeEval repl . quickCheck) case r of Left err -> do return (Error err) Right res | "OK, passed" `isInfixOf` res -> return Success | otherwise -> do let msg = stripEnd (takeWhileEnd (/= '\b') res) return (Failure 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 #if __GLASGOW_HASKELL__ >= 707 unquote ('\8219':xs) = init xs #endif unquote xs = xs doctest-0.9.10/src/Extract.hs0000644000000000000000000002105412242512204014165 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} module Extract (Module(..), extract) where import Prelude hiding (mod, concat) import Control.Monad import Control.Applicative import Control.Exception import Data.List (partition, isSuffixOf) import Data.Maybe import Data.Foldable (concat) import Control.DeepSeq (deepseq, NFData(rnf)) import Data.Generics #if __GLASGOW_HASKELL__ < 707 import GHC hiding (flags, Module, Located) import MonadUtils (liftIO, MonadIO) #else import GHC hiding (Module, Located) import DynFlags import MonadUtils (liftIO) #endif 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) import Util (convertDosLineEndings) import Sandbox (getSandboxArguments) -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. newtype ExtractError = ExtractError SomeException deriving Typeable instance Show ExtractError where show (ExtractError e) = unlines [ "Ouch! Hit an error thunk in GHC's AST while extracting documentation." , "" , " " ++ msg , "" , "This is most likely a bug in doctest." , "" , "Please report it here: https://github.com/sol/doctest-haskell/issues/new" ] where msg = case fromException e of Just (Panic s) -> "GHC panic: " ++ s _ -> show e instance Exception ExtractError -- | Documentation for a module grouped together with the modules name. data Module a = Module { moduleName :: String , moduleSetup :: Maybe a , moduleContent :: [a] } deriving (Eq, Functor) instance NFData a => NFData (Module a) where rnf (Module name setup content) = name `deepseq` setup `deepseq` content `deepseq` () -- | Parse a list of modules. parse :: [String] -> IO [TypecheckedModule] parse args = withGhc args $ \modules_ -> withTempOutputDir $ do -- ignore additional object files let modules = filter (not . isSuffixOf ".o") modules_ mapM (`guessTarget` Nothing) modules >>= setTargets mods <- depanal [] False 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 #if __GLASGOW_HASKELL__ < 707 let enableComp d = d { hscTarget = defaultObjectTarget } #else let enableComp d = let platform = targetPlatform d in d { hscTarget = defaultObjectTarget platform } #endif 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 from Haddock/GhcUtils.hs modifySessionDynFlags :: (DynFlags -> DynFlags) -> Ghc () modifySessionDynFlags f = do dflags <- getSessionDynFlags #if __GLASGOW_HASKELL__ < 707 _ <- setSessionDynFlags (f dflags) #else -- GHCi 7.7 now uses dynamic linking. let dflags' = case lookup "GHC Dynamic" (compilerInfo dflags) of Just "YES" -> gopt_set dflags Opt_BuildDynamicToo _ -> dflags _ <- setSessionDynFlags (f dflags') #endif 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] -> IO [Module (Located String)] extract args = do sandboxArgs <- getSandboxArguments let args' = args ++ sandboxArgs mods <- parse args' 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 -- SIGINT (ctrl-c). All AsyncExceptions are re-thrown (not just -- UserInterrupt) because all of them indicate severe conditions and -- should not occur during normal operation. Handler (\e -> throw (e :: AsyncException)) , Handler (throwIO . ExtractError) ] -- | Extract all docstrings from given module and attach the modules name. extractFromModule :: ParsedModule -> Module (Located String) extractFromModule m = Module name (listToMaybe $ map snd setup) (map snd docs) where isSetup = (== Just "setup") . fst (setup, docs) = partition isSetup (docStringsFromModule m) name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m -- | Extract all docstrings from given module. docStringsFromModule :: ParsedModule -> [(Maybe String, Located String)] docStringsFromModule mod = map (fmap (toLocated . fmap unpackDocString)) docs where source = (unLoc . pm_parsed_source) mod -- we use dlist-style concatenation here docs = header ++ exports ++ decls -- We process header, exports and declarations separately instead of -- traversing the whole source in a generic way, to ensure that we get -- everything in source order. header = [(Nothing, x) | Just x <- [hsmodHaddockModHeader source]] exports = [(Nothing, L loc doc) | L loc (IEDoc doc) <- concat (hsmodExports source)] decls = extractDocStrings (hsmodDecls source) type Selector a = a -> ([(Maybe String, LHsDocString)], Bool) -- | Ignore a subtree. ignore :: Selector a ignore = const ([], True) -- | Collect given value and descend into subtree. select :: a -> ([a], Bool) select x = ([x], False) -- | Extract all docstrings from given value. extractDocStrings :: Data a => a -> [(Maybe String, LHsDocString)] extractDocStrings = everythingBut (++) (([], False) `mkQ` fromLHsDecl `extQ` fromLDocDecl `extQ` fromLHsDocString `extQ` (ignore :: Selector NameSet) `extQ` (ignore :: Selector PostTcKind) -- HsExpr never contains any documentation, but it may contain error thunks. -- -- Problematic are (non comprehensive): -- -- * parallel list comprehensions -- * infix operators -- `extQ` (ignore :: Selector (HsExpr RdrName)) -- undefined before type checking `extQ` (ignore :: Selector Coercion) #if __GLASGOW_HASKELL__ >= 706 -- hswb_kvs and hswb_tvs may be error thunks `extQ` (ignore :: Selector (HsWithBndrs [LHsType RdrName])) `extQ` (ignore :: Selector (HsWithBndrs [LHsType Name])) `extQ` (ignore :: Selector (HsWithBndrs (LHsType RdrName))) `extQ` (ignore :: Selector (HsWithBndrs (LHsType Name))) #endif ) where fromLHsDecl :: Selector (LHsDecl RdrName) fromLHsDecl (L loc decl) = case decl of -- Top-level documentation has to be treated separately, because it has -- no location information attached. The location information is -- attached to HsDecl instead. DocD x -> select (fromDocDecl loc x) _ -> (extractDocStrings decl, True) fromLDocDecl :: Selector LDocDecl fromLDocDecl (L loc x) = select (fromDocDecl loc x) fromLHsDocString :: Selector LHsDocString fromLHsDocString x = select (Nothing, x) fromDocDecl :: SrcSpan -> DocDecl -> (Maybe String, LHsDocString) fromDocDecl loc x = case x of DocCommentNamed name doc -> (Just name, L loc doc) _ -> (Nothing, L loc $ docDeclDoc x) -- | Convert a docstring to a plain string. unpackDocString :: HsDocString -> String unpackDocString (HsDocString s) = unpackFS s doctest-0.9.10/src/Parse.hs0000644000000000000000000001115412242512204013625 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} module Parse ( Module (..) , DocTest (..) , Interaction , Expression , ExpectedResult , getDocTests -- * exported for testing , parseInteractions , parseProperties ) where import Data.Char (isSpace) import Data.List import Data.Maybe import Control.Applicative import Extract import Location data DocTest = Example Expression ExpectedResult | Property Expression deriving (Eq, Show) type Expression = String type ExpectedResult = [String] type Interaction = (Expression, ExpectedResult) -- | -- Extract 'DocTest's from all given modules and all modules included by the -- given modules. getDocTests :: [String] -> IO [Module [Located DocTest]] -- ^ Extracted 'DocTest's getDocTests args = do filter (not . isEmpty) . map parseModule <$> extract args where isEmpty (Module _ setup tests) = null tests && isNothing setup -- | Convert documentation to `Example`s. parseModule :: Module (Located String) -> Module [Located DocTest] parseModule m = case parseComment <$> m of Module name setup tests -> Module name setup_ (filter (not . null) tests) where setup_ = case setup of Just [] -> Nothing _ -> setup parseComment :: Located String -> [Located DocTest] parseComment c = properties ++ examples where examples = map (fmap $ uncurry Example) (parseInteractions c) properties = map (fmap Property) (parseProperties c) -- | 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 :: 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 :: [Located String] -> [Located Interaction] go xs = case dropWhile (not . isPrompt) xs of prompt:rest | ":{" : _ <- words (drop 3 (dropWhile isSpace (unLoc prompt))), (ys,zs) <- break isBlankLine rest -> toInteraction prompt ys : go zs | otherwise -> let (ys,zs) = break isEndOfInteraction rest in toInteraction prompt ys : go zs [] -> [] -- | Create an `Interaction`, strip superfluous whitespace as appropriate. -- -- also merge lines between :{ and :}, preserving whitespace inside -- the block (since this is useful for avoiding {;}). toInteraction :: Located String -> [Located String] -> Located Interaction toInteraction (Located loc x) xs = Located loc $ ( (strip cleanedE) -- we do not care about leading and trailing -- whitespace in expressions, so drop them , result_ ) where -- 1. drop trailing whitespace from the prompt, remember the prefix (prefix, e) = span isSpace x (ePrompt, eRest) = splitAt 3 e -- 2. drop, if possible, the exact same sequence of whitespace -- characters from each result line -- -- 3. interpret lines that only contain the string "" as an -- empty line getResult pfx xs' = map (substituteBlankLine . tryStripPrefix pfx . unLoc) xs' where tryStripPrefix pre ys = fromMaybe ys $ stripPrefix pre ys substituteBlankLine "" = "" substituteBlankLine line = line cleanBody line = fromMaybe (unLoc line) (stripPrefix ePrompt (dropWhile isSpace (unLoc line))) (cleanedE, result_) | (body , endLine : rest) <- break ( (==) [":}"] . take 1 . words . cleanBody) xs = (unlines (eRest : map cleanBody body ++ [dropWhile isSpace (cleanBody endLine)]), getResult (takeWhile isSpace (unLoc endLine)) rest) | otherwise = (eRest, getResult prefix xs) -- | Remove leading and trailing whitespace. strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse doctest-0.9.10/src/GhcUtil.hs0000644000000000000000000000544512242512204014120 0ustar0000000000000000{-# LANGUAGE CPP #-} module GhcUtil (withGhc) where import GHC.Paths (libdir) #if __GLASGOW_HASKELL__ < 707 import Control.Exception import GHC hiding (flags) import DynFlags (dopt_set) #else import GHC import DynFlags (gopt_set) #endif import Panic (throwGhcException) import MonadUtils (liftIO) import System.Exit (exitFailure) #if __GLASGOW_HASKELL__ < 702 import StaticFlags (v_opt_C_ready) import Data.IORef (writeIORef) #elif __GLASGOW_HASKELL__ < 707 import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) #else import StaticFlags (discardStaticFlags) #endif -- | Save static flag globals, run action, and restore them. bracketStaticFlags :: IO a -> IO a #if __GLASGOW_HASKELL__ < 702 -- GHC < 7.2 does not provide saveStaticFlagGlobals/restoreStaticFlagGlobals, -- so we need to modifying v_opt_C_ready directly bracketStaticFlags action = action `finally` writeIORef v_opt_C_ready False #elif __GLASGOW_HASKELL__ < 707 bracketStaticFlags action = bracket saveStaticFlagGlobals restoreStaticFlagGlobals (const action) #else bracketStaticFlags action = action #endif -- Catch GHC source errors, print them and exit. handleSrcErrors :: Ghc a -> Ghc a handleSrcErrors action' = flip handleSourceError action' $ \err -> do #if __GLASGOW_HASKELL__ < 702 printExceptionAndWarnings err #else printException err #endif liftIO exitFailure -- | Run a GHC action in Haddock mode withGhc :: [String] -> ([String] -> Ghc a) -> IO a withGhc flags action = bracketStaticFlags $ do flags_ <- handleStaticFlags flags runGhc (Just libdir) $ do handleDynamicFlags flags_ >>= handleSrcErrors . action handleStaticFlags :: [String] -> IO [Located String] #if __GLASGOW_HASKELL__ < 707 handleStaticFlags flags = fst `fmap` parseStaticFlags (map noLoc flags) #else handleStaticFlags flags = return $ map noLoc $ discardStaticFlags flags #endif handleDynamicFlags :: GhcMonad m => [Located String] -> m [String] handleDynamicFlags flags = do (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 : _ -> throwGhcException (UsageError ("unrecognized option `"++ opt ++ "'")) _ -> return srcs setHaddockMode :: DynFlags -> DynFlags #if __GLASGOW_HASKELL__ < 707 setHaddockMode dynflags = (dopt_set dynflags Opt_Haddock) { #else setHaddockMode dynflags = (gopt_set dynflags Opt_Haddock) { #endif hscTarget = HscNothing , ghcMode = CompManager , ghcLink = NoLink } doctest-0.9.10/src/Runner.hs0000644000000000000000000001400712242512204014024 0ustar0000000000000000{-# LANGUAGE CPP #-} module Runner ( runModules , Summary(..) #ifdef TEST , Report , ReportState (..) , report , report_ #endif ) where import Prelude hiding (putStr, putStrLn, error) import Data.Monoid import Control.Applicative import Control.Monad hiding (forM_) import Text.Printf (printf) import System.IO (hPutStrLn, hPutStr, stderr, hIsTerminalDevice) import Data.Foldable (forM_) import Control.Monad.Trans.State import Control.Monad.IO.Class import Interpreter (Interpreter) import qualified Interpreter import Parse import Location import Property import Runner.Example -- | Summary of a test run. data Summary = Summary { sExamples :: Int , sTried :: Int , sErrors :: Int , sFailures :: Int } deriving Eq -- | 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 a list of modules. runModules :: Interpreter -> [Module [Located DocTest]] -> IO Summary runModules repl modules = do isInteractive <- hIsTerminalDevice stderr ReportState _ _ s <- (`execStateT` ReportState 0 isInteractive mempty {sExamples = c}) $ do forM_ modules $ runModule repl -- report final summary gets (show . reportStateSummary) >>= report return s where c = (sum . map count) modules -- | Count number of expressions in given module. count :: Module [Located DocTest] -> Int count (Module _ setup tests) = sum (map length tests) + maybe 0 length setup -- | 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 [Located DocTest] -> Report () runModule repl (Module module_ setup examples) = do Summary _ _ e0 f0 <- gets reportStateSummary forM_ setup $ runTestGroup repl reload Summary _ _ e1 f1 <- gets reportStateSummary -- only run tests, if setup does not produce any errors/failures when (e0 == e1 && f0 == f1) $ forM_ examples $ runTestGroup repl setup_ where reload :: IO () reload = do -- NOTE: It is important to do the :reload first! There was some odd bug -- with a previous version of GHC (7.4.1?). void $ Interpreter.eval repl ":reload" void $ Interpreter.eval repl $ ":m *" ++ module_ setup_ :: IO () setup_ = do reload forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of Property _ -> return () Example e _ -> void $ Interpreter.eval repl e reportFailure :: Location -> Expression -> Report () reportFailure loc expression = do report (printf "### Failure in %s: expression `%s'" (show loc) expression) updateSummary (Summary 0 1 0 1) reportError :: Location -> Expression -> String -> Report () reportError loc expression err = do report (printf "### Error in %s: expression `%s'" (show loc) expression) report err updateSummary (Summary 0 1 1 0) reportSuccess :: Report () reportSuccess = updateSummary (Summary 0 1 0 0) updateSummary :: Summary -> Report () updateSummary summary = do ReportState n f s <- get put (ReportState n f $ s `mappend` summary) -- | Run given test group. -- -- The interpreter state is zeroed with @:reload@ first. This means that you -- can reuse the same 'Interpreter' for several test groups. runTestGroup :: Interpreter -> IO () -> [Located DocTest] -> Report () runTestGroup repl setup tests = do -- report intermediate summary gets (show . reportStateSummary) >>= report_ liftIO setup runExampleGroup repl examples forM_ properties $ \(loc, expression) -> do r <- liftIO $ do setup runProperty repl expression case r of Success -> reportSuccess Error err -> do reportError loc expression err Failure msg -> do reportFailure loc expression report msg where properties = [(loc, p) | Located loc (Property p) <- tests] examples :: [Located Interaction] examples = [Located loc (e, r) | Located loc (Example e r) <- tests] -- | -- Execute all expressions from given example in given 'Interpreter' and verify -- the output. runExampleGroup :: Interpreter -> [Located Interaction] -> Report () runExampleGroup repl = go where go ((Located loc (expression, expected)) : xs) = do r <- fmap lines <$> liftIO (Interpreter.safeEval repl expression) case r of Left err -> do reportError loc expression err Right actual -> case mkResult expected actual of NotEqual err -> do reportFailure loc expression mapM_ report err Equal -> do reportSuccess go xs go [] = return () doctest-0.9.10/src/Location.hs0000644000000000000000000000376112242512204014330 0ustar0000000000000000{-# 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 doctest-0.9.10/src/Sandbox.hs0000644000000000000000000000563612242512204014161 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} module Sandbox (getSandboxArguments, getPackageDbDir) where import Control.Applicative ((<$>)) import Control.Exception as E (catch, SomeException, throwIO) import Data.Char (isSpace) import Data.List (isPrefixOf, tails) import System.Directory (getCurrentDirectory, doesFileExist) import System.FilePath ((), takeDirectory, takeFileName) configFile :: String configFile = "cabal.sandbox.config" pkgDbKey :: String pkgDbKey = "package-db:" pkgDbKeyLen :: Int pkgDbKeyLen = length pkgDbKey getSandboxArguments :: IO [String] getSandboxArguments = (sandboxArguments <$> getPkgDb) `E.catch` handler where getPkgDb = getCurrentDirectory >>= getSandboxConfigFile >>= getPackageDbDir handler :: SomeException -> IO [String] handler _ = return [] -- | Find a sandbox config file by tracing ancestor directories. -- Exception is thrown if not found getSandboxConfigFile :: FilePath -> IO FilePath getSandboxConfigFile dir = do let cfile = dir configFile exist <- doesFileExist cfile if exist then return cfile else do let dir' = takeDirectory dir if dir == dir' then throwIO $ userError "sandbox config file not found" else getSandboxConfigFile dir' -- | Extract a package db directory from the sandbox config file. -- Exception is thrown if the sandbox config file is broken. getPackageDbDir :: FilePath -> IO FilePath getPackageDbDir sconf = do -- Be strict to ensure that an error can be caught. !path <- extractValue . parse <$> readFile sconf return path where parse = head . filter ("package-db:" `isPrefixOf`) . lines extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen -- | Adding necessary GHC options to the package db. -- Exception is thrown if the string argument is incorrect. -- -- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d" -- ["-no-user-package-db","-package-db","/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d"] -- >>> sandboxArguments "/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d" -- ["-no-user-package-conf","-package-conf","/foo/bar/i386-osx-ghc-7.4.1-packages.conf.d"] sandboxArguments :: FilePath -> [String] sandboxArguments pkgDb = [noUserPkgDbOpt, pkgDbOpt, pkgDb] where ver = extractGhcVer pkgDb (pkgDbOpt,noUserPkgDbOpt) | ver < 706 = ("-package-conf","-no-user-package-conf") | otherwise = ("-package-db", "-no-user-package-db") -- | Extracting GHC version from the path of package db. -- Exception is thrown if the string argument is incorrect. -- -- >>> extractGhcVer "/foo/bar/i386-osx-ghc-7.6.3-packages.conf.d" -- 706 extractGhcVer :: String -> Int extractGhcVer dir = ver where file = takeFileName dir findVer = drop 4 . head . filter ("ghc-" `isPrefixOf`) . tails (verStr1,_:left) = break (== '.') $ findVer file (verStr2,_) = break (== '.') left ver = read verStr1 * 100 + read verStr2 doctest-0.9.10/src/Runner/0000755000000000000000000000000012242512204013466 5ustar0000000000000000doctest-0.9.10/src/Runner/Example.hs0000644000000000000000000000214712242512204015421 0ustar0000000000000000module Runner.Example ( Result (..) , mkResult ) where import Data.Char import Util data Result = Equal | NotEqual [String] deriving (Eq, Show) mkResult :: [String] -> [String] -> Result mkResult expected_ actual_ | expected == actual = Equal | otherwise = NotEqual (formatNotEqual expected actual) where expected = map stripEnd expected_ actual = map stripEnd actual_ formatNotEqual :: [String] -> [String] -> [String] formatNotEqual expected actual = formatLines "expected: " expected ++ formatLines " but got: " actual where -- use show to escape special characters in output lines if any output line -- contains any unsafe character escapeOutput | any (not . isSafe) (concat $ expected ++ actual) = map show | otherwise = id isSafe :: Char -> Bool isSafe c = c == ' ' || (isPrint c && (not . isSpace) c) formatLines :: String -> [String] -> [String] formatLines message xs = case escapeOutput xs of y:ys -> (message ++ y) : map (padding ++) ys [] -> [message] where padding = replicate (length message) ' ' doctest-0.9.10/src/Test/0000755000000000000000000000000012242512204013134 5ustar0000000000000000doctest-0.9.10/src/Test/DocTest.hs0000644000000000000000000000007612242512204015040 0ustar0000000000000000module Test.DocTest ( doctest ) where import Run