module Text.Search.Sphinx.Indexable (
  SchemaType (..), Id, 
  SphinxSchema (..), serialize
  )
  where

import Data.Text (unpack)
import qualified Text.Search.Sphinx.Types as T

--import Text.Search.Sphinx.Types
import Text.XML.Light

data SchemaType = TField
                | TAttribute T.AttrT
                | TFieldString

type Id = Int

class SphinxSchema a where
  -- | Convert a value of a to a document with a document id and some attributes and fields.
  toDocument :: a -> (Id, [(String, T.Attr)])
  -- | The first parameter should be ignored, but is used to satisfy Haskell's type system.
  schema   :: a -> [(String, SchemaType)]

serialize :: SphinxSchema a => [a] -> Element
serialize :: forall a. SphinxSchema a => [a] -> Element
serialize [a]
items =
  String -> Element
sphinxEl String
"docset" Element -> [Element] -> Element
<< (
      String -> Element
sphinxEl String
"schema" Element -> [Element] -> Element
<< (((String, SchemaType) -> Element)
-> [(String, SchemaType)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (String, SchemaType) -> Element
schemaField ([(String, SchemaType)] -> [Element])
-> [(String, SchemaType)] -> [Element]
forall a b. (a -> b) -> a -> b
$ a -> [(String, SchemaType)]
forall a. SphinxSchema a => a -> [(String, SchemaType)]
schema ([a] -> a
forall a. HasCallStack => [a] -> a
head ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ [a]
items))
    Element -> [Element] -> [Element]
forall a. a -> [a] -> [a]
: (a -> Element) -> [a] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map ((Id, [(String, Attr)]) -> Element
doc ((Id, [(String, Attr)]) -> Element)
-> (a -> (Id, [(String, Attr)])) -> a -> Element
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> (Id, [(String, Attr)])
forall a. SphinxSchema a => a -> (Id, [(String, Attr)])
toDocument) [a]
items
  )

doc :: (Id, [(String, T.Attr)]) -> Element
doc :: (Id, [(String, Attr)]) -> Element
doc (Id
id, [(String, Attr)]
fields) = String -> Element
sphinxEl String
"document" Element -> [(String, String)] -> Element
! [(String
"id", Id -> String
forall a. Show a => a -> String
show Id
id)] Element -> [Element] -> Element
<<
                     ((String, Attr) -> Element) -> [(String, Attr)] -> [Element]
forall a b. (a -> b) -> [a] -> [b]
map (String, Attr) -> Element
docEl [(String, Attr)]
fields

docEl :: (String, T.Attr) -> Element
docEl :: (String, Attr) -> Element
docEl (String
name, Attr
content) = String -> Element
normalEl String
name Element -> CData -> Element
`text` Attr -> CData
indexableEl Attr
content

indexableEl :: Attr -> CData
indexableEl (T.AttrUInt Id
i)   = String -> CData
simpleText (String -> CData) -> String -> CData
forall a b. (a -> b) -> a -> b
$ Id -> String
forall a. Show a => a -> String
show Id
i
indexableEl (T.AttrString Text
s) = String -> CData
simpleText (String -> CData) -> String -> CData
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
s
indexableEl (T.AttrFloat Float
f)  = String -> CData
simpleText (String -> CData) -> String -> CData
forall a b. (a -> b) -> a -> b
$ Float -> String
forall a. Show a => a -> String
show Float
f
indexableEl Attr
_  = String -> CData
forall a. HasCallStack => String -> a
error String
"not implemented"

simpleText :: String -> CData
simpleText String
s = CData { cdVerbatim :: CDataKind
cdVerbatim = CDataKind
CDataText
                     , cdData :: String
cdData     = String
s
                     , cdLine :: Maybe Line
cdLine     = Maybe Line
forall a. Maybe a
Nothing
                     }

schemaField :: (String, SchemaType) -> Element
schemaField :: (String, SchemaType) -> Element
schemaField (String
name, SchemaType
TField)       = String -> Element
sphinxEl String
"field" Element -> [(String, String)] -> Element
! [(String
"name", String
name)]
schemaField (String
name, TAttribute AttrT
t) = String -> Element
sphinxEl String
"attr" Element -> [(String, String)] -> Element
! [(String
"name", String
name), (String
"type", AttrT -> String
attrType AttrT
t)]
schemaField (String
name, SchemaType
TFieldString) = String -> Element
sphinxEl String
"field_string" Element -> [(String, String)] -> Element
! [(String
"name", String
name), (String
"type", AttrT -> String
attrType AttrT
T.AttrTString)]

attrType :: T.AttrT -> String
attrType :: AttrT -> String
attrType AttrT
T.AttrTString      = String
"string"
attrType AttrT
T.AttrTStr2Ordinal = String
"str2ordinal"
attrType AttrT
T.AttrTUInt        = String
"int"
attrType AttrT
T.AttrTFloat       = String
"float"
attrType AttrT
_       = String -> String
forall a. HasCallStack => String -> a
error String
"not implemented"

text :: Element -> CData -> Element
text :: Element -> CData -> Element
text Element
el CData
dat = Element
el {elContent = [Text dat]}

(<<) :: Element -> [Element] -> Element
Element
a << :: Element -> [Element] -> Element
<< [Element]
b = Element
a {elContent = map Elem b}

(!) :: Element -> [(String, String)] -> Element
Element
el ! :: Element -> [(String, String)] -> Element
! [(String, String)]
attrs = Element
el {elAttribs = [Attr (unqual name) value | (name, value) <- attrs]}

sphinxEl :: String -> Element
sphinxEl :: String -> Element
sphinxEl String
name = Element { elName :: QName
elName    = String -> QName
sphinxNm String
name
                        , elAttribs :: [Attr]
elAttribs = []
                        , elContent :: [Content]
elContent = []
                        , elLine :: Maybe Line
elLine    = Maybe Line
forall a. Maybe a
Nothing
                        }

normalEl :: String -> Element
normalEl :: String -> Element
normalEl String
name = Element { elName :: QName
elName    = String -> QName
unqual String
name
                        , elAttribs :: [Attr]
elAttribs = []
                        , elContent :: [Content]
elContent = []
                        , elLine :: Maybe Line
elLine    = Maybe Line
forall a. Maybe a
Nothing
                        }

sphinxNm :: String -> QName
sphinxNm String
name = QName
blank_name { qPrefix = Just "sphinx"
                           , qURI    = Nothing
                           , qName   = name
                           }