diff --git a/relational-query.cabal b/relational-query.cabal --- a/relational-query.cabal +++ b/relational-query.cabal @@ -1,5 +1,5 @@ name: relational-query -version: 0.3.0.1 +version: 0.3.0.2 synopsis: Typeful, Modular, Relational, algebraic query engine description: This package contiains typeful relation structure and relational-algebraic query building DSL which can @@ -86,11 +86,13 @@ , Cabal , cabal-test-compat , relational-query + , containers + , transformers type: detailed-0.9 test-module: SQLs other-modules: - Tool + Lex Model hs-source-dirs: test diff --git a/test/Lex.hs b/test/Lex.hs new file mode 100644 --- /dev/null +++ b/test/Lex.hs @@ -0,0 +1,171 @@ +module Lex (eqProp) where + +import Control.Applicative + ((<$>), (<*>), pure, (*>), (<*), (<|>), empty, many, some) +import Control.Monad (void) +import Control.Monad.Trans.State (StateT, runStateT, get, put) +import Control.Monad.Trans.Class (lift) +import Data.Maybe (listToMaybe, fromMaybe) +import Data.Map (Map) +import qualified Data.Map as Map +import Text.ParserCombinators.ReadP (ReadP, readP_to_S) +import qualified Text.ParserCombinators.ReadP as ReadP + +import Distribution.TestSuite (Test) +import Distribution.TestSuite.Compat (prop') + + +type Var = Int + +data Token + = Qualifier Var + | Table Var + | Symbol String + | Op String + | String String + | LParen + | RParen + | Comma + | PlaceHolder + deriving (Eq, Show) + +type VarName = String + +data QState = + QState + { nextVar :: Var + , varMap :: Map VarName Var + } deriving Eq + +type Parser = StateT QState ReadP + +char :: Char -> Parser Char +char = lift . ReadP.char + +satisfy :: (Char -> Bool) -> Parser Char +satisfy = lift . ReadP.satisfy + +quote :: Parser Char +quote = char '\'' + +symbolCharset :: [Char] +symbolCharset = '_' : ['0'..'9'] ++ ['A'..'Z'] ++ ['a'..'z'] + +symbol' :: Parser String +symbol' = some $ satisfy (`elem` symbolCharset) + +symbol :: Parser Token +symbol = Symbol <$> symbol' + +opCharset :: [Char] +opCharset = "=<>+-*|" + +op :: Parser Token +op = Op <$> some (satisfy (`elem` opCharset)) + +stringChar :: Parser Char +stringChar = quote *> quote <|> satisfy (`notElem` ("'().\"")) + +string :: Parser Token +string = String <$> (quote *> many stringChar <* quote) + +queryVar :: VarName -> Parser Var +queryVar n = do + s <- get + let m = varMap s + v' = nextVar s + maybe + (do put $ QState { nextVar = v' + 1, varMap = Map.insert n v' m } + return v') + return + $ n `Map.lookup` m + +qualified :: Parser Token +qualified = do + s <- symbol' + void $ char '.' + Qualifier <$> queryVar s + +table :: Parser Token +table = do + t <- (:) <$> char 'T' <*> some (satisfy (`elem` ['0'..'9'])) + Table <$> queryVar t + +space :: Parser Char +space = satisfy (`elem` " \t") + +someSpaces :: Parser () +someSpaces = some space *> pure () + +spaces :: Parser () +spaces = many space *> pure () + +peekChar :: Parser (Maybe Char) +peekChar = listToMaybe <$> lift ReadP.look + +peekSatisfy :: (Char -> Bool) -> Parser Char +peekSatisfy pre = do + mc <- peekChar + case mc of + Just c | pre c -> pure c + | otherwise -> empty + Nothing -> empty + +symbolSep :: Parser () +symbolSep = peekSatisfy (`elem` ("()," ++ opCharset)) *> return () <|> someSpaces <|> eof + +opSep :: Parser () +opSep = peekSatisfy (`elem` symbolCharset) *> return () <|> someSpaces <|> eof + +lParen :: Parser Token +lParen = char '(' *> pure LParen + +rParen :: Parser Token +rParen = char ')' *> pure RParen + +comma :: Parser Token +comma = char ',' *> pure Comma + +placeholder :: Parser Token +placeholder = char '?' *> pure PlaceHolder + +eof :: Parser () +eof = lift ReadP.eof + +token :: Parser Token +token = + qualified <|> + table <* symbolSep <|> + symbol <* symbolSep <|> + op <* opSep <|> + string <|> + lParen <|> + rParen <|> + comma <|> + placeholder + +tokens :: Parser [Token] +tokens = (many $ token <* spaces) <* eof + +run' :: Parser a -> String -> Maybe (a, String) +run' p = + (result <$>) . listToMaybe . + readP_to_S (runStateT p (QState { nextVar = 0, varMap = Map.empty })) where + result ((a, _s), in') = (a, in') + +run :: String -> Maybe [Token] +run = (fst <$>) . run' tokens + + +eq :: String -> String -> Bool +eq a b = fromMaybe False $ do + x <- run a + y <- run b + return $ x == y + +eqProp' :: String -> (a -> String) -> a -> String -> Test +eqProp' name t x est = prop' name (Just em) (t x `eq` est) + where em = unlines [show . run $ t x, " -- NOT EQUALS! --", show $ run est] + +eqProp :: Show a => String -> a -> String -> Test +eqProp name = eqProp' name show diff --git a/test/SQLs.hs b/test/SQLs.hs --- a/test/SQLs.hs +++ b/test/SQLs.hs @@ -3,7 +3,7 @@ import Distribution.TestSuite (Test) import Distribution.TestSuite.Compat (TestList, testList) -import Tool (eqShow) +import Lex (eqProp) import Model import Data.Int (Int32) @@ -11,9 +11,9 @@ base :: [Test] base = - [ eqShow "setA" setA "SELECT int_a0, str_a1, str_a2 FROM TEST.set_a" - , eqShow "setB" setB "SELECT int_b0, may_str_b1, str_b2 FROM TEST.set_b" - , eqShow "setC" setC "SELECT int_c0, str_c1, int_c2, may_str_c3 FROM TEST.set_c" + [ eqProp "setA" setA "SELECT int_a0, str_a1, str_a2 FROM TEST.set_a" + , eqProp "setB" setB "SELECT int_b0, may_str_b1, str_b2 FROM TEST.set_b" + , eqProp "setC" setC "SELECT int_c0, str_c1, int_c2, may_str_c3 FROM TEST.set_c" ] _p_base :: IO () @@ -36,15 +36,15 @@ directJoins :: [Test] directJoins = - [ eqShow "cross" cross + [ eqProp "cross" cross "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 INNER JOIN TEST.set_b T1 ON (0=0)" - , eqShow "inner" innerX + , eqProp "inner" innerX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 INNER JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" - , eqShow "left" leftX + , eqProp "left" leftX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a1 = T1.may_str_b1)" - , eqShow "right" rightX + , eqProp "right" rightX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" - , eqShow "full" fullX + , eqProp "full" fullX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 FULL JOIN TEST.set_b T1 ON (T0.int_a0 = T1.int_b0)" ] @@ -73,10 +73,10 @@ return $ Abc |$| a |*| b |*| c join3s :: [Test] -join3s = [ eqShow "join-3 left" j3left +join3s = [ eqProp "join-3 left" j3left "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5, T2.int_c0 AS f6, T2.str_c1 AS f7, T2.int_c2 AS f8, T2.may_str_c3 AS f9 FROM (TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (T0.str_a2 = T1.str_b2)) LEFT JOIN TEST.set_c T2 ON (T1.int_b0 = T2.int_c0)" - , eqShow "join-3 right" j3right + , eqProp "join-3 right" j3right "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T3.f0 AS f3, T3.f1 AS f4, T3.f2 AS f5, T3.f3 AS f6, T3.f4 AS f7, T3.f5 AS f8, T3.f6 AS f9 FROM TEST.set_a T0 INNER JOIN (SELECT ALL T1.int_b0 AS f0, T1.may_str_b1 AS f1, T1.str_b2 AS f2, T2.int_c0 AS f3, T2.str_c1 AS f4, T2.int_c2 AS f5, T2.may_str_c3 AS f6 FROM TEST.set_b T1 FULL JOIN TEST.set_c T2 ON (T1.int_b0 = T2.int_c0)) T3 ON (T0.str_a2 = T3.f2)" ] @@ -102,16 +102,74 @@ return $ fromMaybe (value 1) (a ?! intA0') >< b maybes :: [Test] -maybes = [ eqShow "isJust" justX +maybes = [ eqProp "isJust" justX "SELECT ALL T0.int_a0 AS f0, T0.str_a1 AS f1, T0.str_a2 AS f2, T1.int_b0 AS f3, T1.may_str_b1 AS f4, T1.str_b2 AS f5 FROM TEST.set_a T0 LEFT JOIN TEST.set_b T1 ON (0=0) WHERE ((NOT (T1.int_b0 IS NULL)) OR (T0.int_a0 = 1))" - , eqShow "fromMaybe" maybeX + , eqProp "fromMaybe" maybeX "SELECT ALL CASE WHEN (T0.int_a0 IS NULL) THEN 1 ELSE T0.int_a0 END AS f0, T1.int_b0 AS f1, T1.may_str_b1 AS f2, T1.str_b2 AS f3 FROM TEST.set_a T0 RIGHT JOIN TEST.set_b T1 ON (0=0) WHERE (T0.str_a2 = T1.may_str_b1)" ] _p_maybes :: IO () _p_maybes = mapM_ print [show justX, show maybeX] +setAFromB :: Pi SetB SetA +setAFromB = SetA |$| intB0' |*| strB2' |*| strB2' +aFromB :: Relation () SetA +aFromB = relation $ do + x <- query setB + return $ x ! setAFromB + +unionX :: Relation () SetA +unionX = setA `union` aFromB + +unionAllX :: Relation () SetA +unionAllX = setA `unionAll` aFromB + +exceptX :: Relation () SetA +exceptX = setA `except` aFromB + +intersectX :: Relation () SetA +intersectX = setA `intersect` aFromB + +exps :: [Test] +exps = [ eqProp "union" unionX + "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a UNION SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" + , eqProp "unionAll" unionAllX + "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a UNION ALL SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" + , eqProp "except" exceptX + "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a EXCEPT SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" + , eqProp "intersect" intersectX + "SELECT int_a0 AS f0, str_a1 AS f1, str_a2 AS f2 FROM TEST.set_a INTERSECT SELECT ALL T0.int_b0 AS f0, T0.str_b2 AS f1, T0.str_b2 AS f2 FROM TEST.set_b T0" + ] + +insertX :: Insert SetA +insertX = derivedInsert + +updateKeyX :: KeyUpdate Int32 SetA +updateKeyX = primaryUpdate tableOfSetA + +updateX :: Update () +updateX = derivedUpdate $ \proj -> do + strA2' <-# value "X" + wheres $ proj ! strA1' .=. value "A" + return unitPlaceHolder + +deleteX :: Delete () +deleteX = derivedDelete $ \proj -> do + wheres $ proj ! strA1' .=. value "A" + return unitPlaceHolder + +effs :: [Test] +effs = [ eqProp "insert" insertX + "INSERT INTO TEST.set_a (int_a0, str_a1, str_a2) VALUES (?, ?, ?)" + , eqProp "updateKey" updateKeyX + "UPDATE TEST.set_a SET str_a1 = ?, str_a2 = ? WHERE int_a0 = ?" + , eqProp "update" updateX + "UPDATE TEST.set_a SET str_a2 = 'X' WHERE (str_a1 = 'A')" + , eqProp "delete" deleteX + "DELETE FROM TEST.set_a WHERE (str_a1 = 'A')" + ] + tests :: TestList tests = - testList $ concat [base, directJoins, join3s, maybes] + testList $ concat [base, directJoins, join3s, maybes, exps, effs] diff --git a/test/Tool.hs b/test/Tool.hs deleted file mode 100644 --- a/test/Tool.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Tool ( - eq, - eqShow, - ) where - -import Distribution.TestSuite (Test) -import Distribution.TestSuite.Compat (prop') - -eq :: Eq b => String -> (a -> b) -> a -> b -> String -> Test -eq name t x est em = prop' name (Just em) (t x == est) - -eqShow :: Show a => String -> a -> String -> Test -eqShow name x est = - eq name show x est $ unwords [show x, "/=", est]