Make binaryOperator take a QualifiedName instead of a String (#262

)

changelog.d/20230711_125727_shane.obrien_QualifiedName.md

@@ -12,12 +12,12 @@ Uncomment the section that is right (remove the HTML comment wrapper).
 -->
 ### Added
 
-- Added the `QualifiedName` type for named PostgreSQL objects (tables, views, functions, sequences, etc.) that can optionally be qualified by a schema, including an `IsString` instance.
+- Added the `QualifiedName` type for named PostgreSQL objects (tables, views, functions, operators, sequences, etc.) that can optionally be qualified by a schema, including an `IsString` instance.
 
 ### Changed
 
 - The `schema` field from `TableSchema` has been removed and the name field changed from `String` to `QualifiedName`.
-- `nextval` and `function` now take a `QualifiedName` instead of a `String`.
+- `nextval`, `function` and `binaryOperator` now take a `QualifiedName` instead of a `String`.
 
 <!--
 ### Deprecated

rel8.cabal

@@ -135,6 +135,7 @@ library
 
     Rel8.Schema.Context.Nullify
     Rel8.Schema.Dict
+    Rel8.Schema.Escape
     Rel8.Schema.Field
     Rel8.Schema.HTable
     Rel8.Schema.HTable.Either

src/Rel8/Expr/Function.hs

@@ -1,6 +1,7 @@
 {-# language FlexibleContexts #-}
 {-# language FlexibleInstances #-}
 {-# language MultiParamTypeClasses #-}
+{-# language RecordWildCards #-}
 {-# language StandaloneKindSignatures #-}
 {-# language TypeFamilies #-}
 {-# language TypeOperators #-}
@@ -21,15 +22,19 @@ import Prelude
 -- opaleye
 import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 
+-- pretty
+import Text.PrettyPrint (parens, text)
+
 -- rel8
 import {-# SOURCE #-} Rel8.Expr (Expr)
 import Rel8.Expr.Opaleye
   ( castExpr
   , fromPrimExpr, toPrimExpr, zipPrimExprsWith
   )
+import Rel8.Schema.Escape (escape)
 import Rel8.Schema.HTable (hfoldMap)
 import Rel8.Schema.Null ( Sql )
-import Rel8.Schema.QualifiedName (QualifiedName, ppQualifiedName)
+import Rel8.Schema.QualifiedName (QualifiedName (..), showQualifiedName)
 import Rel8.Table (Table, toColumns)
 import Rel8.Type ( DBType )
 
@@ -61,11 +66,20 @@ primFunction :: Arguments arguments
   => QualifiedName -> arguments -> Opaleye.PrimExpr
 primFunction qualified = Opaleye.FunExpr name . arguments
   where
-    name = show (ppQualifiedName qualified)
+    name = showQualifiedName qualified
 
 
 -- | Construct an expression by applying an infix binary operator to two
 -- operands.
-binaryOperator :: Sql DBType c => String -> Expr a -> Expr b -> Expr c
+binaryOperator :: Sql DBType c => QualifiedName -> Expr a -> Expr b -> Expr c
 binaryOperator operator a b =
-  castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther operator)) a b
+  castExpr $ zipPrimExprsWith (Opaleye.BinExpr (Opaleye.OpOther name)) a b
+  where
+    name = showQualifiedOperator operator
+
+
+showQualifiedOperator :: QualifiedName -> String
+showQualifiedOperator QualifiedName {schema = mschema, ..} = case mschema of
+  Nothing -> name
+  Just schema ->
+    show $ text "OPERATOR" <> parens (escape schema <> text "." <> text name)

src/Rel8/Expr/Sequence.hs

@@ -13,13 +13,13 @@ import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
 -- rel8
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Opaleye (fromPrimExpr)
-import Rel8.Schema.QualifiedName (QualifiedName, ppQualifiedName)
+import Rel8.Schema.QualifiedName (QualifiedName, showQualifiedName)
 
 
 -- | See https://www.postgresql.org/docs/current/functions-sequence.html
 nextval :: QualifiedName -> Expr Int64
 nextval name =
   fromPrimExpr $
     Opaleye.FunExpr "nextval"
-      [ Opaleye.ConstExpr (Opaleye.StringLit (show (ppQualifiedName name)))
+      [ Opaleye.ConstExpr (Opaleye.StringLit (showQualifiedName name))
       ]

src/Rel8/Expr/Text.hs

@@ -33,9 +33,13 @@ import Prelude ( flip )
 -- bytestring
 import Data.ByteString ( ByteString )
 
+-- opaleye
+import qualified Opaleye.Internal.HaskellDB.PrimQuery as Opaleye
+
 -- rel8
 import Rel8.Expr ( Expr )
 import Rel8.Expr.Function (binaryOperator, function)
+import Rel8.Expr.Opaleye (zipPrimExprsWith)
 
 -- text
 import Data.Text (Text)
@@ -285,7 +289,7 @@ translate a b c = function "translate" (a, b, c)
 -- you can write expressions like
 -- @filter (like "Rel%" . packageName) =<< each haskellPackages@
 like :: Expr Text -> Expr Text -> Expr Bool
-like = flip (binaryOperator "LIKE")
+like = flip (zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpLike))
 
 
 -- | @ilike x y@ corresponds to the expression @y ILIKE x@.
@@ -294,4 +298,4 @@ like = flip (binaryOperator "LIKE")
 -- you can write expressions like
 -- @filter (ilike "Rel%" . packageName) =<< each haskellPackages@
 ilike :: Expr Text -> Expr Text -> Expr Bool
-ilike = flip (binaryOperator "ILIKE")
+ilike = flip (zipPrimExprsWith (Opaleye.BinExpr Opaleye.OpILike))

src/Rel8/Schema/Escape.hs

@@ -0,0 +1,20 @@
+{-# language LambdaCase #-}
+
+module Rel8.Schema.Escape
+  ( escape
+  )
+where
+
+-- base
+import Prelude
+
+-- pretty
+import Text.PrettyPrint (Doc, doubleQuotes, text)
+
+
+escape :: String -> Doc
+escape = doubleQuotes . text . concatMap go
+  where
+    go = \case
+      '"' -> "\"\""
+      c -> [c]

src/Rel8/Schema/QualifiedName.hs

@@ -7,6 +7,7 @@
 module Rel8.Schema.QualifiedName
   ( QualifiedName (..)
   , ppQualifiedName
+  , showQualifiedName
   )
 where
 
@@ -15,12 +16,11 @@ import Data.Kind (Type)
 import Data.String (IsString, fromString)
 import Prelude
 
--- opaleye
-import qualified Opaleye.Internal.HaskellDB.Sql as Opaleye
-import qualified Opaleye.Internal.HaskellDB.Sql.Print as Opaleye
-
 -- pretty
-import Text.PrettyPrint (Doc)
+import Text.PrettyPrint (Doc, text)
+
+-- rel8
+import Rel8.Schema.Escape (escape)
 
 
 -- | A name of an object (such as a table, view, function or sequence)
@@ -43,7 +43,12 @@ instance IsString QualifiedName where
 
 
 ppQualifiedName :: QualifiedName -> Doc
-ppQualifiedName QualifiedName {..} = Opaleye.ppTable Opaleye.SqlTable
-  { sqlTableSchemaName = schema
-  , sqlTableName = name
-  }
+ppQualifiedName QualifiedName {schema = mschema, ..} = case mschema of
+  Nothing -> name'
+  Just schema -> escape schema <> text "." <> name'
+  where
+    name' = escape name
+
+
+showQualifiedName :: QualifiedName -> String
+showQualifiedName = show . ppQualifiedName

src/Rel8/Statement.hs

@@ -55,6 +55,7 @@ import Rel8.Expr.Bool (false)
 import Rel8.Query (Query)
 import Rel8.Query.Aggregate (countRows)
 import Rel8.Query.Each (each)
+import Rel8.Schema.Escape (escape)
 import Rel8.Schema.Table (TableSchema (..))
 import Rel8.Statement.Rows (Rows (..))
 import Rel8.Table (Table)
@@ -315,13 +316,5 @@ ppAlias Binding {relation, columns = mcolumns} = case mcolumns of
     parens (hcat (punctuate comma (escape <$> toList columns)))
 
 
-escape :: String -> Doc
-escape = doubleQuotes . text . concatMap go
-  where
-    go = \case
-      '"' -> "\"\""
-      c -> [c]
-
-
 unsnoc :: [a] -> Maybe ([a], a)
 unsnoc = foldr (\x -> Just . maybe ([], x) (\(~(a, b)) -> (x : a, b))) Nothing