A lower-level transaction API and a transaction command in the shell

src/compiler/GF/Command/Commands.hs

@@ -730,6 +730,19 @@ pgfCommands = Map.fromList [
        ("lang","the language from which to remove the lin or the lincat")
        ],
      needsTypeCheck = False
+     }),
+  ("t", emptyCommandInfo {
+     longname = "transaction",
+     syntax = "transaction (start|commit|rollback)",
+     synopsis = "Starts, commits or rollbacks a transaction",
+     explanation = unlines [
+       "If there is no active transaction, each create and drop command",
+       "starts its own transaction. Start it manually",
+       "if you want to perform several operations in one transaction.",
+       "This also makes batch operations a lot faster."
+       ],
+     flags = [],
+     needsTypeCheck = False
      })
   ]
  where

src/compiler/GF/Infra/SIO.hs

@@ -14,6 +14,8 @@ module GF.Infra.SIO(
        importGrammar,importSource, link,
        putStrLnFlush,runInterruptibly,
        modifyPGF, checkoutPGF,
+       startTransaction, commitTransaction, rollbackTransaction,
+       inTransaction,
        -- * Restricted accesss to arbitrary (potentially unsafe) IO operations
        -- | If the environment variable GF_RESTRICTED is defined, these
        -- operations will fail. Otherwise, they will be executed normally.
@@ -137,3 +139,7 @@ link opts pgf src = lift0 $ GF.link opts pgf src
 
 modifyPGF   gr t = lift0 (PGFT.modifyPGF gr t)
 checkoutPGF gr = lift0 (PGFT.checkoutPGF gr)
+startTransaction gr = lift0 (PGFT.startTransaction gr)
+commitTransaction tr = lift0 (PGFT.commitTransaction tr)
+rollbackTransaction tr = lift0 (PGFT.rollbackTransaction tr)
+inTransaction tr f = lift0 (PGFT.inTransaction tr f)

src/compiler/GF/Interactive.hs

@@ -25,7 +25,10 @@ import GF.Infra.CheckM
 import qualified System.Console.Haskeline as Haskeline
 
 import PGF2
-import PGF2.Transactions hiding (modifyPGF,checkoutPGF)
+import PGF2.Transactions hiding (modifyPGF,checkoutPGF,
+                                 startTransaction,
+                                 commitTransaction,rollbackTransaction,
+                                 inTransaction)
 
 import Data.Char
 import Data.List(isPrefixOf,sortOn)
@@ -140,12 +143,37 @@ execute1' readNGF s0 =
          (w  :ws) | w == "c" || w == "d" -> do
                         case readTransactionCommand s0 of
                           Just cmd -> do checkout
-                                         mb_pgf <- getPGF
+                                         env <- gets pgfenv
-                                         case mb_pgf of
+                                         case env of
-                                           Just pgf -> transactionCommand cmd pgf
+                                           (_,Just pgf,mb_txnid) -> transactionCommand cmd pgf mb_txnid
-                                           Nothing  -> fail "Import a grammar before using this command"
+                                           _                     -> fail "Import a grammar before using this command"
                           Nothing  -> putStrLnE $ "command not parsed: "++s0
                         continue
+                  | w == "t" -> do
+                        env <- gets pgfenv
+                        case env of
+                          (gr,Just pgf,mb_txnid) ->
+                              case ws of
+                                ["start"]     ->
+                                    case mb_txnid of
+                                      Just _  -> fail "You have already started a transaction"
+                                      Nothing -> do txnid <- lift $ startTransaction pgf
+                                                    modify (\gfenv -> gfenv{pgfenv=(gr,Just pgf,Just txnid)})
+                                ["commit"]    ->
+                                    case mb_txnid of
+                                      Just id -> do lift $ commitTransaction id
+                                                    modify (\gfenv -> gfenv{pgfenv=(gr,Just pgf,Nothing)})
+                                      Nothing -> fail "There is no active transaction"
+                                ["rollback"]  ->
+                                    case mb_txnid of
+                                      Just id -> do lift $ rollbackTransaction id
+                                                    modify (\gfenv -> gfenv{pgfenv=(gr,Just pgf,Nothing)})
+                                      Nothing -> fail "There is no active transaction"
+                                []            -> fail "The transaction command expects start, commit or rollback as an argument"
+                                _             -> fail "The only arguments to the transaction command are start, commit and rollback"
+                          _                   -> fail "Import a grammar before using this command"
+                        continue
+                                           
       -- other special commands, working on GFEnv
          "dc":ws  -> define_command ws
          "dt":ws  -> define_tree ws
@@ -160,11 +188,11 @@ execute1' readNGF s0 =
     stop = return False
 
     checkout = do
-      mb_pgf <- gets multigrammar
+      gfenv <- get
-      case mb_pgf of
+      case pgfenv gfenv of
-        Just pgf -> do pgf <- lift $ checkoutPGF pgf
+        (gr,Just pgf,Nothing) -> do pgf <- lift $ checkoutPGF pgf
-                       modify $ \gfenv -> gfenv{pgfenv = (fst (pgfenv gfenv),Just pgf)}
+                                    put (gfenv{pgfenv = (gr,Just pgf,Nothing)})
-        Nothing  -> return ()
+        _                     -> return ()
 
     interruptible :: ShellM Bool -> ShellM Bool
     interruptible act =
@@ -175,9 +203,13 @@ execute1' readNGF s0 =
 
   -- Special commands:
 
-    quit = do opts <- gets startOpts
+    quit = do
-              when (verbAtLeast opts Normal) $ putStrLnE "See you."
+      env <- gets pgfenv
-              stop
+      case env of
+        (_,_,Just _) -> fail "Commit or rollback the transaction first!"
+        _            -> do opts <- gets startOpts
+                           when (verbAtLeast opts Normal) $ putStrLnE "See you."
+                           stop
 
     system_command ws = do lift $ restrictedSystem $ unwords ws ; continue
 
@@ -236,23 +268,23 @@ import_ readNGF args =
          importInEnv readNGF (addOptions opts (fixRelativeLibPaths curr_dir lib_dir opts')) files
        Bad err -> putStrLnE $ "Command parse error: " ++ err
 
-transactionCommand :: TransactionCommand -> PGF -> ShellM ()
+transactionCommand :: TransactionCommand -> PGF -> Maybe TxnID -> ShellM ()
-transactionCommand (CreateFun opts f ty) pgf = do
+transactionCommand (CreateFun opts f ty) pgf mb_txnid = do
   let prob = realToFrac (valFltOpts "prob" (1/0) opts)
   case checkType pgf ty of
     Left msg -> putStrLnE msg
-    Right ty -> do lift $ modifyPGF pgf (createFunction f ty 0 [] prob)
+    Right ty -> do lift $ updatePGF pgf mb_txnid (createFunction f ty 0 [] prob)
                    return ()
-transactionCommand (CreateCat opts c ctxt) pgf = do
+transactionCommand (CreateCat opts c ctxt) pgf mb_txnid = do
   let prob = realToFrac (valFltOpts "prob" (1/0) opts)
   case checkContext pgf ctxt of
     Left msg -> putStrLnE msg
-    Right ty -> do lift $ modifyPGF pgf (createCategory c ctxt prob)
+    Right ty -> do lift $ updatePGF pgf mb_txnid (createCategory c ctxt prob)
                    return ()
-transactionCommand (CreateConcrete opts name) pgf = do
+transactionCommand (CreateConcrete opts name) pgf mb_txnid = do
-  lift $ modifyPGF pgf (createConcrete name (return ()))
+  lift $ updatePGF pgf mb_txnid (createConcrete name (return ()))
   return ()
-transactionCommand (CreateLin opts f t) pgf = do
+transactionCommand (CreateLin opts f t) pgf mb_txnid = do
   sgr <- getGrammar
   lang <- optLang pgf opts
   mo <- maybe (fail "no source grammar in scope") return $
@@ -267,7 +299,7 @@ transactionCommand (CreateLin opts f t) pgf = do
   case runCheck (compileLinTerm sgr mo t ty) of
     Ok ((prods,seqtbl,fields'),_)
          | fields == fields' ->
-                    do lift $ modifyPGF pgf (alterConcrete lang (createLin f prods seqtbl >> return ()))
+                    do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLin f prods seqtbl >> return ()))
                        return ()
          | otherwise -> fail "The linearization categories in the resource and the compiled grammar does not match"
     Bad msg      -> fail msg
@@ -286,13 +318,13 @@ transactionCommand (CreateLin opts f t) pgf = do
       where
         mapToSequence m = Seq.fromList (map (Left . fst) (sortOn snd (Map.toList m)))
 
-transactionCommand (CreateLincat opts c t) pgf = do
+transactionCommand (CreateLincat opts c t) pgf mb_txnid = do
   sgr <- getGrammar
   lang <- optLang pgf opts
   mo <- maybe (fail "no source grammar in scope") return $
            greatestResource sgr
   case runCheck (compileLincatTerm sgr mo t) of
-    Ok (fields,_)-> do lift $ modifyPGF pgf (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ()))
+    Ok (fields,_)-> do lift $ updatePGF pgf mb_txnid (alterConcrete lang (createLincat c fields [] [] Seq.empty >> return ()))
                        return ()
     Bad msg      -> fail msg
   where
@@ -300,24 +332,29 @@ transactionCommand (CreateLincat opts c t) pgf = do
       t <- renameSourceTerm sgr mo t
       (t,_) <- inferLType sgr [] t
       return (type2fields sgr t)
-transactionCommand (DropFun opts f) pgf = do
+transactionCommand (DropFun opts f) pgf mb_txnid = do
-  lift $ modifyPGF pgf (dropFunction f)
+  lift $ updatePGF pgf mb_txnid (dropFunction f)
   return ()
-transactionCommand (DropCat opts c) pgf = do
+transactionCommand (DropCat opts c) pgf mb_txnid = do
-  lift $ modifyPGF pgf (dropCategory c)
+  lift $ updatePGF pgf mb_txnid (dropCategory c)
   return ()
-transactionCommand (DropConcrete opts name) pgf = do
+transactionCommand (DropConcrete opts name) pgf mb_txnid = do
-  lift $ modifyPGF pgf (dropConcrete name)
+  lift $ updatePGF pgf mb_txnid (dropConcrete name)
   return ()
-transactionCommand (DropLin opts f) pgf = do
+transactionCommand (DropLin opts f) pgf mb_txnid = do
   lang <- optLang pgf opts
-  lift $ modifyPGF pgf (alterConcrete lang (dropLin f))
+  lift $ updatePGF pgf mb_txnid (alterConcrete lang (dropLin f))
   return ()
-transactionCommand (DropLincat opts c) pgf = do
+transactionCommand (DropLincat opts c) pgf mb_txnid = do
   lang <- optLang pgf opts
-  lift $ modifyPGF pgf (alterConcrete lang (dropLincat c))
+  lift $ updatePGF pgf mb_txnid (alterConcrete lang (dropLincat c))
   return ()
 
+updatePGF pgf mb_txnid f = do
+  maybe (modifyPGF pgf f >> return ())
+                                 (\txnid -> inTransaction txnid f)
+                                 mb_txnid
+
 optLang pgf opts =
   case Map.keys (languages pgf) of
     [lang] -> completeLang (valStrOpts "lang" lang opts)
@@ -385,15 +422,18 @@ fetchCommand gfenv = do
 
 importInEnv :: ReadNGF -> Options -> [FilePath] -> ShellM ()
 importInEnv readNGF opts files =
-  do pgf0 <- gets multigrammar
+  do env <- gets pgfenv
-     case flag optRetainResource opts of
+     case env of
-       RetainAll      -> do src <- lift $ importSource opts files
+       (_,pgf0,Nothing) ->
-                            pgf <- lift $ link opts pgf0 src
+           case flag optRetainResource opts of
-                            modify $ \gfenv -> gfenv{pgfenv = (snd src,Just pgf)}
+             RetainAll      -> do src <- lift $ importSource opts files
-       RetainSource   -> do src <- lift $ importSource opts files
+                                  pgf <- lift $ link opts pgf0 src
-                            modify $ \gfenv -> gfenv{pgfenv = (snd src,snd (pgfenv gfenv))}
+                                  modify $ \gfenv -> gfenv{pgfenv = (snd src,Just pgf,Nothing)}
-       RetainCompiled -> do pgf <- lift $ importPGF pgf0
+             RetainSource   -> do src <- lift $ importSource opts files
-                            modify $ \gfenv -> gfenv{pgfenv = (emptyGrammar,pgf)}
+                                  modify $ \gfenv -> gfenv{pgfenv = (snd src,pgf0,Nothing)}
+             RetainCompiled -> do pgf <- lift $ importPGF pgf0
+                                  modify $ \gfenv -> gfenv{pgfenv = (emptyGrammar,pgf,Nothing)}
+       _ -> fail "You must commit/rollback the transaction before loading a new grammar"
   where
     importPGF pgf0 =
       do let opts' = addOptions (setOptimization OptCSE False) opts
@@ -411,11 +451,14 @@ tryGetLine = do
    Left (e :: SomeException) -> return "q"
    Right l -> return l
 
-prompt env = case multigrammar env of
+prompt env = 
-               Just pgf -> abstractName pgf ++ "> "
+  case pgfenv env of
-               Nothing  -> "> "
+    (_,mb_pgf,mb_tr) -> 
+         maybe "" abstractName mb_pgf ++ 
+         maybe "" (const " (transaction)") mb_tr ++
+         "> "
 
-type CmdEnv = (Grammar,Maybe PGF)
+type CmdEnv = (Grammar,Maybe PGF,Maybe TxnID)
 
 data GFEnv = GFEnv {
     startOpts :: Options,
@@ -426,26 +469,33 @@ data GFEnv = GFEnv {
 
 emptyGFEnv opts = GFEnv opts emptyCmdEnv emptyCommandEnv []
 
-emptyCmdEnv = (emptyGrammar,Nothing)
+emptyCmdEnv = (emptyGrammar,Nothing,Nothing)
 
 emptyCommandEnv = mkCommandEnv allCommands
-multigrammar = snd . pgfenv
 
 allCommands =
   extend pgfCommands (helpCommand allCommands:moreCommands)
   `Map.union` sourceCommands
   `Map.union` commonCommands
 
-instance HasGrammar ShellM where getGrammar = gets (fst . pgfenv)
+instance HasGrammar ShellM where
-instance HasPGF ShellM where getPGF = gets (snd . pgfenv)
+  getGrammar = gets $ \gfenv ->
+    case pgfenv gfenv of
+      (gr,_,_) -> gr
+
+instance HasPGF ShellM where
+  getPGF = gets $ \gfenv ->
+    case pgfenv gfenv of
+      (_,mb_pgf,_) -> mb_pgf
 
 wordCompletion gfenv (left,right) = do
   case wc_type (reverse left) of
     CmplCmd pref
       -> ret (length pref) [Haskeline.simpleCompletion name | name <- Map.keys (commands cmdEnv), isPrefixOf pref name]
     CmplStr (Just (Command _ opts _)) s0
-      -> case multigrammar gfenv of
+      -> case pgfenv gfenv of
-           Just pgf -> let langs = languages pgf
+           (_,Just pgf,_) ->
+                       let langs = languages pgf
                            optLang opts = case valStrOpts "lang" "" opts of
                                             ""   -> case Map.minView langs of
                                                       Nothing        -> Nothing
@@ -465,7 +515,7 @@ wordCompletion gfenv (left,right) = do
                             (Just lang,Just cat) -> let compls = [t | ParseOk res <- [complete lang cat s prefix], (t,_,_,_) <- res]
                                                     in ret (length prefix) (map Haskeline.simpleCompletion compls)
                             _                    -> ret 0 []
-           Nothing  -> ret 0 []
+           _        -> ret 0 []
     CmplOpt (Just (Command n _ _)) pref
       -> case Map.lookup n (commands cmdEnv) of
            Just inf -> do let flg_compls = [Haskeline.Completion ('-':flg++"=") ('-':flg) False | (flg,_) <- flags   inf, isPrefixOf pref flg]
@@ -476,9 +526,9 @@ wordCompletion gfenv (left,right) = do
     CmplIdent (Just (Command "i" _ _)) _        -- HACK: file name completion for command i
       -> Haskeline.completeFilename (left,right)
     CmplIdent _ pref
-      -> case multigrammar gfenv of
+      -> case pgfenv gfenv of
-           Just pgf -> ret (length pref) [Haskeline.simpleCompletion name | name <- functions pgf, isPrefixOf pref name]
+           (_,Just pgf,_) -> ret (length pref) [Haskeline.simpleCompletion name | name <- functions pgf, isPrefixOf pref name]
-           Nothing  -> ret (length pref) []
+           _              -> ret (length pref) []
     _ -> ret 0 []
   where
     cmdEnv = commandenv gfenv

src/runtime/c/pgf/db.cxx

@@ -1428,9 +1428,19 @@ void PgfDB::start_transaction()
     last_free_block_txn_id = 0;
 }
 
+PGF_INTERNAL
+void PgfDB::set_transaction_object(object o)
+{
+    transaction_object = o;
+}
+
 PGF_INTERNAL
 void PgfDB::commit(object o)
 {
+    if (transaction_object != o) {
+        return;
+    }
+
     if (last_free_block != 0) {
         free_blocks = insert_block_descriptor(free_blocks,
                                               last_free_block,
@@ -1450,7 +1460,7 @@ void PgfDB::commit(object o)
     int res;
 #ifndef _WIN32
 #ifndef MREMAP_MAYMOVE
-    if (current_db->fd < 0) {
+    if (fd < 0) {
         ms->active_revision = o;
         ms->top = top;
         ms->free_blocks = free_blocks;
@@ -1501,7 +1511,7 @@ void PgfDB::commit(object o)
 
     pthread_mutex_unlock(&ms->write_mutex);
 #else
-    if (current_db->fd > 0) {
+    if (fd > 0) {
         if (free_descriptors[2] != 0) {
             ptr(block_descr,free_descriptors[2])->chain = free_descriptors[0];
             free_descriptors[0] = free_descriptors[1];
@@ -1529,12 +1539,19 @@ void PgfDB::commit(object o)
 
     ReleaseMutex(hWriteMutex);
 #endif
+
+    transaction_object = 0;
 }
 
 PGF_INTERNAL
-void PgfDB::rollback()
+void PgfDB::rollback(object o)
 {
+    if (transaction_object != o) {
+        return;
+    }
+
     top = ms->top;
+    transaction_object = 0;
     free_blocks = ms->free_blocks;
     free_descriptors[0] = ms->free_descriptors;
     free_descriptors[1] = 0;
@@ -1798,6 +1815,11 @@ void PgfDB::resize_map(size_t new_size, bool writeable)
 #endif
 }
 
+bool PgfDB::is_transient_object(object o)
+{
+    return o > ms->top;
+}
+
 DB_scope::DB_scope(PgfDB *db, DB_scope_mode m)
 {
     db->lock(m);

src/runtime/c/pgf/db.h

@@ -69,6 +69,7 @@ private:
     // the corresponding fields in the malloc_state.
     // The exception is when a transaction is active.
     object top;
+    object transaction_object;
     object free_blocks;
     object free_descriptors[3];
     object last_free_block;
@@ -124,8 +125,11 @@ public:
     PGF_INTERNAL_DECL ref<PgfConcr> revision2concr(PgfConcrRevision revision, size_t *p_txn_id = NULL);
 
     PGF_INTERNAL_DECL void start_transaction();
+    PGF_INTERNAL_DECL void set_transaction_object(object o);
     PGF_INTERNAL_DECL void commit(object o);
-    PGF_INTERNAL_DECL void rollback();
+    PGF_INTERNAL_DECL void rollback(object o);
+
+    PGF_INTERNAL_DECL bool is_transient_object(object o);
 
 private:
     PGF_INTERNAL_DECL int init_state();

src/runtime/c/pgf/pgf.cxx

@@ -60,6 +60,8 @@ PgfDB *pgf_read_pgf(const char* fpath, PgfRevision *revision,
             PgfReader rdr(in,probs_callback);
             ref<PgfPGF> pgf = rdr.read_pgf();
 
+            db->set_transaction_object(pgf.as_object());
+
             *revision = db->register_revision(pgf.tagged(), PgfDB::get_txn_id());
             db->commit(pgf.as_object());
         }
@@ -108,6 +110,8 @@ PgfDB *pgf_boot_ngf(const char* pgf_path, const char* ngf_path,
             PgfReader rdr(in,probs_callback);
             ref<PgfPGF> pgf = rdr.read_pgf();
 
+            db->set_transaction_object(pgf.as_object());
+
             *revision = db->register_revision(pgf.tagged(), PgfDB::get_txn_id());
             db->commit(pgf.as_object());
         }
@@ -188,6 +192,9 @@ PgfDB *pgf_new_ngf(PgfText *abstract_name,
             pgf->abstract.funs = 0;
             pgf->abstract.cats = 0;
             pgf->concretes = 0;
+
+            db->set_transaction_object(pgf.as_object());
+
             *revision = db->register_revision(pgf.tagged(), PgfDB::get_txn_id());
             db->commit(pgf.as_object());
         }
@@ -262,6 +269,8 @@ PGF_API_DECL
 void pgf_free_revision(PgfDB *db, PgfRevision revision)
 {
     try {
+        ref<PgfPGF> pgf = db->revision2pgf(revision);
+        db->rollback(pgf.as_object());
         db->unregister_revision(revision);
         db->ref_count--;
     } catch (std::runtime_error& e) {
@@ -1189,6 +1198,8 @@ PgfRevision pgf_start_transaction(PgfDB *db, PgfExn *err)
         new_pgf->abstract.cats = pgf->abstract.cats;
         new_pgf->concretes = pgf->concretes;
 
+        db->set_transaction_object(new_pgf.as_object());
+
         object rev = db->register_revision(new_pgf.tagged(), PgfDB::get_txn_id());
 
         PgfDB::free(pgf);
@@ -1212,21 +1223,6 @@ void pgf_commit_transaction(PgfDB *db, PgfRevision revision,
     } PGF_API_END
 }
 
-PGF_API
-void pgf_rollback_transaction(PgfDB *db, PgfRevision revision)
-{
-    try {
-        db->unregister_revision(revision);
-        db->rollback();
-        db->ref_count--;
-    } catch (std::runtime_error& e) {
-        // silently ignore and hope for the best
-    }
-
-    if (!db->ref_count)
-        delete db;
-}
-
 PGF_API
 PgfRevision pgf_checkout_revision(PgfDB *db, PgfExn *err)
 {
@@ -1391,24 +1387,26 @@ PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision,
         if (concr == 0)
             throw pgf_error("Unknown concrete syntax");
 
-        ref<PgfConcr> clone = PgfDB::malloc<PgfConcr>(name->size+1);
+        ref<PgfConcr> clone = concr;
-        clone->cflags = concr->cflags;
+        if (!current_db->is_transient_object(clone.as_object())) {
-        clone->lins = concr->lins;
+            clone = PgfDB::malloc<PgfConcr>(name->size+1);
-        clone->lincats = concr->lincats;
+            clone->cflags = concr->cflags;
-        clone->phrasetable = concr->phrasetable;
+            clone->lins = concr->lins;
-        clone->printnames = concr->printnames;
+            clone->lincats = concr->lincats;
-        clone->prev = 0;
+            clone->phrasetable = concr->phrasetable;
-        clone->next = 0;
+            clone->printnames = concr->printnames;
-        memcpy(&clone->name, name, sizeof(PgfText)+name->size+1);
+            clone->prev = 0;
+            clone->next = 0;
+            memcpy(&clone->name, name, sizeof(PgfText)+name->size+1);
+
+            Namespace<PgfConcr> concrs =
+                namespace_insert(pgf->concretes, clone);
+            pgf->concretes = concrs;
+
+            PgfDB::free(concr, concr->name.size+1);
+        }
 
         object rev = db->register_revision(clone.tagged(), PgfDB::get_txn_id());
-
-        Namespace<PgfConcr> concrs =
-            namespace_insert(pgf->concretes, clone);
-        pgf->concretes = concrs;
-
-        PgfDB::free(concr, concr->name.size+1);
-
         db->ref_count++;
         return rev;
     } PGF_API_END

src/runtime/c/pgf/pgf.h

@@ -495,9 +495,6 @@ PGF_API_DECL
 void pgf_commit_transaction(PgfDB *db, PgfRevision revision,
                             PgfExn *err);
 
-PGF_API_DECL
-void pgf_rollback_transaction(PgfDB *db, PgfRevision revision);
-
 PGF_API_DECL
 PgfRevision pgf_checkout_revision(PgfDB *db, PgfExn *err);
 

src/runtime/c/pgf/reader.cxx

@@ -689,6 +689,91 @@ ref<Vector<PgfLincatField>> PgfReader::read_lincat_fields(ref<PgfConcrLincat> li
     return fields;
 }
 
+static void add_to_index(ref<PgfConcr> concrete, ref<PgfConcrLin> lin, size_t seq_index, size_t dot)
+{
+    size_t n_fields = lin->lincat->fields->len;
+    ref<PgfSequence> seq = *vector_elem(lin->seqs,seq_index);
+    ref<PgfPResult> result = *vector_elem(lin->res, seq_index / n_fields);
+    ref<PgfLincatField> field = vector_elem(lin->lincat->fields, seq_index % n_fields);
+
+    if (dot >= seq->syms.len) {
+        ref<Vector<PgfLincatEpsilon>> epsilons = field->epsilons;
+        epsilons =
+            vector_resize(epsilons, ((epsilons == 0) ? 0 : epsilons->len)+1,
+                          PgfDB::get_txn_id());
+        field->epsilons = epsilons;
+        ref<PgfLincatEpsilon> epsilon =
+            vector_elem(epsilons,epsilons->len-1);
+        epsilon->lin = lin;
+        epsilon->seq_index = seq_index;
+
+        if (epsilons->len == 1 && field->backrefs != 0) {
+            for (size_t i = 0; i < field->backrefs->len; i++) {
+                ref<PgfLincatBackref> backref = vector_elem(field->backrefs,i);
+                add_to_index(concrete,backref->lin,backref->seq_index,backref->dot+1);
+            }
+        }
+    } else {
+        PgfSymbol sym = *vector_elem(&seq->syms,dot);
+        switch (ref<PgfSymbol>::get_tag(sym)) {
+        case PgfSymbolCat::tag: {
+            auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
+
+            ref<PgfHypo> hypo =
+                vector_elem(lin->absfun->type->hypos,sym_cat->d);
+            ref<PgfConcrLincat> lincat =
+                namespace_lookup(concrete->lincats,
+                                 &hypo->type->name);
+            if (lincat == 0)
+                throw pgf_error("Found a lin which uses a category without a lincat");
+
+            size_t max_values = 1;
+            size_t ranges[sym_cat->r.n_terms];
+            for (size_t i = 0; i < sym_cat->r.n_terms; i++) {
+                for (size_t j = 0; j < result->vars->len; j++) {
+                    auto var_range = vector_elem(result->vars, j);
+                    if (var_range->var == sym_cat->r.terms[i].var) {
+                        ranges[i] = vector_elem(result->vars, j)->range;
+                        max_values *= var_range->range;
+                        break;
+                    }
+                }
+            }
+
+            bool is_epsilon = false;
+            for (size_t values = 0; values < max_values; values++) {
+                size_t v = values;
+                size_t index = sym_cat->r.i0;
+                for (size_t i = 0; i < sym_cat->r.n_terms; i++) {
+                    index += sym_cat->r.terms[i].factor * (v % ranges[i]);
+                    v = v / ranges[i];
+                }
+
+                ref<Vector<PgfLincatBackref>> backrefs =
+                    vector_elem(lincat->fields,index)->backrefs;
+                backrefs =
+                    vector_resize(backrefs, ((backrefs == 0) ? 0 : backrefs->len)+1,
+                                  PgfDB::get_txn_id());
+                vector_elem(lincat->fields,index)->backrefs = backrefs;
+                ref<PgfLincatBackref> backref =
+                    vector_elem(backrefs,backrefs->len-1);
+                backref->lin = lin;
+                backref->seq_index = seq_index;
+                backref->dot = dot;
+
+                if (vector_elem(lincat->fields,index)->epsilons != 0)
+                    is_epsilon = true;
+            }
+
+            if (is_epsilon)
+                add_to_index(concrete,lin,seq_index,dot+1);
+
+            break;
+        }
+        }
+    }
+};
+
 ref<PgfConcrLin> PgfReader::read_lin()
 {
     ref<PgfConcrLin> lin = read_name(&PgfConcrLin::name);
@@ -705,82 +790,10 @@ ref<PgfConcrLin> PgfReader::read_lin()
     if (lin->lincat == 0)
         throw pgf_error("Found a lin which uses a category without a lincat");
 
-    ref<Vector<PgfHypo>> hypos = lin->absfun->type->hypos;
-    ref<PgfConcrLincat> lincats[hypos->len];
-    for (size_t d = 0; d < hypos->len; d++) {
-        lincats[d] =
-            namespace_lookup(concrete->lincats, 
-                             &vector_elem(hypos,d)->type->name);
-        if (lincats[d] == 0)
-            throw pgf_error("Found a lin which uses a category without a lincat");
-    }
-
-    size_t n_fields = lin->lincat->fields->len;
     for (size_t seq_index = 0; seq_index < lin->seqs->len; seq_index++) {
-        ref<PgfSequence> seq = *vector_elem(lin->seqs,seq_index);
+        add_to_index(concrete, lin, seq_index, 0);
-        ref<PgfPResult> result = *vector_elem(lin->res, seq_index / n_fields);
-
-        size_t dot = 0;
-        if (dot >= seq->syms.len) {
-            size_t index = seq_index % n_fields;
-            ref<Vector<PgfLincatEpsilon>> epsilons =
-                vector_elem(lin->lincat->fields,index)->epsilons;
-            epsilons =
-                vector_resize(epsilons, epsilons->len+1,
-                              PgfDB::get_txn_id());
-            vector_elem(lin->lincat->fields,index)->epsilons = epsilons;
-            ref<PgfLincatEpsilon> epsilon =
-                vector_elem(epsilons,epsilons->len-1);
-            epsilon->lin = lin;
-            epsilon->seq_index = seq_index;
-        } else {
-            PgfSymbol sym = *vector_elem(&seq->syms,dot);
-            switch (ref<PgfSymbol>::get_tag(sym)) {
-            case PgfSymbolCat::tag: {
-                auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
-                ref<PgfConcrLincat> lincat = lincats[sym_cat->d];
-
-                size_t max_values = 1;
-                size_t ranges[sym_cat->r.n_terms];
-                for (size_t i = 0; i < sym_cat->r.n_terms; i++) {
-                    size_t range = 1;
-                    for (size_t j = 0; j < result->vars->len; j++) {
-                        auto var_range = vector_elem(result->vars, j);
-                        if (var_range->var == sym_cat->r.terms[i].var) {
-                            range = var_range->range;
-                            break;
-                        }
-                    }
-
-                    ranges[i]   = range;
-                    max_values *= range;
-                }
-
-                for (size_t values = 0; values < max_values; values++) {
-                    size_t v = values;
-                    size_t index = sym_cat->r.i0;
-                    for (size_t i = 0; i < sym_cat->r.n_terms; i++) {
-                        index += sym_cat->r.terms[i].factor * (v % ranges[i]);
-                        v = v / ranges[i];
-                    }
-
-                    ref<Vector<PgfLincatBackref>> backrefs =
-                        vector_elem(lincat->fields,index)->backrefs;
-                    backrefs =
-                        vector_resize(backrefs, backrefs->len+1,
-                                      PgfDB::get_txn_id());
-                    vector_elem(lincat->fields,index)->backrefs = backrefs;
-                    ref<PgfLincatBackref> backref =
-                        vector_elem(backrefs,backrefs->len-1);
-                    backref->lin = lin;
-                    backref->seq_index = seq_index;
-                    backref->dot = dot;
-                }
-                break;
-            }
-            }
-        }
     }
+
     return lin;
 }
 

src/runtime/haskell/PGF2/FFI.hsc

@@ -80,6 +80,8 @@ foreign import ccall pgf_merge_pgf :: Ptr PgfDB -> Ptr PGF -> CString -> Ptr Pgf
 
 foreign import ccall pgf_write_pgf :: CString -> Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -> IO ()
 
+foreign import ccall "pgf_free_revision" pgf_free_revision_ :: Ptr PgfDB -> Ptr PGF -> IO ()
+
 foreign import ccall "&pgf_free_revision" pgf_free_revision :: FinalizerEnvPtr PgfDB PGF
 
 foreign import ccall "pgf_free_concr_revision" pgf_free_concr_revision_ :: Ptr PgfDB -> Ptr Concr -> IO ()
@@ -194,8 +196,6 @@ foreign import ccall pgf_start_transaction :: Ptr PgfDB -> Ptr PgfExn -> IO (Ptr
 
 foreign import ccall pgf_commit_transaction :: Ptr PgfDB -> Ptr PGF -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_rollback_transaction :: Ptr PgfDB -> Ptr PGF -> IO ()
-
 foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfExn -> IO (Ptr PGF)
 
 foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PGF -> Ptr PgfText -> StablePtr Type -> CSize -> Ptr CChar -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()

src/runtime/haskell/PGF2/Transactions.hsc

@@ -1,5 +1,11 @@
 module PGF2.Transactions
-          ( Transaction
+          ( -- transactions
+            TxnID
+          , Transaction
+          , startTransaction
+          , commitTransaction
+          , rollbackTransaction
+          , inTransaction
 
             -- abstract syntax
           , modifyPGF
@@ -64,24 +70,38 @@ instance Monad (Transaction k) where
              Transaction g -> g c_db c_abstr c_revision c_exn
       else return undefined
 
+data TxnID = TxnID (Ptr PgfDB) (ForeignPtr PGF)
+
+startTransaction :: PGF -> IO TxnID
+startTransaction p = do
+  c_revision <- withPgfExn "startTransaction" (pgf_start_transaction (a_db p))
+  fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision
+  return (TxnID (a_db p) fptr)
+
+commitTransaction :: TxnID -> IO PGF
+commitTransaction (TxnID db fptr) = do
+  withForeignPtr fptr $ \c_revision ->
+    withPgfExn "commitTransaction" (pgf_commit_transaction db c_revision)
+  langs <- getConcretes db fptr
+  return (PGF db fptr langs)
+
+rollbackTransaction :: TxnID -> IO ()
+rollbackTransaction (TxnID db fptr) =
+  finalizeForeignPtr fptr
+
+inTransaction :: TxnID -> Transaction PGF a -> IO a
+inTransaction (TxnID db fptr) (Transaction f) =
+  withForeignPtr fptr $ \c_revision -> do
+  withPgfExn "inTransaction" $ \c_exn ->
+    f db c_revision c_revision c_exn
+
 {- | @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
+   will still access the old 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 PGF a -> IO PGF
 modifyPGF p (Transaction f) =
-  withForeignPtr (a_revision p) $ \c_revision ->
   withPgfExn "modifyPGF" $ \c_exn ->
   mask $ \restore -> do
     c_revision <- pgf_start_transaction (a_db p) c_exn
@@ -90,7 +110,7 @@ modifyPGF p (Transaction f) =
       then do ((restore (f (a_db p) c_revision c_revision c_exn))
                `catch`
                (\e -> do
-                    pgf_rollback_transaction (a_db p) c_revision
+                    pgf_free_revision_ (a_db p) c_revision
                     throwIO (e :: SomeException)))
               ex_type <- (#peek PgfExn, type) c_exn
               if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
@@ -100,9 +120,9 @@ modifyPGF p (Transaction f) =
                           then do fptr <- newForeignPtrEnv pgf_free_revision (a_db p) c_revision
                                   langs <- getConcretes (a_db p) fptr
                                   return (PGF (a_db p) fptr langs)
-                          else do pgf_rollback_transaction (a_db p) c_revision
+                          else do pgf_free_revision_ (a_db p) c_revision
                                   return p
-                else do pgf_rollback_transaction (a_db p) c_revision
+                else do pgf_free_revision_ (a_db p) c_revision
                         return p
       else return p