diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,27 @@ # Revision history for sqlc-haskell +## 0.3.0.0 -- 2026-08-20 + +* A hasql backend for PostgreSQL, selected with the new `driver` option + (`driver: hasql`). The default stays `postgresql-simple`, so existing + configurations generate the same code as before. Requires hasql >= 1.10. + The generated internal module declares the `ToRow`/`FromRow` and + `ToField`/`FromField` classes hasql does not ship, and overrides can name + their codecs with the new `hasql_encoder` and `hasql_decoder` keys. +* Normalise numbered `?N` placeholders (emitted by sqlc for `sqlc.arg`) + to positional `?` so sqlite-simple can parse the query (SQLite). +* The hasql runners' error type is named through a `RunnerError` alias + that CPP picks per hasql version, so the generated module compiles + against both hasql 2.0 (`SessionError`) and hasql 2.1, which replaced + it with `UseError` (hasql). +* The generated hasql `ToRow`/`FromRow` instances carry `INLINE`. A row + decoder is a chain of `<$>` and `<*>`, and without an unfolding at the + instance that chain cannot collapse at its definition site, so every + column of every row pays for the closures it is made of. Pairs with + nikita-volkov/hasql#340, which fixes the same problem inside hasql; + together they cut allocation for a 1001-row two-column decode by + 10.2% (hasql). + ## 0.2.0.1 -- 2026-07-14 * Mustache-style naming templates for generated declarations. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ A Haskell code generator plugin for [sqlc](https://github.com/kyleconroy/sqlc), allowing you to generate idiomatic Haskell types and functions directly from your SQL queries. -It leverages [postgresql-simple](https://hackage.haskell.org/package/postgresql-simple), [mysql-simple](https://hackage.haskell.org/package/mysql-simple), and [sqlite-simple](https://hackage.haskell.org/package/sqlite-simple), generating a thin layer on top of these well-known libraries. +It leverages [postgresql-simple](https://hackage.haskell.org/package/postgresql-simple), [hasql](https://hackage.haskell.org/package/hasql), [mysql-simple](https://hackage.haskell.org/package/mysql-simple), and [sqlite-simple](https://hackage.haskell.org/package/sqlite-simple), generating a thin layer on top of these well-known libraries. ## Installation @@ -67,6 +67,136 @@ type: Data.ByteString.ByteString ``` +## Drivers + +`driver` selects the Haskell library the generated code is written against. +Every engine has a default, so configurations that don't set it keep generating +exactly the code they did before. + +| Engine | `driver` | Default | +| ------------ | ---------------------------- | ------------------- | +| `postgresql` | `postgresql-simple`, `hasql` | `postgresql-simple` | +| `mysql` | `mysql-simple` | `mysql-simple` | +| `sqlite` | `sqlite-simple` | `sqlite-simple` | + +```yaml +sql: + - engine: postgresql + queries: query.sql + schema: schema.sql + codegen: + - out: gen + plugin: haskell + options: + driver: hasql + cabal_package_name: your-package +``` + +### The hasql driver + +Requires **hasql >= 1.10**, 2.x included. The generated cabal file depends on +`hasql` without a version bound, like every other dependency it emits, so an +older `hasql` pinned elsewhere in your project shows up as a compile error +rather than a solver one. + +The generated `Queries.Internal` module gives every query the same helpers as +the other drivers do — `exec`, `execRows`, `execResult`, `queryOne`, +`queryMany`, `fold` and `execMany` — taking a `Hasql.Connection.Connection` and +returning `IO (Either Hasql.Errors.SessionError a)`: + +```haskell +users <- queryMany connection query_ListUsers Params_ListUsers {age = 42} +``` + +Each of those runs its query in a session of its own. Every one also comes as a +`…Session` variant returning a `Hasql.Session.Session`, for when several +queries have to share one session: + +```haskell +result <- + Hasql.Connection.use connection $ do + _ <- execSession query_InsertAuthor (Params_InsertAuthor {name = "Kafka"}) + queryManySession query_ListAuthors Params_ListAuthors {} +``` + +Two things work differently from the postgresql-simple driver: + +* `fold`'s step function is pure (`a -> Result name -> a`) — hasql folds a + result without `IO`. +* `sqlc.slice` parameters are bound as one array parameter, which PostgreSQL + only accepts with the array operators, so `IN ($1)` is generated as + `= ANY ($1)` and `NOT IN ($1)` as `<> ALL ($1)`. A slice used anywhere else + is an error; write `= ANY(sqlc.arg(...)::type[])` in your SQL instead of + using `sqlc.slice`. + +#### Codecs + +hasql has no `ToField`-style class. Its encoders and decoders are values, chosen +per SQL type, and from 1.10 on it checks that a column's type matches the +decoder reading it — so `text`, `varchar` and `bpchar`, all `Text` on the +Haskell side, each need their own decoder. sqlc-hs picks the codec from the SQL +type sqlc reported, for every type it knows. + +Columns typed by an `overrides` entry are a different matter: sqlc-hs cannot +know what codec your type wants. Those go through the `ToField` and `FromField` +classes that the generated `Queries.Internal` module declares: + +```haskell +class ToField a where toField :: Hasql.Encoders.Value a +class FromField a where fromField :: Hasql.Decoders.Value a +``` + +Instances ship for `Bool`, the sized `Int`s, `Float`, `Double`, `Scientific`, +`Char`, `Text`, `ByteString`, `UUID`, `Day`, `LocalTime`, `UTCTime`, +`TimeOfDay`, `(TimeOfDay, TimeZone)`, `DiffTime`, `Data.Aeson.Value`, and lists +and vectors of those. The usual overrides therefore need nothing extra — a +`uuid` column mapped to `Data.UUID.UUID`, a `timestamptz` to `UTCTime`, a `date` +to `Day` all work as they stand. For a type of your own, write the instance: + +```haskell +instance ToField UserId where + toField = Data.Functor.Contravariant.contramap unUserId toField + +instance FromField UserId where + fromField = fmap UserId fromField +``` + +When an instance is the wrong place for it, because the same Haskell type wants +different codecs in different columns, an override can name the codecs itself +with `hasql_encoder` and `hasql_decoder`. `UTCTime`'s instance is +`timestamptz`, so a `timestamp` column read as a `UTCTime` has to spell out the +conversion: + +```yaml +overrides: + - db_type: pg_catalog.timestamp + haskell_type: + package: time + module: Data.Time + type: Data.Time.UTCTime + hasql_encoder: Data.Functor.Contravariant.contramap (Data.Time.utcToLocalTime Data.Time.utc) Hasql.Encoders.timestamp + hasql_decoder: fmap (Data.Time.localTimeToUTC Data.Time.utc) Hasql.Decoders.timestamp +``` + +Both are Haskell expressions spliced into the generated code, and both have to +be given together. + +Enum codecs are generated into `Queries.Types` from the catalog, so enums need +nothing either. + +#### Limitations + +* `money` and `name` columns cannot be typed: hasql ships no codec for either, + so sqlc-hs reports them as unresolved rather than generating a decoder that + fails against the server. To use one anyway, give it an override whose + `hasql_encoder`/`hasql_decoder` are built with `Hasql.Encoders.custom` and + `Hasql.Decoders.custom`. +* A value cannot be decoded from a SQL type it is not stored as. + postgresql-simple parses the text form, so `CAST(created_at AS TEXT)` can be + read as a `UTCTime` (see the override examples below); hasql decodes the + binary form and checks the column's type, so the SQL type and the codec have + to agree. + ## Overrides `overrides` is a **list** of mappings — each entry tells sqlc-hs to map a @@ -84,6 +214,8 @@ | `column` | no* | Match a specific column: `column`, `table.column` or `schema.table.column`. The table part matches the table name or its query alias; a bare `column` also matches aliased expression outputs (e.g. `CAST(... AS TEXT) AS created_at`), which carry no table. | | `engine` | no | Restrict the override to a specific engine (`postgresql`, `mysql`, or `sqlite`). Useful when one configuration targets multiple engines. | | `nullable` | no | If `true`, only match columns that are nullable. If `false` or omitted, only match columns that are `NOT NULL`. | +| `hasql_encoder` | no | hasql only: the `Hasql.Encoders.Value` expression to encode matching columns with. Must be given together with `hasql_decoder`. See [The hasql driver](#the-hasql-driver). | +| `hasql_decoder` | no | hasql only: the `Hasql.Decoders.Value` expression to decode matching columns with. Must be given together with `hasql_encoder`. | \* At least one of `db_type` or `column` must be given. When both are given, both must match. diff --git a/sqlc-hs.cabal b/sqlc-hs.cabal --- a/sqlc-hs.cabal +++ b/sqlc-hs.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: sqlc-hs -version: 0.2.0.1 +version: 0.3.0.0 -- synopsis: -- description: @@ -16,13 +16,14 @@ description: A Haskell code generator plugin for sqlc, allowing you to generate idiomatic Haskell types and functions directly from your SQL queries. - It leverages postgresql-simple, mysql-simple, and sqlite-simple, generating a thin layer on top of these well-known libraries. + It leverages postgresql-simple, hasql, mysql-simple, and sqlite-simple, generating a thin layer on top of these well-known libraries. -- copyright: build-type: Simple extra-doc-files: CHANGELOG.md extra-source-files: README.md + templates/internal.hasql.hs.jinja templates/internal.mysql.hs.jinja templates/internal.postgresql.hs.jinja templates/internal.sqlite.hs.jinja @@ -78,6 +79,7 @@ library import: stuff exposed-modules: + Sqlc.Hs.Backend Sqlc.Hs.Codegen Sqlc.Hs.Config Sqlc.Hs.Main diff --git a/src/Sqlc/Hs/Backend.hs b/src/Sqlc/Hs/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Sqlc/Hs/Backend.hs @@ -0,0 +1,70 @@ +-- | The database library the generated code is written against. +-- +-- sqlc tells us the /engine/ (@postgresql@, @mysql@, @sqlite@); the @driver@ +-- configuration option picks between the libraries available for it. Only +-- PostgreSQL currently has more than one. +module Sqlc.Hs.Backend + ( Backend (..), + resolveBackend, + ) +where + +import Data.List (lookup) +import Data.Text qualified + +data Backend + = -- | + PostgresqlSimple + | -- | + Hasql + | -- | + Sqlite + | -- | + Mysql + deriving stock (Eq, Show) + +-- | Pick the backend for an engine and a configured driver. +-- +-- The engine comes from the 'GenerateRequest' settings. sqlc always reports one; +-- 'Nothing' stands for a request that didn't, where there is nothing to pick +-- from and we keep to what sqlc-hs has always generated for it: the +-- postgresql-simple internal module, and no per-query instances. +resolveBackend :: + -- | Engine, e.g. @postgresql@. May be empty. + Text -> + -- | The @driver@ option, if configured. + Maybe Text -> + Either Text (Maybe Backend) +resolveBackend engine driver = + case driver of + Nothing + | engine == mempty -> + Right Nothing + | otherwise -> + Right (Just defaultBackend) + Just driver + | Just backend <- lookup driver drivers -> + Right (Just backend) + | otherwise -> + Left $ + "Unknown driver " + <> show driver + <> " for engine " + <> show engine + <> ". Valid drivers are: " + <> Data.Text.intercalate ", " (map fst drivers) + <> "." + where + -- The drivers available for this engine, the default one first. + (defaultBackend, drivers) = + case engine of + "sqlite" -> + (Sqlite, [("sqlite-simple", Sqlite)]) + "mysql" -> + (Mysql, [("mysql-simple", Mysql)]) + _ -> + ( PostgresqlSimple, + [ ("postgresql-simple", PostgresqlSimple), + ("hasql", Hasql) + ] + ) diff --git a/src/Sqlc/Hs/Codegen.hs b/src/Sqlc/Hs/Codegen.hs --- a/src/Sqlc/Hs/Codegen.hs +++ b/src/Sqlc/Hs/Codegen.hs @@ -10,7 +10,8 @@ import Data.List (lookup) import Data.ProtoLens.Labels () import Proto.Protos.Codegen qualified -import Sqlc.Hs.Config (Config (..), HaskellType (..)) +import Sqlc.Hs.Backend (Backend (..), resolveBackend) +import Sqlc.Hs.Config (Config (..), HaskellType (..), Override (..)) import Sqlc.Hs.Resolve ( ResolveName, ResolveType, @@ -18,12 +19,16 @@ determineInternalModule, determineTopLevelModule, determineTypesModule, + findOverride, + hasqlColumnCodec, mangleQuery, + newBuiltinResolver, newEnumResolver, - newResolveType, + newOverrideResolver, queryParamBindings, resolveQueryName, resolveType, + rewriteSlices, ) import System.Exit qualified import System.IO qualified @@ -50,16 +55,26 @@ codegen :: Config -> Proto.Protos.Codegen.GenerateRequest -> IO [File] codegen config generateRequest = do + backend <- + case resolveBackend engine config.driver of + Left errorMessage -> do + System.IO.hPutStrLn System.IO.stderr (toString errorMessage) + System.Exit.exitWith (System.Exit.ExitFailure 1) + Right backend -> + pure backend + typesModule <- codegenTypes - (generateRequest ^. #settings . #engine) + backend internalName typesName resolveName + (generateRequest ^. #catalog . #defaultSchema) (generateRequest ^. #catalog . #schemas) let resolveType = - newResolveType config (generateRequest ^. #settings . #engine) + newOverrideResolver config engine + <> newBuiltinResolver backend engine <> newEnumResolver ( HaskellType { module' = Just typesModule.name, @@ -75,7 +90,9 @@ modules <- traverse ( codegenQuery - (generateRequest ^. #settings . #engine) + backend + engine + (findOverride config engine) internalName resolveName resolveType @@ -86,7 +103,7 @@ codegenToplevel toplevelName internalName typesName modules internalModule <- - codegenInternal (generateRequest ^. #settings . #engine) internalName + codegenInternal backend internalName let generatedModules = toplevelModule : typesModule : internalModule : modules @@ -96,6 +113,9 @@ pure (cabalPackageFile <> map moduleToFile generatedModules) where + engine = + generateRequest ^. #settings . #engine + resolveName = resolveQueryName config.naming config.haskellModulePrefix @@ -149,11 +169,11 @@ error (show errorDoc) codegenInternal :: - Text -> + Maybe Backend -> -- | ResolvedName of the internal module name ResolvedNames -> IO Module -codegenInternal engine internal = do +codegenInternal backend internal = do let context = Text.EDE.fromPairs [ "moduleName" Text.EDE..= internal.toHaskellModuleName @@ -173,20 +193,35 @@ } where (template, dependencies) = - case engine of - "sqlite" -> + case backend of + Just Sqlite -> ( internalSqliteTemplate, [ HaskellType {package = Just "sqlite-simple", module' = Just "Database.SQLite.Simple", name = Just "ToRow"}, HaskellType {package = Just "sqlite-simple", module' = Just "Database.SQLite.Simple", name = Just "FromRow"}, HaskellType {package = Just "vector", module' = Just "Data.Vector", name = Just "Vector"} ] ) - "mysql" -> + Just Mysql -> ( internalMysqlTemplate, [ HaskellType {package = Just "mysql-simple", module' = Just "Database.MySQL.Simple", name = Just "ToRow"}, HaskellType {package = Just "mysql-simple", module' = Just "Database.MySQL.Simple", name = Just "FromRow"} ] ) + Just Hasql -> + ( internalHasqlTemplate, + -- The ToField/FromField instances the internal module ships cover + -- the types the built-in mappings and the common overrides use. + -- Every one of these packages is already in hasql's own dependency + -- closure, so none of them costs an extra build. + [ HaskellType {package = Just "hasql", module' = Just "Hasql.Session", name = Just "Session"}, + HaskellType {package = Just "aeson", module' = Just "Data.Aeson", name = Just "Value"}, + HaskellType {package = Just "scientific", module' = Just "Data.Scientific", name = Just "Scientific"}, + HaskellType {package = Just "time", module' = Just "Data.Time", name = Just "UTCTime"}, + HaskellType {package = Just "uuid", module' = Just "Data.UUID", name = Just "UUID"}, + HaskellType {package = Just "vector", module' = Just "Data.Vector", name = Just "Vector"} + ] + ) + -- Also the fallback for a request that reported no engine at all. _ -> ( internalPostgresTemplate, [ HaskellType {package = Just "postgresql-simple", module' = Just "Database.PostgreSQL.Simple", name = Just "ToRow"}, @@ -253,26 +288,29 @@ sort (ordNub config.cabalDefaultExtensions) codegenTypes :: - -- | Engine, if defined - Text -> + Maybe Backend -> -- | ResolvedName of the internal module ResolvedNames -> -- | ResolvedName of the types module ResolvedNames -> ResolveName -> + -- | The catalog's default schema, if reported + Text -> [Proto.Protos.Codegen.Schema] -> IO Module -codegenTypes engine internalModule typesModule resolveName schemas = do +codegenTypes backend internalModule typesModule resolveName defaultSchema schemas = do let context = Text.EDE.fromPairs - [ "generatePostgresql" Text.EDE..= (engine == "postgresql"), - "generateSqlite" Text.EDE..= (engine == "sqlite"), - "generateMysql" Text.EDE..= (engine == "mysql"), + [ "generatePostgresql" Text.EDE..= (backend == Just PostgresqlSimple), + "generateHasql" Text.EDE..= (backend == Just Hasql), + "generateSqlite" Text.EDE..= (backend == Just Sqlite), + "generateMysql" Text.EDE..= (backend == Just Mysql), "moduleName" Text.EDE..= typesModule.toHaskellModuleName, "internalModuleName" Text.EDE..= internalModule.toHaskellModuleName, "enums" Text.EDE..= [ Text.EDE.fromPairs [ "escapedEnumName" Text.EDE..= show @Text (enum ^. #name), + "escapedEnumSchema" Text.EDE..= enumSchema (schema ^. #name), "values" Text.EDE..= [ Text.EDE.fromPairs [ "escapedEnumValue" Text.EDE..= show @Text value, @@ -297,6 +335,20 @@ contents = contents context } where + -- hasql resolves an enum's OID by name at runtime. An unqualified name is + -- looked up through the search path, which is what we want for the default + -- schema; anything else has to be qualified. + enumSchema :: Text -> Text + enumSchema schema + | schema == mempty || schema == defaultSchemaName = + "Prelude.Nothing" + | otherwise = + "(Prelude.Just " <> show @Text schema <> ")" + + defaultSchemaName + | defaultSchema == mempty = "public" + | otherwise = defaultSchema + contents context = case Text.EDE.render typesTemplate context of Text.EDE.Success output -> @@ -307,15 +359,18 @@ -- | Generate a file for a single query. This returns the resolved 'HaskellType's so -- that we can generate the necessary build-depends for the cabal file. codegenQuery :: + Maybe Backend -> -- | Engine, if defined Text -> + -- | The override that matched a column, if any. Determines the hasql codec. + (Proto.Protos.Codegen.Column -> Maybe Override) -> -- | ResolvedName of the internal module name ResolvedNames -> ResolveName -> ResolveType -> Proto.Protos.Codegen.Query -> IO Module -codegenQuery engine internalModule resolveName resolver query = do +codegenQuery backend engine resolveOverride internalModule resolveName resolver query = do let resolvedName = resolveName (query ^. #name) @@ -331,12 +386,37 @@ whenNothing (resolveType resolver column) $ couldNotResolveType column + sql <- + case backend of + -- hasql speaks PostgreSQL's own numbered placeholders, so the SQL is + -- passed through as sqlc emitted it. Slices are the exception: they + -- become a single array parameter and need the array operators. + Just Hasql -> + case rewriteSlices (sliceNumbers parameterColumns) (query ^. #text) of + Left errorMessage -> do + System.IO.hPutStrLn System.IO.stderr $ + "In query " + <> show (query ^. #name) + <> ": " + <> toString errorMessage + System.Exit.exitWith (System.Exit.ExitFailure 1) + Right sql -> + pure sql + _ -> + pure (mangleQuery (query ^. #text)) + let importedTypes :: [HaskellType] importedTypes = foldMap (toList . snd . snd) parameterColumns <> foldMap (toList . snd) resultColumns <> [ HaskellType {package = Just "base", module' = Just "Data.Foldable", name = Nothing} ] + <> case backend of + -- The parameter encoders are assembled contravariantly. + Just Hasql -> + [HaskellType {package = Just "base", module' = Just "Data.Functor.Contravariant", name = Nothing}] + _ -> + [] -- Modules that the query module needs to import. imports :: [Text] @@ -346,9 +426,10 @@ context = Text.EDE.fromPairs - [ "generatePostgresql" Text.EDE..= (engine == "postgresql"), - "generateSqlite" Text.EDE..= (engine == "sqlite"), - "generateMysql" Text.EDE..= (engine == "mysql"), + [ "generatePostgresql" Text.EDE..= (backend == Just PostgresqlSimple), + "generateHasql" Text.EDE..= (backend == Just Hasql), + "generateSqlite" Text.EDE..= (backend == Just Sqlite), + "generateMysql" Text.EDE..= (backend == Just Mysql), "sourceFile" Text.EDE..= (query ^. #filename), "moduleName" Text.EDE..= resolvedName.toHaskellModuleName, "moduleImports" Text.EDE..= imports, @@ -359,9 +440,10 @@ "haskellResultName" Text.EDE..= resolvedName.toResultConstructorDeclarationName, "escapedQueryName" Text.EDE..= show @Text (query ^. #name), "escapedCommand" Text.EDE..= show @Text (query ^. #cmd), - "escapedSql" Text.EDE..= show @Text mangledQuery, + "escapedSql" Text.EDE..= show @Text sql, "parameterColumns" Text.EDE..= fmap (toParameterColumn . snd) parameterColumns, "queryColumns" Text.EDE..= fmap toParameterColumn (toQueryColumns parameterColumns), + "encoderColumns" Text.EDE..= fmap (toParameterColumn . snd) (sortOn fst parameterColumns), "resultColumns" Text.EDE..= fmap toResultColumn resultColumns ] @@ -373,8 +455,11 @@ contents = contents context } where - mangledQuery = - mangleQuery (query ^. #text) + sliceNumbers parameterColumns = + [ fromIntegral number + | (number, (column, _haskellTypes)) <- parameterColumns, + column ^. #isSqlcSlice + ] -- It's possible for parametes to appear in a query more than once. -- This function "zips" the occurrences in the query with the actual @@ -399,6 +484,7 @@ [ "name" Text.EDE..= (resolveName (column ^. #name)).toFieldName column, "type" Text.EDE..= encodeColumnType haskellType, "notNull" Text.EDE..= (column ^. #notNull), + "encoder" Text.EDE..= fst (hasqlCodec column), "slice" Text.EDE..= if column ^. #isSqlcSlice then Just (show @Text ("/*SLICE:" <> column ^. #name <> "*/?")) @@ -408,9 +494,16 @@ toResultColumn (column, haskellType :| _) = Text.EDE.fromPairs [ "name" Text.EDE..= (resolveName (column ^. #name)).toFieldName column, - "type" Text.EDE..= encodeColumnType haskellType + "type" Text.EDE..= encodeColumnType haskellType, + "decoder" Text.EDE..= snd (hasqlCodec column) ] + -- Only the hasql templates read the "encoder" and "decoder" fields. + hasqlCodec column = + case backend of + Just Hasql -> hasqlColumnCodec (resolveOverride column) column + _ -> (mempty, mempty) + encodeColumnType haskellType = haskellType.name @@ -445,6 +538,10 @@ internalSqliteTemplate :: Text.EDE.Template internalSqliteTemplate = toTemplate $(Data.FileEmbed.embedFile "templates/internal.sqlite.hs.jinja") + +internalHasqlTemplate :: Text.EDE.Template +internalHasqlTemplate = + toTemplate $(Data.FileEmbed.embedFile "templates/internal.hasql.hs.jinja") cabalTemplate :: Text.EDE.Template cabalTemplate = diff --git a/src/Sqlc/Hs/Config.hs b/src/Sqlc/Hs/Config.hs --- a/src/Sqlc/Hs/Config.hs +++ b/src/Sqlc/Hs/Config.hs @@ -33,7 +33,10 @@ -- concatenation. No need to create a one big vector. overrides :: [Vector Override], -- | Templates for the names of generated declarations. - naming :: Naming + naming :: Naming, + -- | The database library to generate against, e.g. @hasql@. Which drivers + -- are available depends on the engine; see 'Sqlc.Hs.Backend.resolveBackend'. + driver :: Maybe Text } instance Semigroup Config where @@ -50,7 +53,9 @@ overrides = config1.overrides <> config2.overrides, naming = - config1.naming <> config2.naming + config1.naming <> config2.naming, + driver = + getFirst $ First config1.driver <> First config2.driver } instance Monoid Config where @@ -61,7 +66,8 @@ cabalPackageName = Nothing, cabalPackageVersion = Nothing, cabalDefaultExtensions = [], - naming = mempty + naming = mempty, + driver = Nothing } instance FromJSON Config where @@ -73,6 +79,7 @@ <*> o .:? "haskell_module_prefix" <*> fmap pure (o .:? "overrides" .!= mempty) <*> o .:? "naming" .!= mempty + <*> o .:? "driver" -- | Mustache-style templates for the names of generated declarations. Every -- field is optional; an omitted template falls back to the default that @@ -143,7 +150,15 @@ -- | For global overrides only when two different engines are in use. engine :: Maybe Text, -- | True if the haskellType should override if the matching type is nullable - nullable :: Maybe Bool + nullable :: Maybe Bool, + -- | Encoder expression to use for matching columns, e.g. + -- @Hasql.Encoders.timestamp@. hasql only; must be given together with + -- 'hasqlDecoder'. Without them a matched column goes through the generated + -- @ToField@/@FromField@ classes. + hasqlEncoder :: Maybe Text, + -- | Decoder expression to use for matching columns, e.g. + -- @Hasql.Decoders.timestamp@. See 'hasqlEncoder'. + hasqlDecoder :: Maybe Text } instance FromJSON Override where @@ -160,8 +175,12 @@ <*> o .:? "column" <*> o .:? "engine" <*> o .:? "nullable" + <*> o .:? "hasql_encoder" + <*> o .:? "hasql_decoder" when (isNothing override.databaseType && isNothing override.column) $ fail "override requires at least one of \"db_type\" or \"column\"" + when (isJust override.hasqlEncoder /= isJust override.hasqlDecoder) $ + fail "override requires either both or neither of \"hasql_encoder\" and \"hasql_decoder\"" pure override -- | A haskell type denotes a fully qualified data type with module @@ -205,5 +224,6 @@ cabalPackageVersion = Just "0.1.0.0", cabalDefaultExtensions = [], haskellModulePrefix = Just "Queries", - overrides = [] + overrides = [], + driver = Nothing } diff --git a/src/Sqlc/Hs/Resolve.hs b/src/Sqlc/Hs/Resolve.hs --- a/src/Sqlc/Hs/Resolve.hs +++ b/src/Sqlc/Hs/Resolve.hs @@ -1,8 +1,10 @@ module Sqlc.Hs.Resolve ( ResolveType, resolveType, - newResolveType, + newOverrideResolver, + newBuiltinResolver, newEnumResolver, + findOverride, -- | How to resolve names to Haskell modules and files ResolveName, ResolvedNames (..), @@ -14,6 +16,9 @@ -- | Query mangling mangleQuery, queryParamBindings, + rewriteSlices, + -- | hasql codecs + hasqlColumnCodec, ) where @@ -23,6 +28,7 @@ import Data.Text qualified import Data.Vector (Vector) import Proto.Protos.Codegen qualified +import Sqlc.Hs.Backend (Backend (..)) import Sqlc.Hs.Config (Config (..), HaskellType (..), Naming (..), Override (..), defaultConfig) import Sqlc.Hs.NameTemplate qualified import System.FilePath ((<.>)) @@ -257,12 +263,44 @@ resolveType :: ResolveType -> Proto.Protos.Codegen.Column -> Maybe (Proto.Protos.Codegen.Column, NonEmpty HaskellType) resolveType = coerce -newResolveType :: +-- | The user's @overrides@, in configuration order. +newOverrideResolver :: Config -> -- | Engine, if defined Text -> ResolveType -newResolveType config engine = ResolveType $ \column -> +newOverrideResolver config engine = + fromMatchers engine (map overrideToMatcher (configOverrides config)) + +-- | The type mappings sqlc-hs knows out of the box. +newBuiltinResolver :: + Maybe Backend -> + -- | Engine, if defined + Text -> + ResolveType +newBuiltinResolver backend engine = + fromMatchers engine (builtins backend) + +-- | The first override matching a column, if any. 'newOverrideResolver' tells +-- you /that/ an override matched; this tells you /which/ one, which is what +-- carries the hasql codecs. +findOverride :: + Config -> + -- | Engine, if defined + Text -> + Proto.Protos.Codegen.Column -> + Maybe Override +findOverride config engine column = + find + (\override -> matchesEngine engine override.engine && overrideMatches override column) + (configOverrides config) + +configOverrides :: Config -> [Override] +configOverrides config = + toList (Overrides config.overrides) + +fromMatchers :: Text -> [Matcher] -> ResolveType +fromMatchers engine allMatchers = ResolveType $ \column -> case mapMaybe (\matcher -> matcher.matcher column) matchers of haskellTypes : _ -> Just (column, haskellTypes) @@ -271,20 +309,22 @@ where matchers :: [Matcher] matchers = - [ matcher - | matcher <- - concat - [ map overrideToMatcher (toList (Overrides config.overrides)), - builtins - ], - -- In case the GenerateRequest didn't specify an engine. - engine == mempty - -- In case the matcher is engine generic - || isNothing matcher.engine - -- In case matcher engine and requested engine match - || matcher.engine == Just engine - ] + filter (matchesEngine engine . (.engine)) allMatchers +matchesEngine :: + -- | The requested engine, if defined + Text -> + -- | The engine a matcher is restricted to, if any + Maybe Text -> + Bool +matchesEngine engine matcherEngine = + -- In case the GenerateRequest didn't specify an engine. + engine == mempty + -- In case the matcher is engine generic + || isNothing matcherEngine + -- In case matcher engine and requested engine match + || matcherEngine == Just engine + newEnumResolver :: HaskellType -> [Proto.Protos.Codegen.Enum] -> @@ -321,24 +361,29 @@ haskellType {name = fmap wrapParenthesis haskellType.name} :| haskellTypes - -- Every constraint present on the override must hold: db_type (if given) - -- and column (if given). The FromJSON instance guarantees at least one of - -- the two is set, so this can never match unconditionally. matchType column - | fromMaybe False override.nullable /= not (column ^. #notNull) = - Nothing - | matchesDatabaseType column, - matchesColumn column = + | overrideMatches override column = Just override.haskellType | otherwise = Nothing - matchesDatabaseType column = +-- | Every constraint present on the override must hold: db_type (if given) and +-- column (if given). The FromJSON instance guarantees at least one of the two +-- is set, so this can never match unconditionally. +overrideMatches :: Override -> Proto.Protos.Codegen.Column -> Bool +overrideMatches override column = + and + [ fromMaybe False override.nullable == not (column ^. #notNull), + matchesDatabaseType, + matchesColumn + ] + where + matchesDatabaseType = case override.databaseType of Nothing -> True Just databaseType -> columnDataType (column ^. #type') == databaseType - matchesColumn column = + matchesColumn = case override.column of Nothing -> True Just name -> columnMatches name column @@ -391,9 +436,9 @@ Nothing } -builtins :: [Matcher] -builtins = - [ Matcher {engine = Just "postgresql", matcher = postgresBuiltin}, +builtins :: Maybe Backend -> [Matcher] +builtins backend = + [ Matcher {engine = Just "postgresql", matcher = postgresBuiltin backend}, Matcher {engine = Just "mysql", matcher = mysqlBuiltin}, Matcher {engine = Just "sqlite", matcher = sqliteBuiltin} ] @@ -687,8 +732,8 @@ | otherwise = Nothing -postgresBuiltin :: Proto.Protos.Codegen.Column -> Maybe (NonEmpty HaskellType) -postgresBuiltin column = +postgresBuiltin :: Maybe Backend -> Proto.Protos.Codegen.Column -> Maybe (NonEmpty HaskellType) +postgresBuiltin backend column = applyNullable column $ applyArrayLike column identity $ asum @@ -700,14 +745,25 @@ pgType ["smallint", "int2", "pg_catalog.int2"] "base" "Data.Int.Int16", pgType ["float", "double precision", "float8", "pg_catalog.float8"] "ghc-prim" "GHC.Types.Double", pgType ["real", "float4", "pg_catalog.float4"] "ghc-prim" "GHC.Types.Float", - pgType ["numeric", "pg_catalog.numeric", "money"] "scientific" "Data.Scientific.Scientific", + -- hasql has no codec for "money", so leave it unresolved there: the + -- user gets a "could not resolve type" error pointing at the column + -- instead of a decoder that fails at runtime. Same for "name" below. + pgType (["numeric", "pg_catalog.numeric"] <> unlessHasql ["money"]) "scientific" "Data.Scientific.Scientific", pgType ["boolean", "bool", "pg_catalog.bool"] "ghc-prim" "GHC.Types.Bool", pgType ["json", "pg_catalog.json"] "aeson" "Data.Aeson.Value", pgType ["jsonb", "pg_catalog.jsonb"] "aeson" "Data.Aeson.Value", pgBinary ["bytea", "blob", "pg_catalog.bytea"], - pgType ["text", "pg_catalog.varchar", "pg_catalog.bpchar", "string", "citext", "name"] "text" "Data.Text.Text" + pgType + (["text", "pg_catalog.varchar", "pg_catalog.bpchar", "string", "citext"] <> unlessHasql ["name"]) + "text" + "Data.Text.Text" ] where + unlessHasql types = + case backend of + Just Hasql -> [] + _ -> types + columnType :: Text columnType = columnDataType (column ^. #type') @@ -728,7 +784,18 @@ | otherwise = Nothing + -- postgresql-simple needs the Binary wrapper to send/receive bytea in the + -- binary format; hasql's bytea codec works on a plain ByteString. pgBinary pgTypes + | columnType `elem` pgTypes, + Just Hasql <- backend = + Just $ + pure + HaskellType + { package = Just "bytestring", + module' = Just "Data.ByteString", + name = Just "Data.ByteString.ByteString" + } | columnType `elem` pgTypes = Just $ HaskellType @@ -754,7 +821,7 @@ -- understand only. mangleQuery :: Text -> Text mangleQuery = - unQuestionmark . dollarsToQuestionmark + unQuestionmark . numberedQuestionmarksToQuestionmark . dollarsToQuestionmark where -- Replace '$x' with '?' dollarsToQuestionmark = @@ -762,6 +829,19 @@ . map (Data.Text.dropWhile Data.Char.isDigit) . Data.Text.splitOn "$" + -- Normalize numbered '?x' placeholders to a bare '?'. sqlc emits these for + -- @sqlc.arg@ (e.g. @?1@, @?2@) but sqlite-simple only understands the + -- positional '?' and fails to parse the numbered form. Only the digits + -- immediately following a '?' are dropped; the text before the first '?' + -- is left untouched. + numberedQuestionmarksToQuestionmark input = + case Data.Text.splitOn "?" input of + (x : xs) -> + Data.Text.intercalate "?" + (x : map (Data.Text.dropWhile Data.Char.isDigit) xs) + [] -> + input + -- Replace '(?)' with '?' -- Due to pretty printing and formatting it could look like -- @@ -785,16 +865,21 @@ -- -- PostgreSQL uses numbered placeholders (@$1@, @$2@) which may repeat or appear -- out of order, so we read the explicit numbers. SQLite uses positional @?@ --- placeholders with no number; for the @sqlite@ engine we emit sequential --- indices @[1..n]@ matching the parameter list order. +-- placeholders, but sqlc emits numbered @?N@ placeholders for @sqlc.arg@ (which +-- may likewise repeat or be reordered); when present we read those numbers. +-- For bare positional @?@ placeholders we fall back to sequential indices +-- @[1..n]@ matching the parameter list order. -- --- The @?@ fallback is deliberately scoped to SQLite: PostgreSQL always uses +-- The @?@ handling is deliberately scoped to SQLite: PostgreSQL always uses -- @$n@, and the MySQL path is left on the numbered behaviour to avoid changing -- it here. Only SQLite needs (and gets) the positional-@?@ handling. queryParamBindings :: Text -> Text -> [Int] queryParamBindings engine query = case numbered of - [] | engine == "sqlite" -> [1 .. Data.Text.count "?" query] + [] | engine == "sqlite" -> + case questionmarkNumbered of + Just bindings -> bindings + Nothing -> [1 .. Data.Text.count "?" query] bindings -> bindings where numbered = @@ -802,3 +887,222 @@ [ readMaybe (toString (Data.Text.takeWhile Data.Char.isDigit x)) | x <- Data.Text.splitOn "$" query ] + + -- One segment per '?' occurrence (dropping the text before the first '?'). + -- If any occurrence carries an explicit number (@?N@), read the numbers, + -- using the positional index as a fallback for any bare '?'. If none are + -- numbered, return 'Nothing' so the caller uses the sequential default. + questionmarkNumbered = + case drop 1 (Data.Text.splitOn "?" query) of + segments + | any (not . Data.Text.null . takeDigits) segments -> + Just (zipWith bindingFor [1 ..] segments) + | otherwise -> + Nothing + where + takeDigits = Data.Text.takeWhile Data.Char.isDigit + bindingFor index segment = + fromMaybe index (readMaybe (toString (takeDigits segment))) + +-- | The hasql @(encoder, decoder)@ pair to use for a column. +-- +-- An override that carries @hasql_encoder@ / @hasql_decoder@ decides the codec +-- outright. Failing that, an override that chose the column's Haskell type also +-- decides its codec, so we go through the generated @ToField@ / @FromField@ +-- classes, which the user can instantiate for whatever type they picked. Only +-- when sqlc-hs typed the column itself do we know the codec, and then we take +-- it from the SQL type. +hasqlColumnCodec :: + -- | The override that matched the column, if any + Maybe Override -> + Proto.Protos.Codegen.Column -> + (Text, Text) +hasqlColumnCodec override column = + ( wrapHasqlEncoder column encoder, + wrapHasqlDecoder column decoder + ) + where + (encoder, decoder) = + case override of + Just Override {hasqlEncoder = Just encoder, hasqlDecoder = Just decoder} -> + (encoder, decoder) + Just _ -> + classCodec + Nothing -> + fromMaybe classCodec (hasqlValueCodec (columnDataType (column ^. #type'))) + + classCodec = + ("toField", "fromField") + +-- | hasql's codec for a PostgreSQL type, as @(encoder, decoder)@ expressions. +-- +-- Unlike postgresql-simple, hasql picks a codec per SQL type rather than per +-- Haskell type, and from 1.10 on it rejects a result whose column OID doesn't +-- match the decoder. @text@, @varchar@ and @bpchar@ all map to 'Text' but need +-- three different decoders, so the choice has to be made here, from the type +-- sqlc reported, and not from a class keyed on the Haskell type. +hasqlValueCodec :: + -- | Database type, as 'columnDataType' renders it + Text -> + Maybe (Text, Text) +hasqlValueCodec databaseType = + fmap codec $ + find + (\(databaseTypes, _codec) -> databaseType `elem` databaseTypes) + [ (["serial", "serial4", "pg_catalog.serial4", "integer", "int", "int4", "pg_catalog.int4"], "int4"), + (["bigserial", "serial8", "pg_catalog.serial8", "bigint", "int8", "pg_catalog.int8"], "int8"), + (["smallserial", "serial2", "pg_catalog.serial2", "smallint", "int2", "pg_catalog.int2"], "int2"), + (["float", "double precision", "float8", "pg_catalog.float8"], "float8"), + (["real", "float4", "pg_catalog.float4"], "float4"), + (["numeric", "pg_catalog.numeric"], "numeric"), + (["boolean", "bool", "pg_catalog.bool"], "bool"), + (["json", "pg_catalog.json"], "json"), + (["jsonb", "pg_catalog.jsonb"], "jsonb"), + (["bytea", "blob", "pg_catalog.bytea"], "bytea"), + (["text", "string", "pg_catalog.text"], "text"), + (["varchar", "pg_catalog.varchar"], "varchar"), + (["bpchar", "pg_catalog.bpchar"], "bpchar"), + (["citext"], "citext") + ] + where + codec (_databaseTypes, name) = + ("Hasql.Encoders." <> name, "Hasql.Decoders." <> name) + +-- | Lift a hasql value encoder to the parameter encoder for a column, applying +-- the same nullability and array wrapping that 'applyNullable' and +-- 'applyArrayLike' applied to the column's Haskell type. +wrapHasqlEncoder :: Proto.Protos.Codegen.Column -> Text -> Text +wrapHasqlEncoder = + wrapHasqlValue "Hasql.Encoders" "foldableArray" + +-- | 'wrapHasqlEncoder' for decoders. Array columns decode into a 'Vector', which +-- is what 'wrapVector' gave them as a Haskell type. +wrapHasqlDecoder :: Proto.Protos.Codegen.Column -> Text -> Text +wrapHasqlDecoder = + wrapHasqlValue "Hasql.Decoders" "vectorArray" + +wrapHasqlValue :: Text -> Text -> Proto.Protos.Codegen.Column -> Text -> Text +wrapHasqlValue module' arrayCodec column value = + qualified nullability <> " " <> wrapParenthesis arrayed + where + qualified name = + module' <> "." <> name + + nullability + | column ^. #notNull = "nonNullable" + | otherwise = "nullable" + + arrayed + | column ^. #isArray || column ^. #isSqlcSlice = + qualified arrayCodec + <> " " + <> wrapParenthesis (qualified "nonNullable" <> " " <> wrapParenthesis value) + | otherwise = + value + +-- | Rewrite the @IN@ / @NOT IN@ operators over @sqlc.slice@ parameters into +-- their array equivalents. +-- +-- PostgreSQL's @IN@ takes a syntactic list of values, not an array, which is +-- why postgresql-simple expands a slice into as many placeholders as there are +-- elements. hasql binds one parameter per placeholder and cannot do that, so +-- the array operators have to be used instead: +-- +-- * @x IN ($1)@ becomes @x = ANY ($1)@ +-- * @x NOT IN ($1)@ becomes @x <> ALL ($1)@ +-- +-- Returns 'Left' when a slice parameter isn't in a shape we recognise, rather +-- than emitting SQL that only fails once it reaches the server. +rewriteSlices :: + -- | The numbers of the parameters that are slices + [Int] -> + Text -> + Either Text Text +rewriteSlices slices sql + | null slices = + Right sql + | otherwise = + go mempty sql + where + go acc input = + case Data.Text.breakOn "$" input of + (before, rest) + | Just rest <- Data.Text.stripPrefix "$" rest, + (digits, after) <- Data.Text.span Data.Char.isDigit rest, + Just number <- readMaybe (toString digits), + number `elem` slices -> + case rewriteSlice (acc <> before) digits after of + Left errorMessage -> + Left errorMessage + Right (acc, after) -> + go acc after + | Just rest <- Data.Text.stripPrefix "$" rest, + (digits, after) <- Data.Text.span Data.Char.isDigit rest -> + go (acc <> before <> "$" <> digits) after + | otherwise -> + Right (acc <> before) + + -- 'before' is everything preceding the placeholder, 'after' everything + -- following it. Both get rewritten: the operator sits in front of the + -- placeholder, the closing parenthesis (if any) behind it. + rewriteSlice before digits after = do + let placeholder = "$" <> digits + + -- sqlc marks slices with a comment for the engines that use + -- positional placeholders. Drop it, it has served its purpose. + withoutMarker = stripSliceMarker before + + (withoutParenthesis, parenthesised) = + case Data.Text.stripSuffix "(" (Data.Text.stripEnd withoutMarker) of + Just before -> (before, True) + Nothing -> (withoutMarker, False) + + after <- + if parenthesised + then + whenNothing + (Data.Text.stripPrefix ")" (Data.Text.stripStart after)) + (Left (unsupported placeholder)) + else pure after + + beforeIn <- + whenNothing + (stripKeywordSuffix "IN" (Data.Text.stripEnd withoutParenthesis)) + (Left (unsupported placeholder)) + + pure $ + case stripKeywordSuffix "NOT" (Data.Text.stripEnd beforeIn) of + Just beforeNot -> + (Data.Text.stripEnd beforeNot <> " <> ALL (" <> placeholder <> ")", after) + Nothing -> + (Data.Text.stripEnd beforeIn <> " = ANY (" <> placeholder <> ")", after) + + unsupported placeholder = + "The slice parameter " + <> placeholder + <> " is not used with IN or NOT IN. hasql binds a slice as a single\ + \ array parameter, which PostgreSQL only accepts with the array\ + \ operators; write the comparison as \"= ANY(sqlc.arg(...)::type[])\"\ + \ in your SQL instead of using sqlc.slice." + +-- | Strip a @/*SLICE:name*/@ marker off the end of the text, if there is one. +stripSliceMarker :: Text -> Text +stripSliceMarker input = fromMaybe input $ do + comment <- Data.Text.stripSuffix "*/" (Data.Text.stripEnd input) + let (before, marker) = Data.Text.breakOnEnd "/*" comment + guard ("SLICE:" `Data.Text.isPrefixOf` marker) + Data.Text.stripSuffix "/*" before + +-- | Strip a keyword off the end of the text, case insensitively, requiring it +-- to be a word of its own rather than the tail of an identifier. +stripKeywordSuffix :: Text -> Text -> Maybe Text +stripKeywordSuffix keyword input = do + guard (Data.Text.length input >= Data.Text.length keyword) + let (before, suffix) = + Data.Text.splitAt (Data.Text.length input - Data.Text.length keyword) input + guard (Data.Text.toUpper suffix == keyword) + guard (maybe True (not . isIdentifierChar . snd) (Data.Text.unsnoc before)) + pure before + where + isIdentifierChar c = + Data.Char.isAlphaNum c || c == '_' diff --git a/templates/internal.hasql.hs.jinja b/templates/internal.hasql.hs.jinja new file mode 100644 --- /dev/null +++ b/templates/internal.hasql.hs.jinja @@ -0,0 +1,406 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +module {{ moduleName }} ( + Query(..), + Params, + Result, + {{ moduleName }}.Enum, + + -- * Codecs + ToRow(..), + FromRow(..), + ToField(..), + FromField(..), + statement, + + -- * :execResult + ExecResult(..), + execResult, + execResultSession, + + -- * :exec + exec, + execSession, + + -- * :execrows + execRows, + execRowsSession, + + -- * :one + queryOne, + queryOneSession, + + -- * :many + queryMany, + queryManySession, + fold, + foldSession, + + -- * :copyfrom + execMany, + execManySession, + + -- * Reexports + Hasql.Connection.Connection, + Hasql.Session.Session, + RunnerError, + Hasql.Errors.SessionError, + ) where + +import Data.Foldable (Foldable) +import Data.Vector (Vector) +import GHC.TypeLits (Symbol) +import qualified Data.Aeson +import qualified Data.ByteString +import qualified Data.Foldable +import qualified Data.Int +import qualified Data.Scientific +import qualified Data.Text +import qualified Data.Time +import qualified Data.UUID +import qualified Data.Vector +import qualified Hasql.Connection +import qualified Hasql.Decoders +import qualified Hasql.Encoders +import qualified Hasql.Errors +import qualified Hasql.Pipeline +import qualified Hasql.Session +import qualified Hasql.Statement + +-- | What a runner reports when it fails. +-- +-- hasql 2.1 replaced the single session-error type that +-- 'Hasql.Connection.use' returned with @UseError@, which distinguishes a +-- statement that failed on a live connection (@SessionUseError@, wrapping the +-- 'Hasql.Errors.SessionError' the old type expressed) from a connection that is +-- gone and has already been closed (@ConnectionUseError@). +-- +-- Named through this alias so the generated module compiles against both, and +-- so a call site that only passes the error along does not have to care. +#if MIN_VERSION_hasql(2,1,0) +type RunnerError = Hasql.Errors.UseError +#else +type RunnerError = Hasql.Errors.SessionError +#endif + +-- | The SQL of a query, with PostgreSQL's positional @$1@, @$2@ placeholders +-- left as sqlc emitted them. +newtype Query (name :: Symbol) (command :: Symbol) + = Query Data.Text.Text + +data family Params (name :: Symbol) + +data family Result (name :: Symbol) + +data family Enum (name :: Symbol) + +-- | The parameter encoder of a query. hasql has no such class of its own -- +-- encoders are plain values -- so sqlc-hs declares one and generates an +-- instance per query. +class ToRow a where + toRow :: Hasql.Encoders.Params a + +-- | The row decoder of a query's result. The counterpart of 'ToRow'. +class FromRow a where + fromRow :: Hasql.Decoders.Row a + +-- | The codec of a single value. +-- +-- sqlc-hs takes hasql's codec from the SQL type for every column it typed +-- itself, because hasql checks column types when decoding and @text@, @varchar@ +-- and @bpchar@ need three different decoders. Columns typed through an +-- @overrides@ entry go through this class instead, so a custom type only needs +-- an instance here: +-- +-- @ +-- instance ToField MyId where +-- toField = Data.Functor.Contravariant.contramap unMyId toField +-- @ +-- +-- An override can also name the codecs directly, with the @hasql_encoder@ and +-- @hasql_decoder@ keys, in which case no instance is needed. +class ToField a where + toField :: Hasql.Encoders.Value a + +-- | The counterpart of 'ToField'. +-- +-- @ +-- instance FromField MyId where +-- fromField = fmap MyId fromField +-- @ +class FromField a where + fromField :: Hasql.Decoders.Value a + +instance ToField Bool where + toField = Hasql.Encoders.bool + +instance ToField Data.Int.Int16 where + toField = Hasql.Encoders.int2 + +instance ToField Data.Int.Int32 where + toField = Hasql.Encoders.int4 + +instance ToField Data.Int.Int64 where + toField = Hasql.Encoders.int8 + +instance ToField Float where + toField = Hasql.Encoders.float4 + +instance ToField Double where + toField = Hasql.Encoders.float8 + +instance ToField Data.Scientific.Scientific where + toField = Hasql.Encoders.numeric + +instance ToField Char where + toField = Hasql.Encoders.char + +instance ToField Data.Text.Text where + toField = Hasql.Encoders.text + +instance ToField Data.ByteString.ByteString where + toField = Hasql.Encoders.bytea + +instance ToField Data.UUID.UUID where + toField = Hasql.Encoders.uuid + +instance ToField Data.Time.Day where + toField = Hasql.Encoders.date + +instance ToField Data.Time.LocalTime where + toField = Hasql.Encoders.timestamp + +instance ToField Data.Time.UTCTime where + toField = Hasql.Encoders.timestamptz + +instance ToField Data.Time.TimeOfDay where + toField = Hasql.Encoders.time + +instance ToField (Data.Time.TimeOfDay, Data.Time.TimeZone) where + toField = Hasql.Encoders.timetz + +instance ToField Data.Time.DiffTime where + toField = Hasql.Encoders.interval + +instance ToField Data.Aeson.Value where + toField = Hasql.Encoders.jsonb + +instance (ToField a) => ToField (Data.Vector.Vector a) where + toField = Hasql.Encoders.foldableArray (Hasql.Encoders.nonNullable toField) + +instance (ToField a) => ToField [a] where + toField = Hasql.Encoders.foldableArray (Hasql.Encoders.nonNullable toField) + +instance FromField Bool where + fromField = Hasql.Decoders.bool + +instance FromField Data.Int.Int16 where + fromField = Hasql.Decoders.int2 + +instance FromField Data.Int.Int32 where + fromField = Hasql.Decoders.int4 + +instance FromField Data.Int.Int64 where + fromField = Hasql.Decoders.int8 + +instance FromField Float where + fromField = Hasql.Decoders.float4 + +instance FromField Double where + fromField = Hasql.Decoders.float8 + +instance FromField Data.Scientific.Scientific where + fromField = Hasql.Decoders.numeric + +instance FromField Char where + fromField = Hasql.Decoders.char + +instance FromField Data.Text.Text where + fromField = Hasql.Decoders.text + +instance FromField Data.ByteString.ByteString where + fromField = Hasql.Decoders.bytea + +instance FromField Data.UUID.UUID where + fromField = Hasql.Decoders.uuid + +instance FromField Data.Time.Day where + fromField = Hasql.Decoders.date + +instance FromField Data.Time.LocalTime where + fromField = Hasql.Decoders.timestamp + +instance FromField Data.Time.UTCTime where + fromField = Hasql.Decoders.timestamptz + +instance FromField Data.Time.TimeOfDay where + fromField = Hasql.Decoders.time + +instance FromField (Data.Time.TimeOfDay, Data.Time.TimeZone) where + fromField = Hasql.Decoders.timetz + +instance FromField Data.Time.DiffTime where + fromField = Hasql.Decoders.interval + +instance FromField Data.Aeson.Value where + fromField = Hasql.Decoders.jsonb + +instance (FromField a) => FromField (Data.Vector.Vector a) where + fromField = Hasql.Decoders.vectorArray (Hasql.Decoders.nonNullable fromField) + +instance (FromField a) => FromField [a] where + fromField = Hasql.Decoders.listArray (Hasql.Decoders.nonNullable fromField) + +data ExecResult = ExecResult + { rowsAffected :: !Data.Int.Int64 + } + +-- | The statement a query and a result decoder make up. Use it to run a query +-- inside a 'Hasql.Pipeline.Pipeline'. +statement :: + (ToRow (Params name)) => + Query name command -> + Hasql.Decoders.Result result -> + Hasql.Statement.Statement (Params name) result +statement (Query sql) decoder = + Hasql.Statement.preparable sql toRow decoder + +exec :: + (ToRow (Params name)) => + Hasql.Connection.Connection -> + Query name ":exec" -> + Params name -> + IO (Either RunnerError ()) +exec connection query params = + Hasql.Connection.use connection (execSession query params) + +execSession :: + (ToRow (Params name)) => + Query name ":exec" -> + Params name -> + Hasql.Session.Session () +execSession query params = + Hasql.Session.statement params (statement query Hasql.Decoders.noResult) + +execRows :: + (ToRow (Params name)) => + Hasql.Connection.Connection -> + Query name ":execrows" -> + Params name -> + IO (Either RunnerError Data.Int.Int64) +execRows connection query params = + Hasql.Connection.use connection (execRowsSession query params) + +execRowsSession :: + (ToRow (Params name)) => + Query name ":execrows" -> + Params name -> + Hasql.Session.Session Data.Int.Int64 +execRowsSession query params = + Hasql.Session.statement params (statement query Hasql.Decoders.rowsAffected) + +execResult :: + (ToRow (Params name)) => + Hasql.Connection.Connection -> + Query name ":execresult" -> + Params name -> + IO (Either RunnerError ExecResult) +execResult connection query params = + Hasql.Connection.use connection (execResultSession query params) + +execResultSession :: + (ToRow (Params name)) => + Query name ":execresult" -> + Params name -> + Hasql.Session.Session ExecResult +execResultSession query params = do + rowsAffected <- Hasql.Session.statement params (statement query Hasql.Decoders.rowsAffected) + pure ExecResult { + rowsAffected + } + +queryOne :: + (ToRow (Params name), FromRow (Result name)) => + Hasql.Connection.Connection -> + Query name ":one" -> + Params name -> + IO (Either RunnerError (Maybe (Result name))) +queryOne connection query params = + Hasql.Connection.use connection (queryOneSession query params) + +queryOneSession :: + (ToRow (Params name), FromRow (Result name)) => + Query name ":one" -> + Params name -> + Hasql.Session.Session (Maybe (Result name)) +queryOneSession query params = + Hasql.Session.statement params (statement query (Hasql.Decoders.rowMaybe fromRow)) + +queryMany :: + (ToRow (Params name), FromRow (Result name)) => + Hasql.Connection.Connection -> + Query name ":many" -> + Params name -> + IO (Either RunnerError (Vector (Result name))) +queryMany connection query params = + Hasql.Connection.use connection (queryManySession query params) + +queryManySession :: + (ToRow (Params name), FromRow (Result name)) => + Query name ":many" -> + Params name -> + Hasql.Session.Session (Vector (Result name)) +queryManySession query params = + Hasql.Session.statement params (statement query (Hasql.Decoders.rowVector fromRow)) + +-- | Note that hasql folds a result purely, so unlike the postgresql-simple +-- backend the step function is not in 'IO'. +fold :: + (ToRow (Params name), FromRow (Result name)) => + Hasql.Connection.Connection -> + Query name ":many" -> + Params name -> + a -> + (a -> Result name -> a) -> + IO (Either RunnerError a) +fold connection query params initial step = + Hasql.Connection.use connection (foldSession query params initial step) +{-# INLINABLE fold #-} + +foldSession :: + (ToRow (Params name), FromRow (Result name)) => + Query name ":many" -> + Params name -> + a -> + (a -> Result name -> a) -> + Hasql.Session.Session a +foldSession query params initial step = + Hasql.Session.statement params (statement query (Hasql.Decoders.foldlRows step initial fromRow)) +{-# INLINABLE foldSession #-} + +-- | Runs the query once per set of parameters, pipelined into a single +-- round trip, and returns the total number of rows affected. +execMany :: + (ToRow (Params name), Foldable f) => + Hasql.Connection.Connection -> + Query name ":copyfrom" -> + f (Params name) -> + IO (Either RunnerError Data.Int.Int64) +execMany connection query params = + Hasql.Connection.use connection (execManySession query params) + +execManySession :: + (ToRow (Params name), Foldable f) => + Query name ":copyfrom" -> + f (Params name) -> + Hasql.Session.Session Data.Int.Int64 +execManySession query params = + Hasql.Session.pipeline + (fmap sum (traverse pipelined (Data.Foldable.toList params))) + where + pipelined param = + Hasql.Pipeline.statement param (statement query Hasql.Decoders.rowsAffected) diff --git a/templates/query.hs.jinja b/templates/query.hs.jinja --- a/templates/query.hs.jinja +++ b/templates/query.hs.jinja @@ -15,6 +15,11 @@ import qualified Database.PostgreSQL.Simple.ToField import qualified Database.PostgreSQL.Simple.ToRow {% endif %} +{% if generateHasql %} +import {{ internalModuleName }} (Query(..), Enum, Params, Result, ToRow(..), FromRow(..), ToField(..), FromField(..)) +import qualified Hasql.Decoders +import qualified Hasql.Encoders +{% endif %} {% if generateSqlite %} import {{ internalModuleName }} (Query(..), Enum, Params, Result) import qualified Database.SQLite.Simple.FromRow @@ -71,6 +76,24 @@ pure {{ haskellResultName }} {% for column in resultColumns %} <*> Database.PostgreSQL.Simple.FromRow.field + {% endfor %} +{% endif %} +{% if generateHasql %} +instance ToRow (Params {{ escapedQueryName }}) where + {-# INLINE toRow #-} + toRow = + mconcat + [ {% for param in encoderColumns %} + Data.Functor.Contravariant.contramap (\{{ haskellParamsName }}{..} -> {{ param.value.name }}) (Hasql.Encoders.param ({{ param.value.encoder }})){% if !param.last %}, {% endif %} + {% endfor %} + ] + +instance FromRow (Result {{ escapedQueryName }}) where + {-# INLINE fromRow #-} + fromRow = + pure {{ haskellResultName }} + {% for column in resultColumns %} + <*> Hasql.Decoders.column ({{ column.value.decoder }}) {% endfor %} {% endif %} diff --git a/templates/types.hs.jinja b/templates/types.hs.jinja --- a/templates/types.hs.jinja +++ b/templates/types.hs.jinja @@ -18,6 +18,10 @@ import qualified Database.PostgreSQL.Simple.ToField import qualified Database.PostgreSQL.Simple.ToRow {% endif %} +{% if generateHasql %} +import qualified Hasql.Decoders +import qualified Hasql.Encoders +{% endif %} {% if generateSqlite %} import qualified Database.SQLite.Simple.FromRow import qualified Database.SQLite.Simple.ToField @@ -57,6 +61,24 @@ {% endfor %} Just value -> Database.PostgreSQL.Simple.FromField.returnError Database.PostgreSQL.Simple.FromField.ConversionFailed field (show value) Nothing -> Database.PostgreSQL.Simple.FromField.returnError Database.PostgreSQL.Simple.FromField.UnexpectedNull field "" +{% endif %} +{% if generateHasql %} +instance ToField (Enum {{ enum.value.escapedEnumName }}) where + toField = + Hasql.Encoders.enum {{ enum.value.escapedEnumSchema }} {{ enum.value.escapedEnumName }} $ \x -> + case x of + {% for value in enum.value.values %} + {{ value.value.haskellConstructorName }} -> {{ value.value.escapedEnumValue }} + {% endfor %} + +instance FromField (Enum {{ enum.value.escapedEnumName }}) where + fromField = + Hasql.Decoders.enum {{ enum.value.escapedEnumSchema }} {{ enum.value.escapedEnumName }} $ \x -> + case x of + {% for value in enum.value.values %} + {{ value.value.escapedEnumValue }} -> Prelude.Just {{ value.value.haskellConstructorName }} + {% endfor %} + _ -> Prelude.Nothing {% endif %} {% endfor %} diff --git a/test/golden/hasql-features.input b/test/golden/hasql-features.input new file mode 100644 --- /dev/null +++ b/test/golden/hasql-features.input @@ -0,0 +1,212 @@ +settings { + engine: "postgresql" +} + +catalog { + default_schema: "public" + schemas { + name: "public" + enums { + name: "organization_role" + vals: "owner" + vals: "admin" + vals: "member" + } + } +} + +queries { + text: "SELECT id FROM users WHERE $1::TEXT IS NULL OR $1::TEXT = users.name;" + name: "FindUserByName" + cmd: ":many" + filename: "query/users.sql" + columns { + name: "id" + not_null: true + type { + name: "int" + } + } + params { + number: 1 + column { + name: "name" + not_null: true + type { + name: "text" + } + } + } +} + +queries { + text: "SELECT id FROM users WHERE name IN ($1) AND email NOT IN ($2) AND age > $3;" + name: "FindUsers" + cmd: ":many" + filename: "query/users.sql" + columns { + name: "id" + not_null: true + type { + name: "int" + } + } + params { + number: 1 + column { + name: "names" + not_null: true + is_sqlc_slice: true + type { + name: "text" + } + } + } + params { + number: 2 + column { + name: "emails" + not_null: true + is_sqlc_slice: true + type { + name: "text" + } + } + } + params { + number: 3 + column { + name: "age" + not_null: true + type { + name: "int" + } + } + } +} + +queries { + text: "SELECT tags, labels FROM posts WHERE tags && $1;" + name: "FindPosts" + cmd: ":many" + filename: "query/posts.sql" + columns { + name: "tags" + not_null: true + is_array: true + type { + name: "text" + } + } + columns { + name: "labels" + is_array: true + type { + name: "pg_catalog.varchar" + } + } + params { + number: 1 + column { + name: "tags" + not_null: true + is_array: true + type { + name: "text" + } + } + } +} + +queries { + text: "SELECT role, previous_role FROM members WHERE role = $1;" + name: "FindMembers" + cmd: ":many" + filename: "query/members.sql" + columns { + name: "role" + not_null: true + type { + name: "organization_role" + } + } + columns { + name: "previous_role" + type { + name: "organization_role" + } + } + params { + number: 1 + column { + name: "role" + not_null: true + type { + name: "organization_role" + } + } + } +} + +queries { + text: "SELECT id, created_at, updated_at, legacy_at FROM events WHERE id = $1 AND legacy_at > $2;" + name: "GetEvent" + cmd: ":one" + filename: "query/events.sql" + columns { + name: "id" + not_null: true + type { + name: "uuid" + } + } + columns { + name: "created_at" + not_null: true + type { + name: "pg_catalog.timestamptz" + } + } + columns { + name: "updated_at" + type { + name: "pg_catalog.timestamptz" + } + } + columns { + name: "legacy_at" + not_null: true + type { + name: "pg_catalog.timestamp" + } + } + params { + number: 1 + column { + name: "id" + not_null: true + type { + name: "uuid" + } + } + } + params { + number: 2 + column { + name: "since" + not_null: true + type { + name: "pg_catalog.timestamp" + } + } + } +} + +queries { + text: "DELETE FROM users;" + name: "DeleteUsers" + cmd: ":exec" + filename: "query/users.sql" +} + +plugin_options: "{\"cabal_package_name\":\"hasql-features\",\"driver\":\"hasql\",\"overrides\":[{\"db_type\":\"pg_catalog.timestamptz\",\"haskell_type\":{\"package\":\"time\",\"module\":\"Data.Time\",\"type\":\"Data.Time.UTCTime\"}},{\"db_type\":\"pg_catalog.timestamptz\",\"nullable\":true,\"haskell_type\":{\"package\":\"time\",\"module\":\"Data.Time\",\"type\":\"Maybe Data.Time.UTCTime\"}},{\"db_type\":\"uuid\",\"haskell_type\":{\"package\":\"uuid\",\"module\":\"Data.UUID\",\"type\":\"Data.UUID.UUID\"}},{\"db_type\":\"pg_catalog.timestamp\",\"haskell_type\":{\"package\":\"time\",\"module\":\"Data.Time\",\"type\":\"Data.Time.UTCTime\"},\"hasql_encoder\":\"Data.Functor.Contravariant.contramap (Data.Time.utcToLocalTime Data.Time.utc) Hasql.Encoders.timestamp\",\"hasql_decoder\":\"fmap (Data.Time.localTimeToUTC Data.Time.utc) Hasql.Decoders.timestamp\"}]}" diff --git a/test/golden/hasql-features/Queries.hs b/test/golden/hasql-features/Queries.hs new file mode 100644 --- /dev/null +++ b/test/golden/hasql-features/Queries.hs @@ -0,0 +1,15 @@ +module Queries + ( module Queries.Internal, + module Queries.Types, + module Queries + ) +where + +import Queries.Internal +import Queries.Types +import Queries.FindUserByName as Queries +import Queries.FindUsers as Queries +import Queries.FindPosts as Queries +import Queries.FindMembers as Queries +import Queries.GetEvent as Queries +import Queries.DeleteUsers as Queries diff --git a/test/golden/hasql-features/Queries/DeleteUsers.hs b/test/golden/hasql-features/Queries/DeleteUsers.hs new file mode 100644 --- /dev/null +++ b/test/golden/hasql-features/Queries/DeleteUsers.hs @@ -0,0 +1,40 @@ +{- This file was auto-generated from query/users.sql by sqlc-hs. -} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.DeleteUsers where + +import Queries.Internal (Query(..), Enum, Params, Result, ToRow(..), FromRow(..), ToField(..), FromField(..)) +import qualified Hasql.Decoders +import qualified Hasql.Encoders + +import qualified Data.Foldable +import qualified Data.Functor.Contravariant + +query_DeleteUsers :: Query "DeleteUsers" ":exec" +query_DeleteUsers = Query "DELETE FROM users;" + +data instance Params "DeleteUsers" = Params_DeleteUsers + { + } + +data instance Result "DeleteUsers" = Result_DeleteUsers + { + } + +instance ToRow (Params "DeleteUsers") where + {-# INLINE toRow #-} + toRow = + mconcat + [ ] + +instance FromRow (Result "DeleteUsers") where + {-# INLINE fromRow #-} + fromRow = + pure Result_DeleteUsers + + diff --git a/test/golden/hasql-features/Queries/FindMembers.hs b/test/golden/hasql-features/Queries/FindMembers.hs new file mode 100644 --- /dev/null +++ b/test/golden/hasql-features/Queries/FindMembers.hs @@ -0,0 +1,49 @@ +{- This file was auto-generated from query/members.sql by sqlc-hs. -} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.FindMembers where + +import Queries.Internal (Query(..), Enum, Params, Result, ToRow(..), FromRow(..), ToField(..), FromField(..)) +import qualified Hasql.Decoders +import qualified Hasql.Encoders + +import qualified Queries.Types +import qualified GHC.Base +import qualified Data.Foldable +import qualified Data.Functor.Contravariant + +query_FindMembers :: Query "FindMembers" ":many" +query_FindMembers = Query "SELECT role, previous_role FROM members WHERE role = $1;" + +data instance Params "FindMembers" = Params_FindMembers + { + role :: (Queries.Types.Enum "organization_role") + } + +data instance Result "FindMembers" = Result_FindMembers + { + role :: !((Queries.Types.Enum "organization_role")), + previous_role :: !(GHC.Base.Maybe ((Queries.Types.Enum "organization_role"))) + } + +instance ToRow (Params "FindMembers") where + {-# INLINE toRow #-} + toRow = + mconcat + [ + Data.Functor.Contravariant.contramap (\Params_FindMembers{..} -> role) (Hasql.Encoders.param (Hasql.Encoders.nonNullable toField)) + ] + +instance FromRow (Result "FindMembers") where + {-# INLINE fromRow #-} + fromRow = + pure Result_FindMembers + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable fromField) + <*> Hasql.Decoders.column (Hasql.Decoders.nullable fromField) + + diff --git a/test/golden/hasql-features/Queries/FindPosts.hs b/test/golden/hasql-features/Queries/FindPosts.hs new file mode 100644 --- /dev/null +++ b/test/golden/hasql-features/Queries/FindPosts.hs @@ -0,0 +1,50 @@ +{- This file was auto-generated from query/posts.sql by sqlc-hs. -} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.FindPosts where + +import Queries.Internal (Query(..), Enum, Params, Result, ToRow(..), FromRow(..), ToField(..), FromField(..)) +import qualified Hasql.Decoders +import qualified Hasql.Encoders + +import qualified Data.Text +import qualified Data.Vector +import qualified GHC.Base +import qualified Data.Foldable +import qualified Data.Functor.Contravariant + +query_FindPosts :: Query "FindPosts" ":many" +query_FindPosts = Query "SELECT tags, labels FROM posts WHERE tags && $1;" + +data instance Params "FindPosts" = Params_FindPosts + { + tags :: Data.Vector.Vector Data.Text.Text + } + +data instance Result "FindPosts" = Result_FindPosts + { + tags :: !(Data.Vector.Vector Data.Text.Text), + labels :: !(GHC.Base.Maybe (Data.Vector.Vector Data.Text.Text)) + } + +instance ToRow (Params "FindPosts") where + {-# INLINE toRow #-} + toRow = + mconcat + [ + Data.Functor.Contravariant.contramap (\Params_FindPosts{..} -> tags) (Hasql.Encoders.param (Hasql.Encoders.nonNullable (Hasql.Encoders.foldableArray (Hasql.Encoders.nonNullable Hasql.Encoders.text)))) + ] + +instance FromRow (Result "FindPosts") where + {-# INLINE fromRow #-} + fromRow = + pure Result_FindPosts + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable (Hasql.Decoders.vectorArray (Hasql.Decoders.nonNullable Hasql.Decoders.text))) + <*> Hasql.Decoders.column (Hasql.Decoders.nullable (Hasql.Decoders.vectorArray (Hasql.Decoders.nonNullable Hasql.Decoders.varchar))) + + diff --git a/test/golden/hasql-features/Queries/FindUserByName.hs b/test/golden/hasql-features/Queries/FindUserByName.hs new file mode 100644 --- /dev/null +++ b/test/golden/hasql-features/Queries/FindUserByName.hs @@ -0,0 +1,47 @@ +{- This file was auto-generated from query/users.sql by sqlc-hs. -} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.FindUserByName where + +import Queries.Internal (Query(..), Enum, Params, Result, ToRow(..), FromRow(..), ToField(..), FromField(..)) +import qualified Hasql.Decoders +import qualified Hasql.Encoders + +import qualified Data.Text +import qualified Data.Int +import qualified Data.Foldable +import qualified Data.Functor.Contravariant + +query_FindUserByName :: Query "FindUserByName" ":many" +query_FindUserByName = Query "SELECT id FROM users WHERE $1::TEXT IS NULL OR $1::TEXT = users.name;" + +data instance Params "FindUserByName" = Params_FindUserByName + { + name :: Data.Text.Text + } + +data instance Result "FindUserByName" = Result_FindUserByName + { + id :: !(Data.Int.Int32) + } + +instance ToRow (Params "FindUserByName") where + {-# INLINE toRow #-} + toRow = + mconcat + [ + Data.Functor.Contravariant.contramap (\Params_FindUserByName{..} -> name) (Hasql.Encoders.param (Hasql.Encoders.nonNullable Hasql.Encoders.text)) + ] + +instance FromRow (Result "FindUserByName") where + {-# INLINE fromRow #-} + fromRow = + pure Result_FindUserByName + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable Hasql.Decoders.int4) + + diff --git a/test/golden/hasql-features/Queries/FindUsers.hs b/test/golden/hasql-features/Queries/FindUsers.hs new file mode 100644 --- /dev/null +++ b/test/golden/hasql-features/Queries/FindUsers.hs @@ -0,0 +1,53 @@ +{- This file was auto-generated from query/users.sql by sqlc-hs. -} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.FindUsers where + +import Queries.Internal (Query(..), Enum, Params, Result, ToRow(..), FromRow(..), ToField(..), FromField(..)) +import qualified Hasql.Decoders +import qualified Hasql.Encoders + +import qualified Data.Text +import qualified Data.Int +import qualified Data.Foldable +import qualified Data.Functor.Contravariant + +query_FindUsers :: Query "FindUsers" ":many" +query_FindUsers = Query "SELECT id FROM users WHERE name = ANY ($1) AND email <> ALL ($2) AND age > $3;" + +data instance Params "FindUsers" = Params_FindUsers + { + names :: [Data.Text.Text], + emails :: [Data.Text.Text], + age :: Data.Int.Int32 + } + +data instance Result "FindUsers" = Result_FindUsers + { + id :: !(Data.Int.Int32) + } + +instance ToRow (Params "FindUsers") where + {-# INLINE toRow #-} + toRow = + mconcat + [ + Data.Functor.Contravariant.contramap (\Params_FindUsers{..} -> names) (Hasql.Encoders.param (Hasql.Encoders.nonNullable (Hasql.Encoders.foldableArray (Hasql.Encoders.nonNullable Hasql.Encoders.text)))), + + Data.Functor.Contravariant.contramap (\Params_FindUsers{..} -> emails) (Hasql.Encoders.param (Hasql.Encoders.nonNullable (Hasql.Encoders.foldableArray (Hasql.Encoders.nonNullable Hasql.Encoders.text)))), + + Data.Functor.Contravariant.contramap (\Params_FindUsers{..} -> age) (Hasql.Encoders.param (Hasql.Encoders.nonNullable Hasql.Encoders.int4)) + ] + +instance FromRow (Result "FindUsers") where + {-# INLINE fromRow #-} + fromRow = + pure Result_FindUsers + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable Hasql.Decoders.int4) + + diff --git a/test/golden/hasql-features/Queries/GetEvent.hs b/test/golden/hasql-features/Queries/GetEvent.hs new file mode 100644 --- /dev/null +++ b/test/golden/hasql-features/Queries/GetEvent.hs @@ -0,0 +1,56 @@ +{- This file was auto-generated from query/events.sql by sqlc-hs. -} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.GetEvent where + +import Queries.Internal (Query(..), Enum, Params, Result, ToRow(..), FromRow(..), ToField(..), FromField(..)) +import qualified Hasql.Decoders +import qualified Hasql.Encoders + +import qualified Data.UUID +import qualified Data.Time +import qualified Data.Foldable +import qualified Data.Functor.Contravariant + +query_GetEvent :: Query "GetEvent" ":one" +query_GetEvent = Query "SELECT id, created_at, updated_at, legacy_at FROM events WHERE id = $1 AND legacy_at > $2;" + +data instance Params "GetEvent" = Params_GetEvent + { + id :: Data.UUID.UUID, + since :: Data.Time.UTCTime + } + +data instance Result "GetEvent" = Result_GetEvent + { + id :: !(Data.UUID.UUID), + created_at :: !(Data.Time.UTCTime), + updated_at :: !((Maybe Data.Time.UTCTime)), + legacy_at :: !(Data.Time.UTCTime) + } + +instance ToRow (Params "GetEvent") where + {-# INLINE toRow #-} + toRow = + mconcat + [ + Data.Functor.Contravariant.contramap (\Params_GetEvent{..} -> id) (Hasql.Encoders.param (Hasql.Encoders.nonNullable toField)), + + Data.Functor.Contravariant.contramap (\Params_GetEvent{..} -> since) (Hasql.Encoders.param (Hasql.Encoders.nonNullable (Data.Functor.Contravariant.contramap (Data.Time.utcToLocalTime Data.Time.utc) Hasql.Encoders.timestamp))) + ] + +instance FromRow (Result "GetEvent") where + {-# INLINE fromRow #-} + fromRow = + pure Result_GetEvent + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable fromField) + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable fromField) + <*> Hasql.Decoders.column (Hasql.Decoders.nullable fromField) + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable (fmap (Data.Time.localTimeToUTC Data.Time.utc) Hasql.Decoders.timestamp)) + + diff --git a/test/golden/hasql-features/Queries/Internal.hs b/test/golden/hasql-features/Queries/Internal.hs new file mode 100644 --- /dev/null +++ b/test/golden/hasql-features/Queries/Internal.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.Internal ( + Query(..), + Params, + Result, + Queries.Internal.Enum, + + -- * Codecs + ToRow(..), + FromRow(..), + ToField(..), + FromField(..), + statement, + + -- * :execResult + ExecResult(..), + execResult, + execResultSession, + + -- * :exec + exec, + execSession, + + -- * :execrows + execRows, + execRowsSession, + + -- * :one + queryOne, + queryOneSession, + + -- * :many + queryMany, + queryManySession, + fold, + foldSession, + + -- * :copyfrom + execMany, + execManySession, + + -- * Reexports + Hasql.Connection.Connection, + Hasql.Session.Session, + RunnerError, + Hasql.Errors.SessionError, + ) where + +import Data.Foldable (Foldable) +import Data.Vector (Vector) +import GHC.TypeLits (Symbol) +import qualified Data.Aeson +import qualified Data.ByteString +import qualified Data.Foldable +import qualified Data.Int +import qualified Data.Scientific +import qualified Data.Text +import qualified Data.Time +import qualified Data.UUID +import qualified Data.Vector +import qualified Hasql.Connection +import qualified Hasql.Decoders +import qualified Hasql.Encoders +import qualified Hasql.Errors +import qualified Hasql.Pipeline +import qualified Hasql.Session +import qualified Hasql.Statement + +-- | What a runner reports when it fails. +-- +-- hasql 2.1 replaced the single session-error type that +-- 'Hasql.Connection.use' returned with @UseError@, which distinguishes a +-- statement that failed on a live connection (@SessionUseError@, wrapping the +-- 'Hasql.Errors.SessionError' the old type expressed) from a connection that is +-- gone and has already been closed (@ConnectionUseError@). +-- +-- Named through this alias so the generated module compiles against both, and +-- so a call site that only passes the error along does not have to care. +#if MIN_VERSION_hasql(2,1,0) +type RunnerError = Hasql.Errors.UseError +#else +type RunnerError = Hasql.Errors.SessionError +#endif + +-- | The SQL of a query, with PostgreSQL's positional @$1@, @$2@ placeholders +-- left as sqlc emitted them. +newtype Query (name :: Symbol) (command :: Symbol) + = Query Data.Text.Text + +data family Params (name :: Symbol) + +data family Result (name :: Symbol) + +data family Enum (name :: Symbol) + +-- | The parameter encoder of a query. hasql has no such class of its own -- +-- encoders are plain values -- so sqlc-hs declares one and generates an +-- instance per query. +class ToRow a where + toRow :: Hasql.Encoders.Params a + +-- | The row decoder of a query's result. The counterpart of 'ToRow'. +class FromRow a where + fromRow :: Hasql.Decoders.Row a + +-- | The codec of a single value. +-- +-- sqlc-hs takes hasql's codec from the SQL type for every column it typed +-- itself, because hasql checks column types when decoding and @text@, @varchar@ +-- and @bpchar@ need three different decoders. Columns typed through an +-- @overrides@ entry go through this class instead, so a custom type only needs +-- an instance here: +-- +-- @ +-- instance ToField MyId where +-- toField = Data.Functor.Contravariant.contramap unMyId toField +-- @ +-- +-- An override can also name the codecs directly, with the @hasql_encoder@ and +-- @hasql_decoder@ keys, in which case no instance is needed. +class ToField a where + toField :: Hasql.Encoders.Value a + +-- | The counterpart of 'ToField'. +-- +-- @ +-- instance FromField MyId where +-- fromField = fmap MyId fromField +-- @ +class FromField a where + fromField :: Hasql.Decoders.Value a + +instance ToField Bool where + toField = Hasql.Encoders.bool + +instance ToField Data.Int.Int16 where + toField = Hasql.Encoders.int2 + +instance ToField Data.Int.Int32 where + toField = Hasql.Encoders.int4 + +instance ToField Data.Int.Int64 where + toField = Hasql.Encoders.int8 + +instance ToField Float where + toField = Hasql.Encoders.float4 + +instance ToField Double where + toField = Hasql.Encoders.float8 + +instance ToField Data.Scientific.Scientific where + toField = Hasql.Encoders.numeric + +instance ToField Char where + toField = Hasql.Encoders.char + +instance ToField Data.Text.Text where + toField = Hasql.Encoders.text + +instance ToField Data.ByteString.ByteString where + toField = Hasql.Encoders.bytea + +instance ToField Data.UUID.UUID where + toField = Hasql.Encoders.uuid + +instance ToField Data.Time.Day where + toField = Hasql.Encoders.date + +instance ToField Data.Time.LocalTime where + toField = Hasql.Encoders.timestamp + +instance ToField Data.Time.UTCTime where + toField = Hasql.Encoders.timestamptz + +instance ToField Data.Time.TimeOfDay where + toField = Hasql.Encoders.time + +instance ToField (Data.Time.TimeOfDay, Data.Time.TimeZone) where + toField = Hasql.Encoders.timetz + +instance ToField Data.Time.DiffTime where + toField = Hasql.Encoders.interval + +instance ToField Data.Aeson.Value where + toField = Hasql.Encoders.jsonb + +instance (ToField a) => ToField (Data.Vector.Vector a) where + toField = Hasql.Encoders.foldableArray (Hasql.Encoders.nonNullable toField) + +instance (ToField a) => ToField [a] where + toField = Hasql.Encoders.foldableArray (Hasql.Encoders.nonNullable toField) + +instance FromField Bool where + fromField = Hasql.Decoders.bool + +instance FromField Data.Int.Int16 where + fromField = Hasql.Decoders.int2 + +instance FromField Data.Int.Int32 where + fromField = Hasql.Decoders.int4 + +instance FromField Data.Int.Int64 where + fromField = Hasql.Decoders.int8 + +instance FromField Float where + fromField = Hasql.Decoders.float4 + +instance FromField Double where + fromField = Hasql.Decoders.float8 + +instance FromField Data.Scientific.Scientific where + fromField = Hasql.Decoders.numeric + +instance FromField Char where + fromField = Hasql.Decoders.char + +instance FromField Data.Text.Text where + fromField = Hasql.Decoders.text + +instance FromField Data.ByteString.ByteString where + fromField = Hasql.Decoders.bytea + +instance FromField Data.UUID.UUID where + fromField = Hasql.Decoders.uuid + +instance FromField Data.Time.Day where + fromField = Hasql.Decoders.date + +instance FromField Data.Time.LocalTime where + fromField = Hasql.Decoders.timestamp + +instance FromField Data.Time.UTCTime where + fromField = Hasql.Decoders.timestamptz + +instance FromField Data.Time.TimeOfDay where + fromField = Hasql.Decoders.time + +instance FromField (Data.Time.TimeOfDay, Data.Time.TimeZone) where + fromField = Hasql.Decoders.timetz + +instance FromField Data.Time.DiffTime where + fromField = Hasql.Decoders.interval + +instance FromField Data.Aeson.Value where + fromField = Hasql.Decoders.jsonb + +instance (FromField a) => FromField (Data.Vector.Vector a) where + fromField = Hasql.Decoders.vectorArray (Hasql.Decoders.nonNullable fromField) + +instance (FromField a) => FromField [a] where + fromField = Hasql.Decoders.listArray (Hasql.Decoders.nonNullable fromField) + +data ExecResult = ExecResult + { rowsAffected :: !Data.Int.Int64 + } + +-- | The statement a query and a result decoder make up. Use it to run a query +-- inside a 'Hasql.Pipeline.Pipeline'. +statement :: + (ToRow (Params name)) => + Query name command -> + Hasql.Decoders.Result result -> + Hasql.Statement.Statement (Params name) result +statement (Query sql) decoder = + Hasql.Statement.preparable sql toRow decoder + +exec :: + (ToRow (Params name)) => + Hasql.Connection.Connection -> + Query name ":exec" -> + Params name -> + IO (Either RunnerError ()) +exec connection query params = + Hasql.Connection.use connection (execSession query params) + +execSession :: + (ToRow (Params name)) => + Query name ":exec" -> + Params name -> + Hasql.Session.Session () +execSession query params = + Hasql.Session.statement params (statement query Hasql.Decoders.noResult) + +execRows :: + (ToRow (Params name)) => + Hasql.Connection.Connection -> + Query name ":execrows" -> + Params name -> + IO (Either RunnerError Data.Int.Int64) +execRows connection query params = + Hasql.Connection.use connection (execRowsSession query params) + +execRowsSession :: + (ToRow (Params name)) => + Query name ":execrows" -> + Params name -> + Hasql.Session.Session Data.Int.Int64 +execRowsSession query params = + Hasql.Session.statement params (statement query Hasql.Decoders.rowsAffected) + +execResult :: + (ToRow (Params name)) => + Hasql.Connection.Connection -> + Query name ":execresult" -> + Params name -> + IO (Either RunnerError ExecResult) +execResult connection query params = + Hasql.Connection.use connection (execResultSession query params) + +execResultSession :: + (ToRow (Params name)) => + Query name ":execresult" -> + Params name -> + Hasql.Session.Session ExecResult +execResultSession query params = do + rowsAffected <- Hasql.Session.statement params (statement query Hasql.Decoders.rowsAffected) + pure ExecResult { + rowsAffected + } + +queryOne :: + (ToRow (Params name), FromRow (Result name)) => + Hasql.Connection.Connection -> + Query name ":one" -> + Params name -> + IO (Either RunnerError (Maybe (Result name))) +queryOne connection query params = + Hasql.Connection.use connection (queryOneSession query params) + +queryOneSession :: + (ToRow (Params name), FromRow (Result name)) => + Query name ":one" -> + Params name -> + Hasql.Session.Session (Maybe (Result name)) +queryOneSession query params = + Hasql.Session.statement params (statement query (Hasql.Decoders.rowMaybe fromRow)) + +queryMany :: + (ToRow (Params name), FromRow (Result name)) => + Hasql.Connection.Connection -> + Query name ":many" -> + Params name -> + IO (Either RunnerError (Vector (Result name))) +queryMany connection query params = + Hasql.Connection.use connection (queryManySession query params) + +queryManySession :: + (ToRow (Params name), FromRow (Result name)) => + Query name ":many" -> + Params name -> + Hasql.Session.Session (Vector (Result name)) +queryManySession query params = + Hasql.Session.statement params (statement query (Hasql.Decoders.rowVector fromRow)) + +-- | Note that hasql folds a result purely, so unlike the postgresql-simple +-- backend the step function is not in 'IO'. +fold :: + (ToRow (Params name), FromRow (Result name)) => + Hasql.Connection.Connection -> + Query name ":many" -> + Params name -> + a -> + (a -> Result name -> a) -> + IO (Either RunnerError a) +fold connection query params initial step = + Hasql.Connection.use connection (foldSession query params initial step) +{-# INLINABLE fold #-} + +foldSession :: + (ToRow (Params name), FromRow (Result name)) => + Query name ":many" -> + Params name -> + a -> + (a -> Result name -> a) -> + Hasql.Session.Session a +foldSession query params initial step = + Hasql.Session.statement params (statement query (Hasql.Decoders.foldlRows step initial fromRow)) +{-# INLINABLE foldSession #-} + +-- | Runs the query once per set of parameters, pipelined into a single +-- round trip, and returns the total number of rows affected. +execMany :: + (ToRow (Params name), Foldable f) => + Hasql.Connection.Connection -> + Query name ":copyfrom" -> + f (Params name) -> + IO (Either RunnerError Data.Int.Int64) +execMany connection query params = + Hasql.Connection.use connection (execManySession query params) + +execManySession :: + (ToRow (Params name), Foldable f) => + Query name ":copyfrom" -> + f (Params name) -> + Hasql.Session.Session Data.Int.Int64 +execManySession query params = + Hasql.Session.pipeline + (fmap sum (traverse pipelined (Data.Foldable.toList params))) + where + pipelined param = + Hasql.Pipeline.statement param (statement query Hasql.Decoders.rowsAffected) diff --git a/test/golden/hasql-features/Queries/Types.hs b/test/golden/hasql-features/Queries/Types.hs new file mode 100644 --- /dev/null +++ b/test/golden/hasql-features/Queries/Types.hs @@ -0,0 +1,41 @@ +{- This file was auto-generated by sqlc-hs. -} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.Types where + +import qualified Hasql.Decoders +import qualified Hasql.Encoders +import Queries.Internal +import Prelude hiding (Enum) +import qualified Prelude + +data instance Enum "organization_role" + = Enum_organization_role_owner + | Enum_organization_role_admin + | Enum_organization_role_member + deriving stock (Eq, Ord, Show, Bounded, Prelude.Enum) + +instance ToField (Enum "organization_role") where + toField = + Hasql.Encoders.enum Prelude.Nothing "organization_role" $ \x -> + case x of + Enum_organization_role_owner -> "owner" + Enum_organization_role_admin -> "admin" + Enum_organization_role_member -> "member" + +instance FromField (Enum "organization_role") where + fromField = + Hasql.Decoders.enum Prelude.Nothing "organization_role" $ \x -> + case x of + "owner" -> Prelude.Just Enum_organization_role_owner + "admin" -> Prelude.Just Enum_organization_role_admin + "member" -> Prelude.Just Enum_organization_role_member + _ -> Prelude.Nothing + diff --git a/test/golden/hasql-features/hasql-features.cabal b/test/golden/hasql-features/hasql-features.cabal new file mode 100644 --- /dev/null +++ b/test/golden/hasql-features/hasql-features.cabal @@ -0,0 +1,24 @@ +cabal-version: 3.0 +name: hasql-features +version: 0.1.0.0 +library + build-depends: + aeson, + base, + bytestring, + hasql, + scientific, + text, + time, + uuid, + vector, + exposed-modules: + Queries + Queries.DeleteUsers + Queries.FindMembers + Queries.FindPosts + Queries.FindUserByName + Queries.FindUsers + Queries.GetEvent + Queries.Internal + Queries.Types diff --git a/test/golden/simple-query-hasql.input b/test/golden/simple-query-hasql.input new file mode 100644 --- /dev/null +++ b/test/golden/simple-query-hasql.input @@ -0,0 +1,82 @@ +settings { + engine: "postgresql" +} + +queries { + text: "SELECT * FROM users WHERE $1 > 42;" + name: "ListUsers" + cmd: ":many" + filename: "query/users.sql" + columns { + name: "id" + not_null: true + type { + name: "int" + } + } + columns { + name: "name" + not_null: true + type { + name: "pg_catalog.varchar" + } + } + columns { + name: "nickname" + type { + name: "text" + } + } + columns { + name: "initial" + not_null: true + type { + name: "pg_catalog.bpchar" + } + } + columns { + name: "is_admin" + not_null: true + type { + name: "bool" + } + } + columns { + name: "balance" + not_null: true + type { + name: "numeric" + } + } + columns { + name: "ratio" + type { + name: "pg_catalog.float8" + } + } + columns { + name: "meta" + not_null: true + type { + name: "jsonb" + } + } + columns { + name: "avatar" + type { + name: "bytea" + } + } + params { + number: 1 + column { + name: "age" + not_null: true + type { + name: "int" + } + } + } +} + +global_options: "{ \"cabal_package_name\": \"simple-query-hasql\", \"driver\": \"hasql\" }" diff --git a/test/golden/simple-query-hasql/Queries.hs b/test/golden/simple-query-hasql/Queries.hs new file mode 100644 --- /dev/null +++ b/test/golden/simple-query-hasql/Queries.hs @@ -0,0 +1,10 @@ +module Queries + ( module Queries.Internal, + module Queries.Types, + module Queries + ) +where + +import Queries.Internal +import Queries.Types +import Queries.ListUsers as Queries diff --git a/test/golden/simple-query-hasql/Queries/Internal.hs b/test/golden/simple-query-hasql/Queries/Internal.hs new file mode 100644 --- /dev/null +++ b/test/golden/simple-query-hasql/Queries/Internal.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.Internal ( + Query(..), + Params, + Result, + Queries.Internal.Enum, + + -- * Codecs + ToRow(..), + FromRow(..), + ToField(..), + FromField(..), + statement, + + -- * :execResult + ExecResult(..), + execResult, + execResultSession, + + -- * :exec + exec, + execSession, + + -- * :execrows + execRows, + execRowsSession, + + -- * :one + queryOne, + queryOneSession, + + -- * :many + queryMany, + queryManySession, + fold, + foldSession, + + -- * :copyfrom + execMany, + execManySession, + + -- * Reexports + Hasql.Connection.Connection, + Hasql.Session.Session, + RunnerError, + Hasql.Errors.SessionError, + ) where + +import Data.Foldable (Foldable) +import Data.Vector (Vector) +import GHC.TypeLits (Symbol) +import qualified Data.Aeson +import qualified Data.ByteString +import qualified Data.Foldable +import qualified Data.Int +import qualified Data.Scientific +import qualified Data.Text +import qualified Data.Time +import qualified Data.UUID +import qualified Data.Vector +import qualified Hasql.Connection +import qualified Hasql.Decoders +import qualified Hasql.Encoders +import qualified Hasql.Errors +import qualified Hasql.Pipeline +import qualified Hasql.Session +import qualified Hasql.Statement + +-- | What a runner reports when it fails. +-- +-- hasql 2.1 replaced the single session-error type that +-- 'Hasql.Connection.use' returned with @UseError@, which distinguishes a +-- statement that failed on a live connection (@SessionUseError@, wrapping the +-- 'Hasql.Errors.SessionError' the old type expressed) from a connection that is +-- gone and has already been closed (@ConnectionUseError@). +-- +-- Named through this alias so the generated module compiles against both, and +-- so a call site that only passes the error along does not have to care. +#if MIN_VERSION_hasql(2,1,0) +type RunnerError = Hasql.Errors.UseError +#else +type RunnerError = Hasql.Errors.SessionError +#endif + +-- | The SQL of a query, with PostgreSQL's positional @$1@, @$2@ placeholders +-- left as sqlc emitted them. +newtype Query (name :: Symbol) (command :: Symbol) + = Query Data.Text.Text + +data family Params (name :: Symbol) + +data family Result (name :: Symbol) + +data family Enum (name :: Symbol) + +-- | The parameter encoder of a query. hasql has no such class of its own -- +-- encoders are plain values -- so sqlc-hs declares one and generates an +-- instance per query. +class ToRow a where + toRow :: Hasql.Encoders.Params a + +-- | The row decoder of a query's result. The counterpart of 'ToRow'. +class FromRow a where + fromRow :: Hasql.Decoders.Row a + +-- | The codec of a single value. +-- +-- sqlc-hs takes hasql's codec from the SQL type for every column it typed +-- itself, because hasql checks column types when decoding and @text@, @varchar@ +-- and @bpchar@ need three different decoders. Columns typed through an +-- @overrides@ entry go through this class instead, so a custom type only needs +-- an instance here: +-- +-- @ +-- instance ToField MyId where +-- toField = Data.Functor.Contravariant.contramap unMyId toField +-- @ +-- +-- An override can also name the codecs directly, with the @hasql_encoder@ and +-- @hasql_decoder@ keys, in which case no instance is needed. +class ToField a where + toField :: Hasql.Encoders.Value a + +-- | The counterpart of 'ToField'. +-- +-- @ +-- instance FromField MyId where +-- fromField = fmap MyId fromField +-- @ +class FromField a where + fromField :: Hasql.Decoders.Value a + +instance ToField Bool where + toField = Hasql.Encoders.bool + +instance ToField Data.Int.Int16 where + toField = Hasql.Encoders.int2 + +instance ToField Data.Int.Int32 where + toField = Hasql.Encoders.int4 + +instance ToField Data.Int.Int64 where + toField = Hasql.Encoders.int8 + +instance ToField Float where + toField = Hasql.Encoders.float4 + +instance ToField Double where + toField = Hasql.Encoders.float8 + +instance ToField Data.Scientific.Scientific where + toField = Hasql.Encoders.numeric + +instance ToField Char where + toField = Hasql.Encoders.char + +instance ToField Data.Text.Text where + toField = Hasql.Encoders.text + +instance ToField Data.ByteString.ByteString where + toField = Hasql.Encoders.bytea + +instance ToField Data.UUID.UUID where + toField = Hasql.Encoders.uuid + +instance ToField Data.Time.Day where + toField = Hasql.Encoders.date + +instance ToField Data.Time.LocalTime where + toField = Hasql.Encoders.timestamp + +instance ToField Data.Time.UTCTime where + toField = Hasql.Encoders.timestamptz + +instance ToField Data.Time.TimeOfDay where + toField = Hasql.Encoders.time + +instance ToField (Data.Time.TimeOfDay, Data.Time.TimeZone) where + toField = Hasql.Encoders.timetz + +instance ToField Data.Time.DiffTime where + toField = Hasql.Encoders.interval + +instance ToField Data.Aeson.Value where + toField = Hasql.Encoders.jsonb + +instance (ToField a) => ToField (Data.Vector.Vector a) where + toField = Hasql.Encoders.foldableArray (Hasql.Encoders.nonNullable toField) + +instance (ToField a) => ToField [a] where + toField = Hasql.Encoders.foldableArray (Hasql.Encoders.nonNullable toField) + +instance FromField Bool where + fromField = Hasql.Decoders.bool + +instance FromField Data.Int.Int16 where + fromField = Hasql.Decoders.int2 + +instance FromField Data.Int.Int32 where + fromField = Hasql.Decoders.int4 + +instance FromField Data.Int.Int64 where + fromField = Hasql.Decoders.int8 + +instance FromField Float where + fromField = Hasql.Decoders.float4 + +instance FromField Double where + fromField = Hasql.Decoders.float8 + +instance FromField Data.Scientific.Scientific where + fromField = Hasql.Decoders.numeric + +instance FromField Char where + fromField = Hasql.Decoders.char + +instance FromField Data.Text.Text where + fromField = Hasql.Decoders.text + +instance FromField Data.ByteString.ByteString where + fromField = Hasql.Decoders.bytea + +instance FromField Data.UUID.UUID where + fromField = Hasql.Decoders.uuid + +instance FromField Data.Time.Day where + fromField = Hasql.Decoders.date + +instance FromField Data.Time.LocalTime where + fromField = Hasql.Decoders.timestamp + +instance FromField Data.Time.UTCTime where + fromField = Hasql.Decoders.timestamptz + +instance FromField Data.Time.TimeOfDay where + fromField = Hasql.Decoders.time + +instance FromField (Data.Time.TimeOfDay, Data.Time.TimeZone) where + fromField = Hasql.Decoders.timetz + +instance FromField Data.Time.DiffTime where + fromField = Hasql.Decoders.interval + +instance FromField Data.Aeson.Value where + fromField = Hasql.Decoders.jsonb + +instance (FromField a) => FromField (Data.Vector.Vector a) where + fromField = Hasql.Decoders.vectorArray (Hasql.Decoders.nonNullable fromField) + +instance (FromField a) => FromField [a] where + fromField = Hasql.Decoders.listArray (Hasql.Decoders.nonNullable fromField) + +data ExecResult = ExecResult + { rowsAffected :: !Data.Int.Int64 + } + +-- | The statement a query and a result decoder make up. Use it to run a query +-- inside a 'Hasql.Pipeline.Pipeline'. +statement :: + (ToRow (Params name)) => + Query name command -> + Hasql.Decoders.Result result -> + Hasql.Statement.Statement (Params name) result +statement (Query sql) decoder = + Hasql.Statement.preparable sql toRow decoder + +exec :: + (ToRow (Params name)) => + Hasql.Connection.Connection -> + Query name ":exec" -> + Params name -> + IO (Either RunnerError ()) +exec connection query params = + Hasql.Connection.use connection (execSession query params) + +execSession :: + (ToRow (Params name)) => + Query name ":exec" -> + Params name -> + Hasql.Session.Session () +execSession query params = + Hasql.Session.statement params (statement query Hasql.Decoders.noResult) + +execRows :: + (ToRow (Params name)) => + Hasql.Connection.Connection -> + Query name ":execrows" -> + Params name -> + IO (Either RunnerError Data.Int.Int64) +execRows connection query params = + Hasql.Connection.use connection (execRowsSession query params) + +execRowsSession :: + (ToRow (Params name)) => + Query name ":execrows" -> + Params name -> + Hasql.Session.Session Data.Int.Int64 +execRowsSession query params = + Hasql.Session.statement params (statement query Hasql.Decoders.rowsAffected) + +execResult :: + (ToRow (Params name)) => + Hasql.Connection.Connection -> + Query name ":execresult" -> + Params name -> + IO (Either RunnerError ExecResult) +execResult connection query params = + Hasql.Connection.use connection (execResultSession query params) + +execResultSession :: + (ToRow (Params name)) => + Query name ":execresult" -> + Params name -> + Hasql.Session.Session ExecResult +execResultSession query params = do + rowsAffected <- Hasql.Session.statement params (statement query Hasql.Decoders.rowsAffected) + pure ExecResult { + rowsAffected + } + +queryOne :: + (ToRow (Params name), FromRow (Result name)) => + Hasql.Connection.Connection -> + Query name ":one" -> + Params name -> + IO (Either RunnerError (Maybe (Result name))) +queryOne connection query params = + Hasql.Connection.use connection (queryOneSession query params) + +queryOneSession :: + (ToRow (Params name), FromRow (Result name)) => + Query name ":one" -> + Params name -> + Hasql.Session.Session (Maybe (Result name)) +queryOneSession query params = + Hasql.Session.statement params (statement query (Hasql.Decoders.rowMaybe fromRow)) + +queryMany :: + (ToRow (Params name), FromRow (Result name)) => + Hasql.Connection.Connection -> + Query name ":many" -> + Params name -> + IO (Either RunnerError (Vector (Result name))) +queryMany connection query params = + Hasql.Connection.use connection (queryManySession query params) + +queryManySession :: + (ToRow (Params name), FromRow (Result name)) => + Query name ":many" -> + Params name -> + Hasql.Session.Session (Vector (Result name)) +queryManySession query params = + Hasql.Session.statement params (statement query (Hasql.Decoders.rowVector fromRow)) + +-- | Note that hasql folds a result purely, so unlike the postgresql-simple +-- backend the step function is not in 'IO'. +fold :: + (ToRow (Params name), FromRow (Result name)) => + Hasql.Connection.Connection -> + Query name ":many" -> + Params name -> + a -> + (a -> Result name -> a) -> + IO (Either RunnerError a) +fold connection query params initial step = + Hasql.Connection.use connection (foldSession query params initial step) +{-# INLINABLE fold #-} + +foldSession :: + (ToRow (Params name), FromRow (Result name)) => + Query name ":many" -> + Params name -> + a -> + (a -> Result name -> a) -> + Hasql.Session.Session a +foldSession query params initial step = + Hasql.Session.statement params (statement query (Hasql.Decoders.foldlRows step initial fromRow)) +{-# INLINABLE foldSession #-} + +-- | Runs the query once per set of parameters, pipelined into a single +-- round trip, and returns the total number of rows affected. +execMany :: + (ToRow (Params name), Foldable f) => + Hasql.Connection.Connection -> + Query name ":copyfrom" -> + f (Params name) -> + IO (Either RunnerError Data.Int.Int64) +execMany connection query params = + Hasql.Connection.use connection (execManySession query params) + +execManySession :: + (ToRow (Params name), Foldable f) => + Query name ":copyfrom" -> + f (Params name) -> + Hasql.Session.Session Data.Int.Int64 +execManySession query params = + Hasql.Session.pipeline + (fmap sum (traverse pipelined (Data.Foldable.toList params))) + where + pipelined param = + Hasql.Pipeline.statement param (statement query Hasql.Decoders.rowsAffected) diff --git a/test/golden/simple-query-hasql/Queries/ListUsers.hs b/test/golden/simple-query-hasql/Queries/ListUsers.hs new file mode 100644 --- /dev/null +++ b/test/golden/simple-query-hasql/Queries/ListUsers.hs @@ -0,0 +1,68 @@ +{- This file was auto-generated from query/users.sql by sqlc-hs. -} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.ListUsers where + +import Queries.Internal (Query(..), Enum, Params, Result, ToRow(..), FromRow(..), ToField(..), FromField(..)) +import qualified Hasql.Decoders +import qualified Hasql.Encoders + +import qualified Data.Int +import qualified Data.Text +import qualified GHC.Base +import qualified GHC.Types +import qualified Data.Scientific +import qualified Data.Aeson +import qualified Data.ByteString +import qualified Data.Foldable +import qualified Data.Functor.Contravariant + +query_ListUsers :: Query "ListUsers" ":many" +query_ListUsers = Query "SELECT * FROM users WHERE $1 > 42;" + +data instance Params "ListUsers" = Params_ListUsers + { + age :: Data.Int.Int32 + } + +data instance Result "ListUsers" = Result_ListUsers + { + id :: !(Data.Int.Int32), + name :: !(Data.Text.Text), + nickname :: !(GHC.Base.Maybe Data.Text.Text), + initial :: !(Data.Text.Text), + is_admin :: !(GHC.Types.Bool), + balance :: !(Data.Scientific.Scientific), + ratio :: !(GHC.Base.Maybe GHC.Types.Double), + meta :: !(Data.Aeson.Value), + avatar :: !(GHC.Base.Maybe Data.ByteString.ByteString) + } + +instance ToRow (Params "ListUsers") where + {-# INLINE toRow #-} + toRow = + mconcat + [ + Data.Functor.Contravariant.contramap (\Params_ListUsers{..} -> age) (Hasql.Encoders.param (Hasql.Encoders.nonNullable Hasql.Encoders.int4)) + ] + +instance FromRow (Result "ListUsers") where + {-# INLINE fromRow #-} + fromRow = + pure Result_ListUsers + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable Hasql.Decoders.int4) + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable Hasql.Decoders.varchar) + <*> Hasql.Decoders.column (Hasql.Decoders.nullable Hasql.Decoders.text) + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable Hasql.Decoders.bpchar) + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable Hasql.Decoders.bool) + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable Hasql.Decoders.numeric) + <*> Hasql.Decoders.column (Hasql.Decoders.nullable Hasql.Decoders.float8) + <*> Hasql.Decoders.column (Hasql.Decoders.nonNullable Hasql.Decoders.jsonb) + <*> Hasql.Decoders.column (Hasql.Decoders.nullable Hasql.Decoders.bytea) + + diff --git a/test/golden/simple-query-hasql/Queries/Types.hs b/test/golden/simple-query-hasql/Queries/Types.hs new file mode 100644 --- /dev/null +++ b/test/golden/simple-query-hasql/Queries/Types.hs @@ -0,0 +1,18 @@ +{- This file was auto-generated by sqlc-hs. -} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.Types where + +import qualified Hasql.Decoders +import qualified Hasql.Encoders +import Queries.Internal +import Prelude hiding (Enum) +import qualified Prelude + diff --git a/test/golden/simple-query-hasql/simple-query-hasql.cabal b/test/golden/simple-query-hasql/simple-query-hasql.cabal new file mode 100644 --- /dev/null +++ b/test/golden/simple-query-hasql/simple-query-hasql.cabal @@ -0,0 +1,20 @@ +cabal-version: 3.0 +name: simple-query-hasql +version: 0.1.0.0 +library + build-depends: + aeson, + base, + bytestring, + ghc-prim, + hasql, + scientific, + text, + time, + uuid, + vector, + exposed-modules: + Queries + Queries.Internal + Queries.ListUsers + Queries.Types diff --git a/test/golden/sqlite-arg-placeholders.input b/test/golden/sqlite-arg-placeholders.input new file mode 100644 --- /dev/null +++ b/test/golden/sqlite-arg-placeholders.input @@ -0,0 +1,46 @@ +settings { + engine: "sqlite" +} + +queries { + text: "SELECT * FROM users WHERE name = ?1 OR nickname = ?1 OR age > ?2;" + name: "FindUsers" + cmd: "SELECT" + filename: "query/users.sql" + columns { + name: "id" + not_null: true + type { + name: "int" + } + } + columns { + name: "name" + not_null: true + type { + name: "text" + } + } + params { + number: 1 + column { + name: "name" + not_null: true + type { + name: "text" + } + } + } + params { + number: 2 + column { + name: "min_age" + not_null: true + type { + name: "int" + } + } + } +} + +global_options: "{ \"cabal_package_name\": \"sqlite-arg-placeholders\", \"cabal_default_extensions\": [\"OverloadedStrings\", \"StrictData\"] }" diff --git a/test/golden/sqlite-arg-placeholders/Queries.hs b/test/golden/sqlite-arg-placeholders/Queries.hs new file mode 100644 --- /dev/null +++ b/test/golden/sqlite-arg-placeholders/Queries.hs @@ -0,0 +1,10 @@ +module Queries + ( module Queries.Internal, + module Queries.Types, + module Queries + ) +where + +import Queries.Internal +import Queries.Types +import Queries.FindUsers as Queries diff --git a/test/golden/sqlite-arg-placeholders/Queries/FindUsers.hs b/test/golden/sqlite-arg-placeholders/Queries/FindUsers.hs new file mode 100644 --- /dev/null +++ b/test/golden/sqlite-arg-placeholders/Queries/FindUsers.hs @@ -0,0 +1,51 @@ +{- This file was auto-generated from query/users.sql by sqlc-hs. -} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.FindUsers where + +import Queries.Internal (Query(..), Enum, Params, Result) +import qualified Database.SQLite.Simple.FromRow +import qualified Database.SQLite.Simple.ToField +import qualified Database.SQLite.Simple.ToRow + +import qualified Data.Text +import qualified Data.Int +import qualified Data.Foldable + +query_FindUsers :: Query "FindUsers" "SELECT" +query_FindUsers = Query "SELECT * FROM users WHERE name = ? OR nickname = ? OR age > ?;" + +data instance Params "FindUsers" = Params_FindUsers + { + name :: Data.Text.Text, + min_age :: Data.Int.Int64 + } + +data instance Result "FindUsers" = Result_FindUsers + { + id :: !(Data.Int.Int64), + name :: !(Data.Text.Text) + } + + +instance Database.SQLite.Simple.ToRow.ToRow (Params "FindUsers") where + toRow Params_FindUsers{..} = + [ + Database.SQLite.Simple.ToField.toField name, + + Database.SQLite.Simple.ToField.toField name, + + Database.SQLite.Simple.ToField.toField min_age + ] + +instance Database.SQLite.Simple.FromRow.FromRow (Result "FindUsers") where + fromRow = + pure Result_FindUsers + <*> Database.SQLite.Simple.FromRow.field + <*> Database.SQLite.Simple.FromRow.field + diff --git a/test/golden/sqlite-arg-placeholders/Queries/Internal.hs b/test/golden/sqlite-arg-placeholders/Queries/Internal.hs new file mode 100644 --- /dev/null +++ b/test/golden/sqlite-arg-placeholders/Queries/Internal.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.Internal ( + Query(..), + Params, + Result, + Queries.Internal.Enum, + + -- * :execResult + ExecResult(..), + execResult, + + -- * :exec + exec, + + -- * :execrows + execRows, + + -- * :execlastid + execLastId, + + -- * :one + queryOne, + + -- * :many + queryMany, + fold, + + -- * Reexports + Database.SQLite.Simple.Connection, + Database.SQLite.Simple.ToRow, + Database.SQLite.Simple.FromRow, + ) where + +import Database.SQLite.Simple (Connection, FromRow, ToRow) +import GHC.TypeLits (Symbol) +import qualified Data.Int +import qualified Database.SQLite.Simple +import qualified Data.Vector +import qualified Data.Vector.Mutable + +newtype Query (name :: Symbol) (command :: Symbol) + = Query Database.SQLite.Simple.Query + +data family Params (name :: Symbol) + +data family Result (name :: Symbol) + +data family Enum (name :: Symbol) + +data ExecResult = ExecResult + { lastInsertId :: !Data.Int.Int64, + rowsAffected :: !Data.Int.Int64 + } + +exec :: + (ToRow (Params name)) => + Connection -> + Query name ":exec" -> + Params name -> + IO () +exec connection (Query sql) = + Database.SQLite.Simple.execute connection sql + +execRows :: + (ToRow (Params name)) => + Connection -> + Query name ":execrows" -> + Params name -> + IO Data.Int.Int64 +execRows connection (Query sql) params = do + Database.SQLite.Simple.execute connection sql params + rowsAffected <- Database.SQLite.Simple.changes connection + pure (fromIntegral rowsAffected) + +execLastId :: + (ToRow (Params name)) => + Connection -> + Query name ":execlastid" -> + Params name -> + IO Data.Int.Int64 +execLastId connection (Query sql) params = do + Database.SQLite.Simple.execute connection sql params + lastInsertId <- Database.SQLite.Simple.lastInsertRowId connection + pure lastInsertId + +execResult :: + (ToRow (Params name)) => + Connection -> + Query name ":execresult" -> + Params name -> + IO ExecResult +execResult connection (Query sql) params = do + Database.SQLite.Simple.execute connection sql params + rowsAffected <- Database.SQLite.Simple.changes connection + lastInsertId <- Database.SQLite.Simple.lastInsertRowId connection + pure ExecResult { + lastInsertId, + rowsAffected = fromIntegral rowsAffected + } + +queryOne :: + (ToRow (Params name), FromRow (Result name)) => + Connection -> + Query name ":one" -> + Params name -> + IO (Maybe (Result name)) +queryOne connection (Query sql) params = do + result <- Database.SQLite.Simple.query connection sql params + case result of + [] -> pure Nothing + x : _ -> pure (Just x) + +data Grow v = Grow !Int !v + +queryMany :: + (ToRow (Params name), FromRow (Result name)) => + Connection -> + Query name ":many" -> + Params name -> + IO (Data.Vector.Vector (Result name)) +queryMany connection query params = do + vector <- Data.Vector.Mutable.unsafeNew 4 + Grow i vector <- fold connection query params (Grow 0 vector) step + vector <- Data.Vector.unsafeFreeze vector + pure $! Data.Vector.unsafeTake i vector + where + step (Grow i vector) !result + | i < Data.Vector.Mutable.length vector = do + Data.Vector.Mutable.unsafeWrite vector i result + pure $! Grow (i + 1) vector + | otherwise = do + -- Grow vector exponentially by doubling its size + vector <- Data.Vector.Mutable.unsafeGrow vector i + Data.Vector.Mutable.unsafeWrite vector i result + pure $! Grow (i + 1) vector + +fold :: + (ToRow (Params name), FromRow (Result name)) => + Connection -> + Query name ":many" -> + Params name -> + a -> + (a -> Result name -> IO a) -> + IO a +fold connection (Query sql) = + Database.SQLite.Simple.fold connection sql +{-# INLINABLE fold #-} diff --git a/test/golden/sqlite-arg-placeholders/Queries/Types.hs b/test/golden/sqlite-arg-placeholders/Queries/Types.hs new file mode 100644 --- /dev/null +++ b/test/golden/sqlite-arg-placeholders/Queries/Types.hs @@ -0,0 +1,19 @@ +{- This file was auto-generated by sqlc-hs. -} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +module Queries.Types where + +import qualified Database.SQLite.Simple.FromRow +import qualified Database.SQLite.Simple.ToField +import qualified Database.SQLite.Simple.ToRow +import Queries.Internal +import Prelude hiding (Enum) +import qualified Prelude + diff --git a/test/golden/sqlite-arg-placeholders/sqlite-arg-placeholders.cabal b/test/golden/sqlite-arg-placeholders/sqlite-arg-placeholders.cabal new file mode 100644 --- /dev/null +++ b/test/golden/sqlite-arg-placeholders/sqlite-arg-placeholders.cabal @@ -0,0 +1,18 @@ +cabal-version: 3.0 +name: sqlite-arg-placeholders +version: 0.1.0.0 +library + build-depends: + base, + bytestring, + sqlite-simple, + text, + vector, + exposed-modules: + Queries + Queries.FindUsers + Queries.Internal + Queries.Types + default-extensions: + OverloadedStrings + StrictData