--getDisplay
--defs
module
Test.Chuchu
(chuchuMain, module Test.Chuchu.Types, module Test.Chuchu.Parser)
where
import Control.Applicative
import Control.Monad
import System.Environment
import System.Exit
import System.IO
import qualified Data.Text as T
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Text.Parsec
import Text.Parsec.Text
import System.Console.CmdArgs
import qualified Text.PrettyPrint.ANSI.Leijen as D
import Language.Abacate hiding (StepKeyword (..))
import Test.Chuchu.Types
import Test.Chuchu.Parser
chuchuMain :: MonadIO m => Chuchu m -> (m () -> IO ()) -> IO ()
chuchuMain cc runMIO
= do
path <- getPath
parsed <- parseFile path
case parsed of
(Right abacate)
-> runMIO
$ runReaderT
(do
code <- processAbacate abacate
unless code $ liftIO exitFailure)
$ runChuchu cc
(Left e) -> error $ "Could not parse " ++ path ++ ": " ++ show e
type CM m a = ReaderT (Parser (m ())) m a
processAbacate :: MonadIO m => Abacate -> CM m Bool
processAbacate feature
= do
putDoc $ describeAbacate feature
bCode
<- case fBackground feature of
Nothing -> return True
Just background -> processBasicScenario BackgroundKind background
feCode <- processFeatureElements $ fFeatureElements feature
return $ bCode && feCode
putDoc :: MonadIO m => D.Doc -> CM m ()
putDoc = liftIO . D.putDoc . (D.<> D.linebreak)
describeAbacate :: Abacate -> D.Doc
describeAbacate feature =
(if null (fTags feature) then id else (describeTags (fTags feature) D.<$>)) $
D.white (t2d (fHeader feature))
describeTags :: Tags -> D.Doc
describeTags = D.vsep . map (D.dullcyan . ("@" D.<>) . t2d)
t2d :: T.Text -> D.Doc
t2d = D.text . T.unpack
processFeatureElements :: MonadIO m => FeatureElements -> CM m Bool
processFeatureElements featureElements
= do
codes <- mapM processFeatureElement featureElements
return $ and codes
processFeatureElement :: MonadIO m => FeatureElement -> CM m Bool
processFeatureElement (FESO _)
= liftIO (hPutStrLn stderr "Scenario Outlines are not supported yet.")
>> return False
processFeatureElement (FES sc) =
processBasicScenario (ScenarioKind $ scTags sc) $ scBasicScenario sc
data BasicScenarioKind = BackgroundKind | ScenarioKind Tags
processBasicScenario :: MonadIO m => BasicScenarioKind -> BasicScenario -> CM m Bool
processBasicScenario kind scenario = do
putDoc $ describeBasicScenario kind scenario
processSteps (bsSteps scenario)
describeBasicScenario :: BasicScenarioKind -> BasicScenario -> D.Doc
describeBasicScenario kind scenario =
D.indent 2 $
prettyTags kind $
D.bold ((describeBasicScenarioKind kind) D.<+> t2d (bsName scenario))
where describeBasicScenarioKind BackgroundKind = "Background:"
describeBasicScenarioKind (ScenarioKind _) = "Scenario:"
prettyTags BackgroundKind = id
prettyTags (ScenarioKind tags) = (describeTags tags D.<$>)
processSteps :: MonadIO m => Steps -> CM m Bool
processSteps steps
= do
codes <- mapM processStep steps
return $ and codes
processStep :: MonadIO m => Step -> CM m Bool
processStep step
= do
cc <- ask
case parse cc "processStep" $ stBody step of
Left e
-> do
putDoc $ describeStep UnknownStep step
liftIO
$ hPutStrLn stderr
$ "The step "
++ show (stBody step)
++ " doesn't match any step definitions I know."
++ show e
return False
Right m -> do
putDoc $ describeStep SuccessfulStep step
lift m
return True
data StepResult = SuccessfulStep | UnknownStep
describeStep :: StepResult -> Step -> D.Doc
describeStep result step =
D.indent 4 $
color result (D.text (show $ stStepKeyword step) D.<+> t2d (stBody step))
where
color SuccessfulStep = D.green
color UnknownStep = D.yellow
data Options
= Options {file_ :: FilePath}
deriving (Eq, Show, Typeable, Data)
getPath :: IO FilePath
getPath
= do
progName <- getProgName
file_
<$> cmdArgs
(Options (def &= typ "PATH" &= argPos 0)
&= program progName
&= details
["Run test scenarios specified on the abacate file at PATH."])