{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, FunctionalDependencies,
             UndecidableInstances, ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies, FlexibleContexts, CPP #-}
{-# OPTIONS_GHC -Wall #-}

{-# OPTIONS_GHC -fno-warn-unused-imports #-} -- TEMP
{-# OPTIONS_GHC -fno-warn-unused-binds   #-} -- TEMP

----------------------------------------------------------------------
-- |
-- Module      :  Data.Boolean
-- Copyright   :  (c) Conal Elliott 2009-2012
-- License     :  BSD3
-- 
-- Maintainer  :  conal@conal.net
-- Stability   :  experimental
-- 
-- Some classes for generalized boolean operations.
-- 
-- In this design, for if-then-else, equality and inequality tests, the
-- boolean type depends on the value type.
-- 
-- I also tried using a unary type constructor class.  The class doesn't work
-- for regular booleans, so generality is lost.  Also, we'd probably have
-- to wire class constraints in like: @(==*) :: Eq a => f Bool -> f a -> f
-- a -> f a@, which disallows situations needing additional constraints,
-- e.g., Show.
--
-- Starting with 0.1.0, this package uses type families.
-- Up to version 0.0.2, it used MPTCs with functional dependencies.
-- My thanks to Andy Gill for suggesting & helping with the change.

----------------------------------------------------------------------

module Data.Boolean
  ( Boolean(..), BooleanOf, IfB(..)
  , boolean, cond, crop
  , EqB(..), OrdB(..)
  , minB, maxB, sort2B
  , guardedB, caseB
  ) where

#if MIN_VERSION_base(4,8,0)
import Prelude hiding ((<*))
#endif
import Data.Monoid (Monoid,mempty)
import Control.Applicative (Applicative(pure),liftA2,liftA3)

{--------------------------------------------------------------------
    Classes
--------------------------------------------------------------------}

infixr 3  &&*
infixr 2  ||*

-- | Generalized boolean class
class Boolean b where
  true, false  :: b
  notB         :: b -> b
  (&&*), (||*) :: b -> b -> b

instance Boolean Bool where
  true :: Bool
true  = Bool
True
  false :: Bool
false = Bool
False
  notB :: Bool -> Bool
notB  = Bool -> Bool
not
  &&* :: Bool -> Bool -> Bool
(&&*) = Bool -> Bool -> Bool
(&&)
  ||* :: Bool -> Bool -> Bool
(||*) = Bool -> Bool -> Bool
(||)

-- | 'BooleanOf' computed the boolean analog of a specific type.
type family BooleanOf a

-- | Types with conditionals
class Boolean (BooleanOf a) => IfB a where
  ifB  :: (bool ~ BooleanOf a) => bool -> a -> a -> a

-- | Expression-lifted conditional with condition last
boolean :: (IfB a, bool ~ BooleanOf a) => a -> a -> bool -> a
boolean :: forall a bool. (IfB a, bool ~ BooleanOf a) => a -> a -> bool -> a
boolean a
t a
e bool
bool = forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB bool
bool a
t a
e

-- | Point-wise conditional
cond :: (Applicative f, IfB a, bool ~ BooleanOf a) => f bool -> f a -> f a -> f a
cond :: forall (f :: * -> *) a bool.
(Applicative f, IfB a, bool ~ BooleanOf a) =>
f bool -> f a -> f a -> f a
cond = forall (f :: * -> *) a b c d.
Applicative f =>
(a -> b -> c -> d) -> f a -> f b -> f c -> f d
liftA3 forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB

-- | Generalized cropping, filling in 'mempty' where the test yields false.
crop :: (Applicative f, Monoid (f a), IfB a, bool ~ BooleanOf a) => f bool -> f a -> f a
crop :: forall (f :: * -> *) a bool.
(Applicative f, Monoid (f a), IfB a, bool ~ BooleanOf a) =>
f bool -> f a -> f a
crop f bool
r f a
f = forall (f :: * -> *) a bool.
(Applicative f, IfB a, bool ~ BooleanOf a) =>
f bool -> f a -> f a -> f a
cond f bool
r f a
f forall a. Monoid a => a
mempty

-- | A generalized replacement for guards and chained ifs.
guardedB :: (IfB b, bool ~ BooleanOf b) => bool -> [(bool,b)] -> b -> b
guardedB :: forall b bool.
(IfB b, bool ~ BooleanOf b) =>
bool -> [(bool, b)] -> b -> b
guardedB bool
_ []        b
e = b
e
guardedB bool
a ((bool
c,b
b):[(bool, b)]
l) b
e = forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB bool
c b
b (forall b bool.
(IfB b, bool ~ BooleanOf b) =>
bool -> [(bool, b)] -> b -> b
guardedB bool
a [(bool, b)]
l b
e)

-- | A generalized version of a case like control structure.
caseB :: (IfB b, bool ~ BooleanOf b) => a -> [(a -> bool, b)] -> b -> b
caseB :: forall b bool a.
(IfB b, bool ~ BooleanOf b) =>
a -> [(a -> bool, b)] -> b -> b
caseB a
_ []        b
e = b
e
caseB a
x ((a -> bool
p,b
b):[(a -> bool, b)]
l) b
e = forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB (a -> bool
p a
x) b
b (forall b bool a.
(IfB b, bool ~ BooleanOf b) =>
a -> [(a -> bool, b)] -> b -> b
caseB a
x [(a -> bool, b)]
l b
e)

infix  4  ==*, /=*

-- | Types with equality.  Minimum definition: '(==*)'.
class Boolean (BooleanOf a) => EqB a where
  (==*), (/=*) :: (bool ~ BooleanOf a) => a -> a -> bool
  a
u /=* a
v = forall b. Boolean b => b -> b
notB (a
u forall a bool. (EqB a, bool ~ BooleanOf a) => a -> a -> bool
==* a
v)

infix  4  <*, <=*, >=*, >*

-- | Types with inequality.  Minimum definition: '(<*)'.
class Boolean (BooleanOf a) => OrdB a where
  (<*), (<=*), (>*), (>=*) :: (bool ~ BooleanOf a) => a -> a -> bool
  a
u >*  a
v = a
v forall a bool. (OrdB a, bool ~ BooleanOf a) => a -> a -> bool
<* a
u
  a
u >=* a
v = forall b. Boolean b => b -> b
notB (a
u forall a bool. (OrdB a, bool ~ BooleanOf a) => a -> a -> bool
<* a
v)
  a
u <=* a
v = a
v forall a bool. (OrdB a, bool ~ BooleanOf a) => a -> a -> bool
>=* a
u

-- | Variant of 'min' using 'ifB' and '(<=*)'
minB :: (IfB a, OrdB a) => a -> a -> a
a
u minB :: forall a. (IfB a, OrdB a) => a -> a -> a
`minB` a
v = forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB (a
u forall a bool. (OrdB a, bool ~ BooleanOf a) => a -> a -> bool
<=* a
v) a
u a
v

-- | Variant of 'max' using 'ifB' and '(>=*)'
maxB :: (IfB a, OrdB a) => a -> a -> a
a
u maxB :: forall a. (IfB a, OrdB a) => a -> a -> a
`maxB` a
v = forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB (a
u forall a bool. (OrdB a, bool ~ BooleanOf a) => a -> a -> bool
>=* a
v) a
u a
v

-- | Variant of 'min' and 'max' using 'ifB' and '(<=*)'
sort2B :: (IfB a, OrdB a) => (a,a) -> (a,a)
sort2B :: forall a. (IfB a, OrdB a) => (a, a) -> (a, a)
sort2B (a
u,a
v) = forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB (a
u forall a bool. (OrdB a, bool ~ BooleanOf a) => a -> a -> bool
<=* a
v) (a
u,a
v) (a
v,a
u)



{--------------------------------------------------------------------
    Instances for Prelude types
--------------------------------------------------------------------}

-- Simple if-then-else as function.
ife :: Bool -> a -> a -> a
ife :: forall a. Bool -> a -> a -> a
ife Bool
c a
t a
e = if Bool
c then a
t else a
e

-- I'd give the following instances:
-- 
--     instance          IfB a where ifB = ife
--     instance Eq  a => EqB a where { (==*) = (==) ; (/=*) = (/=) }
--     instance Ord a => Ord a where { (<*) = (<) ; (<=*) = (<=)}
-- 
-- Sadly, doing so would break the a->bool fundep, which is needed elsewhere
-- for disambiguation.  So use the instances above as templates, filling
-- in specific types for a.

#define SimpleInstances(Ty) \
instance IfB  (Ty) where { ifB = ife } ;\
instance EqB  (Ty) where { (==*) = (==) ; (/=*) = (/=) } ;\
instance OrdB (Ty) where { (<*) = (<) ; (<=*) = (<=) }

#define SimpleTy(Ty) \
type instance BooleanOf (Ty) = Bool ;\
SimpleInstances(Ty)

SimpleTy(Int)
SimpleTy(Integer)
SimpleTy(Float)
SimpleTy(Double)
SimpleTy(Bool)
SimpleTy(Char)

-- Similarly for other simple types.

-- TODO: Export these macros for external use. I guess I'd want a .h file as in
-- the applicative-numbers package.

type instance BooleanOf [a]       = BooleanOf a
type instance BooleanOf (a,b)     = BooleanOf a
type instance BooleanOf (a,b,c)   = BooleanOf a
type instance BooleanOf (a,b,c,d) = BooleanOf a
type instance BooleanOf (z -> a)  = z -> BooleanOf a

-- I'm uncomfortable with this list instance. It's unlike tuples and unlike
-- functions. It could be generalized from BooleanOf a ~ Bool to a general case
-- for applicatives, but then the list version would form cross products.
-- Consider strings and other list types under a variety of use scenarios.

instance (Boolean (BooleanOf a),BooleanOf a ~ Bool) => IfB [a] where { ifB :: forall bool. (bool ~ BooleanOf [a]) => bool -> [a] -> [a] -> [a]
ifB = forall a. Bool -> a -> a -> a
ife }

instance (bool ~ BooleanOf p, bool ~ BooleanOf q
         ,IfB p, IfB q) => IfB (p,q) where
  ifB :: forall bool.
(bool ~ BooleanOf (p, q)) =>
bool -> (p, q) -> (p, q) -> (p, q)
ifB bool
w (p
p,q
q) (p
p',q
q') = (forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB bool
w p
p p
p', forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB bool
w q
q q
q')

instance (bool ~ BooleanOf p, bool ~ BooleanOf q, bool ~ BooleanOf r
         ,IfB p, IfB q, IfB r)
      => IfB (p,q,r) where
  ifB :: forall bool.
(bool ~ BooleanOf (p, q, r)) =>
bool -> (p, q, r) -> (p, q, r) -> (p, q, r)
ifB bool
w (p
p,q
q,r
r) (p
p',q
q',r
r') = (forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB bool
w p
p p
p', forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB bool
w q
q q
q', forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB bool
w r
r r
r')

instance (bool ~ BooleanOf p, bool ~ BooleanOf q, bool ~ BooleanOf r, bool ~ BooleanOf s
         ,IfB p, IfB q, IfB r, IfB s) => IfB (p,q,r,s) where
  ifB :: forall bool.
(bool ~ BooleanOf (p, q, r, s)) =>
bool -> (p, q, r, s) -> (p, q, r, s) -> (p, q, r, s)
ifB bool
w (p
p,q
q,r
r,s
s) (p
p',q
q',r
r',s
s') =
    (forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB bool
w p
p p
p', forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB bool
w q
q q
q', forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB bool
w r
r r
r', forall a bool. (IfB a, bool ~ BooleanOf a) => bool -> a -> a -> a
ifB bool
w s
s s
s')

-- Instances for functions, using the standard pattern for applicative functions.
-- Note that the [] applicative does not use this instance. Fishy.

instance Boolean bool => Boolean (z -> bool) where
  true :: z -> bool
true  = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b. Boolean b => b
true
  false :: z -> bool
false = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b. Boolean b => b
false
  notB :: (z -> bool) -> z -> bool
notB  = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b. Boolean b => b -> b
notB
  &&* :: (z -> bool) -> (z -> bool) -> z -> bool
(&&*) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall b. Boolean b => b -> b -> b
(&&*)
  ||* :: (z -> bool) -> (z -> bool) -> z -> bool
(||*) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall b. Boolean b => b -> b -> b
(||*)

instance IfB a => IfB (z -> a) where
  ifB :: forall bool.
(bool ~ BooleanOf (z -> a)) =>
bool -> (z -> a) -> (z -> a) -> z -> a
ifB = forall (f :: * -> *) a bool.
(Applicative f, IfB a, bool ~ BooleanOf a) =>
f bool -> f a -> f a -> f a
cond

instance EqB a => EqB (z -> a) where
  { ==* :: forall bool.
(bool ~ BooleanOf (z -> a)) =>
(z -> a) -> (z -> a) -> bool
(==*) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a bool. (EqB a, bool ~ BooleanOf a) => a -> a -> bool
(==*) ; /=* :: forall bool.
(bool ~ BooleanOf (z -> a)) =>
(z -> a) -> (z -> a) -> bool
(/=*) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a bool. (EqB a, bool ~ BooleanOf a) => a -> a -> bool
(/=*) }
instance OrdB a => OrdB (z -> a) where
  { <* :: forall bool.
(bool ~ BooleanOf (z -> a)) =>
(z -> a) -> (z -> a) -> bool
(<*) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a bool. (OrdB a, bool ~ BooleanOf a) => a -> a -> bool
(<*) ; <=* :: forall bool.
(bool ~ BooleanOf (z -> a)) =>
(z -> a) -> (z -> a) -> bool
(<=*) = forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 forall a bool. (OrdB a, bool ~ BooleanOf a) => a -> a -> bool
(<=*) }

-- TODO: Generalize the function instance into a macro for arbitrary
-- applicatives. Instantiate for functions.

{-

{--------------------------------------------------------------------
    Tests
--------------------------------------------------------------------}

t1 :: String
t1 = ifB True "foo" "bar"

t2 :: Float -> Float
t2 = ifB (< 0) negate id

--     No instance for (IfB (a -> Bool) (a1 -> a1))
--       arising from a use of `ifB'
-- 
-- t2 = ifB (< 0) negate id                -- abs

-}