hasql 0.7.1 → 0.7.2

raw patch · 8 files changed

+153/−98 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

hasql.cabal +3/−2
hspec-postgres/Main.hs +13/−0
hspec/Main.hs +8/−1
library/Hasql.hs +2/−45
library/Hasql/Prelude.hs +1/−0
library/Hasql/QParser.hs +0/−50
library/Hasql/QQ.hs +61/−0
library/Hasql/QQ/Parser.hs +65/−0

hasql.cabal view

@@ -1,7 +1,7 @@ name:   hasql version:-  0.7.1+  0.7.2 synopsis:   A minimalistic general high level API for relational databases description:@@ -88,9 +88,10 @@     Haskell2010   other-modules:     Hasql.Prelude-    Hasql.QParser+    Hasql.QQ.Parser     Hasql.CxRow     Hasql.TH+    Hasql.QQ   exposed-modules:     Hasql   build-depends:

hspec-postgres/Main.hs view

@@ -12,6 +12,19 @@ main =    hspec $ do +    context "Multivalue clauses" $ do+      -- See http://www.postgresql.org/docs/current/interactive/functions-comparisons.html++      it "contains" $ do+        flip shouldBe (Right True) =<< do+          session $ +            fmap runIdentity $ H.tx Nothing $ H.singleEx $ [H.stmt|SELECT 2 = ANY (?)|] [1,2,3 :: Int]++      it "contains not" $ do+        flip shouldBe (Right False) =<< do+          session $ +            fmap runIdentity $ H.tx Nothing $ H.singleEx $ [H.stmt|SELECT 2 != ALL (?)|] [1,2,3 :: Int]+     context "Tx" $ do        it "does not commit if in uncommitting mode" $ do

hspec/Main.hs view

@@ -20,7 +20,14 @@ main =    hspec $ do     context "Quasi quoter" $ do-      it "generates a proper statement" $ do+      it "supports free variables" $ do+        let a = 'a'+            b = 'b'+            in+              (flip shouldBe)+                (HB.Stmt "SELECT (? + ?)" (V.fromList [HB.encodeValue a, HB.encodeValue b]) True)+                ([H.stmt| SELECT ($a + $b) |] :: HB.Stmt X)+      it "supports ordered placeholders" $ do         (flip shouldBe)           (HB.Stmt "SELECT (? + ?)" (V.fromList [HB.encodeValue 'a', HB.encodeValue 'b']) True)           ([H.stmt| SELECT (? + ?) |] 'a' 'b' :: HB.Stmt X)

library/Hasql.hs view

@@ -28,7 +28,7 @@    -- * Statement   Bknd.Stmt,-  stmt,+  QQ.stmt,    -- * Statement Execution   Ex,@@ -61,16 +61,12 @@ import Hasql.Prelude import qualified Hasql.Backend as Bknd import qualified Hasql.CxRow as CxRow-import qualified Hasql.QParser as QParser+import qualified Hasql.QQ as QQ import qualified ListT import qualified Data.Pool as Pool-import qualified Data.Text as Text import qualified Data.Vector as Vector import qualified Data.Vector.Mutable as MVector-import qualified Language.Haskell.TH as TH-import qualified Language.Haskell.TH.Quote as TH import qualified Language.Haskell.TH.Syntax as TH-import qualified Hasql.TH as THUtil   -- * Resources@@ -389,42 +385,3 @@     ListT.uncons .      (unsafeCoerce :: TxStreamListT s m r -> ListT.ListT m r) ---- * Statements quasi-quotation------------------------------ |--- Produces a lambda-expression, --- which takes as many parameters as there are placeholders in the quoted text--- and results in a 'Bknd.Stmt'. --- --- E.g.:--- --- >selectSum :: Int -> Int -> Stmt c--- >selectSum = [stmt|SELECT (? + ?)|]--- -stmt :: TH.QuasiQuoter-stmt = -  TH.QuasiQuoter-    (parseExp)-    (const $ fail "Pattern context is not supported")-    (const $ fail "Type context is not supported")-    (const $ fail "Declaration context is not supported")-  where-    parseExp s =-      do-        (t, n) <- either (fail . showString "Parsing failure: ") return (QParser.parse (fromString s))-        return $ statementF (Text.unpack t) (fromIntegral n)-    statementF s n =-      TH.LamE-        (map TH.VarP argNames)-        (THUtil.purify [|Bknd.Stmt $(pure statementE) $(pure argsE) True|])-      where-        argNames = -          map (TH.mkName . ('_' :) . show) [1 .. n]-        statementE = -          TH.LitE (TH.StringL s)-        argsE =-          THUtil.vectorE $-          map (\x -> THUtil.purify [| Bknd.encodeValue $(TH.varE x) |]) $-          argNames

library/Hasql/Prelude.hs view

@@ -13,6 +13,7 @@ ------------------------- import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass)+import Control.Monad.Trans.Writer as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) import Control.Monad.Trans.Maybe as Exports hiding (liftCallCC, liftCatch, liftListen, liftPass) import Control.Monad.Trans.Class as Exports import Control.Monad.IO.Class as Exports

− library/Hasql/QParser.hs

@@ -1,50 +0,0 @@-module Hasql.QParser where--import Hasql.Prelude hiding (takeWhile)-import Data.Attoparsec.Text hiding (Result)-import qualified Data.Text as T-import qualified Data.Text.Lazy as TL-import qualified Data.Text.Lazy.Builder as TLB----- |--- Produces a whitespace-cleaned text and a count of placeholders in it.-parse :: Text -> Either String (Text, Int)-parse = -  parseOnly $ singleTemplate--singleTemplate :: Parser (Text, Int)-singleTemplate =-  template <* -  ((endOfInput) <|>-   (() <$ skipSpace <* char ';' <* fail "A semicolon detected. Only single statements are allowed"))--template :: Parser (Text, Int)-template =-  flip runStateT 0 $ do-    lift $ skipSpace-    fmap (TL.toStrict . TLB.toLazyText . mconcat) $ -      many $ -        (mempty <$ lift trailingWhitespace) <|>-        (TLB.singleton ' ' <$ lift (takeWhile1 isSpace)) <|>-        (TLB.fromText <$> lift stringLit) <|>-        (TLB.singleton <$> lift (char '?') <* modify succ) <|>-        (TLB.singleton <$> lift (notChar ';'))--trailingWhitespace :: Parser ()-trailingWhitespace =-  () <$ takeWhile1 isSpace <* endOfInput--stringLit :: Parser Text-stringLit =-  do-    quote <- -      char '"' <|> char '\''-    content <- -      fmap mconcat $ many $ -        TLB.fromText <$> string "\\\\" <|> -        TLB.fromText <$> string (fromString ['\\', quote]) <|> -        TLB.singleton <$> notChar quote-    char quote-    return $ TL.toStrict . TLB.toLazyText $-      TLB.singleton quote <> content <> TLB.singleton quote

+ library/Hasql/QQ.hs view

@@ -0,0 +1,61 @@+module Hasql.QQ where++import Hasql.Prelude+import Hasql.TH+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax+import qualified Data.Text as Text+import qualified Hasql.QQ.Parser as Parser+import qualified Hasql.Backend as Bknd+++-- |+-- Produces a lambda-expression, +-- which takes as many parameters as there are placeholders in the quoted text+-- and results in a 'Bknd.Stmt'. +-- +-- E.g.:+-- +-- >selectSum :: Int -> Int -> Stmt c+-- >selectSum = [stmt|SELECT (? + ?)|]+-- +-- It also allows to directly refer to free variables like so:+-- +-- >selectSum :: Int -> Int -> Stmt c+-- >selectSum a b = [stmt|SELECT ($a + $b)|]+stmt :: QuasiQuoter+stmt = +  QuasiQuoter+    (parseExp)+    (const $ fail "Pattern context is not supported")+    (const $ fail "Type context is not supported")+    (const $ fail "Declaration context is not supported")+  where+    parseExp =+      fmap (uncurry statementF) .+      either (fail . showString "Parsing failure: ") return .+      Parser.parse .+      fromString+    statementF t params =+      LamE+        (map VarP argNames)+        (purify [|Bknd.Stmt $(pure statementE) $(pure argsE) True|])+      where+        (varNames, argNames) =+          (\(a, b) -> (reverse a, reverse b)) $ +          flip execState ([], []) $ forM_ params $ \case+            Parser.ParamName n ->+              modify $ \(a, b) -> (mkName (Text.unpack n) : a, b)+            Parser.OrderedPlaceholder ->+              modify $ \(a, b) -> +                let n = mkName $ '_' : show (length b + 1)+                    in (n : a, n : b)+            Parser.IndexedPlaceholder i ->+              fail "Indexed placeholders are not supported"+        statementE = +          LitE (StringL (Text.unpack t))+        argsE =+          vectorE $+          map (\x -> purify [| Bknd.encodeValue $(varE x) |]) $+          varNames

+ library/Hasql/QQ/Parser.hs view

@@ -0,0 +1,65 @@+module Hasql.QQ.Parser where++import Hasql.Prelude hiding (takeWhile)+import Data.Attoparsec.Text hiding (Result)+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+++type Result =+  (Text, [Param])++data Param =+  ParamName Text |+  OrderedPlaceholder |+  IndexedPlaceholder Int++-- |+-- Produces a whitespace-cleaned text and a count of placeholders in it.+parse :: Text -> Either String (Text, [Param])+parse = +  parseOnly $ singleTemplate++singleTemplate :: Parser (Text, [Param])+singleTemplate =+  template <* +  ((endOfInput) <|>+   (() <$ skipSpace <* char ';' <* fail "A semicolon detected, but only single statements are allowed"))++template :: Parser (Text, [Param])+template =+  runWriterT $ do+    lift $ skipSpace+    fmap (TL.toStrict . TLB.toLazyText . mconcat) $ +      many $ +        (mempty <$ lift (takeWhile1 isSpace <* endOfInput)) <|>+        (TLB.singleton ' ' <$ lift (takeWhile1 isSpace)) <|>+        (TLB.fromText <$> lift stringLit) <|>+        (TLB.singleton '?' <$ (lift param >>= tell . pure)) <|>+        (TLB.singleton <$> lift (notChar ';'))++stringLit :: Parser Text+stringLit =+  do+    quote <- +      char '"' <|> char '\''+    content <- +      fmap mconcat $ many $ +        TLB.fromText <$> string "\\\\" <|> +        TLB.fromText <$> string (fromString ['\\', quote]) <|> +        TLB.singleton <$> notChar quote+    char quote+    return $ TL.toStrict . TLB.toLazyText $+      TLB.singleton quote <> content <> TLB.singleton quote++param :: Parser Param+param =+  (char '$' *> ((ParamName <$> paramName) <|> (IndexedPlaceholder <$> decimal))) <|>+  (OrderedPlaceholder <$ char '?')++paramName :: Parser Text+paramName =+  T.cons <$> satisfy isLower <*> takeWhile (\c -> isAlphaNum c || elem c extraChars)+  where+    extraChars = "_'" :: [Char]