diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for persistent-qq + +## 2.9.0 + +* Initial release, code separated from `persistent` diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +# persistent-qq + +Provides `sqlQQ` and `executeQQ`. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,7 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff --git a/persistent-qq.cabal b/persistent-qq.cabal new file mode 100644 --- /dev/null +++ b/persistent-qq.cabal @@ -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 . +category: Database, Yesod +homepage: https://github.com/yesodweb/persistent#readme +bug-reports: https://github.com/yesodweb/persistent/issues +author: Michael Snoyman +maintainer: Michael Snoyman +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 diff --git a/src/Database/Persist/Sql/Raw/QQ.hs b/src/Database/Persist/Sql/Raw/QQ.hs new file mode 100644 --- /dev/null +++ b/src/Database/Persist/Sql/Raw/QQ.hs @@ -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 |]