diff --git a/.gitignore b/.gitignore index 178135c2..0875789e 100644 --- a/.gitignore +++ b/.gitignore @@ -1 +1,3 @@ /dist/ +/.cabal-sandbox +cabal.sandbox.config diff --git a/README.markdown b/README.markdown index de656f30..2d26ff66 100644 --- a/README.markdown +++ b/README.markdown @@ -214,6 +214,14 @@ Alternatively you can pass any GHC options to Doctest, e.g.: [language-pragma]: http://www.haskell.org/ghc/docs/latest/html/users_guide/pragmas.html#language-pragma +### Running specific tests + +You can choose to run a subset of your doctests in a project by specifying one or more --dt--select flags. + + doctest --dt-select=Foo src/*.hs # All tests in the Foo module + doctest --dt-select=Foo:22 src/*.hs # Doctest on line 22 of module Foo + doctest --dt-select=Foo:22-25 src/*.hs # Doctest between lines 22 and 25 inclusive. + ### Cabal integration Doctest provides both, an executable and a library. The library exposes a diff --git a/doctest.cabal b/doctest.cabal index 9a48b2a7..9bdbd57a 100644 --- a/doctest.cabal +++ b/doctest.cabal @@ -46,6 +46,7 @@ library , Run , Util , Sandbox + , TestSelector build-depends: base == 4.* , ghc >= 7.0 && < 7.8 diff --git a/src/Help.hs b/src/Help.hs index b8e76cf8..30c2f075 100644 --- a/src/Help.hs +++ b/src/Help.hs @@ -11,13 +11,19 @@ import Interpreter (ghc) usage :: String usage = unlines [ "Usage:" - , " doctest [ GHC OPTION | MODULE ]..." + , " doctest [ --dt-select=:[-lineEnd] | GHC OPTION | MODULE ]..." , " doctest --help" , " doctest --version" , "" , "Options:" - , " --help display this help and exit" - , " --version output version information and exit" + , " --help display this help and exit" + , " --version output version information and exit" + , " --dt-select=:[[-lastLine]]" + , " Selectively run doctests based on Module and line" + , " numbers. Can specify more than one of this option." + , " e.g: --dt-select=Foo All tests in Foo" + , " --dt-select=Foo:13 Foo line 13 " + , " --dt-select=Bar:13-15 Foo lines 13-15" ] printVersion :: IO () diff --git a/src/Run.hs b/src/Run.hs index d4e4a71a..a21e55b5 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -22,6 +22,11 @@ import Parse import Help import Runner import qualified Interpreter +import TestSelector + ( extractTestSelectors + , filterModules + , Args (Args) + , TestSelector ) ghcPackageDbFlag :: String #if __GLASGOW_HASKELL__ >= 706 @@ -58,18 +63,25 @@ doctest args hPutStrLn stderr "WARNING: GHC does not support --interactive, skipping tests" exitSuccess - let (f, args_) = stripOptGhc args - when f $ do - hPutStrLn stderr "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly." - hFlush stderr - r <- doctest_ (addPackageConf args_) `E.catch` \e -> do - case fromException e of - Just (UsageError err) -> do - hPutStrLn stderr ("doctest: " ++ err) - hPutStrLn stderr "Try `doctest --help' for more information." - exitFailure - _ -> E.throwIO e - when (not $ isSuccess r) exitFailure + either + (usageError . show) + (\ (Args selectors ghcArgs) -> do + let (f , args_) = stripOptGhc ghcArgs + + when f $ do + hPutStrLn stderr "WARNING: --optghc is deprecated, doctest now accepts arbitrary GHC options\ndirectly." + hFlush stderr + r <- doctest_ selectors (addPackageConf args_) `E.catch` \e -> do + case fromException e of + Just (UsageError err) -> usageError err + _ -> E.throwIO e + when (not $ isSuccess r) exitFailure) + (extractTestSelectors args) + where + usageError err = do + hPutStrLn stderr ("doctest: " ++ err) + hPutStrLn stderr "Try `doctest --help' for more information." + exitFailure isSuccess :: Summary -> Bool isSuccess s = sErrors s == 0 && sFailures s == 0 @@ -88,11 +100,11 @@ stripOptGhc = go "--optghc" : opt : rest -> (True, opt : snd (go rest)) opt : rest -> maybe (fmap (opt :)) (\x (_, xs) -> (True, x :xs)) (stripPrefix "--optghc=" opt) (go rest) -doctest_ :: [String] -> IO Summary -doctest_ args = do +doctest_ :: [TestSelector] -> [String] -> IO Summary +doctest_ testSelectors args = do -- get examples from Haddock comments - modules <- getDocTests args + modules <- filterModules testSelectors <$> getDocTests args Interpreter.withInterpreter args $ \repl -> do runModules repl modules diff --git a/src/TestSelector.hs b/src/TestSelector.hs new file mode 100644 index 00000000..9d04cb51 --- /dev/null +++ b/src/TestSelector.hs @@ -0,0 +1,196 @@ +module TestSelector + (extractTestSelectors + , filterModuleContent + , filterModules + , TestSelector (..) + , LineSelector (..) + , Args (..) + , ArgParserError (..) + ) where + +import Extract (Module,moduleName,moduleContent) +import Location + (Located (Located) + , Location (Location,UnhelpfulLocation)) +import Parse (DocTest) +import Data.List (isPrefixOf,stripPrefix) +import Data.Monoid (Monoid (mempty,mappend)) +import Control.Applicative ((<$>),(<*>),pure) +import Control.Monad.Trans.State + ( StateT (StateT) + , evalStateT + , runStateT ) +import Data.Char (isDigit,isLetter) +import Data.Maybe (fromMaybe) +import Data.Either (rights) + +type GhcArg = String +data Args = Args [TestSelector] [GhcArg] deriving (Show,Eq) + +instance Monoid Args where + mappend (Args ats aghc) (Args bts bghc) = Args (ats ++ bts) (aghc ++ bghc) + mempty = Args [] [] + +data TestSelector = TestSelector { + selectModule :: String + , lineSelector :: LineSelector + } deriving (Show,Eq) + +data LineSelector = + AllLines | + SingleLine Int | + FromStart Int | + FromEnd Int | + LineRange Int Int + deriving (Show,Eq) + +data ArgParserError = ArgParserError { + expected :: String, + remainingText :: String + } deriving (Eq) + +instance Show ArgParserError where + show (ArgParserError e remain) = + unwords [ + "Error parsing" + , prefix + , "arg. Expected" + , e + , "at '" ++ remain ++ "'"] + +type ArgParserEither = Either ArgParserError +type ArgParser a = StateT String ArgParserEither a + +extractTestSelectors :: [String] -> ArgParserEither Args +extractTestSelectors = foldl accumSelector $ Right mempty + where + accumSelector :: ArgParserEither Args -> String -> ArgParserEither Args + accumSelector a arg = + mappend <$> a <*> if prefix `isPrefixOf` arg + then fmap (\ts -> Args [ts] []) $ parseTestSelector arg + else pure $ Args [] [arg] + + parseTestSelector :: String -> ArgParserEither TestSelector + parseTestSelector s = flip evalStateT s $ do + expectText prefix + expectText "=" + modNm <- parseModule + lineSel <- firstMatch [ + parseLineRange + , parseFromStart + , parseFromEnd + , parseSingleLine + , parseAllLines + ] + "|:|:-|:-|:-" + return $ TestSelector modNm lineSel + + parseAllLines = const AllLines <$> expectEof + parseLineRange = do + start <- parseLineStart + end <- parseLineEnd + expectEof + return $ LineRange start end + + parseFromStart = do + expectText ":" + end <- parseLineEnd + expectEof + return $ FromStart end + + parseFromEnd = do + start <- parseLineStart + expectText "-" + expectEof + return $ FromStart start + + parseSingleLine = do + start <- parseLineStart + expectEof + return $ SingleLine start + + parseModule = do + modStart <- expect isLetter "Module name starting with a letter" + modRest <- fromMaybe "" <$> tryParse (spanParse (/= ':') "Module name") + return (modStart:modRest) + + firstMatch ps desc = StateT $ \s -> + maybe + (Left $ ArgParserError desc s) + Right + ( headMaybe . rights . map (`runStateT` s) $ ps) + + expect :: (Char -> Bool) -> String -> ArgParser Char + expect p d = StateT $ \s -> + maybe + (Left $ ArgParserError d s) + (\c -> if p c then Right (c,tail s) else Left $ ArgParserError d s) + (headMaybe s) + + expectEof = StateT $ \s -> + if null s then Right ((),s) else Left $ ArgParserError "" s + + headMaybe [] = Nothing + headMaybe (x:_) = Just x + + parseLineStart = do + expectText ":" + read <$> spanParse isDigit "Line number start" + + parseLineEnd = do + expectText "-" + read <$> spanParse isDigit "Line number end" + + expectText :: String -> ArgParser () + expectText t = StateT $ \s -> + maybe + (Left $ ArgParserError t s) + (\rest -> Right ((),rest)) + (stripPrefix t s) + + spanParse :: (Char -> Bool) -> String -> ArgParser String + spanParse f desc = StateT $ \s -> + case span f s of + ([],rest) -> (Left . ArgParserError desc) rest + t -> Right t + + tryParse :: ArgParser a -> ArgParser (Maybe a) + tryParse p = StateT $ \s -> Right $ + either + (const (Nothing,s)) + ( \(a,s') -> (Just a , s')) + (runStateT p s) + +prefix :: String +prefix = "--dt-select" + +filterModules :: + [TestSelector] -> + [Module [Located DocTest]] -> + [Module [Located DocTest]] +filterModules ss = + filter (not . null . moduleContent) . map (filterModuleContent ss) + +filterModuleContent :: + [TestSelector] -> + Module [Located DocTest] -> + Module [Located DocTest] +filterModuleContent [] m = m +filterModuleContent ss m = filterContent applicableSelectors + where + applicableSelectors = filter ((moduleName m ==) . selectModule ) ss + filterContent ss' = m { moduleContent = filteredContent ss' } + + filteredContent ss' = + filter (not . null) $ map (filter $ filterDocTest ss') $ moduleContent m + + filterDocTest _ (Located (UnhelpfulLocation _) _) = False + filterDocTest ss' (Located (Location _ l) _) = any (selectorMatches l) ss' + + selectorMatches _ (TestSelector _ AllLines) = True + selectorMatches l (TestSelector _ (SingleLine s)) = l == s + selectorMatches l (TestSelector _ (FromStart e)) = l <= e + selectorMatches l (TestSelector _ (FromEnd s)) = l >= s + selectorMatches l (TestSelector _ (LineRange s e)) = l >= s && l <= e + + diff --git a/test/MainSpec.hs b/test/MainSpec.hs index a2967367..dba74d72 100644 --- a/test/MainSpec.hs +++ b/test/MainSpec.hs @@ -23,7 +23,7 @@ doctest :: FilePath -- ^ current directory of `doctest` process -> Summary -- ^ expected test result -> Assertion doctest workingDir args summary = do - r <- withCurrentDirectory ("test/integration" workingDir) (hSilence [stderr] $ doctest_ args) + r <- withCurrentDirectory ("test/integration" workingDir) (hSilence [stderr] $ doctest_ [] args ) assertEqual label summary r where label = workingDir ++ " " ++ show args diff --git a/test/RunSpec.hs b/test/RunSpec.hs index 50b20f10..0adebd8e 100644 --- a/test/RunSpec.hs +++ b/test/RunSpec.hs @@ -98,7 +98,7 @@ spec = do describe "doctest_" $ do context "on parse error" $ do - let action = withCurrentDirectory "test/integration/parse-error" (doctest_ ["Foo.hs"]) + let action = withCurrentDirectory "test/integration/parse-error" (doctest_ [] ["Foo.hs"]) it "aborts with (ExitFailure 1)" $ do hSilence [stderr] action `shouldThrow` (== ExitFailure 1) diff --git a/test/TestSelectorSpec.hs b/test/TestSelectorSpec.hs new file mode 100644 index 00000000..19f2da15 --- /dev/null +++ b/test/TestSelectorSpec.hs @@ -0,0 +1,145 @@ +module TestSelectorSpec (main, spec) where + +import Test.Hspec +import Orphans () +import TestSelector +import Extract (Module (Module)) +import Location + ( Located (Located) + ,Location (Location,UnhelpfulLocation)) +import Parse (DocTest (Property),moduleContent) +main :: IO () +main = hspec spec + +spec :: Spec +spec = do + + describe "extractTestSelectors" $ do + it "should return all args when no --dt-select= options" $ + extractTestSelectors ["foo","bar"] `shouldBe` (Right $ Args [] ["foo","bar"]) + + it "should return a selector and leave other args alone" $ + extractTestSelectors + [ "--dt-select=foo:21" ,"bar"] + `shouldBe` + (Right $ Args [TestSelector "foo" $ SingleLine 21] ["bar"]) + + it "should return a selector with start and end line num" $ + extractTestSelectors + [ "--dt-select=foo:21-23"] + `shouldBe` + (Right $ Args [TestSelector "foo" $ LineRange 21 23] []) + + it "should return AllLines lineSelector if no line numbers given" $ + extractTestSelectors [ "--dt-select=foo" , "rest"] + `shouldBe` + (Right $ Args [TestSelector "foo" AllLines] ["rest"]) + + it "should return left if just line numbers given" $ + extractTestSelectors [ "--dt-select=21-23"] + `shouldBe` + (Left $ ArgParserError "Module name starting with a letter" "21-23") + + it "should return left if no module given" $ + extractTestSelectors [ "--dt-select="] + `shouldBe` + (Left $ ArgParserError "Module name starting with a letter" "") + + it "should return left if no equals given" $ + extractTestSelectors [ "--dt-select"] + `shouldBe` + (Left $ ArgParserError "=" "") + + it "should return left if --dt-select=: given" $ + extractTestSelectors [ "--dt-select=Foo:"] + `shouldBe` + lineSelectorParseError ":" + + + it "should return left if start line isn't a number" $ + extractTestSelectors [ "--dt-select=Foo:bar" ] + `shouldBe` + lineSelectorParseError ":bar" + + it "should return left if start line isn't a number" $ + extractTestSelectors [ "--dt-select=Foo:1-foo" ] + `shouldBe` + lineSelectorParseError ":1-foo" + + describe "filterModuleContent" $ do + let loc1 = Located (Location "" 13) (Property " ") + loc2 = Located (Location "" 22) (Property " ") + loc3 = Located (Location "" 24) (Property " ") + loc4 = Located (UnhelpfulLocation "") (Property " ") + testModule = Module "foo" Nothing [[loc1,loc2,loc3,loc4]] + + it "should filter nothing with no selectors" $ + filterModuleContent [] testModule `shouldBe` testModule + + it "should filter everything with a selector that doesn't apply" $ + filterModuleContent [TestSelector "bar" AllLines] testModule + `shouldBe` + testModule { moduleContent = [] } + + it "should keep the stuff that is selected" $ + filterModuleContent [TestSelector "foo" $ SingleLine 22] testModule + `shouldBe` + testModule { moduleContent = [[loc2]] } + + it "should filter a range" $ + filterModuleContent [TestSelector "foo" $ LineRange 13 22] testModule + `shouldBe` + testModule { moduleContent = [[loc1,loc2]] } + + it "should include all lines of a AllLines lineselected module" $ + filterModuleContent [TestSelector "foo" AllLines] testModule + `shouldBe` + testModule { moduleContent = [[loc1,loc2,loc3]]} + + it "should include all lines from start to the specified line" $ + filterModuleContent [TestSelector "foo" $ FromStart 22] testModule + `shouldBe` + testModule { moduleContent = [[loc1,loc2]] } + + it "should include all lines from start to the specified line" $ + filterModuleContent [TestSelector "foo" $ FromEnd 22] testModule + `shouldBe` + testModule { moduleContent = [[loc2,loc3]] } + + describe "filterModules" $ do + let loc1 = Located (Location "" 13) (Property " ") + loc2 = Located (Location "" 22) (Property " ") + testModule1 = Module "foo" Nothing [[loc1,loc2]] + testModule2 = Module "bar" Nothing [[loc1,loc2]] + testModules = [testModule1,testModule2] + + it "shouldn't filter anything if there are no filters at all" $ + filterModules [] testModules `shouldBe` testModules + + it "should filter stuff" $ + filterModules [TestSelector "foo" $ SingleLine 22] testModules + `shouldBe` + [testModule1 {moduleContent = [[loc2]] }] + + it "should filter fine with two selectors" $ + filterModules [ + TestSelector "foo" $ SingleLine 22 + , TestSelector "bar" $ SingleLine 13] testModules + `shouldBe` + [testModule1 {moduleContent = [[loc2]] } + , testModule2 {moduleContent = [[loc1]] } ] + + it "should filter a range" $ + filterModules [ TestSelector "foo" $ LineRange 13 22] testModules + `shouldBe` + [testModule1] + + it "should remove modules which become empty" $ + filterModules [TestSelector "foo" $ SingleLine 22] testModules + `shouldBe` + [testModule1 {moduleContent = [[loc2]]}] + +lineSelectorParseError :: String -> Either ArgParserError a +lineSelectorParseError = + Left . ArgParserError "|:|:-|:-|:-" +