sqlite-simple-interpolate (empty) → 0.1

raw patch · 7 files changed

+310/−0 lines, 7 filesdep +basedep +haskell-src-metadep +mtlsetup-changed

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

Files

CHANGELOG.md +5/−0
LICENSE +31/−0
README.md +35/−0
Setup.hs +2/−0
sqlite-simple-interpolate.cabal +41/−0
src/Database/SQLite/Simple/QQ/Interpolated.hs +93/−0
src/Database/SQLite/Simple/QQ/Interpolated/Parser.hs +103/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Changelog++## 0.1.0++* Initial version.

+ LICENSE view

@@ -0,0 +1,31 @@+Copyright (c) 2019, Elliot Cameron+Copyright (c) 2022, ruby0b++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.

+ README.md view

@@ -0,0 +1,35 @@+# `sqlite-simple-interpolate`++Write natural SQL statements in Haskell using QuasiQuoters!++```haskell+{-# LANGUAGE QuasiQuotes #-}+module Main where++import Data.Char (toLower)+import qualified Database.SQLite.Simple as SQL+import Database.SQLite.Simple.QQ.Interpolated+import Control.Exception (bracket)++(&) = flip ($)+infixl 1 &++main :: IO ()+main = bracket (SQL.open ":memory:") SQL.close $ \conn -> do+  conn & [iexecute|CREATE TABLE people (name TEXT, age INTEGER)|]+  conn & [iexecute|INSERT INTO people VALUES ("clive", 40)|]+  -- you can always use 'isql' directly but you'll have to use uncurry:+  (uncurry $ SQL.execute conn) [isql|INSERT INTO people VALUES ("clive", 32)|]++  ageSum <- conn & [ifold|SELECT age FROM people|] 0 (\acc (SQL.Only x) -> pure (acc + x))+  print ageSum++  let limit = 1+  ages <- conn & [iquery|SELECT age FROM people WHERE name = ${map toLower "CLIVE"} LIMIT ${limit}|]+  print (ages :: [SQL.Only Int])+```++## Acknowledgements+This library is a fork of [`postgresql-simple-interpolate`](https://github.com/3noch/postgresql-simple-interpolate), adapted for use with `sqlite-simple`.++The original itself is basically just a copy of the [`here` package](https://github.com/tmhedberg/here) by Taylor M. Hedberg with slight modifications!

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ sqlite-simple-interpolate.cabal view

@@ -0,0 +1,41 @@+cabal-version:      3.0+name:               sqlite-simple-interpolate+version:            0.1+synopsis:           Interpolated SQLite queries via quasiquotation+description:+  This package provides Quasiquoters for writing SQLite queries with inline interpolation of values.+  The values are interpolated using toField from sqlite-simple.+  See the README for more details.++license:            BSD-3-Clause+license-file:       LICENSE+author:             ruby0b+maintainer:         ruby0b+copyright:          ©2022 ruby0b ©2019 Elliot Cameron+homepage:           https://github.com/ruby0b/sqlite-simple-interpolate+category:           Database+tested-with:        GHC ==9.0.2+extra-source-files:+  CHANGELOG.md+  README.md++extra-doc-files:    README.md++source-repository head+  type:     git+  location: git://github.com/ruby0b/sqlite-simple-interpolate.git++library+  hs-source-dirs:   src+  exposed-modules:  Database.SQLite.Simple.QQ.Interpolated+  other-modules:    Database.SQLite.Simple.QQ.Interpolated.Parser+  build-depends:+    , base              >=4.5  && <5+    , haskell-src-meta  >=0.6  && <0.9+    , mtl               >=2.1  && <2.3+    , parsec            ^>=3.1+    , sqlite-simple     >=0.1+    , template-haskell  >=2.17 && <2.19++  ghc-options:      -Wall+  default-language: Haskell2010

+ src/Database/SQLite/Simple/QQ/Interpolated.hs view

@@ -0,0 +1,93 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Interpolated SQL queries+module Database.SQLite.Simple.QQ.Interpolated+  ( isql+  , quoteInterpolatedSql+  , iquery+  , iexecute+  , ifold+  ) where++import Language.Haskell.TH (Exp, Q, appE, listE, sigE, tupE, varE)+import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Database.SQLite.Simple.ToField (toField)+import Database.SQLite.Simple.QQ (sql)+import Text.Parsec (ParseError)+import Database.SQLite.Simple++import Database.SQLite.Simple.QQ.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 ?", [toField ((map toLower) "ELLIOT"), toField 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.SQLite.Simple.QQ.sql'.+--+-- 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 = foldr step ("", [])+  where+    step subExpr (s, exprs) = case subExpr of+      Lit str -> (str <> s, exprs)+      Esc c -> (c : s, exprs)+      Anti e -> ('?' : s, e : exprs)++applySql :: [StringPart] -> Q Exp+applySql parts =+  let+    (s', exps) = combineParts parts+  in+  tupE [quoteExp sql s', sigE (listE $ map (appE (varE 'toField)) exps) [t| [SQLData] |]]++-- | 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 $ mconcat+  [ "Failed to parse interpolated expression in string: "+  , expStr+  , "\n"+  , show parseError+  ]++-- | Invokes 'query' with arguments provided by 'isql'.+-- The result is of type '(Connection -> IO [r])'.+iquery :: QuasiQuoter+iquery = isql { quoteExp = appE [| \(q, qs) c -> query c q qs |] . quoteInterpolatedSql }++-- | Invokes 'execute' with arguments provided by 'isql'+-- The result is of type '(Connection -> IO ())'.+iexecute :: QuasiQuoter+iexecute = isql { quoteExp = appE [| \(q, qs) c -> execute c q qs |] . quoteInterpolatedSql }++-- | Invokes 'fold' with arguments provided by 'isql'.+-- The result is of type 'a -> (a -> row -> IO a) -> Connection -> IO a'.+ifold :: QuasiQuoter+ifold = isql { quoteExp = appE [| \(q, qs) acc f c -> fold c q qs acc f |] . quoteInterpolatedSql }

+ src/Database/SQLite/Simple/QQ/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.SQLite.Simple.QQ.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 ['\\']