packages feed

doctest 0.9.13 → 0.10.0

raw patch · 10 files changed

+275/−175 lines, 10 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

doctest.cabal view
@@ -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:
+ ghci-wrapper/src/Language/Haskell/GhciWrapper.hs view
@@ -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
src/Extract.hs view
@@ -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
src/Interpreter.hs view
@@ -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)-  ]
+ src/PackageDBs.hs view
@@ -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
src/Property.hs view
@@ -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
src/Run.hs view
@@ -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
src/Runner.hs view
@@ -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
src/Sandbox.hs view
@@ -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)
test/doctests.hs view
@@ -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"   ]