Support for free variables by the quasi-quoter

hasql.cabal

@@ -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 @@ library
     Haskell2010
   other-modules:
     Hasql.Prelude
-    Hasql.QParser
+    Hasql.QQ.Parser
     Hasql.CxRow
     Hasql.TH
+    Hasql.QQ
   exposed-modules:
     Hasql
   build-depends:

hspec/Main.hs

@@ -20,7 +20,14 @@ instance HB.CxValue X Char where
 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

@@ -28,7 +28,7 @@ module Hasql
 
   -- * Statement
   Bknd.Stmt,
-  stmt,
+  QQ.stmt,
 
   -- * Statement Execution
   Ex,
@@ -61,16 +61,12 @@ where
 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 @@ instance ListT.MonadTransUncons (TxStreamListT s) where
     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

@@ -13,6 +13,7 @@ import BasePrelude as Exports hiding (left, right, isLeft, isRight)
 -------------------------
 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/QQ.hs

@@ -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

@@ -1,4 +1,4 @@
-module Hasql.QParser where
+module Hasql.QQ.Parser where
 
 import Hasql.Prelude hiding (takeWhile)
 import Data.Attoparsec.Text hiding (Result)
@@ -7,34 +7,38 @@ 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, Int)
+parse :: Text -> Either String (Text, [Param])
 parse = 
   parseOnly $ singleTemplate
 
-singleTemplate :: Parser (Text, Int)
+singleTemplate :: Parser (Text, [Param])
 singleTemplate =
   template <* 
   ((endOfInput) <|>
-   (() <$ skipSpace <* char ';' <* fail "A semicolon detected. Only single statements are allowed"))
+   (() <$ skipSpace <* char ';' <* fail "A semicolon detected, but only single statements are allowed"))
 
-template :: Parser (Text, Int)
+template :: Parser (Text, [Param])
 template =
-  flip runStateT 0 $ do
+  runWriterT $ do
     lift $ skipSpace
     fmap (TL.toStrict . TLB.toLazyText . mconcat) $ 
       many $ 
-        (mempty <$ lift trailingWhitespace) <|>
+        (mempty <$ lift (takeWhile1 isSpace <* endOfInput)) <|>
         (TLB.singleton ' ' <$ lift (takeWhile1 isSpace)) <|>
         (TLB.fromText <$> lift stringLit) <|>
-        (TLB.singleton <$> lift (char '?') <* modify succ) <|>
+        (TLB.singleton '?' <$ (lift param >>= tell . pure)) <|>
         (TLB.singleton <$> lift (notChar ';'))
 
-trailingWhitespace :: Parser ()
-trailingWhitespace =
-  () <$ takeWhile1 isSpace <* endOfInput
-
 stringLit :: Parser Text
 stringLit =
   do
@@ -48,3 +52,14 @@ stringLit =
     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]