1 files changed, 230 insertions, 0 deletions
diff --git a/contrib/c-bindings/PGFFFI.hs b/contrib/c-bindings/PGFFFI.hs
new file mode 100644
index 000000000..9fccdd20c
--- /dev/null
+++ b/contrib/c-bindings/PGFFFI.hs
@@ -0,0 +1,230 @@
+-- GF C Bindings
+-- Copyright (C) 2008-2009 Kevin Kofler
+--
+-- This library is free software; you can redistribute it and/or
+-- modify it under the terms of the GNU Lesser General Public
+-- License as published by the Free Software Foundation; either
+-- version 2.1 of the License, or (at your option) any later version.
+--
+-- This library is distributed in the hope that it will be useful,
+-- but WITHOUT ANY WARRANTY; without even the implied warranty of
+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+-- Lesser General Public License for more details.
+--
+-- You should have received a copy of the GNU Lesser General Public
+-- License along with this library; if not, see <http://www.gnu.org/licenses/>.
+
+
+module PGFFFI where
+
+import PGF
+import CString
+import Foreign
+import Foreign.C.Types
+import Control.Exception
+import IO
+import Data.Maybe
+import GF.Text.Lexing
+
+
+-- Utility functions used in the implementation (not exported):
+
+-- This is a kind of a hack, the FFI spec doesn't guarantee that this will work.
+-- The alternative would be to use Ptr () instead of StablePtr a everywhere.
+nullStablePtr :: StablePtr a
+nullStablePtr = (castPtrToStablePtr nullPtr)
+
+sizeOfStablePtr :: Int
+sizeOfStablePtr = (sizeOf (nullStablePtr))
+
+storeList :: [a] -> Ptr (StablePtr a) -> IO ()
+storeList list buf = do
+  case list of
+    carlist:cdrlist -> do
+      sptr <- (newStablePtr carlist)
+      (poke buf sptr)
+      (storeList cdrlist (plusPtr buf sizeOfStablePtr))
+    [] -> (poke buf nullStablePtr)
+
+listToArray :: [a] -> IO (Ptr (StablePtr a))
+listToArray list = do
+    buf <- (mallocBytes ((sizeOfStablePtr) * ((length list) + 1)))
+    (storeList list buf)
+    return buf
+
+
+-- PGF:
+
+foreign export ccall "gf_freePGF" freeStablePtr :: StablePtr PGF -> IO ()
+
+foreign export ccall gf_readPGF :: CString -> IO (StablePtr PGF)
+gf_readPGF path = do
+  p <- (peekCString path)
+  result <- (readPGF p)
+  (newStablePtr result)
+
+foreign export ccall "gf_freeLanguage" freeStablePtr :: StablePtr Language -> IO ()
+
+foreign export ccall gf_showLanguage :: StablePtr Language -> IO CString
+gf_showLanguage lang = do
+  l <- (deRefStablePtr lang)
+  (newCString (showLanguage l))
+
+foreign export ccall gf_readLanguage :: CString -> IO (StablePtr Language)
+gf_readLanguage str = do
+  s <- (peekCString str)
+  case (readLanguage s) of
+    Just x -> (newStablePtr x)
+    Nothing -> (return (nullStablePtr))
+
+foreign export ccall gf_languages :: StablePtr PGF -> IO (Ptr (StablePtr Language))
+gf_languages pgf = do
+  p <- (deRefStablePtr pgf)
+  (listToArray (languages p))
+
+foreign export ccall gf_abstractName :: StablePtr PGF -> IO (StablePtr Language)
+gf_abstractName pgf = do
+  p <- (deRefStablePtr pgf)
+  (newStablePtr (abstractName p))
+
+foreign export ccall gf_languageCode :: StablePtr PGF -> StablePtr Language -> IO CString
+gf_languageCode pgf lang = do
+  p <- (deRefStablePtr pgf)
+  l <- (deRefStablePtr lang)
+  case (languageCode p l) of
+    Just s -> (newCString s)
+    Nothing -> (return nullPtr)
+
+foreign export ccall "gf_freeType" freeStablePtr :: StablePtr Type -> IO ()
+
+foreign export ccall gf_showType :: StablePtr Type -> IO CString
+gf_showType tp = do
+  t <- (deRefStablePtr tp)
+  (newCString (showType t))
+
+foreign export ccall gf_readType :: CString -> IO (StablePtr Type)
+gf_readType str = do
+  s <- (peekCString str)
+  case (readType s) of
+    Just x -> (newStablePtr x)
+    Nothing -> (return (nullStablePtr))
+
+foreign export ccall gf_categories :: StablePtr PGF -> IO (Ptr (StablePtr Type))
+gf_categories pgf = do
+  p <- (deRefStablePtr pgf)
+  (listToArray (categories p))
+
+foreign export ccall gf_startCat :: StablePtr PGF -> IO (StablePtr Type)
+gf_startCat pgf = do
+  p <- (deRefStablePtr pgf)
+  (newStablePtr (startCat p))
+
+foreign export ccall "gf_freeCId" freeStablePtr :: StablePtr CId -> IO ()
+
+foreign export ccall gf_mkCId :: CString -> IO (StablePtr CId)
+gf_mkCId str = do
+  s <- (peekCString str)
+  (newStablePtr (mkCId s))
+
+foreign export ccall gf_prCId :: StablePtr CId -> IO CString
+gf_prCId cid = do
+  c <- (deRefStablePtr cid)
+  (newCString (prCId c))
+
+foreign export ccall gf_wildCId :: IO (StablePtr CId)
+gf_wildCId = do
+  (newStablePtr (wildCId))
+
+-- TODO: So we can create, print and free a CId, but can we do anything useful with it?
+--       We need some kind of C wrapper for the tree datastructures.
+
+foreign export ccall "gf_freeTree" freeStablePtr :: StablePtr Tree -> IO ()
+
+-- TODO: Literal(..)
+-- (Not much use exporting a free function for that type if you can't do anything with it.)
+
+foreign export ccall gf_showTree :: StablePtr Tree -> IO CString
+gf_showTree tree = do
+  t <- (deRefStablePtr tree)
+  (newCString (showTree t))
+
+foreign export ccall gf_readTree :: CString -> IO (StablePtr Tree)
+gf_readTree str = do
+  s <- (peekCString str)
+  case (readTree s) of
+    Just x -> (newStablePtr x)
+    Nothing -> (return (nullStablePtr))
+
+foreign export ccall "gf_freeExpr" freeStablePtr :: StablePtr Expr -> IO ()
+
+-- TODO: Equation(..)
+-- (Not much use exporting a free function for that type if you can't do anything with it.)
+
+foreign export ccall gf_showExpr :: StablePtr Expr -> IO CString
+gf_showExpr expr = do
+  e <- (deRefStablePtr expr)
+  (newCString (showExpr e))
+
+foreign export ccall gf_readExpr :: CString -> IO (StablePtr Expr)
+gf_readExpr str = do
+  s <- (peekCString str)
+  case (readExpr s) of
+    Just x -> (newStablePtr x)
+    Nothing -> (return (nullStablePtr))
+
+foreign export ccall gf_linearize :: StablePtr PGF -> StablePtr Language -> StablePtr Tree -> IO CString
+gf_linearize pgf lang tree = do
+  p <- (deRefStablePtr pgf)
+  l <- (deRefStablePtr lang)
+  t <- (deRefStablePtr tree)
+  (newCString (linearize p l t))
+
+-- TODO: linearizeAllLang, linearizeAll
+
+foreign export ccall gf_showPrintName :: StablePtr PGF -> StablePtr Language -> StablePtr Type -> IO CString
+gf_showPrintName pgf lang tp = do
+  p <- (deRefStablePtr pgf)
+  l <- (deRefStablePtr lang)
+  t <- (deRefStablePtr tp)
+  (newCString (showPrintName p l t))
+
+foreign export ccall gf_parse :: StablePtr PGF -> StablePtr Language -> StablePtr Type -> CString -> IO (Ptr (StablePtr Tree))
+gf_parse pgf lang cat input = do
+  p <- (deRefStablePtr pgf)
+  l <- (deRefStablePtr lang)
+  c <- (deRefStablePtr cat)
+  i <- (peekCString input)
+  (listToArray (parse p l c i))
+
+foreign export ccall gf_canParse :: StablePtr PGF -> StablePtr Language -> IO CInt
+gf_canParse pgf lang = do
+  p <- (deRefStablePtr pgf)
+  l <- (deRefStablePtr lang)
+  case (canParse p l) of
+    True -> (return 1)
+    False -> (return 0)
+
+-- TODO: parseAllLang, parseAll
+
+-- TODO: tree2expr, expr2tree, PGF.compute, paraphrase, typecheck
+
+-- TODO: complete, Incremental.ParseState, initState, Incremental.nextState, Incremental.getCompletions, extractExps
+
+-- TODO: generateRandom, generateAll, generateAllDepth
+
+
+-- GF.Text.Lexing:
+
+foreign export ccall gf_stringOp :: CString -> CString -> IO CString
+gf_stringOp op str = do
+  o <- (peekCString op)
+  s <- (peekCString str)
+  case (stringOp o) of
+    Just fn -> (newCString (fn s))
+    Nothing -> (return nullPtr)
+
+
+-- Unused (exception handling):
+--  (Control.Exception.catch (listToArray (parse p l c i)) (\(e::SomeException) -> do
+--  (hPutStr stderr ("error: " ++ show e))
+--  (return nullPtr)))