esqueleto-textsearch (empty) → 1.0.0.3
raw patch · 10 files changed
+772/−0 lines, 10 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, data-default, esqueleto, esqueleto-textsearch, hspec, monad-control, monad-logger, parsec, persistent, persistent-postgresql, persistent-template, resourcet, text, transformers
Files
- Changelog.md +6/−0
- LICENSE +20/−0
- README.md +2/−0
- Setup.hs +2/−0
- esqueleto-textsearch.cabal +62/−0
- src/Database/Esqueleto/TextSearch.hs +7/−0
- src/Database/Esqueleto/TextSearch/Language.hs +70/−0
- src/Database/Esqueleto/TextSearch/Types.hs +243/−0
- test/Database/Esqueleto/TextSearchSpec.hs +353/−0
- test/Spec.hs +7/−0
+ Changelog.md view
@@ -0,0 +1,6 @@+# Change log for esqueleto text search ++## Version 1.0.0.3 ++initial version, uploaded from:+https://github.com/creichert/esqueleto-textsearch
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Alberto Valverde Gonzalez++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,2 @@+# esqueleto-fts+PostgreSQL full text search for Esqueleto
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ esqueleto-textsearch.cabal view
@@ -0,0 +1,62 @@+name: esqueleto-textsearch+version: 1.0.0.3+synopsis: PostgreSQL full text search for Esqueleto+description: PostgreSQL text search functions for Esqueleto.+homepage: https://github.com/SupercedeTech/esqueleto-textsearch-ii+license: MIT+license-file: LICENSE+author: Alberto Valverde González+maintainer: info@supercede.com+copyright: 2015 Alberto Valverde González+category: Database+build-type: Simple+extra-source-files: README.md+ Changelog.md+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/SupercedeTech/esqueleto-textsearch-ii ++library+ exposed-modules:+ Database.Esqueleto.TextSearch+ Database.Esqueleto.TextSearch.Language+ Database.Esqueleto.TextSearch.Types++ build-depends:+ base >=4.9 && <5+ , data-default <0.8+ , esqueleto >=3.2 && < 3.6+ , parsec <3.2+ , persistent >=2.8.2 && <2.15+ , persistent-postgresql >=2.10 && <2.15+ , text >=1.2 && <2.1++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall -fwarn-incomplete-uni-patterns++test-suite spec+ type: exitcode-stdio-1.0+ ghc-options: -Wall -fwarn-incomplete-uni-patterns+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules: Database.Esqueleto.TextSearchSpec+ build-depends:+ base+ , esqueleto+ , esqueleto-textsearch+ , hspec+ , HUnit+ , monad-control+ , monad-logger+ , persistent+ , persistent-postgresql+ , persistent-template+ , QuickCheck+ , resourcet+ , text+ , transformers++ default-language: Haskell2010
+ src/Database/Esqueleto/TextSearch.hs view
@@ -0,0 +1,7 @@+module Database.Esqueleto.TextSearch (+ module Database.Esqueleto.TextSearch.Language+ , module Database.Esqueleto.TextSearch.Types+) where++import Database.Esqueleto.TextSearch.Language+import Database.Esqueleto.TextSearch.Types
+ src/Database/Esqueleto/TextSearch/Language.hs view
@@ -0,0 +1,70 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.Esqueleto.TextSearch.Language+ ( (@@.)+ , to_tsvector+ , to_tsquery+ , plainto_tsquery+ , ts_rank+ , ts_rank_cd+ , setweight+ ) where++import Data.String (IsString)+import Data.Text (Text)+import Database.Esqueleto (SqlExpr, Value)+#if MIN_VERSION_esqueleto(3,5,0)+import Database.Esqueleto.Internal.Internal (unsafeSqlBinOp, unsafeSqlFunction)+#else+import Database.Esqueleto.Internal.Sql (unsafeSqlBinOp, unsafeSqlFunction)+#endif+import Database.Esqueleto.TextSearch.Types++(@@.)+ :: SqlExpr (Value TsVector)+ -> SqlExpr (Value (TsQuery Lexemes))+ -> SqlExpr (Value Bool)+(@@.) = unsafeSqlBinOp "@@"++to_tsvector+ :: IsString a+ => SqlExpr (Value RegConfig)+ -> SqlExpr (Value a)+ -> SqlExpr (Value TsVector)+to_tsvector a b = unsafeSqlFunction "to_tsvector" (a, b)++to_tsquery+ :: SqlExpr (Value RegConfig)+ -> SqlExpr (Value (TsQuery Words))+ -> SqlExpr (Value (TsQuery Lexemes) )+to_tsquery a b = unsafeSqlFunction "to_tsquery" (a, b)++plainto_tsquery+ :: SqlExpr (Value RegConfig)+ -> SqlExpr (Value Text)+ -> SqlExpr (Value (TsQuery Lexemes))+plainto_tsquery a b = unsafeSqlFunction "plainto_tsquery" (a, b)++ts_rank+ :: SqlExpr (Value Weights)+ -> SqlExpr (Value TsVector)+ -> SqlExpr (Value (TsQuery Lexemes))+ -> SqlExpr (Value [NormalizationOption])+ -> SqlExpr (Value Double)+ts_rank a b c d = unsafeSqlFunction "ts_rank" (a, b, c, d)++ts_rank_cd+ :: SqlExpr (Value Weights)+ -> SqlExpr (Value TsVector)+ -> SqlExpr (Value (TsQuery Lexemes))+ -> SqlExpr (Value [NormalizationOption])+ -> SqlExpr (Value Double)+ts_rank_cd a b c d = unsafeSqlFunction "ts_rank_cd" (a, b, c, d)++setweight+ :: SqlExpr (Value TsVector)+ -> SqlExpr (Value Weight)+ -> SqlExpr (Value TsVector)+setweight a b = unsafeSqlFunction "setweight" (a, b)
+ src/Database/Esqueleto/TextSearch/Types.hs view
@@ -0,0 +1,243 @@+{-# 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 (Eq, Show, Enum, Bounded)++normToInt :: NormalizationOption -> Int64+normToInt n+ | fromEnum n == 0 = 0+ | otherwise = 2 ^ (fromEnum n - 1)++instance PersistField [NormalizationOption] where+ toPersistValue = PersistInt64 . foldl' (.|.) 0 . map normToInt+ fromPersistValue (PersistInt64 n) = Right $ foldl' go [] [minBound..maxBound]+ where go acc v = case normToInt v .&. n of+ 0 -> acc+ _ -> v:acc+ fromPersistValue f+ = Left $+ "TextSearch/[NormalizationOption]: Unexpected Persist field: " <> tShow f+instance PersistFieldSql [NormalizationOption] where+ sqlType = const SqlInt32++data Weight+ = Highest+ | High+ | Medium+ | Low+ deriving (Eq, Show)++weightToChar :: Weight -> Char+weightToChar Highest = 'A'+weightToChar High = 'B'+weightToChar Medium = 'C'+weightToChar Low = 'D'++instance PersistField Weight where+ toPersistValue = PersistText . singleton . weightToChar+ fromPersistValue (PersistText "A") = Right Highest+ fromPersistValue (PersistText "B") = Right High+ fromPersistValue (PersistText "C") = Right Medium+ fromPersistValue (PersistText "D") = Right Low+ fromPersistValue (PersistText _)+ = Left "TextSearch/Weight: Unexpected character"+ fromPersistValue f+ = Left $ "TextSearch/Weight: Unexpected Persist field: " <> tShow f+instance PersistFieldSql Weight where+ sqlType = const (SqlOther "char")++data Weights+ = Weights { dWeight :: !Double+ , cWeight :: !Double+ , bWeight :: !Double+ , aWeight :: !Double+ } deriving (Eq, Show)++instance Default Weights where+ def = Weights 0.1 0.2 0.4 1.0++instance PersistField Weights where+ toPersistValue (Weights d c b a)+ --FIXME: persistent-postgresql should handle this properly+ = PersistDbSpecific $ fromString $ (printf "{%f,%f,%f,%f}" d c b a)+ fromPersistValue (PersistList [d, c, b, a])+ = Weights <$> fromPersistValue d+ <*> fromPersistValue c+ <*> fromPersistValue b+ <*> fromPersistValue a+ fromPersistValue (PersistList _)+ = Left "TextSearch/Weights: Expected a length-4 float array"+ fromPersistValue f+ = Left $ "TextSearch/Weights: Unexpected Persist field: " <> tShow f++instance PersistFieldSql Weights where+ sqlType = const (SqlOther "float4[4]")++data QueryType = Words | Lexemes+type Lexemes = 'Lexemes+type Words = 'Words++data Position = Prefix | Infix deriving (Show, 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 = PersistDbSpecific . encodeUtf8 . queryToText+ fromPersistValue (PersistDbSpecific _)+ = Left "TextSearch/TsQuery: Cannot parse (TsQuery Words)"+ fromPersistValue f+ = Left $ "TextSearch/TsQuery: Unexpected Persist field: " <> tShow f++instance PersistField (TsQuery Lexemes) where+ toPersistValue = PersistDbSpecific . encodeUtf8 . queryToText+ fromPersistValue (PersistDbSpecific bs)+ = case textToQuery (decodeUtf8 bs) of+ Right q -> Right q+ Left e -> Left $ "Could not parse TsQuery: " <> tShow e+ fromPersistValue f+ = Left $ "TextSearch/TsQuery: Unexpected Persist field: " <> tShow f++instance PersistFieldSql (TsQuery Words) where+ sqlType = const (SqlOther "tsquery")++instance PersistFieldSql (TsQuery Lexemes) where+ sqlType = const (SqlOther "tsquery")++instance a~Words => IsString (TsQuery a) where+ fromString = word . fromString++word :: Text -> TsQuery Words+word = Word Infix []+++queryToText :: TsQuery a -> Text+queryToText = toStrict . toLazyText . build . unsafeAsLexeme+ where+ build :: TsQuery Lexemes -> Builder+ build (Lexeme Infix [] s) = "'" <> fromText s <> "'"+ build (Lexeme Infix ws s) = "'" <> fromText s <> "':" <> buildWeights ws+ build (Lexeme Prefix ws s) = "'" <> fromText s <> "':*" <> buildWeights ws+ build (a :& b) = parens a <> "&" <> parens b+ build (a :| b) = parens a <> "|" <> parens b+ build (Not q) = "!" <> parens q+ buildWeights = fromText . fromString . map weightToChar+ unsafeAsLexeme :: TsQuery a -> TsQuery Lexemes+ unsafeAsLexeme q@Lexeme{} = q+ unsafeAsLexeme (Word p ws s) = Lexeme p ws s+ unsafeAsLexeme (a :& b) = unsafeAsLexeme a :& unsafeAsLexeme b+ unsafeAsLexeme (a :| b) = unsafeAsLexeme a :| unsafeAsLexeme b+ unsafeAsLexeme (Not q) = Not (unsafeAsLexeme q)+ parens a@Lexeme{} = build a+ parens a = "(" <> build a <> ")"++textToQuery :: Text -> Either ParseError (TsQuery Lexemes)+textToQuery = runParser (expr <* eof) () ""+ where+ expr = spaced (P.buildExpressionParser table (spaced term))+ term = parens expr+ <|> lexeme+ table = [ [P.Prefix (char '!' *> pure Not)]+ , [P.Infix (char '&' *> pure (:&)) P.AssocRight]+ , [P.Infix (char '|' *> pure (:|)) P.AssocRight]+ ]+ lexeme = do+ s <- fromString <$> quoted (many1 (satisfy (/='\'')))+ _ <- optional (char ':')+ pos <- char '*' *> pure Prefix <|> pure Infix+ ws <- many weight+ return $ Lexeme pos ws s+ weight = choice [ char 'A' *> pure Highest+ , char 'B' *> pure High+ , char 'C' *> pure Medium+ , char 'D' *> pure Low]+ spaced = between (optional spaces) (optional spaces)+ quoted = between (char '\'') (char '\'')+ parens = between (char '(') (char ')')++newtype TsVector = TsVector {unTsVector::Text} deriving (Eq, Show, IsString)++instance Default TsVector where+ def = TsVector ""++instance PersistField TsVector where+ toPersistValue = PersistDbSpecific . encodeUtf8 . unTsVector+ fromPersistValue (PersistDbSpecific bs) = Right $ TsVector $ decodeUtf8 bs+ fromPersistValue f+ = Left $ "TextSearch/TsVector: Unexpected Persist field: " <> tShow f++instance PersistFieldSql TsVector where+ sqlType = const (SqlOther "tsvector")+++newtype RegConfig = RegConfig {unRegConfig::Text} deriving (Eq, Show, IsString)++instance PersistField RegConfig where+ toPersistValue = PersistDbSpecific . encodeUtf8 . unRegConfig+ fromPersistValue (PersistDbSpecific bs) = Right $ RegConfig $ decodeUtf8 bs+ fromPersistValue f+ = Left $ "TextSearch/RegConfig: Unexpected Persist field: " <> tShow f++instance PersistFieldSql RegConfig where+ sqlType = const (SqlOther "regconfig")++tShow :: Show a => a -> Text+tShow = fromString . show
+ test/Database/Esqueleto/TextSearchSpec.hs view
@@ -0,0 +1,353 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++module Database.Esqueleto.TextSearchSpec (main, spec) where++import Control.Monad (forM_)+import Data.Maybe (fromJust)+import Data.Text (Text, pack)++import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Logger (MonadLogger(..), runStderrLoggingT)+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Trans.Resource (MonadThrow, ResourceT, runResourceT)+import Database.Esqueleto+ ( SqlExpr+ , Value(..)+ , from+ , select+ , set+ , unValue+ , update+ , val+ , where_+ , (=.)+ , (^.)+ )+import Database.Persist (PersistField(..), entityKey, get, insert)+import Database.Persist.Postgresql+ ( ConnectionString+ , SqlPersistT+ , runMigration+ , runSqlConn+ , transactionUndo+ , withPostgresqlConn+ )+import Database.Persist.TH+ (mkMigrate, mkPersist, persistUpperCase, share, sqlSettings)+import Test.Hspec (Spec, describe, hspec, it, shouldBe)+import Test.QuickCheck+ (Arbitrary(..), choose, elements, listOf, listOf1, oneof, property)++import Database.Esqueleto.TextSearch++connString :: ConnectionString+connString = "host=localhost port=5432 user=test dbname=test password=test"++-- Test schema+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|+ Article+ title Text+ content Text+ textsearch TsVector+ deriving Eq Show++ WeightsModel+ weights Weights+ deriving Eq Show++ WeightModel+ weight Weight+ deriving Eq Show++ RegConfigModel+ config RegConfig+ deriving Eq Show++ QueryModel+ query (TsQuery Lexemes)+ deriving Eq Show+|]+++main :: IO ()+main = hspec spec++to_etsvector :: SqlExpr (Value Text) -> SqlExpr (Value TsVector)+to_etsvector = to_tsvector (val "english")++spec :: Spec+spec = do+ describe "TsVector" $ do+ it "can be persisted and retrieved" $ run $ do+ let article = Article "some title" "some content" def+ arId <- insert article+ update $ \a -> do+ set a [ArticleTextsearch =. to_etsvector (a^.ArticleContent)]+ ret <- fromJust <$> get arId+ liftIO $ articleTextsearch ret /= def `shouldBe` True++ it "can be persisted and retrieved with weight" $ run $ do+ let article = Article "some title" "some content" def+ arId <- insert article+ update $ \a -> do+ set a [ ArticleTextsearch+ =. setweight (to_etsvector (a^.ArticleContent)) (val Highest)+ ]+ ret <- fromJust <$> get arId+ liftIO $ articleTextsearch ret /= def `shouldBe` True++ describe "Weight" $ do+ it "can be persisted and retrieved" $ run $ do+ forM_ [Low, Medium, High, Highest] $ \w -> do+ let m = WeightModel w+ wId <- insert m+ ret <- get wId+ liftIO $ ret `shouldBe` Just m++ describe "Weights" $ do+ it "can be persisted and retrieved" $ run $ do+ let m = WeightsModel $ Weights 0.5 0.6 0.7 0.8+ wsId <- insert m+ ret <- get wsId+ liftIO $ ret `shouldBe` Just m++ describe "RegConfig" $ do+ it "can be persisted and retrieved" $ run $ do+ forM_ ["english", "spanish"] $ \c -> do+ let m = RegConfigModel c+ wId <- insert m+ ret <- get wId+ liftIO $ ret `shouldBe` Just m+++ describe "TsQuery" $ do+ it "can be persisted and retrieved" $ run $ do+ let qm = QueryModel (lexm "foo" :& lexm "bar")+ qId <- insert qm+ ret <- fromJust <$> get qId+ liftIO $ qm `shouldBe` ret++ describe "to_tsquery" $ do+ it "converts words to lexemes" $ run $ do+ lqs <- select $ return $+ to_tsquery (val "english") (val ("supernovae" :& "rats"))+ let lq = unValue $ head lqs+ liftIO $ lq `shouldBe` (lexm "supernova" :& lexm "rat")++ describe "plainto_tsquery" $ do+ it "converts text to lexemes" $ run $ do+ lqs <- select $ return $+ plainto_tsquery (val "english") (val "rats in supernovae")+ let lq = unValue $ head lqs+ liftIO $ lq `shouldBe` (lexm "rat" :& lexm "supernova")++ describe "queryToText" $ do+ it "can serialize infix lexeme" $+ queryToText (lexm "foo") `shouldBe` "'foo'"+ it "can serialize infix lexeme with weights" $+ queryToText (Lexeme Infix [Highest,Low] "foo") `shouldBe` "'foo':AD"+ it "can serialize prefix lexeme" $+ queryToText (Lexeme Prefix [] "foo") `shouldBe` "'foo':*"+ it "can serialize prefix lexeme with weights" $+ queryToText (Lexeme Prefix [Highest,Low] "foo") `shouldBe` "'foo':*AD"+ it "can serialize AND" $+ queryToText ("foo" :& "bar" :& "car") `shouldBe` "'foo'&('bar'&'car')"+ it "can serialize OR" $+ queryToText ("foo" :| "bar") `shouldBe` "'foo'|'bar'"+ it "can serialize Not" $+ queryToText (Not "bar") `shouldBe` "!'bar'"++ describe "textToQuery" $ do+ describe "infix lexeme" $ do+ it "can parse it" $+ textToQuery "'foo'" `shouldBe` Right (lexm "foo")+ it "can parse it surrounded by spaces" $+ textToQuery " 'foo' " `shouldBe` Right (lexm "foo")++ describe "infix lexeme with weights" $ do+ it "can parse it" $+ textToQuery "'foo':AB"+ `shouldBe` Right (Lexeme Infix [Highest,High] "foo")+ it "can parse it surrounded by spaces" $+ textToQuery " 'foo':AB "+ `shouldBe` Right (Lexeme Infix [Highest,High] "foo")++ describe "prefix lexeme" $ do+ it "can parse it" $+ textToQuery "'foo':*" `shouldBe` Right (Lexeme Prefix [] "foo")+ it "can parse it surrounded byb spaces" $+ textToQuery " 'foo':* " `shouldBe` Right (Lexeme Prefix [] "foo")++ describe "prefix lexeme with weights" $ do+ it "can parse it" $+ textToQuery "'foo':*AB" `shouldBe`+ Right (Lexeme Prefix [Highest,High] "foo")+ it "can parse it surrounded by spaces" $+ textToQuery " 'foo':*AB " `shouldBe`+ Right (Lexeme Prefix [Highest,High] "foo")++ describe "&" $ do+ it "can parse it" $+ textToQuery "'foo'&'bar'" `shouldBe`+ Right (lexm "foo" :& lexm "bar")+ it "can parse it surrounded by spaces" $ do+ textToQuery "'foo' & 'bar'" `shouldBe`+ Right (lexm "foo" :& lexm "bar")+ textToQuery "'foo'& 'bar'" `shouldBe`+ Right (lexm "foo" :& lexm "bar")+ textToQuery "'foo' &'bar'" `shouldBe`+ Right (lexm "foo" :& lexm "bar")+ textToQuery " 'foo'&'bar' " `shouldBe`+ Right (lexm "foo" :& lexm "bar")+ it "can parse several" $+ textToQuery "'foo'&'bar'&'car'" `shouldBe`+ Right (lexm "foo" :& lexm "bar" :& lexm "car")++ describe "|" $ do+ it "can parse it" $+ textToQuery "'foo'|'bar'" `shouldBe` Right (lexm "foo" :| lexm "bar")+ it "can parse several" $+ textToQuery "'foo'|'bar'|'car'" `shouldBe`+ Right (lexm "foo" :| lexm "bar" :| lexm "car")++ describe "mixed |s and &s" $ do+ it "respects precedence" $ do+ textToQuery "'foo'|'bar'&'car'" `shouldBe`+ Right (lexm "foo" :| lexm "bar" :& lexm "car")+ textToQuery "'foo'&'bar'|'car'" `shouldBe`+ Right (lexm "foo" :& lexm "bar" :| lexm "car")++ describe "!" $ do+ it "can parse it" $+ textToQuery "!'foo'" `shouldBe` Right (Not (lexm "foo"))++ describe "! and &" $ do+ it "can parse it" $ do+ textToQuery "!'foo'&'car'" `shouldBe`+ Right (Not (lexm "foo") :& lexm "car")+ textToQuery "!('foo'&'car')" `shouldBe`+ Right (Not (lexm "foo" :& lexm "car"))+ it "can parse it surrounded by spaces" $ do+ textToQuery "!'foo' & 'car'" `shouldBe`+ Right (Not (lexm "foo") :& lexm "car")+ textToQuery "!( 'foo' & 'car' )" `shouldBe`+ Right (Not (lexm "foo" :& lexm "car"))++ describe "textToQuery . queryToText" $ do+ it "is isomorphism" $ property $ \q ->+ (textToQuery . queryToText) q `shouldBe` Right q++ describe "@@" $ do+ it "works as expected" $ run $ do+ let article = Article "some title" "some content" def+ arId <- insert article+ update $ \a -> do+ set a [ArticleTextsearch =. to_etsvector (a^.ArticleContent)]+ let query = to_tsquery (val "english") (val "content")+ result <- select $ from $ \a -> do+ where_ $ (a^. ArticleTextsearch) @@. query+ return a+ liftIO $ do+ length result `shouldBe` 1+ map entityKey result `shouldBe` [arId]+ let query2 = to_tsquery (val "english") (val "foo")+ result2 <- select $ from $ \a -> do+ where_ $ (a^. ArticleTextsearch) @@. query2+ return a+ liftIO $ length result2 `shouldBe` 0++ describe "ts_rank_cd" $ do+ it "works as expected" $ run $ do+ let vector = to_tsvector (val "english") (val content)+ content = "content" :: Text+ query = to_tsquery (val "english") (val "content")+ norm = val []+ ret <- select $ return $ ts_rank_cd (val def) vector query norm+ liftIO $ map unValue ret `shouldBe` [0.1]++ describe "ts_rank" $ do+ it "works as expected" $ run $ do+ let vector = to_tsvector (val "english") (val content)+ content = "content" :: Text+ query = to_tsquery (val "english") (val "content")+ norm = val []+ ret <- select $ return $ ts_rank (val def) vector query norm+ liftIO $ unValue (head ret) `shouldBe` 6.079271e-2++ describe "NormalizationOption" $ do+ describe "fromPersistValue . toPersistValue" $ do+ let isEqual [] [] = True+ isEqual [NormNone] [] = True+ isEqual [] [NormNone] = True+ isEqual a b = a == b+ toRight (Right a) = a+ toRight _ = error "unexpected Left"+ it "is isomorphism" $ property $ \(q :: [NormalizationOption]) ->+ isEqual ((toRight . fromPersistValue . toPersistValue) q) q+ `shouldBe` True++instance {-# OVERLAPPING #-} Arbitrary [NormalizationOption] where+ arbitrary = (:[]) <$> elements [minBound..maxBound]++instance a ~ Lexemes => Arbitrary (TsQuery a) where+ arbitrary = query 0+ where+ maxDepth :: Int+ maxDepth = 10+ query d+ | d<maxDepth = oneof [lexeme, and_ d, or_ d, not_ d]+ | otherwise = lexeme+ lexeme = Lexeme <$> arbitrary <*> weights <*> lexString+ weights = listOf arbitrary+ and_ d = (:&) <$> query (d+1) <*> query (d+1)+ or_ d = (:|) <$> query (d+1) <*> query (d+1)+ not_ d = Not <$> query (d+1)+ lexString = pack <$> listOf1 (oneof $ [ choose ('a','z')+ , choose ('A','Z')+ , choose ('0','9')+ ] ++ map pure "-_&|ñçáéíóú")++instance Arbitrary Position where+ arbitrary = oneof [pure Infix, pure Prefix]++instance Arbitrary Weight where+ arbitrary = oneof [pure Highest, pure High, pure Medium, pure Low]+++lexm :: Text -> TsQuery Lexemes+lexm = Lexeme Infix []++type RunDbMonad m+ = (MonadBaseControl IO m, MonadIO m, MonadLogger m, MonadThrow m)++run :: (forall m. RunDbMonad m => SqlPersistT (ResourceT m) a) -> IO a+run act+ = runStderrLoggingT+ . runResourceT+ . withPostgresqlConn connString+ . runSqlConn+ $ (initializeDB >> act >>= \ret -> transactionUndo >> return ret)+++initializeDB+ :: (forall m. RunDbMonad m+ => SqlPersistT (ResourceT m) ())+initializeDB = do+ runMigration migrateAll
+ test/Spec.hs view
@@ -0,0 +1,7 @@+module Main where++import qualified Database.Esqueleto.TextSearchSpec+++main :: IO ()+main = Database.Esqueleto.TextSearchSpec.main