{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}

module Database.Bloodhound.Internal.Highlight where

import Bloodhound.Import
import qualified Data.Map.Strict as M
import Database.Bloodhound.Internal.Newtypes
import Database.Bloodhound.Internal.Query

type HitHighlight = M.Map Text [Text]

data Highlights = Highlights
  { Highlights -> Maybe HighlightSettings
globalsettings :: Maybe HighlightSettings,
    Highlights -> [FieldHighlight]
highlightFields :: [FieldHighlight]
  }
  deriving (Highlights -> Highlights -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Highlights -> Highlights -> Bool
$c/= :: Highlights -> Highlights -> Bool
== :: Highlights -> Highlights -> Bool
$c== :: Highlights -> Highlights -> Bool
Eq, Int -> Highlights -> ShowS
[Highlights] -> ShowS
Highlights -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Highlights] -> ShowS
$cshowList :: [Highlights] -> ShowS
show :: Highlights -> String
$cshow :: Highlights -> String
showsPrec :: Int -> Highlights -> ShowS
$cshowsPrec :: Int -> Highlights -> ShowS
Show)

instance ToJSON Highlights where
  toJSON :: Highlights -> Value
toJSON (Highlights Maybe HighlightSettings
global [FieldHighlight]
fields) =
    [Pair] -> Value
omitNulls
      ( (Key
"fields" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [FieldHighlight]
fields)
          forall a. a -> [a] -> [a]
: Maybe HighlightSettings -> [Pair]
highlightSettingsPairs Maybe HighlightSettings
global
      )

data FieldHighlight
  = FieldHighlight FieldName (Maybe HighlightSettings)
  deriving (FieldHighlight -> FieldHighlight -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FieldHighlight -> FieldHighlight -> Bool
$c/= :: FieldHighlight -> FieldHighlight -> Bool
== :: FieldHighlight -> FieldHighlight -> Bool
$c== :: FieldHighlight -> FieldHighlight -> Bool
Eq, Int -> FieldHighlight -> ShowS
[FieldHighlight] -> ShowS
FieldHighlight -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FieldHighlight] -> ShowS
$cshowList :: [FieldHighlight] -> ShowS
show :: FieldHighlight -> String
$cshow :: FieldHighlight -> String
showsPrec :: Int -> FieldHighlight -> ShowS
$cshowsPrec :: Int -> FieldHighlight -> ShowS
Show)

instance ToJSON FieldHighlight where
  toJSON :: FieldHighlight -> Value
toJSON (FieldHighlight (FieldName Text
fName) (Just HighlightSettings
fSettings)) =
    [Pair] -> Value
object [Text -> Key
fromText Text
fName forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= HighlightSettings
fSettings]
  toJSON (FieldHighlight (FieldName Text
fName) Maybe HighlightSettings
Nothing) =
    [Pair] -> Value
object [Text -> Key
fromText Text
fName forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
emptyObject]

data HighlightSettings
  = Plain PlainHighlight
  | Postings PostingsHighlight
  | FastVector FastVectorHighlight
  deriving (HighlightSettings -> HighlightSettings -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HighlightSettings -> HighlightSettings -> Bool
$c/= :: HighlightSettings -> HighlightSettings -> Bool
== :: HighlightSettings -> HighlightSettings -> Bool
$c== :: HighlightSettings -> HighlightSettings -> Bool
Eq, Int -> HighlightSettings -> ShowS
[HighlightSettings] -> ShowS
HighlightSettings -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HighlightSettings] -> ShowS
$cshowList :: [HighlightSettings] -> ShowS
show :: HighlightSettings -> String
$cshow :: HighlightSettings -> String
showsPrec :: Int -> HighlightSettings -> ShowS
$cshowsPrec :: Int -> HighlightSettings -> ShowS
Show)

instance ToJSON HighlightSettings where
  toJSON :: HighlightSettings -> Value
toJSON HighlightSettings
hs = [Pair] -> Value
omitNulls (Maybe HighlightSettings -> [Pair]
highlightSettingsPairs (forall a. a -> Maybe a
Just HighlightSettings
hs))

data PlainHighlight = PlainHighlight
  { PlainHighlight -> Maybe CommonHighlight
plainCommon :: Maybe CommonHighlight,
    PlainHighlight -> Maybe NonPostings
plainNonPost :: Maybe NonPostings
  }
  deriving (PlainHighlight -> PlainHighlight -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PlainHighlight -> PlainHighlight -> Bool
$c/= :: PlainHighlight -> PlainHighlight -> Bool
== :: PlainHighlight -> PlainHighlight -> Bool
$c== :: PlainHighlight -> PlainHighlight -> Bool
Eq, Int -> PlainHighlight -> ShowS
[PlainHighlight] -> ShowS
PlainHighlight -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PlainHighlight] -> ShowS
$cshowList :: [PlainHighlight] -> ShowS
show :: PlainHighlight -> String
$cshow :: PlainHighlight -> String
showsPrec :: Int -> PlainHighlight -> ShowS
$cshowsPrec :: Int -> PlainHighlight -> ShowS
Show)

-- This requires that index_options are set to 'offset' in the mapping.
data PostingsHighlight
  = PostingsHighlight (Maybe CommonHighlight)
  deriving (PostingsHighlight -> PostingsHighlight -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PostingsHighlight -> PostingsHighlight -> Bool
$c/= :: PostingsHighlight -> PostingsHighlight -> Bool
== :: PostingsHighlight -> PostingsHighlight -> Bool
$c== :: PostingsHighlight -> PostingsHighlight -> Bool
Eq, Int -> PostingsHighlight -> ShowS
[PostingsHighlight] -> ShowS
PostingsHighlight -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PostingsHighlight] -> ShowS
$cshowList :: [PostingsHighlight] -> ShowS
show :: PostingsHighlight -> String
$cshow :: PostingsHighlight -> String
showsPrec :: Int -> PostingsHighlight -> ShowS
$cshowsPrec :: Int -> PostingsHighlight -> ShowS
Show)

-- This requires that term_vector is set to 'with_positions_offsets' in the mapping.
data FastVectorHighlight = FastVectorHighlight
  { FastVectorHighlight -> Maybe CommonHighlight
fvCommon :: Maybe CommonHighlight,
    FastVectorHighlight -> Maybe NonPostings
fvNonPostSettings :: Maybe NonPostings,
    FastVectorHighlight -> Maybe Text
boundaryChars :: Maybe Text,
    FastVectorHighlight -> Maybe Int
boundaryMaxScan :: Maybe Int,
    FastVectorHighlight -> Maybe Int
fragmentOffset :: Maybe Int,
    FastVectorHighlight -> [Text]
matchedFields :: [Text],
    FastVectorHighlight -> Maybe Int
phraseLimit :: Maybe Int
  }
  deriving (FastVectorHighlight -> FastVectorHighlight -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FastVectorHighlight -> FastVectorHighlight -> Bool
$c/= :: FastVectorHighlight -> FastVectorHighlight -> Bool
== :: FastVectorHighlight -> FastVectorHighlight -> Bool
$c== :: FastVectorHighlight -> FastVectorHighlight -> Bool
Eq, Int -> FastVectorHighlight -> ShowS
[FastVectorHighlight] -> ShowS
FastVectorHighlight -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FastVectorHighlight] -> ShowS
$cshowList :: [FastVectorHighlight] -> ShowS
show :: FastVectorHighlight -> String
$cshow :: FastVectorHighlight -> String
showsPrec :: Int -> FastVectorHighlight -> ShowS
$cshowsPrec :: Int -> FastVectorHighlight -> ShowS
Show)

data CommonHighlight = CommonHighlight
  { CommonHighlight -> Maybe Text
order :: Maybe Text,
    CommonHighlight -> Maybe Bool
forceSource :: Maybe Bool,
    CommonHighlight -> Maybe HighlightTag
tag :: Maybe HighlightTag,
    CommonHighlight -> Maybe HighlightEncoder
encoder :: Maybe HighlightEncoder,
    CommonHighlight -> Maybe Int
noMatchSize :: Maybe Int,
    CommonHighlight -> Maybe Query
highlightQuery :: Maybe Query,
    CommonHighlight -> Maybe Bool
requireFieldMatch :: Maybe Bool
  }
  deriving (CommonHighlight -> CommonHighlight -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CommonHighlight -> CommonHighlight -> Bool
$c/= :: CommonHighlight -> CommonHighlight -> Bool
== :: CommonHighlight -> CommonHighlight -> Bool
$c== :: CommonHighlight -> CommonHighlight -> Bool
Eq, Int -> CommonHighlight -> ShowS
[CommonHighlight] -> ShowS
CommonHighlight -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CommonHighlight] -> ShowS
$cshowList :: [CommonHighlight] -> ShowS
show :: CommonHighlight -> String
$cshow :: CommonHighlight -> String
showsPrec :: Int -> CommonHighlight -> ShowS
$cshowsPrec :: Int -> CommonHighlight -> ShowS
Show)

-- Settings that are only applicable to FastVector and Plain highlighters.
data NonPostings = NonPostings
  { NonPostings -> Maybe Int
fragmentSize :: Maybe Int,
    NonPostings -> Maybe Int
numberOfFragments :: Maybe Int
  }
  deriving (NonPostings -> NonPostings -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NonPostings -> NonPostings -> Bool
$c/= :: NonPostings -> NonPostings -> Bool
== :: NonPostings -> NonPostings -> Bool
$c== :: NonPostings -> NonPostings -> Bool
Eq, Int -> NonPostings -> ShowS
[NonPostings] -> ShowS
NonPostings -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NonPostings] -> ShowS
$cshowList :: [NonPostings] -> ShowS
show :: NonPostings -> String
$cshow :: NonPostings -> String
showsPrec :: Int -> NonPostings -> ShowS
$cshowsPrec :: Int -> NonPostings -> ShowS
Show)

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

instance ToJSON HighlightEncoder where
  toJSON :: HighlightEncoder -> Value
toJSON HighlightEncoder
DefaultEncoder = Text -> Value
String Text
"default"
  toJSON HighlightEncoder
HTMLEncoder = Text -> Value
String Text
"html"

-- NOTE: Should the tags use some kind of HTML type, rather than Text?
data HighlightTag
  = TagSchema Text
  | -- Only uses more than the first value in the lists if fvh
    CustomTags ([Text], [Text])
  deriving (HighlightTag -> HighlightTag -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HighlightTag -> HighlightTag -> Bool
$c/= :: HighlightTag -> HighlightTag -> Bool
== :: HighlightTag -> HighlightTag -> Bool
$c== :: HighlightTag -> HighlightTag -> Bool
Eq, Int -> HighlightTag -> ShowS
[HighlightTag] -> ShowS
HighlightTag -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HighlightTag] -> ShowS
$cshowList :: [HighlightTag] -> ShowS
show :: HighlightTag -> String
$cshow :: HighlightTag -> String
showsPrec :: Int -> HighlightTag -> ShowS
$cshowsPrec :: Int -> HighlightTag -> ShowS
Show)

highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
highlightSettingsPairs :: Maybe HighlightSettings -> [Pair]
highlightSettingsPairs Maybe HighlightSettings
Nothing = []
highlightSettingsPairs (Just (Plain PlainHighlight
plh)) = Maybe PlainHighlight -> [Pair]
plainHighPairs (forall a. a -> Maybe a
Just PlainHighlight
plh)
highlightSettingsPairs (Just (Postings PostingsHighlight
ph)) = Maybe PostingsHighlight -> [Pair]
postHighPairs (forall a. a -> Maybe a
Just PostingsHighlight
ph)
highlightSettingsPairs (Just (FastVector FastVectorHighlight
fvh)) = Maybe FastVectorHighlight -> [Pair]
fastVectorHighPairs (forall a. a -> Maybe a
Just FastVectorHighlight
fvh)

plainHighPairs :: Maybe PlainHighlight -> [Pair]
plainHighPairs :: Maybe PlainHighlight -> [Pair]
plainHighPairs Maybe PlainHighlight
Nothing = []
plainHighPairs (Just (PlainHighlight Maybe CommonHighlight
plCom Maybe NonPostings
plNonPost)) =
  [Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"plain"]
    forall a. [a] -> [a] -> [a]
++ Maybe CommonHighlight -> [Pair]
commonHighlightPairs Maybe CommonHighlight
plCom
    forall a. [a] -> [a] -> [a]
++ Maybe NonPostings -> [Pair]
nonPostingsToPairs Maybe NonPostings
plNonPost

postHighPairs :: Maybe PostingsHighlight -> [Pair]
postHighPairs :: Maybe PostingsHighlight -> [Pair]
postHighPairs Maybe PostingsHighlight
Nothing = []
postHighPairs (Just (PostingsHighlight Maybe CommonHighlight
pCom)) =
  (Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"postings")
    forall a. a -> [a] -> [a]
: Maybe CommonHighlight -> [Pair]
commonHighlightPairs Maybe CommonHighlight
pCom

fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
fastVectorHighPairs :: Maybe FastVectorHighlight -> [Pair]
fastVectorHighPairs Maybe FastVectorHighlight
Nothing = []
fastVectorHighPairs
  ( Just
      ( FastVectorHighlight
          Maybe CommonHighlight
fvCom
          Maybe NonPostings
fvNonPostSettings'
          Maybe Text
fvBoundChars
          Maybe Int
fvBoundMaxScan
          Maybe Int
fvFragOff
          [Text]
fvMatchedFields
          Maybe Int
fvPhraseLim
        )
    ) =
    [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"fvh",
      Key
"boundary_chars" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
fvBoundChars,
      Key
"boundary_max_scan" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Int
fvBoundMaxScan,
      Key
"fragment_offset" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Int
fvFragOff,
      Key
"matched_fields" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Text]
fvMatchedFields,
      Key
"phraseLimit" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Int
fvPhraseLim
    ]
      forall a. [a] -> [a] -> [a]
++ Maybe CommonHighlight -> [Pair]
commonHighlightPairs Maybe CommonHighlight
fvCom
      forall a. [a] -> [a] -> [a]
++ Maybe NonPostings -> [Pair]
nonPostingsToPairs Maybe NonPostings
fvNonPostSettings'

commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
commonHighlightPairs :: Maybe CommonHighlight -> [Pair]
commonHighlightPairs Maybe CommonHighlight
Nothing = []
commonHighlightPairs
  ( Just
      ( CommonHighlight
          Maybe Text
chScore
          Maybe Bool
chForceSource
          Maybe HighlightTag
chTag
          Maybe HighlightEncoder
chEncoder
          Maybe Int
chNoMatchSize
          Maybe Query
chHighlightQuery
          Maybe Bool
chRequireFieldMatch
        )
    ) =
    [ Key
"order" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Text
chScore,
      Key
"force_source" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Bool
chForceSource,
      Key
"encoder" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe HighlightEncoder
chEncoder,
      Key
"no_match_size" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Int
chNoMatchSize,
      Key
"highlight_query" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Query
chHighlightQuery,
      Key
"require_fieldMatch" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Bool
chRequireFieldMatch
    ]
      forall a. [a] -> [a] -> [a]
++ Maybe HighlightTag -> [Pair]
highlightTagToPairs Maybe HighlightTag
chTag

nonPostingsToPairs :: Maybe NonPostings -> [Pair]
nonPostingsToPairs :: Maybe NonPostings -> [Pair]
nonPostingsToPairs Maybe NonPostings
Nothing = []
nonPostingsToPairs (Just (NonPostings Maybe Int
npFragSize Maybe Int
npNumOfFrags)) =
  [ Key
"fragment_size" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Int
npFragSize,
    Key
"number_of_fragments" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Maybe Int
npNumOfFrags
  ]

highlightTagToPairs :: Maybe HighlightTag -> [Pair]
highlightTagToPairs :: Maybe HighlightTag -> [Pair]
highlightTagToPairs (Just (TagSchema Text
_)) =
  [ Key
"scheme" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text -> Value
String Text
"default"
  ]
highlightTagToPairs (Just (CustomTags ([Text]
pre, [Text]
post))) =
  [ Key
"pre_tags" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Text]
pre,
    Key
"post_tags" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Text]
post
  ]
highlightTagToPairs Maybe HighlightTag
Nothing = []