Source file functions.ml

open UtilsLib
open Value
open Environment
open Svg_rendering
module Compl = Completion
module AcgEnv = AcgData.Environment.Environment
module AcgSig = AcgData.Signature.Data_Signature
module AcgLex = AcgData.Acg_lexicon.Data_Lexicon

module ShowI = Show.Make(AcgData.Environment.Environment)
  (Show_text_dejavu)
  (Show_colors_solarized_dark)
  (Show_embellish_examples.Make(Show_text_dejavu))

let rec resume_to_lazy_list lex s ty resume =
  match AcgLex.get_analysis resume lex with
  | Some (t, w), new_resume ->
      LazyList.Cons
        (RealTerm (s, t, ty, Some w),
          fun () -> resume_to_lazy_list lex s ty new_resume)
  | None, _ -> LazyList.Nil

let fun_last _ env =
  match env.last_value with
  | Some v -> v
  | None -> Errors.(ScriptErrors.emit Script_l.NoLastValue)

let last = {
  name = "last";
  help_text = "This function returns the result of the last successful command. If there was no successful command in the current session, this function will throw an error.";
  args = [];
  f = Environment.Generation_f fun_last
}

let fun_limit args _ vl =
  let n = match args with [ Environment.Int (n, _) ] -> n | _ -> assert false in
  let rec limit tl i =
    if i = 0 then LazyList.Nil
    else
      match tl with
      | LazyList.Cons (v, tail) ->
          LazyList.Cons (v, fun () -> limit (tail ()) (i - 1))
      | _ -> LazyList.Nil
  in
  limit vl n

let limit = {
  name = "limit";
  help_text = "This function truncate its input list to size [n], and outputs it with no other changes. If [n] is greater or equal to the size of its input list, it does nothing.";
  args =
    [ ("n", Environment.Int_s (Some 1)) ];
  f = Environment.Computation_f fun_limit
}

let fun_load args env =
  let paths, loc =
    match args with
    | [ Environment.StringList (paths, loc) ] -> paths, loc
    | _ -> assert false
  in 
    List.fold_left (fun env path ->
      let (_, new_env) = Dump.load_env ~with_magic:env.config.Config.with_magic path env.config.Config.dirs env.acg_env loc in
        { env with acg_env = new_env }) env paths

let load = {
  name = "load";
  help_text = "This function loads all files of the list [paths] in the environment. They can either be ACG data (usually [.acg] file) or compiled ACG data (usually [.acgo] file).";
  args =
    [ ("paths", Environment.StringList_s (None, Ci_Path)) ];
  f = Environment.Special_f fun_load
}

let fun_parse args env vl =
  let lex, ty, local_magic, alt_max =
    match args with
    | [ Environment.Lex (lex, _);
        Environment.Type (ty, _);
        Environment.Bool (b, _);
        Environment.Int (alt_max, _)] -> (lex, ty, b, alt_max)
    | _ -> assert false in
  let magic =
    match AcgLex.has_magic lex, local_magic, env.config.Config.with_magic with
    | AcgLex.Available_wo_magic, true, false  ->
      let () =
        Logs.warn (fun m ->
            m
              "The@ lexicon@ %a@ was@ compiled@ by@ %a@ with@ Magic@ \
               Set@ Rewriting@ disabled.@ Using@ Magic@ Set@ \
               Rewritten@ program@ for@ parsing@ is@ therefore@ not@ \
               available.@ Using@ standard@ parsing@ instead."
              Utils.lex_pp
              (fst (AcgLex.name lex))
              Utils.binary_pp
              "acgc") in
      false
    | AcgLex.Available_wo_magic, true, true  ->
      let () =
        Logs.warn (fun m ->
            m
              "The@ lexicon@ %a@ was@ compiled@ by@ %a@ with@ Magic@ \
               Set@ Rewriting@ disabled.@ Using@ Magic@ Set@ \
               Rewritten@ program@ for@ parsing@ (default@ when@ \
               running@ %a@ with@ the \"-m|--magic\"@ option) is@ \
               therefore@ not@ available.@ Using@ standard@ parsing@ \
               instead."
              Utils.lex_pp
              (fst (AcgLex.name lex))
              Utils.binary_pp
              "acgc"
              Utils.binary_pp
              "acg") in
      false
    | AcgLex.Available_with_magic, false, true ->
      let () =
        Logs.warn (fun m ->
            m
              "Using@ Magic@ Set@ Rewritten@ program@ for@ parsing@ \
               is@ available@ for@ the@ lexicon@ %a@ but@ was@ disabled@ when@ \
               calling@ the@ %a@ command.@ Using@ standard@ parsing@ \
               instead."
              Utils.lex_pp
              (fst (AcgLex.name lex))
              Utils.fun_pp
              "parse"
          ) in
      local_magic
    | AcgLex.Available_with_magic, true, false ->
      let () =
        Logs.warn (fun m ->
            m
              "Using@ Magic@ Set@ Rewritten@ program@ for@ parsing@ \
               was@ not@ set@ by@ default@ on@ the@ %a@ command@ but@ \
               is@ enabled@ for@ this@ %a@ command@ and@ available@ \
               for@ the@ lexicon@ %a.@ Using@ magic@ set@ rewritten@ \
               programs@ for@ parsing."
              Utils.binary_pp
              "acg"
              Utils.fun_pp
              "parse"
              Utils.lex_pp
              (fst (AcgLex.name lex))) in
      local_magic
    | _ -> local_magic in
  let fun_parse_aux vt =
    let abs, obj = AcgLex.get_sig lex in
    let t, t_type = get_term_value_in_sig obj vt in
    let resume = AcgLex.parse ~alt_max ~magic (t,t_type) ty lex in
    resume_to_lazy_list lex abs ty resume in
  match vl with
  | LazyList.Cons (v, tl) -> let res = fun_parse_aux v in
    LazyList.append res (fun () -> match tl () with
        | LazyList.Cons _ -> (* Print warning *) LazyList.Nil
        | LazyList.Nil -> LazyList.Nil)
  | LazyList.Nil -> LazyList.Nil
                      
let parse magic_def_val = {
  name = "parse";
  help_text = "This function parses the first λ-term of its input list in the lexicon [lexicon], using type [type], and output the list of resulting λ-terms. The output list may be infinite or empty. Resulting λ-terms are presented according to increasing (depth, size) values (where depth represent the tree depth and size the overall number of nodes). In case of very ambiguous grammars, this can result in slow output. The optional [stack_limit] value sets the limit (10^stack_limit) beyond which sorting is not ensured, allowing for faster output.";
  args = [ ("lexicon", Environment.Lex_s None) ;
           ("type", Environment.Type_s (Arg_sig 0, None));
           ("magic", Environment.Bool_s (Some magic_def_val));
           ("stack_limit", Environment.Int_s (Some 5)) ];
  f = Environment.Computation_f fun_parse
}

let fun_realize args env vl =
  let lexlist, graph_file =
    match args with [ Environment.LexList (lexlist, _) ; Environment.String (graph, _) ] -> lexlist, graph | _ -> assert false
  in
  let fun_realize_aux vt i =
    let abs =
      match lexlist with
      | lex :: _ -> fst (AcgLex.get_sig lex)
      | _ -> assert false in
    let t, ty = get_term_value_in_sig abs vt in
    let fun_realize_aux2 lex =
      let obj = snd (AcgLex.get_sig lex) in
      let ret_t, ret_ty = AcgLex.interpret t ty lex in
      RealTerm (obj, ret_t, ret_ty, None) in
    let () =
      if graph_file <> "" then
        let d = ShowI.realize_diagram t lexlist env.config.Config.rendering_config in
        let file_name =
          match i with
          | -1 -> graph_file
          | i -> Printf.sprintf "%s%i%s" (Filename.remove_extension graph_file) (i + 1) (Filename.extension graph_file) in
        Diagram.to_svg file_name d in
    LazyList.from_list (List.map fun_realize_aux2 lexlist)
  in
  match vl with
  | LazyList.Cons (t, ll) ->
    let res =
      match (ll ()) with
      | LazyList.Cons _ ->
        LazyList.join (LazyList.mapi fun_realize_aux vl)
      | _ -> fun_realize_aux t (-1) in
    res
  | nil -> nil

let realize = {
  name = "realize";
  help_text = "This function realizes all the λ-terms of its input list all lexicons in the list [lexicons], and output the list of resulting λ-terms. If [svg] is not the empty string, it also saves a graph of the realizations in the file [svg].";
  args =
    [ ("lexicons", Environment.LexList_s None)
    ; ("svg", Environment.String_s (Some "", Ci_Path)) ];
  f = Environment.Computation_f fun_realize
}

let fun_check args _ vl =
  let sigg =
    match args with [ Environment.Sig (sigg, _) ] -> sigg | _ -> assert false
  in
  let fun_check_aux vt =
    let t, ty = get_term_value_in_sig sigg vt in
    RealTerm (sigg, t, ty, None)
  in
  LazyList.map fun_check_aux vl

let check = {
  name = "check";
  help_text = "This function typechecks all the λ-terms of its input list in the signature [signature], and outputs them unchanged. So this function will do nothing if all the terms are correct, but will throw an error otherwise. Only terms typed by hand (using the term literal syntax) may be incorrect.";
  args =
    [ ("signature", Environment.Sig_s None) ];
  f = Environment.Computation_f fun_check
}

let fun_list_terms args _ =
  let sigg, ty, min_depth, max_depth, random =
    match args with [ Environment.Sig (sigg, _) ; Environment.Type (ty, _) ; Environment.Int (min_depth, _) ; Environment.Int (max_depth, _) ; Environment.Bool (random, _) ] -> sigg, ty, min_depth, max_depth, random | _ -> assert false
  in
  let result_list = AcgSig.gen_term_list sigg ty min_depth max_depth random in
  (LazyList.map (fun t -> RealTerm (sigg, t, ty, None)) result_list)

let list_terms = {
  name = "list-terms";
  help_text = "This function computes all possible λ-terms of type [type] in the signature [signature], with a depth between [min_depth] and [max_depth], and outputs a list with all of these terms. This function is deterministic when [random] is false, otherwise the order of the generated terms will be random.";
  args =
    [ ("signature", Environment.Sig_s None)
    ; ("type", Environment.Type_s (Arg_sig 0, None))
    ; ("min_depth", Environment.Int_s (Some 0))
    ; ("max_depth", Environment.Int_s (Some 10))
    ; ("random", Environment.Bool_s (Some false)) ];
  f = Environment.Generation_f fun_list_terms
}

let fun_compose args env =
  let lex1, lex2, name =
    match args with [ Environment.Lex (lex1, _) ; Environment.Lex (lex2, _) ; Environment.String (name, _) ] -> lex1, lex2, name | _ -> assert false
  in
  let new_env = { env with acg_env = AcgEnv.insert ~overwrite:true
    (AcgEnv.Lexicon (AcgLex.compose lex1 lex2 (name, (Lexing.dummy_pos, Lexing.dummy_pos))))
    ~to_be_dumped:true env.acg_env } in
  new_env

let compose = {
  name = "compose";
  help_text = "This function creates a new lexicon named [name] by composing [lexicon1] with [lexicon2] and adds it to the current environment.";
  args =
    [ ("lexicon1", Environment.Lex_s None)
    ; ("lexicon2", Environment.Lex_s None)
    ; ("name", Environment.String_s (None, Ci_None)) ];
  f = Environment.Special_f fun_compose
}

let fun_idb args env =
  let lex = match args with [ Environment.Lex (lex, _) ] -> lex | _ -> assert false in
  let () = match AcgLex.get_program lex with
  | Some prog ->
    Logs.app (fun m ->
        m
          "The datalog program (intensional database) corresponding to the \
           lexicon \"%s\" is:@,\
           @[<v>  %a@]"
          (fst (AcgLex.name lex))
          (DatalogLib.Datalog_AbstractSyntax.AbstractSyntax.Program.pp ~with_position:false ~with_id:false)
          (DatalogLib__Datalog.Datalog.Program.to_abstract prog))
  | None ->
    Logs.app (fun m ->
        m
          "Lexicon \"%s\" is not 2nd-order, hence it is not associated \
           with an intensional database."
          (fst (AcgLex.name lex))) in
  env

let idb = {
  name = "idb";
  help_text = "This function prints the datalog program correspoding to the lexicon [lexicon].";
  args =
    [ ("lexicon", Environment.Lex_s None) ];
  f = Environment.Special_f fun_idb
}

let fun_query args _ vl =
  let lex, ty = match args with [ Environment.Lex (lex, _) ; Environment.Type (ty, _) ] -> lex, ty | _ -> assert false in
  let fun_query_aux v =
    let _, obj = AcgLex.get_sig lex in
    let t, _ = get_term_value_in_sig obj v in
    Logs.app (fun m -> m "%a"
      (AcgLex.pp_query lex) (t, ty)) in
  LazyList.iter fun_query_aux vl

let query = {
  name = "query";
  help_text = "This function outputs the facts (extensional database) and the query associated to its input term list of distinguished type [type] with respect to the lexicon [lexicon].";
  args =
    [ ("lexicon", Environment.Lex_s None) ; ("type", Environment.Type_s (Environment.Arg_sig 0, None)) ];
  f = Environment.Consumption_f fun_query
}

let fun_list _args env =
  let () = Environment.short_print env in
    env

let list_ = {
  name = "list";
  help_text = "This function lists the signatures and lexicons in the current environment. This function can only be used alone in a command.";
  args =
    [ ];
  f = Environment.Special_f fun_list
}

let fun_print args env =
  let e =
    match args with [ Environment.Entry (e, _) ] -> e | _ -> assert false
  in
  let () = match e with
    | AcgEnv.Lexicon l ->
      Logs.app (fun m -> m "%a" AcgLex.pp l)
    | AcgEnv.Signature s ->
      Logs.app (fun m -> m "%a" AcgSig.pp s) in
  env

let print = {
  name = "print";
  help_text = "This function prints the entry [entry].";
  args =
    [ ("entry", Environment.Entry_s None) ];
  f = Environment.Special_f fun_print
}

let fun_help args env =
  let f =
    match args with [ Environment.String (f, _) ] -> f | _ -> assert false
  in
  let () = Environment.print_help env f in env

let help = {
  name = "help";
  help_text = "Prints this help message: lists the functions in the current environment and their description. If parameter [fun] is not empty, lists all functions which name starts with its value.";
  args =
    [ ("fun", Environment.String_s (Some "", Ci_Fun)) ];
  f = Environment.Special_f fun_help
}

let def_fun_list config_o =
  let parse_magic_def_val =
    match config_o with
    | Some config -> config.Config.with_magic
    | None -> false in
  [ last; limit; load; parse parse_magic_def_val; realize; check; list_terms; compose; idb; query; list_; print; help ]