{-# language ViewPatterns #-}
{-# language LambdaCase #-}
{-# language RankNTypes #-}
{-# language FlexibleInstances #-}

-- | 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.Applicative
import Control.DeepSeq(NFData, force)
import Control.Exception(SomeException, Exception, evaluate, throwIO, try)
import Control.Lens hiding (index, zoom)
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

class Predicatory a where
  oneOfTwo :: a -> a -> a
  also :: a -> a -> a
  stop :: a
  continue :: a

class Exceptional a where
  assess :: a -> IO ()

data PredicateFailed = PredicateFailed
  deriving (Show, Typeable)

instance Exception PredicateFailed

instance Predicatory Bool where
  oneOfTwo = (||)
  also = (&&)
  stop = False
  continue = True

instance Exceptional Bool where
  assess b = do
    evaluate b
    unless b stop

instance Predicatory (IO ()) where
  oneOfTwo x y = x <|> y
  also = (>>)
  stop = throwIO PredicateFailed
  continue = return ()

instance Exceptional (IO ()) where
  assess x = x >>= evaluate

-- |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 p a b = (a -> p) -> (b -> p)

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

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

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

-- |Operate on the `Right` branch of an `Either`, or fail.
right :: Predicatory p => PT p a (Either e a)
right = 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 p (toList -> xs) = p $ last xs
{-# inlinable endingWith #-}

-- |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 p (toList -> (x:_)) = p x
startingWith _ (toList -> []) = stop
{-# inlinable startingWith #-}

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

-- |Only test the @k@th element of a foldable.
kth :: (Predicatory p, Foldable f) => Int -> PT p 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 :: Predicatory p => [a -> p] -> [a] -> p
list (p:ps) (x:xs) = p x `also` list ps xs
list [] [] = continue
list _ _ = stop

-- |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) =>
    f (a -> p) -> f a -> p
dist preds values =
    bool stop continue ((() <$ preds) == (() <$ values)) `also`
    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 -> p) -> f a -> f p
distRep pr fa = tabulate (\r -> index pr r $ index fa r)
{-# inlinable distRep #-}

-- |Test all predicates against one value.
allTrue :: (Predicatory p, Foldable f) => f (a -> p) -> a -> p
allTrue ps a = foldr (\p r -> p a `also` r) continue $ 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 :: 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

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

pair :: Predicatory p => (a -> p) -> (b -> p) -> (a, b) -> p
pair f s (a, b) = f a `also` 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.
--  Requires that the predicate's output type includes a notion of failure.
traceFail :: (Predicatory p, Exceptional p) => (a -> String) -> PT p a a
traceFail s p a = unsafePerformIO $ do
  try (assess (p a)) >>= \case
    Left ex -> do
      traceIO (s a)
      throwIO (ex :: SomeException)
    Right () ->
      pure continue

traceFailShow :: (Exceptional p, Predicatory p, Show a) => PT p a a
traceFailShow = traceFail show

-- |Predicate which always succeeds.
something :: Predicatory p => a -> p
something = const continue

-- |Predicate which triggers full evaluation of its input and succeeds.
-- Useful for testing that an exception isn't thrown.
forced :: (Predicatory p, NFData a) => a -> p
forced a = force a `seq` continue