[15] | 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>) ()) |
---|
[23] | 8 | (define-class <ast-decls> (<ast>) |
---|
| 9 | ((delcs :init-keyword :decls :getter decls))) |
---|
[15] | 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) |
---|
[23] | 18 | (type-arity :init-keyword :arity :accessor type-arity :init-value #f) |
---|
[15] | 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] | 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 | |
---|
[15] | 27 | (define-method make-type-decl ((left <ast-simple-type>) (right <ast-type>)) |
---|
[23] | 28 | (make <ast-type-decl> :left left :right right)) |
---|
[15] | 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* |
---|
[23] | 38 | :return (make <ast-decls> :decls (cons decl rest-decls)) |
---|
[15] | 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 | |
---|
[23] | 81 | (FuncApplyExpression |
---|
| 82 | <- (:atom AtomExpression) |
---|
| 83 | (:rest-atoms ((Spaces (:inatm AtomExpression) :return inatm) *)) |
---|
| 84 | Spaces* :return `(:funapply ,atom ,@rest-atoms)) |
---|
[15] | 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 | |
---|
[23] | 118 | (QVar <- LexQVarId |
---|
| 119 | / "(" Spaces* (:sym LexQVarSym) Spaces* ")" :return sym) |
---|
[15] | 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) |
---|
[23] | 132 | :return (make <ast-simple-type> :name con :vars vars)) |
---|
[15] | 133 | (SimpleTypeVars <- Spaces (:var LexTyVar) (:vars SimpleTypeVars) |
---|
| 134 | :return (cons var vars) |
---|
| 135 | / :return ()) |
---|
| 136 | (Type <- (:type BType) Spaces* (:rest-types Type%) |
---|
[23] | 137 | :return |
---|
| 138 | (if (null? rest-types) |
---|
| 139 | type |
---|
| 140 | (make <ast-multi-type> :types (cons type rest-types)))) |
---|
[15] | 141 | (Type% <- "->" Spaces* (:type Type) (:rest-types Type%) |
---|
| 142 | :return (cons type rest-types) |
---|
| 143 | / :return ()) |
---|
| 144 | (BType <- (:type AType) (:rest-types BType%) |
---|
[23] | 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")))) |
---|
[15] | 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%) ")" |
---|
[23] | 160 | :return (make <ast-single-type> :name '$Tuple |
---|
[15] | 161 | :arity (+ 2 (length rest)) |
---|
| 162 | :vars `(,t1 ,t2 ,@rest)) |
---|
| 163 | / "[" Spaces* Type Spaces* "]" |
---|
[23] | 164 | / "(" Spaces* (:t Type) Spaces* ")" :return t) |
---|
[15] | 165 | (AType% <- "," Spaces* (:t Type) Spaces* (:rest AType%) |
---|
| 166 | :return (cons t rest) |
---|
| 167 | / :return ()) |
---|
[23] | 168 | (GtyCon <- (:tycon LexQtyCon) |
---|
| 169 | :return (make <ast-single-type> :name (cadr tycon) |
---|
| 170 | :module (car tycon)) |
---|
[15] | 171 | / "(" Spaces* ")" |
---|
[23] | 172 | :return (make <ast-single-type> :name '$Unit :arity 0) |
---|
[15] | 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) |
---|
[23] | 226 | :return (if mod `(,(car mod) ,tycon) |
---|
| 227 | `(#f ,tycon))) |
---|
[15] | 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 | |
---|
[23] | 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 | |
---|
[15] | 295 | (define (hascheme:parser-test) |
---|
| 296 | (test* "Simplest body" '(()) |
---|
| 297 | (hascheme:parse "{}"))) |
---|
| 298 | |
---|
| 299 | (provide "hascheme/parser") |
---|