API for adding concrete syntaxes. Garbage collection to be fixed!

src/compiler/GF/Compile/GrammarToPGF.hs

@@ -18,6 +18,7 @@ import GF.Infra.Option
 import GF.Infra.UseIO (IOE)
 import GF.Data.Operations
 
+import Control.Monad(forM)
 import Data.List
 import Data.Char
 import qualified Data.Set as Set
@@ -28,26 +29,8 @@ import Data.Maybe(fromMaybe)
 import System.FilePath
 import System.Directory
 
-import GHC.Prim
-import GHC.Base(getTag)
-
 grammar2PGF :: Options -> SourceGrammar -> ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
 grammar2PGF opts gr am probs = do
-  gr <- mkAbstr am probs
-  return gr {-do
-  cnc_infos <- getConcreteInfos gr am
-  return $
-    build (let gflags   = if flag optSplitPGF opts 
-                            then [("split", LStr "true")]
-                            else []
-               (an,abs) = mkAbstr am probs
-               cncs     = map (mkConcr opts abs) cnc_infos
-           in newPGF gflags an abs cncs)-}
-  where
-    aflags = err (const noOptions) mflags (lookupModule gr am)
-
-    mkAbstr :: ModuleName -> Map.Map PGF2.Fun Double -> IO PGF
-    mkAbstr am probs = do
   let abs_name = mi2i am
   mb_ngf_path <-
      if snd (flag optLinkTargets opts)
@@ -61,18 +44,23 @@ grammar2PGF opts gr am probs = do
                putStr ("(Boot image "++fname++") ")
                return (Just fname)
        else do return Nothing
-      gr <- newNGF abs_name mb_ngf_path
+  pgf <- newNGF abs_name mb_ngf_path
-      modifyPGF gr $ do
+  pgf <- modifyPGF pgf $ do
-        sequence_ [setAbstractFlag name value | (name,value) <- flags]
+    sequence_ [setAbstractFlag name value | (name,value) <- optionsPGF aflags]
     sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats]
     sequence_ [createFunction f ty arity p | (f,ty,arity,_,p) <- funs]
+    forM (allConcretes gr am) $ \cm ->
+      createConcrete (mi2i cm) $ do
+        let cflags = err (const noOptions) mflags (lookupModule gr cm)
+        sequence_ [setConcreteFlag name value | (name,value) <- optionsPGF cflags]
+  return pgf
   where
+    aflags = err (const noOptions) mflags (lookupModule gr am)
+
     adefs =
         [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ 
         Look.allOrigInfos gr am
 
-        flags = optionsPGF aflags
-
     toLogProb = realToFrac . negate . log
 
     cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) |
@@ -95,58 +83,7 @@ grammar2PGF opts gr am probs = do
             deflt = case length [f | (f,Nothing) <- pfs] of
                       0 -> 0
                       n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n)
-{-
-    mkConcr opts abs (cm,ex_seqs,cdefs) =
-      let cflags = err (const noOptions) mflags (lookupModule gr cm)
-          ciCmp | flag optCaseSensitive cflags = compare
-                | otherwise                    = compareCaseInsensitive
 
-          flags = optionsPGF aflags
-
-          seqs = (mkSetArray . Set.fromList . concat) $
-                       (elems (ex_seqs :: Array SeqId [Symbol]) : [maybe [] elems (mseqs mi) | (m,mi) <- allExtends gr cm])
-
-          !(!fid_cnt1,!cnccats) = genCncCats gr am cm cdefs
-          cnccat_ranges = Map.fromList (map (\(cid,s,e,_) -> (cid,(s,e))) cnccats)
-          !(!fid_cnt2,!productions,!lindefs,!linrefs,!cncfuns)
-                                = genCncFuns gr am cm ex_seqs ciCmp seqs cdefs fid_cnt1 cnccat_ranges
-
-          printnames = genPrintNames cdefs
-
-          startCat = (fromMaybe "S" (flag optStartCat aflags))
-
-          (lindefs',linrefs',productions',cncfuns',sequences',cnccats') =
-               (if flag optOptimizePGF opts then optimizePGF startCat else id)
-                    (lindefs,linrefs,productions,cncfuns,elems seqs,cnccats)
-
-      in (mi2i cm, newConcr abs
-                            flags
-                            printnames
-                            lindefs'
-                            linrefs'
-                            productions'
-                            cncfuns'
-                            sequences'
-                            cnccats'
-                            fid_cnt2)
-
-    getConcreteInfos gr am = mapM flatten (allConcretes gr am)
-      where
-        flatten cm = do
-          (seqs,infos) <- addMissingPMCFGs cm Map.empty
-                                           (lit_infos ++ Look.allOrigInfos gr cm)
-          return (cm,mkMapArray seqs :: Array SeqId [Symbol],infos)
-
-        lit_infos = [((cPredefAbs,c), CncCat (Just (L NoLoc GM.defLinType)) Nothing Nothing Nothing Nothing) | c <- [cInt,cFloat,cString]]
-
-        -- if some module was compiled with -no-pmcfg, then
-        -- we have to create the PMCFG code just before linking
-        addMissingPMCFGs cm seqs []                  = return (seqs,[])
-        addMissingPMCFGs cm seqs (((m,id), info):is) = do
-          (seqs,info)  <- addPMCFG opts gr cenv Nothing am cm seqs id info
-          (seqs,infos) <- addMissingPMCFGs cm seqs is
-          return (seqs, ((m,id), info) : infos)
--}
 i2i :: Ident -> String
 i2i = showIdent
 

src/runtime/c/pgf/data.cxx

@@ -36,4 +36,10 @@ void PgfPGF::release(ref<PgfPGF> pgf)
     namespace_release(pgf->abstract.aflags);
     namespace_release(pgf->abstract.funs);
     namespace_release(pgf->abstract.cats);
+    namespace_release(pgf->concretes);
+}
+
+void PgfConcr::release(ref<PgfConcr> concr)
+{
+    namespace_release(concr->cflags);
 }

src/runtime/c/pgf/data.h

@@ -54,6 +54,7 @@ private:
 };
 
 class PgfPGF;
+class PgfConcr;
 
 #include "db.h"
 #include "text.h"
@@ -103,6 +104,14 @@ typedef struct {
     Namespace<PgfAbsCat> cats;
 } PgfAbstr;
 
+struct PGF_INTERNAL_DECL PgfConcr {
+    size_t ref_count;
+	Namespace<PgfFlag> cflags;
+    PgfText name;
+
+    static void release(ref<PgfConcr> pgf);
+};
+
 struct PGF_INTERNAL_DECL PgfPGF {
     size_t ref_count;
 
@@ -110,7 +119,7 @@ struct PGF_INTERNAL_DECL PgfPGF {
 	uint16_t minor_version;
 	Namespace<PgfFlag> gflags;
 	PgfAbstr abstract;
-	//PgfConcrs* concretes;
+    Namespace<PgfConcr> concretes;
 
     // If the revision is transient, then it is in a double-linked list
     // with all other transient revisions.

src/runtime/c/pgf/db.cxx

@@ -1043,6 +1043,23 @@ ref<PgfPGF> PgfDB::revision2pgf(PgfRevision revision)
     return pgf;
 }
 
+PGF_INTERNAL
+ref<PgfConcr> PgfDB::revision2concr(PgfConcrRevision revision)
+{
+    if (revision <= sizeof(*current_db->ms) || revision >= current_db->ms->top)
+        throw pgf_error("Invalid revision");
+
+    mchunk *chunk = mem2chunk(ptr(current_db->ms,revision));
+    if (chunksize(chunk) < sizeof(PgfConcr))
+        throw pgf_error("Invalid revision");
+
+    ref<PgfConcr> concr = revision;
+    if (chunksize(chunk) != request2size(sizeof(PgfConcr)+concr->name.size+1))
+        throw pgf_error("Invalid revision");
+
+    return concr;
+}
+
 PGF_INTERNAL
 bool PgfDB::is_persistant_revision(ref<PgfPGF> pgf)
 {

src/runtime/c/pgf/db.h

@@ -85,6 +85,7 @@ public:
     static PGF_INTERNAL_DECL ref<PgfPGF> get_revision(PgfText *name);
     static PGF_INTERNAL_DECL void set_revision(ref<PgfPGF> pgf);
     static PGF_INTERNAL_DECL ref<PgfPGF> revision2pgf(PgfRevision revision);
+    static PGF_INTERNAL_DECL ref<PgfConcr> revision2concr(PgfConcrRevision revision);
     static PGF_INTERNAL_DECL bool is_persistant_revision(ref<PgfPGF> pgf);
     static PGF_INTERNAL_DECL void link_transient_revision(ref<PgfPGF> pgf);
     static PGF_INTERNAL_DECL void unlink_transient_revision(ref<PgfPGF> pgf);

src/runtime/c/pgf/namespace.h

@@ -480,7 +480,7 @@ void namespace_iter(Namespace<V> map, PgfItor* itor, PgfExn *err)
     if (err->type != PGF_EXN_NONE)
         return;
 
-    itor->fn(itor, &map->value->name, &(*map->value), err);
+    itor->fn(itor, &map->value->name, map->value.as_object(), err);
     if (err->type != PGF_EXN_NONE)
         return;
 

src/runtime/c/pgf/pgf.cxx

@@ -175,6 +175,7 @@ PgfDB *pgf_new_ngf(PgfText *abstract_name,
             pgf->abstract.aflags = 0;
             pgf->abstract.funs = 0;
             pgf->abstract.cats = 0;
+            pgf->concretes = 0;
             pgf->prev = 0;
             pgf->next = 0;
             pgf->name.size = master_size;
@@ -255,6 +256,36 @@ void pgf_free_revision(PgfDB *db, PgfRevision revision)
         delete db;
 }
 
+PGF_API_DECL
+void pgf_free_concr_revision(PgfDB *db, PgfConcrRevision revision)
+{
+/*    try {
+        DB_scope scope(db, WRITER_SCOPE);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
+
+        if (pgf->ref_count == 1 && PgfDB::is_persistant_revision(pgf)) {
+            // Someone is trying to release the last reference count
+            // to a persistant revision. Mostly likely this is an
+            // error in the reference counting for one of the clients.
+            // The best that we can do is to ignore the request.
+            return;
+        }
+
+        if (!(--pgf->ref_count)) {
+            PgfDB::unlink_transient_revision(pgf);
+            PgfPGF::release(pgf);
+            PgfDB::free(pgf);
+        }
+
+        db->ref_count--;
+    } catch (std::runtime_error& e) {
+        // silently ignore and hope for the best
+    }
+
+    if (!db->ref_count)
+        delete db;*/
+}
+
 PGF_API
 PgfText *pgf_abstract_name(PgfDB *db, PgfRevision revision,
                            PgfExn *err)
@@ -281,6 +312,18 @@ void pgf_iter_categories(PgfDB *db, PgfRevision revision,
     } PGF_API_END
 }
 
+PGF_API
+void pgf_iter_concretes(PgfDB *db, PgfRevision revision,
+                        PgfItor *itor, PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, READER_SCOPE);
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
+
+        namespace_iter(pgf->concretes, itor, err);
+    } PGF_API_END
+}
+
 PGF_API
 PgfType pgf_start_cat(PgfDB *db, PgfRevision revision,
                       PgfUnmarshaller *u,
@@ -397,11 +440,11 @@ struct PgfItorHelper : PgfItor
 };
 
 static
-void iter_by_cat_helper(PgfItor *itor, PgfText *key, void *value,
+void iter_by_cat_helper(PgfItor *itor, PgfText *key, object value,
 		                PgfExn *err)
 {
     PgfItorHelper* helper = (PgfItorHelper*) itor;
-    PgfAbsFun* absfun = (PgfAbsFun*) value;
+    ref<PgfAbsFun> absfun = value;
     if (textcmp(helper->cat, &absfun->type->name) == 0)
         helper->itor->fn(helper->itor, key, value, err);
 }
@@ -483,6 +526,46 @@ prob_t pgf_function_prob(PgfDB *db, PgfRevision revision,
     return INFINITY;
 }
 
+PGF_API
+PgfText *pgf_concrete_name(PgfDB *db, PgfConcrRevision revision,
+                           PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, READER_SCOPE);
+        ref<PgfConcr> concr = PgfDB::revision2concr(revision);
+
+        return textdup(&concr->name);
+    } PGF_API_END
+
+    return NULL;
+}
+
+PGF_API
+PgfText *pgf_concrete_language_code(PgfDB *db, PgfConcrRevision revision,
+                                    PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, READER_SCOPE);
+
+        ref<PgfConcr> concr = PgfDB::revision2concr(revision);
+
+        size_t size = strlen("language");
+        PgfText *language = (PgfText *) alloca(sizeof(PgfText)+size+1);
+        language->size = size;
+        strcpy((char*) &language->text, "language");
+
+        ref<PgfFlag> flag =
+            namespace_lookup(concr->cflags, language);
+        if (flag != 0 &&
+            ref<PgfLiteral>::get_tag(flag->value) == PgfLiteralStr::tag) {
+            ref<PgfLiteralStr> lstr = ref<PgfLiteralStr>::untagged(flag->value);
+            return textdup(&lstr->val);
+        }
+    } PGF_API_END
+
+    return NULL;
+}
+
 PGF_API
 PgfText *pgf_print_expr(PgfExpr e,
                         PgfPrintContext *ctxt, int prio,
@@ -604,6 +687,10 @@ PgfRevision pgf_clone_revision(PgfDB *db, PgfRevision revision,
         if (pgf->abstract.cats != 0)
             Node<PgfAbsCat>::add_node_ref(pgf->abstract.cats);
 
+        new_pgf->concretes = pgf->concretes;
+        if (pgf->concretes != 0)
+            Node<PgfConcr>::add_node_ref(pgf->concretes);
+
         new_pgf->prev = 0;
         new_pgf->next = 0;
         PgfDB::link_transient_revision(new_pgf);
@@ -752,6 +839,81 @@ void pgf_drop_category(PgfDB *db, PgfRevision revision,
     } PGF_API_END
 }
 
+PGF_API
+PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision,
+                                     PgfText *name,
+                                     PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, WRITER_SCOPE);
+
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
+
+        ref<PgfConcr> concr =
+            namespace_lookup(pgf->concretes, name);
+        if (concr != 0)
+            throw pgf_error("The concrete syntax already exists");
+
+        concr = PgfDB::malloc<PgfConcr>(name->size+1);
+        concr->ref_count = 1;
+        concr->cflags = 0;
+        memcpy(&concr->name, name, sizeof(PgfText)+name->size+1);
+
+        Namespace<PgfConcr> concrs =
+            namespace_insert(pgf->concretes, concr);
+        namespace_release(pgf->concretes);
+        pgf->concretes = concrs;
+        return concr.as_object();
+    } PGF_API_END
+    return 0;
+}
+
+PGF_API
+PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision,
+                                    PgfText *name,
+                                    PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, WRITER_SCOPE);
+
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
+        
+        ref<PgfConcr> concr =
+            namespace_lookup(pgf->concretes, name);
+        if (concr == 0)
+            throw pgf_error("Unknown concrete syntax");
+
+        ref<PgfConcr> clone = PgfDB::malloc<PgfConcr>(name->size+1);
+        clone->ref_count = 1;
+        clone->cflags = concr->cflags;
+        memcpy(&clone->name, name, sizeof(PgfText)+name->size+1);
+
+        Namespace<PgfConcr> concrs =
+            namespace_insert(pgf->concretes, clone);
+        namespace_release(pgf->concretes);
+        pgf->concretes = concrs;
+        return clone.as_object();
+    } PGF_API_END
+    return 0;
+}
+
+PGF_API
+void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
+                       PgfText *name,
+                       PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, WRITER_SCOPE);
+
+        ref<PgfPGF> pgf = PgfDB::revision2pgf(revision);
+
+        Namespace<PgfConcr> concrs =
+            namespace_delete(pgf->concretes, name);
+        namespace_release(pgf->concretes);
+        pgf->concretes = concrs;
+    } PGF_API_END
+}
+
 PGF_API
 PgfLiteral pgf_get_global_flag(PgfDB *db, PgfRevision revision,
                                PgfText *name,
@@ -843,3 +1005,49 @@ void pgf_set_abstract_flag(PgfDB *db, PgfRevision revision,
         pgf->abstract.aflags = aflags;
     } PGF_API_END
 }
+
+PGF_API
+PgfLiteral pgf_get_concrete_flag(PgfDB *db, PgfConcrRevision revision,
+                                 PgfText *name,
+                                 PgfUnmarshaller *u,
+                                 PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, READER_SCOPE);
+
+        ref<PgfConcr> concr = PgfDB::revision2concr(revision);
+
+        ref<PgfFlag> flag =
+            namespace_lookup(concr->cflags, name);
+        if (flag != 0) {
+            return PgfDBMarshaller().match_lit(u, flag->value);
+        }
+    } PGF_API_END
+
+    return 0;
+}
+
+PGF_API
+void pgf_set_concrete_flag(PgfDB *db, PgfConcrRevision revision,
+                           PgfText *name,
+                           PgfLiteral value,
+                           PgfMarshaller *m,
+                           PgfExn *err)
+{
+    PGF_API_BEGIN {
+        DB_scope scope(db, WRITER_SCOPE);
+
+        PgfDBUnmarshaller u(m);
+
+        ref<PgfConcr> concr = PgfDB::revision2concr(revision);
+
+        ref<PgfFlag> flag = PgfDB::malloc<PgfFlag>(name->size+1);
+        flag->ref_count = 1;
+        memcpy(&flag->name, name, sizeof(PgfText)+name->size+1);
+        flag->value = m->match_lit(&u, value);
+        Namespace<PgfFlag> cflags =
+            namespace_insert(concr->cflags, flag);
+        namespace_release(concr->cflags);
+        concr->cflags = cflags;
+    } PGF_API_END
+}

src/runtime/c/pgf/pgf.h

@@ -85,16 +85,16 @@ typedef struct {
     const char *msg;
 } PgfExn;
 
+typedef uintptr_t object;
+
 /* A generic structure to pass a callback for iteration over a collection */
 typedef struct PgfItor PgfItor;
 
 struct PgfItor {
-	void (*fn)(PgfItor* self, PgfText* key, void *value,
+	void (*fn)(PgfItor* self, PgfText* key, object value,
 		       PgfExn *err);
 };
 
-typedef uintptr_t object;
-
 /// An abstract syntax tree
 typedef object PgfExpr;
 
@@ -219,6 +219,7 @@ typedef float prob_t;
 
 typedef struct PgfDB PgfDB;
 typedef object PgfRevision;
+typedef object PgfConcrRevision;
 
 /* Reads a PGF file and builds the database in memory.
  * If successful, *revision will contain the initial revision of
@@ -264,6 +265,9 @@ void pgf_write_pgf(const char* fpath,
 PGF_API_DECL
 void pgf_free_revision(PgfDB *pgf, PgfRevision revision);
 
+PGF_API_DECL
+void pgf_free_concr_revision(PgfDB *db, PgfConcrRevision revision);
+
 /* Returns a newly allocated text which contains the abstract name of
  * the grammar. The text must be released with a call to free.
  */
@@ -275,6 +279,10 @@ PGF_API_DECL
 void pgf_iter_categories(PgfDB *db, PgfRevision revision,
                          PgfItor *itor, PgfExn *err);
 
+PGF_API
+void pgf_iter_concretes(PgfDB *db, PgfRevision revision,
+                        PgfItor *itor, PgfExn *err);
+
 PGF_API_DECL
 PgfType pgf_start_cat(PgfDB *db, PgfRevision revision,
                       PgfUnmarshaller *u,
@@ -313,6 +321,14 @@ prob_t pgf_function_prob(PgfDB *db, PgfRevision revision,
                          PgfText *funname,
                          PgfExn* err);
 
+PGF_API_DECL
+PgfText *pgf_concrete_name(PgfDB *db, PgfConcrRevision revision,
+                           PgfExn* err);
+
+PGF_API_DECL
+PgfText *pgf_concrete_language_code(PgfDB *db, PgfConcrRevision revision,
+                                    PgfExn* err);
+
 typedef struct PgfPrintContext PgfPrintContext;
 
 struct PgfPrintContext {
@@ -387,6 +403,21 @@ void pgf_drop_category(PgfDB *db, PgfRevision revision,
                        PgfText *name,
                        PgfExn *err);
 
+PGF_API_DECL
+PgfConcrRevision pgf_create_concrete(PgfDB *db, PgfRevision revision,
+                                     PgfText *name,
+                                     PgfExn *err);
+
+PGF_API_DECL
+PgfConcrRevision pgf_clone_concrete(PgfDB *db, PgfRevision revision,
+                                    PgfText *name,
+                                    PgfExn *err);
+
+PGF_API_DECL
+void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
+                       PgfText *name,
+                       PgfExn *err);
+
 PGF_API_DECL
 PgfLiteral pgf_get_global_flag(PgfDB *db, PgfRevision revision,
                                PgfText *name,
@@ -409,5 +440,16 @@ void pgf_set_abstract_flag(PgfDB *db, PgfRevision revision,
                            PgfLiteral value,
                            PgfMarshaller *m,
                            PgfExn *err);
+PGF_API_DECL
+PgfLiteral pgf_get_concrete_flag(PgfDB *db, PgfConcrRevision revision,
+                                 PgfText *name,
+                                 PgfUnmarshaller *u,
+                                 PgfExn *err);
+PGF_API_DECL
+void pgf_set_concrete_flag(PgfDB *db, PgfConcrRevision revision,
+                           PgfText *name,
+                           PgfLiteral value,
+                           PgfMarshaller *m,
+                           PgfExn *err);
 
 #endif // PGF_H_

src/runtime/c/pgf/reader.cxx

@@ -203,10 +203,13 @@ PgfLiteral PgfReader::read_literal()
 		break;
 	}
 	case PgfLiteralInt::tag: {
+        size_t size = read_len();
 		ref<PgfLiteralInt> lit_int =
-			PgfDB::malloc<PgfLiteralInt>(sizeof(uintmax_t));
+			PgfDB::malloc<PgfLiteralInt>(sizeof(uintmax_t)*size);
-        lit_int->size   = 1;
+        lit_int->size   = size;
-		lit_int->val[0] = read_int();
+        for (size_t i = 0; i < size; i++) {
+            lit_int->val[i] = (uintmax_t) read_uint();
+        }
         lit = ref<PgfLiteralInt>::tagged(lit_int);
 		break;
 	}
@@ -428,6 +431,14 @@ void PgfReader::read_abstract(ref<PgfAbstr> abstract)
     abstract->cats = read_namespace<PgfAbsCat>(&PgfReader::read_abscat);
 }
 
+ref<PgfConcr> PgfReader::read_concrete()
+{
+    ref<PgfConcr> concr = read_name(&PgfConcr::name);
+    concr->ref_count = 1;
+	concr->cflags = read_namespace<PgfFlag>(&PgfReader::read_flag);
+    return concr;
+}
+
 ref<PgfPGF> PgfReader::read_pgf()
 {
     ref<PgfPGF> pgf = PgfDB::malloc<PgfPGF>(master_size+1);
@@ -445,6 +456,8 @@ ref<PgfPGF> PgfReader::read_pgf()
 
     read_abstract(ref<PgfAbstr>::from_ptr(&pgf->abstract));
 
+    pgf->concretes = read_namespace<PgfConcr>(&PgfReader::read_concrete);
+
     pgf->prev = 0;
     pgf->next = 0;
 

src/runtime/c/pgf/reader.h

@@ -68,6 +68,8 @@ public:
     ref<PgfAbsCat> read_abscat();
     void read_abstract(ref<PgfAbstr> abstract);
 
+    ref<PgfConcr> read_concrete();
+
     ref<PgfPGF> read_pgf();
 
 private:

src/runtime/c/pgf/writer.cxx

@@ -385,6 +385,12 @@ void PgfWriter::write_abstract(ref<PgfAbstr> abstract)
     this->abstract = 0;
 }
 
+void PgfWriter::write_concrete(ref<PgfConcr> concr)
+{
+    write_name(&concr->name);
+    write_namespace<PgfFlag>(concr->cflags, &PgfWriter::write_flag);
+}
+
 void PgfWriter::write_pgf(ref<PgfPGF> pgf)
 {
     write_u16be(pgf->major_version);
@@ -393,4 +399,5 @@ void PgfWriter::write_pgf(ref<PgfPGF> pgf)
     write_namespace<PgfFlag>(pgf->gflags, &PgfWriter::write_flag);
 
     write_abstract(ref<PgfAbstr>::from_ptr(&pgf->abstract));
+    write_namespace<PgfConcr>(pgf->concretes, &PgfWriter::write_concrete);
 }

src/runtime/c/pgf/writer.h

@@ -42,6 +42,8 @@ public:
     void write_abscat(ref<PgfAbsCat> abscat);
     void write_abstract(ref<PgfAbstr> abstract);
 
+    void write_concrete(ref<PgfConcr> concr);
+
     void write_pgf(ref<PgfPGF> pgf);
 
 private:

src/runtime/haskell/PGF2.hsc

@@ -67,7 +67,7 @@ module PGF2 (-- * PGF
              graphvizWordAlignment,
 
              -- * Concrete syntax
-             ConcName,Concr,languages,concreteName,languageCode,
+             ConcName,Concr,languages,concreteName,languageCode,concreteFlag,
 
              -- ** Linearization
              linearize, linearizeAll, tabularLinearize, tabularLinearizeAll,
@@ -115,7 +115,8 @@ readPGF fpath =
     c_db <- withPgfExn "readPGF" (pgf_read_pgf c_fpath p_revision)
     c_revision <- peek p_revision
     fptr <- C.newForeignPtr c_revision (pgf_free_revision c_db c_revision)
-    return (PGF c_db fptr Map.empty)
+    langs <- getConcretes c_db fptr
+    return (PGF c_db fptr langs)
 
 -- | Reads a PGF file and stores the unpacked data in an NGF file
 -- ready to be shared with other process, or used for quick startup.
@@ -130,7 +131,8 @@ bootNGF pgf_path ngf_path =
     c_db <- withPgfExn "bootNGF" (pgf_boot_ngf c_pgf_path c_ngf_path p_revision)
     c_revision <- peek p_revision
     fptr <- C.newForeignPtr c_revision (pgf_free_revision c_db c_revision)
-    return (PGF c_db fptr Map.empty)
+    langs <- getConcretes c_db fptr
+    return (PGF c_db fptr langs)
 
 -- | Reads the grammar from an already booted NGF file.
 -- The function fails if the file does not exist.
@@ -142,7 +144,8 @@ readNGF fpath =
     c_db <- withPgfExn "readNGF" (pgf_read_ngf c_fpath p_revision)
     c_revision <- peek p_revision
     fptr <- C.newForeignPtr c_revision (pgf_free_revision c_db c_revision)
-    return (PGF c_db fptr Map.empty)
+    langs <- getConcretes c_db fptr
+    return (PGF c_db fptr langs)
 
 -- | Creates a new NGF file with a grammar with the given abstract_name.
 -- Aside from the name, the grammar is otherwise empty but can be later
@@ -162,7 +165,7 @@ newNGF abs_name mb_fpath =
 writePGF :: FilePath -> PGF -> IO ()
 writePGF fpath p =
   withCString fpath $ \c_fpath ->
-  withForeignPtr (revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision ->
     withPgfExn "writePGF" (pgf_write_pgf c_fpath (a_db p) c_revision)
 
 showPGF :: PGF -> String
@@ -173,7 +176,7 @@ showPGF = error "TODO: showPGF"
 abstractName :: PGF -> AbsName
 abstractName p =
   unsafePerformIO $
-  withForeignPtr (revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision ->
   bracket (withPgfExn "abstractName" (pgf_abstract_name (a_db p) c_revision)) free $ \c_text ->
     peekText c_text
 
@@ -186,7 +189,7 @@ startCat :: PGF -> Type
 startCat p =
   unsafePerformIO $
   withForeignPtr unmarshaller $ \u ->
-  withForeignPtr (revision p) $ \c_revision -> do
+  withForeignPtr (a_revision p) $ \c_revision -> do
     c_typ <- withPgfExn "startCat" (pgf_start_cat (a_db p) c_revision u)
     typ <- deRefStablePtr c_typ
     freeStablePtr c_typ
@@ -197,7 +200,7 @@ functionType :: PGF -> Fun -> Maybe Type
 functionType p fn =
   unsafePerformIO $
   withForeignPtr unmarshaller $ \u ->
-  withForeignPtr (revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision ->
   withText fn $ \c_fn -> do
     c_typ <- withPgfExn "functionType" (pgf_function_type (a_db p) c_revision c_fn u)
     if c_typ == castPtrToStablePtr nullPtr
@@ -210,7 +213,7 @@ functionIsConstructor :: PGF -> Fun -> Bool
 functionIsConstructor p fun =
   unsafePerformIO $
   withText fun $ \c_fun ->
-  withForeignPtr (revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision ->
       do res <- withPgfExn "functionIsConstructor" (pgf_function_is_constructor (a_db p) c_revision c_fun)
          return (res /= 0)
 
@@ -218,13 +221,13 @@ functionProbability :: PGF -> Fun -> Float
 functionProbability p fun =
   unsafePerformIO $
   withText fun $ \c_fun ->
-  withForeignPtr (revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision ->
       withPgfExn "functionProbability" (pgf_function_prob (a_db p) c_revision c_fun)
 
 exprProbability :: PGF -> Expr -> Float
 exprProbability p e =
   unsafePerformIO $
-  withForeignPtr (revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision ->
   bracket (newStablePtr e) freeStablePtr $ \c_e ->
   withForeignPtr marshaller $ \m ->
     withPgfExn "exprProbability" (pgf_expr_prob (a_db p) c_revision c_e m)
@@ -248,10 +251,33 @@ compute :: PGF -> Expr -> Expr
 compute = error "TODO: compute"
 
 concreteName :: Concr -> ConcName
-concreteName c = error "TODO: concreteName"
+concreteName c =
+  unsafePerformIO $
+  withForeignPtr (c_revision c) $ \c_revision ->
+  bracket (withPgfExn "concreteName" (pgf_concrete_name (c_db c) c_revision)) free $ \c_text ->
+    peekText c_text
 
 languageCode :: Concr -> Maybe String
-languageCode c = error "TODO: languageCode"
+languageCode c =
+  unsafePerformIO $
+  withForeignPtr (c_revision c) $ \c_revision ->
+  bracket (withPgfExn "languageCode" (pgf_concrete_language_code (c_db c) c_revision)) free $ \c_text ->
+    if c_text == nullPtr
+      then return Nothing
+      else fmap Just (peekText c_text)
+
+concreteFlag :: Concr -> String -> Maybe Literal
+concreteFlag c name =
+  unsafePerformIO $
+  withText name $ \c_name ->
+  withForeignPtr (c_revision c) $ \c_revision ->
+  withForeignPtr unmarshaller $ \u -> do
+    c_lit <- withPgfExn "concreteFlag" (pgf_get_concrete_flag (c_db c) c_revision c_name u)
+    if c_lit == castPtrToStablePtr nullPtr
+      then return Nothing
+      else do lit <- deRefStablePtr c_lit
+              freeStablePtr c_lit
+              return (Just lit)
 
 printName :: Concr -> Fun -> Maybe String
 printName lang fun = error "TODO: printName"
@@ -492,14 +518,14 @@ categories p =
     ref <- newIORef []
     (allocaBytes (#size PgfItor) $ \itor ->
      bracket (wrapItorCallback (getCategories ref)) freeHaskellFunPtr $ \fptr ->
-     withForeignPtr (revision p) $ \c_revision -> do
+     withForeignPtr (a_revision p) $ \c_revision -> do
       (#poke PgfItor, fn) itor fptr
       withPgfExn "categories" (pgf_iter_categories (a_db p) c_revision itor)
       cs <- readIORef ref
       return (reverse cs))
   where
     getCategories :: IORef [String] -> ItorCallback
-    getCategories ref itor key exn = do
+    getCategories ref itor key _ exn = do
       names <- readIORef ref
       name  <- peekText key
       writeIORef ref $ (name : names)
@@ -510,7 +536,7 @@ categoryContext p cat =
   withText cat $ \c_cat ->
   alloca $ \p_n_hypos ->
   withForeignPtr unmarshaller $ \u ->
-  withForeignPtr (revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision ->
   mask_ $ do
     c_hypos <- withPgfExn "categoryContext" (pgf_category_context (a_db p) c_revision c_cat p_n_hypos u)
     if c_hypos == nullPtr
@@ -537,7 +563,7 @@ categoryProbability :: PGF -> Cat -> Float
 categoryProbability p cat =
   unsafePerformIO $
   withText cat $ \c_cat ->
-  withForeignPtr (revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision ->
       withPgfExn "categoryProbability" (pgf_category_prob (a_db p) c_revision c_cat)
 
 -- | List of all functions defined in the abstract syntax
@@ -547,14 +573,14 @@ functions p =
     ref <- newIORef []
     (allocaBytes (#size PgfItor) $ \itor ->
      bracket (wrapItorCallback (getFunctions ref)) freeHaskellFunPtr $ \fptr ->
-     withForeignPtr (revision p) $ \c_revision -> do
+     withForeignPtr (a_revision p) $ \c_revision -> do
       (#poke PgfItor, fn) itor fptr
       withPgfExn "functions" (pgf_iter_functions (a_db p) c_revision itor)
       fs <- readIORef ref
       return (reverse fs))
   where
     getFunctions :: IORef [String] -> ItorCallback
-    getFunctions ref itor key exn = do
+    getFunctions ref itor key _ exn = do
       names <- readIORef ref
       name  <- peekText key
       writeIORef ref $ (name : names)
@@ -567,14 +593,14 @@ functionsByCat p cat =
     (withText cat $ \c_cat ->
      allocaBytes (#size PgfItor) $ \itor ->
      bracket (wrapItorCallback (getFunctions ref)) freeHaskellFunPtr $ \fptr ->
-     withForeignPtr (revision p) $ \c_revision -> do
+     withForeignPtr (a_revision p) $ \c_revision -> do
       (#poke PgfItor, fn) itor fptr
       withPgfExn "functionsByCat" (pgf_iter_functions_by_cat (a_db p) c_revision c_cat itor)
       fs <- readIORef ref
       return (reverse fs))
   where
     getFunctions :: IORef [String] -> ItorCallback
-    getFunctions ref itor key exn = do
+    getFunctions ref itor key _ exn = do
       names <- readIORef ref
       name  <- peekText key
       writeIORef ref $ (name : names)
@@ -583,7 +609,7 @@ globalFlag :: PGF -> String -> Maybe Literal
 globalFlag p name =
   unsafePerformIO $
   withText name $ \c_name ->
-  withForeignPtr (revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision ->
   withForeignPtr unmarshaller $ \u -> do
     c_lit <- withPgfExn "globalFlag" (pgf_get_global_flag (a_db p) c_revision c_name u)
     if c_lit == castPtrToStablePtr nullPtr
@@ -596,7 +622,7 @@ abstractFlag :: PGF -> String -> Maybe Literal
 abstractFlag p name =
   unsafePerformIO $
   withText name $ \c_name ->
-  withForeignPtr (revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision ->
   withForeignPtr unmarshaller $ \u -> do
     c_lit <- withPgfExn "abstractFlag" (pgf_get_abstract_flag (a_db p) c_revision c_name u)
     if c_lit == castPtrToStablePtr nullPtr

src/runtime/haskell/PGF2/FFI.hsc

@@ -6,10 +6,12 @@ import GHC.Exts
 import GHC.Prim
 import GHC.Integer.Logarithms
 import Data.Word
+import Data.IORef
 import Data.Typeable
 import Foreign
 import Foreign.C
 import Foreign.Ptr
+import qualified Foreign.Concurrent as C
 import qualified Data.Map as Map
 import Control.Exception(Exception,bracket,mask_,throwIO)
 import System.IO.Unsafe(unsafePerformIO)
@@ -24,10 +26,10 @@ type ConcName = String -- ^ Name of concrete syntax
 -- | An abstract data type representing multilingual grammar
 -- in Portable Grammar Format.
 data PGF = PGF { a_db       :: Ptr PgfDB
-               , revision :: ForeignPtr PgfRevision
+               , a_revision :: ForeignPtr (PgfRevision PGF)
-               , languages:: Map.Map ConcName Concr
+               , languages  :: Map.Map ConcName Concr
                }
-data Concr = Concr {c_pgf :: Ptr PgfDB, concr :: Ptr PgfConcr}
+data Concr = Concr {c_db :: Ptr PgfDB, c_revision :: ForeignPtr (PgfRevision Concr)}
 
 ------------------------------------------------------------------
 -- libpgf API
@@ -36,9 +38,8 @@ data PgfExn
 data PgfText
 data PgfItor
 data PgfDB
-data PgfRevision
+data PgfRevision a
 data PgfPrintContext
-data PgfConcr
 data PgfTypeHypo
 data PgfMarshaller
 data PgfUnmarshaller
@@ -50,23 +51,24 @@ foreign import ccall unsafe "pgf_utf8_encode"
   pgf_utf8_encode :: Word32 -> Ptr CString -> IO ()
 
 foreign import ccall "pgf_read_pgf"
-  pgf_read_pgf :: CString -> Ptr (Ptr PgfRevision) -> Ptr PgfExn -> IO (Ptr PgfDB)
+  pgf_read_pgf :: CString -> Ptr (Ptr (PgfRevision PGF)) -> Ptr PgfExn -> IO (Ptr PgfDB)
 
 foreign import ccall "pgf_boot_ngf"
-  pgf_boot_ngf :: CString -> CString -> Ptr (Ptr PgfRevision) -> Ptr PgfExn -> IO (Ptr PgfDB)
+  pgf_boot_ngf :: CString -> CString -> Ptr (Ptr (PgfRevision PGF)) -> Ptr PgfExn -> IO (Ptr PgfDB)
 
 foreign import ccall "pgf_read_ngf"
-  pgf_read_ngf :: CString -> Ptr (Ptr PgfRevision) -> Ptr PgfExn -> IO (Ptr PgfDB)
+  pgf_read_ngf :: CString -> Ptr (Ptr (PgfRevision PGF)) -> Ptr PgfExn -> IO (Ptr PgfDB)
 
-foreign import ccall pgf_new_ngf :: Ptr PgfText -> CString -> Ptr (Ptr PgfRevision) -> Ptr PgfExn -> IO (Ptr PgfDB)
+foreign import ccall pgf_new_ngf :: Ptr PgfText -> CString -> Ptr (Ptr (PgfRevision PGF)) -> Ptr PgfExn -> IO (Ptr PgfDB)
 
-foreign import ccall pgf_write_pgf :: CString -> Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_write_pgf :: CString -> Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfExn -> IO ()
 
-foreign import ccall "pgf_free_revision"
+foreign import ccall pgf_free_revision :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> IO ()
-  pgf_free_revision :: Ptr PgfDB -> Ptr PgfRevision -> IO ()
+
+foreign import ccall pgf_free_concr_revision :: Ptr PgfDB -> Ptr (PgfRevision Concr) -> IO ()
 
 foreign import ccall "pgf_abstract_name"
-  pgf_abstract_name :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO (Ptr PgfText)
+  pgf_abstract_name :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfExn -> IO (Ptr PgfText)
 
 foreign import ccall "pgf_print_expr"
   pgf_print_expr :: StablePtr Expr -> Ptr PgfPrintContext -> CInt -> Ptr PgfMarshaller -> IO (Ptr PgfText)
@@ -84,61 +86,77 @@ foreign import ccall pgf_print_context :: CSize -> Ptr PgfTypeHypo -> Ptr PgfPri
 foreign import ccall "pgf_read_type"
   pgf_read_type :: Ptr PgfText -> Ptr PgfUnmarshaller -> IO (StablePtr Type)
 
-type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr PgfExn -> IO ()
+type ItorCallback = Ptr PgfItor -> Ptr PgfText -> Ptr () -> Ptr PgfExn -> IO ()
 
 foreign import ccall "wrapper"
   wrapItorCallback :: ItorCallback -> IO (FunPtr ItorCallback)
 
 foreign import ccall "pgf_iter_categories"
-  pgf_iter_categories :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfItor -> Ptr PgfExn -> IO ()
+  pgf_iter_categories :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfItor -> Ptr PgfExn -> IO ()
+
+foreign import ccall pgf_iter_concretes :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfItor -> Ptr PgfExn -> IO ()
 
 foreign import ccall "pgf_start_cat"
-  pgf_start_cat :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
+  pgf_start_cat :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
 
 foreign import ccall "pgf/pgf.h pgf_category_context"
-  pgf_category_context :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr CSize -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfTypeHypo)
+  pgf_category_context :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr CSize -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (Ptr PgfTypeHypo)
 
 foreign import ccall "pgf/pgf.h pgf_category_prob"
-  pgf_category_prob :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
+  pgf_category_prob :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
 
 foreign import ccall "pgf_iter_functions"
-  pgf_iter_functions :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfItor -> Ptr PgfExn -> IO ()
+  pgf_iter_functions :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfItor -> Ptr PgfExn -> IO ()
 
 foreign import ccall "pgf_iter_functions_by_cat"
-  pgf_iter_functions_by_cat :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfItor -> Ptr PgfExn -> IO ()
+  pgf_iter_functions_by_cat :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfItor -> Ptr PgfExn -> IO ()
 
 foreign import ccall "pgf_function_type"
-   pgf_function_type :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
+   pgf_function_type :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Type)
 
 foreign import ccall "pgf_function_is_constructor"
-   pgf_function_is_constructor :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO (#type int)
+   pgf_function_is_constructor :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (#type int)
 
 foreign import ccall "pgf_function_prob"
-   pgf_function_prob :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
+   pgf_function_prob :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (#type prob_t)
 
-foreign import ccall pgf_expr_prob :: Ptr PgfDB -> Ptr PgfRevision -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfExn -> IO (#type prob_t)
+foreign import ccall pgf_concrete_name :: Ptr PgfDB -> Ptr (PgfRevision Concr) -> Ptr PgfExn -> IO (Ptr PgfText)
 
-foreign import ccall pgf_clone_revision :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PgfRevision)
+foreign import ccall pgf_concrete_language_code :: Ptr PgfDB -> Ptr (PgfRevision Concr) -> Ptr PgfExn -> IO (Ptr PgfText)
 
-foreign import ccall pgf_commit_revision :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_expr_prob :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> StablePtr Expr -> Ptr PgfMarshaller -> Ptr PgfExn -> IO (#type prob_t)
 
-foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr PgfRevision)
+foreign import ccall pgf_clone_revision :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr (PgfRevision PGF))
 
-foreign import ccall pgf_create_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Type -> CSize -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_commit_revision :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_drop_function :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_checkout_revision :: Ptr PgfDB -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr (PgfRevision PGF))
 
-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_create_function :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> StablePtr Type -> CSize -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_drop_function :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_get_global_flag :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal)
+foreign import ccall pgf_create_category :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> CSize -> Ptr PgfTypeHypo -> (#type prob_t) -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_set_global_flag :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_drop_category :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO ()
 
-foreign import ccall pgf_get_abstract_flag :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal)
+foreign import ccall pgf_create_concrete :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr (PgfRevision Concr))
 
-foreign import ccall pgf_set_abstract_flag :: Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
+foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO (Ptr (PgfRevision Concr))
+
+foreign import ccall pgf_drop_concrete :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO ()
+
+foreign import ccall pgf_get_global_flag :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal)
+
+foreign import ccall pgf_set_global_flag :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
+
+foreign import ccall pgf_get_abstract_flag :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal)
+
+foreign import ccall pgf_set_abstract_flag :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
+
+foreign import ccall pgf_get_concrete_flag :: Ptr PgfDB -> Ptr (PgfRevision Concr) -> Ptr PgfText -> Ptr PgfUnmarshaller -> Ptr PgfExn -> IO (StablePtr Literal)
+
+foreign import ccall pgf_set_concrete_flag :: Ptr PgfDB -> Ptr (PgfRevision Concr) -> Ptr PgfText -> StablePtr Literal -> Ptr PgfMarshaller -> Ptr PgfExn -> IO ()
 
 -----------------------------------------------------------------------
 -- Texts
@@ -581,3 +599,19 @@ withHypos hypos f =
       (#peek PgfTypeHypo, type) ptr >>= freeStablePtr
       freeHypos (n-1) (ptr `plusPtr` (#size PgfTypeHypo))
 
+getConcretes c_db c_revision = do
+  ref <- newIORef Map.empty
+  (withForeignPtr c_revision $ \c_revision ->
+   allocaBytes (#size PgfItor) $ \itor ->
+   bracket (wrapItorCallback (getConcretes ref)) freeHaskellFunPtr $ \fptr -> do
+     (#poke PgfItor, fn) itor fptr
+     withPgfExn "getConcretes" (pgf_iter_concretes c_db c_revision itor)
+     readIORef ref)
+  where
+    getConcretes :: IORef (Map.Map ConcName Concr) -> ItorCallback
+    getConcretes ref itor key c_revision exn = do
+      print 1
+      concrs <- readIORef ref
+      name  <- peekText key
+      fptr <- C.newForeignPtr (castPtr c_revision) (pgf_free_concr_revision c_db (castPtr c_revision))
+      writeIORef ref (Map.insert name (Concr c_db fptr) concrs)

src/runtime/haskell/PGF2/Transactions.hsc

@@ -9,8 +9,11 @@ module PGF2.Transactions
           , dropFunction
           , createCategory
           , dropCategory
+          , createConcrete
+          , dropConcrete
           , setGlobalFlag
           , setAbstractFlag
+          , setConcreteFlag
 
             -- concrete syntax
           , Token, LIndex, LParam, Symbol(..)
@@ -26,22 +29,22 @@ import Control.Exception
 
 #include <pgf/pgf.h>
 
-newtype Transaction a =
+newtype Transaction k a =
-  Transaction (Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO a)
+  Transaction (Ptr PgfDB -> Ptr (PgfRevision k) -> Ptr PgfExn -> IO a)
 
-instance Functor Transaction where
+instance Functor (Transaction k) where
   fmap f (Transaction g) = Transaction $ \c_db c_revision c_exn -> do
     res <- g c_db c_revision c_exn
     return (f res)
 
-instance Applicative Transaction where
+instance Applicative (Transaction k) where
   pure x = Transaction $ \c_db c_revision c_exn -> return x
   f <*> g = do
     f <- f
     g <- g
     return (f g)
 
-instance Monad Transaction where
+instance Monad (Transaction k) where
   (Transaction f) >>= g = Transaction $ \c_db c_revision c_exn -> do
     res <- f c_db c_revision c_exn
     ex_type <- (#peek PgfExn, type) c_exn
@@ -65,20 +68,20 @@ instance Monad Transaction where
    both @gr1@ and @gr2@ will refer to the new grammar which contains
    the new function @foo@.
 -}
-modifyPGF :: PGF -> Transaction a -> IO PGF
+modifyPGF :: PGF -> Transaction PGF a -> IO PGF
 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 :: PGF -> String -> Transaction PGF 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_ :: Ptr PgfText -> PGF -> Transaction PGF a -> IO PGF
 branchPGF_ c_name p (Transaction f) =
-  withForeignPtr (revision p) $ \c_revision ->
+  withForeignPtr (a_revision p) $ \c_revision ->
   withPgfExn "branchPGF" $ \c_exn ->
   mask $ \restore -> do
     c_revision <- pgf_clone_revision (a_db p) c_revision c_name c_exn
@@ -95,7 +98,8 @@ branchPGF_ c_name p (Transaction f) =
                         ex_type <- (#peek PgfExn, type) c_exn
                         if (ex_type :: (#type PgfExnType)) == (#const PGF_EXN_NONE)
                           then do fptr <- C.newForeignPtr c_revision (pgf_free_revision (a_db p) c_revision)
-                                  return (PGF (a_db p) fptr (languages p))
+                                  langs <- getConcretes (a_db p) fptr
+                                  return (PGF (a_db p) fptr langs)
                           else do pgf_free_revision (a_db p) c_revision
                                   return p
                 else do pgf_free_revision (a_db p) c_revision
@@ -110,46 +114,70 @@ checkoutPGF p name =
     if c_revision == nullPtr
       then return Nothing
       else do fptr <- C.newForeignPtr c_revision (pgf_free_revision (a_db p) c_revision)
-              return (Just (PGF (a_db p) fptr (languages p)))
+              langs <- getConcretes (a_db p) fptr
+              return (Just (PGF (a_db p) fptr langs))
 
-createFunction :: Fun -> Type -> Int -> Float -> Transaction ()
+createFunction :: Fun -> Type -> Int -> Float -> Transaction PGF ()
 createFunction name ty arity prob = Transaction $ \c_db c_revision c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr ty) freeStablePtr $ \c_ty ->
   withForeignPtr marshaller $ \m -> do
     pgf_create_function c_db c_revision c_name c_ty (fromIntegral arity) prob m c_exn
 
-dropFunction :: Fun -> Transaction ()
+dropFunction :: Fun -> Transaction PGF ()
 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 :: Fun -> [Hypo] -> Float -> Transaction PGF ()
 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 :: Cat -> Transaction PGF ()
 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
 
-setGlobalFlag :: String -> Literal -> Transaction ()
+createConcrete :: ConcName -> Transaction Concr () -> Transaction PGF ()
+createConcrete name (Transaction f) = Transaction $ \c_db c_revision c_exn ->
+  withText name $ \c_name -> do
+    c_concr_revision <- pgf_create_concrete c_db c_revision c_name c_exn
+    f c_db c_concr_revision c_exn
+
+alterConcrete :: ConcName -> Transaction Concr () -> Transaction PGF ()
+alterConcrete name (Transaction f) = Transaction $ \c_db c_revision c_exn ->
+  withText name $ \c_name -> do
+    c_concr_revision <- pgf_clone_concrete c_db c_revision c_name c_exn
+    f c_db c_concr_revision c_exn
+
+dropConcrete :: ConcName -> Transaction PGF ()
+dropConcrete name = Transaction $ \c_db c_revision c_exn ->
+  withText name $ \c_name -> do
+    pgf_drop_concrete c_db c_revision c_name c_exn
+
+setGlobalFlag :: String -> Literal -> Transaction PGF ()
 setGlobalFlag name value = Transaction $ \c_db c_revision c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
   withForeignPtr marshaller $ \m ->
     pgf_set_global_flag c_db c_revision c_name c_value m c_exn
 
-setAbstractFlag :: String -> Literal -> Transaction ()
+setAbstractFlag :: String -> Literal -> Transaction PGF ()
 setAbstractFlag name value = Transaction $ \c_db c_revision c_exn ->
   withText name $ \c_name ->
   bracket (newStablePtr value) freeStablePtr $ \c_value ->
   withForeignPtr marshaller $ \m ->
     pgf_set_abstract_flag c_db c_revision c_name c_value m c_exn
 
+setConcreteFlag :: String -> Literal -> Transaction Concr ()
+setConcreteFlag name value = Transaction $ \c_db c_revision c_exn ->
+  withText name $ \c_name ->
+  bracket (newStablePtr value) freeStablePtr $ \c_value ->
+  withForeignPtr marshaller $ \m ->
+    pgf_set_concrete_flag c_db c_revision c_name c_value m c_exn
 
 type Token  = String
 type LIndex = Int