{-# OPTIONS_GHC -Wall #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE FlexibleContexts #-}

module Data.Predicate(
  PredicateT(..)
, Predicate
, predicateT
, predicate
, predicate'
, purePredicate
, true
, false
, (.&&.)
, (.||.)
, (.->.)
, not
, and
, or
, all
, any
, equals
, notEquals
, elem
, notElem
, isInfixOf
, isPrefixOf
, isSuffixOf
, isSubsequenceOf
, find
, filter
, null
, takeWhile
, dropWhile
) where

import Control.Applicative ( Applicative(pure, liftA2) )
import Control.Category ( Category((.), id) )
import Control.Lens
    ( Getting,
      allOf,
      andOf,
      anyOf,
      orOf,
      iso,
      review,
      over,
      Iso )
import Control.Monad ( Monad((>>=)) )
import Control.Monad.Reader.Class ( MonadReader )
import Data.Bool ( Bool(..), (||), bool )
import qualified Data.Bool as Bool
import Data.Either( either )
import Data.Eq ( Eq((==)) )
import Data.Functor( Functor( fmap ))
import Data.Functor.Contravariant ( Contravariant(contramap) )
import Data.Functor.Contravariant.Divisible
    ( Decidable(..), Divisible(..) )
import Data.Functor.Identity ( Identity(..) )
import Data.Foldable(Foldable( foldr ))
import qualified Data.List as List
import Data.Maybe ( Maybe(..) )
import Data.Monoid ( Monoid(mempty), All, Any )
import Data.Semigroup ( Semigroup((<>)) )
import Data.Void( absurd )

newtype PredicateT f a =
  PredicateT (a -> f Bool)

type Predicate a =
  PredicateT Identity a

predicateT ::
  Iso
    (PredicateT f a)
    (PredicateT f' a')
    (a -> f Bool)
    (a' -> f' Bool)
predicateT =
  iso
    (\(PredicateT p) -> p)
    PredicateT

predicate ::
  Iso
    (Predicate a)
    (Predicate a')
    (a -> Bool)
    (a' -> Bool)
predicate =
  iso
    (\(PredicateT p) -> runIdentity . p)
    (\p -> PredicateT (Identity . p))

predicate' ::
  MonadReader (a -> Bool) f =>
  f (Predicate a)
predicate' =
  review predicate

instance Contravariant (PredicateT f) where
  contramap f =
    over predicateT (. f)

instance Monad f => Divisible (PredicateT f) where
  divide f (PredicateT p) (PredicateT q) =
    PredicateT (\a -> let (b, c) = f a in p b >>= bool (pure False) (q c))
  conquer =
    mempty

instance Monad f => Decidable (PredicateT f) where
  lose f =
    PredicateT (pure . absurd . f)
  choose f (PredicateT p) (PredicateT q) =
    PredicateT (either p q . f)

instance Monad f => Semigroup (PredicateT f a) where
  PredicateT p <> PredicateT q =
    PredicateT (\a -> p a >>= bool (pure False) (q a))

instance Monad f => Monoid (PredicateT f a) where
  mempty =
    PredicateT (pure (pure True))

purePredicate ::
  Applicative f =>
  (a -> Bool)
  -> PredicateT f a
purePredicate p =
  PredicateT (pure . p)

true ::
  Applicative f =>
  PredicateT f a
true =
  purePredicate (pure True)

false ::
  Applicative f =>
  PredicateT f b
false =
  purePredicate (pure False)

(.&&.) ::
  Monad f =>
  PredicateT f a
  -> PredicateT f a
  -> PredicateT f a
(.&&.) =
  (<>)

(.||.) ::
  Monad f =>
  PredicateT f a
  -> PredicateT f a
  -> PredicateT f a
PredicateT p .||. PredicateT q =
  PredicateT (\a -> p a >>= bool (q a) (pure True))

(.->.) ::
  Monad f =>
  PredicateT f a
  -> PredicateT f a
  -> PredicateT f a
PredicateT p .->. PredicateT q =
  PredicateT (\a -> p a >>= \p' -> q a >>= \q' -> pure (Bool.not p' || q'))

not ::
  Functor f =>
  PredicateT f a
  -> PredicateT f a
not (PredicateT p) =
  PredicateT (fmap Bool.not . p)

and ::
  Applicative f =>
  Getting All s Bool
  -> PredicateT f s
and =
  purePredicate . andOf

or ::
  Applicative f =>
  Getting Any s Bool
  -> PredicateT f s
or =
  purePredicate . orOf

all ::
  Getting All s a
  -> Predicate a
  -> Predicate s
all =
  over predicate . allOf

any ::
  Getting Any s a
  -> Predicate a
  -> Predicate s
any =
  over predicate . anyOf

equals ::
  (Applicative f, Eq a) =>
  a
  -> PredicateT f a
equals s =
  purePredicate (s ==)

notEquals ::
  (Applicative f, Eq a) =>
  a
  -> PredicateT f a
notEquals =
  not . equals

elem ::
  Eq a =>
  Getting Any s a
  -> a
  -> Predicate s
elem l =
  any l . equals

notElem ::
  Eq a =>
  Getting All s a
  -> a
  -> Predicate s
notElem l =
  all l . notEquals

isInfixOf ::
  (Applicative f, Eq a) =>
  [a]
  -> PredicateT f [a]
isInfixOf s =
  PredicateT (pure . (s `List.isInfixOf`))

isPrefixOf ::
  (Applicative f, Eq a) =>
  [a]
  -> PredicateT f [a]
isPrefixOf s =
  PredicateT (pure . (s `List.isPrefixOf`))

isSuffixOf ::
  (Applicative f, Eq a) =>
  [a]
  -> PredicateT f [a]
isSuffixOf s =
  PredicateT (pure . (s `List.isSuffixOf`))

isSubsequenceOf ::
  (Applicative f, Eq a) =>
  [a]
  -> PredicateT f [a]
isSubsequenceOf s =
  PredicateT (pure . (s `List.isSubsequenceOf`))

find ::
  (Monad f, Foldable t) =>
  PredicateT f a
  -> t a
  -> f (Maybe a)
find (PredicateT p) =
  foldr (\a b -> p a >>= bool b (pure (Just a))) (pure Nothing)

filter ::
  Applicative f =>
  PredicateT f a
  -> [a]
  -> f [a]
filter (PredicateT p) =
  foldr (\a -> liftA2 (bool id (a:)) (p a)) (pure [])

null ::
  (Applicative f, Foldable t) =>
  PredicateT f (t a)
null =
  PredicateT (pure . List.null)

takeWhile ::
  Monad f =>
  PredicateT f a
  -> [a]
  -> f [a]
takeWhile (PredicateT p) =
  foldr (\a b -> p a >>= bool (pure []) (fmap (a:) b)) (pure [])

dropWhile ::
  Monad f =>
  PredicateT f a
  -> [a]
  -> f [a]
dropWhile _ [] =
  pure []
dropWhile p'@(PredicateT p) (h:t) =
  p h >>= bool (pure (h:t)) (dropWhile p' t)