mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
305 lines
8.4 KiB
Haskell
305 lines
8.4 KiB
Haskell
{-# LANGUAGE ForeignFunctionInterface #-}
|
|
--
|
|
-- GF Python bindings
|
|
-- Jordi Saludes, upc.edu 2010, 2011
|
|
--
|
|
|
|
module PyGF where
|
|
|
|
import PGF
|
|
import Foreign
|
|
import CString
|
|
import Foreign.C.Types
|
|
import Control.Monad
|
|
import Data.Map (keys, (!))
|
|
import Data.Char (isSpace)
|
|
|
|
#include "pygf.h"
|
|
|
|
freeSp :: String -> Ptr a -> IO ()
|
|
freeSp tname p = do
|
|
--DEBUG putStrLn $ "about to free pointer " ++ tname ++ " at " ++ (show p)
|
|
sp <- (#peek PyGF, sp) p
|
|
--DEBUG putStrLn "peeked"
|
|
freeStablePtr sp
|
|
--DEBUG putStrLn $ "freeing " ++ tname ++ " at " ++ (show p)
|
|
|
|
instance Storable PGF where
|
|
sizeOf _ = (#size PyGF)
|
|
alignment _ = alignment (undefined::CInt)
|
|
poke p o = do
|
|
sp <- newStablePtr o
|
|
(#poke PyGF, sp) p sp
|
|
peek p = do
|
|
sp <- (#peek PyGF, sp) p
|
|
deRefStablePtr sp
|
|
|
|
instance Storable Type where
|
|
sizeOf _ = (#size PyGF)
|
|
alignment _ = alignment (undefined::CInt)
|
|
poke p o = do
|
|
sp <- newStablePtr o
|
|
(#poke PyGF, sp) p sp
|
|
peek p = do
|
|
sp <- (#peek PyGF, sp) p
|
|
deRefStablePtr sp
|
|
|
|
instance Storable Language where
|
|
sizeOf _ = (#size PyGF)
|
|
alignment _ = alignment (undefined::CInt)
|
|
poke p o = do
|
|
sp <- newStablePtr o
|
|
(#poke PyGF, sp) p sp
|
|
peek p = do
|
|
sp <- (#peek PyGF, sp) p
|
|
deRefStablePtr sp
|
|
|
|
instance Storable Tree where
|
|
sizeOf _ = (#size PyGF)
|
|
alignment _ = alignment (undefined::CInt)
|
|
poke p o = do
|
|
sp <- newStablePtr o
|
|
(#poke PyGF, sp) p sp
|
|
peek p = do
|
|
sp <- (#peek PyGF, sp) p
|
|
deRefStablePtr sp
|
|
|
|
-- It is CId the same as Tree?
|
|
|
|
{- instance Storable CId where
|
|
sizeOf _ = (#size PyGF)
|
|
alignment _ = alignment (undefined::CInt)
|
|
poke p o = do
|
|
sp <- newStablePtr o
|
|
(#poke PyGF, sp) p sp
|
|
peek p = do
|
|
sp <- (#peek PyGF, sp) p
|
|
deRefStablePtr sp
|
|
-}
|
|
|
|
|
|
foreign export ccall gf_freePGF :: Ptr PGF -> IO ()
|
|
foreign export ccall gf_freeType :: Ptr Type -> IO ()
|
|
foreign export ccall gf_freeLanguage :: Ptr Language -> IO ()
|
|
foreign export ccall gf_freeTree :: Ptr Tree -> IO ()
|
|
foreign export ccall gf_freeExpr :: Ptr Expr -> IO ()
|
|
foreign export ccall gf_freeCId :: Ptr CId -> IO ()
|
|
gf_freePGF = freeSp "pgf"
|
|
gf_freeType = freeSp "type"
|
|
gf_freeLanguage = freeSp "language"
|
|
gf_freeTree = freeSp "tree"
|
|
gf_freeExpr = freeSp "expression"
|
|
gf_freeCId = freeSp "CId"
|
|
|
|
|
|
{-foreign export ccall gf_printCId :: Ptr CId-> IO CString
|
|
gf_printCId p = do
|
|
c <- peek p
|
|
newCString (showCId c)
|
|
-}
|
|
|
|
foreign export ccall gf_readPGF :: CString -> IO (Ptr PGF)
|
|
gf_readPGF path = do
|
|
ppgf <- pyPGF
|
|
p <- peekCString path
|
|
readPGF p >>= poke ppgf
|
|
return ppgf
|
|
|
|
foreign export ccall gf_readLanguage :: Ptr Language -> CString -> IO Bool
|
|
gf_readLanguage pt str = do
|
|
s <- (peekCString str)
|
|
case (readLanguage s) of
|
|
Just x -> do
|
|
poke pt x
|
|
return True
|
|
Nothing -> return False
|
|
|
|
foreign export ccall gf_startCat :: Ptr PGF -> IO (Ptr Type)
|
|
gf_startCat ppgf = do
|
|
pgf <- peek ppgf
|
|
pcat <- pyType
|
|
poke pcat (startCat pgf)
|
|
return pcat
|
|
|
|
foreign export ccall gf_parse :: Ptr PGF -> Ptr Language -> Ptr Type -> CString -> IO (Ptr ())
|
|
gf_parse ppgf plang pcat input = do
|
|
p <- peek ppgf
|
|
c <- peek pcat
|
|
i <- peekCString input
|
|
l <- peek plang
|
|
let parsed = parse p l c i
|
|
--DEBUG putStrLn $ (show $ length parsed) ++ " parsings"
|
|
listToPy pyTree parsed
|
|
|
|
foreign export ccall gf_showExpr :: Ptr Expr -> IO CString
|
|
gf_showExpr pexpr = do
|
|
e <- peek pexpr
|
|
newCString (showExpr [] e)
|
|
|
|
listToPy :: Storable a => IO (Ptr a) -> [a] -> IO (Ptr ()) -- opaque -- IO (Ptr (Ptr Language))
|
|
listToPy mk ls = do
|
|
pyls <- pyList
|
|
mapM_ (mpoke pyls) ls
|
|
return pyls
|
|
where mpoke pyl l = do
|
|
pl <- mk
|
|
poke pl l
|
|
pyl << pl
|
|
|
|
|
|
listToPyStrings :: [String] -> IO (Ptr ())
|
|
listToPyStrings ss = do
|
|
pyls <- pyList
|
|
mapM_ (mpoke pyls) ss
|
|
return pyls
|
|
where mpoke pyl s = do
|
|
cs <- newCString s
|
|
pcs <- pyString cs
|
|
pyl << pcs
|
|
|
|
|
|
foreign export ccall gf_showLanguage :: Ptr Language -> IO CString
|
|
gf_showLanguage plang = do
|
|
l <- peek plang
|
|
newCString $ showLanguage l
|
|
|
|
foreign export ccall gf_showType :: Ptr Type -> IO CString
|
|
gf_showType ptp = do
|
|
t <- peek ptp
|
|
newCString $ showType [] t
|
|
|
|
foreign export ccall gf_showPrintName :: Ptr PGF -> Ptr Language -> Ptr CId -> IO CString
|
|
gf_showPrintName ppgf plang pcid = do
|
|
pgf <- peek ppgf
|
|
lang <- peek plang
|
|
cid <- peek pcid
|
|
newCString (showPrintName pgf lang cid)
|
|
|
|
foreign export ccall gf_abstractName :: Ptr PGF -> IO (Ptr Language)
|
|
gf_abstractName ppgf = do
|
|
pabs <- pyLang
|
|
pgf <- peek ppgf
|
|
poke pabs $ abstractName pgf
|
|
return pabs
|
|
|
|
foreign export ccall gf_linearize :: Ptr PGF -> Ptr Language -> Ptr Tree -> IO CString
|
|
gf_linearize ppgf plang ptree = do
|
|
pgf <- peek ppgf
|
|
lang <- peek plang
|
|
tree <- peek ptree
|
|
newCString $ linearize pgf lang tree
|
|
|
|
foreign export ccall gf_languageCode :: Ptr PGF -> Ptr Language -> IO CString
|
|
gf_languageCode ppgf plang = do
|
|
pgf <- peek ppgf
|
|
lang <- peek plang
|
|
case languageCode pgf lang of
|
|
Just s -> newCString s
|
|
Nothing -> return nullPtr
|
|
|
|
foreign export ccall gf_languages :: Ptr PGF -> IO (Ptr ()) -- (Ptr (Ptr Language))
|
|
gf_languages ppgf = do
|
|
pgf <- peek ppgf
|
|
listToPy pyLang $ languages pgf
|
|
|
|
foreign export ccall gf_categories :: Ptr PGF -> IO (Ptr ())
|
|
gf_categories ppgf = do
|
|
pgf <- peek ppgf
|
|
listToPy pyCId $ categories pgf
|
|
|
|
foreign export ccall gf_showCId :: Ptr CId -> IO CString
|
|
gf_showCId pcid = do
|
|
cid <- peek pcid
|
|
newCString $ showCId cid
|
|
|
|
foreign export ccall gf_unapp :: Ptr Expr -> IO (Ptr ())
|
|
foreign export ccall gf_unint :: Ptr Expr -> IO CInt
|
|
foreign export ccall gf_unstr :: Ptr Expr -> IO CString
|
|
|
|
gf_unapp pexp = do
|
|
exp <- peek pexp
|
|
case unApp exp of
|
|
Just (f,args) -> do
|
|
puexp <- pyList
|
|
pf <- pyCId
|
|
poke pf f
|
|
puexp << pf
|
|
mapM_ (\e -> do
|
|
pe <- pyExpr
|
|
poke pe e
|
|
puexp << pe) args
|
|
return puexp
|
|
Nothing -> return nullPtr
|
|
gf_unint pexp = do
|
|
exp <- peek pexp
|
|
return $ fromIntegral $ case unInt exp of
|
|
Just n -> n
|
|
_ -> (-9)
|
|
gf_unstr pexp = do
|
|
exp <- peek pexp
|
|
case unStr exp of
|
|
Just s -> newCString s
|
|
_ -> return nullPtr
|
|
|
|
foreign export ccall gf_inferexpr :: Ptr PGF -> Ptr Expr -> IO (Ptr Type)
|
|
gf_inferexpr ppgf pexp = do
|
|
pgf <- peek ppgf
|
|
exp <- peek pexp
|
|
case inferExpr pgf exp of
|
|
Right (_,t) -> do
|
|
ptype <- pyType
|
|
poke ptype t
|
|
return ptype
|
|
Left _ -> return nullPtr
|
|
|
|
|
|
foreign export ccall gf_functions :: Ptr PGF -> IO (Ptr ())
|
|
gf_functions ppgf = do
|
|
pgf <- peek ppgf
|
|
listToPy pyCId $ functions pgf
|
|
|
|
foreign export ccall gf_functiontype :: Ptr PGF -> Ptr CId -> IO (Ptr Type)
|
|
gf_functiontype ppgf pcid = do
|
|
pgf <- peek ppgf
|
|
cid <- peek pcid
|
|
case functionType pgf cid of
|
|
Just t -> do
|
|
ptp <- pyType
|
|
poke ptp t
|
|
return ptp
|
|
_ -> return nullPtr
|
|
|
|
|
|
foreign export ccall gf_completions :: Ptr PGF -> Ptr Language -> Ptr Type -> CString -> IO (Ptr ())
|
|
gf_completions ppgf plang pcat ctoks = do
|
|
pgf <- peek ppgf
|
|
lang <- peek plang
|
|
cat <- peek pcat
|
|
toks <- peekCString ctoks
|
|
let (rpre,rs) = break isSpace (reverse toks)
|
|
pre = reverse rpre
|
|
ws = words (reverse rs)
|
|
state0 = initState pgf lang cat
|
|
completions =
|
|
case loop state0 ws of
|
|
Nothing -> []
|
|
Just state -> keys $ getCompletions state pre
|
|
listToPyStrings completions
|
|
where
|
|
loop ps [] = Just ps
|
|
loop ps (w:ws) =
|
|
case nextState ps (simpleParseInput w) of
|
|
Left _ -> Nothing
|
|
Right ps -> loop ps ws
|
|
|
|
|
|
foreign import ccall "newLang" pyLang :: IO (Ptr Language)
|
|
foreign import ccall "newPGF" pyPGF :: IO (Ptr PGF)
|
|
foreign import ccall "newTree" pyTree :: IO (Ptr Tree)
|
|
foreign import ccall "newgfType" pyType :: IO (Ptr Type)
|
|
foreign import ccall "newCId" pyCId :: IO (Ptr CId)
|
|
foreign import ccall "newExpr" pyExpr :: IO (Ptr Expr)
|
|
foreign import ccall "newList" pyList :: IO (Ptr ())
|
|
foreign import ccall "newString" pyString :: CString -> IO (Ptr ())
|
|
foreign import ccall "append" (<<) :: Ptr () -> Ptr a -> IO ()
|