diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -1,5 +1,5 @@ name: doctest -version: 0.9.13 +version: 0.10.0 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python @@ -31,13 +31,14 @@ ghc-options: -Wall hs-source-dirs: - src + src, ghci-wrapper/src other-modules: Extract , GhcUtil , Interpreter , Location , Help + , PackageDBs , Parse , Paths_doctest , Property @@ -46,10 +47,11 @@ , Run , Util , Sandbox + , Language.Haskell.GhciWrapper build-depends: base == 4.* , ghc >= 7.0 && < 7.12 - , syb >= 0.3 && < 0.5 + , syb >= 0.3 , deepseq , directory , filepath @@ -78,7 +80,7 @@ cpp-options: -DTEST hs-source-dirs: - src, test + test, src, ghci-wrapper/src c-sources: test/integration/with-cbits/foo.c build-depends: diff --git a/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs b/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs new file mode 100644 --- /dev/null +++ b/ghci-wrapper/src/Language/Haskell/GhciWrapper.hs @@ -0,0 +1,134 @@ +{-# 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 diff --git a/src/Extract.hs b/src/Extract.hs --- a/src/Extract.hs +++ b/src/Extract.hs @@ -38,7 +38,7 @@ import Location hiding (unLoc) import Util (convertDosLineEndings) -import Sandbox (getSandboxArguments) +import PackageDBs (getPackageDBArgs) -- | A wrapper around `SomeException`, to allow for a custom `Show` instance. newtype ExtractError = ExtractError SomeException @@ -146,8 +146,8 @@ -- those modules (possibly indirect). extract :: [String] -> IO [Module (Located String)] extract args = do - sandboxArgs <- getSandboxArguments - let args' = args ++ sandboxArgs + packageDBArgs <- getPackageDBArgs + let args' = args ++ packageDBArgs mods <- parse args' let docs = map (fmap (fmap convertDosLineEndings) . extractFromModule . tm_parsed_module) mods diff --git a/src/Interpreter.hs b/src/Interpreter.hs --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,6 +1,5 @@ module Interpreter ( Interpreter -, eval , safeEval , withInterpreter , ghc @@ -11,32 +10,15 @@ , 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.Monad 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 - } +import Language.Haskell.GhciWrapper haveInterpreterKey :: String haveInterpreterKey = "Have interpreter" @@ -54,39 +36,6 @@ 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: @@ -97,102 +46,25 @@ :: [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 - +withInterpreter flags action = do + let args = ["--interactive"] ++ flags + bracket (new defaultConfig{configGhci = ghc} args) close action --- | 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 :} " +-- | Evaluate an expression; return a Left value on exceptions. -- -filterExpression :: String -> String +-- 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 - [] -> e - l -> if firstLine == ":{" && lastLine /= ":}" then fail_ else e + [] -> Right e + l -> if firstLine == ":{" && lastLine /= ":}" then fail_ else Right e where firstLine = strip $ head l lastLine = strip $ last l - fail_ = error "unterminated multiline command" + fail_ = Left "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) - ] diff --git a/src/PackageDBs.hs b/src/PackageDBs.hs new file mode 100644 --- /dev/null +++ b/src/PackageDBs.hs @@ -0,0 +1,99 @@ +{-# 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 diff --git a/src/Property.hs b/src/Property.hs --- a/src/Property.hs +++ b/src/Property.hs @@ -24,10 +24,10 @@ runProperty :: Interpreter -> Expression -> IO PropertyResult runProperty repl expression = do - _ <- Interpreter.eval repl "import Test.QuickCheck ((==>))" - _ <- Interpreter.eval repl "import Test.QuickCheck.All (polyQuickCheck)" - _ <- Interpreter.eval repl "import Language.Haskell.TH (mkName)" - _ <- Interpreter.eval repl ":set -XTemplateHaskell" + _ <- 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 diff --git a/src/Run.hs b/src/Run.hs --- a/src/Run.hs +++ b/src/Run.hs @@ -12,24 +12,16 @@ 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 PackageDBs 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: @@ -44,15 +36,6 @@ | "--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" @@ -62,6 +45,10 @@ when f $ do hPutStrLn stderr "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly." hFlush stderr + + packageDBArgs <- getPackageDBArgs + let addPackageConf = (packageDBArgs ++) + r <- doctest_ (addPackageConf args_) `E.catch` \e -> do case fromException e of Just (UsageError err) -> do diff --git a/src/Runner.hs b/src/Runner.hs --- a/src/Runner.hs +++ b/src/Runner.hs @@ -126,15 +126,15 @@ 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_ + 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.eval repl e + Example e _ -> void $ Interpreter.safeEval repl e reportFailure :: Location -> Expression -> Report () reportFailure loc expression = do diff --git a/src/Sandbox.hs b/src/Sandbox.hs --- a/src/Sandbox.hs +++ b/src/Sandbox.hs @@ -1,6 +1,10 @@ {-# LANGUAGE BangPatterns #-} -module Sandbox (getSandboxArguments, getPackageDbDir) where +module Sandbox + ( getSandboxArguments + , getPackageDbDir + , getSandboxConfigFile + ) where import Control.Applicative ((<$>)) import Control.Exception as E (catch, SomeException, throwIO) diff --git a/test/doctests.hs b/test/doctests.hs --- a/test/doctests.hs +++ b/test/doctests.hs @@ -6,8 +6,10 @@ main = doctest [ "-packageghc" , "-isrc" + , "-ighci-wrapper/src" , "-idist/build/autogen/" , "-optP-include" , "-optPdist/build/autogen/cabal_macros.h" , "src/Run.hs" + , "src/PackageDBs.hs" ]