Ability to selectively run tests.

.gitignore

@@ -1 +1,3 @@
 /dist/
+/.cabal-sandbox
+cabal.sandbox.config

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

doctest.cabal

@@ -46,6 +46,7 @@ library
     , Run
     , Util
     , Sandbox
+    , TestSelector
   build-depends:
       base          == 4.*
     , ghc           >= 7.0 && < 7.8

src/Help.hs

@@ -11,13 +11,19 @@ import           Interpreter (ghc)
 usage :: String
 usage = unlines [
           "Usage:"
-        , "  doctest [ GHC OPTION | MODULE ]..."
+        , "  doctest [ --dt-select=<Module>:<lineStart>[-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=<Module>:[<firstLine>[-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 ()

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

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
+        ]
+        "<Empty>|:<LineNum>|:-<EndLine>|:<StartLine>-|:<StartLine>-<EndLine>"
+      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
+
+

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

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)