Input and output codes now looks similar to Haskell (or Curry?)
[darcs-mirror-sem_syn.git] / Parser.hs
1 module Parser (parseProgram, parseExpression, parseFile, parseString) where
2
3 import Text.ParserCombinators.Parsec
4 import qualified Text.ParserCombinators.Parsec.Token as Tk
5 import Text.ParserCombinators.Parsec.Language
6
7 import Debug.Trace 
8 import Data.Char (isSpace)
9 import Data.List (partition)
10
11 import AST
12
13
14 -- cnv f s = case f s of
15 --            Left  err -> Left $ show err
16 --            Right r   -> Right $ r 
17
18 parseProgram s = 
19     (parse pProg "") $ insertSemi s
20
21 parseExpression = 
22     (parse pExp "") 
23
24
25 parseString s = 
26     parseProgram s 
27
28
29 parseFile filename =
30     return . parseProgram =<< readFile filename
31
32
33 -- | |insertSemi| inserts ";" after every "\n".
34 insertSemi :: String -> String 
35 insertSemi []  = []
36 insertSemi [x] = [x]
37 insertSemi ('\r':'\n':x) | not (isSpace $ head x) = ';':'\r':'\n':insertSemi x 
38 insertSemi ('\n':x)      | not (isSpace $ head x) = ';':'\n':insertSemi x 
39 insertSemi ('\r':x)      | not (isSpace $ head x) = ';':'\r':insertSemi x 
40 insertSemi (a:x)    = a:insertSemi x
41
42
43                       
44 varId :: Parser String
45 varId = do { c <- lower
46            ; cs <- many (alphaNum <|> char '_')
47            ; return $ (c:cs) }
48
49 conId :: Parser String
50 conId = do { c <- upper 
51            ; cs <- many (alphaNum <|> char '_')
52            ; return $ (c:cs) }
53
54 number :: Parser Int
55 number = do { cs <- many1 digit
56             ; return $ read cs }
57
58 myLexer = Tk.makeTokenParser haskellDef 
59 --             $ emptyDef {
60 --                     commentStart = "{-"
61 --                   , commentEnd   = "-}"
62 --                   , commentLine  = "--"           
63 --                   , reservedNames = ["case", "class", "data", "default", "deriving", "do", "else", "if", "import", "in", "infix", "infixl", "infixr", "instance", "let", "module", "newtype", "of", "then", "type", "where", "_" ]
64 --                  }
65
66
67
68 parens = Tk.parens myLexer
69 symbol = Tk.symbol myLexer
70 comma  = Tk.comma myLexer
71 lexeme = Tk.lexeme myLexer
72 reserved = Tk.reserved myLexer
73 brackets = Tk.brackets myLexer 
74 whiteSpace = Tk.whiteSpace myLexer
75 semi = Tk.semi myLexer
76
77
78 pProg = do { skipMany (whiteSpace >> semi)
79            ; ds <- sepEndBy (pDecl) (many1 (whiteSpace >> semi)) -- many (lexeme pDecl)
80            ; return $ assignIDsAST (AST $ ds) }
81
82
83 pDecl = do { whiteSpace
84            ; pos <- getPosition 
85            ; fName <- lexeme varId 
86            ; ps    <- many1 pAPat -- parens (pPats)
87            ; whiteSpace 
88            ; symbol "=" 
89            ; e     <- pExp
90            ; return $ Decl (Name fName) FTUndet ps e }
91
92
93 -- pPats = sepBy pPat comma 
94
95 {-
96  pPat  ::= pAPat : pPat 
97         |  pCPat 
98  pCPat ::= C pAPat ... pAPat 
99         |  pAPat 
100  pAPat ::= C | x | BList | (pPat)
101  BList ::= [ pPat, ..., pPat ]
102 -}
103
104 pcons x y = PCon Nothing TUndet (Name "Cons") [x,y]
105 pnil      = PCon Nothing TUndet (Name "Nil")  []
106
107 -- list pattern 
108 pPat = do { whiteSpace 
109           ; pos <- getPosition 
110           ; try ( do { p1 <- pAPat 
111                      ; symbol ":" 
112                      ; p2 <- pPat 
113                      ; return $ pcons p1 p2 } )
114             <|> 
115             pCPat }
116
117 -- constructor pattern
118 pCPat = do { whiteSpace
119            ; pos <- getPosition 
120            ; do { c <- lexeme conId
121                 ; ps <- many pAPat 
122                 ; return $ PCon Nothing TUndet (Name c) ps }
123              <|> 
124              pAPat }
125
126 -- pattern need not to be enclosed with parens
127 pAPat = do { whiteSpace 
128            ; pos <- getPosition 
129            ; do { c <- lexeme conId 
130                 ; ps <- many pAPat 
131                 ; return $ PCon Nothing TUndet (Name c) [] }
132              <|>
133              do { c <- lexeme number 
134                 ; return $ PCon Nothing TUndet (Name $ show c) [] }
135              <|>
136              do { c <- lexeme varId 
137                 ; return $ PVar Nothing TUndet (Name c) }
138              <|>
139              do { pBListPat }
140              <|>
141              do { parens pPat } }
142
143 -- [p1, ..., pn]                    
144 pBListPat = do { ps <- brackets (sepBy pPat comma)
145                ; return $ foldr pcons pnil ps}
146
147 -- pPat = do { whiteSpace  
148 --           ; pos <- getPosition 
149 --           ; try pList 
150 --             <|> 
151 --             do { c <- lexeme conId                
152 --                ; ps <- many pAPat -- option [] $ parens pPats 
153 --                ; return $ PCon Nothing TUndet (Name c) ps }
154 --             <|>             
155 --             pAPat  }
156
157
158 -- pAPat = do { whiteSpace
159 --            ; pos <- getPosition 
160 --            ; do { c <- lexeme conId
161 --                 ; return $ PCon Nothing TUndet (Name c) [] }
162 --              <|>
163 --              do { c <- lexeme number 
164 --                 ; return $ PCon Nothing TUndet (Name $ show c) [] }
165 --              <|>
166 --              do { c <- lexeme varId 
167 --                 ; return $ PVar Nothing TUndet (Name c) }
168 --              <|>
169 --            --  do { pBList }
170 --            --  <|>
171 --              do { parens pPat }
172 --            }
173
174 -- pList = do { whiteSpace 
175 --            ; pos <- getPosition 
176 --            ; try (do { p1 <- pAPat 
177 --                      ; symbol ":"
178 --                      ; p2 <- pPat 
179 --                      ; return $ PCon Nothing TUndet (Name $ "Cons") [p1,p2] })
180 --              <|>
181 --              pAPat }
182
183
184
185 -- pTExp = do { whiteSpace
186 --            ; pos <- getPosition
187 --            ; do { c  <- lexeme conId
188 --                 ; es <- option [] $ parens (sepBy (pTExp) comma)
189 --                 ; return $ ECon Nothing TUndet (Name c) es }
190 --              <|>
191 --              do { c <- lexeme $ number
192 --                 ; return $ ECon Nothing TUndet (Name $ show c) [] }
193 --              <|>
194 --              do { c <- lexeme varId 
195 --                 ; do { es <- parens (sepBy (pArg) comma) 
196 --                      ; return $ EFun Nothing TUndet (Name c) es }
197 --                   <|>
198 --                   do { return $ EVar Nothing TUndet (Name c) } } 
199 --              <|> 
200 --              do { _ <- string "("
201 --                 ; c <- pTExp 
202 --                 ; _ <- string ")" 
203 --                 ; return c }}
204
205
206 {-
207  pExp  ::= pAExp : pExp
208         |  pAppExp 
209
210  pAppExp ::= C pAExp ... pAExp
211           |  f pAExp ... pAExp 
212           | pAExp 
213
214  pAPat ::= C | n | x | pBListExp | (pExp)
215  pBListExp ::= [ pExp, ..., pExp ]
216 -}
217
218
219 econs x y = ECon Nothing TUndet (Name $ "Cons") [x,y]
220 enil      = ECon Nothing TUndet (Name $ "Nil")  [] 
221
222 -- Cons 
223 pExp = do { whiteSpace
224           ; pos <- getPosition 
225           ; try (do { e1 <- pAExp 
226                     ; symbol ":" 
227                     ; e2 <- pExp 
228                     ; return $ econs e1 e2 })
229             <|>
230             pAppExp }
231
232 -- Application
233 pAppExp = do { whiteSpace
234              ; pos <- getPosition 
235              ; do { c  <- lexeme conId
236                   ; es <- many pAExp -- option [] $ parens (sepBy (pExp) comma)
237                   ; return $ ECon Nothing TUndet (Name c) es }
238                <|>
239                do { c <- lexeme varId 
240                   ; do { es <- many1 pAExp --  parens (sepBy (pExp) comma) 
241                        ; return $ EFun Nothing TUndet (Name c) es }
242                     <|>
243                     do { return $ EVar Nothing TUndet (Name c) } }                
244                <|>
245                pAExp }
246                     
247 -- Atomic
248 pAExp = do { whiteSpace
249            ; pos <- getPosition 
250            ; do { c <- lexeme conId
251                 ; return $ ECon Nothing TUndet (Name c) [] }
252              <|>
253              do { c <- lexeme number 
254                 ; return $ ECon Nothing TUndet (Name $show c) [] }
255              <|>
256              do { c <- lexeme varId
257                 ; return $ EVar Nothing TUndet (Name c) }
258              <|>
259              do { pBListExp }
260              <|>
261              do { parens pExp }
262            }
263
264 -- [e1, ..., en]                    
265 pBListExp = do { es <- brackets (sepBy pExp comma)
266                ; return $ foldr econs enil es}
267
268
269 -- pExp = do { whiteSpace
270 --           ; pos <- getPosition
271 --           ; do { c  <- lexeme conId
272 --                ; es <- many pAExp -- option [] $ parens (sepBy (pExp) comma)
273 --                ; return $ ECon Nothing TUndet (Name c) es }
274 --             <|>
275 --             do { c <- lexeme $ number
276 --                ; return $ ECon Nothing TUndet (Name $ show c) [] }
277 --             <|>
278 --             do { c <- lexeme varId 
279 --                ; do { es <- many1 pAExp --  parens (sepBy (pExp) comma) 
280 --                     ; return $ EFun Nothing TUndet (Name c) es }
281 --                  <|>
282 --                  do { return $ EVar Nothing TUndet (Name c) } } 
283 --             <|> 
284 --             do { parens pExp }
285 --           }
286
287
288
289 -- pArg = do { pos <- getPosition
290 --           ; c <- lexeme varId
291 --           ; return $ EVar Nothing TUndet (Name c)} 
292
293