mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 04:59:31 -06:00
started on the Haskell binding
This commit is contained in:
krangelov
@@ -1,11 +1,21 @@
|
||||
#include "data.h"
|
||||
#include "reader.h"
|
||||
|
||||
static void
|
||||
pgf_exn_clear(PgfExn* err)
|
||||
{
|
||||
err->type = PGF_EXN_NONE;
|
||||
err->code = 0;
|
||||
err->msg = NULL;
|
||||
}
|
||||
|
||||
PGF_API
|
||||
PgfPGF *pgf_read(const char* fpath, PgfExn* err)
|
||||
{
|
||||
PgfPGF *pgf = NULL;
|
||||
|
||||
pgf_exn_clear(err);
|
||||
|
||||
try {
|
||||
std::string fpath_n = fpath;
|
||||
size_t len = fpath_n.length();
|
||||
@@ -30,11 +40,11 @@ PgfPGF *pgf_read(const char* fpath, PgfExn* err)
|
||||
|
||||
return pgf;
|
||||
} catch (std::system_error& e) {
|
||||
err->type = "system_error";
|
||||
err->msg = NULL;
|
||||
err->type = PGF_EXN_SYSTEM_ERROR;
|
||||
err->code = e.code().value();
|
||||
} catch (pgf_error& e) {
|
||||
err->type = "pgf_error";
|
||||
err->msg = e.what();
|
||||
err->type = PGF_EXN_PGF_ERROR;
|
||||
err->msg = strdup(e.what());
|
||||
}
|
||||
|
||||
if (pgf != NULL)
|
||||
@@ -49,3 +59,9 @@ void PgfPGF::set_root() {
|
||||
root->minor_version = minor_version;
|
||||
DB::set_root(root);
|
||||
}
|
||||
|
||||
PGF_API
|
||||
void pgf_free(PgfPGF *pgf)
|
||||
{
|
||||
delete pgf;
|
||||
}
|
||||
|
||||
@@ -39,12 +39,22 @@
|
||||
|
||||
typedef struct PgfPGF PgfPGF;
|
||||
|
||||
typedef enum {
|
||||
PGF_EXN_NONE,
|
||||
PGF_EXN_SYSTEM_ERROR,
|
||||
PGF_EXN_PGF_ERROR
|
||||
} PgfExnType;
|
||||
|
||||
typedef struct {
|
||||
const char *type;
|
||||
PgfExnType type;
|
||||
int code;
|
||||
const char *msg;
|
||||
} PgfExn;
|
||||
|
||||
PGF_API_DECL
|
||||
PgfPGF *pgf_read(const char* fpath, PgfExn* err);
|
||||
|
||||
PGF_API_DECL
|
||||
void pgf_free(PgfPGF *pgf);
|
||||
|
||||
#endif // PGF_H_
|
||||
|
||||
@@ -1,283 +1,6 @@
|
||||
module PGF (PGF2.PGF, readPGF, showPGF,
|
||||
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
|
||||
module PGF (PGF2.PGF, readPGF
|
||||
) where
|
||||
|
||||
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
|
||||
|
||||
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"
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -2,310 +2,3 @@
|
||||
|
||||
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
|
||||
|
||||
@@ -2,568 +2,26 @@
|
||||
|
||||
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.Ptr
|
||||
import Foreign.ForeignPtr
|
||||
import Control.Exception
|
||||
import GHC.Ptr
|
||||
import Data.Int
|
||||
import Data.Word
|
||||
import qualified Data.Map as Map
|
||||
|
||||
type Touch = IO ()
|
||||
|
||||
-- | An abstract data type representing multilingual grammar
|
||||
-- in Portable Grammar Format.
|
||||
data PGF = PGF {pgf :: Ptr PgfPGF, langs :: Map.Map String Concr, touchPGF :: Touch}
|
||||
data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch}
|
||||
|
||||
------------------------------------------------------------------
|
||||
-- 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
|
||||
data PGF = PGF {a_pgf :: ForeignPtr PgfPGF, langs :: Map.Map String Concr}
|
||||
data Concr = Concr {c_pgf :: ForeignPtr PgfPGF, concr :: Ptr PgfConcr}
|
||||
|
||||
------------------------------------------------------------------
|
||||
-- libpgf API
|
||||
|
||||
data PgfExn
|
||||
data PgfPGF
|
||||
data PgfApplication
|
||||
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"
|
||||
pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF)
|
||||
foreign import ccall "pgf.h pgf_read"
|
||||
pgf_read :: CString -> Ptr PgfExn -> IO (Ptr PgfPGF)
|
||||
|
||||
foreign import ccall "pgf/pgf.h pgf_write"
|
||||
pgf_write :: Ptr PgfPGF -> CSizeT -> Ptr (Ptr PgfConcr) -> CString -> Ptr GuExn -> IO ()
|
||||
foreign import ccall "&pgf_free"
|
||||
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
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -1,148 +1,3 @@
|
||||
#include <pgf/pgf.h>
|
||||
|
||||
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
|
||||
|
||||
@@ -23,7 +23,7 @@ library
|
||||
default-language: Haskell2010
|
||||
build-tools: hsc2hs
|
||||
|
||||
extra-libraries: sg pgf gu
|
||||
extra-libraries: pgf
|
||||
cc-options: -std=c99
|
||||
default-language: Haskell2010
|
||||
c-sources: utils.c
|
||||
|
||||
Reference in New Issue
Block a user