diff --git a/Data/Prednote/Expressions.hs b/Data/Prednote/Expressions.hs deleted file mode 100644 --- a/Data/Prednote/Expressions.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Handles parsing of both infix and RPN Pdct expressions. -module Data.Prednote.Expressions - ( ExprDesc(..) - , Error - , Token - , operand - , opAnd - , opOr - , opNot - , openParen - , closeParen - , parseExpression - ) where - -import Data.Either (partitionEithers) -import qualified Data.Text as X -import qualified Data.Prednote.Expressions.Infix as I -import qualified Data.Prednote.Expressions.RPN as R -import qualified Data.Prednote.Pdct as P -import qualified Control.Monad.Exception.Synchronous as Ex - --- | A single type for both RPN tokens and infix tokens. -newtype Token a = Token { unToken :: I.InfixToken a } -type Error = X.Text - --- | Creates Operands from Pdct. -operand :: P.Pdct a -> Token a -operand p = Token (I.TokRPN (R.TokOperand p)) - --- | The And operator -opAnd :: Token a -opAnd = Token (I.TokRPN (R.TokOperator R.OpAnd)) - --- | The Or operator -opOr :: Token a -opOr = Token (I.TokRPN (R.TokOperator R.OpOr)) - --- | The Not operator -opNot :: Token a -opNot = Token (I.TokRPN (R.TokOperator R.OpNot)) - --- | Open parentheses -openParen :: Token a -openParen = Token (I.TokParen I.Open) - --- | Close parentheses -closeParen :: Token a -closeParen = Token (I.TokParen I.Close) - --- | Is this an infix or RPN expression? -data ExprDesc - = Infix - | RPN - deriving (Eq, Show) - -toksToRPN :: [Token a] -> Maybe [R.RPNToken a] -toksToRPN toks - = let toEither t = case unToken t of - I.TokRPN tok -> Right tok - _ -> Left () - in case partitionEithers . map toEither $ toks of - ([], xs) -> return xs - _ -> Nothing - --- | Parses expressions. Fails if the expression is nonsensical in --- some way (for example, unbalanced parentheses, parentheses in an --- RPN expression, or multiple stack values remaining.) Works by first --- changing infix expressions to RPN ones. -parseExpression - :: ExprDesc - -> [Token a] - -> Ex.Exceptional Error (P.Pdct a) -parseExpression e toks = do - rpnToks <- case e of - Infix -> Ex.fromMaybe "unbalanced parentheses\n" - . I.createRPN - . map unToken - $ toks - RPN -> Ex.fromMaybe "parentheses in an RPN expression\n" - $ toksToRPN toks - R.parseRPN rpnToks diff --git a/Data/Prednote/Expressions/Infix.hs b/Data/Prednote/Expressions/Infix.hs deleted file mode 100644 --- a/Data/Prednote/Expressions/Infix.hs +++ /dev/null @@ -1,126 +0,0 @@ -module Data.Prednote.Expressions.Infix - ( InfixToken (..) - , Paren(..) - , createRPN - ) where - -import qualified Data.Prednote.Expressions.RPN as R -import qualified Data.Foldable as Fdbl - -data InfixToken a - = TokRPN (R.RPNToken a) - | TokParen Paren - -data Paren = Open | Close - --- | Values on the operator stack. -data OpStackVal - = StkOp R.Operator - | StkOpenParen - --- In the shunting yard algorithm, the output sequence is a queue. The --- first values to go into the output sequence are the first to be --- processed by the RPN parser. In this module, the output sequence is --- implemented as a list stack, which means it must be reversed upon --- output (this is done in the createRPN function.) - -processInfixToken - :: ([OpStackVal], [R.RPNToken a]) - -> InfixToken a - -> Maybe ([OpStackVal], [R.RPNToken a]) -processInfixToken (os, ts) t = case t of - TokRPN tok -> return $ processRPNToken (os, ts) tok - TokParen p -> processParen (os, ts) p - - --- | If the token is a binary operator A, then: --- --- If A is left associative, while there is an operator B of higher or --- equal precedence than A at the top of the stack, pop B off the --- stack and append it to the output. --- --- If A is right associative, while there is an operator B of higher --- precedence than A at the top of the stack, pop B off the stack and --- append it to the output. --- --- Push A onto the stack. --- --- If a token is an operand, append it to the postfix output. --- --- And has higher precedence than Or. -processRPNToken - :: ([OpStackVal], [R.RPNToken a]) - -> R.RPNToken a - -> ([OpStackVal], [R.RPNToken a]) -processRPNToken (os, ts) t = case t of - p@(R.TokOperand _) -> (os, p:ts) - R.TokOperator d -> case d of - R.OpNot -> (StkOp R.OpNot : os, ts) - R.OpAnd -> (StkOp R.OpAnd : os, ts) - R.OpOr -> - let (os', ts') = popper os ts - in (StkOp R.OpOr : os', ts') - --- | Pops operators from the operator stack and places then in the --- output queue, as long as there is an And operator on the top of the --- operator stack. -popper :: [OpStackVal] -> [R.RPNToken a] -> ([OpStackVal], [R.RPNToken a]) -popper os ts = case os of - [] -> (os, ts) - x:xs -> case x of - StkOp R.OpAnd -> - let os' = xs - ts' = R.TokOperator R.OpAnd : ts - in popper os' ts' - _ -> (os, ts) - --- | Pops operators off the operator stack and onto the output stack --- as long as the top of the operator stack is not an open --- parenthesis. When an open parenthesis is encountered, pop that too, --- but not onto the output stack. Fails if the stack has no open --- parentheses. -popThroughOpen - :: ([OpStackVal], [R.RPNToken a]) - -> Maybe ([OpStackVal], [R.RPNToken a]) -popThroughOpen (os, ts) = case os of - [] -> Nothing - v:vs -> case v of - StkOp op -> popThroughOpen (vs, R.TokOperator op : ts) - StkOpenParen -> return (vs, ts) - --- | Places an open parenthesis on the top of the operator stack. For --- Close parenthesis, pops operators off the operator stack through --- the next open parenthesis on the operator stack. -processParen - :: ([OpStackVal], [R.RPNToken a]) - -> Paren - -> Maybe ([OpStackVal], [R.RPNToken a]) -processParen (os, ts) p = case p of - Open -> Just (StkOpenParen : os, ts) - Close -> popThroughOpen (os, ts) - --- | Creates an RPN expression from an infix one. Fails only if there --- are mismatched parentheses. It is possible to create a nonsensical --- RPN expression; the RPN parser must catch this. -createRPN - :: Fdbl.Foldable f - => f (InfixToken a) - -- ^ The input tokens, with the beginning of the expression on the - -- left side of the sequence. - - -> Maybe [R.RPNToken a] - -- ^ The output sequence of tokens, with the beginning of the - -- expression on the left side of the list. -createRPN ts = do - (stack, toks) <- Fdbl.foldlM processInfixToken ([], []) ts - fmap reverse $ popRemainingOperators stack toks - --- | Pops remaining items off operator stack. Fails if there is an --- open paren left on the stack, as this indicates mismatched --- parenthesis. -popRemainingOperators :: [OpStackVal] -> [R.RPNToken a] -> Maybe [R.RPNToken a] -popRemainingOperators os ts = case os of - [] -> return ts - x:xs -> case x of - StkOp op -> popRemainingOperators xs (R.TokOperator op : ts) - StkOpenParen -> Nothing diff --git a/Data/Prednote/Expressions/RPN.hs b/Data/Prednote/Expressions/RPN.hs deleted file mode 100644 --- a/Data/Prednote/Expressions/RPN.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Postfix, or RPN, expression parsing. --- --- This module parses RPN expressions where the operands are --- predicates and the operators are one of @and@, @or@, or @not@, --- where @and@ and @or@ are binary and @not@ is unary. -module Data.Prednote.Expressions.RPN where - -import qualified Control.Monad.Exception.Synchronous as Ex -import qualified Data.Foldable as Fdbl -import qualified Data.Prednote.Pdct as P -import Data.Prednote.Pdct ((&&&), (|||)) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as X -import qualified System.Console.Rainbow as C - -type Error = Text - -data RPNToken a - = TokOperand (P.Pdct a) - | TokOperator Operator - -data Operator - = OpAnd - | OpOr - | OpNot - deriving Show - -pushOperand :: P.Pdct a -> [P.Pdct a] -> [P.Pdct a] -pushOperand p ts = p : ts - -pushOperator - :: Operator - -> [P.Pdct a] - -> Ex.Exceptional Error [P.Pdct a] -pushOperator o ts = case o of - OpAnd -> case ts of - x:y:zs -> return $ (y &&& x) : zs - _ -> Ex.throw $ err "and" - OpOr -> case ts of - x:y:zs -> return $ (y ||| x) : zs - _ -> Ex.throw $ err "or" - OpNot -> case ts of - x:zs -> return $ P.not x : zs - _ -> Ex.throw $ err "not" - where - err x = "insufficient operands to apply \"" <> x - <> "\" operator\n" - -pushToken - :: [P.Pdct a] - -> RPNToken a - -> Ex.Exceptional Error [P.Pdct a] -pushToken ts t = case t of - TokOperand p -> return $ pushOperand p ts - TokOperator o -> pushOperator o ts - - --- | Parses an RPN expression and returns the resulting Pdct. Fails if --- there are no operands left on the stack or if there are multiple --- operands left on the stack; the stack must contain exactly one --- operand in order to succeed. -parseRPN - :: Fdbl.Foldable f - => f (RPNToken a) - -> Ex.Exceptional Error (P.Pdct a) -parseRPN ts = do - trees <- Fdbl.foldlM pushToken [] ts - case trees of - [] -> Ex.throw $ "bad expression: no operands left on the stack\n" - x:[] -> return x - xs -> Ex.throw - $ "bad expression: multiple operands left on the stack:\n" - <> ( X.concat - . map C.chunkText - . concatMap (P.showPdct 4 0) - $ xs ) - diff --git a/Data/Prednote/Pdct.hs b/Data/Prednote/Pdct.hs deleted file mode 100644 --- a/Data/Prednote/Pdct.hs +++ /dev/null @@ -1,609 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Trees of predicates. --- --- Exports names which conflict with Prelude names, so you probably --- want to import this module qualified. - -module Data.Prednote.Pdct - ( -- * The Pdct tree - Label - , Pdct(..) - , Node(..) - , rename - , always - , never - - -- * Creating operands - , operand - - -- * Creating Pdct from other Pdct - , and - , or - , not - , neverFalse - , neverTrue - , (&&&) - , (|||) - , boxPdct - , boxNode - - -- * Showing and evaluating Pdct - , Level - , IndentAmt - , ShowDiscards - , showPdct - , eval - , evaluate - , filter - - -- * Helpers for building common Pdct - -- ** Non-overloaded - , compareBy - , greaterBy - , lessBy - , equalBy - , greaterEqBy - , lessEqBy - , notEqBy - , parseComparerBy - - -- ** Overloaded - , compare - , greater - , less - , equal - , greaterEq - , lessEq - , notEq - , parseComparer - - ) where - -import Control.Applicative ((<*>)) -import Data.Maybe (fromMaybe, isJust, catMaybes) -import Data.Text (Text) -import qualified Data.Text as X -import Data.Monoid ((<>), mconcat, mempty) -import qualified System.Console.Rainbow as R -import System.Console.Rainbow ((+.+)) -import Prelude hiding (not, and, or, compare, filter) -import qualified Prelude - -type Label = Text - --- | A tree of predicates. -data Pdct a = Pdct Label (Node a) - -instance Show (Pdct a) where - show _ = "predicate" - --- | Renames the top level of the Pdct. The function you pass will be --- applied to the old name. -rename :: (Text -> Text) -> Pdct a -> Pdct a -rename f (Pdct l n) = Pdct (f l) n - -data Node a - = And [Pdct a] - -- ^ None of the Pdct in list may be Just False. An empty list or - -- list with only Nothing is Just True. - - | Or [Pdct a] - -- ^ At least one of the Pdct in the list must be Just True. An - -- empty list or list with only Nothing is Just False. - - | Not (Pdct a) - -- ^ Just True is Just False and vice versa; Nothing remains Nothing. - - | NeverFalse (Pdct a) - -- ^ Just True if the child is Just True; Nothing otherwise. - - | NeverTrue (Pdct a) - -- ^ Just False if the child is Just False; Nothing otherwise. - - | Operand (a -> Maybe Bool) - -- ^ An operand may return Just True or Just False to indicate - -- success or failure. It may also return Nothing to indicate a - -- discard. - --- | Given a function that un-boxes values of type b, changes a Node --- from type a to type b. -boxNode - :: (b -> a) - -> Node a - -> Node b -boxNode f n = case n of - And ls -> And $ map (boxPdct f) ls - Or ls -> Or $ map (boxPdct f) ls - Not o -> Not $ boxPdct f o - NeverFalse o -> NeverFalse $ boxPdct f o - NeverTrue o -> NeverTrue $ boxPdct f o - Operand g -> Operand $ \b -> g (f b) - - --- | Given a function that un-boxes values of type b, changes a Pdct --- from type a to type b. -boxPdct - :: (b -> a) - -> Pdct a - -> Pdct b -boxPdct f (Pdct l n) = Pdct l $ boxNode f n - -and :: [Pdct a] -> Pdct a -and = Pdct "and" . And - -or :: [Pdct a] -> Pdct a -or = Pdct "or" . Or - -not :: Pdct a -> Pdct a -not = Pdct "not" . Not - --- | Creates a new operand. The Pdct is Just True or Just False, never --- Nothing. -operand :: Text -> (a -> Bool) -> Pdct a -operand t = Pdct t . Operand . fmap Just - --- | Turns an existing Pdct to one that never says False. If the --- underlying predicate returns Just True, the new Pdct also returns --- Just True. Otherwise, the Pdct returns Nothing. -neverFalse :: Pdct a -> Pdct a -neverFalse = Pdct "never False" . NeverFalse - --- | Turns an existing Pdct to one that never says True. If the --- underlying predicate returns Just False, the new Pdct also returns --- Just False. Otherwise, the Pdct returns Nothing. -neverTrue :: Pdct a -> Pdct a -neverTrue = Pdct "never True" . NeverTrue - - --- | Returns a tree that is always True. -always :: Pdct a -always = Pdct "always True" (Operand (const (Just True))) - --- | Returns a tree that is always False. -never :: Pdct a -never = Pdct "always False" (Operand (const (Just False))) - --- | Forms a Pdct using 'and'. -(&&&) :: Pdct a -> Pdct a -> Pdct a -(&&&) x y = Pdct "and" (And [x, y]) -infixr 3 &&& - --- | Forms a Pdct using 'or'. -(|||) :: Pdct a -> Pdct a -> Pdct a -(|||) x y = Pdct "or" (Or [x, y]) -infixr 2 ||| - --- | How many levels of indentation to use. Typically you will start --- this at zero. It is incremented by one for each level as functions --- descend through the tree. -type Level = Int - --- | The number of spaces to use for each level of indentation. -type IndentAmt = Int - --- | Indents text, and adds a newline to the end. -indent :: IndentAmt -> Level -> [R.Chunk] -> [R.Chunk] -indent amt lvl cs = idt : (cs ++ [nl]) - where - idt = R.plain (X.replicate (lvl * amt) " ") - nl = R.plain (X.singleton '\n') - --- | Shows a Pdct tree without evaluating it. -showPdct :: IndentAmt -> Level -> Pdct a -> [R.Chunk] -showPdct amt lvl (Pdct l pd) = case pd of - And ls -> indent amt lvl [R.plain l] - <> mconcat (map (showPdct amt (lvl + 1)) ls) - Or ls -> indent amt lvl [R.plain l] - <> mconcat (map (showPdct amt (lvl + 1)) ls) - Not t -> indent amt lvl [R.plain l] - <> showPdct amt (lvl + 1) t - NeverFalse t -> indent amt lvl [R.plain l] - <> showPdct amt (lvl + 1) t - NeverTrue t -> indent amt lvl [R.plain l] - <> showPdct amt (lvl + 1) t - Operand _ -> indent amt lvl [R.plain l] - - -labelBool :: Text -> Maybe Bool -> [R.Chunk] -labelBool t b = [open, trueFalse, close, blank, txt] - where - trueFalse = case b of - Nothing -> R.plain "discard" +.+ R.f_yellow - Just bl -> if bl - then R.plain "TRUE" +.+ R.f_green - else R.plain "FALSE" +.+ R.f_red - open = R.plain "[" - close = R.plain "]" - blank = R.plain (X.replicate blankLen " ") - blankLen = X.length "discard" - - X.length (R.chunkText trueFalse) + 1 - txt = R.plain t - -type ShowDiscards = Bool - --- | Evaluates a Pdct. -eval :: Pdct a -> a -> Maybe Bool -eval (Pdct _ n) a = case n of - And ps -> Just . Prelude.and . catMaybes $ [flip eval a] <*> ps - Or ps -> Just . Prelude.or . catMaybes $ [flip eval a] <*> ps - Not p -> fmap Prelude.not $ eval p a - NeverFalse p -> case eval p a of - Nothing -> Nothing - Just b -> if Prelude.not b then Nothing else Just b - NeverTrue p -> case eval p a of - Nothing -> Nothing - Just b -> if b then Nothing else Just b - Operand f -> f a - --- | Verbosely evaluates a Pdct. -evaluate - :: IndentAmt - -- ^ Indent each level by this many spaces. - - -> ShowDiscards - -- ^ If True, show discarded test results; otherwise, hide - -- them. - - -> a - -- ^ The subject to evaluate - - -> Level - -- ^ How many levels deep in the tree we are. Typically you will - -- start at level 0. This determines the level of indentation. - - -> Pdct a - - -> (Maybe Bool, [R.Chunk]) -evaluate i sd a lvl (Pdct l pd) = case pd of - - And ps -> let (resBool, resTxt) = evalAnd i sd a (lvl + 1) ps - txt = indent i lvl (labelBool l (Just resBool)) - <> resTxt - in (Just resBool, txt) - - Or ps -> let (resBool, resTxt) = evalOr i sd a (lvl + 1) ps - txt = indent i lvl (labelBool l (Just resBool)) - <> resTxt - in (Just resBool, txt) - - Not p -> let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p - thisMayBool = fmap Prelude.not childMayBool - thisTxt = indent i lvl (labelBool l thisMayBool) - txt = if sd || isJust thisMayBool - then thisTxt <> childTxt else mempty - in (thisMayBool, txt) - - NeverFalse p -> - let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p - thisMayBool = case childMayBool of - Nothing -> Nothing - Just b -> if Prelude.not b then Nothing else Just b - thisTxt = indent i lvl (labelBool l thisMayBool) - txt = if sd || isJust thisMayBool - then thisTxt <> childTxt else mempty - in (thisMayBool, txt) - - NeverTrue p -> - let (childMayBool, childTxt) = evaluate i sd a (lvl + 1) p - thisMayBool = case childMayBool of - Nothing -> Nothing - Just b -> if b then Nothing else Just b - thisTxt = indent i lvl (labelBool l thisMayBool) - txt = if sd || isJust thisMayBool - then thisTxt <> childTxt else mempty - in (thisMayBool, txt) - - Operand p -> let res = p a - txt = indent i lvl (labelBool l res) - in (res, if sd || isJust res then txt else mempty) - -evalAnd :: IndentAmt -> ShowDiscards -> a - -> Level -> [Pdct a] -> (Bool, [R.Chunk]) -evalAnd i sd a l ts = (Prelude.not foundFalse, txt) - where - (foundFalse, txt) = go ts (False, mempty) - go [] p = p - go (x:xs) (fndFalse, acc) = - if fndFalse - then (fndFalse, acc <> indent i l - [R.plain "(short circuit)"]) - else let (res, cTxt) = evaluate i sd a l x - fndFalse' = maybe False Prelude.not res - in go xs (fndFalse', acc <> cTxt) - -evalOr :: IndentAmt -> ShowDiscards -> a - -> Level -> [Pdct a] -> (Bool, [R.Chunk]) -evalOr i sd a l ts = (foundTrue, txt) - where - (foundTrue, txt) = go ts (False, mempty) - go [] p = p - go (x:xs) (fnd, acc) = - if fnd - then (fnd, acc <> indent i l - [R.plain "(short circuit)"]) - else let (res, cTxt) = evaluate i sd a l x - fnd' = fromMaybe False res - in go xs (fnd', acc <> cTxt) - --- | Filters a list of items by including only the ones for which the --- Pdct returns Just True. Also, renames each top-level Pdct so that --- the textual results include a description of the item being --- evaluated. -filter - :: IndentAmt - -- ^ Indent each level by this many spaces. - - -> ShowDiscards - -- ^ If True, show discarded test results; otherwise, hide - -- them. - - -> Level - -- ^ How many levels deep in the tree we are. Typically you will - -- start at level 0. This determines the level of indentation. - - -> (a -> Text) - -- ^ How to show each item. This is used to add a description of - -- each item to the verbose output. This Text should be a one-line - -- description, without any newlines. - - -> Pdct a - -- ^ Use this Pdct to filter - - -> [a] - -- ^ The list to filter - - -> ([a], [R.Chunk]) - -- ^ The results of the filtering, and the verbose output indicating - -- what was kept and discarded and why - -filter ident sd lvl swr pdct items = - let pds = map mkPd items - mkPd a = rename (\x -> mconcat [x, " - ", swr a]) pdct - results = zipWith mkResult pds items - mkResult p i = (evaluate ident sd i lvl p, i) - folder ((maybeBool, cks), i) (as, cksOld) = (as', cks ++ cksOld) - where - as' = if fromMaybe False maybeBool - then i:as - else as - in foldr folder ([], []) results - --- --- Helpers --- - --- | Build a Pdct that compares items. -compareBy - :: Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare an item against the right hand side. Return LT - -- if the item is less than the right hand side; GT if greater; EQ - -- if equal to the right hand side. - - -> Ordering - -- ^ When subjects are compared, this ordering must be the result in - -- order for the Pdct to be Just True; otherwise it is Just - -- False. The subject will be on the left hand side. - - -> Pdct a - -compareBy itemDesc typeDesc cmp ord = Pdct l (Operand f) - where - l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc - cmpDesc = case ord of - LT -> "less than" - GT -> "greater than" - EQ -> "equal to" - f subj = Just $ cmp subj == ord - --- | Overloaded version of 'compareBy'. -compare - :: (Show a, Ord a) - => Text - -- ^ Description of the type of thing being matched - - -> Ordering - -- ^ When subjects are compared, this ordering must be the result in - -- order for the Pdct to be Just True; otherwise it is Just - -- False. The subject will be on the left hand side. - - -> a - -- ^ The right hand side of the comparison. - - -> Pdct a -compare typeDesc ord a = compareBy itemDesc typeDesc cmp ord - where - itemDesc = X.pack . show $ a - cmp item = Prelude.compare item a - -greater - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> a - -- ^ The right hand side of the comparison. - - -> Pdct a -greater d = compare d GT - -less - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> a - -- ^ The right hand side of the comparison. - - -> Pdct a -less d = compare d LT - -equal - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> a - -- ^ The right hand side of the comparison. - - -> Pdct a -equal d = compare d EQ - -greaterEq - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> a - -- ^ The right hand side of the comparison. - - -> Pdct a -greaterEq d a = greater d a ||| equal d a - -lessEq - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> a - -- ^ The right hand side of the comparison. - - -> Pdct a -lessEq d a = less d a ||| equal d a - -notEq - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> a - -- ^ The right hand side of the comparison. - - -> Pdct a -notEq d = not . equal d - -greaterBy - :: Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Pdct a -greaterBy iD tD cmp = compareBy iD tD cmp GT - -lessBy - :: Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Pdct a -lessBy iD tD cmp = compareBy iD tD cmp LT - -equalBy - :: Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Pdct a -equalBy iD tD cmp = compareBy iD tD cmp EQ - -greaterEqBy - :: Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Pdct a -greaterEqBy iD tD cmp = - greaterBy iD tD cmp ||| equalBy iD tD cmp - -lessEqBy - :: Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Pdct a -lessEqBy iD tD cmp = - lessBy iD tD cmp ||| equalBy iD tD cmp - -notEqBy - :: Text - -- ^ How to show the item being compared; used to describe the Pdct - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Pdct a -notEqBy iD tD cmp = - not $ equalBy iD tD cmp - --- --- Comparer parsers --- - --- | Parses a string to find the correct comparer; returns the correct --- function to build a Pdct. -parseComparerBy - :: Text - -- ^ The string with the comparer to be parsed - -> Maybe (Text -> Text -> (a -> Ordering) -> Pdct a) -parseComparerBy t - | t == ">" = Just greaterBy - | t == "<" = Just lessBy - | t == "=" = Just equalBy - | t == "==" = Just equalBy - | t == ">=" = Just greaterEqBy - | t == "<=" = Just lessEqBy - | t == "/=" = Just notEqBy - | t == "!=" = Just notEqBy - | otherwise = Nothing - --- | Parses a string to find the correct comparer; returns the correct --- function to build a Pdct. -parseComparer - :: (Show a, Ord a) - => Text - -- ^ The string with the comparer to be parsed - -> Maybe (Text -> a -> Pdct a) -parseComparer t - | t == ">" = Just greater - | t == "<" = Just less - | t == "=" = Just equal - | t == "==" = Just equal - | t == ">=" = Just greaterEq - | t == "<=" = Just lessEq - | t == "/=" = Just notEq - | t == "!=" = Just notEq - | otherwise = Nothing diff --git a/Data/Prednote/TestTree.hs b/Data/Prednote/TestTree.hs deleted file mode 100644 --- a/Data/Prednote/TestTree.hs +++ /dev/null @@ -1,461 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Helps you build a tree of tests that run against a series of --- items. This is best illustrated with an example. --- --- Let's say that you have a list of Int. You want to make sure that --- every Int in the list is odd and that every Int is greater than --- zero. You also want to make sure that at least 5 Ints in the list --- are greater than 20. --- --- 'Pdct' from "Data.Prednote.Pdct" will help you, but only so much: a --- 'Pdct' can test individual Int, but by itself it will not help you --- run a check against a whole list of Int. Of course you can build --- such a test fairly easily with 'any' and 'all', but what if you --- want to view the results of the tests verbosely? That's where this --- module comes in. --- --- > {-# LANGUAGE OverloadedStrings #-} --- > import System.Console.Rainbow --- > import Data.Prednote.TestTree --- > import Data.Prednote.Pdct --- > --- > isOdd :: Pdct Int --- > isOdd = operand "is odd" odd --- > --- > greaterThan0 :: Pdct Int --- > greaterThan0 = operand "greater than zero" (> 0) --- > --- > greaterThan20 :: Pdct Int --- > greaterThan20 = operand "greater than 20" (> 20) --- > --- > myOpts :: TestOpts Int --- > myOpts = TestOpts --- > { tIndentAmt = 2 --- > , tPassVerbosity = TrueSubjects --- > , tFailVerbosity = TrueSubjects --- > , tGroupPred = const True --- > , tTestPred = const True --- > , tShowSkippedTests = True --- > , tGroupVerbosity = AllGroups --- > , tSubjects = mySubjects --- > , tStopOnFail = False --- > } --- > --- > mySubjects :: [Int] --- > mySubjects = [2, 4, 6, 8, 10, 18, 19, 20, 21, 22, 24, 26] --- > --- > tests :: [TestTree Int] --- > tests = [ isOdd, greaterThan0, greaterThan20 ] --- > --- > main :: IO () --- > main = do --- > let (cks, passed, failed) = runTests myOpts 0 tests --- > t <- termFromEnv --- > printChunks t cks --- > putStrLn $ "number of tests passed: " ++ show passed --- > putStrLn $ "number of tests failed: " ++ show failed -module Data.Prednote.TestTree - ( - -- * The TestTree - Name - , TestFunc - , TestTree (..) - , Payload (..) - , test - - -- * Tests - , eachSubjectMustBeTrue - , nSubjectsMustBeTrue - - -- * Grouping tests - , group - - -- * Simple test runners - , Verbosity(..) - , GroupVerbosity (..) - , Pt.Level - , PassCount - , FailCount - , runTests - - -- * Showing the test tree - , showTestTree - - -- * Tree evaluator - , TestOpts (..) - , ShortCircuit - , Pass - , evalTree - - ) where - -import Data.Either (rights) -import Data.Maybe (isJust) -import Data.List (unfoldr) -import Data.Monoid ((<>)) -import qualified Data.Text as X -import Data.Text (Text) -import qualified Data.List.Split as Sp - -import qualified System.Console.Rainbow as R -import System.Console.Rainbow ((+.+)) -import qualified Data.Prednote.Pdct as Pt - --- --- Types --- - -type Pass = Bool - --- | The name of a test or of a group. -type Name = Text - --- | A tree of tests. -data TestTree a = TestTree Name (Payload a) - -data Payload a - = Group [TestTree a] - | Test (TestFunc a) - --- | A test is a function of this type. The function must make chunks --- in a manner that respects the applicable verbosity. -type TestFunc a - = Pt.IndentAmt - -> Verbosity - -- ^ Use this verbosity for tests that pass - - -> Verbosity - -- ^ Use this verbosity for tests that fail - - -> [a] - -> Pt.Level - -> (Pass, [R.Chunk]) - - --- | Creates groups of tests. -group :: Name -> [TestTree a] -> TestTree a -group n = TestTree n . Group - --- | Creates tests. -test :: Name -> TestFunc a -> TestTree a -test n = TestTree n . Test - --- | How verbose to be when reporting the results of tests. It would --- be possible to have many more knobs to control this behavior; this --- implementation is a compromise and hopefully provides enough --- verbosity settings without being too complex. -data Verbosity - - = Silent - -- ^ Show nothing at all - - | PassFail - -- ^ Show only whether the test passed or failed - - | FalseSubjects - -- ^ Show subjects that are False. In addition, shows all evaluation - -- steps that led to the subject being False; however, does not show - -- discarded evaluation steps. Does not show True subjects at all. - - | TrueSubjects - -- ^ Show subjects that are True. (This is cumulative, so False - -- subjects are shown too, as they would be using 'FalseSubjects'.) - -- Shows all evaluation steps that led to the subject being True; - -- however, does not show discarded evaluation steps. - - | Discards - -- ^ Shows discarded subjects. Cumulative, so also does what - -- 'FalseSubjects' and 'TrueSubjects' do. Also shows all discarded - -- evaluation steps for all subjects. - - deriving (Eq, Ord, Show) - --- --- Helper functions --- - - --- | Determines whether to show a subject, and shows it. -showSubject - :: (a -> X.Text) - -> Verbosity - -> Pt.IndentAmt - -> Pt.Level - -> Pt.Pdct a - -> (a, Maybe Bool) - -> [R.Chunk] -showSubject swr v i l p (s, b) = - let (showSubj, showDisc) = isSubjectAndDiscardsShown v b - renamer txt = X.concat [swr s, " - ", txt] - renamed = Pt.rename renamer p - in if showSubj - then snd $ Pt.evaluate i showDisc s l renamed - else [] - --- | Given a Verbosity and a Maybe Boolean indicating whether a --- subject is True, False, or a discard, returns whether to show the --- subject and whether to show the discards contained within the --- subject. -isSubjectAndDiscardsShown :: Verbosity -> Maybe Bool -> (Bool, Bool) -isSubjectAndDiscardsShown v b = case v of - Silent -> (False, False) - PassFail -> (False, False) - FalseSubjects -> (not . isTrue $ b, False) - TrueSubjects -> (isJust b, False) - Discards -> (True, True) - - -showTestTitle :: Pt.IndentAmt -> Pt.Level -> Name -> Pass -> [R.Chunk] -showTestTitle i l n p = [idt, open, passFail, close, blank, txt, nl] - where - idt = R.plain (X.replicate (i * l) " ") - nl = R.plain "\n" - passFail = - if p - then R.plain "PASS" +.+ R.f_green - else R.plain "FAIL" +.+ R.f_red - open = R.plain "[" - close = R.plain "]" - blank = R.plain (X.singleton ' ') - txt = R.plain n - -isTrue :: Maybe Bool -> Bool -isTrue = maybe False id - --- --- Tests --- - --- | Passes if every subject is True. -eachSubjectMustBeTrue - :: Name - -> (a -> Text) - -> Pt.Pdct a - -> TestTree a -eachSubjectMustBeTrue n swr p = TestTree n (Test tf) - where - tf i pv fv as lvl = (pass, cks) - where - rslts = zip as (map (Pt.eval p) as) - pass = all (isTrue . snd) rslts - v = if pass then pv else fv - cks = tit ++ subjectChunks - tit = if v == Silent then [] else showTestTitle i lvl n pass - subjectChunks = - concatMap (showSubject swr v i (lvl + 1) p) rslts - --- | Passes if at least n subjects are True. -nSubjectsMustBeTrue - :: Name - -> (a -> X.Text) - -> Int - -> Pt.Pdct a - -> TestTree a -nSubjectsMustBeTrue n swr count p = TestTree n (Test tf) - where - tf idnt pv fv as l = (pass, cks) - where - pd (_, res) = isTrue res - resultList = take count - . Sp.split ( Sp.keepDelimsR - (Sp.dropFinalBlank . Sp.whenElt $ pd)) - $ zip as (map (Pt.eval p) as) - pass = length resultList >= count - v = if pass then pv else fv - cks = tit ++ subjectChunks - tit = if v == Silent then [] else showTestTitle idnt l n pass - subjectChunks = - concatMap (showSubject swr v idnt (l + 1) p) - . concat $ resultList - -indent :: Pt.IndentAmt -> Pt.Level -> Text -> R.Chunk -indent amt lvl t = R.plain txt - where - txt = X.concat [spaces, t, "\n"] - spaces = X.replicate (amt * lvl) " " - -skip :: Text -> Pt.IndentAmt -> Pt.Level -> Text -> [R.Chunk] -skip lbl amt lvl t = - [ R.plain (X.replicate (amt * lvl) " ") - , R.plain "[" - , R.plain ("skip " <> lbl) +.+ R.f_yellow - , R.plain "] " - , R.plain t - , R.plain "\n" - ] - --- | Shows a tree, without evaluating it. -showTestTree - :: Pt.IndentAmt - -> Pt.Level - -> TestTree a - -> [R.Chunk] -showTestTree amt l (TestTree n p) = indent amt l n : children - where - children = case p of - Group ts -> concatMap (showTestTree amt l) ts - Test _ -> [] - - --- | Options for running tests. -data TestOpts a = TestOpts - - { tIndentAmt :: Int - -- ^ Indent each level by this many spaces - - , tPassVerbosity :: Verbosity - -- ^ Use this verbosity for tests that pass - - , tFailVerbosity :: Verbosity - -- ^ Use this verbosity for tests that fail - - , tGroupPred :: Name -> Bool - -- ^ Groups are run only if this predicate returns True. - - , tTestPred :: Name -> Bool - -- ^ Tests are run only if this predicate returns True. - - , tShowSkippedTests :: Bool - -- ^ Some tests might be skipped; see 'tTestPred'. This controls - -- whether you want to see a notification of tests that were - -- skipped. (Does not affect skipped groups; see 'tGroupVerbosity' - -- for that.) - - , tGroupVerbosity :: GroupVerbosity - -- ^ Show group names? Even if you do not show the names of - -- groups, tests within the group will still be indented. - - , tSubjects :: [a] - -- ^ The subjects to test - - , tStopOnFail :: Bool - -- ^ If True, then tests will stop running immediately after a - -- single test fails. If False, all tests are always run. - } - - --- | True if the tree returned a result without completely evaluating --- all parts of the tree. This can occur if 'tStopOnFail' is True and --- one of the tests in the tree failed. -type ShortCircuit = Bool - --- | Evaluates a tree. This function is the basis of 'runTests', which --- is typically a bit easier to use. -evalTree - - :: TestOpts a - -- ^ Most options - - -> Pt.Level - -- ^ The tree will indented by this many levels; typically you will - -- want to start this at 0. - - -> TestTree a - - -> (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])]) - -- ^ The first element of the tuple is True if the tree was not - -- fully evaluated. This can happen if 'tStopOnFail' is True and - -- one of the tests in the tree failed. The second element of the - -- tuple is a list of Either; each element of the list will be a - -- Left if that component of the tree was not a test, or a Right if - -- that element was a test. The Right will contain a tuple, where - -- the first element indicates whether the test passed or failed, - -- and the second element is the list of Chunk. - -evalTree ee l (TestTree n p) = case p of - Group ts -> evalGroup ee n l ts - Test f -> evalTest ee n l f - -evalGroup - :: TestOpts a - -> Name - -> Pt.Level - -> [TestTree a] - -> (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])]) -evalGroup ee n l ts = if tGroupPred ee n - then let ls = unfoldr (unfoldList ee l) (False, ts) - stop = any not . map fst $ ls - rslts = concat . map snd $ ls - groupNm = if tGroupVerbosity ee /= NoGroups - then indent (tIndentAmt ee) l n - else R.plain "" - in (stop, Left [groupNm] : rslts) - else let groupNm = if tGroupVerbosity ee == AllGroups - then skip "group" (tIndentAmt ee) l n - else [R.plain ""] - in (False, [Left groupNm]) - - -evalTest - :: TestOpts a - -> Name - -> Pt.Level - -> TestFunc a - -> (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])]) -evalTest ee n l tf = if tTestPred ee n - then (not p, [Right (p, cs)]) - else (False, skipped) - where - (p, cs) = tf (tIndentAmt ee) (tPassVerbosity ee) - (tFailVerbosity ee) (tSubjects ee) l - skipped = if tShowSkippedTests ee - then [Left $ skip "test" (tIndentAmt ee) l n] - else [] - - --- --- Running a group of tests --- - -type PassCount = Int -type FailCount = Int - --- | How verbose to be when showing names of groups. -data GroupVerbosity - - = NoGroups - -- ^ Show no group names at all. However, groups will still be - -- indented. - - | ActiveGroups - -- ^ Show groups that are not skipped. - - | AllGroups - -- ^ Show all groups, and indicate which groups are skipped. - deriving (Eq, Ord, Show) - - --- | Runs each test in a list of tests (though each test might not run --- if 'tStopOnFail' is True.) Reports on how many passed and how many --- failed. (if 'tStopOnFail' is True, the FailCount will never exceed --- 1.) -runTests - :: TestOpts a - -> Pt.Level - -> [TestTree a] - -> ([R.Chunk], PassCount, FailCount) -runTests ee l ts = - let ls = unfoldr (unfoldList ee l) (False, ts) - testRs = rights . concatMap snd $ ls - passed = length . filter id . map fst $ testRs - failed = length . filter (not . id) . map fst $ testRs - cks = concat . map (either id snd) . concatMap snd $ ls - in (cks, passed, failed) - -unfoldList - :: TestOpts a - -> Pt.Level - -> (ShortCircuit, [TestTree a]) - -> Maybe ( (ShortCircuit, [Either [R.Chunk] (Pass, [R.Chunk])]) - , (ShortCircuit, [TestTree a])) -unfoldList ee l (seenFalse, is) = - if seenFalse && tStopOnFail ee - then Nothing - else case is of - [] -> Nothing - t:xs -> - let (short, results) = evalTree ee l t - in Just ((short, results), (short, xs)) - - diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013, Omari Norman +Copyright (c) 2013-2015, Omari Norman All rights reserved. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,43 @@ +# prednote + +prednote helps you build a tree of predicates that you can apply to +a list of items. It was written for Penny: + +http://www.github.com/massysett/penny + +but I also find it useful for dapi: + +http://www.github.com/massysett/dapi + +and so you might find it useful too. + +prednote is on Github: + +http://www.github.com/massysett/prednote + +and Hackage: + +http://hackage.haskell.org/package/prednote + +## Test results + +You can view the results of building and testing on Travis by clicking +the button below: + +[![Build Status](https://travis-ci.org/massysett/prednote.svg?branch=master)](https://travis-ci.org/massysett/prednote) + +If you have trouble building prednote due to dependency issues, try +looking at the previous test results, as they will show you package +versions that were used to build prednote successfully. + +## Something similar + +See also rematch: + +http://hackage.haskell.org/package/rematch + +which is apparently based on a Java library called hamcrest. + +## License + +prednote is licensed under the BSD license; see the LICENSE file. diff --git a/changelog b/changelog new file mode 100644 --- /dev/null +++ b/changelog @@ -0,0 +1,25 @@ +0.28.0.2 + + * Documentation fixes. + +0.28.0.0 + * Completely new API and internals; is simpler and allows + for predicates on sum types. + +0.24.0.4 + + * Dependency bumps. + +0.24.0.2 + + * added wrap function. + +0.24.0.0 + + * complete change in API and internals. + +0.22.0.2 + + * updates for new Rainbow API + + * test with GHC 7.8.2 diff --git a/genCabal.hs b/genCabal.hs new file mode 100644 --- /dev/null +++ b/genCabal.hs @@ -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]) diff --git a/lib/Prednote.hs b/lib/Prednote.hs new file mode 100644 --- /dev/null +++ b/lib/Prednote.hs @@ -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 diff --git a/lib/Prednote/Comparisons.hs b/lib/Prednote/Comparisons.hs new file mode 100644 --- /dev/null +++ b/lib/Prednote/Comparisons.hs @@ -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 + diff --git a/lib/Prednote/Core.hs b/lib/Prednote/Core.hs new file mode 100644 --- /dev/null +++ b/lib/Prednote/Core.hs @@ -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 + diff --git a/lib/Prednote/Expressions.hs b/lib/Prednote/Expressions.hs new file mode 100644 --- /dev/null +++ b/lib/Prednote/Expressions.hs @@ -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 diff --git a/lib/Prednote/Expressions/Infix.hs b/lib/Prednote/Expressions/Infix.hs new file mode 100644 --- /dev/null +++ b/lib/Prednote/Expressions/Infix.hs @@ -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 diff --git a/lib/Prednote/Expressions/RPN.hs b/lib/Prednote/Expressions/RPN.hs new file mode 100644 --- /dev/null +++ b/lib/Prednote/Expressions/RPN.hs @@ -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 + diff --git a/prednote.cabal b/prednote.cabal --- a/prednote.cabal +++ b/prednote.cabal @@ -1,6 +1,24 @@ -name: prednote -version: 0.6.0.0 -synopsis: Build and evaluate trees of predicates +-- This Cabal file generated using the Cartel library. +-- Cartel is available at: +-- http://www.github.com/massysett/cartel +-- +-- Script name used to generate: genCabal.hs +-- Generated on: 2015-09-09 21:57:21.988823 EDT +-- Cartel library version: 0.14.2.6 + +name: prednote +version: 0.36.0.4 +cabal-version: >= 1.18 +license: BSD3 +license-file: LICENSE +build-type: Simple +copyright: Copyright 2013-2015 Omari Norman +author: Omari Norman +maintainer: omari@smileystation.com +stability: Experimental +homepage: http://www.github.com/massysett/prednote +bug-reports: http://www.github.com/massysett/prednote/issues +synopsis: Evaluate and display trees of predicates description: Build and evaluate trees of predicates. For example, you might build a predicate of the type Int -> Bool. You do this by assembling @@ -10,35 +28,112 @@ prednote also provides modules to test several subjects against a given predicate, and to parse infix or RPN expressions into a tree of predicates. - -homepage: http://github.com/massysett/prednote -license: BSD3 -license-file: LICENSE -author: Omari Norman -maintainer: omari@smileystation.com -copyright: 2013 Omari Norman -category: Data -build-type: Simple -cabal-version: >=1.8 - -source-repository head - type: git - location: git://github.com/massysett/prednote.git - -library +category: Data +extra-source-files: + README.md + changelog + genCabal.hs +Library exposed-modules: - Data.Prednote.Pdct - , Data.Prednote.Expressions - , Data.Prednote.Expressions.Infix - , Data.Prednote.Expressions.RPN - , Data.Prednote.TestTree + Prednote + Prednote.Comparisons + Prednote.Core + Prednote.Expressions + Prednote.Expressions.Infix + Prednote.Expressions.RPN + build-depends: + base >= 4.7 && < 5 + , rainbow >= 0.26 + , split >= 0.2.2 + , text >= 0.11.2.0 + , containers >= 0.4.2.1 + , contravariant >= 1.2 + , transformers >= 0.3.0.0 + , bytestring >= 0.10 + hs-source-dirs: + lib + ghc-options: + -Wall + default-language: Haskell2010 +Test-Suite prednote-tests + hs-source-dirs: + lib + tests + other-modules: + Prednote + Prednote.Comparisons + Prednote.Core + Prednote.Expressions + Prednote.Expressions.Infix + Prednote.Expressions.RPN + Instances + Prednote.Core.Instances + Prednote.Core.Properties + Rainbow.Instances + ghc-options: + -Wall + default-language: Haskell2010 + other-extensions: + TemplateHaskell build-depends: - base >= 4.6 && < 5 - , explicit-exception ==0.1.* - , rainbow ==0.2.* - , split ==0.2.* - , text == 0.11.* + tasty >= 0.10 + , tasty-quickcheck >= 0.8 + , tasty-th >= 0.1 + , QuickCheck >= 2.7 + , base >= 4.7 && < 5 + , rainbow >= 0.26 + , split >= 0.2.2 + , text >= 0.11.2.0 + , containers >= 0.4.2.1 + , contravariant >= 1.2 + , transformers >= 0.3.0.0 + , bytestring >= 0.10 + main-is: prednote-tests.hs + type: exitcode-stdio-1.0 - ghc-options: -Wall +Test-Suite prednote-visual-tests + main-is: prednote-visual-tests.hs + type: exitcode-stdio-1.0 + hs-source-dirs: + lib + tests + other-modules: + Prednote + Prednote.Comparisons + Prednote.Core + Prednote.Expressions + Prednote.Expressions.Infix + Prednote.Expressions.RPN + Instances + Prednote.Core.Instances + Prednote.Core.Properties + Rainbow.Instances + ghc-options: + -Wall + default-language: Haskell2010 + other-extensions: + TemplateHaskell + build-depends: + tasty >= 0.10 + , tasty-quickcheck >= 0.8 + , tasty-th >= 0.1 + , QuickCheck >= 2.7 + , base >= 4.7 && < 5 + , rainbow >= 0.26 + , split >= 0.2.2 + , text >= 0.11.2.0 + , containers >= 0.4.2.1 + , contravariant >= 1.2 + , transformers >= 0.3.0.0 + , bytestring >= 0.10 + +source-repository head + type: git + location: https://github.com/massysett/prednote.git + +Flag visual-tests + description: Build the prednote-visual-tests executable + default: False + manual: True diff --git a/tests/Instances.hs b/tests/Instances.hs new file mode 100644 --- /dev/null +++ b/tests/Instances.hs @@ -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 diff --git a/tests/Prednote/Core/Instances.hs b/tests/Prednote/Core/Instances.hs new file mode 100644 --- /dev/null +++ b/tests/Prednote/Core/Instances.hs @@ -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 + diff --git a/tests/Prednote/Core/Properties.hs b/tests/Prednote/Core/Properties.hs new file mode 100644 --- /dev/null +++ b/tests/Prednote/Core/Properties.hs @@ -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] + diff --git a/tests/Rainbow/Instances.hs b/tests/Rainbow/Instances.hs new file mode 100644 --- /dev/null +++ b/tests/Rainbow/Instances.hs @@ -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 diff --git a/tests/prednote-tests.hs b/tests/prednote-tests.hs new file mode 100644 --- /dev/null +++ b/tests/prednote-tests.hs @@ -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 + ] diff --git a/tests/prednote-visual-tests.hs b/tests/prednote-visual-tests.hs new file mode 100644 --- /dev/null +++ b/tests/prednote-visual-tests.hs @@ -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 ()