packages feed

relational-query 0.3.0.1 → 0.3.0.2

raw patch · 4 files changed

+247/−30 lines, 4 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

relational-query.cabal view
@@ -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
+ test/Lex.hs view
@@ -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
test/SQLs.hs view
@@ -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]
− test/Tool.hs 
@@ -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]