packages feed

doctest (empty) → 0.3.0

raw patch · 8 files changed

+446/−0 lines, 8 filesdep +HUnitdep +basedep +containerssetup-changed

Dependencies added: HUnit, base, containers, ghc, ghc-paths, haddock, process

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2009 Simon Hengel <simon.hengel@web.de>++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ doctest.cabal view
@@ -0,0 +1,41 @@+name:                doctest+version:             0.3.0+stability:           experimental+synopsis:            Test interactive Haskell examples+description:         The doctest program checks examples in source code comments.+                     It is modeled after doctest for Python+                     (<http://docs.python.org/library/doctest.html>).+                     .+                     Documentation is at <http://haskell.org/haskellwiki/DocTest>.+category:            Testing+homepage:            http://haskell.org/haskellwiki/DocTest+license:             MIT+license-file:        LICENSE+copyright:           (c) 2009-2011 Simon Hengel+author:              Simon Hengel+maintainer:          simon.hengel@wiktory.org+build-type:          Simple+cabal-version:       >= 1.6++source-repository head+    type:            git+    location:        git://github.com/sol/doctest-haskell.git++executable doctest+    ghc-options:     -Wall+    hs-source-dirs:  src+    main-is:         Main.hs+    other-modules:+                      Interpreter+                    , Options+                    , HaddockBackend.Api+                    , HaddockBackend.Markup++    build-depends:+                       base       >= 4.0  && < 4.4+                     , containers >= 0.3  && < 0.5+                     , haddock    >= 2.8  && < 2.10+                     , ghc        >= 6.12 && < 7.2+                     , ghc-paths  == 0.1.*+                     , HUnit      == 1.2.*+                     , process    == 1.0.*
+ src/HaddockBackend/Api.hs view
@@ -0,0 +1,57 @@+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 (Eq, Show, Read)+++data Interaction = Interaction {+    expression :: String    -- ^ example expression+  , result     :: [String]  -- ^ expected result+} deriving (Eq, Show, Read)+++-- | Extract 'DocTest's+getDocTests :: [Flag]       -- ^ list of Haddock command-line 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 view
@@ -0,0 +1,71 @@+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 = extractFromMaybe declDoc++extractFromMaybe :: Maybe (Doc name) -> [Example]+extractFromMaybe (Just doc) = extract doc+extractFromMaybe Nothing    = []++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       = concat . map combineTuple,+      markupCodeBlock     = id,+      markupURL           = const [],+      markupAName         = const [],+      markupPic           = const [],+      markupExample       = id+      }+      where+        combineTuple = uncurry (++)
+ src/Interpreter.hs view
@@ -0,0 +1,128 @@+module Interpreter (+  Interpreter+, eval+, withInterpreter+) where++import System.IO+import System.Process+import Control.Exception (bracket)+import Data.Char+import Data.List++import GHC.Paths (ghc)++-- | 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+  }++newInterpreter :: [String] -> IO Interpreter+newInterpreter flags = do+  (Just stdin_, Just stdout_, Nothing, _) <- createProcess $ (proc ghc myFlags) {std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle stdout}+  setMode stdin_+  setMode stdout_+  return Interpreter {hIn = stdin_, hOut = stdout_}+  where+    myFlags = ["-v0", "--interactive", "-ignore-dot-ghci"] ++ flags++    setMode handle = do+      hSetBinaryMode handle False+      hSetBuffering handle LineBuffering+      hSetEncoding handle utf8+++-- | Run an interpreter session.+--+-- Example:+--+-- >>> withInterpreter [] $ \i -> eval i "23 + 42"+-- "65\n"+withInterpreter+  :: [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+  hClose $ hOut repl+++putExpression :: Interpreter -> String -> IO ()+putExpression repl e = do+  hPutStrLn stdin_ $ filterExpression e+  hPutStrLn stdin_ marker+  hFlush stdin_+  return ()+  where+    stdin_ = hIn repl+++-- | 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  :}  "+--+filterExpression :: String -> String+filterExpression e =+  case lines e of+    [] -> e+    l  -> if firstLine == ":{" && lastLine /= ":}" then fail_ else e+      where+        firstLine = strip $ head l+        lastLine  = strip $ last l+        fail_ = error "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 isSuffixOf marker 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
+ src/Main.hs view
@@ -0,0 +1,50 @@+module Main where++import Test.HUnit (runTestTT, Test(..), assertEqual)++import HaddockBackend.Api+import Options++import qualified Interpreter++main :: IO ()+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++    if DumpOnly `elem` options+      then do+        -- dump to stdout+        print docTests+      else do+        -- map to unit tests+        let tests = TestList $ map (toTestCase repl) docTests+        _ <- runTestTT tests+        return ()++toTestCase :: Interpreter.Interpreter -> DocTest -> Test+toTestCase repl test = TestLabel sourceFile $ TestCase $ do+  -- bring module into scope before running tests..+  _ <- Interpreter.eval repl $ ":m *" ++ moduleName+  _ <- Interpreter.eval repl $ ":reload"+  mapM_ interactionToAssertion $ interactions test+  where+    moduleName = module_ test+    sourceFile = source test+    interactionToAssertion x = do+      result' <- Interpreter.eval repl exampleExpression+      assertEqual ("expression `" ++ exampleExpression ++ "'")+        exampleResult $ lines result'+      where+        exampleExpression = expression x+        exampleResult     = map subBlankLines $ result x++        -- interpret lines that only contain the string "<BLANKLINE>" as an+        -- empty line+        subBlankLines "<BLANKLINE>" = ""+        subBlankLines line          = line
+ src/Options.hs view
@@ -0,0 +1,77 @@+module Options (+  Option(..)+, getOptions+, ghcOptions+, haddockOptions+) where++import Control.Monad (when)+import System.Environment (getArgs)+import System.Exit++import System.Console.GetOpt++import qualified Documentation.Haddock as Haddock+++data Option = Help+            | Verbose+            | GhcOption String+            | DumpOnly+            deriving (Show, Eq)+++documentedOptions :: [OptDescr Option]+documentedOptions = [+    Option []     ["help"]        (NoArg Help)                    "display this help 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"+  ]++undocumentedOptions :: [OptDescr Option]+undocumentedOptions = [+    Option []     ["dump-only"]   (NoArg DumpOnly)                "dump extracted test cases to stdout"+  ]+++getOptions :: IO ([Option], [String])+getOptions = do+  args  <- getArgs+  let (options, modules, errors) = getOpt Permute (documentedOptions ++ undocumentedOptions) args++  when (Help `elem` options)+    (printAndExit usage)++  when ((not . null) errors)+    (tryHelp $ head errors)++  when (null modules)+    (tryHelp "no input files\n")++  return (options, modules)+  where+    printAndExit :: String -> IO a+    printAndExit s = putStr s >> exitWith ExitSuccess++    usage = usageInfo "Usage: doctest [OPTION]... MODULE...\n" documentedOptions++    tryHelp message = printAndExit $ "doctest: " ++ message+      ++ "Try `doctest --help' for more information.\n"+++-- | Extract all ghc options from given list of options.+--+-- Example:+--+-- >>> ghcOptions [Help, GhcOption "-foo", Verbose, GhcOption "-bar"]+-- ["-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