From 643617ccc4faafa659aa16fae2870ac68a8f394b Mon Sep 17 00:00:00 2001 From: Hans Leiss Date: Tue, 18 Feb 2025 12:41:14 +0100 Subject: [PATCH 1/4] Bug fix for gf-shell command 'pt -compute' in Expr.hs by tryMatch p (VConst _ _) env = match sig f eqs as0 --- src/runtime/haskell/PGF/Expr.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/runtime/haskell/PGF/Expr.hs b/src/runtime/haskell/PGF/Expr.hs index ff1114235..42c0df14e 100644 --- a/src/runtime/haskell/PGF/Expr.hs +++ b/src/runtime/haskell/PGF/Expr.hs @@ -408,7 +408,7 @@ match sig f eqs as0 = tryMatch (p ) (VMeta i envi vs ) env = VSusp i envi vs (\v -> tryMatch p v env) tryMatch (p ) (VGen i vs ) env = VConst f as0 tryMatch (p ) (VSusp i envi vs k) env = VSusp i envi vs (\v -> tryMatch p (k v) env) - tryMatch (p ) v@(VConst _ _ ) env = VConst f as0 + tryMatch (p ) v@(VConst _ _ ) env = match sig f eqs as0 tryMatch (PApp f1 ps1) (VApp f2 vs2 ) env | f1 == f2 = tryMatches eqs (ps1++ps) (vs2++as) res env tryMatch (PLit l1 ) (VLit l2 ) env | l1 == l2 = tryMatches eqs ps as res env tryMatch (PImplArg p ) (VImplArg v ) env = tryMatch p v env From 5776b567a2aa78902bf5e4b40cf0bbb69bdbde9a Mon Sep 17 00:00:00 2001 From: Hans Leiss Date: Wed, 19 Feb 2025 12:59:43 +0100 Subject: [PATCH 2/4] Reactivate the gf-shell command 'pt -transfer' --- src/compiler/GF/Command/Commands.hs | 3 ++- src/compiler/GF/Command/TreeOperations.hs | 23 +++++++++++++++++++++-- 2 files changed, 23 insertions(+), 3 deletions(-) diff --git a/src/compiler/GF/Command/Commands.hs b/src/compiler/GF/Command/Commands.hs index f31a23083..7f27e8a45 100644 --- a/src/compiler/GF/Command/Commands.hs +++ b/src/compiler/GF/Command/Commands.hs @@ -428,7 +428,8 @@ pgfCommands = Map.fromList [ "are type checking and semantic computation." ], examples = [ - mkEx "pt -compute (plus one two) -- compute value" + mkEx "pt -compute (plus one two) -- compute value", + mkEx ("p \"the 4 dogs\" | pt -transfer=digits2numeral | l -- \"the four dogs\" ") ], exec = getEnv $ \ opts arg (Env pgf mos) -> returnFromExprs . takeOptNum opts . treeOps pgf opts $ toExprs arg, diff --git a/src/compiler/GF/Command/TreeOperations.hs b/src/compiler/GF/Command/TreeOperations.hs index fc0e6616d..7497eb7e8 100644 --- a/src/compiler/GF/Command/TreeOperations.hs +++ b/src/compiler/GF/Command/TreeOperations.hs @@ -5,6 +5,8 @@ module GF.Command.TreeOperations ( ) where import PGF(Expr,PGF,CId,compute,mkApp,unApp,unapply,unMeta,exprSize,exprFunctions) +import PGF.Data(Expr(EApp,EFun)) +import PGF.TypeCheck(inferExpr) import Data.List type TreeOp = [Expr] -> [Expr] @@ -16,15 +18,17 @@ allTreeOps :: PGF -> [(String,(String,Either TreeOp (CId -> TreeOp)))] allTreeOps pgf = [ ("compute",("compute by using semantic definitions (def)", Left $ map (compute pgf))), + ("transfer",("apply this transfer function to all maximal subtrees of suitable type", + Right $ \f -> map (transfer pgf f))), -- HL 12/24, modified from gf-3.3 ("largest",("sort trees from largest to smallest, in number of nodes", Left $ largest)), - ("nub",("remove duplicate trees", + ("nub\t",("remove duplicate trees", Left $ nub)), ("smallest",("sort trees from smallest to largest, in number of nodes", Left $ smallest)), ("subtrees",("return all fully applied subtrees (stopping at abstractions), by default sorted from the largest", Left $ concatMap subtrees)), - ("funs",("return all fun functions appearing in the tree, with duplications", + ("funs\t",("return all fun functions appearing in the tree, with duplications", Left $ \es -> [mkApp f [] | e <- es, f <- exprFunctions e])) ] @@ -48,3 +52,18 @@ subtrees :: Expr -> [Expr] subtrees t = t : case unApp t of Just (f,ts) -> concatMap subtrees ts _ -> [] -- don't go under abstractions + +-- Apply transfer function f:C -> D to all maximal subtrees s:C of tree e and replace +-- these s by the values of f(s). This modifies the 'simple-minded transfer' of gf-3.3. +-- If applied to strict subtrees s of e, better use with f:C -> C only. HL 12/2024 + +transfer :: PGF -> CId -> Expr -> Expr +transfer pgf f e = case inferExpr pgf (appf e) of + Left _err -> case e of + EApp g a -> EApp (transfer pgf f g) (transfer pgf f a) + _ -> e + Right _ty -> case (compute pgf (appf e)) of + v | v /= (appf e) -> v + _ -> e -- default case of f, or f has no computation rule + where + appf = EApp (EFun f) From f5752b345a167d07b4e8565ea3b465c16ea49d7e Mon Sep 17 00:00:00 2001 From: Arianna Masciolini Date: Sat, 2 Aug 2025 19:14:09 +0200 Subject: [PATCH 3/4] fail slow --- .github/workflows/build-all-versions.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/build-all-versions.yml b/.github/workflows/build-all-versions.yml index 0f3222809..1b5ebe37d 100644 --- a/.github/workflows/build-all-versions.yml +++ b/.github/workflows/build-all-versions.yml @@ -70,6 +70,7 @@ jobs: name: stack / ghc ${{ matrix.ghc }} runs-on: ${{ matrix.ghc == '7.10.3' && 'ubuntu-20.04' || 'ubuntu-latest' }} strategy: + fail-fast: false matrix: stack: ["latest"] ghc: ["8.4.4", "8.6.5", "8.8.4", "8.10.7", "9.0.2", "9.6.6"] From 703b1e5d925a7e497f98f18b26bb16e7ca0f95b2 Mon Sep 17 00:00:00 2001 From: Arianna Masciolini Date: Sat, 2 Aug 2025 20:18:28 +0200 Subject: [PATCH 4/4] add eval.gfs to expected failures --- testsuite/run.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/testsuite/run.hs b/testsuite/run.hs index f8e6bf49f..287665fd4 100644 --- a/testsuite/run.hs +++ b/testsuite/run.hs @@ -66,6 +66,7 @@ expectedFailures = [ "testsuite/runtime/parser/parser.gfs" -- Only parses `z` as `zero` and not also as e.g. `succ zero` as expected , "testsuite/runtime/linearize/brackets.gfs" -- Missing "cannot linearize in the end" , "testsuite/compiler/typecheck/abstract/non-abstract-terms.gfs" -- Gives a different error than expected + , "testsuite/runtime/eval/eval.gfs" ] -- | Produce HTML document with test results