doctest-0.11.0/0000755000000000000000000000000012677001450011426 5ustar0000000000000000doctest-0.11.0/LICENSE0000644000000000000000000000206712677001450012440 0ustar0000000000000000Copyright (c) 2009-2015 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.11.0/doctest.cabal0000644000000000000000000000500012677001450014052 0ustar0000000000000000name: doctest version: 0.11.0 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/issues homepage: https://github.com/sol/doctest#readme license: MIT license-file: LICENSE copyright: (c) 2009-2015 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 library exposed-modules: Test.DocTest ghc-options: -Wall hs-source-dirs: src, ghci-wrapper/src other-modules: Extract , GhcUtil , Interpreter , Location , Help , PackageDBs , Parse , Paths_doctest , Property , Runner , Runner.Example , Run , Util , Sandbox , Language.Haskell.GhciWrapper build-depends: base == 4.* , base-compat >= 0.4.2 , ghc >= 7.0 && < 8.2 , syb >= 0.3 , 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 -threaded cpp-options: -DTEST hs-source-dirs: test, src, ghci-wrapper/src c-sources: test/integration/with-cbits/foo.c build-depends: base , ghc , syb , deepseq , directory , filepath , process , ghc-paths , transformers , base-compat , HUnit , hspec >= 1.5.1 , QuickCheck >= 2.8.2 , stringbuilder >= 0.4 , silently >= 1.2.4 , setenv , with-location test-suite doctests main-is: doctests.hs type: exitcode-stdio-1.0 ghc-options: -Wall -threaded hs-source-dirs: test build-depends: base , doctest doctest-0.11.0/Setup.lhs0000644000000000000000000000011412677001450013232 0ustar0000000000000000#!/usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain doctest-0.11.0/test/0000755000000000000000000000000012677001450012405 5ustar0000000000000000doctest-0.11.0/test/doctests.hs0000644000000000000000000000042212677001450014567 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = doctest [ "-packageghc" , "-isrc" , "-ighci-wrapper/src" , "-idist/build/autogen/" , "-optP-include" , "-optPdist/build/autogen/cabal_macros.h" , "src/Run.hs" , "src/PackageDBs.hs" ] doctest-0.11.0/test/Spec.hs0000644000000000000000000000005412677001450013632 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} doctest-0.11.0/test/integration/0000755000000000000000000000000012677001450014730 5ustar0000000000000000doctest-0.11.0/test/integration/with-cbits/0000755000000000000000000000000012677001450017005 5ustar0000000000000000doctest-0.11.0/test/integration/with-cbits/foo.c0000644000000000000000000000003312677001450017730 0ustar0000000000000000int foo() { return 23; } doctest-0.11.0/example/0000755000000000000000000000000012677001450013061 5ustar0000000000000000doctest-0.11.0/example/example.cabal0000644000000000000000000000056612677001450015507 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.11.0/example/test/0000755000000000000000000000000012677001450014040 5ustar0000000000000000doctest-0.11.0/example/test/doctests.hs0000644000000000000000000000015312677001450016223 0ustar0000000000000000module Main where import Test.DocTest main :: IO () main = doctest ["-isrc", "src/Example.hs"] doctest-0.11.0/example/src/0000755000000000000000000000000012677001450013650 5ustar0000000000000000doctest-0.11.0/example/src/Example.hs0000644000000000000000000000012512677001450015575 0ustar0000000000000000module Example where -- | -- >>> foo -- 23 foo = 23 -- | -- >>> bar -- 42 bar = 42 doctest-0.11.0/ghci-wrapper/0000755000000000000000000000000012677001450014016 5ustar0000000000000000doctest-0.11.0/ghci-wrapper/src/0000755000000000000000000000000012677001450014605 5ustar0000000000000000doctest-0.11.0/ghci-wrapper/src/Language/0000755000000000000000000000000012677001450016330 5ustar0000000000000000doctest-0.11.0/ghci-wrapper/src/Language/Haskell/0000755000000000000000000000000012677001450017713 5ustar0000000000000000doctest-0.11.0/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs0000644000000000000000000001003212677001450022456 0ustar0000000000000000{-# LANGUAGE RecordWildCards #-} module Language.Haskell.GhciWrapper ( Interpreter , Config(..) , defaultConfig , new , close , eval , evalEcho ) where import System.IO hiding (stdin, stdout, stderr) import System.Process import System.Exit import Control.Monad import Control.Exception import Data.List import Data.Maybe data Config = Config { configGhci :: String , configVerbose :: Bool , configIgnoreDotGhci :: Bool } deriving (Eq, Show) defaultConfig :: Config defaultConfig = Config { configGhci = "ghci" , configVerbose = False , configIgnoreDotGhci = True } -- | 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 } new :: Config -> [String] -> IO Interpreter new Config{..} args_ = do (Just stdin_, Just stdout_, Nothing, processHandle ) <- createProcess $ (proc configGhci args) {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" _ <- eval interpreter ":m - System.IO" _ <- eval interpreter ":m - GHC.IO.Handle" return interpreter where args = args_ ++ catMaybes [ if configIgnoreDotGhci then Just "-ignore-dot-ghci" else Nothing , if configVerbose then Nothing else Just "-v0" ] setMode h = do hSetBinaryMode h False hSetBuffering h LineBuffering hSetEncoding h utf8 close :: Interpreter -> IO () close 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) $ do throwIO (userError $ "Language.Haskell.GhciWrapper.close: Interpreter exited with an error (" ++ show e ++ ")") putExpression :: Interpreter -> String -> IO () putExpression Interpreter{hIn = stdin} e = do hPutStrLn stdin e hPutStrLn stdin marker hFlush stdin getResult :: Bool -> Interpreter -> IO String getResult echoMode Interpreter{hOut = stdout} = go where go = do line <- hGetLine stdout if marker `isSuffixOf` line then do let xs = stripMarker line echo xs return xs else do echo (line ++ "\n") result <- go return (line ++ "\n" ++ result) stripMarker l = take (length l - length marker) l echo :: String -> IO () echo | echoMode = putStr | otherwise = (const $ return ()) -- | Evaluate an expression eval :: Interpreter -> String -> IO String eval repl expr = do putExpression repl expr getResult False repl -- | Evaluate an expression evalEcho :: Interpreter -> String -> IO String evalEcho repl expr = do putExpression repl expr getResult True repl doctest-0.11.0/driver/0000755000000000000000000000000012677001450012721 5ustar0000000000000000doctest-0.11.0/driver/Main.hs0000644000000000000000000000021712677001450014141 0ustar0000000000000000module Main (main) where import Test.DocTest import System.Environment (getArgs) main :: IO () main = getArgs >>= doctest doctest-0.11.0/src/0000755000000000000000000000000012677001450012215 5ustar0000000000000000doctest-0.11.0/src/Help.hs0000644000000000000000000000131512677001450013441 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.11.0/src/Interpreter.hs0000644000000000000000000000417412677001450015062 0ustar0000000000000000{-# LANGUAGE CPP #-} module Interpreter ( Interpreter , safeEval , withInterpreter , ghc , interpreterSupported -- exported for testing , ghcInfo , haveInterpreterKey ) where import System.Process import System.Directory (getPermissions, executable) #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Monad import Control.Exception hiding (handle) import Data.Char import GHC.Paths (ghc) import Language.Haskell.GhciWrapper 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 -- | 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 action = do let args = ["--interactive"] ++ flags bracket (new defaultConfig{configGhci = ghc} args) close action -- | 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 = either (return . Left) (fmap Right . eval repl) . filterExpression filterExpression :: String -> Either String String filterExpression e = case lines e of [] -> Right e l -> if firstLine == ":{" && lastLine /= ":}" then fail_ else Right e where firstLine = strip $ head l lastLine = strip $ last l fail_ = Left "unterminated multiline command" where strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse doctest-0.11.0/src/Util.hs0000644000000000000000000000131312677001450013464 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.11.0/src/PackageDBs.hs0000644000000000000000000000644512677001450014506 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} -- | Manage GHC package databases module PackageDBs ( PackageDBs (..) , ArgStyle (..) , dbArgs , buildArgStyle , getPackageDBsFromEnv , getPackageDBArgs ) where import System.Environment (getEnvironment) import System.FilePath (splitSearchPath, searchPathSeparator) import qualified Sandbox import Control.Exception (try, SomeException) import System.Directory (getCurrentDirectory) -- | Full stack of GHC package databases data PackageDBs = PackageDBs { includeUser :: Bool -- | Unsupported on GHC < 7.6 , includeGlobal :: Bool , extraDBs :: [FilePath] } deriving (Show, Eq) -- | Package database handling switched between GHC 7.4 and 7.6 data ArgStyle = Pre76 | Post76 deriving (Show, Eq) -- | Determine command line arguments to be passed to GHC to set databases correctly -- -- >>> dbArgs Post76 (PackageDBs False True []) -- ["-no-user-package-db"] -- -- >>> dbArgs Pre76 (PackageDBs True True ["somedb"]) -- ["-package-conf","somedb"] dbArgs :: ArgStyle -> PackageDBs -> [String] dbArgs Post76 (PackageDBs user global extras) = (if user then id else ("-no-user-package-db":)) $ (if global then id else ("-no-global-package-db":)) $ concatMap (\extra -> ["-package-db", extra]) extras dbArgs Pre76 (PackageDBs _ False _) = error "Global package database must be included with GHC < 7.6" dbArgs Pre76 (PackageDBs user True extras) = (if user then id else ("-no-user-package-conf":)) $ concatMap (\extra -> ["-package-conf", extra]) extras -- | The argument style to be used with the current GHC version buildArgStyle :: ArgStyle #if __GLASGOW_HASKELL__ >= 706 buildArgStyle = Post76 #else buildArgStyle = Pre76 #endif -- | Determine the PackageDBs based on the environment and cabal sandbox -- information getPackageDBsFromEnv :: IO PackageDBs getPackageDBsFromEnv = do env <- getEnvironment case () of () | Just sandboxes <- lookup "HASKELL_PACKAGE_SANDBOXES" env -> return $ fromEnvMulti sandboxes | Just extra <- lookup "HASKELL_PACKAGE_SANDBOX" env -> return PackageDBs { includeUser = True , includeGlobal = True , extraDBs = [extra] } | Just sandboxes <- lookup "GHC_PACKAGE_PATH" env -> return $ fromEnvMulti sandboxes | otherwise -> do eres <- try $ getCurrentDirectory >>= Sandbox.getSandboxConfigFile >>= Sandbox.getPackageDbDir return $ case eres :: Either SomeException FilePath of Left _ -> PackageDBs True True [] Right db -> PackageDBs False True [db] where fromEnvMulti s = PackageDBs { includeUser = False , includeGlobal = global , extraDBs = splitSearchPath s' } where (s', global) = case reverse s of c:rest | c == searchPathSeparator -> (reverse rest, True) _ -> (s, False) -- | Get the package DB flags for the current GHC version and from the -- environment. getPackageDBArgs :: IO [String] getPackageDBArgs = do dbs <- getPackageDBsFromEnv return $ dbArgs buildArgStyle dbs doctest-0.11.0/src/Run.hs0000644000000000000000000001103112677001450013311 0ustar0000000000000000{-# LANGUAGE CPP #-} module Run ( doctest #ifdef TEST , doctest_ , Summary , stripOptGhc , expandDirs #endif ) where import Prelude () import Prelude.Compat import Data.List.Compat import Control.Monad (when, unless) import System.Directory (doesFileExist, doesDirectoryExist, getDirectoryContents) import System.Environment (getEnvironment) import System.Exit (exitFailure, exitSuccess) import System.FilePath ((), takeExtension) import System.IO import qualified Control.Exception as E import Panic import PackageDBs import Parse import Help import Runner import qualified Interpreter -- | 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. -- -- If a directory is given, it is traversed to find all .hs and .lhs files -- inside of it, ignoring hidden entries. doctest :: [String] -> IO () doctest args0 | "--help" `elem` args0 = putStr usage | "--version" `elem` args0 = printVersion | otherwise = do args <- concat <$> mapM expandDirs args0 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 packageDBArgs <- getPackageDBArgs let addPackageConf = (packageDBArgs ++) addDistArgs <- getAddDistArgs r <- doctest_ (addDistArgs $ 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 -- | Expand a reference to a directory to all .hs and .lhs files within it. expandDirs :: String -> IO [String] expandDirs fp0 = do isDir <- doesDirectoryExist fp0 if isDir then findHaskellFiles fp0 else return [fp0] where findHaskellFiles dir = do contents <- getDirectoryContents dir concat <$> mapM go (filter (not . hidden) contents) where go name = do isDir <- doesDirectoryExist fp if isDir then findHaskellFiles fp else if isHaskellFile fp then return [fp] else return [] where fp = dir name hidden ('.':_) = True hidden _ = False isHaskellFile fp = takeExtension fp `elem` [".hs", ".lhs"] -- | Get the necessary arguments to add the @cabal_macros.h@ file and autogen -- directory, if present. getAddDistArgs :: IO ([String] -> [String]) getAddDistArgs = do env <- getEnvironment let dist = case lookup "HASKELL_DIST_DIR" env of Nothing -> "dist" Just x -> x autogen = dist ++ "/build/autogen/" cabalMacros = autogen ++ "cabal_macros.h" dirExists <- doesDirectoryExist autogen if dirExists then do fileExists <- doesFileExist cabalMacros return $ \rest -> concat ["-i", dist, "/build/autogen/"] : "-optP-include" : (if fileExists then (concat ["-optP", dist, "/build/autogen/cabal_macros.h"]:) else id) rest else return id 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.11.0/src/Property.hs0000644000000000000000000000452212677001450014400 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE PatternGuards #-} module Property ( runProperty , PropertyResult (..) #ifdef TEST , freeVariables , parseNotInScope #endif ) where import Data.List import Data.Maybe import Data.Foldable 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.safeEval repl "import Test.QuickCheck ((==>))" _ <- Interpreter.safeEval repl "import Test.QuickCheck.All (polyQuickCheck)" _ <- Interpreter.safeEval repl "import Language.Haskell.TH (mkName)" _ <- Interpreter.safeEval repl ":set -XTemplateHaskell" r <- freeVariables repl expression >>= (Interpreter.safeEval repl . quickCheck expression) 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 vars = "let doctest_prop " ++ unwords vars ++ " = " ++ term ++ "\n" ++ "$(polyQuickCheck (mkName \"doctest_prop\"))" -- | 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 :: String -> [String] parseNotInScope = nub . mapMaybe extractVariable . lines where -- | Extract variable name from a "Not in scope"-error. extractVariable :: String -> Maybe String extractVariable x | "Not in scope: " `isInfixOf` x = Just . unquote . takeWhileEnd (/= ' ') $ x | Just y <- (asum $ map (stripPrefix "Variable not in scope: ") (tails x)) = Just (takeWhile (/= ' ') y) | otherwise = Nothing -- | Remove quotes from given name, if any. unquote ('`':xs) = init xs #if __GLASGOW_HASKELL__ >= 707 unquote ('\8216':xs) = init xs #endif unquote xs = xs doctest-0.11.0/src/Extract.hs0000644000000000000000000002155512677001450014173 0ustar0000000000000000{-# LANGUAGE CPP, DeriveDataTypeable, DeriveFunctor #-} module Extract (Module(..), extract) where import Prelude hiding (mod, concat) import Control.Monad #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Control.Exception import Data.List (partition, isSuffixOf) import Data.Maybe #if __GLASGOW_HASKELL__ < 710 import Data.Foldable (concat) #endif 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 #if __GLASGOW_HASKELL__ < 710 import NameSet (NameSet) import Coercion (Coercion) #endif import FastString (unpackFS) import Digraph (flattenSCCs) import System.Posix.Internals (c_getpid) import GhcUtil (withGhc) import Location hiding (unLoc) import Util (convertDosLineEndings) import PackageDBs (getPackageDBArgs) -- | 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/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 packageDBArgs <- getPackageDBArgs let args' = args ++ packageDBArgs 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]] #if __GLASGOW_HASKELL__ < 710 exports = [(Nothing, L loc doc) | L loc (IEDoc doc) <- concat (hsmodExports source)] #else exports = [(Nothing, L loc doc) | L loc (IEDoc doc) <- maybe [] unLoc (hsmodExports source)] #endif decls = extractDocStrings (hsmodDecls source) type Selector a = a -> ([(Maybe String, LHsDocString)], Bool) #if __GLASGOW_HASKELL__ < 710 -- | Ignore a subtree. ignore :: Selector a ignore = const ([], True) #endif -- | 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 #if __GLASGOW_HASKELL__ < 710 `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 #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.11.0/src/Parse.hs0000644000000000000000000001322112677001450013622 0ustar0000000000000000{-# LANGUAGE PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} module Parse ( Module (..) , DocTest (..) , Interaction , Expression , ExpectedResult , ExpectedLine (..) , LineChunk (..) , getDocTests -- * exported for testing , parseInteractions , parseProperties , mkLineChunks ) where import Data.Char (isSpace) import Data.List import Data.Maybe import Data.String #if __GLASGOW_HASKELL__ < 710 import Control.Applicative #endif import Extract import Location data DocTest = Example Expression ExpectedResult | Property Expression deriving (Eq, Show) data LineChunk = LineChunk String | WildCardChunk deriving (Show, Eq) instance IsString LineChunk where fromString = LineChunk data ExpectedLine = ExpectedLine [LineChunk] | WildCardLine deriving (Show, Eq) instance IsString ExpectedLine where fromString = ExpectedLine . return . LineChunk type Expression = String type ExpectedResult = [ExpectedLine] 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 , map mkExpectedLine 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 unindent pre = map (tryStripPrefix pre . unLoc) 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)]), unindent (takeWhile isSpace (unLoc endLine)) rest) | otherwise = (eRest, unindent prefix xs) tryStripPrefix :: String -> String -> String tryStripPrefix prefix ys = fromMaybe ys $ stripPrefix prefix ys mkExpectedLine :: String -> ExpectedLine mkExpectedLine x = case x of "" -> "" "..." -> WildCardLine _ -> ExpectedLine $ mkLineChunks x mkLineChunks :: String -> [LineChunk] mkLineChunks = finish . foldr go (0, [], []) where mkChunk :: String -> [LineChunk] mkChunk "" = [] mkChunk x = [LineChunk x] go :: Char -> (Int, String, [LineChunk]) -> (Int, String, [LineChunk]) go '.' (count, acc, res) = if count == 2 then (0, "", WildCardChunk : mkChunk acc ++ res) else (count + 1, acc, res) go c (count, acc, res) = if count > 0 then (0, c : replicate count '.' ++ acc, res) else (0, c : acc, res) finish (count, acc, res) = mkChunk (replicate count '.' ++ acc) ++ res -- | Remove leading and trailing whitespace. strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse doctest-0.11.0/src/GhcUtil.hs0000644000000000000000000000544512677001450014120 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.11.0/src/Runner.hs0000644000000000000000000001407212677001450014026 0ustar0000000000000000{-# LANGUAGE CPP #-} module Runner ( runModules , Summary(..) #ifdef TEST , Report , ReportState (..) , report , report_ #endif ) where import Prelude hiding (putStr, putStrLn, error) #if __GLASGOW_HASKELL__ < 710 import Data.Monoid import Control.Applicative #endif 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.safeEval repl ":reload" void $ Interpreter.safeEval repl $ ":m *" ++ module_ setup_ :: IO () setup_ = do reload forM_ setup $ \l -> forM_ l $ \(Located _ x) -> case x of Property _ -> return () Example e _ -> void $ Interpreter.safeEval 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.11.0/src/Location.hs0000644000000000000000000000376112677001450014330 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.11.0/src/Sandbox.hs0000644000000000000000000000575312677001450014161 0ustar0000000000000000{-# LANGUAGE CPP, BangPatterns #-} module Sandbox ( getSandboxArguments , getPackageDbDir , getSandboxConfigFile ) where #if __GLASGOW_HASKELL__ < 710 import Data.Functor ((<$>)) #endif 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.11.0/src/Runner/0000755000000000000000000000000012677001450013466 5ustar0000000000000000doctest-0.11.0/src/Runner/Example.hs0000644000000000000000000000404612677001450015421 0ustar0000000000000000module Runner.Example ( Result (..) , mkResult ) where import Data.Char import Data.List import Util import Parse data Result = Equal | NotEqual [String] deriving (Eq, Show) mkResult :: ExpectedResult -> [String] -> Result mkResult expected actual | expected `matches` actual = Equal | otherwise = NotEqual (formatNotEqual expected actual) where chunksMatch :: [LineChunk] -> String -> Bool chunksMatch [] "" = True chunksMatch [LineChunk xs] ys = stripEnd xs == stripEnd ys chunksMatch (LineChunk x : xs) ys = x `isPrefixOf` ys && xs `chunksMatch` drop (length x) ys chunksMatch zs@(WildCardChunk : xs) (_:ys) = xs `chunksMatch` ys || zs `chunksMatch` ys chunksMatch _ _ = False matches :: ExpectedResult -> [String] -> Bool matches [] [] = True matches [] _ = False matches _ [] = False matches (ExpectedLine x : xs) (y:ys) = x `chunksMatch` y && xs `matches` ys matches zs@(WildCardLine : xs) (_:ys) = xs `matches` ys || zs `matches` ys formatNotEqual :: ExpectedResult -> [String] -> [String] formatNotEqual expected_ actual = formatLines "expected: " expected ++ formatLines " but got: " actual where expected :: [String] expected = map (\x -> case x of ExpectedLine str -> concatMap lineChunkToString str WildCardLine -> "..." ) expected_ -- 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) ' ' lineChunkToString :: LineChunk -> String lineChunkToString WildCardChunk = "..." lineChunkToString (LineChunk str) = str doctest-0.11.0/src/Test/0000755000000000000000000000000012677001450013134 5ustar0000000000000000doctest-0.11.0/src/Test/DocTest.hs0000644000000000000000000000007612677001450015040 0ustar0000000000000000module Test.DocTest ( doctest ) where import Run