diff --git a/Setup.lhs b/Setup.lhs --- a/Setup.lhs +++ b/Setup.lhs @@ -1,14 +1,19 @@ -#!/usr/bin/runhaskell +#!/usr/bin/runhaskell > module Main where +> import System > import Distribution.Simple -> import Distribution.PackageDescription(PackageDescription) -> import Distribution.Simple.LocalBuildInfo(LocalBuildInfo) +> import Distribution.Simple.Setup +> import Distribution.PackageDescription +> import Distribution.Simple.LocalBuildInfo > import System.Cmd(system) > import Distribution.Simple.LocalBuildInfo +> import Test.Hspec +> import Specs (specs) > > main :: IO () > main = defaultMainWithHooks hooks -> where hooks = simpleUserHooks { runTests = runspecs } +> where hooks = simpleUserHooks { runTests = \ _ _ _ _ -> runspecs, +> preSDist = \ _ _ -> runspecs >> return emptyHookedBuildInfo } > -> runspecs :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () -> runspecs _ _ _ lbi = system "runhaskell ./Specs.hs" >> return () +> runspecs :: IO () +> runspecs = specs >>= hspecX diff --git a/Specs.hs b/Specs.hs --- a/Specs.hs +++ b/Specs.hs @@ -17,10 +17,11 @@ main :: IO () main = do ar <- getArgs + specs' <- specs ss <- case ar of - ["README"] -> withFile "README" WriteMode (\ h -> hPutStrLn h preamble >> hHspec h specs) - [filename] -> withFile filename WriteMode (\ h -> hHspec h specs) - _ -> hspec specs + ["README"] -> withFile "README" WriteMode (\ h -> hPutStrLn h preamble >> hHspec h specs') + [filename] -> withFile filename WriteMode (\ h -> hHspec h specs') + _ -> hspec specs' exitWith $ toExitCode (failedCount ss == 0) preamble :: String @@ -28,6 +29,9 @@ "hspec aims to be a simple, extendable, and useful tool for Behavior Driven Development in Haskell.", "", "", "Step 1, write descriptions and examples of your desired behavior", + "> module Myabs where", + ">", + "> specs :: IO Specs", "> specs = describe \"myabs\" [", "> it \"returns the original number when given a positive input\"", "> (myabs 1 == 1),", @@ -42,12 +46,13 @@ "Step 2, write whatever you are describing", "> myabs n = undefined", "", - "Step 3, watch your examples fail with red text", - "> hspec specs", + "Step 3, watch your examples fail with red text by running from the .hs file itself", + "> main = hspec specs", + "", "myabs", - " x returns the original number when given a positive input FAILED [1]", - " x returns a positive number when given a negative input FAILED [2]", - " x returns zero when given zero FAILED [3]", + " - returns the original number when given a positive input FAILED [1]", + " - returns a positive number when given a negative input FAILED [2]", + " - returns zero when given zero FAILED [3]", "", "1) myabs returns the original number when given a positive input FAILED", "Prelude.undefined", @@ -62,11 +67,14 @@ "", "3 examples, 3 failures", "", + "", + "Specs can also be run from the command line using the hspec program", + " $ hspec myabs.hs", + "", "Step 4, implement your desired behavior", "> myabs n = if n < 0 then negate n else n", "", - "Step 5, watch your examples pass with green text", - "> hspec specs", + "Step 5, watch your examples pass with green text when rerun", "myabs", " - returns the original number when given a positive input", " - returns a positive number when given a negative input", @@ -98,26 +106,31 @@ let report = lines reportContents - descriptions [ + return $ descriptions [ describe "the \"describe\" function" [ it "takes a description of what the behavior is for" ((=="Example") . name . head $ exampleSpecs), it "groups behaviors for what's being described" - (all ((=="Example").name) exampleSpecs) + (all ((=="Example").name) exampleSpecs), + + describe "a nested description" [ + it "has it's own specs" + (True) + ] ], describe "the \"it\" function" [ it "takes a description of a desired behavior" - (requirement (Spec "Example" "whatever" Success) == "whatever" ), + (requirement (Spec "Example" "whatever" Success 0) == "whatever" ), it "takes an example of that behavior" - (result (Spec "Example" "whatever" Success) == Success), + (result (Spec "Example" "whatever" Success 0) == Success), it "can use a Bool, HUnit Test, QuickCheck property, or \"pending\" as an example" (True), it "will treat exceptions as failures" - (any (==" x exceptions FAILED [3]") report) + (any (==" - exceptions FAILED [3]") report) ], describe "the \"hspec\" function" [ it "displays a header for each thing being described" @@ -126,18 +139,12 @@ it "displays one row for each behavior" (HUnit.assertEqual "" 29 (length report)), - it "displays a '-' for successfull examples" + it "displays a row for successfull examples" (any (==" - pass") report), - it "displays an 'x' for failed examples" - (any (==" x fail 1 FAILED [1]") report), - it "displays a detailed list of failed examples" (any (=="1) Example fail 1 FAILED") report), - it "displays a '-' for pending examples" - (any (==" - pending") report ), - it "displays a '#' and an additional message for pending examples" (any (==" # pending message") report ), @@ -199,7 +206,7 @@ (HUnit.assertEqual "" "Example" (lines reportContents !! 1)), it "can use the \"failed_examples\" formatter to show only failed examples" - (HUnit.assertEqual "" " x fail 1 FAILED [1]" (head $ lines failed_examplesReportContents)) + (HUnit.assertEqual "" "1) Example fail 1 FAILED" (lines failed_examplesReportContents !! 1)) ], describe "quantify (an internal function)" [ it "returns an amount and a word given an amount and word" @@ -214,4 +221,3 @@ it "returns a plural word given the number 0" (quantify (0::Int) "thing" == "0 things") ]] - diff --git a/Test/Hspec/Core.hs b/Test/Hspec/Core.hs --- a/Test/Hspec/Core.hs +++ b/Test/Hspec/Core.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -XFlexibleInstances #-} +{-# OPTIONS -XFlexibleInstances -XExistentialQuantification #-} -- | This module contains the core types, constructors, classes, -- instances, and utility functions common to hspec. @@ -8,29 +8,67 @@ import System.IO import System.IO.Silently import Control.Exception -import Control.Monad (liftM) -- | The result of running an example. -data Result = Success | Fail String | Pending String +data Result = Success | Pending String | Fail String deriving Eq + -- | Everything needed to specify and show a specific behavior. data Spec = Spec { -- | What is being tested, usually the name of a type. name::String, -- | The specific behavior being tested. requirement::String, - -- | The status of this behavior. - result::Result } + -- | The status of the example of this behavior. + result::Result, + -- | The level of nestedness. + depth :: Int } + | UnevaluatedSpec { + -- | What is being tested, usually the name of a type. + name::String, + -- | The specific behavior being tested. + requirement::String, + -- | An example of this behavior. + example::AnyExample, + -- | The level of nestedness. + depth :: Int } -data Formatter = Formatter { exampleGroupStarted :: Handle -> Spec -> IO (), + +data Formatter = Formatter { formatterName :: String, + exampleGroupStarted :: Handle -> Spec -> IO (), examplePassed :: Handle -> Spec -> [String] -> IO (), exampleFailed :: Handle -> Spec -> [String] -> IO (), examplePending :: Handle -> Spec -> [String] -> IO (), errorsFormatter :: Handle -> [String] -> IO (), - footerFormatter :: Handle -> [Spec] -> Double -> IO () } + footerFormatter :: Handle -> [Spec] -> Double -> IO (), + usesFormatting :: Bool } +describe :: String -> [[Spec]] -> [Spec] +describe label specs = map desc (concat specs) + where desc spec + | null $ name spec = spec { name = label } + | otherwise = spec { depth = depth spec + 1 } + +-- | Combine a list of descriptions. +descriptions :: [[Spec]] -> [Spec] +descriptions = concat + +-- | Evaluate a Result. Any exceptions (undefined, etc.) are treated as failures. +safely :: Result -> IO Result +safely f = Control.Exception.catch ok failed + where ok = silence $ f `seq` return f + failed e = return $ Fail (show (e :: SomeException)) + + +evaluateSpec :: Spec -> IO Spec +evaluateSpec (UnevaluatedSpec name' requirement' example' depth') = do + r <- evaluateExample example' + return $ Spec name' requirement' r depth' +evaluateSpec spec = return spec + + -- | Create a set of specifications for a specific type being described. -- Once you know what you want specs for, use this. -- @@ -39,48 +77,26 @@ -- > (abs (-1) == 1) -- > ] -- -describe :: String -- ^ The name of what is being described, usually a function or type. - -> [IO (String, Result)] -- ^ A list of behaviors and examples, created by a list of 'it'. - -> IO [IO Spec] -describe n = return . map (>>= \ (req, res) -> return (Spec n req res)) +it :: Example a => String -> a -> [Spec] +it requirement' example' = [UnevaluatedSpec "" requirement' (AnyExample example') 0] --- | Combine a list of descriptions. -descriptions :: [IO [IO Spec]] -> IO [IO Spec] -descriptions = liftM concat . sequence +class Example a where + evaluateExample :: a -> IO Result --- | Evaluate a Result. Any exceptions (undefined, etc.) are treated as failures. -safely :: Result -> IO Result -safely f = Control.Exception.catch ok failed - where ok = silence $ f `seq` return f - failed e = return $ Fail (show (e :: SomeException)) +instance Example Bool where + evaluateExample bool = safely $ if bool then Success else Fail "" --- | Anything that can be used as an example of a behavior. -class SpecVerifier a where - -- | Create a description and example of a behavior, a list of these - -- is used by 'describe'. Once you know what you want to specify, use this. - -- - -- > describe "closeEnough" [ - -- > it "is true if two numbers are almost the same" - -- > (1.001 `closeEnough` 1.002), - -- > - -- > it "is false if two numbers are not almost the same" - -- > (not $ 1.001 `closeEnough` 1.003) - -- > ] - -- - it :: String -- ^ A description of this behavior. - -> a -- ^ An example for this behavior. - -> IO (String, Result) +instance Example Result where + evaluateExample result' = safely result' -instance SpecVerifier Bool where - it description example = do - r <- safely (if example then Success else Fail "") - return (description, r) +-- | An existentially quantified @Example@. This way they can be mixed within the same set of Specs +data AnyExample = forall a. Example a => AnyExample a -instance SpecVerifier Result where - it description example = do - r <- safely example - return (description, r) +instance Example AnyExample where + evaluateExample (AnyExample a) = evaluateExample a + + -- | Declare an example as not successful or failing but pending some other work. -- If you want to report on a behavior but don't have an example yet, use this. -- @@ -102,7 +118,6 @@ success :: [Spec] -> Bool success = not . failure - isFailure :: Result -> Bool isFailure (Fail _) = True diff --git a/Test/Hspec/Formatters.hs b/Test/Hspec/Formatters.hs --- a/Test/Hspec/Formatters.hs +++ b/Test/Hspec/Formatters.hs @@ -2,6 +2,7 @@ -- They follow a structure similar to RSpec formatters. -- module Test.Hspec.Formatters ( + restoreFormat, silent, specdoc, progress, failed_examples ) where @@ -13,39 +14,50 @@ import System.Console.ANSI silent :: Bool -> Formatter -silent _ = Formatter { +silent useColor = Formatter { + formatterName = "silent", exampleGroupStarted = \ _ _ -> return (), examplePassed = \ _ _ _ -> return (), exampleFailed = \ _ _ _ -> return (), examplePending = \ _ _ _ -> return (), errorsFormatter = \ _ _ -> return (), - footerFormatter = \ _ _ _ -> return () + footerFormatter = \ _ _ _ -> return (), + usesFormatting = useColor } +indentationFor :: Spec -> String +indentationFor spec = replicate (depth spec * 2) ' ' specdoc :: Bool -> Formatter -specdoc useColor = Formatter { +specdoc useColor = (silent useColor) { + formatterName = "specdoc", + exampleGroupStarted = \ h spec -> do when useColor (normalColor h) - hPutStr h ('\n' : name spec ++ "\n"), + hPutStrLn h ("\n" ++ indentationFor spec ++ name spec) + when useColor (restoreFormat h), examplePassed = \ h spec _ -> do when useColor (passColor h) - hPutStrLn h $ " - " ++ requirement spec, + hPutStrLn h $ indentationFor spec ++ " - " ++ requirement spec + when useColor (restoreFormat h), exampleFailed = \ h spec errors -> do when useColor (failColor h) - hPutStrLn h $ " x " ++ requirement spec ++ " FAILED [" ++ (show $ (length errors) + 1) ++ "]", + hPutStrLn h $ indentationFor spec ++ " - " ++ requirement spec ++ " FAILED [" ++ (show $ (length errors) + 1) ++ "]" + when useColor (restoreFormat h), examplePending = \ h spec _ -> do when useColor (pendingColor h) let (Pending s) = result spec - hPutStrLn h $ " - " ++ requirement spec ++ "\n # " ++ s, + hPutStrLn h $ indentationFor spec ++ " - " ++ requirement spec ++ "\n # " ++ s + when useColor (restoreFormat h), errorsFormatter = \ h errors -> do when useColor (failColor h) mapM_ (hPutStrLn h) ("" : intersperse "" errors) - when (not $ null errors) (hPutStrLn h ""), + when (not $ null errors) (hPutStrLn h "") + when useColor (restoreFormat h), footerFormatter = \ h specs time -> do when useColor (if failedCount specs == 0 then passColor h else failColor h) @@ -53,30 +65,34 @@ hPutStrLn h "" hPutStr h $ quantify (length specs) "example" ++ ", " hPutStrLn h $ quantify (failedCount specs) "failure" - when useColor (normalColor h) + when useColor (restoreFormat h) } progress :: Bool -> Formatter -progress useColor = Formatter { - exampleGroupStarted = \ _ _ -> return (), +progress useColor = (silent useColor) { + formatterName = "progress", examplePassed = \ h _ _ -> do when useColor (passColor h) - hPutStr h ".", + hPutStr h "." + when useColor (restoreFormat h), exampleFailed = \ h _ _ -> do when useColor (failColor h) - hPutStr h "F", + hPutStr h "F" + when useColor (restoreFormat h), examplePending = \ h _ _ -> do when useColor (pendingColor h) - hPutStr h $ ".", + hPutStr h $ "." + when useColor (restoreFormat h), errorsFormatter = \ h errors -> do when useColor (failColor h) mapM_ (hPutStrLn h) ("" : intersperse "" errors) - when (not $ null errors) (hPutStrLn h ""), + when (not $ null errors) (hPutStrLn h "") + when useColor (restoreFormat h), footerFormatter = \ h specs time -> do when useColor (if failedCount specs == 0 then passColor h else failColor h) @@ -84,26 +100,19 @@ hPutStrLn h "" hPutStr h $ quantify (length specs) "example" ++ ", " hPutStrLn h $ quantify (failedCount specs) "failure" - when useColor (normalColor h) + when useColor (restoreFormat h) } failed_examples :: Bool -> Formatter -failed_examples useColor = Formatter { - exampleGroupStarted = \ _ _ -> return (), - - examplePassed = \ _ _ _ -> return (), - - exampleFailed = \ h spec errors -> do - when useColor (failColor h) - hPutStrLn h $ " x " ++ requirement spec ++ " FAILED [" ++ (show $ (length errors) + 1) ++ "]", - - examplePending = \ _ _ _ -> return (), +failed_examples useColor = (silent useColor) { + formatterName = "failed_examples", errorsFormatter = \ h errors -> do when useColor (failColor h) mapM_ (hPutStrLn h) ("" : intersperse "" errors) - when (not $ null errors) (hPutStrLn h ""), + when (not $ null errors) (hPutStrLn h "") + when useColor (restoreFormat h), footerFormatter = \ h specs time -> do when useColor (if failedCount specs == 0 then passColor h else failColor h) @@ -111,7 +120,7 @@ hPutStrLn h "" hPutStr h $ quantify (length specs) "example" ++ ", " hPutStrLn h $ quantify (failedCount specs) "failure" - when useColor (normalColor h) + when useColor (restoreFormat h) } @@ -126,3 +135,6 @@ normalColor :: Handle -> IO() normalColor h = hSetSGR h [ Reset ] + +restoreFormat :: Handle -> IO() +restoreFormat h = hSetSGR h [ Reset ] diff --git a/Test/Hspec/HUnit.hs b/Test/Hspec/HUnit.hs --- a/Test/Hspec/HUnit.hs +++ b/Test/Hspec/HUnit.hs @@ -21,16 +21,16 @@ import qualified Test.HUnit as HU import Data.List (intersperse) -instance SpecVerifier (IO ()) where - it description example = it description (HU.TestCase example) +instance Example (IO ()) where + evaluateExample io = evaluateExample (HU.TestCase io) -instance SpecVerifier HU.Test where - it description example = do - (counts, fails) <- silence $ HU.runTestText HU.putTextToShowS example - let r' = if HU.errors counts + HU.failures counts == 0 +instance Example HU.Test where + evaluateExample test = do + (counts, fails) <- silence $ HU.runTestText HU.putTextToShowS test + let r = if HU.errors counts + HU.failures counts == 0 then Success else Fail (details $ fails "") - return (description, r') + return r details :: String -> String details = concat . intersperse "\n" . tail . init . lines diff --git a/Test/Hspec/Monadic.hs b/Test/Hspec/Monadic.hs --- a/Test/Hspec/Monadic.hs +++ b/Test/Hspec/Monadic.hs @@ -63,6 +63,7 @@ -- > nums <- elements [7,10,11,12,13,14,15] -- > vectorOf nums (elements "0123456789") -- + module Test.Hspec.Monadic ( -- types Spec(), Result(),Specs, @@ -71,8 +72,7 @@ -- alternate "runner" functions hHspec, -- this is just for internal use - ItSpec - + runSpecM ) where import System.IO @@ -82,9 +82,7 @@ import Control.Monad.Trans.Writer (Writer, execWriter, tell) -type ItSpec = IO (String, Result) - -type Specs = Writer [IO [IO Spec]] () +type Specs = Writer [Spec] () -- | Create a document of the given specs and write it to stdout. hspec :: Specs -> IO [Spec] @@ -105,16 +103,17 @@ hHspec :: Handle -> Specs -> IO [Spec] hHspec h = Runner.hHspec h . runSpecM -runSpecM :: Specs -> IO [IO Spec] -runSpecM specs = Core.descriptions $ execWriter specs +runSpecM :: Specs -> [Spec] +runSpecM specs = execWriter specs -describe :: String -> Writer [ItSpec] () -> Specs -describe label action = tell [Core.describe label (execWriter action)] +describe :: String -> Writer [Spec] () -> Specs +describe label action = tell $ Core.describe label [execWriter action] -- | Combine a list of descriptions. (Note that descriptions can also -- be combined with monadic sequencing.) descriptions :: [Specs] -> Specs descriptions = sequence_ -it :: SpecVerifier v => String -> v -> Writer [ItSpec] () -it label action = tell [Core.it label action] +it :: Example v => String -> v -> Writer [Spec] () +it label action = tell $ Core.it label action + diff --git a/Test/Hspec/QuickCheck.hs b/Test/Hspec/QuickCheck.hs --- a/Test/Hspec/QuickCheck.hs +++ b/Test/Hspec/QuickCheck.hs @@ -13,9 +13,7 @@ -- > ] -- module Test.Hspec.QuickCheck ( - property, - -- shortcut for the Monadic DSL - prop + property, prop ) where import System.IO.Silently @@ -32,15 +30,16 @@ property = QuickCheckProperty -- | Monadic DSL shortcut, use this instead of @it@ -prop :: QC.Testable t => String -> t -> Writer [DSL.ItSpec] () +prop :: QC.Testable t => String -> t -> Writer [Spec] () prop n p = DSL.it n (QuickCheckProperty p) -instance QC.Testable t => SpecVerifier (QuickCheckProperty t) where - it description (QuickCheckProperty p) = do + +instance QC.Testable t => Example (QuickCheckProperty t) where + evaluateExample (QuickCheckProperty p) = do r <- silence $ QC.quickCheckResult p let r' = case r of QC.Success {} -> Success f@(QC.Failure {}) -> Fail (QC.output f) g@(QC.GaveUp {}) -> Fail ("Gave up after " ++ quantify (QC.numTests g) "test" ) QC.NoExpectedFailure {} -> Fail ("No expected failure") - return (description, r') + return r' diff --git a/Test/Hspec/Runner.hs b/Test/Hspec/Runner.hs --- a/Test/Hspec/Runner.hs +++ b/Test/Hspec/Runner.hs @@ -12,16 +12,17 @@ import System.CPUTime (getCPUTime) import Control.Monad (when) import System.Exit +import Control.Exception (bracket_) -type Specs = [IO Spec] +type Specs = [Spec] -- | Evaluate and print the result of checking the spec examples. -runFormatter :: Formatter -> Handle -> String -> [String] -> Specs -> IO [Spec] +runFormatter :: Formatter -> Handle -> String -> [String] -> Specs -> IO Specs runFormatter formatter h _ errors [] = do errorsFormatter formatter h (reverse errors) return [] runFormatter formatter h group errors (iospec:ioss) = do - spec <- iospec + spec <- evaluateSpec iospec when (group /= name spec) (exampleGroupStarted formatter h spec) case result spec of (Success ) -> examplePassed formatter h spec errors @@ -39,35 +40,37 @@ _ -> "" -- | Use in place of @hspec@ to also exit the program with an @ExitCode@ -hspecX :: IO Specs -> IO a +hspecX :: Specs -> IO a hspecX ss = hspecB ss >>= exitWith . toExitCode -- | Use in place of hspec to also give a @Bool@ success indication -hspecB :: IO Specs -> IO Bool +hspecB :: Specs -> IO Bool hspecB ss = hspec ss >>= return . success -- | Create a document of the given specs and write it to stdout. -hspec :: IO Specs -> IO [Spec] +hspec :: Specs -> IO [Spec] hspec ss = hHspec stdout ss -- | Create a document of the given specs and write it to the given handle. -- -- > writeReport filename specs = withFile filename WriteMode (\ h -> hHspec h specs) -- -hHspec :: Handle -> IO Specs -> IO [Spec] +hHspec :: Handle -> Specs -> IO Specs hHspec h = hHspecWithFormat (specdoc $ h == stdout) h -- | Create a document of the given specs and write it to the given handle. -- THIS IS LIKELY TO CHANGE -hHspecWithFormat :: Formatter -> Handle -> IO Specs -> IO [Spec] -hHspecWithFormat formatter h ss = do - t0 <- getCPUTime - ioSpecList <- ss - specList <- (runFormatter formatter) h "" [] ioSpecList - t1 <- getCPUTime - let runTime = ((fromIntegral $ t1 - t0) / (10.0^(12::Integer)) :: Double) - (footerFormatter formatter) h specList runTime - return specList +hHspecWithFormat :: Formatter -> Handle -> Specs -> IO Specs +hHspecWithFormat formatter h ss = + bracket_ (when (usesFormatting formatter) $ restoreFormat h) + (when (usesFormatting formatter) $ restoreFormat h) + (do + t0 <- getCPUTime + specList <- runFormatter formatter h "" [] ss + t1 <- getCPUTime + let runTime = ((fromIntegral $ t1 - t0) / (10.0^(12::Integer)) :: Double) + (footerFormatter formatter) h specList runTime + return specList) toExitCode :: Bool -> ExitCode toExitCode True = ExitSuccess diff --git a/hspec.cabal b/hspec.cabal --- a/hspec.cabal +++ b/hspec.cabal @@ -1,6 +1,6 @@ name: hspec -version: 0.6.1 -cabal-version: -any +version: 0.8 +cabal-version: >= 1.8 build-type: Custom license: BSD3 license-file: LICENSE @@ -17,24 +17,42 @@ . Hspec is roughly based on the Ruby library RSpec. However, Hspec is just a framework for running HUnit and QuickCheck tests. Compared to other options, it provides a much nicer syntax that makes tests very easy to read. -exposed: True -buildable: True -extensions: FlexibleInstances -other-modules: Specs -ghc-options: -Wall - -build-depends: HUnit >=1 && <=2, - QuickCheck >=2.4.0.1 && <=2.5, - base >=4 && <=5, - silently >= 1.1.1 && < 2, - ansi-terminal == 0.5.5, - transformers >= 0.2.0 && < 0.3.0 - extra-source-files: ./Specs.hs ./Test/Hspec/HUnit.hs ./Test/Hspec/Runner.hs ./Test/Hspec/Monadic.hs ./Test/Hspec/Formatters.hs ./Test/Hspec/Core.hs ./Test/Hspec/QuickCheck.hs -exposed-modules: Test.Hspec Test.Hspec.HUnit Test.Hspec.Core - Test.Hspec.Runner Test.Hspec.Monadic - Test.Hspec.Formatters Test.Hspec.QuickCheck +Executable hspec + ghc-options: -Wall -fno-warn-hi-shadowing + main-is: hspec.hs + build-depends: hspec == 0.7, + base >=4 && <=5, + regex-posix >= 0.9, + plugins == 1.5.1.4, + HUnit >=1 && <=2, + QuickCheck >=2.4.0.1 && <=2.5, + base >=4 && <=5, + silently >= 1.1.1 && < 2, + ansi-terminal == 0.5.5, + transformers >= 0.2.0 && < 0.3.0, + filepath >= 1.1, + directory >= 1 + +Library + exposed: True + buildable: True + extensions: FlexibleInstances + other-modules: Specs + ghc-options: -Wall -fno-warn-hi-shadowing + + build-depends: HUnit >=1 && <=2, + QuickCheck >=2.4.0.1 && <=2.5, + base >=4 && <=5, + silently >= 1.1.1 && < 2, + ansi-terminal == 0.5.5, + transformers >= 0.2.0 && < 0.3.0 + + exposed-modules: Test.Hspec Test.Hspec.HUnit Test.Hspec.Core + Test.Hspec.Runner Test.Hspec.Monadic + Test.Hspec.Formatters Test.Hspec.QuickCheck + diff --git a/hspec.hs b/hspec.hs new file mode 100644 --- /dev/null +++ b/hspec.hs @@ -0,0 +1,538 @@ +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"])