prednote 0.22.0.2 → 0.36.0.4

raw patch · 27 files changed

Files

• LICENSE +1/−1
• README.md +16/−14
• changelog +20/−0
• current-versions.txt +0/−49
• genCabal.hs +172/−0
• lib/Data/Prednote.hs +0/−9
• lib/Data/Prednote/Expressions.hs +0/−87
• lib/Data/Prednote/Expressions/Infix.hs +0/−132
• lib/Data/Prednote/Expressions/RPN.hs +0/−85
• lib/Data/Prednote/Predbox.hs +0/−662
• lib/Data/Prednote/Test.hs +0/−224
• lib/Prednote.hs +22/−0
• lib/Prednote/Comparisons.hs +425/−0
• lib/Prednote/Core.hs +496/−0
• lib/Prednote/Expressions.hs +86/−0
• lib/Prednote/Expressions/Infix.hs +126/−0
• lib/Prednote/Expressions/RPN.hs +76/−0
• minimum-versions.txt +0/−46
• prednote-test.hs +0/−90
• prednote.cabal +119/−44
• sunlight-test.hs +0/−15
• tests/Instances.hs +18/−0
• tests/Prednote/Core/Instances.hs +93/−0
• tests/Prednote/Core/Properties.hs +84/−0
• tests/Rainbow/Instances.hs +106/−0
• tests/prednote-tests.hs +10/−0
• tests/prednote-visual-tests.hs +15/−0

@@ -1,4 +1,4 @@-Copyright (c) 2013-2014, Omari Norman+Copyright (c) 2013-2015, Omari Norman  All rights reserved. 

@@ -19,23 +19,25 @@  http://hackage.haskell.org/package/prednote -prednote is licensed under the BSD license; see the LICENSE file.+## Test results -## Versioning+You can view the results of building and testing on Travis by clicking+the button below: -prednote releases are numbered in accordance with the Haskell-Package Versioning Policy.+[![Build Status](https://travis-ci.org/massysett/prednote.svg?branch=master)](https://travis-ci.org/massysett/prednote) -prednote does not set its dependencies in accordance with the-Package Versioning Policy, as I do not set upper bounds.  prednote-is guaranteed to build with the *minimum* versions specified in the-cabal file.  I also include a dependencies.txt file that-documents more recent dependencies that are also known to work.+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. -If you find that prednote does not build due to dependency problems:-1) please let me know at omari@smileystation.com; 2) feel free to-add appropriate upper bounds or patches to the package as-appropriate; and 3) feel free to add command-line contraints to your-cabal command to get it to build.+## 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.

@@ -1,3 +1,23 @@+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

@@ -1,49 +0,0 @@-This package was tested to work with these dependency-versions and compiler version.-These are the default versions fetched by cabal install.-Tested as of: 2014-04-13 22:50:48.223408 UTC-Path to compiler: ghc-7.8.2-Compiler description: 7.8.2--/opt/ghc/7.8.2/lib/ghc-7.8.2/package.conf.d:-    Cabal-1.18.1.3-    array-0.5.0.0-    base-4.7.0.0-    bin-package-db-0.0.0.0-    binary-0.7.1.0-    rts-1.0-    bytestring-0.10.4.0-    containers-0.5.5.1-    deepseq-1.3.0.2-    directory-1.2.1.0-    filepath-1.3.0.2-    (ghc-7.8.2)-    ghc-prim-0.3.1.0-    (haskell2010-1.1.2.0)-    (haskell98-2.0.0.3)-    hoopl-3.10.0.1-    hpc-0.6.0.1-    integer-gmp-0.5.1.0-    old-locale-1.0.0.6-    old-time-1.1.0.2-    pretty-1.1.1.1-    process-1.2.0.0-    template-haskell-2.9.0.0-    time-1.4.2-    transformers-0.3.0.0-    unix-2.7.0.1--/home/massysett/prednote/sunlight-22866/db:-    QuickCheck-2.7.3-    contravariant-0.4.4-    prednote-0.22.0.2-    primitive-0.5.2.1-    rainbow-0.14.0.0-    random-1.0.1.1-    split-0.2.2-    tagged-0.7.1-    terminfo-0.4.0.0-    text-1.1.0.1-    tf-random-0.5-    transformers-compat-0.1.1.1-

@@ -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])

@@ -1,9 +0,0 @@-module Data.Prednote-  ( module Data.Prednote.Predbox-  , module Data.Prednote.Expressions-  , module Data.Prednote.Test-  ) where--import Data.Prednote.Predbox-import Data.Prednote.Expressions-import Data.Prednote.Test

@@ -1,87 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Handles parsing of both infix and RPN Predbox expressions.-module Data.Prednote.Expressions-  ( ExprDesc(..)-  , Error-  , Token-  , operand-  , opAnd-  , opOr-  , opNot-  , openParen-  , closeParen-  , parseExpression-  ) where--import Data.Either (partitionEithers)-import Data.Functor.Contravariant-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.Predbox as P---- | A single type for both RPN tokens and infix tokens.-newtype Token a = Token { unToken :: I.InfixToken a }--instance Contravariant Token where-  contramap f = Token . contramap f . unToken--type Error = X.Text---- | Creates Operands from Predbox.-operand :: P.Predbox 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]-  -> Either Error (P.Predbox a)-parseExpression e toks = do-  rpnToks <- case e of-    Infix -> maybe (Left "unbalanced parentheses\n") Right-             . I.createRPN-             . map unToken-             $ toks-    RPN -> maybe (Left "parentheses in an RPN expression\n") Right-           $ toksToRPN toks-  R.parseRPN rpnToks

@@ -1,132 +0,0 @@-module Data.Prednote.Expressions.Infix-  ( InfixToken (..)-  , Paren(..)-  , createRPN-  ) where--import Data.Functor.Contravariant-import qualified Data.Prednote.Expressions.RPN as R-import qualified Data.Foldable as Fdbl--data InfixToken a-  = TokRPN (R.RPNToken a)-  | TokParen Paren--instance Contravariant InfixToken where-  contramap f t = case t of-    TokRPN r -> TokRPN . contramap f $ r-    TokParen p -> TokParen p--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

@@ -1,85 +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 Data.Functor.Contravariant-import qualified Data.Foldable as Fdbl-import qualified Data.Prednote.Predbox as P-import Data.Prednote.Predbox ((&&&), (|||))-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.Predbox a)-  | TokOperator Operator--instance Contravariant RPNToken where-  contramap f t = case t of-    TokOperand p -> TokOperand . contramap f $ p-    TokOperator o -> TokOperator o--data Operator-  = OpAnd-  | OpOr-  | OpNot-  deriving Show--pushOperand :: P.Predbox a -> [P.Predbox a] -> [P.Predbox a]-pushOperand p ts = p : ts--pushOperator-  :: Operator-  -> [P.Predbox a]-  -> Either Error [P.Predbox 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-  :: [P.Predbox a]-  -> RPNToken a-  -> Either Error [P.Predbox 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 Predbox. 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)-  -> Either Error (P.Predbox 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-      $ "bad expression: multiple operands left on the stack:\n"-      <> ( X.concat-           . concat-           . map C.text-           . concatMap (P.showPredbox 4 0)-           $ xs )-

@@ -1,662 +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.Predbox--  ( -- * The Predbox tree-    Label-  , Hide-  , Predbox(..)-  , Node(..)--  -- * Creating Predbox.-  -- | All functions create Predbox that are shown by default.-  , predicate-  , and-  , or-  , not-  , (&&&)-  , (|||)-  , always-  , never--  -- * Controlling whether Predbox are shown in the results-  , hide-  , show-  , hideTrue-  , hideFalse--  -- * Renaming Predbox-  , rename--  -- * Result-  , Result(..)-  , RNode(..)--  -- * Showing and evaluating Predbox-  , evaluate-  , evaluateNode-  , IndentAmt-  , Level-  , ShowAll-  , showResult-  , showTopResult-  , showPredbox-  , filter-  , verboseFilter--  -- * Helpers for building common Predbox-  -- ** Non-overloaded--  -- | Each of these functions builds a Predbox that compares two-  -- items.  The predicate in the Predbox is applied to an item that-  -- is considered to be the left hand side of the comparison.  The-  -- left hand side side can change; the right hand side is baked-  -- into the Predbox.-  ---  -- For example, to build a Predbox that returns True if an item is-  -- greater than 5:-  ---  -- >>> :set -XOverloadedStrings-  -- >>> let p = compareBy "5" "integer" (`Prelude.compare` (5 :: Integer)) GT-  -- >>> rBool . evaluate p $ 6-  -- True-  -- >>> rBool . evaluate p $ 4-  -- False-  , compareBy-  , compareByMaybe-  , greaterBy-  , lessBy-  , equalBy-  , greaterEqBy-  , lessEqBy-  , notEqBy--  -- ** Overloaded-  , compare-  , greater-  , less-  , equal-  , greaterEq-  , lessEq-  , notEq-  , parseComparer--  ) where----- # Imports--import Data.Functor.Contravariant hiding (Predicate)-import Data.Text (Text)-import qualified Data.Text as X-import Data.Monoid ((<>), mconcat, mempty)-import Data.String (fromString)-import qualified System.Console.Rainbow as R-import Prelude hiding (not, and, or, compare, filter, show)-import qualified Prelude---- # Predbox type--type Label = Text---- | Determines whether a result is shown by default.-type Hide = Bool---- | A predicate. Each Predbox contains a tree of Node.-data Predbox a = Predbox-  { pLabel :: Label-  -- ^ Label used when showing the results--  , pHide :: (Bool -> Hide)-  -- ^ As results are computed, this function is applied to the-  -- result. If this function returns False, then this Predbox will not-  -- be shown by default in the results.--  , pNode :: Node a--  }--data Node a-  = And [Predbox a]-  -- ^ Conjunction. If any Predbox in the list is False, the result is-  -- False. If the list is empty, the result is True.--  | Or [Predbox a]-  -- ^ Disjunction. If at least one Predbox in the list is True, the-  -- result it True. If the list is empty, the result is False.--  | Not (Predbox a)-  -- ^ Negation--  | Predicate (a -> Bool)-  -- ^ Most basic building block.---- | Renames the top level of the Predbox. The function you pass will be--- applied to the old name.-rename :: (Text -> Text) -> Predbox a -> Predbox a-rename f p = p { pLabel = f (pLabel p) }---- | Always True-always :: Predbox a-always = Predbox "always True" (const False) (Predicate (const True))---- | Always False-never :: Predbox a-never = Predbox "always False" (const False) (Predicate (const False))---- | Creates and labels predicates.-predicate :: Label -> (a -> Bool) -> Predbox a-predicate l = Predbox l (const False) . Predicate---- | Creates And Predbox using a generic name-and :: [Predbox a] -> Predbox a-and = Predbox "and" (const False) . And---- | Creates Or Predbox using a generic name-or :: [Predbox a] -> Predbox a-or = Predbox "or" (const False) . Or---- | Creates Not Predbox using a generic name-not :: Predbox a -> Predbox a-not = Predbox "not" (const False) . Not---- | Changes a Predbox so it is always hidden by default.-hide :: Predbox a -> Predbox a-hide p = p { pHide = const True }---- | Changes a Predbox so it is always shown by default.-show :: Predbox a -> Predbox a-show p = p { pHide = const False }---- | Changes a Predbox so that it is hidden if its result is True.-hideTrue :: Predbox a -> Predbox a-hideTrue p = p { pHide = id }---- | Changes a Predbox so that it is hidden if its result is False.-hideFalse :: Predbox a -> Predbox a-hideFalse p = p { pHide = Prelude.not }---- | Forms a Predbox using 'and'; assigns a generic label.-(&&&) :: Predbox a -> Predbox a -> Predbox a-(&&&) x y = Predbox "and" (const False) (And [x, y])-infixr 3 &&&---- | Forms a Predbox using 'or'; assigns a generic label.-(|||) :: Predbox a -> Predbox a -> Predbox a-(|||) x y = Predbox "or" (const False) (Or [x, y])-infixr 2 |||--instance Contravariant Predbox where-  contramap f (Predbox l d n) = Predbox l d $ contramap f n--instance Contravariant Node where-  contramap f n = case n of-    And ls -> And $ map (contramap f) ls-    Or ls -> Or $ map (contramap f) ls-    Not o -> Not $ contramap f o-    Predicate g -> Predicate $ \b -> g (f b)---- # Result---- | The result from evaluating a Predbox.-data Result = Result-  { rLabel :: Label-  -- ^ The label from the original Predbox--  , rBool :: Bool-  -- ^ The boolean result from evaluating the node. If the node is an-  -- predicate, this is the result of applying the predicate function to-  -- the subject. Otherwise, this is the result of application of the-  -- appropriate boolean operation to the child nodes.--  , rHide :: Hide-  -- ^ Is this result hidden in the result by default? Hiding only-  -- affects presentation; it does not affect how this Predbox affects-  -- any parent Predbox.-  , rNode :: RNode-  } deriving (Eq, Show)--data RNode-  = RAnd [Result]-  | ROr [Result]-  | RNot Result-  | RPredicate Bool-  deriving (Eq, Show)---- | Applies a Predbox to a particular value, known as the subject.-evaluate :: Predbox a -> a -> Result-evaluate (Predbox l d n) a = Result l r d' rn-  where-    rn = evaluateNode n a-    r = case rn of-      RAnd ls -> all rBool ls-      ROr ls -> any rBool ls-      RNot x -> Prelude.not . rBool $ x-      RPredicate b -> b-    d' = d r--evaluateNode :: Node a -> a -> RNode-evaluateNode n a = case n of-  And ls -> RAnd (map (flip evaluate a) ls)-  Or ls -> ROr (map (flip evaluate a) ls)-  Not l -> RNot (flip evaluate a l)-  Predicate f -> RPredicate (f a)---- # Types and functions for showing---- | The number of spaces to use for each level of indentation.-type IndentAmt = Int---- | How many levels of indentation to use. Typically you will start--- this at zero. It is incremented by one for each level as functions--- descend through the tree.-type Level = Int---- | Indents text, and adds a newline to the end.-indent :: IndentAmt -> Level -> [R.Chunk] -> [R.Chunk]-indent amt lvl cs = idt : (cs ++ [nl])-  where-    idt = fromString (replicate (lvl * amt) ' ')-    nl = fromString "\n"---- # Showing Predbox---- | Creates a plain Chunk from a Text.-plain :: Text -> R.Chunk-plain = R.Chunk mempty . (:[])---- | Shows a Predbox tree without evaluating it.-showPredbox :: IndentAmt -> Level -> Predbox a -> [R.Chunk]-showPredbox amt lvl (Predbox l _ pd) = case pd of-  And ls -> indent amt lvl [plain ("and - " <> l)]-            <> mconcat (map (showPredbox amt (lvl + 1)) ls)-  Or ls -> indent amt lvl [plain ("or - " <> l)]-           <> mconcat (map (showPredbox amt (lvl + 1)) ls)-  Not t -> indent amt lvl [plain ("not - " <> l)]-           <> showPredbox amt (lvl + 1) t-  Predicate _ -> indent amt lvl [plain ("predicate - " <> l)]--instance Show (Predbox a) where-  show = X.unpack-       . X.concat-       . concat-       . map R.text-       . showPredbox 2 0---filter :: Predbox a -> [a] -> [a]-filter pd as-  = map fst-  . Prelude.filter (rBool . snd)-  . zip as-  . map (evaluate pd)-  $ as----- # Showing Result--labelBool :: Text -> Bool -> [R.Chunk]-labelBool t b = [open, trueFalse, close, blank, txt]-  where-    trueFalse = -      if b then "TRUE" <> R.f_green else "FALSE" <> R.f_red-    open = "["-    close = "]"-    blank = plain (X.replicate blankLen " ")-    blankLen = X.length "discard"-               - (sum . map X.length . R.text $ trueFalse) + 1-    txt = plain t--type ShowAll = Bool---- | Shows a Result in a pretty way with colors and indentation.-showResult-  :: IndentAmt-  -- ^ Indent each level by this many spaces--  -> ShowAll-  -- ^ If True, shows all Predbox, even ones where 'rHide' is-  -- True. Otherwise, respects 'rHide' and does not show hidden Predbox.--  -> Level-  -- ^ How deep in the tree we are; this increments by one for each-  -- level of descent.--  -> Result-  -- ^ The result to show--  -> [R.Chunk]-showResult amt sa lvl (Result lbl rslt hd nd)-  | hd && Prelude.not sa = []-  | otherwise = firstLine ++ restLines-  where-    firstLine = indent amt lvl $ labelBool lbl rslt-    restLines = case nd of-      RAnd ls -> f False ls-      ROr ls -> f True ls-      RNot r -> showResult amt sa (lvl + 1) r-      RPredicate _ -> []-    f stopOn ls = concatMap sr ls' ++ end-      where-        ls' = takeThrough ((== stopOn) . rBool) ls-        sr = showResult amt sa (lvl + 1)-        end = if ls' `shorter` ls-              then indent amt (lvl + 1) ["(short circuit)"]-              else []---- | @shorter x y@ is True if list x is shorter than list y. Lazier--- than taking the length of each list and comparing the results.-shorter :: [a] -> [a] -> Bool-shorter [] [] = False-shorter (_:_) [] = False-shorter [] (_:_) = True-shorter (_:xs) (_:ys) = shorter xs ys---- | For instance,------ > takeThrough odd [2,4,6,7,8] == [2,4,6,7]-takeThrough :: (a -> Bool) -> [a] -> [a]-takeThrough _ [] = []-takeThrough f (x:xs) = x : if f x then [] else takeThrough f xs---- | Shows the top of a Result tree and all the child Results. Adds a--- short label at the top of the tree.-showTopResult-  :: X.Text-  -- ^ Label to add to the top of the tree.-  -> IndentAmt-  -- ^ Indent each level by this many spaces-  -> Level-  -- ^ Indent the top by this many levels-  -> ShowAll-  -- ^ If True, shows all Predbox, even ones where 'rHide' is-  -- True. Otherwise, respects 'rHide' and does not show hidden Predbox.--  -> Result-  -- ^ The result to show-  -> [R.Chunk]-showTopResult txt i lvl sd r = showResult i sd lvl r'-  where-    r' = r { rLabel = rLabel r <> " - " <> txt }----- | Filters a list. Also returns chunks describing the process.-verboseFilter-  :: (a -> X.Text)-  -- ^ How to describe each subject--  -> IndentAmt-  -- ^ Indent each level by this many spaces--  -> ShowAll-  -- ^ If True, shows all Predbox, even ones where 'rHide' is-  -- True. Otherwise, respects 'rHide' and does not show hidden Predbox.--  -> Predbox a-  -- ^ Used to perform the filtering--  -> [a]-  -> ([R.Chunk], [a])--verboseFilter desc amt sa pd as = (chks, as')-  where-    rs = map (evaluate pd) as-    subjAndRslts = zip as rs-    mkChks (subj, rslt) = showTopResult (desc subj) amt 0 sa rslt-    chks = concatMap mkChks subjAndRslts-    as' = map fst . Prelude.filter (rBool . snd) $ subjAndRslts---- # Comparisons---- | Build a Predbox that compares items.-compareBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Predbox--  -> 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 Predbox to be True; otherwise it is False. The subject-  -- will be on the left hand side.--  -> Predbox a--compareBy itemDesc typeDesc cmp ord = Predbox l (const False) (Predicate f)-  where-    l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc-    cmpDesc = case ord of-      LT -> "less than"-      GT -> "greater than"-      EQ -> "equal to"-    f subj = cmp subj == ord---- | Overloaded version of 'compareBy'.-compare-  :: (Show a, Ord a)-  => Text-  -- ^ Description of the type of thing being matched--  -> a-  -- ^ The right hand side of the comparison.--  -> Ordering-  -- ^ When subjects are compared, this ordering must be the result in-  -- order for the Predbox to be True; otherwise it is False. The subject-  -- will be on the left hand side.--  -> Predbox a-compare typeDesc a ord = compareBy itemDesc typeDesc cmp ord-  where-    itemDesc = X.pack . Prelude.show $ a-    cmp item = Prelude.compare item a---- | Builds a Predbox for items that might fail to return a comparison.-compareByMaybe-  :: Text-  -- ^ How to show the item being compared--  -> Text-  -- ^ Description of type of thing being matched--  -> (a -> Maybe Ordering)-  -- ^ How to compare against right hand side. If Nothing, a Predbox that-  -- always returns False is returned.--  -> Ordering-  -- ^ Ordering that must result for the Predbox to be True--  -> Predbox a--compareByMaybe itemDesc typeDesc cmp ord =-  Predbox l (const False) (Predicate f)-  where-    l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc-    cmpDesc = case ord of-      LT -> "less than"-      GT -> "greater than"-      EQ -> "equal to"-    f subj = case cmp subj of-      Nothing -> False-      Just ord' -> ord == ord'--greater-  :: (Show a, Ord a)-  => Text-  -- ^ How to show the item being compared; used to describe the Predbox--  -> a-  -- ^ The right hand side of the comparison.--  -> Predbox a-greater d a = compare d a GT--less-  :: (Show a, Ord a)-  => Text-  -- ^ How to show the item being compared; used to describe the Predbox--  -> a-  -- ^ The right hand side of the comparison.--  -> Predbox a-less d a = compare d a LT--equal-  :: (Show a, Ord a)-  => Text-  -- ^ How to show the item being compared; used to describe the Predbox--  -> a-  -- ^ The right hand side of the comparison.--  -> Predbox a-equal d a = compare d a EQ--greaterEq-  :: (Show a, Ord a)-  => Text-  -- ^ How to show the item being compared; used to describe the Predbox--  -> a-  -- ^ The right hand side of the comparison.--  -> Predbox 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 Predbox--  -> a-  -- ^ The right hand side of the comparison.--  -> Predbox 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 Predbox--  -> a-  -- ^ The right hand side of the comparison.--  -> Predbox a-notEq d a = not $ equal d a--greaterBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Predbox--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Predbox a-greaterBy iD tD cmp = compareBy iD tD cmp GT--lessBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Predbox--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Predbox a-lessBy iD tD cmp = compareBy iD tD cmp LT--equalBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Predbox--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Predbox a-equalBy iD tD cmp = compareBy iD tD cmp EQ--greaterEqBy-  :: Text-  -- ^ How to show the item being compared; used to describe the Predbox--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Predbox 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 Predbox--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Predbox 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 Predbox--  -> Text-  -- ^ Description of the type of thing that is being matched--  -> (a -> Ordering)-  -- ^ How to compare two items--  -> Predbox a-notEqBy iD tD cmp =-  not $ equalBy iD tD cmp---- | Parses a string to find the correct comparer; returns the correct--- function to build a Predbox.--parseComparer-  :: Text-  -- ^ The string with the comparer to be parsed-  -> (Ordering -> Predbox a)-  -- ^ A function that, when given an ordering, returns a Predbox-  -> Maybe (Predbox a)-  -- ^ If an invalid comparer string is given, Nothing; otherwise, the-  -- Predbox.-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-

@@ -1,224 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}---- | Helps you build tests that run against a series of items.-module Data.Prednote.Test-  (-  -- * Test data types-    Name-  , Verbosity(..)-  , TrueVerbosity-  , FalseVerbosity-  , TestVisibility(..)-  , TestVerbosity(..)-  , Pass-  , Test(..)-  , TestResult(..)--  -- * Pre-built tests-  , eachSubjectMustBeTrue-  , nSubjectsMustBeTrue--  -- * Running and showing tests-  , evalTest-  , showTestResult--  ) where--import Control.Arrow (first)-import Data.Functor.Contravariant-import Data.Maybe (fromMaybe)-import Data.Monoid ((<>), mempty)-import qualified Data.Text as X-import Data.Text (Text)--import qualified System.Console.Rainbow as R-import qualified Data.Prednote.Predbox as Pt---- # Types---- | How verbose to be when showing the results of running a Predbox on a--- single subject.-data Verbosity-  = HideAll-  -- ^ Do not show any results from the Predbox--  | ShowDefaults-  -- ^ Show results according to the default settings provided in the-  -- Result itself--  | ShowAll-  -- ^ Show all Result-  deriving (Eq, Show)---- | Use this verbosity for subjects that are True-type TrueVerbosity = Verbosity---- | Use this verbosity for subjects that are False-type FalseVerbosity = Verbosity---- | Determines whether to show any of the results from a single test.-data TestVisibility-  = HideTest-  -- ^ Do not show any results from this test--  | ShowFirstLine TrueVerbosity FalseVerbosity-  -- ^ Show the first line, which indicates whether the test passed or-  -- failed and gives the label for the test. Whether to show-  -- individual subjects is determined by the TrueVerbosity and-  -- FalseVerbosity.--  deriving (Eq, Show)---- | Determines which TestVisibility to use for a particular test.-data TestVerbosity = TestVerbosity-  { onPass :: TestVisibility-    -- ^ Use this TestVisibility when the test passes-  , onFail :: TestVisibility-    -- ^ Use this TestVisibility when the test fails-  } deriving (Eq, Show)--type Pass = Bool---- | The name of a test or of a group.-type Name = Text---- | A single test.-data Test a = Test-  { testName :: Name-  , testPass :: [Pt.Result] -> Pass-  -- ^ Applied to the results of all applications of testFunc;-  -- determines whether the test passes or fails.--  , testFunc :: a -> Pt.Result-  -- ^ This function is applied to each subject.--  , testVerbosity :: TestVerbosity-  -- ^ Default verbosity for the test.-  }--instance Contravariant Test where-  contramap f t = t { testFunc = testFunc t . f }--data TestResult a = TestResult-  { resultName :: Name-  , resultPass :: Pass-  , resultSubjects :: [(a, Pt.Result)]-  , resultDefaultVerbosity :: TestVerbosity-  }--instance Functor TestResult where-  fmap f t = t { resultSubjects = map (first f) . resultSubjects $ t }---- # Showing tests---- | Creates a plain Chunk from a Text.-plain :: X.Text -> R.Chunk-plain = R.Chunk mempty . (:[])--showTestTitle :: Name -> Pass -> [R.Chunk]-showTestTitle n p = [open, passFail, close, blank, txt, nl]-  where-    nl = plain "\n"-    passFail =-      if p-      then "PASS" <> R.f_green-      else "FAIL" <> R.f_red-    open = plain "["-    close = plain "]"-    blank = plain (X.singleton ' ')-    txt = plain n---- | Evaluates a test for a given list of subjects.-evalTest :: Test a -> [a] -> TestResult a-evalTest (Test n fPass fSubj vy) ls = TestResult n p ss vy-  where-    p = fPass results-    results = map fSubj ls-    ss = zip ls results---- | Shows a result with indenting.-showTestResult-  :: Pt.IndentAmt-  -- ^ Indent each level by this many spaces--  -> (a -> Text)-  -- ^ Shows each subject. The function should return a single-line-  -- text without a trailing newline.--  -> Maybe TestVerbosity-  -- ^ If Just, use this TestVerbosity when showing the test. If-  -- Nothing, use the default verbosity.--  -> TestResult a-  -- ^ The result to show--  -> [R.Chunk]-showTestResult amt swr mayVb (TestResult n p ss dfltVb) =-  let vb = fromMaybe dfltVb mayVb-      tv = if p then onPass vb else onFail vb-      firstLine = showTestTitle n p-  in case tv of-      HideTest -> []-      ShowFirstLine trueV falseV ->-        firstLine-        ++ concatMap (showSubject p amt swr (trueV, falseV)) ss--showSubject-  :: Pass-  -> Pt.IndentAmt-  -> (a -> Text)-  -> (TrueVerbosity, FalseVerbosity)-  -> (a, Pt.Result)-  -> [R.Chunk]-showSubject p amt swr (tv, fv) (a, r) =-  let txt = swr a-      vb = if p then tv else fv-  in case vb of-      HideAll -> []-      ShowDefaults -> Pt.showTopResult txt amt 1 False r-      ShowAll -> Pt.showTopResult txt amt 1 True r---- # Pre-built tests---- | The test passes if each subject returns True.-eachSubjectMustBeTrue :: Pt.Predbox a -> Name -> Test a-eachSubjectMustBeTrue pd nm = Test nm pass f vy-  where-    vy = TestVerbosity-      { onPass = ShowFirstLine HideAll HideAll-      , onFail = ShowFirstLine HideAll ShowDefaults }-    pass = all Pt.rBool-    f = Pt.evaluate pd----- | The test passes if at least a given number of subjects are True.-nSubjectsMustBeTrue-  :: Pt.Predbox a-  -> Name-  -> Int-  -- ^ The number of subjects that must be True. This should be a-  -- positive number.-  -> Test a-nSubjectsMustBeTrue pd nm i = Test nm pass f vy-  where-    pass = atLeast i . filter Pt.rBool-    f = Pt.evaluate pd-    vy = TestVerbosity-      { onPass = ShowFirstLine HideAll HideAll-      , onFail = ShowFirstLine HideAll HideAll }----- # Basement---- | Returns True if the list has at least this many elements. Lazier--- than taking the length of the list.-atLeast :: Int -> [a] -> Bool-atLeast i as-  | i < 0 = error "atLeast: negative length parameter"-  | otherwise = go 0 as-  where-    go _ [] = i == 0-    go soFar (_:xs) =-      let nFound = soFar + 1-      in if nFound == i then True else go nFound xs-

@@ -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

@@ -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+

@@ -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+

@@ -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

@@ -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

@@ -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+

@@ -1,46 +0,0 @@-This package was tested to work with these dependency-versions and compiler version.-These are the minimum versions given in the .cabal file.-Tested as of: 2014-04-13 22:50:48.223408 UTC-Path to compiler: ghc-7.4.1-Compiler description: 7.4.1--/opt/ghc/7.4.1/lib/ghc-7.4.1/package.conf.d:-    Cabal-1.14.0-    array-0.4.0.0-    base-4.5.0.0-    bin-package-db-0.0.0.0-    binary-0.5.1.0-    bytestring-0.9.2.1-    containers-0.4.2.1-    deepseq-1.3.0.0-    directory-1.1.0.2-    extensible-exceptions-0.1.1.4-    filepath-1.3.0.0-    (ghc-7.4.1)-    ghc-prim-0.2.0.0-    (haskell2010-1.1.0.1)-    (haskell98-2.0.0.1)-    hoopl-3.8.7.3-    hpc-0.5.1.1-    integer-gmp-0.4.0.0-    old-locale-1.0.0.4-    old-time-1.1.0.0-    pretty-1.1.1.0-    process-1.1.0.1-    rts-1.0-    template-haskell-2.7.0.0-    time-1.4-    unix-2.5.1.0--/home/massysett/prednote/sunlight-22866/db:-    QuickCheck-2.6-    contravariant-0.2.0.1-    prednote-0.22.0.2-    rainbow-0.14.0.0-    random-1.0.1.1-    split-0.2.2-    terminfo-0.4.0.0-    text-0.11.2.0-    transformers-0.3.0.0-

@@ -1,90 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-module Main where--import Control.Applicative-import qualified Test.QuickCheck as Q-import Test.QuickCheck.All (quickCheckAll)-import Test.QuickCheck.Function-import Test.QuickCheck (Arbitrary, Gen, arbitrary)-import qualified Data.Prednote.Predbox as P-import Data.Prednote.Predbox ((&&&), (|||))-import qualified Data.Text as X-import qualified System.Exit as Exit--instance Arbitrary X.Text where-  arbitrary = fmap X.pack (Q.listOf (Q.choose ('!', '~')))--instance Q.CoArbitrary a => Arbitrary (P.Predbox a) where-  arbitrary = P.Predbox <$> arbitrary <*> arbitrary <*> arbitrary--instance Q.CoArbitrary a => Arbitrary (P.Node a) where-  arbitrary = Q.sized tree-    where-      tree 0 = fmap P.Predicate arbitrary-      tree n = Q.oneof-        [ fmap P.And (Q.listOf subtree)-        , fmap P.Or (Q.listOf subtree)-        , fmap P.Not subtree ]-        where-          subtree = P.Predbox <$> arbitrary <*> arbitrary-                    <*> tree (n `div` 2)---- | And is commutative-prop_andCommutative :: a -> P.Predbox a -> P.Predbox a -> Bool-prop_andCommutative a p1 p2 = P.rBool r1 == P.rBool r2-  where-    r1 = P.evaluate (p1 &&& p2) a-    r2 = P.evaluate (p2 &&& p1) a---- | And is associative-prop_andAssociative :: a -> P.Predbox a -> P.Predbox a -> P.Predbox a -> Bool-prop_andAssociative a p1 p2 p3 = P.rBool r1 == P.rBool r2-  where-    r1 = P.evaluate (p1 &&& (p2 &&& p3)) a-    r2 = P.evaluate ((p1 &&& p2) &&& p3) a-    --- | Or is commutative-prop_orCommutative :: a -> P.Predbox a -> P.Predbox a -> Bool-prop_orCommutative a p1 p2 = P.rBool r1 == P.rBool r2-  where-    r1 = P.evaluate (p1 ||| p2) a-    r2 = P.evaluate (p2 ||| p1) a---- | Or is associative-prop_orAssociative :: a -> P.Predbox a -> P.Predbox a -> P.Predbox a -> Bool-prop_orAssociative a p1 p2 p3 = P.rBool r1 == P.rBool r2-  where-    r1 = P.evaluate (p1 ||| (p2 ||| p3)) a-    r2 = P.evaluate ((p1 ||| p2) ||| p3) a---- | Anything or'd with True is True-prop_orWithTrue :: a -> P.Predbox a -> Bool-prop_orWithTrue a p1 = P.rBool r1-  where-    r1 = P.evaluate (p1 ||| P.always) a---- | Anything and'ed with False is False-prop_andWithFalse :: a -> P.Predbox a -> Bool-prop_andWithFalse a p1 = not $ P.rBool r1-  where-    r1 = P.evaluate (p1 &&& P.never) a---- | And Distributivity-prop_andDistributivity :: a -> P.Predbox a -> P.Predbox a -> P.Predbox a -> Bool-prop_andDistributivity x a b c = P.rBool r1 == P.rBool r2-  where-    r1 = P.evaluate (a &&& (b ||| c)) x-    r2 = P.evaluate ((a &&& b) ||| (a &&& c)) x--prop_orDistributivity :: a -> P.Predbox a -> P.Predbox a -> P.Predbox a -> Bool-prop_orDistributivity x a b c = P.rBool r1 == P.rBool r2-  where-    r1 = P.evaluate (a ||| (b &&& c)) x-    r2 = P.evaluate ((a ||| b) &&& (a ||| c)) x--runTests = $quickCheckAll--main :: IO ()-main = do-  b <- runTests-  if b then Exit.exitSuccess else Exit.exitFailure

@@ -1,6 +1,24 @@-name:                prednote-version:             0.22.0.2-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,55 +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-2014 Omari Norman-category:            Data-build-type:          Simple-cabal-version:       >=1.8+category: Data extra-source-files:-  README.md, minimum-versions.txt, current-versions.txt,-  sunlight-test.hs, changelog--tested-with: GHC ==7.4.1, GHC ==7.6.3, GHC ==7.8.2--source-repository head-    type: git-    location: git://github.com/massysett/prednote.git--library+  README.md+  changelog+  genCabal.hs +Library   exposed-modules:-      Data.Prednote-    , Data.Prednote.Predbox-    , Data.Prednote.Expressions-    , Data.Prednote.Expressions.Infix-    , Data.Prednote.Expressions.RPN-    , Data.Prednote.Test-+    Prednote+    Prednote.Comparisons+    Prednote.Core+    Prednote.Expressions+    Prednote.Expressions.Infix+    Prednote.Expressions.RPN   build-depends:-      base >= 4.5.0.0 && < 5-    , contravariant >= 0.2.0.1-    , rainbow >=0.14.0.0 && < 0.15-    , split >=0.2.2+      base >= 4.7 && < 5+    , rainbow >= 0.26+    , split >= 0.2.2     , text >= 0.11.2.0--  ghc-options: -Wall-  hs-source-dirs: lib+    , 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-test+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:+      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-  main-is: prednote-test.hs-  hs-source-dirs: . lib +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:-      base >=4.5.0.0 && < 5-    , contravariant >= 0.2.0.1-    , QuickCheck >=2.6-    , rainbow >=0.14.0.0 && < 0.15+      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

@@ -1,15 +0,0 @@-module Main where--import Test.Sunlight--inputs = TestInputs-  { tiDescription = Nothing-  , tiCabal = "cabal"-  , tiLowest = ("7.4.1", "ghc-7.4.1", "ghc-pkg-7.4.1")-  , tiDefault = [ ("7.4.1", "ghc-7.4.1", "ghc-pkg-7.4.1")-                , ("7.6.3", "ghc-7.6.3", "ghc-pkg-7.6.3")-                , ("7.8.2", "ghc-7.8.2", "ghc-pkg-7.8.2") ]-  , tiTest = [("dist/build/prednote-test/prednote-test", [])]-  }--main = runTests inputs

@@ -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

@@ -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+

@@ -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]+    

@@ -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

@@ -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+  ]

@@ -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 ()