Mercurial > repo

comparison interps/rhotor/Parser.hs @ 996:859f9b4339e6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
<Gregor> tar xf egobot.tar.xz
author HackBot
date Sun, 09 Dec 2012 19:30:08 +0000
parents
children
comparison
equal deleted inserted replaced
995:6883f5911eb7 996:859f9b4339e6
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