utop/syntax/pa_optcomp.ml

(*
 * pa_optcomp.ml
 * -------------
 * Copyright : (c) 2008, Jeremie Dimino <jeremie@dimino.org>
 * Licence   : BSD3
 *
 * This file is a part of optcomp.
 *)

open Camlp4.Sig
open Camlp4.PreCast

external filter : 'a Gram.not_filtered -> 'a = "%identity"
external not_filtered : 'a -> 'a Gram.not_filtered = "%identity"

(* Subset of supported caml types *)
type typ =
  | Tvar of string
  | Tbool
  | Tint
  | Tchar
  | Tstring
  | Ttuple of typ list

(* Subset of supported caml values *)
type value =
  | Bool of bool
  | Int of int
  | Char of char
  | String of string
  | Tuple of value list

type ident = string
    (* An identifier. It is either a lower or a upper identifier. *)

module Env = Map.Make(struct type t = ident let compare = compare end)

type env = value Env.t

type directive =
  | Dir_let of ident * Ast.expr
  | Dir_default of ident * Ast.expr
  | Dir_if of Ast.expr
  | Dir_else
  | Dir_elif of Ast.expr
  | Dir_endif
  | Dir_include of Ast.expr
  | Dir_error of Ast.expr
  | Dir_warning of Ast.expr
  | Dir_directory of Ast.expr

  (* This one is not part of optcomp but this is one of the directives
     handled by camlp4 we probably want to use. *)
  | Dir_default_quotation of Ast.expr

(* Quotations are evaluated by the token filters, but are expansed
   after. Evaluated quotations are kept in this table, which quotation
   id to to values: *)
let quotations : (int, value) Hashtbl.t = Hashtbl.create 42

let next_quotation_id =
  let r = ref 0 in
  fun _ -> incr r; !r

(* +-------------+
   | Environment |
   +-------------+ *)

let env = ref Env.empty
let define id value = env := Env.add id value !env

let _ =
  define "ocaml_version" (Scanf.sscanf Sys.ocaml_version "%d.%d" (fun major minor -> Tuple [Int major; Int minor]))

let dirs = ref []
let add_include_dir dir = dirs := dir :: !dirs

(* +--------------+
   | Dependencies |
   +--------------+ *)

module String_set = Set.Make(String)

(* All depencies of the file being parsed *)
let dependencies = ref String_set.empty

(* Where to write dependencies *)
let dependency_filename = ref None

(* The file being parsed. This is set when the first (token, location)
   pair is fetched. *)
let source_filename = ref None

let write_depencies () =
  match !dependency_filename, !source_filename with
    | None, _
    | _, None ->
        ()

    | Some dependency_filename, Some source_filename ->
        let oc = open_out dependency_filename in
        if not (String_set.is_empty !dependencies) then begin
          output_string oc "# automatically generated by optcomp\n";
          output_string oc source_filename;
          output_string oc ": ";
          output_string oc (String.concat " " (String_set.elements !dependencies));
          output_char oc '\n'
        end;
        close_out oc

(* +----------------------------------------+
   | Value to expression/pattern conversion |
   +----------------------------------------+ *)

let rec expr_of_value _loc = function
  | Bool true -> <:expr< true >>
  | Bool false -> <:expr< false >>
  | Int x -> <:expr< $int:string_of_int x$ >>
  | Char x -> <:expr< $chr:Char.escaped x$ >>
  | String x -> <:expr< $str:String.escaped x$ >>
  | Tuple [] -> <:expr< () >>
  | Tuple [x] -> expr_of_value _loc x
  | Tuple l -> <:expr< $tup:Ast.exCom_of_list (List.map (expr_of_value _loc) l)$ >>

let rec patt_of_value _loc = function
  | Bool true -> <:patt< true >>
  | Bool false -> <:patt< false >>
  | Int x -> <:patt< $int:string_of_int x$ >>
  | Char x -> <:patt< $chr:Char.escaped x$ >>
  | String x -> <:patt< $str:String.escaped x$ >>
  | Tuple [] -> <:patt< () >>
  | Tuple [x] -> patt_of_value _loc x
  | Tuple l -> <:patt< $tup:Ast.paCom_of_list (List.map (patt_of_value _loc) l)$ >>

(* +-----------------------+
   | Expression evaluation |
   +-----------------------+ *)

let rec type_of_value = function
  | Bool _ -> Tbool
  | Int _ -> Tint
  | Char _ -> Tchar
  | String _ -> Tstring
  | Tuple l -> Ttuple (List.map type_of_value l)

let rec string_of_type = function
  | Tvar v -> "'" ^ v
  | Tbool -> "bool"
  | Tint -> "int"
  | Tchar -> "char"
  | Tstring -> "string"
  | Ttuple l -> "(" ^ String.concat " * " (List.map string_of_type l) ^ ")"

let invalid_type loc expected real =
  Loc.raise loc (Failure
                   (Printf.sprintf "this expression has type %s but is used with type %s"
                      (string_of_type real) (string_of_type expected)))

let type_of_patt patt =
  let rec aux (a, n) = function
    | <:patt< $tup:x$ >> ->
      let l, x = List.fold_left
        (fun (l, x) patt -> let t, x = aux x patt in (t :: l, x))
        ([], (a, n)) (Ast.list_of_patt x []) in
      (Ttuple(List.rev l), x)
    | _ ->
        (Tvar(Printf.sprintf "%c%s"
                (char_of_int (Char.code 'a' + a))
                (if n = 0 then "" else string_of_int n)),
         if a = 25 then (0, n + 1) else (a + 1, n))
  in
  fst (aux (0, 0) patt)

let rec eval env = function

  (* Literals *)
  | <:expr< true >> -> Bool true
  | <:expr< false >> -> Bool false
  | <:expr< $int:x$ >> -> Int(int_of_string x)
  | <:expr< $chr:x$ >> -> Char(Camlp4.Struct.Token.Eval.char x)
  | <:expr< $str:x$ >> -> String(Camlp4.Struct.Token.Eval.string ~strict:() x)

  (* Tuples *)
  | <:expr< $tup:x$ >> -> Tuple(List.map (eval env) (Ast.list_of_expr x []))

  (* Variables *)
  | <:expr@loc< $lid:x$ >>
  | <:expr@loc< $uid:x$ >> ->
    begin try
      Env.find x env
    with
        Not_found ->
          Loc.raise loc (Failure (Printf.sprintf "unbound value %s" x))
    end

  (* Value comparing *)
  | <:expr< $x$ = $y$ >> -> let x, y = eval_same env x y in Bool(x = y)
  | <:expr< $x$ < $y$ >> -> let x, y = eval_same env x y in Bool(x < y)
  | <:expr< $x$ > $y$ >> -> let x, y = eval_same env x y in Bool(x > y)
  | <:expr< $x$ <= $y$ >> -> let x, y = eval_same env x y in Bool(x <= y)
  | <:expr< $x$ >= $y$ >> -> let x, y = eval_same env x y in Bool(x >= y)
  | <:expr< $x$ <> $y$ >> -> let x, y = eval_same env x y in Bool(x <> y)

  (* min and max *)
  | <:expr< min $x$ $y$ >> -> let x, y = eval_same env x y in min x y
  | <:expr< max $x$ $y$ >> -> let x, y = eval_same env x y in max x y

  (* Arithmetic *)
  | <:expr< $x$ + $y$ >> -> Int(eval_int env x + eval_int env y)
  | <:expr< $x$ - $y$ >> -> Int(eval_int env x - eval_int env y)
  | <:expr< $x$ * $y$ >> -> Int(eval_int env x * eval_int env y)
  | <:expr< $x$ / $y$ >> -> Int(eval_int env x / eval_int env y)
  | <:expr< $x$ mod $y$ >> -> Int(eval_int env x mod eval_int env y)

  (* Boolean operations *)
  | <:expr< not $x$ >> -> Bool(not (eval_bool env x))
  | <:expr< $x$ or $y$ >> -> Bool(eval_bool env x or eval_bool env y)
  | <:expr< $x$ || $y$ >> -> Bool(eval_bool env x || eval_bool env y)
  | <:expr< $x$ && $y$ >> -> Bool(eval_bool env x && eval_bool env y)

  (* String operations *)
  | <:expr< $x$ ^ $y$ >> -> String(eval_string env x ^ eval_string env y)

  (* Pair operations *)
  | <:expr< fst $x$ >> -> fst (eval_pair env x)
  | <:expr< snd $x$ >> -> snd (eval_pair env x)

  (* Let-binding *)
  | <:expr< let $p$ = $x$ in $y$ >> ->
    let vx = eval env x in
    let env =
      try
        bind env p vx
      with
          Exit -> invalid_type (Ast.loc_of_expr x) (type_of_patt p) (type_of_value vx)
    in
    eval env y

  | e -> Loc.raise (Ast.loc_of_expr e) (Stream.Error "expression not supported")

and bind env patt value = match patt with
  | <:patt< $lid:id$ >> ->
    Env.add id value env

  | <:patt< $tup:patts$ >> ->
    let patts = Ast.list_of_patt patts [] in
    begin match value with
      | Tuple values when List.length values = List.length patts ->
          List.fold_left2 bind env patts values
      | _ ->
          raise Exit
    end

  | _ ->
      Loc.raise (Ast.loc_of_patt patt) (Stream.Error "pattern not supported")

and eval_same env ex ey =
  let vx = eval env ex and vy = eval env ey in
  let tx = type_of_value vx and ty = type_of_value vy in
  if tx = ty then
    (vx, vy)
  else
    invalid_type (Ast.loc_of_expr ey) tx ty

and eval_int env e = match eval env e with
  | Int x -> x
  | v -> invalid_type (Ast.loc_of_expr e) Tint (type_of_value v)

and eval_bool env e = match eval env e with
  | Bool x -> x
  | v -> invalid_type (Ast.loc_of_expr e) Tbool (type_of_value v)

and eval_string env e = match eval env e with
  | String x -> x
  | v -> invalid_type (Ast.loc_of_expr e) Tstring (type_of_value v)

and eval_pair env e = match eval env e with
  | Tuple [x; y] -> (x, y)
  | v -> invalid_type (Ast.loc_of_expr e) (Ttuple [Tvar "a"; Tvar "b"]) (type_of_value v)

(* +-----------------------+
   | Parsing of directives |
   +-----------------------+ *)

let rec skip_space stream = match Stream.peek stream with
  | Some((BLANKS _ | COMMENT _), _) ->
      Stream.junk stream;
      skip_space stream
  | _ ->
      ()

let parse_equal stream =
  skip_space stream;
  match Stream.next stream with
    | KEYWORD "=", _ -> ()
    | _, loc -> Loc.raise loc (Stream.Error "'=' expected")

let rec parse_eol stream =
  let tok, loc = Stream.next stream in
  match tok with
    | BLANKS _ | COMMENT _ ->
        parse_eol stream
    | NEWLINE | EOI ->
        ()
    | _ ->
        Loc.raise loc (Stream.Error "end of line expected")

(* Return wether a keyword can be interpreted as an identifier *)
let keyword_is_id str =
  let rec aux i =
    if i = String.length str then
      true
    else
      match str.[i] with
        | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' ->
            aux (i + 1)
        | _ ->
            false
  in
  aux 0

let parse_ident stream =
  skip_space stream;
  let tok, loc = Stream.next stream in
  begin match tok with
    | LIDENT id | UIDENT id ->
        id
    | KEYWORD kwd when keyword_is_id kwd ->
        kwd
    | _ ->
        Loc.raise loc (Stream.Error "identifier expected")
  end

let parse_expr stream =
  (* Lists of opened brackets *)
  let opened_brackets = ref [] in

  (* Return the next token of [stream] until all opened parentheses
     have been closed and a newline is reached *)
  let rec next_token _ =
    Some(match Stream.next stream, !opened_brackets with
           | (NEWLINE, loc), [] ->
               EOI, loc

           | (KEYWORD("(" | "[" | "{" as b), _) as x, l ->
               opened_brackets := b :: l;
               x

           | (KEYWORD ")", loc) as x, "(" :: l ->
               opened_brackets := l;
               x

           | (KEYWORD "]", loc) as x, "[" :: l ->
               opened_brackets := l;
               x

           | (KEYWORD "}", loc) as x, "{" :: l ->
               opened_brackets := l;
               x

           | x, _ ->
               x)
  in

  Gram.parse_tokens_before_filter Syntax.expr_eoi
    (not_filtered (Stream.from next_token))

let parse_directive stream = match Stream.peek stream with
  | Some(KEYWORD "#", loc) ->
      Stream.junk stream;

      (* Move the location to the beginning of the line *)
      let (file_name,
           start_line, start_bol, start_off,
           stop_line,  stop_bol,  stop_off,
           ghost) = Loc.to_tuple loc in
      let loc = Loc.of_tuple (file_name,
                              start_line, start_bol, start_bol,
                              start_line, start_bol, start_bol,
                              ghost) in

      begin match parse_ident stream with

        | "let" ->
            let id = parse_ident stream in
            parse_equal stream;
            let expr = parse_expr stream in
            Some(Dir_let(id, expr), loc)

        | "let_default" ->
            let id = parse_ident stream in
            parse_equal stream;
            let expr = parse_expr stream in
            Some(Dir_default(id, expr), loc)

        (* For compatibility *)
        | "define" ->
            let id = parse_ident stream in
            let expr = parse_expr stream in
            Some(Dir_let(id, expr), loc)

        (* For compatibility *)
        | "default" ->
            let id = parse_ident stream in
            let expr = parse_expr stream in
            Some(Dir_default(id, expr), loc)

        | "if" ->
            Some(Dir_if(parse_expr stream), loc)

        | "else" ->
            parse_eol stream;
            Some(Dir_else, loc)

        | "elif" ->
            Some(Dir_elif(parse_expr stream), loc)

        | "endif" ->
            parse_eol stream;
            Some(Dir_endif, loc)

        | "include" ->
            Some(Dir_include(parse_expr stream), loc)

        | "directory" ->
            Some(Dir_directory(parse_expr stream), loc)

        | "error" ->
            Some(Dir_error(parse_expr stream), loc)

        | "warning" ->
            Some(Dir_warning(parse_expr stream), loc)

        | "default_quotation" ->
            Some(Dir_default_quotation(parse_expr stream), loc)

        | dir ->
            Loc.raise loc (Stream.Error (Printf.sprintf "bad directive ``%s''" dir))
      end

  | _ ->
      None

let parse_command_line_define str =
  match Gram.parse_string Syntax.expr (Loc.mk "<command line>") str with
    | <:expr< $lid:id$ = $e$ >>
    | <:expr< $uid:id$ = $e$ >> -> define id (eval !env e)
    | _ -> invalid_arg str

(* +----------------+
   | BLock skipping |
   +----------------+ *)

let rec skip_line stream =
  match Stream.next stream with
    | NEWLINE, _ -> ()
    | EOI, loc -> Loc.raise loc (Stream.Error "#endif missing")
    | _ -> skip_line stream

let rec next_directive stream = match parse_directive stream with
  | Some dir -> dir
  | None -> skip_line stream; next_directive stream

let rec next_endif stream =
  let dir, loc = next_directive stream in
  match dir with
    | Dir_if _ -> skip_if stream; next_endif stream
    | Dir_else
    | Dir_elif _
    | Dir_endif -> dir
    | _ -> next_endif stream

and skip_if stream =
  let dir, loc = next_directive stream in
  match dir with
    | Dir_if _ ->
        skip_if stream;
        skip_if stream

    | Dir_else ->
        skip_else stream

    | Dir_elif _ ->
        skip_if stream

    | Dir_endif ->
        ()

    | _ -> skip_if stream

and skip_else stream =
  let dir, loc = next_directive stream in
  match dir with
    | Dir_if _ ->
        skip_if stream;
        skip_else stream

    | Dir_else ->
        Loc.raise loc (Stream.Error "#else without #if")

    | Dir_elif _ ->
        Loc.raise loc (Stream.Error "#elif without #if")

    | Dir_endif ->
        ()

    | _ ->
        skip_else stream

(* +-----------------+
   | Token filtering |
   +-----------------+ *)

type context = Ctx_if | Ctx_else

(* State of the token filter *)
type state = {
  stream : (Gram.Token.t * Loc.t) Stream.t;
  (* Input stream *)

  mutable bol : bool;
  (* Wether we are at the beginning of a line *)

  mutable stack : context list;
  (* Nested contexts *)

  on_eoi : Gram.Token.t * Loc.t -> Gram.Token.t * Loc.t;
  (* Eoi handler, it is used to restore the previous sate on #include
     directives *)
}

(* Read and return one token *)
let really_read state =
  let tok, loc = Stream.next state.stream in
  state.bol <- tok = NEWLINE;
  match tok with
    | QUOTATION ({ q_name = "optcomp" } as quot) ->
        let id = next_quotation_id () in
        Hashtbl.add quotations id (eval !env (Gram.parse_string
                                                Syntax.expr_eoi
                                                (Loc.move `start quot.q_shift loc)
                                                quot.q_contents));

        (* Replace the quotation by its id *)
        (QUOTATION { quot with q_contents = string_of_int id }, loc)

    | EOI ->
        (* If end of input is reached, we call the eoi handler. It may
           continue if we were parsing an included file *)
        if state.stack <> [] then
          Loc.raise loc (Stream.Error "#endif missing");
        state.on_eoi (tok, loc)

    | _ ->
        (tok, loc)

(* Return the next token from a stream, interpreting directives. *)
let rec next_token state_ref =
  let state = !state_ref in
  if state.bol then
    match parse_directive state.stream, state.stack with
      | Some(Dir_if e, _), _ ->
          let rec aux e =
            if eval_bool !env e then begin
              state.stack <- Ctx_if :: state.stack;
              next_token state_ref
            end else
              match next_endif state.stream with
                | Dir_else ->
                    state.stack <- Ctx_else :: state.stack;
                    next_token state_ref

                | Dir_elif e ->
                    aux e

                | Dir_endif ->
                    next_token state_ref

                | _ ->
                    assert false
          in
          aux e

      | Some(Dir_else, loc), ([] | Ctx_else :: _) ->
          Loc.raise loc (Stream.Error "#else without #if")

      | Some(Dir_elif _, loc), ([] | Ctx_else :: _) ->
          Loc.raise loc (Stream.Error "#elif without #if")

      | Some(Dir_endif, loc), [] ->
          Loc.raise loc (Stream.Error "#endif without #if")

      | Some(Dir_else, loc), Ctx_if :: l ->
          skip_else state.stream;
          state.stack <- l;
          next_token state_ref

      | Some(Dir_elif _, loc), Ctx_if :: l ->
          skip_if state.stream;
          state.stack <- l;
          next_token state_ref

      | Some(Dir_endif, loc), _ :: l ->
          state.stack <- l;
          next_token state_ref

      | Some(Dir_let(id, e), _), _ ->
          define id (eval !env e);
          next_token state_ref

      | Some(Dir_default(id, e), _), _ ->
          if not (Env.mem id !env) then
            define id (eval !env e);
          next_token state_ref

      | Some(Dir_include e, _), _ ->
          let fname = eval_string !env e in
          (* Try to looks up in all include directories *)
          let fname =
            try
              List.find (fun dir -> Sys.file_exists (Filename.concat dir fname)) !dirs
            with
                (* Just try in the current directory *)
                Not_found -> fname
          in
          dependencies := String_set.add fname !dependencies;
          let ic = open_in fname in
          let nested_state = {
            stream = Gram.Token.Filter.filter (Gram.get_filter ()) (filter (Gram.lex (Loc.mk fname) (Stream.of_channel ic)));
            bol = true;
            stack = [];
            on_eoi = (fun _ ->
                        (* Restore previous state and close channel on
                           eoi *)
                        state_ref := state;
                        close_in ic;
                        next_token state_ref)
          } in
          (* Replace current state with the new one *)
          state_ref := nested_state;
          next_token state_ref

      | Some(Dir_directory e, loc), _ ->
          let dir = eval_string !env e in
          add_include_dir dir;
          next_token state_ref

      | Some(Dir_error e, loc), _ ->
          Loc.raise loc (Failure (eval_string !env e))

      | Some(Dir_warning e, loc), _ ->
          Syntax.print_warning loc (eval_string !env e);
          next_token state_ref

      | Some(Dir_default_quotation e, loc), _ ->
          Syntax.Quotation.default := eval_string !env e;
          next_token state_ref

      | None, _ ->
          really_read state

  else
    really_read state

let stream_filter filter stream =
  (* Set the source filename *)
  begin match !source_filename with
    | Some _ ->
        ()
    | None ->
        match Stream.peek stream with
          | None ->
              ()
          | Some(tok, loc) ->
              source_filename := Some(Loc.file_name loc)
  end;
  let state_ref = ref { stream = stream;
                        bol = true;
                        stack = [];
                        on_eoi = (fun x -> x) } in
  filter (Stream.from (fun _ -> Some(next_token state_ref)))

(* +----------------------+
   | Quotations expansion |
   +----------------------+ *)

let expand f loc _ contents =
  try
    f loc (Hashtbl.find quotations (int_of_string contents))
  with
      exn -> Loc.raise loc (Failure "fatal error in optcomp!")

(* +--------------+
   | Registration |
   +--------------+ *)

let _ =
  Camlp4.Options.add "-let" (Arg.String parse_command_line_define)
    "<string> Binding for a #let directive.";
  Camlp4.Options.add "-depend"
    (Arg.String (fun filename -> dependency_filename := Some filename))
    "<file> Write dependencies to <file>.";

  Pervasives.at_exit write_depencies;

  Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.expr_tag (expand expr_of_value);
  Syntax.Quotation.add "optcomp" Syntax.Quotation.DynAst.patt_tag (expand patt_of_value);

  Gram.Token.Filter.define_filter (Gram.get_filter ()) stream_filter