diff --git a/src/compiler/GF/Compile/GrammarToPGF.hs b/src/compiler/GF/Compile/GrammarToPGF.hs index 6590079aa..564ac75c3 100644 --- a/src/compiler/GF/Compile/GrammarToPGF.hs +++ b/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,125 +29,61 @@ 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)-} + let abs_name = mi2i am + mb_ngf_path <- + if snd (flag optLinkTargets opts) + then do let fname = maybe id () + (flag optOutputDir opts) + (fromMaybe abs_name (flag optName opts)<.>"ngf") + exists <- doesFileExist fname + if exists + then removeFile fname + else return () + putStr ("(Boot image "++fname++") ") + return (Just fname) + else do return Nothing + pgf <- newNGF abs_name mb_ngf_path + pgf <- modifyPGF pgf $ do + 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) - 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) - then do let fname = maybe id () - (flag optOutputDir opts) - (fromMaybe abs_name (flag optName opts)<.>"ngf") - exists <- doesFileExist fname - if exists - then removeFile fname - else return () - putStr ("(Boot image "++fname++") ") - return (Just fname) - else do return Nothing - gr <- newNGF abs_name mb_ngf_path - modifyPGF gr $ do - sequence_ [setAbstractFlag name value | (name,value) <- flags] - sequence_ [createCategory c ctxt p | (c,ctxt,p) <- cats] - sequence_ [createFunction f ty arity p | (f,ty,arity,_,p) <- funs] + adefs = + [((cPredefAbs,c), AbsCat (Just (L NoLoc []))) | c <- [cFloat,cInt,cString]] ++ + Look.allOrigInfos gr am + + toLogProb = realToFrac . negate . log + + cats = [(c', snd (mkContext [] cont), toLogProb (fromMaybe 0 (Map.lookup c' probs))) | + ((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c] + + funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) | + ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs, + let arity = mkArity ma mdef ty, + let bcode = mkDef gr arity mdef, + let f' = i2i f] + + funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++)) + [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs, + let (_,(_,cat),_) = GM.typeForm ty, + let f' = i2i f] where - 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))) | - ((m,c),AbsCat (Just (L _ cont))) <- adefs, let c' = i2i c] - - funs = [(f', mkType [] ty, arity, bcode, toLogProb (fromMaybe 0 (Map.lookup f' funs_probs))) | - ((m,f),AbsFun (Just (L _ ty)) ma mdef _) <- adefs, - let arity = mkArity ma mdef ty, - let bcode = mkDef gr arity mdef, - let f' = i2i f] - - funs_probs = (Map.fromList . concat . Map.elems . fmap pad . Map.fromListWith (++)) - [(i2i cat,[(i2i f,Map.lookup f' probs)]) | ((m,f),AbsFun (Just (L _ ty)) _ _ _) <- adefs, - let (_,(_,cat),_) = GM.typeForm ty, - let f' = i2i f] + pad :: [(a,Maybe Double)] -> [(a,Double)] + pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs] where - pad :: [(a,Maybe Double)] -> [(a,Double)] - pad pfs = [(f,fromMaybe deflt mb_p) | (f,mb_p) <- pfs] - where - 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 + deflt = case length [f | (f,Nothing) <- pfs] of + 0 -> 0 + n -> max 0 ((1 - sum [d | (f,Just d) <- pfs]) / fromIntegral n) - 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 diff --git a/src/runtime/c/pgf/data.cxx b/src/runtime/c/pgf/data.cxx index bffbce7f4..00db1a0a9 100644 --- a/src/runtime/c/pgf/data.cxx +++ b/src/runtime/c/pgf/data.cxx @@ -36,4 +36,10 @@ void PgfPGF::release(ref pgf) namespace_release(pgf->abstract.aflags); namespace_release(pgf->abstract.funs); namespace_release(pgf->abstract.cats); + namespace_release(pgf->concretes); +} + +void PgfConcr::release(ref concr) +{ + namespace_release(concr->cflags); } diff --git a/src/runtime/c/pgf/data.h b/src/runtime/c/pgf/data.h index 02b98a390..cdc375934 100644 --- a/src/runtime/c/pgf/data.h +++ b/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 cats; } PgfAbstr; +struct PGF_INTERNAL_DECL PgfConcr { + size_t ref_count; + Namespace cflags; + PgfText name; + + static void release(ref pgf); +}; + struct PGF_INTERNAL_DECL PgfPGF { size_t ref_count; @@ -110,7 +119,7 @@ struct PGF_INTERNAL_DECL PgfPGF { uint16_t minor_version; Namespace gflags; PgfAbstr abstract; - //PgfConcrs* concretes; + Namespace concretes; // If the revision is transient, then it is in a double-linked list // with all other transient revisions. diff --git a/src/runtime/c/pgf/db.cxx b/src/runtime/c/pgf/db.cxx index 4450c29fc..5513f0579 100644 --- a/src/runtime/c/pgf/db.cxx +++ b/src/runtime/c/pgf/db.cxx @@ -1043,6 +1043,23 @@ ref PgfDB::revision2pgf(PgfRevision revision) return pgf; } +PGF_INTERNAL +ref 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 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 pgf) { diff --git a/src/runtime/c/pgf/db.h b/src/runtime/c/pgf/db.h index 70812d273..04c4cce7c 100644 --- a/src/runtime/c/pgf/db.h +++ b/src/runtime/c/pgf/db.h @@ -85,6 +85,7 @@ public: static PGF_INTERNAL_DECL ref get_revision(PgfText *name); static PGF_INTERNAL_DECL void set_revision(ref pgf); static PGF_INTERNAL_DECL ref revision2pgf(PgfRevision revision); + static PGF_INTERNAL_DECL ref revision2concr(PgfConcrRevision revision); static PGF_INTERNAL_DECL bool is_persistant_revision(ref pgf); static PGF_INTERNAL_DECL void link_transient_revision(ref pgf); static PGF_INTERNAL_DECL void unlink_transient_revision(ref pgf); diff --git a/src/runtime/c/pgf/namespace.h b/src/runtime/c/pgf/namespace.h index fa92dd830..0811d4b37 100644 --- a/src/runtime/c/pgf/namespace.h +++ b/src/runtime/c/pgf/namespace.h @@ -480,7 +480,7 @@ void namespace_iter(Namespace 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; diff --git a/src/runtime/c/pgf/pgf.cxx b/src/runtime/c/pgf/pgf.cxx index b2f44c7b5..8ead473c7 100644 --- a/src/runtime/c/pgf/pgf.cxx +++ b/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 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 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 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 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 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 flag = + namespace_lookup(concr->cflags, language); + if (flag != 0 && + ref::get_tag(flag->value) == PgfLiteralStr::tag) { + ref lstr = ref::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::add_node_ref(pgf->abstract.cats); + new_pgf->concretes = pgf->concretes; + if (pgf->concretes != 0) + Node::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 pgf = PgfDB::revision2pgf(revision); + + ref concr = + namespace_lookup(pgf->concretes, name); + if (concr != 0) + throw pgf_error("The concrete syntax already exists"); + + concr = PgfDB::malloc(name->size+1); + concr->ref_count = 1; + concr->cflags = 0; + memcpy(&concr->name, name, sizeof(PgfText)+name->size+1); + + Namespace 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 pgf = PgfDB::revision2pgf(revision); + + ref concr = + namespace_lookup(pgf->concretes, name); + if (concr == 0) + throw pgf_error("Unknown concrete syntax"); + + ref clone = PgfDB::malloc(name->size+1); + clone->ref_count = 1; + clone->cflags = concr->cflags; + memcpy(&clone->name, name, sizeof(PgfText)+name->size+1); + + Namespace 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 pgf = PgfDB::revision2pgf(revision); + + Namespace 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 concr = PgfDB::revision2concr(revision); + + ref 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 concr = PgfDB::revision2concr(revision); + + ref flag = PgfDB::malloc(name->size+1); + flag->ref_count = 1; + memcpy(&flag->name, name, sizeof(PgfText)+name->size+1); + flag->value = m->match_lit(&u, value); + Namespace cflags = + namespace_insert(concr->cflags, flag); + namespace_release(concr->cflags); + concr->cflags = cflags; + } PGF_API_END +} diff --git a/src/runtime/c/pgf/pgf.h b/src/runtime/c/pgf/pgf.h index 7c991f440..8c3873a1e 100644 --- a/src/runtime/c/pgf/pgf.h +++ b/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_ diff --git a/src/runtime/c/pgf/reader.cxx b/src/runtime/c/pgf/reader.cxx index 5e090c154..ef3a8ea6c 100644 --- a/src/runtime/c/pgf/reader.cxx +++ b/src/runtime/c/pgf/reader.cxx @@ -203,10 +203,13 @@ PgfLiteral PgfReader::read_literal() break; } case PgfLiteralInt::tag: { + size_t size = read_len(); ref lit_int = - PgfDB::malloc(sizeof(uintmax_t)); - lit_int->size = 1; - lit_int->val[0] = read_int(); + PgfDB::malloc(sizeof(uintmax_t)*size); + lit_int->size = size; + for (size_t i = 0; i < size; i++) { + lit_int->val[i] = (uintmax_t) read_uint(); + } lit = ref::tagged(lit_int); break; } @@ -428,6 +431,14 @@ void PgfReader::read_abstract(ref abstract) abstract->cats = read_namespace(&PgfReader::read_abscat); } +ref PgfReader::read_concrete() +{ + ref concr = read_name(&PgfConcr::name); + concr->ref_count = 1; + concr->cflags = read_namespace(&PgfReader::read_flag); + return concr; +} + ref PgfReader::read_pgf() { ref pgf = PgfDB::malloc(master_size+1); @@ -445,6 +456,8 @@ ref PgfReader::read_pgf() read_abstract(ref::from_ptr(&pgf->abstract)); + pgf->concretes = read_namespace(&PgfReader::read_concrete); + pgf->prev = 0; pgf->next = 0; diff --git a/src/runtime/c/pgf/reader.h b/src/runtime/c/pgf/reader.h index 3cb097d97..c3570c85b 100644 --- a/src/runtime/c/pgf/reader.h +++ b/src/runtime/c/pgf/reader.h @@ -68,6 +68,8 @@ public: ref read_abscat(); void read_abstract(ref abstract); + ref read_concrete(); + ref read_pgf(); private: diff --git a/src/runtime/c/pgf/writer.cxx b/src/runtime/c/pgf/writer.cxx index 4a2278015..feebfb186 100644 --- a/src/runtime/c/pgf/writer.cxx +++ b/src/runtime/c/pgf/writer.cxx @@ -385,6 +385,12 @@ void PgfWriter::write_abstract(ref abstract) this->abstract = 0; } +void PgfWriter::write_concrete(ref concr) +{ + write_name(&concr->name); + write_namespace(concr->cflags, &PgfWriter::write_flag); +} + void PgfWriter::write_pgf(ref pgf) { write_u16be(pgf->major_version); @@ -393,4 +399,5 @@ void PgfWriter::write_pgf(ref pgf) write_namespace(pgf->gflags, &PgfWriter::write_flag); write_abstract(ref::from_ptr(&pgf->abstract)); + write_namespace(pgf->concretes, &PgfWriter::write_concrete); } diff --git a/src/runtime/c/pgf/writer.h b/src/runtime/c/pgf/writer.h index fa0f246ad..3fcca4483 100644 --- a/src/runtime/c/pgf/writer.h +++ b/src/runtime/c/pgf/writer.h @@ -42,6 +42,8 @@ public: void write_abscat(ref abscat); void write_abstract(ref abstract); + void write_concrete(ref concr); + void write_pgf(ref pgf); private: diff --git a/src/runtime/haskell/PGF2.hsc b/src/runtime/haskell/PGF2.hsc index 2af222f92..304ade1fd 100644 --- a/src/runtime/haskell/PGF2.hsc +++ b/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 diff --git a/src/runtime/haskell/PGF2/FFI.hsc b/src/runtime/haskell/PGF2/FFI.hsc index 76caeec29..01fae9543 100644 --- a/src/runtime/haskell/PGF2/FFI.hsc +++ b/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) @@ -23,11 +25,11 @@ 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 - , languages:: Map.Map ConcName Concr +data PGF = PGF { a_db :: Ptr PgfDB + , a_revision :: ForeignPtr (PgfRevision PGF) + , 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" - pgf_free_revision :: Ptr PgfDB -> Ptr PgfRevision -> IO () +foreign import ccall pgf_free_revision :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> 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) diff --git a/src/runtime/haskell/PGF2/Transactions.hsc b/src/runtime/haskell/PGF2/Transactions.hsc index 41c5625e4..4a073686f 100644 --- a/src/runtime/haskell/PGF2/Transactions.hsc +++ b/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 -newtype Transaction a = - Transaction (Ptr PgfDB -> Ptr PgfRevision -> Ptr PgfExn -> IO a) +newtype Transaction k 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