Unify the data model between the C runtime and the Haskell binding

This commit is contained in:
krangelov
2021-11-09 02:04:36 +01:00
parent b3ef14c39b
commit 6552bcf909
13 changed files with 118 additions and 140 deletions

View File

@@ -38,7 +38,7 @@ addPMCFG opts cwd gr cmi (id,CncFun mty@(Just (_,cat,ctxt,val)) mlin@(Just (L lo
return (id,CncFun mty mlin mprn (Just rules))
addPMCFG opts cwd gr cmi id_info = return id_info
pmcfgForm :: Grammar -> Term -> Context -> Type -> Check [PMCFGRule]
pmcfgForm :: Grammar -> Term -> Context -> Type -> Check [Production]
pmcfgForm gr t ctxt ty =
runEvalM gr $ do
((_,ms),args) <- mapAccumM (\(d,ms) (_,_,ty) -> do
@@ -51,14 +51,14 @@ pmcfgForm gr t ctxt ty =
(lins,params) <- flatten v ty ([],[])
lins <- mapM str2lin lins
(r,rs,_) <- compute params
args <- zipWithM tnk2pmcfgcat args ctxt
return (PMCFGRule (PMCFGCat r rs) args (reverse lins))
args <- zipWithM tnk2lparam args ctxt
return (Production args (LParam r rs) (reverse lins))
where
tnk2pmcfgcat tnk (_,_,ty) = do
tnk2lparam tnk (_,_,ty) = do
v <- force tnk
(_,params) <- flatten v ty ([],[])
(r,rs,_) <- compute params
return (PMCFGCat r rs)
return (PArg [] (LParam r rs))
compute [] = return (0,[],1)
compute (v:vs) = do
@@ -125,7 +125,7 @@ str2lin (VApp q [])
| q == (cPredef, cALL_CAPIT) = return [SymALL_CAPIT]
str2lin (VStr s) = return [SymKS s]
str2lin (VSymCat d r rs) = do (r, rs) <- compute r rs
return [SymCat d r rs]
return [SymCat d (LParam r rs)]
where
compute r' [] = return (r',[])
compute r' ((cnt',tnk):tnks) = do

View File

@@ -103,13 +103,17 @@ instance Binary Options where
toString (LInt n) = show n
toString (LFlt d) = show d
instance Binary PMCFGCat where
put (PMCFGCat r rs) = put (r,rs)
get = get >>= \(r,rs) -> return (PMCFGCat r rs)
instance Binary LParam where
put (LParam r rs) = put (r,rs)
get = get >>= \(r,rs) -> return (LParam r rs)
instance Binary PMCFGRule where
put (PMCFGRule res args rules) = put (res,args,rules)
get = get >>= \(res,args,rules) -> return (PMCFGRule res args rules)
instance Binary PArg where
put (PArg x y) = put (x,y)
get = get >>= \(x,y) -> return (PArg x y)
instance Binary Production where
put (Production args res rules) = put (args,res,rules)
get = get >>= \(args,res,rules) -> return (Production args res rules)
instance Binary Info where
put (AbsCat x) = putWord8 0 >> put x
@@ -312,8 +316,8 @@ instance Binary Literal where
_ -> decodingError
instance Binary Symbol where
put (SymCat d r rs) = putWord8 0 >> put (d,r,rs)
put (SymLit n l) = putWord8 1 >> put (n,l)
put (SymCat d r) = putWord8 0 >> put (d,r)
put (SymLit d r) = putWord8 1 >> put (d,r)
put (SymVar n l) = putWord8 2 >> put (n,l)
put (SymKS ts) = putWord8 3 >> put ts
put (SymKP d vs) = putWord8 4 >> put (d,vs)
@@ -325,7 +329,7 @@ instance Binary Symbol where
put SymALL_CAPIT = putWord8 10
get = do tag <- getWord8
case tag of
0 -> liftM3 SymCat get get get
0 -> liftM2 SymCat get get
1 -> liftM2 SymLit get get
2 -> liftM2 SymVar get get
3 -> liftM SymKS get

View File

@@ -64,7 +64,7 @@ module GF.Grammar.Grammar (
Location(..), L(..), unLoc, noLoc, ppLocation, ppL,
-- ** PMCFG
PMCFGCat(..), PMCFGRule(..)
LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..)
) where
import GF.Infra.Ident
@@ -74,7 +74,7 @@ import GF.Infra.Location
import GF.Data.Operations
import PGF2(BindType(..))
import PGF2.Transactions(Symbol,LIndex,LParam)
import PGF2.Transactions(LIndex,LVar,LParam(..),PArg(..),Symbol(..),Production(..))
import Data.Array.IArray(Array)
import Data.Array.Unboxed(UArray)
@@ -304,12 +304,6 @@ allConcreteModules gr =
[i | (i, m) <- modules gr, MTConcrete _ <- [mtype m], isCompleteModule m]
data PMCFGCat = PMCFGCat LIndex [(LIndex,LParam)]
deriving (Eq,Show)
data PMCFGRule = PMCFGRule PMCFGCat [PMCFGCat] [[Symbol]]
deriving (Eq,Show)
-- | the constructors are judgements in
--
-- - abstract syntax (/ABS/)
@@ -335,8 +329,8 @@ data Info =
| ResOverload [ModuleName] [(L Type,L Term)] -- ^ (/RES/) idents: modules inherited
-- judgements in concrete syntax
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [PMCFGRule]) -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [PMCFGRule]) -- ^ (/CNC/) type info added at 'TC'
| CncCat (Maybe (L Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) lindef ini'zed,
| CncFun (Maybe ([Ident],Ident,Context,Type)) (Maybe (L Term)) (Maybe (L Term)) (Maybe [Production]) -- ^ (/CNC/) type info added at 'TC'
-- indirection to module Ident
| AnyInd Bool ModuleName -- ^ (/INDIR/) the 'Bool' says if canonical

View File

@@ -25,7 +25,6 @@ module GF.Grammar.Printer
import Prelude hiding ((<>)) -- GHC 8.4.1 clash with Text.PrettyPrint
import PGF2(Literal(..))
import PGF2.Transactions(LIndex,LParam,Symbol(..))
import GF.Infra.Ident
import GF.Infra.Option
import GF.Grammar.Values
@@ -159,16 +158,18 @@ ppJudgement q (id, AnyInd cann mid) =
Internal -> "ind" <+> id <+> '=' <+> (if cann then pp "canonical" else empty) <+> mid <+> ';'
_ -> empty
ppPmcfgRule id arg_cats res_cat (PMCFGRule res args lins) =
ppPmcfgRule id arg_cats res_cat (Production args res lins) =
pp id <+> (':' <+>
(if null args
then empty
else hsep (intersperse (pp '*') (zipWith ppPmcfgCat arg_cats args)) <+> "->") <+>
else hsep (intersperse (pp '*') (zipWith ppPArg arg_cats args)) <+> "->") <+>
ppPmcfgCat res_cat res $$
'=' <+> brackets (vcat (map (hsep . map ppSymbol) lins)))
ppPmcfgCat :: Ident -> PMCFGCat -> Doc
ppPmcfgCat cat (PMCFGCat r rs) = pp cat <> parens (ppLinFun ppLParam r rs)
ppPArg cat (PArg _ p) = ppPmcfgCat cat p
ppPmcfgCat :: Ident -> LParam -> Doc
ppPmcfgCat cat p = pp cat <> parens (ppLParam p)
instance Pretty Term where pp = ppTerm Unqualified 0
@@ -365,8 +366,8 @@ ppLit (LStr s) = pp (show s)
ppLit (LInt n) = pp n
ppLit (LFlt d) = pp d
ppSymbol (SymCat d r rs)= pp '<' <> pp d <> pp ',' <> ppLinFun ppLParam r rs <> pp '>'
ppSymbol (SymLit d r) = pp '{' <> pp d <> pp ',' <> pp r <> pp '}'
ppSymbol (SymCat d r)= pp '<' <> pp d <> pp ',' <> ppLParam r <> pp '>'
ppSymbol (SymLit d r)= pp '{' <> pp d <> pp ',' <> ppLParam r <> pp '}'
ppSymbol (SymVar d r) = pp '<' <> pp d <> pp ',' <> pp '$' <> pp r <> pp '>'
ppSymbol (SymKS t) = doubleQuotes (pp t)
ppSymbol SymNE = pp "nonExist"
@@ -377,6 +378,8 @@ ppSymbol SymCAPIT = pp "CAPIT"
ppSymbol SymALL_CAPIT = pp "ALL_CAPIT"
ppSymbol (SymKP syms alts) = pp "pre" <+> braces (hsep (punctuate (pp ';') (hsep (map ppSymbol syms) : map ppAlt alts)))
ppLParam (LParam r rs) = ppLinFun ppLVar r rs
ppLinFun ppParam r rs
| r == 0 && not (null rs) = hcat (intersperse (pp '+') ( map ppTerm rs))
| otherwise = hcat (intersperse (pp '+') (pp r : map ppTerm rs))
@@ -385,7 +388,7 @@ ppLinFun ppParam r rs
| i == 1 = ppParam p
| otherwise = pp i <> pp '*' <> ppParam p
ppLParam p
ppLVar p
| i == 0 = pp (chars !! j)
| otherwise = pp (chars !! j : show i)
where

View File

@@ -112,7 +112,7 @@ struct PGF_INTERNAL_DECL PgfConcrLincat {
static void release(ref<PgfConcrLincat> lincat);
};
struct PGF_INTERNAL_DECL PgfConcrLIndex {
struct PGF_INTERNAL_DECL PgfLParam {
size_t i0;
size_t n_terms;
struct {
@@ -121,14 +121,8 @@ struct PGF_INTERNAL_DECL PgfConcrLIndex {
} terms[];
};
struct PGF_INTERNAL_DECL PgfConcrLinArg {
ref<PgfConcrLincat> lincat;
ref<PgfConcrLIndex> param;
};
struct PGF_INTERNAL_DECL PgfConcrLinRes {
ref<PgfConcrLincat> lincat;
ref<PgfConcrLIndex> param;
struct PGF_INTERNAL_DECL PgfPArg {
ref<PgfLParam> param;
};
typedef object PgfSymbol;
@@ -136,13 +130,13 @@ typedef object PgfSymbol;
struct PGF_INTERNAL_DECL PgfSymbolCat {
static const uint8_t tag = 0;
size_t d;
PgfConcrLIndex r;
PgfLParam r;
};
struct PGF_INTERNAL_DECL PgfSymbolLit {
static const uint8_t tag = 1;
size_t d;
PgfConcrLIndex r;
PgfLParam r;
};
struct PGF_INTERNAL_DECL PgfSymbolVar {
@@ -183,14 +177,12 @@ struct PGF_INTERNAL_DECL PgfSymbolALLCAPIT {
static const uint8_t tag = 10;
};
typedef PgfVector<PgfSymbol> PgfSequence;
struct PGF_INTERNAL_DECL PgfConcrLin {
size_t ref_count;
ref<PgfVector<PgfConcrLinArg>> args;
ref<PgfVector<PgfConcrLinRes>> res;
ref<PgfVector<ref<PgfSequence>>> seqs;
ref<PgfVector<PgfPArg>> args;
ref<PgfVector<ref<PgfLParam>>> res;
ref<PgfVector<ref<PgfVector<PgfSymbol>>>> seqs;
PgfText name;

View File

@@ -955,6 +955,15 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
} PGF_API_END
}
PGF_API
void pgf_create_lin(PgfDB *db, PgfConcrRevision revision,
PgfText *name, size_t n_prods, PgfExn *exn)
{
ref<PgfConcrLin> lin = PgfDB::malloc<PgfConcrLin>(name->size+1);
lin->ref_count = 1;
memcpy(&lin->name, name, sizeof(PgfText)+name->size+1);
}
PGF_API
PgfLiteral pgf_get_global_flag(PgfDB *db, PgfRevision revision,
PgfText *name,

View File

@@ -418,6 +418,10 @@ void pgf_drop_concrete(PgfDB *db, PgfRevision revision,
PgfText *name,
PgfExn *err);
PGF_API_DECL
void pgf_create_lin(PgfDB *db, PgfConcrRevision revision,
PgfText *name, size_t n_prods, PgfExn *exn);
PGF_API_DECL
PgfLiteral pgf_get_global_flag(PgfDB *db, PgfRevision revision,
PgfText *name,

View File

@@ -435,67 +435,26 @@ void PgfReader::read_abstract(ref<PgfAbstr> abstract)
abstract->cats = read_namespace<PgfAbsCat>(&PgfReader::read_abscat);
}
ref<PgfConcrLIndex> PgfReader::read_lindex()
ref<PgfLParam> PgfReader::read_lparam()
{
size_t i0 = read_int();
size_t n_terms = read_len();
ref<PgfConcrLIndex> lindex =
PgfDB::malloc<PgfConcrLIndex>(n_terms*sizeof(PgfConcrLIndex::terms[0]));
lindex->i0 = i0;
lindex->n_terms = n_terms;
ref<PgfLParam> lparam =
PgfDB::malloc<PgfLParam>(n_terms*sizeof(PgfLParam::terms[0]));
lparam->i0 = i0;
lparam->n_terms = n_terms;
for (size_t i = 0; i < n_terms; i++) {
lindex->terms[i].factor = read_int();
lindex->terms[i].var = read_int();
lparam->terms[i].factor = read_int();
lparam->terms[i].var = read_int();
}
return lindex;
return lparam;
}
void PgfReader::read_linarg(ref<PgfConcrLinArg> linarg)
void PgfReader::read_parg(ref<PgfPArg> parg)
{
size_t size = read_len();
PgfText* name = (PgfText*) alloca(sizeof(PgfText)+size+1);
name->size = size;
// If reading the extra bytes causes EOF, it is an encoding
// error, not a legitimate end of character stream.
fread(name->text, size, 1, in);
if (feof(in))
throw pgf_error("utf8 decoding error");
if (ferror(in))
throw pgf_error("an error occured while reading the grammar");
name->text[size] = 0;
linarg->lincat = namespace_lookup(this->concrete->lincats, name);
if (linarg->lincat == 0)
throw pgf_error("Encountered an unknown category");
linarg->param = read_lindex();
}
void PgfReader::read_linres(ref<PgfConcrLinRes> linres)
{
size_t size = read_len();
PgfText* name = (PgfText*) alloca(sizeof(PgfText)+size+1);
name->size = size;
// If reading the extra bytes causes EOF, it is an encoding
// error, not a legitimate end of character stream.
fread(name->text, size, 1, in);
if (feof(in))
throw pgf_error("utf8 decoding error");
if (ferror(in))
throw pgf_error("an error occured while reading the grammar");
name->text[size] = 0;
linres->lincat = namespace_lookup(this->concrete->lincats, name);
if (linres->lincat == 0)
throw pgf_error("Encountered an unknown category");
linres->param = read_lindex();
parg->param = read_lparam();
}
template<class I>
@@ -505,7 +464,7 @@ ref<I> PgfReader::read_symbol_idx()
size_t i0 = read_int();
size_t n_terms = read_len();
ref<I> sym_idx =
PgfDB::malloc<I>(n_terms*sizeof(PgfConcrLIndex::terms[0]));
PgfDB::malloc<I>(n_terms*sizeof(PgfLParam::terms[0]));
sym_idx->d = d;
sym_idx->r.i0 = i0;
sym_idx->r.n_terms = n_terms;
@@ -594,8 +553,8 @@ ref<PgfConcrLin> PgfReader::read_lin()
{
ref<PgfConcrLin> lin = read_name(&PgfConcrLin::name);
lin->ref_count = 1;
lin->args = read_vector(&PgfReader::read_linarg);
lin->res = read_vector(&PgfReader::read_linres);
lin->args = read_vector(&PgfReader::read_parg);
lin->res = read_vector(&PgfReader::read_lparam);
lin->seqs = read_vector(&PgfReader::read_seq2);
return lin;
}

View File

@@ -67,9 +67,8 @@ public:
void read_abstract(ref<PgfAbstr> abstract);
ref<PgfConcrLincat> read_lincat();
ref<PgfConcrLIndex> read_lindex();
void read_linarg(ref<PgfConcrLinArg> linarg);
void read_linres(ref<PgfConcrLinRes> linres);
ref<PgfLParam> read_lparam();
void read_parg(ref<PgfPArg> parg);
PgfSymbol read_symbol();
ref<PgfConcrLin> read_lin();
ref<PgfConcrPrintname> read_printname();
@@ -88,8 +87,9 @@ private:
void read_patt2(ref<PgfPatt> r) { *r = read_patt(); };
void read_text2(ref<ref<PgfText>> r) { *r = read_text(); };
void read_lparam(ref<ref<PgfLParam>> r) { *r = read_lparam(); };
void read_symbol2(ref<PgfSymbol> r) { *r = read_symbol(); };
void read_seq2(ref<ref<PgfSequence>> r) { *r = read_vector(&PgfReader::read_symbol2); }
void read_seq2(ref<ref<PgfVector<PgfSymbol>>> r) { *r = read_vector(&PgfReader::read_symbol2); }
template<class I>
ref<I> read_symbol_idx();

View File

@@ -391,26 +391,19 @@ void PgfWriter::write_lincat(ref<PgfConcrLincat> lincat)
write_vector(lincat->fields, &PgfWriter::write_text);
}
void PgfWriter::write_lindex(ref<PgfConcrLIndex> lindex)
void PgfWriter::write_lparam(ref<PgfLParam> lparam)
{
write_int(lindex->i0);
write_len(lindex->n_terms);
for (size_t i = 0; i < lindex->n_terms; i++) {
write_int(lindex->terms[i].factor);
write_int(lindex->terms[i].var);
write_int(lparam->i0);
write_len(lparam->n_terms);
for (size_t i = 0; i < lparam->n_terms; i++) {
write_int(lparam->terms[i].factor);
write_int(lparam->terms[i].var);
}
}
void PgfWriter::write_linarg(ref<PgfConcrLinArg> linarg)
void PgfWriter::write_parg(ref<PgfPArg> parg)
{
write_name(&linarg->lincat->name);
write_lindex(linarg->param);
}
void PgfWriter::write_linres(ref<PgfConcrLinRes> linres)
{
write_name(&linres->lincat->name);
write_lindex(linres->param);
write_lparam(parg->param);
}
void PgfWriter::write_symbol(PgfSymbol sym)
@@ -422,13 +415,13 @@ void PgfWriter::write_symbol(PgfSymbol sym)
case PgfSymbolCat::tag: {
auto sym_cat = ref<PgfSymbolCat>::untagged(sym);
write_int(sym_cat->d);
write_lindex(ref<PgfConcrLIndex>::from_ptr(&sym_cat->r));
write_lparam(ref<PgfLParam>::from_ptr(&sym_cat->r));
break;
}
case PgfSymbolLit::tag: {
auto sym_lit = ref<PgfSymbolLit>::untagged(sym);
write_int(sym_lit->d);
write_lindex(ref<PgfConcrLIndex>::from_ptr(&sym_lit->r));
write_lparam(ref<PgfLParam>::from_ptr(&sym_lit->r));
break;
}
case PgfSymbolVar::tag: {
@@ -458,7 +451,7 @@ void PgfWriter::write_symbol(PgfSymbol sym)
}
}
void PgfWriter::write_seq(ref<PgfSequence> seq)
void PgfWriter::write_seq(ref<PgfVector<PgfSymbol>> seq)
{
write_vector(seq, &PgfWriter::write_symbol);
}
@@ -466,8 +459,8 @@ void PgfWriter::write_seq(ref<PgfSequence> seq)
void PgfWriter::write_lin(ref<PgfConcrLin> lin)
{
write_name(&lin->name);
write_vector(lin->args, &PgfWriter::write_linarg);
write_vector(lin->res, &PgfWriter::write_linres);
write_vector(lin->args, &PgfWriter::write_parg);
write_vector(lin->res, &PgfWriter::write_lparam);
write_vector(lin->seqs, &PgfWriter::write_seq);
}

View File

@@ -42,11 +42,10 @@ public:
void write_abstract(ref<PgfAbstr> abstract);
void write_lincat(ref<PgfConcrLincat> lincat);
void write_lindex(ref<PgfConcrLIndex> lindex);
void write_linarg(ref<PgfConcrLinArg> linarg);
void write_linres(ref<PgfConcrLinRes> linres);
void write_lparam(ref<PgfLParam> lparam);
void write_parg(ref<PgfPArg> linarg);
void write_symbol(PgfSymbol sym);
void write_seq(ref<PgfSequence> seq);
void write_seq(ref<PgfVector<PgfSymbol>> seq);
void write_lin(ref<PgfConcrLin> lin);
void write_printname(ref<PgfConcrPrintname> printname);
@@ -60,7 +59,8 @@ private:
void write_patt(ref<PgfPatt> r) { write_patt(*r); };
void write_text(ref<ref<PgfText>> r) { write_text(&(**r)); };
void write_seq(ref<ref<PgfSequence>> r) { write_seq(*r); };
void write_lparam(ref<ref<PgfLParam>> r) { write_lparam(*r); };
void write_seq(ref<ref<PgfVector<PgfSymbol>>> r) { write_seq(*r); };
void write_symbol(ref<PgfSymbol> r) { write_symbol(*r); };
FILE *out;

View File

@@ -147,6 +147,8 @@ foreign import ccall pgf_clone_concrete :: Ptr PgfDB -> Ptr (PgfRevision PGF) ->
foreign import ccall pgf_drop_concrete :: Ptr PgfDB -> Ptr (PgfRevision PGF) -> Ptr PgfText -> Ptr PgfExn -> IO ()
foreign import ccall pgf_create_lin :: Ptr PgfDB -> Ptr (PgfRevision Concr) -> Ptr PgfText -> CSize -> 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 ()

View File

@@ -9,15 +9,18 @@ module PGF2.Transactions
, dropFunction
, createCategory
, dropCategory
, setGlobalFlag
, setAbstractFlag
-- concrete syntax
, Token, LIndex, LVar, LParam(..)
, PArg(..), Symbol(..), Production(..)
, createConcrete
, alterConcrete
, dropConcrete
, setGlobalFlag
, setAbstractFlag
, setConcreteFlag
-- concrete syntax
, Token, LIndex, LParam, Symbol(..)
, createLin
) where
import PGF2.FFI
@@ -180,11 +183,15 @@ setConcreteFlag name value = Transaction $ \c_db c_revision c_exn ->
pgf_set_concrete_flag c_db c_revision c_name c_value m c_exn
type Token = String
type LIndex = Int
type LParam = Int
type LVar = Int
data LParam = LParam {-# UNPACK #-} !LIndex [(LIndex,LVar)]
deriving (Eq,Show)
data Symbol
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex [(LIndex,LParam)]
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LIndex
= SymCat {-# UNPACK #-} !Int {-# UNPACK #-} !LParam
| SymLit {-# UNPACK #-} !Int {-# UNPACK #-} !LParam
| SymVar {-# UNPACK #-} !Int {-# UNPACK #-} !Int
| SymKS Token
| SymKP [Symbol] [([Symbol],[String])]
@@ -195,3 +202,14 @@ data Symbol
| SymCAPIT -- the special CAPIT token
| SymALL_CAPIT -- the special ALL_CAPIT token
deriving (Eq,Show)
data PArg = PArg [(LIndex,LIndex)] {-# UNPACK #-} !LParam
deriving (Eq,Show)
data Production = Production [PArg] LParam [[Symbol]]
deriving (Eq,Show)
createLin :: Fun -> [Production] -> Transaction Concr ()
createLin name rules = Transaction $ \c_db c_revision c_exn ->
withText name $ \c_name ->
pgf_create_lin c_db c_revision c_name (fromIntegral (length rules)) c_exn