diff options
Diffstat (limited to 'src/runtime')
51 files changed, 3360 insertions, 554 deletions
diff --git a/src/runtime/c/Makefile.am b/src/runtime/c/Makefile.am index 9f6ce9a76..edc4f88b2 100644 --- a/src/runtime/c/Makefile.am +++ b/src/runtime/c/Makefile.am @@ -34,7 +34,8 @@ pgfinclude_HEADERS = \ pgf/linearizer.h \ pgf/literals.h \ pgf/graphviz.h \ - pgf/pgf.h + pgf/pgf.h \ + pgf/data.h sgincludedir=$(includedir)/sg sginclude_HEADERS = \ @@ -75,6 +76,8 @@ libpgf_la_SOURCES = \ pgf/literals.h \ pgf/reader.h \ pgf/reader.c \ + pgf/writer.h \ + pgf/writer.c \ pgf/linearizer.c \ pgf/typechecker.c \ pgf/reasoner.c \ diff --git a/src/runtime/c/gu/bits.c b/src/runtime/c/gu/bits.c index 8c43b8477..b5696a19c 100644 --- a/src/runtime/c/gu/bits.c +++ b/src/runtime/c/gu/bits.c @@ -41,3 +41,36 @@ gu_decode_double(uint64_t u) } return sign ? copysign(ret, -1.0) : ret; } + +GU_INTERNAL uint64_t +gu_encode_double(double d) +{ + int sign = signbit(d) > 0; + unsigned rawexp; + uint64_t mantissa; + + switch (fpclassify(d)) { + case FP_NAN: + rawexp = 0x7ff; + mantissa = 1; + break; + case FP_INFINITE: + rawexp = 0x7ff; + mantissa = 0; + break; + default: { + int exp; + mantissa = (uint64_t) scalbn(frexp(d, &exp), 53); + mantissa &= ~ (1ULL << 52); + exp -= 53; + + rawexp = exp + 1075; + } + } + + uint64_t u = (((uint64_t) sign) << 63) | + (((uint64_t) rawexp & 0x7ff) << 52) | + mantissa; + + return u; +} diff --git a/src/runtime/c/gu/bits.h b/src/runtime/c/gu/bits.h index edf6a0049..ee619f400 100644 --- a/src/runtime/c/gu/bits.h +++ b/src/runtime/c/gu/bits.h @@ -144,6 +144,7 @@ gu_decode_2c64(uint64_t u, GuExn* err) GU_INTERNAL_DECL double gu_decode_double(uint64_t u); - +GU_INTERNAL_DECL uint64_t +gu_encode_double(double d); #endif // GU_BITS_H_ diff --git a/src/runtime/c/gu/defs.h b/src/runtime/c/gu/defs.h index 6b531979c..f5472a414 100644 --- a/src/runtime/c/gu/defs.h +++ b/src/runtime/c/gu/defs.h @@ -23,6 +23,14 @@ #define restrict __restrict +#elif defined(__MINGW32__) + +#define GU_API_DECL +#define GU_API + +#define GU_INTERNAL_DECL +#define GU_INTERNAL + #else #define GU_API_DECL @@ -30,7 +38,9 @@ #define GU_INTERNAL_DECL __attribute__ ((visibility ("hidden"))) #define GU_INTERNAL __attribute__ ((visibility ("hidden"))) + #endif + // end MSVC workaround #include <stddef.h> diff --git a/src/runtime/c/gu/in.c b/src/runtime/c/gu/in.c index b36df7924..c241d3086 100644 --- a/src/runtime/c/gu/in.c +++ b/src/runtime/c/gu/in.c @@ -152,7 +152,7 @@ gu_in_le(GuIn* in, GuExn* err, int n) uint8_t buf[8]; gu_in_bytes(in, buf, n, err); uint64_t u = 0; - for (int i = 0; i < n; i++) { + for (int i = n-1; i >= 0; i--) { u = u << 8 | buf[i]; } return u; @@ -246,7 +246,7 @@ gu_in_f64le(GuIn* in, GuExn* err) GU_API double gu_in_f64be(GuIn* in, GuExn* err) { - return gu_decode_double(gu_in_u64le(in, err)); + return gu_decode_double(gu_in_u64be(in, err)); } static void diff --git a/src/runtime/c/gu/out.c b/src/runtime/c/gu/out.c index 7a287cadb..164f483d1 100644 --- a/src/runtime/c/gu/out.c +++ b/src/runtime/c/gu/out.c @@ -1,6 +1,7 @@ #include <gu/seq.h> #include <gu/out.h> #include <gu/utf8.h> +#include <gu/bits.h> #include <stdio.h> static bool @@ -168,8 +169,31 @@ gu_out_is_buffered(GuOut* out); extern inline bool gu_out_try_u8_(GuOut* restrict out, uint8_t u); +GU_API void +gu_out_u16be(GuOut* out, uint16_t u, GuExn* err) +{ + gu_out_u8(out, (u>>8) & 0xFF, err); + gu_out_u8(out, u & 0xFF, err); +} +GU_API void +gu_out_u64be(GuOut* out, uint64_t u, GuExn* err) +{ + gu_out_u8(out, (u>>56) & 0xFF, err); + gu_out_u8(out, (u>>48) & 0xFF, err); + gu_out_u8(out, (u>>40) & 0xFF, err); + gu_out_u8(out, (u>>32) & 0xFF, err); + gu_out_u8(out, (u>>24) & 0xFF, err); + gu_out_u8(out, (u>>16) & 0xFF, err); + gu_out_u8(out, (u>>8) & 0xFF, err); + gu_out_u8(out, u & 0xFF, err); +} +GU_API void +gu_out_f64be(GuOut* out, double d, GuExn* err) +{ + gu_out_u64be(out, gu_encode_double(d), err); +} typedef struct GuBufferedOutStream GuBufferedOutStream; diff --git a/src/runtime/c/pgf/aligner.c b/src/runtime/c/pgf/aligner.c index d143850d6..53209bb4c 100644 --- a/src/runtime/c/pgf/aligner.c +++ b/src/runtime/c/pgf/aligner.c @@ -142,14 +142,14 @@ pgf_aligner_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok) } static void -pgf_aligner_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_aligner_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfAlignerLin* alin = gu_container(funcs, PgfAlignerLin, funcs); gu_buf_push(alin->parent_stack, int, fid); } static void -pgf_aligner_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_aligner_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfAlignerLin* alin = gu_container(funcs, PgfAlignerLin, funcs); gu_buf_pop(alin->parent_stack, int); diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index 83aff155f..45685c82d 100644 --- a/src/runtime/c/pgf/data.h +++ b/src/runtime/c/pgf/data.h @@ -351,4 +351,20 @@ struct PgfCCat { GuFinalizer fin[0]; }; +PGF_API_DECL bool +pgf_production_is_lexical(PgfProductionApply *papp, + GuBuf* non_lexical_buf, GuPool* pool); + +PGF_API_DECL void +pgf_parser_index(PgfConcr* concr, + PgfCCat* ccat, PgfProduction prod, + bool is_lexical, + GuPool *pool); + +PGF_API_DECL void +pgf_lzr_index(PgfConcr* concr, + PgfCCat* ccat, PgfProduction prod, + bool is_lexical, + GuPool *pool); + #endif diff --git a/src/runtime/c/pgf/expr.c b/src/runtime/c/pgf/expr.c index f9fcd1442..92e92f04f 100644 --- a/src/runtime/c/pgf/expr.c +++ b/src/runtime/c/pgf/expr.c @@ -224,20 +224,24 @@ typedef enum { PGF_TOKEN_EOF, } PGF_TOKEN_TAG; +typedef GuUCS (*PgfParserGetc)(void* state, bool mark, GuExn* err); + struct PgfExprParser { GuExn* err; - GuIn* in; GuPool* expr_pool; GuPool* tmp_pool; PGF_TOKEN_TAG token_tag; GuStringBuf* token_value; + + void* getch_state; + PgfParserGetc getch; GuUCS ch; }; static void -pgf_expr_parser_getc(PgfExprParser* parser) +pgf_expr_parser_getc(PgfExprParser* parser, bool mark) { - parser->ch = gu_in_utf8(parser->in, parser->err); + parser->ch = parser->getch(parser->getch_state, mark, parser->err); if (!gu_ok(parser->err)) { gu_exn_clear(parser->err); parser->ch = EOF; @@ -284,10 +288,11 @@ pgf_is_normal_ident(PgfCId id) } static void -pgf_expr_parser_token(PgfExprParser* parser) +pgf_expr_parser_token(PgfExprParser* parser, bool mark) { while (isspace(parser->ch)) { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); + mark = false; } parser->token_tag = PGF_TOKEN_UNKNOWN; @@ -295,72 +300,73 @@ pgf_expr_parser_token(PgfExprParser* parser) switch (parser->ch) { case EOF: + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_EOF; break; case '(': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_LPAR; break; case ')': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_RPAR; break; case '{': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_LCURLY; break; case '}': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_RCURLY; break; case '<': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_LTRIANGLE; break; case '>': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_RTRIANGLE; break; case '?': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_QUESTION; break; case '\\': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_LAMBDA; break; case '-': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); if (parser->ch == '>') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); parser->token_tag = PGF_TOKEN_RARROW; } break; case ',': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_COMMA; break; case ':': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_COLON; break; case ';': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); parser->token_tag = PGF_TOKEN_SEMI; break; case '\'': - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); GuStringBuf* chars = gu_new_string_buf(parser->tmp_pool); while (parser->ch != '\'' && parser->ch != EOF) { if (parser->ch == '\\') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); } gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); } if (parser->ch == '\'') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); gu_out_utf8(0, gu_string_buf_out(chars), parser->err); parser->token_tag = PGF_TOKEN_IDENT; parser->token_value = chars; @@ -372,7 +378,8 @@ pgf_expr_parser_token(PgfExprParser* parser) if (pgf_is_ident_first(parser->ch)) { do { gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); + mark = false; } while (pgf_is_ident_rest(parser->ch)); gu_out_utf8(0, gu_string_buf_out(chars), parser->err); parser->token_tag = PGF_TOKEN_IDENT; @@ -380,16 +387,17 @@ pgf_expr_parser_token(PgfExprParser* parser) } else if (isdigit(parser->ch)) { while (isdigit(parser->ch)) { gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); + mark = false; } - + if (parser->ch == '.') { gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); while (isdigit(parser->ch)) { gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); } gu_out_utf8(0, gu_string_buf_out(chars), parser->err); parser->token_tag = PGF_TOKEN_FLT; @@ -400,11 +408,11 @@ pgf_expr_parser_token(PgfExprParser* parser) parser->token_value = chars; } } else if (parser->ch == '"') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, mark); while (parser->ch != '"' && parser->ch != EOF) { if (parser->ch == '\\') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); switch (parser->ch) { case '\\': gu_out_utf8('\\', gu_string_buf_out(chars), parser->err); @@ -430,15 +438,17 @@ pgf_expr_parser_token(PgfExprParser* parser) } else { gu_out_utf8(parser->ch, gu_string_buf_out(chars), parser->err); } - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); } if (parser->ch == '"') { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); gu_out_utf8(0, gu_string_buf_out(chars), parser->err); parser->token_tag = PGF_TOKEN_STR; parser->token_value = chars; } + } else { + pgf_expr_parser_getc(parser, mark); } break; } @@ -449,51 +459,51 @@ static bool pgf_expr_parser_lookahead(PgfExprParser* parser, int ch) { while (isspace(parser->ch)) { - pgf_expr_parser_getc(parser); + pgf_expr_parser_getc(parser, false); } - + return (parser->ch == ch); } -static PgfExpr -pgf_expr_parser_expr(PgfExprParser* parser); +PGF_API PgfExpr +pgf_expr_parser_expr(PgfExprParser* parser, bool mark); static PgfType* -pgf_expr_parser_type(PgfExprParser* parser); +pgf_expr_parser_type(PgfExprParser* parser, bool mark); static PgfExpr -pgf_expr_parser_term(PgfExprParser* parser) +pgf_expr_parser_term(PgfExprParser* parser, bool mark) { switch (parser->token_tag) { case PGF_TOKEN_LPAR: { - pgf_expr_parser_token(parser); - PgfExpr expr = pgf_expr_parser_expr(parser); + pgf_expr_parser_token(parser, false); + PgfExpr expr = pgf_expr_parser_expr(parser, false); if (parser->token_tag == PGF_TOKEN_RPAR) { - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); return expr; } else { return gu_null_variant; } } case PGF_TOKEN_LTRIANGLE: { - pgf_expr_parser_token(parser); - PgfExpr expr = pgf_expr_parser_expr(parser); + pgf_expr_parser_token(parser, false); + PgfExpr expr = pgf_expr_parser_expr(parser, false); if (gu_variant_is_null(expr)) return gu_null_variant; - + if (parser->token_tag != PGF_TOKEN_COLON) { return gu_null_variant; } - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); - PgfType* type = pgf_expr_parser_type(parser); + PgfType* type = pgf_expr_parser_type(parser, false); if (type == NULL) return gu_null_variant; if (parser->token_tag != PGF_TOKEN_RTRIANGLE) { return gu_null_variant; } - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); return gu_new_variant_i(parser->expr_pool, PGF_EXPR_TYPED, @@ -501,14 +511,14 @@ pgf_expr_parser_term(PgfExprParser* parser) expr, type); } case PGF_TOKEN_QUESTION: { - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); PgfMetaId id = 0; if (parser->token_tag == PGF_TOKEN_INT) { char* str = gu_string_buf_data(parser->token_value); id = atoi(str); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); } return gu_new_variant_i(parser->expr_pool, PGF_EXPR_META, @@ -517,7 +527,7 @@ pgf_expr_parser_term(PgfExprParser* parser) } case PGF_TOKEN_IDENT: { PgfCId id = gu_string_buf_data(parser->token_value); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); PgfExpr e; PgfExprFun* fun = gu_new_flex_variant(PGF_EXPR_FUN, @@ -528,11 +538,11 @@ pgf_expr_parser_term(PgfExprParser* parser) return e; } case PGF_TOKEN_INT: { - char* str = + char* str = gu_string_buf_data(parser->token_value); int n = atoi(str); - pgf_expr_parser_token(parser); - PgfLiteral lit = + pgf_expr_parser_token(parser, mark); + PgfLiteral lit = gu_new_variant_i(parser->expr_pool, PGF_LITERAL_INT, PgfLiteralInt, @@ -545,7 +555,7 @@ pgf_expr_parser_term(PgfExprParser* parser) case PGF_TOKEN_STR: { char* str = gu_string_buf_data(parser->token_value); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); return pgf_expr_string(str, parser->expr_pool); } case PGF_TOKEN_FLT: { @@ -554,8 +564,8 @@ pgf_expr_parser_term(PgfExprParser* parser) double d; if (!gu_string_to_double(str,&d)) return gu_null_variant; - pgf_expr_parser_token(parser); - PgfLiteral lit = + pgf_expr_parser_token(parser, mark); + PgfLiteral lit = gu_new_variant_i(parser->expr_pool, PGF_LITERAL_FLT, PgfLiteralFlt, @@ -571,29 +581,28 @@ pgf_expr_parser_term(PgfExprParser* parser) } static PgfExpr -pgf_expr_parser_arg(PgfExprParser* parser) +pgf_expr_parser_arg(PgfExprParser* parser, bool mark) { PgfExpr arg; if (parser->token_tag == PGF_TOKEN_LCURLY) { - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); - arg = pgf_expr_parser_expr(parser); + arg = pgf_expr_parser_expr(parser, false); if (gu_variant_is_null(arg)) return gu_null_variant; if (parser->token_tag != PGF_TOKEN_RCURLY) { return gu_null_variant; } - - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); arg = gu_new_variant_i(parser->expr_pool, PGF_EXPR_IMPL_ARG, PgfExprImplArg, arg); } else { - arg = pgf_expr_parser_term(parser); + arg = pgf_expr_parser_term(parser, mark); } return arg; @@ -607,17 +616,17 @@ pgf_expr_parser_bind(PgfExprParser* parser, GuBuf* binds) if (parser->token_tag == PGF_TOKEN_LCURLY) { bind_type = PGF_BIND_TYPE_IMPLICIT; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } for (;;) { if (parser->token_tag == PGF_TOKEN_IDENT) { var = gu_string_copy(gu_string_buf_data(parser->token_value), parser->expr_pool); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } else if (parser->token_tag == PGF_TOKEN_WILD) { var = "_"; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } else { return false; } @@ -635,14 +644,14 @@ pgf_expr_parser_bind(PgfExprParser* parser, GuBuf* binds) parser->token_tag != PGF_TOKEN_COMMA) { break; } - - pgf_expr_parser_token(parser); + + pgf_expr_parser_token(parser, false); } if (bind_type == PGF_BIND_TYPE_IMPLICIT) { if (parser->token_tag != PGF_TOKEN_RCURLY) return false; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } return true; @@ -660,17 +669,17 @@ pgf_expr_parser_binds(PgfExprParser* parser) if (parser->token_tag != PGF_TOKEN_COMMA) break; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } return binds; } -static PgfExpr -pgf_expr_parser_expr(PgfExprParser* parser) +PGF_API PgfExpr +pgf_expr_parser_expr(PgfExprParser* parser, bool mark) { if (parser->token_tag == PGF_TOKEN_LAMBDA) { - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); GuBuf* binds = pgf_expr_parser_binds(parser); if (binds == NULL) return gu_null_variant; @@ -678,9 +687,9 @@ pgf_expr_parser_expr(PgfExprParser* parser) if (parser->token_tag != PGF_TOKEN_RARROW) { return gu_null_variant; } - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); - PgfExpr expr = pgf_expr_parser_expr(parser); + PgfExpr expr = pgf_expr_parser_expr(parser, mark); if (gu_variant_is_null(expr)) return gu_null_variant; @@ -691,10 +700,9 @@ pgf_expr_parser_expr(PgfExprParser* parser) ((PgfExprAbs*) gu_variant_data(bind))->body = expr; expr = bind; } - return expr; } else { - PgfExpr expr = pgf_expr_parser_term(parser); + PgfExpr expr = pgf_expr_parser_term(parser, mark); if (gu_variant_is_null(expr)) return gu_null_variant; @@ -704,17 +712,18 @@ pgf_expr_parser_expr(PgfExprParser* parser) parser->token_tag != PGF_TOKEN_RTRIANGLE && parser->token_tag != PGF_TOKEN_COLON && parser->token_tag != PGF_TOKEN_COMMA && - parser->token_tag != PGF_TOKEN_SEMI) { - PgfExpr arg = pgf_expr_parser_arg(parser); + parser->token_tag != PGF_TOKEN_SEMI && + parser->token_tag != PGF_TOKEN_UNKNOWN) { + PgfExpr arg = pgf_expr_parser_arg(parser, mark); if (gu_variant_is_null(arg)) - return gu_null_variant; + return expr; expr = gu_new_variant_i(parser->expr_pool, PGF_EXPR_APP, PgfExprApp, expr, arg); } - + return expr; } } @@ -729,16 +738,16 @@ pgf_expr_parser_hypos(PgfExprParser* parser, GuBuf* hypos) if (bind_type == PGF_BIND_TYPE_EXPLICIT && parser->token_tag == PGF_TOKEN_LCURLY) { bind_type = PGF_BIND_TYPE_IMPLICIT; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } if (parser->token_tag == PGF_TOKEN_IDENT) { var = gu_string_copy(gu_string_buf_data(parser->token_value), parser->expr_pool); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } else if (parser->token_tag == PGF_TOKEN_WILD) { var = "_"; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } else { return false; } @@ -751,14 +760,14 @@ pgf_expr_parser_hypos(PgfExprParser* parser, GuBuf* hypos) if (bind_type == PGF_BIND_TYPE_IMPLICIT && parser->token_tag == PGF_TOKEN_RCURLY) { bind_type = PGF_BIND_TYPE_EXPLICIT; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } if (parser->token_tag != PGF_TOKEN_COMMA) { break; } - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } if (bind_type == PGF_BIND_TYPE_IMPLICIT) @@ -768,14 +777,14 @@ pgf_expr_parser_hypos(PgfExprParser* parser, GuBuf* hypos) } static PgfType* -pgf_expr_parser_atom(PgfExprParser* parser) +pgf_expr_parser_atom(PgfExprParser* parser, bool mark) { if (parser->token_tag != PGF_TOKEN_IDENT) return NULL; PgfCId cid = gu_string_copy(gu_string_buf_data(parser->token_value), parser->expr_pool); - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, mark); GuBuf* args = gu_new_buf(PgfExpr, parser->tmp_pool); while (parser->token_tag != PGF_TOKEN_EOF && @@ -783,10 +792,10 @@ pgf_expr_parser_atom(PgfExprParser* parser) parser->token_tag != PGF_TOKEN_RTRIANGLE && parser->token_tag != PGF_TOKEN_RARROW) { PgfExpr arg = - pgf_expr_parser_arg(parser); + pgf_expr_parser_arg(parser, mark); if (gu_variant_is_null(arg)) - return NULL; - + break; + gu_buf_push(args, PgfExpr, arg); } @@ -805,14 +814,14 @@ pgf_expr_parser_atom(PgfExprParser* parser) } static PgfType* -pgf_expr_parser_type(PgfExprParser* parser) +pgf_expr_parser_type(PgfExprParser* parser, bool mark) { PgfType* type = NULL; GuBuf* hypos = gu_new_buf(PgfHypo, parser->expr_pool); for (;;) { if (parser->token_tag == PGF_TOKEN_LPAR) { - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); size_t n_start = gu_buf_length(hypos); @@ -828,7 +837,7 @@ pgf_expr_parser_type(PgfExprParser* parser) if (parser->token_tag != PGF_TOKEN_COLON) return NULL; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } else { PgfHypo* hypo = gu_buf_extend(hypos); hypo->bind_type = PGF_BIND_TYPE_EXPLICIT; @@ -838,33 +847,33 @@ pgf_expr_parser_type(PgfExprParser* parser) size_t n_end = gu_buf_length(hypos); - PgfType* type = pgf_expr_parser_type(parser); + PgfType* type = pgf_expr_parser_type(parser, false); if (type == NULL) return NULL; if (parser->token_tag != PGF_TOKEN_RPAR) return NULL; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); if (parser->token_tag != PGF_TOKEN_RARROW) return NULL; - pgf_expr_parser_token(parser); - + pgf_expr_parser_token(parser, false); + for (size_t i = n_start; i < n_end; i++) { PgfHypo* hypo = gu_buf_index(hypos, PgfHypo, i); hypo->type = type; } } else { - type = pgf_expr_parser_atom(parser); + type = pgf_expr_parser_atom(parser, mark); if (type == NULL) return NULL; if (parser->token_tag != PGF_TOKEN_RARROW) break; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); PgfHypo* hypo = gu_buf_extend(hypos); hypo->bind_type = PGF_BIND_TYPE_EXPLICIT; @@ -878,29 +887,34 @@ pgf_expr_parser_type(PgfExprParser* parser) return type; } -static PgfExprParser* -pgf_new_parser(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err) +PGF_API PgfExprParser* +pgf_new_parser(void* getc_state, PgfParserGetc getc, GuPool* pool, GuPool* tmp_pool, GuExn* err) { PgfExprParser* parser = gu_new(PgfExprParser, tmp_pool); parser->err = err; - parser->in = in; parser->expr_pool = pool; parser->tmp_pool = tmp_pool; + parser->getch_state = getc_state; + parser->getch = getc; parser->ch = ' '; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); return parser; } +static GuUCS +pgf_expr_parser_in_getc(void* state, bool mark, GuExn* err) +{ + return gu_in_utf8((GuIn*) state, err); +} + PGF_API PgfExpr -pgf_read_expr(GuIn* in, GuPool* pool, GuExn* err) +pgf_read_expr(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err) { - GuPool* tmp_pool = gu_new_pool(); PgfExprParser* parser = - pgf_new_parser(in, pool, tmp_pool, err); - PgfExpr expr = pgf_expr_parser_expr(parser); + pgf_new_parser(in, pgf_expr_parser_in_getc, pool, tmp_pool, err); + PgfExpr expr = pgf_expr_parser_expr(parser, true); if (parser->token_tag != PGF_TOKEN_EOF) return gu_null_variant; - gu_pool_free(tmp_pool); return expr; } @@ -911,24 +925,24 @@ pgf_read_expr_tuple(GuIn* in, { GuPool* tmp_pool = gu_new_pool(); PgfExprParser* parser = - pgf_new_parser(in, pool, tmp_pool, err); + pgf_new_parser(in, pgf_expr_parser_in_getc, pool, tmp_pool, err); if (parser->token_tag != PGF_TOKEN_LTRIANGLE) goto fail; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); for (size_t i = 0; i < n_exprs; i++) { if (i > 0) { if (parser->token_tag != PGF_TOKEN_COMMA) goto fail; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } - exprs[i] = pgf_expr_parser_expr(parser); + exprs[i] = pgf_expr_parser_expr(parser, false); if (gu_variant_is_null(exprs[i])) goto fail; } if (parser->token_tag != PGF_TOKEN_RTRIANGLE) goto fail; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); if (parser->token_tag != PGF_TOKEN_EOF) goto fail; gu_pool_free(tmp_pool); @@ -947,10 +961,10 @@ pgf_read_expr_matrix(GuIn* in, { GuPool* tmp_pool = gu_new_pool(); PgfExprParser* parser = - pgf_new_parser(in, pool, tmp_pool, err); + pgf_new_parser(in, pgf_expr_parser_in_getc, pool, tmp_pool, err); if (parser->token_tag != PGF_TOKEN_LTRIANGLE) goto fail; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); GuBuf* buf = gu_new_buf(PgfExpr, pool); @@ -962,10 +976,10 @@ pgf_read_expr_matrix(GuIn* in, if (i > 0) { if (parser->token_tag != PGF_TOKEN_COMMA) goto fail; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } - exprs[i] = pgf_expr_parser_expr(parser); + exprs[i] = pgf_expr_parser_expr(parser, false); if (gu_variant_is_null(exprs[i])) goto fail; } @@ -973,14 +987,14 @@ pgf_read_expr_matrix(GuIn* in, if (parser->token_tag != PGF_TOKEN_SEMI) break; - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); } if (parser->token_tag != PGF_TOKEN_RTRIANGLE) goto fail; } - pgf_expr_parser_token(parser); + pgf_expr_parser_token(parser, false); if (parser->token_tag != PGF_TOKEN_EOF) goto fail; gu_pool_free(tmp_pool); @@ -993,15 +1007,13 @@ fail: } PGF_API PgfType* -pgf_read_type(GuIn* in, GuPool* pool, GuExn* err) +pgf_read_type(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err) { - GuPool* tmp_pool = gu_new_pool(); PgfExprParser* parser = - pgf_new_parser(in, pool, tmp_pool, err); - PgfType* type = pgf_expr_parser_type(parser); + pgf_new_parser(in, pgf_expr_parser_in_getc, pool, tmp_pool, err); + PgfType* type = pgf_expr_parser_type(parser, true); if (parser->token_tag != PGF_TOKEN_EOF) return NULL; - gu_pool_free(tmp_pool); return type; } @@ -1177,6 +1189,247 @@ pgf_expr_hash(GuHash h, PgfExpr e) return h; } +PGF_API size_t +pgf_expr_size(PgfExpr expr) +{ + GuVariantInfo ei = gu_variant_open(expr); + switch (ei.tag) { + case PGF_EXPR_ABS: { + PgfExprAbs* abs = ei.data; + return pgf_expr_size(abs->body); + } + case PGF_EXPR_APP: { + PgfExprApp* app = ei.data; + return pgf_expr_size(app->fun) + pgf_expr_size(app->arg); + } + case PGF_EXPR_LIT: + case PGF_EXPR_META: + case PGF_EXPR_FUN: + case PGF_EXPR_VAR: { + return 1; + } + case PGF_EXPR_TYPED: { + PgfExprTyped* typed = ei.data; + return pgf_expr_size(typed->expr); + } + case PGF_EXPR_IMPL_ARG: { + PgfExprImplArg* impl = ei.data; + return pgf_expr_size(impl->expr); + } + default: + gu_impossible(); + return 0; + } +} + +static void +pgf_expr_functions_helper(PgfExpr expr, GuBuf* functions) +{ + GuVariantInfo ei = gu_variant_open(expr); + switch (ei.tag) { + case PGF_EXPR_ABS: { + PgfExprAbs* abs = ei.data; + pgf_expr_functions_helper(abs->body, functions); + break; + } + case PGF_EXPR_APP: { + PgfExprApp* app = ei.data; + pgf_expr_functions_helper(app->fun, functions); + pgf_expr_functions_helper(app->arg, functions); + break; + } + case PGF_EXPR_LIT: + case PGF_EXPR_META: + case PGF_EXPR_VAR: { + break; + } + case PGF_EXPR_FUN:{ + PgfExprFun* fun = ei.data; + gu_buf_push(functions, GuString, fun->fun); + break; + } + case PGF_EXPR_TYPED: { + PgfExprTyped* typed = ei.data; + pgf_expr_functions_helper(typed->expr, functions); + break; + } + case PGF_EXPR_IMPL_ARG: { + PgfExprImplArg* impl = ei.data; + pgf_expr_functions_helper(impl->expr, functions); + break; + } + default: + gu_impossible(); + } +} + +PGF_API GuSeq* +pgf_expr_functions(PgfExpr expr, GuPool* pool) +{ + GuBuf* functions = gu_new_buf(GuString, pool); + pgf_expr_functions_helper(expr, functions); + return gu_buf_data_seq(functions); +} + +PGF_API PgfType* +pgf_type_substitute(PgfType* type, GuSeq* meta_values, GuPool* pool) +{ + size_t n_hypos = gu_seq_length(type->hypos); + PgfHypos* new_hypos = gu_new_seq(PgfHypo, n_hypos, pool); + for (size_t i = 0; i < n_hypos; i++) { + PgfHypo* hypo = gu_seq_index(type->hypos, PgfHypo, i); + PgfHypo* new_hypo = gu_seq_index(new_hypos, PgfHypo, i); + + new_hypo->bind_type = hypo->bind_type; + new_hypo->cid = gu_string_copy(hypo->cid, pool); + new_hypo->type = pgf_type_substitute(hypo->type, meta_values, pool); + } + + PgfType *new_type = + gu_new_flex(pool, PgfType, exprs, type->n_exprs); + new_type->hypos = new_hypos; + new_type->cid = gu_string_copy(type->cid, pool); + new_type->n_exprs = type->n_exprs; + + for (size_t i = 0; i < type->n_exprs; i++) { + new_type->exprs[i] = + pgf_expr_substitute(type->exprs[i], meta_values, pool); + } + + return new_type; +} + +PGF_API PgfExpr +pgf_expr_substitute(PgfExpr expr, GuSeq* meta_values, GuPool* pool) +{ + GuVariantInfo ei = gu_variant_open(expr); + switch (ei.tag) { + case PGF_EXPR_ABS: { + PgfExprAbs* abs = ei.data; + + PgfCId id = gu_string_copy(abs->id, pool); + PgfExpr body = pgf_expr_substitute(abs->body, meta_values, pool); + return gu_new_variant_i(pool, + PGF_EXPR_ABS, + PgfExprAbs, + abs->bind_type, id, body); + } + case PGF_EXPR_APP: { + PgfExprApp* app = ei.data; + + PgfExpr fun = pgf_expr_substitute(app->fun, meta_values, pool); + PgfExpr arg = pgf_expr_substitute(app->arg, meta_values, pool); + return gu_new_variant_i(pool, + PGF_EXPR_APP, + PgfExprApp, + fun, arg); + } + case PGF_EXPR_LIT: { + PgfExprLit* elit = ei.data; + + PgfLiteral lit; + GuVariantInfo i = gu_variant_open(elit->lit); + switch (i.tag) { + case PGF_LITERAL_STR: { + PgfLiteralStr* lstr = i.data; + + PgfLiteralStr* new_lstr = + gu_new_flex_variant(PGF_LITERAL_STR, + PgfLiteralStr, + val, strlen(lstr->val)+1, + &lit, pool); + strcpy(new_lstr->val, lstr->val); + break; + } + case PGF_LITERAL_INT: { + PgfLiteralInt* lint = i.data; + + PgfLiteralInt* new_lint = + gu_new_variant(PGF_LITERAL_INT, + PgfLiteralInt, + &lit, pool); + new_lint->val = lint->val; + break; + } + case PGF_LITERAL_FLT: { + PgfLiteralFlt* lflt = i.data; + + PgfLiteralFlt* new_lflt = + gu_new_variant(PGF_LITERAL_FLT, + PgfLiteralFlt, + &lit, pool); + new_lflt->val = lflt->val; + break; + } + default: + gu_impossible(); + } + + return gu_new_variant_i(pool, + PGF_EXPR_LIT, + PgfExprLit, + lit); + } + case PGF_EXPR_META: { + PgfExprMeta* meta = ei.data; + PgfExpr e = gu_null_variant; + if ((size_t) meta->id < gu_seq_length(meta_values)) { + e = gu_seq_get(meta_values, PgfExpr, meta->id); + } + if (gu_variant_is_null(e)) { + e = gu_new_variant_i(pool, + PGF_EXPR_META, + PgfExprMeta, + meta->id); + } + return e; + } + case PGF_EXPR_FUN: { + PgfExprFun* fun = ei.data; + + PgfExpr e; + PgfExprFun* new_fun = + gu_new_flex_variant(PGF_EXPR_FUN, + PgfExprFun, + fun, strlen(fun->fun)+1, + &e, pool); + strcpy(new_fun->fun, fun->fun); + return e; + } + case PGF_EXPR_VAR: { + PgfExprVar* var = ei.data; + return gu_new_variant_i(pool, + PGF_EXPR_VAR, + PgfExprVar, + var->var); + } + case PGF_EXPR_TYPED: { + PgfExprTyped* typed = ei.data; + + PgfExpr expr = pgf_expr_substitute(typed->expr, meta_values, pool); + PgfType *type = pgf_type_substitute(typed->type, meta_values, pool); + + return gu_new_variant_i(pool, + PGF_EXPR_TYPED, + PgfExprTyped, + expr, + type); + } + case PGF_EXPR_IMPL_ARG: { + PgfExprImplArg* impl = ei.data; + + PgfExpr expr = pgf_expr_substitute(impl->expr, meta_values, pool); + return gu_new_variant_i(pool, + PGF_EXPR_IMPL_ARG, + PgfExprImplArg, + expr); + } + default: + gu_impossible(); + return gu_null_variant; + } +} + PGF_API void pgf_print_cid(PgfCId id, GuOut* out, GuExn* err) @@ -1397,10 +1650,10 @@ pgf_print_hypo(PgfHypo *hypo, PgfPrintContext* ctxt, int prec, } else { pgf_print_type(hypo->type, ctxt, prec, out, err); } - + gu_pool_free(tmp_pool); } - + PgfPrintContext* new_ctxt = malloc(sizeof(PgfPrintContext)); new_ctxt->name = hypo->cid; new_ctxt->next = ctxt; @@ -1415,7 +1668,7 @@ pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec, if (n_hypos > 0) { if (prec > 0) gu_putc('(', out, err); - + PgfPrintContext* new_ctxt = ctxt; for (size_t i = 0; i < n_hypos; i++) { PgfHypo *hypo = gu_seq_index(type->hypos, PgfHypo, i); @@ -1455,6 +1708,22 @@ pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec, } PGF_API void +pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt, + GuOut *out, GuExn *err) +{ + PgfPrintContext* new_ctxt = ctxt; + + size_t n_hypos = gu_seq_length(hypos); + for (size_t i = 0; i < n_hypos; i++) { + if (i > 0) + gu_putc(' ', out, err); + + PgfHypo *hypo = gu_seq_index(hypos, PgfHypo, i); + new_ctxt = pgf_print_hypo(hypo, new_ctxt, 4, out, err); + } +} + +PGF_API void pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt, GuOut* out, GuExn* err) { @@ -1467,30 +1736,6 @@ pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt, gu_putc('>', out, err); } -PGF_API_DECL void -pgf_print_category(PgfPGF *gr, PgfCId catname, - GuOut* out, GuExn *err) -{ - PgfAbsCat* abscat = - gu_seq_binsearch(gr->abstract.cats, pgf_abscat_order, PgfAbsCat, catname); - if (abscat == NULL) { - GuExnData* exn = gu_raise(err, PgfExn); - exn->data = "Unknown category"; - return; - } - - gu_puts(abscat->name, out, err); - - PgfPrintContext* ctxt = NULL; - size_t n_hypos = gu_seq_length(abscat->context); - for (size_t i = 0; i < n_hypos; i++) { - PgfHypo *hypo = gu_seq_index(abscat->context, PgfHypo, i); - - gu_putc(' ', out, err); - ctxt = pgf_print_hypo(hypo, ctxt, 4, out, err); - } -} - PGF_API bool pgf_type_eq(PgfType* t1, PgfType* t2) { diff --git a/src/runtime/c/pgf/expr.h b/src/runtime/c/pgf/expr.h index 6492f8d18..e560d3a83 100644 --- a/src/runtime/c/pgf/expr.h +++ b/src/runtime/c/pgf/expr.h @@ -168,7 +168,7 @@ PGF_API_DECL PgfExprMeta* pgf_expr_unmeta(PgfExpr expr); PGF_API_DECL PgfExpr -pgf_read_expr(GuIn* in, GuPool* pool, GuExn* err); +pgf_read_expr(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err); PGF_API_DECL int pgf_read_expr_tuple(GuIn* in, @@ -180,7 +180,7 @@ pgf_read_expr_matrix(GuIn* in, size_t n_exprs, GuPool* pool, GuExn* err); PGF_API_DECL PgfType* -pgf_read_type(GuIn* in, GuPool* pool, GuExn* err); +pgf_read_type(GuIn* in, GuPool* pool, GuPool* tmp_pool, GuExn* err); PGF_API_DECL bool pgf_literal_eq(PgfLiteral lit1, PgfLiteral lit2); @@ -197,6 +197,18 @@ pgf_literal_hash(GuHash h, PgfLiteral lit); PGF_API_DECL GuHash pgf_expr_hash(GuHash h, PgfExpr e); +PGF_API size_t +pgf_expr_size(PgfExpr expr); + +PGF_API GuSeq* +pgf_expr_functions(PgfExpr expr, GuPool* pool); + +PGF_API PgfExpr +pgf_expr_substitute(PgfExpr expr, GuSeq* meta_values, GuPool* pool); + +PGF_API PgfType* +pgf_type_substitute(PgfType* type, GuSeq* meta_values, GuPool* pool); + typedef struct PgfPrintContext PgfPrintContext; struct PgfPrintContext { @@ -223,14 +235,14 @@ pgf_print_type(PgfType *type, PgfPrintContext* ctxt, int prec, GuOut* out, GuExn *err); PGF_API_DECL void -pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt, - GuOut* out, GuExn* err); +pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt, + GuOut *out, GuExn *err); PGF_API_DECL void -pgf_print_category(PgfPGF *gr, PgfCId catname, - GuOut* out, GuExn *err); +pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt, + GuOut* out, GuExn* err); -PGF_API prob_t +PGF_API_DECL prob_t pgf_compute_tree_probability(PgfPGF *gr, PgfExpr expr); #endif /* EXPR_H_ */ diff --git a/src/runtime/c/pgf/graphviz.c b/src/runtime/c/pgf/graphviz.c index f10303bdc..66e203dbc 100644 --- a/src/runtime/c/pgf/graphviz.c +++ b/src/runtime/c/pgf/graphviz.c @@ -155,7 +155,7 @@ pgf_bracket_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok) } static void -pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); @@ -192,7 +192,7 @@ pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int linde } static void -pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); diff --git a/src/runtime/c/pgf/linearizer.c b/src/runtime/c/pgf/linearizer.c index f18a3e55a..ced2a8cf2 100644 --- a/src/runtime/c/pgf/linearizer.c +++ b/src/runtime/c/pgf/linearizer.c @@ -30,7 +30,7 @@ pgf_lzr_add_overl_entry(PgfCncOverloadMap* overl_table, gu_buf_push(entries, void*, entry); } -PGF_INTERNAL void +PGF_API void pgf_lzr_index(PgfConcr* concr, PgfCCat* ccat, PgfProduction prod, bool is_lexical, @@ -731,7 +731,7 @@ found: } static void -pgf_lzr_cache_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_idx, PgfCId fun) +pgf_lzr_cache_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_idx, PgfCId fun) { PgfLzrCache* cache = gu_container(funcs, PgfLzrCache, funcs); PgfLzrCached* event = gu_buf_extend(cache->events); @@ -743,7 +743,7 @@ pgf_lzr_cache_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_idx } static void -pgf_lzr_cache_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_idx, PgfCId fun) +pgf_lzr_cache_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_idx, PgfCId fun) { PgfLzrCache* cache = gu_container(funcs, PgfLzrCache, funcs); PgfLzrCached* event = gu_buf_extend(cache->events); diff --git a/src/runtime/c/pgf/linearizer.h b/src/runtime/c/pgf/linearizer.h index f2fea4221..57fad962f 100644 --- a/src/runtime/c/pgf/linearizer.h +++ b/src/runtime/c/pgf/linearizer.h @@ -83,10 +83,10 @@ struct PgfLinFuncs void (*symbol_token)(PgfLinFuncs** self, PgfToken tok); /// Begin phrase - void (*begin_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, int lindex, PgfCId fun); + void (*begin_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, size_t lindex, PgfCId fun); /// End phrase - void (*end_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, int lindex, PgfCId fun); + void (*end_phrase)(PgfLinFuncs** self, PgfCId cat, int fid, size_t lindex, PgfCId fun); /// handling nonExist void (*symbol_ne)(PgfLinFuncs** self); diff --git a/src/runtime/c/pgf/lookup.c b/src/runtime/c/pgf/lookup.c index 16874eb0e..5918275c1 100644 --- a/src/runtime/c/pgf/lookup.c +++ b/src/runtime/c/pgf/lookup.c @@ -9,6 +9,9 @@ #include <stdio.h> #include <stdlib.h> #include <math.h> +#if defined(__MINGW32__) || defined(_MSC_VER) +#include <malloc.h> +#endif //#define PGF_LOOKUP_DEBUG //#define PGF_LINEARIZER_DEBUG @@ -116,7 +119,7 @@ typedef struct { static PgfAbsProduction* pgf_lookup_new_production(PgfAbsFun* fun, GuPool *pool) { - size_t n_hypos = gu_seq_length(fun->type->hypos); + size_t n_hypos = fun->type->hypos ? gu_seq_length(fun->type->hypos) : 0; PgfAbsProduction* prod = gu_new_flex(pool, PgfAbsProduction, args, n_hypos); prod->fun = fun; prod->count = 0; @@ -696,8 +699,12 @@ pgf_lookup_tokenize(GuMap* lexicon_idx, GuString sentence, GuPool* pool) break; const uint8_t* start = p-1; - while (c != 0 && !gu_ucs_is_space(c)) { + if (strchr(".!?,:",c) != NULL) c = gu_utf8_decode(&p); + else { + while (c != 0 && strchr(".!?,:",c) == NULL && !gu_ucs_is_space(c)) { + c = gu_utf8_decode(&p); + } } const uint8_t* end = p-1; @@ -869,7 +876,7 @@ pgf_lookup_symbol_token(PgfLinFuncs** self, PgfToken token) } static void -pgf_lookup_begin_phrase(PgfLinFuncs** self, PgfCId cat, int fid, int lindex, PgfCId funname) +pgf_lookup_begin_phrase(PgfLinFuncs** self, PgfCId cat, int fid, size_t lindex, PgfCId funname) { PgfLookupState* st = gu_container(self, PgfLookupState, funcs); @@ -883,7 +890,7 @@ pgf_lookup_begin_phrase(PgfLinFuncs** self, PgfCId cat, int fid, int lindex, Pgf } static void -pgf_lookup_end_phrase(PgfLinFuncs** self, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_lookup_end_phrase(PgfLinFuncs** self, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfLookupState* st = gu_container(self, PgfLookupState, funcs); st->curr_absfun = NULL; diff --git a/src/runtime/c/pgf/parser.c b/src/runtime/c/pgf/parser.c index ecfb7d2ea..d12852a71 100644 --- a/src/runtime/c/pgf/parser.c +++ b/src/runtime/c/pgf/parser.c @@ -65,6 +65,7 @@ typedef enum { BIND_NONE, BIND_HARD, BIND_SOFT } BIND_TYPE; typedef struct { PgfProductionIdx* idx; size_t offset; + size_t sym_idx; } PgfLexiconIdxEntry; typedef GuBuf PgfLexiconIdx; @@ -1060,16 +1061,16 @@ pgf_parsing_complete(PgfParsing* ps, PgfItem* item, PgfExprProb *ep) } static int -pgf_symbols_cmp(GuString* psent, PgfSymbols* syms, bool case_sensitive) +pgf_symbols_cmp(GuString* psent, PgfSymbols* syms, size_t* sym_idx, bool case_sensitive) { size_t n_syms = gu_seq_length(syms); - for (size_t i = 0; i < n_syms; i++) { - PgfSymbol sym = gu_seq_get(syms, PgfSymbol, i); + while (*sym_idx < n_syms) { + PgfSymbol sym = gu_seq_get(syms, PgfSymbol, *sym_idx); - if (i > 0) { + if (*sym_idx > 0) { if (!skip_space(psent)) { if (**psent == 0) - return -1; + return 0; return 1; } @@ -1085,13 +1086,13 @@ pgf_symbols_cmp(GuString* psent, PgfSymbols* syms, bool case_sensitive) case PGF_SYMBOL_LIT: case PGF_SYMBOL_VAR: { if (**psent == 0) - return -1; + return 0; return 1; } case PGF_SYMBOL_KS: { PgfSymbolKS* pks = inf.data; if (**psent == 0) - return -1; + return 0; int cmp = cmp_string(psent, pks->token, case_sensitive); if (cmp != 0) @@ -1110,6 +1111,8 @@ pgf_symbols_cmp(GuString* psent, PgfSymbols* syms, bool case_sensitive) default: gu_impossible(); } + + (*sym_idx)++; } return 0; @@ -1130,7 +1133,8 @@ pgf_parsing_lookahead(PgfParsing *ps, PgfParseState* state, GuString start = ps->sentence + state->end_offset; GuString current = start; - int cmp = pgf_symbols_cmp(¤t, seq->syms, ps->case_sensitive); + size_t sym_idx = 0; + int cmp = pgf_symbols_cmp(¤t, seq->syms, &sym_idx, ps->case_sensitive); if (cmp < 0) { j = k-1; } else if (cmp > 0) { @@ -1151,8 +1155,9 @@ pgf_parsing_lookahead(PgfParsing *ps, PgfParseState* state, if (seq->idx != NULL) { PgfLexiconIdxEntry* entry = gu_buf_extend(state->lexicon_idx); - entry->idx = seq->idx; - entry->offset = (size_t) (current - ps->sentence); + entry->idx = seq->idx; + entry->offset = (size_t) (current - ps->sentence); + entry->sym_idx = sym_idx; } if (len+1 <= max) @@ -1231,6 +1236,7 @@ pgf_new_parse_state(PgfParsing* ps, size_t start_offset, PgfLexiconIdxEntry* entry = gu_buf_extend(state->lexicon_idx); entry->idx = seq->idx; entry->offset = state->start_offset; + entry->sym_idx= 0; } // Add non-epsilon lexical rules to the bottom up index @@ -1254,9 +1260,12 @@ pgf_parsing_add_transition(PgfParsing* ps, PgfToken tok, PgfItem* item) if (ps->prefix != NULL && *current == 0) { if (gu_string_is_prefix(ps->prefix, tok)) { + PgfProductionApply* papp = gu_variant_data(item->prod); + ps->tp = gu_new(PgfTokenProb, ps->out_pool); ps->tp->tok = tok; ps->tp->cat = item->conts->ccat->cnccat->abscat->name; + ps->tp->fun = papp->fun->absfun->name; ps->tp->prob = item->inside_prob + item->conts->outside_prob; } } else { @@ -1275,14 +1284,15 @@ pgf_parsing_add_transition(PgfParsing* ps, PgfToken tok, PgfItem* item) static void pgf_parsing_predict_lexeme(PgfParsing* ps, PgfItemConts* conts, PgfProductionIdxEntry* entry, - size_t offset) + size_t offset, size_t sym_idx) { GuVariantInfo i = { PGF_PRODUCTION_APPLY, entry->papp }; PgfProduction prod = gu_variant_close(i); PgfItem* item = pgf_new_item(ps, conts, prod); PgfSymbols* syms = entry->papp->fun->lins[conts->lin_idx]->syms; - item->sym_idx = gu_seq_length(syms); + item->sym_idx = sym_idx; + pgf_item_set_curr_symbol(item, ps->pool); prob_t prob = item->inside_prob+item->conts->outside_prob; PgfParseState* state = pgf_new_parse_state(ps, offset, BIND_NONE, prob); @@ -1355,7 +1365,7 @@ pgf_parsing_td_predict(PgfParsing* ps, PgfProductionIdxEntry, &key); if (value != NULL) { - pgf_parsing_predict_lexeme(ps, conts, value, lentry->offset); + pgf_parsing_predict_lexeme(ps, conts, value, lentry->offset, lentry->sym_idx); PgfProductionIdxEntry* start = gu_buf_data(lentry->idx); @@ -1366,7 +1376,7 @@ pgf_parsing_td_predict(PgfParsing* ps, while (left >= start && value->ccat->fid == left->ccat->fid && value->lin_idx == left->lin_idx) { - pgf_parsing_predict_lexeme(ps, conts, left, lentry->offset); + pgf_parsing_predict_lexeme(ps, conts, left, lentry->offset, lentry->sym_idx); left--; } @@ -1374,7 +1384,7 @@ pgf_parsing_td_predict(PgfParsing* ps, while (right <= end && value->ccat->fid == right->ccat->fid && value->lin_idx == right->lin_idx) { - pgf_parsing_predict_lexeme(ps, conts, right, lentry->offset); + pgf_parsing_predict_lexeme(ps, conts, right, lentry->offset, lentry->sym_idx); right++; } } @@ -2139,30 +2149,37 @@ pgf_parse_result_enum_next(GuEnum* self, void* to, GuPool* pool) *(PgfExprProb**)to = pgf_parse_result_next(ps); } -static GuString -pgf_parsing_last_token(PgfParsing* ps, GuPool* pool) +static PgfParseError* +pgf_parsing_new_exception(PgfParsing* ps, GuPool* pool) { - if (ps->before == NULL) - return ""; + const uint8_t* p = (uint8_t*) ps->sentence; + const uint8_t* end = p + (ps->before ? ps->before->end_offset : 0); - const uint8_t* start = (uint8_t*) ps->sentence; - const uint8_t* end = (uint8_t*) ps->sentence + ps->before->end_offset; + PgfParseError* err = gu_new(PgfParseError, pool); + err->incomplete= (*end == 0); + err->offset = 0; + err->token_ptr = (char*) p; - const uint8_t* p = start; while (p < end) { if (gu_ucs_is_space(gu_utf8_decode(&p))) { - start = p; + err->token_ptr = (char*) p; } + err->offset++; + } + + if (err->incomplete) { + err->token_ptr = NULL; + err->token_len = 0; + return err; } while (*p && !gu_ucs_is_space(gu_utf8_decode(&p))) { end = p; } - char* tok = gu_malloc(pool, end-start+1); - memcpy(tok, start, (end-start)); - tok[end-start] = 0; - return tok; + err->token_len = ((char*)end)-err->token_ptr; + + return err; } PGF_API GuEnum* @@ -2204,7 +2221,7 @@ pgf_parse_with_heuristics(PgfConcr* concr, PgfType* typ, GuString sentence, while (gu_buf_length(ps->expr_queue) == 0) { if (!pgf_parsing_proceed(ps)) { GuExnData* exn = gu_raise(err, PgfParseError); - exn->data = (void*) pgf_parsing_last_token(ps, exn->pool); + exn->data = (void*) pgf_parsing_new_exception(ps, exn->pool); return NULL; } @@ -2249,7 +2266,7 @@ pgf_parse_with_oracle(PgfConcr* concr, PgfType* typ, while (gu_buf_length(ps->expr_queue) == 0) { if (!pgf_parsing_proceed(ps)) { GuExnData* exn = gu_raise(err, PgfParseError); - exn->data = (void*) pgf_parsing_last_token(ps, exn->pool); + exn->data = (void*) pgf_parsing_new_exception(ps, exn->pool); return NULL; } @@ -2312,7 +2329,7 @@ pgf_complete(PgfConcr* concr, PgfType* type, GuString sentence, while (ps->before->end_offset < len) { if (!pgf_parsing_proceed(ps)) { GuExnData* exn = gu_raise(err, PgfParseError); - exn->data = (void*) pgf_parsing_last_token(ps, exn->pool); + exn->data = (void*) pgf_parsing_new_exception(ps, exn->pool); return NULL; } @@ -2362,8 +2379,9 @@ pgf_sequence_cmp_fn(GuOrder* order, const void* p1, const void* p2) GuString sent = (GuString) p1; const PgfSequence* sp2 = p2; - int res = pgf_symbols_cmp(&sent, sp2->syms, self->case_sensitive); - if (res == 0 && *sent != 0) { + size_t sym_idx = 0; + int res = pgf_symbols_cmp(&sent, sp2->syms, &sym_idx, self->case_sensitive); + if (res == 0 && (*sent != 0 || sym_idx != gu_seq_length(sp2->syms))) { res = 1; } @@ -2494,7 +2512,7 @@ pgf_lookup_word_prefix(PgfConcr *concr, GuString prefix, return &state->en; } -PGF_INTERNAL void +PGF_API void pgf_parser_index(PgfConcr* concr, PgfCCat* ccat, PgfProduction prod, bool is_lexical, diff --git a/src/runtime/c/pgf/parseval.c b/src/runtime/c/pgf/parseval.c index 85df380fa..2882f7643 100644 --- a/src/runtime/c/pgf/parseval.c +++ b/src/runtime/c/pgf/parseval.c @@ -6,7 +6,7 @@ typedef struct { int start, end; PgfCId cat; - int lin_idx; + size_t lin_idx; } PgfPhrase; typedef struct { @@ -46,14 +46,14 @@ pgf_metrics_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok) } static void -pgf_metrics_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_index, PgfCId fun) +pgf_metrics_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_index, PgfCId fun) { PgfMetricsLznState* state = gu_container(funcs, PgfMetricsLznState, funcs); gu_buf_push(state->marks, int, state->pos); } static void -pgf_metrics_lzn_end_phrase1(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_idx, PgfCId fun) +pgf_metrics_lzn_end_phrase1(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_idx, PgfCId fun) { PgfMetricsLznState* state = gu_container(funcs, PgfMetricsLznState, funcs); @@ -85,7 +85,7 @@ pgf_metrics_symbol_bind(PgfLinFuncs** funcs) } static void -pgf_metrics_lzn_end_phrase2(PgfLinFuncs** funcs, PgfCId cat, int fid, int lin_idx, PgfCId fun) +pgf_metrics_lzn_end_phrase2(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lin_idx, PgfCId fun) { PgfMetricsLznState* state = gu_container(funcs, PgfMetricsLznState, funcs); diff --git a/src/runtime/c/pgf/pgf.c b/src/runtime/c/pgf/pgf.c index a1649b9ff..5317830fb 100644 --- a/src/runtime/c/pgf/pgf.c +++ b/src/runtime/c/pgf/pgf.c @@ -2,6 +2,7 @@ #include <pgf/data.h> #include <pgf/expr.h> #include <pgf/reader.h> +#include <pgf/writer.h> #include <pgf/linearizer.h> #include <gu/file.h> #include <gu/string.h> @@ -44,6 +45,28 @@ pgf_read_in(GuIn* in, return pgf; } +PGF_API_DECL void +pgf_write(PgfPGF* pgf, const char* fpath, GuExn* err) +{ + FILE* outfile = fopen(fpath, "wb"); + if (outfile == NULL) { + gu_raise_errno(err); + return; + } + + GuPool* tmp_pool = gu_local_pool(); + + // Create an input stream from the input file + GuOut* out = gu_file_out(outfile, tmp_pool); + + PgfWriter* wtr = pgf_new_writer(out, tmp_pool, err); + pgf_write_pgf(pgf, wtr); + + gu_pool_free(tmp_pool); + + fclose(outfile); +} + PGF_API GuString pgf_abstract_name(PgfPGF* pgf) { @@ -101,7 +124,7 @@ pgf_start_cat(PgfPGF* pgf, GuPool* pool) GuPool* tmp_pool = gu_local_pool(); GuIn* in = gu_string_in(lstr->val,tmp_pool); GuExn* err = gu_new_exn(tmp_pool); - PgfType *type = pgf_read_type(in, pool, err); + PgfType *type = pgf_read_type(in, pool, tmp_pool, err); if (!gu_ok(err)) break; gu_pool_free(tmp_pool); @@ -117,6 +140,29 @@ pgf_start_cat(PgfPGF* pgf, GuPool* pool) return type; } +PGF_API PgfHypos* +pgf_category_context(PgfPGF *gr, PgfCId catname) +{ + PgfAbsCat* abscat = + gu_seq_binsearch(gr->abstract.cats, pgf_abscat_order, PgfAbsCat, catname); + if (abscat == NULL) { + return NULL; + } + + return abscat->context; +} + +PGF_API prob_t +pgf_category_prob(PgfPGF* pgf, PgfCId catname) +{ + PgfAbsCat* abscat = + gu_seq_binsearch(pgf->abstract.cats, pgf_abscat_order, PgfAbsCat, catname); + if (abscat == NULL) + return INFINITY; + + return abscat->prob; +} + PGF_API GuString pgf_language_code(PgfConcr* concr) { @@ -150,7 +196,7 @@ pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err) } PGF_API void -pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, +pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, GuMapItor* itor, GuExn* err) { size_t n_funs = gu_seq_length(pgf->abstract.funs); @@ -176,7 +222,17 @@ pgf_function_type(PgfPGF* pgf, PgfCId funname) return absfun->type; } -PGF_API double +PGF_API_DECL bool +pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname) +{ + PgfAbsFun* absfun = + gu_seq_binsearch(pgf->abstract.funs, pgf_absfun_order, PgfAbsFun, funname); + if (absfun == NULL) + return false; + return (absfun->defns == NULL); +} + +PGF_API prob_t pgf_function_prob(PgfPGF* pgf, PgfCId funname) { PgfAbsFun* absfun = diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 632a1d332..6dd040b49 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/src/runtime/c/pgf/pgf.h @@ -19,6 +19,14 @@ #define PGF_INTERNAL_DECL #define PGF_INTERNAL +#elif defined(__MINGW32__) + +#define PGF_API_DECL +#define PGF_API + +#define PGF_INTERNAL_DECL +#define PGF_INTERNAL + #else #define PGF_API_DECL @@ -57,6 +65,9 @@ pgf_concrete_load(PgfConcr* concr, GuIn* in, GuExn* err); PGF_API_DECL void pgf_concrete_unload(PgfConcr* concr); +PGF_API_DECL void +pgf_write(PgfPGF* pgf, const char* fpath, GuExn* err); + PGF_API_DECL GuString pgf_abstract_name(PgfPGF*); @@ -78,6 +89,12 @@ pgf_iter_categories(PgfPGF* pgf, GuMapItor* itor, GuExn* err); PGF_API_DECL PgfType* pgf_start_cat(PgfPGF* pgf, GuPool* pool); +PGF_API_DECL PgfHypos* +pgf_category_context(PgfPGF *gr, PgfCId catname); + +PGF_API_DECL prob_t +pgf_category_prob(PgfPGF* pgf, PgfCId catname); + PGF_API_DECL void pgf_iter_functions(PgfPGF* pgf, GuMapItor* itor, GuExn* err); @@ -88,7 +105,10 @@ pgf_iter_functions_by_cat(PgfPGF* pgf, PgfCId catname, PGF_API_DECL PgfType* pgf_function_type(PgfPGF* pgf, PgfCId funname); -PGF_API_DECL double +PGF_API_DECL bool +pgf_function_is_constructor(PgfPGF* pgf, PgfCId funname); + +PGF_API_DECL prob_t pgf_function_prob(PgfPGF* pgf, PgfCId funname); PGF_API_DECL GuString @@ -122,6 +142,13 @@ PGF_API_DECL PgfExprEnum* pgf_generate_all(PgfPGF* pgf, PgfType* ty, GuExn* err, GuPool* pool, GuPool* out_pool); +typedef struct { + int incomplete; // equal to !=0 if the sentence is incomplete, 0 otherwise + size_t offset; + const char* token_ptr; + size_t token_len; +} PgfParseError; + PGF_API_DECL PgfExprEnum* pgf_parse(PgfConcr* concr, PgfType* typ, GuString sentence, GuExn* err, GuPool* pool, GuPool* out_pool); @@ -193,6 +220,7 @@ pgf_parse_with_oracle(PgfConcr* concr, PgfType* typ, typedef struct { PgfToken tok; PgfCId cat; + PgfCId fun; prob_t prob; } PgfTokenProb; diff --git a/src/runtime/c/pgf/reader.c b/src/runtime/c/pgf/reader.c index 2129269e8..d7094c9d5 100644 --- a/src/runtime/c/pgf/reader.c +++ b/src/runtime/c/pgf/reader.c @@ -936,20 +936,9 @@ pgf_read_pargs(PgfReader* rdr, PgfConcr* concr) return pargs; } -extern void -pgf_parser_index(PgfConcr* concr, - PgfCCat* ccat, PgfProduction prod, - bool is_lexical, - GuPool *pool); - -extern void -pgf_lzr_index(PgfConcr* concr, - PgfCCat* ccat, PgfProduction prod, - bool is_lexical, - GuPool *pool); - -static bool -pgf_production_is_lexical(PgfReader* rdr, PgfProductionApply *papp) +PGF_API bool +pgf_production_is_lexical(PgfProductionApply *papp, + GuBuf* non_lexical_buf, GuPool* pool) { if (gu_seq_length(papp->args) > 0) return false; @@ -969,13 +958,13 @@ pgf_production_is_lexical(PgfReader* rdr, PgfProductionApply *papp) inf.tag == PGF_SYMBOL_SOFT_SPACE || inf.tag == PGF_SYMBOL_CAPIT || inf.tag == PGF_SYMBOL_ALL_CAPIT) { - seq->idx = rdr->non_lexical_buf; + seq->idx = non_lexical_buf; return false; } } - seq->idx = gu_new_buf(PgfProductionIdxEntry, rdr->opool); - } if (seq->idx == rdr->non_lexical_buf) { + seq->idx = gu_new_buf(PgfProductionIdxEntry, pool); + } if (seq->idx == non_lexical_buf) { return false; } } @@ -1004,7 +993,7 @@ pgf_read_production(PgfReader* rdr, PgfConcr* concr, papp->args = pgf_read_pargs(rdr, concr); gu_return_on_exn(rdr->err, ); - is_lexical = pgf_production_is_lexical(rdr, papp); + is_lexical = pgf_production_is_lexical(papp, rdr->non_lexical_buf, rdr->opool); if (!is_lexical) gu_seq_set(ccat->prods, PgfProduction, (*top)++, prod); else @@ -1075,7 +1064,7 @@ pgf_read_cnccat(PgfReader* rdr, PgfAbstr* abstr, PgfConcr* concr, PgfCId name) int len = last + 1 - first; cnccat->cats = gu_new_seq(PgfCCat*, len, rdr->opool); - + for (int i = 0; i < len; i++) { int fid = first + i; PgfCCat* ccat = gu_map_get(concr->ccats, &fid, PgfCCat*); diff --git a/src/runtime/c/pgf/writer.c b/src/runtime/c/pgf/writer.c new file mode 100644 index 000000000..57c7e3c76 --- /dev/null +++ b/src/runtime/c/pgf/writer.c @@ -0,0 +1,922 @@ +#include "data.h" +#include "expr.h" +#include "writer.h" + +#include <gu/defs.h> +#include <gu/map.h> +#include <gu/seq.h> +#include <gu/assert.h> +#include <gu/in.h> +#include <gu/bits.h> +#include <gu/exn.h> +#include <gu/utf8.h> +#include <math.h> +#include <stdio.h> +#include <stdlib.h> +#if defined(__MINGW32__) || defined(_MSC_VER) +#include <malloc.h> +#endif + +// +// PgfWriter +// + +struct PgfWriter { + GuOut* out; + GuExn* err; +}; + +PGF_INTERNAL void +pgf_write_tag(uint8_t tag, PgfWriter* wtr) +{ + gu_out_u8(wtr->out, tag, wtr->err); +} + +PGF_INTERNAL void +pgf_write_uint(uint32_t val, PgfWriter* wtr) +{ + for (;;) { + uint8_t b = val & 0x7F; + val = val >> 7; + if (val == 0) { + gu_out_u8(wtr->out, b, wtr->err); + break; + } else { + gu_out_u8(wtr->out, b | 0x80, wtr->err); + gu_return_on_exn(wtr->err, ); + } + } +} + +PGF_INTERNAL void +pgf_write_int(int32_t val, PgfWriter* wtr) +{ + pgf_write_uint((uint32_t) val, wtr); +} + +PGF_INTERNAL void +pgf_write_len(size_t len, PgfWriter* wtr) +{ + pgf_write_int(len, wtr); +} + +PGF_INTERNAL void +pgf_write_cid(PgfCId id, PgfWriter* wtr) +{ + size_t len = strlen(id); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + gu_out_bytes(wtr->out, (uint8_t*) id, len, wtr->err); +} + +PGF_INTERNAL void +pgf_write_string(GuString val, PgfWriter* wtr) +{ + size_t len = strlen(val); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + gu_out_bytes(wtr->out, (uint8_t*) val, len, wtr->err); +} + +PGF_INTERNAL void +pgf_write_double(double val, PgfWriter* wtr) +{ + gu_out_f64be(wtr->out, val, wtr->err); +} + +static void +pgf_write_literal(PgfLiteral lit, PgfWriter* wtr) +{ + GuVariantInfo i = gu_variant_open(lit); + pgf_write_tag(i.tag, wtr); + gu_return_on_exn(wtr->err, ); + switch (i.tag) { + case PGF_LITERAL_STR: { + PgfLiteralStr *lstr = i.data; + pgf_write_string(lstr->val, wtr); + break; + } + case PGF_LITERAL_INT: { + PgfLiteralInt *lint = i.data; + pgf_write_int(lint->val, wtr); + break; + } + case PGF_LITERAL_FLT: { + PgfLiteralFlt *lflt = i.data; + pgf_write_double(lflt->val, wtr); + break; + } + default: + gu_impossible(); + } +} + +static void +pgf_write_flags(PgfFlags* flags, PgfWriter* wtr) +{ + size_t n_flags = gu_seq_length(flags); + pgf_write_len(n_flags, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_flags; i++) { + PgfFlag* flag = gu_seq_index(flags, PgfFlag, i); + + pgf_write_cid(flag->name, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_literal(flag->value, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_type_(PgfType* type, PgfWriter* wtr); + +static void +pgf_write_expr_(PgfExpr expr, PgfWriter* wtr) +{ + GuVariantInfo i = gu_variant_open(expr); + pgf_write_tag(i.tag, wtr); + gu_return_on_exn(wtr->err, ); + switch (i.tag) { + case PGF_EXPR_ABS:{ + PgfExprAbs *eabs = i.data; + + pgf_write_tag(eabs->bind_type, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_cid(eabs->id, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_expr_(eabs->body, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_APP: { + PgfExprApp *eapp = i.data; + + pgf_write_expr_(eapp->fun, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_expr_(eapp->arg, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_LIT: { + PgfExprLit *elit = i.data; + pgf_write_literal(elit->lit, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_META: { + PgfExprMeta *emeta = i.data; + pgf_write_int(emeta->id, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_FUN: { + PgfExprFun *efun = i.data; + pgf_write_cid(efun->fun, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_VAR: { + PgfExprVar *evar = i.data; + pgf_write_int(evar->var, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_TYPED: { + PgfExprTyped *etyped = i.data; + pgf_write_expr_(etyped->expr, wtr); + gu_return_on_exn(wtr->err, ); + pgf_write_type_(etyped->type, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_EXPR_IMPL_ARG: { + PgfExprImplArg *eimpl = i.data; + pgf_write_expr_(eimpl->expr, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + default: + gu_impossible(); + } +} + +static void +pgf_write_hypo(PgfHypo* hypo, PgfWriter* wtr) +{ + pgf_write_tag(hypo->bind_type, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_cid(hypo->cid, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_type_(hypo->type, wtr); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_type_(PgfType* type, PgfWriter* wtr) +{ + size_t n_hypos = gu_seq_length(type->hypos); + pgf_write_len(n_hypos, wtr); + gu_return_on_exn(wtr->err, ); + for (size_t i = 0; i < n_hypos; i++) { + PgfHypo* hypo = gu_seq_index(type->hypos, PgfHypo, i); + pgf_write_hypo(hypo, wtr); + gu_return_on_exn(wtr->err, ); + } + + pgf_write_cid(type->cid, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_len(type->n_exprs, wtr); + + for (size_t i = 0; i < type->n_exprs; i++) { + pgf_write_expr_(type->exprs[i], wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_patt(PgfPatt patt, PgfWriter* wtr) +{ + GuVariantInfo i = gu_variant_open(patt); + switch (i.tag) { + case PGF_PATT_APP: { + PgfPattApp *papp = i.data; + pgf_write_cid(papp->ctor, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_len(papp->n_args, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < papp->n_args; i++) { + pgf_write_patt(papp->args[i], wtr); + gu_return_on_exn(wtr->err, ); + } + break; + } + case PGF_PATT_VAR: { + PgfPattVar *papp = i.data; + pgf_write_cid(papp->var, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_PATT_AS: { + PgfPattAs *pas = i.data; + pgf_write_cid(pas->var, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_patt(pas->patt, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_PATT_WILD: { + PgfPattWild* pwild = i.data; + ((void) pwild); + break; + } + case PGF_PATT_LIT: { + PgfPattLit *plit = i.data; + pgf_write_literal(plit->lit, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_PATT_IMPL_ARG: { + PgfPattImplArg *pimpl = i.data; + pgf_write_patt(pimpl->patt, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_PATT_TILDE: { + PgfPattTilde *ptilde = i.data; + pgf_write_expr_(ptilde->expr, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + default: + gu_impossible(); + } +} + +static void +pgf_write_absfun(PgfAbsFun* absfun, PgfWriter* wtr) +{ + pgf_write_cid(absfun->name,wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_type_(absfun->type, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_int(absfun->arity, wtr); + + pgf_write_tag((absfun->defns == NULL) ? 0 : 1, wtr); + gu_return_on_exn(wtr->err, ); + + if (absfun->defns != NULL) { + size_t length = gu_seq_length(absfun->defns); + pgf_write_len(length, wtr); + gu_return_on_exn(wtr->err, ); + + PgfEquation** data = gu_seq_data(absfun->defns); + for (size_t i = 0; i < length; i++) { + PgfEquation *equ = data[i]; + + pgf_write_len(equ->n_patts, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t j = 0; j < equ->n_patts; j++) { + pgf_write_patt(equ->patts[j], wtr); + gu_return_on_exn(wtr->err, ); + } + pgf_write_expr_(equ->body, wtr); + gu_return_on_exn(wtr->err, ); + } + } + + pgf_write_double(exp(-absfun->ep.prob), wtr); +} + +static void +pgf_write_absfuns(PgfAbsFuns* absfuns, PgfWriter* wtr) +{ + size_t n_funs = gu_seq_length(absfuns); + pgf_write_len(n_funs, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_funs; i++) { + PgfAbsFun* absfun = gu_seq_index(absfuns, PgfAbsFun, i); + pgf_write_absfun(absfun, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_abscat(PgfAbsCat* abscat, PgfAbstr* abstr, PgfWriter* wtr) +{ + pgf_write_cid(abscat->name, wtr); + gu_return_on_exn(wtr->err, ); + + size_t n_hypos = gu_seq_length(abscat->context); + pgf_write_len(n_hypos, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_hypos; i++) { + PgfHypo* hypo = gu_seq_index(abscat->context, PgfHypo, i); + pgf_write_hypo(hypo, wtr); + gu_return_on_exn(wtr->err, ); + } + + size_t n_count = 0; + size_t n_funs = gu_seq_length(abstr->funs); + for (size_t i = 0; i < n_funs; i++) { + PgfAbsFun* fun = gu_seq_index(abstr->funs, PgfAbsFun, i); + + if (strcmp(fun->type->cid, abscat->name) == 0) { + n_count++; + } + } + pgf_write_len(n_count, wtr); + for (size_t i = 0; i < n_funs; i++) { + PgfAbsFun* fun = gu_seq_index(abstr->funs, PgfAbsFun, i); + + if (strcmp(fun->type->cid, abscat->name) == 0) { + gu_out_f64be(wtr->out, exp(-fun->ep.prob), wtr->err); // ignore + gu_return_on_exn(wtr->err, ); + + pgf_write_cid(fun->name, wtr); + gu_return_on_exn(wtr->err, ); + } + } + + pgf_write_double(exp(-abscat->prob), wtr); +} + +static void +pgf_write_abscats(PgfAbsCats* abscats, PgfAbstr* abstr, PgfWriter* wtr) +{ + size_t n_cats = gu_seq_length(abscats); + pgf_write_len(n_cats, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_cats; i++) { + PgfAbsCat* abscat = gu_seq_index(abscats, PgfAbsCat, i); + pgf_write_abscat(abscat, abstr, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_abstract(PgfAbstr* abstr, PgfWriter* wtr) +{ + pgf_write_cid(abstr->name, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_flags(abstr->aflags, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_absfuns(abstr->funs, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_abscats(abstr->cats, abstr, wtr); + gu_return_on_exn(wtr->err, ); +} + +typedef struct { + GuMapItor itor; + PgfWriter* wtr; +} PgfWriterIter; + +static void +pgf_write_printname(GuMapItor* self, const void* key, void* value, GuExn *err) +{ + PgfWriterIter* itor = gu_container(self, PgfWriterIter, itor); + PgfCId id = key; + GuString name = value; + + pgf_write_cid(id, itor->wtr); + gu_return_on_exn(err, ); + + pgf_write_string(name, itor->wtr); + gu_return_on_exn(err, ); +} + +static void +pgf_write_printnames(PgfCIdMap* printnames, PgfWriter* wtr) +{ + pgf_write_len(gu_map_count(printnames), wtr); + gu_return_on_exn(wtr->err, ); + + PgfWriterIter itor; + itor.itor.fn = pgf_write_printname; + itor.wtr = wtr; + gu_map_iter(printnames, &itor.itor, wtr->err); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_symbols(PgfSymbols*, PgfWriter* wtr); + +static void +pgf_write_alternative(PgfAlternative* alt, PgfWriter* wtr) +{ + pgf_write_symbols(alt->form, wtr); + gu_return_on_exn(wtr->err,); + + size_t n_prefixes = gu_seq_length(alt->prefixes); + pgf_write_len(n_prefixes, wtr); + gu_return_on_exn(wtr->err,); + + for (size_t i = 0; i < n_prefixes; i++) { + GuString prefix = gu_seq_get(alt->prefixes, GuString, i); + + pgf_write_string(prefix, wtr); + gu_return_on_exn(wtr->err,); + } +} + +static void +pgf_write_symbol(PgfSymbol sym, PgfWriter* wtr) +{ + GuVariantInfo i = gu_variant_open(sym); + + pgf_write_tag(i.tag, wtr); + switch (i.tag) { + case PGF_SYMBOL_CAT: { + PgfSymbolCat *sym_cat = i.data; + + pgf_write_int(sym_cat->d, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_int(sym_cat->r, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_SYMBOL_LIT: { + PgfSymbolLit *sym_lit = i.data; + + pgf_write_int(sym_lit->d, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_int(sym_lit->r, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_SYMBOL_VAR: { + PgfSymbolVar *sym_var = i.data; + + pgf_write_int(sym_var->d, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_int(sym_var->r, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_SYMBOL_KS: { + PgfSymbolKS *sym_ks = i.data; + pgf_write_string(sym_ks->token, wtr); + break; + } + case PGF_SYMBOL_KP: { + PgfSymbolKP *sym_kp = i.data; + pgf_write_symbols(sym_kp->default_form, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_len(sym_kp->n_forms, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < sym_kp->n_forms; i++) { + pgf_write_alternative(&sym_kp->forms[i], wtr); + gu_return_on_exn(wtr->err, ); + } + break; + } + case PGF_SYMBOL_NE: + case PGF_SYMBOL_BIND: + case PGF_SYMBOL_SOFT_BIND: + case PGF_SYMBOL_SOFT_SPACE: + case PGF_SYMBOL_CAPIT: + case PGF_SYMBOL_ALL_CAPIT: { + break; + } + default: + gu_impossible(); + } +} + +static void +pgf_write_symbols(PgfSymbols* syms, PgfWriter* wtr) +{ + size_t len = gu_seq_length(syms); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < len; i++) { + PgfSymbol sym = gu_seq_get(syms, PgfSymbol, i); + pgf_write_symbol(sym, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_sequences(PgfSequences* seqs, PgfWriter* wtr) +{ + size_t len = gu_seq_length(seqs); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < len; i++) { + PgfSymbols* syms = gu_seq_index(seqs, PgfSequence, i)->syms; + pgf_write_symbols(syms, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_cncfun(PgfCncFun* cncfun, PgfConcr* concr, PgfWriter* wtr) +{ + pgf_write_cid(cncfun->absfun->name, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_len(cncfun->n_lins, wtr); + gu_return_on_exn(wtr->err, ); + + PgfSequence* data = gu_seq_data(concr->sequences); + for (size_t i = 0; i < cncfun->n_lins; i++) { + size_t seq_id = (cncfun->lins[i] - data); + + pgf_write_int(seq_id, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_cncfuns(PgfCncFuns* cncfuns, PgfConcr* concr, PgfWriter* wtr) +{ + size_t len = gu_seq_length(cncfuns); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t funid = 0; funid < len; funid++) { + PgfCncFun* cncfun = gu_seq_get(cncfuns, PgfCncFun*, funid); + + pgf_write_cncfun(cncfun, concr, wtr); + gu_return_on_exn(wtr->err, ); + } +} + +static void +pgf_write_fid(PgfCCat* ccat, PgfWriter* wtr) +{ + pgf_write_int(ccat->fid, wtr); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_funid(PgfCncFun* cncfun, PgfWriter* wtr) +{ + pgf_write_int(cncfun->funid, wtr); + gu_return_on_exn(wtr->err, ); +} + +typedef struct { + GuMapItor itor; + PgfWriter* wtr; + bool do_count; + bool do_defs; + size_t count; +} PgfLinDefRefIter; + +static void +pgf_write_ccat_lindefrefs(GuMapItor* self, const void* key, void* value, GuExn *err) +{ + PgfLinDefRefIter* itor = gu_container(self, PgfLinDefRefIter, itor); + PgfCCat* ccat = *((PgfCCat**) value); + + PgfCncFuns* funs = (itor->do_defs) ? ccat->lindefs : ccat->linrefs; + if (funs != NULL) { + if (itor->do_count) { + itor->count++; + } else { + pgf_write_fid(ccat, itor->wtr); + gu_return_on_exn(err, ); + + size_t n_funs = gu_seq_length(funs); + pgf_write_len(n_funs, itor->wtr); + gu_return_on_exn(err, ); + + for (size_t j = 0; j < n_funs; j++) { + PgfCncFun* fun = gu_seq_get(funs, PgfCncFun*, j); + pgf_write_funid(fun, itor->wtr); + } + } + } +} + +static void +pgf_write_lindefs(PgfWriter* wtr, PgfConcr* concr) +{ + PgfLinDefRefIter itor; + itor.itor.fn = pgf_write_ccat_lindefrefs; + itor.wtr = wtr; + itor.do_count= true; + itor.do_defs = true; + itor.count = 0; + gu_map_iter(concr->ccats, &itor.itor, wtr->err); + + pgf_write_len(itor.count, wtr); + gu_return_on_exn(wtr->err, ); + + itor.do_count = false; + gu_map_iter(concr->ccats, &itor.itor, wtr->err); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_linrefs(PgfWriter* wtr, PgfConcr* concr) +{ + PgfLinDefRefIter itor; + itor.itor.fn = pgf_write_ccat_lindefrefs; + itor.wtr = wtr; + itor.do_count= true; + itor.do_defs = false; + itor.count = 0; + gu_map_iter(concr->ccats, &itor.itor, wtr->err); + + pgf_write_len(itor.count, wtr); + gu_return_on_exn(wtr->err, ); + + itor.do_count = false; + gu_map_iter(concr->ccats, &itor.itor, wtr->err); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_parg(PgfPArg* parg, PgfWriter* wtr) +{ + size_t n_hoas = gu_seq_length(parg->hypos); + pgf_write_len(n_hoas, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_hoas; i++) { + PgfCCat* ccat = gu_seq_get(parg->hypos, PgfCCat*, i); + pgf_write_fid(ccat, wtr); + gu_return_on_exn(wtr->err, ); + } + + pgf_write_fid(parg->ccat, wtr); + gu_return_on_exn(wtr->err, ); +} + +static void +pgf_write_pargs(PgfPArgs* pargs, PgfWriter* wtr) +{ + size_t len = gu_seq_length(pargs); + pgf_write_len(len, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < len; i++) { + PgfPArg* parg = gu_seq_index(pargs, PgfPArg, i); + pgf_write_parg(parg, wtr); + } +} + +static void +pgf_write_production(PgfProduction prod, PgfWriter* wtr) +{ + GuVariantInfo i = gu_variant_open(prod); + pgf_write_tag(i.tag, wtr); + switch (i.tag) { + case PGF_PRODUCTION_APPLY: { + PgfProductionApply *papp = i.data; + + pgf_write_funid(papp->fun, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_pargs(papp->args, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + case PGF_PRODUCTION_COERCE: { + PgfProductionCoerce *pcoerce = i.data; + + pgf_write_fid(pcoerce->coerce, wtr); + gu_return_on_exn(wtr->err, ); + break; + } + default: + gu_impossible(); + } +} + +static void +pgf_write_ccat(GuMapItor* self, const void* key, void* value, GuExn *err) +{ + PgfWriterIter* itor = gu_container(self, PgfWriterIter, itor); + PgfCCat* ccat = *((PgfCCat**) value); + + pgf_write_fid(ccat, itor->wtr); + gu_return_on_exn(err, ); + + size_t n_prods = ccat->prods ? gu_seq_length(ccat->prods) : 0; + pgf_write_len(n_prods, itor->wtr); + gu_return_on_exn(err, ); + + for (size_t i = 0; i < n_prods; i++) { + PgfProduction prod = gu_seq_get(ccat->prods, PgfProduction, i); + pgf_write_production(prod, itor->wtr); + gu_return_on_exn(err, ); + } +} + +static void +pgf_write_ccats(GuMap* ccats, PgfWriter* wtr) +{ + pgf_write_len(gu_map_count(ccats), wtr); + gu_return_on_exn(wtr->err, ); + + PgfWriterIter itor; + itor.itor.fn = pgf_write_ccat; + itor.wtr = wtr; + gu_map_iter(ccats, &itor.itor, wtr->err); +} + +static void +pgf_write_cnccat(PgfCncCat* cnccat, PgfWriter* wtr) +{ + size_t len = gu_seq_length(cnccat->cats); + PgfCCat* first = gu_seq_get(cnccat->cats, PgfCCat*, 0); + PgfCCat* last = gu_seq_get(cnccat->cats, PgfCCat*, len-1); + pgf_write_fid(first,wtr); + pgf_write_fid(last,wtr); + pgf_write_len(cnccat->n_lins, wtr); + + for (size_t i = 0; i < cnccat->n_lins; i++) { + pgf_write_string(cnccat->labels[i], wtr); + } +} + +static void +pgf_write_cnccat_iter(GuMapItor* self, const void* key, void* value, GuExn *err) +{ + PgfWriterIter* itor = gu_container(self, PgfWriterIter, itor); + PgfCncCat* cnccat = *((PgfCncCat**) value); + + pgf_write_cid(cnccat->abscat->name, itor->wtr); + gu_return_on_exn(err, ); + + pgf_write_cnccat(cnccat, itor->wtr); +} + +static void +pgf_write_cnccats(PgfCIdMap* cnccats, PgfWriter* wtr) +{ + pgf_write_len(gu_map_count(cnccats), wtr); + gu_return_on_exn(wtr->err, ); + + PgfWriterIter itor; + itor.itor.fn = pgf_write_cnccat_iter; + itor.wtr = wtr; + gu_map_iter(cnccats, &itor.itor, wtr->err); +} + +static void +pgf_write_concrete_content(PgfConcr* concr, PgfWriter* wtr) +{ + pgf_write_printnames(concr->printnames, wtr); + gu_return_on_exn(wtr->err,); + + pgf_write_sequences(concr->sequences, wtr); + gu_return_on_exn(wtr->err,); + + pgf_write_cncfuns(concr->cncfuns, concr, wtr); + gu_return_on_exn(wtr->err,); + + pgf_write_lindefs(wtr, concr); + pgf_write_linrefs(wtr, concr); + pgf_write_ccats(concr->ccats, wtr); + pgf_write_cnccats(concr->cnccats, wtr); + pgf_write_int(concr->total_cats, wtr); +} + +static void +pgf_write_concrete(PgfConcr* concr, PgfWriter* wtr, bool with_content) +{ + if (with_content && + (concr->sequences == NULL || concr->cncfuns == NULL || + concr->ccats == NULL || concr->cnccats == NULL)) { + // the syntax is not loaded so we must skip it. + return; + } + + pgf_write_cid(concr->name, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_flags(concr->cflags, wtr); + gu_return_on_exn(wtr->err, ); + + if (with_content) { + pgf_write_concrete_content(concr, wtr); + } + gu_return_on_exn(wtr->err, ); +} + +PGF_API void +pgf_concrete_save(PgfConcr* concr, GuOut* out, GuExn* err) +{ + GuPool* pool = gu_new_pool(); + + PgfWriter* wtr = pgf_new_writer(out, pool, err); + + pgf_write_concrete(concr, wtr, true); + + gu_pool_free(pool); +} + +static void +pgf_write_concretes(PgfConcrs* concretes, PgfWriter* wtr, bool with_content) +{ + size_t n_concrs = gu_seq_length(concretes); + pgf_write_len(n_concrs, wtr); + gu_return_on_exn(wtr->err, ); + + for (size_t i = 0; i < n_concrs; i++) { + PgfConcr* concr = gu_seq_index(concretes, PgfConcr, i); + pgf_write_concrete(concr, wtr, with_content); + gu_return_on_exn(wtr->err, ); + } +} + +PGF_INTERNAL void +pgf_write_pgf(PgfPGF* pgf, PgfWriter* wtr) { + gu_out_u16be(wtr->out, pgf->major_version, wtr->err); + gu_return_on_exn(wtr->err, ); + + gu_out_u16be(wtr->out, pgf->minor_version, wtr->err); + gu_return_on_exn(wtr->err, ); + + pgf_write_flags(pgf->gflags, wtr); + gu_return_on_exn(wtr->err, ); + + pgf_write_abstract(&pgf->abstract, wtr); + gu_return_on_exn(wtr->err, ); + + bool with_content = + (gu_seq_binsearch(pgf->gflags, pgf_flag_order, PgfFlag, "split") == NULL); + pgf_write_concretes(pgf->concretes, wtr, with_content); + gu_return_on_exn(wtr->err, ); +} + +PGF_INTERNAL PgfWriter* +pgf_new_writer(GuOut* out, GuPool* pool, GuExn* err) +{ + PgfWriter* wtr = gu_new(PgfWriter, pool); + wtr->out = out; + wtr->err = err; + return wtr; +} + diff --git a/src/runtime/c/pgf/writer.h b/src/runtime/c/pgf/writer.h new file mode 100644 index 000000000..de99ee266 --- /dev/null +++ b/src/runtime/c/pgf/writer.h @@ -0,0 +1,39 @@ +#ifndef WRITER_H_ +#define WRITER_H_ + +#include <gu/exn.h> +#include <gu/mem.h> +#include <gu/in.h> + +// the writer interface + +typedef struct PgfWriter PgfWriter; + +PGF_INTERNAL_DECL PgfWriter* +pgf_new_writer(GuOut* out, GuPool* pool, GuExn* err); + +PGF_INTERNAL_DECL void +pgf_write_tag(uint8_t tag, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_uint(uint32_t val, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_int(int32_t val, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_string(GuString val, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_double(double val, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_len(size_t len, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_cid(PgfCId id, PgfWriter* wtr); + +PGF_INTERNAL_DECL void +pgf_write_pgf(PgfPGF* pgf, PgfWriter* wtr); + +#endif // WRITER_H_ diff --git a/src/runtime/c/sg/sqlite3Btree.c b/src/runtime/c/sg/sqlite3Btree.c index 999606791..a75cfd62b 100644 --- a/src/runtime/c/sg/sqlite3Btree.c +++ b/src/runtime/c/sg/sqlite3Btree.c @@ -5040,6 +5040,30 @@ SQLITE_PRIVATE int sqlite3VdbeRecordCompareWithSkip(int, const void *, UnpackedR */ /* #include "sqliteInt.h" */ +/* An array to map all upper-case characters into their corresponding +** lower-case character. +** +** SQLite only considers US-ASCII (or EBCDIC) characters. We do not +** handle case conversions for the UTF character set since the tables +** involved are nearly as big or bigger than SQLite itself. +*/ +const unsigned char sqlite3UpperToLower[] = { + 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, + 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, 30, 31, 32, 33, 34, 35, + 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 46, 47, 48, 49, 50, 51, 52, 53, + 54, 55, 56, 57, 58, 59, 60, 61, 62, 63, 64, 97, 98, 99,100,101,102,103, + 104,105,106,107,108,109,110,111,112,113,114,115,116,117,118,119,120,121, + 122, 91, 92, 93, 94, 95, 96, 97, 98, 99,100,101,102,103,104,105,106,107, + 108,109,110,111,112,113,114,115,116,117,118,119,120,121,122,123,124,125, + 126,127,128,129,130,131,132,133,134,135,136,137,138,139,140,141,142,143, + 144,145,146,147,148,149,150,151,152,153,154,155,156,157,158,159,160,161, + 162,163,164,165,166,167,168,169,170,171,172,173,174,175,176,177,178,179, + 180,181,182,183,184,185,186,187,188,189,190,191,192,193,194,195,196,197, + 198,199,200,201,202,203,204,205,206,207,208,209,210,211,212,213,214,215, + 216,217,218,219,220,221,222,223,224,225,226,227,228,229,230,231,232,233, + 234,235,236,237,238,239,240,241,242,243,244,245,246,247,248,249,250,251, + 252,253,254,255 +}; /* EVIDENCE-OF: R-02982-34736 In order to maintain full backwards ** compatibility for legacy applications, the URI filename capability is ** disabled by default. @@ -9063,6 +9087,22 @@ SQLITE_PRIVATE int sqlite3Strlen30(const char *z){ return 0x3fffffff & (int)strlen(z); } +/* Convenient short-hand */ +#define UpperToLower sqlite3UpperToLower + +int sqlite3StrICmp(const char *zLeft, const char *zRight){ + unsigned char *a, *b; + int c; + a = (unsigned char *)zLeft; + b = (unsigned char *)zRight; + for(;;){ + c = (int)UpperToLower[*a] - (int)UpperToLower[*b]; + if( c || *a==0 ) break; + a++; + b++; + } + return c; +} /* ** The string z[] is an text representation of a real number. ** Convert this string to a double and write it into *pResult. @@ -17831,13 +17871,6 @@ struct winFile { #define WINFILE_PSOW 0x10 /* SQLITE_IOCAP_POWERSAFE_OVERWRITE */ /* - * The size of the buffer used by sqlite3_win32_write_debug(). - */ -#ifndef SQLITE_WIN32_DBG_BUF_SIZE -# define SQLITE_WIN32_DBG_BUF_SIZE ((int)(4096-sizeof(DWORD))) -#endif - -/* * The value used with sqlite3_win32_set_directory() to specify that * the temporary directory should be changed. */ @@ -18786,43 +18819,6 @@ SQLITE_PRIVATE int sqlite3_win32_reset_heap(){ #endif /* SQLITE_WIN32_MALLOC */ /* -** This function outputs the specified (ANSI) string to the Win32 debugger -** (if available). -*/ - -SQLITE_PRIVATE void sqlite3_win32_write_debug(const char *zBuf, int nBuf){ - char zDbgBuf[SQLITE_WIN32_DBG_BUF_SIZE]; - int nMin = MIN(nBuf, (SQLITE_WIN32_DBG_BUF_SIZE - 1)); /* may be negative. */ - if( nMin<-1 ) nMin = -1; /* all negative values become -1. */ - assert( nMin==-1 || nMin==0 || nMin<SQLITE_WIN32_DBG_BUF_SIZE ); -#if defined(SQLITE_WIN32_HAS_ANSI) - if( nMin>0 ){ - memset(zDbgBuf, 0, SQLITE_WIN32_DBG_BUF_SIZE); - memcpy(zDbgBuf, zBuf, nMin); - osOutputDebugStringA(zDbgBuf); - }else{ - osOutputDebugStringA(zBuf); - } -#elif defined(SQLITE_WIN32_HAS_WIDE) - memset(zDbgBuf, 0, SQLITE_WIN32_DBG_BUF_SIZE); - if ( osMultiByteToWideChar( - osAreFileApisANSI() ? CP_ACP : CP_OEMCP, 0, zBuf, - nMin, (LPWSTR)zDbgBuf, SQLITE_WIN32_DBG_BUF_SIZE/sizeof(WCHAR))<=0 ){ - return; - } - osOutputDebugStringW((LPCWSTR)zDbgBuf); -#else - if( nMin>0 ){ - memset(zDbgBuf, 0, SQLITE_WIN32_DBG_BUF_SIZE); - memcpy(zDbgBuf, zBuf, nMin); - fprintf(stderr, "%s", zDbgBuf); - }else{ - fprintf(stderr, "%s", zBuf); - } -#endif -} - -/* ** The following routine suspends the current thread for at least ms ** milliseconds. This is equivalent to the Win32 Sleep() interface. */ @@ -19264,40 +19260,6 @@ SQLITE_PRIVATE char *sqlite3_win32_utf8_to_mbcs(const char *zFilename){ } /* -** This function sets the data directory or the temporary directory based on -** the provided arguments. The type argument must be 1 in order to set the -** data directory or 2 in order to set the temporary directory. The zValue -** argument is the name of the directory to use. The return value will be -** SQLITE_OK if successful. -*/ -SQLITE_PRIVATE int sqlite3_win32_set_directory(DWORD type, LPCWSTR zValue){ - char **ppDirectory = 0; -#ifndef SQLITE_OMIT_AUTOINIT - int rc = sqlite3BtreeInitialize(); - if( rc ) return rc; -#endif - if( type==SQLITE_WIN32_TEMP_DIRECTORY_TYPE ){ - ppDirectory = &sqlite3_temp_directory; - } - assert( !ppDirectory || type==SQLITE_WIN32_TEMP_DIRECTORY_TYPE - ); - assert( !ppDirectory || sqlite3MemdebugHasType(*ppDirectory, MEMTYPE_HEAP) ); - if( ppDirectory ){ - char *zValueUtf8 = 0; - if( zValue && zValue[0] ){ - zValueUtf8 = winUnicodeToUtf8(zValue); - if ( zValueUtf8==0 ){ - return SQLITE_NOMEM; - } - } - sqlite3_free(*ppDirectory); - *ppDirectory = zValueUtf8; - return SQLITE_OK; - } - return SQLITE_ERROR; -} - -/* ** The return value of winGetLastErrorMsg ** is zero if the error message fits in the buffer, or non-zero ** otherwise (if the message was truncated). @@ -22368,9 +22330,6 @@ static int winOpen( if( isReadonly ){ pFile->ctrlFlags |= WINFILE_RDONLY; } - if( sqlite3_uri_boolean(zName, "psow", SQLITE_POWERSAFE_OVERWRITE) ){ - pFile->ctrlFlags |= WINFILE_PSOW; - } pFile->lastErrno = NO_ERROR; pFile->zPath = zName; #if SQLITE_MAX_MMAP_SIZE>0 @@ -22590,43 +22549,6 @@ static BOOL winIsDriveLetterAndColon( } /* -** Returns non-zero if the specified path name should be used verbatim. If -** non-zero is returned from this function, the calling function must simply -** use the provided path name verbatim -OR- resolve it into a full path name -** using the GetFullPathName Win32 API function (if available). -*/ -static BOOL winIsVerbatimPathname( - const char *zPathname -){ - /* - ** If the path name starts with a forward slash or a backslash, it is either - ** a legal UNC name, a volume relative path, or an absolute path name in the - ** "Unix" format on Windows. There is no easy way to differentiate between - ** the final two cases; therefore, we return the safer return value of TRUE - ** so that callers of this function will simply use it verbatim. - */ - if ( winIsDirSep(zPathname[0]) ){ - return TRUE; - } - - /* - ** If the path name starts with a letter and a colon it is either a volume - ** relative path or an absolute path. Callers of this function must not - ** attempt to treat it as a relative path name (i.e. they should simply use - ** it verbatim). - */ - if ( winIsDriveLetterAndColon(zPathname) ){ - return TRUE; - } - - /* - ** If we get to this point, the path name should almost certainly be a purely - ** relative one (i.e. not a UNC name, not absolute, and not volume relative). - */ - return FALSE; -} - -/* ** Turn a relative pathname into a full pathname. Write the full ** pathname into zOut[]. zOut[] will be at least pVfs->mxPathname ** bytes in size. diff --git a/src/runtime/dotNet/Bracket.cs b/src/runtime/dotNet/Bracket.cs index 1fc4c0db7..6fd8756f8 100644 --- a/src/runtime/dotNet/Bracket.cs +++ b/src/runtime/dotNet/Bracket.cs @@ -64,17 +64,17 @@ namespace PGFSharp stack.Peek ().AddChild (new StringChildBracket (str)); } - private void BeginPhrase(IntPtr self, IntPtr cat, int fid, int lindex, IntPtr fun) { + private void BeginPhrase(IntPtr self, IntPtr cat, int fid, UIntPtr lindex, IntPtr fun) { stack.Push (new Bracket ()); } - private void EndPhrase(IntPtr self, IntPtr cat, int fid, int lindex, IntPtr fun) { + private void EndPhrase(IntPtr self, IntPtr cat, int fid, UIntPtr lindex, IntPtr fun) { var b = stack.Pop (); b.CatName = Native.NativeString.StringFromNativeUtf8 (cat); b.FunName = Native.NativeString.StringFromNativeUtf8 (fun); b.FId = fid; - b.LIndex = lindex; + b.LIndex = (int) lindex; if (stack.Count == 0) final = b; diff --git a/src/runtime/dotNet/Expr.cs b/src/runtime/dotNet/Expr.cs index dada28fc0..407ea4af3 100644 --- a/src/runtime/dotNet/Expr.cs +++ b/src/runtime/dotNet/Expr.cs @@ -46,7 +46,7 @@ namespace PGFSharp using (var strNative = new Native.NativeString(exprStr)) { var in_ = NativeGU.gu_data_in(strNative.Ptr, strNative.Size, tmp_pool.Ptr); - var expr = Native.pgf_read_expr(in_, result_pool.Ptr, exn.Ptr); + var expr = Native.pgf_read_expr(in_, result_pool.Ptr, tmp_pool.Ptr, exn.Ptr); if (exn.IsRaised || expr == IntPtr.Zero) { throw new PGFError(); diff --git a/src/runtime/dotNet/Native.cs b/src/runtime/dotNet/Native.cs index 5c750e010..0c055ffd8 100644 --- a/src/runtime/dotNet/Native.cs +++ b/src/runtime/dotNet/Native.cs @@ -128,7 +128,7 @@ namespace PGFSharp public static extern IntPtr pgf_function_type(IntPtr pgf, IntPtr funNameStr); [DllImport(LIBNAME, CallingConvention = CC)] - public static extern IntPtr pgf_read_type(IntPtr in_, IntPtr pool, IntPtr err); + public static extern IntPtr pgf_read_type(IntPtr in_, IntPtr pool, IntPtr tmp_pool, IntPtr err); [DllImport(LIBNAME, CallingConvention = CC)] public static extern void pgf_print_type(IntPtr expr, IntPtr ctxt, int prec, IntPtr output, IntPtr err); @@ -139,7 +139,7 @@ namespace PGFSharp public static extern void pgf_print_expr(IntPtr expr, IntPtr ctxt, int prec, IntPtr output, IntPtr err); [DllImport(LIBNAME, CallingConvention = CC)] - public static extern IntPtr pgf_read_expr(IntPtr in_, IntPtr pool, IntPtr err); + public static extern IntPtr pgf_read_expr(IntPtr in_, IntPtr pool, IntPtr tmp_pool, IntPtr err); [DllImport(LIBNAME, CallingConvention = CC)] public static extern IntPtr pgf_compute(IntPtr pgf, IntPtr expr, IntPtr err, IntPtr tmp_pool, IntPtr res_pool); @@ -207,10 +207,10 @@ namespace PGFSharp public delegate void LinFuncSymbolToken(IntPtr self, IntPtr token); [UnmanagedFunctionPointer(CallingConvention.Cdecl)] - public delegate void LinFuncBeginPhrase(IntPtr self, IntPtr cat, int fid, int lindex, IntPtr fun); + public delegate void LinFuncBeginPhrase(IntPtr self, IntPtr cat, int fid, UIntPtr lindex, IntPtr fun); [UnmanagedFunctionPointer(CallingConvention.Cdecl)] - public delegate void LinFuncEndPhrase(IntPtr self, IntPtr cat, int fid, int lindex, IntPtr fun); + public delegate void LinFuncEndPhrase(IntPtr self, IntPtr cat, int fid, UIntPtr lindex, IntPtr fun); [UnmanagedFunctionPointer(CallingConvention.Cdecl)] public delegate void LinFuncSymbolNonexistant(IntPtr self); diff --git a/src/runtime/dotNet/Type.cs b/src/runtime/dotNet/Type.cs index bf31f8117..819af0b7b 100644 --- a/src/runtime/dotNet/Type.cs +++ b/src/runtime/dotNet/Type.cs @@ -43,7 +43,7 @@ namespace PGFSharp using (var strNative = new Native.NativeString(typeStr)) { var in_ = NativeGU.gu_data_in(strNative.Ptr, strNative.Size, tmp_pool.Ptr); - var typ = Native.pgf_read_type(in_, result_pool.Ptr, exn.Ptr); + var typ = Native.pgf_read_type(in_, result_pool.Ptr, tmp_pool.Ptr, exn.Ptr); if (exn.IsRaised || typ == IntPtr.Zero) { throw new PGFError(); diff --git a/src/runtime/haskell-bind/PGF2.hsc b/src/runtime/haskell-bind/PGF2.hsc index 037145ee6..895d13ca4 100644 --- a/src/runtime/haskell-bind/PGF2.hsc +++ b/src/runtime/haskell-bind/PGF2.hsc @@ -19,7 +19,7 @@ #include <gu/exn.h> module PGF2 (-- * PGF - PGF,readPGF, + PGF,readPGF,showPGF, -- * Identifiers CId, @@ -27,11 +27,12 @@ module PGF2 (-- * PGF -- * Abstract syntax AbsName,abstractName, -- ** Categories - Cat,categories,showCategory, + Cat,categories,categoryContext, -- ** Functions - Fun,functions, functionsByCat, functionType, hasLinearization, + Fun, functions, functionsByCat, + functionType, functionIsConstructor, hasLinearization, -- ** Expressions - Expr,showExpr,readExpr, + Expr,showExpr,readExpr,pExpr, mkAbs,unAbs, mkApp,unApp, mkStr,unStr, @@ -39,11 +40,12 @@ module PGF2 (-- * PGF mkFloat,unFloat, mkMeta,unMeta, mkCId, + exprHash, exprSize, exprFunctions, exprSubstitute, treeProbability, -- ** Types Type, Hypo, BindType(..), startCat, - readType, showType, + readType, showType, showContext, mkType, unType, -- ** Type checking @@ -53,14 +55,16 @@ module PGF2 (-- * PGF compute, -- * Concrete syntax - ConcName,Concr,languages,concreteName, + ConcName,Concr,languages,concreteName,languageCode, + -- ** Linearization linearize,linearizeAll,tabularLinearize,tabularLinearizeAll,bracketedLinearize, FId, LIndex, BracketedString(..), showBracketedString, flattenBracketedString, + printName, alignWords, -- ** Parsing - parse, parseWithHeuristics, + ParseOutput(..), parse, parseWithHeuristics, -- ** Sentence Lookup lookupSentence, -- ** Generation @@ -78,7 +82,7 @@ module PGF2 (-- * PGF LiteralCallback,literalCallbacks ) where -import Prelude hiding (fromEnum) +import Prelude hiding (fromEnum,(<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import Control.Exception(Exception,throwIO) import Control.Monad(forM_) import System.IO.Unsafe(unsafePerformIO,unsafeInterleaveIO) @@ -134,6 +138,17 @@ readPGF fpath = pgfFPtr <- newForeignPtr gu_pool_finalizer pool return (PGF pgf (touchForeignPtr pgfFPtr)) +showPGF :: PGF -> String +showPGF p = + unsafePerformIO $ + withGuPool $ \tmpPl -> + do (sb,out) <- newOut tmpPl + exn <- gu_new_exn tmpPl + pgf_print (pgf p) out exn + touchPGF p + s <- gu_string_buf_freeze sb tmpPl + peekUtf8CString s + -- | List of all languages available in the grammar. languages :: PGF -> Map.Map ConcName Concr languages p = @@ -158,6 +173,10 @@ languages p = concreteName :: Concr -> ConcName concreteName c = unsafePerformIO (peekUtf8CString =<< pgf_concrete_name (concr c)) +languageCode :: Concr -> String +languageCode c = unsafePerformIO (peekUtf8CString =<< pgf_language_code (concr c)) + + -- | Generates an exhaustive possibly infinite list of -- all abstract syntax expressions of the given type. -- The expressions are ordered by their probability. @@ -222,6 +241,16 @@ functionType p fn = then Nothing else Just (Type c_type (touchPGF p))) +-- | The type of a function +functionIsConstructor :: PGF -> Fun -> Bool +functionIsConstructor p fn = + unsafePerformIO $ + withGuPool $ \tmpPl -> do + c_fn <- newUtf8CString fn tmpPl + res <- pgf_function_is_constructor (pgf p) c_fn + touchPGF p + return (res /= 0) + -- | Checks an expression against a specified type. checkExpr :: PGF -> Expr -> Type -> Either String Expr checkExpr (PGF p _) (Expr c_expr touch1) (Type c_ty touch2) = @@ -323,6 +352,45 @@ treeProbability (PGF p _) (Expr c_expr touch1) = touch1 return (realToFrac res) +exprHash :: Int32 -> Expr -> Int32 +exprHash h (Expr c_expr touch1) = + unsafePerformIO $ do + h <- pgf_expr_hash (fromIntegral h) c_expr + touch1 + return (fromIntegral h) + +exprSize :: Expr -> Int +exprSize (Expr c_expr touch1) = + unsafePerformIO $ do + size <- pgf_expr_size c_expr + touch1 + return (fromIntegral size) + +exprFunctions :: Expr -> [Fun] +exprFunctions (Expr c_expr touch) = + unsafePerformIO $ + withGuPool $ \tmpPl -> do + seq <- pgf_expr_functions c_expr tmpPl + len <- (#peek GuSeq, len) seq + arr <- peekArray (fromIntegral (len :: CInt)) (seq `plusPtr` (#offset GuSeq, data)) + funs <- mapM peekUtf8CString arr + touch + return funs + +exprSubstitute :: Expr -> [Expr] -> Expr +exprSubstitute (Expr c_expr touch) meta_values = + unsafePerformIO $ + withGuPool $ \tmpPl -> do + c_meta_values <- newSequence (#size PgfExpr) pokeExpr meta_values tmpPl + exprPl <- gu_new_pool + c_expr <- pgf_expr_substitute c_expr c_meta_values exprPl + touch + exprFPl <- newForeignPtr gu_pool_finalizer exprPl + let touch' = sequence_ (touchForeignPtr exprFPl : map touchExpr meta_values) + return (Expr c_expr touch') + where + pokeExpr ptr (Expr c_expr _) = poke ptr c_expr + ----------------------------------------------------------------------------- -- Graphviz @@ -448,7 +516,15 @@ getAnalysis ref self c_lemma c_anal prob exn = do anal <- peekUtf8CString c_anal writeIORef ref ((lemma, anal, prob):ans) -parse :: Concr -> Type -> String -> Either String [(Expr,Float)] +-- | This data type encodes the different outcomes which you could get from the parser. +data ParseOutput + = ParseFailed Int String -- ^ The integer is the position in number of unicode characters where the parser failed. + -- The string is the token where the parser have failed. + | ParseOk [(Expr,Float)] -- ^ 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. + +parse :: Concr -> Type -> String -> ParseOutput parse lang ty sent = parseWithHeuristics lang ty sent (-1.0) [] parseWithHeuristics :: Concr -- ^ the language with which we parse @@ -465,8 +541,8 @@ parseWithHeuristics :: Concr -- ^ the language with which we parse -- the input sentence; the current offset in the sentence. -- If a literal has been recognized then the output should -- be Just (expr,probability,end_offset) - -> Either String [(Expr,Float)] -parseWithHeuristics lang (Type ctype _) sent heuristic callbacks = + -> ParseOutput +parseWithHeuristics lang (Type ctype touchType) sent heuristic callbacks = unsafePerformIO $ do exprPl <- gu_new_pool parsePl <- gu_new_pool @@ -474,15 +550,24 @@ parseWithHeuristics lang (Type ctype _) sent heuristic callbacks = sent <- newUtf8CString sent parsePl callbacks_map <- mkCallbacksMap (concr lang) callbacks parsePl enum <- pgf_parse_with_heuristics (concr lang) ctype sent heuristic callbacks_map exn parsePl exprPl + touchType failed <- gu_exn_is_raised exn if failed then do is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError if is_parse_error - then do c_tok <- (#peek GuExn, data.data) exn - tok <- peekUtf8CString c_tok - gu_pool_free parsePl - gu_pool_free exprPl - return (Left tok) + then do c_err <- (#peek GuExn, data.data) exn + c_incomplete <- (#peek PgfParseError, incomplete) c_err + if (c_incomplete :: CInt) == 0 + then do c_offset <- (#peek PgfParseError, offset) c_err + token_ptr <- (#peek PgfParseError, token_ptr) c_err + token_len <- (#peek PgfParseError, token_len) c_err + tok <- peekUtf8CStringLen token_ptr token_len + gu_pool_free parsePl + gu_pool_free exprPl + return (ParseFailed (fromIntegral (c_offset :: CInt)) tok) + else do gu_pool_free parsePl + gu_pool_free exprPl + return ParseIncomplete else do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn if is_exn then do c_msg <- (#peek GuExn, data.data) exn @@ -496,7 +581,7 @@ parseWithHeuristics lang (Type ctype _) sent heuristic callbacks = else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl exprFPl <- newForeignPtr gu_pool_finalizer exprPl exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl) - return (Right exprs) + return (ParseOk exprs) mkCallbacksMap :: Ptr PgfConcr -> [(String, Int -> Int -> Maybe (Expr,Float,Int))] -> Ptr GuPool -> IO (Ptr PgfCallbacksMap) mkCallbacksMap concr callbacks pool = do @@ -524,7 +609,7 @@ mkCallbacksMap concr callbacks pool = do c_str <- gu_string_buf_freeze sb tmpPl guin <- gu_string_in c_str tmpPl - pgf_read_expr guin out_pool exn + pgf_read_expr guin out_pool tmpPl exn ep <- gu_malloc out_pool (#size PgfExprProb) (#poke PgfExprProb, expr) ep c_e @@ -563,7 +648,7 @@ parseWithOracle :: Concr -- ^ the language with which we parse -> Cat -- ^ the start category -> String -- ^ the input sentence -> Oracle - -> Either String [(Expr,Float)] + -> ParseOutput parseWithOracle lang cat sent (predict,complete,literal) = unsafePerformIO $ do parsePl <- gu_new_pool @@ -580,11 +665,19 @@ parseWithOracle lang cat sent (predict,complete,literal) = if failed then do is_parse_error <- gu_exn_caught exn gu_exn_type_PgfParseError if is_parse_error - then do c_tok <- (#peek GuExn, data.data) exn - tok <- peekUtf8CString c_tok - gu_pool_free parsePl - gu_pool_free exprPl - return (Left tok) + then do c_err <- (#peek GuExn, data.data) exn + c_incomplete <- (#peek PgfParseError, incomplete) c_err + if (c_incomplete :: CInt) == 0 + then do c_offset <- (#peek PgfParseError, offset) c_err + token_ptr <- (#peek PgfParseError, token_ptr) c_err + token_len <- (#peek PgfParseError, token_len) c_err + tok <- peekUtf8CStringLen token_ptr token_len + gu_pool_free parsePl + gu_pool_free exprPl + return (ParseFailed (fromIntegral (c_offset :: CInt)) tok) + else do gu_pool_free parsePl + gu_pool_free exprPl + return ParseIncomplete else do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn if is_exn then do c_msg <- (#peek GuExn, data.data) exn @@ -598,7 +691,7 @@ parseWithOracle lang cat sent (predict,complete,literal) = else do parseFPl <- newForeignPtr gu_pool_finalizer parsePl exprFPl <- newForeignPtr gu_pool_finalizer exprPl exprs <- fromPgfExprEnum enum parseFPl (touchConcr lang >> touchForeignPtr exprFPl) - return (Right exprs) + return (ParseOk exprs) where oracleWrapper oracle catPtr lblPtr offset = do cat <- peekUtf8CString catPtr @@ -623,7 +716,7 @@ parseWithOracle lang cat sent (predict,complete,literal) = c_str <- gu_string_buf_freeze sb tmpPl guin <- gu_string_in c_str tmpPl - pgf_read_expr guin out_pool exn + pgf_read_expr guin out_pool tmpPl exn ep <- gu_malloc out_pool (#size PgfExprProb) (#poke PgfExprProb, expr) ep c_e @@ -881,6 +974,7 @@ alignWords lang e = unsafePerformIO $ withGuPool $ \pl -> do exn <- gu_new_exn pl seq <- pgf_align_words (concr lang) (expr e) exn pl + touchConcr lang touchExpr e failed <- gu_exn_is_raised exn if failed @@ -905,6 +999,18 @@ alignWords lang e = unsafePerformIO $ (fids :: [CInt]) <- peekArray (fromIntegral (n_fids :: CInt)) (ptr `plusPtr` (#offset PgfAlignmentPhrase, fids)) return (phrase, map fromIntegral fids) +printName :: Concr -> Fun -> Maybe String +printName lang fun = + unsafePerformIO $ + withGuPool $ \tmpPl -> do + c_fun <- newUtf8CString fun tmpPl + c_name <- pgf_print_name (concr lang) c_fun + name <- if c_name == nullPtr + then return Nothing + else fmap Just (peekUtf8CString c_name) + touchConcr lang + return name + -- | List of all functions defined in the abstract syntax functions :: PGF -> [Fun] functions p = @@ -974,25 +1080,38 @@ categories p = name <- peekUtf8CString (castPtr key) writeIORef ref $! (name : names) -showCategory :: PGF -> Cat -> String -showCategory p cat = +categoryContext :: PGF -> Cat -> [Hypo] +categoryContext p cat = unsafePerformIO $ withGuPool $ \tmpPl -> - do (sb,out) <- newOut tmpPl - exn <- gu_new_exn tmpPl - c_cat <- newUtf8CString cat tmpPl - pgf_print_category (pgf p) c_cat out exn + do c_cat <- newUtf8CString cat tmpPl + c_hypos <- pgf_category_context (pgf p) c_cat + if c_hypos == nullPtr + then return [] + else do n_hypos <- (#peek GuSeq, len) c_hypos + peekHypos (c_hypos `plusPtr` (#offset GuSeq, data)) 0 n_hypos + 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 (touchPGF p)) : hs) + | otherwise = return [] + + toBindType :: CInt -> BindType + toBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit + toBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit + +categoryProb :: PGF -> Cat -> Float +categoryProb p cat = + unsafePerformIO $ + withGuPool $ \tmpPl -> + do c_cat <- newUtf8CString cat tmpPl + c_prob <- pgf_category_prob (pgf p) c_cat touchPGF p - failed <- gu_exn_is_raised exn - if failed - then do is_exn <- gu_exn_caught exn gu_exn_type_PgfExn - if is_exn - then do c_msg <- (#peek GuExn, data.data) exn - msg <- peekUtf8CString c_msg - throwIO (PGFError msg) - else throwIO (PGFError "The abstract tree cannot be linearized") - else do s <- gu_string_buf_freeze sb tmpPl - peekUtf8CString s + return (realToFrac c_prob) ----------------------------------------------------------------------------- -- Helper functions diff --git a/src/runtime/haskell-bind/PGF2/Expr.hsc b/src/runtime/haskell-bind/PGF2/Expr.hsc index a03a24be3..096d15bfa 100644 --- a/src/runtime/haskell-bind/PGF2/Expr.hsc +++ b/src/runtime/haskell-bind/PGF2/Expr.hsc @@ -5,6 +5,7 @@ module PGF2.Expr where import System.IO.Unsafe(unsafePerformIO) import Foreign hiding (unsafePerformIO) import Foreign.C +import Data.IORef import PGF2.FFI -- | An data type that represents @@ -51,7 +52,7 @@ mkAbs bind_type var (Expr body bodyTouch) = exprFPl <- newForeignPtr gu_pool_finalizer exprPl return (Expr c_expr (bodyTouch >> touchForeignPtr exprFPl)) where - cbind_type = + cbind_type = case bind_type of Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) @@ -195,7 +196,7 @@ readExpr str = 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 exn + 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 @@ -203,6 +204,48 @@ readExpr str = else do gu_pool_free exprPl return Nothing +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 [] + where + 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 + +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 diff --git a/src/runtime/haskell-bind/PGF2/FFI.hs b/src/runtime/haskell-bind/PGF2/FFI.hsc index 3870e2fba..c33f1da50 100644 --- a/src/runtime/haskell-bind/PGF2/FFI.hs +++ b/src/runtime/haskell-bind/PGF2/FFI.hsc @@ -1,14 +1,20 @@ -{-# LANGUAGE ForeignFunctionInterface, MagicHash #-} +{-# LANGUAGE ForeignFunctionInterface, MagicHash, BangPatterns #-} module PGF2.FFI where -import Foreign ( alloca, poke ) +#include <gu/defs.h> +#include <gu/hash.h> +#include <gu/utf8.h> +#include <pgf/pgf.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(Int32) +import Data.Int +import Data.Word type Touch = IO () @@ -23,77 +29,128 @@ data Concr = Concr {concr :: Ptr PgfConcr, touchConcr :: Touch} data GuEnum data GuExn data GuIn +data GuOut data GuKind data GuType data GuString data GuStringBuf +data GuMap data GuMapItor -data GuOut +data GuHasher data GuSeq +data GuBuf data GuPool +type GuVariant = Ptr () +type GuHash = (#type GuHash) +type GuUCS = (#type GuUCS) -foreign import ccall fopen :: CString -> CString -> IO (Ptr ()) +type CSizeT = (#type size_t) +type CUInt8 = (#type uint8_t) -foreign import ccall "gu/mem.h gu_new_pool" +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 "gu/mem.h gu_malloc" - gu_malloc :: Ptr GuPool -> CInt -> IO (Ptr a) +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 "gu/mem.h gu_pool_free" +foreign import ccall unsafe "gu/mem.h gu_pool_free" gu_pool_free :: Ptr GuPool -> IO () -foreign import ccall "gu/mem.h &gu_pool_free" +foreign import ccall unsafe "gu/mem.h &gu_pool_free" gu_pool_finalizer :: FinalizerPtr GuPool -foreign import ccall "gu/exn.h gu_new_exn" +foreign import ccall unsafe "gu/exn.h gu_new_exn" gu_new_exn :: Ptr GuPool -> IO (Ptr GuExn) -foreign import ccall "gu/exn.h gu_exn_is_raised" +foreign import ccall unsafe "gu/exn.h gu_exn_is_raised" gu_exn_is_raised :: Ptr GuExn -> IO Bool -foreign import ccall "gu/exn.h gu_exn_caught_" +foreign import ccall unsafe "gu/exn.h gu_exn_caught_" gu_exn_caught :: Ptr GuExn -> CString -> IO Bool -foreign import ccall "gu/exn.h gu_exn_raise_" +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_GuErrno = Ptr "GuErrno"## :: CString + +gu_exn_type_GuEOF = Ptr "GuEOF"## :: CString -gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"# :: CString +gu_exn_type_PgfLinNonExist = Ptr "PgfLinNonExist"## :: CString -gu_exn_type_PgfExn = Ptr "PgfExn"# :: CString +gu_exn_type_PgfExn = Ptr "PgfExn"## :: CString -gu_exn_type_PgfParseError = Ptr "PgfParseError"# :: CString +gu_exn_type_PgfParseError = Ptr "PgfParseError"## :: CString -gu_exn_type_PgfTypeError = Ptr "PgfTypeError"# :: CString +gu_exn_type_PgfTypeError = Ptr "PgfTypeError"## :: CString -foreign import ccall "gu/string.h gu_string_in" +foreign import ccall unsafe "gu/string.h gu_string_in" gu_string_in :: CString -> Ptr GuPool -> IO (Ptr GuIn) -foreign import ccall "gu/string.h gu_new_string_buf" +foreign import ccall unsafe "gu/string.h gu_new_string_buf" gu_new_string_buf :: Ptr GuPool -> IO (Ptr GuStringBuf) -foreign import ccall "gu/string.h gu_string_buf_out" +foreign import ccall unsafe "gu/string.h gu_string_buf_out" gu_string_buf_out :: Ptr GuStringBuf -> IO (Ptr GuOut) -foreign import ccall "gu/file.h gu_file_in" +foreign import ccall unsafe "gu/file.h gu_file_in" gu_file_in :: Ptr () -> Ptr GuPool -> IO (Ptr GuIn) -foreign import ccall "gu/enum.h gu_enum_next" +foreign import ccall unsafe "gu/enum.h gu_enum_next" gu_enum_next :: Ptr a -> Ptr (Ptr b) -> Ptr GuPool -> IO () -foreign import ccall "gu/string.h gu_string_buf_freeze" +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 Int32 + gu_utf8_decode :: Ptr CString -> IO GuUCS foreign import ccall unsafe "gu/utf8.h gu_utf8_encode" - gu_utf8_encode :: Int32 -> Ptr CString -> IO () + gu_utf8_encode :: GuUCS -> Ptr CString -> IO () foreign import ccall unsafe "gu/seq.h gu_make_seq" - gu_make_seq :: CInt -> CInt -> Ptr GuPool -> IO (Ptr GuSeq) + 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 @@ -116,15 +173,23 @@ peekUtf8CString ptr = else do cs <- decode pptr return (((toEnum . fromEnum) x) : cs) -newUtf8CString :: String -> Ptr GuPool -> IO CString -newUtf8CString s pool = do - -- An UTF8 character takes up to 6 bytes. We allocate enough - -- memory for the worst case. This is wasteful but those - -- strings are usually allocated only temporary. - ptr <- gu_malloc pool (fromIntegral (length s * 6+1)) +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 - return ptr where encode [] pptr = do gu_utf8_encode 0 pptr @@ -132,6 +197,46 @@ newUtf8CString s pool = 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 + ------------------------------------------------------------------ -- libpgf API @@ -140,6 +245,7 @@ data PgfApplication data PgfConcr type PgfExpr = Ptr () data PgfExprProb +data PgfExprParser data PgfFullFormEntry data PgfMorphoCallback data PgfPrintContext @@ -149,10 +255,19 @@ data PgfOracleCallback data PgfCncTree data PgfLinFuncs data PgfGraphvizOptions +type PgfBindType = (#type PgfBindType) +data PgfAbsFun +data PgfAbsCat +data PgfCCat +data PgfCncFun +data PgfProductionApply foreign import ccall "pgf/pgf.h pgf_read" pgf_read :: CString -> Ptr GuPool -> Ptr GuExn -> IO (Ptr PgfPGF) +foreign import ccall "pgf/pgf.h pgf_write" + pgf_write :: Ptr PgfPGF -> CString -> Ptr GuExn -> IO () + foreign import ccall "pgf/pgf.h pgf_abstract_name" pgf_abstract_name :: Ptr PgfPGF -> IO CString @@ -180,6 +295,12 @@ foreign import ccall "pgf/pgf.h pgf_iter_categories" 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_iter_functions" pgf_iter_functions :: Ptr PgfPGF -> Ptr GuMapItor -> Ptr GuExn -> IO () @@ -189,6 +310,9 @@ foreign import ccall "pgf/pgf.h pgf_iter_functions_by_cat" 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 @@ -205,16 +329,16 @@ 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 -> CInt -> Ptr GuOut -> Ptr GuExn -> Ptr GuPool -> IO () + 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 -> CInt -> Ptr (Ptr PgfLinFuncs) -> Ptr GuPool -> IO () + 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 CInt -> Ptr (Ptr CString) -> IO () + 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 -> CInt -> CString -> IO () +type PhraseCallback = Ptr (Ptr PgfLinFuncs) -> CString -> CInt -> CSizeT -> CString -> IO () type NonExistCallback = Ptr (Ptr PgfLinFuncs) -> IO () type MetaCallback = Ptr (Ptr PgfLinFuncs) -> CInt -> IO () @@ -239,12 +363,12 @@ foreign import ccall "pgf/pgf.h pgf_parse_with_heuristics" 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 = CInt -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb) +type LiteralMatchCallback = CSizeT -> Ptr CSizeT -> Ptr GuPool -> IO (Ptr PgfExprProb) foreign import ccall "wrapper" wrapLiteralMatchCallback :: LiteralMatchCallback -> IO (FunPtr LiteralMatchCallback) -type LiteralPredictCallback = CInt -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb) +type LiteralPredictCallback = CSizeT -> CString -> Ptr GuPool -> IO (Ptr PgfExprProb) foreign import ccall "wrapper" wrapLiteralPredictCallback :: LiteralPredictCallback -> IO (FunPtr LiteralPredictCallback) @@ -255,8 +379,8 @@ foreign import ccall "pgf/pgf.h pgf_new_callbacks_map" foreign import ccall hspgf_callbacks_map_add_literal :: Ptr PgfConcr -> Ptr PgfCallbacksMap -> CString -> FunPtr LiteralMatchCallback -> FunPtr LiteralPredictCallback -> Ptr GuPool -> IO () -type OracleCallback = CString -> CString -> CInt -> IO Bool -type OracleLiteralCallback = CString -> CString -> Ptr CInt -> Ptr GuPool -> IO (Ptr PgfExprProb) +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) @@ -299,7 +423,7 @@ 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_abs" - pgf_expr_abs :: CInt -> CString -> PgfExpr -> Ptr GuPool -> IO PgfExpr + 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) @@ -328,6 +452,18 @@ foreign import ccall "pgf/expr.h pgf_expr_arity" foreign import ccall "pgf/expr.h pgf_expr_eq" pgf_expr_eq :: PgfExpr -> PgfExpr -> IO CInt +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 @@ -347,14 +483,14 @@ 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_expr_tuple" - pgf_print_expr_tuple :: CInt -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO () - -foreign import ccall "pgf/expr.h pgf_print_category" - pgf_print_category :: Ptr PgfPGF -> CString -> Ptr GuOut -> Ptr GuExn -> IO () + pgf_print_expr_tuple :: CSizeT -> Ptr PgfExpr -> Ptr PgfPrintContext -> 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) @@ -362,16 +498,16 @@ foreign import ccall "pgf/pgf.h pgf_print" pgf_print :: Ptr PgfPGF -> Ptr GuOut -> Ptr GuExn -> IO () foreign import ccall "pgf/expr.h pgf_read_expr" - pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr + pgf_read_expr :: Ptr GuIn -> Ptr GuPool -> Ptr GuPool -> Ptr GuExn -> IO PgfExpr foreign import ccall "pgf/expr.h pgf_read_expr_tuple" - pgf_read_expr_tuple :: Ptr GuIn -> CInt -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt + pgf_read_expr_tuple :: Ptr GuIn -> CSizeT -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt foreign import ccall "pgf/expr.h pgf_read_expr_matrix" - pgf_read_expr_matrix :: Ptr GuIn -> CInt -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq) + pgf_read_expr_matrix :: Ptr GuIn -> CSizeT -> Ptr GuPool -> Ptr GuExn -> IO (Ptr GuSeq) foreign import ccall "pgf/expr.h pgf_read_type" - pgf_read_type :: Ptr GuIn -> Ptr GuPool -> Ptr GuExn -> IO PgfType + 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 () @@ -380,4 +516,13 @@ 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) -> CInt -> PgfExpr -> Ptr PgfGraphvizOptions -> Ptr GuOut -> Ptr GuExn -> IO () + 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) diff --git a/src/runtime/haskell-bind/PGF2/Internal.hsc b/src/runtime/haskell-bind/PGF2/Internal.hsc new file mode 100644 index 000000000..c4aef323a --- /dev/null +++ b/src/runtime/haskell-bind/PGF2/Internal.hsc @@ -0,0 +1,932 @@ +{-# LANGUAGE ImplicitParams, RankNTypes #-} + +module PGF2.Internal(-- * Access the internal structures + FId,isPredefFId, + FunId,Token,Production(..),PArg(..),Symbol(..),Literal(..), + globalFlags, abstrFlags, concrFlags, + concrTotalCats, concrCategories, concrProductions, + concrTotalFuns, concrFunction, + concrTotalSeqs, concrSequence, + + -- * Building new PGFs in memory + build, eAbs, eApp, eMeta, eFun, eVar, eTyped, eImplArg, dTyp, hypo, + AbstrInfo, newAbstr, ConcrInfo, newConcr, newPGF, + + -- * Write an in-memory PGF to a file + writePGF + ) where + +#include <pgf/data.h> + +import PGF2 +import PGF2.FFI +import PGF2.Expr +import PGF2.Type +import System.IO.Unsafe(unsafePerformIO) +import Foreign +import Foreign.C +import Data.IORef +import Data.Maybe(fromMaybe) +import Data.List(sortBy) +import Control.Exception(Exception,throwIO) +import Control.Monad(foldM) +import qualified Data.Map as Map + +type Token = String +data Symbol + = SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex + | SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex + | SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int + | SymKS Token + | SymKP [Symbol] [([Symbol],[String])] + | SymBIND -- the special BIND token + | SymNE -- non exist + | SymSOFT_BIND -- the special SOFT_BIND token + | SymSOFT_SPACE -- the special SOFT_SPACE token + | SymCAPIT -- the special CAPIT token + | SymALL_CAPIT -- the special ALL_CAPIT token + deriving (Eq,Ord,Show) +data Production + = PApply {-# UNPACK #-} !FunId [PArg] + | PCoerce {-# UNPACK #-} !FId + deriving (Eq,Ord,Show) +data PArg = PArg [FId] {-# UNPACK #-} !FId deriving (Eq,Ord,Show) +type FunId = Int +type SeqId = Int +data Literal = + LStr String -- ^ a string constant + | LInt Int -- ^ an integer constant + | LFlt Double -- ^ a floating point constant + deriving (Eq,Ord,Show) + + +----------------------------------------------------------------------- +-- Access the internal structures +----------------------------------------------------------------------- + +globalFlags :: PGF -> [(String,Literal)] +globalFlags p = unsafePerformIO $ do + c_flags <- (#peek PgfPGF, gflags) (pgf p) + flags <- peekFlags c_flags + touchPGF p + return flags + +abstrFlags :: PGF -> [(String,Literal)] +abstrFlags p = unsafePerformIO $ do + c_flags <- (#peek PgfPGF, abstract.aflags) (pgf p) + flags <- peekFlags c_flags + touchPGF p + return flags + +concrFlags :: Concr -> [(String,Literal)] +concrFlags c = unsafePerformIO $ do + c_flags <- (#peek PgfConcr, cflags) (concr c) + flags <- peekFlags c_flags + touchConcr c + return flags + +peekFlags :: Ptr GuSeq -> IO [(String,Literal)] +peekFlags c_flags = do + c_len <- (#peek GuSeq, len) c_flags + peekFlags (c_len :: CInt) (c_flags `plusPtr` (#offset GuSeq, data)) + where + peekFlags 0 ptr = return [] + peekFlags c_len ptr = do + name <- (#peek PgfFlag, name) ptr >>= peekUtf8CString + value <- (#peek PgfFlag, value) ptr >>= peekLiteral + flags <- peekFlags (c_len-1) (ptr `plusPtr` (#size PgfFlag)) + return ((name,value):flags) + +peekLiteral :: GuVariant -> IO Literal +peekLiteral p = do + tag <- gu_variant_tag p + ptr <- gu_variant_data p + case tag of + (#const PGF_LITERAL_STR) -> do { val <- peekUtf8CString (ptr `plusPtr` (#offset PgfLiteralStr, val)); + return (LStr val) } + (#const PGF_LITERAL_INT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralInt, val)); + return (LInt (fromIntegral (val :: CInt))) } + (#const PGF_LITERAL_FLT) -> do { val <- peek (ptr `plusPtr` (#offset PgfLiteralFlt, val)); + return (LFlt (realToFrac (val :: CDouble))) } + _ -> error "Unknown literal type in the grammar" + +concrTotalCats :: Concr -> FId +concrTotalCats c = unsafePerformIO $ do + c_total_cats <- (#peek PgfConcr, total_cats) (concr c) + touchConcr c + return (fromIntegral (c_total_cats :: CInt)) + +concrCategories :: Concr -> [(Cat,FId,FId,[String])] +concrCategories c = + unsafePerformIO $ + withGuPool $ \tmpPl -> + allocaBytes (#size GuMapItor) $ \itor -> do + exn <- gu_new_exn tmpPl + ref <- newIORef [] + fptr <- wrapMapItorCallback (getCategories ref) + (#poke GuMapItor, fn) itor fptr + c_cnccats <- (#peek PgfConcr, cnccats) (concr c) + gu_map_iter c_cnccats itor exn + touchConcr c + freeHaskellFunPtr fptr + cs <- readIORef ref + return (reverse cs) + where + getCategories ref itor key value exn = do + names <- readIORef ref + name <- peekUtf8CString (castPtr key) + c_cnccat <- peek (castPtr value) + c_cats <- (#peek PgfCncCat, cats) c_cnccat + c_len <- (#peek GuSeq, len) c_cats + first <- peek (c_cats `plusPtr` (#offset GuSeq, data)) >>= peekFId + last <- peek (c_cats `plusPtr` ((#offset GuSeq, data) + (fromIntegral (c_len-1::CSizeT))*(#size PgfCCat*))) >>= peekFId + c_n_lins <- (#peek PgfCncCat, n_lins) c_cnccat + arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cnccat `plusPtr` (#offset PgfCncCat, labels)) + labels <- mapM peekUtf8CString arr + writeIORef ref ((name,first,last,labels) : names) + +concrProductions :: Concr -> FId -> [Production] +concrProductions c fid = unsafePerformIO $ do + c_ccats <- (#peek PgfConcr, ccats) (concr c) + res <- alloca $ \pfid -> do + poke pfid (fromIntegral fid :: CInt) + gu_map_find_default c_ccats pfid >>= peek + if res == nullPtr + then do touchConcr c + return [] + else do c_prods <- (#peek PgfCCat, prods) res + if c_prods == nullPtr + then do touchConcr c + return [] + else do res <- peekSequence (deRef peekProduction) (#size GuVariant) c_prods + touchConcr c + return res + where + peekProduction p = do + tag <- gu_variant_tag p + dt <- gu_variant_data p + case tag of + (#const PGF_PRODUCTION_APPLY) -> do { c_cncfun <- (#peek PgfProductionApply, fun) dt ; + c_funid <- (#peek PgfCncFun, funid) c_cncfun ; + c_args <- (#peek PgfProductionApply, args) dt ; + pargs <- peekSequence peekPArg (#size PgfPArg) c_args ; + return (PApply (fromIntegral (c_funid :: CInt)) pargs) } + (#const PGF_PRODUCTION_COERCE)-> do { c_coerce <- (#peek PgfProductionCoerce, coerce) dt ; + fid <- peekFId c_coerce ; + return (PCoerce fid) } + _ -> error "Unknown production type in the grammar" + where + peekPArg ptr = do + c_hypos <- (#peek PgfPArg, hypos) ptr + hypos <- peekSequence (deRef peekFId) (#size int) c_hypos + c_ccat <- (#peek PgfPArg, ccat) ptr + fid <- peekFId c_ccat + return (PArg hypos fid) + +peekFId c_ccat = do + c_fid <- (#peek PgfCCat, fid) c_ccat + return (fromIntegral (c_fid :: CInt)) + +concrTotalFuns :: Concr -> FunId +concrTotalFuns c = unsafePerformIO $ do + c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c) + c_len <- (#peek GuSeq, len) c_cncfuns + touchConcr c + return (fromIntegral (c_len :: CSizeT)) + +concrFunction :: Concr -> FunId -> (Fun,[SeqId]) +concrFunction c funid = unsafePerformIO $ do + c_cncfuns <- (#peek PgfConcr, cncfuns) (concr c) + c_cncfun <- peek (c_cncfuns `plusPtr` ((#offset GuSeq, data)+funid*(#size PgfCncFun*))) + c_absfun <- (#peek PgfCncFun, absfun) c_cncfun + c_name <- (#peek PgfAbsFun, name) c_absfun + name <- peekUtf8CString c_name + c_n_lins <- (#peek PgfCncFun, n_lins) c_cncfun + arr <- peekArray (fromIntegral (c_n_lins :: CSizeT)) (c_cncfun `plusPtr` (#offset PgfCncFun, lins)) + seqs_seq <- (#peek PgfConcr, sequences) (concr c) + touchConcr c + let seqs = seqs_seq `plusPtr` (#offset GuSeq, data) + return (name, map (toSeqId seqs) arr) + where + toSeqId seqs seq = minusPtr seq seqs `div` (#size PgfSequence) + +concrTotalSeqs :: Concr -> SeqId +concrTotalSeqs c = unsafePerformIO $ do + seq <- (#peek PgfConcr, sequences) (concr c) + c_len <- (#peek GuSeq, len) seq + touchConcr c + return (fromIntegral (c_len :: CSizeT)) + +concrSequence :: Concr -> SeqId -> [Symbol] +concrSequence c seqid = unsafePerformIO $ do + c_sequences <- (#peek PgfConcr, sequences) (concr c) + let c_sequence = c_sequences `plusPtr` ((#offset GuSeq, data)+seqid*(#size PgfSequence)) + c_syms <- (#peek PgfSequence, syms) c_sequence + res <- peekSequence (deRef peekSymbol) (#size GuVariant) c_syms + touchConcr c + return res + where + peekSymbol p = do + tag <- gu_variant_tag p + dt <- gu_variant_data p + case tag of + (#const PGF_SYMBOL_CAT) -> peekSymbolIdx SymCat dt + (#const PGF_SYMBOL_LIT) -> peekSymbolIdx SymLit dt + (#const PGF_SYMBOL_VAR) -> peekSymbolIdx SymVar dt + (#const PGF_SYMBOL_KS) -> peekSymbolKS dt + (#const PGF_SYMBOL_KP) -> peekSymbolKP dt + (#const PGF_SYMBOL_BIND) -> return SymBIND + (#const PGF_SYMBOL_SOFT_BIND) -> return SymSOFT_BIND + (#const PGF_SYMBOL_NE) -> return SymNE + (#const PGF_SYMBOL_SOFT_SPACE) -> return SymSOFT_SPACE + (#const PGF_SYMBOL_CAPIT) -> return SymCAPIT + (#const PGF_SYMBOL_ALL_CAPIT) -> return SymALL_CAPIT + _ -> error "Unknown symbol type in the grammar" + + peekSymbolIdx constr dt = do + c_d <- (#peek PgfSymbolIdx, d) dt + c_r <- (#peek PgfSymbolIdx, r) dt + return (constr (fromIntegral (c_d :: CInt)) (fromIntegral (c_r :: CInt))) + + peekSymbolKS dt = do + token <- peekUtf8CString (dt `plusPtr` (#offset PgfSymbolKS, token)) + return (SymKS token) + + peekSymbolKP dt = do + c_default_form <- (#peek PgfSymbolKP, default_form) dt + default_form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_default_form + c_n_forms <- (#peek PgfSymbolKP, n_forms) dt + forms <- peekForms (c_n_forms :: CSizeT) (dt `plusPtr` (#offset PgfSymbolKP, forms)) + return (SymKP default_form forms) + + peekForms 0 ptr = return [] + peekForms len ptr = do + c_form <- (#peek PgfAlternative, form) ptr + form <- peekSequence (deRef peekSymbol) (#size GuVariant) c_form + c_prefixes <- (#peek PgfAlternative, prefixes) ptr + prefixes <- peekSequence (deRef peekUtf8CString) (#size GuString*) c_prefixes + forms <- peekForms (len-1) (ptr `plusPtr` (#size PgfAlternative)) + return ((form,prefixes):forms) + +deRef peekValue ptr = peek ptr >>= peekValue + +fidString, fidInt, fidFloat, fidVar, fidStart :: FId +fidString = (-1) +fidInt = (-2) +fidFloat = (-3) +fidVar = (-4) +fidStart = (-5) + +isPredefFId :: FId -> Bool +isPredefFId = (`elem` [fidString, fidInt, fidFloat, fidVar]) + + +----------------------------------------------------------------------- +-- Building new PGFs in memory +----------------------------------------------------------------------- + +data Builder s = Builder (Ptr GuPool) Touch +newtype B s a = B a + +build :: (forall s . (?builder :: Builder s) => B s a) -> a +build f = + unsafePerformIO $ do + pool <- gu_new_pool + poolFPtr <- newForeignPtr gu_pool_finalizer pool + let ?builder = Builder pool (touchForeignPtr poolFPtr) + let B res = f + return res + +eAbs :: (?builder :: Builder s) => BindType -> String -> B s Expr -> B s Expr +eAbs bind_type var (B (Expr body _)) = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_ABS) + (#size PgfExprAbs) + (#const gu_alignof(PgfExprAbs)) + pptr pool + cvar <- newUtf8CString var pool + (#poke PgfExprAbs, bind_type) ptr (cbind_type :: PgfBindType) + (#poke PgfExprAbs, id) ptr cvar + (#poke PgfExprAbs, body) ptr body + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + + cbind_type = + case bind_type of + Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) + Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) + +eApp :: (?builder :: Builder s) => B s Expr -> B s Expr -> B s Expr +eApp (B (Expr fun _)) (B (Expr arg _)) = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_APP) + (#size PgfExprApp) + (#const gu_alignof(PgfExprApp)) + pptr pool + (#poke PgfExprApp, fun) ptr fun + (#poke PgfExprApp, arg) ptr arg + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +eMeta :: (?builder :: Builder s) => Int -> B s Expr +eMeta id = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_META) + (fromIntegral (#size PgfExprMeta)) + (#const gu_alignof(PgfExprMeta)) + pptr pool + (#poke PgfExprMeta, id) ptr (fromIntegral id :: CInt) + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +eFun :: (?builder :: Builder s) => Fun -> B s Expr +eFun fun = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_FUN) + (fromIntegral ((#size PgfExprFun)+utf8Length fun)) + (#const gu_flex_alignof(PgfExprFun)) + pptr pool + pokeUtf8CString fun (ptr `plusPtr` (#offset PgfExprFun, fun)) + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +eVar :: (?builder :: Builder s) => Int -> B s Expr +eVar var = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_VAR) + (#size PgfExprVar) + (#const gu_alignof(PgfExprVar)) + pptr pool + (#poke PgfExprVar, var) ptr (fromIntegral var :: CInt) + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +eTyped :: (?builder :: Builder s) => B s Expr -> B s Type -> B s Expr +eTyped (B (Expr e _)) (B (Type ty _)) = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_TYPED) + (#size PgfExprTyped) + (#const gu_alignof(PgfExprTyped)) + pptr pool + (#poke PgfExprTyped, expr) ptr e + (#poke PgfExprTyped, type) ptr ty + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +eImplArg :: (?builder :: Builder s) => B s Expr -> B s Expr +eImplArg (B (Expr e _)) = + unsafePerformIO $ + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_EXPR_IMPL_ARG) + (#size PgfExprImplArg) + (#const gu_alignof(PgfExprImplArg)) + pptr pool + (#poke PgfExprImplArg, expr) ptr e + e <- peek pptr + return (B (Expr e touch)) + where + (Builder pool touch) = ?builder + +hypo :: BindType -> CId -> B s Type -> (B s Hypo) +hypo bind_type var (B ty) = B (bind_type,var,ty) + +dTyp :: (?builder :: Builder s) => [B s Hypo] -> Cat -> [B s Expr] -> B s Type +dTyp hypos cat es = + unsafePerformIO $ do + ptr <- gu_malloc_aligned pool + ((#size PgfType)+n_exprs*(#size GuVariant)) + (#const gu_flex_alignof(PgfType)) + c_hypos <- newHypos hypos pool + c_cat <- newUtf8CString cat pool + (#poke PgfType, hypos) ptr c_hypos + (#poke PgfType, cid) ptr c_cat + (#poke PgfType, n_exprs) ptr n_exprs + pokeArray (ptr `plusPtr` (#offset PgfType, exprs)) [e | B (Expr e _) <- es] + return (B (Type ptr touch)) + where + (Builder pool touch) = ?builder + n_exprs = fromIntegral (length es) :: CSizeT + +newHypos :: [B s Hypo] -> Ptr GuPool -> IO (Ptr GuSeq) +newHypos hypos pool = do + c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) pool + pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos + return c_hypos + where + pokeHypos ptr [] = return () + pokeHypos ptr (B (bind_type,var,Type ty _):hypos) = do + c_var <- newUtf8CString var pool + (#poke PgfHypo, bind_type) ptr (cbind_type :: PgfBindType) + (#poke PgfHypo, cid) ptr c_var + (#poke PgfHypo, type) ptr ty + pokeHypos (ptr `plusPtr` (#size PgfHypo)) hypos + where + cbind_type = + case bind_type of + Explicit -> (#const PGF_BIND_TYPE_EXPLICIT) + Implicit -> (#const PGF_BIND_TYPE_IMPLICIT) + + +data AbstrInfo = AbstrInfo (Ptr GuSeq) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsCat)) (Ptr GuSeq) (Map.Map String (Ptr PgfAbsFun)) (Ptr PgfAbsFun) (Ptr GuBuf) Touch + +newAbstr :: (?builder :: Builder s) => [(String,Literal)] -> + [(Cat,[B s Hypo],Float)] -> + [(Fun,B s Type,Int,Float)] -> + AbstrInfo +newAbstr aflags cats funs = unsafePerformIO $ do + c_aflags <- newFlags aflags pool + (c_cats,abscats) <- newAbsCats (sortByFst3 cats) pool + (c_funs,absfuns) <- newAbsFuns (sortByFst4 funs) pool + c_abs_lin_fun <- newAbsLinFun + c_non_lexical_buf <- gu_make_buf (#size PgfProductionIdxEntry) pool + return (AbstrInfo c_aflags c_cats abscats c_funs absfuns c_abs_lin_fun c_non_lexical_buf touch) + where + (Builder pool touch) = ?builder + + newAbsCats values pool = do + c_seq <- gu_make_seq (#size PgfAbsCat) (fromIntegral (length values)) pool + abscats <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values + return (c_seq,abscats) + where + pokeElems ptr abscats [] = return abscats + pokeElems ptr abscats (x:xs) = do + abscats <- pokeAbsCat ptr abscats x + pokeElems (ptr `plusPtr` (#size PgfAbsCat)) abscats xs + + pokeAbsCat ptr abscats (name,hypos,prob) = do + c_name <- newUtf8CString name pool + c_hypos <- newHypos hypos pool + (#poke PgfAbsCat, name) ptr c_name + (#poke PgfAbsCat, context) ptr c_hypos + (#poke PgfAbsCat, prob) ptr (realToFrac prob :: CFloat) + return (Map.insert name ptr abscats) + + newAbsFuns values pool = do + c_seq <- gu_make_seq (#size PgfAbsFun) (fromIntegral (length values)) pool + absfuns <- pokeElems (c_seq `plusPtr` (#offset GuSeq, data)) Map.empty values + return (c_seq,absfuns) + where + pokeElems ptr absfuns [] = return absfuns + pokeElems ptr absfuns (x:xs) = do + absfuns <- pokeAbsFun ptr absfuns x + pokeElems (ptr `plusPtr` (#size PgfAbsFun)) absfuns xs + + pokeAbsFun ptr absfuns (name,B (Type c_ty _),arity,prob) = do + pfun <- gu_alloc_variant (#const PGF_EXPR_FUN) + (fromIntegral ((#size PgfExprFun)+utf8Length name)) + (#const gu_flex_alignof(PgfExprFun)) + (ptr `plusPtr` (#offset PgfAbsFun, ep.expr)) pool + let c_name = (pfun `plusPtr` (#offset PgfExprFun, fun)) + pokeUtf8CString name c_name + (#poke PgfAbsFun, name) ptr c_name + (#poke PgfAbsFun, type) ptr c_ty + (#poke PgfAbsFun, arity) ptr (fromIntegral arity :: CInt) + (#poke PgfAbsFun, defns) ptr nullPtr + (#poke PgfAbsFun, ep.prob) ptr (realToFrac prob :: CFloat) + return (Map.insert name ptr absfuns) + + newAbsLinFun = do + ptr <- gu_malloc_aligned pool + (#size PgfAbsFun) + (#const gu_alignof(PgfAbsFun)) + c_wild <- newUtf8CString "_" pool + c_ty <- gu_malloc_aligned pool + (#size PgfType) + (#const gu_alignof(PgfType)) + (#poke PgfType, hypos) c_ty nullPtr + (#poke PgfType, cid) c_ty c_wild + (#poke PgfType, n_exprs) c_ty (0 :: CSizeT) + (#poke PgfAbsFun, name) ptr c_wild + (#poke PgfAbsFun, type) ptr c_ty + (#poke PgfAbsFun, arity) ptr (0 :: CSizeT) + (#poke PgfAbsFun, defns) ptr nullPtr + (#poke PgfAbsFun, ep.prob) ptr (- log 0 :: CFloat) + (#poke PgfAbsFun, ep.expr) ptr nullPtr + return ptr + + +data ConcrInfo = ConcrInfo (Ptr GuSeq) (Ptr GuMap) (Ptr GuMap) (Ptr GuSeq) (Ptr GuSeq) (Ptr GuMap) (Ptr PgfConcr -> Ptr GuPool -> IO ()) CInt + +newConcr :: (?builder :: Builder s) => AbstrInfo -> + [(String,Literal)] -> -- ^ Concrete syntax flags + [(String,String)] -> -- ^ Printnames + [(FId,[FunId])] -> -- ^ Lindefs + [(FId,[FunId])] -> -- ^ Linrefs + [(FId,[Production])] -> -- ^ Productions + [(Fun,[SeqId])] -> -- ^ Concrete functions (must be sorted by Fun) + [[Symbol]] -> -- ^ Sequences (must be sorted) + [(Cat,FId,FId,[String])] -> -- ^ Concrete categories + FId -> -- ^ The total count of the categories + ConcrInfo +newConcr (AbstrInfo _ _ abscats _ absfuns c_abs_lin_fun c_non_lexical_buf _) cflags printnames lindefs linrefs prods cncfuns sequences cnccats total_cats = unsafePerformIO $ do + c_cflags <- newFlags cflags pool + c_printname <- newMap (#size GuString) gu_string_hasher newUtf8CString + (#size GuString) (pokeString pool) + printnames pool + c_seqs <- newSequence (#size PgfSequence) pokeSequence sequences pool + let seqs_ptr = c_seqs `plusPtr` (#offset GuSeq, data) + c_cncfuns <- newSequence (#size PgfCncFun*) (pokeCncFun seqs_ptr) (zip [0..] cncfuns) pool + let funs_ptr = c_cncfuns `plusPtr` (#offset GuSeq, data) + c_ccats <- gu_make_map (#size int) gu_int_hasher + (#size PgfCCat*) gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + mapM_ (addLindefs c_ccats funs_ptr) lindefs + mapM_ (addLinrefs c_ccats funs_ptr) linrefs + mk_index <- foldM (addProductions c_ccats funs_ptr c_non_lexical_buf) (\concr pool -> return ()) prods + c_cnccats <- newMap (#size GuString) gu_string_hasher newUtf8CString (#size PgfCncCat*) (pokeCncCat c_ccats) (map (\v@(k,_,_,_) -> (k,v)) cnccats) pool + return (ConcrInfo c_cflags c_printname c_ccats c_cncfuns c_seqs c_cnccats mk_index (fromIntegral total_cats)) + where + (Builder pool touch) = ?builder + + pokeCncFun seqs_ptr ptr cncfun = do + c_cncfun <- newCncFun absfuns nullPtr cncfun pool + poke ptr c_cncfun + + pokeSequence c_seq syms = do + c_syms <- newSymbols syms pool + (#poke PgfSequence, syms) c_seq c_syms + (#poke PgfSequence, idx) c_seq nullPtr + + addLindefs c_ccats funs_ptr (fid,funids) = do + c_ccat <- getCCat c_ccats fid pool + c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool + (#poke PgfCCat, lindefs) c_ccat c_funs + + addLinrefs c_ccats funs_ptr (fid,funids) = do + c_ccat <- getCCat c_ccats fid pool + c_funs <- newSequence (#size PgfCncFun*) (pokeRefDefFunId funs_ptr) funids pool + (#poke PgfCCat, linrefs) c_ccat c_funs + + addProductions c_ccats funs_ptr c_non_lexical_buf mk_index (fid,prods) = do + c_ccat <- getCCat c_ccats fid pool + let n_prods = length prods + c_prods <- gu_make_seq (#size PgfProduction) (fromIntegral n_prods) pool + (#poke PgfCCat, prods) c_ccat c_prods + pokeProductions c_ccat (c_prods `plusPtr` (#offset GuSeq, data)) 0 (n_prods-1) mk_index prods + where + pokeProductions c_ccat ptr top bot mk_index [] = return mk_index + pokeProductions c_ccat ptr top bot mk_index (prod:prods) = do + (is_lexical,c_prod) <- newProduction c_ccats funs_ptr c_non_lexical_buf prod pool + let mk_index' = \concr pool -> do pgf_parser_index concr c_ccat c_prod is_lexical pool + pgf_lzr_index concr c_ccat c_prod is_lexical pool + mk_index concr pool + if is_lexical == 0 + then do poke (ptr `plusPtr` ((#size PgfProduction)*top)) c_prod + pokeProductions c_ccat ptr (top+1) bot mk_index' prods + else do poke (ptr `plusPtr` ((#size PgfProduction)*bot)) c_prod + pokeProductions c_ccat ptr top (bot-1) mk_index' prods + + pokeRefDefFunId funs_ptr ptr funid = do + let c_fun = funs_ptr `plusPtr` (funid * (#size PgfCncFun)) + (#poke PgfCncFun, absfun) c_fun c_abs_lin_fun + poke ptr c_fun + + pokeCncCat c_ccats ptr (name,start,end,labels) = do + let n_lins = fromIntegral (length labels) :: CSizeT + c_cnccat <- gu_malloc_aligned pool + ((#size PgfCncCat)+n_lins*(#size GuString)) + (#const gu_flex_alignof(PgfCncCat)) + case Map.lookup name abscats of + Just c_abscat -> (#poke PgfCncCat, abscat) c_cnccat c_abscat + Nothing -> throwIO (PGFError ("The category "++name++" is not in the abstract syntax")) + c_ccats <- newSequence (#size PgfCCat*) pokeFId [start..end] pool + (#poke PgfCncCat, cats) c_cnccat c_ccats + pokeLabels (c_cnccat `plusPtr` (#offset PgfCncCat, labels)) labels + poke ptr c_cnccat + where + pokeFId ptr fid = do + c_ccat <- getCCat c_ccats fid pool + poke ptr c_ccat + + pokeLabels ptr [] = return [] + pokeLabels ptr (l:ls) = do + c_l <- newUtf8CString l pool + poke ptr c_l + pokeLabels (ptr `plusPtr` (#size GuString)) ls + + +newPGF :: (?builder :: Builder s) => [(String,Literal)] -> + AbsName -> + AbstrInfo -> + [(ConcName,ConcrInfo)] -> + B s PGF +newPGF gflags absname (AbstrInfo c_aflags c_cats _ c_funs _ c_abs_lin_fun _ _) concrs = + unsafePerformIO $ do + ptr <- gu_malloc_aligned pool + (#size PgfPGF) + (#const gu_alignof(PgfPGF)) + c_gflags <- newFlags gflags pool + c_absname <- newUtf8CString absname pool + let c_abstr = ptr `plusPtr` (#offset PgfPGF, abstract) + c_concrs <- newSequence (#size PgfConcr) (pokeConcr c_abstr) concrs pool + (#poke PgfPGF, major_version) ptr (2 :: (#type uint16_t)) + (#poke PgfPGF, minor_version) ptr (0 :: (#type uint16_t)) + (#poke PgfPGF, gflags) ptr c_gflags + (#poke PgfPGF, abstract.name) ptr c_absname + (#poke PgfPGF, abstract.aflags) ptr c_aflags + (#poke PgfPGF, abstract.funs) ptr c_funs + (#poke PgfPGF, abstract.cats) ptr c_cats + (#poke PgfPGF, abstract.abs_lin_fun) ptr c_abs_lin_fun + (#poke PgfPGF, concretes) ptr c_concrs + (#poke PgfPGF, pool) ptr pool + return (B (PGF ptr touch)) + where + (Builder pool touch) = ?builder + + pokeConcr c_abstr ptr (name, ConcrInfo c_cflags c_printnames c_ccats c_cncfuns c_seqs c_cnccats mk_index c_total_cats) = do + c_name <- newUtf8CString name pool + c_fun_indices <- gu_make_map (#size GuString) gu_string_hasher + (#size PgfCncOverloadMap*) gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + c_coerce_idx <- gu_make_map (#size PgfCCat*) gu_addr_hasher + (#size GuBuf*) gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + (#poke PgfConcr, name) ptr c_name + (#poke PgfConcr, abstr) ptr c_abstr + (#poke PgfConcr, cflags) ptr c_cflags + (#poke PgfConcr, printnames) ptr c_printnames + (#poke PgfConcr, ccats) ptr c_ccats + (#poke PgfConcr, fun_indices) ptr c_fun_indices + (#poke PgfConcr, coerce_idx) ptr c_coerce_idx + (#poke PgfConcr, cncfuns) ptr c_cncfuns + (#poke PgfConcr, sequences) ptr c_seqs + (#poke PgfConcr, cnccats) ptr c_cnccats + (#poke PgfConcr, total_cats) ptr c_total_cats + (#poke PgfConcr, pool) ptr nullPtr + mk_index ptr pool + + +newFlags :: [(String,Literal)] -> Ptr GuPool -> IO (Ptr GuSeq) +newFlags flags pool = newSequence (#size PgfFlag) pokeFlag (sortByFst flags) pool + where + pokeFlag c_flag (name,value) = do + c_name <- newUtf8CString name pool + c_value <- newLiteral value pool + (#poke PgfFlag, name) c_flag c_name + (#poke PgfFlag, value) c_flag c_value + + +newLiteral :: Literal -> Ptr GuPool -> IO GuVariant +newLiteral (LStr val) pool = + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_LITERAL_STR) + (fromIntegral ((#size PgfLiteralStr)+utf8Length val)) + (#const gu_flex_alignof(PgfLiteralStr)) + pptr pool + pokeUtf8CString val (ptr `plusPtr` (#offset PgfLiteralStr, val)) + peek pptr +newLiteral (LInt val) pool = + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_LITERAL_INT) + (fromIntegral (#size PgfLiteralInt)) + (#const gu_alignof(PgfLiteralInt)) + pptr pool + (#poke PgfLiteralInt, val) ptr (fromIntegral val :: CInt) + peek pptr +newLiteral (LFlt val) pool = + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_LITERAL_FLT) + (fromIntegral (#size PgfLiteralFlt)) + (#const gu_alignof(PgfLiteralFlt)) + pptr pool + (#poke PgfLiteralFlt, val) ptr (realToFrac val :: CDouble) + peek pptr + + +newProduction :: Ptr GuMap -> Ptr PgfCncFun -> Ptr GuBuf -> Production -> Ptr GuPool -> IO ((#type bool), GuVariant) +newProduction c_ccats funs_ptr c_non_lexical_buf (PApply fun_id args) pool = + alloca $ \pptr -> do + let c_fun = funs_ptr `plusPtr` (fun_id * (#size PgfCncFun)) + c_args <- newSequence (#size PgfPArg) pokePArg args pool + ptr <- gu_alloc_variant (#const PGF_PRODUCTION_APPLY) + (fromIntegral (#size PgfProductionApply)) + (#const gu_alignof(PgfProductionApply)) + pptr pool + (#poke PgfProductionApply, fun) ptr c_fun + (#poke PgfProductionApply, args) ptr c_args + is_lexical <- pgf_production_is_lexical ptr c_non_lexical_buf pool + c_prod <- peek pptr + return (is_lexical,c_prod) + where + pokePArg ptr (PArg hypos ccat) = do + c_ccat <- getCCat c_ccats ccat pool + (#poke PgfPArg, ccat) ptr c_ccat + c_hypos <- newSequence (#size PgfCCat*) pokeCCat hypos pool + (#poke PgfPArg, hypos) ptr c_hypos + + pokeCCat ptr ccat = do + c_ccat <- getCCat c_ccats ccat pool + poke ptr c_ccat + +newProduction c_ccats funs_ptr c_non_lexical_buf (PCoerce fid) pool = + alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_PRODUCTION_COERCE) + (fromIntegral (#size PgfProductionCoerce)) + (#const gu_alignof(PgfProductionCoerce)) + pptr pool + c_ccat <- getCCat c_ccats fid pool + (#poke PgfProductionCoerce, coerce) ptr c_ccat + c_prod <- peek pptr + return (0,c_prod) + + +newCncFun absfuns seqs_ptr (funid,(fun,seqids)) pool = + do let c_absfun = fromMaybe nullPtr (Map.lookup fun absfuns) + c_ep = if c_absfun == nullPtr + then nullPtr + else c_absfun `plusPtr` (#offset PgfAbsFun, ep) + n_lins = fromIntegral (length seqids) :: CSizeT + ptr <- gu_malloc_aligned pool + ((#size PgfCncFun)+n_lins*(#size PgfSequence*)) + (#const gu_flex_alignof(PgfCncFun)) + (#poke PgfCncFun, absfun) ptr c_absfun + (#poke PgfCncFun, ep) ptr c_ep + (#poke PgfCncFun, funid) ptr (funid :: CInt) + (#poke PgfCncFun, n_lins) ptr n_lins + pokeSequences seqs_ptr (ptr `plusPtr` (#offset PgfCncFun, lins)) seqids + return ptr + where + pokeSequences seqs_ptr ptr [] = return () + pokeSequences seqs_ptr ptr (seqid:seqids) = do + poke ptr (seqs_ptr `plusPtr` (seqid * (#size PgfSequence))) + pokeSequences seqs_ptr (ptr `plusPtr` (#size PgfSequence*)) seqids + +getCCat c_ccats fid pool = + alloca $ \pfid -> do + poke pfid (fromIntegral fid :: CInt) + ptr <- gu_map_find_default c_ccats pfid + c_ccat <- peek ptr + if c_ccat /= nullPtr + then return c_ccat + else do c_ccat <- gu_malloc_aligned pool + (#size PgfCCat) + (#const gu_alignof(PgfCCat)) + (#poke PgfCCat, cnccat) c_ccat nullPtr + (#poke PgfCCat, lindefs) c_ccat nullPtr + (#poke PgfCCat, linrefs) c_ccat nullPtr + (#poke PgfCCat, n_synprods) c_ccat (0 :: CSizeT) + (#poke PgfCCat, prods) c_ccat nullPtr + (#poke PgfCCat, viterbi_prob) c_ccat (0 :: CFloat) + (#poke PgfCCat, fid) c_ccat fid + (#poke PgfCCat, conts) c_ccat nullPtr + (#poke PgfCCat, answers) c_ccat nullPtr + ptr <- gu_map_insert c_ccats pfid + poke ptr c_ccat + return c_ccat + +newSymbol :: Symbol -> Ptr GuPool -> IO GuVariant +newSymbol (SymCat d r) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAT) + (fromIntegral (#size PgfSymbolCat)) + (#const gu_alignof(PgfSymbolCat)) + pptr pool + (#poke PgfSymbolCat, d) ptr (fromIntegral d :: CInt) + (#poke PgfSymbolCat, r) ptr (fromIntegral r :: CInt) + peek pptr +newSymbol (SymLit d r) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_LIT) + (fromIntegral (#size PgfSymbolLit)) + (#const gu_alignof(PgfSymbolLit)) + pptr pool + (#poke PgfSymbolLit, d) ptr (fromIntegral d :: CInt) + (#poke PgfSymbolLit, r) ptr (fromIntegral r :: CInt) + peek pptr +newSymbol (SymVar d r) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_VAR) + (fromIntegral (#size PgfSymbolVar)) + (#const gu_alignof(PgfSymbolVar)) + pptr pool + (#poke PgfSymbolVar, d) ptr (fromIntegral d :: CInt) + (#poke PgfSymbolVar, r) ptr (fromIntegral r :: CInt) + peek pptr +newSymbol (SymKS t) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_KS) + (fromIntegral ((#size PgfSymbolKS)+utf8Length t)) + (#const gu_flex_alignof(PgfSymbolKS)) + pptr pool + pokeUtf8CString t (ptr `plusPtr` (#offset PgfSymbolKS, token)) + peek pptr +newSymbol (SymKP def alts) pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_KP) + (fromIntegral ((#size PgfSymbolKP)+(length alts * (#size PgfAlternative)))) + (#const gu_flex_alignof(PgfSymbolKP)) + pptr pool + c_def <- newSymbols def pool + (#poke PgfSymbolKP, default_form) ptr c_def + pokeAlternatives (ptr `plusPtr` (#offset PgfSymbolKP, forms)) alts pool + peek pptr +newSymbol SymBIND pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_BIND) + (fromIntegral (#size PgfSymbolBIND)) + (#const gu_alignof(PgfSymbolBIND)) + pptr pool + peek pptr +newSymbol SymNE pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_NE) + (fromIntegral (#size PgfSymbolNE)) + (#const gu_alignof(PgfSymbolNE)) + pptr pool + peek pptr +newSymbol SymSOFT_BIND pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_BIND) + (fromIntegral (#size PgfSymbolBIND)) + (#const gu_alignof(PgfSymbolBIND)) + pptr pool + peek pptr +newSymbol SymSOFT_SPACE pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_SOFT_SPACE) + (fromIntegral (#size PgfSymbolBIND)) + (#const gu_alignof(PgfSymbolBIND)) + pptr pool + peek pptr +newSymbol SymCAPIT pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_CAPIT) + (fromIntegral (#size PgfSymbolCAPIT)) + (#const gu_alignof(PgfSymbolCAPIT)) + pptr pool + peek pptr +newSymbol SymALL_CAPIT pool = alloca $ \pptr -> do + ptr <- gu_alloc_variant (#const PGF_SYMBOL_ALL_CAPIT) + (fromIntegral (#size PgfSymbolCAPIT)) + (#const gu_alignof(PgfSymbolCAPIT)) + pptr pool + peek pptr + +newSymbols syms pool = newSequence (#size PgfSymbol) pokeSymbol syms pool + where + pokeSymbol p_sym sym = do + c_sym <- newSymbol sym pool + poke p_sym c_sym + +pokeAlternatives ptr [] pool = return () +pokeAlternatives ptr ((syms,prefixes):alts) pool = do + c_syms <- newSymbols syms pool + c_prefixes <- newSequence (#size GuString) (pokeString pool) prefixes pool + (#poke PgfAlternative, form) ptr c_syms + (#poke PgfAlternative, prefixes) ptr c_prefixes + pokeAlternatives (ptr `plusPtr` (#size PgfAlternative)) alts pool + +pokeString pool c_elem str = do + c_str <- newUtf8CString str pool + poke c_elem c_str + +newMap key_size hasher newKey elem_size pokeElem values pool = do + map <- gu_make_map key_size hasher + elem_size gu_null_struct + (#const GU_MAP_DEFAULT_INIT_SIZE) + pool + insert map values pool + return map + where + insert map [] pool = return () + insert map ((key,elem):values) pool = do + c_key <- newKey key pool + c_elem <- gu_map_insert map c_key + pokeElem c_elem elem + insert map values pool + + +writePGF :: FilePath -> PGF -> IO () +writePGF fpath p = do + pool <- gu_new_pool + exn <- gu_new_exn pool + withCString fpath $ \c_fpath -> + pgf_write (pgf p) c_fpath exn + touchPGF p + failed <- gu_exn_is_raised exn + if failed + then do is_errno <- gu_exn_caught exn gu_exn_type_GuErrno + if is_errno + then do perrno <- (#peek GuExn, data.data) exn + errno <- peek perrno + gu_pool_free pool + ioError (errnoToIOError "writePGF" (Errno errno) Nothing (Just fpath)) + else do gu_pool_free pool + throwIO (PGFError "The grammar cannot be stored") + else do gu_pool_free pool + return () + +sortByFst = sortBy (\(x,_) (y,_) -> compare x y) +sortByFst3 = sortBy (\(x,_,_) (y,_,_) -> compare x y) +sortByFst4 = sortBy (\(x,_,_,_) (y,_,_,_) -> compare x y) diff --git a/src/runtime/haskell-bind/PGF2/Type.hsc b/src/runtime/haskell-bind/PGF2/Type.hsc index ada2b5e03..57e7eeaa9 100644 --- a/src/runtime/haskell-bind/PGF2/Type.hsc +++ b/src/runtime/haskell-bind/PGF2/Type.hsc @@ -31,7 +31,7 @@ readType str = 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 exn + 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 @@ -62,10 +62,9 @@ showType scope (Type ty touch) = mkType :: [Hypo] -> CId -> [Expr] -> Type mkType hypos cat exprs = unsafePerformIO $ do typPl <- gu_new_pool - let n_exprs = fromIntegral (length exprs) :: CInt + let n_exprs = fromIntegral (length exprs) :: CSizeT c_type <- gu_malloc typPl ((#size PgfType) + n_exprs * (#size PgfExpr)) - c_hypos <- gu_make_seq (#size PgfHypo) (fromIntegral (length hypos)) typPl - hs <- pokeHypos (c_hypos `plusPtr` (#offset GuSeq, data)) hypos typPl + 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 @@ -73,27 +72,25 @@ mkType hypos cat exprs = unsafePerformIO $ do 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)) - where - pokeHypos :: Ptr a -> [Hypo] -> Ptr GuPool -> IO () - pokeHypos c_hypo [] typPl = return () - pokeHypos c_hypo ((bind_type,cid,Type c_ty _) : hypos) typPl = do - (#poke PgfHypo, bind_type) c_hypo cbind_type - newUtf8CString cid typPl >>= (#poke PgfHypo, cid) c_hypo - (#poke PgfHypo, type) c_hypo c_ty - pokeHypos (plusPtr c_hypo (#size PgfHypo)) hypos typPl - 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 +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) - touchHypo (_,_,ty) = touchType ty +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. @@ -125,3 +122,20 @@ unType (Type c_type touch) = unsafePerformIO $ do 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 :: [CId] -> [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 diff --git a/src/runtime/haskell-bind/SG/FFI.hs b/src/runtime/haskell-bind/SG/FFI.hs index 833e9aab3..ef1b06de8 100644 --- a/src/runtime/haskell-bind/SG/FFI.hs +++ b/src/runtime/haskell-bind/SG/FFI.hs @@ -65,10 +65,10 @@ foreign import ccall "sg/sg.h sg_triple_result_close" sg_triple_result_close :: Ptr SgTripleResult -> Ptr GuExn -> IO () foreign import ccall "sg/sg.h sg_query" - sg_query :: Ptr SgSG -> CInt -> Ptr PgfExpr -> Ptr GuExn -> IO (Ptr SgQueryResult) + sg_query :: Ptr SgSG -> CSizeT -> Ptr PgfExpr -> Ptr GuExn -> IO (Ptr SgQueryResult) foreign import ccall "sg/sg.h sg_query_result_columns" - sg_query_result_columns :: Ptr SgQueryResult -> IO CInt + sg_query_result_columns :: Ptr SgQueryResult -> IO CSizeT foreign import ccall "sg/sg.h sg_query_result_fetch" sg_query_result_fetch :: Ptr SgQueryResult -> Ptr PgfExpr -> Ptr GuPool -> Ptr GuExn -> IO CInt diff --git a/src/runtime/haskell-bind/examples/pgf-shell.hs b/src/runtime/haskell-bind/examples/pgf-shell.hs index 722770822..05c991691 100644 --- a/src/runtime/haskell-bind/examples/pgf-shell.hs +++ b/src/runtime/haskell-bind/examples/pgf-shell.hs @@ -37,18 +37,18 @@ execute cmd = P lang s -> do pgf <- gets fst c <- getConcr' pgf lang case parse c (startCat pgf) s of - Left tok -> do put (pgf,[]) - putln ("Parse error: "++tok) - Right ts -> do put (pgf,map show ts) - pop + ParseFailed _ tok -> do put (pgf,[]) + putln ("Parse error: "++tok) + ParseOk ts -> do put (pgf,map show ts) + pop T from to s -> do pgf <- gets fst cfrom <- getConcr' pgf from cto <- getConcr' pgf to case parse cfrom (startCat pgf) s of - Left tok -> do put (pgf,[]) - putln ("Parse error: "++tok) - Right ts -> do put (pgf,map (linearize cto.fst) ts) - pop + ParseFailed _ tok -> do put (pgf,[]) + putln ("Parse error: "++tok) + ParseOk ts -> do put (pgf,map (linearize cto.fst) ts) + pop I path -> do pgf <- liftIO (readPGF path) putln . unwords . M.keys $ languages pgf put (pgf,[]) diff --git a/src/runtime/haskell-bind/pgf2.cabal b/src/runtime/haskell-bind/pgf2.cabal index 8f29ea969..178f15023 100644 --- a/src/runtime/haskell-bind/pgf2.cabal +++ b/src/runtime/haskell-bind/pgf2.cabal @@ -1,32 +1,31 @@ name: pgf2 version: 0.1.0.0 --- synopsis: --- description: +-- synopsis: +-- description: homepage: http://www.grammaticalframework.org license: LGPL-3 --license-file: LICENSE author: Krasimir Angelov, Inari -maintainer: --- copyright: +maintainer: +-- copyright: category: Language build-type: Simple extra-source-files: README cabal-version: >=1.10 library - exposed-modules: PGF2, SG, + exposed-modules: PGF2, PGF2.Internal, SG, -- backwards compatibility API: PGF, PGF.Internal other-modules: PGF2.FFI, PGF2.Expr, PGF2.Type, SG.FFI - build-depends: base >=4.3, bytestring >=0.9, + build-depends: base >=4.3, containers, pretty - -- hs-source-dirs: + -- hs-source-dirs: default-language: Haskell2010 build-tools: hsc2hs extra-libraries: sg pgf gu cc-options: -std=c99 - default-language: Haskell2010 c-sources: utils.c executable pgf-shell diff --git a/src/runtime/haskell/Data/Binary/Builder.hs b/src/runtime/haskell/Data/Binary/Builder.hs index 03531daa7..b69371f0e 100644 --- a/src/runtime/haskell/Data/Binary/Builder.hs +++ b/src/runtime/haskell/Data/Binary/Builder.hs @@ -100,6 +100,11 @@ newtype Builder = Builder { runBuilder :: (Buffer -> [S.ByteString]) -> Buffer -> [S.ByteString] } +#if MIN_VERSION_base(4,11,0) +instance Semigroup Builder where + (<>) = append +#endif + instance Monoid Builder where mempty = empty {-# INLINE mempty #-} diff --git a/src/runtime/haskell/PGF.hs b/src/runtime/haskell/PGF.hs index 42519fb63..6c0002a8a 100644 --- a/src/runtime/haskell/PGF.hs +++ b/src/runtime/haskell/PGF.hs @@ -47,14 +47,14 @@ module PGF( Expr, showExpr, readExpr, mkAbs, unAbs, - mkApp, unApp, + mkApp, unApp, unapply, mkStr, unStr, mkInt, unInt, mkDouble, unDouble, mkFloat, unFloat, mkMeta, unMeta, -- extra - pExpr, + pExpr, exprSize, exprFunctions, -- * Operations -- ** Linearization @@ -66,7 +66,7 @@ module PGF( Forest.showBracketedString,flattenBracketedString, -- ** Parsing - parse, parseAllLang, parseAll, parse_, parseWithRecovery, + parse, parseAllLang, parseAll, parse_, parseWithRecovery, complete, -- ** Evaluation PGF.compute, paraphrase, @@ -273,6 +273,25 @@ parse_ pgf lang typ dp s = parseWithRecovery pgf lang typ open_typs dp s = Parse.parseWithRecovery pgf lang typ open_typs dp (words s) +complete :: PGF -> Language -> Type -> String -> String -> (BracketedString,String,Map.Map Token [CId]) +complete pgf from typ input prefix = + let ws = words input + ps0 = Parse.initState pgf from typ + (ps,ws') = loop ps0 ws + bs = snd (Parse.getParseOutput ps typ Nothing) + in if not (null ws') + then (bs, unwords (if null prefix then ws' else ws'++[prefix]), Map.empty) + else (bs, prefix, fmap getFuns (Parse.getCompletions ps prefix)) + where + loop ps [] = (ps,[]) + loop ps (w:ws) = case Parse.nextState ps (Parse.simpleParseInput w) of + Left es -> (ps,w:ws) + Right ps -> loop ps ws + + getFuns ps = [cid | (funid,cid,seq) <- snd . head $ Map.toList contInfo] + where + contInfo = Parse.getContinuationInfo ps + groupResults :: [[(Language,String)]] -> [(Language,[String])] groupResults = Map.toList . foldr more Map.empty . start . concat where @@ -314,6 +333,23 @@ functionType pgf fun = compute :: PGF -> Expr -> Expr compute pgf = PGF.Data.normalForm (funs (abstract pgf),const Nothing) 0 [] +exprSize :: Expr -> Int +exprSize (EAbs _ _ e) = exprSize e +exprSize (EApp e1 e2) = exprSize e1 + exprSize e2 +exprSize (ETyped e ty)= exprSize e +exprSize (EImplArg e) = exprSize e +exprSize _ = 1 + +exprFunctions :: Expr -> [CId] +exprFunctions (EAbs _ _ e) = exprFunctions e +exprFunctions (EApp e1 e2) = exprFunctions e1 ++ exprFunctions e2 +exprFunctions (ETyped e ty)= exprFunctions e +exprFunctions (EImplArg e) = exprFunctions e +exprFunctions (EFun f) = [f] +exprFunctions _ = [] + +--exprFunctions :: Expr -> [Fun] + browse :: PGF -> CId -> Maybe (String,[CId],[CId]) browse pgf id = fmap (\def -> (def,producers,consumers)) definition where diff --git a/src/runtime/haskell/PGF/ByteCode.hs b/src/runtime/haskell/PGF/ByteCode.hs index 579d6b3bb..ef21ab229 100644 --- a/src/runtime/haskell/PGF/ByteCode.hs +++ b/src/runtime/haskell/PGF/ByteCode.hs @@ -2,7 +2,7 @@ module PGF.ByteCode(Literal(..), CodeLabel, Instr(..), IVal(..), TailInfo(..), ppLit, ppCode, ppInstr ) where - +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF.CId import Text.PrettyPrint diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs index 331a69d90..d015f18e0 100644 --- a/src/runtime/haskell/PGF/Expr.hs +++ b/src/runtime/haskell/PGF/Expr.hs @@ -2,7 +2,7 @@ module PGF.Expr(Tree, BindType(..), Expr(..), Literal(..), Patt(..), Equation(.. readExpr, showExpr, pExpr, pBinds, ppExpr, ppPatt, pattScope,
mkAbs, unAbs,
- mkApp, unApp, unAppForm,
+ mkApp, unApp, unapply,
mkStr, unStr,
mkInt, unInt,
mkDouble, unDouble,
@@ -108,13 +108,13 @@ mkApp f es = foldl EApp (EFun f) es -- | Decomposes an expression into application of function
unApp :: Expr -> Maybe (CId,[Expr])
-unApp e = case unAppForm e of
+unApp e = case unapply e of
(EFun f,es) -> Just (f,es)
_ -> Nothing
-- | Decomposes an expression into an application of a constructor such as a constant or a metavariable
-unAppForm :: Expr -> (Expr,[Expr])
-unAppForm = extract []
+unapply :: Expr -> (Expr,[Expr])
+unapply = extract []
where
extract es f@(EFun _) = (f,es)
extract es (EApp e1 e2) = extract (e2:es) e1
diff --git a/src/runtime/haskell/PGF/Macros.hs b/src/runtime/haskell/PGF/Macros.hs index de175616c..3fc7a5804 100644 --- a/src/runtime/haskell/PGF/Macros.hs +++ b/src/runtime/haskell/PGF/Macros.hs @@ -1,4 +1,5 @@ module PGF.Macros where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF.CId import PGF.Data diff --git a/src/runtime/haskell/PGF/Optimize.hs b/src/runtime/haskell/PGF/Optimize.hs index 8739c8665..6e7f51fb2 100644 --- a/src/runtime/haskell/PGF/Optimize.hs +++ b/src/runtime/haskell/PGF/Optimize.hs @@ -21,6 +21,7 @@ import qualified Data.IntMap as IntMap import qualified PGF.TrieMap as TrieMap import qualified Data.List as List import Control.Monad.ST +import Debug.Trace optimizePGF :: PGF -> PGF optimizePGF pgf = pgf{concretes=fmap (updateConcrete (abstract pgf) . @@ -178,26 +179,26 @@ topDownFilter startCat cnc = bottomUpFilter :: Concr -> Concr -bottomUpFilter cnc = cnc{productions=filterProductions IntMap.empty IntSet.empty (productions cnc)} +bottomUpFilter cnc = cnc{productions=filterProductions IntMap.empty (productions cnc)} -filterProductions prods0 hoc0 prods +filterProductions prods0 prods | prods0 == prods1 = prods0 - | otherwise = filterProductions prods1 hoc1 prods + | otherwise = filterProductions prods1 prods where - (prods1,hoc1) = IntMap.foldWithKey foldProdSet (IntMap.empty,IntSet.empty) prods + prods1 = IntMap.foldWithKey foldProdSet IntMap.empty prods + hoc = IntMap.fold (\set !hoc -> Set.fold accumHOC hoc set) IntSet.empty prods - foldProdSet fid set (!prods,!hoc) - | Set.null set1 = (prods,hoc) - | otherwise = (IntMap.insert fid set1 prods,hoc1) + foldProdSet fid set !prods + | Set.null set1 = prods + | otherwise = IntMap.insert fid set1 prods where set1 = Set.filter filterRule set - hoc1 = Set.fold accumHOC hoc set1 filterRule (PApply funid args) = all (\(PArg _ fid) -> isLive fid) args filterRule (PCoerce fid) = isLive fid filterRule _ = True - isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc0 + isLive fid = isPredefFId fid || IntMap.member fid prods0 || IntSet.member fid hoc accumHOC (PApply funid args) hoc = List.foldl' (\hoc (PArg hypos _) -> List.foldl' (\hoc (_,fid) -> IntSet.insert fid hoc) hoc hypos) hoc args accumHOC _ hoc = hoc @@ -241,7 +242,7 @@ splitLexicalRules cnc p_prods = seq2prefix (SymALL_CAPIT :syms) = TrieMap.fromList [wf ["&|"]] updateConcrete abs cnc = - let p_prods0 = filterProductions IntMap.empty IntSet.empty (productions cnc) + let p_prods0 = filterProductions IntMap.empty (productions cnc) (lex,p_prods) = splitLexicalRules cnc p_prods0 l_prods = linIndex cnc p_prods0 in cnc{pproductions = p_prods, lproductions = l_prods, lexicon = lex} diff --git a/src/runtime/haskell/PGF/Printer.hs b/src/runtime/haskell/PGF/Printer.hs index 43c270b13..07e94f866 100644 --- a/src/runtime/haskell/PGF/Printer.hs +++ b/src/runtime/haskell/PGF/Printer.hs @@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} module PGF.Printer (ppPGF,ppCat,ppFId,ppFunId,ppSeqId,ppSeq,ppFun) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF.CId import PGF.Data diff --git a/src/runtime/haskell/PGF/VisualizeTree.hs b/src/runtime/haskell/PGF/VisualizeTree.hs index 5d884fafe..520eb59c3 100644 --- a/src/runtime/haskell/PGF/VisualizeTree.hs +++ b/src/runtime/haskell/PGF/VisualizeTree.hs @@ -23,6 +23,7 @@ module PGF.VisualizeTree , gizaAlignment , conlls2latexDoc ) where +import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint import PGF.CId (wildCId,showCId,ppCId,mkCId) --CId,pCId, import PGF.Data diff --git a/src/runtime/java/jni_utils.c b/src/runtime/java/jni_utils.c index 59c4a7e54..93367bf37 100644 --- a/src/runtime/java/jni_utils.c +++ b/src/runtime/java/jni_utils.c @@ -1,6 +1,8 @@ #include <jni.h> #include <gu/utf8.h> #include <gu/string.h> +#include <pgf/pgf.h> +#include <pgf/linearizer.h> #include "jni_utils.h" #ifndef __MINGW32__ #include <alloca.h> @@ -34,16 +36,48 @@ gu2j_string(JNIEnv *env, GuString s) { } JPGF_INTERNAL jstring +gu2j_string_len(JNIEnv *env, const char* s, size_t len) { + const char* utf8 = s; + + jchar* utf16 = alloca(len*sizeof(jchar)); + jchar* dst = utf16; + while (s-utf8 < len) { + GuUCS ucs = gu_utf8_decode((const uint8_t**) &s); + + if (ucs <= 0xFFFF) { + *dst++ = ucs; + } else { + ucs -= 0x10000; + *dst++ = 0xD800+((ucs >> 10) & 0x3FF); + *dst++ = 0xDC00+(ucs & 0x3FF); + } + } + + return (*env)->NewString(env, utf16, dst-utf16); +} + +JPGF_INTERNAL jstring gu2j_string_buf(JNIEnv *env, GuStringBuf* sbuf) { - const char* s = gu_string_buf_data(sbuf); + return gu2j_string_len(env, gu_string_buf_data(sbuf), gu_string_buf_length(sbuf)); +} + +JPGF_INTERNAL jstring +gu2j_string_capit(JNIEnv *env, GuString s, PgfCapitState capit) { const char* utf8 = s; - size_t len = gu_string_buf_length(sbuf); + size_t len = strlen(s); jchar* utf16 = alloca(len*sizeof(jchar)); jchar* dst = utf16; while (s-utf8 < len) { GuUCS ucs = gu_utf8_decode((const uint8_t**) &s); + if (capit == PGF_CAPIT_FIRST) { + ucs = gu_ucs_to_upper(ucs); + capit = PGF_CAPIT_NONE; + } else if (capit == PGF_CAPIT_NEXT) { + ucs = gu_ucs_to_upper(ucs); + } + if (ucs <= 0xFFFF) { *dst++ = ucs; } else { diff --git a/src/runtime/java/jni_utils.h b/src/runtime/java/jni_utils.h index f2d050092..b69372979 100644 --- a/src/runtime/java/jni_utils.h +++ b/src/runtime/java/jni_utils.h @@ -21,8 +21,14 @@ JPGF_INTERNAL_DECL jstring gu2j_string(JNIEnv *env, GuString s); JPGF_INTERNAL_DECL jstring +gu2j_string_len(JNIEnv *env, const char* s, size_t len); + +JPGF_INTERNAL_DECL jstring gu2j_string_buf(JNIEnv *env, GuStringBuf* sbuf); +JPGF_INTERNAL jstring +gu2j_string_capit(JNIEnv *env, GuString s, PgfCapitState capit); + JPGF_INTERNAL_DECL GuString j2gu_string(JNIEnv *env, jstring s, GuPool* pool); diff --git a/src/runtime/java/jpgf.c b/src/runtime/java/jpgf.c index db662f5c2..bdfdc8e8c 100644 --- a/src/runtime/java/jpgf.c +++ b/src/runtime/java/jpgf.c @@ -188,7 +188,7 @@ Java_org_grammaticalframework_pgf_PGF_getFunctionProb(JNIEnv* env, jobject self, PgfPGF* pgf = get_ref(env, self); GuPool* tmp_pool = gu_local_pool(); PgfCId id = j2gu_string(env, jid, tmp_pool); - double prob = pgf_function_prob(pgf, id); + prob_t prob = pgf_function_prob(pgf, id); gu_pool_free(tmp_pool); return prob; @@ -508,7 +508,7 @@ jpgf_literal_callback_match(PgfLiteralCallback* self, PgfConcr* concr, size_t len = gu_string_buf_length(sbuf); GuIn* in = gu_data_in((uint8_t*) str, len, tmp_pool); - ep->expr = pgf_read_expr(in, out_pool, err); + ep->expr = pgf_read_expr(in, out_pool, tmp_pool, err); if (!gu_ok(err) || gu_variant_is_null(ep->expr)) { throw_string_exception(env, "org/grammaticalframework/pgf/PGFError", "The expression cannot be parsed"); gu_pool_free(tmp_pool); @@ -591,6 +591,30 @@ JNIEXPORT void JNICALL Java_org_grammaticalframework_pgf_Parser_addLiteralCallba j2gu_string(env, jcat, pool), &callback->callback); } +static void +throw_parse_error(JNIEnv *env, PgfParseError* err) +{ + jstring jtoken; + if (err->incomplete) + jtoken = NULL; + else { + jtoken = gu2j_string_len(env, err->token_ptr, err->token_len); + if (!jtoken) + return; + } + + jclass exception_class = (*env)->FindClass(env, "org/grammaticalframework/pgf/ParseError"); + if (!exception_class) + return; + jmethodID constrId = (*env)->GetMethodID(env, exception_class, "<init>", "(Ljava/lang/String;IZ)V"); + if (!constrId) + return; + jobject exception = (*env)->NewObject(env, exception_class, constrId, jtoken, err->offset, err->incomplete); + if (!exception) + return; + (*env)->Throw(env, exception); +} + JNIEXPORT jobject JNICALL Java_org_grammaticalframework_pgf_Parser_parseWithHeuristics (JNIEnv* env, jclass clazz, jobject jconcr, jstring jstartCat, jstring js, jdouble heuristics, jlong callbacksRef, jobject jpool) @@ -615,8 +639,7 @@ Java_org_grammaticalframework_pgf_Parser_parseWithHeuristics GuString msg = (GuString) gu_exn_caught_data(parse_err); throw_string_exception(env, "org/grammaticalframework/pgf/PGFError", msg); } else if (gu_exn_caught(parse_err, PgfParseError)) { - GuString tok = (GuString) gu_exn_caught_data(parse_err); - throw_string_exception(env, "org/grammaticalframework/pgf/ParseError", tok); + throw_parse_error(env, (PgfParseError*) gu_exn_caught_data(parse_err)); } gu_pool_free(out_pool); @@ -656,8 +679,7 @@ Java_org_grammaticalframework_pgf_Completer_complete(JNIEnv* env, jclass clazz, GuString msg = (GuString) gu_exn_caught_data(parse_err); throw_string_exception(env, "org/grammaticalframework/pgf/PGFError", msg); } else if (gu_exn_caught(parse_err, PgfParseError)) { - GuString tok = (GuString) gu_exn_caught_data(parse_err); - throw_string_exception(env, "org/grammaticalframework/pgf/ParseError", tok); + throw_parse_error(env, (PgfParseError*) gu_exn_caught_data(parse_err)); } gu_pool_free(pool); @@ -709,8 +731,8 @@ Java_org_grammaticalframework_pgf_TokenIterator_fetchTokenProb(JNIEnv* env, jcla return NULL; jclass tp_class = (*env)->FindClass(env, "org/grammaticalframework/pgf/TokenProb"); - jmethodID tp_constrId = (*env)->GetMethodID(env, tp_class, "<init>", "(DLjava/lang/String;Ljava/lang/String;)V"); - jobject jtp = (*env)->NewObject(env, tp_class, tp_constrId, tp->prob, gu2j_string(env,tp->tok), gu2j_string(env,tp->cat)); + jmethodID tp_constrId = (*env)->GetMethodID(env, tp_class, "<init>", "(DLjava/lang/String;Ljava/lang/String;Ljava/lang/String;)V"); + jobject jtp = (*env)->NewObject(env, tp_class, tp_constrId, (double) tp->prob, gu2j_string(env,tp->tok), gu2j_string(env,tp->cat), gu2j_string(env,tp->fun)); return jtp; } @@ -908,6 +930,9 @@ typedef struct { GuPool* tmp_pool; GuBuf* stack; GuBuf* list; + bool bind; + PgfCapitState capit; + jobject bind_instance; jclass object_class; jclass bracket_class; jmethodID bracket_constrId; @@ -919,12 +944,27 @@ pgf_bracket_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok) PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); JNIEnv* env = state->env; - jstring jname = gu2j_string(env, tok); - gu_buf_push(state->list, jobject, jname); + if (state->bind) { + jobject bind_instance = (*env)->NewLocalRef(env, state->bind_instance); + gu_buf_push(state->list, jobject, bind_instance); + state->bind = false; + } else { + if (state->capit == PGF_CAPIT_NEXT) + state->capit = PGF_CAPIT_NONE; + } + + if (state->capit == PGF_CAPIT_ALL) + state->capit = PGF_CAPIT_NEXT; + + jstring jtok = gu2j_string_capit(env, tok, state->capit); + gu_buf_push(state->list, jobject, jtok); + + if (state->capit == PGF_CAPIT_FIRST) + state->capit = PGF_CAPIT_NONE; } static void -pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); @@ -933,7 +973,7 @@ pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int linde } static void -pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); JNIEnv* env = state->env; @@ -972,6 +1012,20 @@ pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, } static void +pgf_bracket_lzn_symbol_bind(PgfLinFuncs** funcs) +{ + PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); + state->bind = true; +} + +static void +pgf_bracket_lzn_symbol_capit(PgfLinFuncs** funcs, PgfCapitState capit) +{ + PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); + state->capit = capit; +} + +static void pgf_bracket_lzn_symbol_meta(PgfLinFuncs** funcs, PgfMetaId id) { pgf_bracket_lzn_symbol_token(funcs, "?"); @@ -982,8 +1036,8 @@ static PgfLinFuncs pgf_bracket_lin_funcs = { .begin_phrase = pgf_bracket_lzn_begin_phrase, .end_phrase = pgf_bracket_lzn_end_phrase, .symbol_ne = NULL, - .symbol_bind = NULL, - .symbol_capit = NULL, + .symbol_bind = pgf_bracket_lzn_symbol_bind, + .symbol_capit = pgf_bracket_lzn_symbol_capit, .symbol_meta = pgf_bracket_lzn_symbol_meta }; @@ -1000,6 +1054,16 @@ Java_org_grammaticalframework_pgf_Concr_bracketedLinearize(JNIEnv* env, jobject jmethodID bracket_constrId = (*env)->GetMethodID(env, bracket_class, "<init>", "(Ljava/lang/String;Ljava/lang/String;II[Ljava/lang/Object;)V"); if (!bracket_constrId) return NULL; + + jclass bind_class = (*env)->FindClass(env, "org/grammaticalframework/pgf/BIND"); + if (!bind_class) + return NULL; + jfieldID bind_instance_id = (*env)->GetStaticFieldID(env, bind_class, "instance", "Lorg/grammaticalframework/pgf/BIND;"); + if (!bind_instance_id) + return NULL; + jobject bind_instance = (*env)->GetStaticObjectField(env, bind_class, bind_instance_id); + if (!bind_instance) + return NULL; GuPool* tmp_pool = gu_local_pool(); GuExn* err = gu_exn(tmp_pool); @@ -1034,6 +1098,9 @@ Java_org_grammaticalframework_pgf_Concr_bracketedLinearize(JNIEnv* env, jobject state.tmp_pool = tmp_pool; state.stack = gu_new_buf(GuBuf*, tmp_pool); state.list = gu_new_buf(jobject, tmp_pool); + state.bind = true; + state.capit = PGF_CAPIT_NONE; + state.bind_instance = bind_instance; state.object_class = object_class; state.bracket_class = bracket_class; state.bracket_constrId = bracket_constrId; @@ -1277,7 +1344,7 @@ Java_org_grammaticalframework_pgf_Expr_readExpr(JNIEnv* env, jclass clazz, jstri GuIn* in = gu_data_in((uint8_t*) buf, strlen(buf), tmp_pool); GuExn* err = gu_exn(tmp_pool); - PgfExpr e = pgf_read_expr(in, pool, err); + PgfExpr e = pgf_read_expr(in, pool, tmp_pool, err); if (!gu_ok(err) || gu_variant_is_null(e)) { throw_string_exception(env, "org/grammaticalframework/pgf/PGFError", "The expression cannot be parsed"); gu_pool_free(tmp_pool); @@ -1553,6 +1620,13 @@ Java_org_grammaticalframework_pgf_Expr_hashCode(JNIEnv* env, jobject self) return pgf_expr_hash(0, e); } +JNIEXPORT jint JNICALL +Java_org_grammaticalframework_pgf_Expr_size(JNIEnv* env, jobject self) +{ + PgfExpr e = gu_variant_from_ptr(l2p(get_ref(env, self))); + return pgf_expr_size(e); +} + JNIEXPORT jstring JNICALL Java_org_grammaticalframework_pgf_Type_getCategory(JNIEnv* env, jobject self) { @@ -1589,7 +1663,7 @@ Java_org_grammaticalframework_pgf_Type_readType(JNIEnv* env, jclass clazz, jstri GuIn* in = gu_data_in((uint8_t*) buf, strlen(buf), tmp_pool); GuExn* err = gu_exn(tmp_pool); - PgfType* ty = pgf_read_type(in, pool, err); + PgfType* ty = pgf_read_type(in, pool, tmp_pool, err); if (!gu_ok(err)) { throw_string_exception(env, "org/grammaticalframework/pgf/PGFError", "The type cannot be parsed"); gu_pool_free(tmp_pool); diff --git a/src/runtime/java/jsg.c b/src/runtime/java/jsg.c index 61ee2488e..9419ac127 100644 --- a/src/runtime/java/jsg.c +++ b/src/runtime/java/jsg.c @@ -1,6 +1,7 @@ #include <jni.h> #include <sg/sg.h> #include <pgf/expr.h> +#include <pgf/linearizer.h> #include "jni_utils.h" JNIEXPORT jobject JNICALL diff --git a/src/runtime/java/org/grammaticalframework/pgf/BIND.java b/src/runtime/java/org/grammaticalframework/pgf/BIND.java new file mode 100644 index 000000000..5cbbe4ce5 --- /dev/null +++ b/src/runtime/java/org/grammaticalframework/pgf/BIND.java @@ -0,0 +1,8 @@ +package org.grammaticalframework.pgf; + +public class BIND { + private BIND() { + } + + public static final BIND instance = new BIND(); +} diff --git a/src/runtime/java/org/grammaticalframework/pgf/Expr.java b/src/runtime/java/org/grammaticalframework/pgf/Expr.java index 40655cbcb..db0876bf8 100644 --- a/src/runtime/java/org/grammaticalframework/pgf/Expr.java +++ b/src/runtime/java/org/grammaticalframework/pgf/Expr.java @@ -108,6 +108,9 @@ public class Expr implements Serializable { return showExpr(ref); } + /** Computes the number of functions in the expression */ + public native int size(); + /** Reads a string in the GF syntax for abstract expressions * and returns an object representing the expression. */ public static native Expr readExpr(String s) throws PGFError; diff --git a/src/runtime/java/org/grammaticalframework/pgf/ParseError.java b/src/runtime/java/org/grammaticalframework/pgf/ParseError.java index 7fd332708..8b3f51ae2 100644 --- a/src/runtime/java/org/grammaticalframework/pgf/ParseError.java +++ b/src/runtime/java/org/grammaticalframework/pgf/ParseError.java @@ -4,11 +4,26 @@ package org.grammaticalframework.pgf; public class ParseError extends Exception { private static final long serialVersionUID = -6086991674218306569L; - public ParseError(String token) { - super(token); + private String token; + private int offset; + private boolean incomplete; + + public ParseError(String token, int offset, boolean incomplete) { + super(incomplete ? "The sentence is incomplete" : "Unexpected token: \""+token+"\""); + this.token = token; + this.offset = offset; + this.incomplete = incomplete; } - + public String getToken() { - return getMessage(); + return token; + } + + public int getOffset() { + return offset; + } + + public boolean isIncomplete() { + return incomplete; } } diff --git a/src/runtime/java/org/grammaticalframework/pgf/TokenProb.java b/src/runtime/java/org/grammaticalframework/pgf/TokenProb.java index 2c4ce4447..36db54273 100644 --- a/src/runtime/java/org/grammaticalframework/pgf/TokenProb.java +++ b/src/runtime/java/org/grammaticalframework/pgf/TokenProb.java @@ -4,12 +4,14 @@ package org.grammaticalframework.pgf; public class TokenProb { private String tok; private String cat; + private String fun; private double prob; - public TokenProb(double prob, String tok, String cat) { + public TokenProb(double prob, String tok, String cat, String fun) { this.prob = prob; this.tok = tok; - this.cat = cat; + this.cat = cat; + this.fun = fun; } /** Returns the negative logarithmic probability. */ @@ -26,4 +28,9 @@ public class TokenProb { public String getCategory() { return cat; } + + /** Returns the function from which this word was predicted. */ + public String getFunction() { + return fun; + } } diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c index 7da62e453..a2f77aa42 100644 --- a/src/runtime/python/pypgf.c +++ b/src/runtime/python/pypgf.c @@ -1163,7 +1163,10 @@ Iter_fetch_token(IterObject* self) PyObject* py_tok = PyString_FromString(tp->tok); PyObject* py_cat = PyString_FromString(tp->cat); - PyObject* res = Py_BuildValue("(f,O,O)", tp->prob, py_tok, py_cat); + PyObject* py_fun = PyString_FromString(tp->fun); + PyObject* res = Py_BuildValue("(f,O,O,O)", tp->prob, py_tok, py_cat, py_fun); + Py_DECREF(py_fun); + Py_DECREF(py_cat); Py_DECREF(py_tok); return res; @@ -1391,7 +1394,7 @@ pypgf_literal_callback_match(PgfLiteralCallback* self, PgfConcr* concr, gu_string_buf_length(sbuf), tmp_pool); - ep->expr = pgf_read_expr(in, out_pool, err); + ep->expr = pgf_read_expr(in, out_pool, tmp_pool, err); if (!gu_ok(err) || gu_variant_is_null(ep->expr)) { PyErr_SetString(PGFError, "The expression cannot be parsed"); gu_pool_free(tmp_pool); @@ -1545,13 +1548,28 @@ Concr_parse(ConcrObject* self, PyObject *args, PyObject *keywds) GuString msg = (GuString) gu_exn_caught_data(parse_err); PyErr_SetString(PGFError, msg); } else if (gu_exn_caught(parse_err, PgfParseError)) { - GuString tok = (GuString) gu_exn_caught_data(parse_err); - PyObject* py_tok = PyString_FromString(tok); - PyObject_SetAttrString(ParseError, "token", py_tok); - PyErr_Format(ParseError, "Unexpected token: \"%s\"", tok); - Py_DECREF(py_tok); + PgfParseError* err = (PgfParseError*) gu_exn_caught_data(parse_err); + PyObject* py_offset = PyInt_FromLong(err->offset); + if (err->incomplete) { + PyObject_SetAttrString(ParseError, "incomplete", Py_True); + PyObject_SetAttrString(ParseError, "offset", py_offset); + PyErr_Format(ParseError, "The sentence is incomplete"); + } else { + PyObject* py_tok = PyString_FromStringAndSize(err->token_ptr, + err->token_len); + PyObject_SetAttrString(ParseError, "incomplete", Py_False); + PyObject_SetAttrString(ParseError, "offset", py_offset); + PyObject_SetAttrString(ParseError, "token", py_tok); +#if PY_MAJOR_VERSION >= 3 + PyErr_Format(ParseError, "Unexpected token: \"%U\"", py_tok); +#else + PyErr_Format(ParseError, "Unexpected token: \"%s\"", PyString_AsString(py_tok)); +#endif + Py_DECREF(py_tok); + } + Py_DECREF(py_offset); } - + Py_DECREF(pyres); pyres = NULL; } @@ -2057,7 +2075,7 @@ pgf_bracket_lzn_symbol_token(PgfLinFuncs** funcs, PgfToken tok) } static void -pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); @@ -2066,7 +2084,7 @@ pgf_bracket_lzn_begin_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int linde } static void -pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, int lindex, PgfCId fun) +pgf_bracket_lzn_end_phrase(PgfLinFuncs** funcs, PgfCId cat, int fid, size_t lindex, PgfCId fun) { PgfBracketLznState* state = gu_container(funcs, PgfBracketLznState, funcs); @@ -2601,6 +2619,24 @@ PGF_dealloc(PGFObject* self) Py_TYPE(self)->tp_free((PyObject*)self); } +static PyObject * +PGF_repr(PGFObject *self) +{ + GuPool* tmp_pool = gu_local_pool(); + + GuExn* err = gu_exn(tmp_pool); + GuStringBuf* sbuf = gu_new_string_buf(tmp_pool); + GuOut* out = gu_string_buf_out(sbuf); + + pgf_print(self->pgf, out, err); + + PyObject* pystr = PyString_FromStringAndSize(gu_string_buf_data(sbuf), + gu_string_buf_length(sbuf)); + + gu_pool_free(tmp_pool); + return pystr; +} + static PyObject* PGF_getAbstractName(PGFObject *self, void *closure) { @@ -3221,7 +3257,7 @@ static PyTypeObject pgf_PGFType = { 0, /*tp_as_mapping*/ 0, /*tp_hash */ 0, /*tp_call*/ - 0, /*tp_str*/ + (reprfunc) PGF_repr, /*tp_str*/ 0, /*tp_getattro*/ 0, /*tp_setattro*/ 0, /*tp_as_buffer*/ @@ -3295,7 +3331,7 @@ pgf_readExpr(PyObject *self, PyObject *args) { GuExn* err = gu_new_exn(tmp_pool); pyexpr->pool = gu_new_pool(); - pyexpr->expr = pgf_read_expr(in, pyexpr->pool, err); + pyexpr->expr = pgf_read_expr(in, pyexpr->pool, tmp_pool, err); pyexpr->master = NULL; if (!gu_ok(err) || gu_variant_is_null(pyexpr->expr)) { @@ -3325,7 +3361,7 @@ pgf_readType(PyObject *self, PyObject *args) { GuExn* err = gu_new_exn(tmp_pool); pytype->pool = gu_new_pool(); - pytype->type = pgf_read_type(in, pytype->pool, err); + pytype->type = pgf_read_type(in, pytype->pool, tmp_pool, err); pytype->master = NULL; if (!gu_ok(err) || pytype->type == NULL) { |