XSLT.hs

module Text.XML.XSLT
    ( Stylesheet
    , parseFile
    , parseFile_
    , applyStylesheet
    , saveResultToString
    , saveResultToString_
    , cleanupGlobals
    , freeStylesheet
    ) where

import Foreign.C
import Foreign
import Control.Monad

import qualified Data.ByteString as BS
import qualified Data.ByteString.Base as BS
import Data.ByteString (ByteString)

import qualified Text.XML.LibXML as XML
import qualified Text.XML.LibXML.Internals as XML
import Text.XML.LibXML (Document)

newtype Stylesheet = Stylesheet (ForeignPtr Stylesheet)

freeStylesheet :: Stylesheet -> IO ()
freeStylesheet (Stylesheet ptr) =
#if defined(__GLASGOW_HASKELL__)
  finalizeForeignPtr ptr
#else
  return ()
#endif


-- xsltStylesheetPtr xsltParseStylesheetFile(const xmlChar * filename)
foreign import ccall unsafe xsltParseStylesheetFile :: CString -> IO (Ptr Stylesheet)

parseFile :: FilePath -> IO Stylesheet
parseFile path
    = do mbSheet <- parseFile_ path
         case mbSheet of
           Nothing -> error $ "Text.XML.XSLT.parseFile: failed to parse input from: " ++ path
           Just sheet -> return sheet

parseFile_ :: FilePath -> IO (Maybe Stylesheet)
parseFile_ path
    = do ptr <- xsltParseStylesheetFile =<< newCString path
         if ptr == nullPtr
            then return Nothing
            else liftM Just $ mkFinalizedStylesheet ptr

-- xmlDocPtr xsltApplyStylesheet(xsltStylesheetPtr style, xmlDocPtr doc, const char ** params)
foreign import ccall unsafe xsltApplyStylesheet :: Ptr Stylesheet -> Ptr Document -> Ptr CString -> IO (Ptr Document)

-- FIXME: don't ignore the params
applyStylesheet :: Stylesheet -> Maybe Document -> [(ByteString,ByteString)] -> IO Document
applyStylesheet (Stylesheet stylesheet) mbDocument _params
    = withForeignPtr stylesheet $ \sheetptr ->
      withMbDoc mbDocument $ \docPtr ->
      do ptr <- xsltApplyStylesheet sheetptr docPtr nullPtr
         XML.mkFinalizedDocument ptr
    where withMbDoc Nothing x = x nullPtr
          withMbDoc (Just doc) x = XML.withDocument doc x

--int xsltSaveResultToString(xmlChar ** doc_txt_ptr, 
--                           int * doc_txt_len, 
--                            xmlDocPtr result, 
--                                       xsltStylesheetPtr style)
foreign import ccall unsafe xsltSaveResultToString
    :: Ptr CString -> Ptr CInt -> Ptr Document -> Ptr Stylesheet -> IO CInt

saveResultToString :: Document -> Stylesheet -> IO ByteString
saveResultToString doc stylesheet
    = do mbStr <- saveResultToString_ doc stylesheet
         case mbStr of
           Nothing -> error "Text.XML.XSLT.saveResultToString: failed to save result"
           Just str -> return str

saveResultToString_ :: Document -> Stylesheet -> IO (Maybe ByteString)
saveResultToString_ doc (Stylesheet sheet)
    = withForeignPtr sheet $ \sheetPtr ->
      XML.withDocument doc $ \docPtr ->
      alloca $ \strPtr ->
      alloca $ \lenPtr ->
      do ret <- xsltSaveResultToString strPtr lenPtr docPtr sheetPtr
         case ret of
           (-1) -> return Nothing
           _    -> do cstr <- peek strPtr
                      len  <- peek lenPtr
                      fp <- newForeignPtr finalizerFree (castPtr cstr)
                      return $! Just $! BS.PS fp 0 (fromIntegral len)

foreign import ccall unsafe "xsltCleanupGlobals" cleanupGlobals :: IO ()

foreign import ccall unsafe "&xsltFreeStylesheet" xsltFreeStylesheet :: FunPtr (Ptr Stylesheet -> IO ())

mkFinalizedStylesheet :: Ptr Stylesheet -> IO Stylesheet
mkFinalizedStylesheet = liftM Stylesheet . newForeignPtr xsltFreeStylesheet