forked from GitHub/gf-core
203 lines
5.5 KiB
Haskell
203 lines
5.5 KiB
Haskell
{-# LANGUAGE ForeignFunctionInterface #-}
|
|
module PyGF where
|
|
|
|
import PGF
|
|
import Foreign
|
|
import CString
|
|
import Foreign.C.Types
|
|
import Control.Monad
|
|
|
|
#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 :: Ptr PGF -> CString -> IO ()
|
|
gf_readPGF pt path = do
|
|
p <- (peekCString path)
|
|
result <- (readPGF p)
|
|
poke pt result
|
|
|
|
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 -> Ptr Type -> IO ()
|
|
gf_startCat ppgf pcat= do
|
|
pgf <- peek ppgf
|
|
poke pcat (startCat pgf)
|
|
|
|
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
|
|
let bufl = length ls + 1
|
|
-- buf <- mallocBytes $ (#size PyGF) * bufl
|
|
pyls <- pyList
|
|
-- pokeElemOff buf (length ls) nullPtr
|
|
mapM_ (mpoke pyls) ls
|
|
return pyls
|
|
where mpoke pyl l = do
|
|
pl <- mk
|
|
poke pl l
|
|
pyl << pl
|
|
|
|
|
|
-- foreign export ccall "gf_freeArray" free :: Ptr a -> IO ()
|
|
|
|
|
|
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 -> Ptr Language -> IO ()
|
|
gf_abstractName ppgf pabs = do
|
|
pgf <- peek ppgf
|
|
poke pabs $ abstractName pgf
|
|
|
|
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 import ccall "newLang" pyLang :: IO (Ptr Language)
|
|
foreign import ccall "newTree" pyTree :: IO (Ptr Tree)
|
|
foreign import ccall "newCId" pyCId :: IO (Ptr CId)
|
|
foreign import ccall "newList" pyList :: IO (Ptr ())
|
|
foreign import ccall "append" (<<) :: Ptr () -> Ptr a -> IO ()
|