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

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

(define-class <ast> () ())
(define-class <ast-decl> (<ast>) ())
(define-class <ast-decls> (<ast>)
  ((delcs :init-keyword :decls :getter decls)))
(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 :init-value #f)
   (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>)
  ((type-name :init-keyword :name :getter type-name)
   (type-vars :init-keyword :vars :getter type-vars)))

(define-method make-type-decl ((left <ast-simple-type>) (right <ast-type>))
  (make <ast-type-decl> :left left :right 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 (make <ast-decls> :decls (cons 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 
     <- (:atom AtomExpression)
     (:rest-atoms ((Spaces (:inatm AtomExpression) :return inatm) *))
     Spaces* :return `(:funapply ,atom ,@rest-atoms))
    (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* (:sym LexQVarSym) Spaces* ")" :return sym)
    (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 (make <ast-simple-type> :name con :vars vars))
    (SimpleTypeVars <- Spaces (:var LexTyVar) (:vars SimpleTypeVars)
		    :return (cons var vars)
		    / :return ())
    (Type <- (:type BType) Spaces* (:rest-types Type%)
	  :return
	  (if (null? rest-types)
	      type
	      (make <ast-multi-type> :types (cons type rest-types))))
    (Type% <- "->" Spaces* (:type Type) (:rest-types Type%)
	   :return (cons type rest-types)
	   / :return ())
    (BType <- (:type AType) (:rest-types BType%) 
	   :return (cond 
		    ((is-a? type <ast-single-type>)
		     (begin (set! (type-vars type) rest-types)
			    type))
		    ((and (is-a? #?=type <ast-multi-type>)
			  (null? #?=rest-types))
		     type)
		    (else (error "Type error"))))
    (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-single-type> :name '$Tuple
			 :arity (+ 2 (length rest))
			 :vars `(,t1 ,t2 ,@rest))
	   / "[" Spaces* Type Spaces* "]"
	   / "(" Spaces* (:t Type) Spaces* ")" :return t)
    (AType% <- "," Spaces* (:t Type) Spaces* (:rest AType%)
	    :return (cons t rest)
	    / :return ())
    (GtyCon <- (:tycon LexQtyCon)
	    :return (make <ast-single-type> :name (cadr tycon)
			  :module (car tycon))
	    / "(" Spaces* ")"
	    :return (make <ast-single-type> :name '$Unit :arity 0)
	    / "[" 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 `(,(car mod) ,tycon)
			   `(#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-method hascheme:ast-print ((ast <ast-decls>))
  (let1 ast-decls (decls ast)
    (unless (null? ast-decls)
      (hascheme:ast-print (car ast-decls))
      (unless (null? (cdr ast-decls))
	(display "; ")
	(for-each hascheme:ast-print (cdr ast-decls))))))

(define-method hascheme:ast-print ((ast <ast-type-decl>))
  (hascheme:ast-print (type-decl-left ast))
  (display " = ")
  (hascheme:ast-print (type-decl-right ast)))

(define-method hascheme:ast-print ((ast <ast-simple-type>))
  (let1 vars (type-vars ast)
    (cond
     ((null? vars) (display (type-name ast)))
     (else
      (display (type-name ast))
      (for-each (lambda (sym) (format #t " ~a" sym))
		vars)))))

(define-method hascheme:ast-print ((ast <ast-single-type>))
  (let1 vars (type-vars ast)
    (cond
     ((null? vars) (display (type-name ast)))
     (else
      (display (type-name ast))
      (for-each (lambda (var)
		  (cond
		   ((symbol? var) (format #t " ~a" var))
		   ((is-a? var <ast-type-var>)
		    (display " ")
		    (hascheme:ast-print var))
		   ((is-a? var <ast>)
		    (display " (")
		    (hascheme:ast-print var)
		    (display ")"))
		   (error "Invalid type")))
		vars)))))

(define-method hascheme:ast-print ((ast <ast-type-var>))
  (display (type-var ast)))

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

(provide "hascheme/parser")