diff --git a/Test/Chuchu.hs b/Test/Chuchu.hs deleted file mode 100644 --- a/Test/Chuchu.hs +++ /dev/null @@ -1,314 +0,0 @@ --- | --- Module : Test.Chuchu --- Copyright : (c) Marco Túlio Pimenta Gontijo 2012 --- License : Apache 2.0 (see the file LICENSE) --- --- Maintainer : Marco Túlio Pimenta Gontijo --- Stability : unstable --- Portability : non-portable (DeriveDataTypeable) --- --- Chuchu is a system similar to Ruby's Cucumber for Behaviour Driven --- Development. It works with a language similar to Cucumber's Gherkin, which --- is parsed using package abacate. --- --- This module provides the main function for a test file based on Behaviour --- Driven Development for Haskell. --- --- Example for a Stack calculator: --- --- @calculator.feature@: --- --- @ ---Feature: Division --- In order to avoid silly mistakes --- Cashiers must be able to calculate a fraction --- --- Scenario: Regular numbers --- Given that I have entered 3 into the calculator --- And that I have entered 2 into the calculator --- When I press divide --- Then the result should be 1.5 on the screen --- @ --- --- @calculator.hs@: --- --- @ ---import Control.Applicative ---import Control.Monad.IO.Class ---import Control.Monad.Trans.State ---import Test.Chuchu ---import Test.HUnit --- ---type CalculatorT m = StateT \[Double\] m --- ---enterNumber :: Monad m => Double -> CalculatorT m () ---enterNumber = modify . (:) --- ---getDisplay :: Monad m => CalculatorT m Double ---getDisplay --- = do --- ns <- get --- return $ head $ ns ++ [0] --- ---divide :: Monad m => CalculatorT m () ---divide = do --- (n1:n2:ns) <- get --- put $ (n2 / n1) : ns --- ---defs :: Chuchu (CalculatorT IO) ---defs --- = do --- Given --- (\"that I have entered \" *> number <* \" into the calculator\") --- enterNumber --- When \"I press divide\" $ const divide --- Then (\"the result should be \" *> number <* \" on the screen\") --- $ \\n --- -> do --- d <- getDisplay --- liftIO $ d \@?= n --- ---main :: IO () ---main = chuchuMain defs (\`evalStateT\` []) --- @ - -module - Test.Chuchu - (chuchuMain, module Test.Chuchu.Types, module Test.Chuchu.Parser) - where - --- base -import Control.Applicative -import Control.Monad -import System.Environment -import System.Exit -import System.IO -import qualified Data.IORef as I - --- text -import qualified Data.Text as T - --- transformers -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Reader - --- parsec -import Text.Parsec -import Text.Parsec.Text - --- cmdargs -import System.Console.CmdArgs - --- ansi-wl-pprint -import qualified Text.PrettyPrint.ANSI.Leijen as D - --- abacate -import Language.Abacate hiding (StepKeyword (..)) - --- chuchu -import Test.Chuchu.Types -import Test.Chuchu.Parser - - ----------------------------------------------------------------------- - - --- | The main function for the test file. It expects the @.feature@ file as the --- first parameter on the command line. If you want to use it inside a library, --- consider using 'withArgs'. -chuchuMain :: (MonadIO m, Applicative m) => Chuchu m -> (m () -> IO ()) -> IO () -chuchuMain cc runMIO - = do - path <- getPath - parsed <- parseFile path - case parsed of - Right abacate -> do - ret <- processAbacate cc runMIO abacate - unless ret exitFailure - Left e -> error $ "Could not parse " ++ path ++ ": " ++ show e - - ----------------------------------------------------------------------- - - --- | An execution plan for a scenario. Currently just a simple --- record with a background (optional) and a scenario. -data ExecutionPlan = - ExecutionPlan - { epBackground :: Maybe Background - , epScenario :: FeatureElement - } - deriving (Show) - - --- | Creates an execution plan for a feature. -createExecutionPlans :: Abacate -> [ExecutionPlan] -createExecutionPlans feature = - ExecutionPlan (fBackground feature) `map` fFeatureElements feature - - ----------------------------------------------------------------------- - - --- | Monad used when executing a feature's scenario. 'ReaderT' --- is used to carry along the step parser. -type Execution m a = ReaderT (Parser (m ())) m a - - --- | Print a 'D.Doc' describing what we're currently processing. -putDoc :: (MonadIO m, Applicative m) => D.Doc -> m () -putDoc = liftIO . D.putDoc . (D.<> D.linebreak) - - --- | Same as 'D.text' but using 'T.Text'. -t2d :: T.Text -> D.Doc -t2d = D.text . T.unpack - - --- | Run the 'Execution' monad. -runExecution :: (MonadIO m, Applicative m) => - Chuchu m -> (m () -> IO ()) -> Execution m () -> IO () -runExecution cc runMIO act = runMIO $ runReaderT act $ runChuchu cc - - ----------------------------------------------------------------------- - - --- | Process a whole Abacate file, that is, a whole feature. --- Runs each background+scenario combination on a different --- instance of the 'Execution' monad. -processAbacate :: (MonadIO m, Applicative m) => - Chuchu m - -> (m () -> IO ()) - -> Abacate - -> IO Bool -processAbacate cc runMIO feature = do - -- Print feature description. - putDoc $ describeAbacate feature - - -- Execute features. - let plans = createExecutionPlans feature - retVar <- liftIO $ I.newIORef True - let checkRet ret = unless ret $ liftIO $ I.writeIORef retVar False - mapM_ (runExecution cc runMIO . (>>= checkRet) . processExecutionPlan) plans - liftIO $ I.readIORef retVar - - --- | Process a single execution plan, a combination of --- background+scenario, inside the 'Execution' monad. -processExecutionPlan :: (MonadIO m, Applicative m) => ExecutionPlan -> Execution m Bool -processExecutionPlan (ExecutionPlan mbackground scenario) = do - putDoc D.empty -- empty line - (&&) <$> maybe (return True) (processBasicScenario BackgroundKind) mbackground - <*> processFeatureElement scenario - - --- | Creates a pretty description of the feature. -describeAbacate :: Abacate -> D.Doc -describeAbacate feature = - D.vsep $ - describeTags (fTags feature) ++ [D.white $ t2d $ fHeader feature] - - --- | Creates a vertical list of tags. -describeTags :: Tags -> [D.Doc] -describeTags = map (D.dullcyan . ("@" D.<>) . t2d) - - ----------------------------------------------------------------------- - - -processFeatureElement :: (MonadIO m, Applicative m) => FeatureElement -> Execution 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, Applicative m) => BasicScenarioKind -> BasicScenario -> Execution m Bool -processBasicScenario kind scenario = do - putDoc $ describeBasicScenario kind scenario - processSteps (bsSteps scenario) - - --- | Creates a pretty description of the basic scenario's header. -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) = D.vsep . (describeTags tags ++) . (:[]) - - ----------------------------------------------------------------------- - - -processSteps :: (MonadIO m, Applicative m) => Steps -> Execution m Bool -processSteps steps - = do - codes <- mapM processStep steps - return $ and codes - - -processStep :: (MonadIO m, Applicative m) => Step -> Execution 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 - -- TODO: Catch failures and treat them nicely. - putDoc $ describeStep SuccessfulStep step - lift m - return True - - -data StepResult = SuccessfulStep | UnknownStep - - --- | Pretty-prints a step that has already finished executing. -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."]) diff --git a/Test/Chuchu/Email.hs b/Test/Chuchu/Email.hs deleted file mode 100644 --- a/Test/Chuchu/Email.hs +++ /dev/null @@ -1,32 +0,0 @@ --- | --- Module : Test.Chuchu.Parsec --- Copyright : (c) Marco Túlio Pimenta Gontijo 2012 --- License : Apache 2.0 (see the file LICENSE) --- --- Maintainer : Marco Túlio Pimenta Gontijo --- Stability : unstable --- Portability : portable --- --- This is a very simplified parser for e-mail, which does not follow RFC5322. --- Basically, it parses @TEXT\@TEXT@, where TEXT is @alphaNum <|> oneOf --- "!#$%&'*+-/=?^_`{|}~."@. It's loosely based on --- . -module Test.Chuchu.Email (addrSpecSimple) where - --- base -import Control.Applicative hiding ((<|>), many, optional) - --- parsec -import Text.Parsec -import Text.Parsec.Text - --- | Parses a simplified e-mail address and return everything that was parsed as --- a simple 'String'. -addrSpecSimple :: Parser String -addrSpecSimple = concat <$> sequence [atomWithDot, string "@", atomWithDot] - -atomWithDot :: Parser String -atomWithDot = many1 atomTextWithDot - -atomTextWithDot :: Parser Char -atomTextWithDot = alphaNum <|> oneOf "!#$%&'*+-/=?^_`{|}~." diff --git a/Test/Chuchu/Parsec.hs b/Test/Chuchu/Parsec.hs deleted file mode 100644 --- a/Test/Chuchu/Parsec.hs +++ /dev/null @@ -1,215 +0,0 @@ -{-# OPTIONS_GHC -w #-} --- | --- Module : Test.Chuchu.Parsec --- Copyright : (c) Marco Túlio Pimenta Gontijo 2012 --- License : Apache 2.0 (see the file LICENSE) --- --- Maintainer : Marco Túlio Pimenta Gontijo --- Stability : unstable --- Portability : portable --- --- This is from the where clause of 'makeTokenParser' with types included and --- calls to 'lexeme' removed in the functions where this is noted. --- --- Copyright 1999-2000, Daan Leijen; 2007, Paolo Martini. All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions are met: --- --- * Redistributions of source code must retain the above copyright notice, --- this list of conditions and the following disclaimer. --- --- * Redistributions in binary form must reproduce the above copyright --- notice, this list of conditions and the following disclaimer in the --- documentation and/or other materials provided with the distribution. --- --- This software is provided by the copyright holders "as is" and any express or --- implied warranties, including, but not limited to, the implied warranties of --- merchantability and fitness for a particular purpose are disclaimed. In no --- event shall the copyright holders be liable for any direct, indirect, --- incidental, special, exemplary, or consequential damages (including, but not --- limited to, procurement of substitute goods or services; loss of use, data, --- or profits; or business interruption) however caused and on any theory of --- liability, whether in contract, strict liability, or tort (including --- negligence or otherwise) arising in any way out of the use of this software, --- even if advised of the possibility of such damage. - - -module Test.Chuchu.Parsec (stringLiteral, natFloat, int) where - --- base -import Data.Char - --- parsec -import Text.Parsec -import Text.Parsec.Text - -{-# ANN module ("HLint: ignore" :: String) #-} --- | 'lexeme' removed. -stringLiteral :: Parser String -stringLiteral = do{ str <- between (char '"') - (char '"' "end of string") - (many stringChar) - ; return (foldr (maybe id (:)) "" str) - } - "literal string" - -stringChar :: Parser (Maybe Char) -stringChar = do{ c <- stringLetter; return (Just c) } - <|> stringEscape - "string character" - - -stringLetter :: Parser Char -stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) - -stringEscape :: Parser (Maybe Char) -stringEscape = do{ char '\\' - ; do{ escapeGap ; return Nothing } - <|> do{ escapeEmpty; return Nothing } - <|> do{ esc <- escapeCode; return (Just esc) } - } - -escapeEmpty :: Parser Char -escapeEmpty = char '&' - - -escapeGap :: Parser Char -escapeGap = do{ many1 space - ; char '\\' "end of string gap" - } - -escapeCode :: Parser Char -escapeCode = charEsc <|> charNum <|> charAscii <|> charControl - "escape code" - -charControl :: Parser Char -charControl = do{ char '^' - ; code <- upper - ; return (toEnum (fromEnum code - fromEnum 'A')) - } - -charNum :: Parser Char -charNum = do{ code <- decimal - <|> do{ char 'o'; number 8 octDigit } - <|> do{ char 'x'; number 16 hexDigit } - ; return (toEnum (fromInteger code)) - } - -charEsc :: Parser Char -charEsc = choice (map parseEsc escMap) - where - parseEsc (c,code) = do{ char c; return code } - -charAscii :: Parser Char -charAscii = choice (map parseAscii asciiMap) - where - parseAscii (asc,code) = try (do{ string asc; return code }) - - --- escape code tables -escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") -asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) - -ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", - "FS","GS","RS","US","SP"] -ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", - "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", - "CAN","SUB","ESC","DEL"] - -ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', - '\EM','\FS','\GS','\RS','\US','\SP'] -ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', - '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', - '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] - - -natFloat :: Parser (Either Integer Double) -natFloat = do{ char '0' - ; zeroNumFloat - } - <|> decimalFloat - -zeroNumFloat :: Parser (Either Integer Double) -zeroNumFloat = do{ n <- hexadecimal <|> octal - ; return (Left n) - } - <|> decimalFloat - <|> fractFloat 0 - <|> return (Left 0) - -decimalFloat :: Parser (Either Integer Double) -decimalFloat = do{ n <- decimal - ; option (Left n) - (fractFloat n) - } - -fractFloat :: Integer -> Parser (Either Integer Double) -fractFloat n = do{ f <- fractExponent n - ; return (Right f) - } - -fractExponent :: Integer -> Parser Double -fractExponent n = do{ fract <- fraction - ; expo <- option 1.0 exponent' - ; return ((fromInteger n + fract)*expo) - } - <|> - do{ expo <- exponent' - ; return ((fromInteger n)*expo) - } -fraction :: Parser Double -fraction = do{ char '.' - ; digits <- many1 digit "fraction" - ; return (foldr op 0.0 digits) - } - "fraction" - where - op d f = (f + fromIntegral (digitToInt d))/10.0 - -exponent' :: Parser Double -exponent' = do{ oneOf "eE" - ; f <- sign - ; e <- decimal "exponent" - ; return (power (f e)) - } - "exponent" - where - power e | e < 0 = 1.0/power(-e) - | otherwise = fromInteger (10^e) - --- | 'lexeme' removed. -int :: Parser Integer -int = do{ f <- sign - ; n <- nat - ; return (f n) - } - -sign :: Num a => Parser (a -> a) -sign = (char '-' >> return negate) - <|> (char '+' >> return id) - <|> return id - -nat :: Parser Integer -nat = zeroNumber <|> decimal - -zeroNumber :: Parser Integer -zeroNumber = do{ char '0' - ; hexadecimal <|> octal <|> decimal <|> return 0 - } - "" - -decimal :: Parser Integer -decimal = number 10 digit - -hexadecimal :: Parser Integer -hexadecimal = do{ oneOf "xX"; number 16 hexDigit } - -octal :: Parser Integer -octal = do{ oneOf "oO"; number 8 octDigit } - -number base baseDigit - = do{ digits <- many1 baseDigit - ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits - ; seq n (return n) - } diff --git a/Test/Chuchu/Parser.hs b/Test/Chuchu/Parser.hs deleted file mode 100644 --- a/Test/Chuchu/Parser.hs +++ /dev/null @@ -1,59 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} --- | --- Module : Test.Chuchu.Parser --- Copyright : (c) Marco Túlio Pimenta Gontijo 2012 --- License : Apache 2.0 (see the file LICENSE) --- --- Maintainer : Marco Túlio Pimenta Gontijo --- Stability : unstable --- Portability : non-portable (TypeSynonymInstances, FlexibleInstances) --- --- This modules provides some utility parsers for creating step rules. -module Test.Chuchu.Parser - ( ChuchuParser - , number - , int - , text - , wildcard - , email - ) where - --- base -import Control.Applicative hiding ((<|>)) -import Control.Monad - --- parsec -import Text.Parsec - --- chuchu -import Test.Chuchu.Types (ChuchuParser(..)) -import qualified Test.Chuchu.Parsec as P -import Test.Chuchu.Email - --- | Parses a floating point number, with the same syntax as accepted by --- Haskell. -number :: ChuchuParser Double -number = ChuchuParser $ nofToDouble <$> P.natFloat - -nofToDouble :: Either Integer Double -> Double -nofToDouble (Left i) = fromInteger i -nofToDouble (Right d) = d - --- | Parses an integer. -int :: ChuchuParser Integer -int = ChuchuParser P.int - --- | Parses a quoted string, with the same syntax as accepted by Haskell. -text :: ChuchuParser String -text = ChuchuParser P.stringLiteral - --- | Parses anything until the string passed as parameter, and also the string. -wildcard :: String -> ChuchuParser () -wildcard = ChuchuParser . void . manyTill anyChar . string - --- | Parses a simplified e-mail address and return everything that was parsed as --- a simple 'String'. This is a very simplified parser for e-mail, which does --- not follow RFC5322. Basically, it parses @TEXT\@TEXT@, where TEXT is --- @alphaNum \<|> oneOf \"!#$%&\'*+-\/=?^_\`{|}~.\"@. -email :: ChuchuParser String -email = ChuchuParser addrSpecSimple diff --git a/Test/Chuchu/Types.hs b/Test/Chuchu/Types.hs deleted file mode 100644 --- a/Test/Chuchu/Types.hs +++ /dev/null @@ -1,67 +0,0 @@ --- | --- Module : Test.Chuchu.Types --- Copyright : (c) Marco Túlio Pimenta Gontijo 2012 --- License : Apache 2.0 (see the file LICENSE) --- --- Maintainer : Marco Túlio Pimenta Gontijo --- Stability : unstable --- Portability : non-portable (GADTs, GeneralizedNewtypeDeriving) -module - Test.Chuchu.Types - (ChuchuParser (..), Chuchu, ChuchuM (Given, When, Then, And, But), runChuchu) - where - --- base -import Control.Applicative hiding ((<|>)) -import Control.Monad (MonadPlus) -import Data.String - --- parsec -import Text.Parsec -import Text.Parsec.Text - - --- | @newtype@ for Parsec's 'Parser' used on this library. The --- main reason for not using 'Parser' directly is to be able to --- define the 'IsString' instance. -newtype ChuchuParser a = ChuchuParser (Parser a) - deriving (Functor, Applicative, Alternative, Monad, MonadPlus) - -instance (a ~ ()) => IsString (ChuchuParser a) where - fromString s = ChuchuParser (string s >> return ()) - - --- | The most common use case where the return value of the Monad is ignored. -type Chuchu m = ChuchuM m () - --- | The Monad on which the step rules are constructed. 'Given', 'When', --- 'Then', 'And' and 'But' are interpreted in the same way by the program. All --- of them receive a parser and an action to run if the parser finishes --- correctly. -data ChuchuM m a where - Given :: ChuchuParser a -> (a -> m ()) -> ChuchuM m () - When :: ChuchuParser a -> (a -> m ()) -> ChuchuM m () - Then :: ChuchuParser a -> (a -> m ()) -> ChuchuM m () - And :: ChuchuParser a -> (a -> m ()) -> ChuchuM m () - But :: ChuchuParser a -> (a -> m ()) -> ChuchuM m () - Nil :: ChuchuM m a - Cons :: ChuchuM m b -> ChuchuM m a -> ChuchuM m a - -instance Monad (ChuchuM m) where - return _ = Nil - step >>= k = Cons step $ k $ error "(>>=): ChuchuM does not support 'return'." - --- | Converts the Monad into a single 'Parser' that executes the specified --- action if the parser is executed correctly. It includes an 'eof' on the --- parser of each step to avoid it from accepting prefixes of the desired rule. -runChuchu :: ChuchuM m a -> Parser (m ()) -runChuchu Nil = unexpected "Unknown step" -runChuchu (Cons cc1 cc2) = runChuchu cc1 <|> runChuchu cc2 -runChuchu (Given p f) = apply p f -runChuchu (When p f) = apply p f -runChuchu (Then p f) = apply p f -runChuchu (And p f) = apply p f -runChuchu (But p f) = apply p f - -apply :: ChuchuParser a -> (a -> m ()) -> Parser (m ()) -apply (ChuchuParser p) f = try $ f <$> p <* eof diff --git a/chuchu.cabal b/chuchu.cabal --- a/chuchu.cabal +++ b/chuchu.cabal @@ -1,5 +1,5 @@ name: chuchu -version: 0.1.4 +version: 0.2 cabal-version: >= 1.8 build-type: Simple license: OtherLicense @@ -29,6 +29,7 @@ location: git://github.com/marcotmarcot/chuchu.git library + hs-source-dirs: src exposed-modules: Test.Chuchu, Test.Chuchu.Types, @@ -54,6 +55,7 @@ build-depends: base >= 4 && < 5, unix >= 2.5 && < 2.6, + text, chuchu, HUnit >= 1.2 && < 1.3 extensions: OverloadedStrings diff --git a/src/Test/Chuchu.hs b/src/Test/Chuchu.hs new file mode 100644 --- /dev/null +++ b/src/Test/Chuchu.hs @@ -0,0 +1,314 @@ +-- | +-- Module : Test.Chuchu +-- Copyright : (c) Marco Túlio Pimenta Gontijo 2012 +-- License : Apache 2.0 (see the file LICENSE) +-- +-- Maintainer : Marco Túlio Pimenta Gontijo +-- Stability : unstable +-- Portability : non-portable (DeriveDataTypeable) +-- +-- Chuchu is a system similar to Ruby's Cucumber for Behaviour Driven +-- Development. It works with a language similar to Cucumber's Gherkin, which +-- is parsed using package abacate. +-- +-- This module provides the main function for a test file based on Behaviour +-- Driven Development for Haskell. +-- +-- Example for a Stack calculator: +-- +-- @calculator.feature@: +-- +-- @ +--Feature: Division +-- In order to avoid silly mistakes +-- Cashiers must be able to calculate a fraction +-- +-- Scenario: Regular numbers +-- Given that I have entered 3 into the calculator +-- And that I have entered 2 into the calculator +-- When I press divide +-- Then the result should be 1.5 on the screen +-- @ +-- +-- @calculator.hs@: +-- +-- @ +--import Control.Applicative +--import Control.Monad.IO.Class +--import Control.Monad.Trans.State +--import Test.Chuchu +--import Test.HUnit +-- +--type CalculatorT m = StateT \[Double\] m +-- +--enterNumber :: Monad m => Double -> CalculatorT m () +--enterNumber = modify . (:) +-- +--getDisplay :: Monad m => CalculatorT m Double +--getDisplay +-- = do +-- ns <- get +-- return $ head $ ns ++ [0] +-- +--divide :: Monad m => CalculatorT m () +--divide = do +-- (n1:n2:ns) <- get +-- put $ (n2 / n1) : ns +-- +--defs :: Chuchu (CalculatorT IO) +--defs +-- = do +-- Given +-- (\"that I have entered \" *> number <* \" into the calculator\") +-- enterNumber +-- When \"I press divide\" $ const divide +-- Then (\"the result should be \" *> number <* \" on the screen\") +-- $ \\n +-- -> do +-- d <- getDisplay +-- liftIO $ d \@?= n +-- +--main :: IO () +--main = chuchuMain defs (\`evalStateT\` []) +-- @ + +module + Test.Chuchu + (chuchuMain, module Test.Chuchu.Types, module Test.Chuchu.Parser) + where + +-- base +import Control.Applicative +import Control.Monad +import System.Environment +import System.Exit +import System.IO +import qualified Data.IORef as I + +-- text +import qualified Data.Text as T + +-- transformers +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Reader + +-- parsec +import Text.Parsec +import Text.Parsec.Text + +-- cmdargs +import System.Console.CmdArgs + +-- ansi-wl-pprint +import qualified Text.PrettyPrint.ANSI.Leijen as D + +-- abacate +import Language.Abacate hiding (StepKeyword (..)) + +-- chuchu +import Test.Chuchu.Types +import Test.Chuchu.Parser + + +---------------------------------------------------------------------- + + +-- | The main function for the test file. It expects the @.feature@ file as the +-- first parameter on the command line. If you want to use it inside a library, +-- consider using 'withArgs'. +chuchuMain :: (MonadIO m, Applicative m) => Chuchu m -> (m () -> IO ()) -> IO () +chuchuMain cc runMIO + = do + path <- getPath + parsed <- parseFile path + case parsed of + Right abacate -> do + ret <- processAbacate cc runMIO abacate + unless ret exitFailure + Left e -> error $ "Could not parse " ++ path ++ ": " ++ show e + + +---------------------------------------------------------------------- + + +-- | An execution plan for a scenario. Currently just a simple +-- record with a background (optional) and a scenario. +data ExecutionPlan = + ExecutionPlan + { epBackground :: Maybe Background + , epScenario :: FeatureElement + } + deriving (Show) + + +-- | Creates an execution plan for a feature. +createExecutionPlans :: Abacate -> [ExecutionPlan] +createExecutionPlans feature = + ExecutionPlan (fBackground feature) `map` fFeatureElements feature + + +---------------------------------------------------------------------- + + +-- | Monad used when executing a feature's scenario. 'ReaderT' +-- is used to carry along the step parser. +type Execution m a = ReaderT (Parser (m ())) m a + + +-- | Print a 'D.Doc' describing what we're currently processing. +putDoc :: (MonadIO m, Applicative m) => D.Doc -> m () +putDoc = liftIO . D.putDoc . (D.<> D.linebreak) + + +-- | Same as 'D.text' but using 'T.Text'. +t2d :: T.Text -> D.Doc +t2d = D.text . T.unpack + + +-- | Run the 'Execution' monad. +runExecution :: (MonadIO m, Applicative m) => + Chuchu m -> (m () -> IO ()) -> Execution m () -> IO () +runExecution cc runMIO act = runMIO $ runReaderT act $ runChuchu cc + + +---------------------------------------------------------------------- + + +-- | Process a whole Abacate file, that is, a whole feature. +-- Runs each background+scenario combination on a different +-- instance of the 'Execution' monad. +processAbacate :: (MonadIO m, Applicative m) => + Chuchu m + -> (m () -> IO ()) + -> Abacate + -> IO Bool +processAbacate cc runMIO feature = do + -- Print feature description. + putDoc $ describeAbacate feature + + -- Execute features. + let plans = createExecutionPlans feature + retVar <- liftIO $ I.newIORef True + let checkRet ret = unless ret $ liftIO $ I.writeIORef retVar False + mapM_ (runExecution cc runMIO . (>>= checkRet) . processExecutionPlan) plans + liftIO $ I.readIORef retVar + + +-- | Process a single execution plan, a combination of +-- background+scenario, inside the 'Execution' monad. +processExecutionPlan :: (MonadIO m, Applicative m) => ExecutionPlan -> Execution m Bool +processExecutionPlan (ExecutionPlan mbackground scenario) = do + putDoc D.empty -- empty line + (&&) <$> maybe (return True) (processBasicScenario BackgroundKind) mbackground + <*> processFeatureElement scenario + + +-- | Creates a pretty description of the feature. +describeAbacate :: Abacate -> D.Doc +describeAbacate feature = + D.vsep $ + describeTags (fTags feature) ++ [D.white $ t2d $ fHeader feature] + + +-- | Creates a vertical list of tags. +describeTags :: Tags -> [D.Doc] +describeTags = map (D.dullcyan . ("@" D.<>) . t2d) + + +---------------------------------------------------------------------- + + +processFeatureElement :: (MonadIO m, Applicative m) => FeatureElement -> Execution 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, Applicative m) => BasicScenarioKind -> BasicScenario -> Execution m Bool +processBasicScenario kind scenario = do + putDoc $ describeBasicScenario kind scenario + processSteps (bsSteps scenario) + + +-- | Creates a pretty description of the basic scenario's header. +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) = D.vsep . (describeTags tags ++) . (:[]) + + +---------------------------------------------------------------------- + + +processSteps :: (MonadIO m, Applicative m) => Steps -> Execution m Bool +processSteps steps + = do + codes <- mapM processStep steps + return $ and codes + + +processStep :: (MonadIO m, Applicative m) => Step -> Execution 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 + -- TODO: Catch failures and treat them nicely. + putDoc $ describeStep SuccessfulStep step + lift m + return True + + +data StepResult = SuccessfulStep | UnknownStep + + +-- | Pretty-prints a step that has already finished executing. +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."]) diff --git a/src/Test/Chuchu/Email.hs b/src/Test/Chuchu/Email.hs new file mode 100644 --- /dev/null +++ b/src/Test/Chuchu/Email.hs @@ -0,0 +1,32 @@ +-- | +-- Module : Test.Chuchu.Parsec +-- Copyright : (c) Marco Túlio Pimenta Gontijo 2012 +-- License : Apache 2.0 (see the file LICENSE) +-- +-- Maintainer : Marco Túlio Pimenta Gontijo +-- Stability : unstable +-- Portability : portable +-- +-- This is a very simplified parser for e-mail, which does not follow RFC5322. +-- Basically, it parses @TEXT\@TEXT@, where TEXT is @alphaNum <|> oneOf +-- "!#$%&'*+-/=?^_`{|}~."@. It's loosely based on +-- . +module Test.Chuchu.Email (addrSpecSimple) where + +-- base +import Control.Applicative hiding ((<|>), many, optional) + +-- parsec +import Text.Parsec +import Text.Parsec.Text + +-- | Parses a simplified e-mail address and return everything that was parsed as +-- a simple 'String'. +addrSpecSimple :: Parser String +addrSpecSimple = concat <$> sequence [atomWithDot, string "@", atomWithDot] + +atomWithDot :: Parser String +atomWithDot = many1 atomTextWithDot + +atomTextWithDot :: Parser Char +atomTextWithDot = alphaNum <|> oneOf "!#$%&'*+-/=?^_`{|}~." diff --git a/src/Test/Chuchu/Parsec.hs b/src/Test/Chuchu/Parsec.hs new file mode 100644 --- /dev/null +++ b/src/Test/Chuchu/Parsec.hs @@ -0,0 +1,215 @@ +{-# OPTIONS_GHC -w #-} +-- | +-- Module : Test.Chuchu.Parsec +-- Copyright : (c) Marco Túlio Pimenta Gontijo 2012 +-- License : Apache 2.0 (see the file LICENSE) +-- +-- Maintainer : Marco Túlio Pimenta Gontijo +-- Stability : unstable +-- Portability : portable +-- +-- This is from the where clause of 'makeTokenParser' with types included and +-- calls to 'lexeme' removed in the functions where this is noted. +-- +-- Copyright 1999-2000, Daan Leijen; 2007, Paolo Martini. All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions are met: +-- +-- * Redistributions of source code must retain the above copyright notice, +-- this list of conditions and the following disclaimer. +-- +-- * Redistributions in binary form must reproduce the above copyright +-- notice, this list of conditions and the following disclaimer in the +-- documentation and/or other materials provided with the distribution. +-- +-- This software is provided by the copyright holders "as is" and any express or +-- implied warranties, including, but not limited to, the implied warranties of +-- merchantability and fitness for a particular purpose are disclaimed. In no +-- event shall the copyright holders be liable for any direct, indirect, +-- incidental, special, exemplary, or consequential damages (including, but not +-- limited to, procurement of substitute goods or services; loss of use, data, +-- or profits; or business interruption) however caused and on any theory of +-- liability, whether in contract, strict liability, or tort (including +-- negligence or otherwise) arising in any way out of the use of this software, +-- even if advised of the possibility of such damage. + + +module Test.Chuchu.Parsec (stringLiteral, natFloat, int) where + +-- base +import Data.Char + +-- parsec +import Text.Parsec +import Text.Parsec.Text + +{-# ANN module ("HLint: ignore" :: String) #-} +-- | 'lexeme' removed. +stringLiteral :: Parser String +stringLiteral = do{ str <- between (char '"') + (char '"' "end of string") + (many stringChar) + ; return (foldr (maybe id (:)) "" str) + } + "literal string" + +stringChar :: Parser (Maybe Char) +stringChar = do{ c <- stringLetter; return (Just c) } + <|> stringEscape + "string character" + + +stringLetter :: Parser Char +stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c > '\026')) + +stringEscape :: Parser (Maybe Char) +stringEscape = do{ char '\\' + ; do{ escapeGap ; return Nothing } + <|> do{ escapeEmpty; return Nothing } + <|> do{ esc <- escapeCode; return (Just esc) } + } + +escapeEmpty :: Parser Char +escapeEmpty = char '&' + + +escapeGap :: Parser Char +escapeGap = do{ many1 space + ; char '\\' "end of string gap" + } + +escapeCode :: Parser Char +escapeCode = charEsc <|> charNum <|> charAscii <|> charControl + "escape code" + +charControl :: Parser Char +charControl = do{ char '^' + ; code <- upper + ; return (toEnum (fromEnum code - fromEnum 'A')) + } + +charNum :: Parser Char +charNum = do{ code <- decimal + <|> do{ char 'o'; number 8 octDigit } + <|> do{ char 'x'; number 16 hexDigit } + ; return (toEnum (fromInteger code)) + } + +charEsc :: Parser Char +charEsc = choice (map parseEsc escMap) + where + parseEsc (c,code) = do{ char c; return code } + +charAscii :: Parser Char +charAscii = choice (map parseAscii asciiMap) + where + parseAscii (asc,code) = try (do{ string asc; return code }) + + +-- escape code tables +escMap = zip ("abfnrtv\\\"\'") ("\a\b\f\n\r\t\v\\\"\'") +asciiMap = zip (ascii3codes ++ ascii2codes) (ascii3 ++ ascii2) + +ascii2codes = ["BS","HT","LF","VT","FF","CR","SO","SI","EM", + "FS","GS","RS","US","SP"] +ascii3codes = ["NUL","SOH","STX","ETX","EOT","ENQ","ACK","BEL", + "DLE","DC1","DC2","DC3","DC4","NAK","SYN","ETB", + "CAN","SUB","ESC","DEL"] + +ascii2 = ['\BS','\HT','\LF','\VT','\FF','\CR','\SO','\SI', + '\EM','\FS','\GS','\RS','\US','\SP'] +ascii3 = ['\NUL','\SOH','\STX','\ETX','\EOT','\ENQ','\ACK', + '\BEL','\DLE','\DC1','\DC2','\DC3','\DC4','\NAK', + '\SYN','\ETB','\CAN','\SUB','\ESC','\DEL'] + + +natFloat :: Parser (Either Integer Double) +natFloat = do{ char '0' + ; zeroNumFloat + } + <|> decimalFloat + +zeroNumFloat :: Parser (Either Integer Double) +zeroNumFloat = do{ n <- hexadecimal <|> octal + ; return (Left n) + } + <|> decimalFloat + <|> fractFloat 0 + <|> return (Left 0) + +decimalFloat :: Parser (Either Integer Double) +decimalFloat = do{ n <- decimal + ; option (Left n) + (fractFloat n) + } + +fractFloat :: Integer -> Parser (Either Integer Double) +fractFloat n = do{ f <- fractExponent n + ; return (Right f) + } + +fractExponent :: Integer -> Parser Double +fractExponent n = do{ fract <- fraction + ; expo <- option 1.0 exponent' + ; return ((fromInteger n + fract)*expo) + } + <|> + do{ expo <- exponent' + ; return ((fromInteger n)*expo) + } +fraction :: Parser Double +fraction = do{ char '.' + ; digits <- many1 digit "fraction" + ; return (foldr op 0.0 digits) + } + "fraction" + where + op d f = (f + fromIntegral (digitToInt d))/10.0 + +exponent' :: Parser Double +exponent' = do{ oneOf "eE" + ; f <- sign + ; e <- decimal "exponent" + ; return (power (f e)) + } + "exponent" + where + power e | e < 0 = 1.0/power(-e) + | otherwise = fromInteger (10^e) + +-- | 'lexeme' removed. +int :: Parser Integer +int = do{ f <- sign + ; n <- nat + ; return (f n) + } + +sign :: Num a => Parser (a -> a) +sign = (char '-' >> return negate) + <|> (char '+' >> return id) + <|> return id + +nat :: Parser Integer +nat = zeroNumber <|> decimal + +zeroNumber :: Parser Integer +zeroNumber = do{ char '0' + ; hexadecimal <|> octal <|> decimal <|> return 0 + } + "" + +decimal :: Parser Integer +decimal = number 10 digit + +hexadecimal :: Parser Integer +hexadecimal = do{ oneOf "xX"; number 16 hexDigit } + +octal :: Parser Integer +octal = do{ oneOf "oO"; number 8 octDigit } + +number base baseDigit + = do{ digits <- many1 baseDigit + ; let n = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 digits + ; seq n (return n) + } diff --git a/src/Test/Chuchu/Parser.hs b/src/Test/Chuchu/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Test/Chuchu/Parser.hs @@ -0,0 +1,56 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Test.Chuchu.Parser +-- Copyright : (c) Marco Túlio Pimenta Gontijo 2012 +-- License : Apache 2.0 (see the file LICENSE) +-- +-- Maintainer : Marco Túlio Pimenta Gontijo +-- Stability : unstable +-- Portability : non-portable (TypeSynonymInstances, FlexibleInstances) +-- +-- This modules provides some utility parsers for creating step rules. +module Test.Chuchu.Parser + ( ChuchuParser + , number + , int + , text + , wildcard + , email + ) where + +import Control.Applicative hiding ((<|>)) +import Control.Monad +import Text.Parsec +import qualified Data.Text as T + +import Test.Chuchu.Types (ChuchuParser(..)) +import Test.Chuchu.Email +import qualified Test.Chuchu.Parsec as P + +-- | Parses a floating point number, with the same syntax as accepted by +-- Haskell. +number :: ChuchuParser Double +number = ChuchuParser $ nofToDouble <$> P.natFloat + +nofToDouble :: Either Integer Double -> Double +nofToDouble (Left i) = fromInteger i +nofToDouble (Right d) = d + +-- | Parses an integer. +int :: ChuchuParser Integer +int = ChuchuParser P.int + +-- | Parses a quoted string, with the same syntax as accepted by Haskell. +text :: ChuchuParser T.Text +text = T.pack <$> ChuchuParser P.stringLiteral + +-- | Parses anything until the string passed as parameter, and also the string. +wildcard :: T.Text -> ChuchuParser () +wildcard = ChuchuParser . void . manyTill anyChar . string . T.unpack + +-- | Parses a simplified e-mail address and return everything that was parsed as +-- a simple 'T.Text'. This is a very simplified parser for e-mail, which does +-- not follow RFC5322. Basically, it parses @TEXT\@TEXT@, where TEXT is +-- @alphaNum \<|> oneOf \"!#$%&\'*+-\/=?^_\`{|}~.\"@. +email :: ChuchuParser T.Text +email = T.pack <$> ChuchuParser addrSpecSimple diff --git a/src/Test/Chuchu/Types.hs b/src/Test/Chuchu/Types.hs new file mode 100644 --- /dev/null +++ b/src/Test/Chuchu/Types.hs @@ -0,0 +1,67 @@ +-- | +-- Module : Test.Chuchu.Types +-- Copyright : (c) Marco Túlio Pimenta Gontijo 2012 +-- License : Apache 2.0 (see the file LICENSE) +-- +-- Maintainer : Marco Túlio Pimenta Gontijo +-- Stability : unstable +-- Portability : non-portable (GADTs, GeneralizedNewtypeDeriving) +module + Test.Chuchu.Types + (ChuchuParser (..), Chuchu, ChuchuM (Given, When, Then, And, But), runChuchu) + where + +-- base +import Control.Applicative hiding ((<|>)) +import Control.Monad (MonadPlus) +import Data.String + +-- parsec +import Text.Parsec +import Text.Parsec.Text + + +-- | @newtype@ for Parsec's 'Parser' used on this library. The +-- main reason for not using 'Parser' directly is to be able to +-- define the 'IsString' instance. +newtype ChuchuParser a = ChuchuParser (Parser a) + deriving (Functor, Applicative, Alternative, Monad, MonadPlus) + +instance (a ~ ()) => IsString (ChuchuParser a) where + fromString s = ChuchuParser (string s >> return ()) + + +-- | The most common use case where the return value of the Monad is ignored. +type Chuchu m = ChuchuM m () + +-- | The Monad on which the step rules are constructed. 'Given', 'When', +-- 'Then', 'And' and 'But' are interpreted in the same way by the program. All +-- of them receive a parser and an action to run if the parser finishes +-- correctly. +data ChuchuM m a where + Given :: ChuchuParser a -> (a -> m ()) -> ChuchuM m () + When :: ChuchuParser a -> (a -> m ()) -> ChuchuM m () + Then :: ChuchuParser a -> (a -> m ()) -> ChuchuM m () + And :: ChuchuParser a -> (a -> m ()) -> ChuchuM m () + But :: ChuchuParser a -> (a -> m ()) -> ChuchuM m () + Nil :: ChuchuM m a + Cons :: ChuchuM m b -> ChuchuM m a -> ChuchuM m a + +instance Monad (ChuchuM m) where + return _ = Nil + step >>= k = Cons step $ k $ error "(>>=): ChuchuM does not support 'return'." + +-- | Converts the Monad into a single 'Parser' that executes the specified +-- action if the parser is executed correctly. It includes an 'eof' on the +-- parser of each step to avoid it from accepting prefixes of the desired rule. +runChuchu :: ChuchuM m a -> Parser (m ()) +runChuchu Nil = unexpected "Unknown step" +runChuchu (Cons cc1 cc2) = runChuchu cc1 <|> runChuchu cc2 +runChuchu (Given p f) = apply p f +runChuchu (When p f) = apply p f +runChuchu (Then p f) = apply p f +runChuchu (And p f) = apply p f +runChuchu (But p f) = apply p f + +apply :: ChuchuParser a -> (a -> m ()) -> Parser (m ()) +apply (ChuchuParser p) f = try $ f <$> p <* eof diff --git a/tests/environment.hs b/tests/environment.hs --- a/tests/environment.hs +++ b/tests/environment.hs @@ -17,6 +17,9 @@ import Data.Maybe import System.Environment hiding (getEnv) +-- text +import qualified Data.Text as T + -- unix import System.Posix.Env @@ -31,21 +34,21 @@ = do Given "that I start the test" $ \() -> return () When ("I set the " *> wildcard " as " *> text <* " into the environment") - $ \x -> setEnv "environment" x True + $ \x -> setEnv "environment" (T.unpack x) True Then ("the " *> wildcard " should have " *> text <* " on its content") - $ \n -> fromJust <$> getEnv "environment" >>= (@?= n) + $ \n -> fromJust <$> getEnv "environment" >>= (@?= T.unpack n) When ("I set the " *> wildcard " as e-mail " *> email <* " into the environment") - $ \x -> setEnv "environment" x True + $ \x -> setEnv "environment" (T.unpack x) True Then ("the " *> wildcard " should have e-mail " *> email <* " on its content") - $ \n -> fromJust <$> getEnv "environment" >>= (@?= n) + $ \n -> fromJust <$> getEnv "environment" >>= (@?= T.unpack n) main :: IO () main = withArgs ["tests/data/environment.feature"] $ chuchuMain defs id