diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2009 Simon Hengel + +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. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/doctest.cabal b/doctest.cabal new file mode 100644 --- /dev/null +++ b/doctest.cabal @@ -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 + (). + . + Documentation is at . +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.* diff --git a/src/HaddockBackend/Api.hs b/src/HaddockBackend/Api.hs new file mode 100644 --- /dev/null +++ b/src/HaddockBackend/Api.hs @@ -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) diff --git a/src/HaddockBackend/Markup.hs b/src/HaddockBackend/Markup.hs new file mode 100644 --- /dev/null +++ b/src/HaddockBackend/Markup.hs @@ -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 (++) diff --git a/src/Interpreter.hs b/src/Interpreter.hs new file mode 100644 --- /dev/null +++ b/src/Interpreter.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -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 "" as an + -- empty line + subBlankLines "" = "" + subBlankLines line = line diff --git a/src/Options.hs b/src/Options.hs new file mode 100644 --- /dev/null +++ b/src/Options.hs @@ -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