packages feed

postgresql-simple-interpolate (empty) → 0.1

raw patch · 5 files changed

+240/−0 lines, 5 filesdep +basedep +haskell-src-metadep +mtlsetup-changed

Dependencies added: base, haskell-src-meta, mtl, parsec, postgresql-simple, template-haskell

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Elliot Cameron++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Taylor Hedberg nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ postgresql-simple-interpolate.cabal view
@@ -0,0 +1,31 @@+name: postgresql-simple-interpolate+version: 0.1+synopsis: Interpolated SQL queries via quasiquotation+description: Interpolated SQL queries via quasiquotation+license: BSD3+license-file: LICENSE+author: Elliot Cameron+maintainer: eacameron@gmail.com+copyright: ©2019 Elliot Cameron+homepage: https://github.com/3noch/postgresql-simple-interpolate+category: Database+build-type: Simple+cabal-version: >=1.8++source-repository head+  type: git+  location: git://github.com/3noch/postgresql-simple-interpolate.git++library+  hs-source-dirs: src+  exposed-modules:+    Database.PostgreSQL.Simple.SqlQQ.Interpolated+    Database.PostgreSQL.Simple.SqlQQ.Interpolated.Parser+  build-depends:+    base >= 4.5 && < 5,+    haskell-src-meta >= 0.6 && < 0.9,+    mtl >=2.1 && < 2.3,+    parsec ==3.1.*,+    postgresql-simple,+    template-haskell+  ghc-options: -Wall -O2
+ src/Database/PostgreSQL/Simple/SqlQQ/Interpolated.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Interpolated SQL queries+module Database.PostgreSQL.Simple.SqlQQ.Interpolated (isql, quoteInterpolatedSql) where++import Language.Haskell.TH (Exp, Q, appE, listE, sigE, tupE, varE)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Data.List (foldl')+import Database.PostgreSQL.Simple.ToField (Action, toField)+import Database.PostgreSQL.Simple.SqlQQ (sql)+import Text.Parsec (ParseError)++import Database.PostgreSQL.Simple.SqlQQ.Interpolated.Parser (StringPart (..), parseInterpolated)++-- | Quote a SQL statement with embedded antiquoted expressions.+--+-- The result of the quasiquoter is a tuple, containing the statement string and a list+-- of parameters. For example:+--+-- @[isql|SELECT field FROM table WHERE name = ${map toLower "ELLIOT"} LIMIT ${10}|]@+--+-- produces+--+-- @("SELECT field FROM table WHERE name = ? LIMIT ?", [Escape "elliot", Plain "10"])@+--+-- How the parser works:+--+-- Any expression occurring between @${@ and @}@ will be replaced with a @?@+-- and passed as a query parameter.+--+-- Characters preceded by a backslash are treated literally. This enables the+-- inclusion of the literal substring @${@ within your quoted text by writing+-- it as @\\${@. The literal sequence @\\${@ may be written as @\\\\${@.+--+-- Note: This quasiquoter is a wrapper around 'Database.PostgreSQL.Simple.SqlQQ.sql'+-- which also "minifies" the query at compile time by stripping whitespace and+-- comments. However, there are a few "gotchas" to be aware of so please refer+-- to the documentation of that function for a full specification.+--+-- This quasiquoter only works in expression contexts and will throw an error+-- at compile time if used in any other context.+isql :: QuasiQuoter+isql = QuasiQuoter+  { quoteExp = quoteInterpolatedSql+  , quotePat = error "isql quasiquoter does not support usage in patterns"+  , quoteType = error "isql quasiquoter does not support usage in types"+  , quoteDec = error "isql quasiquoter does not support usage in declarations"+  }++combineParts :: [StringPart] -> (String, [Q Exp])+combineParts = foldl' step ("", [])+  where+    step (s, exprs) subExpr = case subExpr of+      Lit str -> (s <> str, exprs)+      Esc c -> (s <> [c], exprs)+      Anti e -> (s <> "?", exprs <> [e]) -- TODO: Make this not slow++applySql :: [StringPart] -> Q Exp+applySql parts =+  let+    (s', exps) = combineParts parts+  in+  tupE [quoteExp sql s', sigE (listE $ map (appE (varE 'toField)) exps) [t| [Action] |]]++-- | The internal parser used by 'isql'.+quoteInterpolatedSql :: String -> Q Exp+quoteInterpolatedSql s = either (handleError s) applySql (parseInterpolated s)++handleError :: String -> ParseError -> Q Exp+handleError expStr parseError = error $+  "Failed to parse interpolated expression in string: "+    ++ expStr+    ++ "\n"+    ++ show parseError
+ src/Database/PostgreSQL/Simple/SqlQQ/Interpolated/Parser.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Parsers for antiquoted Haskell expressions inside strings.+--+-- This module was largely copied from+-- https://github.com/tmhedberg/here/blob/8a616b358bcc16bd215a78a8f6192ad9df8224b6/src/Data/String/Here/Interpolated.hs+module Database.PostgreSQL.Simple.SqlQQ.Interpolated.Parser where++import Data.Char (isDigit, isLetter)+import Data.Functor (($>))+import Control.Monad (unless)+import Control.Monad.State (evalStateT, get, modify)+import Control.Monad.Trans (lift)+import Language.Haskell.Meta (parseExp)+import Language.Haskell.TH (Exp, Q)+import Text.Parsec ( ParseError, anyChar, between, char, eof, incSourceColumn+                   , getInput, lookAhead, manyTill, noneOf, parse, setInput, statePos+                   , string, try, updateParserState, (<|>)+                   )+import Text.Parsec.String (Parser)++data StringPart = Lit String | Esc Char | Anti (Q Exp)++data HsChompState = HsChompState { quoteState :: QuoteState+                                 , braceCt :: Int+                                 , consumed :: String+                                 , prevCharWasIdentChar :: Bool+                                 }++data QuoteState = None | Single EscapeState | Double EscapeState deriving (Eq, Ord, Show)++data EscapeState = Escaped | Unescaped deriving (Bounded, Enum, Eq, Ord, Show)++parseInterpolated :: String -> Either ParseError [StringPart]+parseInterpolated = parse pInterp ""++pInterp :: Parser [StringPart]+pInterp = manyTill pStringPart eof++pStringPart :: Parser StringPart+pStringPart = pAnti <|> pEsc <|> pLit++pAnti :: Parser StringPart+pAnti = Anti <$> between (try pAntiOpen) pAntiClose pAntiExpr++pAntiOpen :: Parser String+pAntiOpen = string "${"++pAntiClose :: Parser String+pAntiClose = string "}"++pAntiExpr :: Parser (Q Exp)+pAntiExpr = pUntilUnbalancedCloseBrace >>= either fail (pure . pure) . parseExp++pUntilUnbalancedCloseBrace :: Parser String+pUntilUnbalancedCloseBrace = evalStateT go $ HsChompState None 0 "" False+  where+    go = do+      c <- lift anyChar+      modify $ \st@HsChompState {consumed} -> st {consumed = c:consumed}+      HsChompState{..} <- get+      let next = setIdentifierCharState c *> go+      case quoteState of+        None -> case c of+          '{' -> incBraceCt 1 *> next+          '}' | braceCt > 0 -> incBraceCt (-1) *> next+              | otherwise -> stepBack $> reverse (tail consumed)+          '\'' -> unless prevCharWasIdentChar (setQuoteState $ Single Unescaped)+               *> next+          '"' -> setQuoteState (Double Unescaped) *> next+          _ -> next+        Single Unescaped -> do case c of '\\' -> setQuoteState (Single Escaped)+                                         '\'' -> setQuoteState None+                                         _ -> pure ()+                               next+        Single Escaped -> setQuoteState (Single Unescaped) *> next+        Double Unescaped -> do case c of '\\' -> setQuoteState (Double Escaped)+                                         '"' -> setQuoteState None+                                         _ -> pure ()+                               next+        Double Escaped -> setQuoteState (Double Unescaped) *> next+    stepBack = lift $+      updateParserState+        (\s -> s {statePos = incSourceColumn (statePos s) (-1)})+        *> getInput+        >>= setInput . ('}':)+    incBraceCt n = modify $ \st@HsChompState {braceCt} ->+      st {braceCt = braceCt + n}+    setQuoteState qs = modify $ \st -> st {quoteState = qs}+    setIdentifierCharState c = modify $ \st ->+      st+        {prevCharWasIdentChar = or [isLetter c, isDigit c, c == '_', c == '\'']}++pEsc :: Parser StringPart+pEsc = Esc <$> (char '\\' *> anyChar)++pLit :: Parser StringPart+pLit = fmap Lit $+  try (litCharTil $ try $ lookAhead pAntiOpen <|> lookAhead (string "\\"))+    <|> litCharTil eof+  where litCharTil = manyTill $ noneOf ['\\']