prednote 0.22.0.2 → 0.24.0.0
raw patch · 21 files changed
+1383/−1375 lines, 21 filesdep +containersdep −QuickCheckdep ~basedep ~contravariantdep ~rainbow
Dependencies added: containers
Dependencies removed: QuickCheck
Dependency ranges changed: base, contravariant, rainbow, split, text
Files
- README.md +0/−19
- changelog +4/−0
- current-versions.txt +8/−12
- 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 +117/−0
- lib/Prednote/Comparisons.hs +315/−0
- lib/Prednote/Core.hs +325/−0
- lib/Prednote/Expressions.hs +87/−0
- lib/Prednote/Expressions/Infix.hs +132/−0
- lib/Prednote/Expressions/RPN.hs +79/−0
- lib/Prednote/Format.hs +110/−0
- lib/Prednote/Prebuilt.hs +151/−0
- minimum-versions.txt +3/−5
- prednote-test.hs +0/−90
- prednote.cabal +51/−49
- sunlight-test.hs +1/−1
README.md view
@@ -20,22 +20,3 @@ http://hackage.haskell.org/package/prednote prednote is licensed under the BSD license; see the LICENSE file.--## Versioning--prednote releases are numbered in accordance with the Haskell-Package Versioning Policy.--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 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.--
changelog view
@@ -1,3 +1,7 @@+0.24.0.0++ * complete change in API and internals.+ 0.22.0.2 * updates for new Rainbow API
current-versions.txt view
@@ -1,7 +1,7 @@ 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+Tested as of: 2014-07-13 14:54:13.902743 UTC Path to compiler: ghc-7.8.2 Compiler description: 7.8.2 @@ -33,17 +33,13 @@ 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+/home/massysett/prednote/library/sunlight-25515/db:+ contravariant-0.6+ prednote-0.24.0.0+ rainbow-0.14.0.2 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+ text-1.1.1.3+ transformers-0.4.1.0+ transformers-compat-0.3.3.4
− lib/Data/Prednote.hs
@@ -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
− lib/Data/Prednote/Expressions.hs
@@ -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
− lib/Data/Prednote/Expressions/Infix.hs
@@ -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
− lib/Data/Prednote/Expressions/RPN.hs
@@ -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 )-
− lib/Data/Prednote/Predbox.hs
@@ -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-
− lib/Data/Prednote/Test.hs
@@ -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-
+ lib/Prednote.hs view
@@ -0,0 +1,117 @@+-- | This module provides everything you need for most uses of Prednote.+-- The core type of Prednote is the 'Pred', which is a rose+-- 'Tree' of predicates along with some additional information, such+-- as a 'plan', which shows you how the 'Pred' will be evaluated+-- without actually having to apply it to a particular subject. When+-- evaluating a 'Pred', you can also display a 'report' describing the+-- evaluation process.+--+-- This module builds 'Pred' with 'report's that make sparing use of+-- color; for example, 'True' results have @[TRUE]@ indicated in+-- green, @[FALSE]@ in red, and /short circuits/ (that is, 'Pred' that+-- were evaluated without evaluating all their child 'Pred') indicated+-- in yellow. They are also nicely indented to indicate the structure+-- of the 'Tree'.+--+-- If you want more control over how your results are formatted,+-- examine "Prednote.Core" and "Prednote.Format".+-- "Prednote.Comparisons" builds on this module to provide 'Pred' to+-- use for common comparisons (such as greater than, less than, etc.)+-- "Prednote.Expressions" helps you parse infix or postfix (i.e. RPN)+-- expressions.+--+-- This module exports some names that conflict with Prelude names, so+-- you might want to do something like+--+-- > import qualified Prednote as P+module Prednote+ ( -- * Pred+ Pred++ -- * Visibility++ -- | Upon evaluation, each 'Pred' has a visibility, indicated with+ -- 'Visible'. It can be either 'shown' or 'hidden'. The+ -- visibility of a 'Pred' does not affect any of the results, nor+ -- does it affect how the 'Pred' is shown in the 'plan'; rather,+ -- it affects only how the result of the 'Pred' is shown in the+ -- 'report'. If a 'Pred' is 'hidden', its value and the value of+ -- its children is not shown in the 'report'.++ , C.Visible+ , C.shown+ , C.hidden+ , P.visibility+ , P.reveal+ , P.hide+ , P.showTrue+ , P.showFalse++ -- * Predicates++ -- | These 'Pred' have no child 'Pred'.++ , P.predicate+ , P.true+ , P.false+ , P.same++ -- * Combinators++ -- | These functions combine one more more 'Pred' to create a new+ -- 'Pred'; the argument 'Pred' become children of the new 'Pred'.++ , P.all+ , (&&&)+ , P.any+ , (|||)+ , P.not++ -- ** Fanout++ -- | These functions allow you to take a single subject and split it+ -- into multiple subjects, applying a 'Pred' to each subject that+ -- results. As a simple example, this allows you to build a 'Pred'+ -- ['Int'] that combines 'Pred' that test individual 'Int' along+ -- with 'Pred' that examine the entire list of ['Int'].++ , P.fanAll+ , P.fanAny+ , P.fanAtLeast++ -- * Reports and plans++ -- | A 'plan' displays a 'Pred' without evaluating it, while a+ -- 'report' shows the process through which a 'Pred' was evaluated+ -- for a particular subject.++ , C.Output+ , plan+ , C.evaluate+ , report++ -- * Evaluation and reporting++ -- | These functions use 'report', 'C.evaluate', or both.++ , C.test+ , C.testV+ , C.filter+ , C.filterV+ ) where++import qualified Prednote.Prebuilt as P+import Prednote.Prebuilt ((&&&), (|||))+import Prednote.Core (Pred)+import qualified Prednote.Core as C+import System.Console.Rainbow+import Data.Tree++-- | Indents and formats static labels for display. This is a 'plan'+-- for how the 'Pred' would be applied.+plan :: Pred a -> [Chunk]+plan = C.plan 0++-- | Indents and formats output for display.+report :: Tree C.Output -> [Chunk]+report = C.report 0
+ lib/Prednote/Comparisons.hs view
@@ -0,0 +1,315 @@+{-# LANGUAGE OverloadedStrings #-}+module Prednote.Comparisons where++import Prednote.Prebuilt+import Prednote.Format+import qualified Prednote.Core as C+import Data.Text (Text)+import qualified Data.Text as X+import Prelude hiding (compare, not)+import qualified Prelude++-- | 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+ :: Text+ -- ^ Description of the type of thing that is being matched++ -> Text+ -- ^ Description of the right-hand side++ -> (a -> Text)+ -- ^ Describes the left-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.++ -> C.Pred a++compareBy typeDesc rhsDesc lhsDesc get ord = predicate stat dyn pd+ where+ stat = typeDesc <+> "is" <+> ordDesc <+> rhsDesc+ ordDesc = case ord of+ EQ -> "equal to"+ LT -> "less than"+ GT -> "greater than"+ dyn a = typeDesc <+> lhsDesc a <+> "is" <+> ordDesc <+> rhsDesc+ pd a = get a == ord++-- | Overloaded version of 'compareBy'.++compare+ :: (Show a, Ord a)+ => Text+ -- ^ Description of the type of thing that is being matched++ -> 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.++ -> C.Pred a+compare typeDesc rhs ord =+ compareBy typeDesc (X.pack . show $ rhs) (X.pack . show)+ (`Prelude.compare` rhs) ord++-- | Builds a 'Pred' that tests items for equality.++equalBy+ :: Text+ -- ^ Description of the type of thing that is being matched++ -> Text+ -- ^ Description of the right-hand side++ -> (a -> Text)+ -- ^ Describes the left-hand side++ -> (a -> Bool)+ -- ^ How to compare an item against the right hand side. Return+ -- 'True' if the items are equal; 'False' otherwise.++ -> C.Pred a+equalBy typeDesc rhsDesc lhsDesc get = predicate stat dyn get+ where+ stat = typeDesc <+> "is equal to" <+> rhsDesc+ dyn a = typeDesc <+> lhsDesc a <+> "is equal to" <+> rhsDesc++-- | Overloaded version of 'equalBy'.++equal+ :: (Eq a, Show a)+ => Text+ -- ^ Description of the type of thing that is being matched++ -> a+ -- ^ Right-hand side++ -> C.Pred a+equal typeDesc rhs = equalBy typeDesc (X.pack . show $ rhs)+ (X.pack . show) (== rhs)+++-- | Builds a 'Pred' for items that might fail to return a comparison.+compareByMaybe+ :: Text+ -- ^ Description of the type of thing that is being matched++ -> Text+ -- ^ Description of the right-hand side++ -> (a -> Text)+ -- ^ Describes the left-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.++ -> C.Pred a++compareByMaybe typeDesc rhsDesc lhsDesc get ord = predicate stat dyn fn+ where+ stat = typeDesc <+> "is" <+> ordDesc <+> rhsDesc+ dyn a = typeDesc <+> lhsDesc a <+> "is" <+> ordDesc <+> rhsDesc+ ordDesc = case ord of+ EQ -> "equal to"+ LT -> "less than"+ GT -> "greater than"+ fn a = case get a of+ Nothing -> False+ Just o -> o == ord++greater+ :: (Show a, Ord a)++ => Text+ -- ^ Description of the type of thing being matched++ -> a+ -- ^ Right-hand side++ -> C.Pred a+greater typeDesc rhs = compare typeDesc rhs GT++less+ :: (Show a, Ord a)++ => Text+ -- ^ Description of the type of thing being matched++ -> a+ -- ^ Right-hand side++ -> C.Pred a+less typeDesc rhs = compare typeDesc rhs LT++greaterEq+ :: (Show a, Ord a)+ => Text+ -- ^ Description of the type of thing being matched++ -> a+ -- ^ Right-hand side++ -> C.Pred a+greaterEq t r = greater t r ||| equal t r++lessEq+ :: (Show a, Ord a)+ => Text+ -- ^ Description of the type of thing being matched++ -> a+ -- ^ Right-hand side++ -> C.Pred a+lessEq t r = less t r ||| equal t r++notEq+ :: (Show a, Eq a)+ => Text+ -- ^ Description of the type of thing being matched++ -> a+ -- ^ Right-hand side++ -> C.Pred a+notEq t r = not $ equal t r++greaterBy+ :: Text+ -- ^ Description of the type of thing being matched++ -> Text+ -- ^ Description of right-hand side++ -> (a -> Text)+ -- ^ Describes the left-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.++ -> C.Pred a+greaterBy dT dR dL get = compareBy dT dR dL get GT+++lessBy+ :: Text+ -- ^ Description of the type of thing being matched++ -> Text+ -- ^ Description of right-hand side++ -> (a -> Text)+ -- ^ Describes the left-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.++ -> C.Pred a+lessBy dT dR dL get = compareBy dT dR dL get LT++greaterEqBy+ :: Text+ -- ^ Description of the type of thing being matched++ -> Text+ -- ^ Description of right-hand side++ -> (a -> Text)+ -- ^ Describes the left-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.++ -> C.Pred a+greaterEqBy dT dR dL f = greaterBy dT dR dL f ||| equalBy dT dR dL f'+ where+ f' = fmap (== EQ) f++lessEqBy+ :: Text+ -- ^ Description of the type of thing being matched++ -> Text+ -- ^ Description of right-hand side++ -> (a -> Text)+ -- ^ Describes the left-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.++ -> C.Pred a+lessEqBy dT dR dL f = lessBy dT dR dL f ||| equalBy dT dR dL f'+ where+ f' = fmap (== EQ) f++notEqBy+ :: Text+ -- ^ Description of the type of thing being matched++ -> Text+ -- ^ Description of right-hand side++ -> (a -> Text)+ -- ^ Describes the left-hand side++ -> (a -> Bool)+ -- ^ How to compare an item against the right hand side. Return+ -- 'True' if equal; 'False' otherwise.++ -> C.Pred a+notEqBy dT dR dL = not . equalBy dT dR dL+++-- | Parses a string that contains text, such as @>=@, which indicates+-- which comparer to use. Returns the comparer.+parseComparer+ :: Text+ -- ^ The string with the comparer to be parsed++ -> (Ordering -> C.Pred a)+ -- ^ A function that, when given an ordering, returns a 'C.Pred'.+ -- Typically you will get this by partial application of 'compare',+ -- 'compareBy', or 'compareByMaybe'.++ -> Maybe (C.Pred a)+ -- ^ If an invalid comparer string is given, Nothing; otherwise, the+ -- 'C.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+
+ lib/Prednote/Core.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE BangPatterns #-}+-- | 'Pred' core functions. If your needs are simple, "Prednote.Prebuilt"+-- is easier to use. However, the types and functions in this module+-- give you more control.+--+-- Each function in this module that returns a 'Pred' returns one with+-- the following characteristics:+--+-- * No 'static' name+--+-- Upon evaluation:+--+-- * 'visible' is always 'shown'+--+-- * 'short' is either 'Nothing' or @'Just' ('const' [])@+--+-- * 'dynamic' is always @'const' []@+--+-- Thus, the 'Pred' created by this module are rather bare-bones, but+-- you can modify them as you see fit; "Prednote.Prebuilt" already+-- does this for you.+--+-- This module exports some names that conflict with Prelude names, so+-- you might want to do something like+--+-- > import qualified Prednote.Pred.Core as P++module Prednote.Core where++import System.Console.Rainbow+import Prelude hiding (filter, not)+import qualified Prelude+import Data.Functor.Contravariant (Contravariant(..))+import Data.Tree+import qualified Data.Text as X+import Data.Maybe++-- | Indicates how to display text. This function is applied to an+-- 'Int' that is the level of indentation; each level of descent+-- through a tree of 'Pred' increments this 'Int' by one. Because the+-- function returns a list of 'Chunk', you can use multiple colors.+-- Typically this function will indent text accordingly, with a+-- newline at the end.+type Chunker = Int -> [Chunk]++-- | A rose tree of predicates.+data Pred a = Pred+ { static :: Tree Chunker+ -- ^ A tree of static names, allowing you to identify the 'Pred'+ -- without applying it to a subject.++ , evaluate :: a -> Tree Output+ -- ^ Evaluates a 'Pred' by applying it to a subject.+ }++instance Contravariant Pred where+ contramap f (Pred s e) = Pred s (e . f)++-- | The result of evaluating a 'Pred'.+data Output = Output+ { result :: Bool+ , visible :: Visible+ -- ^ Results that are not 'Visible' are not shown by the 'report'+ -- function.+ , short :: Maybe Chunker+ -- ^ Indicates whether there was a short circuit when evaluating+ -- this 'Pred'. A short circuit occurs when the 'Pred' does not+ -- need to evaluate all of its children in order to reach a+ -- result. If 'Nothing', there was no short circuit; otherwise,+ -- this is a 'Just' with a 'Chunker' providing a way to display+ -- the short circuit.++ , dynamic :: Chunker+ -- ^ The dynamic label; this indicates how 'report' will show the+ -- 'Pred' to the user after it has been evaluated.+ }++instance Show Output where+ show (Output r v _ _) = "output - result: " ++ show r+ ++ " visible: " ++ (show . unVisible $ v)++-- | Is this result visible? If not, 'Prednote.report' will not show it.+newtype Visible = Visible { unVisible :: Bool }+ deriving (Eq, Ord, Show)++-- | Shown by 'Prednote.report'+shown :: Visible+shown = Visible True++-- | Hidden by 'Prednote.report'+hidden :: Visible+hidden = Visible False++-- | No 'Pred' in the list may be 'False' for 'all' to be 'True'. An+-- empty list of 'Pred' yields a 'Pred' that always returns 'True'.+-- May short circuit.+all :: [Pred a] -> Pred a+all ls = Pred st' ev+ where+ st' = Node (const []) . map static $ ls+ ev a = go [] ls+ where+ go soFar [] = Node (Output True shown Nothing (const []))+ (reverse soFar)+ go soFar (x:xs) =+ let tree = evaluate x a+ r = result . rootLabel $ tree+ shrt = case xs of+ [] -> Nothing+ _ -> Just (const [])+ out = Output r shown shrt (const [])+ cs = reverse (tree:soFar)+ in case xs of+ [] -> Node out cs+ _ | Prelude.not r -> Node out cs+ | otherwise -> go cs xs+++-- | At least one 'Pred' in the list must be 'True' for the resulting+-- 'Pred' to be 'True'. An empty list of 'Pred' yields a 'Pred' that+-- always returns 'False'. May short circuit.+any :: [Pred a] -> Pred a+any ls = Pred st' ev+ where+ st' = Node (const []) . map static $ ls+ ev a = go [] ls+ where+ go soFar [] = Node (Output False shown Nothing (const []))+ (reverse soFar)+ go soFar (x:xs) =+ let tree = evaluate x a+ r = result . rootLabel $ tree+ shrt = case xs of+ [] -> Nothing+ _ -> Just (const [])+ out = Output r shown shrt (const [])+ cs = reverse (tree:soFar)+ in case xs of+ [] -> Node out cs+ _ | r -> Node out cs+ | otherwise -> go cs xs+++-- | Negates the child 'Pred'. Never short circuits.+not :: Pred a -> Pred a+not pd = Pred st' ev+ where+ st' = Node (const []) [static pd]+ ev a = Node nd [c]+ where+ nd = Output res shown Nothing (const [])+ (res, c) = (Prelude.not r, t)+ where+ t = evaluate pd a+ r = result . rootLabel $ t++-- | Fanout. May short circuit.+fan+ :: ([Bool] -> (Bool, Visible, Maybe Int))+ -- ^ This function is applied to a list of the 'result' from+ -- evaluating the child 'Pred' on each fanout item. The function+ -- must return a triple, with the 'Bool' indicating success or+ -- failure, 'Visible' for visibility, and 'Maybe' 'Int' to indicate+ -- whether a short circuit occurred; this must be 'Nothing' if there+ -- was no short circuit, or 'Just' with an 'Int' to indicate a short+ -- circuit, with the 'Int' indicating that a short circuit occurred+ -- after examining the given number of elements.+ --+ -- The resulting 'Pred' always short circuits if the previous+ -- function returns a 'Just' 'Int' with the 'Int' being less than+ -- zero. Otherwise, the resulting 'Pred' short circuits if+ -- the 'Int' is less than the number of elements returned by the+ -- fanout function.++ -> (a -> [b])+ -- ^ Fanout function++ -> Pred b+ -> Pred a+fan get fn pd = Pred st' ev+ where+ st' = Node (const []) [static pd]+ ev a = Node nd cs+ where+ nd = Output r v shrt (const [])+ (r, v, mayInt) = get bools+ shrt = case mayInt of+ Nothing -> Nothing+ Just s | s < 0 -> Just (const [])+ | cs `shorter` allcs -> Just (const [])+ | otherwise -> Nothing+ bs = fn a+ allcs = map (evaluate pd) bs+ bools = map (result . rootLabel) allcs+ cs = case mayInt of+ Nothing -> allcs+ Just i -> take i allcs+++-- | Fanout all. The resulting 'Pred' is 'True' if no child item+-- returns 'False'; an empty list of child items returns 'True'. May+-- short circuit.+fanAll+ :: (a -> [b])+ -- ^ Fanout function++ -> Pred b+ -> Pred a+fanAll = fan get+ where+ get = go 0+ where+ go !c ls = case ls of+ [] -> (True, shown, Just c)+ x:xs+ | Prelude.not x -> (False, shown, Just (c + 1))+ | otherwise -> go (c + 1) xs++-- | Fanout any. The resulting 'Pred' is 'True' if at least one child+-- item returns 'True'; an empty list of child items returns 'False'.+-- May short circuit.+fanAny+ :: (a -> [b])+ -- ^ Fanout function++ -> Pred b+ -> Pred a+fanAny = fan get+ where+ get = go 0+ where+ go !c ls = case ls of+ [] -> (False, shown, Just c)+ x:xs+ | x -> (True, shown, Just (c + 1))+ | otherwise -> go (c + 1) xs++-- | Fanout at least. The resulting 'Pred' is 'True' if at least the+-- given number of child items return 'True'. May short circuit.+fanAtLeast+ :: Int+ -- ^ Find at least this many. If this number is less than or equal+ -- to zero, 'fanAtLeast' will always return 'True'.++ -> (a -> [b])+ -- ^ Fanout function++ -> Pred b+ -> Pred a+fanAtLeast i = fan get+ where+ get = go 0 0+ where+ go !found !c ls+ | found >= i = (True, shown, Just c)+ | otherwise = case ls of+ [] -> (False, shown, Just c)+ x:xs -> go fnd' (c + 1) xs+ where+ fnd' | x = found + 1+ | otherwise = found++-- | Indents and formats output for display.+report+ :: Int+ -- ^ Start at this level of indentation.+ -> Tree Output+ -> [Chunk]+report l (Node n cs)+ | (== hidden) . visible $ n = []+ | otherwise = this ++ concatMap (report (l + 1)) cs ++ shrt+ where+ this = dynamic n l+ shrt = maybe [] ($ (l + 1)) . short $ n++-- | Indents and formats static labels for display. This is a 'plan'+-- for how the 'Pred' would be applied.+plan+ :: Int+ -- ^ Start at this level of indentation.+ -> Pred a+ -> [Chunk]+plan lvl pd = go lvl (static pd)+ where+ go l (Node n cs) = this ++ concatMap (go (l + 1)) cs+ where+ this = n l++instance Show (Pred a) where+ show = X.unpack . X.concat . concat . map text+ . plan 0++-- | Applies a 'Pred' to a single subject and returns the 'result'.+test :: Pred a -> a -> Bool+test p = result . rootLabel . evaluate p++-- | Like 'test' but also returns the accompanying 'report'.+testV :: Pred a -> a -> (Bool, [Chunk])+testV p a = (result . rootLabel $ t, report 0 t)+ where+ t = evaluate p a++-- | Like 'Prelude.filter'.+filter :: Pred a -> [a] -> [a]+filter p = Prelude.filter (test p)++-- | Like 'filter' but also returns a list of 'report', with one+-- 'report' for each list item.+filterV :: Pred a -> [a] -> ([a], [Chunk])+filterV p as = (mapMaybe fltr (zip as rslts), cks)+ where+ fltr (a, r)+ | result . rootLabel $ r = Just a+ | otherwise = Nothing+ rslts = map (evaluate p) as+ cks = concatMap (report 0) rslts++-- | @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+
+ lib/Prednote/Expressions.hs view
@@ -0,0 +1,87 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Handles parsing of both infix and RPN Predbox expressions.+module 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 Prednote.Expressions.Infix as I+import qualified Prednote.Expressions.RPN as R+import Prednote.Core (Pred)++-- | 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 :: Pred 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 (Pred 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
+ lib/Prednote/Expressions/Infix.hs view
@@ -0,0 +1,132 @@+module Prednote.Expressions.Infix+ ( InfixToken (..)+ , Paren(..)+ , createRPN+ ) where++import Data.Functor.Contravariant+import qualified 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
+ lib/Prednote/Expressions/RPN.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Postfix, or RPN, expression parsing.+--+-- This module parses RPN expressions where the operands are+-- predicates and the operators are one of @and@, @or@, or @not@,+-- where @and@ and @or@ are binary and @not@ is unary.+module Prednote.Expressions.RPN where++import Data.Functor.Contravariant+import qualified Data.Foldable as Fdbl+import qualified Prednote.Prebuilt as P+import Prednote.Core (Pred)+import Prednote.Prebuilt ((&&&), (|||))+import Data.Monoid ((<>))+import Data.Text (Text)+import qualified Data.Text as X++data RPNToken a+ = TokOperand (Pred 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 :: Pred a -> [Pred a] -> [Pred a]+pushOperand p ts = p : ts++pushOperator+ :: Operator+ -> [Pred a]+ -> Either Text [Pred 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+ :: [Pred a]+ -> RPNToken a+ -> Either Text [Pred 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 Text (Pred 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+
+ lib/Prednote/Format.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE OverloadedStrings #-}+-- | Functions used to format text. Typically you won't need these+-- unless you want tailored control over how your 'Prednote.Core.Pred'+-- are formatted.+module Prednote.Format where++import System.Console.Rainbow+import Data.Text (Text)+import qualified Data.Text as X+import qualified Prednote.Core as C+import qualified Data.Tree as E+import Data.Monoid++-- # Labels and indentation++-- | A colorful label for 'True' values.+lblTrue :: [Chunk]+lblTrue = ["[", f_green <> "TRUE", "]"]++-- | A colorful label for 'False' values.+lblFalse :: [Chunk]+lblFalse = ["[", f_red <> "FALSE", "]"]++-- | Indent amount.+indentAmt :: Int+indentAmt = 2++-- | Prefixes the given 'Text' with colorful text to indicate 'True'+-- or 'False' as appropriate.+lblLine :: Bool -> Text -> [Chunk]+lblLine b t = lbl ++ [" ", fromText t]+ where+ lbl | b = lblTrue+ | otherwise = lblFalse++-- | Indents the given list of 'Chunk' by the given 'Int' multipled by+-- 'indentAmt'. Appends a newline.+indent :: [Chunk] -> Int -> [Chunk]+indent cs i = spaces : cs ++ [fromText "\n"]+ where+ spaces = fromText . X.replicate (indentAmt * i)+ . X.singleton $ ' '++-- | A label for a short circuit.+shortCir :: Int -> [Chunk]+shortCir = indent ["[", f_yellow <> "short circuit", "]"]++-- | Indents a 'Text' by the given 'Int' multiplied by+-- 'indentAmt'.+indentTxt :: Text -> Int -> [Chunk]+indentTxt = indent . (:[]) . fromText++-- | Append two 'Text', with an intervening space if both 'Text' are+-- not empty.+(<+>) :: Text -> Text -> Text+l <+> r+ | full l && full r = l <> " " <> r+ | otherwise = l <> r+ where+ full = Prelude.not . X.null++-- | Create a new 'C.Pred' with a different static label.+rename :: Text -> C.Pred a -> C.Pred a+rename x p = p { C.static = (C.static p)+ { E.rootLabel = indentTxt x } }++-- | Creates a new 'C.Pred' with a result differing from the original+-- 'C.Pred'.+changeOutput+ :: (a -> C.Output -> C.Output)+ -- ^ Function to modify the 'C.Output'++ -> C.Pred a+ -- ^ Modify the 'C.Output' of this 'C.Pred'++ -> C.Pred a+changeOutput f p = p { C.evaluate = e' }+ where+ e' a = t'+ where+ t = C.evaluate p a+ t' = t { E.rootLabel = f a (E.rootLabel t) }++-- | Creates a new 'C.Pred' with a different dynamic label.+speak+ :: (a -> Text)+ -- ^ New dynamic label. Do not indicate whether the result is+ -- 'True' or 'False'; this is done for you.++ -> C.Pred a++ -> C.Pred a+speak f = changeOutput g+ where+ g a o = o { C.dynamic = dyn }+ where+ dyn = indent $ lblLine (C.result o) (f a)+++-- | Creates a new 'C.Pred' with any short circuits having a colorful+-- label.+speakShort :: C.Pred a -> C.Pred a+speakShort p = p { C.evaluate = e' }+ where+ e' a = t { E.rootLabel = (E.rootLabel t)+ { C.short = fmap (const shortCir) shrt } }+ where+ t = C.evaluate p a+ shrt = C.short . E.rootLabel $ t+
+ lib/Prednote/Prebuilt.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE OverloadedStrings, BangPatterns #-}++-- | Functions to work with 'Pred'. This module works with 'Text' and+-- produces 'Pred' that make sparing use of color. For more control+-- over the 'Pred' produced, use "Prednote.Pred.Core".+--+-- Exports some names that conflict with Prelude names, so you might+-- want to do something like+--+-- > import qualified Prednote.Pred as P+module Prednote.Prebuilt where++import qualified Prednote.Core as C+import Prednote.Format+import qualified Data.Tree as E+import qualified Data.Text as X+import Data.Text (Text)+import Data.Monoid+import Prelude hiding (and, or, not, filter, compare, any, all)+import qualified Prelude++-- # Predicate++-- | Builds predicates.+predicate+ :: Text+ -- ^ Static label++ -> (a -> Text)+ -- ^ Computes the dynamic label. Do not indicate whether the result+ -- is 'True' or 'False'; this is automatically done for you.++ -> (a -> Bool)+ -- ^ Predicate function++ -> C.Pred a++predicate r s f = rename r . speak s $ C.Pred (E.Node (const []) []) ev+ where+ ev a = E.Node (C.Output (f a) C.shown Nothing (const [])) []++-- | Always returns 'True' and is always visible.+true :: C.Pred a+true = predicate l (const l) (const True)+ where+ l = "always True"++-- | Always returns 'False' and is always visible.+false :: C.Pred a+false = predicate l (const l) (const False)+ where+ l = "always False"++-- | Returns the subject as is; is always visible.+same :: C.Pred Bool+same = predicate l (const l) id+ where+ l = "same as subject"++-- # Visibility++-- | Creates a 'C.Pred' with its visibility modified.+visibility+ :: (Bool -> C.Visible)+ -- ^ When applied to the 'C.result' of the 'C.Pred', this function+ -- returns the desired visibility.+ -> C.Pred a+ -> C.Pred a+visibility f (C.Pred s e) = C.Pred s e'+ where+ e' a = g (e a)+ g (E.Node n cs) = E.Node n { C.visible = f (C.result n) } cs++-- | Creates a 'C.Pred' that is always shown.+reveal :: C.Pred a -> C.Pred a+reveal = visibility (const C.shown)++-- | Creates a 'C.Pred' that is always hidden.+hide :: C.Pred a -> C.Pred a+hide = visibility (const C.hidden)++-- | Creates a 'C.Pred' that is shown only if its 'C.result' is+-- 'True'.+showTrue :: C.Pred a -> C.Pred a+showTrue = visibility (\b -> if b then C.shown else C.hidden)++-- | Creates a 'C.Pred' that is shown only if its 'C.result' is+-- 'False'.+showFalse :: C.Pred a -> C.Pred a+showFalse = visibility (\b -> if Prelude.not b then C.shown else C.hidden)++-- # Conjunction and disjunction, negation++-- | No child 'Pred' may be 'False'. An empty list of child 'Pred'+-- returns 'True'. Always visible.+all :: [C.Pred a] -> C.Pred a+all = speakShort . rename l . speak (const l) . C.all+ where+ l = "all"++-- | Creates 'all' 'Pred' that are always visible.+(&&&) :: C.Pred a -> C.Pred a -> C.Pred a+l &&& r = all [l, r]++infixr 3 &&&++-- | At least one child 'Pred' must be 'True'. An empty list of child+-- 'Pred' returns 'False'. Always visible.+any :: [C.Pred a] -> C.Pred a+any = speakShort . rename l . speak (const l) . C.any+ where+ l = "any"+++-- | Creates 'any' 'Pred' that are always visible.+(|||) :: C.Pred a -> C.Pred a -> C.Pred a+l ||| r = any [l, r]++infixr 2 |||++-- | Negation. Always visible.+not :: C.Pred a -> C.Pred a+not = rename l . speak (const l) . C.not+ where+ l = "not"++-- | No fanned-out item may be 'False'. An empty list of child items+-- returns 'True'.+fanAll :: (a -> [b]) -> C.Pred b -> C.Pred a+fanAll f = speakShort . rename l . speak (const l) . C.fanAll f+ where+ l = "fanout all"++++-- | At least one fanned-out item must be 'True'. An empty list of+-- child items returns 'False'.+fanAny :: (a -> [b]) -> C.Pred b -> C.Pred a+fanAny f = speakShort . rename l . speak (const l) . C.fanAny f+ where+ l = "fanout any"+++-- | At least the given number of child items must be 'True'.+fanAtLeast :: Int -> (a -> [b]) -> C.Pred b -> C.Pred a+fanAtLeast i f = speakShort . rename l . speak (const l)+ . C.fanAtLeast i f+ where+ l = "fanout - at least " <> X.pack (show i) <>+ " fanned-out subject(s) must be True"+
minimum-versions.txt view
@@ -1,7 +1,7 @@ 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+Tested as of: 2014-07-13 14:54:13.902743 UTC Path to compiler: ghc-7.4.1 Compiler description: 7.4.1 @@ -33,12 +33,10 @@ time-1.4 unix-2.5.1.0 -/home/massysett/prednote/sunlight-22866/db:- QuickCheck-2.6+/home/massysett/prednote/library/sunlight-25515/db: contravariant-0.2.0.1- prednote-0.22.0.2+ prednote-0.24.0.0 rainbow-0.14.0.0- random-1.0.1.1 split-0.2.2 terminfo-0.4.0.0 text-0.11.2.0
− prednote-test.hs
@@ -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
prednote.cabal view
@@ -1,6 +1,22 @@-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: 2014-07-13 10:54:10.054497 EDT+-- Cartel library version: 0.10.0.2+name: prednote+version: 0.24.0.0+cabal-version: >= 1.14+build-type: Simple+license: BSD3+license-file: LICENSE+copyright: Copyright 2013-2014 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 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 +26,41 @@ 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+ .+ tests are packaged separately in the prednote-tests package.+category: Data+tested-with: GHC == 7.4.1, GHC == 7.6.3, GHC == 7.8.2 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+ README.md+ , minimum-versions.txt+ , current-versions.txt+ , sunlight-test.hs+ , changelog source-repository head- type: git- location: git://github.com/massysett/prednote.git--library+ type: git+ location: git://github.com/massysett/prednote.git+ branch: master +Library exposed-modules:- Data.Prednote- , Data.Prednote.Predbox- , Data.Prednote.Expressions- , Data.Prednote.Expressions.Infix- , Data.Prednote.Expressions.RPN- , Data.Prednote.Test-- build-depends:- base >= 4.5.0.0 && < 5- , contravariant >= 0.2.0.1- , rainbow >=0.14.0.0 && < 0.15- , split >=0.2.2- , text >= 0.11.2.0-- ghc-options: -Wall- hs-source-dirs: lib--Test-Suite prednote-test- type: exitcode-stdio-1.0- main-is: prednote-test.hs- hs-source-dirs: . lib-+ Prednote+ , Prednote.Comparisons+ , Prednote.Core+ , Prednote.Expressions+ , Prednote.Expressions.Infix+ , Prednote.Expressions.RPN+ , Prednote.Format+ , Prednote.Prebuilt build-depends:- base >=4.5.0.0 && < 5- , contravariant >= 0.2.0.1- , QuickCheck >=2.6- , rainbow >=0.14.0.0 && < 0.15- , text >= 0.11.2.0-+ base ((> 4.5.0.0 || == 4.5.0.0) && < 5)+ , contravariant ((> 0.2.0.1 || == 0.2.0.1) && < 0.7)+ , rainbow ((> 0.14.0.0 || == 0.14.0.0) && < 0.15)+ , split ((> 0.2.2 || == 0.2.2) && < 0.3)+ , text ((> 0.11.2.0 || == 0.11.2.0) && < 1.2)+ , containers ((> 0.4.2.1 || == 0.4.2.1) && < 0.6)+ hs-source-dirs:+ lib+ ghc-options:+ -Wall+ default-language: Haskell2010
sunlight-test.hs view
@@ -9,7 +9,7 @@ , 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", [])]+ , tiTest = [] } main = runTests inputs