{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fexpose-all-unfoldings #-}
{-# LANGUAGE ImpredicativeTypes #-}
module PredicateTransformers 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 GHC.Conc (pseq)
import GHC.Stack
class Predicatory a where
otherHand :: HasCallStack => a -> a -> a
also :: HasCallStack => a -> a -> a
stop :: HasCallStack => a
continue :: a
{-# MINIMAL otherHand, also, stop, continue #-}
instance Predicatory a => Predicatory (e -> a) where
(e -> a
f otherHand :: HasCallStack => (e -> a) -> (e -> a) -> e -> a
`otherHand` e -> a
f') e
e = e -> a
f e
e a -> a -> a
forall a. (Predicatory a, HasCallStack) => a -> a -> a
`otherHand` e -> a
f' e
e
(e -> a
f also :: HasCallStack => (e -> a) -> (e -> a) -> e -> a
`also` e -> a
f') e
e = e -> a
f e
e a -> a -> a
forall a. (Predicatory a, HasCallStack) => a -> a -> a
`also` e -> a
f' e
e
stop :: HasCallStack => e -> a
stop = (HasCallStack => e -> a) -> e -> a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack ((HasCallStack => e -> a) -> e -> a)
-> (HasCallStack => e -> a) -> e -> a
forall a b. (a -> b) -> a -> b
$ \e
_ -> a
forall a. (Predicatory a, HasCallStack) => a
stop
continue :: e -> a
continue = \e
_ -> a
forall a. Predicatory a => a
continue
infixr 3 `also`
infixr 2 `otherHand`
class Exceptional a where
assess :: a -> IO () -> a
instance Exceptional a => Exceptional (e -> a) where
assess :: (e -> a) -> IO () -> e -> a
assess e -> a
f IO ()
act = \e
e -> a -> IO () -> a
forall a. Exceptional a => a -> IO () -> a
assess (e -> a
f e
e) IO ()
act
data PredicateFailed = PredicateFailed !CallStack
deriving (Typeable)
instance Show PredicateFailed where
show :: PredicateFailed -> String
show = PredicateFailed -> String
forall e. Exception e => e -> String
displayException
instance Exception PredicateFailed where
displayException :: PredicateFailed -> String
displayException (PredicateFailed CallStack
cs) =
String
"Predicate failed.\n" String -> ShowS
forall a. Semigroup a => a -> a -> a
<>
CallStack -> String
prettyCallStack CallStack
cs
instance Predicatory Bool where
otherHand :: HasCallStack => Bool -> Bool -> Bool
otherHand = Bool -> Bool -> Bool
(||)
also :: HasCallStack => Bool -> Bool -> Bool
also = Bool -> Bool -> Bool
(&&)
stop :: HasCallStack => Bool
stop = Bool
False
continue :: Bool
continue = Bool
True
instance Exceptional Bool where
assess :: Bool -> IO () -> Bool
assess Bool
b IO ()
act
| Bool
b = Bool
b
| Bool
otherwise = IO () -> ()
forall a. IO a -> a
unsafePerformIO IO ()
act () -> Bool -> Bool
forall a b. a -> b -> b
`pseq` Bool
b
instance Predicatory (IO ()) where
otherHand :: HasCallStack => IO () -> IO () -> IO ()
otherHand IO ()
x IO ()
y = do
IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
catches IO ()
x
[ (SomeAsyncException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeAsyncException -> IO ()) -> Handler ())
-> (SomeAsyncException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \(SomeAsyncException
ex :: SomeAsyncException) -> do
ThreadId
tid <- IO ThreadId
myThreadId
ThreadId -> SomeAsyncException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid SomeAsyncException
ex
, (SomeException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO ()) -> Handler ())
-> (SomeException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
_ex :: SomeException) -> IO ()
y
]
also :: HasCallStack => IO () -> IO () -> IO ()
also = IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>)
stop :: HasCallStack => IO ()
stop = PredicateFailed -> IO ()
forall e a. Exception e => e -> IO a
throwIO (CallStack -> PredicateFailed
PredicateFailed CallStack
HasCallStack => CallStack
callStack)
continue :: IO ()
continue = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
instance Exceptional (IO ()) where
assess :: IO () -> IO () -> IO ()
assess IO ()
x IO ()
act =
IO () -> [Handler ()] -> IO ()
forall a. IO a -> [Handler a] -> IO a
catches IO ()
x
[ (SomeAsyncException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeAsyncException -> IO ()) -> Handler ())
-> (SomeAsyncException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \(SomeAsyncException
ex :: SomeAsyncException) -> do
ThreadId
tid <- IO ThreadId
myThreadId
ThreadId -> SomeAsyncException -> IO ()
forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
tid SomeAsyncException
ex
, (SomeException -> IO ()) -> Handler ()
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO ()) -> Handler ())
-> (SomeException -> IO ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \(SomeException
ex :: SomeException) ->
IO ()
act IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> SomeException -> IO ()
forall e a. Exception e => e -> IO a
throwIO SomeException
ex
]
type Pred p a = HasCallStack => a -> p
type PT p a b = HasCallStack => Pred p a -> Pred p b
just :: Predicatory p => PT p a (Maybe a)
just :: forall p a. Predicatory p => PT p a (Maybe a)
just = Prism' (Maybe a) a -> PT p a (Maybe a)
forall p s a. Predicatory p => Prism' s a -> PT p a s
match p a (f a) -> p (Maybe a) (f (Maybe a))
forall a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Maybe a) (f (Maybe b))
Prism' (Maybe a) a
_Just
left :: Predicatory p => PT p e (Either e a)
left :: forall p e a. Predicatory p => PT p e (Either e a)
left = Prism' (Either e a) e -> PT p e (Either e a)
forall p s a. Predicatory p => Prism' s a -> PT p a s
match p e (f e) -> p (Either e a) (f (Either e a))
forall a c b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Either a c) (f (Either b c))
Prism' (Either e a) e
_Left
right :: Predicatory p => PT p a (Either e a)
right :: forall p a e. Predicatory p => PT p a (Either e a)
right = Prism' (Either e a) a -> PT p a (Either e a)
forall p s a. Predicatory p => Prism' s a -> PT p a s
match p a (f a) -> p (Either e a) (f (Either e a))
forall c a b (p :: * -> * -> *) (f :: * -> *).
(Choice p, Applicative f) =>
p a (f b) -> p (Either c a) (f (Either c b))
Prism' (Either e a) a
_Right
endingWith :: (Predicatory p, Foldable f) => PT p a (f a)
endingWith :: forall p (f :: * -> *) a.
(Predicatory p, Foldable f) =>
PT p a (f a)
endingWith Pred p a
_ (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> []) = p
forall a. (Predicatory a, HasCallStack) => a
stop
endingWith Pred p a
p (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> [a]
xs) = a -> p
Pred p a
p (a -> p) -> a -> p
forall a b. (a -> b) -> a -> b
$ [a] -> a
forall a. HasCallStack => [a] -> a
last [a]
xs
startingWith :: (Predicatory p, Foldable f) => PT p a (f a)
startingWith :: forall p (f :: * -> *) a.
(Predicatory p, Foldable f) =>
PT p a (f a)
startingWith Pred p a
p (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> (a
x : [a]
_)) = a -> p
Pred p a
p a
x
startingWith Pred p a
_ (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList -> []) = p
forall a. (Predicatory a, HasCallStack) => a
stop
soleElementOf :: (Predicatory p) => Fold s a -> PT p a s
soleElementOf :: forall p s a. Predicatory p => Fold s a -> PT p a s
soleElementOf Fold s a
f Pred p a
p (Getting (Endo [a]) s a -> s -> [a]
forall a s. Getting (Endo [a]) s a -> s -> [a]
toListOf Getting (Endo [a]) s a
Fold s a
f -> [a
x]) = a -> p
Pred p a
p a
x
soleElementOf Fold s a
_ Pred p a
_ s
_ = p
forall a. (Predicatory a, HasCallStack) => a
stop
soleElement :: (Predicatory p, Foldable f) => PT p a (f a)
soleElement :: forall p (f :: * -> *) a.
(Predicatory p, Foldable f) =>
PT p a (f a)
soleElement = Fold (f a) a -> PT p a (f a)
forall p s a. Predicatory p => Fold s a -> PT p a s
soleElementOf (a -> f a) -> f a -> f (f a)
Fold (f a) a
forall (f :: * -> *) a. Foldable f => IndexedFold Int (f a) a
IndexedFold Int (f a) a
folded
match :: Predicatory p => Prism' s a -> PT p a s
match :: forall p s a. Predicatory p => Prism' s a -> PT p a s
match = Fold s a -> PT p a s
Prism' s a -> Pred p a -> s -> p
forall p s a. Predicatory p => Fold s a -> PT p a s
soleElementOf
kth :: (Predicatory p, Foldable f) => Int -> PT p a (f a)
kth :: forall p (f :: * -> *) a.
(Predicatory p, Foldable f) =>
Int -> PT p a (f a)
kth Int
k Pred p a
p = Pred p a -> Pred p [a]
forall p (f :: * -> *) a.
(Predicatory p, Foldable f) =>
PT p a (f a)
startingWith a -> p
Pred p a
p ([a] -> p) -> (f a -> [a]) -> f a -> p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
k ([a] -> [a]) -> (f a -> [a]) -> f a -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList
list :: Predicatory p => [Pred p a] -> [a] -> p
list :: forall p a. Predicatory p => [Pred p a] -> [a] -> p
list (Pred p a
p : [Pred p a]
ps) (a
x : [a]
xs) = a -> p
Pred p a
p a
x p -> p -> p
forall a. (Predicatory a, HasCallStack) => a -> a -> a
`also` [Pred p a] -> [a] -> p
forall p a. Predicatory p => [Pred p a] -> [a] -> p
list [Pred p a]
ps [a]
xs
list [] [] = p
forall a. Predicatory a => a
continue
list [Pred p a]
_ [a]
_ = p
forall a. (Predicatory a, HasCallStack) => a
stop
dist ::
(Predicatory p, Eq (f ()), Functor f, Foldable f) =>
f (Pred p a) ->
Pred p (f a)
dist :: forall p (f :: * -> *) a.
(Predicatory p, Eq (f ()), Functor f, Foldable f) =>
f (Pred p a) -> Pred p (f a)
dist f (Pred p a)
preds f a
values =
p -> p -> Bool -> p
forall a. a -> a -> Bool -> a
bool p
forall a. (Predicatory a, HasCallStack) => a
stop p
forall a. Predicatory a => a
continue ((() () -> f (Pred p a) -> f ()
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f (Pred p a)
preds) f () -> f () -> Bool
forall a. Eq a => a -> a -> Bool
== (() () -> f a -> f ()
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f a
values))
p -> p -> p
forall a. (Predicatory a, HasCallStack) => a -> a -> a
`also` [Pred p a] -> [a] -> p
forall p a. Predicatory p => [Pred p a] -> [a] -> p
list (f (Pred p a) -> [Pred p a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f (Pred p a)
preds) (f a -> [a]
forall a. f a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList f a
values)
distRep ::
Representable f =>
f (Pred p a) ->
f a ->
f p
distRep :: forall (f :: * -> *) p a.
Representable f =>
f (Pred p a) -> f a -> f p
distRep f (Pred p a)
pr f a
fa = (Rep f -> p) -> f p
forall a. (Rep f -> a) -> f a
forall (f :: * -> *) a. Representable f => (Rep f -> a) -> f a
tabulate (\Rep f
r -> f (Pred p a) -> Rep f -> Pred p a
forall a. f a -> Rep f -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index f (Pred p a)
pr Rep f
r (a -> p) -> a -> p
forall a b. (a -> b) -> a -> b
$ f a -> Rep f -> a
forall a. f a -> Rep f -> a
forall (f :: * -> *) a. Representable f => f a -> Rep f -> a
index f a
fa Rep f
r)
allTrue :: (Predicatory p, Foldable f) => f (Pred p a) -> Pred p a
allTrue :: forall p (f :: * -> *) a.
(Predicatory p, Foldable f) =>
f (Pred p a) -> Pred p a
allTrue f (Pred p a)
ps a
a = (Pred p a -> p -> p) -> p -> f (Pred p a) -> p
forall a b. (a -> b -> b) -> b -> f a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Pred p a
p p
r -> a -> p
Pred p a
p a
a p -> p -> p
forall a. (Predicatory a, HasCallStack) => a -> a -> a
`also` p
r) p
forall a. Predicatory a => a
continue f (Pred p a)
ps
allOf1 :: Predicatory p => Fold s a -> PT p a s
allOf1 :: forall p s a. Predicatory p => Fold s a -> PT p a s
allOf1 Fold s a
g Pred p a
p s
vs =
p -> p -> Bool -> p
forall a. a -> a -> Bool -> a
bool p
forall a. (Predicatory a, HasCallStack) => a
stop p
forall a. Predicatory a => a
continue (Getting Any s a -> s -> Bool
forall s a. Getting Any s a -> s -> Bool
notNullOf Getting Any s a
Fold s a
g s
vs)
p -> p -> p
forall a. (Predicatory a, HasCallStack) => a -> a -> a
`also` Getting (Endo p) s a -> (a -> p -> p) -> p -> s -> p
forall r s a. Getting (Endo r) s a -> (a -> r -> r) -> r -> s -> r
foldrOf Getting (Endo p) s a
Fold s a
g (\a
x p
r -> a -> p
Pred p a
p a
x p -> p -> p
forall a. (Predicatory a, HasCallStack) => a -> a -> a
`also` p
r) p
forall a. Predicatory a => a
continue s
vs
pattern a $m:=> :: forall {r} {a} {b}. (a, b) -> (a -> b -> r) -> ((# #) -> r) -> r
$b:=> :: forall {a} {b}. a -> b -> (a, b)
:=> b = (a, b)
pair :: Predicatory p => Pred p a -> Pred p b -> Pred p (a, b)
pair :: forall p a b.
Predicatory p =>
Pred p a -> Pred p b -> Pred p (a, b)
pair Pred p a
f Pred p b
s (a
a, b
b) = a -> p
Pred p a
f a
a p -> p -> p
forall a. (Predicatory a, HasCallStack) => a -> a -> a
`also` b -> p
Pred p b
s b
b
pt :: (a -> b) -> PT p b a
pt :: forall a b p. (a -> b) -> PT p b a
pt a -> b
f Pred p b
p = b -> p
Pred p b
p (b -> p) -> (a -> b) -> a -> p
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f
(?) :: (a -> b) -> a -> b
? :: forall a b. (a -> b) -> a -> b
(?) = (a -> b) -> a -> b
forall a b. (a -> b) -> a -> b
($)
infixl 9 ?
traced :: Show a => (a -> String) -> PT c a a
traced :: forall a c. Show a => (a -> String) -> PT c a a
traced a -> String
s Pred c a
p a
a = String -> c -> c
forall a. String -> a -> a
trace (a -> String
s a
a) (a -> c
Pred c a
p a
a)
tracedShow :: Show a => PT c a a
tracedShow :: forall a c. Show a => PT c a a
tracedShow = (a -> String) -> PT c a a
forall a c. Show a => (a -> String) -> PT c a a
traced a -> String
forall a. Show a => a -> String
show
traceFailShow :: (Exceptional p, Predicatory p, Show a) => PT p a a
traceFailShow :: forall p a. (Exceptional p, Predicatory p, Show a) => PT p a a
traceFailShow = (a -> String) -> PT p a a
forall p a.
(Predicatory p, Exceptional p) =>
(a -> String) -> PT p a a
traceFail a -> String
forall a. Show a => a -> String
show
traceFail :: (Predicatory p, Exceptional p) => (a -> String) -> PT p a a
traceFail :: forall p a.
(Predicatory p, Exceptional p) =>
(a -> String) -> PT p a a
traceFail a -> String
s Pred p a
p a
a =
p -> IO () -> p
forall a. Exceptional a => a -> IO () -> a
assess (a -> p
Pred p a
p a
a) (IO () -> p) -> IO () -> p
forall a b. (a -> b) -> a -> b
$ String -> IO ()
traceIO (a -> String
s a
a)
something :: Predicatory p => Pred p a
something :: forall a e. (Predicatory a, HasCallStack) => e -> a
something = p -> a -> p
forall a b. a -> b -> a
const p
forall a. Predicatory a => a
continue
forced :: (Predicatory p, NFData a) => Pred p a
forced :: forall p a. (Predicatory p, NFData a) => Pred p a
forced a
a = a -> a
forall a. NFData a => a -> a
force a
a a -> p -> p
forall a b. a -> b -> b
`seq` p
forall a. Predicatory a => a
continue
equals :: (Predicatory p, Eq a) => a -> Pred p a
equals :: forall p a. (Predicatory p, Eq a) => a -> Pred p a
equals a
a a
a' = p -> p -> Bool -> p
forall a. a -> a -> Bool -> a
bool (a -> p
forall a. (Predicatory a, HasCallStack) => a
stop a
a') p
forall a. Predicatory a => a
continue (a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a')
satAll :: Predicatory p => [Pred p a] -> Pred p a
satAll :: forall p a. Predicatory p => [Pred p a] -> Pred p a
satAll [Pred p a]
xs a
a = (Pred p a -> p -> p) -> p -> [Pred p a] -> p
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Pred p a
p p
xs -> a -> p
Pred p a
p a
a p -> p -> p
forall a. (Predicatory a, HasCallStack) => a -> a -> a
`also` p
xs) p
forall a. Predicatory a => a
continue [Pred p a]
xs