{-# LANGUAGE TemplateHaskell #-}
{-|
Module: IHP.Postgres.TSVector
Description: Adds support for the Postgres tsvector type
Copyright: (c) digitally induced GmbH, 2021
-}
module IHP.Postgres.TSVector where

import BasicPrelude
import Data.String.Conversions (cs)
import IHP.Postgres.TypeInfo
import Database.PostgreSQL.Simple.ToField
import Database.PostgreSQL.Simple.FromField
import Database.PostgreSQL.Simple.TypeInfo.Macro
import Data.Attoparsec.ByteString.Char8 as Attoparsec hiding (Parser(..))
import Data.Attoparsec.Internal.Types (Parser)
import Data.ByteString.Builder (byteString, charUtf8)

-- | Represents a Postgres tsvector
--
-- See https://www.postgresql.org/docs/current/datatype-textsearch.html
data TSVector
    = TSVector [Lexeme]
    deriving (TSVector -> TSVector -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TSVector -> TSVector -> Bool
$c/= :: TSVector -> TSVector -> Bool
== :: TSVector -> TSVector -> Bool
$c== :: TSVector -> TSVector -> Bool
Eq, Int -> TSVector -> ShowS
[TSVector] -> ShowS
TSVector -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TSVector] -> ShowS
$cshowList :: [TSVector] -> ShowS
show :: TSVector -> String
$cshow :: TSVector -> String
showsPrec :: Int -> TSVector -> ShowS
$cshowsPrec :: Int -> TSVector -> ShowS
Show, Eq TSVector
TSVector -> TSVector -> Bool
TSVector -> TSVector -> Ordering
TSVector -> TSVector -> TSVector
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TSVector -> TSVector -> TSVector
$cmin :: TSVector -> TSVector -> TSVector
max :: TSVector -> TSVector -> TSVector
$cmax :: TSVector -> TSVector -> TSVector
>= :: TSVector -> TSVector -> Bool
$c>= :: TSVector -> TSVector -> Bool
> :: TSVector -> TSVector -> Bool
$c> :: TSVector -> TSVector -> Bool
<= :: TSVector -> TSVector -> Bool
$c<= :: TSVector -> TSVector -> Bool
< :: TSVector -> TSVector -> Bool
$c< :: TSVector -> TSVector -> Bool
compare :: TSVector -> TSVector -> Ordering
$ccompare :: TSVector -> TSVector -> Ordering
Ord)

data Lexeme
    = Lexeme { Lexeme -> Text
token :: Text, Lexeme -> [LexemeRanking]
ranking :: [LexemeRanking] }
    deriving (Lexeme -> Lexeme -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Lexeme -> Lexeme -> Bool
$c/= :: Lexeme -> Lexeme -> Bool
== :: Lexeme -> Lexeme -> Bool
$c== :: Lexeme -> Lexeme -> Bool
Eq, Int -> Lexeme -> ShowS
[Lexeme] -> ShowS
Lexeme -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Lexeme] -> ShowS
$cshowList :: [Lexeme] -> ShowS
show :: Lexeme -> String
$cshow :: Lexeme -> String
showsPrec :: Int -> Lexeme -> ShowS
$cshowsPrec :: Int -> Lexeme -> ShowS
Show, Eq Lexeme
Lexeme -> Lexeme -> Bool
Lexeme -> Lexeme -> Ordering
Lexeme -> Lexeme -> Lexeme
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Lexeme -> Lexeme -> Lexeme
$cmin :: Lexeme -> Lexeme -> Lexeme
max :: Lexeme -> Lexeme -> Lexeme
$cmax :: Lexeme -> Lexeme -> Lexeme
>= :: Lexeme -> Lexeme -> Bool
$c>= :: Lexeme -> Lexeme -> Bool
> :: Lexeme -> Lexeme -> Bool
$c> :: Lexeme -> Lexeme -> Bool
<= :: Lexeme -> Lexeme -> Bool
$c<= :: Lexeme -> Lexeme -> Bool
< :: Lexeme -> Lexeme -> Bool
$c< :: Lexeme -> Lexeme -> Bool
compare :: Lexeme -> Lexeme -> Ordering
$ccompare :: Lexeme -> Lexeme -> Ordering
Ord)

data LexemeRanking
    = LexemeRanking { LexemeRanking -> Int
position :: Int, LexemeRanking -> Char
weight :: Char }
    deriving (LexemeRanking -> LexemeRanking -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LexemeRanking -> LexemeRanking -> Bool
$c/= :: LexemeRanking -> LexemeRanking -> Bool
== :: LexemeRanking -> LexemeRanking -> Bool
$c== :: LexemeRanking -> LexemeRanking -> Bool
Eq, Int -> LexemeRanking -> ShowS
[LexemeRanking] -> ShowS
LexemeRanking -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LexemeRanking] -> ShowS
$cshowList :: [LexemeRanking] -> ShowS
show :: LexemeRanking -> String
$cshow :: LexemeRanking -> String
showsPrec :: Int -> LexemeRanking -> ShowS
$cshowsPrec :: Int -> LexemeRanking -> ShowS
Show, Eq LexemeRanking
LexemeRanking -> LexemeRanking -> Bool
LexemeRanking -> LexemeRanking -> Ordering
LexemeRanking -> LexemeRanking -> LexemeRanking
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LexemeRanking -> LexemeRanking -> LexemeRanking
$cmin :: LexemeRanking -> LexemeRanking -> LexemeRanking
max :: LexemeRanking -> LexemeRanking -> LexemeRanking
$cmax :: LexemeRanking -> LexemeRanking -> LexemeRanking
>= :: LexemeRanking -> LexemeRanking -> Bool
$c>= :: LexemeRanking -> LexemeRanking -> Bool
> :: LexemeRanking -> LexemeRanking -> Bool
$c> :: LexemeRanking -> LexemeRanking -> Bool
<= :: LexemeRanking -> LexemeRanking -> Bool
$c<= :: LexemeRanking -> LexemeRanking -> Bool
< :: LexemeRanking -> LexemeRanking -> Bool
$c< :: LexemeRanking -> LexemeRanking -> Bool
compare :: LexemeRanking -> LexemeRanking -> Ordering
$ccompare :: LexemeRanking -> LexemeRanking -> Ordering
Ord)

instance FromField TSVector where
    fromField :: FieldParser TSVector
fromField Field
f Maybe ByteString
v =
        if Field -> Oid
typeOid Field
f forall a. Eq a => a -> a -> Bool
/= $(inlineTypoid tsvector)
        then forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
Incompatible Field
f String
""
        else case Maybe ByteString
v of
               Maybe ByteString
Nothing -> forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
UnexpectedNull Field
f String
""
               Just ByteString
bs ->
                   case forall a. Parser a -> ByteString -> Either String a
parseOnly Parser ByteString TSVector
parseTSVector ByteString
bs of
                     Left  String
err -> forall a err.
(Typeable a, Exception err) =>
(String -> Maybe Oid -> String -> String -> String -> err)
-> Field -> String -> Conversion a
returnError String -> Maybe Oid -> String -> String -> String -> ResultError
ConversionFailed Field
f String
err
                     Right TSVector
val -> forall (f :: * -> *) a. Applicative f => a -> f a
pure TSVector
val

-- 'a:1A fat:2B,4C cat:5D'
-- 'descript':4 'one':1,3 'titl':2
parseTSVector :: Parser ByteString TSVector
parseTSVector :: Parser ByteString TSVector
parseTSVector = [Lexeme] -> TSVector
TSVector forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many' Parser ByteString Lexeme
parseLexeme
    where
        parseLexeme :: Parser ByteString Lexeme
parseLexeme = do
            Parser ()
skipSpace

            Char -> Parser Char
char Char
'\''
            ByteString
token <- (Char -> Bool) -> Parser ByteString
Attoparsec.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\'')
            Char -> Parser Char
char Char
'\''

            Char -> Parser Char
char Char
':'
            [LexemeRanking]
ranking <- forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 do
                forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany forall a b. (a -> b) -> a -> b
$ Char -> Parser Char
char Char
','

                Double
position <- Parser Double
double
                -- The Default Weight Is `D` So Postgres Does Not Include It In The Result
                Char
weight <- forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Char
'D' forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice [Char -> Parser Char
char Char
'A', Char -> Parser Char
char Char
'B', Char -> Parser Char
char Char
'C', Char -> Parser Char
char Char
'D']
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ LexemeRanking { $sel:position:LexemeRanking :: Int
position = forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
position, Char
weight :: Char
$sel:weight:LexemeRanking :: Char
weight }

            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Lexeme { $sel:token:Lexeme :: Text
token = forall a b. ConvertibleStrings a b => a -> b
cs ByteString
token, [LexemeRanking]
ranking :: [LexemeRanking]
$sel:ranking:Lexeme :: [LexemeRanking]
ranking }


instance ToField TSVector where
    toField :: TSVector -> Action
toField = TSVector -> Action
serializeTSVector

serializeTSVector :: TSVector -> Action
serializeTSVector :: TSVector -> Action
serializeTSVector (TSVector [Lexeme]
lexemes) = [Action] -> Action
Many forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map Lexeme -> Action
serializeLexeme [Lexeme]
lexemes
    where
        serializeLexeme :: Lexeme -> Action
serializeLexeme Lexeme { Text
token :: Text
$sel:token:Lexeme :: Lexeme -> Text
token, [LexemeRanking]
ranking :: [LexemeRanking]
$sel:ranking:Lexeme :: Lexeme -> [LexemeRanking]
ranking } = [Action] -> Action
Many
            [ Builder -> Action
Plain forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString forall a b. (a -> b) -> a -> b
$ forall a b. ConvertibleStrings a b => a -> b
cs Text
token
            , forall a. ToField a => a -> Action
toField Char
':'
            , [Action] -> Action
Many forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse (forall a. ToField a => a -> Action
toField Char
',') (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
map LexemeRanking -> Action
serializeLexemeRanking [LexemeRanking]
ranking)
            ]
        serializeLexemeRanking :: LexemeRanking -> Action
serializeLexemeRanking LexemeRanking { Int
position :: Int
$sel:position:LexemeRanking :: LexemeRanking -> Int
position, Char
weight :: Char
$sel:weight:LexemeRanking :: LexemeRanking -> Char
weight } = [Action] -> Action
Many [forall a. ToField a => a -> Action
toField Int
position, forall a. ToField a => a -> Action
toField Char
weight]

instance ToField Char where
    toField :: Char -> Action
toField Char
char = Builder -> Action
Plain forall a b. (a -> b) -> a -> b
$ Char -> Builder
charUtf8 Char
char