prednote 0.26.0.4 → 0.36.0.4
raw patch · 19 files changed
Files
- LICENSE +1/−1
- README.md +9/−1
- changelog +12/−0
- genCabal.hs +172/−0
- lib/Prednote.hs +16/−112
- lib/Prednote/Comparisons.hs +260/−150
- lib/Prednote/Core.hs +442/−271
- lib/Prednote/Expressions.hs +19/−20
- lib/Prednote/Expressions/Infix.hs +16/−22
- lib/Prednote/Expressions/RPN.hs +19/−22
- lib/Prednote/Format.hs +0/−110
- lib/Prednote/Prebuilt.hs +0/−179
- prednote.cabal +107/−32
- tests/Instances.hs +18/−0
- tests/Prednote/Core/Instances.hs +93/−0
- tests/Prednote/Core/Properties.hs +84/−0
- tests/Rainbow/Instances.hs +106/−0
- tests/prednote-tests.hs +10/−0
- tests/prednote-visual-tests.hs +15/−0
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2013-2014, Omari Norman+Copyright (c) 2013-2015, Omari Norman All rights reserved.
README.md view
@@ -24,11 +24,19 @@ You can view the results of building and testing on Travis by clicking the button below: -[](https://travis-ci.org/massysett/prednote)+[](https://travis-ci.org/massysett/prednote) If you have trouble building prednote due to dependency issues, try looking at the previous test results, as they will show you package versions that were used to build prednote successfully.++## Something similar++See also rematch:++http://hackage.haskell.org/package/rematch++which is apparently based on a Java library called hamcrest. ## License
changelog view
@@ -1,3 +1,15 @@+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.
+ genCabal.hs view
@@ -0,0 +1,172 @@+-- Generates the Cabal file for prednote.+-- Written to use version 0.14.2.0 of the Cartel+-- library.++module Main where++import Cartel+import Control.Applicative++atLeast :: NonEmptyString -> [Word] -> Package+atLeast name ver = package name (gtEq ver)++versionInts :: [Word]+versionInts = [0,36,0,4]++base :: Package+base = closedOpen "base" [4,7] [5]++rainbow :: Package+rainbow = atLeast "rainbow" [0,26]++text :: Package+text = atLeast "text" [0,11,2,0]++containers :: Package+containers = atLeast "containers" [0,4,2,1]++quickcheck :: Package+quickcheck = atLeast "QuickCheck" [2,7]++tasty :: Package+tasty = atLeast "tasty" [0,10]++tastyQuickcheck :: Package+tastyQuickcheck = atLeast "tasty-quickcheck" [0,8]++tastyTh :: Package+tastyTh = atLeast "tasty-th" [0,1]++bytestring :: Package+bytestring = atLeast "bytestring" [0,10]++properties :: Properties+properties = blank+ { name = "prednote"+ , version = versionInts+ , cabalVersion = Just (1,18)+ , buildType = Just simple+ , license = Just bsd3+ , licenseFile = "LICENSE"+ , copyright = "Copyright 2013-2015 Omari Norman"+ , author = "Omari Norman"+ , maintainer = "omari@smileystation.com"+ , stability = "Experimental"+ , homepage = "http://www.github.com/massysett/prednote"+ , bugReports = "http://www.github.com/massysett/prednote/issues"+ , category = "Data"+ , synopsis = "Evaluate and display trees of predicates"+ , description =+ [ "Build and evaluate trees of predicates. For example, you might build"+ , "a predicate of the type Int -> Bool. You do this by assembling"+ , "several predicates into a tree. You can then verbosely evaluate"+ , "this tree, showing why a particular result is reached."+ , ""+ , "prednote also provides modules to test several subjects against a"+ , "given predicate, and to parse infix or RPN expressions into a tree of"+ , "predicates."+ ]+ , extraSourceFiles =+ [ "README.md"+ , "changelog"+ , "genCabal.hs"+ ]++ }++ghcOpts :: [String]+ghcOpts = ["-Wall"]++-- Dependencies++split :: Package+split = atLeast "split" [0,2,2]++contravariant :: Package+contravariant = atLeast "contravariant" [1,2]++transformers :: Package+transformers = atLeast "transformers" [0,3,0,0]++libDepends :: [Package]+libDepends =+ [ base+ , rainbow+ , split+ , text+ , containers+ , contravariant+ , transformers+ , bytestring+ ]++library+ :: [String]+ -- ^ Library modules+ -> [LibraryField]+library ms =+ [ exposedModules ms+ , buildDepends libDepends+ , hsSourceDirs ["lib"]+ , ghcOptions ghcOpts+ , haskell2010+ ]++tests+ :: FlagName+ -- ^ Visual-tests flag+ -> [String]+ -- ^ Library modules+ -> [String]+ -- ^ Test modules+ -> (Section, Section)+ -- ^ The prednote-tests test suite, and the prednote-visual-tests+ -- executable+tests fl ls ts =+ ( testSuite "prednote-tests" $+ commonTestOpts ls ts +++ [ mainIs "prednote-tests.hs"+ , exitcodeStdio+ ]+ , testSuite "prednote-visual-tests" $+ [ mainIs "prednote-visual-tests.hs"+ , exitcodeStdio+ ] ++ commonTestOpts ls ts+ )++commonTestOpts+ :: HasBuildInfo a+ => [String]+ -- ^ Library modules+ -> [String]+ -- ^ Test modules+ -> [a]+commonTestOpts ls ts =+ [ hsSourceDirs ["lib", "tests"]+ , otherModules (ls ++ ts)+ , ghcOptions ghcOpts+ , haskell2010+ , otherExtensions ["TemplateHaskell"]+ , buildDepends+ $ tasty : tastyQuickcheck : tastyTh : quickcheck : libDepends+ ]++visualTests :: Applicative m => Betsy m FlagName+visualTests = makeFlag "visual-tests" $ FlagOpts+ { flagDescription = "Build the prednote-visual-tests executable"+ , flagDefault = False+ , flagManual = True+ }++github :: Section+github = githubHead "massysett" "prednote"++main :: IO ()+main = defaultMain $ do+ fl <- visualTests+ libMods <- modules "lib"+ testMods <- modules "tests"+ let (tsts, vis) = tests fl libMods testMods+ lib = library libMods+ repo = githubHead "massysett" "prednote"+ return (properties, lib, [tsts, vis, github])
lib/Prednote.hs view
@@ -1,118 +1,22 @@--- | This module provides everything you need for most uses of Prednote.--- The core type of Prednote is the 'Pred', which is a rose--- 'Tree' of predicates along with some additional information, such--- as a 'plan', which shows you how the 'Pred' will be evaluated--- without actually having to apply it to a particular subject. When--- evaluating a 'Pred', you can also display a 'report' describing the--- evaluation process.------ This module builds 'Pred' with 'report's that make sparing use of--- color; for example, 'True' results have @[TRUE]@ indicated in--- green, @[FALSE]@ in red, and /short circuits/ (that is, 'Pred' that--- were evaluated without evaluating all their child 'Pred') indicated--- in yellow. They are also nicely indented to indicate the structure--- of the 'Tree'.------ If you want more control over how your results are formatted,--- examine "Prednote.Core" and "Prednote.Format".--- "Prednote.Comparisons" builds on this module to provide 'Pred' to--- use for common comparisons (such as greater than, less than, etc.)--- "Prednote.Expressions" helps you parse infix or postfix (i.e. RPN)--- expressions.+-- | Prednote - annotated predicates ----- This module exports some names that conflict with Prelude names, so--- you might want to do something like+-- 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- ( -- * Pred- Pred-- -- * Visibility-- -- | Upon evaluation, each 'Pred' has a visibility, indicated with- -- 'Visible'. It can be either 'shown' or 'hidden'. The- -- visibility of a 'Pred' does not affect any of the results, nor- -- does it affect how the 'Pred' is shown in the 'plan'; rather,- -- it affects only how the result of the 'Pred' is shown in the- -- 'report'. If a 'Pred' is 'hidden', its value and the value of- -- its children is not shown in the 'report'.-- , C.Visible- , C.shown- , C.hidden- , P.visibility- , P.reveal- , P.hide- , P.showTrue- , P.showFalse-- -- * Predicates-- -- | These 'Pred' have no child 'Pred'.-- , P.predicate- , P.true- , P.false- , P.same-- -- * Combinators-- -- | These functions combine one more more 'Pred' to create a new- -- 'Pred'; the argument 'Pred' become children of the new 'Pred'.-- , P.all- , (&&&)- , P.any- , (|||)- , P.not- , P.wrap-- -- ** Fanout-- -- | These functions allow you to take a single subject and split it- -- into multiple subjects, applying a 'Pred' to each subject that- -- results. As a simple example, this allows you to build a 'Pred'- -- ['Int'] that combines 'Pred' that test individual 'Int' along- -- with 'Pred' that examine the entire list of ['Int'].-- , P.fanAll- , P.fanAny- , P.fanAtLeast-- -- * Reports and plans-- -- | A 'plan' displays a 'Pred' without evaluating it, while a- -- 'report' shows the process through which a 'Pred' was evaluated- -- for a particular subject.-- , C.Output- , plan- , C.evaluate- , report-- -- * Evaluation and reporting-- -- | These functions use 'report', 'C.evaluate', or both.-- , C.test- , C.testV- , C.filter- , C.filterV+ ( module Prednote.Comparisons+ , module Prednote.Expressions+ , module Prednote.Core ) where -import qualified Prednote.Prebuilt as P-import Prednote.Prebuilt ((&&&), (|||))-import Prednote.Core (Pred)-import qualified Prednote.Core as C-import Rainbow-import Data.Tree---- | Indents and formats static labels for display. This is a 'plan'--- for how the 'Pred' would be applied.-plan :: Pred a -> [Chunk]-plan = C.plan 0---- | Indents and formats output for display.-report :: Tree C.Output -> [Chunk]-report = C.report 0+import Prednote.Comparisons+import Prednote.Expressions+import Prednote.Core
lib/Prednote/Comparisons.hs view
@@ -1,27 +1,87 @@ {-# LANGUAGE OverloadedStrings #-}-module Prednote.Comparisons where+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 -import Prednote.Prebuilt-import Prednote.Format-import qualified Prednote.Core as C-import Data.Text (Text)-import qualified Data.Text as X+ -- * 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.-compareBy- :: Text- -- ^ Description of the type of thing that is being matched-- -> Text+compareByM+ :: (Show a, Functor f)+ => Text -- ^ Description of the right-hand side - -> (a -> Text)- -- ^ Describes the left-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@@ -32,26 +92,15 @@ -- order for the Predbox to be True; otherwise it is False. The subject -- will be on the left hand side. - -> C.Pred a+ -> Pred a -compareBy typeDesc rhsDesc lhsDesc get ord = predicate stat dyn pd- where- stat = typeDesc <+> "is" <+> ordDesc <+> rhsDesc- ordDesc = case ord of- EQ -> "equal to"- LT -> "less than"- GT -> "greater than"- dyn a = typeDesc <+> lhsDesc a <+> "is" <+> ordDesc <+> rhsDesc- pd a = get a == ord+compareBy rhsDesc get ord = compareByM rhsDesc (fmap return get) ord -- | Overloaded version of 'compareBy'. compare :: (Show a, Ord a)- => Text- -- ^ Description of the type of thing that is being matched-- -> a+ => a -- ^ Right-hand side -> Ordering@@ -59,59 +108,97 @@ -- order for the Predbox to be True; otherwise it is False. The subject -- will be on the left hand side. - -> C.Pred a-compare typeDesc rhs ord =- compareBy typeDesc (X.pack . show $ rhs) (X.pack . show)- (`Prelude.compare` rhs) ord+ -> Pred a+compare rhs ord =+ compareBy (X.pack . show $ rhs) (`Prelude.compare` rhs) ord -- | Builds a 'Pred' that tests items for equality. -equalBy- :: Text- -- ^ Description of the type of thing that is being matched+equalByM+ :: (Show a, Functor f) - -> Text+ => Text -- ^ Description of the right-hand side - -> (a -> Text)- -- ^ Describes the left-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. - -> C.Pred a-equalBy typeDesc rhsDesc lhsDesc get = predicate stat dyn get- where- stat = typeDesc <+> "is equal to" <+> rhsDesc- dyn a = typeDesc <+> lhsDesc a <+> "is equal to" <+> rhsDesc+ -> 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 type of thing that is being matched+ -- ^ Description of the right-hand side - -> a- -- ^ 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. - -> C.Pred a-equal typeDesc rhs = equalBy typeDesc (X.pack . show $ rhs)- (X.pack . show) (== rhs)+ -> 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- :: Text- -- ^ Description of the type of thing that is being matched-- -> Text+ :: Show a+ => Text -- ^ Description of the right-hand side - -> (a -> Text)- -- ^ Describes the left-hand side- -> (a -> Maybe Ordering) -- ^ How to compare an item against the right hand side. Return LT if -- the item is less than the right hand side; GT if greater; EQ if@@ -122,186 +209,200 @@ -- order for the Predbox to be True; otherwise it is False. The subject -- will be on the left hand side. - -> C.Pred a+ -> Pred a -compareByMaybe typeDesc rhsDesc lhsDesc get ord = predicate stat dyn fn- where- stat = typeDesc <+> "is" <+> ordDesc <+> rhsDesc- dyn a = typeDesc <+> lhsDesc a <+> "is" <+> ordDesc <+> rhsDesc- ordDesc = case ord of- EQ -> "equal to"- LT -> "less than"- GT -> "greater than"- fn a = case get a of- Nothing -> False- Just o -> o == ord+compareByMaybe rhsDesc get ord = compareByMaybeM rhsDesc (fmap return get) ord greater :: (Show a, Ord a) - => Text- -- ^ Description of the type of thing being matched-- -> a+ => a -- ^ Right-hand side - -> C.Pred a-greater typeDesc rhs = compare typeDesc rhs GT+ -> Pred a+greater rhs = compare rhs GT less :: (Show a, Ord a) - => Text- -- ^ Description of the type of thing being matched-- -> a+ => a -- ^ Right-hand side - -> C.Pred a-less typeDesc rhs = compare typeDesc rhs LT+ -> Pred a+less rhs = compare rhs LT greaterEq :: (Show a, Ord a)- => Text- -- ^ Description of the type of thing being matched-- -> a+ => a -- ^ Right-hand side - -> C.Pred a-greaterEq t r = greater t r ||| equal t r+ -> Pred a+greaterEq r = greater r ||| equal r lessEq :: (Show a, Ord a)- => Text- -- ^ Description of the type of thing being matched-- -> a+ => a -- ^ Right-hand side - -> C.Pred a-lessEq t r = less t r ||| equal t r+ -> 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 the type of thing being matched+ -- ^ Description of right-hand side - -> a- -- ^ 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. - -> C.Pred a-notEq t r = not $ equal t r+ -> PredM f a+greaterByM desc get = compareByM desc get GT greaterBy- :: Text- -- ^ Description of the type of thing being matched-- -> Text+ :: Show a+ => Text -- ^ Description of right-hand side - -> (a -> Text)- -- ^ Describes the left-hand side- -> (a -> Ordering) -- ^ How to compare an item against the right hand side. Return LT -- if the item is less than the right hand side; GT if greater; EQ -- if equal to the right hand side. - -> C.Pred a-greaterBy dT dR dL get = compareBy dT dR dL get GT+ -> Pred a+greaterBy desc get = greaterByM desc (fmap return get) -lessBy- :: Text- -- ^ Description of the type of thing being matched-- -> Text+lessByM+ :: (Show a, Functor f)+ => Text -- ^ Description of right-hand side - -> (a -> Text)- -- ^ Describes the left-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. - -> C.Pred a-lessBy dT dR dL get = compareBy dT dR dL get LT--greaterEqBy- :: Text- -- ^ Description of the type of thing being matched+ -> Pred a+lessBy desc get = lessByM desc (fmap return get) - -> Text+greaterEqByM+ :: (Functor f, Monad f, Show a)+ => Text -- ^ Description of right-hand side - -> (a -> Text)- -- ^ Describes the left-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. - -> C.Pred a-greaterEqBy dT dR dL f = greaterBy dT dR dL f ||| equalBy dT dR dL f'+ -> 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 (== EQ) f+ f' = fmap (fmap (== EQ)) get lessEqBy- :: Text- -- ^ Description of the type of thing being matched-- -> Text+ :: Show a+ => Text -- ^ Description of right-hand side - -> (a -> Text)- -- ^ Describes the left-hand side- -> (a -> Ordering) -- ^ How to compare an item against the right hand side. Return LT -- if the item is less than the right hand side; GT if greater; EQ -- if equal to the right hand side. - -> C.Pred a-lessEqBy dT dR dL f = lessBy dT dR dL f ||| equalBy dT dR dL f'- where- f' = fmap (== EQ) f--notEqBy- :: Text- -- ^ Description of the type of thing being matched+ -> Pred a+lessEqBy desc get = lessEqByM desc (fmap return get) - -> Text+notEqByM+ :: (Functor f, Show a)+ => Text -- ^ Description of right-hand side - -> (a -> Text)- -- ^ Describes the left-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. - -> C.Pred a-notEqBy dT dR dL = not . equalBy dT dR dL-+ -> 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- :: Text+ :: (Monad f, Functor f)+ => Text -- ^ The string with the comparer to be parsed - -> (Ordering -> C.Pred a)- -- ^ A function that, when given an ordering, returns a 'C.Pred'.+ -> (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 (C.Pred a)+ -> Maybe (PredM f a) -- ^ If an invalid comparer string is given, Nothing; otherwise, the- -- 'C.Pred'.+ -- 'Pred'. parseComparer t f | t == ">" = Just (f GT) | t == "<" = Just (f LT)@@ -312,4 +413,13 @@ | t == "/=" = Just (not $ f EQ) | t == "!=" = Just (not $ f EQ) | otherwise = Nothing++-- | Append two 'X.Text', with an intervening space if both 'X.Text'+-- are not empty.+(<+>) :: Text -> Text -> Text+l <+> r+ | full l && full r = l <> " " <> r+ | otherwise = l <> r+ where+ full = Prelude.not . X.null
lib/Prednote/Core.hs view
@@ -1,325 +1,496 @@-{-# LANGUAGE BangPatterns #-}--- | 'Pred' core functions. If your needs are simple, "Prednote.Prebuilt"--- is easier to use. However, the types and functions in this module--- give you more control.------ Each function in this module that returns a 'Pred' returns one with--- the following characteristics:------ * No 'static' name------ Upon evaluation:------ * 'visible' is always 'shown'------ * 'short' is either 'Nothing' or @'Just' ('const' [])@------ * 'dynamic' is always @'const' []@------ Thus, the 'Pred' created by this module are rather bare-bones, but--- you can modify them as you see fit; "Prednote.Prebuilt" already--- does this for you.------ This module exports some names that conflict with Prelude names, so--- you might want to do something like------ > import qualified Prednote.Pred.Core as P+{-# LANGUAGE OverloadedStrings #-}+module Prednote.Core+ ( -- * Predicates and their creation+ PredM(..)+ , Pred+ , predicate+ , predicateM+ , contramapM -module Prednote.Core where+ -- * 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 Prelude hiding (filter, not)+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.Functor.Contravariant (Contravariant(..))-import Data.Tree+import Data.Text (Text) import qualified Data.Text as X-import Data.Maybe+import Data.List (intersperse)+import Data.Functor.Identity+import Control.Applicative+import qualified Data.ByteString as BS --- | Indicates how to display text. This function is applied to an--- 'Int' that is the level of indentation; each level of descent--- through a tree of 'Pred' increments this 'Int' by one. Because the--- function returns a list of 'Chunk', you can use multiple colors.--- Typically this function will indent text accordingly, with a--- newline at the end.-type Chunker = Int -> [Chunk]+-- | 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 --- | A rose tree of predicates.-data Pred a = Pred- { static :: Tree Chunker- -- ^ A tree of static names, allowing you to identify the 'Pred'- -- without applying it to a subject.+-- | 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) - , evaluate :: a -> Tree Output- -- ^ Evaluates a 'Pred' by applying it to a subject.- }+instance Monoid Condition where+ mempty = Condition []+ mappend (Condition x) (Condition y) = Condition (x ++ y) -instance Contravariant Pred where- contramap f (Pred s e) = Pred s (e . f)+-- | Stores the representation of a value.+newtype Value = Value [Chunk Text]+ deriving (Eq, Ord, Show) --- | The result of evaluating a 'Pred'.-data Output = Output- { result :: Bool- , visible :: Visible- -- ^ Results that are not 'Visible' are not shown by the 'report'- -- function.- , short :: Maybe Chunker- -- ^ Indicates whether there was a short circuit when evaluating- -- this 'Pred'. A short circuit occurs when the 'Pred' does not- -- need to evaluate all of its children in order to reach a- -- result. If 'Nothing', there was no short circuit; otherwise,- -- this is a 'Just' with a 'Chunker' providing a way to display- -- the short circuit.+instance Monoid Value where+ mempty = Value []+ mappend (Value x) (Value y) = Value (x ++ y) - , dynamic :: Chunker- -- ^ The dynamic label; this indicates how 'report' will show the- -- 'Pred' to the user after it has been evaluated.- }+-- | 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 Show Output where- show (Output r v _ _) = "output - result: " ++ show r- ++ " visible: " ++ (show . unVisible $ v)+instance Monoid Label where+ mempty = Label []+ mappend (Label x) (Label y) = Label (x ++ y) --- | Is this result visible? If not, 'Prednote.report' will not show it.-newtype Visible = Visible { unVisible :: Bool }+-- | Any type that is accompanied by a set of labels.+data Labeled a = Labeled [Label] a deriving (Eq, Ord, Show) --- | Shown by 'Prednote.report'-shown :: Visible-shown = Visible True+instance Functor Labeled where+ fmap f (Labeled l a) = Labeled l (f a) --- | Hidden by 'Prednote.report'-hidden :: Visible-hidden = Visible False+-- | 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) --- | No 'Pred' in the list may be 'False' for 'all' to be 'True'. An--- empty list of 'Pred' yields a 'Pred' that always returns 'True'.--- May short circuit.-all :: [Pred a] -> Pred a-all ls = Pred st' ev- where- st' = Node (const []) . map static $ ls- ev a = go [] ls- where- go soFar [] = Node (Output True shown Nothing (const []))- (reverse soFar)- go soFar (x:xs) =- let tree = evaluate x a- r = result . rootLabel $ tree- shrt = case xs of- [] -> Nothing- _ -> Just (const [])- out = Output r shown shrt (const [])- cs = reverse (tree:soFar)- in case xs of- [] -> Node out cs- _ | Prelude.not r -> Node out cs- | otherwise -> go cs xs+-- | 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) --- | At least one 'Pred' in the list must be 'True' for the resulting--- 'Pred' to be 'True'. An empty list of 'Pred' yields a 'Pred' that--- always returns 'False'. May short circuit.-any :: [Pred a] -> Pred a-any ls = Pred st' ev- where- st' = Node (const []) . map static $ ls- ev a = go [] ls- where- go soFar [] = Node (Output False shown Nothing (const []))- (reverse soFar)- go soFar (x:xs) =- let tree = evaluate x a- r = result . rootLabel $ tree- shrt = case xs of- [] -> Nothing- _ -> Just (const [])- out = Output r shown shrt (const [])- cs = reverse (tree:soFar)- in case xs of- [] -> Node out cs- _ | r -> Node out cs- | otherwise -> go cs xs+-- | 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) --- | Negates the child 'Pred'. Never short circuits.-not :: Pred a -> Pred a-not pd = Pred st' ev+-- | 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- st' = Node (const []) [static pd]- ev a = Node nd [c]+ f' a = fmap mkResult $ f a where- nd = Output res shown Nothing (const [])- (res, c) = (Prelude.not r, t)+ mkResult (b, val, cond) = Result (Labeled [] r) where- t = evaluate pd a- r = result . rootLabel $ t+ r | b = Right (PTerminal val cond)+ | otherwise = Left (FTerminal val cond) --- | Fanout. May short circuit.-fan- :: ([Bool] -> (Bool, Visible, Maybe Int))- -- ^ This function is applied to a list of the 'result' from- -- evaluating the child 'Pred' on each fanout item. The function- -- must return a triple, with the 'Bool' indicating success or- -- failure, 'Visible' for visibility, and 'Maybe' 'Int' to indicate- -- whether a short circuit occurred; this must be 'Nothing' if there- -- was no short circuit, or 'Just' with an 'Int' to indicate a short- -- circuit, with the 'Int' indicating that a short circuit occurred- -- after examining the given number of elements.- --- -- The resulting 'Pred' always short circuits if the previous- -- function returns a 'Just' 'Int' with the 'Int' being less than- -- zero. Otherwise, the resulting 'Pred' short circuits if- -- the 'Int' is less than the number of elements returned by the- -- fanout function.+-- | 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) - -> (a -> [b])- -- ^ Fanout function+-- | 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)) - -> Pred b- -> Pred a-fan get fn pd = Pred st' ev- where- st' = Node (const []) [static pd]- ev a = Node nd cs- where- nd = Output r v shrt (const [])- (r, v, mayInt) = get bools- shrt = case mayInt of- Nothing -> Nothing- Just s | s < 0 -> Just (const [])- | cs `shorter` allcs -> Just (const [])- | otherwise -> Nothing- bs = fn a- allcs = map (evaluate pd) bs- bools = map (result . rootLabel) allcs- cs = case mayInt of- Nothing -> allcs- Just i -> take i allcs+infixr 3 &&& --- | Fanout all. The resulting 'Pred' is 'True' if no child item--- returns 'False'; an empty list of child items returns 'True'. May--- short circuit.-fanAll- :: (a -> [b])- -- ^ Fanout function+-- | 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 ||| - -> Pred b- -> Pred a-fanAll = fan get+-- | 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- get = go 0+ g a = Result (Labeled [] rslt) where- go !c ls = case ls of- [] -> (True, shown, Just c)- x:xs- | Prelude.not x -> (False, shown, Just (c + 1))- | otherwise -> go (c + 1) xs+ rslt = case splitResult a of+ Left b -> Right (PNot b)+ Right y -> Left (FNot y) --- | Fanout any. The resulting 'Pred' is 'True' if at least one child--- item returns 'True'; an empty list of child items returns 'False'.--- May short circuit.-fanAny- :: (a -> [b])- -- ^ Fanout function - -> Pred b- -> Pred a-fanAny = fan get+-- | 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- get = go 0- where- go !c ls = case ls of- [] -> (False, shown, Just c)- x:xs- | x -> (True, shown, Just (c + 1))- | otherwise -> go (c + 1) xs+ PredM fa = pa+ PredM fb = pb --- | Fanout at least. The resulting 'Pred' is 'True' if at least the--- given number of child items return 'True'. May short circuit.-fanAtLeast- :: Int- -- ^ Find at least this many. If this number is less than or equal- -- to zero, 'fanAtLeast' will always return 'True'.+-- | Did this 'Result' pass or fail?+resultToBool :: Result -> Bool+resultToBool (Result (Labeled _ ei))+ = either (const False) (const True) ei - -> (a -> [b])- -- ^ Fanout function - -> Pred b- -> Pred a-fanAtLeast i = fan get+-- | Always returns 'True'+true :: Applicative f => PredM f a+true = predicateM (const (pure trip)) where- get = go 0 0- where- go !found !c ls- | found >= i = (True, shown, Just c)- | otherwise = case ls of- [] -> (False, shown, Just c)- x:xs -> go fnd' (c + 1) xs- where- fnd' | x = found + 1- | otherwise = found+ trip = (True, mempty, Condition [chunk "always returns True"]) --- | Indents and formats output for display.-report- :: Int- -- ^ Start at this level of indentation.- -> Tree Output- -> [Chunk]-report l (Node n cs)- | (== hidden) . visible $ n = []- | otherwise = this ++ concatMap (report (l + 1)) cs ++ shrt+-- | Always returns 'False'+false :: Applicative f => PredM f a+false = predicateM (const (pure trip)) where- this = dynamic n l- shrt = maybe [] ($ (l + 1)) . short $ n+ trip = (False, mempty, Condition [chunk "always returns False"]) --- | Indents and formats static labels for display. This is a 'plan'--- for how the 'Pred' would be applied.-plan- :: Int- -- ^ Start at this level of indentation.- -> Pred a- -> [Chunk]-plan lvl pd = go lvl (static pd)+-- | 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- go l (Node n cs) = this ++ concatMap (go (l + 1)) cs+ f' a = fmap g (f a) where- this = n l+ g (Result (Labeled ss ei)) = Result (Labeled (Label s : ss) ei) -instance Show (Pred a) where- show = X.unpack . X.concat . concat . map text- . plan 0 --- | Applies a 'Pred' to a single subject and returns the 'result'.+-- | 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 = result . rootLabel . evaluate p+test p a = runIdentity $ testM p a --- | Like 'test' but also returns the accompanying 'report'.-testV :: Pred a -> a -> (Bool, [Chunk])-testV p a = (result . rootLabel $ t, report 0 t)++-- | 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- t = evaluate p a+ g rslt = (resultToChunks rslt, resultToBool rslt) --- | Like 'Prelude.filter'.-filter :: Pred a -> [a] -> [a]-filter p = Prelude.filter (test p)+verboseTest :: Pred a -> a -> ([Chunk Text], Bool)+verboseTest p a = runIdentity $ verboseTestM p a --- | Like 'filter' but also returns a list of 'report', with one--- 'report' for each list item.-filterV :: Pred a -> [a] -> ([a], [Chunk])-filterV p as = (mapMaybe fltr (zip as rslts), cks)++-- | 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- fltr (a, r)- | result . rootLabel $ r = Just a- | otherwise = Nothing- rslts = map (evaluate p) as- cks = concatMap (report 0) rslts+ full = Prelude.any (Prelude.not . X.null) . map _yarn --- | @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+-- | Append two lists of 'Chunk', with an intervening hyphen if both+-- lists have text.+(<->) :: [Chunk Text] -> [Chunk Text] -> [Chunk Text]+l <-> r+ | full l && full r = l <> hyphen <> r+ | otherwise = l <> r+ where+ full = Prelude.any (Prelude.not . X.null) . map _yarn++hyphen :: [Chunk Text]+hyphen = [chunk " - "]++indentAmt :: Int+indentAmt = 2++spaces :: Int -> [Chunk Text]+spaces i = (:[]) . chunk . X.replicate (i * indentAmt)+ . X.singleton $ ' '++newline :: [Chunk Text]+newline = [chunk "\n"]++labelToChunks :: Label -> [Chunk Text]+labelToChunks (Label cks) = cks++explainTerminal :: Value -> Condition -> [Chunk Text]+explainTerminal (Value v) (Condition c)+ = v ++ (chunk " " : c)++-- | Obtain a list of 'Chunk' describing the evaluation process.+passedToChunks+ :: Int+ -- ^ Number of levels of indentation+ -> Labeled Passed+ -> [Chunk Text]+passedToChunks i (Labeled l p) = this <> rest+ where+ this = spaces i <> (lblTrue <+> (labels `sep` explain)) <> newline+ labels = concat . intersperse hyphen . map labelToChunks $ l+ nextPass = passedToChunks (succ i)+ nextFail = failedToChunks (succ i)+ (explain, rest, sep) = case p of+ PTerminal v c -> (explainTerminal v c, [], (<->))+ PAnd p1 p2 -> (explainAnd, nextPass p1 <> nextPass p2, (<+>))+ POr ei -> (explainOr, more, (<+>))+ where+ more = case ei of+ Left y -> nextPass y+ Right (n, y) -> nextFail n <> nextPass y+ PNot n -> (explainNot, nextFail n, (<+>))++-- | Obtain a list of 'Chunk' describing the evaluation process.+failedToChunks+ :: Int+ -- ^ Number of levels of indentation+ -> Labeled Failed+ -> [Chunk Text]+failedToChunks i (Labeled l p) = this <> rest+ where+ this = spaces i <> (lblFalse <+> (labels `sep` explain)) <> newline+ labels = concat . intersperse hyphen . map labelToChunks $ l+ nextPass = passedToChunks (succ i)+ nextFail = failedToChunks (succ i)+ (explain, rest, sep) = case p of+ FTerminal v c -> (explainTerminal v c, [], (<->))+ FAnd ei -> (explainAnd, more, (<+>))+ where+ more = case ei of+ Left n -> nextFail n+ Right (y, n) -> nextPass y <> nextFail n+ FOr n1 n2 -> (explainOr, nextFail n1 <> nextFail n2, (<+>))+ FNot y -> (explainNot, nextPass y, (<+>))++-- | Like 'verboseTest', but results are printed to standard output.+-- Primarily for use in debugging or in a REPL.+verboseTestStdout :: Pred a -> a -> IO Bool+verboseTestStdout p a = do+ let (cks, r) = verboseTest p a+ mkr <- byteStringMakerFromEnvironment+ mapM_ BS.putStr . chunksToByteStrings mkr $ cks+ return r
lib/Prednote/Expressions.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} --- | Handles parsing of both infix and RPN Predbox expressions.+-- | Handles parsing of both infix and RPN 'Pred' expressions. module Prednote.Expressions ( ExprDesc(..) , Error@@ -15,42 +15,40 @@ ) where import Data.Either (partitionEithers)-import Data.Functor.Contravariant import qualified Data.Text as X import qualified Prednote.Expressions.Infix as I import qualified Prednote.Expressions.RPN as R-import Prednote.Core (Pred)+import Prednote.Core+import qualified Prelude+import Prelude hiding (maybe) -- | 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+newtype Token m a = Token { unToken :: I.InfixToken m a } type Error = X.Text --- | Creates Operands from Predbox.-operand :: Pred a -> Token a+-- | Creates Operands from 'Pred'.+operand :: PredM m a -> Token m a operand p = Token (I.TokRPN (R.TokOperand p)) -- | The And operator-opAnd :: Token a+opAnd :: Token m a opAnd = Token (I.TokRPN (R.TokOperator R.OpAnd)) -- | The Or operator-opOr :: Token a+opOr :: Token m a opOr = Token (I.TokRPN (R.TokOperator R.OpOr)) -- | The Not operator-opNot :: Token a+opNot :: Token m a opNot = Token (I.TokRPN (R.TokOperator R.OpNot)) -- | Open parentheses-openParen :: Token a+openParen :: Token m a openParen = Token (I.TokParen I.Open) -- | Close parentheses-closeParen :: Token a+closeParen :: Token m a closeParen = Token (I.TokParen I.Close) -- | Is this an infix or RPN expression?@@ -59,7 +57,7 @@ | RPN deriving (Eq, Show) -toksToRPN :: [Token a] -> Maybe [R.RPNToken a]+toksToRPN :: [Token m a] -> Maybe [R.RPNToken m a] toksToRPN toks = let toEither t = case unToken t of I.TokRPN tok -> Right tok@@ -73,15 +71,16 @@ -- RPN expression, or multiple stack values remaining.) Works by first -- changing infix expressions to RPN ones. parseExpression- :: ExprDesc- -> [Token a]- -> Either Error (Pred a)+ :: (Functor m, Monad m)+ => ExprDesc+ -> [Token m a]+ -> Either Error (PredM m a) parseExpression e toks = do rpnToks <- case e of- Infix -> maybe (Left "unbalanced parentheses\n") Right+ Infix -> Prelude.maybe (Left "unbalanced parentheses\n") Right . I.createRPN . map unToken $ toks- RPN -> maybe (Left "parentheses in an RPN expression\n") Right+ RPN -> Prelude.maybe (Left "parentheses in an RPN expression\n") Right $ toksToRPN toks R.parseRPN rpnToks
lib/Prednote/Expressions/Infix.hs view
@@ -4,19 +4,13 @@ , createRPN ) where -import Data.Functor.Contravariant import qualified Prednote.Expressions.RPN as R import qualified Data.Foldable as Fdbl -data InfixToken a- = TokRPN (R.RPNToken a)+data InfixToken f a+ = TokRPN (R.RPNToken f 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.@@ -31,9 +25,9 @@ -- output (this is done in the createRPN function.) processInfixToken- :: ([OpStackVal], [R.RPNToken a])- -> InfixToken a- -> Maybe ([OpStackVal], [R.RPNToken a])+ :: ([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@@ -55,9 +49,9 @@ -- -- And has higher precedence than Or. processRPNToken- :: ([OpStackVal], [R.RPNToken a])- -> R.RPNToken a- -> ([OpStackVal], [R.RPNToken a])+ :: ([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@@ -70,7 +64,7 @@ -- | 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 :: [OpStackVal] -> [R.RPNToken f a] -> ([OpStackVal], [R.RPNToken f a]) popper os ts = case os of [] -> (os, ts) x:xs -> case x of@@ -86,8 +80,8 @@ -- but not onto the output stack. Fails if the stack has no open -- parentheses. popThroughOpen- :: ([OpStackVal], [R.RPNToken a])- -> Maybe ([OpStackVal], [R.RPNToken a])+ :: ([OpStackVal], [R.RPNToken f a])+ -> Maybe ([OpStackVal], [R.RPNToken f a]) popThroughOpen (os, ts) = case os of [] -> Nothing v:vs -> case v of@@ -98,9 +92,9 @@ -- Close parenthesis, pops operators off the operator stack through -- the next open parenthesis on the operator stack. processParen- :: ([OpStackVal], [R.RPNToken a])+ :: ([OpStackVal], [R.RPNToken f a]) -> Paren- -> Maybe ([OpStackVal], [R.RPNToken a])+ -> Maybe ([OpStackVal], [R.RPNToken f a]) processParen (os, ts) p = case p of Open -> Just (StkOpenParen : os, ts) Close -> popThroughOpen (os, ts)@@ -110,11 +104,11 @@ -- RPN expression; the RPN parser must catch this. createRPN :: Fdbl.Foldable f- => f (InfixToken a)+ => f (InfixToken m a) -- ^ The input tokens, with the beginning of the expression on the -- left side of the sequence. - -> Maybe [R.RPNToken a]+ -> 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@@ -124,7 +118,7 @@ -- | 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 :: [OpStackVal] -> [R.RPNToken f a] -> Maybe [R.RPNToken f a] popRemainingOperators os ts = case os of [] -> return ts x:xs -> case x of
lib/Prednote/Expressions/RPN.hs view
@@ -6,37 +6,31 @@ -- where @and@ and @or@ are binary and @not@ is unary. module Prednote.Expressions.RPN where -import Data.Functor.Contravariant import qualified Data.Foldable as Fdbl-import qualified Prednote.Prebuilt as P-import Prednote.Core (Pred)-import Prednote.Prebuilt ((&&&), (|||))+import qualified Prednote.Core as P+import Prednote.Core ((&&&), (|||), PredM) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as X -data RPNToken a- = TokOperand (Pred a)+data RPNToken f a+ = TokOperand (PredM f a) | TokOperator Operator -instance Contravariant RPNToken where- contramap f t = case t of- TokOperand p -> TokOperand . contramap f $ p- TokOperator o -> TokOperator o- data Operator = OpAnd | OpOr | OpNot deriving Show -pushOperand :: Pred a -> [Pred a] -> [Pred a]+pushOperand :: PredM f a -> [PredM f a] -> [PredM f a] pushOperand p ts = p : ts pushOperator- :: Operator- -> [Pred a]- -> Either Text [Pred a]+ :: (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@@ -52,22 +46,25 @@ <> "\" operator\n" pushToken- :: [Pred a]- -> RPNToken a- -> Either Text [Pred a]+ :: (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 Predbox. Fails if+-- | 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- :: Fdbl.Foldable f- => f (RPNToken a)- -> Either Text (Pred a)+ :: (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
− lib/Prednote/Format.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--- | Functions used to format text. Typically you won't need these--- unless you want tailored control over how your 'Prednote.Core.Pred'--- are formatted.-module Prednote.Format where--import Rainbow-import Data.Text (Text)-import qualified Data.Text as X-import qualified Prednote.Core as C-import qualified Data.Tree as E-import Data.Monoid---- # Labels and indentation---- | A colorful label for 'True' values.-lblTrue :: [Chunk]-lblTrue = ["[", fore green <> "TRUE", "]"]---- | A colorful label for 'False' values.-lblFalse :: [Chunk]-lblFalse = ["[", fore red <> "FALSE", "]"]---- | Indent amount.-indentAmt :: Int-indentAmt = 2---- | Prefixes the given 'Text' with colorful text to indicate 'True'--- or 'False' as appropriate.-lblLine :: Bool -> Text -> [Chunk]-lblLine b t = lbl ++ [" ", fromText t]- where- lbl | b = lblTrue- | otherwise = lblFalse---- | Indents the given list of 'Chunk' by the given 'Int' multipled by--- 'indentAmt'. Appends a newline.-indent :: [Chunk] -> Int -> [Chunk]-indent cs i = spaces : cs ++ [fromText "\n"]- where- spaces = fromText . X.replicate (indentAmt * i)- . X.singleton $ ' '---- | A label for a short circuit.-shortCir :: Int -> [Chunk]-shortCir = indent ["[", fore yellow <> "short circuit", "]"]---- | Indents a 'Text' by the given 'Int' multiplied by--- 'indentAmt'.-indentTxt :: Text -> Int -> [Chunk]-indentTxt = indent . (:[]) . fromText---- | Append two 'Text', with an intervening space if both 'Text' are--- not empty.-(<+>) :: Text -> Text -> Text-l <+> r- | full l && full r = l <> " " <> r- | otherwise = l <> r- where- full = Prelude.not . X.null---- | Create a new 'C.Pred' with a different static label.-rename :: Text -> C.Pred a -> C.Pred a-rename x p = p { C.static = (C.static p)- { E.rootLabel = indentTxt x } }---- | Creates a new 'C.Pred' with a result differing from the original--- 'C.Pred'.-changeOutput- :: (a -> C.Output -> C.Output)- -- ^ Function to modify the 'C.Output'-- -> C.Pred a- -- ^ Modify the 'C.Output' of this 'C.Pred'-- -> C.Pred a-changeOutput f p = p { C.evaluate = e' }- where- e' a = t'- where- t = C.evaluate p a- t' = t { E.rootLabel = f a (E.rootLabel t) }---- | Creates a new 'C.Pred' with a different dynamic label.-speak- :: (a -> Text)- -- ^ New dynamic label. Do not indicate whether the result is- -- 'True' or 'False'; this is done for you.-- -> C.Pred a-- -> C.Pred a-speak f = changeOutput g- where- g a o = o { C.dynamic = dyn }- where- dyn = indent $ lblLine (C.result o) (f a)----- | Creates a new 'C.Pred' with any short circuits having a colorful--- label.-speakShort :: C.Pred a -> C.Pred a-speakShort p = p { C.evaluate = e' }- where- e' a = t { E.rootLabel = (E.rootLabel t)- { C.short = fmap (const shortCir) shrt } }- where- t = C.evaluate p a- shrt = C.short . E.rootLabel $ t-
− lib/Prednote/Prebuilt.hs
@@ -1,179 +0,0 @@-{-# LANGUAGE OverloadedStrings, BangPatterns #-}---- | Functions to work with 'Pred'. This module works with 'Text' and--- produces 'Pred' that make sparing use of color. For more control--- over the 'Pred' produced, use "Prednote.Pred.Core".------ Exports some names that conflict with Prelude names, so you might--- want to do something like------ > import qualified Prednote.Pred as P-module Prednote.Prebuilt where--import qualified Prednote.Core as C-import Prednote.Format-import qualified Data.Tree as E-import qualified Data.Text as X-import Data.Text (Text)-import Data.Monoid-import Prelude hiding (and, or, not, filter, compare, any, all)-import qualified Prelude---- # Predicate---- | Builds predicates.-predicate- :: Text- -- ^ Static label-- -> (a -> Text)- -- ^ Computes the dynamic label. Do not indicate whether the result- -- is 'True' or 'False'; this is automatically done for you.-- -> (a -> Bool)- -- ^ Predicate function-- -> C.Pred a--predicate r s f = rename r . speak s $ C.Pred (E.Node (const []) []) ev- where- ev a = E.Node (C.Output (f a) C.shown Nothing (const [])) []---- | Always returns 'True' and is always visible.-true :: C.Pred a-true = predicate l (const l) (const True)- where- l = "always True"---- | Always returns 'False' and is always visible.-false :: C.Pred a-false = predicate l (const l) (const False)- where- l = "always False"---- | Returns the subject as is; is always visible.-same :: C.Pred Bool-same = predicate l (const l) id- where- l = "same as subject"---- # Wrap---- | Makes an existing 'C.Pred' the child of a new 'C.Pred'. The new--- 'Pred' has the same 'C.result' as the child 'C.Pred'. The new--- 'C.Pred' is always visible and never short circuits.--wrap- :: Text- -- ^ Static label-- -> (a -> Text)- -- ^ Computes the dynamic label. Do not indicate whether the result- -- is 'True' or 'False'; this is automatically done for you.-- -> (a -> b)- -> C.Pred b- -> C.Pred a-wrap st dyn wr p = C.Pred trC ev- where- trC = E.Node (indentTxt st) [C.static p]- ev a = E.Node o [c]- where- c = C.evaluate p (wr a)- r = C.result . E.rootLabel $ c- o = C.Output r C.shown Nothing dy- dy = indent $ lblLine r (dyn a)----- # Visibility---- | Creates a 'C.Pred' with its visibility modified.-visibility- :: (Bool -> C.Visible)- -- ^ When applied to the 'C.result' of the 'C.Pred', this function- -- returns the desired visibility.- -> C.Pred a- -> C.Pred a-visibility f (C.Pred s e) = C.Pred s e'- where- e' a = g (e a)- g (E.Node n cs) = E.Node n { C.visible = f (C.result n) } cs---- | Creates a 'C.Pred' that is always shown.-reveal :: C.Pred a -> C.Pred a-reveal = visibility (const C.shown)---- | Creates a 'C.Pred' that is always hidden.-hide :: C.Pred a -> C.Pred a-hide = visibility (const C.hidden)---- | Creates a 'C.Pred' that is shown only if its 'C.result' is--- 'True'.-showTrue :: C.Pred a -> C.Pred a-showTrue = visibility (\b -> if b then C.shown else C.hidden)---- | Creates a 'C.Pred' that is shown only if its 'C.result' is--- 'False'.-showFalse :: C.Pred a -> C.Pred a-showFalse = visibility (\b -> if Prelude.not b then C.shown else C.hidden)---- # Conjunction and disjunction, negation---- | No child 'Pred' may be 'False'. An empty list of child 'Pred'--- returns 'True'. Always visible.-all :: [C.Pred a] -> C.Pred a-all = speakShort . rename l . speak (const l) . C.all- where- l = "all"---- | Creates 'all' 'Pred' that are always visible.-(&&&) :: C.Pred a -> C.Pred a -> C.Pred a-l &&& r = all [l, r]--infixr 3 &&&---- | At least one child 'Pred' must be 'True'. An empty list of child--- 'Pred' returns 'False'. Always visible.-any :: [C.Pred a] -> C.Pred a-any = speakShort . rename l . speak (const l) . C.any- where- l = "any"----- | Creates 'any' 'Pred' that are always visible.-(|||) :: C.Pred a -> C.Pred a -> C.Pred a-l ||| r = any [l, r]--infixr 2 |||---- | Negation. Always visible.-not :: C.Pred a -> C.Pred a-not = rename l . speak (const l) . C.not- where- l = "not"---- | No fanned-out item may be 'False'. An empty list of child items--- returns 'True'.-fanAll :: (a -> [b]) -> C.Pred b -> C.Pred a-fanAll f = speakShort . rename l . speak (const l) . C.fanAll f- where- l = "fanout all"------ | At least one fanned-out item must be 'True'. An empty list of--- child items returns 'False'.-fanAny :: (a -> [b]) -> C.Pred b -> C.Pred a-fanAny f = speakShort . rename l . speak (const l) . C.fanAny f- where- l = "fanout any"----- | At least the given number of child items must be 'True'.-fanAtLeast :: Int -> (a -> [b]) -> C.Pred b -> C.Pred a-fanAtLeast i f = speakShort . rename l . speak (const l)- . C.fanAtLeast i f- where- l = "fanout - at least " <> X.pack (show i) <>- " fanned-out subject(s) must be True"-
prednote.cabal view
@@ -3,15 +3,16 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: genCabal.hs--- Generated on: 2015-01-01 23:35:08.896332 EST--- Cartel library version: 0.10.0.2+-- Generated on: 2015-09-09 21:57:21.988823 EDT+-- Cartel library version: 0.14.2.6+ name: prednote-version: 0.26.0.4-cabal-version: >= 1.14-build-type: Simple+version: 0.36.0.4+cabal-version: >= 1.18 license: BSD3 license-file: LICENSE-copyright: Copyright 2013-2014 Omari Norman+build-type: Simple+copyright: Copyright 2013-2015 Omari Norman author: Omari Norman maintainer: omari@smileystation.com stability: Experimental@@ -27,38 +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.- .- tests are packaged separately in the prednote-tests package. category: Data-tested-with: GHC == 7.6.3, GHC == 7.8.2 extra-source-files:- README.md- , changelog--source-repository head- type: git- location: git://github.com/massysett/prednote.git- branch: master+ README.md+ changelog+ genCabal.hs Library exposed-modules:- Prednote- , Prednote.Comparisons- , Prednote.Core- , Prednote.Expressions- , Prednote.Expressions.Infix- , Prednote.Expressions.RPN- , Prednote.Format- , Prednote.Prebuilt+ Prednote+ Prednote.Comparisons+ Prednote.Core+ Prednote.Expressions+ Prednote.Expressions.Infix+ Prednote.Expressions.RPN build-depends:- base ((> 4.5.0.0 || == 4.5.0.0) && < 5)- , contravariant ((> 0.2.0.1 || == 0.2.0.1) && < 1.3)- , rainbow ((> 0.20.0.4 || == 0.20.0.4) && < 0.21)- , split ((> 0.2.2 || == 0.2.2) && < 0.3)- , text ((> 0.11.2.0 || == 0.11.2.0) && < 1.3)- , containers ((> 0.4.2.1 || == 0.4.2.1) && < 0.6)+ base >= 4.7 && < 5+ , rainbow >= 0.26+ , split >= 0.2.2+ , text >= 0.11.2.0+ , containers >= 0.4.2.1+ , contravariant >= 1.2+ , transformers >= 0.3.0.0+ , bytestring >= 0.10 hs-source-dirs:- lib+ lib ghc-options:- -Wall+ -Wall default-language: Haskell2010++Test-Suite prednote-tests+ hs-source-dirs:+ lib+ tests+ other-modules:+ Prednote+ Prednote.Comparisons+ Prednote.Core+ Prednote.Expressions+ Prednote.Expressions.Infix+ Prednote.Expressions.RPN+ Instances+ Prednote.Core.Instances+ Prednote.Core.Properties+ Rainbow.Instances+ ghc-options:+ -Wall+ default-language: Haskell2010+ other-extensions:+ TemplateHaskell+ build-depends:+ 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++Test-Suite prednote-visual-tests+ main-is: prednote-visual-tests.hs+ type: exitcode-stdio-1.0+ hs-source-dirs:+ lib+ tests+ other-modules:+ Prednote+ Prednote.Comparisons+ Prednote.Core+ Prednote.Expressions+ Prednote.Expressions.Infix+ Prednote.Expressions.RPN+ Instances+ Prednote.Core.Instances+ Prednote.Core.Properties+ Rainbow.Instances+ ghc-options:+ -Wall+ default-language: Haskell2010+ other-extensions:+ TemplateHaskell+ build-depends:+ tasty >= 0.10+ , tasty-quickcheck >= 0.8+ , tasty-th >= 0.1+ , QuickCheck >= 2.7+ , base >= 4.7 && < 5+ , rainbow >= 0.26+ , split >= 0.2.2+ , text >= 0.11.2.0+ , containers >= 0.4.2.1+ , contravariant >= 1.2+ , transformers >= 0.3.0.0+ , bytestring >= 0.10++source-repository head+ type: git+ location: https://github.com/massysett/prednote.git++Flag visual-tests+ description: Build the prednote-visual-tests executable+ default: False+ manual: True
+ tests/Instances.hs view
@@ -0,0 +1,18 @@+module Instances where++import Control.Applicative+import Test.QuickCheck+import Rainbow.Types+import qualified Data.Text as X++newtype ChunkA = ChunkA Chunk+ deriving (Eq, Ord, Show)++newtype TextA = TextA X.Text+ deriving (Eq, Ord, Show)++instance Arbitrary TextA where+ arbitrary = (TextA . X.pack) <$> listOf arbitrary++instance Arbitrary Chunk where+ arbitrary = undefined
+ tests/Prednote/Core/Instances.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Prednote.Core.Instances where++import Rainbow.Instances ()+import Test.QuickCheck hiding (Result)+import Control.Monad+import Prednote.Core++instance (CoArbitrary a, Show a) => Arbitrary (Pred a) where+ arbitrary = fmap predicate arbitrary++instance Arbitrary Condition where+ arbitrary = fmap Condition arbitrary++instance CoArbitrary Condition where+ coarbitrary (Condition c) = coarbitrary c++instance Arbitrary Value where+ arbitrary = fmap Value arbitrary++instance CoArbitrary Value where+ coarbitrary (Value x) = coarbitrary x++instance Arbitrary Label where+ arbitrary = fmap Label arbitrary++instance CoArbitrary Label where+ coarbitrary (Label x) = coarbitrary x++instance Arbitrary a => Arbitrary (Labeled a) where+ arbitrary = liftM2 Labeled arbitrary arbitrary++instance CoArbitrary a => CoArbitrary (Labeled a) where+ coarbitrary (Labeled a b) = coarbitrary a . coarbitrary b++instance Arbitrary Passed where+ arbitrary = sized f+ where+ f s | s < 10 = liftM2 PTerminal arbitrary arbitrary+ | otherwise = oneof+ [ liftM2 PTerminal arbitrary arbitrary+ , liftM2 PAnd nestPass nestPass+ , fmap POr+ (oneof [ fmap Left nestPass,+ fmap Right (liftM2 (,) nestFail nestPass)+ ])+ , fmap PNot nestFail+ ]+ where+ nestPass = resize (s `div` 4) arbitrary+ nestFail = resize (s `div` 4) arbitrary + +instance Arbitrary Failed where+ arbitrary = sized f+ where+ f s | s < 10 = liftM2 FTerminal arbitrary arbitrary+ | otherwise = oneof+ [ liftM2 FTerminal arbitrary arbitrary+ , fmap FAnd+ (oneof [ fmap Left nestFail+ , fmap Right (liftM2 (,) nestPass nestFail)+ ])+ , liftM2 FOr nestFail nestFail+ , fmap FNot nestPass+ ]+ where+ nestPass = resize (s `div` 4) arbitrary+ nestFail = resize (s `div` 4) arbitrary++varInt :: Int -> Gen a -> Gen a+varInt = variant++instance CoArbitrary Passed where+ coarbitrary pass = case pass of+ PTerminal v c -> varInt 0 . coarbitrary v . coarbitrary c+ PAnd y1 y2 -> varInt 1 . coarbitrary y1 . coarbitrary y2+ POr e -> varInt 2 . coarbitrary e+ PNot n -> varInt 3 . coarbitrary n++instance CoArbitrary Failed where+ coarbitrary fll = case fll of+ FTerminal v c -> varInt 0 . coarbitrary v . coarbitrary c+ FAnd e -> varInt 1 . coarbitrary e+ FOr x y -> varInt 2 . coarbitrary x . coarbitrary y+ FNot x -> varInt 3 . coarbitrary x++instance Arbitrary Result where+ arbitrary = fmap Result arbitrary++instance CoArbitrary Result where+ coarbitrary (Result x) = coarbitrary x+
+ tests/Prednote/Core/Properties.hs view
@@ -0,0 +1,84 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE TemplateHaskell #-}++module Prednote.Core.Properties where++import Prednote.Core.Instances ()+import Prednote.Core+import Test.QuickCheck.Function+import Prelude hiding (not, any, all)+import qualified Prelude+import Test.Tasty+import Test.Tasty.QuickCheck+import Test.Tasty.TH++tests :: TestTree+tests = $(testGroupGenerator)++testInt :: Pred Int -> Int -> Bool+testInt = test++prop_andIsLazyInSecondArgument i+ = testInt (false &&& undefined) i || True++prop_orIsLazyInSecondArgument i+ = testInt (true ||| undefined) i || True++fst3 :: (a, b, c) -> a+fst3 (a, _, _) = a++prop_andIsLikePreludeAnd (Fun _ f1) (Fun _ f2) i+ = testInt (p1 &&& p2) i == (fst3 (f1 i) && fst3 (f2 i))+ where+ p1 = predicate f1+ p2 = predicate f2++prop_orIsLikePreludeOr (Fun _ f1) (Fun _ f2) i+ = testInt (p1 ||| p2) i == (fst3 (f1 i) || fst3 (f2 i))+ where+ p1 = predicate f1+ p2 = predicate f2++prop_notIsLikePreludeNot (Fun _ f1) i+ = testInt (not p1) i == Prelude.not (fst3 (f1 i))+ where+ p1 = predicate f1++prop_switchIsLazyInFirstArgument pb i+ = test (switch undefined pb) (Right i) || True+ where+ _types = pb :: Pred Int+ +prop_switchIsLazyInSecondArgument pa i+ = test (switch pa undefined) (Left i) || True+ where+ _types = pa :: Pred Int++prop_switch (Fun _ fa) (Fun _ fb) ei+ = test (switch pa pb) ei == expected+ where+ _types = ei :: Either Int Char+ expected = case ei of+ Left i -> fst3 (fa i)+ Right c -> fst3 (fb c)+ pa = predicate fa+ pb = predicate fb+ +prop_true = testInt true++prop_false = Prelude.not . testInt false++prop_same b = test same b == b++prop_any (Fun _ f) ls+ = test (any pa) ls == Prelude.any (fmap fst3 f) ls+ where+ pa = predicate f+ _types = ls :: [Int]+ +prop_all (Fun _ f) ls+ = test (all pa) ls == Prelude.all (fmap fst3 f) ls+ where+ pa = predicate f+ _types = ls :: [Int]+
+ tests/Rainbow/Instances.hs view
@@ -0,0 +1,106 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, DeriveGeneric, StandaloneDeriving #-}++-- | QuickCheck instances for all of Rainbow. Currently Rainbow does+-- not use these instances itself; they are only here for+-- cut-and-paste for other libraries that may need them. There is an+-- executable in Rainbow that is built solely to make sure this module+-- compiles without any errors.+--+-- To use these instances, just drop them into your own project+-- somewhere. They are not packaged as a library because there are+-- orphan instances.++module Rainbow.Instances where++import Control.Applicative+import Test.QuickCheck+import Rainbow.Types+import qualified Data.Text as X+import Data.Typeable++instance (Arbitrary a, Typeable a) => Arbitrary (Color a) where+ arbitrary = Color <$> arbitrary+ shrink = genericShrink++instance CoArbitrary a => CoArbitrary (Color a) where+ coarbitrary (Color a) = coarbitrary a++varInt :: Int -> Gen b -> Gen b+varInt = variant++instance Arbitrary Enum8 where+ arbitrary = elements [E0, E1, E2, E3, E4, E5, E6, E7]+ shrink = genericShrink++instance CoArbitrary Enum8 where+ coarbitrary x = case x of+ E0 -> varInt 0+ E1 -> varInt 1+ E2 -> varInt 2+ E3 -> varInt 3+ E4 -> varInt 4+ E5 -> varInt 5+ E6 -> varInt 6+ E7 -> varInt 7++instance Arbitrary Format where+ arbitrary+ = Format <$> g <*> g <*> g <*> g <*> g <*> g <*> g <*> g+ where+ g = arbitrary+ shrink = genericShrink++instance CoArbitrary Format where+ coarbitrary (Format x0 x1 x2 x3 x4 x5 x6 x7)+ = coarbitrary x0+ . coarbitrary x1+ . coarbitrary x2+ . coarbitrary x3+ . coarbitrary x4+ . coarbitrary x5+ . coarbitrary x6+ . coarbitrary x7++instance (Arbitrary a, Typeable a) => Arbitrary (Style a) where+ arbitrary = Style <$> arbitrary <*> arbitrary <*> arbitrary+ shrink = genericShrink++instance CoArbitrary a => CoArbitrary (Style a) where+ coarbitrary (Style a b c)+ = coarbitrary a+ . coarbitrary b+ . coarbitrary c+++instance Arbitrary Scheme where+ arbitrary = Scheme <$> arbitrary <*> arbitrary+ shrink = genericShrink++instance CoArbitrary Scheme where+ coarbitrary (Scheme a b) = coarbitrary a . coarbitrary b++instance (Arbitrary a, Typeable a) => Arbitrary (Chunk a) where+ arbitrary = Chunk <$> arbitrary <*> arbitrary+ shrink = genericShrink++instance CoArbitrary a => CoArbitrary (Chunk a) where+ coarbitrary (Chunk a b)+ = coarbitrary a+ . coarbitrary b++instance Arbitrary Radiant where+ arbitrary = Radiant <$> arbitrary <*> arbitrary+ shrink = genericShrink++instance CoArbitrary Radiant where+ coarbitrary (Radiant a b) = coarbitrary a . coarbitrary b++instance Arbitrary X.Text where+ arbitrary = fmap X.pack $ listOf genChar+ where+ genChar = elements ['a'..'z']+ shrink = fmap X.pack . shrink . X.unpack++instance CoArbitrary X.Text where+ coarbitrary = coarbitrary . X.unpack
+ tests/prednote-tests.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+module Main where++import Test.Tasty+import qualified Prednote.Core.Properties++main :: IO ()+main = defaultMain $ testGroup "all tests"+ [ Prednote.Core.Properties.tests+ ]
+ tests/prednote-visual-tests.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}+module Main where++import Prednote+import Prelude hiding (any, all, maybe)++main :: IO ()+main = do+ verboseTestStdout (all $ lessEq (5 :: Int)) [0..10]+ verboseTestStdout (any $ equal (4 :: Int)) [0..3]+ verboseTestStdout (any $ equal (10 :: Int)) []+ verboseTestStdout (all $ maybe True (lessEq (5 :: Int)))+ [Nothing, Just 1, Just 2, Nothing, Just 3, Just 4, Just 5]+ return ()