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