{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
module Database.Esqueleto.TextSearch.Types (
    TsQuery (..)
  , Words
  , Lexemes
  , TsVector
  , defaultTsVector
  , RegConfig
  , NormalizationOption (..)
  , Weight (..)
  , defaultWeights
  , Weights (..)
  , Position (..)
  , word
  , queryToText
  , textToQuery
) where

import Control.Applicative (pure, many, optional, (<$>), (*>), (<*), (<|>))
import Data.Bits ((.|.), (.&.))
import Data.Int (Int64)
import Data.List (foldl')
import Data.Monoid ((<>))
import Data.String (IsString(fromString))
import Text.Printf (printf)
import Text.Parsec (
  ParseError, runParser, char, eof, between, choice, spaces, satisfy, many1)
import qualified Text.Parsec.Expr as P

import Data.Text (Text, singleton)
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder (Builder, toLazyText, fromText)
import Database.Persist
import Database.Persist.Postgresql

-- | ranking functions take an integer normalization option that specifies
--   whether and how a document's length should impact its rank.
--  The integer option controls several behaviors, so it is a bit mask: you can specify one or more behaviors using | (for example, 2|4).
--  https://www.postgresql.org/docs/current/textsearch-controls.html#TEXTSEARCH-RANKING
data NormalizationOption
  = NormNone -- ^ 0 (the default) ignores the document length
  | Norm1LogLength -- ^ 1 divides the rank by 1 + the logarithm of the document length
  | NormLength -- ^ 2 divides the rank by the document length
  | NormMeanHarmDist -- ^ 4 divides the rank by the mean harmonic distance between extents (this is implemented only by ts_rank_cd)
  | NormUniqueWords -- ^ 8 divides the rank by the number of unique words in document
  | Norm1LogUniqueWords -- ^ 16 divides the rank by 1 + the logarithm of the number of unique words in document
  | Norm1Self -- ^ 32 divides the rank by itself + 1
  deriving (NormalizationOption -> NormalizationOption -> Bool
(NormalizationOption -> NormalizationOption -> Bool)
-> (NormalizationOption -> NormalizationOption -> Bool)
-> Eq NormalizationOption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NormalizationOption -> NormalizationOption -> Bool
== :: NormalizationOption -> NormalizationOption -> Bool
$c/= :: NormalizationOption -> NormalizationOption -> Bool
/= :: NormalizationOption -> NormalizationOption -> Bool
Eq, Int -> NormalizationOption -> ShowS
[NormalizationOption] -> ShowS
NormalizationOption -> String
(Int -> NormalizationOption -> ShowS)
-> (NormalizationOption -> String)
-> ([NormalizationOption] -> ShowS)
-> Show NormalizationOption
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NormalizationOption -> ShowS
showsPrec :: Int -> NormalizationOption -> ShowS
$cshow :: NormalizationOption -> String
show :: NormalizationOption -> String
$cshowList :: [NormalizationOption] -> ShowS
showList :: [NormalizationOption] -> ShowS
Show, Int -> NormalizationOption
NormalizationOption -> Int
NormalizationOption -> [NormalizationOption]
NormalizationOption -> NormalizationOption
NormalizationOption -> NormalizationOption -> [NormalizationOption]
NormalizationOption
-> NormalizationOption
-> NormalizationOption
-> [NormalizationOption]
(NormalizationOption -> NormalizationOption)
-> (NormalizationOption -> NormalizationOption)
-> (Int -> NormalizationOption)
-> (NormalizationOption -> Int)
-> (NormalizationOption -> [NormalizationOption])
-> (NormalizationOption
    -> NormalizationOption -> [NormalizationOption])
-> (NormalizationOption
    -> NormalizationOption -> [NormalizationOption])
-> (NormalizationOption
    -> NormalizationOption
    -> NormalizationOption
    -> [NormalizationOption])
-> Enum NormalizationOption
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: NormalizationOption -> NormalizationOption
succ :: NormalizationOption -> NormalizationOption
$cpred :: NormalizationOption -> NormalizationOption
pred :: NormalizationOption -> NormalizationOption
$ctoEnum :: Int -> NormalizationOption
toEnum :: Int -> NormalizationOption
$cfromEnum :: NormalizationOption -> Int
fromEnum :: NormalizationOption -> Int
$cenumFrom :: NormalizationOption -> [NormalizationOption]
enumFrom :: NormalizationOption -> [NormalizationOption]
$cenumFromThen :: NormalizationOption -> NormalizationOption -> [NormalizationOption]
enumFromThen :: NormalizationOption -> NormalizationOption -> [NormalizationOption]
$cenumFromTo :: NormalizationOption -> NormalizationOption -> [NormalizationOption]
enumFromTo :: NormalizationOption -> NormalizationOption -> [NormalizationOption]
$cenumFromThenTo :: NormalizationOption
-> NormalizationOption
-> NormalizationOption
-> [NormalizationOption]
enumFromThenTo :: NormalizationOption
-> NormalizationOption
-> NormalizationOption
-> [NormalizationOption]
Enum, NormalizationOption
NormalizationOption
-> NormalizationOption -> Bounded NormalizationOption
forall a. a -> a -> Bounded a
$cminBound :: NormalizationOption
minBound :: NormalizationOption
$cmaxBound :: NormalizationOption
maxBound :: NormalizationOption
Bounded)

normToInt :: NormalizationOption -> Int64
normToInt :: NormalizationOption -> Int64
normToInt NormalizationOption
n
  | NormalizationOption -> Int
forall a. Enum a => a -> Int
fromEnum NormalizationOption
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Int64
0
  | Bool
otherwise       = Int64
2 Int64 -> Int -> Int64
forall a b. (Num a, Integral b) => a -> b -> a
^ (NormalizationOption -> Int
forall a. Enum a => a -> Int
fromEnum NormalizationOption
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)

instance PersistField [NormalizationOption] where
  toPersistValue :: [NormalizationOption] -> PersistValue
toPersistValue = Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue)
-> ([NormalizationOption] -> Int64)
-> [NormalizationOption]
-> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int64 -> Int64 -> Int64) -> Int64 -> [Int64] -> Int64
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
(.|.) Int64
0 ([Int64] -> Int64)
-> ([NormalizationOption] -> [Int64])
-> [NormalizationOption]
-> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NormalizationOption -> Int64) -> [NormalizationOption] -> [Int64]
forall a b. (a -> b) -> [a] -> [b]
map NormalizationOption -> Int64
normToInt
  fromPersistValue :: PersistValue -> Either Text [NormalizationOption]
fromPersistValue (PersistInt64 Int64
n) = [NormalizationOption] -> Either Text [NormalizationOption]
forall a b. b -> Either a b
Right ([NormalizationOption] -> Either Text [NormalizationOption])
-> [NormalizationOption] -> Either Text [NormalizationOption]
forall a b. (a -> b) -> a -> b
$ ([NormalizationOption]
 -> NormalizationOption -> [NormalizationOption])
-> [NormalizationOption]
-> [NormalizationOption]
-> [NormalizationOption]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [NormalizationOption]
-> NormalizationOption -> [NormalizationOption]
go [] [NormalizationOption
forall a. Bounded a => a
minBound..NormalizationOption
forall a. Bounded a => a
maxBound]
    where go :: [NormalizationOption]
-> NormalizationOption -> [NormalizationOption]
go [NormalizationOption]
acc NormalizationOption
v = case NormalizationOption -> Int64
normToInt NormalizationOption
v Int64 -> Int64 -> Int64
forall a. Bits a => a -> a -> a
.&. Int64
n of
                      Int64
0 -> [NormalizationOption]
acc
                      Int64
_ -> NormalizationOption
vNormalizationOption
-> [NormalizationOption] -> [NormalizationOption]
forall a. a -> [a] -> [a]
:[NormalizationOption]
acc
  fromPersistValue PersistValue
f
    = Text -> Either Text [NormalizationOption]
forall a b. a -> Either a b
Left (Text -> Either Text [NormalizationOption])
-> Text -> Either Text [NormalizationOption]
forall a b. (a -> b) -> a -> b
$
      Text
"TextSearch/[NormalizationOption]: Unexpected Persist field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PersistValue -> Text
forall a. Show a => a -> Text
tShow PersistValue
f
instance PersistFieldSql [NormalizationOption] where
  sqlType :: Proxy [NormalizationOption] -> SqlType
sqlType = SqlType -> Proxy [NormalizationOption] -> SqlType
forall a b. a -> b -> a
const SqlType
SqlInt32

data Weight
  = Highest
  | High
  | Medium
  | Low
  deriving (Weight -> Weight -> Bool
(Weight -> Weight -> Bool)
-> (Weight -> Weight -> Bool) -> Eq Weight
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Weight -> Weight -> Bool
== :: Weight -> Weight -> Bool
$c/= :: Weight -> Weight -> Bool
/= :: Weight -> Weight -> Bool
Eq, Int -> Weight -> ShowS
[Weight] -> ShowS
Weight -> String
(Int -> Weight -> ShowS)
-> (Weight -> String) -> ([Weight] -> ShowS) -> Show Weight
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Weight -> ShowS
showsPrec :: Int -> Weight -> ShowS
$cshow :: Weight -> String
show :: Weight -> String
$cshowList :: [Weight] -> ShowS
showList :: [Weight] -> ShowS
Show)

weightToChar :: Weight -> Char
weightToChar :: Weight -> Char
weightToChar Weight
Highest = Char
'A'
weightToChar Weight
High    = Char
'B'
weightToChar Weight
Medium  = Char
'C'
weightToChar Weight
Low     = Char
'D'

instance PersistField Weight where
  toPersistValue :: Weight -> PersistValue
toPersistValue = Text -> PersistValue
PersistText (Text -> PersistValue)
-> (Weight -> Text) -> Weight -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
singleton (Char -> Text) -> (Weight -> Char) -> Weight -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Weight -> Char
weightToChar
  fromPersistValue :: PersistValue -> Either Text Weight
fromPersistValue (PersistText Text
"A") = Weight -> Either Text Weight
forall a b. b -> Either a b
Right Weight
Highest
  fromPersistValue (PersistText Text
"B") = Weight -> Either Text Weight
forall a b. b -> Either a b
Right Weight
High
  fromPersistValue (PersistText Text
"C") = Weight -> Either Text Weight
forall a b. b -> Either a b
Right Weight
Medium
  fromPersistValue (PersistText Text
"D") = Weight -> Either Text Weight
forall a b. b -> Either a b
Right Weight
Low
  fromPersistValue (PersistText Text
_)
    = Text -> Either Text Weight
forall a b. a -> Either a b
Left Text
"TextSearch/Weight: Unexpected character"
  fromPersistValue PersistValue
f
    = Text -> Either Text Weight
forall a b. a -> Either a b
Left (Text -> Either Text Weight) -> Text -> Either Text Weight
forall a b. (a -> b) -> a -> b
$ Text
"TextSearch/Weight: Unexpected Persist field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PersistValue -> Text
forall a. Show a => a -> Text
tShow PersistValue
f
instance PersistFieldSql Weight where
  sqlType :: Proxy Weight -> SqlType
sqlType = SqlType -> Proxy Weight -> SqlType
forall a b. a -> b -> a
const (Text -> SqlType
SqlOther Text
"char")

data Weights
  = Weights { Weights -> Double
dWeight :: !Double
            , Weights -> Double
cWeight :: !Double
            , Weights -> Double
bWeight :: !Double
            , Weights -> Double
aWeight :: !Double
            } deriving (Weights -> Weights -> Bool
(Weights -> Weights -> Bool)
-> (Weights -> Weights -> Bool) -> Eq Weights
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Weights -> Weights -> Bool
== :: Weights -> Weights -> Bool
$c/= :: Weights -> Weights -> Bool
/= :: Weights -> Weights -> Bool
Eq, Int -> Weights -> ShowS
[Weights] -> ShowS
Weights -> String
(Int -> Weights -> ShowS)
-> (Weights -> String) -> ([Weights] -> ShowS) -> Show Weights
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Weights -> ShowS
showsPrec :: Int -> Weights -> ShowS
$cshow :: Weights -> String
show :: Weights -> String
$cshowList :: [Weights] -> ShowS
showList :: [Weights] -> ShowS
Show)

defaultWeights :: Weights
defaultWeights :: Weights
defaultWeights = Double -> Double -> Double -> Double -> Weights
Weights Double
0.1 Double
0.2 Double
0.4 Double
1.0

instance PersistField Weights where
  toPersistValue :: Weights -> PersistValue
toPersistValue (Weights Double
d Double
c Double
b Double
a)
    --FIXME: persistent-postgresql should handle this properly
    = ByteString -> PersistValue
PersistDbSpecific (ByteString -> PersistValue) -> ByteString -> PersistValue
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ (String -> Double -> Double -> Double -> Double -> String
forall r. PrintfType r => String -> r
printf String
"{%f,%f,%f,%f}" Double
d Double
c Double
b Double
a)
  fromPersistValue :: PersistValue -> Either Text Weights
fromPersistValue (PersistList [PersistValue
d, PersistValue
c, PersistValue
b, PersistValue
a])
    = Double -> Double -> Double -> Double -> Weights
Weights (Double -> Double -> Double -> Double -> Weights)
-> Either Text Double
-> Either Text (Double -> Double -> Double -> Weights)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PersistValue -> Either Text Double
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
d
              Either Text (Double -> Double -> Double -> Weights)
-> Either Text Double -> Either Text (Double -> Double -> Weights)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PersistValue -> Either Text Double
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
c
              Either Text (Double -> Double -> Weights)
-> Either Text Double -> Either Text (Double -> Weights)
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PersistValue -> Either Text Double
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
b
              Either Text (Double -> Weights)
-> Either Text Double -> Either Text Weights
forall a b. Either Text (a -> b) -> Either Text a -> Either Text b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PersistValue -> Either Text Double
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
a
  fromPersistValue (PersistList [PersistValue]
_)
    = Text -> Either Text Weights
forall a b. a -> Either a b
Left Text
"TextSearch/Weights: Expected a length-4 float array"
  fromPersistValue PersistValue
f
    = Text -> Either Text Weights
forall a b. a -> Either a b
Left (Text -> Either Text Weights) -> Text -> Either Text Weights
forall a b. (a -> b) -> a -> b
$ Text
"TextSearch/Weights: Unexpected Persist field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PersistValue -> Text
forall a. Show a => a -> Text
tShow PersistValue
f

instance PersistFieldSql Weights where
  sqlType :: Proxy Weights -> SqlType
sqlType = SqlType -> Proxy Weights -> SqlType
forall a b. a -> b -> a
const (Text -> SqlType
SqlOther Text
"float4[4]")

data QueryType = Words | Lexemes
type Lexemes = 'Lexemes
type Words = 'Words

data Position = Prefix | Infix deriving (Int -> Position -> ShowS
[Position] -> ShowS
Position -> String
(Int -> Position -> ShowS)
-> (Position -> String) -> ([Position] -> ShowS) -> Show Position
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Position -> ShowS
showsPrec :: Int -> Position -> ShowS
$cshow :: Position -> String
show :: Position -> String
$cshowList :: [Position] -> ShowS
showList :: [Position] -> ShowS
Show, Position -> Position -> Bool
(Position -> Position -> Bool)
-> (Position -> Position -> Bool) -> Eq Position
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
/= :: Position -> Position -> Bool
Eq)

data TsQuery (a :: QueryType) where
  Lexeme :: Position -> [Weight] -> Text -> TsQuery Lexemes
  Word   :: Position -> [Weight] -> Text -> TsQuery Words
  (:&)   :: TsQuery a -> TsQuery a -> TsQuery a
  (:|)   :: TsQuery a -> TsQuery a -> TsQuery a
  Not    :: TsQuery a -> TsQuery a

infixr 3 :&
infixr 2 :|

deriving instance Show (TsQuery a)
deriving instance Eq (TsQuery a)

instance PersistField (TsQuery Words) where
  toPersistValue :: TsQuery 'Words -> PersistValue
toPersistValue = ByteString -> PersistValue
PersistDbSpecific (ByteString -> PersistValue)
-> (TsQuery 'Words -> ByteString) -> TsQuery 'Words -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (TsQuery 'Words -> Text) -> TsQuery 'Words -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TsQuery 'Words -> Text
forall (a :: QueryType). TsQuery a -> Text
queryToText
  fromPersistValue :: PersistValue -> Either Text (TsQuery 'Words)
fromPersistValue (PersistDbSpecific ByteString
_)
    = Text -> Either Text (TsQuery 'Words)
forall a b. a -> Either a b
Left Text
"TextSearch/TsQuery: Cannot parse (TsQuery Words)"
  fromPersistValue PersistValue
f
    = Text -> Either Text (TsQuery 'Words)
forall a b. a -> Either a b
Left (Text -> Either Text (TsQuery 'Words))
-> Text -> Either Text (TsQuery 'Words)
forall a b. (a -> b) -> a -> b
$ Text
"TextSearch/TsQuery: Unexpected Persist field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PersistValue -> Text
forall a. Show a => a -> Text
tShow PersistValue
f

instance PersistField (TsQuery Lexemes) where
  toPersistValue :: TsQuery 'Lexemes -> PersistValue
toPersistValue = ByteString -> PersistValue
PersistDbSpecific (ByteString -> PersistValue)
-> (TsQuery 'Lexemes -> ByteString)
-> TsQuery 'Lexemes
-> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (TsQuery 'Lexemes -> Text) -> TsQuery 'Lexemes -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TsQuery 'Lexemes -> Text
forall (a :: QueryType). TsQuery a -> Text
queryToText
  fromPersistValue :: PersistValue -> Either Text (TsQuery 'Lexemes)
fromPersistValue (PersistDbSpecific ByteString
bs)
    = case Text -> Either ParseError (TsQuery 'Lexemes)
textToQuery (ByteString -> Text
decodeUtf8 ByteString
bs) of
        Right TsQuery 'Lexemes
q -> TsQuery 'Lexemes -> Either Text (TsQuery 'Lexemes)
forall a b. b -> Either a b
Right TsQuery 'Lexemes
q
        Left  ParseError
e -> Text -> Either Text (TsQuery 'Lexemes)
forall a b. a -> Either a b
Left (Text -> Either Text (TsQuery 'Lexemes))
-> Text -> Either Text (TsQuery 'Lexemes)
forall a b. (a -> b) -> a -> b
$ Text
"Could not parse TsQuery: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ParseError -> Text
forall a. Show a => a -> Text
tShow ParseError
e
  fromPersistValue PersistValue
f
    = Text -> Either Text (TsQuery 'Lexemes)
forall a b. a -> Either a b
Left (Text -> Either Text (TsQuery 'Lexemes))
-> Text -> Either Text (TsQuery 'Lexemes)
forall a b. (a -> b) -> a -> b
$ Text
"TextSearch/TsQuery: Unexpected Persist field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PersistValue -> Text
forall a. Show a => a -> Text
tShow PersistValue
f

instance PersistFieldSql (TsQuery Words) where
  sqlType :: Proxy (TsQuery 'Words) -> SqlType
sqlType = SqlType -> Proxy (TsQuery 'Words) -> SqlType
forall a b. a -> b -> a
const (Text -> SqlType
SqlOther Text
"tsquery")

instance PersistFieldSql (TsQuery Lexemes) where
  sqlType :: Proxy (TsQuery 'Lexemes) -> SqlType
sqlType = SqlType -> Proxy (TsQuery 'Lexemes) -> SqlType
forall a b. a -> b -> a
const (Text -> SqlType
SqlOther Text
"tsquery")

instance a~Words => IsString (TsQuery a) where
  fromString :: String -> TsQuery a
fromString = Text -> TsQuery a
Text -> TsQuery 'Words
word (Text -> TsQuery a) -> (String -> Text) -> String -> TsQuery a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString

word :: Text -> TsQuery Words
word :: Text -> TsQuery 'Words
word = Position -> [Weight] -> Text -> TsQuery 'Words
Word Position
Infix []


queryToText :: TsQuery a -> Text
queryToText :: forall (a :: QueryType). TsQuery a -> Text
queryToText = Text -> Text
toStrict (Text -> Text) -> (TsQuery a -> Text) -> TsQuery a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText (Builder -> Text) -> (TsQuery a -> Builder) -> TsQuery a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TsQuery 'Lexemes -> Builder
build (TsQuery 'Lexemes -> Builder)
-> (TsQuery a -> TsQuery 'Lexemes) -> TsQuery a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TsQuery a -> TsQuery 'Lexemes
forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme
  where
    build :: TsQuery Lexemes -> Builder
    build :: TsQuery 'Lexemes -> Builder
build (Lexeme Position
Infix [] Text
s)    = Builder
"'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"'"
    build (Lexeme Position
Infix [Weight]
ws Text
s)    = Builder
"'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"':"  Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Weight] -> Builder
buildWeights [Weight]
ws
    build (Lexeme Position
Prefix [Weight]
ws Text
s)   = Builder
"'" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"':*" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> [Weight] -> Builder
buildWeights [Weight]
ws
    build (TsQuery 'Lexemes
a :& TsQuery 'Lexemes
b)               = TsQuery 'Lexemes -> Builder
parens TsQuery 'Lexemes
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"&" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TsQuery 'Lexemes -> Builder
parens TsQuery 'Lexemes
b
    build (TsQuery 'Lexemes
a :| TsQuery 'Lexemes
b)               = TsQuery 'Lexemes -> Builder
parens TsQuery 'Lexemes
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"|" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TsQuery 'Lexemes -> Builder
parens TsQuery 'Lexemes
b
    build (Not TsQuery 'Lexemes
q)                = Builder
"!" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TsQuery 'Lexemes -> Builder
parens TsQuery 'Lexemes
q
    buildWeights :: [Weight] -> Builder
buildWeights                 = Text -> Builder
fromText (Text -> Builder) -> ([Weight] -> Text) -> [Weight] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> ([Weight] -> String) -> [Weight] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Weight -> Char) -> [Weight] -> String
forall a b. (a -> b) -> [a] -> [b]
map Weight -> Char
weightToChar
    unsafeAsLexeme :: TsQuery a -> TsQuery Lexemes
    unsafeAsLexeme :: forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme q :: TsQuery a
q@Lexeme{}    = TsQuery a
TsQuery 'Lexemes
q
    unsafeAsLexeme (Word Position
p [Weight]
ws Text
s) = Position -> [Weight] -> Text -> TsQuery 'Lexemes
Lexeme Position
p [Weight]
ws Text
s
    unsafeAsLexeme (TsQuery a
a :& TsQuery a
b)      = TsQuery a -> TsQuery 'Lexemes
forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme TsQuery a
a TsQuery 'Lexemes -> TsQuery 'Lexemes -> TsQuery 'Lexemes
forall (a :: QueryType). TsQuery a -> TsQuery a -> TsQuery a
:& TsQuery a -> TsQuery 'Lexemes
forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme TsQuery a
b
    unsafeAsLexeme (TsQuery a
a :| TsQuery a
b)      = TsQuery a -> TsQuery 'Lexemes
forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme TsQuery a
a TsQuery 'Lexemes -> TsQuery 'Lexemes -> TsQuery 'Lexemes
forall (a :: QueryType). TsQuery a -> TsQuery a -> TsQuery a
:| TsQuery a -> TsQuery 'Lexemes
forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme TsQuery a
b
    unsafeAsLexeme (Not TsQuery a
q)       = TsQuery 'Lexemes -> TsQuery 'Lexemes
forall (a :: QueryType). TsQuery a -> TsQuery a
Not (TsQuery a -> TsQuery 'Lexemes
forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme TsQuery a
q)
    parens :: TsQuery 'Lexemes -> Builder
parens a :: TsQuery 'Lexemes
a@Lexeme{}            = TsQuery 'Lexemes -> Builder
build TsQuery 'Lexemes
a
    parens TsQuery 'Lexemes
a                     = Builder
"(" Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TsQuery 'Lexemes -> Builder
build TsQuery 'Lexemes
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
")"

textToQuery :: Text -> Either ParseError (TsQuery Lexemes)
textToQuery :: Text -> Either ParseError (TsQuery 'Lexemes)
textToQuery = Parsec Text () (TsQuery 'Lexemes)
-> () -> String -> Text -> Either ParseError (TsQuery 'Lexemes)
forall s t u a.
Stream s Identity t =>
Parsec s u a -> u -> String -> s -> Either ParseError a
runParser (Parsec Text () (TsQuery 'Lexemes)
expr Parsec Text () (TsQuery 'Lexemes)
-> ParsecT Text () Identity () -> Parsec Text () (TsQuery 'Lexemes)
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Text () Identity ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof) () String
""
  where
    expr :: Parsec Text () (TsQuery 'Lexemes)
expr    = Parsec Text () (TsQuery 'Lexemes)
-> Parsec Text () (TsQuery 'Lexemes)
forall {u} {a}.
ParsecT Text u Identity a -> ParsecT Text u Identity a
spaced (OperatorTable Text () Identity (TsQuery 'Lexemes)
-> Parsec Text () (TsQuery 'Lexemes)
-> Parsec Text () (TsQuery 'Lexemes)
forall s (m :: * -> *) t u a.
Stream s m t =>
OperatorTable s u m a -> ParsecT s u m a -> ParsecT s u m a
P.buildExpressionParser OperatorTable Text () Identity (TsQuery 'Lexemes)
forall {u} {a :: QueryType}.
[[Operator Text u Identity (TsQuery a)]]
table (Parsec Text () (TsQuery 'Lexemes)
-> Parsec Text () (TsQuery 'Lexemes)
forall {u} {a}.
ParsecT Text u Identity a -> ParsecT Text u Identity a
spaced Parsec Text () (TsQuery 'Lexemes)
term))
    term :: Parsec Text () (TsQuery 'Lexemes)
term    = Parsec Text () (TsQuery 'Lexemes)
-> Parsec Text () (TsQuery 'Lexemes)
forall {u} {a}.
ParsecT Text u Identity a -> ParsecT Text u Identity a
parens Parsec Text () (TsQuery 'Lexemes)
expr
          Parsec Text () (TsQuery 'Lexemes)
-> Parsec Text () (TsQuery 'Lexemes)
-> Parsec Text () (TsQuery 'Lexemes)
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parsec Text () (TsQuery 'Lexemes)
lexeme
    table :: [[Operator Text u Identity (TsQuery a)]]
table   = [ [ParsecT Text u Identity (TsQuery a -> TsQuery a)
-> Operator Text u Identity (TsQuery a)
forall s u (m :: * -> *) a.
ParsecT s u m (a -> a) -> Operator s u m a
P.Prefix (Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'!' ParsecT Text u Identity Char
-> ParsecT Text u Identity (TsQuery a -> TsQuery a)
-> ParsecT Text u Identity (TsQuery a -> TsQuery a)
forall a b.
ParsecT Text u Identity a
-> ParsecT Text u Identity b -> ParsecT Text u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (TsQuery a -> TsQuery a)
-> ParsecT Text u Identity (TsQuery a -> TsQuery a)
forall a. a -> ParsecT Text u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TsQuery a -> TsQuery a
forall (a :: QueryType). TsQuery a -> TsQuery a
Not)]
              , [ParsecT Text u Identity (TsQuery a -> TsQuery a -> TsQuery a)
-> Assoc -> Operator Text u Identity (TsQuery a)
forall s u (m :: * -> *) a.
ParsecT s u m (a -> a -> a) -> Assoc -> Operator s u m a
P.Infix  (Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'&' ParsecT Text u Identity Char
-> ParsecT Text u Identity (TsQuery a -> TsQuery a -> TsQuery a)
-> ParsecT Text u Identity (TsQuery a -> TsQuery a -> TsQuery a)
forall a b.
ParsecT Text u Identity a
-> ParsecT Text u Identity b -> ParsecT Text u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (TsQuery a -> TsQuery a -> TsQuery a)
-> ParsecT Text u Identity (TsQuery a -> TsQuery a -> TsQuery a)
forall a. a -> ParsecT Text u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TsQuery a -> TsQuery a -> TsQuery a
forall (a :: QueryType). TsQuery a -> TsQuery a -> TsQuery a
(:&)) Assoc
P.AssocRight]
              , [ParsecT Text u Identity (TsQuery a -> TsQuery a -> TsQuery a)
-> Assoc -> Operator Text u Identity (TsQuery a)
forall s u (m :: * -> *) a.
ParsecT s u m (a -> a -> a) -> Assoc -> Operator s u m a
P.Infix  (Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'|' ParsecT Text u Identity Char
-> ParsecT Text u Identity (TsQuery a -> TsQuery a -> TsQuery a)
-> ParsecT Text u Identity (TsQuery a -> TsQuery a -> TsQuery a)
forall a b.
ParsecT Text u Identity a
-> ParsecT Text u Identity b -> ParsecT Text u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (TsQuery a -> TsQuery a -> TsQuery a)
-> ParsecT Text u Identity (TsQuery a -> TsQuery a -> TsQuery a)
forall a. a -> ParsecT Text u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TsQuery a -> TsQuery a -> TsQuery a
forall (a :: QueryType). TsQuery a -> TsQuery a -> TsQuery a
(:|)) Assoc
P.AssocRight]
              ]
    lexeme :: Parsec Text () (TsQuery 'Lexemes)
lexeme = do
      Text
s   <- String -> Text
forall a. IsString a => String -> a
fromString (String -> Text)
-> ParsecT Text () Identity String -> ParsecT Text () Identity Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT Text () Identity String -> ParsecT Text () Identity String
forall {u} {a}.
ParsecT Text u Identity a -> ParsecT Text u Identity a
quoted (ParsecT Text () Identity Char -> ParsecT Text () Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ((Char -> Bool) -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\'')))
      Maybe Char
_   <- ParsecT Text () Identity Char
-> ParsecT Text () Identity (Maybe Char)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':')
      Position
pos <- Char -> ParsecT Text () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'*' ParsecT Text () Identity Char
-> ParsecT Text () Identity Position
-> ParsecT Text () Identity Position
forall a b.
ParsecT Text () Identity a
-> ParsecT Text () Identity b -> ParsecT Text () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Position -> ParsecT Text () Identity Position
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position
Prefix ParsecT Text () Identity Position
-> ParsecT Text () Identity Position
-> ParsecT Text () Identity Position
forall a.
ParsecT Text () Identity a
-> ParsecT Text () Identity a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Position -> ParsecT Text () Identity Position
forall a. a -> ParsecT Text () Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Position
Infix
      [Weight]
ws  <- ParsecT Text () Identity Weight
-> ParsecT Text () Identity [Weight]
forall a.
ParsecT Text () Identity a -> ParsecT Text () Identity [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many ParsecT Text () Identity Weight
forall {u}. ParsecT Text u Identity Weight
weight
      TsQuery 'Lexemes -> Parsec Text () (TsQuery 'Lexemes)
forall a. a -> ParsecT Text () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (TsQuery 'Lexemes -> Parsec Text () (TsQuery 'Lexemes))
-> TsQuery 'Lexemes -> Parsec Text () (TsQuery 'Lexemes)
forall a b. (a -> b) -> a -> b
$ Position -> [Weight] -> Text -> TsQuery 'Lexemes
Lexeme Position
pos [Weight]
ws Text
s
    weight :: ParsecT Text u Identity Weight
weight = [ParsecT Text u Identity Weight] -> ParsecT Text u Identity Weight
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'A' ParsecT Text u Identity Char
-> ParsecT Text u Identity Weight -> ParsecT Text u Identity Weight
forall a b.
ParsecT Text u Identity a
-> ParsecT Text u Identity b -> ParsecT Text u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Weight -> ParsecT Text u Identity Weight
forall a. a -> ParsecT Text u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Weight
Highest
                    , Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'B' ParsecT Text u Identity Char
-> ParsecT Text u Identity Weight -> ParsecT Text u Identity Weight
forall a b.
ParsecT Text u Identity a
-> ParsecT Text u Identity b -> ParsecT Text u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Weight -> ParsecT Text u Identity Weight
forall a. a -> ParsecT Text u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Weight
High
                    , Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'C' ParsecT Text u Identity Char
-> ParsecT Text u Identity Weight -> ParsecT Text u Identity Weight
forall a b.
ParsecT Text u Identity a
-> ParsecT Text u Identity b -> ParsecT Text u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Weight -> ParsecT Text u Identity Weight
forall a. a -> ParsecT Text u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Weight
Medium
                    , Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'D' ParsecT Text u Identity Char
-> ParsecT Text u Identity Weight -> ParsecT Text u Identity Weight
forall a b.
ParsecT Text u Identity a
-> ParsecT Text u Identity b -> ParsecT Text u Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Weight -> ParsecT Text u Identity Weight
forall a. a -> ParsecT Text u Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Weight
Low]
    spaced :: ParsecT Text u Identity a -> ParsecT Text u Identity a
spaced = ParsecT Text u Identity (Maybe ())
-> ParsecT Text u Identity (Maybe ())
-> ParsecT Text u Identity a
-> ParsecT Text u Identity a
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (ParsecT Text u Identity () -> ParsecT Text u Identity (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Text u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces) (ParsecT Text u Identity () -> ParsecT Text u Identity (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT Text u Identity ()
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m ()
spaces)
    quoted :: ParsecT Text u Identity a -> ParsecT Text u Identity a
quoted = ParsecT Text u Identity Char
-> ParsecT Text u Identity Char
-> ParsecT Text u Identity a
-> ParsecT Text u Identity a
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\'') (Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'\'')
    parens :: ParsecT Text u Identity a -> ParsecT Text u Identity a
parens = ParsecT Text u Identity Char
-> ParsecT Text u Identity Char
-> ParsecT Text u Identity a
-> ParsecT Text u Identity a
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'(') (Char -> ParsecT Text u Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')')

newtype TsVector = TsVector {TsVector -> Text
unTsVector::Text} deriving (TsVector -> TsVector -> Bool
(TsVector -> TsVector -> Bool)
-> (TsVector -> TsVector -> Bool) -> Eq TsVector
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TsVector -> TsVector -> Bool
== :: TsVector -> TsVector -> Bool
$c/= :: TsVector -> TsVector -> Bool
/= :: 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
$cshowsPrec :: Int -> TsVector -> ShowS
showsPrec :: Int -> TsVector -> ShowS
$cshow :: TsVector -> String
show :: TsVector -> String
$cshowList :: [TsVector] -> ShowS
showList :: [TsVector] -> ShowS
Show, String -> TsVector
(String -> TsVector) -> IsString TsVector
forall a. (String -> a) -> IsString a
$cfromString :: String -> TsVector
fromString :: String -> TsVector
IsString)

defaultTsVector :: TsVector
defaultTsVector :: TsVector
defaultTsVector = Text -> TsVector
TsVector Text
""

instance PersistField TsVector where
  toPersistValue :: TsVector -> PersistValue
toPersistValue = ByteString -> PersistValue
PersistDbSpecific (ByteString -> PersistValue)
-> (TsVector -> ByteString) -> TsVector -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (TsVector -> Text) -> TsVector -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TsVector -> Text
unTsVector
  fromPersistValue :: PersistValue -> Either Text TsVector
fromPersistValue (PersistDbSpecific ByteString
bs) = TsVector -> Either Text TsVector
forall a b. b -> Either a b
Right (TsVector -> Either Text TsVector)
-> TsVector -> Either Text TsVector
forall a b. (a -> b) -> a -> b
$ Text -> TsVector
TsVector (Text -> TsVector) -> Text -> TsVector
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
bs
  fromPersistValue PersistValue
f
    = Text -> Either Text TsVector
forall a b. a -> Either a b
Left (Text -> Either Text TsVector) -> Text -> Either Text TsVector
forall a b. (a -> b) -> a -> b
$ Text
"TextSearch/TsVector: Unexpected Persist field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PersistValue -> Text
forall a. Show a => a -> Text
tShow PersistValue
f

instance PersistFieldSql TsVector where
  sqlType :: Proxy TsVector -> SqlType
sqlType = SqlType -> Proxy TsVector -> SqlType
forall a b. a -> b -> a
const (Text -> SqlType
SqlOther Text
"tsvector")



-- | regconfig is the object identifier type which represents the
--   text search configuration in Postgres: http://www.postgresql.org/docs/9.3/static/datatype-oid.html
--
--   this could for example be a language or simple.
newtype RegConfig = RegConfig {RegConfig -> Text
unRegConfig::Text} deriving (RegConfig -> RegConfig -> Bool
(RegConfig -> RegConfig -> Bool)
-> (RegConfig -> RegConfig -> Bool) -> Eq RegConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RegConfig -> RegConfig -> Bool
== :: RegConfig -> RegConfig -> Bool
$c/= :: RegConfig -> RegConfig -> Bool
/= :: RegConfig -> RegConfig -> Bool
Eq, Int -> RegConfig -> ShowS
[RegConfig] -> ShowS
RegConfig -> String
(Int -> RegConfig -> ShowS)
-> (RegConfig -> String)
-> ([RegConfig] -> ShowS)
-> Show RegConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RegConfig -> ShowS
showsPrec :: Int -> RegConfig -> ShowS
$cshow :: RegConfig -> String
show :: RegConfig -> String
$cshowList :: [RegConfig] -> ShowS
showList :: [RegConfig] -> ShowS
Show, String -> RegConfig
(String -> RegConfig) -> IsString RegConfig
forall a. (String -> a) -> IsString a
$cfromString :: String -> RegConfig
fromString :: String -> RegConfig
IsString)

instance PersistField RegConfig where
  toPersistValue :: RegConfig -> PersistValue
toPersistValue = ByteString -> PersistValue
PersistDbSpecific (ByteString -> PersistValue)
-> (RegConfig -> ByteString) -> RegConfig -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (RegConfig -> Text) -> RegConfig -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RegConfig -> Text
unRegConfig
  fromPersistValue :: PersistValue -> Either Text RegConfig
fromPersistValue (PersistDbSpecific ByteString
bs) = RegConfig -> Either Text RegConfig
forall a b. b -> Either a b
Right (RegConfig -> Either Text RegConfig)
-> RegConfig -> Either Text RegConfig
forall a b. (a -> b) -> a -> b
$ Text -> RegConfig
RegConfig (Text -> RegConfig) -> Text -> RegConfig
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8 ByteString
bs
  fromPersistValue PersistValue
f
    = Text -> Either Text RegConfig
forall a b. a -> Either a b
Left (Text -> Either Text RegConfig) -> Text -> Either Text RegConfig
forall a b. (a -> b) -> a -> b
$ Text
"TextSearch/RegConfig: Unexpected Persist field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PersistValue -> Text
forall a. Show a => a -> Text
tShow PersistValue
f

instance PersistFieldSql RegConfig where
  sqlType :: Proxy RegConfig -> SqlType
sqlType = SqlType -> Proxy RegConfig -> SqlType
forall a b. a -> b -> a
const (Text -> SqlType
SqlOther Text
"regconfig")

tShow :: Show a => a -> Text
tShow :: forall a. Show a => a -> Text
tShow = String -> Text
forall a. IsString a => String -> a
fromString (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show