|
996
|
1 module Parser (parse)
|
|
|
2 where
|
|
|
3
|
|
|
4 import Data.List
|
|
|
5 import Uniqs
|
|
|
6 import Node
|
|
|
7
|
|
|
8 data Token = Variable String |
|
|
|
9 NewVariable String |
|
|
|
10 TFunction |
|
|
|
11 Fail |
|
|
|
12 TCons |
|
|
|
13 TLT | TGT |
|
|
|
14 String String |
|
|
|
15 Number Integer |
|
|
|
16 SubExp [Token] |
|
|
|
17 NCons Token Token |
|
|
|
18 NFunction Token Token Token |
|
|
|
19 NApplication Token Token |
|
|
|
20 TNil
|
|
|
21
|
|
|
22
|
|
|
23 parse :: String -> Node
|
|
|
24 parse x = tokenToNode (parseIntern (tokenize x)) [] Root
|
|
|
25
|
|
|
26 {- Tokenizer -}
|
|
|
27
|
|
|
28 tokenize :: String -> [Token]
|
|
|
29 tokenize [] = []
|
|
|
30 tokenize ( '/' :t) = (TFunction : tokenize t)
|
|
|
31 tokenize ( '\\':t) = (Fail : tokenize t)
|
|
|
32 tokenize ( ',' :t) = (TCons : tokenize t)
|
|
|
33 tokenize ( '<' :t) = (TLT : tokenize t)
|
|
|
34 tokenize ( '>' :t) = (TGT : tokenize t)
|
|
|
35 tokenize ( '%' :( '"' :t )) = (String text : tokenize q)
|
|
|
36 where (text,q) = (textTokenize t)
|
|
|
37 tokenize ( '%' :( '\'' :(c:t))) = (Number (toInteger (fromEnum c)) : tokenize t)
|
|
|
38 tokenize ( '%' :t) = (Number (read text) : tokenize q)
|
|
|
39 where (text,q) = (numberTokenize t)
|
|
|
40 tokenize ( ':' :t) = (NewVariable text : tokenize q)
|
|
|
41 where (text,q) = (varTokenize t)
|
|
|
42 tokenize y@( x :t)
|
|
|
43 | (x >= 'a' && x <= 'z') = (Variable text : tokenize q)
|
|
|
44 | elem x ". \n\t\r" = tokenize t
|
|
|
45 | (x >= 'A' && x <= 'Z') = tokenize t
|
|
|
46 where (text,q) = (varTokenize y)
|
|
|
47
|
|
|
48
|
|
|
49 textTokenize :: String -> (String,String)
|
|
|
50 textTokenize ( '\\' : ( 'n' :t) ) = (( '\n' :text), q)
|
|
|
51 where (text,q) = (textTokenize t)
|
|
|
52 textTokenize ( '\\' : ( x :t) ) = ((x:text), q)
|
|
|
53 where (text,q) = (textTokenize t)
|
|
|
54 textTokenize ( '"' : t) = ("",t)
|
|
|
55 textTokenize ( x : t) = ((x:text), q)
|
|
|
56 where (text,q) = (textTokenize t)
|
|
|
57
|
|
|
58
|
|
|
59 numberTokenize :: String -> (String,String)
|
|
|
60 numberTokenize [] = ("",[])
|
|
|
61 numberTokenize y@( x : t)
|
|
|
62 | x >= '0' && x <= '9' = ((x:text), q)
|
|
|
63 | otherwise = ("",y)
|
|
|
64 where (text,q) = (numberTokenize t)
|
|
|
65
|
|
|
66
|
|
|
67 varTokenize :: String -> (String,String)
|
|
|
68 varTokenize [] = ("",[])
|
|
|
69 varTokenize y@( x : t)
|
|
|
70 | x >= 'a' && x <= 'z' = ((x:text), q)
|
|
|
71 | otherwise = ("",y)
|
|
|
72 where (text,q) = (varTokenize t)
|
|
|
73
|
|
|
74
|
|
|
75 instance Show Token where
|
|
|
76 show (Variable x) = "Variable " ++ (show x)
|
|
|
77 show (NewVariable x) = "NewVariable " ++ (show x)
|
|
|
78 show (TFunction) = "TFunction"
|
|
|
79 show (Fail) = "Fail"
|
|
|
80 show (TCons) = "TCons"
|
|
|
81 show (TLT) = "TLT"
|
|
|
82 show (TGT) = "TGT"
|
|
|
83 show (String x) = "String " ++ (show x)
|
|
|
84 show (Number x) = "Number " ++ (show x)
|
|
|
85 show (SubExp x) = "SubExp " ++ (show x)
|
|
|
86 show (NCons x y) = "NCons (" ++ (show x) ++ ") (" ++ (show y) ++ ")"
|
|
|
87 show (NFunction x y z) = "NFunction (" ++ (show x) ++ ") (" ++ (show y) ++ ") (" ++ (show z) ++ ")"
|
|
|
88 show (NApplication x y) = "NApplication (" ++ (show x) ++ ") (" ++ (show y) ++ ")"
|
|
|
89 show (TNil) = "TNil"
|
|
|
90
|
|
|
91 instance Eq Token where
|
|
|
92 (==) TFunction TFunction = True
|
|
|
93 (==) Fail Fail = True
|
|
|
94 (==) _ _ = False
|
|
|
95
|
|
|
96 {- Parser -}
|
|
|
97
|
|
|
98 parseIntern :: [Token] -> Token
|
|
|
99 parseIntern x = stripSubExp (head (parseApplication (parseCons (fst (parseFunctions (fst (parseTT (expandNumbers (expandStrings x)))))))))
|
|
|
100
|
|
|
101 onReverse :: ([a] -> [a]) -> [a] -> [a]
|
|
|
102 onReverse x y = (reverse (x (reverse y)))
|
|
|
103
|
|
|
104 expandStrings :: [Token] -> [Token]
|
|
|
105 expandStrings [] = []
|
|
|
106 expandStrings ((String x):rest) = (xtail (concatMap toNums x)) ++ (expandStrings rest)
|
|
|
107 where
|
|
|
108 toNums x = [TCons,TLT,Number (toInteger (fromEnum x)),TGT]
|
|
|
109 xtail [] = []
|
|
|
110 xtail (h:t) = t
|
|
|
111 expandStrings (h:rest) = h:(expandStrings rest)
|
|
|
112
|
|
|
113 expandNumbers :: [Token] -> [Token]
|
|
|
114 expandNumbers [] = []
|
|
|
115 expandNumbers ((Number x):rest) = (toNils x) ++ (expandNumbers rest)
|
|
|
116 where
|
|
|
117 toNils 0 = [TNil]
|
|
|
118 toNils (n+1) = TNil:(TCons:(toNils n))
|
|
|
119 expandNumbers (h:rest) = h:(expandNumbers rest)
|
|
|
120
|
|
|
121 parseTT :: [Token] -> ([Token],[Token])
|
|
|
122 parseTT [] = ([],[])
|
|
|
123 parseTT (TGT:y) = ([],y)
|
|
|
124 parseTT (TLT:y) = ((SubExp frst:snd),thrd)
|
|
|
125 where
|
|
|
126 (frst,lst) = parseTT y
|
|
|
127 (snd,thrd) = parseTT lst
|
|
|
128
|
|
|
129 parseTT (x:y) = ((x:frst),lst)
|
|
|
130 where (frst,lst) = parseTT y
|
|
|
131
|
|
|
132 partitionWhen :: (a -> Bool) -> [a] -> Maybe ([a],[a])
|
|
|
133 partitionWhen f x@(h:t) = if f h then
|
|
|
134 Just ([],x)
|
|
|
135 else case (partitionWhen f t) of
|
|
|
136 Nothing -> Nothing
|
|
|
137 Just (q,r) -> Just ((h:q),r)
|
|
|
138 partitionWhen f [] = Nothing
|
|
|
139
|
|
|
140 partitionWhen2 :: (a -> Bool) -> [a] -> Maybe ([a],a,[a])
|
|
|
141 partitionWhen2 f x = case (partitionWhen f x) of
|
|
|
142 Nothing -> Nothing
|
|
|
143 Just (q,h:t)-> Just (q,h,t)
|
|
|
144
|
|
|
145
|
|
|
146
|
|
|
147 parseFunctions :: [Token] -> ([Token],[Token])
|
|
|
148 parseFunctions x = case (partitionWhen2 (\y -> y == TFunction || y == Fail) x) of
|
|
|
149 Nothing -> ((parseSubFunctions x),[])
|
|
|
150 Just (fl,Fail,frst) -> (fl,frst)
|
|
|
151 Just (a,TFunction,c) -> let
|
|
|
152 (def,rst) = parseFunctions c
|
|
|
153 (frst,lrst) = parseFunctions rst
|
|
|
154 in ([NFunction (SubExp (fst (parseFunctions a))) (SubExp (fst (parseFunctions def))) (SubExp (fst (parseFunctions frst)))],lrst)
|
|
|
155
|
|
|
156 parseSubFunctions :: [Token] -> [Token]
|
|
|
157 parseSubFunctions [] = []
|
|
|
158 parseSubFunctions ((SubExp x):t) = (SubExp (fst (parseFunctions x))):(parseSubFunctions t)
|
|
|
159 parseSubFunctions (x:t) = x:(parseSubFunctions t)
|
|
|
160
|
|
|
161 parseApplication :: [Token] -> [Token]
|
|
|
162 parseApplication x = foldr iteration [] (reverse x)
|
|
|
163 where
|
|
|
164 iteration itema (itemb:rest) = (NApplication itemb (parseSubApplication itema)):rest
|
|
|
165 iteration item [] = [parseSubApplication item]
|
|
|
166
|
|
|
167 parseSubApplication :: Token -> Token
|
|
|
168 parseSubApplication (SubExp x) = SubExp (parseApplication x)
|
|
|
169 parseSubApplication (NFunction x y z) = NFunction (parseSubApplication x) (parseSubApplication y) (parseSubApplication z)
|
|
|
170 parseSubApplication (NCons x y) = NCons (parseSubApplication x) (parseSubApplication y)
|
|
|
171 parseSubApplication x = x
|
|
|
172
|
|
|
173 parseCons :: [Token] -> [Token]
|
|
|
174 parseCons x = foldr iteration [] x
|
|
|
175 where
|
|
|
176 iteration itema (TCons:(itemb:rest)) = (NCons (parseSubCons itema) itemb):rest
|
|
|
177 iteration item list = (parseSubCons item):list
|
|
|
178
|
|
|
179 parseSubCons :: Token -> Token
|
|
|
180 parseSubCons (SubExp x) = SubExp (parseCons x)
|
|
|
181 parseSubCons (NFunction x y z) = NFunction (parseSubCons x) (parseSubCons y) (parseSubCons z)
|
|
|
182 parseSubCons x = x
|
|
|
183
|
|
|
184
|
|
|
185 stripSubExp :: Token -> Token
|
|
|
186 stripSubExp (SubExp [a]) = stripSubExp a
|
|
|
187 stripSubExp (SubExp []) = TNil
|
|
|
188 stripSubExp (NCons a b) = NCons (stripSubExp a) (stripSubExp b)
|
|
|
189 stripSubExp (NFunction a b c) = NFunction (stripSubExp a) (stripSubExp b) (stripSubExp c)
|
|
|
190 stripSubExp (NApplication a b) = NApplication (stripSubExp a) (stripSubExp b)
|
|
|
191 stripSubExp a = a
|
|
|
192
|
|
|
193 tokenToNode :: Token -> [(String,Uniqs)] -> Uniqs -> Node
|
|
|
194 tokenToNode TNil _ _ = Nil
|
|
|
195 tokenToNode (NCons a b) tab cn = Cons (tokenToNode a tab (A cn)) (tokenToNode b tab (B cn))
|
|
|
196 tokenToNode (NApplication a b) tab cn = Application (tokenToNode a tab (A cn)) (tokenToNode b tab (B cn))
|
|
|
197 tokenToNode (NFunction a b c) tab cn = let (ac,ntab) = functionPtrnToNode a tab (C cn)
|
|
|
198 in (Function ac (tokenToNode b ntab (A cn)) (tokenToNode c tab (B cn)))
|
|
|
199 tokenToNode (Variable n) tab _ = let Just a = (lookup n tab)
|
|
|
200 in (Symbol a)
|
|
|
201
|
|
|
202 functionPtrnToNode :: Token -> [(String,Uniqs)] -> Uniqs -> (Node,[(String,Uniqs)])
|
|
|
203 functionPtrnToNode TNil tab _ = (Nil,tab)
|
|
|
204 functionPtrnToNode (NCons a b) tab cn = let
|
|
|
205 (newa,tab2) = functionPtrnToNode a tab (A cn)
|
|
|
206 (newb,tab3) = functionPtrnToNode b tab2 (B cn)
|
|
|
207 in ((Cons newa newb),tab3)
|
|
|
208 functionPtrnToNode (NApplication a b) tab cn = let
|
|
|
209 (newa,tab2) = functionPtrnToNode a tab (A cn)
|
|
|
210 (newb,tab3) = functionPtrnToNode b tab2 (B cn)
|
|
|
211 in ((Application newa newb),tab3)
|
|
|
212 functionPtrnToNode a@(NFunction _ _ _) tab cn = ((tokenToNode a tab cn),tab)
|
|
|
213
|
|
|
214 functionPtrnToNode (Variable n) tab cn = case (lookup n tab) of
|
|
|
215 Just a -> (Symbol a,tab)
|
|
|
216 Nothing -> (Symbol cn,((n,cn):tab))
|
|
|
217
|
|
|
218 functionPtrnToNode (NewVariable n) tab cn = (Symbol cn,((n,cn):(deleteBy filter (n,cn) tab)))
|
|
|
219 where filter (a,_) (b,_) = a == b
|
|
|
220 |
