| 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") |
|---|
