module Data.Searchable
    ( Searchable(..)
    , forsome
    , forevery
    , Finite(..)
    , finiteSearch
    , finiteCountPrevious
    , finiteCountMaybeNext
    ) where

import Control.Applicative
import Data.Countable
import Data.Int
import Data.List
import Data.Maybe
import Data.Traversable
import Data.Void
import Data.Word
import Prelude

-- | It turns out there are 'Searchable' instances that are not 'Finite'.
-- The @(c -> s)@ instance is based on the algorithm at
-- <http://math.andrej.com/2007/09/28/seemingly-impossible-functional-programs/>.
class Searchable a where
    search :: (a -> Maybe b) -> Maybe b

forsome :: (Searchable a) => (a -> Bool) -> Bool
forsome :: forall a. Searchable a => (a -> Bool) -> Bool
forsome =
    Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool)
-> ((a -> Bool) -> Maybe ()) -> (a -> Bool) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (a -> Maybe ()) -> Maybe ()
forall a b. Searchable a => (a -> Maybe b) -> Maybe b
forall b. (a -> Maybe b) -> Maybe b
search ((a -> Maybe ()) -> Maybe ())
-> ((a -> Bool) -> a -> Maybe ()) -> (a -> Bool) -> Maybe ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (\a -> Bool
ab a
a ->
         if a -> Bool
ab a
a
             then () -> Maybe ()
forall a. a -> Maybe a
Just ()
             else Maybe ()
forall a. Maybe a
Nothing)

forevery :: (Searchable a) => (a -> Bool) -> Bool
forevery :: forall a. Searchable a => (a -> Bool) -> Bool
forevery a -> Bool
p = Bool -> Bool
not ((a -> Bool) -> Bool
forall a. Searchable a => (a -> Bool) -> Bool
forsome (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Bool
p))

instance (Searchable a) => Searchable (Maybe a) where
    search :: forall b. (Maybe a -> Maybe b) -> Maybe b
search Maybe a -> Maybe b
mamb =
        case Maybe a -> Maybe b
mamb Maybe a
forall a. Maybe a
Nothing of
            Just b
b -> b -> Maybe b
forall a. a -> Maybe a
Just b
b
            Maybe b
Nothing -> (a -> Maybe b) -> Maybe b
forall a b. Searchable a => (a -> Maybe b) -> Maybe b
forall b. (a -> Maybe b) -> Maybe b
search (Maybe a -> Maybe b
mamb (Maybe a -> Maybe b) -> (a -> Maybe a) -> a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just)

instance (Searchable a, Searchable b) => Searchable (Either a b) where
    search :: forall b. (Either a b -> Maybe b) -> Maybe b
search Either a b -> Maybe b
eabb =
        case (a -> Maybe b) -> Maybe b
forall a b. Searchable a => (a -> Maybe b) -> Maybe b
forall b. (a -> Maybe b) -> Maybe b
search (Either a b -> Maybe b
eabb (Either a b -> Maybe b) -> (a -> Either a b) -> a -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left) of
            Just b
b -> b -> Maybe b
forall a. a -> Maybe a
Just b
b
            Maybe b
_ -> (b -> Maybe b) -> Maybe b
forall a b. Searchable a => (a -> Maybe b) -> Maybe b
forall b. (b -> Maybe b) -> Maybe b
search (Either a b -> Maybe b
eabb (Either a b -> Maybe b) -> (b -> Either a b) -> b -> Maybe b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a b
forall a b. b -> Either a b
Right)

instance (Searchable a, Searchable b) => Searchable (a, b) where
    search :: forall b. ((a, b) -> Maybe b) -> Maybe b
search (a, b) -> Maybe b
abb = (a -> Maybe b) -> Maybe b
forall a b. Searchable a => (a -> Maybe b) -> Maybe b
forall b. (a -> Maybe b) -> Maybe b
search (\a
a -> (b -> Maybe b) -> Maybe b
forall a b. Searchable a => (a -> Maybe b) -> Maybe b
forall b. (b -> Maybe b) -> Maybe b
search (\b
b -> (a, b) -> Maybe b
abb (a
a, b
b)))

instance (Countable c, Searchable s) => Searchable (c -> s) where
    search :: forall b. ((c -> s) -> Maybe b) -> Maybe b
search (c -> s) -> Maybe b
csmx =
        case (s -> Maybe s) -> Maybe s
forall a b. Searchable a => (a -> Maybe b) -> Maybe b
forall b. (s -> Maybe b) -> Maybe b
search s -> Maybe s
forall a. a -> Maybe a
Just of
            Just s
def -> let
                prepend :: t -> (t -> t) -> t -> t
prepend t
s t -> t
cs t
c =
                    case t -> Maybe t
forall a. Countable a => a -> Maybe a
countPrevious t
c of
                        Just t
c' -> t -> t
cs t
c'
                        Maybe t
Nothing -> t
s
                -- | prepend :: s -> (c -> s) -> c -> s
                -- | findcs :: ((c -> s) -> Maybe x) -> c -> s
                findcs :: ((t -> s) -> Maybe a) -> t -> s
findcs (t -> s) -> Maybe a
csm = let
                    mx :: Maybe s
mx =
                        (s -> Maybe s) -> Maybe s
forall a b. Searchable a => (a -> Maybe b) -> Maybe b
forall b. (s -> Maybe b) -> Maybe b
search
                            (\s
s' -> do
                                 a
_ <- ((t -> s) -> Maybe a) -> Maybe a
forall a b. Searchable a => (a -> Maybe b) -> Maybe b
forall b. ((t -> s) -> Maybe b) -> Maybe b
search ((t -> s) -> Maybe a
csm ((t -> s) -> Maybe a)
-> ((t -> s) -> t -> s) -> (t -> s) -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> (t -> s) -> t -> s
forall {t} {t}. Countable t => t -> (t -> t) -> t -> t
prepend s
s'))
                                 s -> Maybe s
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return s
s')
                    s :: s
s =
                        case Maybe s
mx of
                            Just s
s' -> s
s'
                            Maybe s
_ -> s
def
                    in s -> (t -> s) -> t -> s
forall {t} {t}. Countable t => t -> (t -> t) -> t -> t
prepend s
s (((t -> s) -> Maybe a) -> t -> s
findcs ((t -> s) -> Maybe a
csm ((t -> s) -> Maybe a)
-> ((t -> s) -> t -> s) -> (t -> s) -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (s -> (t -> s) -> t -> s
forall {t} {t}. Countable t => t -> (t -> t) -> t -> t
prepend s
s)))
                in (c -> s) -> Maybe b
csmx (((c -> s) -> Maybe b) -> c -> s
forall {t} {t} {a}.
(Countable t, Countable t) =>
((t -> s) -> Maybe a) -> t -> s
findcs (c -> s) -> Maybe b
csmx)
            Maybe s
Nothing -> Maybe b
forall a. Maybe a
Nothing

-- | There are a finite number of values (possibly zero).
class (Searchable a, Countable a) => Finite a where
    -- | Not necessarily in counting order.
    allValues :: [a]
    assemble ::
           forall b f. (Applicative f)
        => (a -> f b)
        -> f (a -> b)
    assemble a -> f b
afb = ([(a, b)] -> a -> b) -> f [(a, b)] -> f (a -> b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(a, b)] -> a -> b
forall {t} {a}. Eq t => [(t, a)] -> t -> a
listLookup ((a -> f (a, b)) -> [a] -> f [(a, b)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\a
a -> (b -> (a, b)) -> f b -> f (a, b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\b
b -> (a
a, b
b)) (a -> f b
afb a
a)) [a]
forall a. Finite a => [a]
allValues)
      where
        -- listLookup :: [(a,b)] -> a -> b;
        listLookup :: [(t, a)] -> t -> a
listLookup [] t
_ = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"missing value" -- this should never happen
        listLookup ((t
a, a
b):[(t, a)]
_) t
a'
            | t
a t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
a' = a
b
        listLookup ((t, a)
_:[(t, a)]
l) t
a' = [(t, a)] -> t -> a
listLookup [(t, a)]
l t
a'

firstJust :: [Maybe a] -> Maybe a
firstJust :: forall a. [Maybe a] -> Maybe a
firstJust [] = Maybe a
forall a. Maybe a
Nothing
firstJust ((Just a
a):[Maybe a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
a
firstJust (Maybe a
Nothing:[Maybe a]
mas) = [Maybe a] -> Maybe a
forall a. [Maybe a] -> Maybe a
firstJust [Maybe a]
mas

finiteSearch :: (Finite a) => (a -> Maybe b) -> Maybe b
finiteSearch :: forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch a -> Maybe b
p = [Maybe b] -> Maybe b
forall a. [Maybe a] -> Maybe a
firstJust ((a -> Maybe b) -> [a] -> [Maybe b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe b
p [a]
forall a. Finite a => [a]
allValues)

finiteCountPrevious :: (Finite a) => a -> Maybe a
finiteCountPrevious :: forall a. Finite a => a -> Maybe a
finiteCountPrevious a
x = Maybe a -> [a] -> Maybe a
findp Maybe a
forall a. Maybe a
Nothing [a]
forall a. Finite a => [a]
allValues
  where
    findp :: Maybe a -> [a] -> Maybe a
findp Maybe a
ma (a
a:[a]
_)
        | a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
x = Maybe a
ma
    findp Maybe a
_ (a
a:[a]
as) = Maybe a -> [a] -> Maybe a
findp (a -> Maybe a
forall a. a -> Maybe a
Just a
a) [a]
as
    findp Maybe a
_ [] = a -> Maybe a -> Maybe a
forall a b. a -> b -> b
seq a
x ([Char] -> Maybe a
forall a. HasCallStack => [Char] -> a
error [Char]
"missing value")

firstItem :: [a] -> Maybe a
firstItem :: forall a. [a] -> Maybe a
firstItem [] = Maybe a
forall a. Maybe a
Nothing
firstItem (a
a:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
a

finiteCountMaybeNext :: (Finite a) => Maybe a -> Maybe a
finiteCountMaybeNext :: forall a. Finite a => Maybe a -> Maybe a
finiteCountMaybeNext Maybe a
Nothing = [a] -> Maybe a
forall a. [a] -> Maybe a
firstItem [a]
forall a. Finite a => [a]
allValues
finiteCountMaybeNext (Just a
x) = [a] -> Maybe a
findmn [a]
forall a. Finite a => [a]
allValues
  where
    findmn :: [a] -> Maybe a
findmn (a
a:[a]
as)
        | a
x a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a = [a] -> Maybe a
forall a. [a] -> Maybe a
firstItem [a]
as
    findmn (a
_:[a]
as) = [a] -> Maybe a
findmn [a]
as
    findmn [] = a -> Maybe a -> Maybe a
forall a b. a -> b -> b
seq a
x ([Char] -> Maybe a
forall a. HasCallStack => [Char] -> a
error [Char]
"missing value")

instance Searchable Void where
    search :: forall b. (Void -> Maybe b) -> Maybe b
search = (Void -> Maybe b) -> Maybe b
forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch

instance Finite Void where
    allValues :: [Void]
allValues = []
    assemble :: forall b (f :: * -> *).
Applicative f =>
(Void -> f b) -> f (Void -> b)
assemble Void -> f b
_ = (Void -> b) -> f (Void -> b)
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Void -> b
forall a. Void -> a
absurd

instance Searchable () where
    search :: forall b. (() -> Maybe b) -> Maybe b
search = (() -> Maybe b) -> Maybe b
forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch

instance Finite () where
    allValues :: [()]
allValues = [()]
    assemble :: forall b (f :: * -> *). Applicative f => (() -> f b) -> f (() -> b)
assemble () -> f b
afb = (b -> () -> b) -> f b -> f (() -> b)
forall (f :: * -> *) a b. Applicative f => (a -> b) -> f a -> f b
liftA (\b
v ()
_ -> b
v) (() -> f b
afb ())

instance Searchable Bool where
    search :: forall b. (Bool -> Maybe b) -> Maybe b
search = (Bool -> Maybe b) -> Maybe b
forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch

instance Finite Bool where
    allValues :: [Bool]
allValues = [Bool
False, Bool
True]
    assemble :: forall b (f :: * -> *).
Applicative f =>
(Bool -> f b) -> f (Bool -> b)
assemble Bool -> f b
afb =
        (b -> b -> Bool -> b) -> f b -> f b -> f (Bool -> b)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2
            (\b
f b
t Bool
x ->
                 if Bool
x
                     then b
t
                     else b
f)
            (Bool -> f b
afb Bool
False)
            (Bool -> f b
afb Bool
True)

instance Searchable Word8 where
    search :: forall b. (Word8 -> Maybe b) -> Maybe b
search = (Word8 -> Maybe b) -> Maybe b
forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch

instance Finite Word8 where
    allValues :: [Word8]
allValues = Word8 -> [Word8]
forall a. Enum a => a -> [a]
enumFrom Word8
forall a. Bounded a => a
minBound

instance Searchable Word16 where
    search :: forall b. (Word16 -> Maybe b) -> Maybe b
search = (Word16 -> Maybe b) -> Maybe b
forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch

instance Finite Word16 where
    allValues :: [Word16]
allValues = Word16 -> [Word16]
forall a. Enum a => a -> [a]
enumFrom Word16
forall a. Bounded a => a
minBound

instance Searchable Word32 where
    search :: forall b. (Word32 -> Maybe b) -> Maybe b
search = (Word32 -> Maybe b) -> Maybe b
forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch

instance Finite Word32 where
    allValues :: [Word32]
allValues = Word32 -> [Word32]
forall a. Enum a => a -> [a]
enumFrom Word32
forall a. Bounded a => a
minBound

instance Searchable Word64 where
    search :: forall b. (Word64 -> Maybe b) -> Maybe b
search = (Word64 -> Maybe b) -> Maybe b
forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch

instance Finite Word64 where
    allValues :: [Word64]
allValues = Word64 -> [Word64]
forall a. Enum a => a -> [a]
enumFrom Word64
forall a. Bounded a => a
minBound

instance Searchable Int8 where
    search :: forall b. (Int8 -> Maybe b) -> Maybe b
search = (Int8 -> Maybe b) -> Maybe b
forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch

instance Finite Int8 where
    allValues :: [Int8]
allValues = Int8 -> [Int8]
forall a. Enum a => a -> [a]
enumFrom Int8
forall a. Bounded a => a
minBound

instance Searchable Int16 where
    search :: forall b. (Int16 -> Maybe b) -> Maybe b
search = (Int16 -> Maybe b) -> Maybe b
forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch

instance Finite Int16 where
    allValues :: [Int16]
allValues = Int16 -> [Int16]
forall a. Enum a => a -> [a]
enumFrom Int16
forall a. Bounded a => a
minBound

instance Searchable Int32 where
    search :: forall b. (Int32 -> Maybe b) -> Maybe b
search = (Int32 -> Maybe b) -> Maybe b
forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch

instance Finite Int32 where
    allValues :: [Int32]
allValues = Int32 -> [Int32]
forall a. Enum a => a -> [a]
enumFrom Int32
forall a. Bounded a => a
minBound

instance Searchable Int64 where
    search :: forall b. (Int64 -> Maybe b) -> Maybe b
search = (Int64 -> Maybe b) -> Maybe b
forall a b. Finite a => (a -> Maybe b) -> Maybe b
finiteSearch

instance Finite Int64 where
    allValues :: [Int64]
allValues = Int64 -> [Int64]
forall a. Enum a => a -> [a]
enumFrom Int64
forall a. Bounded a => a
minBound

instance (Finite a) => Finite (Maybe a) where
    allValues :: [Maybe a]
allValues = Maybe a
forall a. Maybe a
Nothing Maybe a -> [Maybe a] -> [Maybe a]
forall a. a -> [a] -> [a]
: ((a -> Maybe a) -> [a] -> [Maybe a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just [a]
forall a. Finite a => [a]
allValues)
    assemble :: forall b (f :: * -> *).
Applicative f =>
(Maybe a -> f b) -> f (Maybe a -> b)
assemble Maybe a -> f b
mafb = (b -> (a -> b) -> Maybe a -> b)
-> f b -> f (a -> b) -> f (Maybe a -> b)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 b -> (a -> b) -> Maybe a -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe a -> f b
mafb Maybe a
forall a. Maybe a
Nothing) ((a -> f b) -> f (a -> b)
forall a b (f :: * -> *).
(Finite a, Applicative f) =>
(a -> f b) -> f (a -> b)
forall b (f :: * -> *). Applicative f => (a -> f b) -> f (a -> b)
assemble (Maybe a -> f b
mafb (Maybe a -> f b) -> (a -> Maybe a) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just))

instance (Finite a, Finite b) => Finite (Either a b) where
    allValues :: [Either a b]
allValues = ((a -> Either a b) -> [a] -> [Either a b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Either a b
forall a b. a -> Either a b
Left [a]
forall a. Finite a => [a]
allValues) [Either a b] -> [Either a b] -> [Either a b]
forall a. [a] -> [a] -> [a]
++ ((b -> Either a b) -> [b] -> [Either a b]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Either a b
forall a b. b -> Either a b
Right [b]
forall a. Finite a => [a]
allValues)
    assemble :: forall b (f :: * -> *).
Applicative f =>
(Either a b -> f b) -> f (Either a b -> b)
assemble Either a b -> f b
eabfr = ((a -> b) -> (b -> b) -> Either a b -> b)
-> f (a -> b) -> f (b -> b) -> f (Either a b -> b)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (a -> b) -> (b -> b) -> Either a b -> b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((a -> f b) -> f (a -> b)
forall a b (f :: * -> *).
(Finite a, Applicative f) =>
(a -> f b) -> f (a -> b)
forall b (f :: * -> *). Applicative f => (a -> f b) -> f (a -> b)
assemble (Either a b -> f b
eabfr (Either a b -> f b) -> (a -> Either a b) -> a -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left)) ((b -> f b) -> f (b -> b)
forall a b (f :: * -> *).
(Finite a, Applicative f) =>
(a -> f b) -> f (a -> b)
forall b (f :: * -> *). Applicative f => (b -> f b) -> f (b -> b)
assemble (Either a b -> f b
eabfr (Either a b -> f b) -> (b -> Either a b) -> b -> f b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b -> Either a b
forall a b. b -> Either a b
Right))

instance (Finite a, Finite b) => Finite (a, b) where
    allValues :: [(a, b)]
allValues = (a -> b -> (a, b)) -> [a] -> [b] -> [(a, b)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) [a]
forall a. Finite a => [a]
allValues [b]
forall a. Finite a => [a]
allValues
    assemble :: forall b (f :: * -> *).
Applicative f =>
((a, b) -> f b) -> f ((a, b) -> b)
assemble (a, b) -> f b
abfr = ((a -> b -> b) -> (a, b) -> b)
-> f (a -> b -> b) -> f ((a, b) -> b)
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\a -> b -> b
abr (a
a, b
b) -> a -> b -> b
abr a
a b
b) ((a -> f (b -> b)) -> f (a -> b -> b)
forall a b (f :: * -> *).
(Finite a, Applicative f) =>
(a -> f b) -> f (a -> b)
forall b (f :: * -> *). Applicative f => (a -> f b) -> f (a -> b)
assemble (\a
a -> (b -> f b) -> f (b -> b)
forall a b (f :: * -> *).
(Finite a, Applicative f) =>
(a -> f b) -> f (a -> b)
forall b (f :: * -> *). Applicative f => (b -> f b) -> f (b -> b)
assemble (\b
b -> (a, b) -> f b
abfr (a
a, b
b))))