home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / parser / module-parser.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  10.9 KB  |  345 lines  |  [TEXT/CCL2]
  1. ;;; File: module-parser         Author: John
  2.  
  3. ;;; This is for using the parser to parse strings.
  4.  
  5. (define (parse-module-body-from-string mod-name body filename has-lines?)
  6.  (dynamic-let ((*current-file* filename))
  7.   (call-with-input-string body
  8.     (lambda (port)
  9.       (let ((tokens (if has-lines?
  10.             (lex-port port '#f)
  11.             (lex-port/nolines port))))
  12.     (init-token-stream tokens)
  13.     (let ((res (parse-modules/named mod-name '())))
  14.       (if (not (eq-token? 'eof))
  15.           (signal-leftover-tokens)
  16.           res)))))))
  17.  
  18. (define (signal-leftover-tokens)
  19.   (fatal-error 'leftover-tokens
  20.            "Leftover tokens after parsing."))
  21.  
  22.  
  23. ;;; This file deals with the basic structure of a module.  It also adds
  24. ;;; the `module Main(main) where' required by abbreviated modules.
  25.  
  26. (define (parse-tokens tokens)
  27.   (init-token-stream tokens)
  28.   (let ((mod (token-case
  29.           (|module| (parse-module))
  30.           (else (parse-modules/named
  31.              '|Main|
  32.              (list (make entity-var (name '|main|))))))))
  33.     (cons mod (parse-module-list))))
  34.  
  35. (define (parse-module)
  36.   (token-case
  37.    (modid (let* ((mod-name (token->symbol))
  38.          (exports (parse-exports)))
  39.         (require-token
  40.           |where|
  41.           (signal-missing-token "`where'" "module definition"))
  42.         (parse-modules/named mod-name exports)))
  43.    (else (signal-missing-token "<modid>" "module definition"))))
  44.  
  45. (define (parse-module-list)
  46.   (token-case
  47.    (|module|
  48.     (let ((mod (parse-module)))
  49.       (cons mod (parse-module-list))))
  50.    (eof '())
  51.    (else (signal-missing-module))))
  52.  
  53. (define (signal-missing-module)
  54.   (parser-error 'missing-module
  55.         "Missing `module', or leftover junk after module definition."))
  56.  
  57. (define (parse-exports)
  58.   (parse-commaized-list (function parse-entity-export) "export list"))
  59.  
  60. (define (parse-commaized-list fn context-msg)
  61.   (token-case
  62.    (\( (parse-commaized-list-aux fn context-msg))
  63.    (else '())))
  64.  
  65. (define *parse-trailing-comma-ok* '#t)
  66.  
  67. (define (parse-commaized-list-aux fn context-msg)
  68.   (let ((object  (funcall fn)))
  69.     (token-case
  70.      (\) (list object))
  71.      (\, (token-case
  72.       (\) (if *parse-trailing-comma-ok*
  73.           (list object)
  74.           (signal-extra-comma context-msg)))
  75.       (else
  76.           (cons object (parse-commaized-list-aux fn context-msg)))))
  77.      (else (signal-missing-token "`)' or ','" context-msg)))))
  78.  
  79. (define (signal-extra-comma context-msg)
  80.   (parser-error 'extra-comma
  81.         "Extra comma at end of ~a." context-msg))
  82.  
  83. (define (parse-modules/named mod-name exports)
  84.   (trace-parser module
  85.     (let ((mod-ast (make module
  86.              (name mod-name)
  87.              (type 'standard)
  88.              (exports exports)
  89.              (default *standard-module-default*))))
  90.       (setf (ast-node-line-number mod-ast) (capture-current-line))
  91.       (start-layout (lambda (in-layout?)
  92.               (parse-module-decls mod-ast in-layout? 'import '#f))))))
  93.  
  94. ;;; The mod-ast fields are kept in non-reversed order by appending
  95. ;;; each decl to the end of the appropriate list.  This loses for
  96. ;;; value decls, so these are in reversed order!!
  97.  
  98. (define (parse-module-decls mod-ast in-layout? state last-was-decl?)
  99.   (token-case
  100.    (|import| (let ((import (parse-import)))
  101.            (if (eq? state 'import)
  102.            (push-decl-list import (module-imports mod-ast))
  103.            (signal-misplaced-import)))
  104.          (terminate-topdecl mod-ast in-layout? state))
  105.    (|infix| (terminate-topdecl mod-ast in-layout?
  106.                    (parse-fixity 'n mod-ast state)))
  107.    (|infixl| (terminate-topdecl mod-ast in-layout?
  108.                 (parse-fixity 'l mod-ast state)))
  109.    (|infixr| (terminate-topdecl mod-ast in-layout?
  110.                 (parse-fixity 'r mod-ast state)))
  111.    (|data| (let ((data-decl (parse-type-decl '#f)))
  112.          (push-decl-list data-decl (module-algdatas mod-ast)))
  113.        (terminate-topdecl mod-ast in-layout? 'topdecl))
  114.    (|type| (let ((synonym-decl (parse-synonym-decl)))
  115.          (push-decl-list synonym-decl (module-synonyms mod-ast)))
  116.        (terminate-topdecl mod-ast in-layout? 'topdecl))
  117.    (|class| (let ((class-decl (parse-class-decl)))
  118.           (push-decl-list class-decl (module-classes mod-ast)))
  119.         (terminate-topdecl mod-ast in-layout? 'topdecl))
  120.    (|instance| (let ((instance-decl (parse-instance-decl '#f '#f)))
  121.          (push-decl-list instance-decl (module-instances mod-ast)))
  122.            (terminate-topdecl mod-ast in-layout? 'topdecl))
  123.    (|deriving| (let ((deriving-decl (parse-deriving-decl)))
  124.          (push-decl-list deriving-decl (module-derivings mod-ast)))
  125.            (terminate-topdecl mod-ast in-layout? 'topdecl))
  126.    (|default| (let ((types 
  127.              (token-case
  128.               (\( (token-case (\) '())
  129.                       (else (parse-type-list))))
  130.               (else
  131.                (signal-missing-token "`('" "default declaration")))))
  132.         (if (eq? (module-default mod-ast) *standard-module-default*)
  133.             (setf (module-default mod-ast)
  134.               (make default-decl (types types)))
  135.             (signal-multiple-defaults)))
  136.     (terminate-topdecl mod-ast in-layout? 'topdecl))
  137.    ((begin-annotation no-advance)
  138.     (let ((annotations (parse-annotations 'topdecl)))
  139.       (setf (module-annotations mod-ast)
  140.         (append (module-annotations mod-ast) annotations)))
  141.     (terminate-topdecl mod-ast in-layout? state))
  142.    (pat-start (let ((decl (parse-decl)))
  143.         (if last-was-decl?
  144.             (setf (module-decls mod-ast)
  145.               (decl-push decl (module-decls mod-ast)))
  146.             (push decl (module-decls mod-ast))))
  147.           (terminate-topdecl/in-decl mod-ast in-layout? 'topdecl))
  148.    (else
  149.     (maybe-end-module mod-ast in-layout? state))))
  150.  
  151. (define (signal-misplaced-import)
  152.   (parser-error 'misplaced-import
  153.         "The import declaration is misplaced."))
  154.  
  155. (define (signal-multiple-defaults)
  156.   (parser-error 'multiple-defaults
  157.         "There are multiple default declarations."))
  158.  
  159. (define (terminate-topdecl mod-ast in-layout? state)
  160.   (token-case
  161.    (\; (parse-module-decls mod-ast in-layout? state '#f))
  162.    (else (maybe-end-module mod-ast in-layout? state))))
  163.  
  164. (define (terminate-topdecl/in-decl mod-ast in-layout? state)
  165.   (token-case
  166.    (\; (parse-module-decls mod-ast in-layout? state '#t))
  167.    (else (maybe-end-module mod-ast in-layout? state))))
  168.  
  169. (define (maybe-end-module mod-ast in-layout? state)
  170.   (declare (ignore state))
  171.   (cond ((or (eq-token? '|module|) (eq-token? 'eof) (eq-token? '\})
  172.          (eq-token? '$\}))
  173.      (close-layout in-layout?)
  174.      (wrapup-module mod-ast)
  175.      mod-ast)
  176.     (else
  177.      (signal-invalid-syntax "a topdecl"))))
  178.  
  179. (define (wrapup-module mod-ast)
  180.   (setf (module-decls mod-ast)
  181.     (nreverse (module-decls mod-ast)))
  182.   (when (and (null? (module-imports mod-ast))
  183.          (null? (module-decls mod-ast))
  184.          (null? (module-algdatas mod-ast))
  185.          (null? (module-synonyms mod-ast))
  186.          (null? (module-instances mod-ast))
  187.          (null? (module-classes mod-ast))
  188.          (null? (module-derivings mod-ast)))
  189.     (signal-empty-module)))
  190.  
  191. (define (signal-empty-module)
  192.   (parser-error 'empty-module "Module definition is empty."))
  193.  
  194. (define (parse-import)
  195.  (save-parser-context
  196.   (token-case
  197.    (modid (let ((mod (token->symbol))
  198.         (mode 'all)
  199.         (specs '()))
  200.         (token-case
  201.          (\( (setf mode 'by-name)
  202.          (token-case
  203.           (\) (setf specs '()))
  204.           (else (setf specs (parse-import-list)))))
  205.          (|hiding| (require-token
  206.              \(
  207.              (signal-missing-token "`('" "hiding clause"))
  208.                (setf specs (parse-import-list)))
  209.          (else '()))
  210.         (let ((renamings (token-case (|renaming|
  211.                        (require-token
  212.                          \(
  213.                          (signal-missing-token
  214.                            "`('" "renaming clause"))
  215.                        (parse-renamings))
  216.                      (else '()))))
  217.           (make import-decl (module-name mod) (mode mode) (specs specs)
  218.                         (renamings renamings)))))
  219.    (else
  220.     (signal-missing-token "<modid>" "import declaration")))))
  221.  
  222. (define (parse-import-list)
  223.   (parse-commaized-list-aux (function parse-entity-import) "import list"))
  224.  
  225. (define (parse-renamings)
  226.   (parse-commaized-list-aux (function parse-renaming)
  227.                 "import renaming clause"))
  228.  
  229. (define (parse-renaming)
  230.   (save-parser-context
  231.    (token-case
  232.     (var (let ((name1 (var->symbol)))
  233.        (require-token
  234.         |to|
  235.         (signal-missing-token "`to'" "import renaming clause"))
  236.        (token-case
  237.         (var (let ((name2 (var->symbol)))
  238.            (make renaming (from name1) (to name2)
  239.              (referenced? '#f))))
  240.         (else (signal-invalid-syntax "import renaming clause")))))
  241.     (con (let ((name1 (con->symbol)))
  242.        (require-token
  243.         |to| 
  244.         (signal-missing-token "`to'" "import renaming clause"))
  245.        (token-case
  246.         (con (let ((name2 (con->symbol)))
  247.            (make renaming (from name1) (to name2)
  248.              (referenced? '#f))))
  249.         (else (signal-invalid-syntax "import renaming clause")))))
  250.     (else (signal-invalid-syntax "import renaming clause")))))
  251.  
  252.  
  253. (define (parse-fixity associativity mod-ast state)
  254.   (let ((fixity-decl
  255.      (save-parser-context
  256.       (let* ((prec (token-case
  257.             (k (let ((p (token->integer)))
  258.                  (cond ((<= p 9)
  259.                     p)
  260.                    (else
  261.                     (signal-bad-fixity)
  262.                     9))))
  263.             (else 9)))
  264.          (ops (parse-op-list))
  265.          (fixity (make fixity (associativity associativity)
  266.                (precedence prec))))
  267.         (make fixity-decl (fixity fixity) (names ops))))))
  268.     (push-decl-list fixity-decl (module-fixities mod-ast))
  269.     (cond ((or (eq? state 'import)
  270.            (eq? state 'fixity))
  271.        'fixity)
  272.       (else
  273.        (signal-misplaced-fixity)
  274.        state))))
  275.  
  276.  
  277. (define (signal-bad-fixity)
  278.   (parser-error 'bad-fixity
  279.         "Expecting fixity value of 0 - 9."))
  280.  
  281. (define (signal-misplaced-fixity)
  282.   (parser-error 'misplaced-fixity "The fixity declaration is misplaced."))
  283.  
  284. (define (parse-op-list)
  285.   (let ((name (token-case
  286.            (op (op->symbol))
  287.            (else (signal-missing-token "<op>" "fixity declaration")))))
  288.     (token-case
  289.      (\, (cons name (parse-op-list)))
  290.      (else (list name)))))
  291.  
  292. (define (parse-entity-export)
  293.   (parse-entity 'export))
  294.  
  295. (define (parse-entity-import)
  296.   (parse-entity 'import))
  297.  
  298. (define (parse-entity context)
  299.  (trace-parser entity
  300.   (save-parser-context
  301.    (token-case
  302.     (var (var->entity))
  303.     (tycon
  304.      (let ((name (token->symbol)))
  305.        (token-case
  306.     (\( (token-case
  307.          (\.\. (require-token
  308.              '\)
  309.              (signal-missing-token "`)'" "class or datatype entity"))
  310.            (make entity-abbreviated (name name)))
  311.          (var (parse-entity-class name))
  312.          (con (parse-entity-datatype name))
  313.          (\) (make entity-class (name name) (methods '())))
  314.          (else (signal-invalid-syntax "an entity"))))
  315.     (\.\. (if (eq? context 'export)
  316.           (make entity-module (name name))
  317.           (signal-invalid-syntax "an entity")))
  318.     (else
  319.      (make entity-con (name name))))))
  320.     (else (signal-invalid-syntax "an entity"))))))
  321.  
  322. (define (parse-entity-class class-name)
  323.   (let ((vars (parse-var-list)))
  324.     (make entity-class (name class-name) (methods vars))))
  325.  
  326. (define (parse-entity-datatype type-name)
  327.   (let ((constrs (parse-con-list)))
  328.     (make entity-datatype (name type-name) (constructors constrs))))
  329.  
  330. (define (parse-var-list)
  331.   (parse-commaized-list-aux
  332.    (lambda ()
  333.      (token-case
  334.       (var  (var->symbol))
  335.       (else (signal-missing-token "<var>" "class entity"))))
  336.    "class entity"))
  337.  
  338. (define (parse-con-list)
  339.   (parse-commaized-list-aux
  340.    (lambda ()
  341.      (token-case
  342.       (con  (con->symbol))
  343.       (else (signal-missing-token "<con>" "datatype entity"))))
  344.    "datatype entity"))
  345.