packages feed

prednote 0.10.0.0 → 0.12.0.0

raw patch · 12 files changed

+1270/−1391 lines, 12 filesdep +QuickChecknew-component:exe:prednote-test

Dependencies added: QuickCheck

Files

− Data/Prednote/Expressions.hs 
@@ -1,83 +0,0 @@-{-# 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 
@@ -1,126 +0,0 @@-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 
@@ -1,79 +0,0 @@-{-# 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._text-           . concatMap (P.showPdct 4 0)-           $ xs )-
− Data/Prednote/Pdct.hs 
@@ -1,637 +0,0 @@-{-# 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-  , filter--  -- * Helpers for building common Pdct-  -- ** Non-overloaded-  , compareBy-  , compareByMaybe-  , greaterBy-  , lessBy-  , equalBy-  , greaterEqBy-  , lessEqBy-  , notEqBy--  -- ** Overloaded-  , compare-  , greater-  , less-  , equal-  , greaterEq-  , lessEq-  , notEq-  , parseComparer--  ) 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 Data.String (fromString)-import qualified System.Console.Rainbow as R-import Prelude hiding (not, and, or, compare, filter)-import qualified Prelude--type Label = Text---- | A tree of predicates.-data Pdct a = Pdct Label (Node a)--instance Show (Pdct a) where-  show = X.unpack-         . X.concat-         . map R._text-         . showPdct 2 0---- | 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 = fromString (replicate (lvl * amt) ' ')-    nl = fromString "\n"---- | Creates a plain Chunk from a Text.-plain :: Text -> R.Chunk-plain = R.Chunk mempty---- | 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 [plain l]-            <> mconcat (map (showPdct amt (lvl + 1)) ls)-  Or ls -> indent amt lvl [plain l]-           <> mconcat (map (showPdct amt (lvl + 1)) ls)-  Not t -> indent amt lvl [plain l]-           <> showPdct amt (lvl + 1) t-  NeverFalse t -> indent amt lvl [plain l]-                  <> showPdct amt (lvl + 1) t-  NeverTrue t -> indent amt lvl [plain l]-                 <> showPdct amt (lvl + 1) t-  Operand _ -> indent amt lvl [plain l]---labelBool :: Text -> Maybe Bool -> [R.Chunk]-labelBool t b = [open, trueFalse, close, blank, txt]-  where-    trueFalse = case b of-      Nothing -> "discard" <> R.f_yellow-      Just bl -> if bl-        then "TRUE" <> R.f_green-        else "FALSE" <> R.f_red-    open = "["-    close = "]"-    blank = plain (X.replicate blankLen " ")-    blankLen = X.length "discard"-               - X.length (R._text trueFalse) + 1-    txt = 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-                             [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-                        [plain "(short circuit)"])-      else let (res, cTxt) = evaluate i sd a l x-               fnd' = fromMaybe False res-           in go xs (fnd', acc <> cTxt)---- | Filters a list of items by including only the ones for which the--- Pdct returns Just True. Also, renames each top-level Pdct so that--- the textual results include a description of the item being--- evaluated.-filter-  :: IndentAmt-  -- ^ Indent each level by this many spaces.--  -> ShowDiscards-  -- ^ If True, show discarded test results; otherwise, hide-  -- them.--  -> Level-  -- ^ How many levels deep in the tree we are. Typically you will-  -- start at level 0. This determines the level of indentation.--  -> (a -> Text)-  -- ^ How to show each item. This is used to add a description of-  -- each item to the verbose output. This Text should be a one-line-  -- description, without any newlines.--  -> Pdct a-  -- ^ Use this Pdct to filter--  -> [a]-  -- ^ The list to filter--  -> ([a], [R.Chunk])-  -- ^ The results of the filtering, and the verbose output indicating-  -- what was kept and discarded and why--filter ident sd lvl swr pdct items =-  let pds = map mkPd items-      mkPd a = rename (\x -> mconcat [x, " - ", swr a]) pdct-      results = zipWith mkResult pds items-      mkResult p i = (evaluate ident sd i lvl p, i)-      folder ((maybeBool, cks), i) (as, cksOld) = (as', cks ++ cksOld)-        where-          as' = if fromMaybe False maybeBool-                then i:as-                else as-  in foldr folder ([], []) results------- Helpers------- | Build a Pdct that compares items.-compareBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare an item against the right hand side. Return LT-  -- if the item is less than the right hand side; GT if greater; EQ-  -- if equal to the right hand side.--  -> Ordering-  -- ^ When subjects are compared, this ordering must be the result in-  -- order for the Pdct to be Just True; otherwise it is Just-  -- False. The subject will be on the left hand side.--  -> Pdct a--compareBy itemDesc typeDesc cmp ord = Pdct l (Operand f)-  where-    l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc-    cmpDesc = case ord of-      LT -> "less than"-      GT -> "greater than"-      EQ -> "equal to"-    f subj = Just $ cmp subj == ord---- | Like 'compareBy' but allows the comparison of items that may fail--- to return an ordering.-compareByMaybe-  :: Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Maybe Ordering)-  -- ^ How to compare an item against the right hand side. Return Just-  -- LT if the item is less than the right hand side; Just GT if-  -- greater; Just EQ if equal to the right hand side. Return Nothing-  -- if the item cannot return an item to be compared. The result of-  -- the evaluation of the Pdct will then be Nothing.--  -> Ordering-  -- ^ When subjects are compared, this ordering must be the result in-  -- order for the Pdct to be Just True; otherwise it is Just False,-  -- or Nothing if the subject does not return an ordering. The-  -- subject will be on the left hand side.--  -> Pdct a--compareByMaybe itemDesc typeDesc cmp ord = Pdct l (Operand f)-  where-    l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc-    cmpDesc = case ord of-      LT -> "less than"-      GT -> "greater than"-      EQ -> "equal to"-    f subj = maybe Nothing (Just . (== ord)) $ cmp subj---- | Overloaded version of 'compareBy'.-compare-  :: (Show a, Ord a)-  => Text-  -- ^ Description of the type of thing being matched--  -> a-  -- ^ The right hand side of the comparison.--  -> Ordering-  -- ^ When subjects are compared, this ordering must be the result in-  -- order for the Pdct to be Just True; otherwise it is Just-  -- False. The subject will be on the left hand side.--  -> Pdct a-compare typeDesc a ord = compareBy itemDesc typeDesc cmp ord-  where-    itemDesc = X.pack . show $ a-    cmp item = Prelude.compare item a--greater-  :: (Show a, Ord a)-  => Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> a-  -- ^ The right hand side of the comparison.--  -> Pdct a-greater d a = compare d a GT--less-  :: (Show a, Ord a)-  => Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> a-  -- ^ The right hand side of the comparison.--  -> Pdct a-less d a = compare d a LT--equal-  :: (Show a, Ord a)-  => Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> a-  -- ^ The right hand side of the comparison.--  -> Pdct a-equal d a = compare d a EQ--greaterEq-  :: (Show a, Ord a)-  => Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> a-  -- ^ The right hand side of the comparison.--  -> Pdct a-greaterEq d a = greater d a ||| equal d a--lessEq-  :: (Show a, Ord a)-  => Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> a-  -- ^ The right hand side of the comparison.--  -> Pdct a-lessEq d a = less d a ||| equal d a--notEq-  :: (Show a, Ord a)-  => Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> a-  -- ^ The right hand side of the comparison.--  -> Pdct a-notEq d a = not $ equal d a--greaterBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Pdct a-greaterBy iD tD cmp = compareBy iD tD cmp GT--lessBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Pdct a-lessBy iD tD cmp = compareBy iD tD cmp LT--equalBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Pdct a-equalBy iD tD cmp = compareBy iD tD cmp EQ--greaterEqBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Pdct a-greaterEqBy iD tD cmp =-  greaterBy iD tD cmp ||| equalBy iD tD cmp--lessEqBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Pdct a-lessEqBy iD tD cmp =-  lessBy iD tD cmp ||| equalBy iD tD cmp--notEqBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Pdct--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Pdct a-notEqBy iD tD cmp =-  not $ equalBy iD tD cmp------- Comparer parsers------- | Parses a string to find the correct comparer; returns the correct--- function to build a Pdct.--parseComparer-  :: Text-  -- ^ The string with the comparer to be parsed-  -> (Ordering -> Pdct a)-  -- ^ A function that, when given an ordering, returns a Pdct-  -> Maybe (Pdct a)-  -- ^ If an invalid comparer string is given, Nothing; otherwise, the-  -- Pdct.-parseComparer t f-  | t == ">" = Just (f GT)-  | t == "<" = Just (f LT)-  | t == "=" = Just (f EQ)-  | t == "==" = Just (f EQ)-  | t == ">=" = Just (f GT ||| f EQ)-  | t == "<=" = Just (f LT ||| f EQ)-  | t == "/=" = Just (not $ f EQ)-  | t == "!=" = Just (not $ f EQ)-  | otherwise = Nothing-
− Data/Prednote/TestTree.hs 
@@ -1,464 +0,0 @@-{-# 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 ((<>), mempty)-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 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)----- | Creates a plain Chunk from a Text.-plain :: X.Text -> R.Chunk-plain = R.Chunk mempty--showTestTitle :: Pt.IndentAmt -> Pt.Level -> Name -> Pass -> [R.Chunk]-showTestTitle i l n p = [idt, open, passFail, close, blank, txt, nl]-  where-    idt = plain (X.replicate (i * l) " ")-    nl = plain "\n"-    passFail =-      if p-      then "PASS" <> R.f_green-      else "FAIL" <> R.f_red-    open = plain "["-    close = plain "]"-    blank = plain (X.singleton ' ')-    txt = 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 = 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 =-  [ plain (X.replicate (amt * lvl) " ")-  , plain "["-  , plain ("skip " <> lbl) <> R.f_yellow-  , plain "] "-  , plain t-  , 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 plain ""-        in (stop, Left [groupNm] : rslts)-  else let groupNm = if tGroupVerbosity ee == AllGroups-                     then skip "group" (tIndentAmt ee) l n-                     else [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))--
+ lib/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
+ lib/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
+ lib/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._text+           . concatMap (P.showPdct 4 0)+           $ xs )+
+ lib/Data/Prednote/Pdct.hs view
@@ -0,0 +1,655 @@+{-# 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+  , Hide+  , Pdct(..)+  , Node(..)++  -- * Creating Pdct.+  -- | All functions create Pdct that are shown by default.+  , operand+  , and+  , or+  , not+  , (&&&)+  , (|||)+  , always+  , never+  , boxPdct+  , boxNode++  -- * Controlling whether Pdct are shown in the results+  , hide+  , show+  , hideTrue+  , hideFalse++  -- * Renaming Pdct+  , rename++  -- * Result+  , Result(..)+  , RNode(..)++  -- * Showing and evaluating Pdct+  , evaluate+  , evaluateNode+  , IndentAmt+  , Level+  , ShowAll+  , showResult+  , showTopResult+  , showPdct+  , filter+  , verboseFilter++  -- * Helpers for building common Pdct+  -- ** Non-overloaded+  , compareBy+  , compareByMaybe+  , greaterBy+  , lessBy+  , equalBy+  , greaterEqBy+  , lessEqBy+  , notEqBy++  -- ** Overloaded+  , compare+  , greater+  , less+  , equal+  , greaterEq+  , lessEq+  , notEq+  , parseComparer++  ) where+++-- # Imports++import Data.Text (Text)+import qualified Data.Text as X+import Data.Monoid ((<>), mconcat, mempty)+import Data.String (fromString)+import qualified System.Console.Rainbow as R+import Prelude hiding (not, and, or, compare, filter, show)+import qualified Prelude++-- # Pdct type++type Label = Text++-- | Determines whether a result is shown by default.+type Hide = Bool++-- | A predicate. Each Pdct contains a tree of Node.+data Pdct a = Pdct+  { pLabel :: Label+  -- ^ Label used when showing the results++  , pHide :: (Bool -> Hide)+  -- ^ As results are computed, this function is applied to the+  -- result. If this function returns False, then this Pdct will not+  -- be shown by default in the results.++  , pNode :: Node a++  }++data Node a+  = And [Pdct a]+  -- ^ Conjunction. If any Pdct in the list is False, the result is+  -- False. If the list is empty, the result is True.++  | Or [Pdct a]+  -- ^ Disjunction. If at least one Pdct in the list is True, the+  -- result it True. If the list is empty, the result is False.++  | Not (Pdct a)+  -- ^ Negation++  | Operand (a -> Bool)+  -- ^ Most basic building block.++-- | 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 p = p { pLabel = f (pLabel p) }++-- | Always True+always :: Pdct a+always = Pdct "always True" (const False) (Operand (const True))++-- | Always False+never :: Pdct a+never = Pdct "always False" (const False) (Operand (const False))++-- | Creates and labels operands.+operand :: Label -> (a -> Bool) -> Pdct a+operand l = Pdct l (const False) . Operand++-- | Creates And Pdct using a generic name+and :: [Pdct a] -> Pdct a+and = Pdct "and" (const False) . And++-- | Creates Or Pdct using a generic name+or :: [Pdct a] -> Pdct a+or = Pdct "or" (const False) . Or++-- | Creates Not Pdct using a generic name+not :: Pdct a -> Pdct a+not = Pdct "not" (const False) . Not++-- | Changes a Pdct so it is always hidden by default.+hide :: Pdct a -> Pdct a+hide p = p { pHide = const True }++-- | Changes a Pdct so it is always shown by default.+show :: Pdct a -> Pdct a+show p = p { pHide = const False }++-- | Changes a Pdct so that it is hidden if its result is True.+hideTrue :: Pdct a -> Pdct a+hideTrue p = p { pHide = id }++-- | Changes a Pdct so that it is hidden if its result is False.+hideFalse :: Pdct a -> Pdct a+hideFalse p = p { pHide = Prelude.not }++-- | Forms a Pdct using 'and'; assigns a generic label.+(&&&) :: Pdct a -> Pdct a -> Pdct a+(&&&) x y = Pdct "and" (const False) (And [x, y])+infixr 3 &&&++-- | Forms a Pdct using 'or'; assigns a generic label.+(|||) :: Pdct a -> Pdct a -> Pdct a+(|||) x y = Pdct "or" (const False) (Or [x, y])+infixr 2 |||++-- | 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 d n) = Pdct l d $ boxNode f n++-- | 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+  Operand g -> Operand $ \b -> g (f b)++-- # Result++-- | The result from evaluating a Pdct.+data Result = Result+  { rLabel :: Label+  -- ^ The label from the original Pdct++  , rBool :: Bool+  -- ^ The boolean result from evaluating the node. If the node is an+  -- operand, this is the result of applying the operand function to+  -- the subject. Otherwise, this is the result of application of the+  -- appropriate boolean operation to the child nodes.++  , rHide :: Hide+  -- ^ Is this result hidden in the result by default? Hiding only+  -- affects presentation; it does not affect how this Pdct affects+  -- any parent Pdct.+  , rNode :: RNode+  } deriving (Eq, Show)++data RNode+  = RAnd [Result]+  | ROr [Result]+  | RNot Result+  | ROperand Bool+  deriving (Eq, Show)++-- | Applies a Pdct to a particular value, known as the subject.+evaluate :: a -> Pdct a -> Result+evaluate a (Pdct l d n) = Result l r d' rn+  where+    rn = evaluateNode a n+    r = case rn of+      RAnd ls -> all rBool ls+      ROr ls -> any rBool ls+      RNot x -> Prelude.not . rBool $ x+      ROperand b -> b+    d' = d r++evaluateNode :: a -> Node a -> RNode+evaluateNode a n = case n of+  And ls -> RAnd (map (evaluate a) ls)+  Or ls -> ROr (map (evaluate a) ls)+  Not l -> RNot (evaluate a l)+  Operand f -> ROperand (f a)++-- # Types and functions for showing++-- | The number of spaces to use for each level of indentation.+type IndentAmt = Int++-- | 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++-- | 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 = fromString (replicate (lvl * amt) ' ')+    nl = fromString "\n"++-- # Showing Pdct++-- | Creates a plain Chunk from a Text.+plain :: Text -> R.Chunk+plain = R.Chunk mempty++-- | 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 [plain ("and - " <> l)]+            <> mconcat (map (showPdct amt (lvl + 1)) ls)+  Or ls -> indent amt lvl [plain ("or - " <> l)]+           <> mconcat (map (showPdct amt (lvl + 1)) ls)+  Not t -> indent amt lvl [plain ("not - " <> l)]+           <> showPdct amt (lvl + 1) t+  Operand _ -> indent amt lvl [plain ("operand - " <> l)]++instance Show (Pdct a) where+  show = X.unpack+       . X.concat+       . map R._text+       . showPdct 2 0+++filter :: Pdct a -> [a] -> [a]+filter pd as+  = map fst+  . Prelude.filter (rBool . snd)+  . zip as+  . map (flip evaluate pd)+  $ as+++-- # Showing Result++labelBool :: Text -> Bool -> [R.Chunk]+labelBool t b = [open, trueFalse, close, blank, txt]+  where+    trueFalse = +      if b then "TRUE" <> R.f_green else "FALSE" <> R.f_red+    open = "["+    close = "]"+    blank = plain (X.replicate blankLen " ")+    blankLen = X.length "discard"+               - X.length (R._text trueFalse) + 1+    txt = plain t++type ShowAll = Bool++-- | Shows a Result in a pretty way with colors and indentation.+showResult+  :: IndentAmt+  -- ^ Indent each level by this many spaces++  -> ShowAll+  -- ^ If True, shows all Pdct, even ones where 'rHide' is+  -- True. Otherwise, respects 'rHide' and does not show hidden Pdct.++  -> Level+  -- ^ How deep in the tree we are; this increments by one for each+  -- level of descent.++  -> Result+  -- ^ The result to show++  -> [R.Chunk]+showResult amt sa lvl (Result lbl rslt hd nd)+  | hd && Prelude.not sa = []+  | otherwise = firstLine ++ restLines+  where+    firstLine = indent amt lvl $ labelBool lbl rslt+    restLines = case nd of+      RAnd ls -> f False ls+      ROr ls -> f True ls+      RNot r -> showResult amt sa (lvl + 1) r+      ROperand _ -> []+    f stopOn ls = concatMap sr ls' ++ end+      where+        ls' = takeThrough ((== stopOn) . rBool) ls+        sr = showResult amt sa (lvl + 1)+        end = if ls' `shorter` ls+              then indent amt (lvl + 1) ["(short circuit)"]+              else []++-- | @shorter x y@ is True if list x is shorter than list y. Lazier+-- than taking the length of each list and comparing the results.+shorter :: [a] -> [a] -> Bool+shorter [] [] = False+shorter (_:_) [] = False+shorter [] (_:_) = True+shorter (_:xs) (_:ys) = shorter xs ys++-- | For instance,+-- > takeThrough odd [2,4,6,7,8] == [2,4,6,7]+takeThrough :: (a -> Bool) -> [a] -> [a]+takeThrough _ [] = []+takeThrough f (x:xs) = x : if f x then [] else takeThrough f xs++-- | Shows the top of a Result tree and all the child Results. Adds a+-- short label at the top of the tree.+showTopResult+  :: X.Text+  -- ^ Label to add to the top of the tree.+  -> IndentAmt+  -- ^ Indent each level by this many spaces+  -> Level+  -- ^ Indent the top by this many levels+  -> ShowAll+  -- ^ If True, shows all Pdct, even ones where 'rHide' is+  -- True. Otherwise, respects 'rHide' and does not show hidden Pdct.++  -> Result+  -- ^ The result to show+  -> [R.Chunk]+showTopResult txt i lvl sd r = showResult i sd lvl r'+  where+    r' = r { rLabel = rLabel r <> " - " <> txt }+++-- | Filters a list. Also returns chunks describing the process.+verboseFilter+  :: (a -> X.Text)+  -- ^ How to describe each subject++  -> IndentAmt+  -- ^ Indent each level by this many spaces++  -> ShowAll+  -- ^ If True, shows all Pdct, even ones where 'rHide' is+  -- True. Otherwise, respects 'rHide' and does not show hidden Pdct.++  -> Pdct a+  -- ^ Used to perform the filtering++  -> [a]+  -> ([R.Chunk], [a])++verboseFilter desc amt sa pd as = (chks, as')+  where+    rs = map (flip evaluate pd) as+    subjAndRslts = zip as rs+    mkChks (subj, rslt) = showTopResult (desc subj) amt 0 sa rslt+    chks = concatMap mkChks subjAndRslts+    as' = map fst . Prelude.filter (rBool . snd) $ subjAndRslts++-- # Comparisons++-- | Build a Pdct that compares items.+compareBy+  :: Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> Text+  -- ^ Description of the type of thing that is being matched++  -> (a -> Ordering)+  -- ^ How to compare an item against the right hand side. Return LT+  -- if the item is less than the right hand side; GT if greater; EQ+  -- if equal to the right hand side.++  -> Ordering+  -- ^ When subjects are compared, this ordering must be the result in+  -- order for the Pdct to be True; otherwise it is False. The subject+  -- will be on the left hand side.++  -> Pdct a++compareBy itemDesc typeDesc cmp ord = Pdct l (const False) (Operand f)+  where+    l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc+    cmpDesc = case ord of+      LT -> "less than"+      GT -> "greater than"+      EQ -> "equal to"+    f subj = cmp subj == ord++-- | Overloaded version of 'compareBy'.+compare+  :: (Show a, Ord a)+  => Text+  -- ^ Description of the type of thing being matched++  -> a+  -- ^ The right hand side of the comparison.++  -> Ordering+  -- ^ When subjects are compared, this ordering must be the result in+  -- order for the Pdct to be True; otherwise it is False. The subject+  -- will be on the left hand side.++  -> Pdct a+compare typeDesc a ord = compareBy itemDesc typeDesc cmp ord+  where+    itemDesc = X.pack . Prelude.show $ a+    cmp item = Prelude.compare item a++-- | Builds a Pdct for items that might fail to return a comparison.+compareByMaybe+  :: Text+  -- ^ How to show the item being compared++  -> Text+  -- ^ Description of type of thing being matched++  -> (a -> Maybe Ordering)+  -- ^ How to compare against right hand side. If Nothing, a Pdct that+  -- always returns False is returned.++  -> Ordering+  -- ^ Ordering that must result for the Pdct to be True++  -> Pdct a++compareByMaybe itemDesc typeDesc cmp ord =+  Pdct l (const False) (Operand f)+  where+    l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc+    cmpDesc = case ord of+      LT -> "less than"+      GT -> "greater than"+      EQ -> "equal to"+    f subj = case cmp subj of+      Nothing -> False+      Just ord' -> ord == ord'++greater+  :: (Show a, Ord a)+  => Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> a+  -- ^ The right hand side of the comparison.++  -> Pdct a+greater d a = compare d a GT++less+  :: (Show a, Ord a)+  => Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> a+  -- ^ The right hand side of the comparison.++  -> Pdct a+less d a = compare d a LT++equal+  :: (Show a, Ord a)+  => Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> a+  -- ^ The right hand side of the comparison.++  -> Pdct a+equal d a = compare d a EQ++greaterEq+  :: (Show a, Ord a)+  => Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> a+  -- ^ The right hand side of the comparison.++  -> Pdct a+greaterEq d a = greater d a ||| equal d a++lessEq+  :: (Show a, Ord a)+  => Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> a+  -- ^ The right hand side of the comparison.++  -> Pdct a+lessEq d a = less d a ||| equal d a++notEq+  :: (Show a, Ord a)+  => Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> a+  -- ^ The right hand side of the comparison.++  -> Pdct a+notEq d a = not $ equal d a++greaterBy+  :: Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> Text+  -- ^ Description of the type of thing that is being matched++  -> (a -> Ordering)+  -- ^ How to compare two items++  -> Pdct a+greaterBy iD tD cmp = compareBy iD tD cmp GT++lessBy+  :: Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> Text+  -- ^ Description of the type of thing that is being matched++  -> (a -> Ordering)+  -- ^ How to compare two items++  -> Pdct a+lessBy iD tD cmp = compareBy iD tD cmp LT++equalBy+  :: Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> Text+  -- ^ Description of the type of thing that is being matched++  -> (a -> Ordering)+  -- ^ How to compare two items++  -> Pdct a+equalBy iD tD cmp = compareBy iD tD cmp EQ++greaterEqBy+  :: Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> Text+  -- ^ Description of the type of thing that is being matched++  -> (a -> Ordering)+  -- ^ How to compare two items++  -> Pdct a+greaterEqBy iD tD cmp =+  greaterBy iD tD cmp ||| equalBy iD tD cmp++lessEqBy+  :: Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> Text+  -- ^ Description of the type of thing that is being matched++  -> (a -> Ordering)+  -- ^ How to compare two items++  -> Pdct a+lessEqBy iD tD cmp =+  lessBy iD tD cmp ||| equalBy iD tD cmp++notEqBy+  :: Text+  -- ^ How to show the item being compared; used to describe the Pdct++  -> Text+  -- ^ Description of the type of thing that is being matched++  -> (a -> Ordering)+  -- ^ How to compare two items++  -> Pdct a+notEqBy iD tD cmp =+  not $ equalBy iD tD cmp++-- | Parses a string to find the correct comparer; returns the correct+-- function to build a Pdct.++parseComparer+  :: Text+  -- ^ The string with the comparer to be parsed+  -> (Ordering -> Pdct a)+  -- ^ A function that, when given an ordering, returns a Pdct+  -> Maybe (Pdct a)+  -- ^ If an invalid comparer string is given, Nothing; otherwise, the+  -- Pdct.+parseComparer t f+  | t == ">" = Just (f GT)+  | t == "<" = Just (f LT)+  | t == "=" = Just (f EQ)+  | t == "==" = Just (f EQ)+  | t == ">=" = Just (f GT ||| f EQ)+  | t == "<=" = Just (f LT ||| f EQ)+  | t == "/=" = Just (not $ f EQ)+  | t == "!=" = Just (not $ f EQ)+  | otherwise = Nothing+
+ lib/Data/Prednote/Test.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Helps you build tests that run against a series of items.+module Data.Prednote.Test+  (+  -- * Test data types+    Name+  , Verbosity(..)+  , TrueVerbosity+  , FalseVerbosity+  , ShowTest(..)+  , TestVerbosity(..)+  , Pass+  , Test(..)+  , TestResult(..)++  -- * Pre-built tests+  , eachSubjectMustBeTrue+  , nSubjectsMustBeTrue++  -- * Running and showing tests+  , evalTest+  , showResult++  ) where++import Data.Maybe (fromMaybe)+import Data.Monoid ((<>), mempty)+import qualified Data.Text as X+import Data.Text (Text)++import qualified System.Console.Rainbow as R+import qualified Data.Prednote.Pdct as Pt++-- # Types++-- | How verbose to be when showing the results of running a Pdct on a+-- single subject.+data Verbosity+  = HideAll+  -- ^ Do not show any results from the Pdct++  | ShowDefaults+  -- ^ Show results according to the default settings provided in the+  -- Result itself++  | ShowAll+  -- ^ Show all Result+  deriving (Eq, Show)++-- | Use this verbosity for subjects that are True+type TrueVerbosity = Verbosity++-- | Use this verbosity for subjects that are False+type FalseVerbosity = Verbosity++-- | Determines whether to show any of the results from a single test.+data ShowTest+  = HideTest+  -- ^ Do not show any results from this test++  | ShowFirstLine TrueVerbosity FalseVerbosity+  -- ^ Show the first line, which indicates whether the test passed or+  -- failed and gives the label for the test. Whether to show+  -- individual subjects is determined by the TrueVerbosity and+  -- FalseVerbosity.++  deriving (Eq, Show)++-- | Determines which ShowTest to use for a particular test.+data TestVerbosity = TestVerbosity+  { onPass :: ShowTest+    -- ^ Use this ShowTest when the test passes+  , onFail :: ShowTest+    -- ^ Use this ShowTest when the test fails+  } deriving (Eq, Show)++type Pass = Bool++-- | The name of a test or of a group.+type Name = Text++-- | A single test.+data Test a = Test+  { testName :: Name+  , testPass :: [Pt.Result] -> Pass+  -- ^ Applied to the results of all applications of testFunc;+  -- determines whether the test passes or fails.++  , testFunc :: a -> Pt.Result+  -- ^ This function is applied to each subject.++  , testVerbosity :: TestVerbosity+  -- ^ Default verbosity for the test.+  }++data TestResult a = TestResult+  { resultName :: Name+  , resultPass :: Pass+  , resultSubjects :: [(a, Pt.Result)]+  , resultDefaultVerbosity :: TestVerbosity+  }++-- # Showing tests++-- | Creates a plain Chunk from a Text.+plain :: X.Text -> R.Chunk+plain = R.Chunk mempty++showTestTitle :: Name -> Pass -> [R.Chunk]+showTestTitle n p = [open, passFail, close, blank, txt, nl]+  where+    nl = plain "\n"+    passFail =+      if p+      then "PASS" <> R.f_green+      else "FAIL" <> R.f_red+    open = plain "["+    close = plain "]"+    blank = plain (X.singleton ' ')+    txt = plain n++-- | Evaluates a test for a given list of subjects.+evalTest :: Test a -> [a] -> TestResult a+evalTest (Test n fPass fSubj vy) ls = TestResult n p ss vy+  where+    p = fPass results+    results = map fSubj ls+    ss = zip ls results++-- | Shows a result with indenting.+showResult+  :: Pt.IndentAmt+  -- ^ Indent each level by this many spaces++  -> (a -> Text)+  -- ^ Shows each subject. The function should return a single-line+  -- text without a trailing newline.++  -> Maybe TestVerbosity+  -- ^ If Just, use this TestVerbosity when showing the test. If+  -- Nothing, use the default verbosity.++  -> TestResult a+  -- ^ The result to show++  -> [R.Chunk]+showResult amt swr mayVb (TestResult n p ss dfltVb) =+  let vb = fromMaybe dfltVb mayVb+      tv = if p then onPass vb else onFail vb+      firstLine = showTestTitle n p+  in case tv of+      HideTest -> []+      ShowFirstLine trueV falseV ->+        firstLine+        ++ concatMap (showSubject p amt swr (trueV, falseV)) ss++showSubject+  :: Pass+  -> Pt.IndentAmt+  -> (a -> Text)+  -> (TrueVerbosity, FalseVerbosity)+  -> (a, Pt.Result)+  -> [R.Chunk]+showSubject p amt swr (tv, fv) (a, r) =+  let txt = swr a+      vb = if p then tv else fv+  in case vb of+      HideAll -> []+      ShowDefaults -> Pt.showTopResult txt amt 1 False r+      ShowAll -> Pt.showTopResult txt amt 1 True r++-- # Pre-built tests++-- | The test passes if each subject returns True.+eachSubjectMustBeTrue :: Pt.Pdct a -> Name -> Test a+eachSubjectMustBeTrue pd nm = Test nm pass f vy+  where+    vy = TestVerbosity+      { onPass = ShowFirstLine HideAll HideAll+      , onFail = ShowFirstLine HideAll ShowDefaults }+    pass = all Pt.rBool+    f = flip Pt.evaluate pd+++-- | The test passes if at least a given number of subjects are True.+nSubjectsMustBeTrue+  :: Pt.Pdct a+  -> Name+  -> Int+  -- ^ The number of subjects that must be True. This should be a+  -- positive number.+  -> Test a+nSubjectsMustBeTrue pd nm i = Test nm pass f vy+  where+    pass = atLeast i . filter Pt.rBool+    f = flip Pt.evaluate pd+    vy = TestVerbosity+      { onPass = ShowFirstLine HideAll HideAll+      , onFail = ShowFirstLine HideAll HideAll }+++-- # Basement++-- | Returns True if the list has at least this many elements. Lazier+-- than taking the length of the list.+atLeast :: Int -> [a] -> Bool+atLeast i as+  | i < 0 = error "atLeast: negative length parameter"+  | otherwise = go 0 as+  where+    go _ [] = i == 0+    go soFar (_:xs) =+      let nFound = soFar + 1+      in if nFound == i then True else go nFound xs+
+ prednote-test.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE TemplateHaskell #-}+module Main where++import Control.Applicative+import qualified Test.QuickCheck as Q+import Test.QuickCheck.All (quickCheckAll)+import Test.QuickCheck.Function+import Test.QuickCheck (Arbitrary, Gen, arbitrary)+import qualified Data.Prednote.Pdct as P+import Data.Prednote.Pdct ((&&&), (|||))+import qualified Data.Text as X+import qualified System.Exit as Exit++instance Arbitrary X.Text where+  arbitrary = fmap X.pack (Q.listOf (Q.choose ('!', '~')))++instance Q.CoArbitrary a => Arbitrary (P.Pdct a) where+  arbitrary = P.Pdct <$> arbitrary <*> arbitrary <*> arbitrary++instance Q.CoArbitrary a => Arbitrary (P.Node a) where+  arbitrary = Q.sized tree+    where+      tree 0 = fmap P.Operand arbitrary+      tree n = Q.oneof+        [ fmap P.And (Q.listOf subtree)+        , fmap P.Or (Q.listOf subtree)+        , fmap P.Not subtree ]+        where+          subtree = P.Pdct <$> arbitrary <*> arbitrary+                    <*> tree (n `div` 2)++-- | And is commutative+prop_andCommutative :: a -> P.Pdct a -> P.Pdct a -> Bool+prop_andCommutative a p1 p2 = P.rBool r1 == P.rBool r2+  where+    r1 = P.evaluate a (p1 &&& p2)+    r2 = P.evaluate a (p2 &&& p1)++-- | And is associative+prop_andAssociative :: a -> P.Pdct a -> P.Pdct a -> P.Pdct a -> Bool+prop_andAssociative a p1 p2 p3 = P.rBool r1 == P.rBool r2+  where+    r1 = P.evaluate a (p1 &&& (p2 &&& p3))+    r2 = P.evaluate a ((p1 &&& p2) &&& p3)+    +-- | Or is commutative+prop_orCommutative :: a -> P.Pdct a -> P.Pdct a -> Bool+prop_orCommutative a p1 p2 = P.rBool r1 == P.rBool r2+  where+    r1 = P.evaluate a (p1 ||| p2)+    r2 = P.evaluate a (p2 ||| p1)++-- | Or is associative+prop_orAssociative :: a -> P.Pdct a -> P.Pdct a -> P.Pdct a -> Bool+prop_orAssociative a p1 p2 p3 = P.rBool r1 == P.rBool r2+  where+    r1 = P.evaluate a (p1 ||| (p2 ||| p3))+    r2 = P.evaluate a ((p1 ||| p2) ||| p3)++-- | Anything or'd with True is True+prop_orWithTrue :: a -> P.Pdct a -> Bool+prop_orWithTrue a p1 = P.rBool r1+  where+    r1 = P.evaluate a (p1 ||| P.always)++-- | Anything and'ed with False is False+prop_andWithFalse :: a -> P.Pdct a -> Bool+prop_andWithFalse a p1 = not $ P.rBool r1+  where+    r1 = P.evaluate a (p1 &&& P.never)++-- | And Distributitivy+prop_andDistributivity :: a -> P.Pdct a -> P.Pdct a -> P.Pdct a -> Bool+prop_andDistributivity x a b c = P.rBool r1 == P.rBool r2+  where+    r1 = P.evaluate x $ a &&& (b ||| c)+    r2 = P.evaluate x $ (a &&& b) ||| (a &&& c)++prop_orDistributivity :: a -> P.Pdct a -> P.Pdct a -> P.Pdct a -> Bool+prop_orDistributivity x a b c = P.rBool r1 == P.rBool r2+  where+    r1 = P.evaluate x $ a ||| (b &&& c)+    r2 = P.evaluate x $ (a ||| b) &&& (a ||| c)++runTests = $quickCheckAll++main :: IO ()+main = do+  b <- runTests+  if b then Exit.exitSuccess else Exit.exitFailure
prednote.cabal view
@@ -1,5 +1,5 @@ name:                prednote-version:             0.10.0.0+version:             0.12.0.0 synopsis:            Build and evaluate trees of predicates description:   Build and evaluate trees of predicates. For example, you might build@@ -32,7 +32,7 @@     , Data.Prednote.Expressions     , Data.Prednote.Expressions.Infix     , Data.Prednote.Expressions.RPN-    , Data.Prednote.TestTree+    , Data.Prednote.Test    build-depends:       base >= 4.6 && < 5@@ -42,3 +42,22 @@     , text == 0.11.*    ghc-options: -Wall+  hs-source-dirs: lib++executable prednote-test+  main-is: prednote-test.hs+  hs-source-dirs: . lib+  if ! flag(test)+    buildable: False++  build-depends:+      base >= 4.6 && < 5+    , QuickCheck ==2.6.*+    , text ==0.11.*+    , explicit-exception ==0.1.*+    , rainbow ==0.4.*+    , split ==0.2.*++flag test+    Description: enables QuickCheck tests+    default: False