need to clear IO somehow, possibly done by performing the bottom queries by themselves, then performing the operators on the pure lists

app/Main.hs

@@ -1,7 +1,7 @@
-
 module Main (main) where
 import System.Environment   
 import Site.Host
+import Seed ( seedData )
 import Lib
 
 

mtgsearch.cabal

@@ -25,10 +25,13 @@ source-repository head
 
 library
   exposed-modules:
+      Algorithm.BaseQuery
       Algorithm.Lex
+      Algorithm.Operator
       Algorithm.Search
       Config
       Lib
+      Seed
       Site.Host
   other-modules:
       Paths_mtgsearch

src/Algorithm/BaseQuery.hs

@@ -0,0 +1,38 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Algorithm.BaseQuery
+    ( superType,
+    Card(..)
+    ) where
+import qualified Data.Text as T
+import Database.SQLite.Simple
+import Config (getDbPath)
+import Data.Text (Text, isInfixOf)
+import Control.Monad.IO.Class (MonadIO(liftIO))
+data Card = Card
+  Int
+  T.Text
+  T.Text
+  T.Text
+  (Maybe T.Text)
+  (Maybe T.Text)
+  T.Text
+  deriving (Show)
+
+instance FromRow Card where
+  fromRow = Card <$> field <*> field <*> field <*> field <*> field <*> field <*> field
+
+instance ToRow Card where
+  toRow (Card id_ scryfall_id lang name oracle_text image_uri type_line) = toRow (id_, scryfall_id, lang, name, oracle_text, image_uri, type_line)
+
+
+superType :: String -> IO [Card]
+superType qry = do
+  dbPath <- getDbPath
+  conn <- open dbPath
+  res <- query_ conn "select id, scryfall_id, lang, name, oracle_text, image_uri, type_line from card where type_line is not null" :: IO [Card];
+  return $ typeLineFilter res (T.pack qry)
+
+typeLineFilter :: [Card] -> Text -> [Card]
+typeLineFilter (card@(Card _ _ _ _ _ _ type_line):cards) qry = if qry `isInfixOf` type_line then card:typeLineFilter cards qry else typeLineFilter cards qry
+
+typeLineFilter [] _ = []

src/Algorithm/Lex.hs

@@ -1,7 +1,9 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Algorithm.Lex
     ( lexx
-    , Token(..)) where
+    , Token(..)
+    , QueryDef(..)
+    , Operator(..)) where
 import Prelude hiding (lex)
 import Debug.Trace
 import Data.ByteString (count, putStr)
@@ -19,6 +21,8 @@ fixSeparators :: [String] -> [(Int, Int)] -> ([String], [(Int, Int)])
 fixSeparators values parenthesis@((start,end):rest) | start == 0 && end == ( length values -1) = (values, parenthesis)
 fixSeparators values parenthesis  = ( ["("] ++ values ++ [")"], (0, length values + 1):map addOne parenthesis)
 
+
+
 addOne (x,y) = (x+1, y+1)
 
 isLegal :: Char -> Bool
@@ -54,31 +58,23 @@ findClosing (x:xs) stackCount count = findClosing xs stackCount (count+1)
 findClosing [] _ _ = error "Unequal number of parenthesis"
 
 
-data Token = Seperated String Token Token | Queri String String deriving Show
+data Token = Func Operator Token Token | Queri QueryDef deriving Show
+data QueryDef = SuperType String| Color String deriving Show
+data Operator = Union deriving Show
 
 seperator :: [String] -> [(Int, Int)] -> Token
 seperator ("(":rest) ((start,end):points) = case drop (end-start) rest of
-            " ":operator:" ":"(":rightRest -> Seperated operator (seperator (take (end-start) rest) points)   (seperator (init rightRest) points)
+            " ":operator:" ":"(":rightRest -> Func (extractOperator operator) (seperator (take (end-start) rest) points)   (seperator (init rightRest) points)
             [] -> seperator (take (end-start) rest) points
             _ ->error "Operator need something to the right and left of it!"
+seperator [name, " ", value, ")"] _ = Queri (extractQueryDef (name, value))
+seperator a _ = error $ "Something went wrong tokenizing the input!\n" ++ (show a) 
 
+extractQueryDef :: (String, String) -> QueryDef
+extractQueryDef ("SuperType", value) = SuperType value
+extractQueryDef _ = error $ "This command was not valid"
 
-
-seperator [name, " ", value, ")"] points = Queri name value
-seperator a _ = error "Something went wrong tokenizing the input!"
-
-
-
---This one works, but not for lines!
-
--- seperator :: [String] -> [(Int, Int)] -> Seperated
--- seperator ("(":rest) ((start,end):points) = case drop (end-start) rest of
---             " ":operator:" ":"(":rightRest -> Seperated operator (seperator (take (end-start) rest) points)   (seperator (init rightRest) points)
---             [] -> seperator (take (end-start) rest) points 
---             a ->trace (show a) error "This is not allowed"
-
-
-
-
+extractOperator "union" = Union
+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

@@ -0,0 +1,8 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Algorithm.Operator
+    ( union
+    ) where
+
+
+union :: IO [a] -> IO [a] -> [a]
+union res1 res2 = res1 ++ res2

src/Algorithm/Search.hs

@@ -3,37 +3,49 @@ module Algorithm.Search
     ( search
     ) where
 import Database.SQLite.Simple
+import Algorithm.BaseQuery
 import Config (getDbPath)
-import Web.Scotty.Internal.Types
-import Control.Monad
 import qualified Data.Text as T
 import Algorithm.Lex
+import Control.Monad
+import Data.Text (unpack)
+import Algorithm.Operator (union)
+import Control.Monad.IO.Class
 
 
-data Card = Card Int T.Text T.Text deriving (Show)
-
-instance FromRow Card where
-  fromRow = Card <$> field <*> field <*> field
-
-instance ToRow Card where
-
-  toRow (Card id_ str image_uri) = toRow (id_, str, image_uri)
 
 search :: String -> IO String
 search q = do
   let tokens = lexx q
-  simpleSearch q
+  queryRes <- executeQuery tokens
+  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 _ = error $ "Not implemented!"
 
-simpleSearch :: String -> IO String
-simpleSearch q = do
-    dbPath <- getDbPath
-    conn <- open dbPath
-    res <-  queryNamed conn "select id, name, image_uri from card where name like :name" [":name" := ("%"++q++"%")] :: IO [Card]
-    let hyperText = buildHtml res
-    return hyperText
 
 buildHtml :: [Card] -> String
 buildHtml = concatMap cardToHtml
 
+
+
+executeBottomQuery :: QueryDef -> IO [Card]
+executeBottomQuery (SuperType value) = superType value
+executeBottomQuery _ = error $ "Not implemented yet"
+
+
+
+
 cardToHtml :: Card -> String
-cardToHtml (Card id name image_uri) = "<div class=\"card\"><h2>" ++ show name ++ "</h2>" ++ "<img src=" ++ show image_uri ++ "/> </div>"
+cardToHtml (Card id_ scryfall_id lang name (Just oracle_text) (Just image_uri) type_line) =
+  "<div class=\"card\" style=\"text-align:center\"><h2>" ++ unpack name ++ "</h2>" ++
+  "<img src=" ++ unpack image_uri ++ " width=\"200px\"/>"++
+  "<p>" ++ unpack oracle_text ++ "<p>"++" </div>"
+
+
+cardToHtml _ = "<h1>Could not load that card</h1>"

src/Lib.hs

@@ -1,68 +1,4 @@
 {-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
 module Lib
-    ( seedData
+    ( 
     ) where
-import Data.Aeson
-import Data.Text
-
-import qualified Data.ByteString.Lazy as B
-
-import Database.SQLite.Simple
-
-import Config
-
-import GHC.Generics
-data ImageUris = ImageUris {
-    small :: Text,
-    normal :: Text,
-    large :: Text,
-    png :: Text,
-    art_crop :: Text,
-    border_crop :: Text
-}deriving (Show,Generic)
-instance FromJSON ImageUris
-instance ToJSON ImageUris
-
-data Card = Card{
-    object :: Text,
-    id :: Text,
-    lang :: Text,
-    name :: Text,
-    oracle_text :: Maybe Text,
-    image_uris :: Maybe ImageUris
-} deriving (Show,Generic)
-
-instance FromJSON Card
-instance ToJSON Card
-
-instance ToRow Card where
-    toRow (Card object id lang name oracle_text (Just (ImageUris _ image_link _ _ _ _ ))) = toRow (id, lang, name, oracle_text, image_link)
-    toRow (Card object id lang name oracle_text Nothing) = toRow (id, lang, name, oracle_text, pack "Nothing")
-
-
-
-getJSON :: String -> IO B.ByteString
-getJSON file = B.readFile file
-
-insertCards :: Connection -> [Card] -> IO()
-insertCards conn ((card):cards) = do
-    execute conn "INSERT INTO card (scryfall_id, lang, name, oracle_text, image_uri) VALUES (?,?,?,?,?)" card 
-    insertCards conn cards
-    return ()
-insertCards conn [] = return ()
-
-seedData :: IO ()
-seedData = do
-    -- Get JSON data and decode it
-    
-    seedData <- getDataSeedPath
-    dbPath <- getDbPath
-    d <- (eitherDecode <$> getJSON seedData) :: IO (Either String [Card])
-    conn <- open dbPath
-    execute_ conn "CREATE TABLE IF NOT EXISTS card (id INTEGER PRIMARY KEY, scryfall_id TEXT, lang TEXT, name TEXT, oracle_text TEXT, image_uri TEXT)"
-    
-
-    case d of
-        Left err -> putStrLn err
-        Right ps -> insertCards conn ps
-

src/Seed.hs

@@ -0,0 +1,70 @@
+{-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
+module Seed
+    ( seedData
+    ) where
+
+import Data.Aeson ( eitherDecode, FromJSON, ToJSON )
+import Data.Text
+
+import qualified Data.ByteString.Lazy as B
+
+import Database.SQLite.Simple
+
+import Config
+
+import GHC.Generics
+data ImageUris = ImageUris {
+    small :: Text,
+    normal :: Text,
+    large :: Text,
+    png :: Text,
+    art_crop :: Text,
+    border_crop :: Text
+}deriving (Show,Generic)
+instance FromJSON ImageUris
+instance ToJSON ImageUris
+
+data Card = Card{
+    object :: Text,
+    id :: Text,
+    lang :: Text,
+    name :: Text,
+    oracle_text :: Maybe Text,
+    image_uris :: Maybe ImageUris,
+    type_line :: Text
+} deriving (Show,Generic)
+
+instance FromJSON Card
+instance ToJSON Card
+
+instance ToRow Card where
+    toRow (Card object id lang name oracle_text (Just (ImageUris _ image_link _ _ _ _ )) type_line) = toRow (id, lang, name, oracle_text, image_link, type_line)
+    toRow (Card object id lang name oracle_text Nothing type_line) = toRow (id, lang, name, oracle_text, Nothing:: (Maybe Text), type_line)
+
+
+
+getJSON :: String -> IO B.ByteString
+getJSON file = B.readFile file
+
+insertCards :: Connection -> [Card] -> IO()
+insertCards conn ((card):cards) = do
+    execute conn "INSERT INTO card (scryfall_id, lang, name, oracle_text, image_uri, type_line) VALUES (?,?,?,?,?,?)" card 
+    insertCards conn cards
+    return ()
+insertCards conn [] = return ()
+
+seedData :: IO ()
+seedData = do
+    -- Get JSON data and decode it
+    
+    seedData <- getDataSeedPath
+    dbPath <- getDbPath
+    d <- (eitherDecode <$> getJSON seedData) :: IO (Either String [Card])
+    conn <- open dbPath
+    execute_ conn "CREATE TABLE IF NOT EXISTS card (id INTEGER PRIMARY KEY, scryfall_id TEXT, lang TEXT, name TEXT, oracle_text TEXT, image_uri TEXT, type_line TEXT)"
+    
+
+    case d of
+        Left err -> putStrLn err
+        Right ps -> insertCards conn ps
+

src/Site/Host.hs

@@ -1,5 +1,4 @@
 {-# LANGUAGE DeriveGeneric, OverloadedStrings #-}
-{-# OPTIONS_GHC -Wno-unused-do-bind #-}
 module Site.Host
     ( host
     ) where
@@ -15,8 +14,8 @@ host = scotty 3000 $ do
   post "/api/req" $ do
 
             query <-  param "query"
-            liftIO (putStrLn $ "\nOutput! " ++ show (lexx query))
-            cards <- liftIO (search query)
+            --liftIO (putStrLn $ "\nOutput! " ++ show (lexx query))
+            --cards <- liftIO (search query)
             result <- liftIO (search query)
             html $ mconcat ["<h1>", pack result, "</h1>"]