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

;; -*- coding: utf-8 mode: scheme -*-

(use text.tree)
(require "hascheme/peg-parser")

(define-class <ast> () ())
(define-class <ast-decl> (<ast>) ())
(define-class <ast-type-decl> (<ast-decl>)
  ((left :init-keyword :left :getter type-decl-left)
   (right :init-keyword :right :getter type-decl-right)))
(define-class <ast-type> (<ast>) ())
(define-class <ast-type-var> (<ast>) 
  ((type-var :init-keyword :var :getter type-var)))
(define-class <ast-single-type> (<ast-type>)
  ((type-name :init-keyword :name :getter type-name)
   (type-arity :init-keyword :arity :accessor type-arity)
   (type-vars :init-keyword :vars :accessor type-vars :init-value #f)
   (type-module :init-keyword :module :getter type-module :init-value #f)))
(define-class <ast-multi-type> (<ast-type>)
  ((types :init-keyword :name :accessor types)))
(define-class <ast-simple-type> (<ast>) ())
(define-method make-type-decl ((left <ast-simple-type>) (right <ast-type>))
  ; (make <type-decl> :left left :right right)
  `(:type-decl ,left ,right))

(define (hascheme:parse str)
  (parse-string-with
   (
    ;; incompl
    (Module <- "module" Spaces LexModId Spaces "where" Spaces Body
            / Body)
    (Body <- "{" (:decls TopDecls) "}" :return decls)
    (TopDecls <- Spaces* (:decl TopDecl) (:rest-decls TopDecls%) Spaces*
              :return `(:decls ,decl ,@rest-decls)
              / Spaces* :return ())
    (TopDecls% <- Spaces* ";" Spaces* TopDecl TopDecls%
              / :return ())

    ;; incoml
    (TopDecl <-
             "type" Spaces (:left SimpleType) Spaces*
             "=" Spaces* (:right Type)
             :return (make-type-decl left right)
             / "data" Spaces ( Context Spaces* "=>" Spaces*) ? SimpleType
             Spaces* "="
             Spaces* Constructors
             Spaces* Deriving ?

             / Decl
             )
    (Decls <- "{" Spaces* Decl Spaces* ("," Decl Spaces*) * "}")
    
    ;; incompl
    (Decl <- GenDecl
          ;; /(FunctionLHS / Variable) RHS ;; do this later
          / Variable Spaces* RHS)
    ;; incompl
    (GenDecl <- Variables Spaces* "::" Spaces*
             ( Context Spaces* "=>" Spaces* ) ? Type
             ;; / Fixity LexInteger ? Operators ;; later
             )
    ;; incompl
    (RHS <- "=" Spaces* Expression (Spaces "where" Spaces Decls) ?)

    (Expression <- "\\" Spaces* AtomPattern 
                (Spaces AtomPattern) * Spaces* "->" Spaces* Expression
                / "let" Spaces* Decls Spaces* "in" Spaces* Expression
                / "if" Spaces* Expression
                Spaces* "then" Spaces* Expression
                Spaces* "else" Spaces* Expression
                / "case" Spaces* Expression
                Spaces* "of" Spaces* "{" Alts "}"
                / "do" Spaces* "{" Spaces* Statements Spaces* "}"
                / FuncApplyExpression
                )

    (FuncApplyExpression <- AtomExpression +)
    (AtomExpression
     <- QVar
     / GCon
     / Literal
     / "(" Spaces* Expression Spaces* ")"
     / "(" Spaces* Expression Spaces* ("," Spaces* Expression Spaces*)+ ")"
     / "[" Spaces* Expression Spaces* ("," Spaces* Expression Spaces*)* "]"
     / "[" Spaces* Expression ( "," Spaces* Expression Spaces* )?
     ".." Spaces* Expression?  Spaces* "]"
     / "[" Spaces* Expression Spaces*
     "|" Spaces* Qual Spaces* ("," Spaces* Qual Spaces*)+ "]"
     ;; / "(" Spaces* Expression Spaces* QualifiedOperator(A,i) ")"
     ;; / "(" LeftExpression(i) QualifiedOperator(L,i) ")"
     ;; / "(" QualifiedOperator(A,i) "<->" Expression(i+1) ")"
     ;; / "(" QualifiedOperator(R,i) "<->" RightExpression(i) ")"
     ;; / QualifiedConstructor "{" [ FBind ("," FBind)* ] "}"
     ;; / AtomExpression<QualifiedConstructor> "{" FBind ("," FBind)* "}"
     )

    (AtomPattern
     <- QVar
     / GCon
     QCon Spaces "{" Spaces*
     ( FieldPattern Spaces*
                    ("," Spaces* FieldPattern Spaces*) * )
     ? "}"
     / Literal
     / "_"
     / "(" Spaces* Pattern Spaces* ")"
     / "(" Spaces* Pattern Spaces* ("," Spaces* Pattern Spaces*) + ")"
     / "[" Spaces* Pattern Spaces* ("," Spaces* Pattern Spaces*) * "]"
     / "~" Spaces* AtomPattern)

    (QVar <- LexQVarId / "(" Spaces* LexQVarSym Spaces* ")")
    (GCon <- "(" Spaces* ")"
          / "[" Spaces* "]"
          / "(" Spaces* ("," Spaces*)+ ")"
          / QCon)
    (QCon <- LexQConId / "(" Spaces* LexGConSym Spaces* ")")

    (Context <-  Class / 
             "(" Spaces* 
             ( Class Spaces* ("," Spaces* Class Spaces*) * ) ? ")")
    (Class <- LexQtyCls Spaces LexTyVar
           / LexQtyCls "(" LexTyVar AType + ")")
    (SimpleType <- (:con LexTyCon) (:vars SimpleTypeVars)
                :return `(:type-name ,con :vars ,vars))
    (SimpleTypeVars <- Spaces (:var LexTyVar) (:vars SimpleTypeVars)
                    :return (cons var vars)
                    / :return ())
    (Type <- (:type BType) Spaces* (:rest-types Type%)
          :return `(:type ,type ,@rest-types))
    (Type% <- "->" Spaces* (:type Type) (:rest-types Type%)
           :return (cons type rest-types)
           / :return ())
    (BType <- (:type AType) (:rest-types BType%) 
           :return (cons type rest-types))
    (BType% <- Spaces (:type AType) (:rest-types BType%)
            :return (cons type rest-types)
            / :return ())
    (AType <- GtyCon
           / (:id LexTyVar) :return (make <ast-type-var> :var id)
           / "(" Spaces* (:t1 Type) Spaces* ","
           Spaces* (:t2 Type) Spaces* (:rest AType%) ")"
           :return (make <ast-simple-type> :name '$Tuple
                         :arity (+ 2 (length rest))
                         :vars `(,t1 ,t2 ,@rest))
           / "[" Spaces* Type Spaces* "]"
           / "(" Spaces* Type Spaces* ")")
    (AType% <- "," Spaces* (:t Type) Spaces* (:rest AType%)
            :return (cons t rest)
            / :return ())
    (GtyCon <- LexQtyCon
            / "(" Spaces* ")"
            :return (make <ast-single-type> :name '$Unit :arity 0 :vars ())
            / "[" Spaces* "]"
            :return '(make <ast-single-type> :name '$Unit :arity 0)
            ; / "(" Spaces* "->" Spaces* ")"
            / "(" Spaces* (:commas (("," Spaces*) +)) ")"
            :return (make <ast-single-type> :name '$Tuple 
                          :arity (+ 1 (length commas))))
    (Literal <- Float / Integer / Char / String)
    (Integer <- Decimal / "0o" Octal / "00" Octal
             / "0x" Hexadecimal / "0X" Hexadecimal)
    (Float <- Decimal "." Decimal Exponent ?
           / Decimal Exponent)
    (Char <- "'" (LexGraphic / LexSpace / LexEscape) "'")
    (String <- "\"" (LexGraphic / LexSpace / LexEscape / LexGap) * "\"")
    (Decimal <- LexDigit LexDigit *)
    (Exponent <- #[eE] #[-+] Decimal)

    (Constructors <- Constructor Spaces* ("|" Spaces* Constructor Spaces*) *)
    (Constructor <-
                 ;; I don't know about this case
;;               / (BType / "!" Spaces* AType)
;;               Spaces* ConstructorOperator
;;               Spaces* (BType / "!" Spaces* AType)
                 LexCon Spaces*
                 "{" (Spaces*
                 FieldDecl Spaces*
                 ("," Spaces* FieldDecl Spaces*) * )* "}"
                 /  LexCon Spaces* ("!" ? Spaces* AType Spaces*) *
                 )
    (FieldDecl <- Variables Spaces* "::"
               Spaces* (Type / "!" Spaces* AType))
    (Variables <- Variable Spaces* ("," Spaces* Variable Spaces*) *)
    (Variable <- LexVarId / "(" Spaces* LexVarSym Spaces* ")")
    (Deriving <- "deriving"
              Spaces
              (DClass 
               / "(" (DClass Spaces* ("," Spaces* DClass Spaces) * )? ")"))

    ;; Tokens

    ;; incompl
    (LexCon <- LexConId
            ; / LexConSym
            )
    (LexConSym <- I Dont Know)
    (LexModId <- LexConId)
    (LexTyVar <- LexVarId)
    (LexTyCon <- LexConId)
    (LexTyCls <- LexConId)
    (LexQVarId <- (LexModId ".") ? LexVarId)
    (LexQVarSym <- (LexModId ".") ? LexVarSym)
    (LexQConId <- (LexModId ".") ? LexConId)
    (LexQConSym <- (LexModId ".") ? LexConSym)
    (LexQtyCon <- (:mod ((LexModId ".") ?)) (:tycon LexTyCon)
               :return (if mod `(:module ,(car mod) ,@tycon)
                           `(:module #f ,@tycon)))
    (LexQtyCls <- (LexModId ".") ? LexTyCls)
    (LexGConSym <- ":" / LexQConSym )

    (LexConId <- (:init LexLarge) (:rest LexIdRest)
              :return (string->symbol (tree->string (cons init rest))))
    (LexVarId <- (:init LexSmall) (:rest LexIdRest)
              :return (string->symbol (tree->string (cons init rest))))
    (LexVarSym <- LexSymbol (":" / LexSymbol) *)
    (LexConSym <- LexSymbol (":" / LexSymbol) *)
    (LexLarge <- #[A-Z])
    (LexSmall <- #[a-z])
    (LexIdRest <- #[A-Za-z'0-9] *)
    (LexSymbol <- #[-!#$%&*+\./<=>?@\\^\|~])

    (LexDigit <- #[0-9])

    (Spaces* <- Space *)
    (Spaces <- Space +)
    (Space <- #[ \t\n])
    )
   str))


(define (hascheme:parser-test)
  (test* "Simplest body" '(())
         (hascheme:parse "{}")))

(provide "hascheme/parser")