{-# 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
(TSVector -> TSVector -> Bool)
-> (TSVector -> TSVector -> Bool) -> Eq TSVector
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
(Int -> TSVector -> ShowS)
-> (TSVector -> String) -> ([TSVector] -> ShowS) -> Show TSVector
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
Eq TSVector
-> (TSVector -> TSVector -> Ordering)
-> (TSVector -> TSVector -> Bool)
-> (TSVector -> TSVector -> Bool)
-> (TSVector -> TSVector -> Bool)
-> (TSVector -> TSVector -> Bool)
-> (TSVector -> TSVector -> TSVector)
-> (TSVector -> TSVector -> TSVector)
-> Ord 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
$cp1Ord :: Eq TSVector
Ord)

data Lexeme
    = Lexeme { Lexeme -> Text
token :: Text, Lexeme -> [LexemeRanking]
ranking :: [LexemeRanking] }
    deriving (Lexeme -> Lexeme -> Bool
(Lexeme -> Lexeme -> Bool)
-> (Lexeme -> Lexeme -> Bool) -> Eq Lexeme
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
(Int -> Lexeme -> ShowS)
-> (Lexeme -> String) -> ([Lexeme] -> ShowS) -> Show Lexeme
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
Eq Lexeme
-> (Lexeme -> Lexeme -> Ordering)
-> (Lexeme -> Lexeme -> Bool)
-> (Lexeme -> Lexeme -> Bool)
-> (Lexeme -> Lexeme -> Bool)
-> (Lexeme -> Lexeme -> Bool)
-> (Lexeme -> Lexeme -> Lexeme)
-> (Lexeme -> Lexeme -> Lexeme)
-> Ord 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
$cp1Ord :: Eq Lexeme
Ord)

data LexemeRanking
    = LexemeRanking { LexemeRanking -> Int
position :: Int, LexemeRanking -> Char
weight :: Char }
    deriving (LexemeRanking -> LexemeRanking -> Bool
(LexemeRanking -> LexemeRanking -> Bool)
-> (LexemeRanking -> LexemeRanking -> Bool) -> Eq LexemeRanking
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
(Int -> LexemeRanking -> ShowS)
-> (LexemeRanking -> String)
-> ([LexemeRanking] -> ShowS)
-> Show LexemeRanking
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
Eq LexemeRanking
-> (LexemeRanking -> LexemeRanking -> Ordering)
-> (LexemeRanking -> LexemeRanking -> Bool)
-> (LexemeRanking -> LexemeRanking -> Bool)
-> (LexemeRanking -> LexemeRanking -> Bool)
-> (LexemeRanking -> LexemeRanking -> Bool)
-> (LexemeRanking -> LexemeRanking -> LexemeRanking)
-> (LexemeRanking -> LexemeRanking -> LexemeRanking)
-> Ord 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
$cp1Ord :: Eq LexemeRanking
Ord)

instance FromField TSVector where
    fromField :: FieldParser TSVector
fromField Field
f Maybe ByteString
v =
        if Field -> Oid
typeOid Field
f Oid -> Oid -> Bool
forall a. Eq a => a -> a -> Bool
/= $(inlineTypoid tsvector)
        then (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion TSVector
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 -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion TSVector
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 Parser TSVector -> ByteString -> Either String TSVector
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser TSVector
parseTSVector ByteString
bs of
                     Left  String
err -> (String -> Maybe Oid -> String -> String -> String -> ResultError)
-> Field -> String -> Conversion TSVector
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 -> TSVector -> Conversion TSVector
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 TSVector
parseTSVector = [Lexeme] -> TSVector
TSVector ([Lexeme] -> TSVector)
-> Parser ByteString [Lexeme] -> Parser TSVector
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Lexeme -> Parser ByteString [Lexeme]
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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\'')
            Char -> Parser Char
char Char
'\''

            Char -> Parser Char
char Char
':'
            [LexemeRanking]
ranking <- Parser ByteString LexemeRanking
-> Parser ByteString [LexemeRanking]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 do
                Parser Char -> Parser ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
skipMany (Parser Char -> Parser ()) -> Parser Char -> Parser ()
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 <- Char -> Parser Char -> Parser Char
forall (f :: * -> *) a. Alternative f => a -> f a -> f a
option Char
'D' (Parser Char -> Parser Char) -> Parser Char -> Parser Char
forall a b. (a -> b) -> a -> b
$ [Parser Char] -> Parser Char
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']
                LexemeRanking -> Parser ByteString LexemeRanking
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LexemeRanking -> Parser ByteString LexemeRanking)
-> LexemeRanking -> Parser ByteString LexemeRanking
forall a b. (a -> b) -> a -> b
$ LexemeRanking :: Int -> Char -> LexemeRanking
LexemeRanking { $sel:position:LexemeRanking :: Int
position = Double -> Int
forall a b. (RealFrac a, Integral b) => a -> b
truncate Double
position, Char
weight :: Char
$sel:weight:LexemeRanking :: Char
weight }

            Lexeme -> Parser ByteString Lexeme
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Lexeme -> Parser ByteString Lexeme)
-> Lexeme -> Parser ByteString Lexeme
forall a b. (a -> b) -> a -> b
$ Lexeme :: Text -> [LexemeRanking] -> Lexeme
Lexeme { $sel:token:Lexeme :: Text
token = ByteString -> Text
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 ([Action] -> Action) -> [Action] -> Action
forall a b. (a -> b) -> a -> b
$ (Lexeme -> Action) -> [Lexeme] -> [Action]
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 (Builder -> Action) -> Builder -> Action
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
token
            , Char -> Action
forall a. ToField a => a -> Action
toField Char
':'
            , [Action] -> Action
Many ([Action] -> Action) -> [Action] -> Action
forall a b. (a -> b) -> a -> b
$ Action -> [Action] -> [Action]
forall a. a -> [a] -> [a]
intersperse (Char -> Action
forall a. ToField a => a -> Action
toField Char
',') ((LexemeRanking -> Action) -> [LexemeRanking] -> [Action]
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 [Int -> Action
forall a. ToField a => a -> Action
toField Int
position, Char -> Action
forall a. ToField a => a -> Action
toField Char
weight]

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