{-# 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
  , RegConfig
  , NormalizationOption (..)
  , Weight (..)
  , Weights (..)
  , Position (..)
  , word
  , queryToText
  , textToQuery
  , def
) 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.Default (Default(def))
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

data NormalizationOption
  = NormNone
  | Norm1LogLength
  | NormLength
  | NormMeanHarmDist
  | NormUniqueWords
  | Norm1LogUniqueWords
  | Norm1Self
  deriving (NormalizationOption -> NormalizationOption -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NormalizationOption -> NormalizationOption -> Bool
$c/= :: NormalizationOption -> NormalizationOption -> Bool
== :: NormalizationOption -> NormalizationOption -> Bool
$c== :: NormalizationOption -> NormalizationOption -> Bool
Eq, Int -> NormalizationOption -> ShowS
[NormalizationOption] -> ShowS
NormalizationOption -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NormalizationOption] -> ShowS
$cshowList :: [NormalizationOption] -> ShowS
show :: NormalizationOption -> String
$cshow :: NormalizationOption -> String
showsPrec :: Int -> NormalizationOption -> ShowS
$cshowsPrec :: Int -> NormalizationOption -> ShowS
Show, Int -> NormalizationOption
NormalizationOption -> Int
NormalizationOption -> [NormalizationOption]
NormalizationOption -> NormalizationOption
NormalizationOption -> NormalizationOption -> [NormalizationOption]
NormalizationOption
-> NormalizationOption
-> NormalizationOption
-> [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
enumFromThenTo :: NormalizationOption
-> NormalizationOption
-> NormalizationOption
-> [NormalizationOption]
$cenumFromThenTo :: NormalizationOption
-> NormalizationOption
-> NormalizationOption
-> [NormalizationOption]
enumFromTo :: NormalizationOption -> NormalizationOption -> [NormalizationOption]
$cenumFromTo :: NormalizationOption -> NormalizationOption -> [NormalizationOption]
enumFromThen :: NormalizationOption -> NormalizationOption -> [NormalizationOption]
$cenumFromThen :: NormalizationOption -> NormalizationOption -> [NormalizationOption]
enumFrom :: NormalizationOption -> [NormalizationOption]
$cenumFrom :: NormalizationOption -> [NormalizationOption]
fromEnum :: NormalizationOption -> Int
$cfromEnum :: NormalizationOption -> Int
toEnum :: Int -> NormalizationOption
$ctoEnum :: Int -> NormalizationOption
pred :: NormalizationOption -> NormalizationOption
$cpred :: NormalizationOption -> NormalizationOption
succ :: NormalizationOption -> NormalizationOption
$csucc :: NormalizationOption -> NormalizationOption
Enum, NormalizationOption
forall a. a -> a -> Bounded a
maxBound :: NormalizationOption
$cmaxBound :: NormalizationOption
minBound :: NormalizationOption
$cminBound :: NormalizationOption
Bounded)

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

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

data Weight
  = Highest
  | High
  | Medium
  | Low
  deriving (Weight -> Weight -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Weight -> Weight -> Bool
$c/= :: Weight -> Weight -> Bool
== :: Weight -> Weight -> Bool
$c== :: Weight -> Weight -> Bool
Eq, Int -> Weight -> ShowS
[Weight] -> ShowS
Weight -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Weight] -> ShowS
$cshowList :: [Weight] -> ShowS
show :: Weight -> String
$cshow :: Weight -> String
showsPrec :: Int -> Weight -> ShowS
$cshowsPrec :: Int -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Text
singleton forall b c a. (b -> c) -> (a -> b) -> a -> c
. Weight -> Char
weightToChar
  fromPersistValue :: PersistValue -> Either Text Weight
fromPersistValue (PersistText Text
"A") = forall a b. b -> Either a b
Right Weight
Highest
  fromPersistValue (PersistText Text
"B") = forall a b. b -> Either a b
Right Weight
High
  fromPersistValue (PersistText Text
"C") = forall a b. b -> Either a b
Right Weight
Medium
  fromPersistValue (PersistText Text
"D") = forall a b. b -> Either a b
Right Weight
Low
  fromPersistValue (PersistText Text
_)
    = forall a b. a -> Either a b
Left Text
"TextSearch/Weight: Unexpected character"
  fromPersistValue PersistValue
f
    = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"TextSearch/Weight: Unexpected Persist field: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tShow PersistValue
f
instance PersistFieldSql Weight where
  sqlType :: Proxy Weight -> SqlType
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Weights -> Weights -> Bool
$c/= :: Weights -> Weights -> Bool
== :: Weights -> Weights -> Bool
$c== :: Weights -> Weights -> Bool
Eq, Int -> Weights -> ShowS
[Weights] -> ShowS
Weights -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Weights] -> ShowS
$cshowList :: [Weights] -> ShowS
show :: Weights -> String
$cshow :: Weights -> String
showsPrec :: Int -> Weights -> ShowS
$cshowsPrec :: Int -> Weights -> ShowS
Show)

instance Default Weights where
  def :: Weights
def = 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 forall a b. (a -> b) -> a -> b
$ forall a. IsString a => String -> a
fromString forall a b. (a -> b) -> a -> b
$ (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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
d
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
c
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
b
              forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
a
  fromPersistValue (PersistList [PersistValue]
_)
    = forall a b. a -> Either a b
Left Text
"TextSearch/Weights: Expected a length-4 float array"
  fromPersistValue PersistValue
f
    = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"TextSearch/Weights: Unexpected Persist field: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tShow PersistValue
f

instance PersistFieldSql Weights where
  sqlType :: Proxy Weights -> SqlType
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Position] -> ShowS
$cshowList :: [Position] -> ShowS
show :: Position -> String
$cshow :: Position -> String
showsPrec :: Int -> Position -> ShowS
$cshowsPrec :: Int -> Position -> ShowS
Show, Position -> Position -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Position -> Position -> Bool
$c/= :: Position -> Position -> Bool
== :: Position -> Position -> Bool
$c== :: 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: QueryType). TsQuery a -> Text
queryToText
  fromPersistValue :: PersistValue -> Either Text (TsQuery 'Words)
fromPersistValue (PersistDbSpecific ByteString
_)
    = forall a b. a -> Either a b
Left Text
"TextSearch/TsQuery: Cannot parse (TsQuery Words)"
  fromPersistValue PersistValue
f
    = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"TextSearch/TsQuery: Unexpected Persist field: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tShow PersistValue
f

instance PersistField (TsQuery Lexemes) where
  toPersistValue :: TsQuery 'Lexemes -> PersistValue
toPersistValue = ByteString -> PersistValue
PersistDbSpecific forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 -> forall a b. b -> Either a b
Right TsQuery 'Lexemes
q
        Left  ParseError
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Could not parse TsQuery: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tShow ParseError
e
  fromPersistValue PersistValue
f
    = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"TextSearch/TsQuery: Unexpected Persist field: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tShow PersistValue
f

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

instance PersistFieldSql (TsQuery Lexemes) where
  sqlType :: Proxy (TsQuery 'Lexemes) -> SqlType
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 'Words
word forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. TsQuery 'Lexemes -> Builder
build forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme
  where
    build :: TsQuery Lexemes -> Builder
    build :: TsQuery 'Lexemes -> Builder
build (Lexeme Position
Infix [] Text
s)    = Builder
"'" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
s forall a. Semigroup a => a -> a -> a
<> Builder
"'"
    build (Lexeme Position
Infix [Weight]
ws Text
s)    = Builder
"'" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
s forall a. Semigroup a => a -> a -> a
<> Builder
"':"  forall a. Semigroup a => a -> a -> a
<> [Weight] -> Builder
buildWeights [Weight]
ws
    build (Lexeme Position
Prefix [Weight]
ws Text
s)   = Builder
"'" forall a. Semigroup a => a -> a -> a
<> Text -> Builder
fromText Text
s forall a. Semigroup a => a -> a -> a
<> 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 forall a. Semigroup a => a -> a -> a
<> 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 forall a. Semigroup a => a -> a -> a
<> Builder
"|" forall a. Semigroup a => a -> a -> a
<> TsQuery 'Lexemes -> Builder
parens TsQuery 'Lexemes
b
    build (Not TsQuery 'Lexemes
q)                = Builder
"!" forall a. Semigroup a => a -> a -> a
<> TsQuery 'Lexemes -> Builder
parens TsQuery 'Lexemes
q
    buildWeights :: [Weight] -> Builder
buildWeights                 = Text -> Builder
fromText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
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)      = forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme TsQuery a
a forall (a :: QueryType). TsQuery a -> TsQuery a -> TsQuery a
:& forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme TsQuery a
b
    unsafeAsLexeme (TsQuery a
a :| TsQuery a
b)      = forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme TsQuery a
a forall (a :: QueryType). TsQuery a -> TsQuery a -> TsQuery a
:| forall (a :: QueryType). TsQuery a -> TsQuery 'Lexemes
unsafeAsLexeme TsQuery a
b
    unsafeAsLexeme (Not TsQuery a
q)       = forall (a :: QueryType). TsQuery a -> TsQuery a
Not (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
"(" forall a. Semigroup a => a -> a -> a
<> TsQuery 'Lexemes -> Builder
build TsQuery 'Lexemes
a forall a. Semigroup a => a -> a -> a
<> Builder
")"

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

instance Default TsVector where
  def :: TsVector
def = Text -> TsVector
TsVector Text
""

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

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


newtype RegConfig = RegConfig {RegConfig -> Text
unRegConfig::Text} deriving (RegConfig -> RegConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RegConfig -> RegConfig -> Bool
$c/= :: RegConfig -> RegConfig -> Bool
== :: RegConfig -> RegConfig -> Bool
$c== :: RegConfig -> RegConfig -> Bool
Eq, Int -> RegConfig -> ShowS
[RegConfig] -> ShowS
RegConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RegConfig] -> ShowS
$cshowList :: [RegConfig] -> ShowS
show :: RegConfig -> String
$cshow :: RegConfig -> String
showsPrec :: Int -> RegConfig -> ShowS
$cshowsPrec :: Int -> RegConfig -> ShowS
Show, String -> RegConfig
forall a. (String -> a) -> IsString a
fromString :: String -> RegConfig
$cfromString :: String -> RegConfig
IsString)

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

instance PersistFieldSql RegConfig where
  sqlType :: Proxy RegConfig -> SqlType
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 = forall a. IsString a => String -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show