packages feed

prednote 0.6.0.0 → 0.36.0.4

raw patch · 22 files changed

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.chunkText-           . concatMap (P.showPdct 4 0)-           $ xs )-
− Data/Prednote/Pdct.hs 
@@ -1,609 +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-  , greaterBy-  , lessBy-  , equalBy-  , greaterEqBy-  , lessEqBy-  , notEqBy-  , parseComparerBy--  -- ** 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 qualified System.Console.Rainbow as R-import System.Console.Rainbow ((+.+))-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 _ = "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)---- | 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---- | Overloaded version of 'compareBy'.-compare-  :: (Show a, Ord a)-  => Text-  -- ^ Description of the type of thing being matched--  -> 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.--  -> a-  -- ^ The right hand side of the comparison.--  -> Pdct a-compare typeDesc ord a = 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 = compare d 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 = compare d 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 = compare d 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 = not . equal d--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.-parseComparerBy-  :: Text-  -- ^ The string with the comparer to be parsed-  -> Maybe (Text -> Text -> (a -> Ordering) -> Pdct a)-parseComparerBy t-  | t == ">" = Just greaterBy-  | t == "<" = Just lessBy-  | t == "=" = Just equalBy-  | t == "==" = Just equalBy-  | t == ">=" = Just greaterEqBy-  | t == "<=" = Just lessEqBy-  | t == "/=" = Just notEqBy-  | t == "!=" = Just notEqBy-  | otherwise = Nothing---- | Parses a string to find the correct comparer; returns the correct--- function to build a Pdct.-parseComparer-  :: (Show a, Ord a)-  => Text-  -- ^ The string with the comparer to be parsed-  -> Maybe (Text -> a -> Pdct a)-parseComparer t-  | t == ">" = Just greater-  | t == "<" = Just less-  | t == "=" = Just equal-  | t == "==" = Just equal-  | t == ">=" = Just greaterEq-  | t == "<=" = Just lessEq-  | t == "/=" = Just notEq-  | t == "!=" = Just notEq-  | otherwise = Nothing
− Data/Prednote/TestTree.hs 
@@ -1,461 +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 ((<>))-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
@@ -1,4 +1,4 @@-Copyright (c) 2013, Omari Norman+Copyright (c) 2013-2015, Omari Norman  All rights reserved.
+ README.md view
@@ -0,0 +1,43 @@+# prednote++prednote helps you build a tree of predicates that you can apply to+a list of items.  It was written for Penny:++http://www.github.com/massysett/penny++but I also find it useful for dapi:++http://www.github.com/massysett/dapi++and so you might find it useful too.++prednote is on Github:++http://www.github.com/massysett/prednote++and Hackage:++http://hackage.haskell.org/package/prednote++## Test results++You can view the results of building and testing on Travis by clicking+the button below:++[![Build Status](https://travis-ci.org/massysett/prednote.svg?branch=master)](https://travis-ci.org/massysett/prednote)++If you have trouble building prednote due to dependency issues, try+looking at the previous test results, as they will show you package+versions that were used to build prednote successfully.++## Something similar++See also rematch:++http://hackage.haskell.org/package/rematch++which is apparently based on a Java library called hamcrest.++## License++prednote is licensed under the BSD license; see the LICENSE file.
+ changelog view
@@ -0,0 +1,25 @@+0.28.0.2++  * Documentation fixes.++0.28.0.0+  * Completely new API and internals; is simpler and allows+    for predicates on sum types.++0.24.0.4++  * Dependency bumps.++0.24.0.2++  * added wrap function.++0.24.0.0++  * complete change in API and internals.++0.22.0.2++  * updates for new Rainbow API++  * test with GHC 7.8.2
+ genCabal.hs view
@@ -0,0 +1,172 @@+-- Generates the Cabal file for prednote.+-- Written to use version 0.14.2.0 of the Cartel+-- library.++module Main where++import Cartel+import Control.Applicative++atLeast :: NonEmptyString -> [Word] -> Package+atLeast name ver = package name (gtEq ver)++versionInts :: [Word]+versionInts = [0,36,0,4]++base :: Package+base = closedOpen "base" [4,7] [5]++rainbow :: Package+rainbow = atLeast "rainbow" [0,26]++text :: Package+text = atLeast "text" [0,11,2,0]++containers :: Package+containers = atLeast "containers" [0,4,2,1]++quickcheck :: Package+quickcheck = atLeast "QuickCheck" [2,7]++tasty :: Package+tasty = atLeast "tasty" [0,10]++tastyQuickcheck :: Package+tastyQuickcheck = atLeast "tasty-quickcheck" [0,8]++tastyTh :: Package+tastyTh = atLeast "tasty-th" [0,1]++bytestring :: Package+bytestring = atLeast "bytestring" [0,10]++properties :: Properties+properties = blank+  { name = "prednote"+  , version = versionInts+  , cabalVersion = Just (1,18)+  , buildType = Just simple+  , license = Just bsd3+  , licenseFile = "LICENSE"+  , copyright = "Copyright 2013-2015 Omari Norman"+  , author = "Omari Norman"+  , maintainer = "omari@smileystation.com"+  , stability = "Experimental"+  , homepage = "http://www.github.com/massysett/prednote"+  , bugReports = "http://www.github.com/massysett/prednote/issues"+  , category = "Data"+  , synopsis = "Evaluate and display 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."+    ]+  , extraSourceFiles =+    [ "README.md"+    , "changelog"+    , "genCabal.hs"+    ]++  }++ghcOpts :: [String]+ghcOpts = ["-Wall"]++-- Dependencies++split :: Package+split = atLeast "split" [0,2,2]++contravariant :: Package+contravariant = atLeast "contravariant" [1,2]++transformers :: Package+transformers = atLeast "transformers" [0,3,0,0]++libDepends :: [Package]+libDepends =+  [ base+  , rainbow+  , split+  , text+  , containers+  , contravariant+  , transformers+  , bytestring+  ]++library+  :: [String]+  -- ^ Library modules+  -> [LibraryField]+library ms =+  [ exposedModules ms+  , buildDepends libDepends+  , hsSourceDirs ["lib"]+  , ghcOptions ghcOpts+  , haskell2010+  ]++tests+  :: FlagName+  -- ^ Visual-tests flag+  -> [String]+  -- ^ Library modules+  -> [String]+  -- ^ Test modules+  -> (Section, Section)+  -- ^ The prednote-tests test suite, and the prednote-visual-tests+  -- executable+tests fl ls ts =+  ( testSuite "prednote-tests" $+    commonTestOpts ls ts +++    [ mainIs "prednote-tests.hs"+    , exitcodeStdio+    ]+  , testSuite "prednote-visual-tests" $+    [ mainIs "prednote-visual-tests.hs"+    , exitcodeStdio+    ] ++ commonTestOpts ls ts+  )++commonTestOpts+  :: HasBuildInfo a+  => [String]+  -- ^ Library modules+  -> [String]+  -- ^ Test modules+  -> [a]+commonTestOpts ls ts =+  [ hsSourceDirs ["lib", "tests"]+  , otherModules (ls ++ ts)+  , ghcOptions ghcOpts+  , haskell2010+  , otherExtensions ["TemplateHaskell"]+  , buildDepends+    $ tasty : tastyQuickcheck : tastyTh : quickcheck : libDepends+  ]++visualTests :: Applicative m => Betsy m FlagName+visualTests = makeFlag "visual-tests" $ FlagOpts+  { flagDescription = "Build the prednote-visual-tests executable"+  , flagDefault = False+  , flagManual = True+  }++github :: Section+github = githubHead "massysett" "prednote"++main :: IO ()+main = defaultMain $ do+  fl <- visualTests+  libMods <- modules "lib"+  testMods <- modules "tests"+  let (tsts, vis) = tests fl libMods testMods+      lib = library libMods+      repo = githubHead "massysett" "prednote"+  return (properties, lib, [tsts, vis, github])
+ lib/Prednote.hs view
@@ -0,0 +1,22 @@+-- | Prednote - annotated predicates+--+-- This module exports all the types and functions you will ordinarily+-- need.  Many names clash with Prelude names, because these names+-- made the most sense.  But I didn't make any clashing operators, as+-- I'm not that much of a masochist.  So you will probably want to do+-- something like+--+-- > import qualified Prednote as P+-- > import Prednote ((|||), (&&&))+--+-- For more documentation, first see "Prednote.Core", and then+-- "Prednote.Comparisons" and then "Prednote.Expressions".+module Prednote+  ( module Prednote.Comparisons+  , module Prednote.Expressions+  , module Prednote.Core+  ) where++import Prednote.Comparisons+import Prednote.Expressions+import Prednote.Core
+ lib/Prednote/Comparisons.hs view
@@ -0,0 +1,425 @@+{-# LANGUAGE OverloadedStrings #-}+module Prednote.Comparisons+  ( -- * Comparisions that do not run in a context+    compareBy+  , compare+  , equalBy+  , equal+  , compareByMaybe+  , greater+  , less+  , greaterEq+  , lessEq+  , notEq+  , greaterBy+  , lessBy+  , greaterEqBy+  , lessEqBy+  , notEqBy++  -- * Comparisions that run in a context+  , compareByM+  , equalByM+  , compareByMaybeM+  , greaterByM+  , lessByM+  , greaterEqByM+  , lessEqByM+  , notEqByM++  -- * Parsing comparers+  , parseComparer+  ) where++import Prednote.Core+import Prelude hiding (compare, not)+import qualified Prelude+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as X+import Rainbow++-- | Build a Pred that compares items.  The idea is that the item on+-- the right hand side is baked into the 'Pred' and that the 'Pred'+-- compares this single right-hand side to each left-hand side item.+compareByM+  :: (Show a, Functor f)+  => Text+  -- ^ Description of the right-hand side++  -> (a -> f Ordering)+  -- ^ How to compare the left-hand side to 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 Predbox to be True; otherwise it is False. The subject+  -- will be on the left hand side.++  -> PredM f a++compareByM rhsDesc get tgt = predicateM f+  where+    f a = fmap mkTup (get a)+      where+        mkTup ord = (bl, val, cond)+          where+            val = Value [chunk . X.pack . show $ a]+            cond = Condition [chunk condTxt]+            condTxt = "is" <+> ordDesc <+> rhsDesc+            ordDesc = case ord of+              EQ -> "equal to"+              LT -> "less than"+              GT -> "greater than"+            bl = ord == tgt++-- | Build a Pred that compares items.  The idea is that the item on+-- the right hand side is baked into the 'Pred' and that the 'Pred'+-- compares this single right-hand side to each left-hand side item.+compareBy+  :: Show a+  => Text+  -- ^ Description of the right-hand side++  -> (a -> Ordering)+  -- ^ How to compare the left-hand side to 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 Predbox to be True; otherwise it is False. The subject+  -- will be on the left hand side.++  -> Pred a++compareBy rhsDesc get ord = compareByM rhsDesc (fmap return get) ord++-- | Overloaded version of 'compareBy'.++compare+  :: (Show a, Ord a)+  => a+  -- ^ Right-hand side++  -> Ordering+  -- ^ When subjects are compared, this ordering must be the result in+  -- order for the Predbox to be True; otherwise it is False. The subject+  -- will be on the left hand side.++  -> Pred a+compare rhs ord =+  compareBy (X.pack . show $ rhs) (`Prelude.compare` rhs) ord++-- | Builds a 'Pred' that tests items for equality.++equalByM+  :: (Show a, Functor f)++  => Text+  -- ^ Description of the right-hand side++  -> (a -> f Bool)+  -- ^ How to compare an item against the right hand side.  Return+  -- 'True' if the items are equal; 'False' otherwise.++  -> PredM f a+equalByM rhsDesc get = predicateM f+  where+    f a = fmap mkTup (get a)+      where+        mkTup bl = (bl, Value [chunk . X.pack . show $ a],+          Condition [chunk $ "is equal to" <+> rhsDesc])++-- | Builds a 'Pred' that tests items for equality.++equalBy+  :: Show a++  => Text+  -- ^ Description of the right-hand side++  -> (a -> Bool)+  -- ^ How to compare an item against the right hand side.  Return+  -- 'True' if the items are equal; 'False' otherwise.++  -> Pred a+equalBy rhsDesc f = equalByM rhsDesc (fmap return f)++-- | Overloaded version of 'equalBy'.++equal+  :: (Eq a, Show a)+  => a+  -- ^ Right-hand side++  -> Pred a+equal rhs = equalBy (X.pack . show $ rhs) (== rhs)+++-- | Builds a 'Pred' for items that might fail to return a comparison.+compareByMaybeM+  :: (Functor f, Show a)+  => Text+  -- ^ Description of the right-hand side++  -> (a -> f (Maybe 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 Predbox to be True; otherwise it is False. The subject+  -- will be on the left hand side.++  -> PredM f a++compareByMaybeM rhsDesc get ord = predicateM f+  where+    f a = fmap mkTup (get a)+      where+        mkTup mayOrd = (bl, val, cond)+          where+            val = Value [chunk . X.pack . show $ a]+            cond = Condition [chunk $ "is" <+> ordDesc <+> rhsDesc]+            ordDesc = case ord of+              EQ -> "equal to"+              LT -> "less than"+              GT -> "greater than"+            bl = case mayOrd of+              Nothing -> False+              Just o -> o == ord+++-- | Builds a 'Pred' for items that might fail to return a comparison.+compareByMaybe+  :: Show a+  => Text+  -- ^ Description of the right-hand side++  -> (a -> Maybe 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 Predbox to be True; otherwise it is False. The subject+  -- will be on the left hand side.++  -> Pred a++compareByMaybe rhsDesc get ord = compareByMaybeM rhsDesc (fmap return get) ord++greater+  :: (Show a, Ord a)++  => a+  -- ^ Right-hand side++  -> Pred a+greater rhs = compare rhs GT++less+  :: (Show a, Ord a)++  => a+  -- ^ Right-hand side++  -> Pred a+less rhs = compare rhs LT++greaterEq+  :: (Show a, Ord a)+  => a+  -- ^ Right-hand side++  -> Pred a+greaterEq r = greater r ||| equal r++lessEq+  :: (Show a, Ord a)+  => a+  -- ^ Right-hand side++  -> Pred a+lessEq r = less r ||| equal r++notEq+  :: (Show a, Eq a)+  => a+  -- ^ Right-hand side++  -> Pred a+notEq = not . equal++greaterByM+  :: (Show a, Functor f)+  => Text+  -- ^ Description of right-hand side++  -> (a -> f 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.++  -> PredM f a+greaterByM desc get = compareByM desc get GT++greaterBy+  :: Show a+  => Text+  -- ^ Description of right-hand side++  -> (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.++  -> Pred a+greaterBy desc get = greaterByM desc (fmap return get)+++lessByM+  :: (Show a, Functor f)+  => Text+  -- ^ Description of right-hand side++  -> (a -> f 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.++  -> PredM f a+lessByM desc get = compareByM desc get LT++lessBy+  :: Show a+  => Text+  -- ^ Description of right-hand side++  -> (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.++  -> Pred a+lessBy desc get = lessByM desc (fmap return get)++greaterEqByM+  :: (Functor f, Monad f, Show a)+  => Text+  -- ^ Description of right-hand side++  -> (a -> f 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.++  -> PredM f a+greaterEqByM desc get = greaterByM desc get ||| equalByM desc f'+  where+    f' = fmap (fmap (== EQ)) get++greaterEqBy+  :: Show a+  => Text+  -- ^ Description of right-hand side++  -> (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.++  -> Pred a+greaterEqBy desc get = greaterEqByM desc (fmap return get)++lessEqByM+  :: (Functor f, Monad f, Show a)+  => Text+  -- ^ Description of right-hand side++  -> (a -> f 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.++  -> PredM f a+lessEqByM desc get = lessByM desc get ||| equalByM desc f'+  where+    f' = fmap (fmap (== EQ)) get++lessEqBy+  :: Show a+  => Text+  -- ^ Description of right-hand side++  -> (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.++  -> Pred a+lessEqBy desc get = lessEqByM desc (fmap return get)++notEqByM+  :: (Functor f, Show a)+  => Text+  -- ^ Description of right-hand side++  -> (a -> f Bool)+  -- ^ How to compare an item against the right hand side.  Return+  -- 'True' if equal; 'False' otherwise.++  -> PredM f a+notEqByM desc = not . equalByM desc++notEqBy+  :: Show a+  => Text+  -- ^ Description of right-hand side++  -> (a -> Bool)+  -- ^ How to compare an item against the right hand side.  Return+  -- 'True' if equal; 'False' otherwise.++  -> Pred a+notEqBy desc f = notEqByM desc (fmap return f)++-- | Parses a string that contains text, such as @>=@, which indicates+-- which comparer to use.  Returns the comparer.+parseComparer+  :: (Monad f, Functor f)+  => Text+  -- ^ The string with the comparer to be parsed++  -> (Ordering -> PredM f a)+  -- ^ A function that, when given an ordering, returns a 'Pred'.+  -- Typically you will get this by partial application of 'compare',+  -- 'compareBy', or 'compareByMaybe'.++  -> Maybe (PredM f a)+  -- ^ If an invalid comparer string is given, Nothing; otherwise, the+  -- 'Pred'.+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++-- | Append two 'X.Text', with an intervening space if both 'X.Text'+-- are not empty.+(<+>) :: Text -> Text -> Text+l <+> r+  | full l && full r = l <> " " <> r+  | otherwise = l <> r+  where+    full = Prelude.not . X.null+
+ lib/Prednote/Core.hs view
@@ -0,0 +1,496 @@+{-# LANGUAGE OverloadedStrings #-}+module Prednote.Core+  ( -- * Predicates and their creation+    PredM(..)+  , Pred+  , predicate+  , predicateM+  , contramapM++  -- * Predicate combinators+  -- ** Primitive combinators+  --+  -- | You might consider these combinators to be \"primitive\" in the+  -- sense that you can build a 'Pred' for any user-defined type by+  -- using these combinators alone, along with 'contramap'.  Use+  -- '&&&', '|||', and 'contramap' to analyze product types.  Use 'switch'+  -- and 'contramap' to analyze sum types.  For a simple example, see the+  -- source code for 'maybe', which is a simple sum type.  For more+  -- complicated examples, see the source code for 'any' and 'all', as+  -- a list is a sum type where one of the summands is a (recursive!)+  -- product type.+  , (&&&)+  , (|||)+  , not+  , switch++  -- ** Convenience combinators+  --+  -- | These were written using entirely the \"primitive\" combinators+  -- given above.+  , any+  , all+  , maybe++  -- * Labeling+  , addLabel++  -- * Constant predicates+  , true+  , false+  , same++  -- * Evaluating predicates+  , test+  , testM+  , runPred+  , verboseTest+  , verboseTestStdout++  -- * Results and converting them to 'Chunk's+  --+  -- | Usually you will not need these functions and types, as the+  -- functions and types above should meet most use cases; however,+  -- these are here so the test suites can use them, and in case you+  -- need them.+  , Condition(..)+  , Value(..)+  , Label(..)+  , Labeled(..)+  , Passed(..)+  , Failed(..)+  , Result(..)+  , splitResult+  , resultToChunks+  , passedToChunks+  , failedToChunks+  ) where++import Rainbow+import Rainbow.Types (_yarn)+import Data.Monoid+import Data.Functor.Contravariant+import Prelude hiding (all, any, maybe, and, or, not)+import qualified Prelude+import Data.Text (Text)+import qualified Data.Text as X+import Data.List (intersperse)+import Data.Functor.Identity+import Control.Applicative+import qualified Data.ByteString as BS++-- | Like 'contramap' but allows the mapping function to run in a+-- monad.+contramapM+  :: Monad m+  => (a -> m b)+  -> PredM m b+  -> PredM m a+contramapM conv (PredM f) = PredM $ \a -> conv a >>= f++-- | Describes the condition; for example, for a @'Pred' 'Int'@,+-- this might be @is greater than 5@; for a @'Pred' 'String'@, this+-- might be @begins with \"Hello\"@.+newtype Condition = Condition [Chunk Text]+  deriving (Eq, Ord, Show)++instance Monoid Condition where+  mempty = Condition []+  mappend (Condition x) (Condition y) = Condition (x ++ y)++-- | Stores the representation of a value.+newtype Value = Value [Chunk Text]+  deriving (Eq, Ord, Show)++instance Monoid Value where+  mempty = Value []+  mappend (Value x) (Value y) = Value (x ++ y)++-- | Gives additional information about a particular 'Pred' to aid the+-- user when viewing the output.+newtype Label = Label [Chunk Text]+  deriving (Eq, Ord, Show)++instance Monoid Label where+  mempty = Label []+  mappend (Label x) (Label y) = Label (x ++ y)++-- | Any type that is accompanied by a set of labels.+data Labeled a = Labeled [Label] a+  deriving (Eq, Ord, Show)++instance Functor Labeled where+  fmap f (Labeled l a) = Labeled l (f a)++-- | A 'Pred' that returned 'True'+data Passed+  = PTerminal Value Condition+  -- ^ A 'Pred' created with 'predicate'+  | PAnd (Labeled Passed) (Labeled Passed)+  -- ^ A 'Pred' created with '&&&'+  | POr (Either (Labeled Passed) (Labeled Failed, Labeled Passed))+  -- ^ A 'Pred' created with '|||'+  | PNot (Labeled Failed)+  -- ^ A 'Pred' created with 'not'+  deriving (Eq, Ord, Show)++-- | A 'Pred' that returned 'False'+data Failed+  = FTerminal Value Condition+  -- ^ A 'Pred' created with 'predicate'+  | FAnd (Either (Labeled Failed) (Labeled Passed, Labeled Failed))+  -- ^ A 'Pred' created with '&&&'+  | FOr (Labeled Failed) (Labeled Failed)+  -- ^ A 'Pred' created with '|||'+  | FNot (Labeled Passed)+  -- ^ A 'Pred' created with 'not'+  deriving (Eq, Ord, Show)+++-- | The result of processing a 'Pred'.+newtype Result = Result (Labeled (Either Failed Passed))+  deriving (Eq, Ord, Show)++-- | Returns whether this 'Result' failed or passed.+splitResult+  :: Result+  -> Either (Labeled Failed) (Labeled Passed)+splitResult (Result (Labeled l ei)) = case ei of+  Left n -> Left (Labeled l n)+  Right g -> Right (Labeled l g)++-- | Predicates.  Is an instance of 'Contravariant', which allows you+-- to change the type using 'contramap'.  Though the constructor is+-- exported, ordinarily you shouldn't need to use it; other functions+-- in this module create 'PredM' and manipulate them as needed.+--+-- The @f@ type variable is an arbitrary context; ordinarily this type+-- will be an instance of 'Monad', and some of the bindings in this+-- module require this.  That allows you to run predicate computations+-- that run in some sort of context, allowing you to perform IO,+-- examine state, or whatever.  If you only want to do pure+-- computations, just use the 'Pred' type synonym.+newtype PredM f a = PredM { runPredM :: (a -> f Result) }++-- | Predicates that do not run in any context.+type Pred = PredM Identity++-- | Runs pure 'Pred' computations.+runPred :: Pred a -> a -> Result+runPred (PredM f) a = runIdentity $ f a++instance Show (PredM f a) where+  show _ = "Pred"++instance Contravariant (PredM f) where+  contramap f (PredM g) = PredM (g . f)++-- | Creates a new 'PredM' that run in some arbitrary context.  In+-- @predicateM cond f@, @cond@ describes the condition, while @f@+-- gives the predicate function.  For example, if @f@ is @(> 5)@, then+-- @cond@ might be @"is greater than 5"@.+predicateM+  :: Functor f+  => (a -> f (Bool, Value, Condition))+  -> PredM f a+predicateM f = PredM f'+  where+    f' a = fmap mkResult $ f a+      where+        mkResult (b, val, cond) = Result (Labeled [] r)+          where+            r | b = Right (PTerminal val cond)+              | otherwise = Left (FTerminal val cond)++-- | Creates a new 'Pred' that do not run in any context.  In+-- @predicate cond f@, @cond@ describes the condition, while @f@ gives+-- the predicate function.  For example, if @f@ is @(> 5)@, then+-- @cond@ might be @"is greater than 5"@.+predicate+  :: (a -> (Bool, Value, Condition))+  -> Pred a+predicate f = predicateM (fmap return f)++-- | And.  Returns 'True' if both argument 'Pred' return 'True'.  Is+-- lazy in its second argment; if the first argument returns 'False',+-- the second is ignored.+(&&&) :: Monad m => PredM m a -> PredM m a -> PredM m a+(PredM fL) &&& r = PredM $ \a -> do+  resL <- fL a+  ei <- case splitResult resL of+    Left n -> return (Left (FAnd (Left n)))+    Right g -> do+      let PredM fR = r+      resR <- fR a+      return $ case splitResult resR of+        Left b -> Left (FAnd (Right (g, b)))+        Right g' -> Right (PAnd g g')+  return (Result (Labeled [] ei))++infixr 3 &&&+++-- | Or.  Returns 'True' if either argument 'Pred' returns 'True'.  Is+-- lazy in its second argument; if the first argument returns 'True',+-- the second argument is ignored.+(|||) :: Monad m => PredM m a -> PredM m a -> PredM m a+(PredM fL) ||| r = PredM $ \a -> do+  resL <- fL a+  ei <- case splitResult resL of+    Left b -> do+      let PredM fR = r+      resR <- fR a+      return $ case splitResult resR of+        Left b' -> Left $ FOr b b'+        Right g -> Right $ POr (Right (b, g))+    Right g -> return (Right (POr (Left g)))+  return (Result (Labeled [] ei))  +infixr 2 |||++-- | Negation.  Returns 'True' if the argument 'Pred' returns 'False'.+not :: Functor m => PredM m a -> PredM m a+not (PredM f) = PredM $ \a -> fmap g (f a)+  where+    g a = Result (Labeled [] rslt)+      where+        rslt = case splitResult a of+          Left b -> Right (PNot b)+          Right y -> Left (FNot y)+++-- | Uses the appropriate 'Pred' depending on the 'Either' value.  In+-- @'test' ('switch' l r) e@, the resulting 'Pred' returns the result+-- of @l@ if @e@ is 'Left' or the result of @r@ if @e@ is 'Right'.  Is+-- lazy, so the the argument 'Pred' that is not used is ignored.+switch+  :: PredM m a+  -> PredM m b+  -> PredM m (Either a b)+switch pa pb = PredM (either fa fb)+  where+    PredM fa = pa+    PredM fb = pb++-- | Did this 'Result' pass or fail?+resultToBool :: Result -> Bool+resultToBool (Result (Labeled _ ei))+  = either (const False) (const True) ei+++-- | Always returns 'True'+true :: Applicative f => PredM f a+true = predicateM (const (pure trip))+  where+    trip = (True, mempty, Condition [chunk "always returns True"])++-- | Always returns 'False'+false :: Applicative f => PredM f a+false = predicateM (const (pure trip))+  where+    trip = (False, mempty, Condition [chunk "always returns False"])++-- | Always returns its argument+same :: Applicative f => PredM f Bool+same = predicateM+  (\b -> pure (b, (Value [(chunk . X.pack . show $ b)]),+                  Condition [chunk "is returned"]))++-- | Adds descriptive text to a 'Pred'.  Gives useful information for+-- the user.  The label is added to the top 'Pred' in the tree; any+-- existing labels are also retained.  Labels that were added last+-- will be printed first.  For an example of this, see the source code+-- for 'any' and 'all'.+addLabel :: Functor f => [Chunk Text] -> PredM f a -> PredM f a+addLabel s (PredM f) = PredM f'+  where+    f' a = fmap g (f a)+      where+        g (Result (Labeled ss ei)) = Result (Labeled (Label s : ss) ei)+++-- | Like 'Prelude.any'; is 'True' if any of the list items are+-- 'True'.  An empty list returns 'False'.  Is lazy; will stop+-- processing if it encounters a 'True' item.+any :: (Monad m, Applicative m) => PredM m a -> PredM m [a]+any pa = contramap f (switch (addLabel [chunk "cons cell"] pConsCell) pEnd)+  where+    pConsCell =+      contramap fst (addLabel [chunk "head"] pa)+      ||| contramap snd (addLabel [chunk "tail"] (any pa))+    f ls = case ls of+      [] -> Right ()+      x:xs -> Left (x, xs)+    pEnd = predicateM (const (pure (False, Value [chunk "end of list"],+                                    Condition [chunk "always returns False"])))++-- | Like 'Prelude.all'; is 'True' if none of the list items is+-- 'False'.  An empty list returns 'True'.  Is lazy; will stop+-- processing if it encouters a 'False' item.+all :: (Monad m, Applicative m) => PredM m a -> PredM m [a]+all pa = contramap f (switch (addLabel [chunk "cons cell"] pConsCell) pEnd)+  where+    pConsCell =+      contramap fst (addLabel [chunk "head"] pa)+      &&& contramap snd (addLabel [chunk "tail"] (all pa))+    f ls = case ls of+      x:xs -> Left (x, xs)+      [] -> Right ()+    pEnd = predicateM (const (pure (True, Value [chunk "end of list"],+                                    Condition [chunk "always returns True"])))+++-- | Create a 'Pred' for 'Maybe'.+maybe+  :: Applicative m+  => Bool+  -- ^ What to return on 'Nothing'+  -> PredM m a+  -- ^ Analyzes 'Just' values+  -> PredM m (Maybe a)+maybe onEmp pa = contramap f+  (switch emp (addLabel [chunk "Just value"] pa))+  where+    emp | onEmp = predicateM (const+            (pure (True, noth, Condition [chunk "always returns True"])))+        | otherwise = predicateM (const+            (pure (False, noth, Condition [chunk "always returns False"])))+    noth = Value [chunk "Nothing"]+    f may = case may of+      Nothing -> Left ()+      Just a -> Right a+++explainAnd :: [Chunk Text]+explainAnd = [chunk "(and)"]++explainOr :: [Chunk Text]+explainOr = [chunk "(or)"]++explainNot :: [Chunk Text]+explainNot = [chunk "(not)"]++-- | Runs a 'Pred' against a value.+testM :: Functor f => PredM f a -> a -> f Bool+testM (PredM p) = fmap (either (const False) (const True))+  . fmap splitResult . p++-- | Runs a 'Pred' against a value, without a context.+test :: Pred a -> a -> Bool+test p a = runIdentity $ testM p a+++-- | Runs a 'Pred' against a particular value; also returns a list of+-- 'Chunk' describing the steps of evaulation.+verboseTestM :: Functor f => PredM f a -> a -> f ([Chunk Text], Bool)+verboseTestM (PredM f) a = fmap g (f a)+  where+    g rslt = (resultToChunks rslt, resultToBool rslt)++verboseTest :: Pred a -> a -> ([Chunk Text], Bool)+verboseTest p a = runIdentity $ verboseTestM p a+++-- | Obtain a list of 'Chunk' describing the evaluation process.+resultToChunks :: Result -> [Chunk Text]+resultToChunks = either (failedToChunks 0) (passedToChunks 0)+  . splitResult++-- | A colorful label for 'True' values.+lblTrue :: [Chunk Text]+lblTrue = [chunk "[", chunk "TRUE" & fore green, chunk "]"]++-- | A colorful label for 'False' values.+lblFalse :: [Chunk Text]+lblFalse = [chunk "[", chunk "FALSE" & fore red, chunk "]"]++-- | Append two lists of 'Chunk', with an intervening space if both+-- lists are not empty.+(<+>) :: [Chunk Text] -> [Chunk Text] -> [Chunk Text]+l <+> r+  | full l && full r = l <> [chunk " "] <> r+  | otherwise = l <> r+  where+    full = Prelude.any (Prelude.not . X.null) . map _yarn++-- | Append two lists of 'Chunk', with an intervening hyphen if both+-- lists have text.+(<->) :: [Chunk Text] -> [Chunk Text] -> [Chunk Text]+l <-> r+  | full l && full r = l <> hyphen <> r+  | otherwise = l <> r+  where+    full = Prelude.any (Prelude.not . X.null) . map _yarn++hyphen :: [Chunk Text]+hyphen = [chunk " - "]++indentAmt :: Int+indentAmt = 2++spaces :: Int -> [Chunk Text]+spaces i = (:[]) . chunk . X.replicate (i * indentAmt)+  . X.singleton $ ' '++newline :: [Chunk Text]+newline = [chunk "\n"]++labelToChunks :: Label -> [Chunk Text]+labelToChunks (Label cks) = cks++explainTerminal :: Value -> Condition -> [Chunk Text]+explainTerminal (Value v) (Condition c)+  = v ++ (chunk " " : c)++-- | Obtain a list of 'Chunk' describing the evaluation process.+passedToChunks+  :: Int+  -- ^ Number of levels of indentation+  -> Labeled Passed+  -> [Chunk Text]+passedToChunks i (Labeled l p) = this <> rest+  where+    this = spaces i <> (lblTrue <+> (labels `sep` explain)) <> newline+    labels = concat . intersperse hyphen . map labelToChunks $ l+    nextPass = passedToChunks (succ i)+    nextFail = failedToChunks (succ i)+    (explain, rest, sep) = case p of+      PTerminal v c -> (explainTerminal v c, [], (<->))+      PAnd p1 p2 -> (explainAnd, nextPass p1 <> nextPass p2, (<+>))+      POr ei -> (explainOr, more, (<+>))+        where+          more = case ei of+            Left y -> nextPass y+            Right (n, y) -> nextFail n <> nextPass y+      PNot n -> (explainNot, nextFail n, (<+>))++-- | Obtain a list of 'Chunk' describing the evaluation process.+failedToChunks+  :: Int+  -- ^ Number of levels of indentation+  -> Labeled Failed+  -> [Chunk Text]+failedToChunks i (Labeled l p) = this <> rest+  where+    this = spaces i <> (lblFalse <+> (labels `sep` explain)) <> newline+    labels = concat . intersperse hyphen . map labelToChunks $ l+    nextPass = passedToChunks (succ i)+    nextFail = failedToChunks (succ i)+    (explain, rest, sep) = case p of+      FTerminal v c -> (explainTerminal v c, [], (<->))+      FAnd ei -> (explainAnd, more, (<+>))+        where+          more = case ei of+            Left n -> nextFail n+            Right (y, n) -> nextPass y <> nextFail n+      FOr n1 n2 -> (explainOr, nextFail n1 <> nextFail n2, (<+>))+      FNot y -> (explainNot, nextPass y, (<+>))++-- | Like 'verboseTest', but results are printed to standard output.+-- Primarily for use in debugging or in a REPL.+verboseTestStdout :: Pred a -> a -> IO Bool+verboseTestStdout p a = do+  let (cks, r) = verboseTest p a+  mkr <- byteStringMakerFromEnvironment+  mapM_ BS.putStr . chunksToByteStrings mkr $ cks+  return r+
+ lib/Prednote/Expressions.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Handles parsing of both infix and RPN 'Pred' expressions.+module 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 Prednote.Expressions.Infix as I+import qualified Prednote.Expressions.RPN as R+import Prednote.Core+import qualified Prelude+import Prelude hiding (maybe)++-- | A single type for both RPN tokens and infix tokens.+newtype Token m a = Token { unToken :: I.InfixToken m a }++type Error = X.Text++-- | Creates Operands from 'Pred'.+operand :: PredM m a -> Token m a+operand p = Token (I.TokRPN (R.TokOperand p))++-- | The And operator+opAnd :: Token m a+opAnd = Token (I.TokRPN (R.TokOperator R.OpAnd))++-- | The Or operator+opOr :: Token m a+opOr = Token (I.TokRPN (R.TokOperator R.OpOr))++-- | The Not operator+opNot :: Token m a+opNot = Token (I.TokRPN (R.TokOperator R.OpNot))++-- | Open parentheses+openParen :: Token m a+openParen = Token (I.TokParen I.Open)++-- | Close parentheses+closeParen :: Token m a+closeParen = Token (I.TokParen I.Close)++-- | Is this an infix or RPN expression?+data ExprDesc+  = Infix+  | RPN+  deriving (Eq, Show)++toksToRPN :: [Token m a] -> Maybe [R.RPNToken m 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+  :: (Functor m, Monad m)+  => ExprDesc+  -> [Token m a]+  -> Either Error (PredM m a)+parseExpression e toks = do+  rpnToks <- case e of+    Infix -> Prelude.maybe (Left "unbalanced parentheses\n") Right+             . I.createRPN+             . map unToken+             $ toks+    RPN -> Prelude.maybe (Left "parentheses in an RPN expression\n") Right+           $ toksToRPN toks+  R.parseRPN rpnToks
+ lib/Prednote/Expressions/Infix.hs view
@@ -0,0 +1,126 @@+module Prednote.Expressions.Infix+  ( InfixToken (..)+  , Paren(..)+  , createRPN+  ) where++import qualified Prednote.Expressions.RPN as R+import qualified Data.Foldable as Fdbl++data InfixToken f a+  = TokRPN (R.RPNToken f 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 f a])+  -> InfixToken f a+  -> Maybe ([OpStackVal], [R.RPNToken f 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 f a])+  -> R.RPNToken f a+  -> ([OpStackVal], [R.RPNToken f 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 f a] -> ([OpStackVal], [R.RPNToken f 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 f a])+  -> Maybe ([OpStackVal], [R.RPNToken f 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 f a])+  -> Paren+  -> Maybe ([OpStackVal], [R.RPNToken f 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 m a)+  -- ^ The input tokens, with the beginning of the expression on the+  -- left side of the sequence.++  -> Maybe [R.RPNToken m 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 f a] -> Maybe [R.RPNToken f 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/Prednote/Expressions/RPN.hs view
@@ -0,0 +1,76 @@+{-# 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 Prednote.Expressions.RPN where++import qualified Data.Foldable as Fdbl+import qualified Prednote.Core as P+import Prednote.Core ((&&&), (|||), PredM)+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as X++data RPNToken f a+  = TokOperand (PredM f a)+  | TokOperator Operator++data Operator+  = OpAnd+  | OpOr+  | OpNot+  deriving Show++pushOperand :: PredM f a -> [PredM f a] -> [PredM f a]+pushOperand p ts = p : ts++pushOperator+  :: (Monad m, Functor m)+  => Operator+  -> [PredM m a]+  -> Either Text [PredM m a]+pushOperator o ts = case o of+  OpAnd -> case ts of+    x:y:zs -> return $ (y &&& x) : zs+    _ -> Left $ err "and"+  OpOr -> case ts of+    x:y:zs -> return $ (y ||| x) : zs+    _ -> Left $ err "or"+  OpNot -> case ts of+    x:zs -> return $ P.not x : zs+    _ -> Left $ err "not"+  where+    err x = "insufficient operands to apply \"" <> x+            <> "\" operator\n"++pushToken+  :: (Functor f, Monad f)+  => [PredM f a]+  -> RPNToken f a+  -> Either Text [PredM f a]+pushToken ts t = case t of+  TokOperand p -> return $ pushOperand p ts+  TokOperator o -> pushOperator o ts++-- TODO improve "Bad expression" error message?++-- | Parses an RPN expression and returns the resulting 'Pred'. 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+  :: (Functor m, Monad m)+  => Fdbl.Foldable f+  => f (RPNToken m a)+  -> Either Text (PredM m a)+parseRPN ts = do+  trees <- Fdbl.foldlM pushToken [] ts+  case trees of+    [] -> Left $ "bad expression: no operands left on the stack\n"+    x:[] -> return x+    xs -> Left . X.pack+      $ "bad expression: multiple operands left on the stack:\n"+      <> concatMap show xs+
prednote.cabal view
@@ -1,6 +1,24 @@-name:                prednote-version:             0.6.0.0-synopsis:            Build and evaluate trees of predicates+-- This Cabal file generated using the Cartel library.+-- Cartel is available at:+-- http://www.github.com/massysett/cartel+--+-- Script name used to generate: genCabal.hs+-- Generated on: 2015-09-09 21:57:21.988823 EDT+-- Cartel library version: 0.14.2.6++name: prednote+version: 0.36.0.4+cabal-version: >= 1.18+license: BSD3+license-file: LICENSE+build-type: Simple+copyright: Copyright 2013-2015 Omari Norman+author: Omari Norman+maintainer: omari@smileystation.com+stability: Experimental+homepage: http://www.github.com/massysett/prednote+bug-reports: http://www.github.com/massysett/prednote/issues+synopsis: Evaluate and display 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@@ -10,35 +28,112 @@   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+category: Data+extra-source-files:+  README.md+  changelog+  genCabal.hs +Library   exposed-modules:-      Data.Prednote.Pdct-    , Data.Prednote.Expressions-    , Data.Prednote.Expressions.Infix-    , Data.Prednote.Expressions.RPN-    , Data.Prednote.TestTree+    Prednote+    Prednote.Comparisons+    Prednote.Core+    Prednote.Expressions+    Prednote.Expressions.Infix+    Prednote.Expressions.RPN+  build-depends:+      base >= 4.7 && < 5+    , rainbow >= 0.26+    , split >= 0.2.2+    , text >= 0.11.2.0+    , containers >= 0.4.2.1+    , contravariant >= 1.2+    , transformers >= 0.3.0.0+    , bytestring >= 0.10+  hs-source-dirs:+    lib+  ghc-options:+    -Wall+  default-language: Haskell2010 +Test-Suite prednote-tests+  hs-source-dirs:+    lib+    tests+  other-modules:+    Prednote+    Prednote.Comparisons+    Prednote.Core+    Prednote.Expressions+    Prednote.Expressions.Infix+    Prednote.Expressions.RPN+    Instances+    Prednote.Core.Instances+    Prednote.Core.Properties+    Rainbow.Instances+  ghc-options:+    -Wall+  default-language: Haskell2010+  other-extensions:+    TemplateHaskell   build-depends:-      base >= 4.6 && < 5-    , explicit-exception ==0.1.*-    , rainbow ==0.2.*-    , split ==0.2.*-    , text == 0.11.*+      tasty >= 0.10+    , tasty-quickcheck >= 0.8+    , tasty-th >= 0.1+    , QuickCheck >= 2.7+    , base >= 4.7 && < 5+    , rainbow >= 0.26+    , split >= 0.2.2+    , text >= 0.11.2.0+    , containers >= 0.4.2.1+    , contravariant >= 1.2+    , transformers >= 0.3.0.0+    , bytestring >= 0.10+  main-is: prednote-tests.hs+  type: exitcode-stdio-1.0 -  ghc-options: -Wall+Test-Suite prednote-visual-tests+  main-is: prednote-visual-tests.hs+  type: exitcode-stdio-1.0+  hs-source-dirs:+    lib+    tests+  other-modules:+    Prednote+    Prednote.Comparisons+    Prednote.Core+    Prednote.Expressions+    Prednote.Expressions.Infix+    Prednote.Expressions.RPN+    Instances+    Prednote.Core.Instances+    Prednote.Core.Properties+    Rainbow.Instances+  ghc-options:+    -Wall+  default-language: Haskell2010+  other-extensions:+    TemplateHaskell+  build-depends:+      tasty >= 0.10+    , tasty-quickcheck >= 0.8+    , tasty-th >= 0.1+    , QuickCheck >= 2.7+    , base >= 4.7 && < 5+    , rainbow >= 0.26+    , split >= 0.2.2+    , text >= 0.11.2.0+    , containers >= 0.4.2.1+    , contravariant >= 1.2+    , transformers >= 0.3.0.0+    , bytestring >= 0.10++source-repository head+  type: git+  location: https://github.com/massysett/prednote.git++Flag visual-tests+  description: Build the prednote-visual-tests executable+  default: False+  manual: True
+ tests/Instances.hs view
@@ -0,0 +1,18 @@+module Instances where++import Control.Applicative+import Test.QuickCheck+import Rainbow.Types+import qualified Data.Text as X++newtype ChunkA = ChunkA Chunk+  deriving (Eq, Ord, Show)++newtype TextA = TextA X.Text+  deriving (Eq, Ord, Show)++instance Arbitrary TextA where+  arbitrary = (TextA . X.pack) <$> listOf arbitrary++instance Arbitrary Chunk where+  arbitrary = undefined
+ tests/Prednote/Core/Instances.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Prednote.Core.Instances where++import Rainbow.Instances ()+import Test.QuickCheck hiding (Result)+import Control.Monad+import Prednote.Core++instance (CoArbitrary a, Show a) => Arbitrary (Pred a) where+  arbitrary = fmap predicate arbitrary++instance Arbitrary Condition where+  arbitrary = fmap Condition arbitrary++instance CoArbitrary Condition where+  coarbitrary (Condition c) = coarbitrary c++instance Arbitrary Value where+  arbitrary = fmap Value arbitrary++instance CoArbitrary Value where+  coarbitrary (Value x) = coarbitrary x++instance Arbitrary Label where+  arbitrary = fmap Label arbitrary++instance CoArbitrary Label where+  coarbitrary (Label x) = coarbitrary x++instance Arbitrary a => Arbitrary (Labeled a) where+  arbitrary = liftM2 Labeled arbitrary arbitrary++instance CoArbitrary a => CoArbitrary (Labeled a) where+  coarbitrary (Labeled a b) = coarbitrary a . coarbitrary b++instance Arbitrary Passed where+  arbitrary = sized f+    where+      f s | s < 10 = liftM2 PTerminal arbitrary arbitrary+          | otherwise = oneof+              [ liftM2 PTerminal arbitrary arbitrary+              , liftM2 PAnd nestPass nestPass+              , fmap POr+                (oneof [ fmap Left nestPass,+                         fmap Right (liftM2 (,) nestFail nestPass)+                       ])+              , fmap PNot nestFail+              ]+        where+          nestPass = resize (s `div` 4) arbitrary+          nestFail = resize (s `div` 4) arbitrary  +      +instance Arbitrary Failed where+  arbitrary = sized f+    where+      f s | s < 10 = liftM2 FTerminal arbitrary arbitrary+          | otherwise = oneof+              [ liftM2 FTerminal arbitrary arbitrary+              , fmap FAnd+                (oneof [ fmap Left nestFail+                       , fmap Right (liftM2 (,) nestPass nestFail)+                       ])+              , liftM2 FOr nestFail nestFail+              , fmap FNot nestPass+              ]+        where+          nestPass = resize (s `div` 4) arbitrary+          nestFail = resize (s `div` 4) arbitrary++varInt :: Int -> Gen a -> Gen a+varInt = variant++instance CoArbitrary Passed where+  coarbitrary pass = case pass of+    PTerminal v c -> varInt 0 . coarbitrary v . coarbitrary c+    PAnd y1 y2 -> varInt 1 . coarbitrary y1 . coarbitrary y2+    POr e -> varInt 2 . coarbitrary e+    PNot n -> varInt 3 . coarbitrary n++instance CoArbitrary Failed where+  coarbitrary fll = case fll of+    FTerminal v c -> varInt 0 . coarbitrary v . coarbitrary c+    FAnd e -> varInt 1 . coarbitrary e+    FOr x y -> varInt 2 . coarbitrary x . coarbitrary y+    FNot x -> varInt 3 . coarbitrary x++instance Arbitrary Result where+  arbitrary = fmap Result arbitrary++instance CoArbitrary Result where+  coarbitrary (Result x) = coarbitrary x+
+ tests/Prednote/Core/Properties.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE TemplateHaskell #-}++module Prednote.Core.Properties where++import Prednote.Core.Instances ()+import Prednote.Core+import Test.QuickCheck.Function+import Prelude hiding (not, any, all)+import qualified Prelude+import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.TH++tests :: TestTree+tests = $(testGroupGenerator)++testInt :: Pred Int -> Int -> Bool+testInt = test++prop_andIsLazyInSecondArgument i+  = testInt (false &&& undefined) i || True++prop_orIsLazyInSecondArgument i+  = testInt (true ||| undefined) i || True++fst3 :: (a, b, c) -> a+fst3 (a, _, _) = a++prop_andIsLikePreludeAnd (Fun _ f1) (Fun _ f2) i+  = testInt (p1 &&& p2) i == (fst3 (f1 i) && fst3 (f2 i))+  where+    p1 = predicate f1+    p2 = predicate f2++prop_orIsLikePreludeOr (Fun _ f1) (Fun _ f2) i+  = testInt (p1 ||| p2) i == (fst3 (f1 i) || fst3 (f2 i))+  where+    p1 = predicate f1+    p2 = predicate f2++prop_notIsLikePreludeNot (Fun _ f1) i+  = testInt (not p1) i == Prelude.not (fst3 (f1 i))+  where+    p1 = predicate f1++prop_switchIsLazyInFirstArgument pb i+  = test (switch undefined pb) (Right i) || True+  where+    _types = pb :: Pred Int+    +prop_switchIsLazyInSecondArgument pa i+  = test (switch pa undefined) (Left i) || True+  where+    _types = pa :: Pred Int++prop_switch (Fun _ fa) (Fun _ fb) ei+  = test (switch pa pb) ei == expected+  where+    _types = ei :: Either Int Char+    expected = case ei of+      Left i -> fst3 (fa i)+      Right c -> fst3 (fb c)+    pa = predicate fa+    pb = predicate fb+    +prop_true = testInt true++prop_false = Prelude.not . testInt false++prop_same b = test same b == b++prop_any (Fun _ f) ls+  = test (any pa) ls == Prelude.any (fmap fst3 f) ls+  where+    pa = predicate f+    _types = ls :: [Int]+    +prop_all (Fun _ f) ls+  = test (all pa) ls == Prelude.all (fmap fst3 f) ls+  where+    pa = predicate f+    _types = ls :: [Int]+
+ tests/Rainbow/Instances.hs view
@@ -0,0 +1,106 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, DeriveGeneric, StandaloneDeriving #-}++-- | QuickCheck instances for all of Rainbow.  Currently Rainbow does+-- not use these instances itself; they are only here for+-- cut-and-paste for other libraries that may need them.  There is an+-- executable in Rainbow that is built solely to make sure this module+-- compiles without any errors.+--+-- To use these instances, just drop them into your own project+-- somewhere.  They are not packaged as a library because there are+-- orphan instances.++module Rainbow.Instances where++import Control.Applicative+import Test.QuickCheck+import Rainbow.Types+import qualified Data.Text as X+import Data.Typeable++instance (Arbitrary a, Typeable a) => Arbitrary (Color a) where+  arbitrary = Color <$> arbitrary+  shrink = genericShrink++instance CoArbitrary a => CoArbitrary (Color a) where+  coarbitrary (Color a) = coarbitrary a++varInt :: Int -> Gen b -> Gen b+varInt = variant++instance Arbitrary Enum8 where+  arbitrary = elements [E0, E1, E2, E3, E4, E5, E6, E7]+  shrink = genericShrink++instance CoArbitrary Enum8 where+  coarbitrary x = case x of+    E0 -> varInt 0+    E1 -> varInt 1+    E2 -> varInt 2+    E3 -> varInt 3+    E4 -> varInt 4+    E5 -> varInt 5+    E6 -> varInt 6+    E7 -> varInt 7++instance Arbitrary Format where+  arbitrary+    = Format <$> g <*> g <*> g <*> g <*> g <*> g <*> g <*> g+    where+      g = arbitrary+  shrink = genericShrink++instance CoArbitrary Format where+  coarbitrary (Format x0 x1 x2 x3 x4 x5 x6 x7)+    = coarbitrary x0+    . coarbitrary x1+    . coarbitrary x2+    . coarbitrary x3+    . coarbitrary x4+    . coarbitrary x5+    . coarbitrary x6+    . coarbitrary x7++instance (Arbitrary a, Typeable a) => Arbitrary (Style a) where+  arbitrary = Style <$> arbitrary <*> arbitrary <*> arbitrary+  shrink = genericShrink++instance CoArbitrary a => CoArbitrary (Style a) where+  coarbitrary (Style a b c)+    = coarbitrary a+    . coarbitrary b+    . coarbitrary c+++instance Arbitrary Scheme where+  arbitrary = Scheme <$> arbitrary <*> arbitrary+  shrink = genericShrink++instance CoArbitrary Scheme where+  coarbitrary (Scheme a b) = coarbitrary a . coarbitrary b++instance (Arbitrary a, Typeable a) => Arbitrary (Chunk a) where+  arbitrary = Chunk <$> arbitrary <*> arbitrary+  shrink = genericShrink++instance CoArbitrary a => CoArbitrary (Chunk a) where+  coarbitrary (Chunk a b)+    = coarbitrary a+    . coarbitrary b++instance Arbitrary Radiant where+  arbitrary = Radiant <$> arbitrary <*> arbitrary+  shrink = genericShrink++instance CoArbitrary Radiant where+  coarbitrary (Radiant a b) = coarbitrary a . coarbitrary b++instance Arbitrary X.Text where+  arbitrary = fmap X.pack $ listOf genChar+    where+      genChar = elements ['a'..'z']+  shrink = fmap X.pack . shrink . X.unpack++instance CoArbitrary X.Text where+  coarbitrary = coarbitrary . X.unpack
+ tests/prednote-tests.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module Main where++import Test.Tasty+import qualified Prednote.Core.Properties++main :: IO ()+main = defaultMain $ testGroup "all tests"+  [ Prednote.Core.Properties.tests+  ]
+ tests/prednote-visual-tests.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Main where++import Prednote+import Prelude hiding (any, all, maybe)++main :: IO ()+main = do+  verboseTestStdout (all $ lessEq (5 :: Int)) [0..10]+  verboseTestStdout (any $ equal (4 :: Int)) [0..3]+  verboseTestStdout (any $ equal (10 :: Int)) []+  verboseTestStdout (all $ maybe True (lessEq (5 :: Int)))+    [Nothing, Just 1, Just 2, Nothing, Just 3, Just 4, Just 5]+  return ()