Basically finished with main functionality. Need to extend the language with more set operators as well as more bottom queries

src/Algorithm/BaseQuery.hs

@@ -18,6 +18,9 @@ data Card = Card
   T.Text
   deriving (Show)
 
+instance Eq Card where
+  (==) (Card id_ _ _ _ _ _ _) (Card id2_ _ _ _ _ _ _) = id_ == id2_
+
 instance FromRow Card where
   fromRow = Card <$> field <*> field <*> field <*> field <*> field <*> field <*> field
 

src/Algorithm/Lex.hs

@@ -60,7 +60,7 @@ findClosing [] _ _ = error "Unequal number of parenthesis"
 
 data Token = Func Operator Token Token | Queri QueryDef deriving Show
 data QueryDef = SuperType String| Color String deriving Show
-data Operator = Union deriving Show
+data Operator = Union | Intersect deriving Show
 
 seperator :: [String] -> [(Int, Int)] -> Token
 seperator ("(":rest) ((start,end):points) = case drop (end-start) rest of
@@ -75,6 +75,7 @@ extractQueryDef ("SuperType", value) = SuperType value
 extractQueryDef _ = error $ "This command was not valid"
 
 extractOperator "union" = Union
+extractOperator "intersect" = Intersect
 extractOperator _ = error $ "This operator is not defined"
 -- ((Is instant) union (Color R)) union ((Is instant) union (Color R))
 -- (((Color Red) union (Color Blue)) union ((Is instant) union (Is Enchantment)))

src/Algorithm/Operator.hs

@@ -1,8 +1,14 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Algorithm.Operator
-    ( union
+    ( union,
+    intersect
     ) where
 
 
-union :: IO [a] -> IO [a] -> [a]
-union res1 res2 = res1 ++ res2
+union :: [a] -> [a] -> [a]
+union res1 res2 = res1 ++ res2
+
+intersect :: Eq a => [a] -> [a] -> [a]
+intersect (a:as) b = if a `elem` b then a: intersect as b else intersect as b
+
+intersect [] _ = []

src/Algorithm/Search.hs

@@ -9,23 +9,26 @@ import qualified Data.Text as T
 import Algorithm.Lex
 import Control.Monad
 import Data.Text (unpack)
-import Algorithm.Operator (union)
+import Algorithm.Operator (union, intersect)
 import Control.Monad.IO.Class
 
-
+data Tree = Funct Operator Tree Tree | Holder [Card]
 
 search :: String -> IO String
 search q = do
   let tokens = lexx q
-  queryRes <- executeQuery tokens
+  tree <- liftIO (executeBottomQuery tokens)
+
+  let queryRes = executeQuery tree
   let hyperText = buildHtml queryRes
   return hyperText
 
 
 
-executeQuery :: Token -> IO [Card]
-executeQuery (Queri bottom) = executeBottomQuery bottom
-executeQuery (Func Union leftToken rightToken) = executeQuery leftToken `union` executeQuery rightToken
+executeQuery :: Tree -> [Card]
+executeQuery (Holder cards) = cards
+executeQuery (Funct Union leftToken rightToken) = executeQuery leftToken `union` executeQuery rightToken
+executeQuery (Funct Intersect leftToken rightToken) = executeQuery leftToken `intersect` executeQuery rightToken
 executeQuery _ = error $ "Not implemented!"
 
 
@@ -33,10 +36,17 @@ buildHtml :: [Card] -> String
 buildHtml = concatMap cardToHtml
 
 
+--Fancy trickery to move the IO to outer, in order to allow all the combinatorics to not have to live in IO land :)
+executeBottomQuery :: Token -> IO Tree
+executeBottomQuery (Queri (SuperType value)) =  do 
+  temp <- superType value
+  return $ Holder temp
+executeBottomQuery (Queri _) = error $ "Not implemented yet"
+executeBottomQuery (Func operator left right) = do 
+  left <- executeBottomQuery left
+  right <- executeBottomQuery right
+  return $ Funct operator left right
 
-executeBottomQuery :: QueryDef -> IO [Card]
-executeBottomQuery (SuperType value) = superType value
-executeBottomQuery _ = error $ "Not implemented yet"