summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/GF/Command/Commands.hs6
-rw-r--r--src/GF/Command/TreeOperations.hs16
-rw-r--r--src/PGF.hs5
-rw-r--r--src/PGF/AbsCompute.hs106
-rw-r--r--src/PGF/Macros.hs5
5 files changed, 123 insertions, 15 deletions
diff --git a/src/GF/Command/Commands.hs b/src/GF/Command/Commands.hs
index 27ac61c81..2aa616739 100644
--- a/src/GF/Command/Commands.hs
+++ b/src/GF/Command/Commands.hs
@@ -384,7 +384,7 @@ allCommands cod pgf = Map.fromList [
"p \"foo\" | pt -typecheck -- type check parse results"
],
exec = \opts -> return . fromTrees . treeOps (map prOpt opts),
- options = treeOpOptions
+ options = treeOpOptions pgf
}),
("q", emptyCommandInfo {
longname = "quit",
@@ -608,7 +608,7 @@ allCommands cod pgf = Map.fromList [
app f = maybe id id (stringOp f)
treeOps opts s = foldr app s (reverse opts) where
- app f = maybe id id (treeOp f)
+ app f = maybe id id (treeOp pgf f)
showAsString t = case t of
Lit (LStr s) -> s
@@ -641,7 +641,7 @@ stringOpOptions = [
("words","lexer that assumes tokens separated by spaces (default)")
]
-treeOpOptions = [(op,expl) | (op,(expl,_)) <- allTreeOps]
+treeOpOptions pgf = [(op,expl) | (op,(expl,_)) <- allTreeOps pgf]
translationQuiz :: String -> PGF -> Language -> Language -> Category -> IO ()
translationQuiz cod pgf ig og cat = do
diff --git a/src/GF/Command/TreeOperations.hs b/src/GF/Command/TreeOperations.hs
index f05b8dec3..0ff6ac682 100644
--- a/src/GF/Command/TreeOperations.hs
+++ b/src/GF/Command/TreeOperations.hs
@@ -2,11 +2,10 @@ module GF.Command.TreeOperations (
treeOp,
allTreeOps
--typeCheck,
- --compute
) where
import GF.Compile.TypeCheck
-import GF.Compile.AbsCompute
+import PGF (compute)
-- for conversions
import PGF.Data
@@ -18,13 +17,13 @@ import Data.List
type TreeOp = [Tree] -> [Tree]
-treeOp :: String -> Maybe TreeOp
-treeOp f = fmap snd $ lookup f allTreeOps
+treeOp :: PGF -> String -> Maybe TreeOp
+treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
-allTreeOps :: [(String,(String,TreeOp))]
-allTreeOps = [
+allTreeOps :: PGF -> [(String,(String,TreeOp))]
+allTreeOps pgf = [
("compute",("compute by using semantic definitions (def)",
- id)),
+ map (compute pgf))),
("smallest",("sort trees from smallest to largest, in number of nodes",
smallest)),
("typecheck",("type check and solve metavariables; reject if incorrect",
@@ -34,9 +33,6 @@ allTreeOps = [
typeCheck :: PGF -> Tree -> (Tree,(Bool,[String]))
typeCheck pgf t = (t,(True,[]))
-compute :: PGF -> Tree -> Tree
-compute pgf t = t
-
smallest :: [Tree] -> [Tree]
smallest = sortBy (\t u -> compare (size t) (size u)) where
size t = case t of
diff --git a/src/PGF.hs b/src/PGF.hs
index 8c64469db..31801a54f 100644
--- a/src/PGF.hs
+++ b/src/PGF.hs
@@ -44,7 +44,7 @@ module PGF(
parse, canParse, parseAllLang, parseAll,
-- ** Evaluation
- tree2expr, expr2tree,
+ tree2expr, expr2tree, compute,
-- ** Word Completion (Incremental Parsing)
complete,
@@ -58,6 +58,7 @@ module PGF(
import PGF.CId
import PGF.Linearize
import PGF.Generate
+import PGF.AbsCompute
import PGF.Macros
import PGF.Data
import PGF.Expr
@@ -265,4 +266,4 @@ complete pgf from cat input =
tokensAndPrefix s | not (null s) && isSpace (last s) = (words s, "")
| null ws = ([],"")
| otherwise = (init ws, last ws)
- where ws = words s \ No newline at end of file
+ where ws = words s
diff --git a/src/PGF/AbsCompute.hs b/src/PGF/AbsCompute.hs
new file mode 100644
index 000000000..f38b8d952
--- /dev/null
+++ b/src/PGF/AbsCompute.hs
@@ -0,0 +1,106 @@
+----------------------------------------------------------------------
+-- |
+-- Module : AbsCompute
+-- Maintainer : AR
+-- Stability : (stable)
+-- Portability : (portable)
+--
+-- computation in abstract syntax with def definitions.
+--
+-- modified from src GF computation
+-----------------------------------------------------------------------------
+
+module PGF.AbsCompute (
+ compute
+ ) where
+
+import PGF.Data
+import PGF.Macros (lookDef,isData)
+import PGF.Expr
+import PGF.CId
+
+compute :: PGF -> Tree -> Tree
+compute pgf = computeAbsTermIn pgf []
+
+computeAbsTermIn :: PGF -> [CId] -> Tree -> Tree
+computeAbsTermIn pgf vv = expr2tree . compt vv . tree2expr where
+ compt vv t =
+ let
+ t' = beta vv t
+ (yy,f,aa) = exprForm t'
+ vv' = yy ++ vv
+ aa' = map (compt vv') aa
+ in
+ mkAbs yy $ case look f of
+ Left (EEq eqs) -> case match eqs aa' of
+ Just (d,g) -> compt vv' $ subst vv' g d
+ _ -> mkApp f aa'
+ Left (EMeta _) -> mkApp f aa' -- canonical or primitive
+ Left d -> compt vv' $ mkApp d aa'
+ _ -> mkApp f aa' -- literal
+ look f = case f of
+ EVar c -> Left $ lookDef pgf c
+ _ -> Right f
+ match = findMatch pgf
+
+beta :: [CId] -> Expr -> Expr
+beta vv c = case c of
+ EApp f a ->
+ let (a',f') = (beta vv a, beta vv f) in
+ case f' of
+ EAbs x b -> beta vv $ subst vv [(x,a')] (beta (x:vv) b)
+ _ -> (if a'==a && f'==f then id else beta vv) $ EApp f' a'
+ EAbs x b -> EAbs x (beta (x:vv) b)
+ _ -> c
+
+
+subst :: [CId] -> Subst -> Expr -> Expr
+subst xs g e = case e of
+ EAbs x b -> EAbs x (subst (x:xs) g e)
+ EApp f a -> EApp (substg f) (substg a)
+ EVar x -> maybe e id $ lookup x g
+ _ -> e
+ where
+ substg = subst xs g
+
+type Subst = [(CId,Expr)]
+type Patt = Expr
+
+
+exprForm :: Expr -> ([CId],Expr,[Expr])
+exprForm exp = upd ([],exp,[]) where
+ upd (xs,f,es) = case f of
+ EAbs x b -> upd (x:xs,b,es)
+ EApp c a -> upd (xs,c,a:es)
+ _ -> (reverse xs,f,es)
+
+mkAbs xs b = foldr EAbs b xs
+mkApp f es = foldl EApp f es
+
+-- special version of pattern matching, to deal with comp under lambda
+
+findMatch :: PGF -> [Equation] -> [Expr] -> Maybe (Expr, Subst)
+findMatch pgf cases terms = case cases of
+ [] -> Nothing
+ (Equ patts _):_ | length patts /= length terms -> Nothing
+ (Equ patts val):cc -> case mapM tryMatch (zip patts terms) of
+ Just substs -> return (val, concat substs)
+ _ -> findMatch pgf cc terms
+ where
+
+ tryMatch (p,t) = case (exprForm p, exprForm t) of
+ (([],EVar c,[]),_) | constructor c -> if p==t then return [] else Nothing
+ (([],EVar x,[]),_) | notMeta t -> return [(x,t)]
+ (([],p, pp), ([], f, tt)) | p == f && length pp == length tt -> do
+ matches <- mapM tryMatch (zip pp tt)
+ return (concat matches)
+ _ -> if p==t then return [] else Nothing
+
+ notMeta e = case e of
+ EMeta _ -> False
+ EApp f a -> notMeta f && notMeta a
+ EAbs _ b -> notMeta b
+ _ -> True
+
+ constructor = isData pgf
+
diff --git a/src/PGF/Macros.hs b/src/PGF/Macros.hs
index b79715f44..4c73817dc 100644
--- a/src/PGF/Macros.hs
+++ b/src/PGF/Macros.hs
@@ -38,6 +38,11 @@ lookDef :: PGF -> CId -> Expr
lookDef pgf f =
snd $ lookMap (error $ "lookDef " ++ show f) f (funs (abstract pgf))
+isData :: PGF -> CId -> Bool
+isData pgf f = case Map.lookup f (funs (abstract pgf)) of
+ Just (_,EMeta 0) -> True ---- the encoding of data constrs
+ _ -> False
+
lookValCat :: PGF -> CId -> CId
lookValCat pgf = valCat . lookType pgf
generated by cgit v1.2.3 (git 2.39.1) at 2026-05-20 14:13:20 +0000