GitHub/gf-core
1
0
Fork 1
mirror of https://github.com/GrammaticalFramework/gf-core.git synced 2026-04-24 03:52:50 -06:00
Code Issues Packages Projects Releases Wiki Activity

started on the Haskell binding

Browse Source
This commit is contained in:
krangelov
2021-08-05 17:01:49 +02:00
parent 54421492b2
commit 5e320943c9
9 changed files with 55 additions and 4339 deletions
Download Patch File Download Diff File Expand all files Collapse all files

24
src/runtime/c/pgf.cxx
View File

@@ -1,11 +1,21 @@
#include "data.h" #include "data.h"
#include "reader.h" #include "reader.h"
static void
pgf_exn_clear(PgfExn* err)
{
err->type = PGF_EXN_NONE;
err->code = 0;
err->msg = NULL;
}
PGF_API PGF_API
PgfPGF *pgf_read(const char* fpath, PgfExn* err) PgfPGF *pgf_read(const char* fpath, PgfExn* err)
{ {
PgfPGF *pgf = NULL; PgfPGF *pgf = NULL;
pgf_exn_clear(err);
try { try {
std::string fpath_n = fpath; std::string fpath_n = fpath;
size_t len = fpath_n.length(); size_t len = fpath_n.length();
@@ -30,11 +40,11 @@ PgfPGF *pgf_read(const char* fpath, PgfExn* err)
return pgf; return pgf;
} catch (std::system_error& e) { } catch (std::system_error& e) {
err->type = "system_error"; err->type = PGF_EXN_SYSTEM_ERROR;
err->msg = NULL; err->code = e.code().value();
} catch (pgf_error& e) { } catch (pgf_error& e) {
err->type = "pgf_error"; err->type = PGF_EXN_PGF_ERROR;
err->msg = e.what(); err->msg = strdup(e.what());
} }
if (pgf != NULL) if (pgf != NULL)
@@ -49,3 +59,9 @@ void PgfPGF::set_root() {
root->minor_version = minor_version; root->minor_version = minor_version;
DB::set_root(root); DB::set_root(root);
} }
PGF_API
void pgf_free(PgfPGF *pgf)
{
delete pgf;
}

12
src/runtime/c/pgf.h
View File

@@ -39,12 +39,22 @@
typedef struct PgfPGF PgfPGF; typedef struct PgfPGF PgfPGF;
typedef enum {
PGF_EXN_NONE,
PGF_EXN_SYSTEM_ERROR,
PGF_EXN_PGF_ERROR
} PgfExnType;
typedef struct { typedef struct {
const char *type; PgfExnType type;
int code;
const char *msg; const char *msg;
} PgfExn; } PgfExn;
PGF_API_DECL PGF_API_DECL
PgfPGF *pgf_read(const char* fpath, PgfExn* err); PgfPGF *pgf_read(const char* fpath, PgfExn* err);
PGF_API_DECL
void pgf_free(PgfPGF *pgf);
#endif // PGF_H_ #endif // PGF_H_

279
src/runtime/haskell/PGF.hs
View File

@@ -1,283 +1,6 @@
module PGF (PGF2.PGF, readPGF, showPGF, module PGF (PGF2.PGF, readPGF
abstractName,
CId, mkCId, wildCId, showCId, readCId,
categories, categoryContext, categoryProbability,
functions, functionsByCat, functionType, functionIsDataCon, browse,
PGF2.Expr,Tree,showExpr,PGF2.readExpr,pExpr,pIdent,
mkAbs,unAbs,
mkApp,unApp,unapply,
PGF2.mkStr,PGF2.unStr,
PGF2.mkInt,PGF2.unInt,
PGF2.mkFloat,PGF2.unFloat,
PGF2.mkMeta,PGF2.unMeta,
PGF2.exprSize, exprFunctions,PGF2.exprSubstitute,
compute,
rankTreesByProbs,treeProbability,
TcError, ppTcError, inferExpr, checkType,
PGF2.Type, PGF2.Hypo, showType, showContext, PGF2.readType,
mkType, unType,
PGF2.Token, PGF2.FId,
Language, readLanguage, showLanguage,
languages, startCat, languageCode,
linearize, bracketedLinearize, tabularLinearizes, showBracketedString,
ParseOutput(..), parse, parse_, complete,
PGF2.BracketedString(..), PGF2.flattenBracketedString,
hasLinearization,
showPrintName,
Morpho, buildMorpho,
lookupMorpho, isInMorpho, morphoMissing, morphoKnown, fullFormLexicon,
Labels, getDepLabels, CncLabels, getCncDepLabels,
generateAllDepth, generateRandom, generateRandomFrom, generateRandomDepth, generateRandomFromDepth,
generateFromDepth,
PGF2.GraphvizOptions(..),
graphvizAbstractTree, graphvizParseTree, graphvizAlignment, graphvizDependencyTree, graphvizParseTreeDep,
-- * Tries
ATree(..),Trie(..),toATree,toTrie,
readProbabilitiesFromFile,
groupResults, conlls2latexDoc, gizaAlignment
) where ) where
import qualified PGF2 as PGF2 import qualified PGF2 as PGF2
import qualified PGF2.Internal as PGF2
import qualified Data.Map as Map
import qualified Text.ParserCombinators.ReadP as RP
import Data.List(sortBy)
import Text.PrettyPrint(text)
import Data.Char(isDigit)
newtype CId = CId String deriving (Show,Read,Eq,Ord)
type Language = CId
lookConcr gr (CId lang) =
case Map.lookup lang (PGF2.languages gr) of
Just cnc -> cnc
Nothing -> error "Unknown language"
readPGF = PGF2.readPGF readPGF = PGF2.readPGF
showPGF gr = PGF2.showPGF gr
readLanguage = readCId
showLanguage (CId s) = s
startCat = PGF2.startCat
languageCode pgf lang = Just (PGF2.languageCode (lookConcr pgf lang))
abstractName gr = CId (PGF2.abstractName gr)
categories gr = map CId (PGF2.categories gr)
categoryContext gr (CId c) = PGF2.categoryContext gr c
categoryProbability gr (CId c) = PGF2.categoryProbability gr c
functions gr = map CId (PGF2.functions gr)
functionsByCat gr (CId c) = map CId (PGF2.functionsByCat gr c)
functionType gr (CId f) = PGF2.functionType gr f
functionIsDataCon gr (CId f) = PGF2.functionIsDataCon gr f
type Tree = PGF2.Expr
type Labels = Map.Map CId [String]
type CncLabels = [(String, String -> Maybe (String -> String,String,String))]
mkCId x = CId x
wildCId = CId "_"
showCId (CId x) = x
readCId s = Just (CId s)
showExpr xs e = PGF2.showExpr [x | CId x <- xs] e
pExpr = RP.readS_to_P PGF2.pExpr
pIdent = RP.readS_to_P PGF2.pIdent
mkAbs bind_type (CId var) e = PGF2.mkAbs bind_type var e
unAbs e = case PGF2.unAbs e of
Just (bind_type, var, e) -> Just (bind_type, CId var, e)
Nothing -> Nothing
mkApp (CId f) es = PGF2.mkApp f es
unApp e = case PGF2.unApp e of
Just (f,es) -> Just (CId f,es)
Nothing -> Nothing
unapply = PGF2.unapply
instance Read PGF2.Expr where
readsPrec _ s = case PGF2.readExpr s of
Just e -> [(e,"")]
Nothing -> []
showType xs ty = PGF2.showType [x | CId x <- xs] ty
showContext xs hypos = PGF2.showContext [x | CId x <- xs] hypos
mkType hypos (CId var) es = PGF2.mkType [(bt,var,ty) | (bt,CId var,ty) <- hypos] var es
unType ty = case PGF2.unType ty of
(hypos,var,es) -> ([(bt,CId var,ty) | (bt,var,ty) <- hypos],CId var,es)
linearize pgf lang e = PGF2.linearize (lookConcr pgf lang) e
bracketedLinearize pgf lang e = PGF2.bracketedLinearize (lookConcr pgf lang) e
tabularLinearizes pgf lang e = [PGF2.tabularLinearize (lookConcr pgf lang) e]
showBracketedString = PGF2.showBracketedString
type TcError = String
-- | This data type encodes the different outcomes which you could get from the parser.
data ParseOutput
= ParseFailed Int -- ^ The integer is the position in number of tokens where the parser failed.
| TypeError [(PGF2.FId,TcError)] -- ^ The parsing was successful but none of the trees is type correct.
-- The forest id ('FId') points to the bracketed string from the parser
-- where the type checking failed. More than one error is returned
-- if there are many analizes for some phrase but they all are not type correct.
| ParseOk [Tree] -- ^ If the parsing and the type checking are successful we get a list of abstract syntax trees.
-- The list should be non-empty.
| ParseIncomplete -- ^ The sentence is not complete. Only partial output is produced
parse pgf lang cat s =
case PGF2.parse (lookConcr pgf lang) cat s of
PGF2.ParseOk ts -> map fst ts
_ -> []
parse_ pgf lang cat dp s =
case PGF2.parse (lookConcr pgf lang) cat s of
PGF2.ParseFailed pos _ -> (ParseFailed pos, PGF2.Leaf s)
PGF2.ParseOk ts -> (ParseOk (map fst ts), PGF2.Leaf s)
PGF2.ParseIncomplete -> (ParseIncomplete, PGF2.Leaf s)
complete pgf lang cat s prefix =
let compls = Map.fromListWith (++) [(tok,[CId fun]) | PGF2.ParseOk res <- [PGF2.complete (lookConcr pgf lang) cat s prefix], (tok,_,fun,_) <- res]
in (PGF2.Leaf [],s,compls)
hasLinearization pgf lang (CId f) = PGF2.hasLinearization (lookConcr pgf lang) f
ppTcError s = s
inferExpr gr e =
case PGF2.inferExpr gr e of
Right res -> Right res
Left msg -> Left (text msg)
checkType gr ty =
case PGF2.checkType gr ty of
Right res -> Right res
Left msg -> Left (text msg)
showPrintName pgf lang (CId f) =
case PGF2.printName (lookConcr pgf lang) f of
Just n -> n
Nothing -> f
getDepLabels :: String -> Labels
getDepLabels s = Map.fromList [(mkCId f,ls) | f:ls <- map words (lines s)]
getCncDepLabels :: String -> CncLabels
getCncDepLabels = PGF2.getCncDepLabels
generateAllDepth gr ty _ = map fst (PGF2.generateAll gr ty)
generateFromDepth = error "generateFromDepth is not implemented"
generateRandom = error "generateRandom is not implemented"
generateRandomFrom = error "generateRandomFrom is not implemented"
generateRandomDepth = error "generateRandomDepth is not implemented"
generateRandomFromDepth = error "generateRandomFromDepth is not implemented"
exprFunctions e = [CId f | f <- PGF2.exprFunctions e]
compute = error "compute is not implemented"
-- | rank from highest to lowest probability
rankTreesByProbs :: PGF2.PGF -> [PGF2.Expr] -> [(PGF2.Expr,Double)]
rankTreesByProbs pgf ts = sortBy (\ (_,p) (_,q) -> compare q p)
[(t, realToFrac (PGF2.treeProbability pgf t)) | t <- ts]
treeProbability = PGF2.treeProbability
languages pgf = fmap CId (Map.keys (PGF2.languages pgf))
type Morpho = PGF2.Concr
buildMorpho pgf lang = lookConcr pgf lang
lookupMorpho cnc w = [(CId lemma,an) | (lemma,an,_) <- PGF2.lookupMorpho cnc w]
isInMorpho cnc w = not (null (PGF2.lookupMorpho cnc w))
fullFormLexicon cnc = [(w, [(CId fun,an) | (fun,an,_) <- analyses]) | (w, analyses) <- PGF2.fullFormLexicon cnc]
graphvizAbstractTree pgf (funs,cats) = PGF2.graphvizAbstractTree pgf PGF2.graphvizDefaults{PGF2.noFun=not funs,PGF2.noCat=not cats}
graphvizParseTree pgf lang = PGF2.graphvizParseTree (lookConcr pgf lang)
graphvizAlignment pgf langs = PGF2.graphvizWordAlignment (map (lookConcr pgf) langs) PGF2.graphvizDefaults
graphvizDependencyTree format debug lbls cnclbls pgf lang e =
let to_lbls' lbls = Map.fromList [(id,xs) | (CId id,xs) <- Map.toList lbls]
in PGF2.graphvizDependencyTree format debug (fmap to_lbls' lbls) cnclbls (lookConcr pgf lang) e
graphvizParseTreeDep = error "graphvizParseTreeDep is not implemented"
browse :: PGF2.PGF -> CId -> Maybe (String,[CId],[CId])
browse = error "browse is not implemented"
-- | A type for plain applicative trees
data ATree t = Other t | App CId [ATree t] deriving Show
data Trie = Oth Tree | Ap CId [[Trie ]] deriving Show
-- ^ A type for tries of plain applicative trees
-- | Convert a 'Tree' to an 'ATree'
toATree :: Tree -> ATree Tree
toATree e = maybe (Other e) app (PGF2.unApp e)
where
app (f,es) = App (mkCId f) (map toATree es)
-- | Combine a list of trees into a trie
toTrie = combines . map ((:[]) . singleton)
where
singleton t = case t of
Other e -> Oth e
App f ts -> Ap f [map singleton ts]
combines [] = []
combines (ts:tss) = ts1:combines tss2
where
(ts1,tss2) = combines2 [] tss ts
combines2 ots [] ts1 = (ts1,reverse ots)
combines2 ots (ts2:tss) ts1 =
maybe (combines2 (ts2:ots) tss ts1) (combines2 ots tss) (combine ts1 ts2)
combine ts us = mapM combine2 (zip ts us)
where
combine2 (Ap f ts,Ap g us) | f==g = Just (Ap f (combines (ts++us)))
combine2 _ = Nothing
readProbabilitiesFromFile :: FilePath -> IO (Map.Map CId Double)
readProbabilitiesFromFile fpath = do
s <- readFile fpath
return $ Map.fromList [(mkCId f,read p) | f:p:_ <- map words (lines s)]
groupResults :: [[(Language,String)]] -> [(Language,[String])]
groupResults = Map.toList . foldr more Map.empty . start . concat
where
start ls = [(l,[s]) | (l,s) <- ls]
more (l,s) =
Map.insertWith (\ [x] xs -> if elem x xs then xs else (x : xs)) l s
conlls2latexDoc = error "conlls2latexDoc is not implemented"
morphoMissing :: Morpho -> [String] -> [String]
morphoMissing = morphoClassify False
morphoKnown :: Morpho -> [String] -> [String]
morphoKnown = morphoClassify True
morphoClassify :: Bool -> Morpho -> [String] -> [String]
morphoClassify k mo ws = [w | w <- ws, k /= null (lookupMorpho mo w), notLiteral w] where
notLiteral w = not (all isDigit w) ---- should be defined somewhere
gizaAlignment = error "gizaAlignment is not implemented"

2036
src/runtime/haskell/PGF2.hsc
View File

File diff suppressed because it is too large Load Diff

307
src/runtime/haskell/PGF2/Expr.hsc
View File

@@ -2,310 +2,3 @@
module PGF2.Expr where module PGF2.Expr where
import System.IO.Unsafe(unsafePerformIO)
import Foreign hiding (unsafePerformIO)
import Foreign.C
import Data.IORef
import Data.Data
import PGF2.FFI
import Data.Maybe(fromJust)
type Cat = String -- ^ Name of syntactic category
type Fun = String -- ^ Name of function
data BindType =
Explicit
| Implicit
deriving (Show, Eq, Ord)
-----------------------------------------------------------------------------
-- 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 = Expr {expr :: PgfExpr, touchExpr :: Touch}
instance Show Expr where
show = showExpr []
instance Eq Expr where
(Expr e1 e1_touch) == (Expr e2 e2_touch) =
unsafePerformIO $ do
res <- pgf_expr_eq e1 e2
e1_touch >> e2_touch
return (res /= 0)
instance Data Expr where
gfoldl f z e = z (fromJust . readExpr) `f` (showExpr [] e)
toConstr _ = readExprConstr
gunfold k z c = case constrIndex c of
1 -> k (z (fromJust . readExpr))
_ -> error "gunfold"
dataTypeOf _ = exprDataType
readExprConstr :: Constr
readExprConstr = mkConstr exprDataType "(fromJust . readExpr)" [] Prefix
exprDataType :: DataType
exprDataType = mkDataType "PGF2.Expr" [readExprConstr]
-- | Constructs an expression by lambda abstraction
mkAbs :: BindType -> String -> Expr -> Expr
mkAbs bind_type var (Expr body bodyTouch) =
unsafePerformIO $ do
exprPl <- gu_new_pool
cvar <- newUtf8CString var exprPl
c_expr <- pgf_expr_abs cbind_type cvar body exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr (bodyTouch >> touchForeignPtr exprFPl))
where
cbind_type =
case bind_type of
Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
-- | Decomposes an expression into an abstraction and a body
unAbs :: Expr -> Maybe (BindType, String, Expr)
unAbs (Expr expr touch) =
unsafePerformIO $ do
c_abs <- pgf_expr_unabs expr
if c_abs == nullPtr
then return Nothing
else do bt <- fmap toBindType ((#peek PgfExprAbs, bind_type) c_abs)
var <- (#peek PgfExprAbs, id) c_abs >>= peekUtf8CString
c_body <- (#peek PgfExprAbs, body) c_abs
return (Just (bt, var, Expr c_body touch))
where
toBindType :: CInt -> BindType
toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit
-- | Constructs an expression by applying a function to a list of expressions
mkApp :: Fun -> [Expr] -> Expr
mkApp fun args =
unsafePerformIO $
withCString fun $ \cfun ->
allocaBytes ((#size PgfApplication) + len * sizeOf (undefined :: PgfExpr)) $ \papp -> do
(#poke PgfApplication, fun) papp cfun
(#poke PgfApplication, n_args) papp len
pokeArray (papp `plusPtr` (#offset PgfApplication, args)) (map expr args)
exprPl <- gu_new_pool
c_expr <- pgf_expr_apply papp exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr (mapM_ touchExpr args >> touchForeignPtr exprFPl))
where
len = length args
-- | Decomposes an expression into an application of a function
unApp :: Expr -> Maybe (Fun,[Expr])
unApp (Expr expr touch) =
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 touch | c_arg <- c_args])
-- | Decomposes an expression into an application of a function
unapply :: Expr -> (Expr,[Expr])
unapply (Expr expr touch) =
unsafePerformIO $
withGuPool $ \pl -> do
appl <- pgf_expr_unapply_ex expr pl
efun <- (#peek PgfApplication, efun) appl
arity <- (#peek PgfApplication, n_args) appl :: IO CInt
c_args <- peekArray (fromIntegral arity) (appl `plusPtr` (#offset PgfApplication, args))
return (Expr efun touch, [Expr c_arg touch | c_arg <- c_args])
-- | Constructs an expression from a string literal
mkStr :: String -> Expr
mkStr str =
unsafePerformIO $
withCString str $ \cstr -> do
exprPl <- gu_new_pool
c_expr <- pgf_expr_string cstr exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr (touchForeignPtr exprFPl))
-- | Decomposes an expression into a string literal
unStr :: Expr -> Maybe String
unStr (Expr expr touch) =
unsafePerformIO $ do
plit <- pgf_expr_unlit expr (#const PGF_LITERAL_STR)
if plit == nullPtr
then return Nothing
else do s <- peekUtf8CString (plit `plusPtr` (#offset PgfLiteralStr, val))
touch
return (Just s)
-- | Constructs an expression from an integer literal.
-- Note that the C runtime does not support long integers, and you may run into overflow issues with large values.
-- See [here](https://github.com/GrammaticalFramework/gf-core/issues/109) for more details.
mkInt :: Int -> Expr
mkInt val =
unsafePerformIO $ do
exprPl <- gu_new_pool
c_expr <- pgf_expr_int (fromIntegral val) exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr (touchForeignPtr exprFPl))
-- | Decomposes an expression into an integer literal
unInt :: Expr -> Maybe Int
unInt (Expr expr touch) =
unsafePerformIO $ do
plit <- pgf_expr_unlit expr (#const PGF_LITERAL_INT)
if plit == nullPtr
then return Nothing
else do n <- peek (plit `plusPtr` (#offset PgfLiteralInt, val))
touch
return (Just (fromIntegral (n :: CInt)))
-- | Constructs an expression from a real number
mkFloat :: Double -> Expr
mkFloat val =
unsafePerformIO $ do
exprPl <- gu_new_pool
c_expr <- pgf_expr_float (realToFrac val) exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr (touchForeignPtr exprFPl))
-- | Decomposes an expression into a real number literal
unFloat :: Expr -> Maybe Double
unFloat (Expr expr touch) =
unsafePerformIO $ do
plit <- pgf_expr_unlit expr (#const PGF_LITERAL_FLT)
if plit == nullPtr
then return Nothing
else do n <- peek (plit `plusPtr` (#offset PgfLiteralFlt, val))
touch
return (Just (realToFrac (n :: CDouble)))
-- | Constructs a meta variable as an expression
mkMeta :: Int -> Expr
mkMeta id =
unsafePerformIO $ do
exprPl <- gu_new_pool
c_expr <- pgf_expr_meta (fromIntegral id) exprPl
exprFPl <- newForeignPtr gu_pool_finalizer exprPl
return (Expr c_expr (touchForeignPtr exprFPl))
-- | Decomposes an expression into a meta variable
unMeta :: Expr -> Maybe Int
unMeta (Expr expr touch) =
unsafePerformIO $ do
c_meta <- pgf_expr_unmeta expr
if c_meta == nullPtr
then return Nothing
else do id <- (#peek PgfExprMeta, id) c_meta
touch
return (Just (fromIntegral (id :: CInt)))
-- | parses a 'String' as an expression
readExpr :: String -> Maybe Expr
readExpr str =
unsafePerformIO $
do exprPl <- gu_new_pool
withGuPool $ \tmpPl ->
do c_str <- newUtf8CString str tmpPl
guin <- gu_string_in c_str tmpPl
exn <- gu_new_exn tmpPl
c_expr <- pgf_read_expr guin exprPl tmpPl 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 (touchForeignPtr exprFPl))
else do gu_pool_free exprPl
return Nothing
pIdent :: ReadS String
pIdent str =
unsafePerformIO $
withGuPool $ \tmpPl ->
do ref <- newIORef (str,str,str)
exn <- gu_new_exn tmpPl
c_fetch_char <- wrapParserGetc (fetch_char ref)
c_parser <- pgf_new_parser nullPtr c_fetch_char tmpPl tmpPl exn
c_ident <- pgf_expr_parser_ident c_parser
status <- gu_exn_is_raised exn
if (not status && c_ident /= nullPtr)
then do ident <- peekUtf8CString c_ident
(str,_,_) <- readIORef ref
return [(ident,str)]
else do return []
pExpr :: ReadS Expr
pExpr str =
unsafePerformIO $
do exprPl <- gu_new_pool
withGuPool $ \tmpPl ->
do ref <- newIORef (str,str,str)
exn <- gu_new_exn tmpPl
c_fetch_char <- wrapParserGetc (fetch_char ref)
c_parser <- pgf_new_parser nullPtr c_fetch_char exprPl tmpPl exn
c_expr <- pgf_expr_parser_expr c_parser 1
status <- gu_exn_is_raised exn
if (not status && c_expr /= nullPtr)
then do exprFPl <- newForeignPtr gu_pool_finalizer exprPl
(str,_,_) <- readIORef ref
return [(Expr c_expr (touchForeignPtr exprFPl),str)]
else do gu_pool_free exprPl
return []
fetch_char :: IORef (String,String,String) -> Ptr () -> (#type bool) -> Ptr GuExn -> IO (#type GuUCS)
fetch_char ref _ mark exn = do
(str1,str2,str3) <- readIORef ref
let str1' = if mark /= 0
then str2
else str1
case str3 of
[] -> do writeIORef ref (str1',str3,[])
gu_exn_raise exn gu_exn_type_GuEOF
return (-1)
(c:cs) -> do writeIORef ref (str1',str3,cs)
return ((fromIntegral . fromEnum) c)
foreign import ccall "pgf/expr.h pgf_new_parser"
pgf_new_parser :: Ptr () -> (FunPtr ParserGetc) -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfExprParser)
foreign import ccall "pgf/expr.h pgf_expr_parser_expr"
pgf_expr_parser_expr :: Ptr PgfExprParser -> (#type bool) -> IO PgfExpr
foreign import ccall "pgf/expr.h pgf_expr_parser_ident"
pgf_expr_parser_ident :: Ptr PgfExprParser -> IO CString
type ParserGetc = Ptr () -> (#type bool) -> Ptr GuExn -> IO (#type GuUCS)
foreign import ccall "wrapper"
wrapParserGetc :: ParserGetc -> IO (FunPtr ParserGetc)
-- | renders an expression as a 'String'. The list
-- of identifiers is the list of all free variables
-- in the expression in order reverse to the order
-- of binding.
showExpr :: [String] -> Expr -> String
showExpr scope e =
unsafePerformIO $
withGuPool $ \tmpPl ->
do (sb,out) <- newOut tmpPl
printCtxt <- newPrintCtxt scope tmpPl
exn <- gu_new_exn tmpPl
pgf_print_expr (expr e) printCtxt 1 out exn
touchExpr e
s <- gu_string_buf_freeze sb tmpPl
peekUtf8CString s
newPrintCtxt :: [String] -> Ptr GuPool -> IO (Ptr PgfPrintContext)
newPrintCtxt [] pool = return nullPtr
newPrintCtxt (x:xs) pool = do
pctxt <- gu_malloc pool (#size PgfPrintContext)
newUtf8CString x pool >>= (#poke PgfPrintContext, name) pctxt
newPrintCtxt xs pool >>= (#poke PgfPrintContext, next) pctxt
return pctxt

556
src/runtime/haskell/PGF2/FFI.hsc
View File

@@ -2,568 +2,26 @@
module PGF2.FFI where module PGF2.FFI where
#include <gu/defs.h>
#include <gu/hash.h>
#include <gu/utf8.h>
#include <pgf/pgf.h>
#include <pgf/data.h>
import Foreign ( alloca, peek, poke, peekByteOff )
import Foreign.C import Foreign.C
import Foreign.Ptr import Foreign.Ptr
import Foreign.ForeignPtr import Foreign.ForeignPtr
import Control.Exception
import GHC.Ptr
import Data.Int
import Data.Word
import qualified Data.Map as Map import qualified Data.Map as Map
type Touch = IO ()
-- | An abstract data type representing multilingual grammar -- | An abstract data type representing multilingual grammar
-- in Portable Grammar Format. -- in Portable Grammar Format.
data PGF = PGF {pgf :: Ptr PgfPGF, langs :: Map.Map String Concr, touchPGF :: Touch} data PGF = PGF {a_pgf :: ForeignPtr PgfPGF, langs :: Map.Map String Concr}
data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch} data Concr = Concr {c_pgf :: ForeignPtr PgfPGF, concr :: Ptr PgfConcr}
------------------------------------------------------------------
-- libgu API
data GuEnum
data GuExn
data GuIn
data GuOut
data GuKind
data GuType
data GuStringBuf
data GuMap
data GuMapItor
data GuHasher
data GuSeq
data GuBuf
data GuPool
type GuVariant = Ptr ()
type GuHash = (#type GuHash)
type GuUCS = (#type GuUCS)
type CSizeT = (#type size_t)
type CUInt8 = (#type uint8_t)
foreign import ccall unsafe fopen :: CString -> CString -> IO (Ptr ())
foreign import ccall unsafe "gu/mem.h gu_new_pool"
gu_new_pool :: IO (Ptr GuPool)
foreign import ccall unsafe "gu/mem.h gu_malloc"
gu_malloc :: Ptr GuPool -> CSizeT -> IO (Ptr a)
foreign import ccall unsafe "gu/mem.h gu_malloc_aligned"
gu_malloc_aligned :: Ptr GuPool -> CSizeT -> CSizeT -> IO (Ptr a)
foreign import ccall unsafe "gu/mem.h gu_pool_free"
gu_pool_free :: Ptr GuPool -> IO ()
foreign import ccall unsafe "gu/mem.h &gu_pool_free"
gu_pool_finalizer :: FinalizerPtr GuPool
foreign import ccall unsafe "gu/exn.h gu_new_exn"
gu_new_exn :: Ptr GuPool -> IO (Ptr GuExn)
foreign import ccall unsafe "gu/exn.h gu_exn_is_raised"
gu_exn_is_raised :: Ptr GuExn -> IO Bool
foreign import ccall unsafe "gu/exn.h gu_exn_caught_"
gu_exn_caught :: Ptr GuExn -> CString -> IO Bool
foreign import ccall unsafe "gu/exn.h gu_exn_raise_"
gu_exn_raise :: Ptr GuExn -> CString -> IO (Ptr ())
gu_exn_type_GuErrno = Ptr "GuErrno"## :: CString
gu_exn_type_GuEOF = Ptr "GuEOF"## :: CString
gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"## :: CString
gu_exn_type_PgfExn = Ptr "PgfExn"## :: CString
gu_exn_type_PgfParseError = Ptr "PgfParseError"## :: CString
gu_exn_type_PgfTypeError = Ptr "PgfTypeError"## :: CString
foreign import ccall unsafe "gu/string.h gu_string_in"
gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn)
foreign import ccall unsafe "gu/string.h gu_new_string_buf"
gu_new_string_buf :: Ptr GuPool -> IO (Ptr GuStringBuf)
foreign import ccall unsafe "gu/string.h gu_string_buf_out"
gu_string_buf_out :: Ptr GuStringBuf -> IO (Ptr GuOut)
foreign import ccall unsafe "gu/file.h gu_file_in"
gu_file_in :: Ptr () -> Ptr GuPool -> IO (Ptr GuIn)
foreign import ccall safe "gu/enum.h gu_enum_next"
gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO ()
foreign import ccall unsafe "gu/string.h gu_string_buf_freeze"
gu_string_buf_freeze :: Ptr GuStringBuf -> Ptr GuPool -> IO CString
foreign import ccall unsafe "gu/utf8.h gu_utf8_decode"
gu_utf8_decode :: Ptr CString -> IO GuUCS
foreign import ccall unsafe "gu/utf8.h gu_utf8_encode"
gu_utf8_encode :: GuUCS -> Ptr CString -> IO ()
foreign import ccall unsafe "gu/seq.h gu_make_seq"
gu_make_seq :: CSizeT -> CSizeT -> Ptr GuPool -> IO (Ptr GuSeq)
foreign import ccall unsafe "gu/seq.h gu_make_buf"
gu_make_buf :: CSizeT -> Ptr GuPool -> IO (Ptr GuBuf)
foreign import ccall unsafe "gu/map.h gu_make_map"
gu_make_map :: CSizeT -> Ptr GuHasher -> CSizeT -> Ptr a -> CSizeT -> Ptr GuPool -> IO (Ptr GuMap)
foreign import ccall unsafe "gu/map.h gu_map_insert"
gu_map_insert :: Ptr GuMap -> Ptr a -> IO (Ptr b)
foreign import ccall unsafe "gu/map.h gu_map_find_default"
gu_map_find_default :: Ptr GuMap -> Ptr a -> IO (Ptr b)
foreign import ccall "gu/map.h gu_map_iter"
gu_map_iter :: Ptr GuMap -> Ptr GuMapItor -> Ptr GuExn -> IO ()
foreign import ccall unsafe "gu/hash.h &gu_int_hasher"
gu_int_hasher :: Ptr GuHasher
foreign import ccall unsafe "gu/hash.h &gu_addr_hasher"
gu_addr_hasher :: Ptr GuHasher
foreign import ccall unsafe "gu/hash.h &gu_string_hasher"
gu_string_hasher :: Ptr GuHasher
foreign import ccall unsafe "gu/hash.h &gu_null_struct"
gu_null_struct :: Ptr a
foreign import ccall unsafe "gu/variant.h gu_variant_tag"
gu_variant_tag :: GuVariant -> IO CInt
foreign import ccall unsafe "gu/variant.h gu_variant_data"
gu_variant_data :: GuVariant -> IO (Ptr a)
foreign import ccall unsafe "gu/variant.h gu_alloc_variant"
gu_alloc_variant :: CUInt8 -> CSizeT -> CSizeT -> Ptr GuVariant -> Ptr GuPool -> IO (Ptr a)
withGuPool :: (Ptr GuPool -> IO a) -> IO a
withGuPool f = bracket gu_new_pool gu_pool_free f
newOut :: Ptr GuPool -> IO (Ptr GuStringBuf, Ptr GuOut)
newOut pool =
do sb <- gu_new_string_buf pool
out <- gu_string_buf_out sb
return (sb,out)
peekUtf8CString :: CString -> IO String
peekUtf8CString ptr =
alloca $ \pptr ->
poke pptr ptr >> decode pptr
where
decode pptr = do
x <- gu_utf8_decode pptr
if x == 0
then return []
else do cs <- decode pptr
return (((toEnum . fromEnum) x) : cs)
peekUtf8CStringLen :: CString -> CInt -> IO String
peekUtf8CStringLen ptr len =
alloca $ \pptr ->
poke pptr ptr >> decode pptr (ptr `plusPtr` fromIntegral len)
where
decode pptr end = do
ptr <- peek pptr
if ptr >= end
then return []
else do x <- gu_utf8_decode pptr
cs <- decode pptr end
return (((toEnum . fromEnum) x) : cs)
pokeUtf8CString :: String -> CString -> IO ()
pokeUtf8CString s ptr =
alloca $ \pptr ->
poke pptr ptr >> encode s pptr
where
encode [] pptr = do
gu_utf8_encode 0 pptr
encode (c:cs) pptr = do
gu_utf8_encode ((toEnum . fromEnum) c) pptr
encode cs pptr
newUtf8CString :: String -> Ptr GuPool -> IO CString
newUtf8CString s pool = do
ptr <- gu_malloc pool (fromIntegral (utf8Length s))
pokeUtf8CString s ptr
return ptr
utf8Length s = count 0 s
where
count !c [] = c+1
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
peekSequence peekElem size ptr = do
c_len <- (#peek GuSeq, len) ptr
peekElems (c_len :: CSizeT) (ptr `plusPtr` (#offset GuSeq, data))
where
peekElems 0 ptr = return []
peekElems len ptr = do
e <- peekElem ptr
es <- peekElems (len-1) (ptr `plusPtr` size)
return (e:es)
newSequence :: CSizeT -> (Ptr a -> v -> IO ()) -> [v] -> Ptr GuPool -> IO (Ptr GuSeq)
newSequence elem_size pokeElem values pool = do
c_seq <- gu_make_seq elem_size (fromIntegral (length values)) pool
pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) values
return c_seq
where
pokeElems ptr [] = return ()
pokeElems ptr (x:xs) = do
pokeElem ptr x
pokeElems (ptr `plusPtr` (fromIntegral elem_size)) xs
type FId = Int
data PArg = PArg [(FId,FId)] {-# UNPACK #-} !FId deriving (Eq,Ord,Show)
peekFId :: Ptr a -> IO FId
peekFId c_ccat = do
c_fid <- (#peek PgfCCat, fid) c_ccat
return (fromIntegral (c_fid :: CInt))
deRef peekValue ptr = peek ptr >>= peekValue
------------------------------------------------------------------ ------------------------------------------------------------------
-- libpgf API -- libpgf API
data PgfExn
data PgfPGF data PgfPGF
data PgfApplication
data PgfConcr data PgfConcr
type PgfExpr = Ptr ()
data PgfExprProb
data PgfTokenProb
data PgfExprParser
data PgfFullFormEntry
data PgfMorphoCallback
data PgfPrintContext
type PgfType = Ptr ()
data PgfCallbacksMap
data PgfOracleCallback
data PgfCncTree
data PgfLinFuncs
data PgfGraphvizOptions
type PgfBindType = (#type PgfBindType)
data PgfAbsFun
data PgfAbsCat
data PgfCCat
data PgfCncFun
data PgfProductionApply
data PgfParsing
foreign import ccall "pgf/pgf.h pgf_read" foreign import ccall "pgf.h pgf_read"
pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF) pgf_read :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
foreign import ccall "pgf/pgf.h pgf_write" foreign import ccall "&pgf_free"
pgf_write :: Ptr PgfPGF -> CSizeT -> Ptr (Ptr PgfConcr) -> CString -> Ptr GuExn -> IO () pgf_free_fptr :: FinalizerPtr PgfPGF
foreign import ccall "pgf/writer.h pgf_concrete_save"
pgf_concrete_save :: Ptr PgfConcr -> CString -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_have_same_abstract"
pgf_have_same_abstract :: Ptr PgfPGF -> Ptr PgfPGF -> (#type bool)
foreign import ccall "pgf/pgf.h pgf_abstract_name"
pgf_abstract_name :: Ptr PgfPGF -> IO CString
foreign import ccall "pgf/pgf.h pgf_iter_languages"
pgf_iter_languages :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_get_language"
pgf_get_language :: Ptr PgfPGF -> CString -> IO (Ptr PgfConcr)
foreign import ccall "pgf/pgf.h pgf_concrete_name"
pgf_concrete_name :: Ptr PgfConcr -> IO CString
foreign import ccall "pgf/pgf.h pgf_concrete_load"
pgf_concrete_load :: Ptr PgfConcr -> Ptr GuIn -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_concrete_unload"
pgf_concrete_unload :: Ptr PgfConcr -> IO ()
foreign import ccall "pgf/pgf.h pgf_language_code"
pgf_language_code :: Ptr PgfConcr -> IO CString
foreign import ccall "pgf/pgf.h pgf_iter_categories"
pgf_iter_categories :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_concrete_fix_internals"
pgf_concrete_fix_internals :: Ptr PgfConcr -> IO ()
foreign import ccall "pgf/pgf.h pgf_start_cat"
pgf_start_cat :: Ptr PgfPGF -> Ptr GuPool -> IO PgfType
foreign import ccall "pgf/pgf.h pgf_category_context"
pgf_category_context :: Ptr PgfPGF -> CString -> IO (Ptr GuSeq)
foreign import ccall "pgf/pgf.h pgf_category_prob"
pgf_category_prob :: Ptr PgfPGF -> CString -> IO (#type prob_t)
foreign import ccall "pgf/pgf.h pgf_category_fields"
pgf_category_fields :: Ptr PgfConcr -> CString -> Ptr CSize -> IO (Ptr CString)
foreign import ccall "pgf/pgf.h pgf_iter_functions"
pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat"
pgf_iter_functions_by_cat :: Ptr PgfPGF -> CString -> Ptr GuMapItor -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_function_type"
pgf_function_type :: Ptr PgfPGF -> CString -> IO PgfType
foreign import ccall "pgf/expr.h pgf_function_is_constructor"
pgf_function_is_constructor :: Ptr PgfPGF -> CString -> IO (#type bool)
foreign import ccall "pgf/pgf.h pgf_print_name"
pgf_print_name :: Ptr PgfConcr -> CString -> IO CString
foreign import ccall "pgf/pgf.h pgf_has_linearization"
pgf_has_linearization :: Ptr PgfConcr -> CString -> IO CInt
foreign import ccall "pgf/pgf.h pgf_linearize"
pgf_linearize :: Ptr PgfConcr -> PgfExpr -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_lzr_concretize"
pgf_lzr_concretize :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuEnum)
foreign import ccall "pgf/pgf.h pgf_lzr_wrap_linref"
pgf_lzr_wrap_linref :: Ptr PgfCncTree -> Ptr GuPool -> IO (Ptr PgfCncTree)
foreign import ccall "pgf/pgf.h pgf_lzr_linearize_simple"
pgf_lzr_linearize_simple :: Ptr PgfConcr -> Ptr PgfCncTree -> CSizeT -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO ()
foreign import ccall "pgf/pgf.h pgf_lzr_linearize"
pgf_lzr_linearize :: Ptr PgfConcr -> Ptr PgfCncTree -> CSizeT -> Ptr (Ptr PgfLinFuncs) -> Ptr GuPool -> IO ()
foreign import ccall "pgf/pgf.h pgf_lzr_get_table"
pgf_lzr_get_table :: Ptr PgfConcr -> Ptr PgfCncTree -> Ptr CSizeT -> Ptr (Ptr CString) -> IO ()
type SymbolTokenCallback = Ptr (Ptr PgfLinFuncs) -> CString -> IO ()
type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CString -> CString -> IO ()
type NonExistCallback = Ptr (Ptr PgfLinFuncs) -> IO ()
type BindCallback = Ptr (Ptr PgfLinFuncs) -> IO ()
type MetaCallback = Ptr (Ptr PgfLinFuncs) -> CInt -> IO ()
foreign import ccall "wrapper"
wrapSymbolTokenCallback :: SymbolTokenCallback -> IO (FunPtr SymbolTokenCallback)
foreign import ccall "wrapper"
wrapPhraseCallback :: PhraseCallback -> IO (FunPtr PhraseCallback)
foreign import ccall "wrapper"
wrapSymbolNonExistCallback :: NonExistCallback -> IO (FunPtr NonExistCallback)
foreign import ccall "wrapper"
wrapSymbolBindCallback :: BindCallback -> IO (FunPtr BindCallback)
foreign import ccall "wrapper"
wrapSymbolMetaCallback :: MetaCallback -> IO (FunPtr MetaCallback)
foreign import ccall "pgf/pgf.h pgf_align_words"
pgf_align_words :: Ptr PgfConcr -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuSeq)
foreign import ccall "pgf/pgf.h pgf_parse_to_chart"
pgf_parse_to_chart :: Ptr PgfConcr -> PgfType -> CString -> Double -> Ptr PgfCallbacksMap -> CSizeT -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr PgfParsing)
foreign import ccall "pgf/pgf.h pgf_get_parse_roots"
pgf_get_parse_roots :: Ptr PgfParsing -> Ptr GuPool -> IO (Ptr GuSeq)
foreign import ccall "pgf/pgf.h pgf_ccat_to_range"
pgf_ccat_to_range :: Ptr PgfParsing -> Ptr PgfCCat -> Ptr GuPool -> IO (Ptr GuSeq)
foreign import ccall "pgf/pgf.h pgf_parse_with_heuristics"
pgf_parse_with_heuristics :: Ptr PgfConcr -> PgfType -> CString -> Double -> Ptr PgfCallbacksMap -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
foreign import ccall "pgf/pgf.h pgf_lookup_sentence"
pgf_lookup_sentence :: Ptr PgfConcr -> PgfType -> CString -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
type LiteralMatchCallback = CString -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb)
foreign import ccall "wrapper"
wrapLiteralMatchCallback :: LiteralMatchCallback -> IO (FunPtr LiteralMatchCallback)
type LiteralPredictCallback = CString -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb)
foreign import ccall "wrapper"
wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback)
foreign import ccall "pgf/pgf.h pgf_new_callbacks_map"
pgf_new_callbacks_map :: Ptr PgfConcr -> Ptr GuPool -> IO (Ptr PgfCallbacksMap)
foreign import ccall
hspgf_callbacks_map_add_literal :: Ptr PgfConcr -> Ptr PgfCallbacksMap -> CString -> FunPtr LiteralMatchCallback -> FunPtr LiteralPredictCallback -> Ptr GuPool -> IO ()
type OracleCallback = CString -> CString -> CSizeT -> IO Bool
type OracleLiteralCallback = CString -> CString -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb)
foreign import ccall "wrapper"
wrapOracleCallback :: OracleCallback -> IO (FunPtr OracleCallback)
foreign import ccall "wrapper"
wrapOracleLiteralCallback :: OracleLiteralCallback -> IO (FunPtr OracleLiteralCallback)
foreign import ccall
hspgf_new_oracle_callback :: CString -> FunPtr OracleCallback -> FunPtr OracleCallback -> FunPtr OracleLiteralCallback -> Ptr GuPool -> IO (Ptr PgfOracleCallback)
foreign import ccall "pgf/pgf.h pgf_parse_with_oracle"
pgf_parse_with_oracle :: Ptr PgfConcr -> CString -> CString -> Ptr PgfOracleCallback -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
foreign import ccall "pgf/pgf.h pgf_complete"
pgf_complete :: Ptr PgfConcr -> PgfType -> CString -> CString -> Ptr GuExn -> Ptr GuPool -> IO (Ptr GuEnum)
foreign import ccall "pgf/pgf.h pgf_lookup_morpho"
pgf_lookup_morpho :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_lookup_cohorts"
pgf_lookup_cohorts :: Ptr PgfConcr -> CString -> Ptr PgfMorphoCallback -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuEnum)
type LookupMorphoCallback = Ptr PgfMorphoCallback -> CString -> CString -> Float -> Ptr GuExn -> IO ()
foreign import ccall "wrapper"
wrapLookupMorphoCallback :: LookupMorphoCallback -> IO (FunPtr LookupMorphoCallback)
type MapItorCallback = Ptr GuMapItor -> Ptr () -> Ptr () -> Ptr GuExn -> IO ()
foreign import ccall "wrapper"
wrapMapItorCallback :: MapItorCallback -> IO (FunPtr MapItorCallback)
foreign import ccall "pgf/pgf.h pgf_fullform_lexicon"
pgf_fullform_lexicon :: Ptr PgfConcr -> Ptr GuPool -> IO (Ptr GuEnum)
foreign import ccall "pgf/pgf.h pgf_fullform_get_string"
pgf_fullform_get_string :: Ptr PgfFullFormEntry -> IO CString
foreign import ccall "pgf/pgf.h pgf_fullform_get_analyses"
pgf_fullform_get_analyses :: Ptr PgfFullFormEntry -> Ptr PgfMorphoCallback -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_expr_apply"
pgf_expr_apply :: Ptr PgfApplication -> Ptr GuPool -> IO PgfExpr
foreign import ccall "pgf/pgf.h pgf_expr_unapply"
pgf_expr_unapply :: PgfExpr -> Ptr GuPool -> IO (Ptr PgfApplication)
foreign import ccall "pgf/pgf.h pgf_expr_unapply_ex"
pgf_expr_unapply_ex :: PgfExpr -> Ptr GuPool -> IO (Ptr PgfApplication)
foreign import ccall "pgf/pgf.h pgf_expr_abs"
pgf_expr_abs :: PgfBindType -> CString -> PgfExpr -> Ptr GuPool -> IO PgfExpr
foreign import ccall "pgf/pgf.h pgf_expr_unabs"
pgf_expr_unabs :: PgfExpr -> IO (Ptr a)
foreign import ccall "pgf/pgf.h pgf_expr_meta"
pgf_expr_meta :: CInt -> Ptr GuPool -> IO PgfExpr
foreign import ccall "pgf/pgf.h pgf_expr_unmeta"
pgf_expr_unmeta :: PgfExpr -> IO (Ptr a)
foreign import ccall "pgf/pgf.h pgf_expr_string"
pgf_expr_string :: CString -> Ptr GuPool -> IO PgfExpr
foreign import ccall "pgf/pgf.h pgf_expr_int"
pgf_expr_int :: CInt -> Ptr GuPool -> IO PgfExpr
foreign import ccall "pgf/pgf.h pgf_expr_float"
pgf_expr_float :: CDouble -> Ptr GuPool -> IO PgfExpr
foreign import ccall "pgf/pgf.h pgf_expr_unlit"
pgf_expr_unlit :: PgfExpr -> CInt -> IO (Ptr a)
foreign import ccall "pgf/expr.h pgf_expr_eq"
pgf_expr_eq :: PgfExpr -> PgfExpr -> IO CInt
foreign import ccall "pgf/expr.h pgf_type_eq"
pgf_type_eq :: PgfType -> PgfType -> IO (#type bool)
foreign import ccall "pgf/expr.h pgf_expr_hash"
pgf_expr_hash :: GuHash -> PgfExpr -> IO GuHash
foreign import ccall "pgf/expr.h pgf_expr_size"
pgf_expr_size :: PgfExpr -> IO CInt
foreign import ccall "pgf/expr.h pgf_expr_functions"
pgf_expr_functions :: PgfExpr -> Ptr GuPool -> IO (Ptr GuSeq)
foreign import ccall "pgf/expr.h pgf_expr_substitute"
pgf_expr_substitute :: PgfExpr -> Ptr GuSeq -> Ptr GuPool -> IO PgfExpr
foreign import ccall "pgf/expr.h pgf_compute_tree_probability"
pgf_compute_tree_probability :: Ptr PgfPGF -> PgfExpr -> IO CFloat
foreign import ccall "pgf/expr.h pgf_check_expr"
pgf_check_expr :: Ptr PgfPGF -> Ptr PgfExpr -> PgfType -> Ptr GuExn -> Ptr GuPool -> IO ()
foreign import ccall "pgf/expr.h pgf_infer_expr"
pgf_infer_expr :: Ptr PgfPGF -> Ptr PgfExpr -> Ptr GuExn -> Ptr GuPool -> IO PgfType
foreign import ccall "pgf/expr.h pgf_check_type"
pgf_check_type :: Ptr PgfPGF -> Ptr PgfType -> Ptr GuExn -> Ptr GuPool -> IO ()
foreign import ccall "pgf/expr.h pgf_compute"
pgf_compute :: Ptr PgfPGF -> PgfExpr -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO PgfExpr
foreign import ccall "pgf/expr.h pgf_print_expr"
pgf_print_expr :: PgfExpr -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/expr.h pgf_print_type"
pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/expr.h pgf_print_context"
pgf_print_context :: Ptr GuSeq -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/pgf.h pgf_generate_all"
pgf_generate_all :: Ptr PgfPGF -> PgfType -> Ptr GuExn -> Ptr GuPool -> Ptr GuPool -> IO (Ptr GuEnum)
foreign import ccall "pgf/pgf.h pgf_print"
pgf_print :: Ptr PgfPGF -> CSizeT -> Ptr (Ptr PgfConcr) -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/expr.h pgf_read_expr"
pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr
foreign import ccall "pgf/expr.h pgf_read_type"
pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfType
foreign import ccall "pgf/graphviz.h pgf_graphviz_abstract_tree"
pgf_graphviz_abstract_tree :: Ptr PgfPGF -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/graphviz.h pgf_graphviz_parse_tree"
pgf_graphviz_parse_tree :: Ptr PgfConcr -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/graphviz.h pgf_graphviz_word_alignment"
pgf_graphviz_word_alignment :: Ptr (Ptr PgfConcr) -> CSizeT -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/data.h pgf_parser_index"
pgf_parser_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO ()
foreign import ccall "pgf/data.h pgf_lzr_index"
pgf_lzr_index :: Ptr PgfConcr -> Ptr PgfCCat -> GuVariant -> (#type bool) -> Ptr GuPool -> IO ()
foreign import ccall "pgf/data.h pgf_production_is_lexical"
pgf_production_is_lexical :: Ptr PgfProductionApply -> Ptr GuBuf -> Ptr GuPool -> IO (#type bool)
foreign import ccall "pgf/expr.h pgf_clone_expr"
pgf_clone_expr :: PgfExpr -> Ptr GuPool -> IO PgfExpr

1033
src/runtime/haskell/PGF2/Internal.hsc
View File

File diff suppressed because it is too large Load Diff

145
src/runtime/haskell/PGF2/Type.hsc
View File

@@ -1,148 +1,3 @@
#include <pgf/pgf.h> #include <pgf/pgf.h>
module PGF2.Type where module PGF2.Type where
import System.IO.Unsafe(unsafePerformIO)
import Foreign hiding (unsafePerformIO)
import Foreign.C
import qualified Text.PrettyPrint as PP
import Data.List(mapAccumL)
import PGF2.Expr
import PGF2.FFI
-- 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 Type = Type {typ :: PgfExpr, touchType :: Touch}
-- | 'Hypo' represents a hypothesis in a type i.e. in the type A -> B, A is the hypothesis
type Hypo = (BindType,String,Type)
instance Show Type where
show = showType []
instance Eq Type where
(Type ty1 ty1_touch) == (Type ty2 ty2_touch) =
unsafePerformIO $ do
res <- pgf_type_eq ty1 ty2
ty1_touch >> ty2_touch
return (res /= 0)
-- | parses a 'String' as a type
readType :: String -> Maybe Type
readType str =
unsafePerformIO $
do typPl <- gu_new_pool
withGuPool $ \tmpPl ->
do c_str <- newUtf8CString str tmpPl
guin <- gu_string_in c_str tmpPl
exn <- gu_new_exn tmpPl
c_type <- pgf_read_type guin typPl tmpPl exn
status <- gu_exn_is_raised exn
if (not status && c_type /= nullPtr)
then do typFPl <- newForeignPtr gu_pool_finalizer typPl
return $ Just (Type c_type (touchForeignPtr typFPl))
else do gu_pool_free typPl
return Nothing
-- | renders a type as a 'String'. The list
-- of identifiers is the list of all free variables
-- in the type in order reverse to the order
-- of binding.
showType :: [String] -> Type -> String
showType scope (Type ty touch) =
unsafePerformIO $
withGuPool $ \tmpPl ->
do (sb,out) <- newOut tmpPl
printCtxt <- newPrintCtxt scope tmpPl
exn <- gu_new_exn tmpPl
pgf_print_type ty printCtxt 0 out exn
touch
s <- gu_string_buf_freeze sb tmpPl
peekUtf8CString s
-- | creates a type from a list of hypothesises, a category and
-- a list of arguments for the category. The operation
-- @mkType [h_1,...,h_n] C [e_1,...,e_m]@ will create
-- @h_1 -> ... -> h_n -> C e_1 ... e_m@
mkType :: [Hypo] -> String -> [Expr] -> Type
mkType hypos cat exprs = unsafePerformIO $ do
typPl <- gu_new_pool
let n_exprs = fromIntegral (length exprs) :: CSizeT
c_type <- gu_malloc typPl ((#size PgfType) + n_exprs * (#size PgfExpr))
c_hypos <- newSequence (#size PgfHypo) (pokeHypo typPl) hypos typPl
(#poke PgfType, hypos) c_type c_hypos
ccat <- newUtf8CString cat typPl
(#poke PgfType, cid) c_type ccat
(#poke PgfType, n_exprs) c_type n_exprs
pokeExprs (c_type `plusPtr` (#offset PgfType, exprs)) exprs
typFPl <- newForeignPtr gu_pool_finalizer typPl
return (Type c_type (mapM_ touchHypo hypos >> mapM_ touchExpr exprs >> touchForeignPtr typFPl))
pokeHypo :: Ptr GuPool -> Ptr a -> Hypo -> IO ()
pokeHypo pool c_hypo (bind_type,cid,Type c_ty _) = do
(#poke PgfHypo, bind_type) c_hypo cbind_type
newUtf8CString cid pool >>= (#poke PgfHypo, cid) c_hypo
(#poke PgfHypo, type) c_hypo c_ty
where
cbind_type :: CInt
cbind_type =
case bind_type of
Explicit -> (#const PGF_BIND_TYPE_EXPLICIT)
Implicit -> (#const PGF_BIND_TYPE_IMPLICIT)
pokeExprs ptr [] = return ()
pokeExprs ptr ((Expr e _):es) = do
poke ptr e
pokeExprs (plusPtr ptr (#size PgfExpr)) es
touchHypo (_,_,ty) = touchType ty
-- | Decomposes a type into a list of hypothesises, a category and
-- a list of arguments for the category.
unType :: Type -> ([Hypo],String,[Expr])
unType (Type c_type touch) = unsafePerformIO $ do
cid <- (#peek PgfType, cid) c_type >>= peekUtf8CString
c_hypos <- (#peek PgfType, hypos) c_type
n_hypos <- (#peek GuSeq, len) c_hypos
hs <- peekHypos (c_hypos `plusPtr` (#offset GuSeq, data)) 0 n_hypos
n_exprs <- (#peek PgfType, n_exprs) c_type
es <- peekExprs (c_type `plusPtr` (#offset PgfType, exprs)) 0 n_exprs
return (hs,cid,es)
where
peekHypos :: Ptr a -> Int -> Int -> IO [Hypo]
peekHypos c_hypo i n
| i < n = do cid <- (#peek PgfHypo, cid) c_hypo >>= peekUtf8CString
c_ty <- (#peek PgfHypo, type) c_hypo
bt <- fmap toBindType ((#peek PgfHypo, bind_type) c_hypo)
hs <- peekHypos (plusPtr c_hypo (#size PgfHypo)) (i+1) n
return ((bt,cid,Type c_ty touch) : hs)
| otherwise = return []
toBindType :: CInt -> BindType
toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit
peekExprs ptr i n
| i < n = do e <- peekElemOff ptr i
es <- peekExprs ptr (i+1) n
return (Expr e touch : es)
| otherwise = return []
-- | renders a type as a 'String'. The list
-- of identifiers is the list of all free variables
-- in the type in order reverse to the order
-- of binding.
showContext :: [String] -> [Hypo] -> String
showContext scope hypos =
unsafePerformIO $
withGuPool $ \tmpPl ->
do (sb,out) <- newOut tmpPl
c_hypos <- newSequence (#size PgfHypo) (pokeHypo tmpPl) hypos tmpPl
printCtxt <- newPrintCtxt scope tmpPl
exn <- gu_new_exn tmpPl
pgf_print_context c_hypos printCtxt out exn
mapM_ touchHypo hypos
s <- gu_string_buf_freeze sb tmpPl
peekUtf8CString s

2
src/runtime/haskell/pgf2.cabal
View File

@@ -23,7 +23,7 @@ library
default-language: Haskell2010 default-language: Haskell2010
build-tools: hsc2hs build-tools: hsc2hs
extra-libraries: sg pgf gu extra-libraries: pgf
cc-options: -std=c99 cc-options: -std=c99
default-language: Haskell2010 default-language: Haskell2010
c-sources: utils.c c-sources: utils.c