mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-05-09 11:12:51 -06:00
104 lines
3.0 KiB
Haskell
104 lines
3.0 KiB
Haskell
{-# LANGUAGE ForeignFunctionInterface, MagicHash, BangPatterns #-}
|
|
|
|
module PGF2.FFI where
|
|
|
|
import Data.Word
|
|
import Foreign
|
|
import Foreign.C
|
|
import Foreign.Ptr
|
|
import Foreign.ForeignPtr
|
|
import qualified Data.Map as Map
|
|
|
|
#include <pgf.h>
|
|
|
|
-- | An abstract data type representing multilingual grammar
|
|
-- in Portable Grammar Format.
|
|
data PGF = PGF {a_pgf :: ForeignPtr PgfPGF, langs :: Map.Map String Concr}
|
|
data Concr = Concr {c_pgf :: ForeignPtr PgfPGF, concr :: Ptr PgfConcr}
|
|
|
|
------------------------------------------------------------------
|
|
-- libpgf API
|
|
|
|
data PgfExn
|
|
data PgfText
|
|
data PgfItor
|
|
data PgfPGF
|
|
data PgfConcr
|
|
|
|
foreign import ccall unsafe "pgf_utf8_decode"
|
|
pgf_utf8_decode :: Ptr CString -> IO Word32
|
|
|
|
foreign import ccall unsafe "pgf_utf8_encode"
|
|
pgf_utf8_encode :: Word32 -> Ptr CString -> IO ()
|
|
|
|
foreign import ccall "pgf_read"
|
|
pgf_read :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
|
|
|
|
foreign import ccall "&pgf_free"
|
|
pgf_free_fptr :: FinalizerPtr PgfPGF
|
|
|
|
foreign import ccall "pgf_abstract_name"
|
|
pgf_abstract_name :: Ptr PgfPGF -> IO (Ptr PgfText)
|
|
|
|
type ItorCallback = Ptr PgfItor -> Ptr PgfText -> IO ()
|
|
|
|
foreign import ccall "wrapper"
|
|
wrapItorCallback :: ItorCallback -> IO (FunPtr ItorCallback)
|
|
|
|
foreign import ccall "pgf_iter_categories"
|
|
pgf_iter_categories :: Ptr PgfPGF -> Ptr PgfItor -> IO ()
|
|
|
|
foreign import ccall "pgf_iter_functions"
|
|
pgf_iter_functions :: Ptr PgfPGF -> Ptr PgfItor -> IO ()
|
|
|
|
foreign import ccall "pgf_iter_functions_by_cat"
|
|
pgf_iter_functions_by_cat :: Ptr PgfPGF -> Ptr PgfText -> Ptr PgfItor -> IO ()
|
|
|
|
peekText :: Ptr PgfText -> IO String
|
|
peekText ptr =
|
|
alloca $ \pptr -> do
|
|
size <- ((#peek PgfText, size) ptr) :: IO CSize
|
|
let c_text = castPtr ptr `plusPtr` (#offset PgfText, text)
|
|
poke pptr c_text
|
|
decode pptr (c_text `plusPtr` fromIntegral size)
|
|
where
|
|
decode pptr end = do
|
|
ptr <- peek pptr
|
|
if ptr >= end
|
|
then return []
|
|
else do x <- pgf_utf8_decode pptr
|
|
cs <- decode pptr end
|
|
return (((toEnum . fromEnum) x) : cs)
|
|
|
|
withText :: String -> (Ptr PgfText -> IO a) -> IO a
|
|
withText s fn =
|
|
allocaBytes ((#size PgfText) + size + 1) $ \ptr -> do
|
|
(#poke PgfText, size) ptr (fromIntegral size :: CSize)
|
|
pokeUtf8CString s (ptr `plusPtr` (#const offsetof(PgfText, text)))
|
|
fn ptr
|
|
where
|
|
size = utf8Length s
|
|
|
|
pokeUtf8CString s ptr =
|
|
alloca $ \pptr ->
|
|
poke pptr ptr >> encode s pptr
|
|
where
|
|
encode [] pptr = do
|
|
pgf_utf8_encode 0 pptr
|
|
encode (c:cs) pptr = do
|
|
pgf_utf8_encode ((toEnum . fromEnum) c) pptr
|
|
encode cs pptr
|
|
|
|
utf8Length s = count 0 s
|
|
where
|
|
count !c [] = c
|
|
count !c (x:xs)
|
|
| ucs < 0x80 = count (c+1) xs
|
|
| ucs < 0x800 = count (c+2) xs
|
|
| ucs < 0x10000 = count (c+3) xs
|
|
| ucs < 0x200000 = count (c+4) xs
|
|
| ucs < 0x4000000 = count (c+5) xs
|
|
| otherwise = count (c+6) xs
|
|
where
|
|
ucs = fromEnum x
|