persistent-qq (empty) → 2.9.0

raw patch · 6 files changed

+274/−0 lines, 6 filesdep +basedep +haskell-src-metadep +mtlsetup-changed

Dependencies added: base, haskell-src-meta, mtl, persistent, template-haskell, text

Files

ChangeLog.md +5/−0
LICENSE +20/−0
README.md +3/−0
Setup.lhs +7/−0
persistent-qq.cabal +44/−0
src/Database/Persist/Sql/Raw/QQ.hs +195/−0

+ ChangeLog.md view

@@ -0,0 +1,5 @@+# Changelog for persistent-qq++## 2.9.0++* Initial release, code separated from `persistent`

+ LICENSE view

@@ -0,0 +1,20 @@+Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

+ README.md view

@@ -0,0 +1,3 @@+# persistent-qq++Provides `sqlQQ` and `executeQQ`.

+ Setup.lhs view

@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain

+ persistent-qq.cabal view

@@ -0,0 +1,44 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.30.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 01105cd47a96bd60bf3b8a6912b056d68f7fb516660a271c0031a24c9a420302++name:           persistent-qq+version:        2.9.0+synopsis:       Provides a quasi-quoter for raw SQL for persistent+description:    Please see README and API docs at <http://www.stackage.org/package/persistent>.+category:       Database, Yesod+homepage:       https://github.com/yesodweb/persistent#readme+bug-reports:    https://github.com/yesodweb/persistent/issues+author:         Michael Snoyman <michael@snoyman.com>+maintainer:     Michael Snoyman <michael@snoyman.com>+license:        MIT+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    ChangeLog.md+    README.md++source-repository head+  type: git+  location: https://github.com/yesodweb/persistent++library+  exposed-modules:+      Database.Persist.Sql.Raw.QQ+  other-modules:+      Paths_persistent_qq+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >=4.7 && <5+    , haskell-src-meta+    , mtl+    , persistent >=2.9.1+    , template-haskell+    , text+  default-language: Haskell2010

+ src/Database/Persist/Sql/Raw/QQ.hs view

@@ -0,0 +1,195 @@+{-|+@since 2.9.0++Module: module Database.Persist.Sql.Raw.QQ+Description: QuasiQuoters for performing raw sql queries++This module exports convenient QuasiQuoters to perform raw SQL queries.+All QuasiQuoters follow the same pattern and are analogous to the similar named+functions exported from 'Database.Persist.Sql.Raw'. Neither the quoted+function's behaviour, nor it's return value is altered during the translation+and all documentation provided with it holds.++The QuasiQuoters in this module perform a simple substitution on the query text,+that allows value substitutions, table name substitutions as well as column name+substitutions.+-}++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-unused-imports #-}++module Database.Persist.Sql.Raw.QQ (+      -- * Sql QuasiQuoters+      queryQQ+    , queryResQQ+    , sqlQQ+    , executeQQ+    , executeCountQQ+    ) where++import Prelude+import Control.Arrow (first, second)+import Control.Monad.Reader (ask)+import Data.Text (pack, unpack)+import Data.Maybe (fromMaybe, Maybe(..))+import Data.Monoid (mempty, (<>))+import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote+import Language.Haskell.Meta.Parse++import Database.Persist.Class (toPersistValue)+import Database.Persist+import Database.Persist.Sql++data Token+  = Literal String+  | Value String+  | TableName String+  | ColumnName String+  deriving Show++parseHaskell :: (String -> Token) -> String -> String -> [Token]+parseHaskell cons = go+    where+    go a []          = [Literal (reverse a)]+    go a ('\\':x:xs) = go (x:a) xs+    go a ['\\']      = go ('\\':a) []+    go a ('}':xs)    = cons (reverse a) : parseStr [] xs+    go a (x:xs)      = go (x:a) xs++parseStr :: String -> String -> [Token]+parseStr a []           = [Literal (reverse a)]+parseStr a ('\\':x:xs)  = parseStr (x:a) xs+parseStr a ['\\']       = parseStr ('\\':a) []+parseStr a ('#':'{':xs) = Literal (reverse a) : parseHaskell Value      [] xs+parseStr a ('^':'{':xs) = Literal (reverse a) : parseHaskell TableName  [] xs+parseStr a ('@':'{':xs) = Literal (reverse a) : parseHaskell ColumnName [] xs+parseStr a (x:xs)       = parseStr (x:a) xs++makeExpr :: TH.ExpQ -> [Token] -> TH.ExpQ+makeExpr fun toks = do+    TH.infixE+        (Just [| uncurry $(fun) |])+        ([| (=<<) |])+        (Just $ go toks)++    where+    go :: [Token] -> TH.ExpQ+    go [] = [| return (mempty, mempty) |]+    go (Literal a:xs) =+        TH.appE+            [| fmap $ first (pack a <>) |]+            (go xs)+    go (Value a:xs) =+        TH.appE+            [| fmap $ first ("?" <>) . second (toPersistValue $(reifyExp a) :) |]+            (go xs)+    go (ColumnName a:xs) = do+        colN <- TH.newName "field"+        TH.infixE+            (Just [| getFieldName $(reifyExp a) |])+            [| (>>=) |]+            (Just $ TH.lamE [ TH.varP colN ] $+                TH.appE+                    [| fmap $ first ($(TH.varE colN) <>) |]+                    (go xs))+    go (TableName a:xs) = do+        typeN <- TH.lookupTypeName a >>= \case+                Just t  -> return t+                Nothing -> fail $ "Type not in scope: " ++ show a+        tableN <- TH.newName "table"+        TH.infixE+            (Just $+                TH.appE+                    [| getTableName |]+                    (TH.sigE+                        [| error "record" |] $+                        (TH.conT typeN)))+            [| (>>=) |]+            (Just $ TH.lamE [ TH.varP tableN ] $+                TH.appE+                    [| fmap $ first ($(TH.varE tableN) <>) |]+                    (go xs))++reifyExp :: String -> TH.Q TH.Exp+reifyExp s =+    case parseExp s of+        Left e -> TH.reportError e >> [| mempty |]+        Right v -> return v++makeQQ :: TH.Q TH.Exp -> QuasiQuoter+makeQQ x = QuasiQuoter+    (makeExpr x . parseStr [])+    (error "Cannot use qc as a pattern")+    (error "Cannot use qc as a type")+    (error "Cannot use qc as a dec")++-- | QuasiQuoter for performing raw sql queries, analoguous to+-- 'Database.Persist.Sql.Raw.rawSql'+--+-- This and the following are convenient QuasiQuoters to perform raw SQL+-- queries.  They each follow the same pattern and are analogous to+-- the similarly named @raw@ functions.  Neither the quoted function's+-- behaviour, nor it's return value is altered during the translation and+-- all documentation provided with it holds.+--+-- These QuasiQuoters perform a simple substitution on the query text, that+-- allows value substitutions, table name substitutions as well as column name+-- substitutions.+--+-- Here is a small example:+--+-- Given the following simple model:+--+-- @+-- Category+--   rgt Int+--   lft Int+-- @+--+-- We can now execute this raw query:+--+-- @+-- let lft = 10 :: Int+--     rgt = 20 :: Int+--     width = rgt - lft+--  in [sqlQQ|+--       DELETE FROM ^{Category} WHERE @{CategoryLft} BETWEEN #{lft} AND #{rgt};+--       UPDATE category SET @{CategoryRgt} = @{CategoryRgt} - #{width} WHERE @{CategoryRgt} > #{rgt};+--       UPDATE category SET @{CategoryLft} = @{CategoryLft} - #{width} WHERE @{CategoryLft} > #{rgt};+--     |]+-- @+--+-- @^{TableName}@ looks up the table's name and escapes it, @\@{ColumnName}@+-- looks up the column's name and properly escapes it and @#{value}@ inserts+-- the value via the usual parameter substitution mechanism.+--+-- @since 2.9.0+sqlQQ :: QuasiQuoter+sqlQQ = makeQQ [| rawSql |]++-- | Analoguous to 'Database.Persist.Sql.Raw.rawExecute'+--+-- @since 2.9.0+executeQQ :: QuasiQuoter+executeQQ = makeQQ [| rawExecute |]++-- | Analoguous to 'Database.Persist.Sql.Raw.rawExecuteCount'+--+-- @since 2.9.0+executeCountQQ :: QuasiQuoter+executeCountQQ = makeQQ [| rawExecuteCount |]++-- | Analoguous to 'Database.Persist.Sql.Raw.rawQuery'+--+-- @since 2.9.0+queryQQ :: QuasiQuoter+queryQQ = makeQQ [| rawQuery |]++-- | Analoguous to 'Database.Persist.Sql.Raw.rawQueryRes'+--+-- @since 2.9.0+queryResQQ :: QuasiQuoter+queryResQQ = makeQQ [| rawQueryRes |]