added support for branches and explicit transaction commit

src/runtime/c/pgf/data.h

@@ -54,6 +54,8 @@ private:
     const char *m_filepath;
 };
 
+class PgfPGF;
+
 #include "db.h"
 #include "text.h"
 #include "vector.h"
@@ -137,12 +139,23 @@ typedef struct {
     Namespace<PgfAbsCat> cats;
 } PgfAbstr;
 
-typedef struct PGF_INTERNAL_DECL {
+struct PGF_INTERNAL_DECL PgfPGF {
 	uint16_t major_version;
 	uint16_t minor_version;
 	Namespace<PgfFlag> gflags;
 	PgfAbstr abstract;
 	//PgfConcrs* concretes;
-} PgfPGF;
+
+    // If the revision is transient, then it is in a double-linked list
+    // with all other transient revisions.
+    ref<PgfPGF> prev, next;
+
+    // The name lets the user to find a particular revision in
+    // the database.
+    PgfText name;
+};
+
+extern PGF_INTERNAL_DECL
+PgfText master;
 
 #endif

src/runtime/c/pgf/db.cxx

@@ -250,7 +250,7 @@ typedef struct mchunk mbin;
  */
 #define FASTBIN_CONSOLIDATION_THRESHOLD  (65536UL)
 
-struct malloc_state
+struct PGF_INTERNAL_DECL malloc_state
 {
     /* Set if the fastbin chunks contain recently inserted free blocks.  */
     bool have_fastchunks;
@@ -264,8 +264,14 @@ struct malloc_state
     object bins[NBINS * 2 - 2];
     /* Bitmap of bins */
     unsigned int binmap[BINMAPSIZE];
-    /* Reference to the root object */
+
-    object root_offset;
+    /* The namespace of all persistant grammar revisions */
+    Namespace<PgfPGF> revisions;
+
+    /* A reference to the first transient revision in
+     * a double-linked list.
+     */
+    ref<PgfPGF> transient_revisions;
 };
 
 PGF_INTERNAL
@@ -346,15 +352,17 @@ void PgfDB::sync()
 }
 
 PGF_INTERNAL
-object PgfDB::get_root_internal()
+ref<PgfPGF> PgfDB::get_revision(PgfText *name)
 {
-    return ms->root_offset;
+    return namespace_lookup(current_db->ms->revisions, name);
 }
 
 PGF_INTERNAL
-void PgfDB::set_root_internal(object root_offset)
+void PgfDB::set_revision(ref<PgfPGF> pgf)
 {
-    ms->root_offset = root_offset;
+    Namespace<PgfPGF> nmsp = namespace_insert(current_db->ms->revisions, pgf);
+    namespace_release(current_db->ms->revisions);
+    current_db->ms->revisions = nmsp;
 }
 
 PGF_INTERNAL
@@ -383,7 +391,8 @@ void PgfDB::init_state(size_t size)
 
     memset(ms->binmap, 0, sizeof(ms->binmap));
 
-    ms->root_offset = 0;
+    ms->revisions = 0;
+    ms->transient_revisions = 0;
 }
 
 /* Take a chunk off a bin list.  */
@@ -958,12 +967,41 @@ void PgfDB::free_internal(object o)
     }
 }
 
-bool PgfDB::is_valid_object(object o, size_t bytes)
+PGF_INTERNAL
+ref<PgfPGF> PgfDB::revision2pgf(PgfRevision revision)
 {
-    if (o <= sizeof(*ms) || o >= ms->top)
+    if (revision <= sizeof(*current_db->ms) || revision >= current_db->ms->top)
-        return false;
+        throw pgf_error("Invalid revision");
-    mchunk *chunk = mem2chunk(ptr(ms,o));
+
-    return (chunksize(chunk) == request2size(bytes));
+    mchunk *chunk = mem2chunk(ptr(current_db->ms,revision));
+    if (chunksize(chunk) < sizeof(PgfPGF))
+        throw pgf_error("Invalid revision");
+
+    ref<PgfPGF> pgf = revision;
+    if (chunksize(chunk) != request2size(sizeof(PgfPGF)+pgf->name.size+1))
+        throw pgf_error("Invalid revision");
+
+    return pgf;
+}
+
+PGF_INTERNAL
+void PgfDB::link_transient_revision(ref<PgfPGF> pgf)
+{
+    pgf->next = current_db->ms->transient_revisions;
+    if (current_db->ms->transient_revisions == 0)
+        current_db->ms->transient_revisions->prev = pgf;
+    current_db->ms->transient_revisions = pgf;
+}
+
+PGF_INTERNAL
+void PgfDB::unlink_transient_revision(ref<PgfPGF> pgf)
+{
+    if (pgf->next != 0)
+        pgf->next->prev = pgf->prev;
+    if (pgf->prev != 0)
+        pgf->prev->next = pgf->next;
+    else
+        current_db->ms->transient_revisions = pgf->next;
 }
 
 DB_scope::DB_scope(PgfDB *db, DB_scope_mode tp)

src/runtime/c/pgf/db.h

@@ -83,23 +83,11 @@ public:
         return current_db->free_internal(o.as_object());
     }
 
-    template<class A>
+    static PGF_INTERNAL_DECL ref<PgfPGF> get_revision(PgfText *name);
-    static ref<A> get_root() {
+    static PGF_INTERNAL_DECL void set_revision(ref<PgfPGF> pgf);
-        return current_db->get_root_internal();
+    static PGF_INTERNAL_DECL ref<PgfPGF> revision2pgf(PgfRevision revision);
-    }
+    static PGF_INTERNAL_DECL void link_transient_revision(ref<PgfPGF> pgf);
-
+    static PGF_INTERNAL_DECL void unlink_transient_revision(ref<PgfPGF> pgf);
-    template<class A>
-    static void set_root(ref<A> root) {
-        current_db->set_root_internal(root.offset);
-    }
-
-    template<class A>
-    static ref<A> safe_object2ref(object o) {
-        if (!current_db->is_valid_object(o, sizeof(A)))
-            throw pgf_error("Invalid database object");
-        return o;
-    }
-
 
     PGF_INTERNAL_DECL static void sync();
 
@@ -112,8 +100,6 @@ private:
     PGF_INTERNAL_DECL object get_root_internal();
     PGF_INTERNAL_DECL void set_root_internal(object root_offset);
 
-    PGF_INTERNAL_DECL bool is_valid_object(object o, size_t bytes);
-
     PGF_INTERNAL_DECL unsigned char* relocate(unsigned char* ptr);
 
     friend class DB_scope;

src/runtime/c/pgf/pgf.cxx

@@ -27,6 +27,9 @@ pgf_exn_clear(PgfExn* err)
         err->msg  = strdup(e.what()); \
     }
 
+PGF_INTERNAL
+PgfText master = {size: 6, text: {'m','a','s','t','e','r','0'}};
+
 PGF_API
 PgfDB *pgf_read_pgf(const char* fpath,
                     PgfRevision *revision,
@@ -47,7 +50,7 @@ PgfDB *pgf_read_pgf(const char* fpath,
             PgfReader rdr(&in, fpath);
             ref<PgfPGF> pgf = rdr.read_pgf();
 
-            PgfDB::set_root(pgf);
+            PgfDB::set_revision(pgf);
             *revision = pgf.as_object();
         }
 
@@ -82,7 +85,7 @@ PgfDB *pgf_boot_ngf(const char* pgf_path, const char* ngf_path,
             PgfReader rdr(&in, pgf_path);
             ref<PgfPGF> pgf = rdr.read_pgf();
 
-            db->set_root<PgfPGF>(pgf);
+            PgfDB::set_revision(pgf);
             *revision = pgf.as_object();
 
             PgfDB::sync();
@@ -113,9 +116,9 @@ PgfDB *pgf_read_ngf(const char *fpath,
         {
             DB_scope scope(db, WRITER_SCOPE);
 
-            if (PgfDB::get_root<PgfPGF>() == 0) {
+            if (PgfDB::get_revision(&master) == 0) {
                 is_new = true;
-                ref<PgfPGF> pgf = PgfDB::malloc<PgfPGF>();
+                ref<PgfPGF> pgf = PgfDB::malloc<PgfPGF>(sizeof(PgfPGF)+master.size+1);
                 pgf->major_version = 2;
                 pgf->minor_version = 0;
                 pgf->gflags = 0;
@@ -124,10 +127,13 @@ PgfDB *pgf_read_ngf(const char *fpath,
                 pgf->abstract.aflags = 0;
                 pgf->abstract.funs = 0;
                 pgf->abstract.cats = 0;
-                PgfDB::set_root<PgfPGF>(pgf);
+                pgf->prev = 0;
+                pgf->next = 0;
+                memcpy(&pgf->name, &master, sizeof(PgfText)+master.size+1);
+                PgfDB::set_revision(pgf);
                 *revision = pgf.as_object();
             } else {
-                *revision = PgfDB::get_root<PgfPGF>().as_object();
+                *revision = PgfDB::get_revision(&master).as_object();
             }
         }
 
@@ -160,7 +166,7 @@ PgfText *pgf_abstract_name(PgfDB *db, PgfRevision revision,
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
 
         return textdup(&(*pgf->abstract.name));
     } PGF_API_END
@@ -174,7 +180,7 @@ void pgf_iter_categories(PgfDB *db, PgfRevision revision,
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
     
         namespace_iter(pgf->abstract.cats, itor, err);
     } PGF_API_END
@@ -187,7 +193,7 @@ PgfType pgf_start_cat(PgfDB *db, PgfRevision revision,
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
 
         PgfText *startcat = (PgfText *)
             alloca(sizeof(PgfText)+9);
@@ -228,7 +234,7 @@ PgfTypeHypo *pgf_category_context(PgfDB *db, PgfRevision revision,
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
 
         ref<PgfAbsCat> abscat =
             namespace_lookup(pgf->abstract.cats, catname);
@@ -262,7 +268,7 @@ prob_t pgf_category_prob(PgfDB *db, PgfRevision revision,
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
 
         ref<PgfAbsCat> abscat =
             namespace_lookup(pgf->abstract.cats, catname);
@@ -282,7 +288,7 @@ void pgf_iter_functions(PgfDB *db, PgfRevision revision,
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
 
         pgf_exn_clear(err);
         namespace_iter(pgf->abstract.funs, itor, err);
@@ -311,7 +317,7 @@ void pgf_iter_functions_by_cat(PgfDB *db, PgfRevision revision,
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
 
         PgfItorHelper helper;
         helper.fn   = iter_by_cat_helper;
@@ -329,7 +335,7 @@ PgfType pgf_function_type(PgfDB *db, PgfRevision revision,
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
 
         ref<PgfAbsFun> absfun =
             namespace_lookup(pgf->abstract.funs, funname);
@@ -349,7 +355,7 @@ int pgf_function_is_constructor(PgfDB *db, PgfRevision revision,
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
 
         ref<PgfAbsFun> absfun =
             namespace_lookup(pgf->abstract.funs, funname);
@@ -369,7 +375,7 @@ prob_t pgf_function_prob(PgfDB *db, PgfRevision revision,
 {
     PGF_API_BEGIN {
         DB_scope scope(db, READER_SCOPE);
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
 
         ref<PgfAbsFun> absfun =
             namespace_lookup(pgf->abstract.funs, funname);
@@ -426,18 +432,20 @@ PgfType pgf_read_type(PgfText *input, PgfUnmarshaller *u)
     return res;
 }
 
-PGF_API_DECL
+PGF_API
 PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision,
+                               PgfText *name,
                                PgfExn *err)
 {
-    DB_scope scope(db, WRITER_SCOPE);
+    PGF_API_BEGIN {
+        DB_scope scope(db, WRITER_SCOPE);
 
-    pgf_exn_clear(err);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
 
-    try {
+        size_t name_size =
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+            (name == NULL) ? pgf->name.size : name->size;
 
-        ref<PgfPGF> new_pgf = PgfDB::malloc<PgfPGF>();
+        ref<PgfPGF> new_pgf = PgfDB::malloc<PgfPGF>(sizeof(PgfPGF)+name_size+1);
         new_pgf->major_version = pgf->major_version;
         new_pgf->minor_version = pgf->minor_version;
 
@@ -461,15 +469,44 @@ PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision,
         if (pgf->abstract.cats != 0)
             pgf->abstract.cats->ref_count++;
 
+        new_pgf->prev = 0;
+        new_pgf->next = 0;
+        PgfDB::link_transient_revision(new_pgf);
+
+        memcpy(&new_pgf->name, ((name == NULL) ? &pgf->name : name),
+                   sizeof(PgfText)+name_size+1);
+
         return new_pgf.as_object();
-    } catch (pgf_systemerror& e) {
+    } PGF_API_END
-        err->type = PGF_EXN_SYSTEM_ERROR;
+
-        err->code = e.code();
+    return 0;
-        err->msg  = e.filepath();
+}
-    } catch (pgf_error& e) {
+
-        err->type = PGF_EXN_PGF_ERROR;
+PGF_API
-        err->msg  = strdup(e.what());
+void pgf_commit_revision(PgfDB *db, PgfRevision revision,
-    }
+                         PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, WRITER_SCOPE);
+
+        ref<PgfPGF> new_pgf = PgfDB::revision2pgf(revision);
+        ref<PgfPGF> old_pgf = PgfDB::get_revision(&new_pgf->name);
+
+        PgfDB::unlink_transient_revision(new_pgf);
+        PgfDB::set_revision(new_pgf);
+
+        PgfDB::link_transient_revision(old_pgf);
+    } PGF_API_END
+}
+
+PGF_API
+PgfRevision pgf_checkout_revision(PgfDB *db, PgfText *name,
+                                  PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, WRITER_SCOPE);
+        return PgfDB::get_revision(name).as_object();
+    } PGF_API_END
 
     return 0;
 }
@@ -481,14 +518,12 @@ void pgf_create_function(PgfDB *db, PgfRevision revision,
                          PgfMarshaller *m,
                          PgfExn *err)
 {
-    DB_scope scope(db, WRITER_SCOPE);
+    PGF_API_BEGIN {
+        DB_scope scope(db, WRITER_SCOPE);
 
-    pgf_exn_clear(err);
-
-    try {
         PgfDBUnmarshaller u(m);
 
-        ref<PgfPGF> pgf = PgfDB::safe_object2ref<PgfPGF>(revision);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
         ref<PgfAbsFun> absfun = PgfDB::malloc<PgfAbsFun>(sizeof(PgfAbsFun)+name->size+1);
         absfun->type  = m->match_type(&u, ty);
         absfun->arity = 0;
@@ -503,12 +538,5 @@ void pgf_create_function(PgfDB *db, PgfRevision revision,
             namespace_insert(pgf->abstract.funs, absfun);
         namespace_release(pgf->abstract.funs);
         pgf->abstract.funs = nmsp;
-    } catch (pgf_systemerror& e) {
+    } PGF_API_END
-        err->type = PGF_EXN_SYSTEM_ERROR;
-        err->code = e.code();
-        err->msg  = e.filepath();
-    } catch (pgf_error& e) {
-        err->type = PGF_EXN_PGF_ERROR;
-        err->msg  = strdup(e.what());
-    }
 }

src/runtime/c/pgf/pgf.h

@@ -318,8 +318,17 @@ PgfType pgf_read_type(PgfText *input, PgfUnmarshaller *u);
 
 PGF_API_DECL
 PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision,
+                               PgfText *name,
                                PgfExn *err);
 
+PGF_API
+void pgf_commit_revision(PgfDB *db, PgfRevision revision,
+                         PgfExn *err);
+
+PGF_API_DECL
+PgfRevision pgf_checkout_revision(PgfDB *db, PgfText *name,
+                                  PgfExn *err);
+
 PGF_API_DECL
 void pgf_create_function(PgfDB *db, PgfRevision revision,
                          PgfText *name,

src/runtime/c/pgf/reader.cxx

@@ -428,7 +428,7 @@ void PgfReader::read_abstract(ref<PgfAbstr> abstract)
 
 ref<PgfPGF> PgfReader::read_pgf()
 {
-    ref<PgfPGF> pgf = PgfDB::malloc<PgfPGF>();
+    ref<PgfPGF> pgf = PgfDB::malloc<PgfPGF>(sizeof(PgfPGF)+master.size+1);
 
     pgf->major_version = read_u16be();
     pgf->minor_version = read_u16be();
@@ -437,5 +437,10 @@ ref<PgfPGF> PgfReader::read_pgf()
 
     read_abstract(ref<PgfAbstr>::from_ptr(&pgf->abstract));
 
+    pgf->prev = 0;
+    pgf->next = 0;
+
+    memcpy(&pgf->name, &master, sizeof(PgfText)+master.size+1);
+
     return pgf;
 }

src/runtime/haskell/PGF2/FFI.hsc

@@ -108,11 +108,13 @@ foreign import ccall "pgf_function_is_constructor"
 foreign import ccall "pgf_function_prob"
    pgf_function_prob :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
 
-foreign import ccall "pgf_clone_revision"
+foreign import ccall pgf_clone_revision :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PgfRevision)
-   pgf_clone_revision :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO (Ptr PgfRevision)
 
-foreign import ccall "pgf_create_function"
+foreign import ccall pgf_commit_revision :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO ()
-   pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Type -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
+
+foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PgfRevision)
+
+foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Type -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
 
 
 -----------------------------------------------------------------------
@@ -198,7 +200,7 @@ withPgfExn f =
     res <- f c_exn
     ex_type <- (#peek PgfExn, type) c_exn :: IO (#type PgfExnType)
     case ex_type of
-      (#const PGF_EXN_NONE)         -> return res
+      (#const PGF_EXN_NONE) -> return res
       (#const PGF_EXN_SYSTEM_ERROR) -> do
          errno <- (#peek PgfExn, code) c_exn
          c_msg <- (#peek PgfExn, msg) c_exn

src/runtime/haskell/PGF2/Transactions.hsc

@@ -1,6 +1,8 @@
 module PGF2.Transactions
           ( Transaction
           , modifyPGF
+          , branchPGF
+          , checkoutPGF
           , createFunction
           ) where
 
@@ -10,7 +12,7 @@ import PGF2.Expr
 import Foreign
 import Foreign.C
 import qualified Foreign.Concurrent as C
-import Control.Exception(bracket)
+import Control.Exception
 
 #include <pgf/pgf.h>
 
@@ -38,19 +40,70 @@ instance Monad Transaction where
              Transaction g -> g c_db c_revision c_exn
       else return undefined
 
+{- | @modifyPGF gr t@ updates the grammar @gr@ by performing the
+   transaction @t@. The changes are applied to the new grammar
+   returned by the function, while any further operations with @gr@
+   will still work with the old grammar. The newly created grammar
+   also replaces the corresponding branch. In the example:
+   
+   > do gr <- readPGF "my_grammar.pgf"
+   >    Just ty = readType "S"
+   >    gr1 <- modifyPGF gr (createFunction "foo" ty)
+   >    gr2 <- checkoutPGF gr "master"
+   >    print (functionType gr2 "foo")
+
+   both @gr1@ and @gr2@ will refer to the new grammar which contains
+   the new function @foo@.
+-}
 modifyPGF :: PGF -> Transaction a -> IO PGF
-modifyPGF p (Transaction f) =
+modifyPGF = branchPGF_ nullPtr
+
+{- | @branchPGF gr branch_name t@ is similar to @modifyPGF gr t@,
+   except that it stores the result as a branch with the given name.
+-}
+branchPGF :: PGF -> String -> Transaction a -> IO PGF
+branchPGF p name t =
+  withText name $ \c_name ->
+    branchPGF_ c_name p t
+
+branchPGF_ :: Ptr PgfText -> PGF -> Transaction a -> IO PGF
+branchPGF_ c_name p (Transaction f) =
   withForeignPtr (a_db p) $ \c_db ->
   withForeignPtr (revision p) $ \c_revision ->
-  withPgfExn $ \c_exn -> do
+  withPgfExn $ \c_exn ->
-    c_revision <- pgf_clone_revision c_db c_revision c_exn
+  mask $ \restore -> do
+    c_revision <- pgf_clone_revision c_db c_revision c_name c_exn
     ex_type <- (#peek PgfExn, type) c_exn
     if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
-      then do f c_db c_revision c_exn
+      then do ((restore (f c_db c_revision c_exn))
-              fptr2 <- C.newForeignPtr c_revision (withForeignPtr (a_db p) (\c_db -> pgf_free_revision c_db c_revision))
+               `catch`
-              return (PGF (a_db p) fptr2 (langs p))
+               (\e -> do
+                    pgf_free_revision c_db c_revision
+                    throwIO (e :: SomeException)))
+              ex_type <- (#peek PgfExn, type) c_exn
+              if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
+                then do pgf_commit_revision c_db c_revision c_exn
+                        ex_type <- (#peek PgfExn, type) c_exn
+                        if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
+                          then do fptr2 <- C.newForeignPtr c_revision (withForeignPtr (a_db p) (\c_db -> pgf_free_revision c_db c_revision))
+                                  return (PGF (a_db p) fptr2 (langs p))
+                          else do pgf_free_revision c_db c_revision
+                                  return p
+                else do pgf_free_revision c_db c_revision
+                        return p
       else return p
 
+{- | Retrieves the branch with the given name -}
+checkoutPGF :: PGF -> String -> IO (Maybe PGF)
+checkoutPGF p name =
+  withForeignPtr (a_db p) $ \c_db ->
+  withText name $ \c_name -> do
+    c_revision <- withPgfExn (pgf_checkout_revision c_db c_name)
+    if c_revision == nullPtr
+      then return Nothing
+      else do fptr2 <- C.newForeignPtr c_revision (withForeignPtr (a_db p) (\c_db -> pgf_free_revision c_db c_revision))
+              return (Just (PGF (a_db p) fptr2 (langs p)))
+
 createFunction :: Fun -> Type -> Float -> Transaction ()
 createFunction name ty prob = Transaction $ \c_db c_revision c_exn ->
   withText name $ \c_name ->

src/runtime/haskell/tests/transactions.hs

@@ -5,12 +5,20 @@ import PGF2.Transactions
 main = do
   gr1 <- readPGF "tests/basic.pgf"
   let Just ty = readType "(N -> N) -> P (s z)"
-  gr2 <- modifyPGF gr1 (createFunction "foo" ty pi)
+
+  gr2 <- modifyPGF gr1              (createFunction "foo" ty pi)
+  gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty pi)
+
+  Just gr4 <- checkoutPGF gr1 "master"
+  Just gr5 <- checkoutPGF gr1 "bar_branch"
 
   runTestTTAndExit $
     TestList $
       [TestCase (assertEqual "original functions" ["c","ind","s","z"] (functions gr1))
       ,TestCase (assertEqual "extended functions" ["c","foo","ind","s","z"] (functions gr2))
+      ,TestCase (assertEqual "branched functions" ["bar","c","ind","s","z"] (functions gr3))
+      ,TestCase (assertEqual "checked-out extended functions" ["c","foo","ind","s","z"] (functions gr4))
+      ,TestCase (assertEqual "checked-out branched functions" ["bar","c","ind","s","z"] (functions gr5))
       ,TestCase (assertEqual "old function type" Nothing   (functionType gr1 "foo"))
       ,TestCase (assertEqual "new function type" (Just ty) (functionType gr2 "foo"))
       ,TestCase (assertEqual "old function prob" (-log 0)  (functionProb gr1 "foo"))