BoolLike.hs

{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
module BoolLike where

import Prelude hiding ((&&), (||), not)
import qualified Prelude as P

newtype BoolLike a = BoolLike ((a -> Bool) -> Bool)

toBoolLike :: a -> BoolLike a
toBoolLike x = BoolLike $ \k -> k x


(&&), (||) :: (IsBool a c, IsBool b c) => a -> b -> BoolLike c
(toBool -> BoolLike f) && (toBool -> BoolLike g) = BoolLike $ \k -> f k P.&& g k
(toBool -> BoolLike f) || (toBool -> BoolLike g) = BoolLike $ \k -> f k P.|| g k

not :: IsBool a b => a -> BoolLike b
not (toBool -> BoolLike f) = BoolLike $ \k -> P.not (f k)

infixr 3 &&
infixr 2 ||

belongs :: (Eq b, IsBool a b) => a -> [b] -> Bool
belongs (toBool -> BoolLike f) xs = f (\x -> x `elem` xs)

contains :: forall a a1. (IsBool a [a1], Eq a1) => a -> a1 -> Bool
contains (toBool -> BoolLike (f :: ([a1] -> Bool) -> Bool)) x = f (\xs -> x `elem` xs)

class IsBool a item where
  toBool :: a -> BoolLike item

instance (item ~ a) => IsBool (BoolLike a) item where
  toBool = id

instance {-# INCOHERENT #-} (item ~ a) => IsBool a item where
  toBool = toBoolLike


a, b, c :: Char
a = 'a'
b = 'b'
c = 'c'
d = 'd'

data Color = R | G | B deriving (Eq, Ord, Show)

main :: IO ()
main = do
  print $ (a && b || c) `belongs` [a]
  print $ (a && b || c) `belongs` [b]
  print $ (a && b || c) `belongs` [a, b]
  print $ (a && b || c) `belongs` [c]
  print $ (a && b || c) `belongs` []
  print $ (R && G || B) `belongs` [R]
  print $ (1 && 2 || 3) `belongs` [1, 2]