From a5693a2010e6d13f51cdc576fa1dc9985e79ee0e Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Przemys=C5=82aw=20Kaminski?= <pk@intrepidus.pl>
Date: Mon, 27 Feb 2023 06:17:12 +0100
Subject: [PATCH] [FTS] full text search implementation

---
 src/Opaleye/Internal/HaskellDB/PrimQuery.hs   |  1 +
 src/Opaleye/Internal/HaskellDB/Sql/Default.hs |  1 +
 src/Opaleye/Internal/PGTypesExternal.hs       | 14 ++++++++++++++
 src/Opaleye/Operators.hs                      |  7 +++++++
 src/Opaleye/SqlTypes.hs                       |  7 +++++++
 5 files changed, 30 insertions(+)

diff --git a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs
index e9d5c71c..2e85e2ba 100644
--- a/src/Opaleye/Internal/HaskellDB/PrimQuery.hs
+++ b/src/Opaleye/Internal/HaskellDB/PrimQuery.hs
@@ -64,6 +64,7 @@ data BinOp      = (:==) | (:<) | (:<=) | (:>) | (:>=) | (:<>)
                 | (:->) | (:->>) | (:#>) | (:#>>)
                 | (:@>) | (:<@) | (:?) | (:?|) | (:?&)
                 | (:&&) | (:<<) | (:>>) | (:&<) | (:&>) | (:-|-)
+                | (:@@)
                 deriving (Show,Read)
 
 data UnOp = OpNot
diff --git a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs
index 4fb964fd..9258d2db 100644
--- a/src/Opaleye/Internal/HaskellDB/Sql/Default.hs
+++ b/src/Opaleye/Internal/HaskellDB/Sql/Default.hs
@@ -205,6 +205,7 @@ showBinOp  (:>>)        = ">>"
 showBinOp  (:&<)        = "&<"
 showBinOp  (:&>)        = "&>"
 showBinOp  (:-|-)       = "-|-"
+showBinOp  (:@@)        = "@@"
 
 data UnOpType = UnOpFun | UnOpPrefix | UnOpPostfix
 
diff --git a/src/Opaleye/Internal/PGTypesExternal.hs b/src/Opaleye/Internal/PGTypesExternal.hs
index c8f18760..632980cc 100644
--- a/src/Opaleye/Internal/PGTypesExternal.hs
+++ b/src/Opaleye/Internal/PGTypesExternal.hs
@@ -182,6 +182,15 @@ pgRange pgEl start end =
         oneEl R.NegInfinity   = HPQ.NegInfinity
         oneEl R.PosInfinity   = HPQ.PosInfinity
 
+-- Full Text Search
+
+pgTSVector :: Field SqlText -> Field SqlTSVector
+pgTSVector (C.Column e) = C.Column (HPQ.FunExpr "tsvector" [e])
+
+pgTSQuery :: Field SqlText -> Field SqlTSQuery
+pgTSQuery (C.Column e) = C.Column (HPQ.FunExpr "tsquery" [e])
+
+
 instance IsSqlType SqlBool where
   showSqlType _ = "boolean"
 instance IsSqlType SqlDate where
@@ -246,6 +255,9 @@ instance IsRangeType SqlTimestamptz where
 instance IsRangeType SqlDate where
   showRangeType _ = "daterange"
 
+instance IsSqlType SqlTSQuery where
+  showSqlType _ = "tsquery"
+
 -- * SQL datatypes
 
 data SqlBool
@@ -287,6 +299,8 @@ data SqlBytea
 data SqlJson
 data SqlJsonb
 data SqlRange a
+data SqlTSQuery
+data SqlTSVector
 
 type PGBool = SqlBool
 type PGDate = SqlDate
diff --git a/src/Opaleye/Operators.hs b/src/Opaleye/Operators.hs
index cee26942..892b2b18 100644
--- a/src/Opaleye/Operators.hs
+++ b/src/Opaleye/Operators.hs
@@ -39,6 +39,7 @@ module Opaleye.Operators
   , (.<)
   , (.<=)
   , (.>=)
+  , (@@)
   -- * Numerical operators
   , quot_
   , rem_
@@ -212,6 +213,12 @@ infix 4 .>=
 (.>=) :: Ord.SqlOrd a => Field a -> Field a -> F.Field T.SqlBool
 (.>=) = C.binOp (HPQ.:>=)
 
+infix 4 @@
+(@@) :: Field T.SqlTSVector -> Field T.SqlTSQuery -> F.Field T.SqlBool
+(@@) = C.binOp (HPQ.:@@)
+
+-- * Numerical operators
+
 -- | Integral division, named after 'Prelude.quot'.  It maps to the
 -- @/@ operator in Postgres.
 quot_ :: C.SqlIntegral a => Field a -> Field a -> Field a
diff --git a/src/Opaleye/SqlTypes.hs b/src/Opaleye/SqlTypes.hs
index 1dc86ee2..196b12e5 100644
--- a/src/Opaleye/SqlTypes.hs
+++ b/src/Opaleye/SqlTypes.hs
@@ -90,6 +90,10 @@ module Opaleye.SqlTypes (
   SqlBytea,
   -- * @IsSqlType@
   P.IsSqlType(P.showSqlType),
+
+  P.SqlTSQuery,
+  P.SqlTSVector,
+  sqlTSQuery
   ) where
 
 import qualified Opaleye.Field   as F
@@ -207,6 +211,9 @@ sqlLazyJSON = P.pgLazyJSON
 sqlValueJSON :: Ae.ToJSON a => a -> F.Field SqlJson
 sqlValueJSON = P.pgValueJSON
 
+sqlTSQuery :: String -> F.Field P.SqlTSQuery
+sqlTSQuery = P.pgTSQuery . sqlString
+
 -- The jsonb data type was introduced in PostgreSQL version 9.4
 -- JSONB values must be SQL string quoted
 --