a first version of PGF.AbsCompute

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

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 :: PGF -> String -> Maybe TreeOp
-treeOp f = fmap snd $ lookup f allTreeOps
+treeOp pgf f = fmap snd $ lookup f $ allTreeOps pgf
 
-allTreeOps :: [(String,(String,TreeOp))]
+allTreeOps :: PGF -> [(String,(String,TreeOp))]
-allTreeOps = [
+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

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
+        where ws = words s

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
+

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