diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -1,5 +1,5 @@ name: doctest -version: 0.9.7 +version: 0.9.8 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python @@ -45,6 +45,7 @@ , Runner.Example , Run , Util + , Sandbox build-depends: base == 4.* , ghc >= 7.0 && < 7.8 @@ -92,7 +93,7 @@ , transformers , HUnit - , hspec >= 1.3 + , hspec >= 1.5.1 , QuickCheck >= 2.5 , stringbuilder >= 0.4 , silently >= 1.2.4 diff --git a/src/Extract.hs b/src/Extract.hs --- a/src/Extract.hs +++ b/src/Extract.hs @@ -12,8 +12,14 @@ 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 @@ -28,6 +34,7 @@ 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 @@ -79,7 +86,12 @@ -- 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) } @@ -90,7 +102,15 @@ 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 @@ -122,7 +142,9 @@ -- those modules (possibly indirect). extract :: [String] -> IO [Module (Located String)] extract args = do - mods <- parse args + 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` [ diff --git a/src/GhcUtil.hs b/src/GhcUtil.hs --- a/src/GhcUtil.hs +++ b/src/GhcUtil.hs @@ -3,16 +3,21 @@ import Control.Exception import GHC.Paths (libdir) +#if __GLASGOW_HASKELL__ < 707 import GHC hiding (flags) import DynFlags (dopt_set) -import Panic (ghcError) +#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) + +#if __GLASGOW_HASKELL__ < 702 #else import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) #endif @@ -41,6 +46,7 @@ -- | Run a GHC action in Haddock mode withGhc :: [String] -> ([String] -> Ghc a) -> IO a withGhc flags action = bracketStaticFlags $ do + writeIORef v_opt_C_ready False flags_ <- handleStaticFlags flags runGhc (Just libdir) $ do @@ -59,11 +65,15 @@ let srcs = map unLoc locSrcs unknown_opts = [ f | f@('-':_) <- srcs ] case unknown_opts of - opt : _ -> ghcError (UsageError ("unrecognized option `"++ opt ++ "'")) + 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 diff --git a/src/Interpreter.hs b/src/Interpreter.hs --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -22,6 +22,7 @@ import Data.List import GHC.Paths (ghc) +import Sandbox (getSandboxArguments) -- | Truly random marker, used to separate expressions. -- @@ -55,13 +56,22 @@ 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) @@ -70,8 +80,7 @@ return interpreter where - myFlags = ["-v0", "--interactive", "-ignore-dot-ghci"] ++ flags - + ghciFlags = ["-v0", "--interactive", "-ignore-dot-ghci"] setMode handle = do hSetBinaryMode handle False hSetBuffering handle LineBuffering diff --git a/src/Property.hs b/src/Property.hs --- a/src/Property.hs +++ b/src/Property.hs @@ -67,5 +67,8 @@ extractVariable = unquote . takeWhileEnd (/= ' ') -- | Remove quotes from given name, if any. - unquote ('`':xs) = init xs - unquote xs = xs + unquote ('`':xs) = init xs +#if __GLASGOW_HASKELL__ >= 707 + unquote ('\8219':xs) = init xs +#endif + unquote xs = xs diff --git a/src/Sandbox.hs b/src/Sandbox.hs new file mode 100644 --- /dev/null +++ b/src/Sandbox.hs @@ -0,0 +1,77 @@ +module Sandbox (getSandboxArguments) where + +import Control.Applicative ((<$>)) +import Data.Char (isSpace) +import Data.List (isPrefixOf, tails) +import System.Directory (getCurrentDirectory, doesFileExist, doesDirectoryExist) +import System.FilePath ((), takeDirectory, takeFileName) +import Control.Exception (handle, SomeException) + +configFile :: String +configFile = "cabal.sandbox.config" + +sandboxDir :: String +sandboxDir = ".cabal-sandbox" + +pkgDbKey :: String +pkgDbKey = "package-db:" + +pkgDbKeyLen :: Int +pkgDbKeyLen = length pkgDbKey + +getSandboxArguments :: IO [String] +getSandboxArguments = do + mdir <- getCurrentDirectory >>= getSandboxDir + case mdir of + Nothing -> return [] + Just (sdir,sconf) -> sandboxArguments sdir sconf + +getSandboxDir :: FilePath -> IO (Maybe (FilePath,FilePath)) +getSandboxDir dir = do + exist <- doesSandboxExist dir + if exist then + return $ Just (dir sandboxDir, dir configFile) + else do + let dir' = takeDirectory dir + if dir == dir' then + return Nothing + else + getSandboxDir dir' + +doesSandboxExist :: FilePath -> IO Bool +doesSandboxExist dir = do + fileExist <- doesFileExist $ dir configFile + dirExist <- doesDirectoryExist $ dir sandboxDir + return (fileExist && dirExist) + +sandboxArguments :: FilePath -> FilePath -> IO [String] +sandboxArguments sdir sconf = handle handler $ do + pkgDb <- getPackageDbDir sconf + let ver = extractGhcVer pkgDb + let (pkgDbOpt,noUserPkgDbOpt) + | ver < 706 = ("-package-conf","-no-user-package-conf") + | otherwise = ("-package-db", "-no-user-package-db") + pkgDbPath = sdir pkgDb + libPath = sdir "lib" + impOpt = "-i" ++ libPath + return [noUserPkgDbOpt, pkgDbOpt, pkgDbPath, impOpt] + where + handler :: SomeException -> IO [String] + handler _ = return [] + +getPackageDbDir :: FilePath -> IO FilePath +getPackageDbDir sconf = do + ls <- lines <$> readFile sconf + let [target] = filter ("package-db:" `isPrefixOf`) ls + return $ extractValue target + where + extractValue = fst . break isSpace . dropWhile isSpace . drop pkgDbKeyLen + +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