first draft of a typechecker

src/runtime/c/pgf/pgf.cxx

@@ -1249,19 +1249,21 @@ void pgf_release_phrasetable_ids(PgfPhrasetableIds *seq_ids)
 }
 
 PGF_API
-void pgf_check_expr(PgfDB *db, PgfRevision revision,
+PgfExpr pgf_check_expr(PgfDB *db, PgfRevision revision,
-                    PgfExpr* pe, PgfType ty,
+                       PgfExpr e, PgfType ty,
-                    PgfMarshaller *m, PgfUnmarshaller *u,
+                       PgfMarshaller *m, PgfUnmarshaller *u,
-                    PgfExn *err)
+                       PgfExn *err)
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
 
         ref<PgfPGF> pgf = db->revision2pgf(revision);
 
-        PgfTypechecker checker(pgf,m,u);
+        PgfTypechecker checker(pgf,m,u,err);
-        *pe = m->match_expr(&checker, *pe);
+        return checker.check_expr(e, ty);
     } PGF_API_END
+
+    return 0;
 }
 
 PGF_API
@@ -1275,31 +1277,29 @@ PgfType pgf_infer_expr(PgfDB *db, PgfRevision revision,
 
         ref<PgfPGF> pgf = db->revision2pgf(revision);
 
-        PgfTypechecker checker(pgf,m,u);
+        PgfTypechecker checker(pgf,m,u,err);
-        *pe = m->match_expr(&checker, *pe);
+        return checker.infer_expr(pe);
     } PGF_API_END
 
-    PgfText *cat = (PgfText *) alloca(sizeof(PgfText)+2);
+    return 0;
-    cat->size = 1;
-    cat->text[0] = 'S';
-    cat->text[1] = 0;
-    return u->dtyp(0,NULL,cat,0,NULL);
 }
 
 PGF_API
-void pgf_check_type(PgfDB *db, PgfRevision revision,
+PgfType pgf_check_type(PgfDB *db, PgfRevision revision,
-                    PgfType* pty,
+                       PgfType ty,
-                    PgfMarshaller *m, PgfUnmarshaller *u,
+                       PgfMarshaller *m, PgfUnmarshaller *u,
-                    PgfExn *err)
+                       PgfExn *err)
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
 
         ref<PgfPGF> pgf = db->revision2pgf(revision);
 
-        PgfTypechecker checker(pgf,m,u);
+        PgfTypechecker checker(pgf,m,u,err);
-        *pty = m->match_type(&checker, *pty);
+        return checker.check_type(ty);
     } PGF_API_END
+
+    return 0;
 }
 
 PGF_API
@@ -1647,7 +1647,7 @@ void pgf_drop_category(PgfDB *db, PgfRevision revision,
             itor.fn       = iter_drop_cat_helper;
             itor.pgf      = pgf;
             PgfProbspace funs_by_cat =
-                probspace_delete_by_cat(pgf->abstract.funs_by_cat, &cat->name,
+                probspace_delete_by_cat(pgf->abstract.funs_by_cat, name,
                                         &itor, err);
             pgf->abstract.funs_by_cat = funs_by_cat;
             PgfAbsCat::release(cat);

src/runtime/c/pgf/pgf.h

@@ -522,10 +522,10 @@ PGF_API_DECL
 void pgf_release_phrasetable_ids(PgfPhrasetableIds *seq_ids);
 
 PGF_API_DECL
-void pgf_check_expr(PgfDB *db, PgfRevision revision,
+PgfExpr pgf_check_expr(PgfDB *db, PgfRevision revision,
-                    PgfExpr* pe, PgfType ty,
+                       PgfExpr e, PgfType ty,
-                    PgfMarshaller *m, PgfUnmarshaller *u,
+                       PgfMarshaller *m, PgfUnmarshaller *u,
-                    PgfExn *err);
+                       PgfExn *err);
 
 PGF_API_DECL
 PgfType pgf_infer_expr(PgfDB *db, PgfRevision revision,
@@ -534,10 +534,10 @@ PgfType pgf_infer_expr(PgfDB *db, PgfRevision revision,
                        PgfExn *err);
 
 PGF_API_DECL
-void pgf_check_type(PgfDB *db, PgfRevision revision,
+PgfType pgf_check_type(PgfDB *db, PgfRevision revision,
-                    PgfType* pty,
+                       PgfType ty,
-                    PgfMarshaller *m, PgfUnmarshaller *u,
+                       PgfMarshaller *m, PgfUnmarshaller *u,
-                    PgfExn *err);
+                       PgfExn *err);
 
 PGF_API_DECL
 PgfExpr pgf_generate_random(PgfDB *db, PgfRevision revision,

src/runtime/c/pgf/typechecker.cxx

@@ -1,84 +1,464 @@
+#include <stdarg.h>
 #include "data.h"
 #include "typechecker.h"
 
-PgfExpr PgfTypechecker::eabs(PgfBindType btype, PgfText *name, PgfExpr body)
+class PgfTypechecker::Unmarshaller1 : public PgfUnmarshaller {
+    virtual PgfExpr eabs(PgfBindType bind_type, PgfText *name, PgfExpr body) { return 0; }
+    virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg) { return 0; }
+    virtual PgfExpr elit(PgfLiteral lit) { return 0; }
+    virtual PgfExpr emeta(PgfMetaId meta_id) { return 0; }
+    virtual PgfExpr efun(PgfText *name) { return 0; }
+    virtual PgfExpr evar(int index) { return 0; }
+    virtual PgfExpr etyped(PgfExpr expr, PgfType ty) { return 0; }
+    virtual PgfExpr eimplarg(PgfExpr expr) { return 0; }
+    virtual PgfLiteral lint(size_t size, uintmax_t *val) { return 0; }
+    virtual PgfLiteral lflt(double val) { return 0; }
+    virtual PgfLiteral lstr(PgfText *val) { return 0; }
+
+    virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
+                         PgfText *name,
+                         size_t n_exprs, PgfExpr *exprs)
+    {
+        Type *ty = new(name) Cat;
+        while (n_hypos > 0) {
+            PgfTypeHypo *hypo = &hypos[--n_hypos];
+            ty = new(hypo->bind_type, hypo->cid, (Type*) hypo->type, ty) Pi;
+        }
+        return (PgfType) ty;
+    }
+
+    virtual void free_ref(object x) { }
+};
+
+class PgfTypechecker::Unmarshaller2 : public Unmarshaller1 {
+    PgfMarshaller *m;
+
+public:
+    Unmarshaller2(PgfMarshaller *m) {
+        this->m = m;
+    }
+
+    virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
+                         PgfText *name,
+                         size_t n_exprs, PgfExpr *exprs)
+    {
+        Type *ty = new(name) Cat;
+        while (n_hypos > 0) {
+            PgfTypeHypo *hypo = &hypos[--n_hypos];
+            Type *arg_ty = (Type *) m->match_type(this, hypo->type);
+            ty = new(hypo->bind_type, hypo->cid, arg_ty, ty) Pi;
+        }
+        return (PgfType) ty;
+    }
+
+    virtual void free_ref(object x) { }
+};
+
+PgfType PgfTypechecker::marshall_type(Type *ty, PgfUnmarshaller *u)
 {
-    return u->eabs(btype,name,body);
+    size_t n_hypos = 0;
+    PgfTypeHypo *hypos = 0;
+    for (;;) {
+        Pi *pi = ty->is_pi();
+        if (pi) {
+            hypos = (PgfTypeHypo *) realloc(hypos, n_hypos*sizeof(PgfTypeHypo));
+            PgfTypeHypo *hypo = &hypos[n_hypos++];
+            hypo->bind_type = pi->bind_type;
+            hypo->cid = &pi->var;
+            hypo->type = marshall_type(pi->arg, u);
+            ty = pi->res;
+        }
+        Cat *cat = ty->is_cat();
+        if (cat) {
+            return u->dtyp(n_hypos,hypos,&cat->name,0,NULL);
+        }
+    }
 }
 
-PgfExpr PgfTypechecker::eapp(PgfExpr fun, PgfExpr arg)
+PgfTypechecker::PgfTypechecker(ref<PgfPGF> gr, PgfMarshaller *m, PgfUnmarshaller *u, PgfExn* err) {
-{
+    this->gr   = gr;
-    fun = m->match_expr(this, fun);
+    this->m    = m;
+    this->u    = u;
+    this->err  = err;
+};
 
-    size_t       fun_n_args = n_args;
+PgfTypechecker::~PgfTypechecker() {
-    ref<PgfDTyp> fun_type   = type;
+    while (temps.size() > 0) {
-
+        Type *ty = temps.back(); temps.pop_back();
-    arg = m->match_expr(this, arg);
+        delete(ty);
-    return u->eapp(fun, arg);
+    }
 }
 
-PgfExpr PgfTypechecker::elit(PgfLiteral lit)
+PgfTypechecker::Context::Context(PgfTypechecker *tc, Type *exp_type, PgfBindType bind_type) {
-{
+    this->tc         = tc;
-    return u->elit(lit);
+    this->bind_type  = bind_type;
+    this->exp_type   = exp_type;
+    this->inf_type   = NULL;
 }
 
-PgfExpr PgfTypechecker::emeta(PgfMetaId meta)
+PgfExpr PgfTypechecker::Context::eabs(PgfBindType btype, PgfText *name, PgfExpr body)
 {
-    return u->emeta(meta);
+    if (!checkImplArgument())
+        return 0;
+    return tc->u->eabs(btype,name,body);
 }
 
-PgfExpr PgfTypechecker::efun(PgfText *name)
+PgfExpr PgfTypechecker::Context::eapp(PgfExpr fun, PgfExpr arg)
 {
+    if (!checkImplArgument())
+        return 0;
+
+    Context fun_ctxt(tc);
+    fun = tc->m->match_expr(&fun_ctxt, fun);
+    if (fun == 0)
+        return 0;
+
+repeat:
+    Pi *pi = fun_ctxt.inf_type->is_pi();
+    if (!pi) {
+        tc->type_error("Too many arguments");
+        return 0;
+    }
+
+    Context arg_ctxt(tc,pi->arg,pi->bind_type);
+    PgfExpr new_arg = tc->m->match_expr(&arg_ctxt, arg);
+    if (new_arg == 0) {
+        if (tc->err->type == PGF_EXN_TYPE_ERROR && tc->err->code == 1) {
+            tc->err->type = PGF_EXN_NONE;
+            tc->err->code = 0;
+            tc->err->msg  = NULL;
+            PgfExpr meta = tc->u->emeta(0);
+            PgfExpr impl = tc->u->eimplarg(meta);
+            PgfExpr new_fun = tc->u->eapp(fun, impl);
+            tc->u->free_ref(fun);
+            tc->u->free_ref(impl);
+            tc->u->free_ref(meta);
+            fun = new_fun;
+            fun_ctxt.inf_type = pi->res;
+            goto repeat;
+        }
+        return 0;
+    }
+
+    PgfExpr e = tc->u->eapp(fun, new_arg);
+    free_ref(fun);
+    free_ref(new_arg);
+
+    inf_type = pi->res;
+
+    if (!unifyTypes(&e)) {
+        free_ref(fun);
+        free_ref(arg);
+        return 0;
+    }
+
+    return e;
+}
+
+PgfExpr PgfTypechecker::Context::elit(PgfLiteral lit)
+{
+    if (!checkImplArgument())
+        return 0;
+
+    lit = tc->m->match_lit(this, lit);
+    if (!lit)
+        return 0;
+
+    PgfExpr e = tc->u->elit(lit);  free_ref(lit);
+
+    if (!unifyTypes(&e))
+        return 0;
+
+    return e;
+}
+
+PgfExpr PgfTypechecker::Context::emeta(PgfMetaId meta)
+{
+    if (!checkImplArgument())
+        return 0;
+
+    if (exp_type == NULL)
+        return tc->type_error("Cannot infer the type of a meta variable");
+
+    PgfExpr e = tc->u->emeta(meta);
+
+    inf_type = exp_type;
+
+    if (!unifyTypes(&e))
+        return 0;
+
+    return e;
+}
+
+PgfExpr PgfTypechecker::Context::efun(PgfText *name)
+{
+    if (!checkImplArgument())
+        return 0;
+
     ref<PgfAbsFun> absfun =
-        namespace_lookup(gr->abstract.funs, name);
+        namespace_lookup(tc->gr->abstract.funs, name);
     if (absfun == 0)
-        throw pgf_error("Unknown function");
+        return tc->type_error("Function %s is not defined", name->text);
 
-    type   = absfun->type;
+    Unmarshaller1 tu;
-    n_args = 0;
+    inf_type = (Type*) tc->db_m.match_type(&tu, absfun->type.as_object());
-    return u->efun(name);
+    tc->temps.push_back(inf_type);
+
+    PgfExpr e = tc->u->efun(name);
+
+    if (!unifyTypes(&e)) {
+        tc->u->free_ref(e);
+        return 0;
+    }
+
+    return e;
 }
 
-PgfExpr PgfTypechecker::evar(int index)
+PgfExpr PgfTypechecker::Context::evar(int index)
 {
-    return u->evar(index);
+    if (!checkImplArgument())
+        return 0;
+
+    return tc->u->evar(index);
 }
 
-PgfExpr PgfTypechecker::etyped(PgfExpr expr, PgfType ty)
+PgfExpr PgfTypechecker::Context::etyped(PgfExpr expr, PgfType type)
 {
-    expr = m->match_expr(this, expr);
+    if (!checkImplArgument())
-    return u->etyped(expr,ty);
+        return 0;
+
+    Context type_ctxt(tc);
+    type = tc->m->match_type(&type_ctxt, type);
+    if (type == 0)
+        return 0;
+
+    Unmarshaller2 tu(tc->m);
+    Type *ty = (Type*) tc->m->match_type(&tu,type);
+
+    Context expr_ctxt(tc, ty, PGF_BIND_TYPE_EXPLICIT);
+    expr = tc->m->match_expr(&expr_ctxt, expr);
+    if (expr == 0) {
+        free_ref(type);
+        return 0;
+    }
+    inf_type = expr_ctxt.inf_type;
+
+    PgfExpr e = tc->u->etyped(expr,type);
+
+    free_ref(expr);
+    free_ref(type);
+
+    return e;
 }
 
-PgfExpr PgfTypechecker::eimplarg(PgfExpr expr)
+PgfExpr PgfTypechecker::Context::eimplarg(PgfExpr expr)
 {
-    expr = m->match_expr(this, expr);
+    if (bind_type != PGF_BIND_TYPE_IMPLICIT) {
-    return u->eimplarg(expr);
+        tc->type_error("Unexpected implicit argument");
+        return 0;
+    }
+
+    Context expr_ctxt(tc,exp_type,PGF_BIND_TYPE_EXPLICIT);
+    expr = tc->m->match_expr(&expr_ctxt, expr);
+    if (expr == 0) {
+        return 0;
+    }
+
+    inf_type = expr_ctxt.inf_type;
+
+    PgfExpr e = tc->u->eimplarg(expr);
+
+    free_ref(expr);
+
+    return e;
 }
 
-PgfLiteral PgfTypechecker::lint(size_t size, uintmax_t *v)
+PgfLiteral PgfTypechecker::Context::lint(size_t size, uintmax_t *v)
 {
-    return u->lint(size,v);
+    inf_type = new("Int") Cat;
+    tc->temps.push_back(inf_type);
+    return tc->u->lint(size,v);
 }
 
-PgfLiteral PgfTypechecker::lflt(double v)
+PgfLiteral PgfTypechecker::Context::lflt(double v)
 {
-    return u->lflt(v);
+    inf_type = new("Float") Cat;
+    tc->temps.push_back(inf_type);
+    return tc->u->lflt(v);
 }
 
-PgfLiteral PgfTypechecker::lstr(PgfText *v)
+PgfLiteral PgfTypechecker::Context::lstr(PgfText *v)
 {
-    return u->lstr(v);
+    inf_type = new("String") Cat;
+    tc->temps.push_back(inf_type);
+    return tc->u->lstr(v);
 }
 
-PgfType PgfTypechecker::dtyp(size_t n_hypos, PgfTypeHypo *hypos,
+PgfType PgfTypechecker::Context::dtyp(size_t n_hypos, PgfTypeHypo *hypos,
-                             PgfText *cat,
+                                      PgfText *cat,
-                             size_t n_exprs, PgfExpr *exprs)
+                                      size_t n_exprs, PgfExpr *exprs)
 {
-    return u->dtyp(n_hypos, hypos, cat, n_exprs, exprs);
+    ref<PgfAbsCat> abscat =
+        namespace_lookup(tc->gr->abstract.cats, cat);
+    if (abscat == 0)
+        return tc->type_error("Category %s is not defined", cat->text);
+
+    PgfType ty = 0;
+    PgfTypeHypo *new_hypos = (PgfTypeHypo *)
+        alloca(sizeof(PgfTypeHypo)*n_hypos);
+    size_t n_new_exprs = abscat->context->len;
+    PgfExpr *new_exprs = (PgfExpr *)
+        alloca(sizeof(PgfExpr)*n_new_exprs);
+
+    for (size_t i = 0; i < n_hypos; i++) {
+        new_hypos[i].bind_type = hypos[i].bind_type;
+        new_hypos[i].cid       = hypos[i].cid;
+        new_hypos[i].type      = tc->m->match_type(this, hypos[i].type);
+        if (new_hypos[i].type == 0) {
+            n_hypos = i;
+            n_new_exprs = 0;
+            goto exit;
+        }
+    }
+
+    size_t i, j;
+    for (i = 0, j = 0; i < n_new_exprs && j < n_exprs; i++) {
+        Unmarshaller1 tu;
+        PgfHypo *hypo = vector_elem(abscat->context,i);
+        Type *ty = (Type *) tc->db_m.match_type(&tu,hypo->type.as_object());
+        tc->temps.push_back(ty);
+        Context expr_ctxt(tc,ty,hypo->bind_type);
+        new_exprs[i] = tc->m->match_expr(&expr_ctxt, exprs[j]);
+        if (new_exprs[i] == 0) {
+            if (tc->err->type == PGF_EXN_TYPE_ERROR && tc->err->code == 1) {
+                tc->err->type = PGF_EXN_NONE;
+                tc->err->code = 0;
+                tc->err->msg  = NULL;
+                PgfExpr e1 = tc->u->emeta(0);
+                new_exprs[i] = tc->u->eimplarg(e1);  free_ref(e1);
+            } else {
+                n_new_exprs = i;
+                goto exit;
+            }
+        } else {
+            j++;
+        }
+    }
+
+    if (i < n_new_exprs) {
+        tc->type_error("Too few arguments to category %s - %ld expected but %ld given",
+                       cat->text,
+                       n_new_exprs,
+                       n_exprs);
+        n_new_exprs = n_exprs;
+        goto exit;
+    }
+    if (j < n_exprs) {
+        tc->type_error("Too many arguments to category %s - %ld expected but %ld given",
+                       cat->text,
+                       n_new_exprs,
+                       n_exprs);
+        goto exit;
+    }
+
+    ty = tc->u->dtyp(n_hypos, new_hypos, cat, n_new_exprs, new_exprs);
+
+exit:
+    for (size_t i = 0; i < n_hypos; i++) {
+        free_ref(new_hypos[i].type);
+    }
+    for (size_t i = 0; i < n_new_exprs; i++) {
+        free_ref(new_exprs[i]);
+    }
+    return ty;
 }
 
-void PgfTypechecker::free_ref(object x)
+void PgfTypechecker::Context::free_ref(object x)
 {
-    u->free_ref(x);
+    tc->u->free_ref(x);
+}
+
+bool PgfTypechecker::Context::checkImplArgument()
+{
+    if (bind_type == PGF_BIND_TYPE_IMPLICIT) {
+        tc->err->type = PGF_EXN_TYPE_ERROR;
+        tc->err->code = 1;
+        tc->err->msg  = "Unexpected explicit argument";
+        return false;
+    }
+    return true;
+}
+
+bool PgfTypechecker::unifyTypes(Type *ty1, Type *ty2)
+{
+    Cat *cat1 = ty1->is_cat();
+    Cat *cat2 = ty2->is_cat();
+    if (cat1 && cat2) {
+        if (textcmp(&cat1->name, &cat2->name) != 0) {
+            return type_error("Types %s and %s doesn't match", cat1->name.text, cat2->name.text);
+        }
+        return true;
+    }
+
+    Pi *pi1 = ty1->is_pi();
+    Pi *pi2 = ty2->is_pi();
+    if (pi1 && pi2) {
+        return unifyTypes(pi1->arg, pi2->arg) && unifyTypes(pi1->res, pi2->res);
+    }
+
+    return type_error("Types doesn't match");
+}
+
+bool PgfTypechecker::Context::unifyTypes(PgfExpr *e)
+{
+    if (exp_type == NULL)
+        return true;
+    return tc->unifyTypes(inf_type,exp_type);
+}
+
+bool PgfTypechecker::type_error(const char *fmt, ...)
+{
+    va_list arg_ptr;
+
+    va_start(arg_ptr, fmt);
+    size_t n_bytes = vsnprintf(NULL, 0, fmt, arg_ptr);
+    va_end(arg_ptr);
+
+    char *buffer = (char*) err->msg;
+
+    va_start(arg_ptr, fmt);
+    buffer = (char*) realloc(buffer, n_bytes+1);
+    if (buffer) {
+        vsnprintf(buffer, n_bytes+1, fmt, arg_ptr);
+        err->type = PGF_EXN_TYPE_ERROR;
+        err->code = 0;
+        err->msg  = buffer;
+    }
+    va_end(arg_ptr);
+
+    return false;
+}
+
+PgfType PgfTypechecker::infer_expr(PgfExpr *pe)
+{
+    Context ctxt(this);
+    *pe = m->match_expr(&ctxt, *pe);
+    if (*pe == 0)
+        return 0;
+    return marshall_type(ctxt.inf_type, u);
+}
+
+PgfExpr PgfTypechecker::check_expr(PgfExpr expr, PgfType type)
+{
+    Unmarshaller2 tu(m);
+    Type *ty = (Type*) m->match_type(&tu, type);
+    Context ctxt(this,ty,PGF_BIND_TYPE_EXPLICIT);
+    expr = m->match_expr(&ctxt, expr);
+    return expr;
+}
+
+PgfType PgfTypechecker::check_type(PgfType type)
+{
+    Context ctxt(this);
+    return m->match_type(&ctxt, type);
 }

src/runtime/c/pgf/typechecker.h

@@ -1,35 +1,108 @@
 #ifndef TYPECHECKER_H
 #define TYPECHECKER_H
 
-class PGF_INTERNAL_DECL PgfTypechecker : public PgfUnmarshaller {
+class PGF_INTERNAL_DECL PgfTypechecker {
     ref<PgfPGF> gr;
-    ref<PgfDTyp> type;
-    size_t n_args;
     PgfMarshaller *m;
     PgfUnmarshaller *u;
+    PgfExn* err;
 
-public:
+    class Unmarshaller1;
-    PgfTypechecker(ref<PgfPGF> gr, PgfMarshaller *m, PgfUnmarshaller *u) {
+    class Unmarshaller2;
-        this->gr = gr;
+
-        this->m  = m;
+    struct Pi;
-        this->u  = u;
+    struct Cat;
+
+    struct Type {
+        virtual Pi  *is_pi()  { return NULL; }
+        virtual Cat *is_cat() { return NULL; }
+        virtual ~Type() {}
     };
 
-    virtual PgfExpr eabs(PgfBindType btype, PgfText *name, PgfExpr body);
+    struct Pi : Type {
-    virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg);
+        PgfBindType bind_type;
-    virtual PgfExpr elit(PgfLiteral lit);
+        Type *arg, *res;
-    virtual PgfExpr emeta(PgfMetaId meta);
+        PgfText var;
-    virtual PgfExpr efun(PgfText *name);
+
-    virtual PgfExpr evar(int index);
+        void *operator new(size_t size, PgfBindType bind_type, PgfText *var, Type *arg, Type *res) {
-    virtual PgfExpr etyped(PgfExpr expr, PgfType typ);
+            Pi *pi = (Pi *) malloc(size+var->size+1);
-    virtual PgfExpr eimplarg(PgfExpr expr);
+            pi->bind_type = bind_type;
-    virtual PgfLiteral lint(size_t size, uintmax_t *v);
+            memcpy(&pi->var, var, sizeof(PgfText)+var->size+1);
-    virtual PgfLiteral lflt(double v);
+            pi->arg = arg;
-    virtual PgfLiteral lstr(PgfText *v);
+            pi->res = res;
-    virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
+            return pi;
-                         PgfText *cat,
+        }
-                         size_t n_exprs, PgfExpr *exprs);
+        virtual Pi *is_pi()  { return this; }
-    virtual void free_ref(object x);
+
+        virtual ~Pi() {
+            delete arg;
+            delete res;
+        }
+    };
+
+    struct Cat : Type {
+        PgfText name;
+
+        void *operator new(size_t size, PgfText *name) {
+            Cat *cat = (Cat *) malloc(size+name->size+1);
+            memcpy(&cat->name, name, sizeof(PgfText)+name->size+1);
+            return cat;
+        }
+        void *operator new(size_t size, const char *name) {
+            size_t len = strlen(name);
+            Cat *cat = (Cat *) malloc(size+len+1);
+            cat->name.size = len;
+            memcpy(&cat->name.text, name, len+1);
+            return cat;
+        }
+        virtual Cat *is_cat() { return this; }
+    };
+
+    PgfType marshall_type(Type *ty, PgfUnmarshaller *u);
+    std::vector<Type*> temps;
+
+    bool unifyTypes(Type *ty1, Type *ty2);
+
+    struct Context : public PgfUnmarshaller {
+        PgfTypechecker *tc;
+
+        PgfBindType bind_type;
+        Type *exp_type;
+        Type *inf_type;
+
+        bool checkImplArgument();
+        bool unifyTypes(PgfExpr *e);
+
+    public:
+        Context(PgfTypechecker *tc, Type *exp_type = NULL, PgfBindType bind_type = PGF_BIND_TYPE_EXPLICIT);
+
+        virtual PgfExpr eabs(PgfBindType btype, PgfText *name, PgfExpr body);
+        virtual PgfExpr eapp(PgfExpr fun, PgfExpr arg);
+        virtual PgfExpr elit(PgfLiteral lit);
+        virtual PgfExpr emeta(PgfMetaId meta);
+        virtual PgfExpr efun(PgfText *name);
+        virtual PgfExpr evar(int index);
+        virtual PgfExpr etyped(PgfExpr expr, PgfType typ);
+        virtual PgfExpr eimplarg(PgfExpr expr);
+        virtual PgfLiteral lint(size_t size, uintmax_t *v);
+        virtual PgfLiteral lflt(double v);
+        virtual PgfLiteral lstr(PgfText *v);
+        virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
+                             PgfText *cat,
+                             size_t n_exprs, PgfExpr *exprs);
+        virtual void free_ref(object x);
+    };
+
+    PgfDBMarshaller db_m;
+    bool type_error(const char *fmt, ...) __attribute__ ((format (printf, 2, 3)));
+
+public:
+    PgfTypechecker(ref<PgfPGF> gr, PgfMarshaller *m, PgfUnmarshaller *u, PgfExn* err);
+    ~PgfTypechecker();
+    
+    PgfExpr check_expr(PgfExpr expr, PgfType type);
+    PgfType infer_expr(PgfExpr *pe);
+    PgfType check_type(PgfType type);
 };
 
 #endif

src/runtime/haskell/PGF2.hsc

@@ -481,7 +481,37 @@ exprProbability p e =
     withPgfExn "exprProbability" (pgf_expr_prob (a_db p) c_revision c_e marshaller)
 
 checkExpr :: PGF -> Expr -> Type -> Either String Expr
-checkExpr = error "TODO: checkExpr"
+checkExpr p e ty =
+  unsafePerformIO $
+  withForeignPtr (a_revision p) $ \c_revision ->
+  bracket (newStablePtr e) freeStablePtr $ \c_e ->
+  bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
+  allocaBytes (#size PgfExn) $ \c_exn -> do
+    c_e <- pgf_check_expr (a_db p) c_revision c_e c_ty marshaller unmarshaller c_exn
+    ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
+    case ex_type of
+      (#const PGF_EXN_NONE) -> do
+         e  <- deRefStablePtr c_e
+         freeStablePtr c_e
+         return (Right e)
+      (#const PGF_EXN_SYSTEM_ERROR) -> do
+         errno <- (#peek PgfExn, code) c_exn
+         c_msg <- (#peek PgfExn, msg) c_exn
+         mb_fpath <- if c_msg == nullPtr
+                       then return Nothing
+                       else fmap Just (peekCString c_msg)
+         ioError (errnoToIOError "checkExpr" (Errno errno) Nothing mb_fpath)
+      (#const PGF_EXN_PGF_ERROR) -> do
+         c_msg <- (#peek PgfExn, msg) c_exn
+         msg <- peekCString c_msg
+         free c_msg
+         throwIO (PGFError "checkExpr" msg)
+      (#const PGF_EXN_TYPE_ERROR) -> do
+         c_msg <- (#peek PgfExn, msg) c_exn
+         msg <- peekCString c_msg
+         free c_msg
+         return (Left msg)
+      _ -> throwIO (PGFError "checkExpr" "An unidentified error occurred")
 
 -- | Tries to infer the type of an expression. Note that
 -- even if the expression is type correct it is not always
@@ -513,6 +543,11 @@ inferExpr p e =
                        else fmap Just (peekCString c_msg)
          ioError (errnoToIOError "inferExpr" (Errno errno) Nothing mb_fpath)
       (#const PGF_EXN_PGF_ERROR) -> do
+         c_msg <- (#peek PgfExn, msg) c_exn
+         msg <- peekCString c_msg
+         free c_msg
+         throwIO (PGFError "inferExpr" msg)
+      (#const PGF_EXN_TYPE_ERROR) -> do
          c_msg <- (#peek PgfExn, msg) c_exn
          msg <- peekCString c_msg
          free c_msg
@@ -522,7 +557,36 @@ inferExpr p e =
 -- | Check whether a type is consistent with the abstract
 -- syntax of the grammar.
 checkType :: PGF -> Type -> Either String Type
-checkType pgf ty = Right ty
+checkType p ty =
+  unsafePerformIO $
+  withForeignPtr (a_revision p) $ \c_revision ->
+  bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
+  allocaBytes (#size PgfExn) $ \c_exn -> do
+    c_ty <- pgf_check_type (a_db p) c_revision c_ty marshaller unmarshaller c_exn
+    ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
+    case ex_type of
+      (#const PGF_EXN_NONE) -> do
+         ty <- deRefStablePtr c_ty
+         freeStablePtr c_ty
+         return (Right ty)
+      (#const PGF_EXN_SYSTEM_ERROR) -> do
+         errno <- (#peek PgfExn, code) c_exn
+         c_msg <- (#peek PgfExn, msg) c_exn
+         mb_fpath <- if c_msg == nullPtr
+                       then return Nothing
+                       else fmap Just (peekCString c_msg)
+         ioError (errnoToIOError "checkType" (Errno errno) Nothing mb_fpath)
+      (#const PGF_EXN_PGF_ERROR) -> do
+         c_msg <- (#peek PgfExn, msg) c_exn
+         msg <- peekCString c_msg
+         free c_msg
+         throwIO (PGFError "checkType" msg)
+      (#const PGF_EXN_TYPE_ERROR) -> do
+         c_msg <- (#peek PgfExn, msg) c_exn
+         msg <- peekCString c_msg
+         free c_msg
+         return (Left msg)
+      _ -> throwIO (PGFError "checkType" "An unidentified error occurred")
 
 -- | Check whether a context is consistent with the abstract
 -- syntax of the grammar.

src/runtime/haskell/PGF2/FFI.hsc

@@ -203,11 +203,11 @@ foreign import ccall pgf_concrete_language_code :: Ptr PgfDB -> Ptr Concr -> Ptr
 
 foreign import ccall pgf_expr_prob :: Ptr PgfDB -> Ptr PGF -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfExn -> IO (#type prob_t)
 
-foreign import ccall pgf_check_expr :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Expr) -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_check_expr :: Ptr PgfDB -> Ptr PGF -> StablePtr Expr -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr)
 
 foreign import ccall pgf_infer_expr :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Expr) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
 
-foreign import ccall pgf_check_type :: Ptr PgfDB -> Ptr PGF -> Ptr (StablePtr Type) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_check_type :: Ptr PgfDB -> Ptr PGF -> StablePtr Type -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
 
 foreign import ccall pgf_generate_random :: Ptr PgfDB -> Ptr PGF -> Ptr (Ptr Concr) -> CSize -> StablePtr Type -> CSize -> Ptr Word64 -> Ptr (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Expr)
 

src/runtime/haskell/pgf2.cabal

@@ -73,3 +73,13 @@ test-suite linearization
     HUnit >= 1.6.1.0,
     containers,
     pgf2
+
+test-suite typechecking
+  type: exitcode-stdio-1.0
+  main-is: tests/typechecking.hs
+  default-language: Haskell2010
+  build-depends:
+    base,
+    HUnit >= 1.6.1.0,
+    containers,
+    pgf2

src/runtime/haskell/tests/basic.gf

@@ -11,6 +11,8 @@ cat P N ;
 fun nat : (x : N) -> P x ;
 fun ind : P z -> ((x:N) -> P x -> P (s x)) -> ((x : N) -> P x) ;
 
+fun imp : ({x},y : N) -> S ;
+
 fun intLit    : Int -> S;
 fun stringLit : String -> S;
 fun floatLit  : Float -> S;

src/runtime/haskell/tests/basic.hs

@@ -15,9 +15,9 @@ main = do
     grammarTests gr =
       [TestCase (assertEqual "abstract names" "basic" (abstractName gr))
       ,TestCase (assertEqual "abstract categories" ["Float","Int","N","P","S","String"] (categories gr))
-      ,TestCase (assertEqual "abstract functions" ["c","floatLit","ind","intLit","nat","s","stringLit","z"] (functions gr))
+      ,TestCase (assertEqual "abstract functions" ["c","floatLit","imp","ind","intLit","nat","s","stringLit","z"] (functions gr))
       ,TestCase (assertEqual "abstract functions by cat 1" ["s","z"] (functionsByCat gr "N"))
-      ,TestCase (assertEqual "abstract functions by cat 2" ["c","floatLit","intLit","stringLit"] (functionsByCat gr "S"))
+      ,TestCase (assertEqual "abstract functions by cat 2" ["c","floatLit","imp","intLit","stringLit"] (functionsByCat gr "S"))
       ,TestCase (assertEqual "abstract functions by cat 2" [] (functionsByCat gr "X")) -- no such category
       ,TestCase (assertBool  "type of z" (eqJust (readType "N")    (functionType gr "z")))
       ,TestCase (assertBool  "type of s" (eqJust (readType "N->N") (functionType gr "s")))

src/runtime/haskell/tests/basic.pmcfg

@@ -5,13 +5,14 @@ abstract basic {
   cat P N ; -- 0.693147
   cat S ; -- 0.693147
   cat String ; -- 0.693147
-  data c : N -> S ; -- 1.38629
+  data c : N -> S ; -- 1.60944
-  fun floatLit : Float -> S ; -- 1.38629
+  fun floatLit : Float -> S ; -- 1.60944
+  fun imp : ({x} : N) -> (y : N) -> S ; -- 1.60944
   fun ind : P z -> ((x : N) -> P x -> P (s x)) -> (x : N) -> P x ; -- 0.693147
-  fun intLit : Int -> S ; -- 1.38629
+  fun intLit : Int -> S ; -- 1.60944
   fun nat : (x : N) -> P x ; -- 0.693147
   data s : N -> N ; -- 0.693147
-  fun stringLit : String -> S ; -- 1.38629
+  fun stringLit : String -> S ; -- 1.60944
   data z : N ; -- 0.693147
 }
 concrete basic_cnc {

src/runtime/haskell/tests/transactions.hs

@@ -41,11 +41,11 @@ main = do
 
   c <- runTestTT $
     TestList $
-      [TestCase (assertEqual "original functions" ["c","floatLit","ind","intLit","nat","s","stringLit","z"] (functions gr1))
+      [TestCase (assertEqual "original functions" ["c","floatLit","imp","ind","intLit","nat","s","stringLit","z"] (functions gr1))
       ,TestCase (assertEqual "existing function" (Left (PGFError "modifyPGF" "A function with that name already exists")) excpt1)
       ,TestCase (assertEqual "existing category" (Left (PGFError "modifyPGF" "A category with that name already exists")) excpt2)
-      ,TestCase (assertEqual "extended functions" ["c","floatLit","foo","ind","intLit","nat","s","stringLit","z"] (functions gr2))
+      ,TestCase (assertEqual "extended functions" ["c","floatLit","foo","imp","ind","intLit","nat","s","stringLit","z"] (functions gr2))
-      ,TestCase (assertEqual "checked-out extended functions" ["c","floatLit","foo","ind","intLit","nat","s","stringLit","z"] (functions gr4))
+      ,TestCase (assertEqual "checked-out extended functions" ["c","floatLit","foo","imp","ind","intLit","nat","s","stringLit","z"] (functions gr4))
       ,TestCase (assertEqual "original categories" ["Float","Int","N","P","S","String"] (categories gr1))
       ,TestCase (assertEqual "extended categories" ["Float","Int","N","P","Q","S","String"] (categories gr2))
       ,TestCase (assertEqual "Q context" (Just [(Explicit,"x",ty)]) (categoryContext gr2 "Q"))

src/runtime/haskell/tests/typechecking.hs

@@ -0,0 +1,73 @@
+import Test.HUnit
+import Test.HUnit.Text
+import PGF2
+
+main = do
+  gr <- readPGF "tests/basic.pgf"
+  runTestTTAndExit $
+    TestList $
+      [TestCase (assertInference "infer fun" gr (Right "N") "z")
+      ,TestCase (assertInference "infer app" gr (Right "N") "s z")
+      ,TestCase (assertInference "infer n-args 1" gr (Left "Too many arguments") "z z")
+      ,TestCase (assertInference "infer n-args 2" gr (Left "Too many arguments") "s z z")
+      ,TestCase (assertInference "infer implarg 1" gr (Left "Unexpected implicit argument") "s {z}")
+      ,TestCase (assertInference "infer implarg 2" gr (Right "(y : N) -> S") "imp {z}")  --
+      ,TestCase (assertInference "infer implarg 3" gr (Right "S") "imp {z} z")
+      ,TestCase (assertInference "infer implarg 4" gr (Right "({x},y : N) -> S") "imp")
+      ,TestCase (assertInference' "infer implarg 4" gr (Right ("imp {?} z","S")) "imp z")
+      ,TestCase (assertInference "infer typed 1" gr (Right "N->N") "<s : N->N>")
+      ,TestCase (assertInference "infer typed 2" gr (Left "Types doesn't match") "<s : N>")
+      ,TestCase (assertInference "infer typed 3" gr (Left "Too many arguments to category N - 0 expected but 1 given") "<s : N z>")
+      ,TestCase (assertInference "infer hoas 1" gr (Left "Types doesn't match") "s s")
+      ,TestCase (assertInference "infer literal 1" gr (Right "Int") "0")
+      ,TestCase (assertInference "infer literal 2" gr (Right "Float") "3.14")
+      ,TestCase (assertInference "infer literal 3" gr (Right "String") "\"abc\"")
+      ,TestCase (assertInference "infer meta 1" gr (Left "Cannot infer the type of a meta variable") "?")
+      ,TestCase (assertInference "infer meta 2" gr (Right "N->N") "<? : N->N>")
+      ,TestCase (assertChecking "check fun" gr (Right "s") "s" "N->N")
+      ,TestCase (assertChecking "check fun" gr (Right "s z") "s z" "N")
+      ,TestCase (assertChecking "check fun" gr (Left "Types doesn't match") "s z" "N->N")
+      ,TestCase (assertType "check type 1" gr (Right "N -> N") "N -> N")
+      ,TestCase (assertType "check type 2" gr (Left "Category s is not defined") "s")
+      ,TestCase (assertType "check type 3" gr (Left "Too many arguments to category N - 0 expected but 1 given") "N z")
+      ,TestCase (assertType "check type 4" gr (Left "Too few arguments to category P - 1 expected but 0 given") "P")
+      ,TestCase (assertType "check type 5" gr (Right "P z") "P z")
+      ,TestCase (assertType "check type 6" gr (Left "Types doesn't match") "P s")
+      ,TestCase (assertType "check type 7" gr (Left "Unexpected implicit argument") "P {z}")
+      ]
+
+assertInference name gr (Left msg) e =
+  case readExpr e of
+    Just e -> assertEqual name (Left msg) (inferExpr gr e)
+    _       -> error "Reading the expression failed"
+assertInference name gr (Right ty) e =
+  case (readType ty, readExpr e) of
+    (Just ty,Just e) -> assertEqual name (Right (e,ty)) (inferExpr gr e)
+    _                -> error "Reading the type/expression failed"
+
+assertInference' name gr (Left msg) e =
+  case readExpr e of
+    Just e -> assertEqual name (Left msg) (inferExpr gr e)
+    _       -> error "Reading the expression failed"
+assertInference' name gr (Right (e1,ty)) e0 =
+  case (readExpr e1, readType ty, readExpr e0) of
+    (Just e1,Just ty,Just e0) -> assertEqual name (Right (e1,ty)) (inferExpr gr e0)
+    _                         -> error "Reading the type/expression failed"
+
+assertChecking name gr (Left msg) e ty =
+  case (readExpr e, readType ty) of
+    (Just e,Just ty) -> assertEqual name (Left msg) (checkExpr gr e ty)
+    _                -> error "Reading the expression failed"
+assertChecking name gr (Right e1) e ty =
+  case (readExpr e1, readExpr e, readType ty) of
+    (Just e1,Just e,Just ty) -> assertEqual name (Right e1) (checkExpr gr e ty)
+    _                        -> error "Reading the type/expression failed"
+
+assertType name gr (Left msg) ty =
+  case readType ty of
+    Just ty -> assertEqual name (Left msg) (checkType gr ty)
+    _       -> error "Reading the type failed"
+assertType name gr (Right ty) ty0 =
+  case (readType ty, readType ty0) of
+    (Just ty,Just ty0) -> assertEqual name (Right ty) (checkType gr ty0)
+    _                  -> error "Reading the type failed"