diff --git a/src/runtime/haskell-bind/CId.hs b/src/runtime/haskell-bind/CId.hs deleted file mode 100644 index 74db63c2c..000000000 --- a/src/runtime/haskell-bind/CId.hs +++ /dev/null @@ -1,56 +0,0 @@ -module CId (CId(..), - mkCId, wildCId, - readCId, showCId, - - -- utils - pCId, pIdent, ppCId) where - -import Control.Monad -import qualified Data.ByteString.Char8 as BS -import Data.Char -import qualified Text.ParserCombinators.ReadP as RP -import qualified Text.PrettyPrint as PP - - - --- | An abstract data type that represents --- identifiers for functions and categories in PGF. -newtype CId = CId BS.ByteString deriving (Eq,Ord) - -wildCId :: CId -wildCId = CId (BS.singleton '_') - --- | Creates a new identifier from 'String' -mkCId :: String -> CId -mkCId s = CId (BS.pack s) - --- | Reads an identifier from 'String'. The function returns 'Nothing' if the string is not valid identifier. -readCId :: String -> Maybe CId -readCId s = case [x | (x,cs) <- RP.readP_to_S pCId s, all isSpace cs] of - [x] -> Just x - _ -> Nothing - --- | Renders the identifier as 'String' -showCId :: CId -> String -showCId (CId x) = BS.unpack x - -instance Show CId where - showsPrec _ = showString . showCId - -instance Read CId where - readsPrec _ = RP.readP_to_S pCId - -pCId :: RP.ReadP CId -pCId = do s <- pIdent - if s == "_" - then RP.pfail - else return (mkCId s) - -pIdent :: RP.ReadP String -pIdent = liftM2 (:) (RP.satisfy isIdentFirst) (RP.munch isIdentRest) - where - isIdentFirst c = c == '_' || isLetter c - isIdentRest c = c == '_' || c == '\'' || isAlphaNum c - -ppCId :: CId -> PP.Doc -ppCId = PP.text . showCId diff --git a/src/runtime/haskell-bind/CRuntimeFFI.hsc b/src/runtime/haskell-bind/CRuntimeFFI.hsc deleted file mode 100644 index 6564ac70e..000000000 --- a/src/runtime/haskell-bind/CRuntimeFFI.hsc +++ /dev/null @@ -1,310 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, ExistentialQuantification, TypeSynonymInstances, FlexibleInstances #-} -#include -#include -#include - -module CRuntimeFFI(-- * PGF - PGF,readPGF,abstractName,startCat, - -- * Concrete syntax - Concr,Language,languages,getConcr,parse,linearize, - -- * Trees - Expr,Tree,readExpr,showExpr,unApp, - -- * Morphology - MorphoAnalysis,lookupMorpho,fullFormLexicon, - printLexEntry, - ) where - -import Prelude hiding (fromEnum) -import Control.Exception -import System.IO -import System.IO.Unsafe -import CId (CId(..), - mkCId, wildCId, - readCId, showCId) -import Gu -import PgfLow - -import Foreign hiding ( Pool, newPool, unsafePerformIO ) -import Foreign.C -import Foreign.C.String -import Foreign.Ptr - - -import Data.Char -import Data.Map (Map, empty, insert) -import qualified Data.ByteString as BS -import Data.IORef - - ------------------------------------------------------------------------------ --- How to compile --- hsc2hs Gu.hsc CRuntimeFFI.hsc -v --cflag="-std=c99" && ghc -lpgf -lgu --make CRuntimeFFI ------------------------------------------------------------------------------ --- Mindless copypasting and translating of the C functions in Gu.hsc and PgfLow.hs --- More user-friendly functions here - ------------------------------------------------------------------------------ ---Memory management, pools and outs -type Pool = ForeignPtr GuPool -type Out = (Ptr GuStringBuf, Ptr GuOut) - - ---when you create a GuOut, you create also a GuStringBuf ---and when you give GuOut to a function that outputs something, ---the result goes into that GuStringBuf -newOut :: Ptr GuPool -> IO Out -newOut pool = - do sb <- gu_string_buf pool - out <- gu_string_buf_out sb - return (sb,out) ---Don't create newOut using withGuPool inside ---Rather do like this: -{- -withGuPool $ \pl -> - do out <- newOut pl - --} - -- withGuPool $ \pl -> - -- do sb <- gu_string_buf pl - -- out <- gu_string_buf_out sb - -- return (sb,out) - - ------------------------------------------------------------------------------ --- Functions that take a PGF. --- PGF has many Concrs. --- A Concr retains its PGF in a field (memory management reasons?) - -data PGF = PGF {pgfPool :: Ptr GuPool, pgf :: Ptr PgfPGF} deriving Show -data Concr = Concr {concr :: (Ptr PgfConcr), concrMaster :: PGF} -type Language = CId - -readPGF :: FilePath -> IO PGF -readPGF filepath = - do pl <- gu_new_pool - pgf <- withCString filepath $ \file -> - pgf_read file pl nullPtr - return PGF {pgfPool = pl, pgf = pgf} - - -getConcr :: PGF -> Language -> Maybe Concr -getConcr p (CId lang) = unsafePerformIO $ - BS.useAsCString lang $ \lng -> do - cnc <- pgf_get_language (pgf p) lng - return (if cnc==nullPtr then Nothing else Just (Concr cnc p)) - - -languages :: PGF -> Map Language Concr -languages p = unsafePerformIO $ - do ref <- newIORef empty - allocaBytes (#size GuMapItor) $ \itor -> - do fptr <- wrapLanguages (getLanguages ref) - (#poke GuMapItor, fn) itor fptr - pgf_iter_languages (pgf p) itor nullPtr - readIORef ref - where - getLanguages :: IORef (Map Language Concr) -> Languages - getLanguages ref itor key value exn = do - langs <- readIORef ref - key' <- fmap CId $ BS.packCString (castPtr key) - value' <- fmap (\ptr -> Concr ptr p) $ peek (castPtr value) - writeIORef ref (insert key' value' langs) ---type Languages = Ptr GuMapItor -> Ptr () -> Ptr () -> Ptr GuExn -> IO ( - - -generateAll :: PGF -> CId -> [(Tree,Float)] -generateAll p (CId cat) = unsafePerformIO $ - withGuPool $ \iterPl -> --- withGuPool $ \exprPl -> --segfaults if I use this - do exprPl <- gu_new_pool - pgfExprs <- BS.useAsCString cat $ \cat -> - pgf_generate_all (pgf p) cat exprPl --this pool isn't freed. segfaults if I try. - fromPgfExprEnum pgfExprs iterPl p --this pool is freed afterwards. it's used in fromPgfExprEnum, and I imagine it makes more sense to give a pool as an argument, rather than in that function create and free new pools in its body (it calls itself recursively) - - -abstractName :: PGF -> Language -abstractName p = unsafePerformIO $ fmap CId (BS.packCString =<< pgf_abstract_name (pgf p)) - -startCat :: PGF -> CId -startCat p = unsafePerformIO $ fmap CId (BS.packCString =<< pgf_start_cat (pgf p)) - -printGrammar :: PGF -> String -printGrammar p = unsafePerformIO $ - withGuPool $ \outPl -> - withGuPool $ \printPl -> - do (sb,out) <- newOut outPl - pgf_print (pgf p) out nullPtr --nullPtr is for exception - grammar <- gu_string_buf_freeze sb printPl - peekCString grammar - - ------------------------------------------------------------------------------ --- Expressions - ---exprMaster is one of the following: --- * PGF --- * pool from which the expr is allocated --- * iterator from generateAll --- TODO ask more about this design --- the master of an Expr needs to be retained because of memory management (?) -data Expr = forall a . Expr {expr :: PgfExpr, exprMaster :: a} - -instance Show Expr where - show = showExpr - -instance Eq Expr where - (Expr e1 m1) == (Expr e2 m2) = e1 == e2 - -type Tree = Expr - - -unApp :: Expr -> Maybe (CId,[Expr]) -unApp (Expr expr master) = unsafePerformIO $ - withGuPool $ \pl -> do - pgfAppl <- pgf_expr_unapply expr pl - if pgfAppl == nullPtr - then return Nothing - else do - fun <- peekCString =<< (#peek PgfApplication, fun) pgfAppl - arity <- (#peek PgfApplication, n_args) pgfAppl :: IO CInt - pgfExprs <- ptrToList pgfAppl (fromIntegral arity) --CInt to Int - --print (arity,fun) - let args = [Expr a master | a<-pgfExprs] - return $ Just (mkCId fun, args) - ---Krasimir recommended not to use PgfApplication, but PgfExprApp instead. ---but then we found out that some of those functions don't behave nicely ---with the FFI, so we need to use PgfApplication anyway, unless we do some ---C coding to make the C library nicer. - - -readExpr :: String -> Maybe Expr -readExpr str = unsafePerformIO $ - do exprPl <- gu_new_pool --we return this pool with the Expr - withGuPool $ \inPl -> --these pools are freed right after - withGuPool $ \exnPl -> - withCString str $ \str -> - do guin <- gu_string_in str inPl - exn <- gu_new_exn nullPtr gu_type__type exnPl - pgfExpr <- pgf_read_expr guin exprPl exn - status <- gu_exn_is_raised exn - if (status==False && pgfExpr /= nullPtr) - then return $ Just (Expr pgfExpr exprPl) - else do - gu_pool_free exprPl --if Expr is not returned, free pool - return Nothing - --- TODO: do we need 3 different pools for this? -showExpr :: Expr -> String -showExpr e = unsafePerformIO $ - withGuPool $ \pl -> - do (sb,out) <- newOut pl - let printCtxt = nullPtr - exn <- gu_new_exn nullPtr gu_type__type pl - pgf_print_expr (expr e) printCtxt 1 out exn - abstree <- gu_string_buf_freeze sb pl - peekCString abstree - - ------------------------------------------------------------------------------ --- Functions using Concr --- Morpho analyses, parsing & linearization - -type MorphoAnalysis = (CId,String,Float) - - ---There is no buildMorpho in the C library, just a lookupMorpho from a Concr -lookupMorpho :: Concr -> String -> [MorphoAnalysis] -lookupMorpho (Concr concr master) sent = unsafePerformIO $ - do ref <- newIORef [] - allocaBytes (#size PgfMorphoCallback) $ \cback -> - do fptr <- wrapLookupMorpho (getAnalysis ref) - (#poke PgfMorphoCallback, callback) cback fptr - withCString sent $ \sent -> - pgf_lookup_morpho concr sent cback nullPtr - - readIORef ref - where - getAnalysis :: IORef [MorphoAnalysis] -> Ptr PgfMorphoCallback -> CString -> CString -> Float -> Ptr GuExn -> IO () --IORef [(CId, String, Float)] -> Callback - getAnalysis ref self clemma canal prob exn = do - ans <- readIORef ref - lemma <- fmap CId (BS.packCString clemma) - anal <- peekCString canal - writeIORef ref ((lemma, anal, prob):ans) - -fullFormLexicon :: Concr -> [(String, [MorphoAnalysis])] -fullFormLexicon lang = - let lexicon = fullformLexicon' lang - analyses = map (lookupMorpho lang) lexicon - in zip lexicon analyses - where fullformLexicon' :: Concr -> [String] - fullformLexicon' lang = unsafePerformIO $ - do pl <- gu_new_pool - lexEnum <- pgf_fullform_lexicon (concr lang) pl - fromFullFormEntry lexEnum pl (concrMaster lang) - -printLexEntry :: (String, [MorphoAnalysis]) -> String -printLexEntry (lemma, anals) = - "Lemma: " ++ lemma ++ "\nAnalyses: " ++ show anals ++ "\n" -- map show' anals --- where show' :: MorphoAnalysis -> String --- show' (id,anal,prob) = showCId id ++ ", " ++ anal ++ ", " ++ show prob ++ "\n" - - ---Note: unlike in Haskell library, we give Concr -> ... and not PGF -> Lang -> ... ---Also this returns a list of tuples (tree,prob) instead of just trees -parse :: Concr -> CId -> String -> [(Tree,Float)] -parse (Concr lang master) (CId cat) sent = unsafePerformIO $ - withGuPool $ \iterPl -> -- this pool will get freed eventually - do inpool <- gu_new_pool - outpool <- gu_new_pool - treesEnum <- parse_ lang cat sent inpool outpool - outpoolFPtr <- newForeignPtr gu_pool_free_ptr outpool - fromPgfExprEnum treesEnum iterPl (master,outpoolFPtr) - where - parse_ :: Ptr PgfConcr -> BS.ByteString -> String -> Ptr GuPool -> Ptr GuPool -> IO (Ptr PgfExprEnum) - parse_ pgfcnc cat sent inpool outpool = - do BS.useAsCString cat $ \cat -> - withCString sent $ \sent -> - pgf_parse pgfcnc cat sent nullPtr inpool outpool - - ---In Haskell library, this function has type signature PGF -> Language -> Tree -> String ---Here we replace PGF -> Language with Concr -linearize :: Concr -> Tree -> String -linearize lang tree = unsafePerformIO $ - withGuPool $ \outPl -> - withGuPool $ \linPl -> - do (sb,out) <- newOut outPl - pgf_linearize (concr lang) (expr tree) out nullPtr --linearization goes to stringbuf - lin <- gu_string_buf_freeze sb linPl - peekCString lin - - ------------------------------------------------------------------------------ --- Helper functions - --- # syntax: http://www.haskell.org/ghc/docs/7.2.1/html/users_guide/hsc2hs.html -fromPgfExprEnum :: Ptr PgfExprEnum -> Ptr GuPool -> a -> IO [(Tree, Float)] -fromPgfExprEnum enum pl master = - do pgfExprProb <- alloca $ \ptr -> - do gu_enum_next enum ptr pl - peek ptr - if pgfExprProb == nullPtr - then return [] - else do expr <- (#peek PgfExprProb, expr) pgfExprProb - prob <- (#peek PgfExprProb, prob) pgfExprProb - ts <- unsafeInterleaveIO (fromPgfExprEnum enum pl master) - return ((Expr expr master,prob) : ts) - - -fromFullFormEntry :: Ptr GuEnum -> Ptr GuPool -> PGF -> IO [String] -fromFullFormEntry enum pl master = - do ffEntry <- alloca $ \ptr -> - do gu_enum_next enum ptr pl - peek ptr --- ffEntry :: Ptr PgfFullFormEntry - if ffEntry == nullPtr - then return [] - else do tok <- peekCString =<< pgf_fullform_get_string ffEntry - toks <- unsafeInterleaveIO (fromFullFormEntry enum pl master) - return (tok : toks) diff --git a/src/runtime/haskell-bind/Gu.hsc b/src/runtime/haskell-bind/Gu.hsc deleted file mode 100644 index 20a728c79..000000000 --- a/src/runtime/haskell-bind/Gu.hsc +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -#include -#include -#include - -module Gu where - -import Foreign -import Foreign.C -import Foreign.C.String -import Foreign.Ptr -import Control.Exception - - -data GuEnum -data GuExn -data GuIn -data GuInStream -data GuKind -data GuString -data GuStringBuf -data GuMapItor -data GuOut -data GuOutStream -data GuPool - -data PgfPGF -data PgfApplication -data PgfConcr -type PgfExpr = Ptr () -data PgfExprEnum -data PgfExprProb -data PgfFullFormEntry -data PgfMorphoCallback -data PgfPrintContext -data PgfType -data PgfLexer - ------------------------------------------------------------------------------- --- Mindless copypasting and translating of the C functions used in CRuntimeFFI --- GU stuff - - - -foreign import ccall "gu/mem.h gu_new_pool" - gu_new_pool :: IO (Ptr GuPool) - -foreign import ccall "gu/mem.h gu_pool_free" - gu_pool_free :: Ptr GuPool -> IO () - -foreign import ccall "gu/mem.h &gu_pool_free" - gu_pool_free_ptr :: FunPtr (Ptr GuPool -> IO ()) - -foreign import ccall "gu/exn.h gu_new_exn" - gu_new_exn :: Ptr GuExn -> Ptr GuKind -> Ptr GuPool -> IO (Ptr GuExn) - -foreign import ccall "gu/exn.h gu_exn_is_raised" - gu_exn_is_raised :: Ptr GuExn -> IO Bool --- gu_ok exn = do --- state <- (#peek GuExn, state) exn --- return (state /= GU_EXN_RAISED) - -foreign import ccall "gu/type.h &gu_type__type" - gu_type__type :: Ptr GuKind - - ---GuIn* gu_string_in(GuString string, GuPool* pool); -foreign import ccall "gu/string.h gu_string_in" - gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn) - ---GuStringBuf* gu_string_buf(GuPool* pool); -foreign import ccall "gu/string.h gu_string_buf" - gu_string_buf :: Ptr GuPool -> IO (Ptr GuStringBuf) - ---GuOut* gu_string_buf_out(GuStringBuf* sb); -foreign import ccall "gu/string.h gu_string_buf_out" - gu_string_buf_out :: Ptr GuStringBuf -> IO (Ptr GuOut) - - ---void gu_enum_next(GuEnum* en, void* to, GuPool* pool) -foreign import ccall "gu/enum.h gu_enum_next" - gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO () - - ---GuString gu_string_buf_freeze(GuStringBuf* sb, GuPool* pool); -foreign import ccall "gu/string.h gu_string_buf_freeze" - gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString - -{- -typedef struct PgfMorphoCallback PgfMorphoCallback; -struct PgfMorphoCallback { - void (*callback)(PgfMorphoCallback* self, - PgfCId lemma, GuString analysis, prob_t prob, - GuExn* err); -}; ---allocate this type of structure in haskell ---make a function and do Something --} - -{- Not used ---GuIn* gu_new_in(GuInStream* stream, GuPool* pool); -foreign import ccall "gu/in.h gu_new_in" - gu_new_in :: Ptr GuInStream -> Ptr GuPool -> Ptr GuIn - ---GuOut* gu_new_out(GuOutStream* stream, GuPool* pool); -foreign import ccall "gu/mem.h gu_new_out" - gu_new_out :: Ptr GuOutStream -> Ptr GuPool -> IO (Ptr GuOut) ---TODO no idea how to get a GuOutStream - ---GuOut* gu_file_out(FILE* file, GuPool* pool); -foreign import ccall "gu/file.h gu_file_out" - gu_file_out :: Ptr CString -> Ptr GuPool -> IO (Ptr GuOut) -} - - ---Pointer magic here, using plusPtr etc. -ptrToList :: Ptr PgfApplication -> Int -> IO [PgfExpr] -ptrToList appl arity = do - let ptr = appl `plusPtr` (#offset PgfApplication, args) --args is not an argument, it's the actual field name - sequence [peek (ptr `plusPtr` (i * (#size PgfExpr))) | i<-[0..arity-1]] - -withGuPool :: (Ptr GuPool -> IO a) -> IO a -withGuPool f = do - pl <- gu_new_pool - f pl `finally` gu_pool_free pl - -- for true haskell persons - -- withGuPool f = bracket gu_new_pool gu_pool_free f - diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc new file mode 100644 index 000000000..06bf30ef0 --- /dev/null +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -0,0 +1,232 @@ +{-# LANGUAGE ExistentialQuantification #-} +#include +#include +#include + +module PGF2 (-- * PGF + PGF,readPGF,abstractName,startCat, + -- * Concrete syntax + Concr,languages,parse,linearize, + -- * Trees + Expr,readExpr,showExpr,unApp, + -- * Morphology + MorphoAnalysis, lookupMorpho, fullFormLexicon, + ) where + +import Prelude hiding (fromEnum) +import Control.Exception +import System.IO +import System.IO.Unsafe +import PGF2.FFI + +import Foreign hiding ( Pool, newPool, unsafePerformIO ) +import Foreign.C +import Foreign.C.String +import Foreign.Ptr +import Data.Char +import qualified Data.Map as Map +import qualified Data.ByteString as BS +import Data.IORef + + +----------------------------------------------------------------------------- +-- Functions that take a PGF. +-- PGF has many Concrs. +-- +-- A Concr retains its PGF in a field in order to retain a reference to +-- the foreign pointer in case if the application still has a reference +-- to Concr but has lost its reference to PGF. + +data PGF = PGF {pgf :: Ptr PgfPGF, pgfMaster :: ForeignPtr GuPool} +data Concr = Concr {concr :: Ptr PgfConcr, concrMaster :: PGF} + +readPGF :: FilePath -> IO PGF +readPGF fpath = + do pool <- gu_new_pool + pgf <- withCString fpath $ \c_fpath -> + pgf_read c_fpath pool nullPtr + master <- newForeignPtr gu_pool_finalizer pool + return PGF {pgf = pgf, pgfMaster = master} + +languages :: PGF -> Map.Map String Concr +languages p = + unsafePerformIO $ + do ref <- newIORef Map.empty + allocaBytes (#size GuMapItor) $ \itor -> + do fptr <- wrapMapItorCallback (getLanguages ref) + (#poke GuMapItor, fn) itor fptr + pgf_iter_languages (pgf p) itor nullPtr + readIORef ref + where + getLanguages :: IORef (Map.Map String Concr) -> MapItorCallback + getLanguages ref itor key value exn = do + langs <- readIORef ref + name <- peekCString (castPtr key) + concr <- fmap (\ptr -> Concr ptr p) $ peek (castPtr value) + writeIORef ref $! Map.insert name concr langs + +generateAll :: PGF -> String -> [(Expr,Float)] +generateAll p cat = + unsafePerformIO $ + do genPl <- gu_new_pool + exprPl <- gu_new_pool + enum <- withCString cat $ \cat -> + pgf_generate_all (pgf p) cat genPl + genFPl <- newForeignPtr gu_pool_finalizer genPl + exprFPl <- newForeignPtr gu_pool_finalizer exprPl + fromPgfExprEnum enum genFPl (p,exprFPl) + +abstractName :: PGF -> String +abstractName p = unsafePerformIO (peekCString =<< pgf_abstract_name (pgf p)) + +startCat :: PGF -> String +startCat p = unsafePerformIO (peekCString =<< pgf_start_cat (pgf p)) + + +----------------------------------------------------------------------------- +-- Expressions + +-- The C structure for the expression may point to other structures +-- which are allocated from other pools. In order to ensure that +-- they are not released prematurely we use the exprMaster to +-- store references to other Haskell objects + +data Expr = forall a . Expr {expr :: PgfExpr, exprMaster :: a} + +instance Show Expr where + show = showExpr + +unApp :: Expr -> Maybe (String,[Expr]) +unApp (Expr expr master) = + unsafePerformIO $ + withGuPool $ \pl -> do + appl <- pgf_expr_unapply expr pl + if appl == nullPtr + then return Nothing + else do + fun <- peekCString =<< (#peek PgfApplication, fun) appl + arity <- (#peek PgfApplication, n_args) appl :: IO CInt + c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args)) + return $ Just (fun, [Expr c_arg master | c_arg <- c_args]) + +readExpr :: String -> Maybe Expr +readExpr str = + unsafePerformIO $ + do exprPl <- gu_new_pool + withGuPool $ \tmpPl -> + withCString str $ \c_str -> + do guin <- gu_string_in c_str tmpPl + exn <- gu_new_exn nullPtr gu_type__type tmpPl + c_expr <- pgf_read_expr guin exprPl exn + status <- gu_exn_is_raised exn + if (not status && c_expr /= nullPtr) + then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl + return $ Just (Expr c_expr exprFPl) + else do gu_pool_free exprPl + return Nothing + +showExpr :: Expr -> String +showExpr e = + unsafePerformIO $ + withGuPool $ \tmpPl -> + do (sb,out) <- newOut tmpPl + let printCtxt = nullPtr + exn <- gu_new_exn nullPtr gu_type__type tmpPl + pgf_print_expr (expr e) printCtxt 1 out exn + s <- gu_string_buf_freeze sb tmpPl + peekCString s + + +----------------------------------------------------------------------------- +-- Functions using Concr +-- Morpho analyses, parsing & linearization + +type MorphoAnalysis = (String,String,Float) + +lookupMorpho :: Concr -> String -> [MorphoAnalysis] +lookupMorpho (Concr concr master) sent = unsafePerformIO $ + do ref <- newIORef [] + allocaBytes (#size PgfMorphoCallback) $ \cback -> + do fptr <- wrapLookupMorphoCallback (getAnalysis ref) + (#poke PgfMorphoCallback, callback) cback fptr + withCString sent $ \c_sent -> + pgf_lookup_morpho concr c_sent cback nullPtr + readIORef ref + +fullFormLexicon :: Concr -> [(String, [MorphoAnalysis])] +fullFormLexicon lang = + unsafePerformIO $ + do pl <- gu_new_pool + enum <- pgf_fullform_lexicon (concr lang) pl + fpl <- newForeignPtr gu_pool_finalizer pl + fromFullFormEntry enum fpl + where + fromFullFormEntry :: Ptr GuEnum -> ForeignPtr GuPool -> IO [(String, [MorphoAnalysis])] + fromFullFormEntry enum fpl = + do ffEntry <- alloca $ \ptr -> + withForeignPtr fpl $ \pl -> + do gu_enum_next enum ptr pl + peek ptr + if ffEntry == nullPtr + then do finalizeForeignPtr fpl + return [] + else do tok <- peekCString =<< pgf_fullform_get_string ffEntry + ref <- newIORef [] + allocaBytes (#size PgfMorphoCallback) $ \cback -> + do fptr <- wrapLookupMorphoCallback (getAnalysis ref) + (#poke PgfMorphoCallback, callback) cback fptr + pgf_fullform_get_analyses ffEntry cback nullPtr + ans <- readIORef ref + toks <- unsafeInterleaveIO (fromFullFormEntry enum fpl) + return ((tok,ans) : toks) + +getAnalysis :: IORef [MorphoAnalysis] -> LookupMorphoCallback +getAnalysis ref self c_lemma c_anal prob exn = do + ans <- readIORef ref + lemma <- peekCString c_lemma + anal <- peekCString c_anal + writeIORef ref ((lemma, anal, prob):ans) + +parse :: Concr -> String -> String -> [(Expr,Float)] +parse lang cat sent = + unsafePerformIO $ + do parsePl <- gu_new_pool + exprPl <- gu_new_pool + enum <- withCString cat $ \cat -> + withCString sent $ \sent -> + pgf_parse (concr lang) cat sent nullPtr parsePl exprPl + parseFPl <- newForeignPtr gu_pool_finalizer parsePl + exprFPl <- newForeignPtr gu_pool_finalizer exprPl + fromPgfExprEnum enum parseFPl (lang,exprFPl) + +linearize :: Concr -> Expr -> String +linearize lang e = unsafePerformIO $ + withGuPool $ \pl -> + do (sb,out) <- newOut pl + pgf_linearize (concr lang) (expr e) out nullPtr + lin <- gu_string_buf_freeze sb pl + peekCString lin + + +----------------------------------------------------------------------------- +-- Helper functions + +newOut :: Ptr GuPool -> IO (Ptr GuStringBuf, Ptr GuOut) +newOut pool = + do sb <- gu_string_buf pool + out <- gu_string_buf_out sb + return (sb,out) + +fromPgfExprEnum :: Ptr GuEnum -> ForeignPtr GuPool -> a -> IO [(Expr, Float)] +fromPgfExprEnum enum fpl master = + do pgfExprProb <- alloca $ \ptr -> + withForeignPtr fpl $ \pl -> + do gu_enum_next enum ptr pl + peek ptr + if pgfExprProb == nullPtr + then do finalizeForeignPtr fpl + return [] + else do expr <- (#peek PgfExprProb, expr) pgfExprProb + ts <- unsafeInterleaveIO (fromPgfExprEnum enum fpl master) + prob <- (#peek PgfExprProb, prob) pgfExprProb + return ((Expr expr master,prob) : ts) diff --git a/src/runtime/haskell-bind/PgfLow.hs b/src/runtime/haskell-bind/PGF2/FFI.hs similarity index 50% rename from src/runtime/haskell-bind/PgfLow.hs rename to src/runtime/haskell-bind/PGF2/FFI.hs index 0caad1ab9..c0a9adf0a 100644 --- a/src/runtime/haskell-bind/PgfLow.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hs @@ -1,152 +1,154 @@ {-# LANGUAGE ForeignFunctionInterface #-} -module PgfLow where +module PGF2.FFI where import Foreign.C import Foreign.C.String import Foreign.Ptr -import Gu +import Foreign.ForeignPtr +import Control.Exception ------------------------------------------------------------------------------- --- Mindless copypasting and translating of the C functions used in CRuntimeFFI --- From pgf.h +------------------------------------------------------------------ +-- libgu API + +data GuEnum +data GuExn +data GuIn +data GuKind +data GuString +data GuStringBuf +data GuMapItor +data GuOut +data GuPool + +foreign import ccall "gu/mem.h gu_new_pool" + gu_new_pool :: IO (Ptr GuPool) + +foreign import ccall "gu/mem.h gu_pool_free" + gu_pool_free :: Ptr GuPool -> IO () + +foreign import ccall "gu/mem.h &gu_pool_free" + gu_pool_finalizer :: FinalizerPtr GuPool + +foreign import ccall "gu/exn.h gu_new_exn" + gu_new_exn :: Ptr GuExn -> Ptr GuKind -> Ptr GuPool -> IO (Ptr GuExn) + +foreign import ccall "gu/exn.h gu_exn_is_raised" + gu_exn_is_raised :: Ptr GuExn -> IO Bool + +foreign import ccall "gu/type.h &gu_type__type" + gu_type__type :: Ptr GuKind + +foreign import ccall "gu/string.h gu_string_in" + gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn) + +foreign import ccall "gu/string.h gu_string_buf" + gu_string_buf :: Ptr GuPool -> IO (Ptr GuStringBuf) + +foreign import ccall "gu/string.h gu_string_buf_out" + gu_string_buf_out :: Ptr GuStringBuf -> IO (Ptr GuOut) + +foreign import ccall "gu/enum.h gu_enum_next" + gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO () + +foreign import ccall "gu/string.h gu_string_buf_freeze" + gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString + +withGuPool :: (Ptr GuPool -> IO a) -> IO a +withGuPool f = bracket gu_new_pool gu_pool_free f +------------------------------------------------------------------ +-- libpgf API + +data PgfPGF +data PgfApplication +data PgfConcr +type PgfExpr = Ptr () +data PgfExprProb +data PgfFullFormEntry +data PgfMorphoCallback +data PgfPrintContext +data PgfType --- PgfPGF* pgf_read(const char* fpath, GuPool* pool, GuExn* err); foreign import ccall "pgf/pgf.h pgf_read" pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF) --- GuString pgf_abstract_name(PgfPGF*); foreign import ccall "pgf/pgf.h pgf_abstract_name" pgf_abstract_name :: Ptr PgfPGF -> IO CString --- void pgf_iter_languages(PgfPGF*, GuMapItor*, GuExn* err); foreign import ccall "pgf/pgf.h pgf_iter_languages" pgf_iter_languages :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO () --- TODO test this function --- GuMapItor??? --- implement a fun in haskell, export it to c --- GuMapItor contains a pointer to a function --- Ask Koen --- foreign export --- PgfConcr* pgf_get_language(PgfPGF*, PgfCId lang); foreign import ccall "pgf/pgf.h pgf_get_language" pgf_get_language :: Ptr PgfPGF -> CString -> IO (Ptr PgfConcr) - --- GuString pgf_concrete_name(PgfConcr*); foreign import ccall "pgf/pgf.h pgf_concrete_name" pgf_concrete_name :: Ptr PgfConcr -> IO CString --- GuString pgf_language_code(PgfConcr* concr); foreign import ccall "pgf/pgf.h pgf_language_code" pgf_language_code :: Ptr PgfConcr -> IO CString - ---void pgf_iter_categories(PgfPGF* pgf, GuMapItor* fn, GuExn* err); foreign import ccall "pgf/pgf.h pgf_iter_categories" pgf_iter_categories :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO () ---TODO test this function --- PgfCId pgf_start_cat(PgfPGF* pgf, GuPool* pool); foreign import ccall "pgf/pgf.h pgf_start_cat" pgf_start_cat :: Ptr PgfPGF -> IO CString --- void pgf_iter_functions(PgfPGF* pgf, GuMapItor* fn, GuExn* err); foreign import ccall "pgf/pgf.h pgf_iter_functions" pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO () ---TODO test this function --- void pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, --- GuMapItor* fn, GuExn* err); foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat" pgf_iter_functions_by_cat :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO () ---TODO test this function --- PgfType* pgf_function_type(PgfPGF* pgf, PgfCId funname); foreign import ccall "pgf/pgf.h pgf_function_type" pgf_function_type :: Ptr PgfPGF -> CString -> IO (Ptr PgfType) --- GuString pgf_print_name(PgfConcr*, PgfCId id); foreign import ccall "pgf/pgf.h pgf_print_name" pgf_print_name :: Ptr PgfConcr -> CString -> IO CString ---void pgf_linearize(PgfConcr* concr, PgfExpr expr, GuOut* out, GuExn* err); foreign import ccall "pgf/pgf.h pgf_linearize" pgf_linearize :: Ptr PgfConcr -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO () --- PgfExprEnum* pgf_parse(PgfConcr* concr, PgfCId cat, GuString sentence, --- GuExn* err, GuPool* pool, GuPool* out_pool); foreign import ccall "pgf/pgf.h pgf_parse" - pgf_parse :: Ptr PgfConcr -> CString -> CString -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr PgfExprEnum) + pgf_parse :: Ptr PgfConcr -> CString -> CString -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum) ---void pgf_lookup_morpho(PgfConcr *concr, GuString sentence, --- PgfMorphoCallback* callback, GuExn* err); foreign import ccall "pgf/pgf.h pgf_lookup_morpho" pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO () -type Callback = Ptr PgfMorphoCallback -> CString -> CString -> Float -> Ptr GuExn -> IO () +type LookupMorphoCallback = Ptr PgfMorphoCallback -> CString -> CString -> Float -> Ptr GuExn -> IO () foreign import ccall "wrapper" - wrapLookupMorpho :: Callback -> IO (FunPtr Callback) + wrapLookupMorphoCallback :: LookupMorphoCallback -> IO (FunPtr LookupMorphoCallback) -type Languages = Ptr GuMapItor -> Ptr () -> Ptr () -> Ptr GuExn -> IO () +type MapItorCallback = Ptr GuMapItor -> Ptr () -> Ptr () -> Ptr GuExn -> IO () foreign import ccall "wrapper" - wrapLanguages :: Languages -> IO (FunPtr Languages) + wrapMapItorCallback :: MapItorCallback -> IO (FunPtr MapItorCallback) ---GuEnum* pgf_fullform_lexicon(PgfConcr *concr, GuPool* pool); foreign import ccall "pgf/pgf.h pgf_fullform_lexicon" pgf_fullform_lexicon :: Ptr PgfConcr -> Ptr GuPool -> IO (Ptr GuEnum) ---GuString pgf_fullform_get_string(PgfFullFormEntry* entry); foreign import ccall "pgf/pgf.h pgf_fullform_get_string" pgf_fullform_get_string :: Ptr PgfFullFormEntry -> IO CString --- void pgf_fullform_get_analyses(PgfFullFormEntry* entry, --- PgfMorphoCallback* callback, GuExn* err) foreign import ccall "pgf/pgf.h pgf_fullform_get_analyses" pgf_fullform_get_analyses :: Ptr PgfFullFormEntry -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO () - ---PgfApplication* pgf_expr_unapply(PgfExpr expr, GuPool* pool); foreign import ccall "pgf/pgf.h pgf_expr_unapply" pgf_expr_unapply :: PgfExpr -> Ptr GuPool -> IO (Ptr PgfApplication) ---int pgf_expr_arity(PgfExpr expr); foreign import ccall "pgf/expr.h pgf_expr_arity" pgf_expr_arity :: PgfExpr -> IO Int ---Not needed anymore, solved the problem with unapply using CInt instead of Int - ---void pgf_print_expr(PgfExpr expr, PgfPrintContext* ctxt, int prec, --- GuOut* out, GuExn* err); foreign import ccall "pgf/expr.h pgf_print_expr" pgf_print_expr :: PgfExpr -> Ptr PgfPrintContext -> Int -> Ptr GuOut -> Ptr GuExn -> IO () ---PgfExprEnum* pgf_generate_all(PgfPGF* pgf, PgfCId cat, GuPool* pool); -foreign import ccall "pgf/pgf.h pgf_generate_all" - pgf_generate_all :: Ptr PgfPGF -> CString -> Ptr GuPool -> IO (Ptr PgfExprEnum) --- void pgf_print(PgfPGF* pgf, GuOut* out, GuExn* err); +foreign import ccall "pgf/pgf.h pgf_generate_all" + pgf_generate_all :: Ptr PgfPGF -> CString -> Ptr GuPool -> IO (Ptr GuEnum) + foreign import ccall "pgf/pgf.h pgf_print" pgf_print :: Ptr PgfPGF -> Ptr GuOut -> Ptr GuExn -> IO () ---PgfExpr pgf_read_expr(GuIn* in, GuPool* pool, GuExn* err); foreign import ccall "pgf/expr.h pgf_read_expr" pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr - ---PgfExprEnum* ---pgf_parse_with_heuristics(PgfConcr* concr, PgfCId cat, PgfLexer *lexer, --- double heuristics, --- GuPool* pool, GuPool* out_pool); --- Not needed - --- GuEnum* pgf_complete(PgfConcr* concr, PgfCId cat, PgfLexer *lexer, --- GuString prefix, GuPool* pool); --- TODO - --- bool pgf_parseval(PgfConcr* concr, PgfExpr expr, PgfCId cat, --- double *precision, double *recall, double *exact); --- Not needed diff --git a/src/runtime/haskell-bind/examples/pgf-shell.hs b/src/runtime/haskell-bind/examples/pgf-shell.hs index fbb4c4023..1159ea794 100644 --- a/src/runtime/haskell-bind/examples/pgf-shell.hs +++ b/src/runtime/haskell-bind/examples/pgf-shell.hs @@ -13,9 +13,9 @@ import qualified Data.Map as M import System.IO(hFlush,stdout) import System.IO.Error(catchIOError) import System.Environment -import CRuntimeFFI -import CId +import PGF2 import System.Mem(performGC) +import qualified Data.Map as Map main = getPGF =<< getArgs @@ -42,13 +42,13 @@ execute pgf cmd = getConcr' pgf lang = maybe (fail $ "Concrete syntax not found: "++show lang) return $ - getConcr pgf lang + Map.lookup lang (languages pgf) printl xs = putl $ map show xs putl = putStr . unlines -- | Abstracy syntax of shell commands -data Command = P CId String | L CId Tree | T CId CId String deriving Show +data Command = P String String | L String Expr | T String String String deriving Show -- | Shell command parser instance Read Command where diff --git a/src/runtime/haskell-bind/haskell-bind.cabal b/src/runtime/haskell-bind/pgf2-bind.cabal similarity index 83% rename from src/runtime/haskell-bind/haskell-bind.cabal rename to src/runtime/haskell-bind/pgf2-bind.cabal index 863bd3da8..e2a9e2e7a 100644 --- a/src/runtime/haskell-bind/haskell-bind.cabal +++ b/src/runtime/haskell-bind/pgf2-bind.cabal @@ -1,7 +1,7 @@ -- Initial haskell-bind.cabal generated by cabal init. For further -- documentation, see http://haskell.org/cabal/users-guide/ -name: haskell-bind +name: pgf2-bind version: 0.1.0.0 -- synopsis: -- description: @@ -9,7 +9,7 @@ homepage: http://www.grammaticalframework.org license: LGPL-3 --license-file: LICENSE author: Inari --- maintainer: +maintainer: Krasimir Angelov -- copyright: category: Language build-type: Simple @@ -17,10 +17,10 @@ extra-source-files: README cabal-version: >=1.10 library - exposed-modules: CId, CRuntimeFFI - other-modules: Gu, PgfLow + exposed-modules: PGF2 + other-modules: PGF2.FFI build-depends: base >=4.5 && <4.7, bytestring >=0.9 && <0.11, - pretty >=1.1 && <1.2, containers + containers -- hs-source-dirs: build-tools: hsc2hs extra-libraries: gu pgf