{-# 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.Traversable (Traversable)
import Data.Monoid ((<>), All(..), Any(..))
import GHC.Generics (Generic)
data Logic a =
Leaf a
| And (Logic a) [Logic a]
| Or (Logic a) [Logic a]
| Not (Logic a)
deriving (Int -> Logic a -> ShowS
[Logic a] -> ShowS
Logic a -> String
(Int -> Logic a -> ShowS)
-> (Logic a -> String) -> ([Logic a] -> ShowS) -> Show (Logic a)
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,Logic a -> Logic a -> Bool
(Logic a -> Logic a -> Bool)
-> (Logic a -> Logic a -> Bool) -> Eq (Logic a)
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,Eq (Logic a)
Eq (Logic a)
-> (Logic a -> Logic a -> Ordering)
-> (Logic a -> Logic a -> Bool)
-> (Logic a -> Logic a -> Bool)
-> (Logic a -> Logic a -> Bool)
-> (Logic a -> Logic a -> Bool)
-> (Logic a -> Logic a -> Logic a)
-> (Logic a -> Logic a -> Logic a)
-> Ord (Logic a)
Logic a -> Logic a -> Bool
Logic a -> Logic a -> Ordering
Logic a -> Logic a -> Logic a
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
$cp1Ord :: forall a. Ord a => Eq (Logic a)
Ord,(forall x. Logic a -> Rep (Logic a) x)
-> (forall x. Rep (Logic a) x -> Logic a) -> Generic (Logic a)
forall x. Rep (Logic a) x -> Logic a
forall x. Logic a -> Rep (Logic a) x
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)
instance Functor Logic where
fmap :: (a -> b) -> Logic a -> Logic b
fmap a -> b
f Logic a
l =
case Logic a
l of
Leaf a
a -> b -> Logic b
forall a. a -> Logic a
Leaf (a -> b
f a
a)
And Logic a
ll [Logic a]
rls -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
And ((a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Logic a
ll) ((Logic a -> Logic b) -> [Logic a] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Logic a -> Logic b
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 -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
Or ((a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Logic a
ll) ((Logic a -> Logic b) -> [Logic a] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map ((a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [Logic a]
rls)
Not Logic a
nl -> Logic b -> Logic b
forall a. Logic a -> Logic a
Not ((a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f Logic a
nl)
instance Applicative Logic where
pure :: a -> Logic a
pure a
a = a -> Logic a
forall a. a -> Logic a
Leaf a
a
Logic (a -> b)
fl <*> :: Logic (a -> b) -> Logic a -> Logic b
<*> Logic a
rl =
case Logic (a -> b)
fl of
Leaf a -> b
f -> (a -> b) -> Logic a -> Logic b
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 -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
And (Logic (a -> b)
lfl Logic (a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl) ((Logic (a -> b) -> Logic b) -> [Logic (a -> b)] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map (Logic (a -> b) -> Logic a -> Logic b
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 -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
Or (Logic (a -> b)
lfl Logic (a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl) ((Logic (a -> b) -> Logic b) -> [Logic (a -> b)] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map (Logic (a -> b) -> Logic a -> Logic b
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 -> Logic b -> Logic b
forall a. Logic a -> Logic a
Not (Logic (a -> b)
nfl Logic (a -> b) -> Logic a -> Logic b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Logic a
rl)
instance Monad Logic where
return :: a -> Logic a
return = a -> Logic a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
Logic a
l >>= :: 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 -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
And (Logic a
ll Logic a -> (a -> Logic b) -> Logic b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f) ((Logic a -> Logic b) -> [Logic a] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map (Logic a -> (a -> Logic b) -> Logic b
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 -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
Or (Logic a
ll Logic a -> (a -> Logic b) -> Logic b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f) ((Logic a -> Logic b) -> [Logic a] -> [Logic b]
forall a b. (a -> b) -> [a] -> [b]
map (Logic a -> (a -> Logic b) -> Logic b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f) [Logic a]
rls)
Not Logic a
nl -> Logic b -> Logic b
forall a. Logic a -> Logic a
Not (Logic a
nl Logic a -> (a -> Logic b) -> Logic b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Logic b
f)
instance Foldable Logic where
foldMap :: (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 -> (a -> m) -> Logic a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Logic a
ll m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (Logic a -> m) -> [Logic a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> Logic a -> m
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 -> (a -> m) -> Logic a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f Logic a
ll m -> m -> m
forall a. Semigroup a => a -> a -> a
<> (Logic a -> m) -> [Logic a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((a -> m) -> Logic a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> m
f) [Logic a]
rls
Not Logic a
nl -> (a -> m) -> Logic a -> m
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 :: (a -> f b) -> Logic a -> f (Logic b)
traverse a -> f b
f Logic a
l =
case Logic a
l of
Leaf a
a -> b -> Logic b
forall a. a -> Logic a
Leaf (b -> Logic b) -> f b -> f (Logic b)
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 -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
And (Logic b -> [Logic b] -> Logic b)
-> f (Logic b) -> f ([Logic b] -> Logic b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Logic a -> f (Logic 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 f ([Logic b] -> Logic b) -> f [Logic b] -> f (Logic b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Logic a -> f (Logic b)) -> [Logic a] -> f [Logic b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> Logic a -> f (Logic 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]
rls
Or Logic a
ll [Logic a]
rls -> Logic b -> [Logic b] -> Logic b
forall a. Logic a -> [Logic a] -> Logic a
Or (Logic b -> [Logic b] -> Logic b)
-> f (Logic b) -> f ([Logic b] -> Logic b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Logic a -> f (Logic 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 f ([Logic b] -> Logic b) -> f [Logic b] -> f (Logic b)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Logic a -> f (Logic b)) -> [Logic a] -> f [Logic b]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((a -> f b) -> Logic a -> f (Logic 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]
rls
Not Logic a
nl -> Logic b -> Logic b
forall a. Logic a -> Logic a
Not (Logic b -> Logic b) -> f (Logic b) -> f (Logic b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> f b) -> Logic a -> f (Logic 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 (All -> Bool) -> All -> Bool
forall a b. (a -> b) -> a -> b
$ [All] -> All
forall a. Monoid a => [a] -> a
mconcat ([All] -> All) -> [All] -> All
forall a b. (a -> b) -> a -> b
$ (Bool -> All
All (Bool -> All) -> Bool -> All
forall a b. (a -> b) -> a -> b
$ Logic Bool -> Bool
runBool Logic Bool
ll) All -> [All] -> [All]
forall a. a -> [a] -> [a]
: (Logic Bool -> All) -> [Logic Bool] -> [All]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> All
All (Bool -> All) -> (Logic Bool -> Bool) -> Logic Bool -> 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 (Any -> Bool) -> Any -> Bool
forall a b. (a -> b) -> a -> b
$ [Any] -> Any
forall a. Monoid a => [a] -> a
mconcat ([Any] -> Any) -> [Any] -> Any
forall a b. (a -> b) -> a -> b
$ (Bool -> Any
Any (Bool -> Any) -> Bool -> Any
forall a b. (a -> b) -> a -> b
$ Logic Bool -> Bool
runBool Logic Bool
ll) Any -> [Any] -> [Any]
forall a. a -> [a] -> [a]
: (Logic Bool -> Any) -> [Logic Bool] -> [Any]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Any
Any (Bool -> Any) -> (Logic Bool -> Bool) -> Logic Bool -> 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 (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Logic Bool -> Bool
runBool Logic Bool
nl