From 5f8cf39aa77caceffb3f642e6a502e92d5eee541 Mon Sep 17 00:00:00 2001 From: polsevev Date: Fri, 28 Apr 2023 21:08:56 +0200 Subject: [PATCH] Finished a dumb lexer --- config.json => Config/config.json | 0 README.md | 21 +++++++++ mtgsearch.cabal | 2 + src/Algorithm/BottomQuery.hs | 0 src/Algorithm/Lex.hs | 75 +++++++++++++++++++++++++++++++ src/Algorithm/Search.hs | 5 ++- src/Config.hs | 19 +++++++- src/Site/Host.hs | 11 ++++- 8 files changed, 127 insertions(+), 6 deletions(-) rename config.json => Config/config.json (100%) create mode 100644 src/Algorithm/BottomQuery.hs create mode 100644 src/Algorithm/Lex.hs diff --git a/config.json b/Config/config.json similarity index 100% rename from config.json rename to Config/config.json diff --git a/README.md b/README.md index 21929c1..e21373c 100644 --- a/README.md +++ b/README.md @@ -1 +1,22 @@ # mtgsearch + + +Developement of a custom magic card search engine. + +# DSL + +Will be a language based in set theory, where queries can be combined, negated etc etc. +Example. + +# Lexer + +This languages lexer is very dumb. Therefore you the user has to be very verbose with your parenthesis. Example: + +This will not work: +``` +(IS Instant) union (Color Red) union (Color Green) +``` +However this will +``` +((IS Instant) union (Color Red) union (Color Green)) +``` \ No newline at end of file diff --git a/mtgsearch.cabal b/mtgsearch.cabal index 0ba1e29..c23455e 100644 --- a/mtgsearch.cabal +++ b/mtgsearch.cabal @@ -25,6 +25,8 @@ source-repository head library exposed-modules: + Algorithm.BottomQuery + Algorithm.Lex Algorithm.Search Config Lib diff --git a/src/Algorithm/BottomQuery.hs b/src/Algorithm/BottomQuery.hs new file mode 100644 index 0000000..e69de29 diff --git a/src/Algorithm/Lex.hs b/src/Algorithm/Lex.hs new file mode 100644 index 0000000..d4ba1b8 --- /dev/null +++ b/src/Algorithm/Lex.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE OverloadedStrings #-} +module Algorithm.Lex + ( lexx + , Token(..)) where +import Prelude hiding (lex) +import Debug.Trace +import Data.ByteString (count, putStr) + +lexx :: String -> Token +lexx qur = do + + let collected = collector qur + let parenthesisFixed = fixSeparators collected + let parenthesis = matchParenthesis parenthesisFixed 0 + seperator parenthesisFixed parenthesis + + +fixSeparators :: [String] -> [String] +fixSeparators ("(":values) = "(":values +fixSeparators values = ["("] ++ values++ [")"] + + +isLegal :: Char -> Bool +isLegal x = x `notElem` ['(',')',' '] + +collector :: String -> [String] +collector [] = [] +collector (x:r) | not $ isLegal x = [x] : collector r +collector elements = case takeWhile isLegal elements of + "" -> collector (dropWhile isLegal elements) + b -> b : collector (dropWhile isLegal elements) + + +matchParenthesis :: [String] -> Int -> [(Int, Int)] +matchParenthesis ("(":rest) count = (count, findClosing rest 0 (count+1)):matchParenthesis rest (count+1) +matchParenthesis (a:rest) count = matchParenthesis rest (count+1) +matchParenthesis [] _ = [] + + +findClosing :: [String] -> Int -> Int -> Int +findClosing (")":xs) stackCount count | stackCount == 0 = count +findClosing (")":xs) stackCount count = findClosing xs (stackCount-1) (count+1) +findClosing ("(":xs) stackCount count = findClosing xs (stackCount+1) (count+1) +findClosing (x:xs) stackCount count = findClosing xs stackCount (count+1) +findClosing [] _ _ = error "Unequal number of parenthesis" + + +data Token = Seperated String Token Token | Queri String 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) + [] -> seperator (take (end-start) rest) points + _ ->error "Operator need something to the right and left of it!" + + + +seperator [name, " ", value, ")"] points = Queri (name++" "++value) +seperator a _ = Queri "LOL" --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" + + + + +-- ((Is instant) union (Color R)) union ((Is instant) union (Color R)) +-- (((Color Red) union (Color Blue)) union ((Is instant) union (Is Enchantment))) \ No newline at end of file diff --git a/src/Algorithm/Search.hs b/src/Algorithm/Search.hs index eecb637..75f2650 100644 --- a/src/Algorithm/Search.hs +++ b/src/Algorithm/Search.hs @@ -20,7 +20,8 @@ instance ToRow Card where search :: String -> IO String search q = do - simpleSearch q + let tokens = lexx q + simpleSearch q simpleSearch :: String -> IO String simpleSearch q = do @@ -34,4 +35,4 @@ buildHtml :: [Card] -> String buildHtml = concatMap cardToHtml cardToHtml :: Card -> String -cardToHtml (Card id name image_uri) = "

" ++ show name ++ "

" ++ "" \ No newline at end of file +cardToHtml (Card id name image_uri) = "

" ++ show name ++ "

" ++ "
" \ No newline at end of file diff --git a/src/Config.hs b/src/Config.hs index 7bc3176..4905e22 100644 --- a/src/Config.hs +++ b/src/Config.hs @@ -7,6 +7,11 @@ import Data.Text import qualified Data.ByteString.Lazy as B import GHC.Generics +import Control.Exception (try) +import Data.ByteString.Builder (lazyByteString) +import qualified Data.Aeson.Key as B +import qualified Data.Data as B +import GHC.IO.Exception @@ -18,9 +23,18 @@ data Config = Config{ instance FromJSON Config instance ToJSON Config -configFile = "./config.json" + + +configFile = "./Config/config.json" + + getJSON :: IO B.ByteString -getJSON = B.readFile configFile +getJSON = do + a <- try $ B.readFile configFile :: IO (Either IOException B.ByteString ) + case a of + Right a -> return a + Left b -> error $ "Could not load configuration file" + readConfig :: IO (Maybe Config) @@ -33,6 +47,7 @@ readConfig = do putStrLn err return Nothing +getConfig :: IO Config getConfig = extract readConfig getDataSeedPath ::IO (String) diff --git a/src/Site/Host.hs b/src/Site/Host.hs index 6fe7eb9..adb1af9 100644 --- a/src/Site/Host.hs +++ b/src/Site/Host.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric, OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-unused-do-bind #-} module Site.Host ( host ) where @@ -7,12 +8,18 @@ import Web.Scotty import Algorithm.Search import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.Text.Lazy (pack) +import Database.SQLite.Simple (query) +import Algorithm.Lex (lexx) host = scotty 3000 $ do post "/api/req" $ do + query <- param "query" + liftIO (putStrLn $ "\nOutput!" ++ show (lexx query)) + cards <- liftIO (search query) result <- liftIO (search query) html $ mconcat ["

", pack result, "

"] - get "/" $ file "src/Site/Static/index.html" - + + get "/" $ file "src/Site/Static/index.html" +