meowc/lib/eval.ml

open Ast

type opt = { oname : string; oty : string; odefault : string list; ospan : Span.t }

type env = {
  vars : (string, string list) Hashtbl.t;
  mutable declared : string list;
  opts : (string, opt) Hashtbl.t;
  overrides : (string, string) Hashtbl.t;
  probe : Probe.t;
  mutable tc : Types.toolchain;
  mutable blocks : (Ast.block * string) list;
  mutable defines : Types.define list;
  mutable config_header : string option;
  pkgs : (string, string list * string list) Hashtbl.t;
  mutable stack : string list;
  mutable pname : string;
  mutable quiet : bool;
  mutable probes_shown : int;
}

let placeholders =
  [ "in"; "out"; "stem"; "dir"; "base"; "ext"; "name" ]
  @ List.init 8 (fun i -> Printf.sprintf "out%d" i)
  @ List.init 8 (fun i -> Printf.sprintf "in%d" i)

let truthy = function
  | [] -> false
  | l -> (
      match String.lowercase_ascii (String.concat " " l) with
      | "" | "0" | "false" | "no" | "off" | "n" -> false
      | _ -> true)

let setvar env name values =
  if not (Hashtbl.mem env.vars name) then env.declared <- env.declared @ [ name ];
  Hashtbl.replace env.vars name values

let var_names env = List.sort compare env.declared

let uname () =
  let code, out = Exec.capture [| "uname"; "-s" |] in
  if code = 0 then String.lowercase_ascii (String.trim out) else "unknown"

let arch () =
  let code, out = Exec.capture [| "uname"; "-m" |] in
  if code = 0 then String.trim out else "unknown"

let compiler_id cc =
  let code, out = Exec.capture [| cc; "--version" |] in
  if code <> 0 then "unknown"
  else
    let l = String.lowercase_ascii out in
    let has s =
      let n = String.length s and m = String.length l in
      let rec go i = i + n <= m && (String.sub l i n = s || go (i + 1)) in
      go 0
    in
    if has "clang" then "clang"
    else if has "free software foundation" || has "gcc" then "gcc"
    else if has "tcc" then "tcc"
    else "unknown"

let default_tc : Types.toolchain =
  {
    cc = "cc";
    cxx = "c++";
    ar = "ar";
    ranlib = "ranlib";
    cflags = [];
    cxxflags = [];
    ldflags = [];
    builddir = "build";
  }

let create ~overrides ~quiet ~builddir =
  let tc = { default_tc with builddir } in
  let env =
    {
      vars = Hashtbl.create 64;
      declared = [];
      opts = Hashtbl.create 16;
      overrides;
      probe = Probe.load (Filename.concat builddir ".meowc-probe");
      tc;
      blocks = [];
      defines = [];
      config_header = None;
      pkgs = Hashtbl.create 8;
      stack = [];
      pname = "unnamed";
      quiet;
      probes_shown = 0;
    }
  in
  let os = uname () in
  let plat =
    match os with
    | "linux" -> "linux"
    | "darwin" -> "darwin"
    | "freebsd" | "openbsd" | "netbsd" -> "bsd"
    | s -> s
  in
  List.iter (fun (k, v) -> setvar env k [ v ])
    [
      ("platform", plat);
      ("arch", arch ());
      ("linux", if plat = "linux" then "true" else "false");
      ("darwin", if plat = "darwin" then "true" else "false");
      ("bsd", if plat = "bsd" then "true" else "false");
      ("windows", if plat = "windows" then "true" else "false");
      ("unix", if plat = "windows" then "false" else "true");
      ("builddir", builddir);
      ("cc", tc.cc);
      ("cxx", tc.cxx);
      ("cc_id", "unknown");
      ("project", env.pname);
      ("prefix", "/usr/local");
    ];
  env

let lookup env name span =
  if String.length name > 4 && String.sub name 0 4 = "env." then
    let k = String.sub name 4 (String.length name - 4) in
    [ (match Sys.getenv_opt k with Some v -> v | None -> "") ]
  else
    match Hashtbl.find_opt env.vars name with
    | Some l -> l
    | None ->
        if List.mem name placeholders then [ "${" ^ name ^ "}" ]
        else
          Diag.error ~span ~hint:(Suggest.hint name (var_names env)) "unknown variable ${%s}" name

let is_whole_ref t =
  let n = String.length t in
  n > 3
  && String.sub t 0 2 = "${"
  && t.[n - 1] = '}'
  && match String.index_opt t '}' with Some i -> i = n - 1 | None -> false

let expand env (v : value) =
  let t = v.text in
  let n = String.length t in
  if is_whole_ref t then lookup env (String.sub t 2 (n - 3)) v.span
  else begin
    let b = Buffer.create n in
    let i = ref 0 in
    while !i < n do
      if t.[!i] = '$' && !i + 1 < n && t.[!i + 1] = '{' then
        match String.index_from_opt t (!i + 2) '}' with
        | None -> (Buffer.add_char b t.[!i]; incr i)
        | Some j ->
            let name = String.sub t (!i + 2) (j - !i - 2) in
            Buffer.add_string b (String.concat " " (lookup env name v.span));
            i := j + 1
      else (Buffer.add_char b t.[!i]; incr i)
    done;
    [ Buffer.contents b ]
  end

let expand_all env vs = List.concat_map (expand env) vs
let expand1 env v = String.concat " " (expand env v)

let rec eval_expr env = function
  | Atom v ->
      if v.quoted || String.length v.text > 1 && v.text.[0] = '$' then truthy (expand env v)
      else truthy (lookup env v.text v.span)
  | Not (e, _) -> not (eval_expr env e)
  | And (a, b) -> eval_expr env a && eval_expr env b
  | Or (a, b) -> eval_expr env a || eval_expr env b
  | Cmp (a, op, b) ->
      let x = expand1 env a and y = expand1 env b in
      if op = "==" then x = y else x <> y

let show_probe env label result detail =
  if not env.quiet then begin
    env.probes_shown <- env.probes_shown + 1;
    Printf.printf "  %s%s%s\n"
      (Style.blue (Style.pad 8 "check"))
      (Style.pad 46 label)
      (if result then Style.green detail else Style.dim detail);
    flush stdout
  end

let define env name value = env.defines <- env.defines @ [ { Types.dname = name; dvalue = value } ]

let record env ~label ~var ~macro (o : Probe.outcome) ~detail =
  setvar env var [ (if o.ok then "true" else "false") ];
  define env macro (if o.ok then Some "1" else None);
  if env.probe.Probe.ran > 0 then show_probe env label o.ok detail

let run_check env (c : check) =
  let before = env.probe.Probe.ran in
  let fresh () = env.probe.Probe.ran > before in
  match c with
  | Header h ->
      let name = expand1 env h in
      let o = Probe.header env.probe name in
      setvar env (Ident.have_var name) [ (if o.ok then "true" else "false") ];
      define env (Ident.have name) (if o.ok then Some "1" else None);
      if fresh () then show_probe env ("header " ^ name) o.ok (if o.ok then "yes" else "no")
  | Func (f, lib) ->
      let name = expand1 env f in
      let l = Option.map (expand1 env) lib in
      let o = Probe.func env.probe name l in
      setvar env (Ident.have_var name) [ (if o.ok then "true" else "false") ];
      define env (Ident.have name) (if o.ok then Some "1" else None);
      let label = "func " ^ name ^ (match l with Some x -> " in " ^ x | None -> "") in
      if fresh () then show_probe env label o.ok (if o.ok then "yes" else "no")
  | Symbol (s, h) ->
      let name = expand1 env s and hdr = expand1 env h in
      let o = Probe.symbol env.probe name hdr in
      setvar env (Ident.have_var name) [ (if o.ok then "true" else "false") ];
      define env (Ident.have name) (if o.ok then Some "1" else None);
      if fresh () then
        show_probe env ("symbol " ^ name ^ " in " ^ hdr) o.ok (if o.ok then "yes" else "no")
  | Sizeof ty ->
      let name = expand1 env ty in
      let o = Probe.sizeof env.probe name in
      setvar env (Ident.sizeof_var name) [ (if o.ok then o.value else "0") ];
      define env (Ident.sizeof_name name) (if o.ok then Some o.value else None);
      if fresh () then
        show_probe env ("sizeof " ^ name) o.ok (if o.ok then o.value else "unknown")
  | Compiles (n, body) ->
      let name = expand1 env n in
      let o = Probe.snippet env.probe name (expand1 env body) in
      setvar env (Ident.have_var name) [ (if o.ok then "true" else "false") ];
      define env (Ident.have name) (if o.ok then Some "1" else None);
      if fresh () then show_probe env ("compiles " ^ name) o.ok (if o.ok then "yes" else "no")

let run_pkg env name cons span =
  let n = expand1 env name in
  let c = Option.map (expand1 env) cons in
  let before = env.probe.Probe.ran in
  let o = Probe.pkg_config env.probe n c in
  let cflags, libs = Probe.pkg_parts o in
  Hashtbl.replace env.pkgs n (cflags, libs);
  setvar env (Ident.have_var n) [ (if o.ok then "true" else "false") ];
  setvar env (n ^ "_cflags") cflags;
  setvar env (n ^ "_libs") libs;
  define env (Ident.have n) (if o.ok then Some "1" else None);
  ignore span;
  if env.probe.Probe.ran > before then
    show_probe env
      ("pkg " ^ n ^ (match c with Some x -> " " ^ x | None -> ""))
      o.ok
      (if o.ok then if o.note = "" then "yes" else o.note else "not found")

let under base p =
  if base = "" || base = "." then p
  else if String.length p > 0 && p.[0] = '/' then p
  else Filename.concat base p

let rec flatten_items env items =
  List.concat_map
    (function
      | FField f -> [ f ]
      | FIf (arms, els) -> (
          match List.find_opt (fun (c, _) -> eval_expr env c) arms with
          | Some (_, body) -> flatten_items env body
          | None -> flatten_items env els))
    items

let apply_toolchain env fields =
  List.iter
    (fun (f : field) ->
      let vs = expand_all env f.values in
      let one () = String.concat " " vs in
      let tc = env.tc in
      env.tc <-
        (match f.key with
        | "cc" -> { tc with cc = one () }
        | "cxx" -> { tc with cxx = one () }
        | "ar" -> { tc with ar = one () }
        | "ranlib" -> { tc with ranlib = one () }
        | "cflags" -> { tc with cflags = tc.cflags @ vs }
        | "cxxflags" -> { tc with cxxflags = tc.cxxflags @ vs }
        | "ldflags" -> { tc with ldflags = tc.ldflags @ vs }
        | "builddir" -> { tc with builddir = one () }
        | k ->
            Diag.error ~span:f.kspan
              ~hint:
                (Suggest.hint k
                   [ "cc"; "cxx"; "ar"; "ranlib"; "cflags"; "cxxflags"; "ldflags"; "builddir" ])
              "toolchain has no field %S" k))
    fields;
  setvar env "cc" [ env.tc.cc ];
  setvar env "cxx" [ env.tc.cxx ];
  setvar env "builddir" [ env.tc.builddir ];
  setvar env "cc_id" [ compiler_id env.tc.cc ];
  env.probe.Probe.cc <- env.tc.cc;
  env.probe.Probe.cflags <- env.tc.cflags;
  env.probe.Probe.ldflags <- env.tc.ldflags

let rec predeclare env stmts =
  let name (v : value) = v.text in
  List.iter
    (fun st ->
      match st with
      | Check (c, _) -> (
          match c with
          | Header h -> setvar env (Ident.have_var (name h)) [ "false" ]
          | Func (f, _) -> setvar env (Ident.have_var (name f)) [ "false" ]
          | Symbol (s, _) -> setvar env (Ident.have_var (name s)) [ "false" ]
          | Sizeof t -> setvar env (Ident.sizeof_var (name t)) [ "0" ]
          | Compiles (n, _) -> setvar env (Ident.have_var (name n)) [ "false" ])
      | Pkg (n, _, _) ->
          setvar env (Ident.have_var (name n)) [ "false" ];
          setvar env (name n ^ "_cflags") [];
          setvar env (name n ^ "_libs") []
      | Option (n, _, d) ->
          if not (Hashtbl.mem env.vars n.text) then
            setvar env n.text
              (match Hashtbl.find_opt env.overrides n.text with
              | Some v -> String.split_on_char ' ' v |> List.filter (fun s -> s <> "")
              | None -> List.map name d)
      | If (arms, els) ->
          List.iter (fun (_, b) -> predeclare env b) arms;
          predeclare env els
      | _ -> ())
    stmts

let rec run env base stmts =
  predeclare env stmts;
  List.iter (run_stmt env base) stmts

and run_stmt env base st =
  match st with
  | Project n ->
      env.pname <- expand1 env n;
      setvar env "project" [ env.pname ]
  | Set (n, vs) -> setvar env n.text (expand_all env vs)
  | Append (n, vs) ->
      let prev = match Hashtbl.find_opt env.vars n.text with Some l -> l | None -> [] in
      setvar env n.text (prev @ expand_all env vs)
  | Option (n, ty, dflt) ->
      let o = { oname = n.text; oty = ty.text; odefault = expand_all env dflt; ospan = n.span } in
      Hashtbl.replace env.opts n.text o;
      let value =
        match Hashtbl.find_opt env.overrides n.text with
        | Some v -> String.split_on_char ' ' v |> List.filter (fun s -> s <> "")
        | None -> o.odefault
      in
      setvar env n.text value
  | Include v ->
      let path = under base (expand1 env v) in
      splice env (Filename.dirname path) path v.span
  | Subdir v ->
      let dir = under base (expand1 env v) in
      let path = Filename.concat dir "build.meow" in
      splice env dir path v.span
  | If (arms, els) -> (
      match List.find_opt (fun (c, _) -> eval_expr env c) arms with
      | Some (_, body) -> run env base body
      | None -> run env base els)
  | Check (c, _) -> run_check env c
  | Pkg (n, c, span) -> run_pkg env n c span
  | ConfigHeader v -> env.config_header <- Some (under base (expand1 env v))
  | Message (lvl, vs) ->
      let text = String.concat " " (expand_all env vs) in
      (match lvl.text with
      | "error" -> Diag.error ~span:lvl.span "%s" text
      | "warn" -> Printf.eprintf "  %s %s\n" (Style.yellow "warning") text
      | _ -> if not env.quiet then Printf.printf "  %s %s\n" (Style.blue "note") text)
  | Blk b ->
      let fields = flatten_items env b.items in
      if b.kind = "toolchain" then apply_toolchain env fields
      else
        let expanded =
          List.map
            (fun (f : field) ->
              {
                f with
                values =
                  List.concat_map
                    (fun (v : value) ->
                      List.map (fun t -> { text = t; span = v.span; quoted = v.quoted }) (expand env v))
                    f.values;
              })
            fields
        in
        env.blocks <-
          env.blocks @ [ ({ b with items = List.map (fun f -> FField f) expanded }, base) ]

and splice env dir path span =
  if List.mem path env.stack then
    Diag.error ~span "include cycle: %s" (String.concat " -> " (List.rev (path :: env.stack)));
  if not (Sys.file_exists path) then Diag.error ~span "cannot read %s" path;
  env.stack <- path :: env.stack;
  run env dir (Parse.file path);
  env.stack <- List.tl env.stack