From 89d478a93e53d0ba989dd64452a8aae421610cc2 Mon Sep 17 00:00:00 2001 From: Ben Kolera Date: Thu, 9 Jan 2014 08:53:33 +1000 Subject: [PATCH 1/8] A start on being able to select specific tests to run. Looks like this will work. Still todo: * make filterModuleContent use lineNumEnd * write tests around error conditions * wire all of this into Run.hs --- src/TestSelector.hs | 112 +++++++++++++++++++++++++++++++++++++++ test/TestSelectorSpec.hs | 60 +++++++++++++++++++++ 2 files changed, 172 insertions(+) create mode 100644 src/TestSelector.hs create mode 100644 test/TestSelectorSpec.hs diff --git a/src/TestSelector.hs b/src/TestSelector.hs new file mode 100644 index 00000000..f5d829cc --- /dev/null +++ b/src/TestSelector.hs @@ -0,0 +1,112 @@ +module TestSelector + (extractTestSelectors + , filterModuleContent + , filterModules + , TestSelector (..) + , Args (..) + , ArgParserError (..) + ) where + +import Extract (Module,moduleName,moduleContent) +import Location + (Located (Located) + , Location (Location,UnhelpfulLocation)) +import Parse (DocTest) +import Data.List (partition,isPrefixOf,stripPrefix,filter,null) +import Data.Monoid (Monoid (mempty,mappend)) +import Control.Applicative ((<$>),(<*>),pure) +import Data.Either (Either,either) +import Control.Monad.Trans.State + ( StateT (StateT) + , get + , modify + , evalStateT + , runStateT ) +import Data.Tuple (swap) +import Data.Maybe (maybe) +import Data.Char (isDigit) + +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 + , lineStart :: Int + , lineEnd :: Maybe Int + } deriving (Show,Eq) + +data ArgParserError = ArgParserError { + expected :: String, + remainingText :: String + } deriving (Eq) + +instance Show ArgParserError where + show (ArgParserError e remain) = + "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 isPrefixOf prefix arg + then fmap (\ts -> Args [ts] []) $ parseTestSelector arg + else pure $ Args [] [arg] + parseTestSelector :: String -> ArgParserEither TestSelector + parseTestSelector s = (flip evalStateT) s $ do + expectText prefix + modName <- spanParse (/= ':') "Module name" + parseDrop 1 + ls <- read <$> spanParse isDigit "Line number" + le <- tryParse parseLineEnd + return $ TestSelector modName ls le + + parseLineEnd = do + expectText "-" + read <$> spanParse isDigit "Line number" + + parseDrop n = modify (drop n) + + 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 = filterLines $ filter ((moduleName m ==) . selectModule ) ss + where + filterLines ss' = m { moduleContent = filter (not . null) $ map (filter $ filterDocTest ss') $ moduleContent m } + filterDocTest :: [TestSelector] -> Located DocTest -> Bool + filterDocTest _ (Located (UnhelpfulLocation _) _) = False + filterDocTest ss' (Located (Location _ line) _) = + any (\s -> line == lineStart s ) ss' + diff --git a/test/TestSelectorSpec.hs b/test/TestSelectorSpec.hs new file mode 100644 index 00000000..46503e54 --- /dev/null +++ b/test/TestSelectorSpec.hs @@ -0,0 +1,60 @@ +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" $ do + extractTestSelectors ["foo","bar"] `shouldBe` (Right $ Args [] ["foo","bar"]) + it "should return a selector and leave other args alone" $ do + extractTestSelectors + [ "--dt-select=foo:21" ,"bar"] + `shouldBe` + (Right $ Args [TestSelector "foo" 21 Nothing] ["bar"]) + it "should return a selector with start and end line num" $ do + extractTestSelectors + [ "--dt-select=foo:21-23"] + `shouldBe` + (Right $ Args [TestSelector "foo" 21 (Just 23)] []) + + describe "filterModuleTests" $ do + let loc1 = Located (Location "" 13) (Property " ") + loc2 = Located (Location "" 22) (Property " ") + testModule = Module "foo" Nothing [[loc1,loc2]] + + it "should filter nothing with no selectors" $ do + filterModuleContent [] testModule `shouldBe` testModule + + it "should filter everything with a selector that doesn't apply" $ do + (filterModuleContent [TestSelector "bar" 22 Nothing] testModule) + `shouldBe` + testModule { moduleContent = [] } + + it "should keep the stuff that is selected" $ do + (filterModuleContent [TestSelector "foo" 22 Nothing] testModule) + `shouldBe` + testModule { moduleContent = [[loc2]] } + + 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 "should filter stuff" $ do + filterModules [TestSelector "foo" 22 Nothing] testModules + `shouldBe` + ([testModule1 {moduleContent = [[loc2]] }]) + From 2e4752a51c2fbbd5d21247230dda24ec1e67ecdd Mon Sep 17 00:00:00 2001 From: Ben Kolera Date: Thu, 9 Jan 2014 21:25:18 +1000 Subject: [PATCH 2/8] Integrated with Run.hs But now I get a weird linking error. vagrant at localhost in ~/src/personal/haskell/doctest $ cabal build Building doctest-0.9.10... Preprocessing library doctest-0.9.10... [14 of 15] Compiling Run ( src/Run.hs, dist/build/Run.o ) In-place registering doctest-0.9.10... Preprocessing executable 'doctest' for doctest-0.9.10... Linking dist/build/doctest/doctest ... /home/vagrant/src/personal/haskell/doctest-haskell/dist/build/libHSdoctest-0.9.10.a(Run.o): In function `s8rZ_info': (.text+0x12f2): undefined reference to `doctestzm0zi9zi10_TestSelector_extractTestSelectorszuzz0_closure' /home/vagrant/src/personal/haskell/doctest-haskell/dist/build/libHSdoctest-0.9.10.a(Run.o): In function `s8qO_info': (.text+0xc86): undefined reference to `doctestzm0zi9zi10_TestSelector_zdfShowArgParserErrorzuzdcshow_info' /home/vagrant/src/personal/haskell/doctest-haskell/dist/build/libHSdoctest-0.9.10.a(Run.o): In function `s8Ca_info': (.text+0xe3c): undefined reference to `doctestzm0zi9zi10_TestSelector_filterModules_info' /home/vagrant/src/personal/haskell/doctest-haskell/dist/build/libHSdoctest-0.9.10.a(Run.o): In function `s8rZ_info': (.text+0x1303): undefined reference to `doctestzm0zi9zi10_TestSelector_extractTestSelectorszulgo_info' /home/vagrant/src/personal/haskell/doctest-haskell/dist/build/libHSdoctest-0.9.10.a(Run.o): In function `doctestzm0zi9zi10_Run_doctest1_srt': (.data+0x238): undefined reference to `doctestzm0zi9zi10_TestSelector_extractTestSelectorszulgo_closure' /home/vagrant/src/personal/haskell/doctest-haskell/dist/build/libHSdoctest-0.9.10.a(Run.o): In function `doctestzm0zi9zi10_Run_doctest1_srt': (.data+0x240): undefined reference to `doctestzm0zi9zi10_TestSelector_zdfShowArgParserErrorzuzdcshow_closure' collect2: error: ld returned 1 exit stat --- src/Run.hs | 42 +++++++++++++++++++++++++++--------------- src/TestSelector.hs | 4 ++-- 2 files changed, 29 insertions(+), 17 deletions(-) diff --git a/src/Run.hs b/src/Run.hs index d4e4a71a..7be35df4 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 index f5d829cc..c1c03d70 100644 --- a/src/TestSelector.hs +++ b/src/TestSelector.hs @@ -12,10 +12,10 @@ import Location (Located (Located) , Location (Location,UnhelpfulLocation)) import Parse (DocTest) -import Data.List (partition,isPrefixOf,stripPrefix,filter,null) +import Data.List (isPrefixOf,stripPrefix) import Data.Monoid (Monoid (mempty,mappend)) import Control.Applicative ((<$>),(<*>),pure) -import Data.Either (Either,either) +--import Data.Either (Either,either) import Control.Monad.Trans.State ( StateT (StateT) , get From d9d6a56c3e6dc2706235df2a8f3e8cdb188b7cdd Mon Sep 17 00:00:00 2001 From: Ben Kolera Date: Sat, 11 Jan 2014 18:49:15 +1000 Subject: [PATCH 3/8] Almost done. Works end to end! Could do with some tests for arg parsing failures, still. --- .gitignore | 2 ++ doctest.cabal | 3 ++- src/Help.hs | 10 ++++--- src/Run.hs | 2 +- src/TestSelector.hs | 42 ++++++++++++++++++----------- test/MainSpec.hs | 2 +- test/RunSpec.hs | 2 +- test/TestSelectorSpec.hs | 57 ++++++++++++++++++++++++++++++---------- 8 files changed, 83 insertions(+), 37 deletions(-) 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/doctest.cabal b/doctest.cabal index 9a48b2a7..25056784 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 @@ -61,7 +62,7 @@ executable doctest main-is: Main.hs ghc-options: - -Wall -threaded + -Wall hs-source-dirs: driver build-depends: diff --git a/src/Help.hs b/src/Help.hs index b8e76cf8..3abc0927 100644 --- a/src/Help.hs +++ b/src/Help.hs @@ -11,13 +11,17 @@ 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:13 --dt-select=Bar:13-15" ] printVersion :: IO () diff --git a/src/Run.hs b/src/Run.hs index 7be35df4..a21e55b5 100644 --- a/src/Run.hs +++ b/src/Run.hs @@ -104,7 +104,7 @@ doctest_ :: [TestSelector] -> [String] -> IO Summary doctest_ testSelectors args = do -- get examples from Haddock comments - modules <- (filterModules testSelectors) <$> 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 index c1c03d70..0d95608e 100644 --- a/src/TestSelector.hs +++ b/src/TestSelector.hs @@ -15,15 +15,11 @@ import Parse (DocTest) import Data.List (isPrefixOf,stripPrefix) import Data.Monoid (Monoid (mempty,mappend)) import Control.Applicative ((<$>),(<*>),pure) ---import Data.Either (Either,either) import Control.Monad.Trans.State ( StateT (StateT) - , get , modify , evalStateT , runStateT ) -import Data.Tuple (swap) -import Data.Maybe (maybe) import Data.Char (isDigit) type GhcArg = String @@ -56,11 +52,11 @@ extractTestSelectors = foldl accumSelector $ Right mempty where accumSelector :: ArgParserEither Args -> String -> ArgParserEither Args accumSelector a arg = - mappend <$> a <*> if isPrefixOf prefix 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 + parseTestSelector s = flip evalStateT s $ do expectText prefix modName <- spanParse (/= ':') "Module name" parseDrop 1 @@ -97,16 +93,30 @@ extractTestSelectors = foldl accumSelector $ Right mempty 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] +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 = filterLines $ filter ((moduleName m ==) . selectModule ) ss +filterModuleContent ss m = filterContent applicableSelectors where - filterLines ss' = m { moduleContent = filter (not . null) $ map (filter $ filterDocTest ss') $ moduleContent m } - filterDocTest :: [TestSelector] -> Located DocTest -> Bool - filterDocTest _ (Located (UnhelpfulLocation _) _) = False - filterDocTest ss' (Located (Location _ line) _) = - any (\s -> line == lineStart s ) ss' + 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 line (TestSelector _ s Nothing) = line == s + selectorMatches line (TestSelector _ s (Just e)) = line >= s && line <= 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 index 46503e54..a79c183e 100644 --- a/test/TestSelectorSpec.hs +++ b/test/TestSelectorSpec.hs @@ -1,7 +1,7 @@ module TestSelectorSpec (main, spec) where import Test.Hspec -import Orphans +import Orphans () import TestSelector import Extract (Module (Module)) import Location @@ -15,37 +15,46 @@ spec :: Spec spec = do describe "extractTestSelectors" $ do - it "should return all args when no --dt-select= options" $ 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" $ do + + it "should return a selector and leave other args alone" $ extractTestSelectors [ "--dt-select=foo:21" ,"bar"] `shouldBe` (Right $ Args [TestSelector "foo" 21 Nothing] ["bar"]) - it "should return a selector with start and end line num" $ do + + it "should return a selector with start and end line num" $ extractTestSelectors [ "--dt-select=foo:21-23"] `shouldBe` (Right $ Args [TestSelector "foo" 21 (Just 23)] []) - describe "filterModuleTests" $ do + describe "filterModuleContent" $ do let loc1 = Located (Location "" 13) (Property " ") loc2 = Located (Location "" 22) (Property " ") - testModule = Module "foo" Nothing [[loc1,loc2]] - - it "should filter nothing with no selectors" $ do + 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" $ do - (filterModuleContent [TestSelector "bar" 22 Nothing] testModule) + it "should filter everything with a selector that doesn't apply" $ + filterModuleContent [TestSelector "bar" 22 Nothing] testModule `shouldBe` testModule { moduleContent = [] } - it "should keep the stuff that is selected" $ do - (filterModuleContent [TestSelector "foo" 22 Nothing] testModule) + it "should keep the stuff that is selected" $ + filterModuleContent [TestSelector "foo" 22 Nothing] testModule `shouldBe` testModule { moduleContent = [[loc2]] } + it "should filter a range" $ + filterModuleContent [TestSelector "foo" 13 (Just 22)] testModule + `shouldBe` + testModule { moduleContent = [[loc1,loc2]] } + describe "filterModules" $ do let loc1 = Located (Location "" 13) (Property " ") loc2 = Located (Location "" 22) (Property " ") @@ -53,8 +62,28 @@ spec = do testModule2 = Module "bar" Nothing [[loc1,loc2]] testModules = [testModule1,testModule2] - it "should filter stuff" $ do + it "shouldn't filter anything if there are no filters at all" $ + filterModules [] testModules `shouldBe` testModules + + it "should filter stuff" $ filterModules [TestSelector "foo" 22 Nothing] testModules `shouldBe` - ([testModule1 {moduleContent = [[loc2]] }]) + [testModule1 {moduleContent = [[loc2]] }] + + it "should filter fine with two selectors" $ + filterModules [ + TestSelector "foo" 22 Nothing + , TestSelector "bar" 13 Nothing] testModules + `shouldBe` + [testModule1 {moduleContent = [[loc2]] } + , testModule2 {moduleContent = [[loc1]] } ] + + it "should filter a range" $ + filterModules [ TestSelector "foo" 13 (Just 22) ] testModules + `shouldBe` + [testModule1] + it "should remove modules which become empty" $ + filterModules [TestSelector "foo" 22 Nothing] testModules + `shouldBe` + [testModule1 {moduleContent = [[loc2]]}] From 82c41d2b32dafeb39fc9ad4a508326e2e1b1abb5 Mon Sep 17 00:00:00 2001 From: Ben Kolera Date: Sat, 11 Jan 2014 21:04:40 +1000 Subject: [PATCH 4/8] Added the ability to include all tests from a module. Also more tests. --- src/Help.hs | 6 +++-- src/TestSelector.hs | 58 +++++++++++++++++++++++++++++----------- test/TestSelectorSpec.hs | 44 +++++++++++++++++++++--------- 3 files changed, 78 insertions(+), 30 deletions(-) diff --git a/src/Help.hs b/src/Help.hs index 3abc0927..30c2f075 100644 --- a/src/Help.hs +++ b/src/Help.hs @@ -18,10 +18,12 @@ usage = unlines [ , "Options:" , " --help display this help and exit" , " --version output version information and exit" - , " --dt-select=:[-lastLine] " + , " --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:13 --dt-select=Bar:13-15" + , " 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/TestSelector.hs b/src/TestSelector.hs index 0d95608e..9a82d714 100644 --- a/src/TestSelector.hs +++ b/src/TestSelector.hs @@ -3,6 +3,7 @@ module TestSelector , filterModuleContent , filterModules , TestSelector (..) + , LineSelector (..) , Args (..) , ArgParserError (..) ) where @@ -17,10 +18,10 @@ import Data.Monoid (Monoid (mempty,mappend)) import Control.Applicative ((<$>),(<*>),pure) import Control.Monad.Trans.State ( StateT (StateT) - , modify , evalStateT , runStateT ) -import Data.Char (isDigit) +import Data.Char (isDigit,isLetter) +import Data.Maybe (fromMaybe) type GhcArg = String data Args = Args [TestSelector] [GhcArg] deriving (Show,Eq) @@ -31,10 +32,12 @@ instance Monoid Args where data TestSelector = TestSelector { selectModule :: String - , lineStart :: Int - , lineEnd :: Maybe Int + , lineSelector :: LineSelector } deriving (Show,Eq) +data LineSelector = + AllLines | SingleLine Int | LineRange Int Int deriving (Show,Eq) + data ArgParserError = ArgParserError { expected :: String, remainingText :: String @@ -42,7 +45,12 @@ data ArgParserError = ArgParserError { instance Show ArgParserError where show (ArgParserError e remain) = - "Error parsing " ++ prefix ++ " arg. Expected " ++ e ++ " at " ++ remain + unwords [ + "Error parsing" + , prefix + , "arg. Expected" + , e + , "at '" ++ remain ++ "'"] type ArgParserEither = Either ArgParserError type ArgParser a = StateT String ArgParserEither a @@ -58,17 +66,34 @@ extractTestSelectors = foldl accumSelector $ Right mempty parseTestSelector :: String -> ArgParserEither TestSelector parseTestSelector s = flip evalStateT s $ do expectText prefix - modName <- spanParse (/= ':') "Module name" - parseDrop 1 - ls <- read <$> spanParse isDigit "Line number" + modStart <- expect isLetter "Module name starting with a letter" + modRest <- fromMaybe "" <$> tryParse (spanParse (/= ':') "Module name") + ls <- tryParse parseLineStart le <- tryParse parseLineEnd - return $ TestSelector modName ls le + return $ TestSelector (modStart : modRest) $ makeLineSelector ls le + + makeLineSelector Nothing _ = AllLines + makeLineSelector (Just s) Nothing = SingleLine s + makeLineSelector (Just s) (Just e) = LineRange s e + + 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) + + + headMaybe [] = Nothing + headMaybe (x:_) = Just x + + parseLineStart = do + expectText ":" + read <$> spanParse isDigit "Line number start" parseLineEnd = do expectText "-" - read <$> spanParse isDigit "Line number" - - parseDrop n = modify (drop n) + read <$> spanParse isDigit "Line number end" expectText :: String -> ArgParser () expectText t = StateT $ \s -> @@ -87,8 +112,8 @@ extractTestSelectors = foldl accumSelector $ Right mempty tryParse p = StateT $ \s -> Right $ either (const (Nothing,s)) - (\(a,s') -> (Just a , s')) - (runStateT p s) + ( \(a,s') -> (Just a , s')) + (runStateT p s) prefix :: String prefix = "--dt-select=" @@ -116,7 +141,8 @@ filterModuleContent ss m = filterContent applicableSelectors filterDocTest _ (Located (UnhelpfulLocation _) _) = False filterDocTest ss' (Located (Location _ l) _) = any (selectorMatches l) ss' - selectorMatches line (TestSelector _ s Nothing) = line == s - selectorMatches line (TestSelector _ s (Just e)) = line >= s && line <= e + selectorMatches _ (TestSelector _ AllLines) = True + selectorMatches l (TestSelector _ (SingleLine s)) = l == s + selectorMatches l (TestSelector _ (LineRange s e)) = l >= s && l <= e diff --git a/test/TestSelectorSpec.hs b/test/TestSelectorSpec.hs index a79c183e..3036850a 100644 --- a/test/TestSelectorSpec.hs +++ b/test/TestSelectorSpec.hs @@ -22,14 +22,29 @@ spec = do extractTestSelectors [ "--dt-select=foo:21" ,"bar"] `shouldBe` - (Right $ Args [TestSelector "foo" 21 Nothing] ["bar"]) - + (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" 21 (Just 23)] []) - + (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" "") + describe "filterModuleContent" $ do let loc1 = Located (Location "" 13) (Property " ") loc2 = Located (Location "" 22) (Property " ") @@ -41,19 +56,24 @@ spec = do filterModuleContent [] testModule `shouldBe` testModule it "should filter everything with a selector that doesn't apply" $ - filterModuleContent [TestSelector "bar" 22 Nothing] testModule + filterModuleContent [TestSelector "bar" AllLines] testModule `shouldBe` testModule { moduleContent = [] } it "should keep the stuff that is selected" $ - filterModuleContent [TestSelector "foo" 22 Nothing] testModule + filterModuleContent [TestSelector "foo" $ SingleLine 22] testModule `shouldBe` testModule { moduleContent = [[loc2]] } it "should filter a range" $ - filterModuleContent [TestSelector "foo" 13 (Just 22)] testModule + 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]]} describe "filterModules" $ do let loc1 = Located (Location "" 13) (Property " ") @@ -66,24 +86,24 @@ spec = do filterModules [] testModules `shouldBe` testModules it "should filter stuff" $ - filterModules [TestSelector "foo" 22 Nothing] testModules + filterModules [TestSelector "foo" $ SingleLine 22] testModules `shouldBe` [testModule1 {moduleContent = [[loc2]] }] it "should filter fine with two selectors" $ filterModules [ - TestSelector "foo" 22 Nothing - , TestSelector "bar" 13 Nothing] testModules + TestSelector "foo" $ SingleLine 22 + , TestSelector "bar" $ SingleLine 13] testModules `shouldBe` [testModule1 {moduleContent = [[loc2]] } , testModule2 {moduleContent = [[loc1]] } ] it "should filter a range" $ - filterModules [ TestSelector "foo" 13 (Just 22) ] testModules + filterModules [ TestSelector "foo" $ LineRange 13 22] testModules `shouldBe` [testModule1] it "should remove modules which become empty" $ - filterModules [TestSelector "foo" 22 Nothing] testModules + filterModules [TestSelector "foo" $ SingleLine 22] testModules `shouldBe` [testModule1 {moduleContent = [[loc2]]}] From 1945d641c628e9e814dc83f1c749f3fc41eecbcb Mon Sep 17 00:00:00 2001 From: Ben Kolera Date: Sat, 11 Jan 2014 21:10:06 +1000 Subject: [PATCH 5/8] And a readme update. --- README.markdown | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/README.markdown b/README.markdown index de656f30..d40bc1d5 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.s + + 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 From e62ea233277438d771c800566e7472a6ab9269e4 Mon Sep 17 00:00:00 2001 From: Ben Kolera Date: Sat, 11 Jan 2014 21:11:00 +1000 Subject: [PATCH 6/8] Removing that extra s. --- README.markdown | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.markdown b/README.markdown index d40bc1d5..2d26ff66 100644 --- a/README.markdown +++ b/README.markdown @@ -216,7 +216,7 @@ Alternatively you can pass any GHC options to Doctest, e.g.: ### Running specific tests -You can choose to run a subset of your doctests in a project by specifying one or more --dt--select flags.s +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 From 6e91df7ae2c28eecd09670a5dd55f88c09dfe281 Mon Sep 17 00:00:00 2001 From: Ben Kolera Date: Sat, 11 Jan 2014 21:15:27 +1000 Subject: [PATCH 7/8] That shouldn't have been removed. Reverting. --- doctest.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doctest.cabal b/doctest.cabal index 25056784..9bdbd57a 100644 --- a/doctest.cabal +++ b/doctest.cabal @@ -62,7 +62,7 @@ executable doctest main-is: Main.hs ghc-options: - -Wall + -Wall -threaded hs-source-dirs: driver build-depends: From e730fa2bc4ff0bc8fc73566cc36864fe3ae9b53a Mon Sep 17 00:00:00 2001 From: Ben Kolera Date: Sun, 12 Jan 2014 12:53:42 +1000 Subject: [PATCH 8/8] Has line ranges that work from the start or end of file. Also much better error handling. --- src/TestSelector.hs | 64 +++++++++++++++++++++++++++++++++++----- test/TestSelectorSpec.hs | 36 ++++++++++++++++++++++ 2 files changed, 92 insertions(+), 8 deletions(-) diff --git a/src/TestSelector.hs b/src/TestSelector.hs index 9a82d714..9d04cb51 100644 --- a/src/TestSelector.hs +++ b/src/TestSelector.hs @@ -22,6 +22,7 @@ import Control.Monad.Trans.State , 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) @@ -36,7 +37,12 @@ data TestSelector = TestSelector { } deriving (Show,Eq) data LineSelector = - AllLines | SingleLine Int | LineRange Int Int deriving (Show,Eq) + AllLines | + SingleLine Int | + FromStart Int | + FromEnd Int | + LineRange Int Int + deriving (Show,Eq) data ArgParserError = ArgParserError { expected :: String, @@ -63,18 +69,56 @@ extractTestSelectors = foldl accumSelector $ Right mempty 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") - ls <- tryParse parseLineStart - le <- tryParse parseLineEnd - return $ TestSelector (modStart : modRest) $ makeLineSelector ls le + return (modStart:modRest) - makeLineSelector Nothing _ = AllLines - makeLineSelector (Just s) Nothing = SingleLine s - makeLineSelector (Just s) (Just e) = LineRange s e + 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 -> @@ -83,6 +127,8 @@ extractTestSelectors = foldl accumSelector $ Right mempty (\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 @@ -116,7 +162,7 @@ extractTestSelectors = foldl accumSelector $ Right mempty (runStateT p s) prefix :: String -prefix = "--dt-select=" +prefix = "--dt-select" filterModules :: [TestSelector] -> @@ -143,6 +189,8 @@ filterModuleContent ss m = filterContent applicableSelectors 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/TestSelectorSpec.hs b/test/TestSelectorSpec.hs index 3036850a..19f2da15 100644 --- a/test/TestSelectorSpec.hs +++ b/test/TestSelectorSpec.hs @@ -44,6 +44,27 @@ spec = do 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 " ") @@ -74,6 +95,16 @@ spec = do 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 " ") @@ -107,3 +138,8 @@ spec = do filterModules [TestSelector "foo" $ SingleLine 22] testModules `shouldBe` [testModule1 {moduleContent = [[loc2]]}] + +lineSelectorParseError :: String -> Either ArgParserError a +lineSelectorParseError = + Left . ArgParserError "|:|:-|:-|:-" +