msyds/gf-core
1
0
Fork 0
forked from GitHub/gf-core
Code Pull Requests Activity

Merge remote-tracking branch 'origin/master' into fix-newer-cabal

Browse Source
This commit is contained in:
Andreas Källberg
2020-09-05 21:11:12 +02:00
parent 57ce76dbc1 bca0691cb0
commit 56f94da772
12 changed files with 264 additions and 133 deletions
Download Patch File Download Diff File Expand all files Collapse all files

70
src/compiler/GF/Compile/PGFtoHaskell.hs
View File

@@ -26,50 +26,58 @@ import Data.List --(isPrefixOf, find, intersperse)
import qualified Data.Map as Map
type Prefix = String -> String
type DerivingClause = String
-- | the main function
grammar2haskell :: Options
-> String -- ^ Module name.
-> PGF
-> String
grammar2haskell opts name gr = foldr (++++) [] $
pragmas ++ haskPreamble gadt name ++ [types, gfinstances gId lexical gr'] ++ compos
grammar2haskell opts name gr = foldr (++++) [] $
pragmas ++ haskPreamble gadt name derivingClause extraImports ++
[types, gfinstances gId lexical gr'] ++ compos
where gr' = hSkeleton gr
gadt = haskellOption opts HaskellGADT
dataExt = haskellOption opts HaskellData
lexical cat = haskellOption opts HaskellLexical && isLexicalCat opts cat
gId | haskellOption opts HaskellNoPrefix = id
| otherwise = ("G"++)
pragmas | gadt = ["{-# OPTIONS_GHC -fglasgow-exts #-}","{-# LANGUAGE GADTs #-}"]
gId | haskellOption opts HaskellNoPrefix = rmForbiddenChars
| otherwise = ("G"++) . rmForbiddenChars
-- GF grammars allow weird identifier names inside '', e.g. 'VP/Object'
rmForbiddenChars = filter (`notElem` "'!#$%&*+./<=>?@\\^|-~")
pragmas | gadt = ["{-# LANGUAGE GADTs, FlexibleInstances, KindSignatures, RankNTypes, TypeSynonymInstances #-}"]
| dataExt = ["{-# LANGUAGE DeriveDataTypeable #-}"]
| otherwise = []
derivingClause
| dataExt = "deriving (Show,Data)"
| otherwise = "deriving Show"
extraImports | gadt = ["import Control.Monad.Identity",
"import Data.Monoid"]
| dataExt = ["import Data.Data"]
| otherwise = []
types | gadt = datatypesGADT gId lexical gr'
| otherwise = datatypes gId lexical gr'
| otherwise = datatypes gId derivingClause lexical gr'
compos | gadt = prCompos gId lexical gr' ++ composClass
| otherwise = []
haskPreamble gadt name =
haskPreamble gadt name derivingClause extraImports =
[
"module " ++ name ++ " where",
""
] ++
(if gadt then [
"import Control.Monad.Identity",
"import Data.Monoid"
] else []) ++
[
] ++ extraImports ++ [
"import PGF hiding (Tree)",
"----------------------------------------------------",
"-- automatic translation from GF to Haskell",
"----------------------------------------------------",
"",
"",
"class Gf a where",
" gf :: a -> Expr",
" fg :: Expr -> a",
"",
predefInst gadt "GString" "String" "unStr" "mkStr",
predefInst gadt derivingClause "GString" "String" "unStr" "mkStr",
"",
predefInst gadt "GInt" "Int" "unInt" "mkInt",
predefInst gadt derivingClause "GInt" "Int" "unInt" "mkInt",
"",
predefInst gadt "GFloat" "Double" "unFloat" "mkFloat",
predefInst gadt derivingClause "GFloat" "Double" "unFloat" "mkFloat",
"",
"----------------------------------------------------",
"-- below this line machine-generated",
@@ -77,11 +85,11 @@ haskPreamble gadt name =
""
]
predefInst gadt gtyp typ destr consr =
predefInst gadt derivingClause gtyp typ destr consr =
(if gadt
then []
else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ " deriving Show\n\n")
)
then []
else ("newtype" +++ gtyp +++ "=" +++ gtyp +++ typ +++ derivingClause ++ "\n\n")
)
++
"instance Gf" +++ gtyp +++ "where" ++++
" gf (" ++ gtyp +++ "x) =" +++ consr +++ "x" ++++
@@ -94,24 +102,24 @@ type OIdent = String
type HSkeleton = [(OIdent, [(OIdent, [OIdent])])]
datatypes :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypes gId lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId lexical)) . snd
datatypes :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (String,HSkeleton) -> String
datatypes gId derivingClause lexical = (foldr (+++++) "") . (filter (/="")) . (map (hDatatype gId derivingClause lexical)) . snd
gfinstances :: Prefix -> (OIdent -> Bool) -> (String,HSkeleton) -> String
gfinstances gId lexical (m,g) = (foldr (+++++) "") $ (filter (/="")) $ (map (gfInstance gId lexical m)) g
hDatatype :: Prefix -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
hDatatype _ _ ("Cn",_) = "" ---
hDatatype gId _ (cat,[]) = "data" +++ gId cat
hDatatype gId _ (cat,rules) | isListCat (cat,rules) =
"newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
+++ "deriving Show"
hDatatype gId lexical (cat,rules) =
hDatatype :: Prefix -> DerivingClause -> (OIdent -> Bool) -> (OIdent, [(OIdent, [OIdent])]) -> String
hDatatype _ _ _ ("Cn",_) = "" ---
hDatatype gId _ _ (cat,[]) = "data" +++ gId cat
hDatatype gId derivingClause _ (cat,rules) | isListCat (cat,rules) =
"newtype" +++ gId cat +++ "=" +++ gId cat +++ "[" ++ gId (elemCat cat) ++ "]"
+++ derivingClause
hDatatype gId derivingClause lexical (cat,rules) =
"data" +++ gId cat +++ "=" ++
(if length rules == 1 then "" else "\n ") +++
foldr1 (\x y -> x ++ "\n |" +++ y) constructors ++++
" deriving Show"
" " +++ derivingClause
where
constructors = [gId f +++ foldr (+++) "" (map (gId) xx) | (f,xx) <- nonLexicalRules (lexical cat) rules]
++ if lexical cat then [lexicalConstructor cat +++ "String"] else []

5
src/compiler/GF/Infra/Option.hs
View File

@@ -132,7 +132,7 @@ data CFGTransform = CFGNoLR
deriving (Show,Eq,Ord)
data HaskellOption = HaskellNoPrefix | HaskellGADT | HaskellLexical
| HaskellConcrete | HaskellVariants
| HaskellConcrete | HaskellVariants | HaskellData
deriving (Show,Eq,Ord)
data Warning = WarnMissingLincat
@@ -531,7 +531,8 @@ haskellOptionNames =
("gadt", HaskellGADT),
("lexical", HaskellLexical),
("concrete", HaskellConcrete),
("variants", HaskellVariants)]
("variants", HaskellVariants),
("data", HaskellData)]
-- | This is for bacward compatibility. Since GHC 6.12 we
-- started using the native Unicode support in GHC but it

175
src/runtime/c/pgf/expr.c
View File

@@ -1635,19 +1635,6 @@ pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt,
}
}
PGF_API void
pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
GuOut* out, GuExn* err)
{
gu_putc('<', out, err);
for (size_t i = 0; i < n_exprs; i++) {
if (i > 0)
gu_putc(',', out, err);
pgf_print_expr(exprs[i], ctxt, 0, out, err);
}
gu_putc('>', out, err);
}
PGF_API bool
pgf_type_eq(PgfType* t1, PgfType* t2)
{
@@ -1683,6 +1670,168 @@ pgf_type_eq(PgfType* t1, PgfType* t2)
return true;
}
PGF_API PgfLiteral
pgf_clone_literal(PgfLiteral lit, GuPool* pool)
{
PgfLiteral new_lit = gu_null_variant;
GuVariantInfo inf = gu_variant_open(lit);
switch (inf.tag) {
case PGF_LITERAL_STR: {
PgfLiteralStr* lit_str = inf.data;
PgfLiteralStr* new_lit_str =
gu_new_flex_variant(PGF_LITERAL_STR,
PgfLiteralStr,
val, strlen(lit_str->val)+1,
&new_lit, pool);
strcpy(new_lit_str->val, lit_str->val);
break;
}
case PGF_LITERAL_INT: {
PgfLiteralInt *lit_int = inf.data;
PgfLiteralInt *new_lit_int =
gu_new_variant(PGF_LITERAL_INT,
PgfLiteralInt,
&new_lit, pool);
new_lit_int->val = lit_int->val;
break;
}
case PGF_LITERAL_FLT: {
PgfLiteralFlt *lit_flt = inf.data;
PgfLiteralFlt *new_lit_flt =
gu_new_variant(PGF_LITERAL_FLT,
PgfLiteralFlt,
&new_lit, pool);
new_lit_flt->val = lit_flt->val;
break;
}
default:
gu_impossible();
}
return new_lit;
}
PGF_API PgfExpr
pgf_clone_expr(PgfExpr expr, GuPool* pool)
{
PgfExpr new_expr = gu_null_variant;
GuVariantInfo inf = gu_variant_open(expr);
switch (inf.tag) {
case PGF_EXPR_ABS: {
PgfExprAbs* abs = inf.data;
PgfExprAbs* new_abs =
gu_new_variant(PGF_EXPR_ABS,
PgfExprAbs,
&new_expr, pool);
new_abs->bind_type = abs->bind_type;
new_abs->id = gu_string_copy(abs->id, pool);
new_abs->body = pgf_clone_expr(abs->body,pool);
break;
}
case PGF_EXPR_APP: {
PgfExprApp* app = inf.data;
PgfExprApp* new_app =
gu_new_variant(PGF_EXPR_APP,
PgfExprApp,
&new_expr, pool);
new_app->fun = pgf_clone_expr(app->fun, pool);
new_app->arg = pgf_clone_expr(app->arg, pool);
break;
}
case PGF_EXPR_LIT: {
PgfExprLit* lit = inf.data;
PgfExprLit* new_lit =
gu_new_variant(PGF_EXPR_LIT,
PgfExprLit,
&new_expr, pool);
new_lit->lit = pgf_clone_literal(lit->lit, pool);
break;
}
case PGF_EXPR_META: {
PgfExprMeta* meta = inf.data;
PgfExprMeta* new_meta =
gu_new_variant(PGF_EXPR_META,
PgfExprMeta,
&new_expr, pool);
new_meta->id = meta->id;
break;
}
case PGF_EXPR_FUN: {
PgfExprFun* fun = inf.data;
PgfExprFun* new_fun =
gu_new_flex_variant(PGF_EXPR_FUN,
PgfExprFun,
fun, strlen(fun->fun)+1,
&new_expr, pool);
strcpy(new_fun->fun, fun->fun);
break;
}
case PGF_EXPR_VAR: {
PgfExprVar* var = inf.data;
PgfExprVar* new_var =
gu_new_variant(PGF_EXPR_VAR,
PgfExprVar,
&new_expr, pool);
new_var->var = var->var;
break;
}
case PGF_EXPR_TYPED: {
PgfExprTyped* typed = inf.data;
PgfExprTyped *new_typed =
gu_new_variant(PGF_EXPR_TYPED,
PgfExprTyped,
&new_expr, pool);
new_typed->expr = pgf_clone_expr(typed->expr, pool);
new_typed->type = pgf_clone_type(typed->type, pool);
break;
}
case PGF_EXPR_IMPL_ARG: {
PgfExprImplArg* impl = inf.data;
PgfExprImplArg *new_impl =
gu_new_variant(PGF_EXPR_IMPL_ARG,
PgfExprImplArg,
&new_expr, pool);
new_impl->expr = pgf_clone_expr(impl->expr, pool);
break;
}
default:
gu_impossible();
}
return new_expr;
}
PGF_API PgfType*
pgf_clone_type(PgfType* type, GuPool* pool)
{
PgfType* new_type =
gu_new_flex(pool, PgfType, exprs, type->n_exprs);
size_t n_hypos = gu_seq_length(type->hypos);
new_type->hypos = gu_new_seq(PgfHypo, n_hypos, pool);
for (size_t i = 0; i < n_hypos; i++) {
PgfHypo* hypo = gu_seq_index(type->hypos, PgfHypo, i);
PgfHypo* new_hypo = gu_seq_index(new_type->hypos, PgfHypo, i);
new_hypo->bind_type = hypo->bind_type;
new_hypo->cid = gu_string_copy(hypo->cid, pool);
new_hypo->type = pgf_clone_type(hypo->type, pool);
}
new_type->cid = gu_string_copy(type->cid, pool);
new_type->n_exprs = type->n_exprs;
for (size_t i = 0; i < new_type->n_exprs; i++) {
new_type->exprs[i] = pgf_clone_expr(type->exprs[i], pool);
}
return new_type;
}
PGF_API prob_t
pgf_compute_tree_probability(PgfPGF *gr, PgfExpr expr)
{

11
src/runtime/c/pgf/expr.h
View File

@@ -229,9 +229,14 @@ PGF_API_DECL void
pgf_print_context(PgfHypos *hypos, PgfPrintContext* ctxt,
GuOut *out, GuExn *err);
PGF_API_DECL void
pgf_print_expr_tuple(size_t n_exprs, PgfExpr exprs[], PgfPrintContext* ctxt,
GuOut* out, GuExn* err);
PGF_API PgfLiteral
pgf_clone_literal(PgfLiteral lit, GuPool* pool);
PGF_API PgfExpr
pgf_clone_expr(PgfExpr expr, GuPool* pool);
PGF_API PgfType*
pgf_clone_type(PgfType* type, GuPool* pool);
PGF_API_DECL prob_t
pgf_compute_tree_probability(PgfPGF *gr, PgfExpr expr);

12
src/runtime/haskell-bind/PGF2.hsc
View File

@@ -433,6 +433,7 @@ graphvizParseTree c opts e =
c_opts <- newGraphvizOptions tmpPl opts
pgf_graphviz_parse_tree (concr c) (expr e) c_opts out exn
touchExpr e
touchConcr c
s <- gu_string_buf_freeze sb tmpPl
peekUtf8CString s
@@ -858,16 +859,7 @@ mkCallbacksMap concr callbacks pool = do
Just (e,prob,offset') -> do poke poffset (fromIntegral offset')
-- here we copy the expression to out_pool
c_e <- withGuPool $ \tmpPl -> do
exn <- gu_new_exn tmpPl
(sb,out) <- newOut tmpPl
let printCtxt = nullPtr
pgf_print_expr (expr e) printCtxt 1 out exn
c_str <- gu_string_buf_freeze sb tmpPl
guin <- gu_string_in c_str tmpPl
pgf_read_expr guin out_pool tmpPl exn
c_e <- pgf_clone_expr (expr e) out_pool
ep <- gu_malloc out_pool (#size PgfExprProb)
(#poke PgfExprProb, expr) ep c_e

6
src/runtime/haskell-bind/PGF2/FFI.hsc
View File

@@ -513,9 +513,6 @@ foreign import ccall "pgf/expr.h pgf_compute"
foreign import ccall "pgf/expr.h pgf_print_expr"
pgf_print_expr :: PgfExpr -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/expr.h pgf_print_expr_tuple"
pgf_print_expr_tuple :: CSizeT -> Ptr PgfExpr -> Ptr PgfPrintContext -> Ptr GuOut -> Ptr GuExn -> IO ()
foreign import ccall "pgf/expr.h pgf_print_type"
pgf_print_type :: PgfType -> Ptr PgfPrintContext -> CInt -> Ptr GuOut -> Ptr GuExn -> IO ()
@@ -551,3 +548,6 @@ foreign import ccall "pgf/data.h pgf_lzr_index"
foreign import ccall "pgf/data.h pgf_production_is_lexical"
pgf_production_is_lexical :: Ptr PgfProductionApply -> Ptr GuBuf -> Ptr GuPool -> IO (#type bool)
foreign import ccall "pgf/expr.h pgf_clone_expr"
pgf_clone_expr :: PgfExpr -> Ptr GuPool -> IO PgfExpr

33
src/runtime/java/jpgf.c
View File

@@ -486,39 +486,8 @@ jpgf_literal_callback_match(PgfLiteralCallback* self, PgfConcr* concr,
PgfExprProb* ep = gu_new(PgfExprProb, out_pool);
ep->expr = gu_variant_from_ptr(get_ref(env, jexpr));
ep->expr = pgf_clone_expr(ep->expr, out_pool);
ep->prob = prob;
{
// This is an uggly hack. We first show the expression ep->expr
// and then we read it back but in out_pool. The whole purpose
// of this is to copy the expression from the temporary pool
// that was created in the Java binding to the parser pool.
// There should be a real copying function or even better
// there must be a way to avoid copying at all.
GuPool* tmp_pool = gu_local_pool();
GuExn* err = gu_exn(tmp_pool);
GuStringBuf* sbuf = gu_new_string_buf(tmp_pool);
GuOut* out = gu_string_buf_out(sbuf);
pgf_print_expr(ep->expr, NULL, 0, out, err);
GuString str = gu_string_buf_data(sbuf);
size_t len = gu_string_buf_length(sbuf);
GuIn* in = gu_data_in((uint8_t*) str, len, tmp_pool);
ep->expr = pgf_read_expr(in, out_pool, tmp_pool, err);
if (!gu_ok(err) || gu_variant_is_null(ep->expr)) {
throw_string_exception(env, "org/grammaticalframework/pgf/PGFError", "The expression cannot be parsed");
gu_pool_free(tmp_pool);
return NULL;
}
gu_pool_free(tmp_pool);
}
return ep;
}

34
src/runtime/python/pypgf.c
View File

@@ -1412,7 +1412,7 @@ pypgf_literal_callback_match(PgfLiteralCallback* self, PgfConcr* concr,
ExprObject* pyexpr;
#if PY_MAJOR_VERSION >= 3
size_t chars;
int chars;
if (!PyArg_ParseTuple(result, "Ofi", &pyexpr, &ep->prob, &chars))
return NULL;
*poffset = unicode_to_utf8_offset(sentence, chars);
@@ -1421,37 +1421,7 @@ pypgf_literal_callback_match(PgfLiteralCallback* self, PgfConcr* concr,
return NULL;
#endif
ep->expr = pyexpr->expr;
{
// This is an uggly hack. We first show the expression ep->expr
// and then we read it back but in out_pool. The whole purpose
// of this is to copy the expression from the temporary pool
// that was created in the Java binding to the parser pool.
// There should be a real copying function or even better
// there must be a way to avoid copying at all.
GuPool* tmp_pool = gu_local_pool();
GuExn* err = gu_exn(tmp_pool);
GuStringBuf* sbuf = gu_new_string_buf(tmp_pool);
GuOut* out = gu_string_buf_out(sbuf);
pgf_print_expr(ep->expr, NULL, 0, out, err);
GuIn* in = gu_data_in((uint8_t*) gu_string_buf_data(sbuf),
gu_string_buf_length(sbuf),
tmp_pool);
ep->expr = pgf_read_expr(in, out_pool, tmp_pool, err);
if (!gu_ok(err) || gu_variant_is_null(ep->expr)) {
PyErr_SetString(PGFError, "The expression cannot be parsed");
gu_pool_free(tmp_pool);
return NULL;
}
gu_pool_free(tmp_pool);
}
ep->expr = pgf_clone_expr(pyexpr->expr, out_pool);
Py_DECREF(result);