From 0c21b85dbb54cc027a4d07b4f56f0a6b1e07a809 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Sun, 7 Sep 2025 20:44:15 +0200 Subject: [PATCH 1/4] added tabularLinearize --- src/runtime/python/pypgf.c | 57 ++++++++++++++++++++++++++++++++++++-- 1 file changed, 55 insertions(+), 2 deletions(-) diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c index 7e90c51ad..50803a58c 100644 --- a/src/runtime/python/pypgf.c +++ b/src/runtime/python/pypgf.c @@ -355,6 +355,59 @@ PgfLinearizationOutputIfaceVtbl pypgf_lin_out_iface_vtbl = (void*) pypgf_lin_out_flush }; +static PyObject* +Concr_tabularLinearize(ConcrObject* self, PyObject *args) +{ + ExprObject* pyexpr; + if (!PyArg_ParseTuple(args, "O!", &pgf_ExprType, &pyexpr)) + return NULL; + + PgfExn err; + PgfText **texts = + pgf_tabular_linearize(self->grammar->db, self->concr, (PgfExpr) pyexpr, NULL, + &marshaller, &err); + if (handleError(err) != PGF_EXN_NONE) { + return NULL; + } + + if (texts == NULL) { + Py_RETURN_NONE; + } + + PyObject *res = PyList_New(0); + if (!res) + goto fail; + + while (texts[0] != NULL && texts[1] != NULL) { + PyObject* pyfield = PyUnicode_FromStringAndSize(texts[0]->text, texts[0]->size); + free(texts[0]); texts++; + if (!pyfield) + goto fail; + + PyObject* pylin = PyUnicode_FromStringAndSize(texts[0]->text, texts[0]->size); + free(texts[0]); texts++; + if (!pylin) + goto fail; + + PyObject *tup = PyTuple_New(2); + PyTuple_SetItem(tup, 0, pyfield); + PyTuple_SetItem(tup, 1, pylin); + PyList_Append(res, tup); + Py_DECREF(tup); + } + + return res; + +fail: + Py_XDECREF(res); + + while (texts[0]) { + free(texts[0]); texts++; + } + + return NULL; +} + static PyObject* Concr_bracketedLinearize(ConcrObject* self, PyObject *args) { @@ -548,10 +601,10 @@ static PyMethodDef Concr_methods[] = { }, /*{"linearizeAll", (PyCFunction)Concr_linearizeAll, METH_VARARGS | METH_KEYWORDS, "Takes an abstract tree and linearizes with all variants" - }, + },*/ {"tabularLinearize", (PyCFunction)Concr_tabularLinearize, METH_VARARGS, "Takes an abstract tree and linearizes it to a table containing all fields" - },*/ + }, {"bracketedLinearize", (PyCFunction)Concr_bracketedLinearize, METH_VARARGS, "Takes an abstract tree and linearizes it to a bracketed string" }, From d42e351fde5f5efdf22694766e503ac8330e1859 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 9 Sep 2025 19:34:20 +0200 Subject: [PATCH 2/4] fix space leak in functionsByCat --- src/runtime/python/pypgf.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/runtime/python/pypgf.c b/src/runtime/python/pypgf.c index 50803a58c..020171991 100644 --- a/src/runtime/python/pypgf.c +++ b/src/runtime/python/pypgf.c @@ -945,8 +945,8 @@ _collect_funs(PgfItor *fn, PgfText *key, object value, PgfExn *err) if (PyList_Append((PyObject*) clo->collection, py_name) != 0) { err->type = PGF_EXN_OTHER_ERROR; - Py_DECREF(py_name); } + Py_DECREF(py_name); } static PyObject * From ae9ac01e00933e43030e5404333f71fb9e1878ae Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 16 Sep 2025 19:47:34 +0200 Subject: [PATCH 3/4] remove deprecated module --- src/compiler/api/GF/Grammar/PatternMatch.hs | 183 -------------------- src/compiler/gf.cabal | 1 - 2 files changed, 184 deletions(-) delete mode 100644 src/compiler/api/GF/Grammar/PatternMatch.hs diff --git a/src/compiler/api/GF/Grammar/PatternMatch.hs b/src/compiler/api/GF/Grammar/PatternMatch.hs deleted file mode 100644 index 53a99fe56..000000000 --- a/src/compiler/api/GF/Grammar/PatternMatch.hs +++ /dev/null @@ -1,183 +0,0 @@ ----------------------------------------------------------------------- --- | --- Module : PatternMatch --- Maintainer : AR --- Stability : (stable) --- Portability : (portable) --- --- > CVS $Date: 2005/10/12 12:38:29 $ --- > CVS $Author: aarne $ --- > CVS $Revision: 1.7 $ --- --- pattern matching for both concrete and abstract syntax. AR -- 16\/6\/2003 ------------------------------------------------------------------------------ - -module GF.Grammar.PatternMatch ( - matchPattern, - testOvershadow, - findMatch - ) where - -import GF.Data.Operations -import GF.Grammar.Grammar -import GF.Infra.Ident -import GF.Grammar.Macros ---import GF.Grammar.Printer - -import Data.Maybe(fromMaybe) -import Control.Monad -import GF.Text.Pretty ---import Debug.Trace - -matchPattern :: ErrorMonad m => [(Patt,rhs)] -> Term -> m (rhs, Substitution) -matchPattern pts term = - if not (isInConstantForm term) - then raise (render ("variables occur in" <+> pp term)) - else do - term' <- mkK term - errIn (render ("trying patterns" <+> hsep (punctuate ',' (map fst pts)))) $ - findMatch [([p],t) | (p,t) <- pts] [term'] - where - -- to capture all Str with string pattern matching - mkK s = case s of - C _ _ -> do - s' <- getS s - return (K (unwords s')) - _ -> return s - - getS s = case s of - K w -> return [w] - C v w -> liftM2 (++) (getS v) (getS w) - Empty -> return [] - _ -> raise (render ("cannot get string from" <+> s)) - -testOvershadow :: ErrorMonad m => [Patt] -> [Term] -> m [Patt] -testOvershadow pts vs = do - let numpts = zip pts [0..] - let cases = [(p,EInt i) | (p,i) <- numpts] - ts <- mapM (liftM fst . matchPattern cases) vs - return [p | (p,i) <- numpts, notElem i [i | EInt i <- ts] ] - -findMatch :: ErrorMonad m => [([Patt],rhs)] -> [Term] -> m (rhs, Substitution) -findMatch cases terms = case cases of - [] -> raise (render ("no applicable case for" <+> hsep (punctuate ',' terms))) - (patts,_):_ | length patts /= length terms -> - raise (render ("wrong number of args for patterns :" <+> hsep patts <+> - "cannot take" <+> hsep terms)) - (patts,val):cc -> case mapM tryMatch (zip patts terms) of - Ok substs -> return (val, concat substs) - _ -> findMatch cc terms - -tryMatch :: (Patt, Term) -> Err [(Ident, Term)] -tryMatch (p,t) = do - t' <- termForm t - trym p t' - where - trym p t' = - case (p,t') of --- (_,(x,Typed e ty,y)) -> trym p (x,e,y) -- Add this? /TH 2013-09-05 - (_,(x,Empty,y)) -> trym p (x,K [],y) -- because "" = [""] = [] - (PW, _) -> return [] -- optimization with wildcard - (PV x,([],K s,[])) -> return [(x,words2term (words s))] - (PV x, _) -> return [(x,t)] - (PString s, ([],K i,[])) | s==i -> return [] - (PInt s, ([],EInt i,[])) | s==i -> return [] - (PFloat s,([],EFloat i,[])) | s==i -> return [] --- rounding? - (PC p pp, ([], Con f, tt)) | - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - - (PP (q,p) pp, ([], QC (r,f), tt)) | - -- q `eqStrIdent` r && --- not for inherited AR 10/10/2005 - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - ---- hack for AppPredef bug - (PP (q,p) pp, ([], Q (r,f), tt)) | - -- q `eqStrIdent` r && --- - p `eqStrIdent` f && length pp == length tt -> - do matches <- mapM tryMatch (zip pp tt) - return (concat matches) - - (PR r, ([],R r',[])) | - all (`elem` map fst r') (map fst r) -> - do matches <- mapM tryMatch - [(p,snd a) | (l,p) <- r, let Just a = lookup l r'] - return (concat matches) - (PT _ p',_) -> trym p' t' - - (PAs x p',([],K s,[])) -> do - subst <- trym p' t' - return $ (x,words2term (words s)) : subst - - (PAs x p',_) -> do - subst <- trym p' t' - return $ (x,t) : subst - - (PAlt p1 p2,_) -> checks [trym p1 t', trym p2 t'] - - (PNeg p',_) -> case tryMatch (p',t) of - Bad _ -> return [] - _ -> raise (render ("no match with negative pattern" <+> p)) - - (PSeq min1 max1 p1 min2 max2 p2, ([],K s, [])) -> matchPSeq min1 max1 p1 min2 max2 p2 s - - (PRep _ _ p1, ([],K s, [])) -> checks [ - trym (foldr (const (PSeq 0 Nothing p1 0 Nothing)) (PString "") - [1..n]) t' | n <- [0 .. length s] - ] >> - return [] - - (PChar, ([],K [_], [])) -> return [] - (PChars cs, ([],K [c], [])) | elem c cs -> return [] - - _ -> raise (render ("no match in case expr for" <+> t)) - - words2term [] = Empty - words2term [w] = K w - words2term (w:ws) = C (K w) (words2term ws) - -matchPSeq min1 max1 p1 min2 max2 p2 s = - do let n = length s - lo = min1 `max` (n-fromMaybe n max2) - hi = (n-min2) `min` (fromMaybe n max1) - cuts = [splitAt i s | i <- [lo..hi]] - matches <- checks [mapM tryMatch [(p1,K s1),(p2,K s2)] | (s1,s2) <- cuts] - return (concat matches) - -isInConstantForm :: Term -> Bool -isInConstantForm trm = case trm of - Cn _ -> True - Con _ -> True - Q _ -> True - QC _ -> True - Abs _ _ _ -> True - C c a -> isInConstantForm c && isInConstantForm a - App c a -> isInConstantForm c && isInConstantForm a - R r -> all (isInConstantForm . snd . snd) r - K _ -> True - Empty -> True - EInt _ -> True - V ty ts -> isInConstantForm ty && all isInConstantForm ts -- TH 2013-09-05 --- Typed e t-> isInConstantForm e && isInConstantForm t -- Add this? TH 2013-09-05 - - _ -> False ---- isInArgVarForm trm -{- -- unused and suspicuous, see contP in GF.Compile.Compute.Concrete instead -varsOfPatt :: Patt -> [Ident] -varsOfPatt p = case p of - PV x -> [x] - PC _ ps -> concat $ map varsOfPatt ps - PP _ ps -> concat $ map varsOfPatt ps - PR r -> concat $ map (varsOfPatt . snd) r - PT _ q -> varsOfPatt q - _ -> [] - --- | to search matching parameter combinations in tables -isMatchingForms :: [Patt] -> [Term] -> Bool -isMatchingForms ps ts = all match (zip ps ts') where - match (PC c cs, (Cn d, ds)) = c == d && isMatchingForms cs ds - match _ = True - ts' = map appForm ts - --} diff --git a/src/compiler/gf.cabal b/src/compiler/gf.cabal index a4f6bd7cf..e79a7fdad 100644 --- a/src/compiler/gf.cabal +++ b/src/compiler/gf.cabal @@ -146,7 +146,6 @@ library GF.Grammar.Lookup GF.Grammar.Macros GF.Grammar.Parser - GF.Grammar.PatternMatch GF.Grammar.Predef GF.Grammar.Printer GF.Grammar.ShowTerm From cd5ef68b4da595c2b19aa767dfb49924212923f4 Mon Sep 17 00:00:00 2001 From: Krasimir Angelov Date: Tue, 16 Sep 2025 19:52:04 +0200 Subject: [PATCH 4/4] Variants is a functor --- .../api/GF/Compile/Compute/Concrete2.hs | 50 +++++++++---------- 1 file changed, 25 insertions(+), 25 deletions(-) diff --git a/src/compiler/api/GF/Compile/Compute/Concrete2.hs b/src/compiler/api/GF/Compile/Compute/Concrete2.hs index 3cfb3f772..1af64bf83 100644 --- a/src/compiler/api/GF/Compile/Compute/Concrete2.hs +++ b/src/compiler/api/GF/Compile/Compute/Concrete2.hs @@ -3,7 +3,7 @@ module GF.Compile.Compute.Concrete2 (Env, Scope, Value(..), Variants(..), OptionInfo(..), ConstValue(..), Globals(..), PredefTable, EvalM, - mapVariants, mapVariantsC, unvariants, + mapVariantsC, unvariants, runEvalM, runEvalMWithInput, stdPredef, globals, PredefImpl, Predef(..), ($\), pdCanonicalArgs, pdArity, @@ -97,9 +97,9 @@ data Variants a = VarFree [a] | VarOpts Value [(Value, a)] -mapVariants :: (a -> b) -> Variants a -> Variants b -mapVariants f (VarFree vs) = VarFree (f <$> vs) -mapVariants f (VarOpts n cs) = VarOpts n (second f <$> cs) +instance Functor Variants where + fmap f (VarFree vs) = VarFree (f <$> vs) + fmap f (VarOpts n cs) = VarOpts n (second f <$> cs) mapVariantsC :: (Choice -> a -> b) -> Choice -> Variants a -> Variants b mapVariantsC f c (VarFree vs) = VarFree (mapC f c vs) @@ -139,7 +139,7 @@ data ConstValue a instance Functor ConstValue where fmap f (Const c) = Const (f c) - fmap f (CFV i vs) = CFV i (mapVariants (fmap f) vs) + fmap f (CFV i vs) = CFV i (fmap (fmap f) vs) fmap f (CSusp i k) = CSusp i (fmap f . k) fmap f RunTime = RunTime fmap f NonExist = NonExist @@ -148,8 +148,8 @@ instance Applicative ConstValue where pure = Const (Const f) <*> (Const x) = Const (f x) - (CFV s vs) <*> v2 = CFV s (mapVariants (<*> v2) vs) - v1 <*> (CFV s vs) = CFV s (mapVariants (v1 <*>) vs) + (CFV s vs) <*> v2 = CFV s (fmap (<*> v2) vs) + v1 <*> (CFV s vs) = CFV s (fmap (v1 <*>) vs) (CSusp i k) <*> v2 = CSusp i (\v -> k v <*> v2) v1 <*> (CSusp i k) = CSusp i (\v -> v1 <*> k v) NonExist <*> _ = NonExist @@ -192,7 +192,7 @@ eval g env s (P t lbl) vs = let project (VR as) = case lookup lbl a Nothing -> VError ("Missing value for label" <+> pp lbl $$ "in" <+> pp (P t lbl)) Just v -> apply g v vs - project (VFV s fvs) = VFV s (mapVariants project fvs) + project (VFV s fvs) = VFV s (fmap project fvs) project (VMeta i vs) = VSusp i (\v -> project (apply g v vs)) [] project (VSusp i k vs) = VSusp i (\v -> project (apply g (k v) vs)) [] project v = VP v lbl vs @@ -201,8 +201,8 @@ eval g env s (ExtR t1 t2) [] = let (s1,s2) = split s extend (VR as1) (VR as2) = VR (foldl (\as (lbl,v) -> update lbl v as) as1 as2) extend (VRecType as1 e1) (VRecType as2 e2)=VRecType (foldl (\as (lbl,o,v) -> update3 lbl o v as) as1 as2) (e1 || e2) - extend (VFV i fvs) v2 = VFV i (mapVariants (`extend` v2) fvs) - extend v1 (VFV i fvs) = VFV i (mapVariants (v1 `extend`) fvs) + extend (VFV i fvs) v2 = VFV i (fmap (`extend` v2) fvs) + extend v1 (VFV i fvs) = VFV i (fmap (v1 `extend`) fvs) extend (VMeta i vs) v2 = VSusp i (\v -> extend (apply g v vs) v2) [] extend v1 (VMeta i vs) = VSusp i (\v -> extend v1 (apply g v vs)) [] extend (VSusp i k vs) v2 = VSusp i (\v -> extend (apply g (k v) vs) v2) [] @@ -230,7 +230,7 @@ eval g env s (S t1 t2) vs = let (!s1,!s2) = split s Success tys ws -> case tys of [ty] -> vtableSelect g v0 ty tvs v2 vs tys -> vtableSelect g v0 (FV (reverse tys)) tvs v2 vs - select (VFV i fvs) = VFV i (mapVariants select fvs) + select (VFV i fvs) = VFV i (fmap select fvs) select (VMeta i vs) = VSusp i (\v -> select (apply g v vs)) [] select (VSusp i k vs) = VSusp i (\v -> select (apply g (k v) vs)) [] select v1 = v0 @@ -253,8 +253,8 @@ eval g env s (C t1 t2) [] = let (!s1,!s2) = split s concat v1 VEmpty = v1 concat VEmpty v2 = v2 - concat (VFV i fvs) v2 = VFV i (mapVariants (`concat` v2) fvs) - concat v1 (VFV i fvs) = VFV i (mapVariants (v1 `concat`) fvs) + concat (VFV i fvs) v2 = VFV i (fmap (`concat` v2) fvs) + concat v1 (VFV i fvs) = VFV i (fmap (v1 `concat`) fvs) concat (VMeta i vs) v2 = VSusp i (\v -> concat (apply g v vs) v2) [] concat v1 (VMeta i vs) = VSusp i (\v -> concat v1 (apply g v vs)) [] concat (VSusp i k vs) v2 = VSusp i (\v -> concat (apply g (k v) vs) v2) [] @@ -276,8 +276,8 @@ eval g env s (Glue t1 t2) [] = let (!s1,!s2) = split s glue v (VAlts d vas) = VAlts (glue v d) [(glue v v',ss) | (v',ss) <- vas] glue (VAlts d vas) (VStr s) = pre d vas s glue (VAlts d vas) v = glue d v - glue (VFV i fvs) v2 = VFV i (mapVariants (`glue` v2) fvs) - glue v1 (VFV i fvs) = VFV i (mapVariants (v1 `glue`) fvs) + glue (VFV i fvs) v2 = VFV i (fmap (`glue` v2) fvs) + glue v1 (VFV i fvs) = VFV i (fmap (v1 `glue`) fvs) glue (VMeta i vs) v2 = VSusp i (\v -> glue (apply g v vs) v2) [] glue v1 (VMeta i vs) = VSusp i (\v -> glue v1 (apply g v vs)) [] glue (VSusp i k vs) v2 = VSusp i (\v -> glue (apply g (k v) vs) v2) [] @@ -327,7 +327,7 @@ evalPredef g@(Gl gr pds) c n args = case Map.lookup n pds of Nothing -> VApp c (cPredef,n) args Just def -> let valueOf (Const res) = res - valueOf (CFV i vs) = VFV i (mapVariants valueOf vs) + valueOf (CFV i vs) = VFV i (fmap valueOf vs) valueOf (CSusp i k) = VSusp i (valueOf . k) [] valueOf RunTime = VApp c (cPredef,n) args valueOf NonExist = VApp c (cPredef,cNonExist) [] @@ -362,7 +362,7 @@ apply g (VApp c f@(m,n) vs0) vs | m == cPredef = evalPredef g c n (vs0++vs) | otherwise = VApp c f (vs0++vs) apply g (VGen i vs0) vs = VGen i (vs0++vs) -apply g (VFV i fvs) vs = VFV i (mapVariants (\v -> apply g v vs) fvs) +apply g (VFV i fvs) vs = VFV i (fmap (\v -> apply g v vs) fvs) apply g (VS v1 v2 vs') vs = VS v1 v2 (vs'++vs) apply g (VClosure env s (Abs b x t)) (v:vs) = eval g ((x,v):env) s t vs apply g v [] = v @@ -546,7 +546,7 @@ patternMatch g s v0 ((env0,ps,args0,t):eqs) = match env0 ps eqs args0 (p, VMeta i vs) -> VSusp i (\v -> match' env p ps eqs (apply g v vs) args) [] (p, VGen i vs) -> v0 (p, VSusp i k vs) -> VSusp i (\v -> match' env p ps eqs (apply g (k v) vs) args) [] - (p, VFV s vs) -> VFV s (mapVariants (\arg -> match' env p ps eqs arg args) vs) + (p, VFV s vs) -> VFV s (fmap (\arg -> match' env p ps eqs arg args) vs) (PP q qs, VApp c r vs) | q == r -> match env (qs++ps) eqs (vs++args) (PR pas, VR as) -> matchRec env (reverse pas) as ps eqs args @@ -605,7 +605,7 @@ vtableSelect g v0 ty cs v2 vs = where select (Const (i,_)) = cs !! i select (CSusp i k) = VSusp i (\v -> select (k v)) [] - select (CFV c vs) = VFV c (mapVariants select vs) + select (CFV c vs) = VFV c (fmap select vs) select _ = v0 value2index (VMeta i vs) ty = CSusp i (\v -> value2index (apply g v vs) ty) @@ -645,7 +645,7 @@ vtableSelect g v0 ty cs v2 vs = Gl gr _ = g value2index (VInt n) ty | Just max <- isTypeInts ty = Const (fromIntegral n,fromIntegral max+1) - value2index (VFV c vs) ty = CFV c (mapVariants (\v -> value2index v ty) vs) + value2index (VFV c vs) ty = CFV c (fmap (\v -> value2index v ty) vs) value2index v ty = RunTime @@ -1088,7 +1088,7 @@ value2string' g VEmpty b ws qs = Const (b,ws,qs) value2string' g (VC v1 v2) b ws qs = concat v1 (value2string' g v2 b ws qs) where concat v1 (Const (b,ws,qs)) = value2string' g v1 b ws qs - concat v1 (CFV c vs) = CFV c (mapVariants (concat v1) vs) + concat v1 (CFV c vs) = CFV c (fmap (concat v1) vs) concat v1 res = res value2string' g (VApp c q []) b ws qs | q == (cPredef,cNonExist) = NonExist @@ -1122,7 +1122,7 @@ value2string' g (VAlts vd vas) b ws qs = | or [startsWith s w | VStr s <- ss] = value2string' g v | otherwise = pre vd vas w value2string' g (VFV s vs) b ws qs = - CFV s (mapVariants (\v -> value2string' g v b ws qs) vs) + CFV s (fmap (\v -> value2string' g v b ws qs) vs) value2string' _ _ _ _ _ = RunTime startsWith [] _ = True @@ -1139,13 +1139,13 @@ string2value' (w:ws) = VC (VStr w) (string2value' ws) value2int g (VMeta i vs) = CSusp i (\v -> value2int g (apply g v vs)) value2int g (VSusp i k vs) = CSusp i (\v -> value2int g (apply g (k v) vs)) value2int g (VInt n) = Const n -value2int g (VFV s vs) = CFV s (mapVariants (value2int g) vs) +value2int g (VFV s vs) = CFV s (fmap (value2int g) vs) value2int g _ = RunTime value2float g (VMeta i vs) = CSusp i (\v -> value2float g (apply g v vs)) value2float g (VSusp i k vs) = CSusp i (\v -> value2float g (apply g (k v) vs)) value2float g (VFlt f) = Const f -value2float g (VFV s vs) = CFV s (mapVariants (value2float g) vs) +value2float g (VFV s vs) = CFV s (fmap (value2float g) vs) value2float g _ = RunTime value2expr g xs (VApp _ (m,f) vs) @@ -1159,7 +1159,7 @@ value2expr g xs (VClosure env s (Abs b x t)) = in fmap (EAbs b (showIdent x')) (value2expr g (x':xs) v) value2expr g xs (VInt n) = pure (ELit (LInt n)) value2expr g xs (VFlt f) = pure (ELit (LFlt f)) -value2expr g xs (VFV s vs) = CFV s (mapVariants (value2expr g xs) vs) +value2expr g xs (VFV s vs) = CFV s (fmap (value2expr g xs) vs) value2expr g xs v = fmap (ELit . LStr) (value2string g v) newtype Choice = Choice { unchoice :: Integer }