{-# language ViewPatterns #-}
{-# language LambdaCase #-}

-- | 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@.
-- They act as a sort of compositional "matcher language".
-- Composing these predicate transformers is meant to be analogous to composing optics
-- and there are utilities for using predicate transformers with (`lens`-style) optics.
--
-- Some predicate transformers provided by other libraries:
-- `Data.Foldable.all`, `Data.Foldable.any` (base)
-- `either` (base)
-- `Control.Lens.allOf` (lens)

module PredicateTransformers where

import Control.DeepSeq(NFData, force)
import Control.Exception(SomeException, evaluate, throwIO, try)
import Control.Lens hiding (index, zoom)
import Control.Monad.Writer(execWriter, tell)
import Data.Foldable(toList)
import Data.Functor.Rep(Representable(..))
import Data.Semigroup(All(..), Any(..))
import Debug.Trace
import System.IO.Unsafe

-- |A convenient alias for predicates.
type Pred a = a -> Bool

-- |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 a b = Pred a -> Pred b

-- |Operate on the target of a prism, or fail.
match :: APrism s t a b -> PT a s
match p pred = either (const False) pred . matching p

-- |Invert a predicate.
nay :: PT a a
nay = (not .)

-- |Operate on the `Just` branch of a `Maybe`, or fail.
just :: PT a (Maybe a)
just = match _Just

-- |Operate on the `Left` branch of an `Either`, or fail.
left :: PT e (Either e a)
left = match _Left

-- |Operate on the `Right` branch of an `Either`, or fail.
right :: PT a (Either e a)
right = match _Right

-- |Operate on the last value in a foldable, or fail if it's not present.
endingWith :: Foldable f => PT a (f a)
endingWith _ (toList -> []) = False
endingWith p (toList -> xs) = p $ last xs
{-# inlinable endingWith #-}

-- |Operate on the first value in a foldable, or fail if it's not present.
startingWith :: Foldable f => PT a (f a)
startingWith p (toList -> (x:_)) = p x
startingWith _ (toList -> []) = False
{-# inlinable startingWith #-}

-- |Require that a foldable has a single element, and operate on that element.
only :: Foldable f => PT a (f a)
only p (toList -> [x]) = p x
only _ _ = False
{-# inlinable only #-}

-- |Only test the @k@th element of a foldable.
kth :: Foldable f => Int -> PT a (f a)
kth k p = startingWith p . drop k . toList
{-# inlinable kth #-}

-- |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 :: [Pred a] -> Pred [a]
list (p:ps) (x:xs) = p x && dist ps xs
list [] [] = True
list _ _ = False

-- |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 ::
    (Eq (f ()), Functor f, Foldable f) =>
    f (Pred a) -> Pred (f a)
dist preds values =
    (() <$ preds) == (() <$ values) &&
    list (toList preds) (toList values)
{-# inlinable dist #-}

-- |Given a representable functor-full of predicates, and a functor-full of values,
-- yield a representable functor-full of booleans. Similar to `dist`.
distRep :: Representable f =>
    f (a -> Bool) -> f a -> f Bool
distRep pr fa = tabulate (\r -> index pr r $ index fa r)
{-# inlinable distRep #-}

-- |Test all predicates against one value.
allTrue :: [Pred a] -> Pred a
allTrue ps a = all ($ a) ps

-- |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 :: Getting (All, Any) s a -> PT a s
allOf1 g p (foldMapOf g (\x -> (All $ p x, Any $ p x)) -> (All a, Any y)) = a && y

-- |Sugar for tupling.
(==>) :: a -> b -> (a, b)
(==>) = (,)

pair :: Pred a -> Pred b -> Pred (a,b)
pair f s (a,b) = f a && s b

-- |Flipped function composition; @f !@ for a function @f@ is a predicate transformer.
(!) :: (b -> a) -> (a -> c) -> b -> c
(!) = flip (.)

-- |Prints the input of a predicate, for debugging.
traced :: Show a => (a -> c) -> a -> c
traced p a = traceShow a (p a)

-- |Prints the input of a predicate, if the predicate fails.
traceFail :: (a -> String) -> PT a a
traceFail s p a = unsafePerformIO $ do
  try (evaluate (p a)) >>= \case
    Left ex -> do
      traceIO (s a)
      throwIO (ex :: SomeException)
    Right True ->
      pure True
    Right False -> do
      traceIO ("\n" <> s a)
      pure False

traceFailShow :: Show a => PT a a
traceFailShow = traceFail show

-- |Predicate which always succeeds.
something :: Pred a
something = const True

-- |Predicate which triggers full evaluation of its input.
-- Useful for testing that an exception isn't thrown.
forced :: NFData a => a -> Bool
forced a = force a `seq` True