module Network.Hinquire where
import Prelude hiding (foldr)
import Control.Applicative (Alternative (..), Applicative, pure, (<*>), (<$>))
import Data.Biapplicative
import Data.Bifoldable
import Data.Bitraversable
import Data.Foldable
import Data.Monoid
import Data.Traversable
data Relation = Equal
| NEqual
| GThan
| GThanE
| LThan
| LThanE
deriving Eq
data GBool = And
| Or
deriving Eq
data WBool = NoBool
| Not
deriving Eq
data Inquire k v = Atom
| Predicate k Relation v
| Group (Inquire k v) GBool (Inquire k v)
| Wrap WBool (Inquire k v)
deriving Eq
instance Monoid (Inquire k v) where
mempty = Atom
mappend = (<&&&>)
instance Functor (Inquire k) where
fmap _ Atom = Atom
fmap f (Predicate k r v) = Predicate k r (f v)
fmap f (Group i1 b i2) = Group (fmap f i1) b (fmap f i2)
fmap f (Wrap b i) = Wrap b (fmap f i)
instance Monoid k => Applicative (Inquire k) where
pure = Predicate mempty Equal
Atom <*> _ = Atom
_ <*> Atom = Atom
(Predicate _ _ f) <*> (Predicate k r v) = Predicate k r (f v)
p@Predicate {} <*> (Group i1 b i2) = Group (p <*> i1) b (p <*> i2)
p@Predicate {} <*> (Wrap b i) = Wrap b (p <*> i)
(Group i1 b i2) <*> i3 = Group (i1 <*> i3) b (i2 <*> i3)
(Wrap b i1) <*> i2 = Wrap b (i1 <*> i2)
instance Monoid k => Alternative (Inquire k) where
empty = Atom
Atom <|> i = i
i <|> _ = i
instance Foldable (Inquire k) where
foldr _ z Atom = z
foldr f z (Predicate _ _ v) = f v z
foldr f z (Group i1 _ i2) = foldr f (foldr f z i2) i1
foldr f z (Wrap _ i) = foldr f z i
instance Traversable (Inquire k) where
traverse _ Atom = pure Atom
traverse f (Predicate k r v) = Predicate <$> pure k <*> pure r <*> f v
traverse f (Group i1 b i2) =
Group <$> traverse f i1 <*> pure b <*> traverse f i2
traverse f (Wrap b i) = Wrap <$> pure b <*> traverse f i
instance Monoid k => Monad (Inquire k) where
return = Predicate mempty Equal
Atom >>= _ = Atom
(Predicate _ _ v) >>= f = f v
(Group i1 b i2) >>= f = Group (i1 >>= f) b (i2 >>= f)
(Wrap b i) >>= f = Wrap b (i >>= f)
instance Bifunctor Inquire where
bimap _ _ Atom = Atom
bimap f g (Predicate k r v) = Predicate (f k) r (g v)
bimap f g (Group i1 b i2) = Group (bimap f g i1) b (bimap f g i2)
bimap f g (Wrap b i) = Wrap b (bimap f g i)
instance Bifoldable Inquire where
bifoldr _ _ z Atom = z
bifoldr f g z (Predicate k _ v) = f k $ g v z
bifoldr f g z (Group i1 _ i2) = bifoldr f g (bifoldr f g z i2) i1
bifoldr f g z (Wrap _ i) = bifoldr f g z i
instance Biapplicative Inquire where
bipure k = Predicate k Equal
Atom <<*>> _ = Atom
_ <<*>> Atom = Atom
(Predicate f _ g) <<*>> (Predicate k2 r v2) = Predicate (f k2) r (g v2)
p@Predicate {} <<*>> (Group i1 b i2) = Group (p <<*>> i1) b (p <<*>> i2)
p@Predicate {} <<*>> (Wrap b i) = Wrap b (p <<*>> i)
(Group i1 b i2) <<*>> i3 = Group (i1 <<*>> i3) b (i2 <<*>> i3)
(Wrap b i1) <<*>> i2 = Wrap b (i1 <<*>> i2)
instance Bitraversable Inquire where
bitraverse _ _ Atom = pure Atom
bitraverse f g (Predicate k r v) = Predicate <$> f k <*> pure r <*> g v
bitraverse f g (Group i1 b i2) =
Group <$> bitraverse f g i1 <*> pure b <*> bitraverse f g i2
bitraverse f g (Wrap b i) = Wrap <$> pure b <*> bitraverse f g i
class Dyad d where
bireturn :: a -> b -> d a b
(>>==) :: d a b -> (a -> b -> d e f) -> d e f
instance Dyad Inquire where
bireturn k = Predicate k Equal
Atom >>== _ = Atom
(Predicate k _ v) >>== f = f k v
(Group i1 b i2) >>== f = Group (i1 >>== f) b (i2 >>== f)
(Wrap b i) >>== f = Wrap b (i >>== f)
instance Show Relation where
show Equal = "="
show NEqual = "!="
show GThan = ">"
show GThanE = ">="
show LThan = "<"
show LThanE = "<="
instance Show GBool where
show And = "&"
show Or = ";"
instance Show WBool where
show NoBool = ""
show Not = "!"
instance (Show k, Show v) => Show (Inquire k v) where
show Atom = ""
show (Predicate k r v) = show k ++ show r ++ show v
show (Group Atom _ Atom) = ""
show (Group Atom _ r) = show r
show (Group l _ Atom) = show l
show (Group l@Predicate {} b r@Predicate {}) = show l ++ show b ++ show r
show (Group l@Predicate {} b r) = show l ++ show b ++ "(" ++ show r ++ ")"
show (Group l b r@Predicate {}) = "(" ++ show l ++ ")" ++ show b ++ show r
show (Group l b r) = "(" ++ show l ++ ")" ++ show b ++ "(" ++ show r ++ ")"
show (Wrap n i) = show n ++ "(" ++ show i ++ ")"
(<&&&>) :: Inquire k v -> Inquire k v -> Inquire k v
i1 <&&&> i2 = Group i1 And i2
(<|||>) :: Inquire k v -> Inquire k v -> Inquire k v
i1 <|||> i2 = Group i1 Or i2
generate :: (Show v, Show k) => Inquire k v -> String
generate = ('?':) . show