Founding the newly structured GF2.0 cvs archive.

1 files changed, 105 insertions, 0 deletions

diff --git a/src/GF/Grammar/Refresh.hs b/src/GF/Grammar/Refresh.hs
new file mode 100644
index 000000000..8b33444d0
--- /dev/null
+++ b/src/GF/Grammar/Refresh.hs
@@ -0,0 +1,105 @@
+module Refresh where
+
+import Operations
+import Grammar
+import Ident
+import Modules
+import Macros
+import Monad
+
+refreshTerm :: Term -> Err Term
+refreshTerm = refreshTermN 0
+
+refreshTermN :: Int -> Term -> Err Term
+refreshTermN i e = liftM snd $ refreshTermKN i e
+
+refreshTermKN :: Int -> Term -> Err (Int,Term)
+refreshTermKN i e = liftM (\ (t,(_,i)) -> (i,t)) $ 
+                    appSTM (refresh e) (initIdStateN i)
+
+refresh :: Term -> STM IdState Term
+refresh e = case e of
+
+  Vr x    -> liftM  Vr  (lookVar x)
+  Abs x b -> liftM2 Abs (refVarPlus x)  (refresh b)
+
+  Prod x a b -> do
+    a'  <- refresh a
+    x'  <- refVar  x
+    b'  <- refresh b
+    return $ Prod x' a' b'
+
+  Let (x,(mt,a)) b -> do
+    a'  <- refresh a
+    mt' <- case mt of
+             Just t -> refresh t >>= (return . Just) 
+             _ -> return mt
+    x'  <- refVar x
+    b'  <- refresh b
+    return (Let (x',(mt',a')) b')
+
+  R r  -> liftM R $ refreshRecord r
+
+  ExtR r s -> liftM2 ExtR (refresh r)  (refresh s)
+  
+  T i cc -> liftM2 T (refreshTInfo i) (mapM refreshCase cc)
+
+  _ -> composOp refresh e
+
+refreshCase :: (Patt,Term) -> STM IdState (Patt,Term)
+refreshCase (p,t) = liftM2 (,) (refreshPatt p) (refresh t)
+
+refreshPatt p = case p of
+  PV x    -> liftM PV     (refVar x)
+  PC c ps -> liftM (PC c) (mapM refreshPatt ps)
+  PP q c ps -> liftM (PP q c) (mapM refreshPatt ps)
+  PR r    -> liftM PR     (mapPairsM refreshPatt r)
+  PT t p' -> liftM2 PT    (refresh t) (refreshPatt p')
+  _ -> return p
+
+refreshRecord r = case r of
+  [] -> return r
+  (x,(mt,a)):b -> do
+    a'  <- refresh a
+    mt' <- case mt of
+             Just t -> refresh t >>= (return . Just) 
+             _ -> return mt
+    b'  <- refreshRecord b
+    return $ (x,(mt',a')) : b'
+
+refreshTInfo i = case i of
+  TTyped t -> liftM TTyped $ refresh t
+  TComp t -> liftM TComp $ refresh t
+  TWild t -> liftM TWild $ refresh t
+  _ -> return i
+
+-- for abstract syntax
+
+refreshEquation :: Equation -> Err ([Patt],Term)
+refreshEquation pst = err Bad (return . fst) (appSTM (refr pst) initIdState) where
+  refr (ps,t) = liftM2 (,) (mapM refreshPatt ps) (refresh t)
+
+-- for concrete and resource in grammar, before optimizing
+
+refreshGrammar :: SourceGrammar -> Err SourceGrammar
+refreshGrammar = liftM (MGrammar . snd) . foldM refreshModule (0,[]) . modules
+
+refreshModule :: (Int,[SourceModule]) -> SourceModule -> Err (Int,[SourceModule])
+refreshModule (k,ms) mi@(i,m) = case m of
+    ModMod mo@(Module mt fs me ops js) | (isModCnc mo || mt == MTResource) -> do
+      (k',js') <- foldM refreshRes (k,[]) $ tree2list js
+      return (k', (i, ModMod(Module mt fs me ops (buildTree js'))) : ms)
+    _ -> return (k, mi:ms)
+ where
+  refreshRes (k,cs) ci@(c,info) = case info of
+    ResOper ptyp (Yes trm) -> do   ---- refresh ptyp
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, ResOper ptyp (Yes trm')):cs)
+    CncCat mt (Yes trm) pn -> do   ---- refresh mt, pn
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, CncCat mt (Yes trm') pn):cs)
+    CncFun mt (Yes trm) pn -> do   ---- refresh pn
+      (k',trm') <- refreshTermKN k trm
+      return $ (k', (c, CncFun mt (Yes trm') pn):cs)
+    _ -> return (k, ci:cs)
+