Founding the newly structured GF2.0 cvs archive.

1 files changed, 117 insertions, 0 deletions

diff --git a/src/GF/Infra/Ident.hs b/src/GF/Infra/Ident.hs
new file mode 100644
index 000000000..3e564460c
--- /dev/null
+++ b/src/GF/Infra/Ident.hs
@@ -0,0 +1,117 @@
+module Ident where
+
+import Operations
+-- import Monad
+
+data Ident = 
+   IC String            -- raw identifier after parsing, resolved in Rename
+ | IW                   -- wildcard
+
+-- below this line: internal representation never returned by the parser
+ | IV (Int,String)      -- variable
+ | IA (String,Int)      -- argument of cat at position
+ | IAV (String,Int,Int) -- argument of cat with bindings at position
+
+  deriving (Eq, Ord, Show, Read)
+
+prIdent :: Ident -> String
+prIdent i = case i of
+  IC s -> s
+  IV (n,s) -> s ++ "_" ++ show n
+  IA (s,j) -> s ++ "_" ++ show j
+  IAV (s,b,j) -> s ++ "_" ++ show b ++ "_" ++ show j
+  IW -> "_"
+
+(identC, identV, identA, identAV, identW) = 
+    (IC,     IV,     IA,     IAV,     IW)
+
+-- normal identifier
+-- ident s = IC s
+
+-- to mark argument variables
+argIdent 0 (IC c) i = identA  (c,i)
+argIdent b (IC c) i = identAV (c,b,i)
+
+-- used in lin defaults
+strVar = identA ("str",0)
+
+-- wild card
+wildIdent = identW
+
+isWildIdent :: Ident -> Bool
+isWildIdent = (== wildIdent)
+
+newIdent = identC "#h"
+
+mkIdent :: String -> Int -> Ident
+mkIdent s i = identV (i,s)
+
+varIndex :: Ident -> Int
+varIndex (IV (n,_)) = n
+varIndex _ = -1 --- other than IV should not count
+
+-- refreshing identifiers
+
+type IdState = ([(Ident,Ident)],Int) 
+
+initIdStateN :: Int -> IdState
+initIdStateN i = ([],i)
+
+initIdState :: IdState
+initIdState = initIdStateN 0
+
+lookVar :: Ident -> STM IdState Ident
+lookVar a@(IA _) = return a
+lookVar x = do
+  (sys,_) <- readSTM
+  stm (\s -> maybe (Bad ("cannot find" +++ show x +++ prParenth (show sys))) 
+                   return $ 
+             lookup x sys >>= (\y -> return (y,s)))
+
+refVar :: Ident -> STM IdState Ident
+----refVar IW = return IW --- no update of wildcard
+refVar x = do
+  (_,m) <- readSTM
+  let x' = IV (m, prIdent x)
+  updateSTM (\ (sys,mx) -> ((x, x'):sys, mx + 1))
+  return x'
+
+refVarPlus :: Ident -> STM IdState Ident
+----refVarPlus IW = refVar (identC "h")
+refVarPlus x = refVar x
+
+
+{-
+------------------------------
+-- to test
+
+refreshExp :: Exp -> Err Exp
+refreshExp e = err Bad (return . fst) (appSTM (refresh e) initState)
+
+refresh :: Exp -> STM State Exp
+refresh e = case e of
+  Atom x  -> lookVar x >>= return . Atom
+  App f a -> liftM2 App (refresh f) (refresh a)
+  Abs x b -> liftM2 Abs (refVar x)  (refresh b)
+  Fun xs a b -> do
+    a'  <- refresh a
+    xs' <- mapM refVar xs
+    b'  <- refresh b
+    return $ Fun xs' a' b'
+
+data Exp =
+   Atom Ident
+ | App Exp Exp
+ | Abs Ident Exp
+ | Fun [Ident] Exp Exp
+  deriving Show
+
+exp1 = Abs (IC "y") (Atom (IC "y"))
+exp2 = Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y")))
+exp3 = Abs (IC "y") (Abs (IC "z") (App (Atom (IC "y")) (Atom (IC "z"))))
+exp4 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "z"))))
+exp5 = Abs (IC "y") (Abs (IC "y") (App (Atom (IC "y")) (Atom (IC "y"))))
+exp6 = Abs (IC "y") (Fun [IC "x", IC "y"] (Atom (IC "y")) (Atom (IC "y")))
+exp7 = Abs (IL "8") (Atom (IC "y"))
+
+-}