predicate-transformers 0.15.0.0 → 0.16.0.0

raw patch · 2 files changed

+122/−58 lines, 2 filesdep +pretty-simpledep +prettyprinterdep +recover-rttiPVP ok

version bump matches the API change (PVP)

Dependencies added: pretty-simple, prettyprinter, recover-rtti, text

API changes (from Hackage documentation)

Files

• predicate-transformers.cabal +6/−1
• src/PredicateTransformers.hs +116/−57

@@ -1,7 +1,7 @@ cabal-version: 2.4  name: predicate-transformers-version: 0.15.0.0+version: 0.16.0.0 synopsis: A library for writing predicates and transformations over predicates in Haskell description:   This package provides ways to write predicates such that they compose nicely and are easy to debug.@@ -17,12 +17,17 @@  library   exposed-modules: PredicateTransformers+  ghc-options: -Wall   build-depends:     base >=4.8 && <4.30    ,adjunctions >= 4.4.2 && < 5    ,deepseq >= 1.4.8 && < 2    ,mtl >= 2.3.1 && < 3    ,lens >= 5.3.2 && < 6+   ,recover-rtti >= 0.3 && < 0.6+   ,pretty-simple >= 1.1 && < 4.2+   ,prettyprinter >= 1.6 && < 2.0+   ,text >= 1.0 && < 2.2   if !impl(ghc >= 8.0)     build-depends:       semigroups >= 0.8.4 && < 1

@@ -6,6 +6,9 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fexpose-all-unfoldings #-} {-# LANGUAGE ImpredicativeTypes #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}  -- | This library is based on the notion of a predicate transformer, the below -- type @PT a b@, which is a function from @a@ to predicates on @b@.@@ -17,42 +20,73 @@ -- `Data.Foldable.all`, `Data.Foldable.any` (base) -- `either` (base) -- `Control.Lens.allOf` (lens)-module PredicateTransformers where+module PredicateTransformers+  ( Predicatory(..)+  , Exceptional(..)+  , PredicateFailed(..)+  , Pred+  , PT+  , predJust+  , predLeft+  , predRight+  , endingWith+  , startingWith+  , soleElementOf+  , soleElement+  , match+  , kth+  , predList+  , predful+  , predCompose+  , allTrue+  , allOf1+  , pattern (:=>)+  , pair+  , pt+  , (?)+  , traced+  , tracedShow+  , traceFailShow+  , traceFail+  , something+  , forced+  , equals+  , satAll+  )+  where -import Control.Applicative import Control.DeepSeq (NFData, force) import Control.Exception import Control.Lens hiding (index) import Control.Monad-import Control.Monad.Writer (execWriter, tell)-import Data.Bool import Data.Foldable (toList) import Data.Functor.Rep (Representable (..))-import Data.Semigroup (All (..), Any (..)) import Data.Typeable import Debug.Trace import System.IO.Unsafe-import Control.Concurrent (myThreadId, throwTo)-import Control.Exception (SomeAsyncException)+import Control.Concurrent (myThreadId) import GHC.Conc (pseq) import GHC.Stack+import Text.Pretty.Simple+import qualified Prettyprinter as PP+import qualified Prettyprinter.Render.String as PP+import Debug.RecoverRTTI+import qualified Data.Text.Lazy as TL  -- | Class of possible predicate results. -- This is mostly a lattice with `otherHand` as disjunction, `also` as conjunction, `stop` as the falsy -- value, and `continue` as the truthy value. There may be multiple falsy values, however.--- Note that test failure messages are not really the domain of this library.--- It's the author's hope that they can be mostly replaced by `traceFail`. class Predicatory a where-  otherHand :: HasCallStack => a -> a -> a-  also :: HasCallStack => a -> a -> a-  stop :: HasCallStack => a+  otherHand :: a -> a -> a+  also :: a -> a -> a+  stop :: HasCallStack => v -> PP.Doc ann -> a   continue :: a   {-# MINIMAL otherHand, also, stop, continue #-}  instance Predicatory a => Predicatory (e -> a) where   (f `otherHand` f') e = f e `otherHand` f' e   (f `also` f') e = f e `also` f' e-  stop = withFrozenCallStack $ \_ -> stop+  stop v expected = withFrozenCallStack $ \_ -> stop v expected   continue = \_ -> continue  infixr 3 `also`@@ -67,20 +101,36 @@   assess f act = \e -> assess (f e) act  -- | The exception thrown by predicates of type `IO ()` by default. Other IOExceptions will work fine.-data PredicateFailed = PredicateFailed !CallStack+data PredicateFailed = forall actual ann. PredicateFailed !CallStack (PP.Doc ann) actual   deriving (Typeable) instance Show PredicateFailed where   show = displayException +anythingToStringPretty :: a -> String+anythingToStringPretty = TL.unpack . pStringOpt opts . anythingToString+  where+  opts = defaultOutputOptionsNoColor+    { outputOptionsIndentAmount = 2+    , outputOptionsPageWidth = 120+    , outputOptionsCompact = True+    , outputOptionsCompactParens = True+    , outputOptionsInitialIndent = 0+    }+ instance Exception PredicateFailed where-  displayException (PredicateFailed cs) =-    "Predicate failed.\n" <>-    prettyCallStack cs+  displayException (PredicateFailed cs expected actual)+    = PP.renderString $ PP.layoutSmart PP.defaultLayoutOptions $+      PP.sep+        [ "Actual" <> PP.softline <> PP.pretty prettyActual+        , "but expected" <> PP.softline <> expected+        ] <> PP.hardline <> PP.pretty (prettyCallStack cs)+    where+    prettyActual = anythingToStringPretty actual  instance Predicatory Bool where   otherHand = (||)   also = (&&)-  stop = False+  stop _ _ = False   continue = True  instance Exceptional Bool where@@ -88,7 +138,7 @@     | b = b     | otherwise = unsafePerformIO act `pseq` b -instance Predicatory (IO ()) where+instance a ~ () => Predicatory (IO a) where   otherHand x y = do     catches x       -- explicitly do not handle async exceptions.@@ -99,10 +149,10 @@       , Handler $ \(_ex :: SomeException) -> y       ]   also = (>>)-  stop = throwIO (PredicateFailed callStack)+  stop v expected = throwIO (PredicateFailed (popCallStack callStack) expected v)   continue = return () -instance Exceptional (IO ()) where+instance a ~ () => Exceptional (IO a) where   assess x act =     catches x       -- explicitly do not handle async exceptions.@@ -115,40 +165,40 @@       ]  -- | A convenient alias for predicates.-type Pred p a = HasCallStack => a -> p+type Pred p a = a -> p  -- | Predicate transformers form a category where composition is ordinary function composition. --  Forms a category with `.` and `id`. --  Multiple are already provided by the standard library, --  for instance `Data.Foldable.all` and `Data.Foldable.any`.-type PT p a b = HasCallStack => Pred p a -> Pred p b+type PT p a b = Pred p a -> Pred p b  -- | Operate on the `Just` branch of a `Maybe`, or fail.-just :: Predicatory p => PT p a (Maybe a)-just = match _Just+predJust :: Predicatory p => PT p a (Maybe a)+predJust = match _Just  -- | Operate on the `Left` branch of an `Either`, or fail.-left :: Predicatory p => PT p e (Either e a)-left = match _Left+predLeft :: Predicatory p => PT p e (Either e a)+predLeft = match _Left  -- | Operate on the `Right` branch of an `Either`, or fail.-right :: Predicatory p => PT p a (Either e a)-right = match _Right+predRight :: Predicatory p => PT p a (Either e a)+predRight = match _Right  -- | Operate on the last value in a foldable, or fail if it's not present.-endingWith :: (Predicatory p, Foldable f) => PT p a (f a)-endingWith _ (toList -> []) = stop+endingWith :: (HasCallStack, Predicatory p, Foldable f) => PT p a (f a)+endingWith _ actual@(toList -> []) = stop actual "nonempty foldable" endingWith p (toList -> xs) = p $ last xs  -- | Operate on the first value in a foldable, or fail if it's not present.-startingWith :: (Predicatory p, Foldable f) => PT p a (f a)+startingWith :: (HasCallStack, Predicatory p, Foldable f) => PT p a (f a)+startingWith _ actual@(toList -> []) = stop actual "nonempty foldable" startingWith p (toList -> (x : _)) = p x-startingWith _ (toList -> []) = stop  -- | Require that a @Fold@ has a single element, and operate on that element.-soleElementOf :: (Predicatory p) => Fold s a -> PT p a s+soleElementOf :: (HasCallStack, Predicatory p) => Fold s a -> PT p a s soleElementOf f p (toListOf f -> [x]) = p x-soleElementOf _ _ _ = stop+soleElementOf _ _ actual = stop actual "only one element targeted by fold"  -- | Require that a @Foldable@ has a single element, and operate on that element. soleElement :: (Predicatory p, Foldable f) => PT p a (f a)@@ -164,30 +214,34 @@  -- | Given a list of predicates and a list of values, ensure that each predicate holds for each respective value. --  Fails if the two lists have different lengths.-list :: Predicatory p => [Pred p a] -> [a] -> p-list (p : ps) (x : xs) = p x `also` list ps xs-list [] [] = continue-list _ _ = stop+predList :: (HasCallStack, Predicatory p) => [Pred p a] -> [a] -> p+predList ps xs+  | psl == length xs = foldr also continue (zipWith ($) ps xs)+  | otherwise = stop xs $ "list with length " <> PP.pretty psl+  where+  psl = length ps  -- | Given a functor-full of predicates, and a functor-full of values, ensure that the structures --  of the two functors match and apply all of the predicates to all of the values. --  Generalized version of `list`.-dist ::-  (Predicatory p, Eq (f ()), Functor f, Foldable f) =>+predful ::+  (HasCallStack, Predicatory p, Eq (f ()), Functor f, Foldable f) =>   f (Pred p a) ->   Pred p (f a)-dist preds values =-  bool stop continue ((() <$ preds) == (() <$ values))-    `also` list (toList preds) (toList values)+predful preds values+  | void preds == void values =+    predList (toList preds) (toList values)+  | otherwise =+    stop values ("shape equal to that of" <> PP.pretty (anythingToStringPretty preds))  -- | Given a representable functor-full of predicates, and a functor-full of values,---  yield a representable functor-full of booleans. Similar to `dist`.-distRep ::+--  yield a representable functor-full of booleans. Similar to `predful`.+predCompose ::   Representable f =>   f (Pred p a) ->   f a ->   f p-distRep pr fa = tabulate (\r -> index pr r $ index fa r)+predCompose pr fa = tabulate (\r -> index pr r $ index fa r)  -- | Test all predicates against one value. allTrue :: (Predicatory p, Foldable f) => f (Pred p a) -> Pred p a@@ -195,26 +249,29 @@  -- | Check that a predicate is true for all values behind a generalized getter --  and that there's at least one value for which it's true.-allOf1 :: Predicatory p => Fold s a -> PT p a s-allOf1 g p vs =-  bool stop continue (notNullOf g vs)-    `also` foldrOf g (\x r -> p x `also` r) continue vs+allOf1 :: (HasCallStack, Predicatory p) => Fold s a -> PT p a s+allOf1 g p vs+  | notNullOf g vs =+    foldrOf g (\x r -> p x `also` r) continue vs+  | otherwise = stop vs "non-empty for fold"  -- | Sugar for tupling.+pattern (:=>) :: a -> b -> (a, b) pattern a :=> b = (a, b)  -- | A pair of predicates, made into a predicate on pairs. pair :: Predicatory p => Pred p a -> Pred p b -> Pred p (a, b) pair f s (a, b) = f a `also` s b --- | Flipped function composition; @pt f@ for a function @f@ is a predicate transformer.+-- | Flipped function composition; @pf f@ for a function @f@ is a predicate transformer+-- such that @pf f p i == p (f i)@. pt :: (a -> b) -> PT p b a pt f p = p . f --- | Higher precedence @$@, to work well with '&'.+-- | Higher precedence '$', to work well with '&'. (?) :: (a -> b) -> a -> b (?) = ($)-infixl 8 ?+infixr 8 ?  -- | Prints the input of a predicate, for debugging. traced :: Show a => (a -> String) -> PT c a a@@ -245,9 +302,11 @@ forced a = force a `seq` continue  -- | Predicate on equality.-equals :: (Predicatory p, Eq a) => a -> Pred p a-equals a a' = bool (stop a') continue (a == a')+equals :: (HasCallStack, Predicatory p, Eq a) => a -> Pred p a+equals expected actual+  | expected == actual = continue+  | otherwise = stop actual ("equal to" <> PP.softline <> PP.pretty (anythingToStringPretty expected))  -- | Check that all of the input predicates are satisfied. satAll :: Predicatory p => [Pred p a] -> Pred p a-satAll xs a = foldr (\p xs -> p a `also` xs) continue xs+satAll xs a = foldr also continue $ map ($ a) xs