diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013-2014, Omari Norman +Copyright (c) 2013-2015, Omari Norman All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -19,23 +19,25 @@ http://hackage.haskell.org/package/prednote -prednote is licensed under the BSD license; see the LICENSE file. +## Test results -## Versioning +You can view the results of building and testing on Travis by clicking +the button below: -prednote releases are numbered in accordance with the Haskell -Package Versioning Policy. +[![Build Status](https://travis-ci.org/massysett/prednote.svg?branch=master)](https://travis-ci.org/massysett/prednote) -prednote does not set its dependencies in accordance with the -Package Versioning Policy, as I do not set upper bounds. prednote -is guaranteed to build with the *minimum* versions specified in the -cabal file. I also include a dependencies.txt file that -documents more recent dependencies that are also known to work. +If you have trouble building prednote due to dependency issues, try +looking at the previous test results, as they will show you package +versions that were used to build prednote successfully. -If you find that prednote does not build due to dependency problems: -1) please let me know at omari@smileystation.com; 2) feel free to -add appropriate upper bounds or patches to the package as -appropriate; and 3) feel free to add command-line contraints to your -cabal command to get it to build. +## Something similar +See also rematch: +http://hackage.haskell.org/package/rematch + +which is apparently based on a Java library called hamcrest. + +## License + +prednote is licensed under the BSD license; see the LICENSE file. diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,23 @@ +0.28.0.2 + + * Documentation fixes. + +0.28.0.0 + * Completely new API and internals; is simpler and allows + for predicates on sum types. + +0.24.0.4 + + * Dependency bumps. + +0.24.0.2 + + * added wrap function. + +0.24.0.0 + + * complete change in API and internals. + 0.22.0.2 * updates for new Rainbow API diff --git a/current-versions.txt b/current-versions.txt deleted file mode 100644 --- a/current-versions.txt +++ /dev/null @@ -1,49 +0,0 @@ -This package was tested to work with these dependency -versions and compiler version. -These are the default versions fetched by cabal install. -Tested as of: 2014-04-13 22:50:48.223408 UTC -Path to compiler: ghc-7.8.2 -Compiler description: 7.8.2 - -/opt/ghc/7.8.2/lib/ghc-7.8.2/package.conf.d: - Cabal-1.18.1.3 - array-0.5.0.0 - base-4.7.0.0 - bin-package-db-0.0.0.0 - binary-0.7.1.0 - rts-1.0 - bytestring-0.10.4.0 - containers-0.5.5.1 - deepseq-1.3.0.2 - directory-1.2.1.0 - filepath-1.3.0.2 - (ghc-7.8.2) - ghc-prim-0.3.1.0 - (haskell2010-1.1.2.0) - (haskell98-2.0.0.3) - hoopl-3.10.0.1 - hpc-0.6.0.1 - integer-gmp-0.5.1.0 - old-locale-1.0.0.6 - old-time-1.1.0.2 - pretty-1.1.1.1 - process-1.2.0.0 - template-haskell-2.9.0.0 - time-1.4.2 - transformers-0.3.0.0 - unix-2.7.0.1 - -/home/massysett/prednote/sunlight-22866/db: - QuickCheck-2.7.3 - contravariant-0.4.4 - prednote-0.22.0.2 - primitive-0.5.2.1 - rainbow-0.14.0.0 - random-1.0.1.1 - split-0.2.2 - tagged-0.7.1 - terminfo-0.4.0.0 - text-1.1.0.1 - tf-random-0.5 - transformers-compat-0.1.1.1 - 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/Data/Prednote.hs b/lib/Data/Prednote.hs deleted file mode 100644 --- a/lib/Data/Prednote.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Data.Prednote - ( module Data.Prednote.Predbox - , module Data.Prednote.Expressions - , module Data.Prednote.Test - ) where - -import Data.Prednote.Predbox -import Data.Prednote.Expressions -import Data.Prednote.Test diff --git a/lib/Data/Prednote/Expressions.hs b/lib/Data/Prednote/Expressions.hs deleted file mode 100644 --- a/lib/Data/Prednote/Expressions.hs +++ /dev/null @@ -1,87 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Handles parsing of both infix and RPN Predbox expressions. -module Data.Prednote.Expressions - ( ExprDesc(..) - , Error - , Token - , operand - , opAnd - , opOr - , opNot - , openParen - , closeParen - , parseExpression - ) where - -import Data.Either (partitionEithers) -import Data.Functor.Contravariant -import qualified Data.Text as X -import qualified Data.Prednote.Expressions.Infix as I -import qualified Data.Prednote.Expressions.RPN as R -import qualified Data.Prednote.Predbox as P - --- | A single type for both RPN tokens and infix tokens. -newtype Token a = Token { unToken :: I.InfixToken a } - -instance Contravariant Token where - contramap f = Token . contramap f . unToken - -type Error = X.Text - --- | Creates Operands from Predbox. -operand :: P.Predbox a -> Token a -operand p = Token (I.TokRPN (R.TokOperand p)) - --- | The And operator -opAnd :: Token a -opAnd = Token (I.TokRPN (R.TokOperator R.OpAnd)) - --- | The Or operator -opOr :: Token a -opOr = Token (I.TokRPN (R.TokOperator R.OpOr)) - --- | The Not operator -opNot :: Token a -opNot = Token (I.TokRPN (R.TokOperator R.OpNot)) - --- | Open parentheses -openParen :: Token a -openParen = Token (I.TokParen I.Open) - --- | Close parentheses -closeParen :: Token a -closeParen = Token (I.TokParen I.Close) - --- | Is this an infix or RPN expression? -data ExprDesc - = Infix - | RPN - deriving (Eq, Show) - -toksToRPN :: [Token a] -> Maybe [R.RPNToken a] -toksToRPN toks - = let toEither t = case unToken t of - I.TokRPN tok -> Right tok - _ -> Left () - in case partitionEithers . map toEither $ toks of - ([], xs) -> return xs - _ -> Nothing - --- | Parses expressions. Fails if the expression is nonsensical in --- some way (for example, unbalanced parentheses, parentheses in an --- RPN expression, or multiple stack values remaining.) Works by first --- changing infix expressions to RPN ones. -parseExpression - :: ExprDesc - -> [Token a] - -> Either Error (P.Predbox a) -parseExpression e toks = do - rpnToks <- case e of - Infix -> maybe (Left "unbalanced parentheses\n") Right - . I.createRPN - . map unToken - $ toks - RPN -> maybe (Left "parentheses in an RPN expression\n") Right - $ toksToRPN toks - R.parseRPN rpnToks diff --git a/lib/Data/Prednote/Expressions/Infix.hs b/lib/Data/Prednote/Expressions/Infix.hs deleted file mode 100644 --- a/lib/Data/Prednote/Expressions/Infix.hs +++ /dev/null @@ -1,132 +0,0 @@ -module Data.Prednote.Expressions.Infix - ( InfixToken (..) - , Paren(..) - , createRPN - ) where - -import Data.Functor.Contravariant -import qualified Data.Prednote.Expressions.RPN as R -import qualified Data.Foldable as Fdbl - -data InfixToken a - = TokRPN (R.RPNToken a) - | TokParen Paren - -instance Contravariant InfixToken where - contramap f t = case t of - TokRPN r -> TokRPN . contramap f $ r - TokParen p -> TokParen p - -data Paren = Open | Close - --- | Values on the operator stack. -data OpStackVal - = StkOp R.Operator - | StkOpenParen - --- In the shunting yard algorithm, the output sequence is a queue. The --- first values to go into the output sequence are the first to be --- processed by the RPN parser. In this module, the output sequence is --- implemented as a list stack, which means it must be reversed upon --- output (this is done in the createRPN function.) - -processInfixToken - :: ([OpStackVal], [R.RPNToken a]) - -> InfixToken a - -> Maybe ([OpStackVal], [R.RPNToken a]) -processInfixToken (os, ts) t = case t of - TokRPN tok -> return $ processRPNToken (os, ts) tok - TokParen p -> processParen (os, ts) p - - --- | If the token is a binary operator A, then: --- --- If A is left associative, while there is an operator B of higher or --- equal precedence than A at the top of the stack, pop B off the --- stack and append it to the output. --- --- If A is right associative, while there is an operator B of higher --- precedence than A at the top of the stack, pop B off the stack and --- append it to the output. --- --- Push A onto the stack. --- --- If a token is an operand, append it to the postfix output. --- --- And has higher precedence than Or. -processRPNToken - :: ([OpStackVal], [R.RPNToken a]) - -> R.RPNToken a - -> ([OpStackVal], [R.RPNToken a]) -processRPNToken (os, ts) t = case t of - p@(R.TokOperand _) -> (os, p:ts) - R.TokOperator d -> case d of - R.OpNot -> (StkOp R.OpNot : os, ts) - R.OpAnd -> (StkOp R.OpAnd : os, ts) - R.OpOr -> - let (os', ts') = popper os ts - in (StkOp R.OpOr : os', ts') - --- | Pops operators from the operator stack and places then in the --- output queue, as long as there is an And operator on the top of the --- operator stack. -popper :: [OpStackVal] -> [R.RPNToken a] -> ([OpStackVal], [R.RPNToken a]) -popper os ts = case os of - [] -> (os, ts) - x:xs -> case x of - StkOp R.OpAnd -> - let os' = xs - ts' = R.TokOperator R.OpAnd : ts - in popper os' ts' - _ -> (os, ts) - --- | Pops operators off the operator stack and onto the output stack --- as long as the top of the operator stack is not an open --- parenthesis. When an open parenthesis is encountered, pop that too, --- but not onto the output stack. Fails if the stack has no open --- parentheses. -popThroughOpen - :: ([OpStackVal], [R.RPNToken a]) - -> Maybe ([OpStackVal], [R.RPNToken a]) -popThroughOpen (os, ts) = case os of - [] -> Nothing - v:vs -> case v of - StkOp op -> popThroughOpen (vs, R.TokOperator op : ts) - StkOpenParen -> return (vs, ts) - --- | Places an open parenthesis on the top of the operator stack. For --- Close parenthesis, pops operators off the operator stack through --- the next open parenthesis on the operator stack. -processParen - :: ([OpStackVal], [R.RPNToken a]) - -> Paren - -> Maybe ([OpStackVal], [R.RPNToken a]) -processParen (os, ts) p = case p of - Open -> Just (StkOpenParen : os, ts) - Close -> popThroughOpen (os, ts) - --- | Creates an RPN expression from an infix one. Fails only if there --- are mismatched parentheses. It is possible to create a nonsensical --- RPN expression; the RPN parser must catch this. -createRPN - :: Fdbl.Foldable f - => f (InfixToken a) - -- ^ The input tokens, with the beginning of the expression on the - -- left side of the sequence. - - -> Maybe [R.RPNToken a] - -- ^ The output sequence of tokens, with the beginning of the - -- expression on the left side of the list. -createRPN ts = do - (stack, toks) <- Fdbl.foldlM processInfixToken ([], []) ts - fmap reverse $ popRemainingOperators stack toks - --- | Pops remaining items off operator stack. Fails if there is an --- open paren left on the stack, as this indicates mismatched --- parenthesis. -popRemainingOperators :: [OpStackVal] -> [R.RPNToken a] -> Maybe [R.RPNToken a] -popRemainingOperators os ts = case os of - [] -> return ts - x:xs -> case x of - StkOp op -> popRemainingOperators xs (R.TokOperator op : ts) - StkOpenParen -> Nothing diff --git a/lib/Data/Prednote/Expressions/RPN.hs b/lib/Data/Prednote/Expressions/RPN.hs deleted file mode 100644 --- a/lib/Data/Prednote/Expressions/RPN.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --- | Postfix, or RPN, expression parsing. --- --- This module parses RPN expressions where the operands are --- predicates and the operators are one of @and@, @or@, or @not@, --- where @and@ and @or@ are binary and @not@ is unary. -module Data.Prednote.Expressions.RPN where - -import Data.Functor.Contravariant -import qualified Data.Foldable as Fdbl -import qualified Data.Prednote.Predbox as P -import Data.Prednote.Predbox ((&&&), (|||)) -import Data.Monoid ((<>)) -import Data.Text (Text) -import qualified Data.Text as X -import qualified System.Console.Rainbow as C - -type Error = Text - -data RPNToken a - = TokOperand (P.Predbox a) - | TokOperator Operator - -instance Contravariant RPNToken where - contramap f t = case t of - TokOperand p -> TokOperand . contramap f $ p - TokOperator o -> TokOperator o - -data Operator - = OpAnd - | OpOr - | OpNot - deriving Show - -pushOperand :: P.Predbox a -> [P.Predbox a] -> [P.Predbox a] -pushOperand p ts = p : ts - -pushOperator - :: Operator - -> [P.Predbox a] - -> Either Error [P.Predbox a] -pushOperator o ts = case o of - OpAnd -> case ts of - x:y:zs -> return $ (y &&& x) : zs - _ -> Left $ err "and" - OpOr -> case ts of - x:y:zs -> return $ (y ||| x) : zs - _ -> Left $ err "or" - OpNot -> case ts of - x:zs -> return $ P.not x : zs - _ -> Left $ err "not" - where - err x = "insufficient operands to apply \"" <> x - <> "\" operator\n" - -pushToken - :: [P.Predbox a] - -> RPNToken a - -> Either Error [P.Predbox a] -pushToken ts t = case t of - TokOperand p -> return $ pushOperand p ts - TokOperator o -> pushOperator o ts - - --- | Parses an RPN expression and returns the resulting Predbox. Fails if --- there are no operands left on the stack or if there are multiple --- operands left on the stack; the stack must contain exactly one --- operand in order to succeed. -parseRPN - :: Fdbl.Foldable f - => f (RPNToken a) - -> Either Error (P.Predbox a) -parseRPN ts = do - trees <- Fdbl.foldlM pushToken [] ts - case trees of - [] -> Left $ "bad expression: no operands left on the stack\n" - x:[] -> return x - xs -> Left - $ "bad expression: multiple operands left on the stack:\n" - <> ( X.concat - . concat - . map C.text - . concatMap (P.showPredbox 4 0) - $ xs ) - diff --git a/lib/Data/Prednote/Predbox.hs b/lib/Data/Prednote/Predbox.hs deleted file mode 100644 --- a/lib/Data/Prednote/Predbox.hs +++ /dev/null @@ -1,662 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Trees of predicates. --- --- Exports names which conflict with Prelude names, so you probably --- want to import this module qualified. - -module Data.Prednote.Predbox - - ( -- * The Predbox tree - Label - , Hide - , Predbox(..) - , Node(..) - - -- * Creating Predbox. - -- | All functions create Predbox that are shown by default. - , predicate - , and - , or - , not - , (&&&) - , (|||) - , always - , never - - -- * Controlling whether Predbox are shown in the results - , hide - , show - , hideTrue - , hideFalse - - -- * Renaming Predbox - , rename - - -- * Result - , Result(..) - , RNode(..) - - -- * Showing and evaluating Predbox - , evaluate - , evaluateNode - , IndentAmt - , Level - , ShowAll - , showResult - , showTopResult - , showPredbox - , filter - , verboseFilter - - -- * Helpers for building common Predbox - -- ** Non-overloaded - - -- | Each of these functions builds a Predbox that compares two - -- items. The predicate in the Predbox is applied to an item that - -- is considered to be the left hand side of the comparison. The - -- left hand side side can change; the right hand side is baked - -- into the Predbox. - -- - -- For example, to build a Predbox that returns True if an item is - -- greater than 5: - -- - -- >>> :set -XOverloadedStrings - -- >>> let p = compareBy "5" "integer" (`Prelude.compare` (5 :: Integer)) GT - -- >>> rBool . evaluate p $ 6 - -- True - -- >>> rBool . evaluate p $ 4 - -- False - , compareBy - , compareByMaybe - , greaterBy - , lessBy - , equalBy - , greaterEqBy - , lessEqBy - , notEqBy - - -- ** Overloaded - , compare - , greater - , less - , equal - , greaterEq - , lessEq - , notEq - , parseComparer - - ) where - - --- # Imports - -import Data.Functor.Contravariant hiding (Predicate) -import Data.Text (Text) -import qualified Data.Text as X -import Data.Monoid ((<>), mconcat, mempty) -import Data.String (fromString) -import qualified System.Console.Rainbow as R -import Prelude hiding (not, and, or, compare, filter, show) -import qualified Prelude - --- # Predbox type - -type Label = Text - --- | Determines whether a result is shown by default. -type Hide = Bool - --- | A predicate. Each Predbox contains a tree of Node. -data Predbox a = Predbox - { pLabel :: Label - -- ^ Label used when showing the results - - , pHide :: (Bool -> Hide) - -- ^ As results are computed, this function is applied to the - -- result. If this function returns False, then this Predbox will not - -- be shown by default in the results. - - , pNode :: Node a - - } - -data Node a - = And [Predbox a] - -- ^ Conjunction. If any Predbox in the list is False, the result is - -- False. If the list is empty, the result is True. - - | Or [Predbox a] - -- ^ Disjunction. If at least one Predbox in the list is True, the - -- result it True. If the list is empty, the result is False. - - | Not (Predbox a) - -- ^ Negation - - | Predicate (a -> Bool) - -- ^ Most basic building block. - --- | Renames the top level of the Predbox. The function you pass will be --- applied to the old name. -rename :: (Text -> Text) -> Predbox a -> Predbox a -rename f p = p { pLabel = f (pLabel p) } - --- | Always True -always :: Predbox a -always = Predbox "always True" (const False) (Predicate (const True)) - --- | Always False -never :: Predbox a -never = Predbox "always False" (const False) (Predicate (const False)) - --- | Creates and labels predicates. -predicate :: Label -> (a -> Bool) -> Predbox a -predicate l = Predbox l (const False) . Predicate - --- | Creates And Predbox using a generic name -and :: [Predbox a] -> Predbox a -and = Predbox "and" (const False) . And - --- | Creates Or Predbox using a generic name -or :: [Predbox a] -> Predbox a -or = Predbox "or" (const False) . Or - --- | Creates Not Predbox using a generic name -not :: Predbox a -> Predbox a -not = Predbox "not" (const False) . Not - --- | Changes a Predbox so it is always hidden by default. -hide :: Predbox a -> Predbox a -hide p = p { pHide = const True } - --- | Changes a Predbox so it is always shown by default. -show :: Predbox a -> Predbox a -show p = p { pHide = const False } - --- | Changes a Predbox so that it is hidden if its result is True. -hideTrue :: Predbox a -> Predbox a -hideTrue p = p { pHide = id } - --- | Changes a Predbox so that it is hidden if its result is False. -hideFalse :: Predbox a -> Predbox a -hideFalse p = p { pHide = Prelude.not } - --- | Forms a Predbox using 'and'; assigns a generic label. -(&&&) :: Predbox a -> Predbox a -> Predbox a -(&&&) x y = Predbox "and" (const False) (And [x, y]) -infixr 3 &&& - --- | Forms a Predbox using 'or'; assigns a generic label. -(|||) :: Predbox a -> Predbox a -> Predbox a -(|||) x y = Predbox "or" (const False) (Or [x, y]) -infixr 2 ||| - -instance Contravariant Predbox where - contramap f (Predbox l d n) = Predbox l d $ contramap f n - -instance Contravariant Node where - contramap f n = case n of - And ls -> And $ map (contramap f) ls - Or ls -> Or $ map (contramap f) ls - Not o -> Not $ contramap f o - Predicate g -> Predicate $ \b -> g (f b) - --- # Result - --- | The result from evaluating a Predbox. -data Result = Result - { rLabel :: Label - -- ^ The label from the original Predbox - - , rBool :: Bool - -- ^ The boolean result from evaluating the node. If the node is an - -- predicate, this is the result of applying the predicate function to - -- the subject. Otherwise, this is the result of application of the - -- appropriate boolean operation to the child nodes. - - , rHide :: Hide - -- ^ Is this result hidden in the result by default? Hiding only - -- affects presentation; it does not affect how this Predbox affects - -- any parent Predbox. - , rNode :: RNode - } deriving (Eq, Show) - -data RNode - = RAnd [Result] - | ROr [Result] - | RNot Result - | RPredicate Bool - deriving (Eq, Show) - --- | Applies a Predbox to a particular value, known as the subject. -evaluate :: Predbox a -> a -> Result -evaluate (Predbox l d n) a = Result l r d' rn - where - rn = evaluateNode n a - r = case rn of - RAnd ls -> all rBool ls - ROr ls -> any rBool ls - RNot x -> Prelude.not . rBool $ x - RPredicate b -> b - d' = d r - -evaluateNode :: Node a -> a -> RNode -evaluateNode n a = case n of - And ls -> RAnd (map (flip evaluate a) ls) - Or ls -> ROr (map (flip evaluate a) ls) - Not l -> RNot (flip evaluate a l) - Predicate f -> RPredicate (f a) - --- # Types and functions for showing - --- | The number of spaces to use for each level of indentation. -type IndentAmt = Int - --- | How many levels of indentation to use. Typically you will start --- this at zero. It is incremented by one for each level as functions --- descend through the tree. -type Level = Int - --- | Indents text, and adds a newline to the end. -indent :: IndentAmt -> Level -> [R.Chunk] -> [R.Chunk] -indent amt lvl cs = idt : (cs ++ [nl]) - where - idt = fromString (replicate (lvl * amt) ' ') - nl = fromString "\n" - --- # Showing Predbox - --- | Creates a plain Chunk from a Text. -plain :: Text -> R.Chunk -plain = R.Chunk mempty . (:[]) - --- | Shows a Predbox tree without evaluating it. -showPredbox :: IndentAmt -> Level -> Predbox a -> [R.Chunk] -showPredbox amt lvl (Predbox l _ pd) = case pd of - And ls -> indent amt lvl [plain ("and - " <> l)] - <> mconcat (map (showPredbox amt (lvl + 1)) ls) - Or ls -> indent amt lvl [plain ("or - " <> l)] - <> mconcat (map (showPredbox amt (lvl + 1)) ls) - Not t -> indent amt lvl [plain ("not - " <> l)] - <> showPredbox amt (lvl + 1) t - Predicate _ -> indent amt lvl [plain ("predicate - " <> l)] - -instance Show (Predbox a) where - show = X.unpack - . X.concat - . concat - . map R.text - . showPredbox 2 0 - - -filter :: Predbox a -> [a] -> [a] -filter pd as - = map fst - . Prelude.filter (rBool . snd) - . zip as - . map (evaluate pd) - $ as - - --- # Showing Result - -labelBool :: Text -> Bool -> [R.Chunk] -labelBool t b = [open, trueFalse, close, blank, txt] - where - trueFalse = - if b then "TRUE" <> R.f_green else "FALSE" <> R.f_red - open = "[" - close = "]" - blank = plain (X.replicate blankLen " ") - blankLen = X.length "discard" - - (sum . map X.length . R.text $ trueFalse) + 1 - txt = plain t - -type ShowAll = Bool - --- | Shows a Result in a pretty way with colors and indentation. -showResult - :: IndentAmt - -- ^ Indent each level by this many spaces - - -> ShowAll - -- ^ If True, shows all Predbox, even ones where 'rHide' is - -- True. Otherwise, respects 'rHide' and does not show hidden Predbox. - - -> Level - -- ^ How deep in the tree we are; this increments by one for each - -- level of descent. - - -> Result - -- ^ The result to show - - -> [R.Chunk] -showResult amt sa lvl (Result lbl rslt hd nd) - | hd && Prelude.not sa = [] - | otherwise = firstLine ++ restLines - where - firstLine = indent amt lvl $ labelBool lbl rslt - restLines = case nd of - RAnd ls -> f False ls - ROr ls -> f True ls - RNot r -> showResult amt sa (lvl + 1) r - RPredicate _ -> [] - f stopOn ls = concatMap sr ls' ++ end - where - ls' = takeThrough ((== stopOn) . rBool) ls - sr = showResult amt sa (lvl + 1) - end = if ls' `shorter` ls - then indent amt (lvl + 1) ["(short circuit)"] - else [] - --- | @shorter x y@ is True if list x is shorter than list y. Lazier --- than taking the length of each list and comparing the results. -shorter :: [a] -> [a] -> Bool -shorter [] [] = False -shorter (_:_) [] = False -shorter [] (_:_) = True -shorter (_:xs) (_:ys) = shorter xs ys - --- | For instance, --- --- > takeThrough odd [2,4,6,7,8] == [2,4,6,7] -takeThrough :: (a -> Bool) -> [a] -> [a] -takeThrough _ [] = [] -takeThrough f (x:xs) = x : if f x then [] else takeThrough f xs - --- | Shows the top of a Result tree and all the child Results. Adds a --- short label at the top of the tree. -showTopResult - :: X.Text - -- ^ Label to add to the top of the tree. - -> IndentAmt - -- ^ Indent each level by this many spaces - -> Level - -- ^ Indent the top by this many levels - -> ShowAll - -- ^ If True, shows all Predbox, even ones where 'rHide' is - -- True. Otherwise, respects 'rHide' and does not show hidden Predbox. - - -> Result - -- ^ The result to show - -> [R.Chunk] -showTopResult txt i lvl sd r = showResult i sd lvl r' - where - r' = r { rLabel = rLabel r <> " - " <> txt } - - --- | Filters a list. Also returns chunks describing the process. -verboseFilter - :: (a -> X.Text) - -- ^ How to describe each subject - - -> IndentAmt - -- ^ Indent each level by this many spaces - - -> ShowAll - -- ^ If True, shows all Predbox, even ones where 'rHide' is - -- True. Otherwise, respects 'rHide' and does not show hidden Predbox. - - -> Predbox a - -- ^ Used to perform the filtering - - -> [a] - -> ([R.Chunk], [a]) - -verboseFilter desc amt sa pd as = (chks, as') - where - rs = map (evaluate pd) as - subjAndRslts = zip as rs - mkChks (subj, rslt) = showTopResult (desc subj) amt 0 sa rslt - chks = concatMap mkChks subjAndRslts - as' = map fst . Prelude.filter (rBool . snd) $ subjAndRslts - --- # Comparisons - --- | Build a Predbox that compares items. -compareBy - :: Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare an item against the right hand side. Return LT - -- if the item is less than the right hand side; GT if greater; EQ - -- if equal to the right hand side. - - -> Ordering - -- ^ When subjects are compared, this ordering must be the result in - -- order for the Predbox to be True; otherwise it is False. The subject - -- will be on the left hand side. - - -> Predbox a - -compareBy itemDesc typeDesc cmp ord = Predbox l (const False) (Predicate f) - where - l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc - cmpDesc = case ord of - LT -> "less than" - GT -> "greater than" - EQ -> "equal to" - f subj = cmp subj == ord - --- | Overloaded version of 'compareBy'. -compare - :: (Show a, Ord a) - => Text - -- ^ Description of the type of thing being matched - - -> a - -- ^ The right hand side of the comparison. - - -> Ordering - -- ^ When subjects are compared, this ordering must be the result in - -- order for the Predbox to be True; otherwise it is False. The subject - -- will be on the left hand side. - - -> Predbox a -compare typeDesc a ord = compareBy itemDesc typeDesc cmp ord - where - itemDesc = X.pack . Prelude.show $ a - cmp item = Prelude.compare item a - --- | Builds a Predbox for items that might fail to return a comparison. -compareByMaybe - :: Text - -- ^ How to show the item being compared - - -> Text - -- ^ Description of type of thing being matched - - -> (a -> Maybe Ordering) - -- ^ How to compare against right hand side. If Nothing, a Predbox that - -- always returns False is returned. - - -> Ordering - -- ^ Ordering that must result for the Predbox to be True - - -> Predbox a - -compareByMaybe itemDesc typeDesc cmp ord = - Predbox l (const False) (Predicate f) - where - l = typeDesc <> " is " <> cmpDesc <> " " <> itemDesc - cmpDesc = case ord of - LT -> "less than" - GT -> "greater than" - EQ -> "equal to" - f subj = case cmp subj of - Nothing -> False - Just ord' -> ord == ord' - -greater - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> a - -- ^ The right hand side of the comparison. - - -> Predbox a -greater d a = compare d a GT - -less - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> a - -- ^ The right hand side of the comparison. - - -> Predbox a -less d a = compare d a LT - -equal - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> a - -- ^ The right hand side of the comparison. - - -> Predbox a -equal d a = compare d a EQ - -greaterEq - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> a - -- ^ The right hand side of the comparison. - - -> Predbox a -greaterEq d a = greater d a ||| equal d a - -lessEq - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> a - -- ^ The right hand side of the comparison. - - -> Predbox a -lessEq d a = less d a ||| equal d a - -notEq - :: (Show a, Ord a) - => Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> a - -- ^ The right hand side of the comparison. - - -> Predbox a -notEq d a = not $ equal d a - -greaterBy - :: Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Predbox a -greaterBy iD tD cmp = compareBy iD tD cmp GT - -lessBy - :: Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Predbox a -lessBy iD tD cmp = compareBy iD tD cmp LT - -equalBy - :: Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Predbox a -equalBy iD tD cmp = compareBy iD tD cmp EQ - -greaterEqBy - :: Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Predbox a -greaterEqBy iD tD cmp = - greaterBy iD tD cmp ||| equalBy iD tD cmp - -lessEqBy - :: Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Predbox a -lessEqBy iD tD cmp = - lessBy iD tD cmp ||| equalBy iD tD cmp - -notEqBy - :: Text - -- ^ How to show the item being compared; used to describe the Predbox - - -> Text - -- ^ Description of the type of thing that is being matched - - -> (a -> Ordering) - -- ^ How to compare two items - - -> Predbox a -notEqBy iD tD cmp = - not $ equalBy iD tD cmp - --- | Parses a string to find the correct comparer; returns the correct --- function to build a Predbox. - -parseComparer - :: Text - -- ^ The string with the comparer to be parsed - -> (Ordering -> Predbox a) - -- ^ A function that, when given an ordering, returns a Predbox - -> Maybe (Predbox a) - -- ^ If an invalid comparer string is given, Nothing; otherwise, the - -- Predbox. -parseComparer t f - | t == ">" = Just (f GT) - | t == "<" = Just (f LT) - | t == "=" = Just (f EQ) - | t == "==" = Just (f EQ) - | t == ">=" = Just (f GT ||| f EQ) - | t == "<=" = Just (f LT ||| f EQ) - | t == "/=" = Just (not $ f EQ) - | t == "!=" = Just (not $ f EQ) - | otherwise = Nothing - diff --git a/lib/Data/Prednote/Test.hs b/lib/Data/Prednote/Test.hs deleted file mode 100644 --- a/lib/Data/Prednote/Test.hs +++ /dev/null @@ -1,224 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Helps you build tests that run against a series of items. -module Data.Prednote.Test - ( - -- * Test data types - Name - , Verbosity(..) - , TrueVerbosity - , FalseVerbosity - , TestVisibility(..) - , TestVerbosity(..) - , Pass - , Test(..) - , TestResult(..) - - -- * Pre-built tests - , eachSubjectMustBeTrue - , nSubjectsMustBeTrue - - -- * Running and showing tests - , evalTest - , showTestResult - - ) where - -import Control.Arrow (first) -import Data.Functor.Contravariant -import Data.Maybe (fromMaybe) -import Data.Monoid ((<>), mempty) -import qualified Data.Text as X -import Data.Text (Text) - -import qualified System.Console.Rainbow as R -import qualified Data.Prednote.Predbox as Pt - --- # Types - --- | How verbose to be when showing the results of running a Predbox on a --- single subject. -data Verbosity - = HideAll - -- ^ Do not show any results from the Predbox - - | ShowDefaults - -- ^ Show results according to the default settings provided in the - -- Result itself - - | ShowAll - -- ^ Show all Result - deriving (Eq, Show) - --- | Use this verbosity for subjects that are True -type TrueVerbosity = Verbosity - --- | Use this verbosity for subjects that are False -type FalseVerbosity = Verbosity - --- | Determines whether to show any of the results from a single test. -data TestVisibility - = HideTest - -- ^ Do not show any results from this test - - | ShowFirstLine TrueVerbosity FalseVerbosity - -- ^ Show the first line, which indicates whether the test passed or - -- failed and gives the label for the test. Whether to show - -- individual subjects is determined by the TrueVerbosity and - -- FalseVerbosity. - - deriving (Eq, Show) - --- | Determines which TestVisibility to use for a particular test. -data TestVerbosity = TestVerbosity - { onPass :: TestVisibility - -- ^ Use this TestVisibility when the test passes - , onFail :: TestVisibility - -- ^ Use this TestVisibility when the test fails - } deriving (Eq, Show) - -type Pass = Bool - --- | The name of a test or of a group. -type Name = Text - --- | A single test. -data Test a = Test - { testName :: Name - , testPass :: [Pt.Result] -> Pass - -- ^ Applied to the results of all applications of testFunc; - -- determines whether the test passes or fails. - - , testFunc :: a -> Pt.Result - -- ^ This function is applied to each subject. - - , testVerbosity :: TestVerbosity - -- ^ Default verbosity for the test. - } - -instance Contravariant Test where - contramap f t = t { testFunc = testFunc t . f } - -data TestResult a = TestResult - { resultName :: Name - , resultPass :: Pass - , resultSubjects :: [(a, Pt.Result)] - , resultDefaultVerbosity :: TestVerbosity - } - -instance Functor TestResult where - fmap f t = t { resultSubjects = map (first f) . resultSubjects $ t } - --- # Showing tests - --- | Creates a plain Chunk from a Text. -plain :: X.Text -> R.Chunk -plain = R.Chunk mempty . (:[]) - -showTestTitle :: Name -> Pass -> [R.Chunk] -showTestTitle n p = [open, passFail, close, blank, txt, nl] - where - nl = plain "\n" - passFail = - if p - then "PASS" <> R.f_green - else "FAIL" <> R.f_red - open = plain "[" - close = plain "]" - blank = plain (X.singleton ' ') - txt = plain n - --- | Evaluates a test for a given list of subjects. -evalTest :: Test a -> [a] -> TestResult a -evalTest (Test n fPass fSubj vy) ls = TestResult n p ss vy - where - p = fPass results - results = map fSubj ls - ss = zip ls results - --- | Shows a result with indenting. -showTestResult - :: Pt.IndentAmt - -- ^ Indent each level by this many spaces - - -> (a -> Text) - -- ^ Shows each subject. The function should return a single-line - -- text without a trailing newline. - - -> Maybe TestVerbosity - -- ^ If Just, use this TestVerbosity when showing the test. If - -- Nothing, use the default verbosity. - - -> TestResult a - -- ^ The result to show - - -> [R.Chunk] -showTestResult amt swr mayVb (TestResult n p ss dfltVb) = - let vb = fromMaybe dfltVb mayVb - tv = if p then onPass vb else onFail vb - firstLine = showTestTitle n p - in case tv of - HideTest -> [] - ShowFirstLine trueV falseV -> - firstLine - ++ concatMap (showSubject p amt swr (trueV, falseV)) ss - -showSubject - :: Pass - -> Pt.IndentAmt - -> (a -> Text) - -> (TrueVerbosity, FalseVerbosity) - -> (a, Pt.Result) - -> [R.Chunk] -showSubject p amt swr (tv, fv) (a, r) = - let txt = swr a - vb = if p then tv else fv - in case vb of - HideAll -> [] - ShowDefaults -> Pt.showTopResult txt amt 1 False r - ShowAll -> Pt.showTopResult txt amt 1 True r - --- # Pre-built tests - --- | The test passes if each subject returns True. -eachSubjectMustBeTrue :: Pt.Predbox a -> Name -> Test a -eachSubjectMustBeTrue pd nm = Test nm pass f vy - where - vy = TestVerbosity - { onPass = ShowFirstLine HideAll HideAll - , onFail = ShowFirstLine HideAll ShowDefaults } - pass = all Pt.rBool - f = Pt.evaluate pd - - --- | The test passes if at least a given number of subjects are True. -nSubjectsMustBeTrue - :: Pt.Predbox a - -> Name - -> Int - -- ^ The number of subjects that must be True. This should be a - -- positive number. - -> Test a -nSubjectsMustBeTrue pd nm i = Test nm pass f vy - where - pass = atLeast i . filter Pt.rBool - f = Pt.evaluate pd - vy = TestVerbosity - { onPass = ShowFirstLine HideAll HideAll - , onFail = ShowFirstLine HideAll HideAll } - - --- # Basement - --- | Returns True if the list has at least this many elements. Lazier --- than taking the length of the list. -atLeast :: Int -> [a] -> Bool -atLeast i as - | i < 0 = error "atLeast: negative length parameter" - | otherwise = go 0 as - where - go _ [] = i == 0 - go soFar (_:xs) = - let nFound = soFar + 1 - in if nFound == i then True else go nFound xs - 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/minimum-versions.txt b/minimum-versions.txt deleted file mode 100644 --- a/minimum-versions.txt +++ /dev/null @@ -1,46 +0,0 @@ -This package was tested to work with these dependency -versions and compiler version. -These are the minimum versions given in the .cabal file. -Tested as of: 2014-04-13 22:50:48.223408 UTC -Path to compiler: ghc-7.4.1 -Compiler description: 7.4.1 - -/opt/ghc/7.4.1/lib/ghc-7.4.1/package.conf.d: - Cabal-1.14.0 - array-0.4.0.0 - base-4.5.0.0 - bin-package-db-0.0.0.0 - binary-0.5.1.0 - bytestring-0.9.2.1 - containers-0.4.2.1 - deepseq-1.3.0.0 - directory-1.1.0.2 - extensible-exceptions-0.1.1.4 - filepath-1.3.0.0 - (ghc-7.4.1) - ghc-prim-0.2.0.0 - (haskell2010-1.1.0.1) - (haskell98-2.0.0.1) - hoopl-3.8.7.3 - hpc-0.5.1.1 - integer-gmp-0.4.0.0 - old-locale-1.0.0.4 - old-time-1.1.0.0 - pretty-1.1.1.0 - process-1.1.0.1 - rts-1.0 - template-haskell-2.7.0.0 - time-1.4 - unix-2.5.1.0 - -/home/massysett/prednote/sunlight-22866/db: - QuickCheck-2.6 - contravariant-0.2.0.1 - prednote-0.22.0.2 - rainbow-0.14.0.0 - random-1.0.1.1 - split-0.2.2 - terminfo-0.4.0.0 - text-0.11.2.0 - transformers-0.3.0.0 - diff --git a/prednote-test.hs b/prednote-test.hs deleted file mode 100644 --- a/prednote-test.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE TemplateHaskell #-} -module Main where - -import Control.Applicative -import qualified Test.QuickCheck as Q -import Test.QuickCheck.All (quickCheckAll) -import Test.QuickCheck.Function -import Test.QuickCheck (Arbitrary, Gen, arbitrary) -import qualified Data.Prednote.Predbox as P -import Data.Prednote.Predbox ((&&&), (|||)) -import qualified Data.Text as X -import qualified System.Exit as Exit - -instance Arbitrary X.Text where - arbitrary = fmap X.pack (Q.listOf (Q.choose ('!', '~'))) - -instance Q.CoArbitrary a => Arbitrary (P.Predbox a) where - arbitrary = P.Predbox <$> arbitrary <*> arbitrary <*> arbitrary - -instance Q.CoArbitrary a => Arbitrary (P.Node a) where - arbitrary = Q.sized tree - where - tree 0 = fmap P.Predicate arbitrary - tree n = Q.oneof - [ fmap P.And (Q.listOf subtree) - , fmap P.Or (Q.listOf subtree) - , fmap P.Not subtree ] - where - subtree = P.Predbox <$> arbitrary <*> arbitrary - <*> tree (n `div` 2) - --- | And is commutative -prop_andCommutative :: a -> P.Predbox a -> P.Predbox a -> Bool -prop_andCommutative a p1 p2 = P.rBool r1 == P.rBool r2 - where - r1 = P.evaluate (p1 &&& p2) a - r2 = P.evaluate (p2 &&& p1) a - --- | And is associative -prop_andAssociative :: a -> P.Predbox a -> P.Predbox a -> P.Predbox a -> Bool -prop_andAssociative a p1 p2 p3 = P.rBool r1 == P.rBool r2 - where - r1 = P.evaluate (p1 &&& (p2 &&& p3)) a - r2 = P.evaluate ((p1 &&& p2) &&& p3) a - --- | Or is commutative -prop_orCommutative :: a -> P.Predbox a -> P.Predbox a -> Bool -prop_orCommutative a p1 p2 = P.rBool r1 == P.rBool r2 - where - r1 = P.evaluate (p1 ||| p2) a - r2 = P.evaluate (p2 ||| p1) a - --- | Or is associative -prop_orAssociative :: a -> P.Predbox a -> P.Predbox a -> P.Predbox a -> Bool -prop_orAssociative a p1 p2 p3 = P.rBool r1 == P.rBool r2 - where - r1 = P.evaluate (p1 ||| (p2 ||| p3)) a - r2 = P.evaluate ((p1 ||| p2) ||| p3) a - --- | Anything or'd with True is True -prop_orWithTrue :: a -> P.Predbox a -> Bool -prop_orWithTrue a p1 = P.rBool r1 - where - r1 = P.evaluate (p1 ||| P.always) a - --- | Anything and'ed with False is False -prop_andWithFalse :: a -> P.Predbox a -> Bool -prop_andWithFalse a p1 = not $ P.rBool r1 - where - r1 = P.evaluate (p1 &&& P.never) a - --- | And Distributivity -prop_andDistributivity :: a -> P.Predbox a -> P.Predbox a -> P.Predbox a -> Bool -prop_andDistributivity x a b c = P.rBool r1 == P.rBool r2 - where - r1 = P.evaluate (a &&& (b ||| c)) x - r2 = P.evaluate ((a &&& b) ||| (a &&& c)) x - -prop_orDistributivity :: a -> P.Predbox a -> P.Predbox a -> P.Predbox a -> Bool -prop_orDistributivity x a b c = P.rBool r1 == P.rBool r2 - where - r1 = P.evaluate (a ||| (b &&& c)) x - r2 = P.evaluate ((a ||| b) &&& (a ||| c)) x - -runTests = $quickCheckAll - -main :: IO () -main = do - b <- runTests - if b then Exit.exitSuccess else Exit.exitFailure diff --git a/prednote.cabal b/prednote.cabal --- a/prednote.cabal +++ b/prednote.cabal @@ -1,6 +1,24 @@ -name: prednote -version: 0.22.0.2 -synopsis: Build and evaluate trees of predicates +-- This Cabal file generated using the Cartel library. +-- Cartel is available at: +-- http://www.github.com/massysett/cartel +-- +-- Script name used to generate: genCabal.hs +-- Generated on: 2015-09-09 21:57:21.988823 EDT +-- Cartel library version: 0.14.2.6 + +name: prednote +version: 0.36.0.4 +cabal-version: >= 1.18 +license: BSD3 +license-file: LICENSE +build-type: Simple +copyright: Copyright 2013-2015 Omari Norman +author: Omari Norman +maintainer: omari@smileystation.com +stability: Experimental +homepage: http://www.github.com/massysett/prednote +bug-reports: http://www.github.com/massysett/prednote/issues +synopsis: Evaluate and display trees of predicates description: Build and evaluate trees of predicates. For example, you might build a predicate of the type Int -> Bool. You do this by assembling @@ -10,55 +28,112 @@ prednote also provides modules to test several subjects against a given predicate, and to parse infix or RPN expressions into a tree of predicates. - -homepage: http://github.com/massysett/prednote -license: BSD3 -license-file: LICENSE -author: Omari Norman -maintainer: omari@smileystation.com -copyright: 2013-2014 Omari Norman -category: Data -build-type: Simple -cabal-version: >=1.8 +category: Data extra-source-files: - README.md, minimum-versions.txt, current-versions.txt, - sunlight-test.hs, changelog - -tested-with: GHC ==7.4.1, GHC ==7.6.3, GHC ==7.8.2 - -source-repository head - type: git - location: git://github.com/massysett/prednote.git - -library + README.md + changelog + genCabal.hs +Library exposed-modules: - Data.Prednote - , Data.Prednote.Predbox - , Data.Prednote.Expressions - , Data.Prednote.Expressions.Infix - , Data.Prednote.Expressions.RPN - , Data.Prednote.Test - + Prednote + Prednote.Comparisons + Prednote.Core + Prednote.Expressions + Prednote.Expressions.Infix + Prednote.Expressions.RPN build-depends: - base >= 4.5.0.0 && < 5 - , contravariant >= 0.2.0.1 - , rainbow >=0.14.0.0 && < 0.15 - , split >=0.2.2 + base >= 4.7 && < 5 + , rainbow >= 0.26 + , split >= 0.2.2 , text >= 0.11.2.0 - - ghc-options: -Wall - hs-source-dirs: lib + , containers >= 0.4.2.1 + , contravariant >= 1.2 + , transformers >= 0.3.0.0 + , bytestring >= 0.10 + hs-source-dirs: + lib + ghc-options: + -Wall + default-language: Haskell2010 -Test-Suite prednote-test +Test-Suite prednote-tests + hs-source-dirs: + lib + tests + other-modules: + Prednote + Prednote.Comparisons + Prednote.Core + Prednote.Expressions + Prednote.Expressions.Infix + Prednote.Expressions.RPN + Instances + Prednote.Core.Instances + Prednote.Core.Properties + Rainbow.Instances + ghc-options: + -Wall + default-language: Haskell2010 + other-extensions: + TemplateHaskell + build-depends: + tasty >= 0.10 + , tasty-quickcheck >= 0.8 + , tasty-th >= 0.1 + , QuickCheck >= 2.7 + , base >= 4.7 && < 5 + , rainbow >= 0.26 + , split >= 0.2.2 + , text >= 0.11.2.0 + , containers >= 0.4.2.1 + , contravariant >= 1.2 + , transformers >= 0.3.0.0 + , bytestring >= 0.10 + main-is: prednote-tests.hs type: exitcode-stdio-1.0 - main-is: prednote-test.hs - hs-source-dirs: . lib +Test-Suite prednote-visual-tests + main-is: prednote-visual-tests.hs + type: exitcode-stdio-1.0 + hs-source-dirs: + lib + tests + other-modules: + Prednote + Prednote.Comparisons + Prednote.Core + Prednote.Expressions + Prednote.Expressions.Infix + Prednote.Expressions.RPN + Instances + Prednote.Core.Instances + Prednote.Core.Properties + Rainbow.Instances + ghc-options: + -Wall + default-language: Haskell2010 + other-extensions: + TemplateHaskell build-depends: - base >=4.5.0.0 && < 5 - , contravariant >= 0.2.0.1 - , QuickCheck >=2.6 - , rainbow >=0.14.0.0 && < 0.15 + tasty >= 0.10 + , tasty-quickcheck >= 0.8 + , tasty-th >= 0.1 + , QuickCheck >= 2.7 + , base >= 4.7 && < 5 + , rainbow >= 0.26 + , split >= 0.2.2 , text >= 0.11.2.0 + , containers >= 0.4.2.1 + , contravariant >= 1.2 + , transformers >= 0.3.0.0 + , bytestring >= 0.10 +source-repository head + type: git + location: https://github.com/massysett/prednote.git + +Flag visual-tests + description: Build the prednote-visual-tests executable + default: False + manual: True diff --git a/sunlight-test.hs b/sunlight-test.hs deleted file mode 100644 --- a/sunlight-test.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Main where - -import Test.Sunlight - -inputs = TestInputs - { tiDescription = Nothing - , tiCabal = "cabal" - , tiLowest = ("7.4.1", "ghc-7.4.1", "ghc-pkg-7.4.1") - , tiDefault = [ ("7.4.1", "ghc-7.4.1", "ghc-pkg-7.4.1") - , ("7.6.3", "ghc-7.6.3", "ghc-pkg-7.6.3") - , ("7.8.2", "ghc-7.8.2", "ghc-pkg-7.8.2") ] - , tiTest = [("dist/build/prednote-test/prednote-test", [])] - } - -main = runTests inputs 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 ()