{-# LANGUAGE DeriveGeneric #-}
module Data.Greskell.Logic
( Logic (..)
, runBool
) where
import Control.Applicative (Applicative (pure, (<*>)), (<$>))
import Control.Monad (Monad (return, (>>=)))
import Data.Foldable (Foldable (foldMap, toList))
import Data.Monoid (All (..), Any (..), (<>))
import Data.Traversable (Traversable)
import GHC.Generics (Generic)
data Logic a
= Leaf a
| And (Logic a) [Logic a]
| Or (Logic a) [Logic a]
| Not (Logic a)
deriving (Logic a -> Logic a -> Bool
forall a. Eq a => Logic a -> Logic a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Logic a -> Logic a -> Bool
$c/= :: forall a. Eq a => Logic a -> Logic a -> Bool
== :: Logic a -> Logic a -> Bool
$c== :: forall a. Eq a => Logic a -> Logic a -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Logic a) x -> Logic a
forall a x. Logic a -> Rep (Logic a) x
$cto :: forall a x. Rep (Logic a) x -> Logic a
$cfrom :: forall a x. Logic a -> Rep (Logic a) x
Generic, Logic a -> Logic a -> Ordering
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (Logic a)
forall a. Ord a => Logic a -> Logic a -> Bool
forall a. Ord a => Logic a -> Logic a -> Ordering
forall a. Ord a => Logic a -> Logic a -> Logic a
min :: Logic a -> Logic a -> Logic a
$cmin :: forall a. Ord a => Logic a -> Logic a -> Logic a
max :: Logic a -> Logic a -> Logic a
$cmax :: forall a. Ord a => Logic a -> Logic a -> Logic a
>= :: Logic a -> Logic a -> Bool
$c>= :: forall a. Ord a => Logic a -> Logic a -> Bool
> :: Logic a -> Logic a -> Bool
$c> :: forall a. Ord a => Logic a -> Logic a -> Bool
<= :: Logic a -> Logic a -> Bool
$c<= :: forall a. Ord a => Logic a -> Logic a -> Bool
< :: Logic a -> Logic a -> Bool
$c< :: forall a. Ord a => Logic a -> Logic a -> Bool
compare :: Logic a -> Logic a -> Ordering
$ccompare :: forall a. Ord a => Logic a -> Logic a -> Ordering
Ord, Int -> Logic a -> ShowS
forall a. Show a => Int -> Logic a -> ShowS
forall a. Show a => [Logic a] -> ShowS
forall a. Show a => Logic a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Logic a] -> ShowS
$cshowList :: forall a. Show a => [Logic a] -> ShowS
show :: Logic a -> String
$cshow :: forall a. Show a => Logic a -> String
showsPrec :: Int -> Logic a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Logic a -> ShowS
Show)
instance Functor Logic where
fmap :: forall a b. (a -> b) -> Logic a -> Logic b
fmap a -> b
f Logic a
l =
case Logic a
l of
Leaf a
a -> forall a. a -> Logic a
Leaf (a -> b
f a
a)
And Logic a
ll [Logic a]
rls -> forall a. Logic a -> [Logic a] -> Logic a
And (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Logic a
ll) (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Logic a]
rls)
Or Logic a
ll [Logic a]
rls -> forall a. Logic a -> [Logic a] -> Logic a
Or (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Logic a
ll) (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Logic a]
rls)
Not Logic a
nl -> forall a. Logic a -> Logic a
Not (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Logic a
nl)
instance Applicative Logic where
pure :: forall a. a -> Logic a
pure a
a = forall a. a -> Logic a
Leaf a
a
Logic (a -> b)
fl <*> :: forall a b. Logic (a -> b) -> Logic a -> Logic b
<*> Logic a
rl =
case Logic (a -> b)
fl of
Leaf a -> b
f -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Logic a
rl
And Logic (a -> b)
lfl [Logic (a -> b)]
rfls -> forall a. Logic a -> [Logic a] -> Logic a
And (Logic (a -> b)
lfl forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl) (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl) [Logic (a -> b)]
rfls)
Or Logic (a -> b)
lfl [Logic (a -> b)]
rfls -> forall a. Logic a -> [Logic a] -> Logic a
Or (Logic (a -> b)
lfl forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl) (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl) [Logic (a -> b)]
rfls)
Not Logic (a -> b)
nfl -> forall a. Logic a -> Logic a
Not (Logic (a -> b)
nfl forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl)
instance Monad Logic where
return :: forall a. a -> Logic a
return = forall (f :: * -> *) a. Applicative f => a -> f a
pure
Logic a
l >>= :: forall a b. Logic a -> (a -> Logic b) -> Logic b
>>= a -> Logic b
f =
case Logic a
l of
Leaf a
a -> a -> Logic b
f a
a
And Logic a
ll [Logic a]
rls -> forall a. Logic a -> [Logic a] -> Logic a
And (Logic a
ll forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f) (forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f) [Logic a]
rls)
Or Logic a
ll [Logic a]
rls -> forall a. Logic a -> [Logic a] -> Logic a
Or (Logic a
ll forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f) (forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f) [Logic a]
rls)
Not Logic a
nl -> forall a. Logic a -> Logic a
Not (Logic a
nl forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f)
instance Foldable Logic where
foldMap :: forall m a. Monoid m => (a -> m) -> Logic a -> m
foldMap a -> m
f Logic a
l =
case Logic a
l of
Leaf a
a -> a -> m
f a
a
And Logic a
ll [Logic a]
rls -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Logic a
ll forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) [Logic a]
rls
Or Logic a
ll [Logic a]
rls -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Logic a
ll forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) [Logic a]
rls
Not Logic a
nl -> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Logic a
nl
instance Traversable Logic where
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Logic a -> f (Logic b)
traverse a -> f b
f Logic a
l =
case Logic a
l of
Leaf a
a -> forall a. a -> Logic a
Leaf forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
a
And Logic a
ll [Logic a]
rls -> forall a. Logic a -> [Logic a] -> Logic a
And forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Logic a
ll forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) [Logic a]
rls
Or Logic a
ll [Logic a]
rls -> forall a. Logic a -> [Logic a] -> Logic a
Or forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Logic a
ll forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f) [Logic a]
rls
Not Logic a
nl -> forall a. Logic a -> Logic a
Not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> f b
f Logic a
nl
runBool :: Logic Bool -> Bool
runBool :: Logic Bool -> Bool
runBool Logic Bool
l =
case Logic Bool
l of
Leaf Bool
b -> Bool
b
And Logic Bool
ll [Logic Bool]
rls -> All -> Bool
getAll forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ (Bool -> All
All forall a b. (a -> b) -> a -> b
$ Logic Bool -> Bool
runBool Logic Bool
ll) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Bool -> All
All forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logic Bool -> Bool
runBool) [Logic Bool]
rls
Or Logic Bool
ll [Logic Bool]
rls -> Any -> Bool
getAny forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ (Bool -> Any
Any forall a b. (a -> b) -> a -> b
$ Logic Bool -> Bool
runBool Logic Bool
ll) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Any
Any forall b c a. (b -> c) -> (a -> b) -> a -> c
. Logic Bool -> Bool
runBool) [Logic Bool]
rls
Not Logic Bool
nl -> Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Logic Bool -> Bool
runBool Logic Bool
nl