;;; File: module-parser         Author: John

;;; This is for using the parser to parse strings.

(define (parse-from-string string parse-proc filename)
 (dynamic-let ((*current-file* filename))
  (call-with-input-string string
    (lambda (port)
      (let ((tokens (lex-port port '#f)))
	(init-token-stream tokens)
	(let ((res (funcall parse-proc)))
	  (if (not (eq-token? 'eof))
	      (signal-leftover-tokens)
	      res)))))))

(define (signal-leftover-tokens)
  (fatal-error 'leftover-tokens
	       "Leftover tokens after parsing."))


;;; This file deals with the basic structure of a module.  It also adds
;;; the `module Main where' required by abbreviated modules.

(define (parse-tokens tokens)
  (init-token-stream tokens)
  (let ((mod (token-case
	      (|module| (parse-module))
	      (else (parse-modules/named '|Main| '())))))
    (cons mod (parse-module-list))))

(define (parse-module)
  (token-case
   (modid (let* ((mod-name (token->symbol))
		 (exports (parse-exports)))
	    (require-token
	      |where|
	      (signal-missing-token "`where'" "module definition"))
	    (parse-modules/named mod-name exports)))
   (else (signal-missing-token "<modid>" "module definition"))))

(define (parse-module-list)
  (token-case
   (|module|
    (let ((mod (parse-module)))
      (cons mod (parse-module-list))))
   (eof '())
   (else (signal-missing-module))))

(define (signal-missing-module)
  (parser-error 'missing-module
		"Missing `module', or leftover junk after module definition."))

(define (parse-exports)
  (token-case
   (\( (parse-export-list))
   (else '())))

(define (parse-export-list)
  (let ((entity (parse-entity 'export)))
    (token-case
     (\) (list entity))
     (\, (cons entity (parse-export-list)))
     (else (signal-missing-token "`)' or ','" "export list")))))

(define (parse-modules/named mod-name exports)
  (trace-parser module
    (let ((mod-ast (make module
		     (name mod-name)
		     (type 'standard)
		     (exports exports)
		     (default *standard-module-default*))))
      (start-layout (lambda (in-layout?)
		      (parse-module-decls mod-ast in-layout? 'import))))))

;;; The mod-ast fields are kept in non-reversed order by appending
;;; each decl to the end of the appropriate list.  This loses for
;;; value decls, so these are in reversed order!!

(define (parse-module-decls mod-ast in-layout? state)
  (token-case
   (|import| (let ((import (parse-import)))
	       (if (eq? state 'import)
		   (push-decl-list import (module-imports mod-ast))
		   (signal-misplaced-import)))
	     (terminate-topdecl mod-ast in-layout? state))
   (|infix| (terminate-topdecl mod-ast in-layout?
			       (parse-fixity 'n mod-ast state)))
   (|infixl| (terminate-topdecl mod-ast in-layout?
				(parse-fixity 'l mod-ast state)))
   (|infixr| (terminate-topdecl mod-ast in-layout?
				(parse-fixity 'r mod-ast state)))
   (|data| (let ((data-decl (parse-type-decl '#f)))
	     (push-decl-list data-decl (module-algdatas mod-ast)))
	   (terminate-topdecl mod-ast in-layout? 'topdecl))
   (|type| (let ((synonym-decl (parse-synonym-decl)))
	     (push-decl-list synonym-decl (module-synonyms mod-ast)))
	   (terminate-topdecl mod-ast in-layout? 'topdecl))
   (|class| (let ((class-decl (parse-class-decl)))
	      (push-decl-list class-decl (module-classes mod-ast)))
	    (terminate-topdecl mod-ast in-layout? 'topdecl))
   (|instance| (let ((instance-decl (parse-instance-decl '#f)))
		 (push-decl-list instance-decl (module-instances mod-ast)))
	       (terminate-topdecl mod-ast in-layout? 'topdecl))
   (|default| (let ((types 
		     (token-case
		      (\( (token-case (\) '())
				      (else (parse-type-list))))
		      (else (list (parse-type))))))
		(if (eq? (module-default mod-ast) *standard-module-default*)
		    (setf (module-default mod-ast)
			  (make default-decl (types types)))
		    (signal-multiple-defaults)))
    (terminate-topdecl mod-ast in-layout? 'topdecl))
   ((begin-annotation no-advance)
    (let ((annotations (parse-annotations)))
      (setf (module-annotations mod-ast)
	    (append (module-annotations mod-ast) annotations)))
    (terminate-topdecl mod-ast in-layout? state))
   (pat-start (let ((decl (parse-decl)))
		(setf (module-decls mod-ast)
		      (decl-push decl (module-decls mod-ast))))
	      (terminate-topdecl mod-ast in-layout? 'topdecl))
   (else
    (maybe-end-module mod-ast in-layout? state))))

(define (signal-misplaced-import)
  (parser-error 'misplaced-import
		"The import declaration is misplaced."))

(define (signal-multiple-defaults)
  (parser-error 'multiple-defaults
		"There are multiple default declarations."))

(define (terminate-topdecl mod-ast in-layout? state)
  (token-case
   (\; (parse-module-decls mod-ast in-layout? state))
   (else (maybe-end-module mod-ast in-layout? state))))

(define (maybe-end-module mod-ast in-layout? state)
  (declare (ignore state))
  (cond ((or (eq-token? '|module|) (eq-token? 'eof) (eq-token? '\})
	     (eq-token? '$\}))
	 (close-layout in-layout?)
	 (wrapup-module mod-ast)
	 mod-ast)
	(else
	 (signal-invalid-syntax "a topdecl"))))

(define (wrapup-module mod-ast)
  (setf (module-decls mod-ast)
	(nreverse (module-decls mod-ast)))
  (when (and (null? (module-imports mod-ast))
	     (null? (module-decls mod-ast))
	     (null? (module-algdatas mod-ast))
	     (null? (module-synonyms mod-ast))
	     (null? (module-instances mod-ast))
	     (null? (module-classes mod-ast)))
    (signal-empty-module)))

(define (signal-empty-module)
  (parser-error 'empty-module "Module definition is empty."))

(define (parse-import)
 (save-parser-context
  (token-case
   (modid (let ((mod (token->symbol))
		(mode 'all)
		(specs '()))
	    (token-case
	     (\( (setf mode 'by-name)
		 (token-case
		  (\) (setf specs '()))
		  (else (setf specs (parse-import-list)))))
	     (|hiding| (require-token
			 \(
			 (signal-missing-token "`('" "hiding clause"))
		       (setf specs (parse-import-list)))
	     (else '()))
	    (let ((renamings (token-case (|renaming|
					   (require-token
					     \(
					     (signal-missing-token
					       "`('" "renaming clause"))
					   (parse-renamings))
					 (else '()))))
	      (make import-decl (module-name mod) (mode mode) (specs specs)
		                (renamings renamings)))))
   (else
    (signal-missing-token "<modid>" "import declaration")))))

(define (parse-import-list)
  (let ((import (parse-entity 'import)))
    (token-case
     (\, (cons import (parse-import-list)))
     (\) (list import))
     (else (signal-missing-token "`)' or `,'" "import list")))))

(define (parse-renamings)
 (let ((renaming
	(save-parser-context
	 (token-case
	  (var (let ((name1 (var->symbol)))
		 (require-token
		   |to|
		   (signal-missing-token "`to'" "import renaming clause"))
		 (token-case
		  (var (let ((name2 (var->symbol)))
			 (make renaming (from name1) (to name2)
			       (referenced? '#f))))
		  (else (signal-invalid-syntax "import renaming clause")))))
	  (con (let ((name1 (con->symbol)))
		 (require-token
 		   |to| 
		   (signal-missing-token "`to'" "import renaming clause"))
		 (token-case
		  (con (let ((name2 (con->symbol)))
			 (make renaming (from name1) (to name2)
			       (referenced? '#f))))
		  (else (signal-invalid-syntax "import renaming clause")))))
	  (else (signal-invalid-syntax "import renaming clause"))))))
    (token-case (\, (cons renaming (parse-renamings)))
		(\) (list renaming)))))

(define (parse-fixity associativity mod-ast state)
  (let ((fixity-decl
	 (save-parser-context
	  (let* ((prec (token-case
			(k (let ((p (token->integer)))
			     (cond ((<= p 9)
				    p)
				   (else
				    (signal-bad-fixity)
				    9))))
			(else 9)))
		 (ops (parse-op-list))
		 (fixity (make fixity (associativity associativity)
		       (precedence prec))))
	    (make fixity-decl (fixity fixity) (names ops))))))
    (push-decl-list fixity-decl (module-fixities mod-ast))
    (cond ((or (eq? state 'import)
	       (eq? state 'fixity))
	   'fixity)
	  (else
	   (signal-misplaced-fixity)
	   state))))


(define (signal-bad-fixity)
  (parser-error 'bad-fixity
		"Expecting fixity value of 0 - 9."))

(define (signal-misplaced-fixity)
  (parser-error 'misplaced-fixity "The fixity declaration is misplaced."))

(define (parse-op-list)
  (let ((name (token-case
	       (op (op->symbol))
	       (else (signal-missing-token "<op>" "fixity declaration")))))
    (token-case
     (\, (cons name (parse-op-list)))
     (else (list name)))))

(define (parse-entity context)
 (trace-parser entity
  (save-parser-context
   (token-case
    (var (var->entity))
    (tycon
     (let ((name (token->symbol)))
       (token-case
	(\( (token-case
	     (\.\. (require-token
		     '\)
		     (signal-missing-token "`)'" "class or datatype entity"))
		   (make entity-abbreviated (name name)))
	     (var (parse-entity-class name))
	     (con (parse-entity-datatype name))
	     (\) (make entity-class (name name) (methods '())))
	     (else (signal-invalid-syntax "an entity"))))
	(\.\. (if (eq? context 'export)
		  (make entity-module (name name))
		  (signal-invalid-syntax "an entity")))
	(else
	 (make entity-con (name name))))))
    (else (signal-invalid-syntax "an entity"))))))

(define (parse-entity-class class-name)
  (let ((vars (parse-var-list)))
    (make entity-class (name class-name) (methods vars))))

(define (parse-entity-datatype type-name)
  (let ((constrs (parse-con-list)))
    (make entity-datatype (name type-name) (constructors constrs))))

(define (parse-var-list)
  (token-case
   (var (let ((name (var->symbol)))
	  (token-case
	   (\) (list name))
	   (\, (cons name (parse-var-list)))
	   (else
	    (signal-missing-token "`)' or `,'" "class entity")))))
   (else (signal-missing-token "<var>" "class entity"))))

(define (parse-con-list)
  (token-case
   (con (let ((name (con->symbol)))
	  (token-case
	   (\) (list name))
	   (\, (cons name (parse-con-list)))
	   (else (signal-missing-token "`)' or `,'" "datatype entity")))))
   (else (signal-missing-token "<con>" "datatype entity"))))