DocTest (empty) → 0.0.0

raw patch · 8 files changed

+274/−0 lines, 8 filesdep +HUnitdep +basedep +directorysetup-changed

Dependencies added: HUnit, base, directory, filepath, haskell-src, parsec, plugins

Files

DocTest.cabal +31/−0
LICENSE +19/−0
Main.hs +28/−0
Setup.lhs +3/−0
Test/DocTest.hs +83/−0
Test/DocTest/Error.hs +27/−0
Test/DocTest/Parser.hs +59/−0
Test/DocTest/Util.hs +24/−0

+ DocTest.cabal view

@@ -0,0 +1,31 @@+name:                DocTest+version:             0.0.0+stability:           experimental+synopsis:            Test interactive Haskell examples+description:         DocTest checks examples in source code comments.+                     It is modeled after doctest for Python+                     (<http://docs.python.org/library/doctest.html>).+category:            Testing+license:             BSD3+license-file:        LICENSE+author:              Simon Hengel+maintainer:          simon.hengel@web.de+build-depends:+                       base+                     , HUnit+                     , parsec+                     , haskell-src+                     , directory+                     , filepath+                     , plugins+build-type:          Simple++extra-source-files:+                       Test/DocTest.hs+                     , Test/DocTest/Error.hs+                     , Test/DocTest/Parser.hs+                     , Test/DocTest/Util.hs+++executable:          doctest+main-is:             Main.hs

+ 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.

+ Main.hs view

@@ -0,0 +1,28 @@+module Main where++import System.Directory+import System.Environment+import System.FilePath+import Control.Exception(finally)+import Test.DocTest+import Test.DocTest.Parser+import Test.HUnit+++main = do+	withTempDir "DocTestSandbox" run++run tmpdir = do+	args <- getArgs+	docTests <- mapM parseModule args+	tests <- mapM (doTest tmpdir) (concat docTests)+	runTestTT (TestList tests)++withTempDir :: FilePath -> (FilePath -> IO a) -> IO a+withTempDir name action = do+	tmpdir <- catch getTemporaryDirectory (\_ -> return ".")+	let path = combine tmpdir name+	--createDirectory path+	--finally (action path) (removeDirectoryRecursive path)+	createDirectoryIfMissing False path+	action path

+ Setup.lhs view

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

+ Test/DocTest.hs view

@@ -0,0 +1,83 @@+-- Copyright (c) 2009 Simon Hengel <simon.hengel@web.de>+module Test.DocTest where++import Control.Exception+import Test.HUnit+import System.Plugins+import System.IO+import System.FilePath+import System.Directory+import Test.DocTest.Util+++loadTest :: FilePath -> FilePath -> IO Test+loadTest file dir = do+	mv <- load file [dir] [] "docTest"+	case mv of+		LoadFailure msg -> fail ("error while loading " ++ file ++ ": " ++ (concat msg))+		LoadSuccess _ v -> return v+++compileModule filename dir = do+	status <- makeAll filename ["-i" ++ dir]+	case status of+		 MakeFailure errors -> fail (concat errors)+		 MakeSuccess _ file -> return file+++-- Example:+--+-- > makeTest (DocTest "Fib.hs - line 6: " "Fib" "fib 10" "55")+-- "docTest = TestCase (assertEqual \"Fib.hs - line 6: \" (show (fib 10)) \"55\")"++makeTest (DocTest source _ expression result) = (+		"docTest = TestCase (assertEqual \"" +++		source ++ "\" " +++		"(show (" ++ expression ++ "))" ++ " \"" +++		(escape result) ++ "\")"+	)++escape :: String -> String+escape str = replace "\"" "\\\"" $ replace "\\" "\\\\" str+++data DocTest = DocTest {+	  source		:: String+	, _module		:: String+	, expression	:: String+	, result		:: String+	}+	deriving (Show)+++writeModule test moduleName handle = do+	hPutStrLn handle ("module " ++ moduleName ++ " where")+	hPutStrLn handle "import Test.HUnit"+	hPutStrLn handle ("import " ++ (_module test))+	hPutStrLn handle (makeTest test)+++doTest :: FilePath -> DocTest -> IO Test+doTest directory test = do+	let moduleBaseName = replace "." "_" (_module test)+	(filename, handle) <- openTempFile directory (moduleBaseName ++ ".hs")++	putStrLn filename+	let testModuleName = takeBaseName filename++	--withFile filename WriteMode (writeModule test testModuleName)+	writeModule test testModuleName handle+	hClose handle+++	canonicalModulePath <- canonicalizePath $ source test+	putStrLn canonicalModulePath++	let baseDir = packageBaseDir canonicalModulePath (_module test)+	putStrLn baseDir++	obj_file <- compileModule filename baseDir+	loadTest obj_file directory++packageBaseDir :: FilePath -> String -> FilePath+packageBaseDir moduleSrcFile moduleName = stripPostfix (dropExtension moduleSrcFile) (replace "." [pathSeparator] moduleName)

+ Test/DocTest/Error.hs view

@@ -0,0 +1,27 @@+module Test.DocTest.Error where++import Data.List+import Language.Haskell.Syntax+import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Error++data Error = Error {+	  location	:: SrcLoc+	, message	:: String+	}++instance Show Error where+	show (Error (SrcLoc filename line column) message) = intercalate ":" [filename, show line, show column, " " ++ message]++reportError :: Error -> a+reportError e = error (show e)+++_showErrorMessages = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input"+++toSrcLoc :: SourcePos -> SrcLoc+toSrcLoc x = SrcLoc (sourceName x) (sourceLine x) (sourceColumn x)++toError :: ParseError -> Error+toError e = Error (toSrcLoc (errorPos e)) (_showErrorMessages (errorMessages e))

+ Test/DocTest/Parser.hs view

@@ -0,0 +1,59 @@+module Test.DocTest.Parser (parseModule) where++import System.IO+import Language.Haskell.Parser hiding (parseModule)+import Language.Haskell.Syntax+import Text.ParserCombinators.Parsec+import Test.DocTest+import Test.DocTest.Error+import Data.List++parseModule :: FilePath -> IO [DocTest]+parseModule fileName = do+	moduleSource <- readFile fileName++	let moduleName =+		case (parseModuleWithMode (ParseMode fileName) moduleSource) of+			ParseFailed l m								-> reportError (Error l m)+			ParseOk (HsModule _ (Module name) _ _ _)	-> name++	docTests <-+		case (parse manyTestsParser fileName moduleSource) of+			--Left  e -> error ("parse error at " ++ show e)+			Left  e	-> reportError (toError e)+			Right x	-> return x++	return+		(+			map+			(\(expression, result) -> DocTest fileName moduleName expression result)+			docTests+		)++-- Parser++tillEndOfLine :: Parser String+tillEndOfLine = manyTill anyChar newline++commentLine :: Parser String+commentLine = do+	{+		  string "-- "+		; tillEndOfLine+	}++commentLines :: Parser [String]+commentLines = many1 commentLine++docTestStart = string "-- > "++singelTestParser :: Parser (String, String) +singelTestParser = do+	{+		  manyTill anyChar (try docTestStart)+		; expression	<- tillEndOfLine+		; result		<- commentLines+		; return (expression, (intercalate "\n" result))+	}++manyTestsParser = (many (try singelTestParser))

+ Test/DocTest/Util.hs view

@@ -0,0 +1,24 @@+module Test.DocTest.Util where++import Data.List+++-- Source: Posted from Chaddaï Fouché to Haskell-Cafe mailing list.+--+-- Example:+-- > replace "." "/" "Foo.Bar.Baz"+-- "Foo/Bar/Baz"+replace :: (Eq a) => [a] -> [a] -> [a] -> [a]+replace _ _ [] = []+replace old new xs@(y:ys) =+	case stripPrefix old xs of+		Nothing -> y : replace old new ys+		Just ys' -> new ++ replace old new ys' +++--removePost :: [a] -> [a] -> [a]++stripPostfix [] ys = undefined+stripPostfix (x:xs) ys+	| xs == ys	= [x]+	| otherwise	= x : (stripPostfix xs ys)