flan/lib/ast.ml

(** The AST: syntax with special forms recognised, before typing.

    Sugar is gone by this point. [when], [unless], [cond] and [and]/[or] are
    desugared into [If] and [Do]; they are compiler special forms until macros
    arrive at milestone 5, so there is nothing to preserve for a macroexpander
    to see yet.

    Types here are *surface* type expressions, not resolved types. [Ptr] and
    [Option] are still just names; the checker resolves them. *)

(* ── Type expressions ──────────────────────────────────────────────── *)

type texpr = { t : texpr_kind; tloc : Loc.t }

and texpr_kind =
  | Tname  of string                  (* i32  bool  Cursor  string *)
  | Tslice of texpr                   (* [u8]                      ptr+len *)
  | Tarray of len * texpr             (* [4 f32]  [rows [cols u32]]        *)
  | Tmap   of texpr * texpr           (* (Map string i32)                  *)
  | Tapp   of string * texpr list     (* (Ptr Cursor)  (Option f64)        *)
  | Tfn    of texpr list * texpr      (* (Fn [a a] bool)                   *)

(* An array length is an integer or a compile-time constant's name. *)
and len =
  | Lint  of int64
  | Lname of string

(* ── Expressions ───────────────────────────────────────────────────── *)

type expr = { e : expr_kind; loc : Loc.t }

and expr_kind =
  | Int    of int64
  | Float  of float
  | Byte   of int
  | Str    of string
  | Kw     of string                  (* :space — coerced at typed call sites *)
  | Quote  of string                  (* 'skip-form — restart names *)
  | Var    of string
  | Do     of expr list
  | Let    of binding list * expr list
  | If     of expr * expr * expr option
  (* The [string option] is a loop label: [(while :outer c ...)]. A keyword in
     that position is unambiguous because a loop condition is never one. *)
  | While  of string option * expr * expr list
  (* [(loop [x 0 acc 1] body ...)] and [(recur v ...)]. A loop answers with the
     value of its body; a [recur] rebinds every one of the loop's names at once
     and jumps back to the top. It is not a tail call and there is no tail-call
     elimination anywhere in this compiler — the checker refuses a [recur] that
     is not in the loop body's tail position, so what would be a stack overflow
     under silent TCO is a compile error here. Each name takes a plain symbol:
     a destructuring pattern would turn one name into several and [recur]'s
     argument count could no longer be read off the binding vector. *)
  | Loop   of (string * expr) list * expr list
  | Recur  of expr list
  | Return of expr option
  (* Leaving a loop, and starting its next iteration. The [string option] is
     the label of the loop meant, and [None] means the innermost. Neither is a
     goto: the checker resolves the name against the loops this form is
     lexically inside, so control can only leave a loop it is already in —
     Odin's restriction, and what keeps it safe. *)
  | Break    of string option
  | Continue of string option
  | Set    of place * expr
  | Field  of expr * string           (* (.pos c) — auto-derefs one level *)
  | Call   of expr * expr list
  | Match  of expr * arm list
  | Struct of string * (string * expr) list   (* (Cursor {.src s}) *)
  (* {:a 1 :b s} — a dyn map literal. Braces whose first form is not a
     [.field] symbol are this; the struct spelling keeps the dot. Keys are
     ordinary expressions, keywords being the common case. *)
  (* The [string option] is a shape tag, and the parser never writes one: a
     tagged map is what a (defclass ...) constructor builds, and
     [Classes.expand] is the only thing that writes that constructor. The tag
     is the class's name; the instance carries it in its object header, not as
     an entry, so a tagged literal and an untagged one with the same pairs
     differ in exactly one word and in nothing a [get] can see. *)
  | MapLit of string option * (expr * expr) list
  | Arr    of expr list               (* [0xE6B800FF ...] — a fixed array value *)
  (* (array 4 rl/Vector2) — a zeroed fixed array, given its count and its
     element type. [n T] is the ordinary *type* syntax and already works
     everywhere a type is expected; a [let] binding is the one position with no
     type slot, so there [4 rl/Vector2] reads as a two-element [Arr] literal and
     fails on an unknown name. This is that position's answer, and it says what
     it does rather than looking like a vector of two things. *)
  | ArrayOf of texpr                  (* the whole array type, built by Parse *)
  (* These bind names or alter control flow, so none of them can be a call. *)
  | Fn      of string list * expr list        (* (fn [x y] ...) — non-escaping *)
  | Dotimes of string option * string * expr * expr list (* (dotimes :o [i n] ...) *)
  | Defer   of expr list                      (* runs on scope exit            *)
  | Unwrap  of unwrap * expr                  (* (some x) / (try x)            *)
  (* (handler-bind [(Type [c] body ...) ...] body ...) — spec-conditions.md.
     A clause binds a name for the condition, so this cannot be a call. *)
  | HandlerBind of hclause list * expr list
  (* (handler-case BODY [(Type [c] body ...) ...]) — the other half of
     spec-conditions.md's pair. Where a handler-bind clause runs at the signal
     with the stack below it intact, a handler-case clause runs *here*, after
     that stack has gone, and its value is the value of the whole form. The
     clauses share [hclause] with handler-bind because the syntax is the same
     one; what differs is entirely where the body runs. *)
  | HandlerCase of expr * hclause list
  | Signal  of sigkind * expr                 (* (signal c) / (error c)        *)
  (* (restart-case body (name [p T] body ...) ...) and
     (invoke-restart 'name arg ...). Both alter control flow, so neither can be
     a call, and a clause binds its parameters — §3. *)
  | RestartCase of expr * rclause list
  | InvokeRestart of string * expr list

(* Two ways to signal, because they are two different things — §1 and §2.
   [signal] returns Unit whatever it finds; [error] has type Never and, with
   nothing transferring, the program stops. *)
and sigkind = Ssignal | Serror

and hclause = { hty : texpr; hname : string; hbody : expr list; hloc : Loc.t }
(* [rparams] are §3's inline annotations, the same name/type pairs a [defn]
   takes. They are bound in the clause body and filled in by whatever invoked
   the restart, which is why their count and types are checked at run time
   (§3): a restart is found by name on a dynamic stack. *)
and rclause =
  { rname : string; rparams : field list; rbody : expr list; rloc : Loc.t }

(* Inline name/type pairs, as in [defn], [let] and [defstruct]. Here because a
   restart clause's parameters are one, and a clause is part of an expression. *)
and field = { fname : string; fty : texpr; floc : Loc.t }

(* One slot of a [defn]'s parameter vector, before it is known whether the slot
   is a name or a type. [(defn f [x y] ...)] is two dyn parameters if [y] is
   not a type and one parameter [x : y] if it is, and the parser cannot tell:
   the type names are not all known until macros have run and every file has
   been loaded. So the vector is carried undecided and paired in [Check], where
   the set is complete. See the argument in Parse beside the [defn] case. *)
and pitem =
  (* A bare symbol: either a parameter's name or a type's. *)
  | Pname of string * Loc.t
  (* Anything that cannot be a parameter name — [(Ptr T)], [[T]], [[n T]], [()]
     — and so is a type whatever the environment says. *)
  | Ptype of texpr

(* Two unwrap operators, because they are two different things — plan.org. *)
and unwrap = Usome | Utry

and binding = { bname : string; bty : texpr option; bval : expr; bloc : Loc.t }

(* The fixed list of assignable forms — spec-memory.md. Not setf. *)
and place =
  | Pvar   of string
  | Pfield of expr * string           (* (set (.hp e) v)      *)
  | Pindex of expr * expr list        (* (set (at grid r c) v) *)
  | Pderef of expr                    (* (set (deref p) v)     *)

and arm = { pat : pattern; body : expr list; aloc : Loc.t }

and pattern =
  | Pctor of string * string list     (* (Some e)  (Rect w h)  None *)
  | Pwild                             (* _  :else *)

(* ── Declarations ──────────────────────────────────────────────────── *)

(* One [where] predicate: [(ordered? $t)] is [{ pname = "ordered?"; pvar = "t" }].
   A predicate is a *compile-time question about a type*, not a type class: it
   carries no implementation and selects no instance, it only tells the
   abstract pass which builtin operators the variable may be used with, and
   makes each instantiation check the concrete type answers yes. *)
type pred = { pname : string; pvar : string; ploc : Loc.t }

type fn = {
  name    : string;
  params  : field list;
  (* [Some items] means the parameter vector has not been paired yet: it was
     written by a [defn], where a slot with no type means [dyn], and [Check]
     fills [params] from it before anything reads them. [None] is every other
     way a signature is built — [declare], the shim, the C importer — where
     every parameter's type was written out and the pairing was never in
     doubt. Nothing downstream of [Check.pair_params] sees [Some]. *)
  praw    : pitem list option;
  ret     : texpr option;             (* None means (); only declare omits it *)
  (* The [{:where ...}] map at the head of the body, already unpacked. Empty
     for every function that has none, which is every function that is not
     generic and most that are. *)
  fwhere  : pred list;
  fbody   : expr list;
  nloc    : Loc.t;
}

type decl = { d : decl_kind; dloc : Loc.t }

and decl_kind =
  | Package  of string
  | Import   of string * string       (* alias, path *)
  | Defalias of string * texpr
  | Defstruct of string * field list
  | Defdata of string * variant list
  (* C's union: the members overlay one another at offset zero, the size is
     the largest of them and the alignment the strictest. It carries the same
     [field list] a struct does, because that is what it is — the difference
     is entirely in the layout, and saying it with a second field type would
     only mean every walk had two shapes to handle for one idea. *)
  | Defunion of string * field list
  | Defn     of fn
  (* No body, so no [defn]: a foreign function, and the string is the C symbol
     it is actually called by (plan.org, Types — [declare] is kept only where
     there is no body). *)
  | Declare  of fn * string
  (* The same, but written in the C library's own terms — structs by value,
     strings as strings. [Shim] generates the C that flattens it and rewrites
     this into a [Declare] plus an ordinary [Defn], so nothing downstream sees
     one. Two forms and not one because [(declare f [p string] ...)] already
     means "the symbol takes ptr+len", which is the opposite of what this
     means. *)
  | DeclareC of fn * string
  (* Inline name/value pairs, as everywhere else. The members are what a
     keyword at a call site resolves against. *)
  | Defenum  of string * (string * int64) list
  (* value is optional: ZII. `uninit` opts out and is recorded as Uninit. *)
  | Defvar   of string * texpr option * init
  | Defconst of string * texpr option * expr
  (* ── The dyn side's classes and generic functions ──────────────────
     None of these four reaches [Check]. [Classes.expand] turns the whole set
     into ordinary [Defn]s before pass one collects anything, the way [Shim]
     already turns a [DeclareC] into a [Declare] plus a [Defn]: a class is a
     constructor, and a generic function is one function whose body is a
     dispatch over the methods written for it.

     They are declarations here rather than a macro because the expansion
     needs the *whole* declaration list in hand — a method may be written
     anywhere in the file, or arrive at a reload long after the generic did,
     and a macro sees one form. *)

  (* (defclass point [x y]) — the slot names, in constructor order. *)
  | Defclass of string * (string * Loc.t) list
  (* (defgeneric area [self] dyn) — CLOS's class dispatch: the dispatch value
     is the shape tag of the first argument. The parameter vector and the
     return slot are a [defn]'s, and there is no body. *)
  | Defgeneric of fn
  (* (defmulti describe [x] dyn (get x :kind)) — Clojure's: the body IS the
     dispatch function, computing the value the methods are keyed by. Exactly
     a [defn]'s shape, which is what it is. *)
  | Defmulti of fn
  (* (defmethod area point [p] body ...) — one method of a generic. [mgen] is
     the generic's name, [mkey] the dispatch value it answers for, and [mfn]
     carries the parameter vector and the body. There is no return slot: the
     generic states the return type once, for all of its methods. *)
  | Defmethod of methd

(* A dispatch value, written at a [defmethod]. Only literals: the value is
   compared at run time and the *name* the method is declared under is built
   from it at compile time, so it has to be something both passes can read. *)
and dispatch =
  (* [point] — a class's name, standing for the keyword its instances carry.
     Refused unless a [defclass] of that name is in scope, which is the one
     compile-time check a shape tag makes possible. *)
  | Dclass of string
  | Dkw    of string                  (* :circle *)
  | Dstr   of string                  (* "circle" *)
  | Dint   of int64
  | Dbool  of bool
  (* [:else] — the method that answers when no other does. The spelling is
     [match]'s, not Clojure's [:default], because this language already has
     one word for "none of the above" and two would be one too many. *)
  | Delse

and methd = { mgen : string; mkey : dispatch; mfn : fn; mkloc : Loc.t }

and variant = { vname : string; vfields : field list; vloc : Loc.t }

(* [Ambiguous] is the three-element [(defvar x foo)] and [(defvar x (f y))]:
   forms whose third element parses as a type *and* as an expression, so which
   one it is cannot be decided until names exist. The [texpr] beside it in
   [Defvar] is the type reading and this is the value reading; [Check.collect]
   picks, type first — a known type name or a built-in type constructor is
   [Zeroed], anything else is [Init] of this expression at [dyn]. Everything
   whose shape settles it is settled in [Parse] and never becomes one of
   these. *)
and init = Zeroed | Uninit | Init of expr | Ambiguous of expr

(* Every top-level name a declaration introduces, whatever kind it is. There is
   one top-level namespace, so this is both the set [Load] renames on an import
   and the set [Check] refuses to see twice — one definition, so the two cannot
   drift apart. *)
(* How a dispatch value reads back, in a message and in the name below. The
   keyword keeps its colon and the string its quotes, so that a method written
   for :circle and one written for "circle" — two different values — do not
   read as the same thing in a duplicate-method refusal. *)
let dispatch_text = function
  | Dclass n -> n
  | Dkw k -> ":" ^ k
  | Dstr s -> "\"" ^ s ^ "\""
  | Dint i -> Int64.to_string i
  | Dbool b -> if b then "true" else "false"
  | Delse -> ":else"

(* The top-level name a [defmethod] declares. No function is ever emitted
   under it — a method's body is inlined into its generic's dispatch, so the
   only function the pass writes is the generic itself — but a declaration
   still needs a name of its own, for the reason every declaration does: a
   session replaces a declaration it has already seen by name, and appends one
   it has not. Redefining a method has to replace, and adding one has to
   append, and the pair (generic, dispatch value) is what tells those two
   apart. The [@] is what keeps the name out of a program's reach: no symbol a
   reader accepts contains one. *)
let method_name (m : methd) = m.mgen ^ "@" ^ dispatch_text m.mkey

let declared_name (d : decl) =
  match d.d with
  | Defenum (n, _) | Defalias (n, _) | Defstruct (n, _) | Defdata (n, _)
  | Defunion (n, _) | Defvar (n, _, _) | Defconst (n, _, _)
  | Defclass (n, _) -> Some n
  | Declare (fn, _) | DeclareC (fn, _) | Defn fn
  | Defgeneric fn | Defmulti fn -> Some fn.name
  | Defmethod m -> Some (method_name m)
  | Package _ | Import _ -> None

(* ── Instrumenting a form with (pause) ─────────────────────────────── *)

(* [C-u C-c C-c] marks a form so the program stops when it runs — docs/DISCUSS.md
   §9. The mark travels beside the source as a position and is applied *here*,
   to the AST, rather than being spliced into the text the editor sends: text
   would shift every line and column after the insertion, and the error
   overlays, the layout, the break loop's frame locations and DWARF all read
   those. Applied after parsing, every location is already attached and none of
   them moves.

   Nothing in the compiler knows about this. [(pause)] is an ordinary prelude
   function — [error] under a [restart-case] — so an instrumented body is a
   body that calls one more function, and the break loop it lands in is the one
   an unhandled condition already builds. *)

(* Rebuild [e] with [f] applied to each expression written directly inside it.
   Exhaustive on purpose: a constructor left out would be a form the mark
   silently cannot be set inside, which is the kind of hole nobody finds
   except by trying it on the one function they wanted to stop in. *)
let map_children f (e : expr) : expr =
  let ex = f in
  let bind (b : binding) = { b with bval = ex b.bval } in
  let arm (a : arm) = { a with body = List.map ex a.body } in
  let hcl (h : hclause) = { h with hbody = List.map ex h.hbody } in
  let rcl (r : rclause) = { r with rbody = List.map ex r.rbody } in
  let place = function
    | Pvar n -> Pvar n
    | Pfield (x, n) -> Pfield (ex x, n)
    | Pindex (x, is) -> Pindex (ex x, List.map ex is)
    | Pderef x -> Pderef (ex x)
  in
  let kind =
    match e.e with
    | Int _ | Float _ | Byte _ | Str _ | Kw _ | Quote _ | Var _ | ArrayOf _
    | Break _ | Continue _ -> e.e
    | Do es -> Do (List.map ex es)
    | Let (bs, es) -> Let (List.map bind bs, List.map ex es)
    | If (c, a, b) -> If (ex c, ex a, Option.map ex b)
    | While (l, c, es) -> While (l, ex c, List.map ex es)
    | Loop (bs, es) -> Loop (List.map (fun (n, v) -> (n, ex v)) bs, List.map ex es)
    | Recur es -> Recur (List.map ex es)
    | Return x -> Return (Option.map ex x)
    | Set (p, v) -> Set (place p, ex v)
    | Field (x, n) -> Field (ex x, n)
    | Call (fn, args) -> Call (ex fn, List.map ex args)
    | Match (s, arms) -> Match (ex s, List.map arm arms)
    | Struct (n, fs) -> Struct (n, List.map (fun (n, v) -> (n, ex v)) fs)
    | MapLit (tag, kvs) -> MapLit (tag, List.map (fun (k, v) -> (ex k, ex v)) kvs)
    | Arr es -> Arr (List.map ex es)
    | Fn (ps, es) -> Fn (ps, List.map ex es)
    | Dotimes (l, n, c, es) -> Dotimes (l, n, ex c, List.map ex es)
    | Defer es -> Defer (List.map ex es)
    | Unwrap (u, x) -> Unwrap (u, ex x)
    | HandlerBind (cs, es) -> HandlerBind (List.map hcl cs, List.map ex es)
    | HandlerCase (b, cs) -> HandlerCase (ex b, List.map hcl cs)
    | Signal (k, x) -> Signal (k, ex x)
    | RestartCase (b, cs) -> RestartCase (ex b, List.map rcl cs)
    | InvokeRestart (n, args) -> InvokeRestart (n, List.map ex args)
  in
  { e with e = kind }

let pause_call loc = { e = Call ({ e = Var "pause"; loc }, []); loc }

(* [mark_pause ~line ~col ds] is [ds] with a [(pause)] put in front of whatever
   starts at that position, or [None] when nothing does.

   [None] rather than "leave it alone": installing an unmarked body and
   answering "ok" would report a breakpoint that is not there, which is the
   failure the session refuses everywhere else.

   Pre-order, and it stops at the first hit. Desugaring gives several nested
   nodes the same location — [(when c a)] becomes an [If] whose else-less
   branch is a [Do] at the [when]'s own position — so the outermost of those is
   the one the editor pointed at.

   A whole top-level [defn] is the third target from §9 and cannot be wrapped:
   [(do (pause) (defn ...))] is not an expression. Marking one means stopping
   on entry, so the call goes at the front of its body. *)
let mark_pause ~line ~col (ds : decl list) : decl list option =
  let at (l : Loc.t) = l.Loc.line = line && l.Loc.col = col in
  let hit = ref false in
  let rec walk (e : expr) =
    if !hit then e
    else if at e.loc then begin
      hit := true;
      (* The [Do] takes the target's own location, and the target keeps its
         own: a wrapper at [Loc.unknown] would put the frame the break loop
         reports, and the line DWARF names, nowhere. *)
      { e with e = Do [ pause_call e.loc; e ] }
    end
    else map_children walk e
  in
  let body es = List.map walk es in
  let decl (d : decl) =
    match d.d with
    | Defn f when (not !hit) && at d.dloc ->
      hit := true;
      { d with d = Defn { f with fbody = pause_call d.dloc :: f.fbody } }
    | Defn f -> { d with d = Defn { f with fbody = body f.fbody } }
    (* A method's body and a defmulti's dispatch body are code someone wrote
       and can stop inside, so both are walked. Marking the whole declaration
       — the [at d.dloc] case above — is deliberately not offered for either:
       a method is not a function of its own by the time it runs, so there is
       no entry to stop at, only the forms inside it. *)
    | Defmethod m ->
      { d with d = Defmethod { m with mfn = { m.mfn with fbody = body m.mfn.fbody } } }
    | Defmulti f -> { d with d = Defmulti { f with fbody = body f.fbody } }
    | Defvar (n, t, Init e) -> { d with d = Defvar (n, t, Init (walk e)) }
    (* The value reading of an undecided [defvar] is walked too: if it is the
       one that wins it is an initialiser like any other, and if the type
       reading wins the expression is dropped whole and the mark with it. *)
    | Defvar (n, t, Ambiguous e) ->
      { d with d = Defvar (n, t, Ambiguous (walk e)) }
    | Defconst (n, t, e) -> { d with d = Defconst (n, t, walk e) }
    | _ -> d
  in
  let ds = List.map decl ds in
  if !hit then Some ds else None