diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/compiler/GF/Command/Commands.hs | 3 | ||||
| -rw-r--r-- | src/compiler/GF/Command/TreeOperations.hs | 23 | ||||
| -rw-r--r-- | src/runtime/haskell/PGF/Expr.hs | 2 |
3 files changed, 24 insertions, 4 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) 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
|