{-# LANGUAGE TemplateHaskell #-}
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)
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
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
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