flan/lib/load.ml

(** Imports: {v (import rl "vendor:raylib") v} resolved into ordinary
    declarations, before the checker ever runs.

    The directory is the package (plan.org, Modules), so a path is a directory
    and every [.flan] file in it contributes. [vendor:] and [core:] are
    collections — root-directory aliases, as in Odin — and are resolved by
    walking up from the importing file until a directory of that name is found.
    No project file, no manifest: a loose file in a scratch directory is still
    a package of one.

    Importing is a rename, done here: every top-level name the package declares
    becomes [alias/name], and every use of one of its own names — in a type, in
    a body, in a struct literal — is rewritten to match. Local bindings shadow,
    so a parameter named like a package function stays the parameter. Nothing
    downstream knows a package existed; the checker sees one flat list of
    declarations with names that happen to contain a slash.

    That is not a module system yet. There is no visibility, no cycle
    detection, and a package cannot import another one — milestone 4 needs one
    package, imported once, and the rest can wait for a use that exercises it.

    A package may also carry the C it binds to. Every [.c] file in the
    directory is compiled into the build, and a file named [link] lists extra
    linker arguments, one per line. That is where the aggregate calling
    convention lives: a shim written in C means clang classifies [Vector2] and
    [Color] correctly on x86-64, arm64 and wasm32 alike, and [emit.ml] never
    learns the difference. *)

type t = {
  decls  : Ast.decl list;
  csrcs  : string list;    (* C sources compiled into the build *)
  lflags : string list;    (* extra linker arguments *)
  (* Which alias each package's directory was imported under, and the names it
     owns. A file on disk does not say what it is called from outside — the
     *importer* chooses that — so this is the only place the answer exists, and
     a REPL editing a package's source needs it to know that [settle] typed in
     sand-sim/sim.flan means [sim/settle] to the running program. *)
  pkgs   : pkg list;
}

and pkg = { alias : string; dir : string; owns : string list }

let fail loc fmt = Printf.ksprintf (fun m -> raise (Loc.Error (loc, m))) fmt

(* "vendor:raylib" -> the collection "vendor" and the subpath "raylib". A path
   with no colon is relative to the importing file's own directory. *)
let split_path path =
  match String.index_opt path ':' with
  | None -> None, path
  | Some i ->
    Some (String.sub path 0 i),
    String.sub path (i + 1) (String.length path - i - 1)

(* Walk up from [dir] looking for a subdirectory named [name]. Stops at the
   filesystem root, so a missing collection is an error and never a silent
   search of the whole machine. *)
let rec find_collection dir name =
  let candidate = Filename.concat dir name in
  if Sys.file_exists candidate && Sys.is_directory candidate then Some candidate
  else
    let parent = Filename.dirname dir in
    if String.equal parent dir then None else find_collection parent name

let resolve_dir ~file loc path =
  let here =
    let d = Filename.dirname file in
    if Filename.is_relative d then Filename.concat (Sys.getcwd ()) d else d
  in
  match split_path path with
  | None, rel ->
    let d = Filename.concat here rel in
    if Sys.file_exists d && Sys.is_directory d then d
    else fail loc "no package directory at %s" d
  | Some collection, rel ->
    (match find_collection here collection with
     | None ->
       fail loc
         "the collection %s: is a directory named %s somewhere above %s, and \
          there is none" collection collection here
     | Some root ->
       let d = Filename.concat root rel in
       if Sys.file_exists d && Sys.is_directory d then d
       else fail loc "the package %s is not at %s" path d)

let entries dir suffix =
  Sys.readdir dir
  |> Array.to_list
  |> List.filter (fun f -> Filename.check_suffix f suffix)
  |> List.sort String.compare
  |> List.map (Filename.concat dir)

(* ── Qualifying an imported package ────────────────────────────────── *)

let qualify alias n = alias ^ "/" ^ n

(* The type names the package itself declares. Only these are rewritten: a
   reference to [i32] or to [Ptr] must survive untouched. *)
let rec rename_texpr owned alias (t : Ast.texpr) : Ast.texpr =
  let k =
    match t.Ast.t with
    | Ast.Tname n when List.mem n owned -> Ast.Tname (qualify alias n)
    | Ast.Tname _ as k -> k
    | Ast.Tslice e -> Ast.Tslice (rename_texpr owned alias e)
    (* The length too: [rows] in [[rows [cols u32]]] is an ordinary
       compile-time constant of the package, not part of the type syntax. *)
    | Ast.Tarray (l, e) ->
      let l =
        match l with
        | Ast.Lname n when List.mem n owned -> Ast.Lname (qualify alias n)
        | l -> l
      in
      Ast.Tarray (l, rename_texpr owned alias e)
    | Ast.Tmap (k, v) ->
      Ast.Tmap (rename_texpr owned alias k, rename_texpr owned alias v)
    | Ast.Tapp (n, args) ->
      Ast.Tapp (n, List.map (rename_texpr owned alias) args)
    | Ast.Tfn (ps, r) ->
      Ast.Tfn (List.map (rename_texpr owned alias) ps, rename_texpr owned alias r)
  in
  { t with Ast.t = k }

(* Bodies too, once a package may define and not only declare. A package-local
   name is qualified wherever it is *used*; a local binding shadows it, which is
   why [bound] is carried down through [let], [fn] and [dotimes]. Everything
   else — field names, keywords, enum members — is not a top-level name and is
   left alone. *)
let rec rename_expr owned alias bound (e : Ast.expr) : Ast.expr =
  let go = rename_expr owned alias bound in
  let gos = List.map go in
  let name n = if List.mem n owned && not (List.mem n bound) then qualify alias n else n in
  let k =
    match e.Ast.e with
    | Ast.Int _ | Ast.Float _ | Ast.Byte _ | Ast.Str _ | Ast.Kw _
    | Ast.Quote _ -> e.Ast.e
    | Ast.Var n -> Ast.Var (name n)
    | Ast.Do body -> Ast.Do (gos body)
    | Ast.Let (bs, body) ->
      (* Sequential, as [let] itself is: each initialiser sees the bindings
         before it and not its own. *)
      let bound, bs =
        List.fold_left
          (fun (bound, acc) (b : Ast.binding) ->
             let b =
               { b with
                 Ast.bty = Option.map (rename_texpr owned alias) b.Ast.bty;
                 bval = rename_expr owned alias bound b.Ast.bval }
             in
             (b.Ast.bname :: bound, b :: acc))
          (bound, []) bs
      in
      Ast.Let (List.rev bs, List.map (rename_expr owned alias bound) body)
    | Ast.If (c, t, e') -> Ast.If (go c, go t, Option.map go e')
    | Ast.While (c, body) -> Ast.While (go c, gos body)
    | Ast.Return v -> Ast.Return (Option.map go v)
    | Ast.Set (p, v) -> Ast.Set (rename_place owned alias bound p, go v)
    | Ast.Field (t, f) -> Ast.Field (go t, f)
    | Ast.Call (h, args) -> Ast.Call (go h, gos args)
    | Ast.Match (sc, arms) ->
      Ast.Match (go sc,
                 List.map (fun (a : Ast.arm) ->
                   let bound =
                     match a.Ast.pat with
                     | Ast.Pctor (_, ns) -> ns @ bound
                     | Ast.Pwild -> bound
                   in
                   { a with Ast.body = List.map (rename_expr owned alias bound)
                                         a.Ast.body }) arms)
    | Ast.Struct (n, kvs) ->
      Ast.Struct (name n, List.map (fun (k, v) -> (k, go v)) kvs)
    | Ast.Arr items -> Ast.Arr (gos items)
    | Ast.Fn (ps, body) ->
      Ast.Fn (ps, List.map (rename_expr owned alias (ps @ bound)) body)
    | Ast.Dotimes (i, n, body) ->
      Ast.Dotimes (i, go n, List.map (rename_expr owned alias (i :: bound)) body)
    | Ast.Defer body -> Ast.Defer (gos body)
    | Ast.Unwrap (u, v) -> Ast.Unwrap (u, go v)
    | Ast.Signal c -> Ast.Signal (go c)
    (* A clause names a condition *type*, which an import renames like any
       other, and binds a name for the condition inside its own body. *)
    | Ast.HandlerBind (clauses, body) ->
      Ast.HandlerBind
        (List.map
           (fun (c : Ast.hclause) ->
              { c with
                Ast.hty = rename_texpr owned alias c.Ast.hty;
                hbody =
                  List.map (rename_expr owned alias (c.Ast.hname :: bound))
                    c.Ast.hbody })
           clauses,
         gos body)
  in
  { e with Ast.e = k }

and rename_place owned alias bound (p : Ast.place) : Ast.place =
  let go = rename_expr owned alias bound in
  match p with
  | Ast.Pvar n ->
    Ast.Pvar (if List.mem n owned && not (List.mem n bound) then qualify alias n else n)
  | Ast.Pfield (t, f) -> Ast.Pfield (go t, f)
  | Ast.Pindex (t, idx) -> Ast.Pindex (go t, List.map go idx)
  | Ast.Pkey (m, k) -> Ast.Pkey (go m, go k)
  | Ast.Pderef t -> Ast.Pderef (go t)

let rename_field owned alias (f : Ast.field) : Ast.field =
  { f with Ast.fty = rename_texpr owned alias f.Ast.fty }

let qualify_decl owned alias (d : Ast.decl) : Ast.decl =
  let loc = d.Ast.dloc in
  let k =
    match d.Ast.d with
    | Ast.Declare (fn, csym) ->
      Ast.Declare
        ({ fn with
           Ast.name = qualify alias fn.Ast.name;
           params = List.map (rename_field owned alias) fn.Ast.params;
           ret = Option.map (rename_texpr owned alias) fn.Ast.ret },
         csym)
    | Ast.Defenum (n, ms) -> Ast.Defenum (qualify alias n, ms)
    | Ast.Defalias (n, t) ->
      Ast.Defalias (qualify alias n, rename_texpr owned alias t)
    | Ast.Defconst (n, t, v) ->
      Ast.Defconst (qualify alias n,
                    Option.map (rename_texpr owned alias) t,
                    rename_expr owned alias [] v)
    | Ast.Defstruct (n, fs) ->
      Ast.Defstruct (qualify alias n, List.map (rename_field owned alias) fs)
    | Ast.Defvar (n, t, init) ->
      Ast.Defvar (qualify alias n, Option.map (rename_texpr owned alias) t,
                  (match init with
                   | Ast.Init v -> Ast.Init (rename_expr owned alias [] v)
                   | other -> other))
    | Ast.Defn fn ->
      let params = List.map (rename_field owned alias) fn.Ast.params in
      let bound = List.map (fun (p : Ast.field) -> p.Ast.fname) fn.Ast.params in
      Ast.Defn
        { fn with
          Ast.name = qualify alias fn.Ast.name;
          params;
          ret = Option.map (rename_texpr owned alias) fn.Ast.ret;
          fbody = List.map (rename_expr owned alias bound) fn.Ast.fbody }
    | Ast.Package _ -> Ast.Package alias
    | Ast.Import _ ->
      fail loc "an imported package may not import another one yet (milestone 4)"
    | Ast.Defunion (n, _) ->
      fail loc "%s is a union, and an imported union is not implemented yet \
                (milestone 4)" n
  in
  { d with Ast.d = k }

(* Every top-level name the package declares — types and values alike, since a
   use site is rewritten by name and the two never collide in one namespace. *)
let owned_names (ds : Ast.decl list) =
  List.filter_map Ast.declared_name ds

let import ~loc alias dir =
  let files = entries dir ".flan" in
  if files = [] then fail loc "the package at %s has no .flan file" dir;
  let ds = List.concat_map (fun f -> Parse.program (Reader.read_file f)) files in
  let owned = owned_names ds in
  let decls = List.map (qualify_decl owned alias) ds in
  let lflags =
    let path = Filename.concat dir "link" in
    if not (Sys.file_exists path) then []
    else begin
      let ch = open_in path in
      let rec go acc =
        match input_line ch with
        | line ->
          let line = String.trim line in
          go (if line = "" || line.[0] = '#' then acc else line :: acc)
        | exception End_of_file -> List.rev acc
      in
      let r = go [] in
      close_in ch; r
    end
  in
  { decls; csrcs = entries dir ".c"; lflags;
    pkgs = [ { alias; dir; owns = owned } ] }

(* ── The one entry point ───────────────────────────────────────────── *)

let program ~file (decls : Ast.decl list) : t =
  List.fold_left
    (fun acc (d : Ast.decl) ->
       match d.Ast.d with
       | Ast.Import (alias, path) ->
         let dir = resolve_dir ~file d.Ast.dloc path in
         let p = import ~loc:d.Ast.dloc alias dir in
         { decls = acc.decls @ p.decls;
           csrcs = acc.csrcs @ p.csrcs;
           lflags = acc.lflags @ p.lflags;
           pkgs = acc.pkgs @ p.pkgs }
       | _ -> { acc with decls = acc.decls @ [ d ] })
    { decls = []; csrcs = []; lflags = []; pkgs = [] }
    decls