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 @@ -24,11 +24,19 @@ You can view the results of building and testing on Travis by clicking the button below: -[![Build Status](https://travis-ci.org/massysett/prednote.svg?branch=v0.26.0.4)](https://travis-ci.org/massysett/prednote) +[![Build Status](https://travis-ci.org/massysett/prednote.svg?branch=master)](https://travis-ci.org/massysett/prednote) If you have trouble building prednote due to dependency issues, try looking at the previous test results, as they will show you package versions that were used to build prednote successfully. + +## Something similar + +See also rematch: + +http://hackage.haskell.org/package/rematch + +which is apparently based on a Java library called hamcrest. ## License diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -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. diff --git a/genCabal.hs b/genCabal.hs new file mode 100644 --- /dev/null +++ b/genCabal.hs @@ -0,0 +1,172 @@ +-- Generates the Cabal file for prednote. +-- Written to use version 0.14.2.0 of the Cartel +-- library. + +module Main where + +import Cartel +import Control.Applicative + +atLeast :: NonEmptyString -> [Word] -> Package +atLeast name ver = package name (gtEq ver) + +versionInts :: [Word] +versionInts = [0,36,0,4] + +base :: Package +base = closedOpen "base" [4,7] [5] + +rainbow :: Package +rainbow = atLeast "rainbow" [0,26] + +text :: Package +text = atLeast "text" [0,11,2,0] + +containers :: Package +containers = atLeast "containers" [0,4,2,1] + +quickcheck :: Package +quickcheck = atLeast "QuickCheck" [2,7] + +tasty :: Package +tasty = atLeast "tasty" [0,10] + +tastyQuickcheck :: Package +tastyQuickcheck = atLeast "tasty-quickcheck" [0,8] + +tastyTh :: Package +tastyTh = atLeast "tasty-th" [0,1] + +bytestring :: Package +bytestring = atLeast "bytestring" [0,10] + +properties :: Properties +properties = blank + { name = "prednote" + , version = versionInts + , cabalVersion = Just (1,18) + , buildType = Just simple + , license = Just bsd3 + , licenseFile = "LICENSE" + , copyright = "Copyright 2013-2015 Omari Norman" + , author = "Omari Norman" + , maintainer = "omari@smileystation.com" + , stability = "Experimental" + , homepage = "http://www.github.com/massysett/prednote" + , bugReports = "http://www.github.com/massysett/prednote/issues" + , category = "Data" + , synopsis = "Evaluate and display trees of predicates" + , description = + [ "Build and evaluate trees of predicates. For example, you might build" + , "a predicate of the type Int -> Bool. You do this by assembling" + , "several predicates into a tree. You can then verbosely evaluate" + , "this tree, showing why a particular result is reached." + , "" + , "prednote also provides modules to test several subjects against a" + , "given predicate, and to parse infix or RPN expressions into a tree of" + , "predicates." + ] + , extraSourceFiles = + [ "README.md" + , "changelog" + , "genCabal.hs" + ] + + } + +ghcOpts :: [String] +ghcOpts = ["-Wall"] + +-- Dependencies + +split :: Package +split = atLeast "split" [0,2,2] + +contravariant :: Package +contravariant = atLeast "contravariant" [1,2] + +transformers :: Package +transformers = atLeast "transformers" [0,3,0,0] + +libDepends :: [Package] +libDepends = + [ base + , rainbow + , split + , text + , containers + , contravariant + , transformers + , bytestring + ] + +library + :: [String] + -- ^ Library modules + -> [LibraryField] +library ms = + [ exposedModules ms + , buildDepends libDepends + , hsSourceDirs ["lib"] + , ghcOptions ghcOpts + , haskell2010 + ] + +tests + :: FlagName + -- ^ Visual-tests flag + -> [String] + -- ^ Library modules + -> [String] + -- ^ Test modules + -> (Section, Section) + -- ^ The prednote-tests test suite, and the prednote-visual-tests + -- executable +tests fl ls ts = + ( testSuite "prednote-tests" $ + commonTestOpts ls ts ++ + [ mainIs "prednote-tests.hs" + , exitcodeStdio + ] + , testSuite "prednote-visual-tests" $ + [ mainIs "prednote-visual-tests.hs" + , exitcodeStdio + ] ++ commonTestOpts ls ts + ) + +commonTestOpts + :: HasBuildInfo a + => [String] + -- ^ Library modules + -> [String] + -- ^ Test modules + -> [a] +commonTestOpts ls ts = + [ hsSourceDirs ["lib", "tests"] + , otherModules (ls ++ ts) + , ghcOptions ghcOpts + , haskell2010 + , otherExtensions ["TemplateHaskell"] + , buildDepends + $ tasty : tastyQuickcheck : tastyTh : quickcheck : libDepends + ] + +visualTests :: Applicative m => Betsy m FlagName +visualTests = makeFlag "visual-tests" $ FlagOpts + { flagDescription = "Build the prednote-visual-tests executable" + , flagDefault = False + , flagManual = True + } + +github :: Section +github = githubHead "massysett" "prednote" + +main :: IO () +main = defaultMain $ do + fl <- visualTests + libMods <- modules "lib" + testMods <- modules "tests" + let (tsts, vis) = tests fl libMods testMods + lib = library libMods + repo = githubHead "massysett" "prednote" + return (properties, lib, [tsts, vis, github]) diff --git a/lib/Prednote.hs b/lib/Prednote.hs --- a/lib/Prednote.hs +++ b/lib/Prednote.hs @@ -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 diff --git a/lib/Prednote/Comparisons.hs b/lib/Prednote/Comparisons.hs --- a/lib/Prednote/Comparisons.hs +++ b/lib/Prednote/Comparisons.hs @@ -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 diff --git a/lib/Prednote/Core.hs b/lib/Prednote/Core.hs --- a/lib/Prednote/Core.hs +++ b/lib/Prednote/Core.hs @@ -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 diff --git a/lib/Prednote/Expressions.hs b/lib/Prednote/Expressions.hs --- a/lib/Prednote/Expressions.hs +++ b/lib/Prednote/Expressions.hs @@ -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 diff --git a/lib/Prednote/Expressions/Infix.hs b/lib/Prednote/Expressions/Infix.hs --- a/lib/Prednote/Expressions/Infix.hs +++ b/lib/Prednote/Expressions/Infix.hs @@ -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 diff --git a/lib/Prednote/Expressions/RPN.hs b/lib/Prednote/Expressions/RPN.hs --- a/lib/Prednote/Expressions/RPN.hs +++ b/lib/Prednote/Expressions/RPN.hs @@ -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 diff --git a/lib/Prednote/Format.hs b/lib/Prednote/Format.hs deleted file mode 100644 --- a/lib/Prednote/Format.hs +++ /dev/null @@ -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 - diff --git a/lib/Prednote/Prebuilt.hs b/lib/Prednote/Prebuilt.hs deleted file mode 100644 --- a/lib/Prednote/Prebuilt.hs +++ /dev/null @@ -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" - diff --git a/prednote.cabal b/prednote.cabal --- a/prednote.cabal +++ b/prednote.cabal @@ -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 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 ()