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}) *)
  | 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
  | 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 }

(* 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;
  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

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

and init = Zeroed | Uninit | Init 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. *)
let declared_name (d : decl) =
  match d.d with
  | Defenum (n, _) | Defalias (n, _) | Defstruct (n, _) | Defdata (n, _)
  | Defunion (n, _) | Defvar (n, _, _) | Defconst (n, _, _) -> Some n
  | Declare (fn, _) | DeclareC (fn, _) | Defn fn -> Some fn.name
  | 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)
    | 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)
    | 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 } }
    | Defvar (n, t, Init e) -> { d with d = Defvar (n, t, Init (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