1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
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"))
-}
|
