module Text.Search.Sphinx.Indexable (
SchemaType (..), Id,
SphinxSchema (..), serialize
)
where
import Data.ByteString.Lazy.UTF8 (toString)
import qualified Text.Search.Sphinx.Types as T
import Text.XML.Light
data SchemaType = TField
| TAttribute T.AttrT
| TFieldString
type Id = Int
class SphinxSchema a where
toDocument :: a -> (Id, [(String, T.Attr)])
schema :: a -> [(String, SchemaType)]
serialize :: SphinxSchema a => [a] -> Element
serialize items =
sphinxEl "docset" << (
sphinxEl "schema" << (map schemaField $ schema (head $ items))
: map (doc . toDocument) items
)
doc :: (Id, [(String, T.Attr)]) -> Element
doc (id, fields) = sphinxEl "document" ! [("id", show id)] <<
map docEl fields
docEl :: (String, T.Attr) -> Element
docEl (name, content) = normalEl name `text` indexableEl content
indexableEl (T.AttrUInt i) = simpleText $ show i
indexableEl (T.AttrString s) = simpleText $ toString s
indexableEl (T.AttrFloat f) = simpleText $ show f
indexableEl _ = error "not implemented"
simpleText s = CData { cdVerbatim = CDataText
, cdData = s
, cdLine = Nothing
}
schemaField :: (String, SchemaType) -> Element
schemaField (name, TField) = sphinxEl "field" ! [("name", name)]
schemaField (name, TAttribute t) = sphinxEl "attr" ! [("name", name), ("type", attrType t)]
schemaField (name, TFieldString) = sphinxEl "field_string" ! [("name", name), ("type", attrType T.AttrTString)]
attrType :: T.AttrT -> String
attrType T.AttrTString = "string"
attrType T.AttrTStr2Ordinal = "str2ordinal"
attrType T.AttrTUInt = "int"
attrType T.AttrTFloat = "float"
attrType _ = error "not implemented"
text :: Element -> CData -> Element
text el dat = el {elContent = [Text dat]}
(<<) :: Element -> [Element] -> Element
a << b = a {elContent = map Elem b}
(!) :: Element -> [(String, String)] -> Element
el ! attrs = el {elAttribs = [Attr (unqual name) value | (name, value) <- attrs]}
sphinxEl :: String -> Element
sphinxEl name = Element { elName = sphinxNm name
, elAttribs = []
, elContent = []
, elLine = Nothing
}
normalEl :: String -> Element
normalEl name = Element { elName = unqual name
, elAttribs = []
, elContent = []
, elLine = Nothing
}
sphinxNm name = blank_name { qPrefix = Just "sphinx"
, qURI = Nothing
, qName = name
}