diff --git a/DocTest.cabal b/DocTest.cabal new file mode 100644 --- /dev/null +++ b/DocTest.cabal @@ -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 + (). +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 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/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -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 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/Test/DocTest.hs b/Test/DocTest.hs new file mode 100644 --- /dev/null +++ b/Test/DocTest.hs @@ -0,0 +1,83 @@ +-- Copyright (c) 2009 Simon Hengel +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) diff --git a/Test/DocTest/Error.hs b/Test/DocTest/Error.hs new file mode 100644 --- /dev/null +++ b/Test/DocTest/Error.hs @@ -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)) diff --git a/Test/DocTest/Parser.hs b/Test/DocTest/Parser.hs new file mode 100644 --- /dev/null +++ b/Test/DocTest/Parser.hs @@ -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)) diff --git a/Test/DocTest/Util.hs b/Test/DocTest/Util.hs new file mode 100644 --- /dev/null +++ b/Test/DocTest/Util.hs @@ -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)