added createCategory, dropCategory

src/runtime/c/pgf/db.cxx

@@ -988,7 +988,7 @@ PGF_INTERNAL
 void PgfDB::link_transient_revision(ref<PgfPGF> pgf)
 {
     pgf->next = current_db->ms->transient_revisions;
-    if (current_db->ms->transient_revisions == 0)
+    if (current_db->ms->transient_revisions != 0)
         current_db->ms->transient_revisions->prev = pgf;
     current_db->ms->transient_revisions = pgf;
 }

src/runtime/c/pgf/expr.cxx

@@ -194,9 +194,9 @@ PgfLiteral PgfDBUnmarshaller::lstr(PgfText *val)
     return ref<PgfLiteralStr>::tagged(lit_str);
 }
 
-PgfType PgfDBUnmarshaller::dtyp(int n_hypos, PgfTypeHypo *hypos,
+PgfType PgfDBUnmarshaller::dtyp(size_t n_hypos, PgfTypeHypo *hypos,
                                 PgfText *cat,
-                                int n_exprs, PgfExpr *exprs)
+                                size_t n_exprs, PgfExpr *exprs)
 {
     ref<PgfDTyp> ty =
         PgfDB::malloc<PgfDTyp>(cat->size+1);
@@ -205,8 +205,7 @@ PgfType PgfDBUnmarshaller::dtyp(int n_hypos, PgfTypeHypo *hypos,
     for (size_t i = 0; i < n_hypos; i++) {
         ref<PgfHypo> hypo = vector_elem(ty->hypos,i);
         hypo->bind_type = hypos[i].bind_type;
-        hypo->cid = PgfDB::malloc<PgfText>(hypos[i].cid->size+1);
+        hypo->cid = textdup_db(hypos[i].cid);
-        memcpy(hypo->cid, hypos[i].cid, sizeof(PgfText)+hypos[i].cid->size+1);
         hypo->type = m->match_type(this, hypos[i].type);
     }
     ty->exprs = vector_new<PgfExpr>(n_exprs);

src/runtime/c/pgf/expr.h

@@ -116,9 +116,9 @@ struct PGF_INTERNAL_DECL PgfDBUnmarshaller : public PgfUnmarshaller {
     virtual PgfLiteral lint(size_t size, uintmax_t *val);
     virtual PgfLiteral lflt(double val);
     virtual PgfLiteral lstr(PgfText *val);
-    virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos,
+    virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
                          PgfText *cat,
-                         int n_exprs, PgfExpr *exprs);
+                         size_t n_exprs, PgfExpr *exprs);
     virtual void free_ref(object x);
 };
 

src/runtime/c/pgf/pgf.cxx

@@ -453,9 +453,7 @@ PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision,
         if (pgf->gflags != 0)
             pgf->gflags->ref_count++;
 
-        new_pgf->abstract.name =
+        new_pgf->abstract.name = textdup_db(&(*pgf->abstract.name));
-            PgfDB::malloc<PgfText>(pgf->abstract.name->size+1);
-        memcpy(new_pgf->abstract.name, pgf->abstract.name, sizeof(PgfText)+pgf->abstract.name->size+1);
 
         new_pgf->abstract.aflags = pgf->abstract.aflags;
         if (pgf->abstract.aflags != 0)
@@ -495,7 +493,8 @@ void pgf_commit_revision(PgfDB *db, PgfRevision revision,
         PgfDB::unlink_transient_revision(new_pgf);
         PgfDB::set_revision(new_pgf);
 
-        PgfDB::link_transient_revision(old_pgf);
+        if (old_pgf != 0)
+            PgfDB::link_transient_revision(old_pgf);
     } PGF_API_END
 }
 
@@ -557,3 +556,51 @@ void pgf_drop_function(PgfDB *db, PgfRevision revision,
         pgf->abstract.funs = funs;
     } PGF_API_END
 }
+
+PGF_API
+void pgf_create_category(PgfDB *db, PgfRevision revision,
+                         PgfText *name,
+                         size_t n_hypos, PgfTypeHypo *context, prob_t prob,
+                         PgfMarshaller *m,
+                         PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, WRITER_SCOPE);
+
+        PgfDBUnmarshaller u(m);
+
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
+        ref<PgfAbsCat> abscat = PgfDB::malloc<PgfAbsCat>(name->size+1);
+        abscat->context = vector_new<PgfHypo>(n_hypos);
+        abscat->prob    = prob;
+        memcpy(&abscat->name, name, sizeof(PgfText)+name->size+1);
+
+        for (size_t i = 0; i < n_hypos; i++) {
+            vector_elem(abscat->context, i)->bind_type = context[i].bind_type;
+            vector_elem(abscat->context, i)->cid = textdup_db(context[i].cid);
+            vector_elem(abscat->context, i)->type = m->match_type(&u, context[i].type);
+        }
+
+        Namespace<PgfAbsCat> cats =
+            namespace_insert(pgf->abstract.cats, abscat);
+        namespace_release(pgf->abstract.cats);
+        pgf->abstract.cats = cats;
+    } PGF_API_END
+}
+
+PGF_API
+void pgf_drop_category(PgfDB *db, PgfRevision revision,
+                       PgfText *name,
+                       PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, WRITER_SCOPE);
+
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
+
+        Namespace<PgfAbsCat> cats =
+            namespace_delete(pgf->abstract.cats, name);
+        namespace_release(pgf->abstract.cats);
+        pgf->abstract.cats = cats;
+    } PGF_API_END
+}

src/runtime/c/pgf/pgf.h

@@ -164,9 +164,9 @@ struct PgfUnmarshaller {
     virtual PgfLiteral lint(size_t size, uintmax_t *v)=0;
     virtual PgfLiteral lflt(double v)=0;
     virtual PgfLiteral lstr(PgfText *v)=0;
-    virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos,
+    virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
                          PgfText *cat,
-                         int n_exprs, PgfExpr *exprs)=0;
+                         size_t n_exprs, PgfExpr *exprs)=0;
     virtual void free_ref(object x)=0;
 };
 
@@ -347,4 +347,16 @@ void pgf_drop_function(PgfDB *db, PgfRevision revision,
                        PgfText *name,
                        PgfExn *err);
 
+PGF_API_DECL
+void pgf_create_category(PgfDB *db, PgfRevision revision,
+                         PgfText *name,
+                         size_t n_hypos, PgfTypeHypo *context, prob_t prob,
+                         PgfMarshaller *m,
+                         PgfExn *err);
+
+PGF_API_DECL
+void pgf_drop_category(PgfDB *db, PgfRevision revision,
+                       PgfText *name,
+                       PgfExn *err);
+
 #endif // PGF_H_

src/runtime/c/pgf/printer.cxx

@@ -380,9 +380,9 @@ PgfLiteral PgfPrinter::lstr(PgfText *v)
     return 0;
 }
 
-PgfType PgfPrinter::dtyp(int n_hypos, PgfTypeHypo *hypos,
+PgfType PgfPrinter::dtyp(size_t n_hypos, PgfTypeHypo *hypos,
                          PgfText *cat,
-                         int n_exprs, PgfExpr *exprs)
+                         size_t n_exprs, PgfExpr *exprs)
 {
     bool p = (prio > 0 && n_hypos > 0) ||
              (prio > 3 && n_exprs > 0);

src/runtime/c/pgf/printer.h

@@ -61,9 +61,9 @@ public:
     virtual PgfLiteral lint(size_t size, uintmax_t *v);
     virtual PgfLiteral lflt(double v);
     virtual PgfLiteral lstr(PgfText *v);
-    virtual PgfType dtyp(int n_hypos, PgfTypeHypo *hypos,
+    virtual PgfType dtyp(size_t n_hypos, PgfTypeHypo *hypos,
                          PgfText *cat,
-                         int n_exprs, PgfExpr *exprs);
+                         size_t n_exprs, PgfExpr *exprs);
     virtual void free_ref(object x);
 };
 

src/runtime/c/pgf/text.cxx

@@ -26,6 +26,14 @@ PgfText* textdup(PgfText *t1)
     return t2;
 }
 
+PGF_INTERNAL
+ref<PgfText> textdup_db(PgfText *t1)
+{
+    ref<PgfText> t2 = PgfDB::malloc<PgfText>(t1->size+1);
+    memcpy(&(*t2), t1, sizeof(PgfText)+t1->size+1);
+    return t2;
+}
+
 PGF_API uint32_t
 pgf_utf8_decode(const uint8_t** src_inout)
 {

src/runtime/c/pgf/text.h

@@ -7,6 +7,9 @@ int textcmp(PgfText *t1, PgfText *t2);
 PGF_INTERNAL_DECL
 PgfText* textdup(PgfText *t1);
 
+PGF_INTERNAL_DECL
+ref<PgfText> textdup_db(PgfText *t1);
+
 PGF_API uint32_t
 pgf_utf8_decode(const uint8_t** src_inout);
 

src/runtime/haskell/PGF2/FFI.hsc

@@ -118,6 +118,10 @@ foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr
 
 foreign import ccall pgf_drop_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
+foreign import ccall pgf_create_category :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> CSize -> Ptr PgfTypeHypo -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
+
+foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO ()
+
 
 -----------------------------------------------------------------------
 -- Texts
@@ -310,7 +314,7 @@ foreign import ccall "dynamic"
 foreign import ccall "wrapper"
   wrapLStrFun :: LStrFun -> IO (FunPtr LStrFun)
 
-type DTypFun = Ptr PgfUnmarshaller -> CInt -> Ptr PgfTypeHypo -> Ptr PgfText -> CInt -> Ptr (StablePtr Expr) -> IO (StablePtr Type)
+type DTypFun = Ptr PgfUnmarshaller -> CSize -> Ptr PgfTypeHypo -> Ptr PgfText -> CSize -> Ptr (StablePtr Expr) -> IO (StablePtr Type)
 
 foreign import ccall "dynamic"
   callDTypFun :: FunPtr DTypFun -> DTypFun
@@ -397,21 +401,19 @@ marshaller = unsafePerformIO $ do
       ty   <- deRefStablePtr c_ty
       case ty of
         DTyp hypos cat es -> let n_hypos = length hypos
-                             in allocaBytes (n_hypos * (#size PgfTypeHypo)) $ \c_hypos ->
+                             in withHypos hypos $ \n_hypos c_hypos ->
                                 withText cat $ \c_cat ->
                                 mask_ $ do
-                                  marshalHypos c_hypos hypos
                                   c_es <- mapM newStablePtr es
                                   res <- withArray c_es $ \c_exprs -> do
                                            fun <- (#peek PgfUnmarshallerVtbl, dtyp) vtbl
                                            callDTypFun fun u
-                                                       (fromIntegral n_hypos)
+                                                       n_hypos
                                                        c_hypos
                                                        c_cat
                                                        (fromIntegral (length es))
                                                        c_exprs
                                   mapM_ freeStablePtr c_es
-                                  freeHypos c_hypos n_hypos
                                   return res
       where
         marshalHypos _   []               = return ()
@@ -533,3 +535,26 @@ marshalBindType Implicit = (#const PGF_BIND_TYPE_IMPLICIT)
 unmarshalBindType :: (#type PgfBindType) -> BindType
 unmarshalBindType (#const PGF_BIND_TYPE_EXPLICIT) = Explicit
 unmarshalBindType (#const PGF_BIND_TYPE_IMPLICIT) = Implicit
+
+withHypos hypos f =
+  let n_hypos = length hypos
+  in allocaBytes (n_hypos * (#size PgfTypeHypo)) $ \c_hypos ->
+     mask_ $ do
+       marshalHypos c_hypos hypos
+       res <- f (fromIntegral n_hypos :: CSize) c_hypos
+       freeHypos n_hypos c_hypos
+       return res
+  where
+    marshalHypos _   []               = return ()
+    marshalHypos ptr ((bt,var,ty):hs) = do
+      (#poke PgfTypeHypo, bind_type) ptr (marshalBindType bt)
+      newText var     >>= (#poke PgfTypeHypo, cid)  ptr
+      newStablePtr ty >>= (#poke PgfTypeHypo, type) ptr
+      marshalHypos (ptr `plusPtr` (#size PgfTypeHypo)) hs
+
+    freeHypos 0 ptr = return ()
+    freeHypos n ptr = do
+      (#peek PgfTypeHypo, cid)  ptr >>= free
+      (#peek PgfTypeHypo, type) ptr >>= freeStablePtr
+      freeHypos (n-1) (ptr `plusPtr` (#size PgfTypeHypo))
+

src/runtime/haskell/PGF2/Transactions.hsc

@@ -5,6 +5,8 @@ module PGF2.Transactions
           , checkoutPGF
           , createFunction
           , dropFunction
+          , createCategory
+          , dropCategory
           ) where
 
 import PGF2.FFI
@@ -116,3 +118,15 @@ dropFunction :: Fun -> Transaction ()
 dropFunction name = Transaction $ \c_db c_revision c_exn ->
   withText name $ \c_name -> do
     pgf_drop_function c_db c_revision c_name c_exn
+
+createCategory :: Fun -> [Hypo] -> Float -> Transaction ()
+createCategory name hypos prob = Transaction $ \c_db c_revision c_exn ->
+  withText name $ \c_name ->
+  withHypos hypos $ \n_hypos c_hypos ->
+  withForeignPtr marshaller $ \m -> do
+    pgf_create_category c_db c_revision c_name n_hypos c_hypos prob m c_exn
+
+dropCategory :: Cat -> Transaction ()
+dropCategory name = Transaction $ \c_db c_revision c_exn ->
+  withText name $ \c_name -> do
+    pgf_drop_category c_db c_revision c_name c_exn

src/runtime/haskell/tests/transactions.hs

@@ -6,13 +6,15 @@ 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)
+                                     createCategory "Q" [(Explicit,"x",ty)] pi)
+  gr3 <- branchPGF gr1 "bar_branch" (createFunction "bar" ty pi >>
+                                     createCategory "R" [(Explicit,"x",ty)] pi)
 
   Just gr4 <- checkoutPGF gr1 "master"
   Just gr5 <- checkoutPGF gr1 "bar_branch"
 
-  gr6 <- modifyPGF gr1 (dropFunction "ind")
+  gr6 <- modifyPGF gr1 (dropFunction "ind" >> dropCategory "S")
 
   runTestTTAndExit $
     TestList $
@@ -21,7 +23,13 @@ main = do
       ,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 "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 "branched categories" ["Float","Int","N","P","R","S","String"] (categories gr3))
+      ,TestCase (assertEqual "Q context" [(Explicit,"x",ty)] (categoryContext gr2 "Q"))
+      ,TestCase (assertEqual "R context" [(Explicit,"x",ty)] (categoryContext gr3 "R"))
       ,TestCase (assertEqual "reduced functions" ["c","s","z"] (functions gr6))
+      ,TestCase (assertEqual "reduced categories" ["Float","Int","N","P","String"] (categories gr6))
       ,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"))