diff --git a/doctest.cabal b/doctest.cabal --- a/doctest.cabal +++ b/doctest.cabal @@ -1,5 +1,5 @@ name: doctest -version: 0.5.2 +version: 0.6.0 synopsis: Test interactive Haskell examples description: The doctest program checks examples in source code comments. It is modeled after doctest for Python @@ -16,7 +16,7 @@ author: Simon Hengel maintainer: Simon Hengel build-type: Simple -cabal-version: >= 1.6 +cabal-version: >= 1.8 source-repository head type: git @@ -32,21 +32,19 @@ other-modules: Interpreter , Options - , HaddockBackend.Api - , HaddockBackend.Markup , DocTest + , Parse + , Extract + , GhcUtil build-depends: - base >= 4.0 && < 4.5 - , ghc >= 6.12 && < 7.4 + base >= 4.0 && < 4.6 + , ghc >= 6.12 && < 7.6 + , syb + , deepseq , directory - , containers , process , ghc-paths == 0.1.* , HUnit == 1.2.* - if impl(ghc >= 7.2) - build-depends: haddock >= 2.9.4 && < 2.10 - else - build-depends: haddock >= 2.8 && <= 2.9.2 executable doctest main-is: @@ -58,18 +56,39 @@ other-modules: Interpreter , Options - , HaddockBackend.Api - , HaddockBackend.Markup , DocTest + , Parse + , Extract + , GhcUtil build-depends: - base >= 4.0 && < 4.5 - , ghc >= 6.12 && < 7.4 + base >= 4.0 && < 4.6 + , ghc >= 6.12 && < 7.6 + , syb + , deepseq , directory - , containers , process , ghc-paths == 0.1.* , HUnit == 1.2.* - if impl(ghc >= 7.2) - build-depends: haddock >= 2.9.4 && < 2.10 - else - build-depends: haddock >= 2.8 && <= 2.9.2 + +test-suite spec + type: + exitcode-stdio-1.0 + main-is: + Spec.hs + ghc-options: + -Wall -Werror -threaded + hs-source-dirs: + src, test + build-depends: + base >= 4.0 && < 4.6 + , ghc >= 6.12 && < 7.6 + , syb + , deepseq + , directory + , process + , ghc-paths == 0.1.* + , HUnit == 1.2.* + , hspec-shouldbe + , transformers + , stringbuilder + , filepath diff --git a/src/DocTest.hs b/src/DocTest.hs --- a/src/DocTest.hs +++ b/src/DocTest.hs @@ -8,13 +8,14 @@ import Test.HUnit (Test(..), assertEqual, Assertion) import qualified Interpreter -import HaddockBackend.Api +import Parse toTestCase :: Interpreter.Interpreter -> DocTest -> Test toTestCase repl test = TestLabel sourceFile $ TestCase $ toAssertion repl test where - sourceFile = source test + -- FIXME: use source location here + sourceFile = moduleName test -- | -- Execute all expressions from given 'DocTest' in given @@ -25,11 +26,10 @@ -- 'Interpreter.Interpreter' for several calls to `toAssertion`. toAssertion :: Interpreter.Interpreter -> DocTest -> Assertion toAssertion repl test = do - _ <- Interpreter.eval repl $ ":m *" ++ moduleName _ <- Interpreter.eval repl $ ":reload" + _ <- Interpreter.eval repl $ ":m *" ++ moduleName test mapM_ interactionToAssertion $ interactions test where - moduleName = module_ test interactionToAssertion x = do result' <- Interpreter.eval repl exampleExpression assertEqual ("expression `" ++ exampleExpression ++ "'") diff --git a/src/Extract.hs b/src/Extract.hs new file mode 100644 --- /dev/null +++ b/src/Extract.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Extract (Module(..), extract) where + +import Prelude hiding (mod, catch) +import Control.Monad +import Control.Applicative +import Control.Exception + +import Control.DeepSeq (deepseq, NFData(rnf)) +import Data.Generics + +import GHC hiding (flags, Module) +import NameSet (NameSet) +import Coercion (Coercion) +import FastString (unpackFS) +import Digraph (flattenSCCs) + +import GhcUtil (withGhc) + +-- | A wrapper around `SomeException`, to allow for a custom `Show` instance. +newtype ExtractError = ExtractError SomeException + deriving Typeable + +instance Show ExtractError where + show (ExtractError e) = + unlines [ + "Ouch! Hit an error thunk in GHC's AST while extracting documentation." + , "" + , " " ++ msg + , "" + , "This is most likely a bug in doctest." + , "" + , "Please report it here: https://github.com/sol/doctest-haskell/issues/new" + ] + where + msg = case fromException e of + Just (Panic s) -> "GHC panic: " ++ s + _ -> show e + +instance Exception ExtractError + +-- | Documentation for a module grouped together with the modules name. +data Module = Module { + moduleName :: String +, moduleDocumentation :: [String] +} deriving (Eq, Show) + +instance NFData Module where + rnf (Module name docs) = name `deepseq` docs `deepseq` () + +-- | Parse a list of modules. +parse :: [String] -- ^ flags + -> [String] -- ^ files/modules + -> IO [TypecheckedModule] +parse flags modules = withGhc flags $ do + mapM (flip guessTarget Nothing) modules >>= setTargets + mods <- depanal [] False + let sortedMods = flattenSCCs (topSortModuleGraph False mods Nothing) + reverse <$> mapM (parseModule >=> typecheckModule >=> loadModule) sortedMods + +-- | 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] -- ^ flags + -> [String] -- ^ files/modules + -> IO [Module] +extract flags modules = do + mods <- parse flags modules + let docs = map extractFromModule (map 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 +extractFromModule m = Module name docs + where + docs = map unLoc (docStringsFromModule m) + name = (moduleNameString . GHC.moduleName . ms_mod . pm_mod_summary) m + +-- | Extract all docstrings from given module. +docStringsFromModule :: ParsedModule -> [Located String] +docStringsFromModule mod = map (fmap unpackDocString) docs + where + source = (unLoc . pm_parsed_source) mod + + -- we use dlist-style concatenation here + docs = (maybe id (:) mHeader . maybe id (++) mExports) 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. + mHeader = hsmodHaddockModHeader source + mExports = f `fmap` hsmodExports source + where + f xs = [L loc doc | L loc (IEDoc doc) <- xs] + decls = extractDocStrings (hsmodDecls source) + + +type Selector a = a -> ([LHsDocString], Bool) + +-- | Ignore a subtree. +ignore :: Selector a +ignore = const ([], True) + +-- | Collect given value and descend into subtree. +select :: a -> ([a], Bool) +select x = ([x], False) + +-- | Extract all docstrings from given value. +extractDocStrings :: Data a => a -> [LHsDocString] +extractDocStrings = everythingBut (++) (([], False) `mkQ` fromLHsDecl + `extQ` fromLDocDecl + `extQ` fromLHsDocString + `extQ` (ignore :: Selector NameSet) + `extQ` (ignore :: Selector PostTcKind) + + -- HsExpr never contains any documentation, but it may contain error thunks. + -- + -- Problematic are (non comprehensive): + -- + -- * parallel list comprehensions + -- * infix operators + -- + `extQ` (ignore :: Selector (HsExpr RdrName)) + + -- undefined before type checking + `extQ` (ignore :: Selector Coercion) + ) + 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 . L loc . docDeclDoc) x + + _ -> (extractDocStrings decl, True) + + fromLDocDecl :: Selector LDocDecl + fromLDocDecl = select . fmap docDeclDoc + + fromLHsDocString :: Selector LHsDocString + fromLHsDocString = select + +-- | Convert a docstring to a plain string. +unpackDocString :: HsDocString -> String +unpackDocString (HsDocString s) = unpackFS s diff --git a/src/GhcUtil.hs b/src/GhcUtil.hs new file mode 100644 --- /dev/null +++ b/src/GhcUtil.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} +module GhcUtil (withGhc) where + +import Control.Exception + +import GHC.Paths (libdir) +import GHC hiding (flags) +import DynFlags (dopt_set) + +import MonadUtils (liftIO) +import System.Exit (exitFailure) + +#if __GLASGOW_HASKELL__ < 702 +import StaticFlags (v_opt_C_ready) +import Data.IORef (writeIORef) +#else +import StaticFlags (saveStaticFlagGlobals, restoreStaticFlagGlobals) +#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 +#else +bracketStaticFlags action = bracket saveStaticFlagGlobals restoreStaticFlagGlobals (const 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] -> 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] +handleStaticFlags flags = fst `fmap` parseStaticFlags (map noLoc flags) + +handleDynamicFlags :: GhcMonad m => [Located String] -> m () +handleDynamicFlags flags = do + (dynflags, rest, _) <- (setHaddockMode `fmap` getSessionDynFlags) >>= flip parseDynamicFlags flags + case rest of + x : _ -> error ("Unrecognized GHC option: " ++ unLoc x) + _ -> setSessionDynFlags dynflags >> return () + +setHaddockMode :: DynFlags -> DynFlags +setHaddockMode dynflags = (dopt_set dynflags Opt_Haddock) { + hscTarget = HscNothing + , ghcMode = CompManager + , ghcLink = NoLink + } diff --git a/src/HaddockBackend/Api.hs b/src/HaddockBackend/Api.hs deleted file mode 100644 --- a/src/HaddockBackend/Api.hs +++ /dev/null @@ -1,62 +0,0 @@ -module HaddockBackend.Api ( - DocTest(..) -, Interaction(..) -, getDocTests -) where - -import Module (moduleName, moduleNameString) -import HaddockBackend.Markup (examplesFromInterface) - -import Documentation.Haddock( - Interface(ifaceMod, ifaceOrigFilename) - , exampleExpression - , exampleResult - , createInterfaces - , Flag - ) - - -data DocTest = DocExample { - source :: String -- ^ source file - , module_ :: String -- ^ originating module - , interactions :: [Interaction] -} deriving (Show) - - -data Interaction = Interaction { - expression :: String -- ^ example expression - , result :: [String] -- ^ expected result -} deriving (Show) - - --- | --- Extract 'DocTest's from all given modules and all modules included by the --- given modules. --- --- Note that this function can be called only once during process lifetime, so --- use it wisely. -getDocTests :: [Flag] -- ^ List of Haddock flags - -> [String] -- ^ File or module names - -> IO [DocTest] -- ^ Extracted 'DocTest's -getDocTests flags modules = do - interfaces <- createInterfaces flags modules - return $ concat $ map docTestsFromInterface interfaces - - --- | Get name of the module, that is associated with given 'Interface' -moduleNameFromInterface :: Interface -> String -moduleNameFromInterface = moduleNameString . moduleName . ifaceMod - - --- | Get 'DocTest's from 'Interface'. -docTestsFromInterface :: Interface -> [DocTest] -docTestsFromInterface interface = map docTestFromExamples listOfExamples - where - listOfExamples = examplesFromInterface interface - moduleName' = moduleNameFromInterface interface - fileName = ifaceOrigFilename interface - docTestFromExamples examples = - DocExample fileName moduleName' $ map interactionFromExample examples - where - interactionFromExample e = - Interaction (exampleExpression e) (exampleResult e) diff --git a/src/HaddockBackend/Markup.hs b/src/HaddockBackend/Markup.hs deleted file mode 100644 --- a/src/HaddockBackend/Markup.hs +++ /dev/null @@ -1,67 +0,0 @@ -module HaddockBackend.Markup (examplesFromInterface) where - -import Name (Name) -import qualified Data.Map as Map -import Data.Map (Map) -import Documentation.Haddock ( - markup - , DocMarkup(..) - , Interface(ifaceRnDocMap, ifaceRnExportItems, ifaceRnDoc) - , Example - , DocForDecl - , Doc - , DocName - , ExportItem(ExportDoc) - ) - --- | Extract all 'Example's from given 'Interface'. -examplesFromInterface :: Interface -> [[Example]] -examplesFromInterface interface = filter (not . null) $ [fromModuleHeader] ++ fromExportItems ++ fromDeclarations - where - fromModuleHeader = case ifaceRnDoc interface of - Just doc -> extract doc - Nothing -> [] - fromExportItems = - map extractFromExportItem . ifaceRnExportItems $ interface - where - extractFromExportItem (ExportDoc doc) = extract doc - extractFromExportItem _ = [] - fromDeclarations = fromDeclMap $ ifaceRnDocMap interface - -fromDeclMap :: Map Name (DocForDecl DocName) -> [[Example]] -fromDeclMap docMap = concatMap docForDeclName $ Map.elems docMap - -docForDeclName :: DocForDecl name -> [[Example]] -docForDeclName (declDoc, argsDoc) = argsExamples:declExamples - where - declExamples = extractFromMap argsDoc - argsExamples = maybe [] extract declDoc - -extractFromMap :: Map key (Doc name) -> [[Example]] -extractFromMap m = map extract $ Map.elems m - --- | Extract all 'Example's from given 'Doc' node. -extract :: Doc name -> [Example] -extract = markup exampleMarkup - where - exampleMarkup :: DocMarkup name [Example] - exampleMarkup = Markup { - markupEmpty = [], - markupString = const [], - markupParagraph = id, - markupAppend = (++), - markupIdentifier = const [], - markupModule = const [], - markupEmphasis = id, - markupMonospaced = id, - markupUnorderedList = concat, - markupOrderedList = concat, - markupDefList = concatMap combineTuple, - markupCodeBlock = id, - markupURL = const [], - markupAName = const [], - markupPic = const [], - markupExample = id - } - where - combineTuple = uncurry (++) diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -4,7 +4,7 @@ import System.Exit (exitSuccess, exitFailure) import System.IO -import HaddockBackend.Api +import Parse import Options import DocTest @@ -14,21 +14,20 @@ main = do (options, files) <- getOptions let ghciArgs = ghcOptions options ++ files - Interpreter.withInterpreter ghciArgs $ \repl -> do - -- get examples from Haddock comments - let haddockFlags = haddockOptions options - docTests <- getDocTests haddockFlags files + -- get examples from Haddock comments + docTests <- getDocTests (ghcOptions options) files - let (tCount, iCount) = (length docTests, length (concatMap interactions docTests)) - hPutStrLn stderr (formatTestAndInteractionCount tCount iCount) + let (tCount, iCount) = (length docTests, length (concatMap interactions docTests)) + hPutStrLn stderr (formatTestAndInteractionCount tCount iCount) - if DumpOnly `elem` options - then do - -- dump to stdout - print docTests - else do - -- map to unit tests + if DumpOnly `elem` options + then do + -- dump to stdout + print docTests + else do + -- map to unit tests + Interpreter.withInterpreter ghciArgs $ \repl -> do let tests = TestList $ map (toTestCase repl) docTests Counts _ _ errCount failCount <- runTestTT tests if errCount == 0 && failCount == 0 diff --git a/src/Options.hs b/src/Options.hs --- a/src/Options.hs +++ b/src/Options.hs @@ -2,7 +2,6 @@ Option(..) , getOptions , ghcOptions -, haddockOptions ) where import Control.Monad (when) @@ -12,10 +11,12 @@ import System.Console.GetOpt -import qualified Documentation.Haddock as Haddock - +import Paths_doctest (version) +import Data.Version (showVersion) +import Config as GHC data Option = Help + | Version | Verbose | GhcOption String | DumpOnly @@ -25,6 +26,7 @@ documentedOptions :: [OptDescr Option] documentedOptions = [ Option [] ["help"] (NoArg Help) "display this help and exit" + , Option [] ["version"] (NoArg Version) "output version information and exit" , Option ['v'] ["verbose"] (NoArg Verbose) "explain what is being done, enable Haddock warnings" , Option [] ["optghc"] (ReqArg GhcOption "OPTION") "option to be forwarded to GHC" ] @@ -44,6 +46,11 @@ putStr usage exitSuccess + when (Version `elem` options) $ do + putStrLn ("doctest version " ++ showVersion version) + putStrLn ("using version " ++ GHC.cProjectVersion ++ " of the GHC API") + exitSuccess + when ((not . null) errors) $ do tryHelp $ head errors @@ -67,11 +74,3 @@ -- ["-foo","-bar"] ghcOptions :: [Option] -> [String] ghcOptions opts = [ option | GhcOption option <- opts ] - - --- | Format given list of options for Haddock. -haddockOptions :: [Option] -> [Haddock.Flag] -haddockOptions opts = verbosity ++ ghcOpts - where - verbosity = if (Verbose `elem` opts) then [Haddock.Flag_Verbosity "3"] else [Haddock.Flag_Verbosity "0", Haddock.Flag_NoWarnings] - ghcOpts = map Haddock.Flag_OptGhc $ ghcOptions opts diff --git a/src/Parse.hs b/src/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Parse.hs @@ -0,0 +1,85 @@ +module Parse ( + DocTest(..) +, Interaction(..) +, getDocTests + +-- * exported for testing +, parse +) where + +import Data.Char (isSpace) +import Data.List +import Data.Maybe (fromMaybe) + +import Extract + +data DocTest = DocExample { + moduleName :: String +, interactions :: [Interaction] +} deriving (Eq, Show) + + +data Interaction = Interaction { + expression :: String -- ^ example expression +, result :: [String] -- ^ expected result +} deriving (Eq, Show) + + +-- | +-- Extract 'DocTest's from all given modules and all modules included by the +-- given modules. +getDocTests :: [String] -- ^ List of GHC flags + -> [String] -- ^ File or module names + -> IO [DocTest] -- ^ Extracted 'DocTest's +getDocTests flags modules = do + mods <- extract flags modules + return (concatMap moduleToDocTest mods) + +-- | Convert a `Module` to a list of `DocTest`s. +moduleToDocTest :: Module -> [DocTest] +moduleToDocTest (Module name docs) = (map (DocExample name) . filter (not . null) . map parse) docs + +-- | Extract all interactions from given Haddock documentation. +parse :: String -> [Interaction] +parse input = go (lines input) + where + isPrompt = isPrefixOf ">>>" . dropWhile isSpace + isBlankLine = null . dropWhile isSpace + isEndOfInteraction x = isPrompt x || isBlankLine x + + go :: [String] -> [Interaction] + go xs = + case dropWhile (not . isPrompt) xs of + prompt:rest -> + let + (ys,zs) = break isEndOfInteraction rest + in + toInteraction prompt ys : go zs + _ -> [] + +-- | Create an `Interaction`, strip superfluous whitespace as appropriate. +toInteraction :: String -> [String] -> Interaction +toInteraction x xs = + Interaction + (strip $ drop 3 e) -- we do not care about leading and trailing + -- whitespace in expressions, so drop them + result_ + where + -- 1. drop trailing whitespace from the prompt, remember the prefix + (prefix, e) = span isSpace x + + -- 2. drop, if possible, the exact same sequence of whitespace + -- characters from each result line + -- + -- 3. interpret lines that only contain the string "" as an + -- empty line + result_ = map (substituteBlankLine . tryStripPrefix prefix) xs + where + tryStripPrefix pre ys = fromMaybe ys $ stripPrefix pre ys + + substituteBlankLine "" = "" + substituteBlankLine line = line + +-- | Remove leading and trailing whitespace. +strip :: String -> String +strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse diff --git a/src/Test/DocTest.hs b/src/Test/DocTest.hs --- a/src/Test/DocTest.hs +++ b/src/Test/DocTest.hs @@ -15,13 +15,15 @@ , withInterpreter ) where -import HaddockBackend.Api import DocTest import Interpreter (Interpreter) import qualified Interpreter +-- | Instead of what the name suggests, this returns the module name, not the +-- file name. sourcePath :: DocTest -> FilePath -sourcePath = source +sourcePath = moduleName +{-# DEPRECATED sourcePath "this function will vanish in a future release" #-} firstExpression :: DocTest -> String firstExpression test = expression $ head $ interactions test diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import Test.Hspec.ShouldBe + +import qualified ExtractSpec +import qualified ParseSpec +import qualified InterpreterSpec +import qualified MainSpec + +main :: IO () +main = hspecX $ do + describe "ExtractSpec" ExtractSpec.spec + describe "ParseSpec" ParseSpec.spec + describe "InterpreterSpec" InterpreterSpec.spec + describe "MainSpec" MainSpec.spec