{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_GHC -fexpose-all-unfoldings #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE ImportQualifiedPost #-}

-- | This library is based on the notion of a property transformer, the below
-- type @PT a b@, which is a function from @a@ to properties on @b@.
-- They act as a sort of compositional "matcher language".
-- Composing these property transformers is meant to be analogous to composing optics
-- and there are utilities for using property transformers with (lens-style) optics.
--
-- Some property transformers provided by other libraries:
-- `Data.Foldable.all`, `Data.Foldable.any` (base)
-- `either` (base)
-- `Control.Lens.allOf` (lens)
module PropertyMatchers
  ( Boolish(..)
  , PropertyFailed(..)
  , Prop
  , PT
  , endingWith
  , startingWith
  , match
  , atIndex
  , list
  , propful
  , compose
  , allTrue
  , allOf1
  , pattern (:=>)
  , pair
  , fun
  , (?)
  , traced
  , tracedShow
  , traceFailShow
  , traceFail
  , forced
  , equals
  )
  where

import "base" Prelude hiding (and, fail, or)
import "base" Control.Concurrent (myThreadId)
import "base" Control.Exception
import "base" Control.Monad hiding (fail)
import "base" Data.Foldable (toList)
import "base" Data.Functor.Const
import "base" Data.Typeable
import "base" Debug.Trace
import "base" GHC.Conc (pseq)
import "base" GHC.Stack
import "base" System.IO.Unsafe

import "deepseq" Control.DeepSeq (NFData, force)
import "text" Data.Text.Lazy qualified as TL
import "adjunctions" Data.Functor.Rep (Representable (..))

import "pretty-simple" Text.Pretty.Simple qualified as Pretty.Simple
import "prettyprinter" Prettyprinter qualified as PP
import "prettyprinter" Prettyprinter.Render.String qualified as PP
import "recover-rtti" Debug.RecoverRTTI (anythingToString)

type Getting r s a = (a -> Const r a) -> s -> Const r s

-- | Class of possible property results.
-- This is almost a lattice with `or` as disjunction, `and` as conjunction, `fail` as the falsy
-- value, and `succeed` as the truthy value. However there may be multiple falsy values, and
-- `and` will pick the first one it's passed, whereas `or` will pick the second it's passed.
class Boolish a where
  or :: a -> a -> a
  and :: a -> a -> a
  fail :: HasCallStack => PP.Doc ann -> v -> a
  succeed :: a
  -- | Check and execute a callback on failure.
  assess :: a -> IO () -> a
  {-# MINIMAL or, and, fail, succeed, assess #-}

instance Boolish a => Boolish (e -> a) where
  (f `or` f') e = f e `or` f' e
  (f `and` f') e = f e `and` f' e
  fail expected actual = withFrozenCallStack $ \_ -> fail expected actual
  succeed = \_ -> succeed
  assess f act = \e -> assess (f e) act

infixr 3 `and`
infixr 2 `or`

-- | The exception thrown by properties of type `IO ()` by default. Other IOExceptions will work fine.
data PropertyFailed = forall actual ann. PropertyFailed !CallStack (PP.Doc ann) actual
  deriving (Typeable)
instance Show PropertyFailed where
  show = displayException

anythingToTextPretty :: a -> TL.Text
anythingToTextPretty = Pretty.Simple.pStringOpt opts . anythingToString
  where
  opts = Pretty.Simple.defaultOutputOptionsNoColor
    { Pretty.Simple.outputOptionsIndentAmount = 2
    , Pretty.Simple.outputOptionsPageWidth = 120
    , Pretty.Simple.outputOptionsCompact = True
    , Pretty.Simple.outputOptionsCompactParens = True
    , Pretty.Simple.outputOptionsInitialIndent = 0
    }

instance Exception PropertyFailed where
  displayException (PropertyFailed cs expected actual) =
    PP.renderString $ PP.layoutSmart PP.defaultLayoutOptions $
      PP.group
        ( PP.line'
        <> PP.flatAlt "Actual:" "Actual value"
        <> PP.softline <> PP.pretty prettyActual
        <> PP.line' <> PP.line
        <> PP.flatAlt "Expected:" "but expected"
        <> PP.softline <> expected
        )
      <> PP.hardline <> PP.pretty (prettyCallStack cs)
    where
    prettyActual = anythingToTextPretty actual

instance Boolish Bool where
  or = (||)
  and = (&&)
  fail _ _ = False
  succeed = True
  assess b act
    | b = b
    | otherwise = unsafePerformIO act `pseq` b

instance a ~ () => Boolish (IO a) where
  or x y = do
    catches x
      -- explicitly do not handle async exceptions.
      -- otherwise, a thread being killed may appear as a property failure.
      [ Handler $ \(ex :: SomeAsyncException) -> do
        tid <- myThreadId
        throwTo tid ex
      , Handler $ \(_ex :: SomeException) -> y
      ]
  and = (>>)
  fail expected actual = throwIO (PropertyFailed (popCallStack callStack) expected actual)
  succeed = return ()
  assess x act =
    catches x
      -- explicitly do not handle async exceptions.
      -- otherwise, a thread being killed may appear as a property failure.
      [ Handler $ \(ex :: SomeAsyncException) -> do
        tid <- myThreadId
        throwTo tid ex
      , Handler $ \(ex :: SomeException) ->
        act >> throwIO ex
      ]

-- | A convenient alias for properties.
type Prop p a = a -> p

-- | Property 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 = Prop p a -> Prop p b

-- | Operate on the last value in a foldable, or fail if it's not present.
endingWith :: (HasCallStack, Boolish p, Foldable f) => PT p a (f a)
endingWith _ actual@(toList -> []) = fail "nonempty foldable" actual
endingWith p (toList -> xs) = p $ last xs

-- | Operate on the first value in a foldable, or fail if it's not present.
startingWith :: (HasCallStack, Boolish p, Foldable f) => PT p a (f a)
startingWith _ actual@(toList -> []) = fail "nonempty foldable" actual
startingWith p (toList -> (x : _)) = p x

-- | Require that a @Prism@ matches, and apply the property to its contents.
-- This works for folds, too.
match
  :: (HasCallStack, Boolish p)
  => Getting [a] s a
  -> PT p a s
match f p s =
  case f (Const . pure) s of
    Const [x] -> p x
    _ -> fail "fold to match" s

-- | Test the element of a foldable at some index.
atIndex :: (Boolish p, Foldable f) => Int -> PT p a (f a)
atIndex k p = startingWith p . drop k . toList

-- | Given a list of properties and a list of values, ensure that each property holds for each respective value.
--  Fails if the two lists have different lengths.
list :: (HasCallStack, Boolish p) => [Prop p a] -> [a] -> p
list ps xs
  | psl == length xs = foldr and succeed (zipWith ($) ps xs)
  | otherwise = fail ("list with length " <> PP.pretty psl) xs
  where
  psl = length ps

-- | Given a functor-full of properties, and a functor-full of values, ensure that the structures
--  of the two functors match and apply all of the properties to all of the values.
--  Generalized version of `list`.
propful ::
  (HasCallStack, Boolish p, Eq (f ()), Functor f, Foldable f) =>
  f (Prop p a) ->
  Prop p (f a)
propful props values
  | void props == void values =
    list (toList props) (toList values)
  | otherwise =
    fail ("shape equal to that of" <> PP.pretty (anythingToTextPretty props)) values

-- | Given a representable functor-full of properties, and a functor-full of values,
--  yield a representable functor-full of booleans. Similar to `propful`.
compose ::
  Representable f =>
  f (Prop p a) ->
  f a ->
  f p
compose pr fa = tabulate (\r -> index pr r $ index fa r)

-- | Test all properties against one value.
allTrue :: (Boolish p, Foldable f) => f (Prop p a) -> Prop p a
allTrue ps a = foldr (\p r -> p a `and` r) succeed ps

-- | Check that a property is true for all values behind a generalized getter
--  and that there's at least one value for which it's true.
allOf1
  :: (HasCallStack, Boolish p)
  => Getting [a] s a
  -> PT p a s
allOf1 g p vs
  | [] <- vsList =
    foldr (\x r -> p x `and` r) succeed vsList
  | otherwise = fail "non-empty for fold" vs
  where
  Const vsList = g (Const . pure) vs

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

-- | A pair of properties, made into a property of pairs.
pair :: Boolish p => Prop p a -> Prop p b -> Prop p (a, b)
pair f s (a, b) = f a `and` s b

-- | Flipped function composition; @pf f@ for a function @f@ is a property transformer
-- such that @pf f p i == p (f i)@.
fun :: (a -> b) -> PT p b a
fun f p = p . f

-- | Higher precedence '$', to work well with '&'.
-- The intended use is something like `x & match _Right ? equals 2`.
(?) :: (a -> b) -> a -> b
(?) = ($)
infixr 8 ?

-- | Prints the input of a property, if the property fails, using `Show`.
--   Requires that the property's output type can be checked for failure.
traceFailShow :: (Boolish p, Show a) => PT p a a
traceFailShow = traceFail show

-- | Prints the input of a property over functions, if the property fails.
--   Requires that the property's output type can be checked for failure.
traceFail :: (Boolish p) => (a -> String) -> PT p a a
traceFail s p a =
  assess (p a) $ traceIO (s a)

-- | Prints the input of a property, for debugging.
traced :: Show a => (a -> String) -> PT c a a
traced s p a = trace (s a) (p a)

-- | Prints the input of a property, for debugging.
tracedShow :: Show a => PT c a a
tracedShow = traced show

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

-- | The property of being equal to some expected value.
equals :: (HasCallStack, Boolish p, Eq a) => a -> Prop p a
equals expected actual
  | expected == actual = succeed
  | otherwise = fail (PP.pretty (anythingToTextPretty expected)) actual