packages feed

prednote 0.28.0.2 → 0.36.0.4

raw patch · 14 files changed

Files

genCabal.hs view
@@ -1,81 +1,62 @@ -- Generates the Cabal file for prednote.--- Written to use version 0.10.0.2 of the Cartel+-- Written to use version 0.14.2.0 of the Cartel -- library.  module Main where -import qualified Cartel as C--versionInts :: [Int]-versionInts = [0,28,0,2]--base :: C.Package-base = C.closedOpen "base" [4,5,0,0] [5]--rainbowLower :: [Int]-rainbowLower = [0,20,0,4]--rainbowUpper :: [Int]-rainbowUpper = [0,21]--rainbow :: C.Package-rainbow = C.closedOpen "rainbow" rainbowLower rainbowUpper--rainbow_tests :: C.Package-rainbow_tests = C.closedOpen "rainbow-tests" rainbowLower rainbowUpper+import Cartel+import Control.Applicative -text :: C.Package-text = C.closedOpen "text" [0,11,2,0] [1,3]+atLeast :: NonEmptyString -> [Word] -> Package+atLeast name ver = package name (gtEq ver) -containers :: C.Package-containers = C.closedOpen "containers" [0,4,2,1] [0,6]+versionInts :: [Word]+versionInts = [0,36,0,4] -barecheck :: C.Package-barecheck = C.closedOpen "barecheck" [0,2,0,0] [0,3]+base :: Package+base = closedOpen "base" [4,7] [5] -quickcheck :: C.Package-quickcheck = C.closedOpen "QuickCheck" [2,5] [2,8]+rainbow :: Package+rainbow = atLeast "rainbow" [0,26] -commonProperties :: C.Properties-commonProperties = C.empty-  { C.prVersion = C.Version versionInts-  , C.prLicenseFile = "LICENSE"-  , C.prCopyright = "Copyright 2013-2015 Omari Norman"-  , C.prAuthor = "Omari Norman"-  , C.prMaintainer = "omari@smileystation.com"-  , C.prStability = "Experimental"-  , C.prHomepage = "http://www.github.com/massysett/prednote"-  , C.prBugReports = "http://www.github.com/massysett/prednote/issues"-  , C.prCategory = "Data"-  , C.prSynopsis = "Evaluate and display trees of predicates"-  }+text :: Package+text = atLeast "text" [0,11,2,0] -repo :: C.Repository-repo = C.empty-  { C.repoVcs = C.Git-  , C.repoKind = C.Head-  , C.repoLocation = "git://github.com/massysett/prednote.git"-  , C.repoBranch = "master"-  }+containers :: Package+containers = atLeast "containers" [0,4,2,1] -ghcOptions :: [String]-ghcOptions = ["-Wall"]+quickcheck :: Package+quickcheck = atLeast "QuickCheck" [2,7] --- Dependencies+tasty :: Package+tasty = atLeast "tasty" [0,10] -split :: C.Package-split = C.closedOpen "split" [0,2,2] [0,3]+tastyQuickcheck :: Package+tastyQuickcheck = atLeast "tasty-quickcheck" [0,8] -quickpull :: C.Package-quickpull = C.closedOpen "quickpull" [0,4] [0,5]+tastyTh :: Package+tastyTh = atLeast "tasty-th" [0,1] -contravariant :: C.Package-contravariant = C.closedOpen "contravariant" [1,2] [1,3]+bytestring :: Package+bytestring = atLeast "bytestring" [0,10] -properties :: C.Properties-properties = commonProperties-  { C.prName = "prednote"-  , C.prDescription =+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"@@ -85,16 +66,29 @@     , "given predicate, and to parse infix or RPN expressions into a tree of"     , "predicates."     ]-  , C.prTestedWith = map (\ls -> (C.GHC, C.eq ls))-    [ [7,6,3], [7,8,2] ]-  , C.prExtraSourceFiles =+  , extraSourceFiles =     [ "README.md"     , "changelog"     , "genCabal.hs"     ]+   } -libDepends :: [C.Package]+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@@ -102,87 +96,77 @@   , text   , containers   , contravariant+  , transformers+  , bytestring   ]  library   :: [String]   -- ^ Library modules-  -> C.Library-library ms = C.Library-  [ C.LibExposedModules ms-  , C.buildDepends libDepends-  , C.hsSourceDirs ["lib"]-  , C.ghcOptions ghcOptions-  , C.defaultLanguage C.Haskell2010+  -> [LibraryField]+library ms =+  [ exposedModules ms+  , buildDepends libDepends+  , hsSourceDirs ["lib"]+  , ghcOptions ghcOpts+  , haskell2010   ]  tests-  :: [String]+  :: FlagName+  -- ^ Visual-tests flag+  -> [String]   -- ^ Library modules   -> [String]   -- ^ Test modules-  -> (C.TestSuite, C.Executable)-tests ls ts =-  ( C.TestSuite "prednote-tests" $+  -> (Section, Section)+  -- ^ The prednote-tests test suite, and the prednote-visual-tests+  -- executable+tests fl ls ts =+  ( testSuite "prednote-tests" $     commonTestOpts ls ts ++-    [ C.TestMainIs "prednote-tests.hs"-    , C.TestType C.ExitcodeStdio-    ]-  , C.Executable "prednote-visual-tests" $-    [ C.ExeMainIs "prednote-visual-tests.hs"-    , C.cif (C.flag "visual-tests")-       ( commonTestOpts ls ts ++-        [ C.buildable True-        ]-       )-      [ C.buildable False-      ]+    [ mainIs "prednote-tests.hs"+    , exitcodeStdio     ]+  , testSuite "prednote-visual-tests" $+    [ mainIs "prednote-visual-tests.hs"+    , exitcodeStdio+    ] ++ commonTestOpts ls ts   )  commonTestOpts-  :: C.Field a+  :: HasBuildInfo a   => [String]   -- ^ Library modules   -> [String]   -- ^ Test modules   -> [a] commonTestOpts ls ts =-  [ C.hsSourceDirs ["lib", "tests"]-  , C.otherModules (ls ++ ts)-  , C.ghcOptions ghcOptions-  , C.defaultLanguage C.Haskell2010-  , C.buildDepends $ quickcheck : quickpull : libDepends+  [ hsSourceDirs ["lib", "tests"]+  , otherModules (ls ++ ts)+  , ghcOptions ghcOpts+  , haskell2010+  , otherExtensions ["TemplateHaskell"]+  , buildDepends+    $ tasty : tastyQuickcheck : tastyTh : quickcheck : libDepends   ] -visualTests :: C.Flag-visualTests = C.Flag-  { C.flName = "visual-tests"-  , C.flDescription = "Build the prednote-visual-tests executable"-  , C.flDefault = False-  , C.flManual = True+visualTests :: Applicative m => Betsy m FlagName+visualTests = makeFlag "visual-tests" $ FlagOpts+  { flagDescription = "Build the prednote-visual-tests executable"+  , flagDefault = False+  , flagManual = True   } --cabal-  :: [String]-  -- ^ Modules for library-  -> [String]-  -- ^ Modules for tests-  -> C.Cabal-cabal ls ts = C.empty-  { C.cProperties = properties-  , C.cRepositories = [repo]-  , C.cLibrary = Just $ library ls-  , C.cTestSuites = [testSuite]-  , C.cExecutables = [executable]-  , C.cFlags = [visualTests]-  }-  where-    (testSuite, executable) = tests ls ts+github :: Section+github = githubHead "massysett" "prednote"  main :: IO ()-main = do-  libMods <- C.modules "lib"-  testMods <- C.modules "tests"-  C.render "genCabal.hs" $ cabal libMods testMods+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/Comparisons.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Prednote.Comparisons-  ( compareBy+  ( -- * Comparisions that do not run in a context+    compareBy   , compare   , equalBy   , equal@@ -15,6 +16,18 @@   , greaterEqBy   , lessEqBy   , notEqBy++  -- * Comparisions that run in a context+  , compareByM+  , equalByM+  , compareByMaybeM+  , greaterByM+  , lessByM+  , greaterEqByM+  , lessEqByM+  , notEqByM++  -- * Parsing comparers   , parseComparer   ) where @@ -22,12 +35,48 @@ import Prelude hiding (compare, not) import qualified Prelude import Data.Monoid-import qualified Data.Text as X import Data.Text (Text)+import qualified Data.Text as X+import Rainbow  -- | Build a Pred that compares items.  The idea is that the item on -- the right hand side is baked into the 'Pred' and that the 'Pred' -- compares this single right-hand side to each left-hand side item.+compareByM+  :: (Show a, Functor f)+  => Text+  -- ^ Description of the right-hand side++  -> (a -> f Ordering)+  -- ^ How to compare the left-hand side to the right-hand side.+  -- Return LT if the item is less than the right hand side; GT if+  -- greater; EQ if equal to the right hand side.++  -> Ordering+  -- ^ When subjects are compared, this ordering must be the result in+  -- order for the Predbox to be True; otherwise it is False. The subject+  -- will be on the left hand side.++  -> PredM f a++compareByM rhsDesc get tgt = predicateM f+  where+    f a = fmap mkTup (get a)+      where+        mkTup ord = (bl, val, cond)+          where+            val = Value [chunk . X.pack . show $ a]+            cond = Condition [chunk condTxt]+            condTxt = "is" <+> ordDesc <+> rhsDesc+            ordDesc = case ord of+              EQ -> "equal to"+              LT -> "less than"+              GT -> "greater than"+            bl = ord == tgt++-- | Build a Pred that compares items.  The idea is that the item on+-- the right hand side is baked into the 'Pred' and that the 'Pred'+-- compares this single right-hand side to each left-hand side item. compareBy   :: Show a   => Text@@ -45,14 +94,7 @@    -> Pred a -compareBy rhsDesc get ord = predicate cond pd-  where-    cond = "is" <+> ordDesc <+> rhsDesc-    ordDesc = case ord of-      EQ -> "equal to"-      LT -> "less than"-      GT -> "greater than"-    pd a = get a == ord+compareBy rhsDesc get ord = compareByM rhsDesc (fmap return get) ord  -- | Overloaded version of 'compareBy'. @@ -72,6 +114,26 @@  -- | Builds a 'Pred' that tests items for equality. +equalByM+  :: (Show a, Functor f)++  => Text+  -- ^ Description of the right-hand side++  -> (a -> f Bool)+  -- ^ How to compare an item against the right hand side.  Return+  -- 'True' if the items are equal; 'False' otherwise.++  -> PredM f a+equalByM rhsDesc get = predicateM f+  where+    f a = fmap mkTup (get a)+      where+        mkTup bl = (bl, Value [chunk . X.pack . show $ a],+          Condition [chunk $ "is equal to" <+> rhsDesc])++-- | Builds a 'Pred' that tests items for equality.+ equalBy   :: Show a @@ -83,9 +145,7 @@   -- 'True' if the items are equal; 'False' otherwise.    -> Pred a-equalBy rhsDesc = predicate cond-  where-    cond = "is equal to" <+> rhsDesc+equalBy rhsDesc f = equalByM rhsDesc (fmap return f)  -- | Overloaded version of 'equalBy'. @@ -99,6 +159,41 @@   -- | Builds a 'Pred' for items that might fail to return a comparison.+compareByMaybeM+  :: (Functor f, Show a)+  => Text+  -- ^ Description of the right-hand side++  -> (a -> f (Maybe Ordering))+  -- ^ How to compare an item against the right hand side. Return LT if+  -- the item is less than the right hand side; GT if greater; EQ if+  -- equal to the right hand side.++  -> Ordering+  -- ^ When subjects are compared, this ordering must be the result in+  -- order for the Predbox to be True; otherwise it is False. The subject+  -- will be on the left hand side.++  -> PredM f a++compareByMaybeM rhsDesc get ord = predicateM f+  where+    f a = fmap mkTup (get a)+      where+        mkTup mayOrd = (bl, val, cond)+          where+            val = Value [chunk . X.pack . show $ a]+            cond = Condition [chunk $ "is" <+> ordDesc <+> rhsDesc]+            ordDesc = case ord of+              EQ -> "equal to"+              LT -> "less than"+              GT -> "greater than"+            bl = case mayOrd of+              Nothing -> False+              Just o -> o == ord+++-- | Builds a 'Pred' for items that might fail to return a comparison. compareByMaybe   :: Show a   => Text@@ -116,16 +211,7 @@    -> Pred a -compareByMaybe rhsDesc get ord = predicate cond pd-  where-    cond = "is" <+> ordDesc <+> rhsDesc-    ordDesc = case ord of-      EQ -> "equal to"-      LT -> "less than"-      GT -> "greater than"-    pd 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)@@ -169,6 +255,19 @@   -> Pred a notEq = not . equal +greaterByM+  :: (Show a, Functor f)+  => Text+  -- ^ Description of right-hand side++  -> (a -> f Ordering)+  -- ^ How to compare an item against the right hand side. Return LT+  -- if the item is less than the right hand side; GT if greater; EQ+  -- if equal to the right hand side.++  -> PredM f a+greaterByM desc get = compareByM desc get GT+ greaterBy   :: Show a   => Text@@ -180,9 +279,22 @@   -- if equal to the right hand side.    -> Pred a-greaterBy desc get = compareBy desc get GT+greaterBy desc get = greaterByM desc (fmap return get)  +lessByM+  :: (Show a, Functor f)+  => Text+  -- ^ Description of right-hand side++  -> (a -> f Ordering)+  -- ^ How to compare an item against the right hand side. Return LT+  -- if the item is less than the right hand side; GT if greater; EQ+  -- if equal to the right hand side.++  -> PredM f a+lessByM desc get = compareByM desc get LT+ lessBy   :: Show a   => Text@@ -194,8 +306,23 @@   -- if equal to the right hand side.    -> Pred a-lessBy desc get = compareBy desc get LT+lessBy desc get = lessByM desc (fmap return get) +greaterEqByM+  :: (Functor f, Monad f, Show a)+  => Text+  -- ^ Description of right-hand side++  -> (a -> f Ordering)+  -- ^ How to compare an item against the right hand side. Return LT+  -- if the item is less than the right hand side; GT if greater; EQ+  -- if equal to the right hand side.++  -> PredM f a+greaterEqByM desc get = greaterByM desc get ||| equalByM desc f'+  where+    f' = fmap (fmap (== EQ)) get+ greaterEqBy   :: Show a   => Text@@ -207,9 +334,22 @@   -- if equal to the right hand side.    -> Pred a-greaterEqBy desc get = greaterBy desc get ||| equalBy desc f'+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) get+    f' = fmap (fmap (== EQ)) get  lessEqBy   :: Show a@@ -222,10 +362,20 @@   -- if equal to the right hand side.    -> Pred a-lessEqBy desc get = lessBy desc get ||| equalBy desc f'-  where-    f' = fmap (== EQ) get+lessEqBy desc get = lessEqByM desc (fmap return get) +notEqByM+  :: (Functor f, Show a)+  => Text+  -- ^ Description of right-hand side++  -> (a -> f Bool)+  -- ^ How to compare an item against the right hand side.  Return+  -- 'True' if equal; 'False' otherwise.++  -> PredM f a+notEqByM desc = not . equalByM desc+ notEqBy   :: Show a   => Text@@ -236,21 +386,21 @@   -- 'True' if equal; 'False' otherwise.    -> Pred a-notEqBy desc = not . equalBy desc-+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 -> Pred a)+  -> (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 (Pred a)+  -> Maybe (PredM f a)   -- ^ If an invalid comparer string is given, Nothing; otherwise, the   -- 'Pred'. parseComparer t f
lib/Prednote/Core.hs view
@@ -1,8 +1,11 @@ {-# LANGUAGE OverloadedStrings #-} module Prednote.Core   ( -- * Predicates and their creation-    Pred(..)+    PredM(..)+  , Pred   , predicate+  , predicateM+  , contramapM    -- * Predicate combinators   -- ** Primitive combinators@@ -27,7 +30,6 @@   -- given above.   , any   , all-  , Nothing   , maybe    -- * Labeling@@ -40,6 +42,8 @@    -- * Evaluating predicates   , test+  , testM+  , runPred   , verboseTest   , verboseTestStdout @@ -63,31 +67,54 @@   ) where  import Rainbow+import Rainbow.Types (_yarn) import Data.Monoid import Data.Functor.Contravariant import Prelude hiding (all, any, maybe, and, or, not) import qualified Prelude-import qualified System.IO as IO-import qualified Data.Text as X import Data.Text (Text)+import qualified Data.Text as X import Data.List (intersperse)+import Data.Functor.Identity+import Control.Applicative+import qualified Data.ByteString as BS +-- | Like 'contramap' but allows the mapping function to run in a+-- monad.+contramapM+  :: Monad m+  => (a -> m b)+  -> PredM m b+  -> PredM m a+contramapM conv (PredM f) = PredM $ \a -> conv a >>= f+ -- | Describes the condition; for example, for a @'Pred' 'Int'@, -- this might be @is greater than 5@; for a @'Pred' 'String'@, this -- might be @begins with \"Hello\"@.-newtype Condition = Condition [Chunk]+newtype Condition = Condition [Chunk Text]   deriving (Eq, Ord, Show) --- | Stores the representation of a value; created using @'X.pack' '.'--- 'show'@.-newtype Value = Value Text+instance Monoid Condition where+  mempty = Condition []+  mappend (Condition x) (Condition y) = Condition (x ++ y)++-- | Stores the representation of a value.+newtype Value = Value [Chunk Text]   deriving (Eq, Ord, Show) +instance Monoid Value where+  mempty = Value []+  mappend (Value x) (Value y) = Value (x ++ y)+ -- | Gives additional information about a particular 'Pred' to aid the -- user when viewing the output.-newtype Label = Label Text+newtype Label = Label [Chunk Text]   deriving (Eq, Ord, Show) +instance Monoid Label where+  mempty = Label []+  mappend (Label x) (Label y) = Label (x ++ y)+ -- | Any type that is accompanied by a set of labels. data Labeled a = Labeled [Label] a   deriving (Eq, Ord, Show)@@ -135,75 +162,98 @@ -- | 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 'Pred' and manipulate them as needed.-newtype Pred a = Pred (a -> Result)+-- 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) } -instance Show (Pred a) where+-- | 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 Pred where-  contramap f (Pred g) = Pred (g . f)+instance Contravariant (PredM f) where+  contramap f (PredM g) = PredM (g . f) --- | Creates a new 'Pred'.  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-  :: Show a-  => Text-  -> (a -> Bool)-  -> Pred a-predicate tCond p = Pred f+-- | Creates a new 'PredM' that run in some arbitrary context.  In+-- @predicateM cond f@, @cond@ describes the condition, while @f@+-- gives the predicate function.  For example, if @f@ is @(> 5)@, then+-- @cond@ might be @"is greater than 5"@.+predicateM+  :: Functor f+  => (a -> f (Bool, Value, Condition))+  -> PredM f a+predicateM f = PredM f'   where-    f a = Result (Labeled [] r)+    f' a = fmap mkResult $ f a       where-        r | p a = Right (PTerminal val cond)-          | otherwise = Left (FTerminal val cond)-        cond = Condition [fromText tCond]-        val = Value . X.pack . show $ a+        mkResult (b, val, cond) = Result (Labeled [] r)+          where+            r | b = Right (PTerminal val cond)+              | otherwise = Left (FTerminal val cond) +-- | Creates a new 'Pred' that do not run in any context.  In+-- @predicate cond f@, @cond@ describes the condition, while @f@ gives+-- the predicate function.  For example, if @f@ is @(> 5)@, then+-- @cond@ might be @"is greater than 5"@.+predicate+  :: (a -> (Bool, Value, Condition))+  -> Pred a+predicate f = predicateM (fmap return f)  -- | And.  Returns 'True' if both argument 'Pred' return 'True'.  Is -- lazy in its second argment; if the first argument returns 'False', -- the second is ignored.-(&&&) :: Pred a -> Pred a -> Pred a-(Pred fL) &&& r = Pred f-  where-    f a = Result (Labeled [] rslt)-      where-        rslt = case splitResult $ fL a of-          Left n -> Left (FAnd (Left n))-          Right g -> case splitResult $ fR a of-            Left b -> Left (FAnd (Right (g, b)))-            Right g' -> Right (PAnd g g')-        Pred fR = r+(&&&) :: Monad m => PredM m a -> PredM m a -> PredM m a+(PredM fL) &&& r = PredM $ \a -> do+  resL <- fL a+  ei <- case splitResult resL of+    Left n -> return (Left (FAnd (Left n)))+    Right g -> do+      let PredM fR = r+      resR <- fR a+      return $ case splitResult resR of+        Left b -> Left (FAnd (Right (g, b)))+        Right g' -> Right (PAnd g g')+  return (Result (Labeled [] ei))+ infixr 3 &&&   -- | Or.  Returns 'True' if either argument 'Pred' returns 'True'.  Is -- lazy in its second argument; if the first argument returns 'True', -- the second argument is ignored.-(|||) :: Pred a -> Pred a -> Pred a-(Pred fL) ||| r = Pred f-  where-    Pred fR = r-    f a = Result (Labeled [] rslt)-      where-        rslt = case splitResult $ fL a of-          Left b -> case splitResult $ fR a of-            Left b' -> Left $ FOr b b'-            Right g -> Right $ POr (Right (b, g))-          Right g -> Right $ POr (Left g)+(|||) :: Monad m => PredM m a -> PredM m a -> PredM m a+(PredM fL) ||| r = PredM $ \a -> do+  resL <- fL a+  ei <- case splitResult resL of+    Left b -> do+      let PredM fR = r+      resR <- fR a+      return $ case splitResult resR of+        Left b' -> Left $ FOr b b'+        Right g -> Right $ POr (Right (b, g))+    Right g -> return (Right (POr (Left g)))+  return (Result (Labeled [] ei))   infixr 2 ||| - -- | Negation.  Returns 'True' if the argument 'Pred' returns 'False'.-not :: Pred a -> Pred a-not (Pred f) = Pred g+not :: Functor m => PredM m a -> PredM m a+not (PredM f) = PredM $ \a -> fmap g (f a)   where     g a = Result (Labeled [] rslt)       where-        rslt = case splitResult $ f a of+        rslt = case splitResult a of           Left b -> Right (PNot b)           Right y -> Left (FNot y) @@ -213,13 +263,13 @@ -- 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-  :: Pred a-  -> Pred b-  -> Pred (Either a b)-switch pa pb = Pred (either fa fb)+  :: PredM m a+  -> PredM m b+  -> PredM m (Either a b)+switch pa pb = PredM (either fa fb)   where-    Pred fa = pa-    Pred fb = pb+    PredM fa = pa+    PredM fb = pb  -- | Did this 'Result' pass or fail? resultToBool :: Result -> Bool@@ -228,178 +278,175 @@   -- | Always returns 'True'-true :: Show a => Pred a-true = predicate "always returns True" (const True)+true :: Applicative f => PredM f a+true = predicateM (const (pure trip))+  where+    trip = (True, mempty, Condition [chunk "always returns True"])  -- | Always returns 'False'-false :: Show a => Pred a-false = predicate "always returns False" (const False)+false :: Applicative f => PredM f a+false = predicateM (const (pure trip))+  where+    trip = (False, mempty, Condition [chunk "always returns False"])  -- | Always returns its argument-same :: Pred Bool-same = predicate "is returned" id-+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 :: Text -> Pred a -> Pred a-addLabel s (Pred f) = Pred f'+addLabel :: Functor f => [Chunk Text] -> PredM f a -> PredM f a+addLabel s (PredM f) = PredM f'   where-    f' a = Result (Labeled (Label s : ss) ei)+    f' a = fmap g (f a)       where-        Result (Labeled ss ei) = f a+        g (Result (Labeled ss ei)) = Result (Labeled (Label s : ss) ei)  --- | Represents the end of a list.-data EndOfList = EndOfList--instance Show EndOfList where-  show _ = ""- -- | 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 :: Pred a -> Pred [a]-any pa = contramap f (switch (addLabel "cons cell" pConsCell) pEnd)+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 "head" pa)-      ||| contramap snd (addLabel "tail" (any pa))+      contramap fst (addLabel [chunk "head"] pa)+      ||| contramap snd (addLabel [chunk "tail"] (any pa))     f ls = case ls of-      [] -> Right EndOfList+      [] -> Right ()       x:xs -> Left (x, xs)-    pEnd = addLabel "end of list" $ contramap (const EndOfList) false+    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 :: Pred a -> Pred [a]-all pa = contramap f (switch (addLabel "cons cell" pConsCell) pEnd)+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 "head" pa)-      &&& contramap snd (addLabel "tail" (all pa))+      contramap fst (addLabel [chunk "head"] pa)+      &&& contramap snd (addLabel [chunk "tail"] (all pa))     f ls = case ls of       x:xs -> Left (x, xs)-      [] -> Right EndOfList-    pEnd = addLabel "end of list" $ contramap (const EndOfList) true+      [] -> Right ()+    pEnd = predicateM (const (pure (True, Value [chunk "end of list"],+                                    Condition [chunk "always returns True"]))) --- | Represents 'Prelude.Nothing' of 'Maybe'.-data Nothing = CoreNothing -instance Show Nothing where-  show _ = ""- -- | Create a 'Pred' for 'Maybe'. maybe-  :: Pred Nothing-  -- ^ What to do on 'Nothing'.  Usually you wil use 'true' or 'false'.-  -> Pred a-  -- ^ Analyzes 'Just' values.-  -> Pred (Maybe a)-maybe emp pa = contramap f-  (switch (addLabel "Nothing" emp) (addLabel "Just value" pa))+  :: 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 CoreNothing+      Nothing -> Left ()       Just a -> Right a  -explainAnd :: [Chunk]-explainAnd = ["(and)"]+explainAnd :: [Chunk Text]+explainAnd = [chunk "(and)"] -explainOr :: [Chunk]-explainOr = ["(or)"]+explainOr :: [Chunk Text]+explainOr = [chunk "(or)"] -explainNot :: [Chunk]-explainNot = ["(not)"]+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 (Pred p) = either (const False) (const True)-  . splitResult . p+test p a = runIdentity $ testM p a + -- | Runs a 'Pred' against a particular value; also returns a list of -- 'Chunk' describing the steps of evaulation.-verboseTest :: Pred a -> a -> ([Chunk], Bool)-verboseTest (Pred f) a = (cks, resultToBool rslt)+verboseTestM :: Functor f => PredM f a -> a -> f ([Chunk Text], Bool)+verboseTestM (PredM f) a = fmap g (f a)   where-    rslt = f a-    cks = resultToChunks rslt+    g rslt = (resultToChunks rslt, resultToBool rslt) +verboseTest :: Pred a -> a -> ([Chunk Text], Bool)+verboseTest p a = runIdentity $ verboseTestM p a --- | 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-  t <- smartTermFromEnv IO.stdout-  putChunks t cks-  return r +-- | 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]-lblTrue = ["[", fore green <> "TRUE", "]"]+lblTrue :: [Chunk Text]+lblTrue = [chunk "[", chunk "TRUE" & fore green, chunk "]"]  -- | A colorful label for 'False' values.-lblFalse :: [Chunk]-lblFalse = ["[", fore red <> "FALSE", "]"]+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] -> [Chunk] -> [Chunk]+(<+>) :: [Chunk Text] -> [Chunk Text] -> [Chunk Text] l <+> r-  | full l && full r = l <> [" "] <> r+  | full l && full r = l <> [chunk " "] <> r   | otherwise = l <> r   where-    full = Prelude.not . chunksNull+    full = Prelude.any (Prelude.not . X.null) . map _yarn  -- | Append two lists of 'Chunk', with an intervening hyphen if both -- lists have text.-(<->) :: [Chunk] -> [Chunk] -> [Chunk]+(<->) :: [Chunk Text] -> [Chunk Text] -> [Chunk Text] l <-> r   | full l && full r = l <> hyphen <> r   | otherwise = l <> r   where-    full = Prelude.not . chunksNull--hyphen :: [Chunk]-hyphen = [" - "]+    full = Prelude.any (Prelude.not . X.null) . map _yarn -chunksNull :: [Chunk] -> Bool-chunksNull = Prelude.all $ Prelude.all X.null . text+hyphen :: [Chunk Text]+hyphen = [chunk " - "]  indentAmt :: Int indentAmt = 2 -spaces :: Int -> [Chunk]-spaces i = (:[]) . fromText . X.replicate (i * indentAmt)+spaces :: Int -> [Chunk Text]+spaces i = (:[]) . chunk . X.replicate (i * indentAmt)   . X.singleton $ ' ' -newline :: [Chunk]-newline = ["\n"]+newline :: [Chunk Text]+newline = [chunk "\n"] -labelToChunks :: Label -> [Chunk]-labelToChunks (Label txt) = [fromText txt]+labelToChunks :: Label -> [Chunk Text]+labelToChunks (Label cks) = cks -explainTerminal :: Value -> Condition -> [Chunk]+explainTerminal :: Value -> Condition -> [Chunk Text] explainTerminal (Value v) (Condition c)-  = [fromText v] <+> c---- | Obtain a list of 'Chunk' describing the evaluation process.-resultToChunks :: Result -> [Chunk]-resultToChunks = either (failedToChunks 0) (passedToChunks 0)-  . splitResult+  = v ++ (chunk " " : c)  -- | Obtain a list of 'Chunk' describing the evaluation process. passedToChunks   :: Int   -- ^ Number of levels of indentation   -> Labeled Passed-  -> [Chunk]+  -> [Chunk Text] passedToChunks i (Labeled l p) = this <> rest   where     this = spaces i <> (lblTrue <+> (labels `sep` explain)) <> newline@@ -421,7 +468,7 @@   :: Int   -- ^ Number of levels of indentation   -> Labeled Failed-  -> [Chunk]+  -> [Chunk Text] failedToChunks i (Labeled l p) = this <> rest   where     this = spaces i <> (lblFalse <+> (labels `sep` explain)) <> newline@@ -437,3 +484,13 @@             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
@@ -23,32 +23,32 @@ import Prelude hiding (maybe)  -- | A single type for both RPN tokens and infix tokens.-newtype Token a = Token { unToken :: I.InfixToken a }+newtype Token m a = Token { unToken :: I.InfixToken m a }  type Error = X.Text  -- | Creates Operands from 'Pred'.-operand :: Pred a -> Token a+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?@@ -57,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@@ -71,9 +71,10 @@ -- 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 -> Prelude.maybe (Left "unbalanced parentheses\n") Right
lib/Prednote/Expressions/Infix.hs view
@@ -7,8 +7,8 @@ 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  data Paren = Open | Close@@ -25,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@@ -49,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@@ -64,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@@ -80,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@@ -92,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)@@ -104,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@@ -118,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
@@ -7,15 +7,14 @@ module Prednote.Expressions.RPN where  import qualified Data.Foldable as Fdbl-import Prednote.Core (Pred) import qualified Prednote.Core as P-import Prednote.Core ((&&&), (|||))+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  data Operator@@ -24,13 +23,14 @@   | 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@@ -46,9 +46,10 @@             <> "\" 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@@ -60,9 +61,10 @@ -- 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
prednote.cabal view
@@ -3,14 +3,15 @@ -- http://www.github.com/massysett/cartel -- -- Script name used to generate: genCabal.hs--- Generated on: 2015-01-12 07:59:16.893944 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.28.0.2-cabal-version: >= 1.14-build-type: Simple+version: 0.36.0.4+cabal-version: >= 1.18 license: BSD3 license-file: LICENSE+build-type: Simple copyright: Copyright 2013-2015 Omari Norman author: Omari Norman maintainer: omari@smileystation.com@@ -28,104 +29,111 @@   given predicate, and to parse infix or RPN expressions into a tree of   predicates. category: Data-tested-with: GHC == 7.6.3, GHC == 7.8.2 extra-source-files:-    README.md-  , changelog-  , genCabal.hs--source-repository head-  type: git-  location: git://github.com/massysett/prednote.git-  branch: master--Flag visual-tests-  Description: Build the prednote-visual-tests executable-  Default: False-  Manual: True+  README.md+  changelog+  genCabal.hs  Library   exposed-modules:-      Prednote-    , Prednote.Comparisons-    , Prednote.Core-    , Prednote.Expressions-    , Prednote.Expressions.Infix-    , Prednote.Expressions.RPN+    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)-    , 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)-    , contravariant ((> 1.2 || == 1.2) && < 1.3)+      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 -Executable prednote-visual-tests-  main-is: prednote-visual-tests.hs-  if flag(visual-tests)-    hs-source-dirs:-        lib-      , tests-    other-modules:-        Prednote-      , Prednote.Comparisons-      , Prednote.Core-      , Prednote.Expressions-      , Prednote.Expressions.Infix-      , Prednote.Expressions.RPN-      , Decrees-      , Instances-      , Prednote.Core.Instances-      , Prednote.Core.Properties-      , Rainbow.Types.Instances-    ghc-options:-        -Wall-    default-language: Haskell2010-    build-depends:-        QuickCheck ((> 2.5 || == 2.5) && < 2.8)-      , quickpull ((> 0.4 || == 0.4) && < 0.5)-      , base ((> 4.5.0.0 || == 4.5.0.0) && < 5)-      , 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)-      , contravariant ((> 1.2 || == 1.2) && < 1.3)-    buildable: True-  else-    buildable: False- Test-Suite prednote-tests   hs-source-dirs:-      lib-    , tests+    lib+    tests   other-modules:-      Prednote-    , Prednote.Comparisons-    , Prednote.Core-    , Prednote.Expressions-    , Prednote.Expressions.Infix-    , Prednote.Expressions.RPN-    , Decrees-    , Instances-    , Prednote.Core.Instances-    , Prednote.Core.Properties-    , Rainbow.Types.Instances+    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+    -Wall   default-language: Haskell2010+  other-extensions:+    TemplateHaskell   build-depends:-      QuickCheck ((> 2.5 || == 2.5) && < 2.8)-    , quickpull ((> 0.4 || == 0.4) && < 0.5)-    , base ((> 4.5.0.0 || == 4.5.0.0) && < 5)-    , 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)-    , contravariant ((> 1.2 || == 1.2) && < 1.3)+      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/Decrees.hs 
@@ -1,28 +0,0 @@--- | This module generated by the Quickpull package.--- Quickpull is available at:--- <http://www.github.com/massysett/quickpull>--module Decrees where--import Quickpull-import qualified Prednote.Core.Properties--decrees :: [Decree]-decrees =--  [ Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 14, qName = "prop_predicateIsLazyInArguments"} ) ( Single Prednote.Core.Properties.prop_predicateIsLazyInArguments )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 17, qName = "prop_predicateIsSameAsOriginal"} ) ( Single Prednote.Core.Properties.prop_predicateIsSameAsOriginal )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 20, qName = "prop_andIsLazyInSecondArgument"} ) ( Single Prednote.Core.Properties.prop_andIsLazyInSecondArgument )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 23, qName = "prop_orIsLazyInSecondArgument"} ) ( Single Prednote.Core.Properties.prop_orIsLazyInSecondArgument )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 26, qName = "prop_andIsLikePreludeAnd"} ) ( Single Prednote.Core.Properties.prop_andIsLikePreludeAnd )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 32, qName = "prop_orIsLikePreludeOr"} ) ( Single Prednote.Core.Properties.prop_orIsLikePreludeOr )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 38, qName = "prop_notIsLikePreludeNot"} ) ( Single Prednote.Core.Properties.prop_notIsLikePreludeNot )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 43, qName = "prop_switchIsLazyInFirstArgument"} ) ( Single Prednote.Core.Properties.prop_switchIsLazyInFirstArgument )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 48, qName = "prop_switchIsLazyInSecondArgument"} ) ( Single Prednote.Core.Properties.prop_switchIsLazyInSecondArgument )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 53, qName = "prop_switch"} ) ( Single Prednote.Core.Properties.prop_switch )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 63, qName = "prop_true"} ) ( Single Prednote.Core.Properties.prop_true )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 65, qName = "prop_false"} ) ( Single Prednote.Core.Properties.prop_false )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 67, qName = "prop_same"} ) ( Single Prednote.Core.Properties.prop_same )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 69, qName = "prop_any"} ) ( Single Prednote.Core.Properties.prop_any )-  , Decree ( Meta {modDesc = ModDesc {modPath = "tests/Prednote/Core/Properties.hs", modName = ["Prednote","Core","Properties"]}, linenum = 75, qName = "prop_all"} ) ( Single Prednote.Core.Properties.prop_all )-  ]
tests/Prednote/Core/Instances.hs view
@@ -1,16 +1,14 @@+{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Prednote.Core.Instances where -import Rainbow.Types.Instances ()+import Rainbow.Instances () import Test.QuickCheck hiding (Result) import Control.Monad import Prednote.Core -instance CoArbitrary a => Arbitrary (Pred a) where-  arbitrary = fmap Pred arbitrary--instance Arbitrary a => CoArbitrary (Pred a) where-  coarbitrary (Pred f) = coarbitrary f+instance (CoArbitrary a, Show a) => Arbitrary (Pred a) where+  arbitrary = fmap predicate arbitrary  instance Arbitrary Condition where   arbitrary = fmap Condition arbitrary
tests/Prednote/Core/Properties.hs view
@@ -1,4 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE TemplateHaskell #-}  module Prednote.Core.Properties where @@ -7,38 +8,41 @@ 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_predicateIsLazyInArguments (Fun _ f) i-  = testInt (predicate undefined f) i || True--prop_predicateIsSameAsOriginal (Fun _ f) i-  = testInt (predicate undefined f) i == f i- 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 == (f1 i && f2 i)+  = testInt (p1 &&& p2) i == (fst3 (f1 i) && fst3 (f2 i))   where-    p1 = predicate undefined f1-    p2 = predicate undefined f2+    p1 = predicate f1+    p2 = predicate f2  prop_orIsLikePreludeOr (Fun _ f1) (Fun _ f2) i-  = testInt (p1 ||| p2) i == (f1 i || f2 i)+  = testInt (p1 ||| p2) i == (fst3 (f1 i) || fst3 (f2 i))   where-    p1 = predicate undefined f1-    p2 = predicate undefined f2+    p1 = predicate f1+    p2 = predicate f2  prop_notIsLikePreludeNot (Fun _ f1) i-  = testInt (not p1) i == Prelude.not (f1 i)+  = testInt (not p1) i == Prelude.not (fst3 (f1 i))   where-    p1 = predicate undefined f1+    p1 = predicate f1  prop_switchIsLazyInFirstArgument pb i   = test (switch undefined pb) (Right i) || True@@ -55,10 +59,10 @@   where     _types = ei :: Either Int Char     expected = case ei of-      Left i -> fa i-      Right c -> fb c-    pa = predicate undefined fa-    pb = predicate undefined fb+      Left i -> fst3 (fa i)+      Right c -> fst3 (fb c)+    pa = predicate fa+    pb = predicate fb      prop_true = testInt true @@ -67,14 +71,14 @@ prop_same b = test same b == b  prop_any (Fun _ f) ls-  = test (any pa) ls == Prelude.any f ls+  = test (any pa) ls == Prelude.any (fmap fst3 f) ls   where-    pa = predicate undefined f+    pa = predicate f     _types = ls :: [Int]      prop_all (Fun _ f) ls-  = test (all pa) ls == Prelude.all f ls+  = test (all pa) ls == Prelude.all (fmap fst3 f) ls   where-    pa = predicate undefined f+    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/Rainbow/Types/Instances.hs 
@@ -1,80 +0,0 @@-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Rainbow.Types.Instances where--import Control.Monad-import Control.Applicative-import Data.Monoid-import Test.QuickCheck-import Rainbow.Types-import qualified Data.Text as X--instance Arbitrary a => Arbitrary (Last a) where-  arbitrary = Last <$> arbitrary--instance CoArbitrary a => CoArbitrary (Last a) where-  coarbitrary (Last m) = case m of-    Nothing -> varInt 0-    Just x -> varInt 1 . coarbitrary x--instance Arbitrary Enum8 where-  arbitrary = elements [ E0, E1, E2, E3, E4, E5, E6, E7 ]--varInt :: Int -> Gen b -> Gen b-varInt = variant--instance CoArbitrary Enum8 where-  coarbitrary a = case a 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 Color8 where-  arbitrary = Color8 <$> arbitrary--instance CoArbitrary Color8 where-  coarbitrary (Color8 a) = coarbitrary a--instance Arbitrary Color256 where-  arbitrary = Color256 <$> arbitrary--instance CoArbitrary Color256 where-  coarbitrary (Color256 a) = coarbitrary a--instance Arbitrary StyleCommon where-  arbitrary = liftM4 StyleCommon arbitrary arbitrary arbitrary-    arbitrary--instance CoArbitrary StyleCommon where-  coarbitrary (StyleCommon a b c d) =-    coarbitrary a . coarbitrary b . coarbitrary c . coarbitrary d--instance Arbitrary Style8 where-  arbitrary = liftM3 Style8 arbitrary arbitrary arbitrary--instance CoArbitrary Style8 where-  coarbitrary (Style8 a b c) =-    coarbitrary a . coarbitrary b . coarbitrary c--instance Arbitrary Style256 where-  arbitrary = liftM3 Style256 arbitrary arbitrary arbitrary--instance CoArbitrary Style256 where-  coarbitrary (Style256 a b c) =-    coarbitrary a . coarbitrary b . coarbitrary c--instance Arbitrary TextSpec where-  arbitrary = liftM2 TextSpec arbitrary arbitrary--instance CoArbitrary TextSpec where-  coarbitrary (TextSpec x y) = coarbitrary x . coarbitrary y--instance Arbitrary X.Text where-  arbitrary = X.pack <$> listOf arbitrary--instance CoArbitrary X.Text where-  coarbitrary = coarbitrary . X.unpack--instance Arbitrary Chunk where-  arbitrary = liftM2 Chunk arbitrary arbitrary--instance CoArbitrary Chunk where-  coarbitrary (Chunk x y) = coarbitrary x . coarbitrary y
tests/prednote-tests.hs view
@@ -1,8 +1,10 @@ {-# OPTIONS_GHC -fno-warn-unused-imports #-} module Main where -import Quickpull-import Decrees+import Test.Tasty+import qualified Prednote.Core.Properties  main :: IO ()-main = defaultMain decrees+main = defaultMain $ testGroup "all tests"+  [ Prednote.Core.Properties.tests+  ]
tests/prednote-visual-tests.hs view
@@ -10,6 +10,6 @@   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)))+  verboseTestStdout (all $ maybe True (lessEq (5 :: Int)))     [Nothing, Just 1, Just 2, Nothing, Just 3, Just 4, Just 5]   return ()