root/hh2008/hayamiz/trunk/hascheme/parser.scm @ 128

Revision 23, 10.0 kB (checked in by hayamizu, 17 years ago)

worte parser

Line 
1;; -*- coding: utf-8 mode: scheme -*-
2
3(use text.tree)
4(require "hascheme/peg-parser")
5
6(define-class <ast> () ())
7(define-class <ast-decl> (<ast>) ())
8(define-class <ast-decls> (<ast>)
9  ((delcs :init-keyword :decls :getter decls)))
10(define-class <ast-type-decl> (<ast-decl>)
11  ((left :init-keyword :left :getter type-decl-left)
12   (right :init-keyword :right :getter type-decl-right)))
13(define-class <ast-type> (<ast>) ())
14(define-class <ast-type-var> (<ast>) 
15  ((type-var :init-keyword :var :getter type-var)))
16(define-class <ast-single-type> (<ast-type>)
17  ((type-name :init-keyword :name :getter type-name)
18   (type-arity :init-keyword :arity :accessor type-arity :init-value #f)
19   (type-vars :init-keyword :vars :accessor type-vars :init-value #f)
20   (type-module :init-keyword :module :getter type-module :init-value #f)))
21(define-class <ast-multi-type> (<ast-type>)
22  ((types :init-keyword :name :accessor types)))
23(define-class <ast-simple-type> (<ast>)
24  ((type-name :init-keyword :name :getter type-name)
25   (type-vars :init-keyword :vars :getter type-vars)))
26
27(define-method make-type-decl ((left <ast-simple-type>) (right <ast-type>))
28  (make <ast-type-decl> :left left :right right))
29
30(define (hascheme:parse str)
31  (parse-string-with
32   (
33    ;; incompl
34    (Module <- "module" Spaces LexModId Spaces "where" Spaces Body
35            / Body)
36    (Body <- "{" (:decls TopDecls) "}" :return decls)
37    (TopDecls <- Spaces* (:decl TopDecl) (:rest-decls TopDecls%) Spaces*
38              :return (make <ast-decls> :decls (cons decl rest-decls))
39              / Spaces* :return ())
40    (TopDecls% <- Spaces* ";" Spaces* TopDecl TopDecls%
41              / :return ())
42
43    ;; incoml
44    (TopDecl <-
45             "type" Spaces (:left SimpleType) Spaces*
46             "=" Spaces* (:right Type)
47             :return (make-type-decl left right)
48             / "data" Spaces ( Context Spaces* "=>" Spaces*) ? SimpleType
49             Spaces* "="
50             Spaces* Constructors
51             Spaces* Deriving ?
52
53             / Decl
54             )
55    (Decls <- "{" Spaces* Decl Spaces* ("," Decl Spaces*) * "}")
56   
57    ;; incompl
58    (Decl <- GenDecl
59          ;; /(FunctionLHS / Variable) RHS ;; do this later
60          / Variable Spaces* RHS)
61    ;; incompl
62    (GenDecl <- Variables Spaces* "::" Spaces*
63             ( Context Spaces* "=>" Spaces* ) ? Type
64             ;; / Fixity LexInteger ? Operators ;; later
65             )
66    ;; incompl
67    (RHS <- "=" Spaces* Expression (Spaces "where" Spaces Decls) ?)
68
69    (Expression <- "\\" Spaces* AtomPattern 
70                (Spaces AtomPattern) * Spaces* "->" Spaces* Expression
71                / "let" Spaces* Decls Spaces* "in" Spaces* Expression
72                / "if" Spaces* Expression
73                Spaces* "then" Spaces* Expression
74                Spaces* "else" Spaces* Expression
75                / "case" Spaces* Expression
76                Spaces* "of" Spaces* "{" Alts "}"
77                / "do" Spaces* "{" Spaces* Statements Spaces* "}"
78                / FuncApplyExpression
79                )
80
81    (FuncApplyExpression 
82     <- (:atom AtomExpression)
83     (:rest-atoms ((Spaces (:inatm AtomExpression) :return inatm) *))
84     Spaces* :return `(:funapply ,atom ,@rest-atoms))
85    (AtomExpression
86     <- QVar
87     / GCon
88     / Literal
89     / "(" Spaces* Expression Spaces* ")"
90     / "(" Spaces* Expression Spaces* ("," Spaces* Expression Spaces*)+ ")"
91     / "[" Spaces* Expression Spaces* ("," Spaces* Expression Spaces*)* "]"
92     / "[" Spaces* Expression ( "," Spaces* Expression Spaces* )?
93     ".." Spaces* Expression?  Spaces* "]"
94     / "[" Spaces* Expression Spaces*
95     "|" Spaces* Qual Spaces* ("," Spaces* Qual Spaces*)+ "]"
96     ;; / "(" Spaces* Expression Spaces* QualifiedOperator(A,i) ")"
97     ;; / "(" LeftExpression(i) QualifiedOperator(L,i) ")"
98     ;; / "(" QualifiedOperator(A,i) "<->" Expression(i+1) ")"
99     ;; / "(" QualifiedOperator(R,i) "<->" RightExpression(i) ")"
100     ;; / QualifiedConstructor "{" [ FBind ("," FBind)* ] "}"
101     ;; / AtomExpression<QualifiedConstructor> "{" FBind ("," FBind)* "}"
102     )
103
104    (AtomPattern
105     <- QVar
106     / GCon
107     QCon Spaces "{" Spaces*
108     ( FieldPattern Spaces*
109                    ("," Spaces* FieldPattern Spaces*) * )
110     ? "}"
111     / Literal
112     / "_"
113     / "(" Spaces* Pattern Spaces* ")"
114     / "(" Spaces* Pattern Spaces* ("," Spaces* Pattern Spaces*) + ")"
115     / "[" Spaces* Pattern Spaces* ("," Spaces* Pattern Spaces*) * "]"
116     / "~" Spaces* AtomPattern)
117
118    (QVar <- LexQVarId
119          / "(" Spaces* (:sym LexQVarSym) Spaces* ")" :return sym)
120    (GCon <- "(" Spaces* ")"
121          / "[" Spaces* "]"
122          / "(" Spaces* ("," Spaces*)+ ")"
123          / QCon)
124    (QCon <- LexQConId / "(" Spaces* LexGConSym Spaces* ")")
125
126    (Context <-  Class / 
127             "(" Spaces* 
128             ( Class Spaces* ("," Spaces* Class Spaces*) * ) ? ")")
129    (Class <- LexQtyCls Spaces LexTyVar
130           / LexQtyCls "(" LexTyVar AType + ")")
131    (SimpleType <- (:con LexTyCon) (:vars SimpleTypeVars)
132                :return (make <ast-simple-type> :name con :vars vars))
133    (SimpleTypeVars <- Spaces (:var LexTyVar) (:vars SimpleTypeVars)
134                    :return (cons var vars)
135                    / :return ())
136    (Type <- (:type BType) Spaces* (:rest-types Type%)
137          :return
138          (if (null? rest-types)
139              type
140              (make <ast-multi-type> :types (cons type rest-types))))
141    (Type% <- "->" Spaces* (:type Type) (:rest-types Type%)
142           :return (cons type rest-types)
143           / :return ())
144    (BType <- (:type AType) (:rest-types BType%) 
145           :return (cond
146                    ((is-a? type <ast-single-type>)
147                     (begin (set! (type-vars type) rest-types)
148                            type))
149                    ((and (is-a? #?=type <ast-multi-type>)
150                          (null? #?=rest-types))
151                     type)
152                    (else (error "Type error"))))
153    (BType% <- Spaces (:type AType) (:rest-types BType%)
154            :return (cons type rest-types)
155            / :return ())
156    (AType <- GtyCon
157           / (:id LexTyVar) :return (make <ast-type-var> :var id)
158           / "(" Spaces* (:t1 Type) Spaces* ","
159           Spaces* (:t2 Type) Spaces* (:rest AType%) ")"
160           :return (make <ast-single-type> :name '$Tuple
161                         :arity (+ 2 (length rest))
162                         :vars `(,t1 ,t2 ,@rest))
163           / "[" Spaces* Type Spaces* "]"
164           / "(" Spaces* (:t Type) Spaces* ")" :return t)
165    (AType% <- "," Spaces* (:t Type) Spaces* (:rest AType%)
166            :return (cons t rest)
167            / :return ())
168    (GtyCon <- (:tycon LexQtyCon)
169            :return (make <ast-single-type> :name (cadr tycon)
170                          :module (car tycon))
171            / "(" Spaces* ")"
172            :return (make <ast-single-type> :name '$Unit :arity 0)
173            / "[" Spaces* "]"
174            :return '(make <ast-single-type> :name '$Unit :arity 0)
175            ; / "(" Spaces* "->" Spaces* ")"
176            / "(" Spaces* (:commas (("," Spaces*) +)) ")"
177            :return (make <ast-single-type> :name '$Tuple 
178                          :arity (+ 1 (length commas))))
179    (Literal <- Float / Integer / Char / String)
180    (Integer <- Decimal / "0o" Octal / "00" Octal
181             / "0x" Hexadecimal / "0X" Hexadecimal)
182    (Float <- Decimal "." Decimal Exponent ?
183           / Decimal Exponent)
184    (Char <- "'" (LexGraphic / LexSpace / LexEscape) "'")
185    (String <- "\"" (LexGraphic / LexSpace / LexEscape / LexGap) * "\"")
186    (Decimal <- LexDigit LexDigit *)
187    (Exponent <- #[eE] #[-+] Decimal)
188
189    (Constructors <- Constructor Spaces* ("|" Spaces* Constructor Spaces*) *)
190    (Constructor <-
191                 ;; I don't know about this case
192;;               / (BType / "!" Spaces* AType)
193;;               Spaces* ConstructorOperator
194;;               Spaces* (BType / "!" Spaces* AType)
195                 LexCon Spaces*
196                 "{" (Spaces*
197                 FieldDecl Spaces*
198                 ("," Spaces* FieldDecl Spaces*) * )* "}"
199                 /  LexCon Spaces* ("!" ? Spaces* AType Spaces*) *
200                 )
201    (FieldDecl <- Variables Spaces* "::"
202               Spaces* (Type / "!" Spaces* AType))
203    (Variables <- Variable Spaces* ("," Spaces* Variable Spaces*) *)
204    (Variable <- LexVarId / "(" Spaces* LexVarSym Spaces* ")")
205    (Deriving <- "deriving"
206              Spaces
207              (DClass 
208               / "(" (DClass Spaces* ("," Spaces* DClass Spaces) * )? ")"))
209
210    ;; Tokens
211
212    ;; incompl
213    (LexCon <- LexConId
214            ; / LexConSym
215            )
216    (LexConSym <- I Dont Know)
217    (LexModId <- LexConId)
218    (LexTyVar <- LexVarId)
219    (LexTyCon <- LexConId)
220    (LexTyCls <- LexConId)
221    (LexQVarId <- (LexModId ".") ? LexVarId)
222    (LexQVarSym <- (LexModId ".") ? LexVarSym)
223    (LexQConId <- (LexModId ".") ? LexConId)
224    (LexQConSym <- (LexModId ".") ? LexConSym)
225    (LexQtyCon <- (:mod ((LexModId ".") ?)) (:tycon LexTyCon)
226               :return (if mod `(,(car mod) ,tycon)
227                           `(#f ,tycon)))
228    (LexQtyCls <- (LexModId ".") ? LexTyCls)
229    (LexGConSym <- ":" / LexQConSym )
230
231    (LexConId <- (:init LexLarge) (:rest LexIdRest)
232              :return (string->symbol (tree->string (cons init rest))))
233    (LexVarId <- (:init LexSmall) (:rest LexIdRest)
234              :return (string->symbol (tree->string (cons init rest))))
235    (LexVarSym <- LexSymbol (":" / LexSymbol) *)
236    (LexConSym <- LexSymbol (":" / LexSymbol) *)
237    (LexLarge <- #[A-Z])
238    (LexSmall <- #[a-z])
239    (LexIdRest <- #[A-Za-z'0-9] *)
240    (LexSymbol <- #[-!#$%&*+\./<=>?@\\^\|~])
241
242    (LexDigit <- #[0-9])
243
244    (Spaces* <- Space *)
245    (Spaces <- Space +)
246    (Space <- #[ \t\n])
247    )
248   str))
249
250
251(define-method hascheme:ast-print ((ast <ast-decls>))
252  (let1 ast-decls (decls ast)
253    (unless (null? ast-decls)
254      (hascheme:ast-print (car ast-decls))
255      (unless (null? (cdr ast-decls))
256        (display "; ")
257        (for-each hascheme:ast-print (cdr ast-decls))))))
258
259(define-method hascheme:ast-print ((ast <ast-type-decl>))
260  (hascheme:ast-print (type-decl-left ast))
261  (display " = ")
262  (hascheme:ast-print (type-decl-right ast)))
263
264(define-method hascheme:ast-print ((ast <ast-simple-type>))
265  (let1 vars (type-vars ast)
266    (cond
267     ((null? vars) (display (type-name ast)))
268     (else
269      (display (type-name ast))
270      (for-each (lambda (sym) (format #t " ~a" sym))
271                vars)))))
272
273(define-method hascheme:ast-print ((ast <ast-single-type>))
274  (let1 vars (type-vars ast)
275    (cond
276     ((null? vars) (display (type-name ast)))
277     (else
278      (display (type-name ast))
279      (for-each (lambda (var)
280                  (cond
281                   ((symbol? var) (format #t " ~a" var))
282                   ((is-a? var <ast-type-var>)
283                    (display " ")
284                    (hascheme:ast-print var))
285                   ((is-a? var <ast>)
286                    (display " (")
287                    (hascheme:ast-print var)
288                    (display ")"))
289                   (error "Invalid type")))
290                vars)))))
291
292(define-method hascheme:ast-print ((ast <ast-type-var>))
293  (display (type-var ast)))
294
295(define (hascheme:parser-test)
296  (test* "Simplest body" '(())
297         (hascheme:parse "{}")))
298
299(provide "hascheme/parser")
Note: See TracBrowser for help on using the browser.