giles
5603ecc3a6
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 53s
Parser: module F (M) (N) ... = struct DECLS end -> (:functor-def NAME PARAMS DECLS). module N = expr (non-struct) -> (:module-alias NAME BODY-SRC). Functor params accept (P) or (P : Sig) — signatures parsed-and-skipped via skip-optional-sig. Eval: ocaml-make-functor builds curried host-SX closures from module dicts to a module dict. ocaml-resolve-module-path extended for :app so F(A), F(A)(B), and Outer.Inner all resolve to dicts. Phase 4 LOC ~290 cumulative (still well under 2000).
1016 lines
37 KiB
Plaintext
1016 lines
37 KiB
Plaintext
;; lib/ocaml/parser.sx — OCaml expression parser.
|
|
;;
|
|
;; Input: token list from (ocaml-tokenize src).
|
|
;; Output: an OCaml AST. Nodes are plain lists tagged by a keyword head;
|
|
;; keywords serialize to their string name so `(list :var "x")` is the
|
|
;; same value as `(list "var" "x")` at runtime.
|
|
;;
|
|
;; Expression scope:
|
|
;; atoms int/float/string/char/bool, unit (), var, con, list literal
|
|
;; application left-associative, f x y z
|
|
;; prefix -E unary minus, not E
|
|
;; infix 29 ops via lib/guest/pratt.sx
|
|
;; tuple a, b, c (lower than infix, higher than let/if)
|
|
;; parens (e)
|
|
;; if if c then t else e (else optional → unit)
|
|
;; fun fun x y -> body
|
|
;; let let x = e in body (no rec, function shorthand)
|
|
;; let rec f x = e in body
|
|
;; match match e with [|] p -> body | p -> body | ...
|
|
;; sequence e1 ; e2 → (:seq e1 e2 …) (lowest-precedence binary)
|
|
;;
|
|
;; Pattern scope:
|
|
;; _ (wildcard), int/string/char/bool literals, ident (var binding),
|
|
;; ctor (no args), ctor pat, (), parens, tuple (pat,pat,…),
|
|
;; list literal [pat;pat;…], cons p1 :: p2.
|
|
;;
|
|
;; AST shapes:
|
|
;; (:int N) (:float N) (:string S) (:char C) (:bool B) (:unit)
|
|
;; (:var NAME) (:con NAME)
|
|
;; (:app FN ARG)
|
|
;; (:op OP LHS RHS)
|
|
;; (:neg E) (:not E)
|
|
;; (:tuple ITEMS) (:list ITEMS)
|
|
;; (:seq EXPRS)
|
|
;; (:if C T E)
|
|
;; (:fun PARAMS BODY)
|
|
;; (:let NAME PARAMS EXPR BODY) (:let-rec NAME PARAMS EXPR BODY)
|
|
;; (:match SCRUTINEE CLAUSES) CLAUSES = ((:case PAT BODY) ...)
|
|
;;
|
|
;; (:pwild) (:pvar N) (:plit LIT)
|
|
;; (:pcon NAME ARG-PATS) — ARG-PATS empty for nullary
|
|
;; (:ptuple PATS) (:plist PATS) (:pcons HEAD TAIL)
|
|
|
|
(define ocaml-tok-type (fn (t) (if (= t nil) "eof" (get t :type))))
|
|
|
|
(define ocaml-tok-value (fn (t) (if (= t nil) nil (get t :value))))
|
|
|
|
(define
|
|
ocaml-op-table
|
|
(list
|
|
(list ":=" 1 :right)
|
|
(list "||" 2 :right)
|
|
(list "or" 2 :right)
|
|
(list "&&" 3 :right)
|
|
(list "&" 3 :right)
|
|
(list "=" 4 :left)
|
|
(list "<" 4 :left)
|
|
(list ">" 4 :left)
|
|
(list "<=" 4 :left)
|
|
(list ">=" 4 :left)
|
|
(list "<>" 4 :left)
|
|
(list "==" 4 :left)
|
|
(list "!=" 4 :left)
|
|
(list "|>" 4 :left)
|
|
(list "@" 5 :right)
|
|
(list "^" 5 :right)
|
|
(list "::" 6 :right)
|
|
(list "+" 7 :left)
|
|
(list "-" 7 :left)
|
|
(list "*" 8 :left)
|
|
(list "/" 8 :left)
|
|
(list "%" 8 :left)
|
|
(list "mod" 8 :left)
|
|
(list "land" 8 :left)
|
|
(list "lor" 8 :left)
|
|
(list "lxor" 8 :left)
|
|
(list "**" 9 :right)
|
|
(list "lsl" 9 :right)
|
|
(list "lsr" 9 :right)
|
|
(list "asr" 9 :right)))
|
|
|
|
(define
|
|
ocaml-binop-prec
|
|
(fn
|
|
(op)
|
|
(let
|
|
((entry (pratt-op-lookup ocaml-op-table op)))
|
|
(if (= entry nil) 0 (pratt-op-prec entry)))))
|
|
|
|
(define
|
|
ocaml-binop-right?
|
|
(fn
|
|
(op)
|
|
(let
|
|
((entry (pratt-op-lookup ocaml-op-table op)))
|
|
(and (not (= entry nil)) (= (pratt-op-assoc entry) :right)))))
|
|
|
|
(define
|
|
ocaml-tok-is-binop?
|
|
(fn
|
|
(tok)
|
|
(let
|
|
((tt (ocaml-tok-type tok)) (tv (ocaml-tok-value tok)))
|
|
(cond
|
|
((= tt "op") (not (= (ocaml-binop-prec tv) 0)))
|
|
((= tt "keyword") (not (= (ocaml-binop-prec tv) 0)))
|
|
(else false)))))
|
|
|
|
(define
|
|
ocaml-parse
|
|
(fn
|
|
(src)
|
|
(let
|
|
((tokens (ocaml-tokenize src)) (idx 0) (tok-len 0))
|
|
(begin
|
|
(set! tok-len (len tokens))
|
|
(define peek-tok (fn () (nth tokens idx)))
|
|
(define advance-tok! (fn () (set! idx (+ idx 1))))
|
|
(define
|
|
check-tok?
|
|
(fn
|
|
(type value)
|
|
(let
|
|
((t (peek-tok)))
|
|
(and
|
|
(= (ocaml-tok-type t) type)
|
|
(or (= value nil) (= (ocaml-tok-value t) value))))))
|
|
(define
|
|
consume!
|
|
(fn
|
|
(type value)
|
|
(if
|
|
(check-tok? type value)
|
|
(let ((t (peek-tok))) (begin (advance-tok!) t))
|
|
(error
|
|
(str
|
|
"ocaml-parse: expected "
|
|
type
|
|
" "
|
|
value
|
|
" got "
|
|
(ocaml-tok-type (peek-tok))
|
|
" "
|
|
(ocaml-tok-value (peek-tok)))))))
|
|
(define at-kw? (fn (kw) (check-tok? "keyword" kw)))
|
|
(define at-op? (fn (op) (check-tok? "op" op)))
|
|
(define parse-pattern (fn () nil))
|
|
(define parse-pattern-cons (fn () nil))
|
|
(define parse-pattern-app (fn () nil))
|
|
(define parse-pattern-atom (fn () nil))
|
|
(define
|
|
at-pattern-atom?
|
|
(fn
|
|
()
|
|
(let
|
|
((tt (ocaml-tok-type (peek-tok)))
|
|
(tv (ocaml-tok-value (peek-tok))))
|
|
(cond
|
|
((= tt "number") true)
|
|
((= tt "string") true)
|
|
((= tt "char") true)
|
|
((= tt "ident") true)
|
|
((= tt "ctor") true)
|
|
((and (= tt "keyword") (or (= tv "true") (= tv "false")))
|
|
true)
|
|
((and (= tt "op") (or (= tv "(") (= tv "["))) true)
|
|
(else false)))))
|
|
(set!
|
|
parse-pattern-atom
|
|
(fn
|
|
()
|
|
(let
|
|
((tt (ocaml-tok-type (peek-tok)))
|
|
(tv (ocaml-tok-value (peek-tok))))
|
|
(cond
|
|
((= tt "number")
|
|
(begin
|
|
(advance-tok!)
|
|
(if
|
|
(= (round tv) tv)
|
|
(list :plit (list :int tv))
|
|
(list :plit (list :float tv)))))
|
|
((= tt "string")
|
|
(begin (advance-tok!) (list :plit (list :string tv))))
|
|
((= tt "char")
|
|
(begin (advance-tok!) (list :plit (list :char tv))))
|
|
((and (= tt "keyword") (= tv "true"))
|
|
(begin (advance-tok!) (list :plit (list :bool true))))
|
|
((and (= tt "keyword") (= tv "false"))
|
|
(begin (advance-tok!) (list :plit (list :bool false))))
|
|
((and (= tt "ident") (= tv "_"))
|
|
(begin (advance-tok!) (list :pwild)))
|
|
((= tt "ident") (begin (advance-tok!) (list :pvar tv)))
|
|
((= tt "ctor") (begin (advance-tok!) (list :pcon tv)))
|
|
((and (= tt "op") (= tv "("))
|
|
(begin
|
|
(advance-tok!)
|
|
(cond
|
|
((at-op? ")")
|
|
(begin (advance-tok!) (list :plit (list :unit))))
|
|
(else
|
|
(let
|
|
((first (parse-pattern)))
|
|
(cond
|
|
((at-op? ",")
|
|
(let
|
|
((items (list first)))
|
|
(begin
|
|
(define
|
|
loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-op? ",")
|
|
(begin
|
|
(advance-tok!)
|
|
(append! items (parse-pattern))
|
|
(loop)))))
|
|
(loop)
|
|
(consume! "op" ")")
|
|
(cons :ptuple items))))
|
|
(else (begin (consume! "op" ")") first))))))))
|
|
((and (= tt "op") (= tv "["))
|
|
(begin
|
|
(advance-tok!)
|
|
(cond
|
|
((at-op? "]") (begin (advance-tok!) (list :plist)))
|
|
(else
|
|
(let
|
|
((items (list)))
|
|
(begin
|
|
(append! items (parse-pattern))
|
|
(define
|
|
loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-op? ";")
|
|
(begin
|
|
(advance-tok!)
|
|
(when
|
|
(not (at-op? "]"))
|
|
(begin
|
|
(append! items (parse-pattern))
|
|
(loop)))))))
|
|
(loop)
|
|
(consume! "op" "]")
|
|
(cons :plist items)))))))
|
|
(else
|
|
(error
|
|
(str
|
|
"ocaml-parse: unexpected pattern token "
|
|
tt
|
|
" "
|
|
tv
|
|
" at idx "
|
|
idx)))))))
|
|
(set!
|
|
parse-pattern-app
|
|
(fn
|
|
()
|
|
(let
|
|
((head (parse-pattern-atom)))
|
|
(cond
|
|
((and (= (nth head 0) :pcon) (at-pattern-atom?))
|
|
(let
|
|
((arg (parse-pattern-atom)))
|
|
(let
|
|
((args (cond ((= (nth arg 0) :ptuple) (rest arg)) (else (list arg)))))
|
|
(concat (list :pcon (nth head 1)) args))))
|
|
(else head)))))
|
|
(set!
|
|
parse-pattern-cons
|
|
(fn
|
|
()
|
|
(let
|
|
((lhs (parse-pattern-app)))
|
|
(cond
|
|
((at-op? "::")
|
|
(begin
|
|
(advance-tok!)
|
|
(list :pcons lhs (parse-pattern-cons))))
|
|
(else lhs)))))
|
|
(set! parse-pattern (fn () (parse-pattern-cons)))
|
|
(define parse-expr (fn () nil))
|
|
(define parse-expr-no-seq (fn () nil))
|
|
(define parse-tuple (fn () nil))
|
|
(define parse-binop-rhs (fn (lhs min-prec) lhs))
|
|
(define parse-prefix (fn () nil))
|
|
(define parse-app (fn () nil))
|
|
(define parse-atom (fn () nil))
|
|
(set!
|
|
parse-atom
|
|
(fn
|
|
()
|
|
(let
|
|
((t (peek-tok))
|
|
(tt (ocaml-tok-type (peek-tok)))
|
|
(tv (ocaml-tok-value (peek-tok))))
|
|
(cond
|
|
((= tt "number")
|
|
(begin
|
|
(advance-tok!)
|
|
(if (= (round tv) tv) (list :int tv) (list :float tv))))
|
|
((= tt "string") (begin (advance-tok!) (list :string tv)))
|
|
((= tt "char") (begin (advance-tok!) (list :char tv)))
|
|
((and (= tt "keyword") (= tv "true"))
|
|
(begin (advance-tok!) (list :bool true)))
|
|
((and (= tt "keyword") (= tv "false"))
|
|
(begin (advance-tok!) (list :bool false)))
|
|
((= tt "ident") (begin (advance-tok!) (list :var tv)))
|
|
((= tt "ctor") (begin (advance-tok!) (list :con tv)))
|
|
((and (= tt "op") (= tv "("))
|
|
(begin
|
|
(advance-tok!)
|
|
(cond
|
|
((at-op? ")") (begin (advance-tok!) (list :unit)))
|
|
(else
|
|
(let
|
|
((e (parse-expr)))
|
|
(begin (consume! "op" ")") e))))))
|
|
((and (= tt "op") (= tv "["))
|
|
(begin
|
|
(advance-tok!)
|
|
(cond
|
|
((at-op? "]") (begin (advance-tok!) (list :list)))
|
|
(else
|
|
(let
|
|
((items (list)))
|
|
(begin
|
|
(append! items (parse-expr-no-seq))
|
|
(define
|
|
loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-op? ";")
|
|
(begin
|
|
(advance-tok!)
|
|
(when
|
|
(not (at-op? "]"))
|
|
(begin
|
|
(append! items (parse-expr-no-seq))
|
|
(loop)))))))
|
|
(loop)
|
|
(consume! "op" "]")
|
|
(cons :list items)))))))
|
|
((at-kw? "begin")
|
|
(begin
|
|
(advance-tok!)
|
|
(let
|
|
((e (parse-expr)))
|
|
(begin (consume! "keyword" "end") e))))
|
|
(else
|
|
(error
|
|
(str
|
|
"ocaml-parse: unexpected token "
|
|
tt
|
|
" "
|
|
tv
|
|
" at idx "
|
|
idx)))))))
|
|
(define
|
|
at-app-start?
|
|
(fn
|
|
()
|
|
(let
|
|
((tt (ocaml-tok-type (peek-tok)))
|
|
(tv (ocaml-tok-value (peek-tok))))
|
|
(cond
|
|
((= tt "number") true)
|
|
((= tt "string") true)
|
|
((= tt "char") true)
|
|
((= tt "ident") true)
|
|
((= tt "ctor") true)
|
|
((and (= tt "keyword") (or (= tv "true") (= tv "false") (= tv "begin")))
|
|
true)
|
|
((and (= tt "op") (or (= tv "(") (= tv "["))) true)
|
|
(else false)))))
|
|
(define parse-atom-postfix
|
|
(fn ()
|
|
;; After a primary atom, consume `.field` chains. Field name
|
|
;; may be lower (record field, module value) or upper (module
|
|
;; or constructor reference). Note: `M.x.y` is left-assoc:
|
|
;; `(:field (:field M "x") "y")`.
|
|
(let ((head (parse-atom)))
|
|
(begin
|
|
(define loop
|
|
(fn ()
|
|
(when (at-op? ".")
|
|
(begin
|
|
(advance-tok!)
|
|
(let ((tok (peek-tok)))
|
|
(begin
|
|
(advance-tok!)
|
|
(set! head (list :field head (ocaml-tok-value tok)))
|
|
(loop)))))))
|
|
(loop)
|
|
head))))
|
|
(set!
|
|
parse-app
|
|
(fn
|
|
()
|
|
(let
|
|
((head (parse-atom-postfix)))
|
|
(begin
|
|
(define
|
|
loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-app-start?)
|
|
(let
|
|
((arg (parse-atom-postfix)))
|
|
(begin (set! head (list :app head arg)) (loop))))))
|
|
(loop)
|
|
head))))
|
|
(set!
|
|
parse-prefix
|
|
(fn
|
|
()
|
|
(cond
|
|
((at-op? "-")
|
|
(begin (advance-tok!) (list :neg (parse-prefix))))
|
|
((at-op? "!")
|
|
(begin (advance-tok!) (list :deref (parse-prefix))))
|
|
((at-kw? "not")
|
|
(begin (advance-tok!) (list :not (parse-prefix))))
|
|
(else (parse-app)))))
|
|
(set!
|
|
parse-binop-rhs
|
|
(fn
|
|
(lhs min-prec)
|
|
(let
|
|
((tok (peek-tok)))
|
|
(cond
|
|
((not (ocaml-tok-is-binop? tok)) lhs)
|
|
(else
|
|
(let
|
|
((op (ocaml-tok-value tok))
|
|
(prec (ocaml-binop-prec (ocaml-tok-value tok))))
|
|
(cond
|
|
((< prec min-prec) lhs)
|
|
(else
|
|
(begin
|
|
(advance-tok!)
|
|
(let
|
|
((rhs (parse-prefix))
|
|
(next-min
|
|
(if
|
|
(ocaml-binop-right? op)
|
|
prec
|
|
(+ prec 1))))
|
|
(begin
|
|
(set! rhs (parse-binop-rhs rhs next-min))
|
|
(parse-binop-rhs (list :op op lhs rhs) min-prec))))))))))))
|
|
(define
|
|
parse-binary
|
|
(fn
|
|
()
|
|
(let ((lhs (parse-prefix))) (parse-binop-rhs lhs 1))))
|
|
(set!
|
|
parse-tuple
|
|
(fn
|
|
()
|
|
(let
|
|
((first (parse-binary)))
|
|
(cond
|
|
((at-op? ",")
|
|
(let
|
|
((items (list first)))
|
|
(begin
|
|
(define
|
|
loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-op? ",")
|
|
(begin
|
|
(advance-tok!)
|
|
(append! items (parse-binary))
|
|
(loop)))))
|
|
(loop)
|
|
(cons :tuple items))))
|
|
(else first)))))
|
|
(define
|
|
parse-fun
|
|
(fn
|
|
()
|
|
(let
|
|
((params (list)))
|
|
(begin
|
|
(define
|
|
collect-params
|
|
(fn
|
|
()
|
|
(when
|
|
(check-tok? "ident" nil)
|
|
(begin
|
|
(append! params (ocaml-tok-value (peek-tok)))
|
|
(advance-tok!)
|
|
(collect-params)))))
|
|
(collect-params)
|
|
(when
|
|
(= (len params) 0)
|
|
(error "ocaml-parse: fun expects at least one parameter"))
|
|
(consume! "op" "->")
|
|
(let ((body (parse-expr))) (list :fun params body))))))
|
|
(define
|
|
parse-let
|
|
(fn
|
|
()
|
|
(let
|
|
((reccy false))
|
|
(begin
|
|
(when
|
|
(at-kw? "rec")
|
|
(begin (advance-tok!) (set! reccy true)))
|
|
(let
|
|
((name (ocaml-tok-value (consume! "ident" nil)))
|
|
(params (list)))
|
|
(begin
|
|
(define
|
|
collect-params
|
|
(fn
|
|
()
|
|
(when
|
|
(check-tok? "ident" nil)
|
|
(begin
|
|
(append! params (ocaml-tok-value (peek-tok)))
|
|
(advance-tok!)
|
|
(collect-params)))))
|
|
(collect-params)
|
|
(consume! "op" "=")
|
|
(let
|
|
((rhs (parse-expr)))
|
|
(begin
|
|
(consume! "keyword" "in")
|
|
(let
|
|
((body (parse-expr)))
|
|
(if
|
|
reccy
|
|
(list :let-rec name params rhs body)
|
|
(list :let name params rhs body)))))))))))
|
|
(define
|
|
parse-if
|
|
(fn
|
|
()
|
|
(let
|
|
((cond-expr (parse-expr-no-seq)))
|
|
(begin
|
|
(consume! "keyword" "then")
|
|
(let
|
|
((then-expr (parse-expr-no-seq)))
|
|
(cond
|
|
((at-kw? "else")
|
|
(begin
|
|
(advance-tok!)
|
|
(let
|
|
((else-expr (parse-expr-no-seq)))
|
|
(list :if cond-expr then-expr else-expr))))
|
|
(else (list :if cond-expr then-expr (list :unit)))))))))
|
|
(define
|
|
parse-match
|
|
(fn
|
|
()
|
|
(let
|
|
((scrut (parse-expr-no-seq)))
|
|
(begin
|
|
(consume! "keyword" "with")
|
|
(when (at-op? "|") (advance-tok!))
|
|
(let
|
|
((cases (list)))
|
|
(begin
|
|
(define
|
|
one
|
|
(fn
|
|
()
|
|
(let
|
|
((p (parse-pattern)))
|
|
(begin
|
|
(consume! "op" "->")
|
|
(let
|
|
((body (parse-expr)))
|
|
(append! cases (list :case p body)))))))
|
|
(one)
|
|
(define
|
|
loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-op? "|")
|
|
(begin (advance-tok!) (one) (loop)))))
|
|
(loop)
|
|
(cons :match (cons scrut (list cases)))))))))
|
|
(define parse-try
|
|
(fn ()
|
|
(let ((expr (parse-expr-no-seq)))
|
|
(begin
|
|
(consume! "keyword" "with")
|
|
(when (at-op? "|") (advance-tok!))
|
|
(let ((cases (list)))
|
|
(begin
|
|
(define one
|
|
(fn ()
|
|
(let ((p (parse-pattern)))
|
|
(begin
|
|
(consume! "op" "->")
|
|
(let ((body (parse-expr)))
|
|
(append! cases (list :case p body)))))))
|
|
(one)
|
|
(define loop
|
|
(fn ()
|
|
(when (at-op? "|")
|
|
(begin (advance-tok!) (one) (loop)))))
|
|
(loop)
|
|
(list :try expr cases)))))))
|
|
(define parse-function
|
|
(fn ()
|
|
;; `function | pat -> body | …` ≡ fun x -> match x with | pat -> body
|
|
(let ()
|
|
(begin
|
|
(when (at-op? "|") (advance-tok!))
|
|
(let ((cases (list)))
|
|
(begin
|
|
(define one
|
|
(fn ()
|
|
(let ((p (parse-pattern)))
|
|
(begin
|
|
(consume! "op" "->")
|
|
(let ((body (parse-expr)))
|
|
(append! cases (list :case p body)))))))
|
|
(one)
|
|
(define loop
|
|
(fn ()
|
|
(when (at-op? "|")
|
|
(begin (advance-tok!) (one) (loop)))))
|
|
(loop)
|
|
(list :function cases)))))))
|
|
(define parse-for
|
|
(fn ()
|
|
(let ((name (ocaml-tok-value (consume! "ident" nil))))
|
|
(begin
|
|
(consume! "op" "=")
|
|
(let ((lo (parse-expr-no-seq)))
|
|
(let ((dir
|
|
(cond
|
|
((at-kw? "to") (begin (advance-tok!) :ascend))
|
|
((at-kw? "downto") (begin (advance-tok!) :descend))
|
|
(else (error "ocaml-parse: expected to/downto in for")))))
|
|
(let ((hi (parse-expr-no-seq)))
|
|
(begin
|
|
(consume! "keyword" "do")
|
|
(let ((body (parse-expr)))
|
|
(begin
|
|
(consume! "keyword" "done")
|
|
(list :for name lo hi dir body)))))))))))
|
|
(define parse-while
|
|
(fn ()
|
|
(let ((cond-expr (parse-expr-no-seq)))
|
|
(begin
|
|
(consume! "keyword" "do")
|
|
(let ((body (parse-expr)))
|
|
(begin
|
|
(consume! "keyword" "done")
|
|
(list :while cond-expr body)))))))
|
|
(set!
|
|
parse-expr-no-seq
|
|
(fn
|
|
()
|
|
(cond
|
|
((at-kw? "fun") (begin (advance-tok!) (parse-fun)))
|
|
((at-kw? "let") (begin (advance-tok!) (parse-let)))
|
|
((at-kw? "if") (begin (advance-tok!) (parse-if)))
|
|
((at-kw? "match") (begin (advance-tok!) (parse-match)))
|
|
((at-kw? "function") (begin (advance-tok!) (parse-function)))
|
|
((at-kw? "for") (begin (advance-tok!) (parse-for)))
|
|
((at-kw? "while") (begin (advance-tok!) (parse-while)))
|
|
((at-kw? "try") (begin (advance-tok!) (parse-try)))
|
|
(else (parse-tuple)))))
|
|
(set!
|
|
parse-expr
|
|
(fn
|
|
()
|
|
(let
|
|
((lhs (parse-expr-no-seq)))
|
|
(cond
|
|
((at-op? ";")
|
|
(let
|
|
((items (list lhs)))
|
|
(begin
|
|
(define
|
|
loop
|
|
(fn
|
|
()
|
|
(when
|
|
(at-op? ";")
|
|
(begin
|
|
(advance-tok!)
|
|
(cond
|
|
((at-kw? "end") nil)
|
|
((at-op? ")") nil)
|
|
((at-op? "|") nil)
|
|
((at-kw? "in") nil)
|
|
((at-kw? "then") nil)
|
|
((at-kw? "else") nil)
|
|
((= (ocaml-tok-type (peek-tok)) "eof") nil)
|
|
(else
|
|
(begin
|
|
(append! items (parse-expr-no-seq))
|
|
(loop))))))))
|
|
(loop)
|
|
(cons :seq items))))
|
|
(else lhs)))))
|
|
(let
|
|
((result (parse-expr)))
|
|
(begin
|
|
(when
|
|
(not (= (ocaml-tok-type (peek-tok)) "eof"))
|
|
(error
|
|
(str
|
|
"ocaml-parse: trailing tokens at idx "
|
|
idx
|
|
" — got "
|
|
(ocaml-tok-type (peek-tok))
|
|
" "
|
|
(ocaml-tok-value (peek-tok)))))
|
|
result))))))
|
|
|
|
(define
|
|
ocaml-parse-program
|
|
(fn
|
|
(src)
|
|
(let
|
|
((tokens (ocaml-tokenize src))
|
|
(idx 0)
|
|
(tok-len 0)
|
|
(decls (list)))
|
|
(begin
|
|
(set! tok-len (len tokens))
|
|
(define peek-tok (fn () (nth tokens idx)))
|
|
(define advance-tok! (fn () (set! idx (+ idx 1))))
|
|
(define
|
|
check-tok?
|
|
(fn
|
|
(type value)
|
|
(let
|
|
((t (peek-tok)))
|
|
(and
|
|
(= (ocaml-tok-type t) type)
|
|
(or (= value nil) (= (ocaml-tok-value t) value))))))
|
|
(define
|
|
consume!
|
|
(fn
|
|
(type value)
|
|
(if
|
|
(check-tok? type value)
|
|
(let ((t (peek-tok))) (begin (advance-tok!) t))
|
|
(error
|
|
(str
|
|
"ocaml-parse-program: expected "
|
|
type
|
|
" "
|
|
value
|
|
" got "
|
|
(ocaml-tok-type (peek-tok))
|
|
" "
|
|
(ocaml-tok-value (peek-tok)))))))
|
|
(define at-kw? (fn (kw) (check-tok? "keyword" kw)))
|
|
(define at-op? (fn (op) (check-tok? "op" op)))
|
|
(define
|
|
skip-double-semi!
|
|
(fn
|
|
()
|
|
(when (at-op? ";;") (begin (advance-tok!) (skip-double-semi!)))))
|
|
(define
|
|
cur-pos
|
|
(fn
|
|
()
|
|
(let ((t (peek-tok))) (if (= t nil) (len src) (get t :pos)))))
|
|
(define
|
|
skip-to-boundary!
|
|
(fn
|
|
()
|
|
(cond
|
|
((>= idx tok-len) nil)
|
|
((= (ocaml-tok-type (peek-tok)) "eof") nil)
|
|
((at-op? ";;") nil)
|
|
((at-kw? "let") nil)
|
|
((at-kw? "module") nil)
|
|
((at-kw? "open") nil)
|
|
((at-kw? "include") nil)
|
|
(else (begin (advance-tok!) (skip-to-boundary!))))))
|
|
(define
|
|
parse-decl-let
|
|
(fn
|
|
()
|
|
(advance-tok!)
|
|
(let
|
|
((reccy false))
|
|
(begin
|
|
(when
|
|
(at-kw? "rec")
|
|
(begin (advance-tok!) (set! reccy true)))
|
|
(let
|
|
((name (ocaml-tok-value (consume! "ident" nil)))
|
|
(params (list)))
|
|
(begin
|
|
(define
|
|
collect-params
|
|
(fn
|
|
()
|
|
(when
|
|
(check-tok? "ident" nil)
|
|
(begin
|
|
(append! params (ocaml-tok-value (peek-tok)))
|
|
(advance-tok!)
|
|
(collect-params)))))
|
|
(collect-params)
|
|
(consume! "op" "=")
|
|
(let
|
|
((expr-start (cur-pos)))
|
|
(begin
|
|
(skip-to-boundary!)
|
|
(let
|
|
((expr-src (slice src expr-start (cur-pos))))
|
|
(let
|
|
((expr (ocaml-parse expr-src)))
|
|
(if
|
|
reccy
|
|
(list :def-rec name params expr)
|
|
(list :def name params expr))))))))))))
|
|
(define
|
|
parse-decl-expr
|
|
(fn
|
|
()
|
|
(let
|
|
((expr-start (cur-pos)))
|
|
(begin
|
|
(skip-to-boundary!)
|
|
(let
|
|
((expr-src (slice src expr-start (cur-pos))))
|
|
(let ((expr (ocaml-parse expr-src))) (list :expr expr)))))))
|
|
;; module M = struct DECLS end
|
|
;; Parsed by sub-tokenising the body source between `struct` and
|
|
;; the matching `end`. Nested modules / sigs increment depth.
|
|
;; open M / include M — collect a path Ctor(.SubCtor)* and emit
|
|
;; (:open PATH) or (:include PATH).
|
|
(define
|
|
parse-decl-open
|
|
(fn (include?)
|
|
(advance-tok!)
|
|
(let ((path-start (cur-pos)))
|
|
(begin
|
|
;; Walk until end of the path. A path is Ctor (. Ctor)*.
|
|
(define skip-path
|
|
(fn ()
|
|
(cond
|
|
((>= idx tok-len) nil)
|
|
((= (ocaml-tok-type (peek-tok)) "ctor")
|
|
(begin (advance-tok!) (skip-path)))
|
|
((at-op? ".") (begin (advance-tok!) (skip-path)))
|
|
(else nil))))
|
|
(skip-path)
|
|
(let ((path-src (slice src path-start (cur-pos))))
|
|
(let ((path-expr (ocaml-parse path-src)))
|
|
(if include?
|
|
(list :include path-expr)
|
|
(list :open path-expr))))))))
|
|
;; Parse a `struct DECLS end` body and return the decls list.
|
|
(define
|
|
parse-struct-body
|
|
(fn ()
|
|
(consume! "keyword" "struct")
|
|
(let ((body-start (cur-pos)) (depth 1))
|
|
(begin
|
|
(define skip
|
|
(fn ()
|
|
(cond
|
|
((>= idx tok-len) nil)
|
|
((= (ocaml-tok-type (peek-tok)) "eof") nil)
|
|
((at-kw? "struct")
|
|
(begin (set! depth (+ depth 1)) (advance-tok!) (skip)))
|
|
((at-kw? "begin")
|
|
(begin (set! depth (+ depth 1)) (advance-tok!) (skip)))
|
|
((at-kw? "sig")
|
|
(begin (set! depth (+ depth 1)) (advance-tok!) (skip)))
|
|
((at-kw? "end")
|
|
(cond
|
|
((= depth 1) nil)
|
|
(else
|
|
(begin (set! depth (- depth 1)) (advance-tok!) (skip)))))
|
|
(else (begin (advance-tok!) (skip))))))
|
|
(skip)
|
|
(let ((body-end (cur-pos)))
|
|
(begin
|
|
(consume! "keyword" "end")
|
|
(let ((body-src (slice src body-start body-end)))
|
|
(let ((body-prog (ocaml-parse-program body-src)))
|
|
(rest body-prog)))))))))
|
|
|
|
;; Skip an optional `: Sig` constraint (parens-balanced; we
|
|
;; ignore signatures in this iteration).
|
|
(define
|
|
skip-optional-sig
|
|
(fn ()
|
|
(when (at-op? ":")
|
|
(begin
|
|
(advance-tok!)
|
|
(let ((depth 0))
|
|
(begin
|
|
(define skip
|
|
(fn ()
|
|
(cond
|
|
((>= idx tok-len) nil)
|
|
((= (ocaml-tok-type (peek-tok)) "eof") nil)
|
|
((and (= depth 0) (at-op? ")")) nil)
|
|
((and (= depth 0) (at-op? "=")) nil)
|
|
((at-op? "(")
|
|
(begin (set! depth (+ depth 1)) (advance-tok!) (skip)))
|
|
((at-kw? "sig")
|
|
(begin (set! depth (+ depth 1)) (advance-tok!) (skip)))
|
|
((at-op? ")")
|
|
(begin (set! depth (- depth 1)) (advance-tok!) (skip)))
|
|
((at-kw? "end")
|
|
(begin (set! depth (- depth 1)) (advance-tok!) (skip)))
|
|
(else (begin (advance-tok!) (skip))))))
|
|
(skip)))))))
|
|
|
|
(define
|
|
parse-decl-module
|
|
(fn ()
|
|
(advance-tok!)
|
|
(let ((name (ocaml-tok-value (consume! "ctor" nil)))
|
|
(params (list)))
|
|
(begin
|
|
;; Functor parameters: `(P)` or `(P : Sig)`, repeated.
|
|
(define collect-params
|
|
(fn ()
|
|
(when (at-op? "(")
|
|
(begin
|
|
(advance-tok!)
|
|
(when (= (ocaml-tok-type (peek-tok)) "ctor")
|
|
(begin
|
|
(append! params (ocaml-tok-value (peek-tok)))
|
|
(advance-tok!)))
|
|
(skip-optional-sig)
|
|
(consume! "op" ")")
|
|
(collect-params)))))
|
|
(collect-params)
|
|
(skip-optional-sig)
|
|
(consume! "op" "=")
|
|
(cond
|
|
;; Body is `struct DECLS end` — possibly a functor body.
|
|
((at-kw? "struct")
|
|
(let ((decls (parse-struct-body)))
|
|
(cond
|
|
((= (len params) 0) (list :module-def name decls))
|
|
(else (list :functor-def name params decls)))))
|
|
;; Body is a path possibly applied: `M`, `M.Sub`, `F(A)`, `F(A)(B)`.
|
|
(else
|
|
(let ((body-start (cur-pos)))
|
|
(begin
|
|
(define skip-path-app
|
|
(fn ()
|
|
(cond
|
|
((>= idx tok-len) nil)
|
|
((= (ocaml-tok-type (peek-tok)) "ctor")
|
|
(begin (advance-tok!) (skip-path-app)))
|
|
((at-op? ".")
|
|
(begin (advance-tok!) (skip-path-app)))
|
|
((at-op? "(")
|
|
;; Paren-balanced argument list.
|
|
(let ((d 1))
|
|
(begin
|
|
(advance-tok!)
|
|
(define skip-args
|
|
(fn ()
|
|
(cond
|
|
((>= idx tok-len) nil)
|
|
((= (ocaml-tok-type (peek-tok)) "eof") nil)
|
|
((at-op? "(")
|
|
(begin (set! d (+ d 1)) (advance-tok!) (skip-args)))
|
|
((at-op? ")")
|
|
(cond
|
|
((= d 1) (begin (advance-tok!) nil))
|
|
(else (begin (set! d (- d 1)) (advance-tok!) (skip-args)))))
|
|
(else (begin (advance-tok!) (skip-args))))))
|
|
(skip-args)
|
|
(skip-path-app))))
|
|
(else nil))))
|
|
(skip-path-app)
|
|
(let ((body-src (slice src body-start (cur-pos))))
|
|
(list :module-alias name body-src))))))))))
|
|
(define
|
|
loop
|
|
(fn
|
|
()
|
|
(begin
|
|
(skip-double-semi!)
|
|
(when
|
|
(< idx tok-len)
|
|
(cond
|
|
((= (ocaml-tok-type (peek-tok)) "eof") nil)
|
|
((at-kw? "let")
|
|
(begin (append! decls (parse-decl-let)) (loop)))
|
|
((at-kw? "module")
|
|
(begin (append! decls (parse-decl-module)) (loop)))
|
|
((at-kw? "open")
|
|
(begin (append! decls (parse-decl-open false)) (loop)))
|
|
((at-kw? "include")
|
|
(begin (append! decls (parse-decl-open true)) (loop)))
|
|
(else (begin (append! decls (parse-decl-expr)) (loop))))))))
|
|
(loop)
|
|
(cons :program decls)))))
|