prednote (empty) → 0.2.0.0
raw patch · 8 files changed
+1130/−0 lines, 8 filesdep +basedep +explicit-exceptiondep +rainbowsetup-changed
Dependencies added: base, explicit-exception, rainbow, split, text
Files
- Data/Prednote/Expressions.hs +83/−0
- Data/Prednote/Expressions/Infix.hs +126/−0
- Data/Prednote/Expressions/RPN.hs +79/−0
- Data/Prednote/Pdct.hs +305/−0
- Data/Prednote/TestTree.hs +461/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- prednote.cabal +44/−0
+ Data/Prednote/Expressions.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Handles parsing of both infix and RPN Pdct expressions.+module Data.Prednote.Expressions+ ( ExprDesc(..)+ , Error+ , Token+ , operand+ , opAnd+ , opOr+ , opNot+ , openParen+ , closeParen+ , parseExpression+ ) where++import Data.Either (partitionEithers)+import qualified Data.Text as X+import qualified Data.Prednote.Expressions.Infix as I+import qualified Data.Prednote.Expressions.RPN as R+import qualified Data.Prednote.Pdct as P+import qualified Control.Monad.Exception.Synchronous as Ex++-- | A single type for both RPN tokens and infix tokens.+newtype Token a = Token { unToken :: I.InfixToken a }+type Error = X.Text++-- | Creates Operands from Pdct.+operand :: P.Pdct a -> Token a+operand p = Token (I.TokRPN (R.TokOperand p))++-- | The And operator+opAnd :: Token a+opAnd = Token (I.TokRPN (R.TokOperator R.OpAnd))++-- | The Or operator+opOr :: Token a+opOr = Token (I.TokRPN (R.TokOperator R.OpOr))++-- | The Not operator+opNot :: Token a+opNot = Token (I.TokRPN (R.TokOperator R.OpNot))++-- | Open parentheses+openParen :: Token a+openParen = Token (I.TokParen I.Open)++-- | Close parentheses+closeParen :: Token a+closeParen = Token (I.TokParen I.Close)++-- | Is this an infix or RPN expression?+data ExprDesc+ = Infix+ | RPN+ deriving (Eq, Show)++toksToRPN :: [Token a] -> Maybe [R.RPNToken a]+toksToRPN toks+ = let toEither t = case unToken t of+ I.TokRPN tok -> Right tok+ _ -> Left ()+ in case partitionEithers . map toEither $ toks of+ ([], xs) -> return xs+ _ -> Nothing++-- | Parses expressions. Fails if the expression is nonsensical in+-- some way (for example, unbalanced parentheses, parentheses in an+-- RPN expression, or multiple stack values remaining.) Works by first+-- changing infix expressions to RPN ones.+parseExpression+ :: ExprDesc+ -> [Token a]+ -> Ex.Exceptional Error (P.Pdct a)+parseExpression e toks = do+ rpnToks <- case e of+ Infix -> Ex.fromMaybe "unbalanced parentheses\n"+ . I.createRPN+ . map unToken+ $ toks+ RPN -> Ex.fromMaybe "parentheses in an RPN expression\n"+ $ toksToRPN toks+ R.parseRPN rpnToks
+ Data/Prednote/Expressions/Infix.hs view
@@ -0,0 +1,126 @@+module Data.Prednote.Expressions.Infix+ ( InfixToken (..)+ , Paren(..)+ , createRPN+ ) where++import qualified Data.Prednote.Expressions.RPN as R+import qualified Data.Foldable as Fdbl++data InfixToken a+ = TokRPN (R.RPNToken a)+ | TokParen Paren++data Paren = Open | Close++-- | Values on the operator stack.+data OpStackVal+ = StkOp R.Operator+ | StkOpenParen++-- In the shunting yard algorithm, the output sequence is a queue. The+-- first values to go into the output sequence are the first to be+-- processed by the RPN parser. In this module, the output sequence is+-- implemented as a list stack, which means it must be reversed upon+-- output (this is done in the createRPN function.)++processInfixToken+ :: ([OpStackVal], [R.RPNToken a])+ -> InfixToken a+ -> Maybe ([OpStackVal], [R.RPNToken a])+processInfixToken (os, ts) t = case t of+ TokRPN tok -> return $ processRPNToken (os, ts) tok+ TokParen p -> processParen (os, ts) p+++-- | If the token is a binary operator A, then:+--+-- If A is left associative, while there is an operator B of higher or+-- equal precedence than A at the top of the stack, pop B off the+-- stack and append it to the output.+--+-- If A is right associative, while there is an operator B of higher+-- precedence than A at the top of the stack, pop B off the stack and+-- append it to the output.+--+-- Push A onto the stack.+--+-- If a token is an operand, append it to the postfix output.+--+-- And has higher precedence than Or.+processRPNToken+ :: ([OpStackVal], [R.RPNToken a])+ -> R.RPNToken a+ -> ([OpStackVal], [R.RPNToken a])+processRPNToken (os, ts) t = case t of+ p@(R.TokOperand _) -> (os, p:ts)+ R.TokOperator d -> case d of+ R.OpNot -> (StkOp R.OpNot : os, ts)+ R.OpAnd -> (StkOp R.OpAnd : os, ts)+ R.OpOr ->+ let (os', ts') = popper os ts+ in (StkOp R.OpOr : os', ts')++-- | Pops operators from the operator stack and places then in the+-- output queue, as long as there is an And operator on the top of the+-- operator stack.+popper :: [OpStackVal] -> [R.RPNToken a] -> ([OpStackVal], [R.RPNToken a])+popper os ts = case os of+ [] -> (os, ts)+ x:xs -> case x of+ StkOp R.OpAnd ->+ let os' = xs+ ts' = R.TokOperator R.OpAnd : ts+ in popper os' ts'+ _ -> (os, ts)++-- | Pops operators off the operator stack and onto the output stack+-- as long as the top of the operator stack is not an open+-- parenthesis. When an open parenthesis is encountered, pop that too,+-- but not onto the output stack. Fails if the stack has no open+-- parentheses.+popThroughOpen+ :: ([OpStackVal], [R.RPNToken a])+ -> Maybe ([OpStackVal], [R.RPNToken a])+popThroughOpen (os, ts) = case os of+ [] -> Nothing+ v:vs -> case v of+ StkOp op -> popThroughOpen (vs, R.TokOperator op : ts)+ StkOpenParen -> return (vs, ts)++-- | Places an open parenthesis on the top of the operator stack. For+-- Close parenthesis, pops operators off the operator stack through+-- the next open parenthesis on the operator stack.+processParen+ :: ([OpStackVal], [R.RPNToken a])+ -> Paren+ -> Maybe ([OpStackVal], [R.RPNToken a])+processParen (os, ts) p = case p of+ Open -> Just (StkOpenParen : os, ts)+ Close -> popThroughOpen (os, ts)++-- | Creates an RPN expression from an infix one. Fails only if there+-- are mismatched parentheses. It is possible to create a nonsensical+-- RPN expression; the RPN parser must catch this.+createRPN+ :: Fdbl.Foldable f+ => f (InfixToken a)+ -- ^ The input tokens, with the beginning of the expression on the+ -- left side of the sequence.++ -> Maybe [R.RPNToken a]+ -- ^ The output sequence of tokens, with the beginning of the+ -- expression on the left side of the list.+createRPN ts = do+ (stack, toks) <- Fdbl.foldlM processInfixToken ([], []) ts+ fmap reverse $ popRemainingOperators stack toks++-- | Pops remaining items off operator stack. Fails if there is an+-- open paren left on the stack, as this indicates mismatched+-- parenthesis.+popRemainingOperators :: [OpStackVal] -> [R.RPNToken a] -> Maybe [R.RPNToken a]+popRemainingOperators os ts = case os of+ [] -> return ts+ x:xs -> case x of+ StkOp op -> popRemainingOperators xs (R.TokOperator op : ts)+ StkOpenParen -> Nothing
+ Data/Prednote/Expressions/RPN.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Postfix, or RPN, expression parsing.+--+-- This module parses RPN expressions where the operands are+-- predicates and the operators are one of @and@, @or@, or @not@,+-- where @and@ and @or@ are binary and @not@ is unary.+module Data.Prednote.Expressions.RPN where++import qualified Control.Monad.Exception.Synchronous as Ex+import qualified Data.Foldable as Fdbl+import qualified Data.Prednote.Pdct as P+import Data.Prednote.Pdct ((&&&), (|||))+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as X+import qualified System.Console.Rainbow as C++type Error = Text++data RPNToken a+ = TokOperand (P.Pdct a)+ | TokOperator Operator++data Operator+ = OpAnd+ | OpOr+ | OpNot+ deriving Show++pushOperand :: P.Pdct a -> [P.Pdct a] -> [P.Pdct a]+pushOperand p ts = p : ts++pushOperator+ :: Operator+ -> [P.Pdct a]+ -> Ex.Exceptional Error [P.Pdct a]+pushOperator o ts = case o of+ OpAnd -> case ts of+ x:y:zs -> return $ (y &&& x) : zs+ _ -> Ex.throw $ err "and"+ OpOr -> case ts of+ x:y:zs -> return $ (y ||| x) : zs+ _ -> Ex.throw $ err "or"+ OpNot -> case ts of+ x:zs -> return $ P.not x : zs+ _ -> Ex.throw $ err "not"+ where+ err x = "insufficient operands to apply \"" <> x+ <> "\" operator\n"++pushToken+ :: [P.Pdct a]+ -> RPNToken a+ -> Ex.Exceptional Error [P.Pdct a]+pushToken ts t = case t of+ TokOperand p -> return $ pushOperand p ts+ TokOperator o -> pushOperator o ts+++-- | Parses an RPN expression and returns the resulting Pdct. Fails if+-- there are no operands left on the stack or if there are multiple+-- operands left on the stack; the stack must contain exactly one+-- operand in order to succeed.+parseRPN+ :: Fdbl.Foldable f+ => f (RPNToken a)+ -> Ex.Exceptional Error (P.Pdct a)+parseRPN ts = do+ trees <- Fdbl.foldlM pushToken [] ts+ case trees of+ [] -> Ex.throw $ "bad expression: no operands left on the stack\n"+ x:[] -> return x+ xs -> Ex.throw+ $ "bad expression: multiple operands left on the stack:\n"+ <> ( X.concat+ . map C.chunkText+ . concatMap (P.showPdct 4 0)+ $ xs )+
+ Data/Prednote/Pdct.hs view
@@ -0,0 +1,305 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Trees of predicates.+--+-- Exports names which conflict with Prelude names, so you probably+-- want to import this module qualified.++module Data.Prednote.Pdct+ ( -- * The Pdct tree+ Label+ , Pdct(..)+ , Node(..)+ , rename+ , always+ , never++ -- * Creating operands+ , operand++ -- * Creating Pdct from other Pdct+ , and+ , or+ , not+ , neverFalse+ , neverTrue+ , (&&&)+ , (|||)+ , boxPdct+ , boxNode++ -- * Showing and evaluating Pdct+ , Level+ , IndentAmt+ , ShowDiscards+ , showPdct+ , eval+ , evaluate+ ) where++import Control.Applicative ((<*>))+import Data.Maybe (fromMaybe, isJust, catMaybes)+import Data.Text (Text)+import qualified Data.Text as X+import Data.Monoid ((<>), mconcat, mempty)+import qualified System.Console.Rainbow as R+import System.Console.Rainbow ((+.+))+import Prelude hiding (not, and, or)+import qualified Prelude++type Label = Text++-- | A tree of predicates.+data Pdct a = Pdct Label (Node a)++instance Show (Pdct a) where+ show _ = "predicate"++-- | Renames the top level of the Pdct. The function you pass will be+-- applied to the old name.+rename :: (Text -> Text) -> Pdct a -> Pdct a+rename f (Pdct l n) = Pdct (f l) n++data Node a+ = And [Pdct a]+ -- ^ None of the Pdct in list may be Just False. An empty list or+ -- list with only Nothing is Just True.++ | Or [Pdct a]+ -- ^ At least one of the Pdct in the list must be Just True. An+ -- empty list or list with only Nothing is Just False.++ | Not (Pdct a)+ -- ^ Just True is Just False and vice versa; Nothing remains Nothing.++ | NeverFalse (Pdct a)+ -- ^ Just True if the child is Just True; Nothing otherwise.++ | NeverTrue (Pdct a)+ -- ^ Just False if the child is Just False; Nothing otherwise.++ | Operand (a -> Maybe Bool)+ -- ^ An operand may return Just True or Just False to indicate+ -- success or failure. It may also return Nothing to indicate a+ -- discard.++-- | Given a function that un-boxes values of type b, changes a Node+-- from type a to type b.+boxNode+ :: (b -> a)+ -> Node a+ -> Node b+boxNode f n = case n of+ And ls -> And $ map (boxPdct f) ls+ Or ls -> Or $ map (boxPdct f) ls+ Not o -> Not $ boxPdct f o+ NeverFalse o -> NeverFalse $ boxPdct f o+ NeverTrue o -> NeverTrue $ boxPdct f o+ Operand g -> Operand $ \b -> g (f b)+++-- | Given a function that un-boxes values of type b, changes a Pdct+-- from type a to type b.+boxPdct+ :: (b -> a)+ -> Pdct a+ -> Pdct b+boxPdct f (Pdct l n) = Pdct l $ boxNode f n++and :: [Pdct a] -> Pdct a+and = Pdct "and" . And++or :: [Pdct a] -> Pdct a+or = Pdct "or" . Or++not :: Pdct a -> Pdct a+not = Pdct "not" . Not++-- | Creates a new operand. The Pdct is Just True or Just False, never+-- Nothing.+operand :: Text -> (a -> Bool) -> Pdct a+operand t = Pdct t . Operand . fmap Just++-- | Turns an existing Pdct to one that never says False. If the+-- underlying predicate returns Just True, the new Pdct also returns+-- Just True. Otherwise, the Pdct returns Nothing.+neverFalse :: Pdct a -> Pdct a+neverFalse = Pdct "never False" . NeverFalse++-- | Turns an existing Pdct to one that never says True. If the+-- underlying predicate returns Just False, the new Pdct also returns+-- Just False. Otherwise, the Pdct returns Nothing.+neverTrue :: Pdct a -> Pdct a+neverTrue = Pdct "never True" . NeverTrue+++-- | Returns a tree that is always True.+always :: Pdct a+always = Pdct "always True" (Operand (const (Just True)))++-- | Returns a tree that is always False.+never :: Pdct a+never = Pdct "always False" (Operand (const (Just False)))++-- | Forms a Pdct using 'and'.+(&&&) :: Pdct a -> Pdct a -> Pdct a+(&&&) x y = Pdct "and" (And [x, y])+infixr 3 &&&++-- | Forms a Pdct using 'or'.+(|||) :: Pdct a -> Pdct a -> Pdct a+(|||) x y = Pdct "or" (Or [x, y])+infixr 2 |||++-- | How many levels of indentation to use. Typically you will start+-- this at zero. It is incremented by one for each level as functions+-- descend through the tree.+type Level = Int++-- | The number of spaces to use for each level of indentation.+type IndentAmt = Int++-- | Indents text, and adds a newline to the end.+indent :: IndentAmt -> Level -> [R.Chunk] -> [R.Chunk]+indent amt lvl cs = idt : (cs ++ [nl])+ where+ idt = R.plain (X.replicate (lvl * amt) " ")+ nl = R.plain (X.singleton '\n')++-- | Shows a Pdct tree without evaluating it.+showPdct :: IndentAmt -> Level -> Pdct a -> [R.Chunk]+showPdct amt lvl (Pdct l pd) = case pd of+ And ls -> indent amt lvl [R.plain l]+ <> mconcat (map (showPdct amt (lvl + 1)) ls)+ Or ls -> indent amt lvl [R.plain l]+ <> mconcat (map (showPdct amt (lvl + 1)) ls)+ Not t -> indent amt lvl [R.plain l]+ <> showPdct amt (lvl + 1) t+ NeverFalse t -> indent amt lvl [R.plain l]+ <> showPdct amt (lvl + 1) t+ NeverTrue t -> indent amt lvl [R.plain l]+ <> showPdct amt (lvl + 1) t+ Operand _ -> indent amt lvl [R.plain l]+++labelBool :: Text -> Maybe Bool -> [R.Chunk]+labelBool t b = [open, trueFalse, close, blank, txt]+ where+ trueFalse = case b of+ Nothing -> R.plain "discard" +.+ R.f_yellow+ Just bl -> if bl+ then R.plain "TRUE" +.+ R.f_green+ else R.plain "FALSE" +.+ R.f_red+ open = R.plain "["+ close = R.plain "]"+ blank = R.plain (X.replicate blankLen " ")+ blankLen = X.length "discard"+ - X.length (R.chunkText trueFalse) + 1+ txt = R.plain t++type ShowDiscards = Bool++-- | Evaluates a Pdct.+eval :: Pdct a -> a -> Maybe Bool+eval (Pdct _ n) a = case n of+ And ps -> Just . Prelude.and . catMaybes $ [flip eval a] <*> ps+ Or ps -> Just . Prelude.or . catMaybes $ [flip eval a] <*> ps+ Not p -> fmap Prelude.not $ eval p a+ NeverFalse p -> case eval p a of+ Nothing -> Nothing+ Just b -> if Prelude.not b then Nothing else Just b+ NeverTrue p -> case eval p a of+ Nothing -> Nothing+ Just b -> if b then Nothing else Just b+ Operand f -> f a++-- | Verbosely evaluates a Pdct.+evaluate+ :: IndentAmt+ -- ^ Indent each level by this many spaces.++ -> ShowDiscards+ -- ^ If True, show discarded test results; otherwise, hide+ -- them.++ -> a+ -- ^ The subject to evaluate++ -> Level+ -- ^ How many levels deep in the tree we are. Typically you will+ -- start at level 0. This determines the level of indentation.++ -> Pdct a++ -> (Maybe Bool, [R.Chunk])+evaluate i sd a lvl (Pdct l pd) = case pd of++ And ps -> let (resBool, resTxt) = evalAnd i sd a (lvl + 1) ps+ txt = indent i lvl (labelBool l (Just resBool))+ <> resTxt+ in (Just resBool, txt)++ Or ps -> let (resBool, resTxt) = evalOr i sd a (lvl + 1) ps+ txt = indent i lvl (labelBool l (Just resBool))+ <> resTxt+ in (Just resBool, txt)++ Not p -> let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p+ thisMayBool = fmap Prelude.not childMayBool+ thisTxt = indent i lvl (labelBool l thisMayBool)+ txt = if sd || isJust thisMayBool+ then thisTxt <> childTxt else mempty+ in (thisMayBool, txt)++ NeverFalse p ->+ let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p+ thisMayBool = case childMayBool of+ Nothing -> Nothing+ Just b -> if Prelude.not b then Nothing else Just b+ thisTxt = indent i lvl (labelBool l thisMayBool)+ txt = if sd || isJust thisMayBool+ then thisTxt <> childTxt else mempty+ in (thisMayBool, txt)++ NeverTrue p ->+ let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p+ thisMayBool = case childMayBool of+ Nothing -> Nothing+ Just b -> if b then Nothing else Just b+ thisTxt = indent i lvl (labelBool l thisMayBool)+ txt = if sd || isJust thisMayBool+ then thisTxt <> childTxt else mempty+ in (thisMayBool, txt)++ Operand p -> let res = p a+ txt = indent i lvl (labelBool l res)+ in (res, if sd || isJust res then txt else mempty)++evalAnd :: IndentAmt -> ShowDiscards -> a+ -> Level -> [Pdct a] -> (Bool, [R.Chunk])+evalAnd i sd a l ts = (Prelude.not foundFalse, txt)+ where+ (foundFalse, txt) = go ts (False, mempty)+ go [] p = p+ go (x:xs) (fndFalse, acc) =+ if fndFalse+ then (fndFalse, acc <> indent i l+ [R.plain "(short circuit)"])+ else let (res, cTxt) = evaluate i sd a l x+ fndFalse' = maybe False Prelude.not res+ in go xs (fndFalse', acc <> cTxt)++evalOr :: IndentAmt -> ShowDiscards -> a+ -> Level -> [Pdct a] -> (Bool, [R.Chunk])+evalOr i sd a l ts = (foundTrue, txt)+ where+ (foundTrue, txt) = go ts (False, mempty)+ go [] p = p+ go (x:xs) (fnd, acc) =+ if fnd+ then (fnd, acc <> indent i l+ [R.plain "(short circuit)"])+ else let (res, cTxt) = evaluate i sd a l x+ fnd' = fromMaybe False res+ in go xs (fnd', acc <> cTxt)+
+ Data/Prednote/TestTree.hs view
@@ -0,0 +1,461 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Helps you build a tree of tests that run against a series of+-- items. This is best illustrated with an example.+--+-- Let's say that you have a list of Int. You want to make sure that+-- every Int in the list is odd and that every Int is greater than+-- zero. You also want to make sure that at least 5 Ints in the list+-- are greater than 20.+--+-- 'Pdct' from "Data.Prednote.Pdct" will help you, but only so much: a+-- 'Pdct' can test individual Int, but by itself it will not help you+-- run a check against a whole list of Int. Of course you can build+-- such a test fairly easily with 'any' and 'all', but what if you+-- want to view the results of the tests verbosely? That's where this+-- module comes in.+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import System.Console.Rainbow+-- > import Data.Prednote.TestTree+-- > import Data.Prednote.Pdct+-- >+-- > isOdd :: Pdct Int+-- > isOdd = operand "is odd" odd+-- >+-- > greaterThan0 :: Pdct Int+-- > greaterThan0 = operand "greater than zero" (> 0)+-- >+-- > greaterThan20 :: Pdct Int+-- > greaterThan20 = operand "greater than 20" (> 20)+-- >+-- > myOpts :: TestOpts Int+-- > myOpts = TestOpts+-- > { tIndentAmt = 2+-- > , tPassVerbosity = TrueSubjects+-- > , tFailVerbosity = TrueSubjects+-- > , tGroupPred = const True+-- > , tTestPred = const True+-- > , tShowSkippedTests = True+-- > , tGroupVerbosity = AllGroups+-- > , tSubjects = mySubjects+-- > , tStopOnFail = False+-- > }+-- >+-- > mySubjects :: [Int]+-- > mySubjects = [2, 4, 6, 8, 10, 18, 19, 20, 21, 22, 24, 26]+-- >+-- > tests :: [TestTree Int]+-- > tests = [ isOdd, greaterThan0, greaterThan20 ]+-- >+-- > main :: IO ()+-- > main = do+-- > let (cks, passed, failed) = runTests myOpts 0 tests+-- > t <- termFromEnv+-- > printChunks t cks+-- > putStrLn $ "number of tests passed: " ++ show passed+-- > putStrLn $ "number of tests failed: " ++ show failed+module Data.Prednote.TestTree+ (+ -- * The TestTree+ Name+ , TestFunc+ , TestTree (..)+ , Payload (..)+ , test++ -- * Tests+ , eachSubjectMustBeTrue+ , nSubjectsMustBeTrue++ -- * Grouping tests+ , group++ -- * Simple test runners+ , Verbosity(..)+ , GroupVerbosity (..)+ , Pt.Level+ , PassCount+ , FailCount+ , runTests++ -- * Showing the test tree+ , showTestTree++ -- * Tree evaluator+ , TestOpts (..)+ , ShortCircuit+ , Pass+ , evalTree++ ) where++import Data.Either (rights)+import Data.Maybe (isJust)+import Data.List (unfoldr)+import Data.Monoid ((<>))+import qualified Data.Text as X+import Data.Text (Text)+import qualified Data.List.Split as Sp++import qualified System.Console.Rainbow as R+import System.Console.Rainbow ((+.+))+import qualified Data.Prednote.Pdct as Pt++--+-- Types+--++type Pass = Bool++-- | The name of a test or of a group.+type Name = Text++-- | A tree of tests.+data TestTree a = TestTree Name (Payload a)++data Payload a+ = Group [TestTree a]+ | Test (TestFunc a)++-- | A test is a function of this type. The function must make chunks+-- in a manner that respects the applicable verbosity.+type TestFunc a+ = Pt.IndentAmt+ -> Verbosity+ -- ^ Use this verbosity for tests that pass++ -> Verbosity+ -- ^ Use this verbosity for tests that fail++ -> [a]+ -> Pt.Level+ -> (Pass, [R.Chunk])+++-- | Creates groups of tests.+group :: Name -> [TestTree a] -> TestTree a+group n = TestTree n . Group++-- | Creates tests.+test :: Name -> TestFunc a -> TestTree a+test n = TestTree n . Test++-- | How verbose to be when reporting the results of tests. It would+-- be possible to have many more knobs to control this behavior; this+-- implementation is a compromise and hopefully provides enough+-- verbosity settings without being too complex.+data Verbosity++ = Silent+ -- ^ Show nothing at all++ | PassFail+ -- ^ Show only whether the test passed or failed++ | FalseSubjects+ -- ^ Show subjects that are False. In addition, shows all evaluation+ -- steps that led to the subject being False; however, does not show+ -- discarded evaluation steps. Does not show True subjects at all.++ | TrueSubjects+ -- ^ Show subjects that are True. (This is cumulative, so False+ -- subjects are shown too, as they would be using 'FalseSubjects'.)+ -- Shows all evaluation steps that led to the subject being True;+ -- however, does not show discarded evaluation steps.++ | Discards+ -- ^ Shows discarded subjects. Cumulative, so also does what+ -- 'FalseSubjects' and 'TrueSubjects' do. Also shows all discarded+ -- evaluation steps for all subjects.++ deriving (Eq, Ord, Show)++--+-- Helper functions+--+++-- | Determines whether to show a subject, and shows it.+showSubject+ :: (a -> X.Text)+ -> Verbosity+ -> Pt.IndentAmt+ -> Pt.Level+ -> Pt.Pdct a+ -> (a, Maybe Bool)+ -> [R.Chunk]+showSubject swr v i l p (s, b) =+ let (showSubj, showDisc) = isSubjectAndDiscardsShown v b+ renamer txt = X.concat [swr s, " - ", txt]+ renamed = Pt.rename renamer p+ in if showSubj+ then snd $ Pt.evaluate i showDisc s l renamed+ else []++-- | Given a Verbosity and a Maybe Boolean indicating whether a+-- subject is True, False, or a discard, returns whether to show the+-- subject and whether to show the discards contained within the+-- subject.+isSubjectAndDiscardsShown :: Verbosity -> Maybe Bool -> (Bool, Bool)+isSubjectAndDiscardsShown v b = case v of+ Silent -> (False, False)+ PassFail -> (False, False)+ FalseSubjects -> (not . isTrue $ b, False)+ TrueSubjects -> (isJust b, False)+ Discards -> (True, True)+++showTestTitle :: Pt.IndentAmt -> Pt.Level -> Name -> Pass -> [R.Chunk]+showTestTitle i l n p = [idt, open, passFail, close, blank, txt, nl]+ where+ idt = R.plain (X.replicate (i * l) " ")+ nl = R.plain "\n"+ passFail =+ if p+ then R.plain "PASS" +.+ R.f_green+ else R.plain "FAIL" +.+ R.f_red+ open = R.plain "["+ close = R.plain "]"+ blank = R.plain (X.singleton ' ')+ txt = R.plain n++isTrue :: Maybe Bool -> Bool+isTrue = maybe False id++--+-- Tests+--++-- | Passes if every subject is True.+eachSubjectMustBeTrue+ :: Name+ -> (a -> Text)+ -> Pt.Pdct a+ -> TestTree a+eachSubjectMustBeTrue n swr p = TestTree n (Test tf)+ where+ tf i pv fv as lvl = (pass, cks)+ where+ rslts = zip as (map (Pt.eval p) as)+ pass = all (isTrue . snd) rslts+ v = if pass then pv else fv+ cks = tit ++ subjectChunks+ tit = if v == Silent then [] else showTestTitle i lvl n pass+ subjectChunks =+ concatMap (showSubject swr v i (lvl + 1) p) rslts++-- | Passes if at least n subjects are True.+nSubjectsMustBeTrue+ :: Name+ -> (a -> X.Text)+ -> Int+ -> Pt.Pdct a+ -> TestTree a+nSubjectsMustBeTrue n swr count p = TestTree n (Test tf)+ where+ tf idnt pv fv as l = (pass, cks)+ where+ pd (_, res) = isTrue res+ resultList = take count+ . Sp.split ( Sp.keepDelimsR+ (Sp.dropFinalBlank . Sp.whenElt $ pd))+ $ zip as (map (Pt.eval p) as)+ pass = length resultList >= count+ v = if pass then pv else fv+ cks = tit ++ subjectChunks+ tit = if v == Silent then [] else showTestTitle idnt l n pass+ subjectChunks =+ concatMap (showSubject swr v idnt (l + 1) p)+ . concat $ resultList++indent :: Pt.IndentAmt -> Pt.Level -> Text -> R.Chunk+indent amt lvl t = R.plain txt+ where+ txt = X.concat [spaces, t, "\n"]+ spaces = X.replicate (amt * lvl) " "++skip :: Text -> Pt.IndentAmt -> Pt.Level -> Text -> [R.Chunk]+skip lbl amt lvl t =+ [ R.plain (X.replicate (amt * lvl) " ")+ , R.plain "["+ , R.plain ("skip " <> lbl) +.+ R.f_yellow+ , R.plain "] "+ , R.plain t+ , R.plain "\n"+ ]++-- | Shows a tree, without evaluating it.+showTestTree+ :: Pt.IndentAmt+ -> Pt.Level+ -> TestTree a+ -> [R.Chunk]+showTestTree amt l (TestTree n p) = indent amt l n : children+ where+ children = case p of+ Group ts -> concatMap (showTestTree amt l) ts+ Test _ -> []+++-- | Options for running tests.+data TestOpts a = TestOpts++ { tIndentAmt :: Int+ -- ^ Indent each level by this many spaces++ , tPassVerbosity :: Verbosity+ -- ^ Use this verbosity for tests that pass++ , tFailVerbosity :: Verbosity+ -- ^ Use this verbosity for tests that fail++ , tGroupPred :: Name -> Bool+ -- ^ Groups are run only if this predicate returns True.++ , tTestPred :: Name -> Bool+ -- ^ Tests are run only if this predicate returns True.++ , tShowSkippedTests :: Bool+ -- ^ Some tests might be skipped; see 'tTestPred'. This controls+ -- whether you want to see a notification of tests that were+ -- skipped. (Does not affect skipped groups; see 'tGroupVerbosity'+ -- for that.)++ , tGroupVerbosity :: GroupVerbosity+ -- ^ Show group names? Even if you do not show the names of+ -- groups, tests within the group will still be indented.++ , tSubjects :: [a]+ -- ^ The subjects to test++ , tStopOnFail :: Bool+ -- ^ If True, then tests will stop running immediately after a+ -- single test fails. If False, all tests are always run.+ }+++-- | True if the tree returned a result without completely evaluating+-- all parts of the tree. This can occur if 'tStopOnFail' is True and+-- one of the tests in the tree failed.+type ShortCircuit = Bool++-- | Evaluates a tree. This function is the basis of 'runTests', which+-- is typically a bit easier to use.+evalTree++ :: TestOpts a+ -- ^ Most options++ -> Pt.Level+ -- ^ The tree will indented by this many levels; typically you will+ -- want to start this at 0.++ -> TestTree a++ -> (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])])+ -- ^ The first element of the tuple is True if the tree was not+ -- fully evaluated. This can happen if 'tStopOnFail' is True and+ -- one of the tests in the tree failed. The second element of the+ -- tuple is a list of Either; each element of the list will be a+ -- Left if that component of the tree was not a test, or a Right if+ -- that element was a test. The Right will contain a tuple, where+ -- the first element indicates whether the test passed or failed,+ -- and the second element is the list of Chunk.++evalTree ee l (TestTree n p) = case p of+ Group ts -> evalGroup ee n l ts+ Test f -> evalTest ee n l f++evalGroup+ :: TestOpts a+ -> Name+ -> Pt.Level+ -> [TestTree a]+ -> (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])])+evalGroup ee n l ts = if tGroupPred ee n+ then let ls = unfoldr (unfoldList ee l) (False, ts)+ stop = any not . map fst $ ls+ rslts = concat . map snd $ ls+ groupNm = if tGroupVerbosity ee /= NoGroups+ then indent (tIndentAmt ee) l n+ else R.plain ""+ in (stop, Left [groupNm] : rslts)+ else let groupNm = if tGroupVerbosity ee == AllGroups+ then skip "group" (tIndentAmt ee) l n+ else [R.plain ""]+ in (False, [Left groupNm])+++evalTest+ :: TestOpts a+ -> Name+ -> Pt.Level+ -> TestFunc a+ -> (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])])+evalTest ee n l tf = if tTestPred ee n+ then (not p, [Right (p, cs)])+ else (False, skipped)+ where+ (p, cs) = tf (tIndentAmt ee) (tPassVerbosity ee)+ (tFailVerbosity ee) (tSubjects ee) l+ skipped = if tShowSkippedTests ee+ then [Left $ skip "test" (tIndentAmt ee) l n]+ else []+++--+-- Running a group of tests+--++type PassCount = Int+type FailCount = Int++-- | How verbose to be when showing names of groups.+data GroupVerbosity++ = NoGroups+ -- ^ Show no group names at all. However, groups will still be+ -- indented.++ | ActiveGroups+ -- ^ Show groups that are not skipped.++ | AllGroups+ -- ^ Show all groups, and indicate which groups are skipped.+ deriving (Eq, Ord, Show)+++-- | Runs each test in a list of tests (though each test might not run+-- if 'tStopOnFail' is True.) Reports on how many passed and how many+-- failed. (if 'tStopOnFail' is True, the FailCount will never exceed+-- 1.)+runTests+ :: TestOpts a+ -> Pt.Level+ -> [TestTree a]+ -> ([R.Chunk], PassCount, FailCount)+runTests ee l ts =+ let ls = unfoldr (unfoldList ee l) (False, ts)+ testRs = rights . concatMap snd $ ls+ passed = length . filter id . map fst $ testRs+ failed = length . filter (not . id) . map fst $ testRs+ cks = concat . map (either id snd) . concatMap snd $ ls+ in (cks, passed, failed)++unfoldList+ :: TestOpts a+ -> Pt.Level+ -> (ShortCircuit, [TestTree a])+ -> Maybe ( (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])])+ , (ShortCircuit, [TestTree a]))+unfoldList ee l (seenFalse, is) =+ if seenFalse && tStopOnFail ee+ then Nothing+ else case is of+ [] -> Nothing+ t:xs ->+ let (short, results) = evalTree ee l t+ in Just ((short, results), (short, xs))++
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Omari Norman++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.++ * Neither the name of Omari Norman nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"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+OWNER OR CONTRIBUTORS 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ prednote.cabal view
@@ -0,0 +1,44 @@+name: prednote+version: 0.2.0.0+synopsis: Build and evaluate trees of predicates+description:+ Build and evaluate trees of predicates. For example, you might build+ a predicate of the type Int -> Bool. You do this by assembling+ several predicates into a tree. You can then verbosely evaluate+ this tree, showing why a particular result is reached.+ .+ prednote also provides modules to test several subjects against a+ given predicate, and to parse infix or RPN expressions into a tree of+ predicates.++homepage: http://github.com/massysett/prednote+license: BSD3+license-file: LICENSE+author: Omari Norman+maintainer: omari@smileystation.com+copyright: 2013 Omari Norman+category: Data+build-type: Simple+cabal-version: >=1.8++source-repository head+ type: git+ location: git://github.com/massysett/prednote.git++library++ exposed-modules:+ Data.Prednote.Pdct+ , Data.Prednote.Expressions+ , Data.Prednote.Expressions.Infix+ , Data.Prednote.Expressions.RPN+ , Data.Prednote.TestTree++ build-depends:+ base >= 4.6 && < 5+ , explicit-exception ==0.1.*+ , rainbow ==0.1.*+ , split ==0.2.*+ , text == 0.11.*++ ghc-options: -Wall