1 files changed, 64 insertions, 0 deletions
diff --git a/src/GF/Grammar/AbsCompute.hs b/src/GF/Grammar/AbsCompute.hs
new file mode 100644
index 000000000..52a2ca678
--- /dev/null
+++ b/src/GF/Grammar/AbsCompute.hs
@@ -0,0 +1,64 @@
+module AbsCompute where
+
+import Operations
+
+import Abstract
+import PrGrammar
+import LookAbs
+import PatternMatch
+import Compute
+
+import Monad (liftM, liftM2)
+
+-- computation in abstract syntax w.r.t. explicit definitions.
+--- old GF computation; to be updated
+
+compute :: GFCGrammar -> Exp -> Err Exp
+compute = computeAbsTerm
+
+computeAbsTerm :: GFCGrammar -> Exp -> Err Exp
+computeAbsTerm gr = computeAbsTermIn gr []
+
+computeAbsTermIn :: GFCGrammar -> [Ident] -> Exp -> Err Exp
+computeAbsTermIn gr = compt where
+  compt vv t = case t of
+    Prod x a b  -> liftM2 (Prod x) (compt vv a) (compt (x:vv) b)
+    Abs x b     -> liftM  (Abs  x)              (compt (x:vv) b)
+    _ -> do
+      let t' = beta vv t
+      (yy,f,aa) <- termForm t'
+      let vv' = yy ++ vv
+      aa'    <- mapM (compt vv') aa
+      case look f of
+        Just (Eqs eqs) -> case findMatch eqs aa' of
+          Ok (d,g) -> do
+            let (xs,ts) = unzip g
+            ts' <- alphaFreshAll vv' ts ---
+            let g' = zip xs ts'
+            d' <- compt vv' $ substTerm vv' g' d
+            return $ mkAbs yy $ d'
+          _ -> do
+            return $ mkAbs yy $ mkApp f aa'
+        Just d -> do
+          d' <- compt vv' d
+          da <- ifNull (return d') (compt vv' . mkApp d') aa' 
+          return $ mkAbs yy $ da
+        _ -> do
+          return $ mkAbs yy $ mkApp f aa'
+
+  look (Q m f) = case lookupAbsDef gr m f of
+    Ok (Just (Eqs [])) -> Nothing  -- canonical
+    Ok md -> md
+    _ -> Nothing
+  look _ = Nothing
+
+beta :: [Ident] -> Exp -> Exp
+beta vv c = case c of
+  App (Abs x b) a -> beta vv $ substTerm vv [xvv] (beta (x:vv) b) 
+                                                    where xvv = (x,beta vv a) 
+  App f         a -> let (a',f') = (beta vv a, beta vv f) in 
+                     (if a'==a && f'==f then id else beta vv) $ App f' a'
+  Prod x a b      -> Prod x (beta vv a) (beta (x:vv) b)
+  Abs x b         -> Abs x (beta (x:vv) b)
+  _               -> c
+