doctest-extract (empty) → 0.1
raw patch · 8 files changed
+681/−0 lines, 8 filesdep +basedep +doctest-libdep +non-emptysetup-changed
Dependencies added: base, doctest-lib, non-empty, optparse-applicative, pathtype, semigroups, transformers, utility-ht
Files
- LICENSE +31/−0
- Setup.lhs +3/−0
- doctest-extract.cabal +107/−0
- src/Format.hs +154/−0
- src/Main.hs +62/−0
- src/ModuleName.hs +49/−0
- src/Option.hs +79/−0
- src/Parse.hs +196/−0
+ LICENSE view
@@ -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.
+ Setup.lhs view
@@ -0,0 +1,3 @@+#! /usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ doctest-extract.cabal view
@@ -0,0 +1,107 @@+Cabal-Version: 2.2+Name: doctest-extract+Version: 0.1+License: BSD-3-Clause+License-File: LICENSE+Author: Henning Thielemann <haskell@henning-thielemann.de>+Maintainer: Henning Thielemann <haskell@henning-thielemann.de>+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
+ src/Format.hs view
@@ -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)
+ src/Main.hs view
@@ -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
+ src/ModuleName.hs view
@@ -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"
+ src/Option.hs view
@@ -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")
+ src/Parse.hs view
@@ -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}