a72311a · typeable/bloodhound

git.iko.soy/typeable/bloodhound

on master help sign in

WIP: fix several bugs with parsers, more to go

a72311aMichael Xavier11 years ago

bloodhound.cabal+5−2

compare with master

unifiedsplit

@@ -45,7 +45,8 @@ library

45 data-default-class,

46 blaze-builder,

47 unordered-containers,

48− mtl-compat

48+ mtl-compat,

49+ hashable

49 default-language: Haskell2010

50 default-language: Haskell2010

51test-suite tests

52test-suite tests

@@ -68,7 +69,9 @@ test-suite tests

68 vector,

69 vector,

69 unordered-containers >= 0.2.5.0 && <0.3,

70 unordered-containers >= 0.2.5.0 && <0.3,

70 mtl,

71 mtl,

71− quickcheck-properties

72+ quickcheck-properties,

73+ derive,

74+ quickcheck-instances

72 default-language: Haskell2010

75 default-language: Haskell2010

74test-suite doctests

77test-suite doctests

src/Database/Bloodhound/Types.hs+79−39

@@ -251,6 +251,7 @@ import Data.Aeson.Types (Pair, Parser, emptyObject,

251 parseMaybe)

252import qualified Data.ByteString.Lazy.Char8 as L

253import Data.Char

254+import Data.Hashable (Hashable)

254import qualified Data.HashMap.Strict as HM

255import qualified Data.HashMap.Strict as HM

255import Data.List (foldl', nub)

256import Data.List (foldl', nub)

256import Data.List.NonEmpty (NonEmpty (..), toList)

257import Data.List.NonEmpty (NonEmpty (..), toList)

@@ -266,6 +267,8 @@ import GHC.Generics (Generic)

266import Network.HTTP.Client

267import Network.HTTP.Client

267import qualified Network.HTTP.Types.Method as NHTM

268import qualified Network.HTTP.Types.Method as NHTM

268

269

270+import Debug.Trace

271+

269import Database.Bloodhound.Types.Class

272import Database.Bloodhound.Types.Class

270

273

271-- $setup

274-- $setup

@@ -711,8 +714,6 @@ newtype BoostTerms =

711-}

714-}

712newtype MinimumMatch =

715newtype MinimumMatch =

713 MinimumMatch Int deriving (Eq, Show, Generic, ToJSON, FromJSON)

716 MinimumMatch Int deriving (Eq, Show, Generic, ToJSON, FromJSON)

714−newtype MinimumMatchText =

715− MinimumMatchText Text deriving (Eq, Show, ToJSON, FromJSON)

716newtype DisableCoord =

717newtype DisableCoord =

717 DisableCoord Bool deriving (Eq, Show, Generic, ToJSON, FromJSON)

718 DisableCoord Bool deriving (Eq, Show, Generic, ToJSON, FromJSON)

718newtype IgnoreTermFrequency =

719newtype IgnoreTermFrequency =

@@ -1722,18 +1723,24 @@ instance FromJSON Filter where

1722 <*> o .:? "_cache" .!= defaultCache

1723 <*> o .:? "_cache" .!= defaultCache

1723 orFilter o = OrFilter <$> o .: "filters"

1724 orFilter o = OrFilter <$> o .: "filters"

1724 <*> o .:? "_cache" .!= defaultCache

1725 <*> o .:? "_cache" .!= defaultCache

1725− notFilter o = NotFilter <$> o .: "filters"

1726+ notFilter o = NotFilter <$> o .: "filter"

1726 <*> o .: "_cache" .!= defaultCache

1727 <*> o .: "_cache" .!= defaultCache

1728+ identityFilter :: Object -> Parser Filter

1729+ identityFilter m

1727− identityFilter () = pure IdentityFilter

1730+ | HM.null m = pure IdentityFilter

1731+ | otherwise = fail ("Identityfilter expected empty object but got " <> show m)

1728 boolFilter = pure . BoolFilter

1732 boolFilter = pure . BoolFilter

1729 existsFilter o = ExistsFilter <$> o .: "field"

1733 existsFilter o = ExistsFilter <$> o .: "field"

1730 geoBoundingBoxFilter = pure . GeoBoundingBoxFilter

1734 geoBoundingBoxFilter = pure . GeoBoundingBoxFilter

1731− geoDistanceFilter o = flip fieldTagged o $ \fn o' -> do

1735+ geoDistanceFilter o = do

1736+ case HM.toList (deleteSeveral ["distance", "distance_type", "optimize_bbox", "_cache"] o) of

1737+ [(fn, v)] -> do

1732− gp <- GeoPoint fn <$> parseJSON (Object o')

1738+ gp <- GeoPoint (FieldName fn) <$> parseJSON v

1733− GeoDistanceFilter gp <$> o .: "distance"

1739+ GeoDistanceFilter gp <$> o .: "distance"

1734− <*> o .: "distance_type"

1740+ <*> o .: "distance_type"

1735− <*> o .: "optimize_bbox"

1741+ <*> o .: "optimize_bbox"

1736− <*> o .:? "_cache" .!= defaultCache

1742+ <*> o .:? "_cache" .!= defaultCache

1743+ _ -> fail "Could not find GeoDistanceFilter field name"

1737 geoDistanceRangeFilter o = flip fieldTagged o $ \fn o' -> do

1744 geoDistanceRangeFilter o = flip fieldTagged o $ \fn o' -> do

1738 gp <- GeoPoint fn <$> parseJSON (Object o')

1745 gp <- GeoPoint fn <$> parseJSON (Object o')

1739 rng <- DistanceRange <$> o .: "from" <*> o .: "to"

1746 rng <- DistanceRange <$> o .: "from" <*> o .: "to"

@@ -1745,21 +1752,27 @@ instance FromJSON Filter where

1745 missingFilter o = MissingFilter <$> o .: "field"

1752 missingFilter o = MissingFilter <$> o .: "field"

1746 <*> o .: "existence"

1753 <*> o .: "existence"

1747 <*> o .: "null_value"

1754 <*> o .: "null_value"

1748− prefixFilter o = flip fieldTagged o $ \fn o' -> PrefixFilter fn <$> parseJSON (Object o')

1755+ prefixFilter o = case HM.toList (HM.delete "_cache" o) of

1749− <*> o .:? "_cache" .!= defaultCache

1756+ [(fn, String v)] -> PrefixFilter (FieldName fn) v <$> o .:? "_cache" .!= defaultCache

1757+ _ -> fail "Could not parse PrefixFilter"

1758+

1750 queryFilter q = pure (QueryFilter q False)

1759 queryFilter q = pure (QueryFilter q False)

1751 fqueryFilter o = QueryFilter <$> o .: "query" <*> pure True

1760 fqueryFilter o = QueryFilter <$> o .: "query" <*> pure True

1752− rangeFilter o = flip fieldTagged o $ \fn o' -> RangeFilter fn <$> parseJSON (Object o')

1761+ rangeFilter o = case HM.toList (deleteSeveral ["execution", "_cache"] o) of

1762+ [(fn, v)] -> RangeFilter (FieldName fn)

1763+ <$> parseJSON v

1753− <*> o .: "execution"

1764+ <*> o .: "execution"

1754− <*> o .:? "_cache" .!= defaultCache

1765+ <*> o .:? "_cache" .!= defaultCache

1766+ _ -> fail "Could not find field name for RangeFilter"

1755 regexpFilter = fieldTagged $ \fn o -> RegexpFilter fn <$> o .: "value"

1767 regexpFilter = fieldTagged $ \fn o -> RegexpFilter fn <$> o .: "value"

1756 <*> o .: "flags"

1768 <*> o .: "flags"

1757 <*> o .: "_name"

1769 <*> o .: "_name"

1758 <*> o .:? "_cache" .!= defaultCache

1770 <*> o .:? "_cache" .!= defaultCache

1759 <*> o .: "_cache_key"

1771 <*> o .: "_cache_key"

1760− termFilter o = flip fieldTagged o $ \(FieldName fn) o' -> do

1772+ termFilter o = case HM.toList (HM.delete "_cache" o) of

1761− trm <- Term fn <$> parseJSON (Object o')

1773+ [(termField, String termVal)] -> TermFilter (Term termField termVal)

1762− TermFilter trm <$> o .: "_cache" .!= defaultCache

1774+ <$> o .:? "_cache" .!= defaultCache

1775+ _ -> fail "Could not find term field for TermFilter"

1763

1776

1764fieldTagged :: Monad m => (FieldName -> Object -> m a) -> Object -> m a

1777fieldTagged :: Monad m => (FieldName -> Object -> m a) -> Object -> m a

1765fieldTagged f o = case HM.toList o of

1778fieldTagged f o = case HM.toList o of

@@ -1866,13 +1879,13 @@ instance ToJSON Query where

1866 object [ "simple_query_string" .= query ]

1879 object [ "simple_query_string" .= query ]

1867

1880

1868instance FromJSON Query where

1881instance FromJSON Query where

1869− parseJSON = withObject "Query" parse

1882+ parseJSON v = withObject "Query" parse v

1870 where parse o = termQuery `taggedWith` "term"

1883 where parse o = termQuery `taggedWith` "term"

1871 <|> termsQuery `taggedWith` "terms"

1884 <|> termsQuery `taggedWith` "terms"

1872 <|> idsQuery `taggedWith` "ids"

1885 <|> idsQuery `taggedWith` "ids"

1873 <|> queryQueryStringQuery `taggedWith` "query_string"

1886 <|> queryQueryStringQuery `taggedWith` "query_string"

1874 <|> queryMatchQuery `taggedWith` "match"

1887 <|> queryMatchQuery `taggedWith` "match"

1875− <|> queryMultiMatchQuery o --TODO: is this a precedence issue?

1888+ <|> queryMultiMatchQuery --TODO: is this a precedence issue?

1876 <|> queryBoolQuery `taggedWith` "bool"

1889 <|> queryBoolQuery `taggedWith` "bool"

1877 <|> queryBoostingQuery `taggedWith` "boosting"

1890 <|> queryBoostingQuery `taggedWith` "boosting"

1878 <|> queryCommonTermsQuery `taggedWith` "common"

1891 <|> queryCommonTermsQuery `taggedWith` "common"

@@ -1895,8 +1908,8 @@ instance FromJSON Query where

1895 <|> queryRegexpQuery `taggedWith` "regexp"

1908 <|> queryRegexpQuery `taggedWith` "regexp"

1896 <|> querySimpleQueryStringQuery `taggedWith` "simple_query_string"

1909 <|> querySimpleQueryStringQuery `taggedWith` "simple_query_string"

1897 where taggedWith parser k = parser =<< o .: k

1910 where taggedWith parser k = parser =<< o .: k

1898− termQuery o = TermQuery <$> parseJSON (Object o)

1911+ termQuery = fieldTagged $ \(FieldName fn) o ->

1899− <*> o .:? "boost"

1912+ TermQuery <$> (Term fn <$> o .: "value") <*> o .:? "boost"

1900 termsQuery o = case HM.toList o of

1913 termsQuery o = case HM.toList o of

1901 [(fn, vs)] -> do vals <- parseJSON vs

1914 [(fn, vs)] -> do vals <- parseJSON vs

1902 case vals of

1915 case vals of

@@ -1907,7 +1920,7 @@ instance FromJSON Query where

1907 <*> o .: "values"

1920 <*> o .: "values"

1908 queryQueryStringQuery = pure . QueryQueryStringQuery

1921 queryQueryStringQuery = pure . QueryQueryStringQuery

1909 queryMatchQuery = pure . QueryMatchQuery

1922 queryMatchQuery = pure . QueryMatchQuery

1910− queryMultiMatchQuery = undefined

1923+ queryMultiMatchQuery = QueryMultiMatchQuery <$> parseJSON v

1911 queryBoolQuery = pure . QueryBoolQuery

1924 queryBoolQuery = pure . QueryBoolQuery

1912 queryBoostingQuery = pure . QueryBoostingQuery

1925 queryBoostingQuery = pure . QueryBoostingQuery

1913 queryCommonTermsQuery = pure . QueryCommonTermsQuery

1926 queryCommonTermsQuery = pure . QueryCommonTermsQuery

@@ -2071,7 +2084,7 @@ instance FromJSON QueryStringQuery where

2071

2084

2072instance ToJSON RangeQuery where

2085instance ToJSON RangeQuery where

2073 toJSON (RangeQuery (FieldName fieldName) range boost) =

2086 toJSON (RangeQuery (FieldName fieldName) range boost) =

2074− object [ fieldName .= conjoined ]

2087+ object [ fieldName .= object conjoined ]

2075 where conjoined = [ "boost" .= boost ] ++ (rangeValueToPair range)

2088 where conjoined = [ "boost" .= boost ] ++ (rangeValueToPair range)

2076

2089

2077instance FromJSON RangeQuery where

2090instance FromJSON RangeQuery where

@@ -2312,7 +2325,7 @@ instance ToJSON FuzzyLikeThisQuery where

2312instance FromJSON FuzzyLikeThisQuery where

2325instance FromJSON FuzzyLikeThisQuery where

2313 parseJSON = withObject "FuzzyLikeThisQuery" parse

2326 parseJSON = withObject "FuzzyLikeThisQuery" parse

2314 where parse o = FuzzyLikeThisQuery

2327 where parse o = FuzzyLikeThisQuery

2315− <$> o .: "fields"

2328+ <$> o .:? "fields" .!= []

2316 <*> o .: "like_text"

2329 <*> o .: "like_text"

2317 <*> o .: "max_query_terms"

2330 <*> o .: "max_query_terms"

2318 <*> o .: "ignore_tf"

2331 <*> o .: "ignore_tf"

@@ -2342,7 +2355,7 @@ instance ToJSON DisMaxQuery where

2342instance FromJSON DisMaxQuery where

2355instance FromJSON DisMaxQuery where

2343 parseJSON = withObject "DisMaxQuery" parse

2356 parseJSON = withObject "DisMaxQuery" parse

2344 where parse o = DisMaxQuery

2357 where parse o = DisMaxQuery

2345− <$> o .: "queries"

2358+ <$> o .:? "queries" .!= []

2346 <*> o .: "tie_breaker"

2359 <*> o .: "tie_breaker"

2347 <*> o .:? "boost"

2360 <*> o .:? "boost"

2348

2361

@@ -2467,6 +2480,20 @@ instance ToJSON MultiMatchQuery where

2467 , "max_expansions" .= maxEx

2480 , "max_expansions" .= maxEx

2468 , "lenient" .= lenient ]

2481 , "lenient" .= lenient ]

2469

2482

2483+instance FromJSON MultiMatchQuery where

2484+ parseJSON = withObject "MultiMatchQuery" parse

2485+ where parse raw = do o <- raw .: "multi_match"

2486+ MultiMatchQuery

2487+ <$> o .:? "fields" .!= []

2488+ <*> o .: "query"

2489+ <*> o .: "operator"

2490+ <*> o .: "zero_terms_query"

2491+ <*> o .:? "tiebreaker"

2492+ <*> o .:? "type"

2493+ <*> o .:? "cutoff_frequency"

2494+ <*> o .:? "analyzer"

2495+ <*> o .:? "max_expansions"

2496+ <*> o .:? "lenient"

2470

2497

2471instance ToJSON MultiMatchQueryType where

2498instance ToJSON MultiMatchQueryType where

2472 toJSON MultiMatchBestFields = "best_fields"

2499 toJSON MultiMatchBestFields = "best_fields"

@@ -2603,12 +2630,16 @@ instance FromJSON AliasRouting where

2603 parseJSON = withObject "AliasRouting" parse

2630 parseJSON = withObject "AliasRouting" parse

2604 where parse o = parseAll o <|> parseGranular o

2631 where parse o = parseAll o <|> parseGranular o

2605 parseAll o = AllAliasRouting <$> o .: "routing"

2632 parseAll o = AllAliasRouting <$> o .: "routing"

2633+ parseGranular o = do

2634+ sr <- o .:? "search_routing"

2635+ ir <- o .:? "index_routing"

2636+ if isNothing sr && isNothing ir

2637+ then fail "Both search_routing and index_routing can't be blank"

2606− parseGranular o = GranularAliasRouting <$> o .:? "search_routing"

2638+ else return (GranularAliasRouting sr ir)

2607− <*> o .:? "index_routing"

2608

2639

2609instance FromJSON IndexAliasCreate where

2640instance FromJSON IndexAliasCreate where

2610 parseJSON v = withObject "IndexAliasCreate" parse v

2641 parseJSON v = withObject "IndexAliasCreate" parse v

2611− where parse o = IndexAliasCreate <$> parseJSON v

2642+ where parse o = IndexAliasCreate <$> optional (parseJSON v)

2612 <*> o .:? "filter"

2643 <*> o .:? "filter"

2613

2644

2614instance ToJSON SearchAliasRouting where

2645instance ToJSON SearchAliasRouting where

@@ -2700,6 +2731,9 @@ fastVectorHighPairs (Just

2700 ++ commonHighlightPairs fvCom

2731 ++ commonHighlightPairs fvCom

2701 ++ nonPostingsToPairs fvNonPostSettings

2732 ++ nonPostingsToPairs fvNonPostSettings

2702

2733

2734+deleteSeveral :: (Eq k, Hashable k) => [k] -> HM.HashMap k v -> HM.HashMap k v

2735+deleteSeveral ks hm = foldr HM.delete hm ks

2736+

2703commonHighlightPairs :: Maybe CommonHighlight -> [Pair]

2737commonHighlightPairs :: Maybe CommonHighlight -> [Pair]

2704commonHighlightPairs Nothing = []

2738commonHighlightPairs Nothing = []

2705commonHighlightPairs (Just (CommonHighlight chScore chForceSource chTag chEncoder

2739commonHighlightPairs (Just (CommonHighlight chScore chForceSource chTag chEncoder

@@ -2778,10 +2812,10 @@ instance ToJSON ScoreType where

2778

2812

2779instance FromJSON ScoreType where

2813instance FromJSON ScoreType where

2780 parseJSON = withText "ScoreType" parse

2814 parseJSON = withText "ScoreType" parse

2781− where parse "max" = pure ScoreTypeMax

2815+ where parse "max" = pure ScoreTypeMax

2782− parse "avg" = pure ScoreTypeAvg

2816+ parse "avg" = pure ScoreTypeAvg

2783− parse "sum" = pure ScoreTypeSum

2817+ parse "sum" = pure ScoreTypeSum

2784− parse "non" = pure ScoreTypeNone

2818+ parse "none" = pure ScoreTypeNone

2785 parse t = fail ("Unexpected ScoreType: " <> show t)

2819 parse t = fail ("Unexpected ScoreType: " <> show t)

2786

2820

2787instance ToJSON Distance where

2821instance ToJSON Distance where

@@ -2795,7 +2829,12 @@ instance FromJSON Distance where

2795 parseJSON = withText "Distance" parse

2829 parseJSON = withText "Distance" parse

2796 where parse t = Distance <$> parseCoeff nT

2830 where parse t = Distance <$> parseCoeff nT

2797 <*> parseJSON (String unitT)

2831 <*> parseJSON (String unitT)

2798− where (nT, unitT) = T.span isNumber t

2832+ where (nT, unitT) = T.span validForNumber t

2833+ -- may be a better way to do this

2834+ validForNumber '-' = True

2835+ validForNumber '.' = True

2836+ validForNumber 'e' = True

2837+ validForNumber c = isNumber c

2799 parseCoeff "" = fail "Empty string cannot be parsed as number"

2838 parseCoeff "" = fail "Empty string cannot be parsed as number"

2800 parseCoeff s = return (read (T.unpack s))

2839 parseCoeff s = return (read (T.unpack s))

2801

2840

@@ -2857,11 +2896,12 @@ instance ToJSON GeoBoundingBoxConstraint where

2857

2896

2858instance FromJSON GeoBoundingBoxConstraint where

2897instance FromJSON GeoBoundingBoxConstraint where

2859 parseJSON = withObject "GeoBoundingBoxConstraint" parse

2898 parseJSON = withObject "GeoBoundingBoxConstraint" parse

2860− where parse o = flip fieldTagged o $ \fn o' ->

2899+ where parse o = case HM.toList (deleteSeveral ["type", "_cache"] o) of

2861− GeoBoundingBoxConstraint fn

2900+ [(fn, v)] -> GeoBoundingBoxConstraint (FieldName fn)

2862− <$> parseJSON (Object o')

2901+ <$> parseJSON v

2863− <*> o .:? "cache" .!= defaultCache

2902+ <*> o .:? "_cache" .!= defaultCache

2864− <*> o .: "type"

2903+ <*> o .: "type"

2904+ _ -> fail "Could not find field name for GeoBoundingBoxConstraint"

2865

2905

2866instance ToJSON GeoFilterType where

2906instance ToJSON GeoFilterType where

2867 toJSON GeoFilterMemory = String "memory"

2907 toJSON GeoFilterMemory = String "memory"

tests/tests.hs+239−31

@@ -1,6 +1,7 @@

1{-# LANGUAGE DeriveGeneric #-}

2{-# LANGUAGE OverloadedStrings #-}

3{-# LANGUAGE ScopedTypeVariables #-}

4+{-# LANGUAGE TemplateHaskell #-}

4{-# OPTIONS_GHC -fno-warn-orphans #-}

5{-# OPTIONS_GHC -fno-warn-orphans #-}

5module Main where

6module Main where

@@ -9,21 +10,25 @@ import Control.Exception

9import Control.Monad

10import Control.Monad

10import Control.Monad.Reader

11import Control.Monad.Reader

11import Data.Aeson

12import Data.Aeson

13+import Data.Aeson.Types (parseEither)

14+import Data.DeriveTH

12import qualified Data.HashMap.Strict as HM

15import qualified Data.HashMap.Strict as HM

13import Data.List (nub)

16import Data.List (nub)

14import Data.List.NonEmpty (NonEmpty (..))

17import Data.List.NonEmpty (NonEmpty (..))

15import qualified Data.List.NonEmpty as NE

18import qualified Data.List.NonEmpty as NE

16import qualified Data.Map.Strict as M

19import qualified Data.Map.Strict as M

17import Data.Monoid

20import Data.Monoid

21+import Data.Proxy

18import Data.Text (Text)

22import Data.Text (Text)

19import qualified Data.Text as T

23import qualified Data.Text as T

20import Data.Time.Calendar (Day (..))

24import Data.Time.Calendar (Day (..))

21import Data.Time.Clock (UTCTime (..),

25import Data.Time.Clock (UTCTime (..),

22 secondsToDiffTime)

26 secondsToDiffTime)

27+import Data.Typeable

23import qualified Data.Vector as V

28import qualified Data.Vector as V

24import Database.Bloodhound

29import Database.Bloodhound

25import GHC.Generics (Generic)

30import GHC.Generics (Generic)

26−import Network.HTTP.Client

31+import Network.HTTP.Client hiding (Proxy)

27import qualified Network.HTTP.Types.Status as NHTS

32import qualified Network.HTTP.Types.Status as NHTS

28import Prelude hiding (filter)

33import Prelude hiding (filter)

29import Test.Hspec

34import Test.Hspec

@@ -31,6 +36,7 @@ import Test.QuickCheck.Property.Monoid (T (..), eq, prop_Monoid)

32import Test.Hspec.QuickCheck (prop)

37import Test.Hspec.QuickCheck (prop)

33import Test.QuickCheck

38import Test.QuickCheck

39+import Test.QuickCheck.Instances ()

35testServer :: Server

41testServer :: Server

36testServer = Server "http://localhost:9200"

42testServer = Server "http://localhost:9200"

@@ -101,6 +107,12 @@ is v = testServerBranch >>= \x -> return $ x == Just (serverBranch v)

101when' :: Monad m => m Bool -> m () -> m ()

107when' :: Monad m => m Bool -> m () -> m ()

102when' b f = b >>= \x -> when x f

108when' b f = b >>= \x -> when x f

103

109

110+propJSON :: forall a. (Arbitrary a, ToJSON a, FromJSON a, Show a, Eq a, Typeable a) => Proxy a -> Spec

111+propJSON _ = prop testName $ \(a :: a) ->

112+ parseEither parseJSON (toJSON a) === Right a

113+ where testName = show ty <> " FromJSON/ToJSON roundtrips"

114+ ty = typeOf (undefined :: a)

115+

104data Location = Location { lat :: Double

116data Location = Location { lat :: Double

105 , lon :: Double } deriving (Eq, Generic, Show)

117 , lon :: Double } deriving (Eq, Generic, Show)

106

118

@@ -265,42 +277,12 @@ instance ToJSON BulkTest where

265noDuplicates :: Eq a => [a] -> Bool

277noDuplicates :: Eq a => [a] -> Bool

266noDuplicates xs = nub xs == xs

278noDuplicates xs = nub xs == xs

267

279

268−instance Arbitrary RegexpFlags where

269− arbitrary = oneof [ pure AllRegexpFlags

270− , pure NoRegexpFlags

271− , SomeRegexpFlags <$> arbitrary

272− ]

273−

274instance Arbitrary a => Arbitrary (NonEmpty a) where

280instance Arbitrary a => Arbitrary (NonEmpty a) where

275 arbitrary = liftA2 (:|) arbitrary arbitrary

281 arbitrary = liftA2 (:|) arbitrary arbitrary

276

282

277−instance Arbitrary RegexpFlag where

278− arbitrary = oneof [ pure AnyString

279− , pure Automaton

280− , pure Complement

281− , pure Empty

282− , pure Intersection

283− , pure Interval

284− ]

285−

286arbitraryScore :: Gen Score

283arbitraryScore :: Gen Score

287arbitraryScore = fmap getPositive <$> arbitrary

284arbitraryScore = fmap getPositive <$> arbitrary

288

285

289−instance Arbitrary Text where

290− arbitrary = T.pack <$> arbitrary

291−

292−instance (Arbitrary k, Arbitrary v, Ord k) => Arbitrary (M.Map k v) where

293− arbitrary = M.fromList <$> arbitrary

294−

295−instance Arbitrary IndexName where

296− arbitrary = IndexName <$> arbitrary

297−

298−instance Arbitrary MappingName where

299− arbitrary = MappingName <$> arbitrary

300−

301−instance Arbitrary DocId where

302− arbitrary = DocId <$> arbitrary

303−

304instance Arbitrary a => Arbitrary (Hit a) where

286instance Arbitrary a => Arbitrary (Hit a) where

305 arbitrary = Hit <$> arbitrary

287 arbitrary = Hit <$> arbitrary

306 <*> arbitrary

288 <*> arbitrary

@@ -327,6 +309,135 @@ grabFirst r =

327 (Right Nothing) -> Left "Source was missing"

309 (Right Nothing) -> Left "Source was missing"

328 (Right (Just x)) -> Right x

310 (Right (Just x)) -> Right x

329

311

312+-------------------------------------------------------------------------------

313+arbitraryAlphaNum :: Gen Char

314+arbitraryAlphaNum = oneof [choose ('a', 'z')

315+ ,choose ('A','Z')

316+ , choose ('0', '9')]

317+

318+instance Arbitrary RoutingValue where

319+ arbitrary = RoutingValue . T.pack <$> listOf1 arbitraryAlphaNum

320+

321+instance Arbitrary AliasRouting where

322+ arbitrary = oneof [allAlias

323+ ,one

324+ ,theOther

325+ ,both]

326+ where one = GranularAliasRouting

327+ <$> (Just <$> arbitrary)

328+ <*> pure Nothing

329+ theOther = GranularAliasRouting Nothing

330+ <$> (Just <$> arbitrary)

331+ both = GranularAliasRouting

332+ <$> (Just <$> arbitrary)

333+ <*> (Just <$> arbitrary)

334+ allAlias = AllAliasRouting <$> arbitrary

335+

336+$(derive makeArbitrary ''IndexName)

337+$(derive makeArbitrary ''FieldName)

338+$(derive makeArbitrary ''MappingName)

339+$(derive makeArbitrary ''DocId)

340+$(derive makeArbitrary ''Version)

341+$(derive makeArbitrary ''IndexAliasRouting)

342+$(derive makeArbitrary ''ShardCount)

343+$(derive makeArbitrary ''ReplicaCount)

344+$(derive makeArbitrary ''TemplateName)

345+$(derive makeArbitrary ''TemplatePattern)

346+$(derive makeArbitrary ''QueryString)

347+$(derive makeArbitrary ''CacheName)

348+$(derive makeArbitrary ''CacheKey)

349+$(derive makeArbitrary ''Existence)

350+$(derive makeArbitrary ''CutoffFrequency)

351+$(derive makeArbitrary ''Analyzer)

352+$(derive makeArbitrary ''MaxExpansions)

353+$(derive makeArbitrary ''Lenient)

354+$(derive makeArbitrary ''Tiebreaker)

355+$(derive makeArbitrary ''Boost)

356+$(derive makeArbitrary ''BoostTerms)

357+$(derive makeArbitrary ''MinimumMatch)

358+$(derive makeArbitrary ''DisableCoord)

359+$(derive makeArbitrary ''IgnoreTermFrequency)

360+$(derive makeArbitrary ''MinimumTermFrequency)

361+$(derive makeArbitrary ''MaxQueryTerms)

362+$(derive makeArbitrary ''Fuzziness)

363+$(derive makeArbitrary ''PrefixLength)

364+$(derive makeArbitrary ''TypeName)

365+$(derive makeArbitrary ''PercentMatch)

366+$(derive makeArbitrary ''StopWord)

367+$(derive makeArbitrary ''QueryPath)

368+$(derive makeArbitrary ''AllowLeadingWildcard)

369+$(derive makeArbitrary ''LowercaseExpanded)

370+$(derive makeArbitrary ''EnablePositionIncrements)

371+$(derive makeArbitrary ''AnalyzeWildcard)

372+$(derive makeArbitrary ''GeneratePhraseQueries)

373+$(derive makeArbitrary ''Locale)

374+$(derive makeArbitrary ''MaxWordLength)

375+$(derive makeArbitrary ''MinWordLength)

376+$(derive makeArbitrary ''PhraseSlop)

377+$(derive makeArbitrary ''MinDocFrequency)

378+$(derive makeArbitrary ''MaxDocFrequency)

379+$(derive makeArbitrary ''Regexp)

380+$(derive makeArbitrary ''Filter)

381+$(derive makeArbitrary ''Query)

382+$(derive makeArbitrary ''SimpleQueryStringQuery)

383+$(derive makeArbitrary ''FieldOrFields)

384+$(derive makeArbitrary ''SimpleQueryFlag)

385+$(derive makeArbitrary ''RegexpQuery)

386+$(derive makeArbitrary ''QueryStringQuery)

387+$(derive makeArbitrary ''RangeQuery)

388+$(derive makeArbitrary ''RangeValue)

389+$(derive makeArbitrary ''PrefixQuery)

390+$(derive makeArbitrary ''NestedQuery)

391+$(derive makeArbitrary ''MoreLikeThisFieldQuery)

392+$(derive makeArbitrary ''MoreLikeThisQuery)

393+$(derive makeArbitrary ''IndicesQuery)

394+$(derive makeArbitrary ''HasParentQuery)

395+$(derive makeArbitrary ''HasChildQuery)

396+$(derive makeArbitrary ''FuzzyQuery)

397+$(derive makeArbitrary ''FuzzyLikeFieldQuery)

398+$(derive makeArbitrary ''FuzzyLikeThisQuery)

399+$(derive makeArbitrary ''FilteredQuery)

400+$(derive makeArbitrary ''DisMaxQuery)

401+$(derive makeArbitrary ''CommonTermsQuery)

402+$(derive makeArbitrary ''DistanceRange)

403+$(derive makeArbitrary ''MultiMatchQuery)

404+$(derive makeArbitrary ''LessThanD)

405+$(derive makeArbitrary ''LessThanEqD)

406+$(derive makeArbitrary ''GreaterThanD)

407+$(derive makeArbitrary ''GreaterThanEqD)

408+$(derive makeArbitrary ''LessThan)

409+$(derive makeArbitrary ''LessThanEq)

410+$(derive makeArbitrary ''GreaterThan)

411+$(derive makeArbitrary ''GreaterThanEq)

412+$(derive makeArbitrary ''GeoPoint)

413+$(derive makeArbitrary ''NullValue)

414+$(derive makeArbitrary ''MinimumMatchHighLow)

415+$(derive makeArbitrary ''CommonMinimumMatch)

416+$(derive makeArbitrary ''BoostingQuery)

417+$(derive makeArbitrary ''BoolQuery)

418+$(derive makeArbitrary ''MatchQuery)

419+$(derive makeArbitrary ''MultiMatchQueryType)

420+$(derive makeArbitrary ''BooleanOperator)

421+$(derive makeArbitrary ''ZeroTermsQuery)

422+$(derive makeArbitrary ''MatchQueryType)

423+$(derive makeArbitrary ''IndexAliasCreate)

424+$(derive makeArbitrary ''SearchAliasRouting)

425+$(derive makeArbitrary ''ScoreType)

426+$(derive makeArbitrary ''Distance)

427+$(derive makeArbitrary ''DistanceUnit)

428+$(derive makeArbitrary ''DistanceType)

429+$(derive makeArbitrary ''OptimizeBbox)

430+$(derive makeArbitrary ''GeoBoundingBoxConstraint)

431+$(derive makeArbitrary ''GeoFilterType)

432+$(derive makeArbitrary ''GeoBoundingBox)

433+$(derive makeArbitrary ''LatLon)

434+$(derive makeArbitrary ''RangeExecution)

435+$(derive makeArbitrary ''RegexpFlags)

436+$(derive makeArbitrary ''RegexpFlag)

437+$(derive makeArbitrary ''BoolMatch)

438+$(derive makeArbitrary ''Term)

439+

440+

330main :: IO ()

441main :: IO ()

331main = hspec $ do

442main = hspec $ do

332

443

@@ -869,3 +980,100 @@ main = hspec $ do

869 regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored

980 regular_search `shouldBe` Right exampleTweet -- Check that the size restrtiction is being honored

870 liftIO $

981 liftIO $

871 scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]

982 scan_search `shouldMatchList` [Just exampleTweet, Just otherTweet]

983+

984+ describe "JSON instances" $ do

985+ propJSON (Proxy :: Proxy Version)

986+ propJSON (Proxy :: Proxy IndexName)

987+ propJSON (Proxy :: Proxy MappingName)

988+ propJSON (Proxy :: Proxy DocId)

989+ propJSON (Proxy :: Proxy IndexAliasRouting)

990+ propJSON (Proxy :: Proxy RoutingValue)

991+ propJSON (Proxy :: Proxy ShardCount)

992+ propJSON (Proxy :: Proxy ReplicaCount)

993+ propJSON (Proxy :: Proxy TemplateName)

994+ propJSON (Proxy :: Proxy TemplatePattern)

995+ propJSON (Proxy :: Proxy QueryString)

996+ propJSON (Proxy :: Proxy FieldName)

997+ propJSON (Proxy :: Proxy CacheName)

998+ propJSON (Proxy :: Proxy CacheKey)

999+ propJSON (Proxy :: Proxy Existence)

1000+ propJSON (Proxy :: Proxy CutoffFrequency)

1001+ propJSON (Proxy :: Proxy Analyzer)

1002+ propJSON (Proxy :: Proxy MaxExpansions)

1003+ propJSON (Proxy :: Proxy Lenient)

1004+ propJSON (Proxy :: Proxy Tiebreaker)

1005+ propJSON (Proxy :: Proxy Boost)

1006+ propJSON (Proxy :: Proxy BoostTerms)

1007+ propJSON (Proxy :: Proxy MaxExpansions)

1008+ propJSON (Proxy :: Proxy MinimumMatch)

1009+ propJSON (Proxy :: Proxy DisableCoord)

1010+ propJSON (Proxy :: Proxy IgnoreTermFrequency)

1011+ propJSON (Proxy :: Proxy MinimumTermFrequency)

1012+ propJSON (Proxy :: Proxy MaxQueryTerms)

1013+ propJSON (Proxy :: Proxy Fuzziness)

1014+ propJSON (Proxy :: Proxy PrefixLength)

1015+ propJSON (Proxy :: Proxy TypeName)

1016+ propJSON (Proxy :: Proxy PercentMatch)

1017+ propJSON (Proxy :: Proxy StopWord)

1018+ propJSON (Proxy :: Proxy QueryPath)

1019+ propJSON (Proxy :: Proxy AllowLeadingWildcard)

1020+ propJSON (Proxy :: Proxy LowercaseExpanded)

1021+ propJSON (Proxy :: Proxy EnablePositionIncrements)

1022+ propJSON (Proxy :: Proxy AnalyzeWildcard)

1023+ propJSON (Proxy :: Proxy GeneratePhraseQueries)

1024+ propJSON (Proxy :: Proxy Locale)

1025+ propJSON (Proxy :: Proxy MaxWordLength)

1026+ propJSON (Proxy :: Proxy MinWordLength)

1027+ propJSON (Proxy :: Proxy PhraseSlop)

1028+ propJSON (Proxy :: Proxy MinDocFrequency)

1029+ propJSON (Proxy :: Proxy MaxDocFrequency)

1030+ propJSON (Proxy :: Proxy Filter)

1031+ propJSON (Proxy :: Proxy Query)

1032+ propJSON (Proxy :: Proxy SimpleQueryStringQuery)

1033+ propJSON (Proxy :: Proxy FieldOrFields)

1034+ propJSON (Proxy :: Proxy SimpleQueryFlag)

1035+ propJSON (Proxy :: Proxy RegexpQuery)

1036+ propJSON (Proxy :: Proxy QueryStringQuery)

1037+ propJSON (Proxy :: Proxy RangeQuery)

1038+ propJSON (Proxy :: Proxy PrefixQuery)

1039+ propJSON (Proxy :: Proxy NestedQuery)

1040+ propJSON (Proxy :: Proxy MoreLikeThisFieldQuery)

1041+ propJSON (Proxy :: Proxy MoreLikeThisQuery)

1042+ propJSON (Proxy :: Proxy IndicesQuery)

1043+ propJSON (Proxy :: Proxy HasParentQuery)

1044+ propJSON (Proxy :: Proxy HasChildQuery)

1045+ propJSON (Proxy :: Proxy FuzzyQuery)

1046+ propJSON (Proxy :: Proxy FuzzyLikeFieldQuery)

1047+ propJSON (Proxy :: Proxy FuzzyLikeThisQuery)

1048+ propJSON (Proxy :: Proxy FilteredQuery)

1049+ propJSON (Proxy :: Proxy DisMaxQuery)

1050+ propJSON (Proxy :: Proxy CommonTermsQuery)

1051+ propJSON (Proxy :: Proxy CommonMinimumMatch)

1052+ propJSON (Proxy :: Proxy BoostingQuery)

1053+ propJSON (Proxy :: Proxy BoolQuery)

1054+ propJSON (Proxy :: Proxy MatchQuery)

1055+ propJSON (Proxy :: Proxy MultiMatchQueryType)

1056+ propJSON (Proxy :: Proxy BooleanOperator)

1057+ propJSON (Proxy :: Proxy ZeroTermsQuery)

1058+ propJSON (Proxy :: Proxy MatchQueryType)

1059+ propJSON (Proxy :: Proxy AliasRouting)

1060+ propJSON (Proxy :: Proxy IndexAliasCreate)

1061+ propJSON (Proxy :: Proxy SearchAliasRouting)

1062+ propJSON (Proxy :: Proxy ScoreType)

1063+ propJSON (Proxy :: Proxy Distance)

1064+ propJSON (Proxy :: Proxy DistanceUnit)

1065+ propJSON (Proxy :: Proxy DistanceType)

1066+ propJSON (Proxy :: Proxy OptimizeBbox)

1067+ propJSON (Proxy :: Proxy GeoBoundingBoxConstraint)

1068+ propJSON (Proxy :: Proxy GeoFilterType)

1069+ propJSON (Proxy :: Proxy GeoBoundingBox)

1070+ propJSON (Proxy :: Proxy LatLon)

1071+ propJSON (Proxy :: Proxy RangeExecution)

1072+ prop "RegexpFlags FromJSON/ToJSON roundtrips, removing dups " $ \rfs ->

1073+ let expected = case rfs of

1074+ SomeRegexpFlags fs -> SomeRegexpFlags (NE.fromList (nub (NE.toList fs)))

1075+ x -> x

1076+ in parseEither parseJSON (toJSON rfs) === Right expected

1077+ propJSON (Proxy :: Proxy BoolMatch)

1078+ propJSON (Proxy :: Proxy Term)

1079+ propJSON (Proxy :: Proxy MultiMatchQuery)