├── .gitignore ├── shell.nix ├── default.nix ├── lib └── Hasql │ ├── Interpolate │ └── Internal │ │ ├── OneColumn.hs │ │ ├── OneRow.hs │ │ ├── RowsAffected.hs │ │ ├── Sql.hs │ │ ├── Decoder │ │ └── TH.hs │ │ ├── CompositeValue.hs │ │ ├── EncodeRow │ │ └── TH.hs │ │ ├── Json.hs │ │ ├── Encoder.hs │ │ ├── EncodeRow.hs │ │ ├── Decoder.hs │ │ └── TH.hs │ └── Interpolate.hs ├── .github └── workflows │ └── ci.yml ├── README.md ├── CHANGELOG.md ├── LICENSE ├── flake.lock ├── hasql-interpolate.cabal ├── flake.nix └── test └── Main.hs /.gitignore: -------------------------------------------------------------------------------- 1 | dist-newstyle 2 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | (import ( 2 | let 3 | lock = builtins.fromJSON (builtins.readFile ./flake.lock); 4 | in fetchTarball { 5 | url = "https://github.com/edolstra/flake-compat/archive/${lock.nodes.flake-compat.locked.rev}.tar.gz"; 6 | sha256 = lock.nodes.flake-compat.locked.narHash; } 7 | ) { 8 | src = ./.; 9 | }).shellNix 10 | -------------------------------------------------------------------------------- /default.nix: -------------------------------------------------------------------------------- 1 | (import ( 2 | let 3 | lock = builtins.fromJSON (builtins.readFile ./flake.lock); 4 | in fetchTarball { 5 | url = "https://github.com/edolstra/flake-compat/archive/${lock.nodes.flake-compat.locked.rev}.tar.gz"; 6 | sha256 = lock.nodes.flake-compat.locked.narHash; } 7 | ) { 8 | src = ./.; 9 | }).defaultNix 10 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/OneColumn.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | 4 | module Hasql.Interpolate.Internal.OneColumn 5 | ( OneColumn (..), 6 | ) 7 | where 8 | 9 | import GHC.Generics (Generic) 10 | import qualified Hasql.Decoders as D 11 | import Hasql.Interpolate.Internal.Decoder 12 | 13 | newtype OneColumn a = OneColumn 14 | { getOneColumn :: a 15 | } 16 | deriving stock (Show, Eq, Generic) 17 | 18 | -- | Parse a single column row 19 | instance DecodeField a => DecodeRow (OneColumn a) where 20 | decodeRow = OneColumn <$> D.column decodeField 21 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: "CI" 2 | on: 3 | pull_request: 4 | push: 5 | jobs: 6 | linux: 7 | runs-on: ubuntu-latest 8 | strategy: 9 | fail-fast: false 10 | matrix: 11 | include: 12 | - compiler: ghc965 13 | - compiler: ghc982 14 | - compiler: ghc9101 15 | steps: 16 | - uses: actions/checkout@v3 17 | - uses: DeterminateSystems/nix-installer-action@main 18 | - uses: DeterminateSystems/magic-nix-cache-action@main 19 | 20 | - run: nix -L build ".#checks.x86_64-linux.$GHCVER" 21 | env: 22 | GHCVER: ${{ matrix.compiler }} 23 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/OneRow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | 4 | module Hasql.Interpolate.Internal.OneRow 5 | ( OneRow (..), 6 | ) 7 | where 8 | 9 | import GHC.Generics (Generic) 10 | import qualified Hasql.Decoders as D 11 | import Hasql.Interpolate.Internal.Decoder 12 | 13 | newtype OneRow a = OneRow 14 | { getOneRow :: a 15 | } 16 | deriving stock (Show, Eq, Generic) 17 | 18 | -- | Parse a single row result, throw 19 | -- 'Hasql.Errors.UnexpectedAmountOfRows' 20 | -- otherwise. ('Hasql.Decoders.singleRow') 21 | instance DecodeRow a => DecodeResult (OneRow a) where 22 | decodeResult = OneRow <$> D.singleRow decodeRow 23 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # hasql-interpolate 2 | 3 | [![GitHub CI](https://github.com/awkward-squad/hasql-interpolate/workflows/CI/badge.svg)](https://github.com/awkward-squad/hasql-interpolate/actions) 4 | [![Hackage](https://img.shields.io/hackage/v/hasql-interpolate.svg?label=hasql-interpolate&logo=haskell)](https://hackage.haskell.org/package/hasql-interpolate) 5 | 6 | `hasql-interpolate` provides a sql QuasiQuoter for hasql that supports 7 | interpolation of haskell expressions and splicing of sql snippets. A 8 | number of type classes are also provided to reduce encoder/decoder 9 | boilerplate. 10 | 11 | # Documentation 12 | 13 | [Hackage documentation](https://hackage.haskell.org/package/hasql-interpolate/docs/Hasql-Interpolate.html) 14 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/RowsAffected.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE DerivingStrategies #-} 3 | 4 | module Hasql.Interpolate.Internal.RowsAffected 5 | ( RowsAffected (..), 6 | ) 7 | where 8 | 9 | import Data.Int 10 | import GHC.Generics (Generic) 11 | import qualified Hasql.Decoders as D 12 | import Hasql.Interpolate.Internal.Decoder 13 | 14 | newtype RowsAffected = RowsAffected 15 | { getRowsAffected :: Int64 16 | } 17 | deriving stock (Show, Eq, Generic) 18 | 19 | -- | Parse the rows affected from the query result, as in an @insert@, 20 | -- @update@, or @delete@ statement without a returning clause. ('D.rowsAffected') 21 | instance DecodeResult RowsAffected where 22 | decodeResult = RowsAffected <$> D.rowsAffected 23 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | ## [1.0.1.0] - July 16, 2024 2 | 3 | * Add `DecodeValue` instance for `ByteString` and `LazyByteString` 4 | 5 | ## [1.0.0.0] - July 10, 2024 6 | 7 | * Add IP address type encoders and decoders 8 | * Increase tuple instances to size 16 9 | * Support `hasql-1.8` 10 | 11 | ## [0.2.2.0] - May 7, 2024 12 | 13 | * Make compile-time syntax error messages prettier 14 | * Add `EncodeValue` instances for `ByteString` and `LazyByteString` 15 | * Add `JsonBytes` and `JsonbBytes` newtypes 16 | 17 | ## [0.2.1.0] - August 29, 2023 18 | 19 | * Fix encoder generation bug (https://github.com/awkward-squad/hasql-interpolate/pull/10) 20 | 21 | ## [0.2.0.0] - August 17, 2023 22 | 23 | * Relax context of tuple instances for `EncodeRow` from `EncodeValue` to `EncodeField` (https://github.com/awkward-squad/hasql-interpolate/pull/9) 24 | 25 | ## [0.1.0.4] - January 10, 2023 26 | 27 | * Support `mtl-2.3` 28 | 29 | ## [0.1.0.3] - July 31, 2022 30 | 31 | * Support GHC 9.2 32 | 33 | ## [0.1.0.2] - February 4, 2022 34 | 35 | * Support `hasql-1.5` 36 | 37 | ## [0.1.0.1] - November 15, 2021 38 | 39 | * Fixed bug in multiline parser 40 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/Sql.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | 3 | module Hasql.Interpolate.Internal.Sql 4 | ( Sql (..), 5 | ) 6 | where 7 | 8 | import Control.Monad.Trans.State.Strict 9 | import Data.ByteString.Builder 10 | import Data.String (IsString (..)) 11 | import Hasql.Encoders 12 | 13 | -- | A SQL string with interpolated expressions. 14 | data Sql = Sql 15 | { -- | The sql string. It is stateful over an 'Int' in order to 16 | -- assign the postgresql parameter placeholders (e.g. @$1@, @$2@) 17 | sqlTxt :: State Int Builder, 18 | -- | The encoders associated with the sql string. Already applied 19 | -- to their parameters. 20 | encoder :: Params () 21 | } 22 | 23 | instance IsString Sql where 24 | fromString str = Sql (pure (stringUtf8 str)) mempty 25 | 26 | instance Semigroup Sql where 27 | a <> b = 28 | Sql 29 | { sqlTxt = 30 | ( (<>) <$> sqlTxt a <*> sqlTxt b 31 | ), 32 | encoder = encoder a <> encoder b 33 | } 34 | {-# INLINE (<>) #-} 35 | 36 | instance Monoid Sql where 37 | mempty = 38 | Sql 39 | { sqlTxt = pure mempty, 40 | encoder = mempty 41 | } 42 | {-# INLINE mempty #-} 43 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/Decoder/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | module Hasql.Interpolate.Internal.Decoder.TH 4 | ( genDecodeRowInstance, 5 | ) 6 | where 7 | 8 | import Control.Monad 9 | import Data.Foldable (foldl') 10 | import Hasql.Decoders 11 | import Language.Haskell.TH 12 | 13 | -- | Generate a single 'Hasql.Interpolate.DecodeRow' instance for a 14 | -- tuple of size @tupSize@ 15 | genDecodeRowInstance :: 16 | -- | tuple size 17 | Int -> 18 | Q Dec 19 | genDecodeRowInstance tupSize 20 | | tupSize < 2 = fail "this is just for tuples, must specify a tuple size of 2 or greater" 21 | | otherwise = do 22 | tyVars <- replicateM tupSize (newName "x") 23 | context <- traverse (\x -> [t|$(conT (mkName "DecodeField")) $(varT x)|]) tyVars 24 | instanceHead <- [t|$(conT (mkName "DecodeRow")) $(pure $ foldl' AppT (TupleT tupSize) (map VarT tyVars))|] 25 | let tupSection = TupE (replicate tupSize Nothing) 26 | go b _a = do 27 | [e|$(b) <*> column decodeField|] 28 | 29 | instanceBodyExp <- foldl' go [e|$(pure tupSection) <$> column decodeField|] (drop 1 tyVars) 30 | let instanceBody = FunD (mkName "decodeRow") [Clause [] (NormalB instanceBodyExp) []] 31 | pure (InstanceD Nothing context instanceHead [instanceBody]) 32 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/CompositeValue.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | module Hasql.Interpolate.Internal.CompositeValue 8 | ( CompositeValue (..), 9 | ) 10 | where 11 | 12 | import Data.Coerce 13 | import GHC.Generics 14 | import Hasql.Decoders 15 | import Hasql.Interpolate.Internal.Decoder 16 | 17 | -- | Useful with @DerivingVia@ to get a 'DecodeValue' instance for any 18 | -- product type by parsing it as a composite. 19 | -- 20 | -- ==== __Example__ 21 | -- 22 | -- @ 23 | -- data Point = Point Int64 Int64 24 | -- deriving stock (Generic) 25 | -- deriving (DecodeValue) via CompositeValue Point 26 | -- @ 27 | newtype CompositeValue a 28 | = CompositeValue a 29 | 30 | instance (Generic a, GToComposite (Rep a)) => DecodeValue (CompositeValue a) where 31 | decodeValue = coerce @(Value a) (composite (to <$> gtoComposite)) 32 | 33 | class GToComposite a where 34 | gtoComposite :: Composite (a p) 35 | 36 | instance GToComposite a => GToComposite (M1 t i a) where 37 | gtoComposite = M1 <$> gtoComposite 38 | 39 | instance (GToComposite a, GToComposite b) => GToComposite (a :*: b) where 40 | gtoComposite = (:*:) <$> gtoComposite <*> gtoComposite 41 | 42 | instance DecodeValue a => GToComposite (K1 i a) where 43 | gtoComposite = K1 <$> field decodeField 44 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2021-2025 Travis Staton, Mitchell Dalvi Rosen 2 | 3 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 4 | 5 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 6 | 7 | 2. 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. 8 | 9 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 10 | 11 | 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 HOLDER 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. 12 | -------------------------------------------------------------------------------- /flake.lock: -------------------------------------------------------------------------------- 1 | { 2 | "nodes": { 3 | "flake-compat": { 4 | "flake": false, 5 | "locked": { 6 | "lastModified": 1696426674, 7 | "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", 8 | "owner": "edolstra", 9 | "repo": "flake-compat", 10 | "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", 11 | "type": "github" 12 | }, 13 | "original": { 14 | "owner": "edolstra", 15 | "repo": "flake-compat", 16 | "type": "github" 17 | } 18 | }, 19 | "flake-utils": { 20 | "inputs": { 21 | "systems": "systems" 22 | }, 23 | "locked": { 24 | "lastModified": 1710146030, 25 | "narHash": "sha256-SZ5L6eA7HJ/nmkzGG7/ISclqe6oZdOZTNoesiInkXPQ=", 26 | "owner": "numtide", 27 | "repo": "flake-utils", 28 | "rev": "b1d9ab70662946ef0850d488da1c9019f3a9752a", 29 | "type": "github" 30 | }, 31 | "original": { 32 | "owner": "numtide", 33 | "repo": "flake-utils", 34 | "type": "github" 35 | } 36 | }, 37 | "nixpkgs": { 38 | "locked": { 39 | "lastModified": 1720386169, 40 | "narHash": "sha256-NGKVY4PjzwAa4upkGtAMz1npHGoRzWotlSnVlqI40mo=", 41 | "owner": "NixOS", 42 | "repo": "nixpkgs", 43 | "rev": "194846768975b7ad2c4988bdb82572c00222c0d7", 44 | "type": "github" 45 | }, 46 | "original": { 47 | "owner": "NixOS", 48 | "ref": "nixos-24.05", 49 | "repo": "nixpkgs", 50 | "type": "github" 51 | } 52 | }, 53 | "root": { 54 | "inputs": { 55 | "flake-compat": "flake-compat", 56 | "flake-utils": "flake-utils", 57 | "nixpkgs": "nixpkgs" 58 | } 59 | }, 60 | "systems": { 61 | "locked": { 62 | "lastModified": 1681028828, 63 | "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", 64 | "owner": "nix-systems", 65 | "repo": "default", 66 | "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", 67 | "type": "github" 68 | }, 69 | "original": { 70 | "owner": "nix-systems", 71 | "repo": "default", 72 | "type": "github" 73 | } 74 | } 75 | }, 76 | "root": "root", 77 | "version": 7 78 | } 79 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate.hs: -------------------------------------------------------------------------------- 1 | module Hasql.Interpolate 2 | ( -- * QuasiQuoters 3 | sql, 4 | Sql, 5 | 6 | -- * Interpolators 7 | interp, 8 | interpFoldl, 9 | interpWith, 10 | 11 | -- * Decoders 12 | DecodeValue (..), 13 | DecodeField (..), 14 | DecodeRow (..), 15 | DecodeResult (..), 16 | 17 | -- * Encoders 18 | EncodeValue (..), 19 | EncodeField, 20 | 21 | -- * Newtypes for decoding/encoding 22 | OneRow (..), 23 | OneColumn (..), 24 | RowsAffected (..), 25 | Json (..), 26 | Jsonb (..), 27 | JsonBytes (..), 28 | JsonbBytes (..), 29 | AsJson (..), 30 | AsJsonb (..), 31 | CompositeValue (..), 32 | 33 | -- * toTable 34 | toTable, 35 | EncodeRow (..), 36 | ) 37 | where 38 | 39 | import Control.Monad.Trans.State.Strict (evalState) 40 | import Data.ByteString.Builder (toLazyByteString) 41 | import Data.ByteString.Lazy (toStrict) 42 | import Hasql.Decoders (Result, foldlRows) 43 | import Hasql.Interpolate.Internal.CompositeValue 44 | import Hasql.Interpolate.Internal.Decoder 45 | import Hasql.Interpolate.Internal.EncodeRow 46 | import Hasql.Interpolate.Internal.Encoder 47 | import Hasql.Interpolate.Internal.Json 48 | import Hasql.Interpolate.Internal.OneColumn 49 | import Hasql.Interpolate.Internal.OneRow 50 | import Hasql.Interpolate.Internal.RowsAffected 51 | import Hasql.Interpolate.Internal.Sql 52 | import Hasql.Interpolate.Internal.TH 53 | import Hasql.Statement (Statement (..)) 54 | 55 | -- | Interpolate a 'Sql' into a 'Statement' using the 'DecodeResult' 56 | -- type class to determine the appropriate decoder. 57 | -- 58 | -- @ 59 | -- example :: Int64 -> Statement () [(Int64, Int64)] 60 | -- example bonk = interp False [sql| select x, y from t where t.x > #{bonk} |] 61 | -- @ 62 | interp :: 63 | DecodeResult b => 64 | -- | 'True' if the 'Statement' should be prepared 65 | Bool -> 66 | Sql -> 67 | Statement () b 68 | interp prepared = interpWith prepared decodeResult 69 | 70 | -- | interpolate then consume with 'foldlRows' 71 | interpFoldl :: DecodeRow a => Bool -> (b -> a -> b) -> b -> Sql -> Statement () b 72 | interpFoldl prepared f z = interpWith prepared (foldlRows f z decodeRow) 73 | 74 | -- | A more general version of 'interp' that allows for passing an 75 | -- explicit decoder. 76 | interpWith :: Bool -> Result b -> Sql -> Statement () b 77 | interpWith prepare decoder (Sql bldr enc) = Statement (toStrict (toLazyByteString (evalState bldr 1))) enc decoder prepare 78 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/EncodeRow/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | module Hasql.Interpolate.Internal.EncodeRow.TH 5 | ( genEncodeRowInstance, 6 | ) 7 | where 8 | 9 | import Control.Monad 10 | import Data.Foldable (foldl') 11 | import Data.Functor.Contravariant 12 | import qualified Hasql.Encoders as E 13 | import Hasql.Interpolate.Internal.Encoder (EncodeField (..)) 14 | import Language.Haskell.TH 15 | 16 | -- | Generate a single 'Hasql.Interpolate.EncodeRow' instance for a 17 | -- tuple of size @tupSize@ 18 | genEncodeRowInstance :: 19 | -- | tuple size 20 | Int -> 21 | Q Dec 22 | genEncodeRowInstance tupSize 23 | | tupSize < 2 = fail "this is just for tuples, must specify a tuple size of 2 or greater" 24 | | otherwise = do 25 | tyVars <- replicateM tupSize (newName "x") 26 | context <- traverse (\x -> [t|EncodeField $(varT x)|]) tyVars 27 | let unzipWithEncoderName = mkName "unzipWithEncoder" 28 | instanceHead <- [t|$(conT (mkName "EncodeRow")) $(pure $ foldl' AppT (TupleT tupSize) (map VarT tyVars))|] 29 | innerContName <- newName "k" 30 | cons <- [e|(:)|] 31 | kconsTailNames <- traverse (\_ -> newName "tail") tyVars 32 | let kconsPats :: [Pat] 33 | kconsPats = 34 | [ TupP (map VarP tyVars), 35 | TildeP (TupP (map VarP kconsTailNames)) 36 | ] 37 | kconsTupBody :: [Exp] 38 | kconsTupBody = 39 | let vars = zipWith phi tyVars kconsTailNames 40 | phi headName tailName = foldl' AppE cons [VarE headName, VarE tailName] 41 | in vars 42 | kcons :: Exp 43 | kcons = LamE kconsPats (TupE (map Just kconsTupBody)) 44 | knil :: Exp 45 | knil = TupE . map Just $ replicate tupSize (ListE []) 46 | kenc :: Exp <- do 47 | let listEncoder = [e|E.param (E.nonNullable (E.foldableArray encodeField))|] 48 | plucks = map (pluck tupSize) [0 .. tupSize - 1] 49 | encExps <- traverse (\getTupElem -> [e|contramap $getTupElem $listEncoder|]) plucks 50 | foldr (\a b -> [e|$(pure a) <> $(b)|]) [e|mempty|] encExps 51 | let kExp :: Exp 52 | kExp = foldl' AppE (VarE innerContName) [kcons, knil, kenc, LitE (IntegerL (fromIntegral tupSize))] 53 | let instanceBody = FunD unzipWithEncoderName [Clause [VarP innerContName] (NormalB kExp) []] 54 | pure (InstanceD Nothing context instanceHead [instanceBody]) 55 | 56 | pluck :: Int -> Int -> Q Exp 57 | pluck 1 0 = [e|id|] 58 | pluck tupSize idx = do 59 | matchName <- newName "match" 60 | let tupPat = TupP (map (\n -> if n == idx then VarP matchName else WildP) [0 .. tupSize - 1]) 61 | pure $ LamE [tupPat] (VarE matchName) 62 | -------------------------------------------------------------------------------- /hasql-interpolate.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.4 2 | name: hasql-interpolate 3 | version: 1.0.1.0 4 | x-revision: 3 5 | 6 | author: Travis Staton, Mitchell Dalvi Rosen 7 | category: Hasql, Database, PostgreSQL 8 | copyright: Copyright (C) 2021-2025 Travis Staton, Mitchell Dalvi Rosen 9 | extra-source-files: CHANGELOG.md 10 | homepage: https://github.com/awkward-squad/hasql-interpolate 11 | license-file: LICENSE 12 | license: BSD-3-Clause 13 | tested-with: GHC == 9.2.8, GHC == 9.4.5 14 | maintainer: Travis Staton , Mitchell Dalvi Rosen 15 | synopsis: QuasiQuoter that supports expression interpolation for hasql 16 | description: 17 | 18 | @hasql-interpolate@ provides a sql QuasiQuoter for hasql that 19 | supports interpolation of haskell expressions and splicing of sql 20 | snippets. A number of type classes are also provided to reduce 21 | encoder/decoder boilerplate. 22 | 23 | library 24 | exposed-modules: Hasql.Interpolate 25 | Hasql.Interpolate.Internal.TH 26 | 27 | other-modules: Hasql.Interpolate.Internal.Json 28 | Hasql.Interpolate.Internal.Encoder 29 | Hasql.Interpolate.Internal.Decoder 30 | Hasql.Interpolate.Internal.OneColumn 31 | Hasql.Interpolate.Internal.OneRow 32 | Hasql.Interpolate.Internal.RowsAffected 33 | Hasql.Interpolate.Internal.Decoder.TH 34 | Hasql.Interpolate.Internal.Sql 35 | Hasql.Interpolate.Internal.CompositeValue 36 | Hasql.Interpolate.Internal.EncodeRow 37 | Hasql.Interpolate.Internal.EncodeRow.TH 38 | 39 | build-depends: aeson ^>= 1.5 || ^>= 2.0 || ^>= 2.1 || ^>= 2.2, 40 | array ^>= 0.5, 41 | base ^>= 4.14 || ^>= 4.15 || ^>= 4.16 || ^>= 4.17 || ^>= 4.18 || ^>= 4.19 || ^>= 4.20 || ^>= 4.21, 42 | bytestring ^>= 0.11.2.0 || ^>= 0.12, 43 | containers ^>= 0.5 || ^>= 0.6 || ^>= 0.7 || ^>= 0.8, 44 | haskell-src-meta ^>= 0.8, 45 | hasql ^>= 1.8 || ^>= 1.9, 46 | iproute ^>= 1.7, 47 | megaparsec 48 | ^>= 8.0.0 49 | || ^>= 9.0 50 | || ^>= 9.1 51 | || ^>= 9.2 52 | || ^>= 9.3 53 | || ^>= 9.4 54 | || ^>= 9.5 55 | || ^>= 9.6 56 | || ^>= 9.7, 57 | mtl ^>= 2.1 || ^>= 2.2 || ^>= 2.3, 58 | scientific ^>= 0.3, 59 | template-haskell 60 | ^>= 2.14 61 | || ^>= 2.15 62 | || ^>= 2.16 63 | || ^>= 2.17 64 | || ^>= 2.18 65 | || ^>= 2.19 66 | || ^>= 2.20 67 | || ^>= 2.21 68 | || ^>= 2.22 69 | || ^>= 2.23, 70 | text ^>= 1.2.4 || ^>= 2.0 || ^>= 2.1, 71 | time ^>= 1.9.3 || ^>= 1.10 || ^>= 1.11 || ^>= 1.12 || ^>= 1.14, 72 | transformers ^>= 0.5 || ^>= 0.6, 73 | uuid ^>= 1.3, 74 | vector ^>= 0.11 || ^>= 0.12 || ^>= 0.13, 75 | 76 | hs-source-dirs: lib 77 | default-language: Haskell2010 78 | ghc-options: 79 | -Wall 80 | -Wcompat 81 | -Widentities 82 | -Wincomplete-record-updates 83 | -Wincomplete-uni-patterns 84 | -Wredundant-constraints 85 | -Wpartial-fields 86 | -O2 87 | 88 | test-suite unit 89 | type: exitcode-stdio-1.0 90 | main-is: Main.hs 91 | build-depends: base 92 | , hasql 93 | , hasql-interpolate 94 | , template-haskell 95 | , tasty 96 | , text 97 | , tasty-hunit 98 | , tmp-postgres 99 | hs-source-dirs: test 100 | default-language: Haskell2010 101 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/Json.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | {-# LANGUAGE TypeApplications #-} 3 | 4 | module Hasql.Interpolate.Internal.Json 5 | ( Json (..), 6 | Jsonb (..), 7 | JsonBytes (..), 8 | JsonbBytes (..), 9 | AsJson (..), 10 | AsJsonb (..), 11 | ) 12 | where 13 | 14 | import Data.Aeson 15 | import qualified Data.Aeson as Aeson 16 | import Data.Bifunctor (first) 17 | import Data.ByteString (ByteString) 18 | import qualified Data.ByteString.Lazy as BL 19 | import Data.Coerce 20 | import Data.Functor.Contravariant 21 | import qualified Data.Text as T 22 | import qualified Hasql.Decoders as D 23 | import qualified Hasql.Encoders as E 24 | import Hasql.Interpolate.Internal.Decoder 25 | import Hasql.Interpolate.Internal.Encoder 26 | 27 | -- | Newtype for 'Hasql.Interpolate.Decoder.DecodeValue' / 28 | -- 'Hasql.Interpolate.Encoder.EncodeValue' instances that converts 29 | -- between a postgres @jsonb@ and an Aeson 'Value' 30 | newtype Jsonb = Jsonb Value 31 | 32 | -- | Newtype for 'Hasql.Interpolate.Decoder.DecodeValue' / 33 | -- 'Hasql.Interpolate.Encoder.EncodeValue' instances that converts 34 | -- between a postgres @json@ and an Aeson 'Value' 35 | newtype Json = Json Value 36 | 37 | -- | Newtype for 'Hasql.Interpolate.Decoder.DecodeValue' / 38 | -- 'Hasql.Interpolate.Encoder.EncodeValue' instances that converts 39 | -- between a postgres @jsonb@ and a 'ByteString' 40 | newtype JsonbBytes = JsonbBytes ByteString 41 | 42 | -- | Newtype for 'Hasql.Interpolate.Decoder.DecodeValue' / 43 | -- 'Hasql.Interpolate.Encoder.EncodeValue' instances that converts 44 | -- between a postgres @json@ and a 'ByteString' 45 | newtype JsonBytes = JsonBytes ByteString 46 | 47 | -- | Newtype for 'Hasql.Interpolate.Decoder.DecodeValue' / 48 | -- 'Hasql.Interpolate.Encoder.EncodeValue' instances that converts 49 | -- between a postgres @json@ and anything that is an instance of 50 | -- 'FromJSON' / 'ToJSON' 51 | newtype AsJson a = AsJson a 52 | 53 | -- | Newtype for 'Hasql.Interpolate.Decoder.DecodeValue' / 54 | -- 'Hasql.Interpolate.Encoder.EncodeValue' instances that converts 55 | -- between a postgres @jsonb@ and anything that is an instance of 56 | -- 'FromJSON' / 'ToJSON' 57 | newtype AsJsonb a = AsJsonb a 58 | 59 | -- | Parse a postgres @jsonb@ using 'D.jsonb' 60 | instance DecodeValue Jsonb where 61 | decodeValue = coerce D.jsonb 62 | 63 | -- | Parse a postgres @json@ using 'D.json' 64 | instance DecodeValue Json where 65 | decodeValue = coerce D.json 66 | 67 | -- | Parse a postgres @jsonb@ using 'D.jsonbBytes' 68 | instance DecodeValue JsonbBytes where 69 | decodeValue = coerce (D.jsonbBytes Right) 70 | 71 | -- | Parse a postgres @json@ using 'D.jsonBytes' 72 | instance DecodeValue JsonBytes where 73 | decodeValue = coerce (D.jsonBytes Right) 74 | 75 | -- | Parse a postgres @json@ to anything that is an instance of 76 | -- 'Aeson.FromJSON' 77 | instance Aeson.FromJSON a => DecodeValue (AsJson a) where 78 | decodeValue = AsJson <$> D.jsonBytes (first T.pack . Aeson.eitherDecodeStrict) 79 | 80 | -- | Parse a postgres @jsonb@ to anything that is an instance of 81 | -- 'Aeson.FromJSON' 82 | instance Aeson.FromJSON a => DecodeValue (AsJsonb a) where 83 | decodeValue = AsJsonb <$> D.jsonbBytes (first T.pack . Aeson.eitherDecodeStrict) 84 | 85 | -- | Encode an Aeson 'Aeson.Value' to a postgres @json@ using 'E.json' 86 | instance EncodeValue Json where 87 | encodeValue = coerce E.json 88 | 89 | -- | Encode an Aeson 'Aeson.Value' to a postgres @jsonb@ using 'E.jsonb' 90 | instance EncodeValue Jsonb where 91 | encodeValue = coerce E.jsonb 92 | 93 | -- | Encode a 'ByteString' to a postgres @json@ using 'E.jsonBytes' 94 | instance EncodeValue JsonBytes where 95 | encodeValue = coerce E.jsonbBytes 96 | 97 | -- | Encode a 'ByteString' to a postgres @jsonb@ using 'E.jsonbBytes' 98 | instance EncodeValue JsonbBytes where 99 | encodeValue = coerce E.jsonbBytes 100 | 101 | -- | Encode anything that is an instance of 'Aeson.ToJSON' to a postgres @json@ 102 | instance Aeson.ToJSON a => EncodeValue (AsJson a) where 103 | encodeValue = BL.toStrict . Aeson.encode . coerce @_ @a >$< E.jsonBytes 104 | 105 | -- | Encode anything that is an instance of 'Aeson.ToJSON' to a postgres @jsonb@ 106 | instance Aeson.ToJSON a => EncodeValue (AsJsonb a) where 107 | encodeValue = BL.toStrict . Aeson.encode . coerce @_ @a >$< E.jsonbBytes 108 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/Encoder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleInstances #-} 2 | {-# LANGUAGE ImportQualifiedPost #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# LANGUAGE TypeApplications #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | 7 | module Hasql.Interpolate.Internal.Encoder 8 | ( EncodeValue (..), 9 | EncodeField (..), 10 | ) 11 | where 12 | 13 | import Data.ByteString (ByteString) 14 | import Data.ByteString.Lazy (LazyByteString) 15 | import Data.ByteString.Lazy qualified as ByteString.Lazy 16 | import Data.Functor.Contravariant (contramap) 17 | import Data.IP (IPRange) 18 | import Data.Int 19 | import Data.Scientific (Scientific) 20 | import Data.Text (Text) 21 | import Data.Time (Day, DiffTime, LocalTime, UTCTime) 22 | import Data.UUID (UUID) 23 | import Data.Vector (Vector) 24 | import Hasql.Encoders 25 | 26 | -- | This type class determines which encoder we will apply to a field 27 | -- by its type. 28 | -- 29 | -- ==== __Example__ 30 | -- 31 | -- @ 32 | -- 33 | -- data ThreatLevel = None | Midnight 34 | -- 35 | -- instance EncodeValue ThreatLevel where 36 | -- encodeValue = enum \\case 37 | -- None -> "none" 38 | -- Midnight -> "midnight" 39 | -- @ 40 | class EncodeValue a where 41 | encodeValue :: Value a 42 | 43 | -- | Encode a list as a postgres array using 'foldableArray' 44 | instance (EncodeField a) => EncodeValue [a] where 45 | encodeValue = foldableArray encodeField 46 | 47 | -- | Encode a 'Vector' as a postgres array using 'foldableArray' 48 | instance (EncodeField a) => EncodeValue (Vector a) where 49 | encodeValue = foldableArray encodeField 50 | 51 | -- | Encode a 'Bool' as a postgres @boolean@ using 'bool' 52 | instance EncodeValue Bool where 53 | encodeValue = bool 54 | 55 | -- | Encode a 'Text' as a postgres @text@ using 'text' 56 | instance EncodeValue Text where 57 | encodeValue = text 58 | 59 | -- | Encode a 'Int16' as a postgres @int2@ using 'int2' 60 | instance EncodeValue Int16 where 61 | encodeValue = int2 62 | 63 | -- | Encode a 'Int32' as a postgres @int4@ using 'int4' 64 | instance EncodeValue Int32 where 65 | encodeValue = int4 66 | 67 | -- | Encode a 'Int64' as a postgres @int8@ using 'int8' 68 | instance EncodeValue Int64 where 69 | encodeValue = int8 70 | 71 | -- | Encode a 'Float' as a postgres @float4@ using 'float4' 72 | instance EncodeValue Float where 73 | encodeValue = float4 74 | 75 | -- | Encode a 'Double' as a postgres @float8@ using 'float8' 76 | instance EncodeValue Double where 77 | encodeValue = float8 78 | 79 | -- | Encode a 'Char' as a postgres @char@ using 'char' 80 | instance EncodeValue Char where 81 | encodeValue = char 82 | 83 | -- | Encode a 'Day' as a postgres @date@ using 'date' 84 | instance EncodeValue Day where 85 | encodeValue = date 86 | 87 | -- | Encode a 'LocalTime' as a postgres @timestamp@ using 'timestamp' 88 | instance EncodeValue LocalTime where 89 | encodeValue = timestamp 90 | 91 | -- | Encode a 'UTCTime' as a postgres @timestamptz@ using 'timestamptz' 92 | instance EncodeValue UTCTime where 93 | encodeValue = timestamptz 94 | 95 | -- | Encode a 'Scientific' as a postgres @numeric@ using 'numeric' 96 | instance EncodeValue Scientific where 97 | encodeValue = numeric 98 | 99 | -- | Encode a 'DiffTime' as a postgres @interval@ using 'interval' 100 | instance EncodeValue DiffTime where 101 | encodeValue = interval 102 | 103 | -- | Encode a 'UUID' as a postgres @uuid@ using 'uuid' 104 | instance EncodeValue UUID where 105 | encodeValue = uuid 106 | 107 | -- | Encode an 'IPRange' as a postgres @inet@ using 'inet' 108 | instance EncodeValue IPRange where 109 | encodeValue = inet 110 | 111 | -- | Encode a 'ByteString' as a postgres @bytea@ using 'bytea' 112 | instance EncodeValue ByteString where 113 | encodeValue = bytea 114 | 115 | -- | Encode a 'LazyByteString' as a postgres @bytea@ using 'bytea' 116 | instance EncodeValue LazyByteString where 117 | encodeValue = contramap ByteString.Lazy.toStrict bytea 118 | 119 | -- | You do not need to define instances for this class; The two 120 | -- instances exported here cover all uses. The class only exists to 121 | -- lift 'Value' to hasql's 'NullableOrNot' GADT. 122 | class EncodeField a where 123 | encodeField :: NullableOrNot Value a 124 | 125 | -- | Overlappable instance for all non-nullable types. 126 | instance {-# OVERLAPPABLE #-} (EncodeValue a) => EncodeField a where 127 | encodeField = nonNullable encodeValue 128 | 129 | -- | Instance for all nullable types. 'Nothing' is encoded as @null@. 130 | instance (EncodeValue a) => EncodeField (Maybe a) where 131 | encodeField = nullable encodeValue 132 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/EncodeRow.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MonoLocalBinds #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RankNTypes #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TemplateHaskell #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE UndecidableInstances #-} 13 | 14 | module Hasql.Interpolate.Internal.EncodeRow 15 | ( EncodeRow (..), 16 | GEncodeRow (..), 17 | toTable, 18 | ) 19 | where 20 | 21 | import Control.Monad 22 | import Data.Functor.Contravariant 23 | import Data.List (intersperse) 24 | import Data.Monoid 25 | import GHC.Generics 26 | import qualified Hasql.Encoders as E 27 | import Hasql.Interpolate.Internal.EncodeRow.TH 28 | import Hasql.Interpolate.Internal.Encoder 29 | import Hasql.Interpolate.Internal.Sql 30 | import Hasql.Interpolate.Internal.TH (addParam) 31 | 32 | class EncodeRow a where 33 | -- | The continuation @(forall x. (a -> x -> x) -> x -> E.Params x 34 | -- -> Int -> r)@ is given cons @(a -> x -> x)@ and nil @(x)@ for some 35 | -- existential type @x@ and an encoder (@'E.Params' x@) for @x@. An 36 | -- Int is also given to tally up how many sql fields are in the 37 | -- unzipped structure. 38 | -- 39 | -- ==== __Example__ 40 | -- 41 | -- Consider the following manually written instance: 42 | -- 43 | -- @ 44 | -- data Blerg = Blerg Int64 Bool Text Char 45 | -- 46 | -- instance EncodeRow Blerg where 47 | -- unzipWithEncoder k = k cons nil enc 4 48 | -- where 49 | -- cons (Blerg a b c d) ~(as, bs, cs, ds) = 50 | -- (a : as, b : bs, c : cs, d : ds) 51 | -- nil = ([], [], [], []) 52 | -- enc = 53 | -- ((\(x, _, _, _) -> x) >$< param encodeField) 54 | -- <> ((\(_, x, _, _) -> x) >$< param encodeField) 55 | -- <> ((\(_, _, x, _) -> x) >$< param encodeField) 56 | -- <> ((\(_, _, _, x) -> x) >$< param encodeField) 57 | -- @ 58 | -- 59 | -- We chose @([Int64], [Bool], [Text], [Char])@ as our existential 60 | -- type. If we instead use the default instance based on 61 | -- 'GEncodeRow' then we would produce the same code as the 62 | -- instance below: 63 | -- 64 | -- @ 65 | -- instance EncodeRow Blerg where 66 | -- unzipWithEncoder k = k cons nil enc 4 67 | -- where 68 | -- cons (Blerg a b c d) ~(~(as, bs), ~(cs, ds)) = 69 | -- ((a : as, b : bs), (c : cs, d : ds)) 70 | -- nil = (([], []), ([], [])) 71 | -- enc = 72 | -- ((\((x, _), _) -> x) >$< param encodeField) 73 | -- <> ((\((_, x), _) -> x) >$< param encodeField) 74 | -- <> ((\(_ , (x, _)) -> x) >$< param encodeField) 75 | -- <> ((\(_ , (_, x)) -> x) >$< param encodeField) 76 | -- @ 77 | -- 78 | -- The notable difference being we don't produce a flat tuple, but 79 | -- instead produce a balanced tree of tuples isomorphic to the 80 | -- balanced tree of @':*:'@ from the generic 'Rep' of @Blerg@. 81 | unzipWithEncoder :: (forall x. (a -> x -> x) -> x -> E.Params x -> Int -> r) -> r 82 | default unzipWithEncoder :: 83 | (Generic a, GEncodeRow (Rep a)) => 84 | (forall x. (a -> x -> x) -> x -> E.Params x -> Int -> r) -> 85 | r 86 | unzipWithEncoder k = gUnzipWithEncoder \cons nil enc fc -> 87 | k (cons . from) nil enc fc 88 | {-# INLINE unzipWithEncoder #-} 89 | 90 | class GEncodeRow a where 91 | gUnzipWithEncoder :: (forall x. (a p -> x -> x) -> x -> E.Params x -> Int -> r) -> r 92 | 93 | -- | 'toTable' takes some list of products into the corresponding 94 | -- relation in sql. It is applying the @unnest@ based technique 95 | -- described [in the hasql 96 | -- documentation](https://hackage.haskell.org/package/hasql-1.4.5.1/docs/Hasql-Statement.html#g:2). 97 | -- 98 | -- ==== __Example__ 99 | -- 100 | -- Here is a small example that takes a haskell list and inserts it 101 | -- into a table @blerg@ which has columns @x@, @y@, and @z@ of type 102 | -- @int8@, @boolean@, and @text@ respectively. 103 | -- 104 | -- @ 105 | -- toTableExample :: [(Int64, Bool, Text)] -> Statement () () 106 | -- toTableExample rowsToInsert = 107 | -- interp [sql| insert into blerg (x, y, z) select * from ^{toTable rowsToInsert} |] 108 | -- @ 109 | -- 110 | -- This is driven by the 'EncodeRow' type class that has a 111 | -- default implementation for product types that are an instance of 112 | -- 'Generic'. So the following also works: 113 | -- 114 | -- @ 115 | -- data Blerg 116 | -- = Blerg Int64 Bool Text 117 | -- deriving stock (Generic) 118 | -- deriving anyclass (EncodeRow) 119 | -- 120 | -- toTableExample :: [Blerg] -> Statement () () 121 | -- toTableExample blergs = 122 | -- interp [sql| insert into blerg (x, y, z) select * from ^{toTable blergs} |] 123 | -- @ 124 | toTable :: EncodeRow a => [a] -> Sql 125 | toTable xs = unzipWithEncoder \cons nil enc i -> 126 | let unzippedEncoder = foldr cons nil xs >$ enc 127 | queryString = getAp $ pure "unnest(" <> (mconcat . intersperse ", " <$> Ap (replicateM i addParam)) <> pure ")" 128 | in Sql queryString unzippedEncoder 129 | {-# INLINE toTable #-} 130 | 131 | instance GEncodeRow x => GEncodeRow (M1 t i x) where 132 | gUnzipWithEncoder k = gUnzipWithEncoder \cons nil enc i -> 133 | k (\(M1 a) -> cons a) nil enc i 134 | {-# INLINE gUnzipWithEncoder #-} 135 | 136 | instance (GEncodeRow a, GEncodeRow b) => GEncodeRow (a :*: b) where 137 | gUnzipWithEncoder k = gUnzipWithEncoder \consa nila enca ia -> gUnzipWithEncoder \consb nilb encb ib -> 138 | k 139 | ( \(a :*: b) ~(as, bs) -> 140 | (consa a as, consb b bs) 141 | ) 142 | (nila, nilb) 143 | (contramap fst enca <> contramap snd encb) 144 | (ia + ib) 145 | {-# INLINE gUnzipWithEncoder #-} 146 | 147 | instance EncodeField a => GEncodeRow (K1 i a) where 148 | gUnzipWithEncoder k = 149 | k (\(K1 a) b -> a : b) [] (E.param (E.nonNullable (E.foldableArray encodeField))) 1 150 | {-# INLINE gUnzipWithEncoder #-} 151 | 152 | $(traverse genEncodeRowInstance [2 .. 16]) 153 | -------------------------------------------------------------------------------- /flake.nix: -------------------------------------------------------------------------------- 1 | { 2 | description = "hasql-interpolate"; 3 | 4 | inputs = { 5 | flake-utils.url = "github:numtide/flake-utils"; 6 | nixpkgs.url = "github:NixOS/nixpkgs/nixos-24.05"; 7 | flake-compat = { 8 | url = "github:edolstra/flake-compat"; 9 | flake = false; 10 | }; 11 | }; 12 | 13 | outputs = { self, flake-utils, nixpkgs, flake-compat }: 14 | flake-utils.lib.eachDefaultSystem 15 | (system: 16 | let 17 | compiler = "ghc9101"; 18 | pkgs = nixpkgs.legacyPackages."${system}".extend self.overlay; 19 | ghc = pkgs.haskell.packages."${compiler}"; 20 | in 21 | { 22 | apps.repl = flake-utils.lib.mkApp { 23 | drv = nixpkgs.legacyPackages."${system}".writeShellScriptBin "repl" '' 24 | confnix=$(mktemp) 25 | echo "builtins.getFlake (toString $(git rev-parse --show-toplevel))" >$confnix 26 | trap "rm $confnix" EXIT 27 | nix repl $confnix 28 | ''; 29 | }; 30 | 31 | devShells.default = ghc.shellFor { 32 | withHoogle = false; 33 | packages = hpkgs: 34 | with hpkgs; 35 | with pkgs.haskell.lib; 36 | [ 37 | hasql-interpolate 38 | ]; 39 | buildInputs = [ 40 | pkgs.cabal-install 41 | ]; 42 | }; 43 | 44 | inherit pkgs; 45 | 46 | packages = { hasql-interpolate = ghc.hasql-interpolate; }; 47 | 48 | nixpkgs = pkgs; 49 | 50 | defaultPackage = self.packages."${system}".hasql-interpolate; 51 | 52 | checks = pkgs.lib.attrsets.genAttrs [ "ghc965" "ghc982" "ghc9101" ] 53 | (ghc-ver: pkgs.haskell.packages."${ghc-ver}".hasql-interpolate); 54 | }) // { 55 | overlay = final: prev: { 56 | haskell = with prev.haskell.lib; 57 | prev.haskell // { 58 | packages = 59 | let 60 | ghcs = prev.lib.filterAttrs 61 | (k: v: prev.lib.strings.hasPrefix "ghc" k) 62 | prev.haskell.packages; 63 | patchedGhcs = builtins.mapAttrs patchGhc ghcs; 64 | patchGhc = k: v: 65 | prev.haskell.packages."${k}".extend (self: super: 66 | with prev.haskell.lib; 67 | with builtins; 68 | with prev.lib.strings; 69 | let 70 | cleanSource = pth: 71 | let 72 | src' = prev.lib.cleanSourceWith { 73 | filter = filt; 74 | src = pth; 75 | }; 76 | filt = path: type: 77 | let 78 | bn = baseNameOf path; 79 | isHiddenFile = hasPrefix "." bn; 80 | isFlakeLock = bn == "flake.lock"; 81 | isNix = hasSuffix ".nix" bn; 82 | in 83 | !isHiddenFile && !isFlakeLock && !isNix; 84 | in 85 | src'; 86 | in 87 | { 88 | tmp-postgres = 89 | let 90 | src = prev.fetchFromGitHub { 91 | owner = "jfischoff"; 92 | repo = "tmp-postgres"; 93 | rev = "7f2467a6d6d5f6db7eed59919a6773fe006cf22b"; 94 | hash = "sha256-dE1OQN7I4Lxy6RBdLCvm75Z9D/Hu+9G4ejV2pEtvL1A="; 95 | }; 96 | pkg = self.callCabal2nix "tmp-postgres" src { }; 97 | in 98 | overrideCabal pkg (drv: { 99 | libraryToolDepends = drv.libraryToolDepends or [ ] ++ [ final.postgresql ]; 100 | doCheck = false; 101 | }); 102 | hasql = dontCheck (super.callHackageDirect 103 | { 104 | pkg = "hasql"; 105 | ver = "1.8"; 106 | sha256 = "01kfj0dan0qp46r168mqz3sbsnj09mwbc0zr72jdm32fhi6ck57r"; 107 | } 108 | { }); 109 | postgresql-binary = dontCheck (super.callHackageDirect 110 | { 111 | pkg = "postgresql-binary"; 112 | ver = "0.14"; 113 | sha256 = "0h3islag95f7rlxzr38ixhv2j9g18gp17jqypk8fax39f9xy3mcm"; 114 | } 115 | { }); 116 | postgresql-libpq = dontCheck (super.callHackageDirect 117 | { 118 | pkg = "postgresql-libpq"; 119 | ver = "0.10.1.0"; 120 | sha256 = "1zhmph5g1nqwy1x7vc6r6qia6flyzr0cfswgjhi978mw4fl8qwxm"; 121 | } 122 | { }); 123 | hasql-interpolate = 124 | let 125 | p = self.callCabal2nix "hasql-interpolate" 126 | (cleanSource ./.) 127 | { }; 128 | in 129 | overrideCabal p (drv: { 130 | testToolDepends = drv.libraryToolDepends or [ ] ++ [ final.postgresql ]; 131 | # tmp-postgres is failing to initialize a db in the 132 | # nix env now, but I haven't had time to figure out 133 | # why. Once resolved we can reenable the test suite in 134 | # CI. 135 | doCheck = false; 136 | revision = null; 137 | editedCabalFile = null; 138 | }); 139 | }); 140 | in 141 | prev.haskell.packages // patchedGhcs; 142 | }; 143 | }; 144 | }; 145 | } 146 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BlockArguments #-} 2 | {-# LANGUAGE DeriveAnyClass #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE DerivingVia #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE QuasiQuotes #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | 11 | module Main where 12 | 13 | import Control.Exception 14 | import Data.Int 15 | import Data.Text (Text) 16 | import qualified Database.Postgres.Temp as Tmp 17 | import GHC.Generics (Generic) 18 | import qualified Hasql.Connection as Hasql 19 | import Hasql.Decoders (column) 20 | import Hasql.Interpolate 21 | import Hasql.Interpolate.Internal.TH 22 | import qualified Hasql.Session as Hasql 23 | import Language.Haskell.TH 24 | import Test.Tasty 25 | import Test.Tasty.HUnit 26 | import Prelude 27 | 28 | main :: IO () 29 | main = defaultMain tests 30 | 31 | tests :: TestTree 32 | tests = 33 | testGroup 34 | "Tests" 35 | [ parserTests, 36 | withResource (either (error . show) pure =<< Tmp.startConfig Tmp.defaultConfig) Tmp.stop executionTests 37 | ] 38 | 39 | parserTests :: TestTree 40 | parserTests = 41 | testGroup 42 | "parser" 43 | [ testCase "quote" testParseQuotes, 44 | testCase "comment" testParseComment, 45 | testCase "param" testParseParam 46 | ] 47 | 48 | executionTests :: IO Tmp.DB -> TestTree 49 | executionTests getDb = 50 | testGroup 51 | "execution" 52 | ( ($ getDb) 53 | <$> [ testCase "basic" . testBasic, 54 | testCase "composite test" . testComposite, 55 | testCase "row" . testRow, 56 | testCase "row generic" . testRowGeneric, 57 | testCase "snippet" . testSnippet 58 | ] 59 | ) 60 | 61 | testParseQuotes :: IO () 62 | testParseQuotes = do 63 | let expected = SqlExpr expectedSqlExpr [] [] 0 64 | expectedSqlExpr = 65 | [ Sbe'Quote "#{bonk}", 66 | Sbe'Sql " ", 67 | Sbe'Quote "^{z''onk}", 68 | Sbe'Sql " ", 69 | Sbe'Ident "#{k\"\"onk}", 70 | Sbe'Sql " ", 71 | Sbe'DollarQuote "tag" "#{kiplonk}", 72 | Sbe'Sql " ", 73 | Sbe'Cquote "newline \\n escaped \\'string\\'" 74 | ] 75 | parseSqlExpr "'#{bonk}' '^{z''onk}' \"#{k\"\"onk}\" $tag$#{kiplonk}$tag$ E'newline \\n escaped \\'string\\''" @?= Right expected 76 | 77 | testParseComment :: IO () 78 | testParseComment = do 79 | let expected = SqlExpr expectedSqlExpr [] [] 0 80 | expectedSqlExpr = 81 | [ Sbe'Sql "content ", 82 | Sbe'Sql "\nhello ", 83 | Sbe'Sql " world\n", 84 | Sbe'Sql " end\n" 85 | ] 86 | inputStr = 87 | unlines 88 | [ "content -- trailing comment", 89 | "hello /* / comment * */ world", 90 | "/* comment", 91 | "blerg /* nested comment */", 92 | "*/ end" 93 | ] 94 | parseSqlExpr inputStr @?= Right expected 95 | 96 | testParseParam :: IO () 97 | testParseParam = do 98 | let expected = 99 | SqlExpr 100 | [Sbe'Param, Sbe'Sql " ", Sbe'Param] 101 | [Pe'Exp (VarE (mkName "x")), Pe'Exp (LitE (IntegerL 2))] 102 | [] 103 | 0 104 | parseSqlExpr "#{x} #{2}" @?= Right expected 105 | 106 | testBasic :: IO Tmp.DB -> IO () 107 | testBasic getDb = do 108 | withLocalTransaction getDb \conn -> do 109 | let relation :: [(Int64, Bool, Int64)] 110 | relation = 111 | [ (0, True, 5), 112 | (1, True, 6), 113 | (2, False, 7) 114 | ] 115 | createRes <- run conn [sql| create table hasql_interpolate_test(x int8, y boolean, z int8) |] 116 | createRes @?= () 117 | RowsAffected insertRes <- run conn [sql| insert into hasql_interpolate_test (x,y,z) select * from ^{toTable relation} |] 118 | insertRes @?= 3 119 | selectRes <- run conn [sql| select x, y, z from hasql_interpolate_test where x > #{0 :: Int64} order by x |] 120 | selectRes @?= filter (\(x, _, _) -> x > 0) relation 121 | 122 | testComposite :: IO Tmp.DB -> IO () 123 | testComposite getDb = do 124 | withLocalTransaction getDb \conn -> do 125 | let expected = [Point 0 0, Point 1 1] 126 | res <- run conn [sql| select * from (values (row(0,0)), (row(1,1)) ) as t |] 127 | res @?= map OneColumn expected 128 | 129 | data T = T Int64 Bool Text deriving stock (Eq, Show) 130 | 131 | instance DecodeRow T where 132 | decodeRow = 133 | T 134 | <$> column decodeField 135 | <*> column decodeField 136 | <*> column decodeField 137 | 138 | testRow :: IO Tmp.DB -> IO () 139 | testRow getDb = do 140 | withLocalTransaction getDb \conn -> do 141 | let expected = [T 0 True "foo", T 1 False "bar"] 142 | res <- run conn [sql| select * from (values (0,true,'foo'), (1,false,'bar') ) as t |] 143 | res @?= expected 144 | 145 | testRowGeneric :: IO Tmp.DB -> IO () 146 | testRowGeneric getDb = do 147 | withLocalTransaction getDb \conn -> do 148 | let expected = [Point 0 0, Point 1 1] 149 | res <- run conn [sql| select * from (values (0,0), (1,1) ) as t |] 150 | res @?= expected 151 | 152 | testSnippet :: IO Tmp.DB -> IO () 153 | testSnippet getDb = do 154 | withLocalTransaction getDb \conn -> do 155 | let expected = [Point 0 0] 156 | let snippet = [sql| t.y = 0 |] 157 | let xVal :: Int64 = 0 158 | res <- run conn [sql| select * from (values (0,0), (1,1) ) as t(x,y) where t.x = #{xVal} and ^{snippet} |] 159 | res @?= expected 160 | 161 | withLocalTransaction :: IO Tmp.DB -> (Hasql.Connection -> IO a) -> IO a 162 | withLocalTransaction getDb k = 163 | getDb >>= \db -> bracket (either (fail . show) pure =<< Hasql.acquire (Tmp.toConnectionString db)) Hasql.release \conn -> do 164 | let beginTrans = do 165 | Hasql.run (Hasql.statement () (interp False [sql| begin |])) conn >>= \case 166 | Left err -> fail (show err) 167 | Right () -> pure () 168 | rollbackTrans = do 169 | Hasql.run (Hasql.statement () (interp False [sql| rollback |])) conn >>= \case 170 | Left err -> fail (show err) 171 | Right () -> pure () 172 | bracket beginTrans (\() -> rollbackTrans) \() -> k conn 173 | 174 | run :: DecodeResult a => Hasql.Connection -> Sql -> IO a 175 | run conn stmt = do 176 | Hasql.run (Hasql.statement () (interp False stmt)) conn >>= \case 177 | Left err -> assertFailure ("Hasql statement unexpectedly failed with error: " <> show err) 178 | Right x -> pure x 179 | 180 | data Point = Point Int64 Int64 181 | deriving stock (Generic, Eq, Show) 182 | deriving (DecodeValue) via CompositeValue Point 183 | deriving anyclass (DecodeRow) 184 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/Decoder.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE ScopedTypeVariables #-} 5 | {-# LANGUAGE TemplateHaskell #-} 6 | {-# LANGUAGE TupleSections #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | module Hasql.Interpolate.Internal.Decoder 12 | ( -- * Decoding type classes 13 | DecodeValue (..), 14 | DecodeField (..), 15 | DecodeRow (..), 16 | DecodeResult (..), 17 | 18 | -- * Generics 19 | GDecodeRow (..), 20 | ) 21 | where 22 | 23 | import Data.ByteString (ByteString) 24 | import Data.ByteString.Lazy (LazyByteString) 25 | import qualified Data.ByteString.Lazy as LazyByteString 26 | import Data.IP (IPRange) 27 | import Data.Int (Int16, Int32, Int64) 28 | import Data.Scientific (Scientific) 29 | import Data.Text (Text) 30 | import Data.Time (Day, DiffTime, LocalTime, UTCTime) 31 | import Data.UUID (UUID) 32 | import Data.Vector (Vector) 33 | import GHC.Generics 34 | import Hasql.Decoders 35 | import Hasql.Interpolate.Internal.Decoder.TH (genDecodeRowInstance) 36 | 37 | -- | This type class determines which decoder we will apply to a query 38 | -- field by the type of the result. 39 | -- 40 | -- ==== __Example__ 41 | -- 42 | -- @ 43 | -- 44 | -- data ThreatLevel = None | Midnight 45 | -- 46 | -- instance DecodeValue ThreatLevel where 47 | -- decodeValue = enum \\case 48 | -- "none" -> Just None 49 | -- "midnight" -> Just Midnight 50 | -- _ -> Nothing 51 | -- @ 52 | class DecodeValue a where 53 | decodeValue :: Value a 54 | 55 | -- | You do not need to define instances for this class; The two 56 | -- instances exported here cover all uses. The class only exists to 57 | -- lift 'Value' to hasql's 'NullableOrNot' GADT. 58 | class DecodeField a where 59 | decodeField :: NullableOrNot Value a 60 | 61 | -- | Determine a row decoder from a Haskell type. Derivable with 62 | -- generics for any product type. 63 | -- 64 | -- ==== __Examples__ 65 | -- 66 | -- A manual instance: 67 | -- 68 | -- @ 69 | -- data T = T Int64 Bool Text 70 | -- 71 | -- instance DecodeRow T where 72 | -- decodeRow = T 73 | -- <$> column decodeField 74 | -- <*> column decodeField 75 | -- <*> column decodeField 76 | -- @ 77 | -- 78 | -- A generic instance: 79 | -- 80 | -- @ 81 | -- data T 82 | -- = T Int64 Bool Text 83 | -- deriving stock (Generic) 84 | -- deriving anyclass (DecodeRow) 85 | -- @ 86 | class DecodeRow a where 87 | decodeRow :: Row a 88 | default decodeRow :: (Generic a, GDecodeRow (Rep a)) => Row a 89 | decodeRow = to <$> gdecodeRow 90 | 91 | class GDecodeRow a where 92 | gdecodeRow :: Row (a p) 93 | 94 | -- | Determine a result decoder from a Haskell type. 95 | class DecodeResult a where 96 | decodeResult :: Result a 97 | 98 | instance (GDecodeRow a) => GDecodeRow (M1 t i a) where 99 | gdecodeRow = M1 <$> gdecodeRow 100 | 101 | instance (GDecodeRow a, GDecodeRow b) => GDecodeRow (a :*: b) where 102 | gdecodeRow = (:*:) <$> gdecodeRow <*> gdecodeRow 103 | 104 | instance (DecodeField a) => GDecodeRow (K1 i a) where 105 | gdecodeRow = K1 <$> column decodeField 106 | 107 | -- | Parse a postgres @array@ using 'listArray' 108 | instance (DecodeField a) => DecodeValue [a] where 109 | decodeValue = listArray decodeField 110 | 111 | -- | Parse a postgres @array@ using 'vectorArray' 112 | instance (DecodeField a) => DecodeValue (Vector a) where 113 | decodeValue = vectorArray decodeField 114 | 115 | -- | Parse a postgres @bool@ using 'bool' 116 | instance DecodeValue Bool where 117 | decodeValue = bool 118 | 119 | -- | Parse a postgres @text@ using 'text' 120 | instance DecodeValue Text where 121 | decodeValue = text 122 | 123 | -- | Parse a postgres @int2@ using 'int2' 124 | instance DecodeValue Int16 where 125 | decodeValue = int2 126 | 127 | -- | Parse a postgres @int4@ using 'int4' 128 | instance DecodeValue Int32 where 129 | decodeValue = int4 130 | 131 | -- | Parse a postgres @int8@ using 'int8' 132 | instance DecodeValue Int64 where 133 | decodeValue = int8 134 | 135 | -- | Parse a postgres @float4@ using 'float4' 136 | instance DecodeValue Float where 137 | decodeValue = float4 138 | 139 | -- | Parse a postgres @float8@ using 'float8' 140 | instance DecodeValue Double where 141 | decodeValue = float8 142 | 143 | -- | Parse a postgres @char@ using 'char' 144 | instance DecodeValue Char where 145 | decodeValue = char 146 | 147 | -- | Parse a postgres @date@ using 'date' 148 | instance DecodeValue Day where 149 | decodeValue = date 150 | 151 | -- | Parse a postgres @timestamp@ using 'timestamp' 152 | instance DecodeValue LocalTime where 153 | decodeValue = timestamp 154 | 155 | -- | Parse a postgres @timestamptz@ using 'timestamptz' 156 | instance DecodeValue UTCTime where 157 | decodeValue = timestamptz 158 | 159 | -- | Parse a postgres @numeric@ using 'numeric' 160 | instance DecodeValue Scientific where 161 | decodeValue = numeric 162 | 163 | -- | Parse a postgres @interval@ using 'interval' 164 | instance DecodeValue DiffTime where 165 | decodeValue = interval 166 | 167 | -- | Parse a postgres @uuid@ using 'uuid' 168 | instance DecodeValue UUID where 169 | decodeValue = uuid 170 | 171 | -- | Parse a postgres @inet@ using 'inet' 172 | instance DecodeValue IPRange where 173 | decodeValue = inet 174 | 175 | -- | Parse a postgres @bytea@ using 'bytea' 176 | instance DecodeValue ByteString where 177 | decodeValue = bytea 178 | 179 | -- | Parse a postgres @bytea@ using 'bytea' 180 | instance DecodeValue LazyByteString where 181 | decodeValue = LazyByteString.fromStrict <$> bytea 182 | 183 | -- | Overlappable instance for parsing non-nullable values 184 | instance {-# OVERLAPPABLE #-} (DecodeValue a) => DecodeField a where 185 | decodeField = nonNullable decodeValue 186 | 187 | -- | Instance for parsing nullable values 188 | instance (DecodeValue a) => DecodeField (Maybe a) where 189 | decodeField = nullable decodeValue 190 | 191 | -- | Parse any number of rows into a list ('rowList') 192 | instance (DecodeRow a) => DecodeResult [a] where 193 | decodeResult = rowList decodeRow 194 | 195 | -- | Parse any number of rows into a 'Vector' ('rowVector') 196 | instance (DecodeRow a) => DecodeResult (Vector a) where 197 | decodeResult = rowVector decodeRow 198 | 199 | -- | Parse zero or one rows, throw 'Hasql.Errors.UnexpectedAmountOfRows' otherwise. ('rowMaybe') 200 | instance (DecodeRow a) => DecodeResult (Maybe a) where 201 | decodeResult = rowMaybe decodeRow 202 | 203 | -- | Ignore the query response ('noResult') 204 | instance DecodeResult () where 205 | decodeResult = noResult 206 | 207 | $(traverse genDecodeRowInstance [2 .. 16]) 208 | -------------------------------------------------------------------------------- /lib/Hasql/Interpolate/Internal/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE BangPatterns #-} 2 | {-# LANGUAGE BlockArguments #-} 3 | {-# LANGUAGE CPP #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE LambdaCase #-} 6 | {-# LANGUAGE NamedFieldPuns #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeFamilies #-} 10 | 11 | module Hasql.Interpolate.Internal.TH 12 | ( sql, 13 | addParam, 14 | parseSqlExpr, 15 | compileSqlExpr, 16 | SqlExpr (..), 17 | SqlBuilderExp (..), 18 | ParamEncoder (..), 19 | SpliceBind (..), 20 | ) 21 | where 22 | 23 | import Control.Applicative 24 | import Control.Monad (replicateM) 25 | import Control.Monad.State.Strict (State, StateT, execStateT, get, put, state) 26 | import Data.Array (listArray, (!)) 27 | import Data.ByteString.Builder (Builder, stringUtf8) 28 | import Data.Char 29 | import Data.Functor 30 | import Data.Functor.Contravariant 31 | import qualified Data.IntSet as IS 32 | import Data.Monoid (Ap (..)) 33 | import Data.Void 34 | import qualified Hasql.Encoders as E 35 | import Hasql.Interpolate.Internal.Encoder (EncodeField (..)) 36 | import Hasql.Interpolate.Internal.Sql 37 | import Language.Haskell.Meta (parseExp) 38 | import Language.Haskell.TH 39 | import Language.Haskell.TH.Quote 40 | import Text.Megaparsec 41 | ( ParseErrorBundle, 42 | Parsec, 43 | anySingle, 44 | chunk, 45 | eof, 46 | errorBundlePretty, 47 | notFollowedBy, 48 | runParser, 49 | single, 50 | takeWhileP, 51 | try, 52 | ) 53 | 54 | data SqlExpr = SqlExpr 55 | { sqlBuilderExp :: [SqlBuilderExp], 56 | paramEncoder :: [ParamEncoder], 57 | spliceBinds :: [SpliceBind], 58 | bindCount :: Int 59 | } 60 | deriving stock (Show, Eq) 61 | 62 | data SqlBuilderExp 63 | = Sbe'Var Int 64 | | Sbe'Param 65 | | Sbe'Quote String 66 | | Sbe'Ident String 67 | | Sbe'DollarQuote String String 68 | | Sbe'Cquote String 69 | | Sbe'Sql String 70 | deriving stock (Show, Eq) 71 | 72 | data ParamEncoder 73 | = Pe'Exp Exp 74 | | Pe'Var Int 75 | deriving stock (Show, Eq) 76 | 77 | data SpliceBind = SpliceBind 78 | { sbBuilder :: Int, 79 | sbParamEncoder :: Int, 80 | sbExp :: Exp 81 | } 82 | deriving stock (Show, Eq) 83 | 84 | dollar :: Builder 85 | dollar = "$" 86 | 87 | cquote :: Builder 88 | cquote = "E'" 89 | 90 | sq :: Builder 91 | sq = "'" 92 | 93 | dq :: Builder 94 | dq = "\"" 95 | 96 | data ParserState = ParserState 97 | { ps'sqlBuilderExp :: [SqlBuilderExp] -> [SqlBuilderExp], 98 | ps'paramEncoder :: [ParamEncoder] -> [ParamEncoder], 99 | ps'spliceBinds :: [SpliceBind] -> [SpliceBind], 100 | ps'nextUnique :: Int 101 | } 102 | 103 | type Parser a = StateT (ParserState) (Parsec Void String) a 104 | 105 | sqlExprParser :: Parser () 106 | sqlExprParser = go 107 | where 108 | go = 109 | quoted 110 | <|> ident 111 | <|> dollarQuotes 112 | <|> cquoted 113 | <|> param 114 | <|> splice 115 | <|> comment 116 | <|> multilineComment 117 | <|> someSql 118 | <|> eof 119 | 120 | nextUnique :: Parser Int 121 | nextUnique = do 122 | st <- get 123 | let next = ps'nextUnique st 124 | !nextnext = next + 1 125 | put st {ps'nextUnique = nextnext} 126 | pure next 127 | 128 | appendSqlBuilderExp :: SqlBuilderExp -> Parser () 129 | appendSqlBuilderExp x = do 130 | st <- get 131 | put st {ps'sqlBuilderExp = ps'sqlBuilderExp st . (x :)} 132 | 133 | appendEncoder :: ParamEncoder -> Parser () 134 | appendEncoder x = do 135 | st <- get 136 | put st {ps'paramEncoder = ps'paramEncoder st . (x :)} 137 | 138 | addSpliceBinding :: Exp -> Parser () 139 | addSpliceBinding x = do 140 | exprVar <- nextUnique 141 | paramVar <- nextUnique 142 | st <- get 143 | put 144 | st 145 | { ps'spliceBinds = 146 | ps'spliceBinds st 147 | . (SpliceBind {sbBuilder = exprVar, sbParamEncoder = paramVar, sbExp = x} :) 148 | } 149 | appendSqlBuilderExp (Sbe'Var exprVar) 150 | appendEncoder (Pe'Var paramVar) 151 | 152 | comment = do 153 | _ <- chunk "--" 154 | void $ takeWhileP (Just "comment") (/= '\n') 155 | go 156 | 157 | multilineComment = do 158 | multilineCommentBegin 159 | go 160 | 161 | multilineCommentBegin = do 162 | _ <- chunk "/*" 163 | multilineCommentEnd 164 | 165 | multilineCommentEnd = do 166 | void $ takeWhileP (Just "multiline comment") (\c -> c /= '*' && c /= '/') 167 | (multilineCommentBegin >> multilineCommentEnd) <|> void (chunk "*/") <|> (anySingle >> multilineCommentEnd) 168 | 169 | escapedContent name terminal escapeChar escapeParser = 170 | let loop sofar = do 171 | content <- takeWhileP (Just name) (\c -> c /= terminal && c /= escapeChar) 172 | notFollowedBy eof 173 | (try escapeParser >>= \esc -> loop (sofar . (content ++) . (esc ++))) 174 | <|> (single terminal $> sofar content) 175 | in loop id 176 | 177 | betwixt name initial terminal escapeChar escapeParser = do 178 | _ <- chunk initial 179 | escapedContent name terminal escapeChar escapeParser 180 | 181 | quoted = do 182 | content <- betwixt "single quotes" "'" '\'' '\'' (chunk "''") 183 | appendSqlBuilderExp (Sbe'Quote content) 184 | go 185 | 186 | cquoted = do 187 | content <- betwixt "C-style escape quote" "E'" '\'' '\\' do 188 | a <- single '\\' 189 | b <- anySingle 190 | pure [a, b] 191 | appendSqlBuilderExp (Sbe'Cquote content) 192 | go 193 | 194 | ident = do 195 | content <- betwixt "identifier" "\"" '"' '"' (chunk "\"\"") 196 | appendSqlBuilderExp (Sbe'Ident content) 197 | go 198 | 199 | dollarQuotes = do 200 | _ <- single '$' 201 | tag <- takeWhileP (Just "identifier") isAlphaNum 202 | _ <- single '$' 203 | let bonk sofar = do 204 | notFollowedBy eof 205 | c <- takeWhileP (Just "dollar quoted content") (/= '$') 206 | (parseEndQuote $> (sofar . (c ++))) <|> bonk (sofar . (c ++)) 207 | parseEndQuote = do 208 | _ <- single '$' 209 | _ <- chunk tag 210 | void $ single '$' 211 | content <- ($ "") <$> bonk id 212 | appendSqlBuilderExp (Sbe'DollarQuote tag content) 213 | go 214 | 215 | param = do 216 | _ <- chunk "#{" 217 | content <- takeWhileP (Just "parameter") (/= '}') 218 | _ <- single '}' 219 | alpha <- 220 | case parseExp content of 221 | Left err -> fail err 222 | Right x -> pure x 223 | appendEncoder (Pe'Exp alpha) 224 | appendSqlBuilderExp Sbe'Param 225 | go 226 | 227 | splice = do 228 | _ <- chunk "^{" 229 | content <- takeWhileP (Just "splice") (/= '}') 230 | _ <- single '}' 231 | alpha <- 232 | case parseExp content of 233 | Left err -> fail err 234 | Right x -> pure x 235 | addSpliceBinding alpha 236 | go 237 | 238 | breakCharsIS = IS.fromList (map fromEnum breakChars) 239 | breakChars = 240 | [ '\'', 241 | 'E', 242 | '"', 243 | '#', 244 | '^', 245 | '$', 246 | '-', 247 | '/' 248 | ] 249 | 250 | someSql = do 251 | s <- anySingle 252 | content <- takeWhileP (Just "sql") (\c -> IS.notMember (fromEnum c) breakCharsIS) 253 | appendSqlBuilderExp (Sbe'Sql (s : content)) 254 | go 255 | 256 | addParam :: State Int Builder 257 | addParam = state \i -> 258 | let !i' = i + 1 259 | in (dollar <> stringUtf8 (show i), i') 260 | 261 | parseSqlExpr :: String -> Either (ParseErrorBundle String Void) SqlExpr 262 | parseSqlExpr str = do 263 | ps <- runParser (execStateT sqlExprParser (ParserState id id id 0)) "" str 264 | pure 265 | SqlExpr 266 | { sqlBuilderExp = ps'sqlBuilderExp ps [], 267 | paramEncoder = ps'paramEncoder ps [], 268 | spliceBinds = ps'spliceBinds ps [], 269 | bindCount = ps'nextUnique ps 270 | } 271 | 272 | -- | QuasiQuoter that supports interpolation and splices. Produces a 273 | -- 'Sql'. 274 | -- 275 | -- @#{..}@ interpolates a haskell expression into a sql query. 276 | -- 277 | -- @ 278 | -- example1 :: EncodeValue a => a -> Sql 279 | -- example1 x = [sql| select \#{x} |] 280 | -- @ 281 | -- 282 | -- @^{..}@ introduces a splice, which allows us to inject a sql 283 | -- snippet along with the associated parameters into another sql 284 | -- snippet. 285 | -- 286 | -- @ 287 | -- example2 :: Sql 288 | -- example2 = [sql| ^{example1 True} where true |] 289 | -- @ 290 | sql :: QuasiQuoter 291 | sql = 292 | QuasiQuoter 293 | { quoteExp = \str -> do 294 | case parseSqlExpr str of 295 | Left err -> fail (errorBundlePretty err) 296 | Right sqlExpr -> compileSqlExpr sqlExpr, 297 | quotePat = undefined, 298 | quoteType = undefined, 299 | quoteDec = undefined 300 | } 301 | 302 | compileSqlExpr :: SqlExpr -> Q Exp 303 | compileSqlExpr (SqlExpr sqlBuilder enc spliceBindings bindCount) = do 304 | nameArr <- listArray (0, bindCount - 1) <$> replicateM bindCount (newName "x") 305 | let spliceDecs = 306 | map 307 | ( \SpliceBind {sbBuilder, sbParamEncoder, sbExp} -> 308 | ValD (conP_compat 'Sql (map VarP [nameArr ! sbBuilder, nameArr ! sbParamEncoder])) (NormalB sbExp) [] 309 | ) 310 | spliceBindings 311 | sqlBuilderExp <- 312 | let go a b = case a of 313 | Sbe'Var i -> [e|Ap $(varE (nameArr ! i)) <> $b|] 314 | Sbe'Param -> [e|Ap addParam <> $b|] 315 | Sbe'Quote content -> [e|pure (sq <> stringUtf8 content <> sq) <> $b|] 316 | Sbe'Ident content -> [e|pure (dq <> stringUtf8 content <> dq) <> $b|] 317 | Sbe'DollarQuote tag content -> [e|pure (dollar <> stringUtf8 tag <> dollar <> stringUtf8 content <> dollar <> stringUtf8 tag <> dollar) <> $b|] 318 | Sbe'Cquote content -> [e|pure (cquote <> content <> sq) <> $b|] 319 | Sbe'Sql content -> [e|pure (stringUtf8 content) <> $b|] 320 | in foldr go [e|pure mempty|] sqlBuilder 321 | encExp <- 322 | let go a b = case a of 323 | Pe'Exp x -> [e|($(pure x) >$ E.param encodeField) <> $b|] 324 | Pe'Var x -> [e|$(varE (nameArr ! x)) <> $b|] 325 | in foldr go [e|E.noParams|] enc 326 | body <- [e|Sql (getAp $(pure sqlBuilderExp)) $(pure encExp)|] 327 | pure case spliceDecs of 328 | [] -> body 329 | _ -> LetE spliceDecs body 330 | 331 | -- In template-haskell-2.18.0.0, the ConP constructor grew a new [Type] field for matching with type applications. 332 | conP_compat :: Name -> [Pat] -> Pat 333 | #if MIN_VERSION_template_haskell(2,18,0) 334 | conP_compat name fields = ConP name [] fields 335 | #else 336 | conP_compat name fields = ConP name fields 337 | #endif 338 | --------------------------------------------------------------------------------