packages feed

doctest 0.5.2 → 0.6.0

raw patch · 11 files changed

+390/−179 lines, 11 filesdep +deepseqdep +filepathdep +hspec-shouldbedep −containersdep −haddockdep ~basedep ~ghc

Dependencies added: deepseq, filepath, hspec-shouldbe, stringbuilder, syb, transformers

Dependencies removed: containers, haddock

Dependency ranges changed: base, ghc

Files

doctest.cabal view
@@ -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 <sol@typeful.net> maintainer:       Simon Hengel <sol@typeful.net> 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
src/DocTest.hs view
@@ -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 ++ "'")
+ src/Extract.hs view
@@ -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
+ src/GhcUtil.hs view
@@ -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+    }
− src/HaddockBackend/Api.hs 
@@ -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)
− src/HaddockBackend/Markup.hs 
@@ -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 (++)
src/Main.hs view
@@ -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
src/Options.hs view
@@ -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
+ src/Parse.hs view
@@ -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 "<BLANKLINE>" as an+    -- empty line+    result_ = map (substituteBlankLine . tryStripPrefix prefix) xs+      where+        tryStripPrefix pre ys = fromMaybe ys $ stripPrefix pre ys++        substituteBlankLine "<BLANKLINE>" = ""+        substituteBlankLine line          = line++-- | Remove leading and trailing whitespace.+strip :: String -> String+strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse
src/Test/DocTest.hs view
@@ -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
+ test/Spec.hs view
@@ -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