;; -*- Hen -*-
;;
;;  A grammar for a simple ML-like language.
;;
;;  Based on the code and paper by Xavier Leroy (2000): A modular
;;  module system. Journal of Functional Programming, 10, pp 269-303
;;  doi:10.1017/S0956796800003683
;;
;;
;; Copyright 2010-2012 Ivan Raikov and the Okinawa Institute of
;; Science and Technology.
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.
;;

(require-extension lalr static-modules miniML)

(define expr-parser
  (lalr-parser

   (output:  parser "miniML.grm.scm")

   (out-table: "miniML.grm.out")

   ;; --- token definitions

   (IDENT STRING LABEL NAT REAL ELSE
	  END EOF FUNCTOR 
	  IF IN  LET  MODULE
	  RPAREN RBRACE SEMISEMI RETURN
	  SIG STRUCT THEN TYPE VALUE
	  (left: COMMA DOT FUNCTION)
	  (left: LG LESS LEQ GREATER GEQ EQ EQUAL)
	  (left: PLUS MINUS STAR SLASH)
	  (right: ARROW)
	  (right: LPAREN LBRACE SEMICOLON COLON QUOTE POUND))

   ;; Toplevel entry point 

   (phrase
    (moddef)          :           (list $1)
    (phrase SEMISEMI moddef) :    (cons $3 $1)
    )
   
   ;; Paths 

   (path
    (IDENT)            : (Pident  $1)
    (path DOT IDENT)   : (Pdot $1 (ident-name $3))) 

   ;; Value expressions for the core language 

   (valexpr
    (valexpr1)                          : $1
    (valexpr COMMA valexpr)             : (binop "pair" $1 $3 )
    (valexpr PLUS valexpr)              : (binop "add" $1 $3 )
    (valexpr MINUS valexpr)             : (binop "sub" $1 $3 )
    (valexpr STAR valexpr)              : (binop "mul" $1 $3 )
    (valexpr SLASH valexpr)             : (binop "div" $1 $3 )
    (valexpr EQ valexpr)                : (binop "==" $1 $3 )
    (valexpr LG valexpr)                : (binop "<>" $1 $3 )
    (valexpr LESS valexpr)              : (binop "<" $1 $3 )
    (valexpr LEQ valexpr)               : (binop "<=" $1 $3 )
    (valexpr GREATER valexpr)           : (binop ">" $1 $3 )
    (valexpr GEQ valexpr)               : (binop ">=" $1 $3 )
    (FUNCTION IDENT ARROW valexpr)      : (Function $2 $4)
    (LET IDENT valbind IN valexpr)      : (Let0 $2 $3 $5) 
    (IF valexpr THEN valexpr ELSE valexpr) : (ternop "cond" $2 $4 $6)
    )

   (valexpr1
    (valexpr0) : $1 
    (valexpr1 valexpr0) : (Apply $1 $2))

   (valexpr0
    (path)                              : (Longid $1)
    (STRING)                            : (Const `(string ,$1))
    (LABEL)                             : (Const `(label ,$1))
    (REAL)                              : (Const `(real ,$1))
    (NAT)                               : (Const `(nat ,$1))
    (LPAREN valexpr RPAREN)             : $2 
    (POUND IDENT valexpr)               : (Rproj (string->symbol (ident-name $2)) $3)
    (LBRACE rfieldlist RBRACE)          : (Rcon  (sort $2 rfield-compare))
    )

   (valbind
    (EQUAL valexpr)     : $2 
    (IDENT valbind)     : (Function $1 $2)
    )

   (rfield
    (IDENT EQUAL valexpr)                : (cons $1 $3 )
    )

   (rfieldlist
    (rfield) :  (list $1)
    (rfieldlist COMMA rfield) : (cons $3 $1)
    )

   ;; Type expressions for the core language 

   (simpletype
    (QUOTE IDENT)                 : (Tvar (find-type-variable $2)) 
    (simpletype ARROW simpletype) : (Tcon (Tpath path-arrow) (list $1 $3))
    (simpletype STAR simpletype)  : (Tcon (Tpath path-star) (list $1 $3))
    (path)                        : (Tcon (Tpath $1) '())
    (simpletype path)             : (Tcon (Tpath $2) (list $1))
    (LPAREN simpletypelist RPAREN path) :  (Tcon (Tpath $4) (reverse $2))
    (LBRACE rfieldtypelist RBRACE) :  (let ((fs (sort $2 rfield-compare ))) 
					(Tcon (Trec (map car fs)) (map cdr fs)))
					      
    )


   (simpletypelist
    (simpletype) :  (list $1)
    (simpletypelist COMMA simpletype) : (cons $3 $1)
    )


   (rfieldtype
    (IDENT COLON simpletype)                : (cons (string->symbol (ident-name $1)) $3 )
    )


   (rfieldtypelist
    (rfieldtype) :  (list $1)
    (rfieldtypelist COMMA rfieldtype) : (cons $3 $1)
    )


   (valuedecl
    (colon-begin-scheme simpletype) : (begin (reset-type-variables)
					     (end-def)
					     (generalize $2)))

   (colon-begin-scheme ;; Hack to perform side effects before reading the type 
    (COLON):   (begin
		 (begin-def)
		 (reset-type-variables)))


   ;; Type definitions and declarations 

   (typedecl
    (typeparams IDENT) :        (list $2 (make-kind (length $1))))

   (typedef
    (typeparams IDENT EQUAL simpletype):   (begin
					     (reset-type-variables)
					     (list $2 (make-kind (length $1)) (make-deftype $1 $4)))
    )

   (typeparams
    () : '()
    (typeparam) :  (list $1)
    (LPAREN typeparamlist RPAREN) : (reverse $2))

   (typeparamlist
    (typeparam) : (list $1)
    (typeparamlist COMMA typeparam) :   (cons $3 $1 ))

   
   (typeparam
    (QUOTE IDENT) : (find-type-variable $2))

   (typeinfo
    (typedef) :   (begin
		    (let ((id (car $1)) (kind (cadr $1)) (def (caddr $1)))
		      (list id (make-typedecl kind def))))
    (typedecl) :  (begin
		    (let ((id (car $1)) (kind (cadr $1)))
		      (list id (make-typedecl kind #f)))))


;; Value expressions for the module language 

   (modterm
    (path) :                              (Modid $1)
    (STRUCT modstruct END) :              (Structure (reverse $2))
    (FUNCTOR LPAREN IDENT COLON modtype RPAREN modterm) : (Functor $3 $5 $7)
    (modterm LPAREN modterm RPAREN) : (Mapply $1 $3)
    (LPAREN modterm RPAREN) :           $2 
    (modterm COLON modtype) :        (Constraint $1 $3))

   (modstruct
    () : '()
    (modstruct moddef opt_semi) : (cons $2  $1))


   (moddef
    (VALUE IDENT valbind) :            (Value_def $2 $3)
    (TYPE typedef) :                   (begin
					 (let ((id (car $2)) (kind (cadr $2)) (def (caddr $2)))
					   (Type_def id kind def)))
    (MODULE IDENT COLON modtype EQUAL modterm) : (Module_def $2 (Constraint $6 $4))
    (MODULE IDENT EQUAL modterm) :   (Module_def $2 $4))

   (opt_semi
    () : '()
    (SEMICOLON) : '())


   ;; Type expressions for the module language 

   (modtype
    (SIG modsig END) :               (Signature (reverse $2))
    (FUNCTOR LPAREN IDENT COLON modtype RPAREN modtype) : (Functorty $3 $5 $7)
    (LPAREN modtype RPAREN) :        $2 
    )

   (modsig
    () : '()
    (modsig modspec opt_semi) : (cons $2  $1 ))

   (modspec
    (VALUE IDENT valuedecl) :         (Value_sig $2 $3)
    (TYPE typeinfo) :                 (begin
					(let ((id (car $2))
					      (def (cadr $2)))
					  (Type_sig id def) ))
    (MODULE IDENT COLON modtype) :   (Module_sig $2 $4)
    )


))