diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,31 @@ +Copyright (c) 2020, Henning Thielemann + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 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-extract.cabal b/doctest-extract.cabal new file mode 100644 --- /dev/null +++ b/doctest-extract.cabal @@ -0,0 +1,107 @@ +Cabal-Version: 2.2 +Name: doctest-extract +Version: 0.1 +License: BSD-3-Clause +License-File: LICENSE +Author: Henning Thielemann +Maintainer: Henning Thielemann +Homepage: https://hub.darcs.net/thielema/doctest-extract/ +Category: Testing +Synopsis: Alternative doctest implementation that extracts comments to modules +Description: + @doctest-extract@ lets you write test examples and QuickCheck properties + in Haddock comments and extracts them to test modules. + It means that the user sees your tests in the documentation + and knows that the examples and properties are machine-tested, + or at least, she can run the tests herself. + . + I found the barrier to write tests much lower + when I do not need to write new test modules + but just add some lines to the Haddock comments. + I do not need to think of test names or filling test data structures. + The test identifier is the module name and the line number and + if a test fails I can easily jump to the failing code. + . + . + Differences to the original GHCi-based implementation of @doctest@: + . + Pros: + . + * Package versions for tests are consistent with tested library + . + * Tests run much faster, especially QuickCheck property tests + . + * No dependency on GHCi or GHC-as-library + . + * The tested package need not be ready for compilation. + Our simple parser requires only clearly recognizable Haskell comments. + . + * QuickCheck properties do not cause confusing type error messages + when actually only identifiers are missing. + . + * You can inspect extracted modules + . + * @doctest@ collects tests from the transitive hull of imports + of the specified modules. + This might help you to keep the list of modules short. + @doctest-extract@ only processes the specified modules + and thus allows you to focus on a module for development of tests. + . + * With option @--verbose@ test source path and line number are formatted + such that Emacs allows you to click and jump to the test definition. + . + * Report success only of real tests. + @doctest@ reports successful imports and + definition of helper types and functions as successful tests. + This makes it hard to monitor the number of real tests, + e.g. whether some tests have been dropped by accident. + . + Cons: + . + * Cannot test for output of IO functions + or error messages from partial functions. + . + * All free variables in QuickCheck properties + must be all-quantified using lambda. + (Could be even seen as an advantage for the reader of your doctests.) + . + * No support for a single-line 'let' as an example. + . + * The Test module does not automatically import modules + that the tested module imports. + Thus, you usually have to add a setup section with required imports. + . + * You need tools additional to @Cabal@, e.g. @make@ and a @Makefile@, + in order generate test modules. +Tested-With: GHC==7.4.2, GHC==8.6.5 +Build-Type: Simple + +Source-Repository this + Tag: 0.1 + Type: darcs + Location: https://hub.darcs.net/thielema/doctest-extract/ + +Source-Repository head + Type: darcs + Location: https://hub.darcs.net/thielema/doctest-extract/ + +Executable doctest-extract-0.1 + Build-Depends: + doctest-lib >=0.0 && <0.2, + optparse-applicative >=0.11 && <0.17, + pathtype >=0.8 && <0.9, + transformers >=0.5.6 && <0.6, + non-empty >=0.3.3 && <0.4, + semigroups >=0.18.5 && <0.20, + utility-ht >=0.0.16 && <0.1, + base >=4.5 && <5 + + GHC-Options: -Wall + Hs-Source-Dirs: src + Default-Language: Haskell98 + Main-Is: Main.hs + Other-Modules: + Format + Parse + Option + ModuleName diff --git a/src/Format.hs b/src/Format.hs new file mode 100644 --- /dev/null +++ b/src/Format.hs @@ -0,0 +1,154 @@ +module Format where + +import qualified ModuleName +import Parse (Module(..), Line, Column) +import Test.DocTest.Parse (DocTest(Property, Example)) +import Test.DocTest.Location (Located(Located)) + +import qualified Data.Monoid.HT as Mn +import qualified Data.List.Match as Match +import qualified Data.List.HT as ListHT +import Data.Semigroup ((<>)) +import Data.Foldable (foldMap) +import Data.Char (isSpace) + +import qualified System.Path.IO as PathIO +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path +import System.Path.Directory (createDirectoryIfMissing) +import System.Path (()) + +import Text.Printf (printf) + + + +indentRemainder :: Int -> String -> String +indentRemainder n str = + let (prefix, suffix) = break isSpace str + in prefix ++ Mn.when (not $ null suffix) (replicate n ' ' ++ suffix) + + +type Pos = (Line, Column) + +type Flags = (Bool, Bool) + +writeTestSuite :: + (PathClass.AbsRel ar) => + Path.Dir ar -> + ModuleName.T -> Flags -> [Module [Located Pos DocTest]] -> IO () +writeTestSuite outDir testPrefix flags ms = do + let testDir = outDir ModuleName.dirPath testPrefix + mapM_ (writeTestModule testDir testPrefix flags) ms + +importDriver :: String +importDriver = "import qualified Test.DocTest.Driver as DocTest" + +writeTestMain :: + (PathClass.AbsRel ar) => + Bool -> + Path.File ar -> ModuleName.T -> + ModuleName.T -> [Module [Located Pos DocTest]] -> IO () +writeTestMain run path mainName testPrefix ms = do + let indent = map (" " ++) + let prefixed = ModuleName.string . (testPrefix<>) . moduleName + PathIO.writeFile path $ unlines $ + "-- Do not edit! Automatically created with doctest-extract." : + printf "module %s where" (ModuleName.string mainName) : + "" : + map (printf "import qualified %s" . prefixed) ms ++ + "" : + importDriver : + "" : + (if run + then + "main :: IO ()" : + "main = DocTest.run $ do" : + [] + else + "main :: DocTest.T ()" : + "main = do" : + [] + )++ + indent (map (printf "%s.test" . prefixed) ms) + +writeTestModule :: + (PathClass.AbsRel ar) => + Path.Dir ar -> ModuleName.T -> Flags -> Module [Located Pos DocTest] -> IO () +writeTestModule testDir testPrefix flags m = do + let path = testDir ModuleName.filePath (moduleName m) + createDirectoryIfMissing True $ Path.takeDirectory path + PathIO.writeFile path $ formatTestModule testPrefix flags m + +-- ToDo: move to List.HT +mapLast :: (a -> a) -> [a] -> [a] +mapLast f xs = zipWith id (drop 1 (Match.replicate xs id) ++ [f]) xs + +formatTestModule :: + ModuleName.T -> Flags -> Module [Located Pos DocTest] -> String +formatTestModule testPrefix (verbose,importTested) m = + let escapedPath = show $ Path.toString $ modulePath m + formatLinePragma loc = + printf "{-# LINE %d %s #-}" loc escapedPath + formatPragma (Located loc lns) = + unlines $ + formatLinePragma loc : + map + (\ln -> + Mn.when (not $ null ln) (printf "{-# OPTIONS_GHC %s #-}" ln)) + lns + formatImport (Located loc lns) = + unlines $ + formatLinePragma loc : + map (\(Located col ln) -> indentRemainder col ln) lns + isExample (Located _loc (Example _ _)) = True; isExample _ = False + formatTest (Located (loc,col) body) = + let testCode command mark code = + (if verbose + then [printf " DocTest.printLine %s\n" (show code)] else []) ++ + formatLinePragma loc : + (' ':command) : + formatLinePragma loc : + (case lines code of + (':':'{':firstLine) : remainingLines -> + (replicate (col + length mark) ' ' ++ '(':firstLine) : + map (replicate (max 2 col) ' ' ++) + (mapLast ((++")") . ListHT.dropRev 2) + remainingLines) + _ -> [replicate (col + length mark) ' ' ++ '(':code++")"]) ++ + [] + in (if verbose + then printf " DocTest.printLine ('\\n':%s++\":%d:1\")" escapedPath loc + else printf " DocTest.printPrefix \"%s:%d: \"" + (ModuleName.string $ moduleName m) loc) : + case body of + Property prop -> testCode "DocTest.property" "prop>" prop + Example str results -> + testCode "DocTest.example" ">>>" str ++ + (" " ++ showsPrec 11 results "") : + [] + in printf + "-- Do not edit! Automatically created with doctest-extract from %s\n" + (Path.toString $ modulePath m) + ++ + foldMap formatPragma (modulePragma m) + ++ + printf "module %s where\n\n" + (ModuleName.string $ testPrefix <> moduleName m) + ++ + Mn.when importTested + (printf "import %s\n" $ ModuleName.string $ moduleName m) + ++ + Mn.when (any isExample $ concat $ moduleContent m) + "import Test.DocTest.Base\n" + ++ + importDriver ++ "\n\n" + ++ + foldMap formatImport (moduleSetup m) + ++ + "\n" + ++ + "test :: DocTest.T ()\n" + ++ + "test = do\n" + ++ + (unlines $ concatMap formatTest $ concat $ moduleContent m) diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,62 @@ +module Main where + +import qualified Format +import qualified Parse +import qualified Option +import qualified ModuleName + +import qualified Options.Applicative as OP +import qualified System.Path.IO as PathIO +import System.Path (()) + +import System.IO.Error (catchIOError) + +import qualified Data.Foldable as Fold +import qualified Data.NonEmpty as NonEmpty +import Data.Traversable (for) +import Data.Foldable (for_) +import Data.Semigroup ((<>)) + +import Control.Monad (when) +import Control.Applicative ((<$>)) + + +{- +'mplus' in base>=4.9 (GHC>=8.0) + +Orphan instance importable from transformers:Control.Monad.Trans.Error, +but this is deprecated. +-} +alternative :: IO a -> IO a -> IO a +alternative m n = catchIOError m (const n) + +alternatives :: NonEmpty.T [] (IO a) -> IO a +alternatives = Fold.foldr1 alternative + + +main :: IO () +main = do + (inDirs, outDir, testPrefix, + (executableMain, libraryMain), + (flags,emitModuleList), moduleNames) <- + OP.execParser $ Option.info Option.parser + + modules <- + fmap (map Parse.parseModule) $ + for moduleNames $ \moduleName -> do + let fileName = ModuleName.filePath moduleName + alternatives $ flip fmap inDirs $ \inDir -> do + let path = inDir fileName + Parse.moduleFromLines moduleName path . + Parse.numberedLines . filter ('\r'/=) + <$> PathIO.readFile path + Format.writeTestSuite outDir testPrefix flags modules + for_ executableMain $ \mainPath -> + Format.writeTestMain True + (outDir mainPath) (ModuleName.singleton "Main") testPrefix modules + for_ libraryMain $ \mainName -> do + let fullName = testPrefix <> mainName + Format.writeTestMain False + (outDir ModuleName.filePath fullName) fullName testPrefix modules + when emitModuleList $ + putStrLn $ unlines $ map (ModuleName.string . (testPrefix<>)) moduleNames diff --git a/src/ModuleName.hs b/src/ModuleName.hs new file mode 100644 --- /dev/null +++ b/src/ModuleName.hs @@ -0,0 +1,49 @@ +module ModuleName ( + T(..), + singleton, + parse, + dirPath, + filePath, + ) where + +import qualified Data.NonEmpty.Class as NonEmptyC +import qualified Data.NonEmpty as NonEmpty +import qualified Data.Foldable as Fold +import Data.Semigroup (Semigroup, (<>)) + +import qualified System.Path.PartClass as PathClass +import qualified System.Path as Path +import System.Path (joinPath, (<.>)) + +import Control.Monad (when) + + +data T = Cons { + string :: String, + components :: NonEmpty.T [] String + } deriving (Show) + +instance Semigroup T where + Cons name0 components0 <> Cons name1 components1 = + Cons + (name0 ++ '.' : name1) + (NonEmptyC.append components0 components1) + +singleton :: String -> T +singleton name = Cons name (NonEmpty.singleton name) + +parse :: String -> Either String T +parse name = do + let comps = NonEmpty.chop ('.'==) name + when (Fold.any null comps) (Left "empty module name component") + return (Cons name comps) + + +genericPath :: (PathClass.FileDir fd) => T -> Path.Rel fd +genericPath = joinPath . NonEmpty.flatten . ModuleName.components + +dirPath :: T -> Path.RelDir +dirPath = genericPath + +filePath :: T -> Path.RelFile +filePath name = genericPath name <.> "hs" diff --git a/src/Option.hs b/src/Option.hs new file mode 100644 --- /dev/null +++ b/src/Option.hs @@ -0,0 +1,79 @@ +module Option where + +import qualified Options.Applicative as OP + +import qualified ModuleName + +import qualified System.Path as Path + +import qualified Data.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) + +import qualified Control.Applicative.HT as App +import Control.Applicative ((<$>), (<*>)) + + +mainParser :: OP.Parser (Maybe Path.RelFile, Maybe ModuleName.T) +mainParser = + App.lift2 (,) + (OP.option (Just <$> OP.eitherReader Path.parse) $ + OP.long "executable-main" <> + OP.metavar "PATH" <> + OP.value Nothing <> + OP.help "Main module importing and running all test modules") + (OP.option (Just <$> OP.eitherReader ModuleName.parse) $ + OP.long "library-main" <> + OP.metavar "MODULENAME" <> + OP.value Nothing <> + OP.help "Library module importing and running all test modules") + +parser :: + OP.Parser + (NonEmpty.T [] Path.AbsRelDir, Path.AbsRelDir, ModuleName.T, + (Maybe Path.RelFile, Maybe ModuleName.T), + ((Bool, Bool), Bool), [ModuleName.T]) +parser = + App.lift6 (,,,,,) + (fmap + (fromMaybe (NonEmpty.singleton (Path.toAbsRel Path.currentDir)) . + NonEmpty.fetch) + $ + OP.many $ OP.option (OP.eitherReader Path.parse) $ + OP.short 'i' <> + OP.long "import-dir" <> + OP.metavar "DIR" <> + OP.help "Import directory") + (OP.option (OP.eitherReader Path.parse) $ + OP.short 'o' <> + OP.long "output-dir" <> + OP.metavar "DIR" <> + OP.value (Path.toAbsRel $ Path.relDir "test") <> + OP.help "Output directory") + (OP.option (OP.eitherReader ModuleName.parse) $ + OP.long "module-prefix" <> + OP.metavar "PREFIX" <> + OP.value (ModuleName.singleton "Test") <> + OP.help "Module name prefix for test modules") + mainParser + (App.lift2 (,) + (App.lift2 (,) + (OP.switch $ + OP.long "verbose" <> + OP.help "Show test code before running test") + (OP.switch $ + OP.long "import-tested" <> + OP.help "Test.A imports A automatically")) + (OP.switch $ + OP.long "emit-module-list" <> + OP.help "Emit list of test modules for use in Cabal.Other-Modules")) + (OP.many $ OP.argument (OP.eitherReader ModuleName.parse) $ + OP.metavar "MODULE" <> + OP.help "Module containing DocTest comments") + +info :: OP.Parser a -> OP.ParserInfo a +info p = + OP.info + (OP.helper <*> p) + (OP.fullDesc <> + OP.progDesc "Extract DocTests in Haskell comments into modules") diff --git a/src/Parse.hs b/src/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Parse.hs @@ -0,0 +1,196 @@ +module Parse where + +import Test.DocTest.Parse (DocTest, parseComment) +import Test.DocTest.Location (Located(Located), unLoc) + +import qualified ModuleName + +import qualified System.Path as Path + +import qualified Data.NonEmpty as NonEmpty +import qualified Data.List.Reverse.StrictSpine as Rev +import qualified Data.List.HT as ListHT +import Data.Functor.Identity (Identity, runIdentity) +import Data.Traversable (traverse) +import Data.NonEmpty ((!:)) +import Data.Maybe.HT (toMaybe) +import Data.Maybe (fromMaybe, isNothing) +import Data.Tuple.HT (mapFst) +import Data.Char (isSpace) + +import qualified Control.Monad.Trans.State as MS +import qualified Control.Functor.HT as FuncHT +import Control.Monad (guard) +import Control.Applicative (optional, (<$>), (<|>)) + + + +type Line = Int +type Column = Int + +data Module a = + Module { + moduleName :: ModuleName.T, + modulePath :: Path.AbsRelFile, + modulePragma :: Maybe (Located Line [String]), + moduleSetup :: Maybe (Located Line [Located Column String]), + moduleContent :: [a] + } deriving (Show) + +emptyModule :: Module a -> Bool +emptyModule (Module _ _ pragma setup tests) = + null tests && isNothing pragma && isNothing setup + + +moduleFromLines :: + ModuleName.T -> Path.AbsRelFile -> + [Located Line String] -> Module [Located (Line, Column) String] +moduleFromLines modName path nLines = + let (pragmas,setup) = + FuncHT.unzip $ fmap extractPragmas $ extractInit "setup" nLines + in Module { + moduleName = modName, + modulePath = path, + modulePragma = pragmas, + moduleSetup = setup, + moduleContent = extractComments nLines + } + + +type FlexParser = MS.StateT (Located Column String) +type LineParser = FlexParser Maybe + +parseLine :: (Monad m) => FlexParser m a -> String -> m a +parseLine p line = MS.evalStateT p $ Located 0 line + +parseWithLineNumber :: + (Monad m) => + FlexParser m () -> Located n String -> m (Located (n,Column) String) +parseWithLineNumber p (Located n line) = + parseLine (p >> getWithLineNumber n) line + +getWithLineNumber :: + (Monad m) => n -> FlexParser m (Located (n,Column) String) +getWithLineNumber n = MS.gets $ \(Located col line) -> Located (n,col) line + +nextChar :: LineParser Char +nextChar = MS.StateT $ \(Located col line0) -> do + (c,line1) <- ListHT.viewL line0 + return (c, Located (col+1) line1) + +matchChar :: Char -> LineParser () +matchChar c = guard . (c==) =<< nextChar + +match :: String -> LineParser () +match = mapM_ matchChar + +matchEnd :: LineParser () +matchEnd = MS.gets (null . unLoc) >>= guard + +{- +For @m = Maybe@ it holds + +> trap p = p <|> return () +-} +trap :: (Monad m) => LineParser () -> FlexParser m () +trap p = MS.modify $ \line -> fromMaybe line $ MS.execStateT p line + +class (Monad m) => ToMaybe m where monadToMaybe :: m a -> Maybe a +instance ToMaybe Maybe where monadToMaybe = id +instance ToMaybe Identity where monadToMaybe = Just . runIdentity + +skip :: (ToMaybe m) => (Char -> Bool) -> FlexParser m () +skip cond = + let go = trap (nextChar >>= guard . cond >> MS.mapStateT monadToMaybe go) + in go + +skipSpaces :: (ToMaybe m) => FlexParser m () +skipSpaces = skip isSpace + + +matchCommentHead :: + String -> Located n String -> + Maybe ([Located n String] -> + (NonEmpty.T [] (Located (n, Column) String), [Located n String])) +matchCommentHead ident (Located n line) = + let matchIdent = match ident >> skipSpaces >> getWithLineNumber n + in flip parseLine line $ do + skipSpaces + singleLineComments <$> (match "-- " >> matchIdent) + <|> + multiLineComment <$> + (match "{-" >> optional (matchChar ' ') >> matchIdent) + +extractPragmas :: + Located Line [Located col String] -> + (Located Line [String], Located Line [Located col String]) +extractPragmas (Located start initial) = + let (pragmas,setup) = + ListHT.spanJust + (\(Located _ ln) -> + ListHT.maybePrefixOf ":set " ln + <|> + toMaybe (null $ dropWhile isSpace ln) "") + initial + in (Located start pragmas, Located (start + length pragmas) setup) + +extractInit :: + String -> [Located n String] -> Maybe (Located n [Located Column String]) +extractInit name = + fmap (\fsuff -> + let NonEmpty.Cons (Located (n,col) ln) lns = fst $ uncurry ($) fsuff + in Located n $ + ((Located col $ + if null ln then "" else "-- junk after setup keyword: " ++ ln) : ) $ + ListHT.takeWhileJust $ + map + (parseLine (skipSpaces >> match ">>>" >> + (matchChar ' ' <|> matchEnd) >> MS.get) . unLoc) + lns) + . + ListHT.dropWhileNothing (matchCommentHead ('$':name)) + +extractComments :: [Located n String] -> [[Located (n, Column) String]] +extractComments = + let go ts = + case ListHT.dropWhileNothing (matchCommentHead "|") ts of + Nothing -> [] + Just (splitPart,suffix) -> + let (part,remainder) = splitPart suffix + in NonEmpty.flatten part : go remainder + in go + +singleLineComments :: + Located (n, Column) String -> [Located n String] -> + (NonEmpty.T [] (Located (n, Column) String), [Located n String]) +singleLineComments firstLine suffix = + mapFst (firstLine!:) $ + ListHT.spanJust + (parseWithLineNumber $ skipSpaces >> match "--" >> skipSpaces) + suffix + +multiLineComment :: + Located (n, Column) String -> [Located n String] -> + (NonEmpty.T [] (Located (n, Column) String), [Located n String]) +multiLineComment firstLine0 suffix0 = + let maybeClosing = ListHT.maybeSuffixOf "-}" . Rev.dropWhile isSpace + in case traverse maybeClosing firstLine0 of + Just firstLine1 -> (NonEmpty.singleton firstLine1, suffix0) + Nothing -> + let (part,msuffix1) = + ListHT.breakJust (traverse maybeClosing) suffix0 + unindent = runIdentity . parseWithLineNumber skipSpaces + in mapFst (NonEmpty.appendRight (firstLine0 !: map unindent part)) $ + case msuffix1 of + Nothing -> ([], []) + Just (lastLine,suffix1) -> ([unindent lastLine], suffix1) + +numberedLines :: String -> [Located Line String] +numberedLines = zipWith Located [1..] . lines + + +-- | Convert documentation to `Example`s. +parseModule :: Module [Located pos String] -> Module [Located pos DocTest] +parseModule modu = + modu {moduleContent = + filter (not . null) $ map parseComment $ moduleContent modu}