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
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
|
----------------------------------------------------------------------
-- |
-- Module : (Module)
-- Maintainer : (Maintainer)
-- Stability : (stable)
-- Portability : (portable)
--
-- > CVS $Date $
-- > CVS $Author $
-- > CVS $Revision $
--
-- (Description of the module)
-----------------------------------------------------------------------------
module Ident where
import Operations
-- import Monad
-- | the constructors labelled /INTERNAL/ are
-- internal representation never returned by the parser
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) -- ^ /INTERNAL/ variable
| IA (String,Int) -- ^ /INTERNAL/ argument of cat at position
| IAV (String,Int,Int) -- ^ /INTERNAL/ 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"))
-}
|
