module Main where import Test.Hspec import Test.Hspec.Core import Test.Hspec.Runner import Test.Hspec.Formatters import Test.Hspec.HUnit () import qualified Test.HUnit as HUnit import qualified Test.Hspec.Monadic import qualified Test.Hspec.Monadic as Monadic import Text.Regex.Posix import System.Environment import System.IO import System.Directory import System.FilePath import System.Exit import System.Plugins import System.Console.GetOpt import Control.Exception import Data.Char (toLower,toUpper,isAlphaNum) debug :: Options -> String -> IO () debug opts msg = if verbose opts then putStrLn (" [verbose] " ++ msg) else return () main :: IO () main = do result <- getArgs >>= runWithArgs case result of Left results -> exitWith . toExitCode . success $ results Right message -> putStrLn message >> exitFailure runWithArgs :: [String] -> IO (Either Specs String) runWithArgs args = do let (targets, errors, opts) = getOptions args if help opts then printHelp >> return (Left []) else if not $ null errors then return $ Right $ unlines errors else runWithTargetsAndOptions targets opts runWithTargetsAndOptions :: [String] -> Options -> IO (Either Specs String) runWithTargetsAndOptions targets opts = do allSpecsFound <- getAllSpecs targets opts if null allSpecsFound then return $ Right "no valid *.hs files found\n" else do result <- runSpecsWithOptions allSpecsFound opts case result of Left results -> do updateLastRunFile opts results return $ Left results Right message -> return $ Right message getAllSpecs :: [String] -> Options -> IO Specs getAllSpecs targets opts = do filenames <- getFileNamesToSearchFromTargets (getTargets opts targets) specs <- getAllSpecsFromFiles filenames opts return $ includeSelfSpecs specs opts runSpecsWithOptions :: Specs -> Options -> IO (Either Specs String) runSpecsWithOptions allFoundSpecs opts = do result <- filterSpecs allFoundSpecs opts case result of Left specsToRun -> runSpecs opts specsToRun >>= return . Left Right noneMessage -> return $ Right noneMessage runSpecs :: Options -> Specs -> IO Specs runSpecs opts specs = withHandle (output opts) work where work h = hHspecWithFormat formatter h specs formatter = getFormatter (formatterToUse opts) (useColor opts) updateLastRunFile :: Options -> [Spec] -> IO () updateLastRunFile opts results = do let fileName = lastRunFile opts failedExamples = unlines [ requirement s | s <- results, isFailure (result s)] isFile <- doesFileExist fileName case (failedCount results, isFile) of (0, True) -> do debug opts $ "removing " ++ fileName ++ " since there are no failed examples" removeFile fileName (0, False) -> debug opts $ "skipping " ++ fileName ++ " since file doesn't exist and there are no failed examples" (_, _ ) -> do debug opts $ "writing failed examples to " ++ fileName writeFile fileName failedExamples getFileNamesToSearchFromTargets :: [String] -> IO [String] getFileNamesToSearchFromTargets names = do files <- mapM getFileNamesToSearchFromTarget names return $ concat files getFileNamesToSearchFromTarget :: String -> IO [String] getFileNamesToSearchFromTarget pathName = do isFile <- doesFileExist pathName isDir <- doesDirectoryExist pathName if isFile then if takeExtension pathName == ".hs" then return [pathName] else return [] else if isDir then do names <- getDirectoryContents pathName let validNames = map (combine pathName) $ filter ((/='.').head) names getFileNamesToSearchFromTargets validNames else fail $ pathName ++ " is not a valid *.hs file or directory name" -- Parsing haskell files hasModuleHeader :: String -> Bool hasModuleHeader contents = getFirstWord contents == "module" -- lame getFirstWord :: String -> String getFirstWord xs@('{':'-':_) = getFirstWord (removeBlockComment xs 0) getFirstWord xs@('-':'-':_) = getFirstWord (removeLineComment xs) getFirstWord (' ':xs) = getFirstWord xs getFirstWord ('\t':xs) = getFirstWord xs getFirstWord ('\n':xs) = getFirstWord xs getFirstWord xs = takeWhile isAlphaNum xs removeBlockComment :: String -> Int -> String removeBlockComment ('-':'}':xs) d | d == 1 = xs | otherwise = removeBlockComment xs (d-1) removeBlockComment ('{':'-':xs) d = removeBlockComment xs (d+1) removeBlockComment (_:xs) d = removeBlockComment xs d removeBlockComment [] _ = fail "bad block comment" removeLineComment :: String -> String removeLineComment ('\n':xs) = xs removeLineComment ('-':'-':xs) = removeLineComment xs removeLineComment (_:xs) = removeLineComment xs removeLineComment [] = fail "bad line comment" -- Loading specs from files getAllSpecsFromFiles :: [String] -> Options -> IO [Spec] getAllSpecsFromFiles filenames opts = fmap concat $ mapM (getAllSpecsFromFile opts) filenames getAllSpecsFromFile :: Options -> String -> IO Specs getAllSpecsFromFile opts filename = do contents <- readFile filename if contents =~ "^module Main where$" then do debug opts $ "skipping " ++ filename ++ " because it is a Main module and those can't be dynamically loaded." return [] else if hasModuleHeader contents then do debug opts $ "seaching " ++ filename (s1,n1) <- getSpecsFromFile filename contents (s2,n2) <- getIOSpecsFromFile filename contents (ms1,n3) <- getMonadicSpecsFromFile filename contents (ms2,n4) <- getMonadicIOSpecsFromFile filename contents mapM_ (debug opts) (map (" "++) (concat $ [n1, n2, n3, n4])) return (s1 ++ s2 ++ ms1 ++ ms2) else do let justName = takeFileName filename cleanName = dropExtension $ toUpper (head justName) : tail justName debug opts $ "skipping " ++ filename ++ " because only library modules (like \"module " ++ cleanName ++ " where\") can be dynamically loaded." return [] getName :: String -> String getName = takeWhile (`notElem`" :") getDeclariations :: String -> String -> [String] getDeclariations pattern contents = map head matches where matches = (contents =~ pattern) :: [[String]] getSpecDeclariations :: String -> [String] getSpecDeclariations = getDeclariations "^[^ ]+ *:: *(Test\\.Hspec\\.)?Specs\\w*$" getSpecsFromFile :: String -> String -> IO (Specs,[String]) getSpecsFromFile filename contents = do let names = getSpecDeclariations contents specs <- mapM (\ n -> loadSpecsFromFile filename (getName n) :: IO Specs) names return (concat specs, names) getIOSpecDeclariations :: String -> [String] getIOSpecDeclariations = getDeclariations "^[^ ]+ *:: *IO +(Test\\.Hspec\\.)?Specs\\w*$" getIOSpecsFromFile :: String -> String -> IO (Specs,[String]) getIOSpecsFromFile filename contents = do let names = getIOSpecDeclariations contents specs <- sequence =<< mapM (\ n -> loadSpecsFromFile filename (getName n) :: IO (IO Specs)) names return (concat specs, names) getMonadicSpecDeclariations :: String -> [String] getMonadicSpecDeclariations = getDeclariations "^[^ ]+ *:: *Test\\.Hspec\\.Monadic\\.Specs\\w*$" getMonadicSpecsFromFile :: String -> String -> IO (Specs,[String]) getMonadicSpecsFromFile filename contents = do let names = getMonadicSpecDeclariations contents specs <- mapM (\ n -> loadSpecsFromFile filename (getName n) :: IO Monadic.Specs) names return (concatMap Monadic.runSpecM specs, names) getMonadicIOSpecDeclariations :: String -> [String] getMonadicIOSpecDeclariations = getDeclariations "^[^ ]+ *:: *IO +Test\\.Hspec\\.Monadic\\.Specs\\w*$" getMonadicIOSpecsFromFile :: String -> String -> IO (Specs,[String]) getMonadicIOSpecsFromFile filename contents = do let names = getMonadicIOSpecDeclariations contents specs <- sequence =<< mapM (\ n -> loadSpecsFromFile filename (getName n) :: IO (IO Monadic.Specs)) names return (concatMap Monadic.runSpecM specs, names) loadSpecsFromFile :: String -> String -> IO a loadSpecsFromFile filename specName = do status <- makeAll filename [] obj <- case status of MakeSuccess _ o -> return o MakeFailure e -> mapM_ putStrLn e >> fail "can't make" mv <- load obj ["."] [] specName case mv of LoadFailure msgs -> putStrLn (unwords msgs) >> fail "can't load" LoadSuccess _ v -> return v -- excluding from loaded specs filterSpecs :: [Spec] -> Options -> IO (Either [Spec] String) filterSpecs allSpecsFound opts = do (matchingSpecs, noneMessage) <- filterByExampleOption opts allSpecsFound specsToRun <- filterByRerunOption opts matchingSpecs return $ if null specsToRun then Right noneMessage else Left specsToRun filterByExampleOption :: Options -> Specs -> IO (Specs, String) filterByExampleOption opts specs = case specificExample opts of Nothing -> return (specs, "no specs found") Just pattern -> do debug opts $ "only running descriptions matching \"" ++ pattern ++ "\"" let s = filterSpecsByRegex pattern specs return (s, "no specs matching \"" ++ pattern ++ "\" found") filterByRerunOption :: Options -> Specs -> IO Specs filterByRerunOption opts specs | lastRunOption opts == RunFailed = do isFile <- doesFileExist (lastRunFile opts) if isFile then do failedDescriptions <- readFile (lastRunFile opts) return $ filterExactSpecs (lines failedDescriptions) specs else return specs | otherwise = return specs filterSpecsByRegex :: String -> Specs -> Specs filterSpecsByRegex pattern = filter p where p s = requirement s =~ pattern filterExactSpecs :: [String] -> Specs -> Specs filterExactSpecs ok = filter p where p s = requirement s `elem` ok -- getting specific options getTargets :: Options -> [String] -> [String] getTargets opts xs | runSelfSpecs opts = xs getTargets _ [] = ["."] getTargets _ xs = xs getFormatter :: String -> (Bool -> Formatter) getFormatter "silent" = silent getFormatter "progress" = progress getFormatter "specdoc" = specdoc getFormatter "failed_examples" = failed_examples getFormatter _ = specdoc useColor :: Options -> Bool useColor opts = case color opts of Nothing -> output opts `elem` ["stdout","stderr"] Just x -> x withHandle :: String -> (Handle -> IO a) -> IO a withHandle "stdout" f = f stdout withHandle "stderr" f = f stderr withHandle filename f = bracket (openFile filename WriteMode) (hClose) (f) includeSelfSpecs :: Specs -> Options -> Specs includeSelfSpecs specs opts | runSelfSpecs opts = specs ++ Monadic.runSpecM allSpecs | otherwise = specs -- getting Options getOptions :: [String] -> ([String], [String], Options) getOptions args = (filenames, errors, opts) where (actions, filenames, errors) = getOpt RequireOrder options args opts = (foldl (.) id actions) startOptions data LastRunOption = RunAll | RunFailed deriving Eq data Options = Options { formatterToUse :: String, output :: String, specificExample :: Maybe String, color :: Maybe Bool, help :: Bool, runSelfSpecs :: Bool, verbose :: Bool, lastRunFile :: String, lastRunOption :: LastRunOption } startOptions :: Options startOptions = Options { formatterToUse = "specdoc", output = "stdout", specificExample = Nothing, color = Nothing, help = False, runSelfSpecs = False, verbose = False, lastRunFile = ".hspecLastRun", lastRunOption = RunAll } trim :: String -> String trim = reverse . dropWhile (==' ') . reverse . dropWhile (==' ') options :: [OptDescr (Options -> Options)] options = [ Option "f" ["format"] (ReqArg (\x s -> s { formatterToUse = trim $ map toLower x }) "FORMAT") "Specifies what format to use for output.\n\ \By default the specdoc format is used.\n\ \FORMAT can be silent, progress, specdoc, or failed_examples." , Option "o" ["output"] (ReqArg (\x s -> s { output = trim $ x }) "FILE_NAME") "Specifies the file to use for output.\n\ \By default output is directed to stdout.\n\ \FILE_NAME can be stdout or stderr for those handles." , Option "e" ["example"] (ReqArg (\x s -> s { specificExample = Just x }) "REGEX") "Only execute examples with a matching description.\n\ \By default all examples are executed." , Option "c" ["color"] (ReqArg (\ x s -> s { color = Just (map toLower (trim x) == "true") }) "TRUE|FALSE") "Force output to have or not have red and green color.\n\ \By default color is only used when output is directed to stdout." , Option "" ["runfile"] (ReqArg (\ x s -> s { lastRunFile = x }) "FILE_NAME") "Use a specific file to log the last run results. This is read when using the --rerun option.\n\ \By default the file \".hspecLastRun\" logs the last run results." , Option "r" ["rerun"] (ReqArg (\ x s -> let opt = case map toLower (trim x) of "all" -> RunAll "failed" -> RunFailed _ -> error $ "unsupported run option \"" ++ x ++ "\"" in s { lastRunOption = opt }) "RERUNOPT") "Rerun a specific subset of specs. This looks at the last run file specified by --runfile.\n\ \RERUNOPT can be \"all\" or \"failed\".\n\ \By default the last run file is ignored and all specs are run." , Option "h?" ["help"] (NoArg (\ s -> s { help = True })) "Display this help." , Option "v" ["verbose"] (NoArg (\ s -> s { verbose = True })) "Display detailed information about what hspec is doing." , Option "" ["specs"] (NoArg (\ s -> s { runSelfSpecs = True })) "Include the specs for the hspec command line runner itself. When used, the target list \n\ \will not default to the current directory. A non-empty target list will still be \n\ \searched though." ] helpInfo :: String helpInfo = "hspec searches through files or folders and runs any top level declarations with \ \a type of `Specs` or `IO Specs`. Monadic specs must be fully qualified, \ \list-based specs may be qualified or not. You can specify specific *.hs \ \files or directories to search through or let hspec search the current \ \directory tree for specs to run.\n\n\ \usage: hspec [OPTIONS] [TARGET_LIST]" printHelp :: IO () printHelp = putStrLn $ usageInfo helpInfo options -- Specs allSpecs :: Test.Hspec.Monadic.Specs allSpecs = Monadic.describe "hspec command line runner" $ do Monadic.it "searches target files for specs and runs them" (True) Monadic.describe "options" $ do let test :: (Eq a, Show a) => String -> a -> (Options -> a) -> IO () test arg expected func = HUnit.assertEqual arg expected (func opts) where (_, _, opts) = getOptions (words arg) Monadic.it "accepts -h, -?, and --help to get help" (do test "-h" True help test "-?" True help test "--help" True help test "" False help) Monadic.it "accepts -c or --color to set weather or not to color the output" (do test "-c false" (Just False) color test "-c true" (Just True) color test "--color false" (Just False) color test "--color true" (Just True) color test "" Nothing color) Monadic.it "accepts -f or --format and a formatter name to use" (do test "-f progress" "progress" formatterToUse test "--format progress" "progress" formatterToUse test "" "specdoc" formatterToUse) Monadic.it "accepts -o or --output and a filename to output to" (do test "-o foo.txt" "foo.txt" output test "--output foo.txt" "foo.txt" output test "" "stdout" output) Monadic.it "accepts -o or --output and stdout or stderr to output to" (do test "-o stderr" "stderr" output test "--output stdout" "stdout" output) Monadic.it "accepts --specs to display it's own specs" (do test "--specs" True runSelfSpecs test "" False runSelfSpecs) Monadic.it "accepts -v or --verbose to display extra details" (do test "-v" True verbose test "--verbose" True verbose test "" False verbose) Monadic.it "accepts one or more targets to search" (let args = ["a", "b"] (files, _, _) = getOptions args in HUnit.assertEqual (unwords args) args files) Monadic.it "defaults to the current directory tree if no targets are specified and not running --specs" (HUnit.assertEqual "" ["."] (getTargets startOptions [])) Monadic.describe "an hspec target" $ do Monadic.it "can be a file name to run all specs in that file" (do filenames <- getFileNamesToSearchFromTargets ["hspec.hs"] HUnit.assertEqual "hspec.hs" ["hspec.hs"] filenames) Monadic.it "can be a directory name to run all specs in that directory tree" (do filenames <- getFileNamesToSearchFromTargets ["."] HUnit.assertBool "hspec.hs" ("./hspec.hs" `elem` filenames)) Monadic.describe "the --format option" $ do let test :: String -> (Bool -> Formatter) -> IO () test arg expected = HUnit.assertEqual arg (formatterName $ expected False) (formatterName $ getFormatter (formatterToUse opts) $ False) where (_, _, opts) = getOptions ["--format", arg] Monadic.it "allows the \"silent\" formatter" (test "silent" silent) Monadic.it "allows the \"progress\" formatter" (test "progress" progress) Monadic.it "allows the \"specdoc\" formatter" (test "specdoc" specdoc) Monadic.it "allows the \"failed_examples\" formatter" (test "failed_examples" failed_examples) Monadic.it "uses \"specdoc\" by default" (test "" specdoc) Monadic.describe "the --color option" $ do let test :: String -> String -> Bool -> IO () test colorArg outputArg expected = HUnit.assertEqual (unwords args) expected (useColor opts) where args = if colorArg == "" then ["-o", outputArg] else ["-c", colorArg, "-o", outputArg] (_, _, opts) = getOptions args Monadic.it "allows \"true\" to force color output" (test "true" "stdout" True) Monadic.it "allows \"false\" to force non-color output" (test "false" "stdout" False) Monadic.it "by default, uses color when outputing to stdout" (test "" "stdout" True) Monadic.it "by default, uses color when outputing to stderr" (test "" "stderr" True) Monadic.it "by default, doesn't color when outputing to a file" (test "" "foo.txt" False) Monadic.describe "searching for specs to run" $ do let test :: String -> [String] -> IO () test contents expected = HUnit.assertEqual contents expected decs where decs = concat [ getSpecDeclariations contents, getIOSpecDeclariations contents, getMonadicSpecDeclariations contents, getMonadicIOSpecDeclariations contents ] Monadic.it "finds top level definitions of type \"Specs\"" (test "\ntest :: Specs\ntest = undefined\n" ["test :: Specs"]) Monadic.it "finds top level definitions of type \"IO Specs\"" (test "\ntest :: IO Specs\ntest = undefined\n" ["test :: IO Specs"]) Monadic.it "finds top level definitions of type \"Test.Hspec.Specs\"" (test "\ntest :: Test.Hspec.Specs\ntest = undefined\n" ["test :: Test.Hspec.Specs"]) Monadic.it "finds top level definitions of type \"IO Test.Hspec.Specs\"" (test "\ntest :: IO Test.Hspec.Specs\ntest = undefined\n" ["test :: IO Test.Hspec.Specs"]) Monadic.it "finds top level definitions of type \"Test.Hspec.Monadic.Specs\"" (test "\ntest :: Test.Hspec.Monadic.Specs\ntest = undefined\n" ["test :: Test.Hspec.Monadic.Specs"]) Monadic.it "finds top level definitions of type \"IO Test.Hspec.Monadic.Specs\"" (test "\ntest :: IO Test.Hspec.Monadic.Specs\ntest = undefined\n" ["test :: IO Test.Hspec.Monadic.Specs"])