Source file environment.ml

open Logic.Lambda
open UtilsLib
module AcgEnv = AcgData.Environment.Environment
module AcgSig = AcgData.Signature.Data_Signature
module AcgLex = AcgData.Acg_lexicon.Data_Lexicon

type sig_ref =
  | Real_sig of AcgSig.t
  | Arg_sig of int

type var =
  | Bool of bool * Error.pos
  | Int of int * Error.pos
  | Sig of AcgSig.t * Error.pos
  | Lex of AcgLex.t * Error.pos
  | Entry of AcgEnv.entry * Error.pos
  | LexList of AcgLex.t list * Error.pos
  | String of string * Error.pos
  | StringList of string list * Error.pos
  | Type of Lambda.stype * Error.pos

type completion_info =
  | Ci_Path
  | Ci_Fun
  | Ci_List of string list
  | Ci_None

type var_type =
  | T_Bool
  | T_Int
  | T_Sig
  | T_Lex
  | T_Entry
  | T_LexList
  | T_String of completion_info
  | T_StringList of completion_info
  | T_Type of sig_ref

type var_arg =
  | Bool_a of bool * Error.pos
  | Int_a of int * Error.pos
  | Sig_a of AcgSig.t * Error.pos
  | Lex_a of AcgLex.t * Error.pos
  | Entry_a of AcgEnv.entry * Error.pos
  | LexList_a of AcgLex.t list * Error.pos
  | String_a of string * Error.pos
  | StringList_a of string list * Error.pos
  | Type_a of Lambda.stype * Error.pos
  | Argument_a of int * var_type * Error.pos

type var_temp =
  | Bool_t of bool * Error.pos
  | Int_t of int * Error.pos
  | Sig_t of AcgSig.t * Error.pos
  | Lex_t of AcgLex.t * Error.pos
  | Entry_t of AcgEnv.entry * Error.pos
  | LexList_t of AcgLex.t list * Error.pos
  | String_t of string * Error.pos
  | StringList_t of string list * Error.pos
  | Type_t_s of (sig_ref * string) * Error.pos
  | Type_t_r of Lambda.stype * Error.pos
  | Argument_t of int * var_type * Error.pos

type var_spec =
  | Bool_s of bool option
  | Int_s of int option
  | Sig_s of AcgSig.t option
  | Lex_s of AcgLex.t option
  | Entry_s of AcgEnv.entry option
  | LexList_s of (AcgLex.t list) option
  | String_s of string option * completion_info
  | StringList_s of (string list) option * completion_info
  | Type_s of sig_ref * Lambda.stype option

type vlist_type =
  | StringList_lt
  | IdList_lt

type vlist_elem =
  | Vl_elem of string * Error.pos
  | Completion_list_val

type arg_parse =
  | Int_p of int * Error.pos
  | Id_p of string * Error.pos
  | Data_p of string * Error.pos
  | Bool_p of bool * Error.pos
  | VList_p of vlist_elem list * Error.pos
  | StringList_p of vlist_elem list * Error.pos
  | Completion_val

type var_type_parse =
  | T_Bool_p of Error.pos
  | T_Int_p of Error.pos
  | T_Sig_p of Error.pos
  | T_Lex_p of Error.pos
  | T_Entry_p of Error.pos
  | T_VListF_p of Error.pos
  | T_LexList_p of Error.pos
  | T_LexListF_p of Error.pos
  | T_StringList_p of Error.pos * completion_info
  | T_StringListF_p of Error.pos * completion_info option
  | T_String_p of Error.pos * completion_info
  | T_Type_p of sig_ref option * Error.pos
  | T_Id_p of Error.pos
  | T_Data_p of Error.pos

type arg_full =
  | Arg of (string * Error.pos) option * arg_parse
  | Completion_name of var_type option * (string * char)

type binding_list = ((string * Error.pos) * var_type_parse option * bool) list
type param = (string * Error.pos) * arg_parse option
type param_list = param list

type func_type =
  | All
  | AtStart
  | Generation
  | Computation
  | Consumption
  | Special
  | End

type func =
  | Generation_f of (var list -> env -> Value.value)
  | Computation_f of (var list -> env -> Value.value -> Value.value)
  | Consumption_f of (var list -> env -> Value.value -> unit)
  | Special_f of (var list -> env -> env)

and func_spec = {
  name : string;
  help_text : string;
  args : (string * var_spec) list;
  f : func
}

and env = {
  config : Config.config;
  acg_env : AcgEnv.t;
  functions : func_spec list;
  last_value : Value.value option
}

type completion =
  | Compl_Fun_name of func_type
  | Compl_Arg_name of string * (string * char) * var_type option * string list
  | Compl_Arg_val of var_spec * string list
  | Compl_None
  | Compl_Custom of string list

exception Completion of completion

let get_fun env fname =
  List.find_opt (fun f -> f.name = fname) env.functions

let get_lex env name loc =
  match AcgEnv.get name env.acg_env loc with
  (* FIXME use Environment.focus *)
  | AcgEnv.Signature _ -> Errors.(ScriptErrors.emit (Script_l.OnlyLexicon name) ~loc)
  | AcgEnv.Lexicon lex -> lex

let get_sig env name loc =
  match AcgEnv.get name env.acg_env loc with
  (* FIXME use Environment.focus *)
  | AcgEnv.Signature s -> s
  | AcgEnv.Lexicon lex ->
      let abs, _ = AcgLex.get_sig lex in
      abs

let string_of_var_spec vs =
  match vs with
  | Bool_s _ -> "a boolean"
  | Int_s _ -> "an integer"
  | Sig_s _ -> "a signature"
  | Lex_s _ -> "a lexicon"
  | Entry_s _ -> "a signature or a lexicon"
  | LexList_s _ -> "a lexicon list"
  | String_s _ -> "a string"
  | StringList_s _ -> "a string list"
  | Type_s _ -> "a type"

let string_of_arg_parse ap =
  match ap with
  | Int_p _ -> "an integer"
  | Id_p _ -> "an identifier"
  | Data_p _ -> "a string or a type"
  | Bool_p _ -> "a boolean"
  | VList_p _ -> "a list"
  | StringList_p _ -> "a string list"
  | Completion_val -> ""

let pos_of_arg_parse ap =
  match ap with
  | Int_p (_, pos)
  | Id_p (_, pos)
  | Data_p (_, pos)
  | Bool_p (_, pos)
  | VList_p (_, pos)
  | StringList_p (_, pos) -> Some pos
  | Completion_val -> None

let _string_of_var_temp vt =
  match vt with
  | Bool_t _ -> "a boolean"
  | Int_t _ -> "an integer"
  | Sig_t _ -> "a signature"
  | Lex_t _ -> "a lexicon"
  | Entry_t _ -> "a signature or a lexicon"
  | LexList_t _ -> "a lexicon list"
  | StringList_t _ -> "a string list"
  | String_t _ -> "a string"
  | Type_t_r _ | Type_t_s _ -> "a type"
  | Argument_t _ -> "unknown"

let string_of_var_type vt =
  match vt with
  | T_Bool -> "a boolean"
  | T_Int -> "an integer"
  | T_Sig -> "a signature"
  | T_Lex -> "a lexicon"
  | T_Entry -> "a signature or a lexicon"
  | T_LexList -> "a lexicon list"
  | T_String _ -> "a string" (* TODO *)
  | T_StringList _-> "a string list"
  | T_Type _ -> "a type"

let string_of_var_type_parse vtp =
  match vtp with
  | T_Bool_p _ -> "a boolean"
  | T_Int_p _ -> "an integer"
  | T_Sig_p _ -> "a signature"
  | T_Lex_p _ -> "a lexicon"
  | T_Entry_p _ -> "a signature or a lexicon"
  | T_VListF_p _ -> "a list"
  | T_LexList_p _
  | T_LexListF_p _ -> "a lexicon list"
  | T_StringList_p _ -> "a string list"
  | T_StringListF_p _ -> "a string list"
  | T_String_p _ -> "a string"
  | T_Type_p _ -> "a type"
  | T_Data_p _ -> "a type or a string"
  | T_Id_p _ -> "an identifier"

let var_spec_to_var_type_parse vs prev_vt_o name loc fname varname =
  match vs, prev_vt_o with
  | Bool_s _, None -> T_Bool_p loc
  | Bool_s _, (Some (T_Bool_p loc))
  | Bool_s _, (Some (T_Id_p loc)) -> T_Bool_p loc
  | Int_s _, None -> T_Int_p loc
  | Int_s _, (Some (T_Int_p loc)) -> T_Int_p loc
  | Sig_s _, None -> T_Sig_p loc
  | Sig_s _, (Some (T_Sig_p loc))
  | Sig_s _, (Some (T_Id_p loc)) -> T_Sig_p loc
  | Lex_s _, None -> T_Lex_p loc
  | Lex_s _, (Some (T_Lex_p loc))
  | Lex_s _, (Some (T_LexList_p loc))
  | Lex_s _, (Some (T_Id_p loc)) -> T_Lex_p loc
  | Entry_s _, None -> T_Entry_p loc
  | Entry_s _, (Some (T_Lex_p loc)) -> T_Lex_p loc
  | Entry_s _, (Some (T_LexList_p loc)) -> T_Lex_p loc
  | Entry_s _, (Some (T_Sig_p loc)) -> T_Sig_p loc
  | Entry_s _, (Some (T_Id_p loc)) -> T_Entry_p loc
  | LexList_s _, None -> T_LexList_p loc
  | LexList_s _, (Some (T_LexList_p loc)) -> T_LexList_p loc
  | LexList_s _, (Some (T_LexListF_p loc)) -> T_LexListF_p loc
  | LexList_s _, (Some (T_VListF_p loc)) -> T_LexListF_p loc
  | LexList_s _, (Some (T_Lex_p loc)) -> T_Lex_p loc
  | LexList_s _, (Some (T_Entry_p loc)) -> T_Lex_p loc
  | LexList_s _, (Some (T_Id_p loc)) -> T_LexList_p loc
  | String_s (_, ci), None -> T_String_p (loc, ci)
  | String_s (_, ci1), (Some (T_String_p (loc, ci2)))
  | String_s (_, ci1), (Some (T_StringList_p (loc, ci2))) ->
    if ci1 = ci2 then T_String_p (loc, ci1) else T_String_p (loc, Ci_None)
  | String_s (_, ci), (Some (T_Data_p loc))
  | String_s (_, ci), (Some (T_Id_p loc)) -> T_String_p (loc, ci)
  | StringList_s (_, ci), None -> T_StringList_p (loc, ci)
  | StringList_s (_, ci1), (Some (T_StringList_p (loc, ci2))) ->
    if ci1 = ci2 then T_StringList_p (loc, ci1) else T_StringList_p (loc, Ci_None)
  | StringList_s (_, ci1), (Some (T_StringListF_p (loc, Some ci2))) ->
    if ci1 = ci2 then T_StringListF_p (loc, Some ci1) else T_StringListF_p (loc, Some Ci_None)
  | StringList_s (_, ci), (Some (T_StringListF_p (loc, None))) -> T_StringListF_p (loc, Some ci)
  | StringList_s (_, ci), (Some (T_VListF_p loc)) -> T_StringListF_p (loc, Some ci)
  | StringList_s (_, ci), (Some (T_Data_p loc)) 
  | StringList_s (_, ci), (Some (T_Id_p loc)) -> T_StringList_p (loc, ci) 
  | StringList_s (_, ci1), (Some (T_String_p (loc, ci2))) ->
    if ci1 = ci2 then T_String_p (loc, ci1) else T_String_p (loc, Ci_None)
  | Type_s (sr, _), None -> T_Type_p (Some sr, loc)
  | Type_s (sr, _), (Some (T_Id_p loc))
  | Type_s (sr, _), (Some (T_Data_p loc))
  | Type_s (sr, _), (Some (T_Type_p (None, loc))) -> T_Type_p (Some sr, loc)
  | Type_s (sr, _), (Some (T_Type_p (Some prev_sr, loc))) ->
      if sr = prev_sr then
        T_Type_p (Some sr, loc)
      else
        (match sr, prev_sr with
        | Real_sig sig1, Real_sig sig2 ->
          Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, Some (sig1, sig2))) ~loc)
        | _ -> Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, None)) ~loc))
  | (vs, Some vt) -> Errors.(TypeErrors.emit (Type_l.Variable (fname, name, varname, (string_of_var_spec vs), (string_of_var_type_parse vt))) ~loc)

let var_spec_to_var_type vs =
  match vs with
  | Bool_s _ -> T_Bool
  | Int_s _ -> T_Int
  | Sig_s _ -> T_Sig
  | Lex_s _ -> T_Lex
  | Entry_s _ -> T_Entry
  | LexList_s _ -> T_LexList
  | StringList_s (_, ci) -> T_StringList ci
  | String_s (_, ci) -> T_String ci
  | Type_s (sr, _) -> T_Type sr

let match_variable env name var vspec barr fname =
  let get_index f a = Array.fold_right (fun e res ->
    match res with
    | Some i -> Some (i + 1)
    | None -> if f e then Some 0 else None) a None in
  match var, vspec with
  | Id_p (id, loc), _ ->
    (match get_index (fun ((n, _), _, _) -> n = id) barr with
    | Some i -> let ((_, loc_o), prev_vt_o, _) = barr.(i) in
      let () = barr.(i) <- ((id, loc_o), Some (var_spec_to_var_type_parse vspec prev_vt_o name loc fname id), true) in
      Argument_t (i, (var_spec_to_var_type vspec), loc)
    | None -> (match vspec with
        | Sig_s _ -> Sig_t ((get_sig env id loc), loc)
        | Lex_s _ -> Lex_t ((get_lex env id loc), loc)
        | Entry_s _ -> Entry_t ((AcgEnv.get id env.acg_env loc), loc)
        | LexList_s _ -> LexList_t ([ (get_lex env id loc) ], loc)
        | Type_s (sr, _) -> Type_t_s ((sr, id), loc)
        | String_s _ -> String_t (id, loc)
        | StringList_s _ -> StringList_t ([ id ], loc)
        | Bool_s _ -> (match id with
          | "true" -> Bool_t (true, loc)
          | "false" -> Bool_t (false, loc)
          | _ -> Errors.(TypeErrors.emit (Type_l.Literal (fname, name, (string_of_var_spec vspec), (string_of_arg_parse var))) ~loc))
        | _ -> Errors.(TypeErrors.emit (Type_l.Literal (fname, name, (string_of_var_spec vspec), (string_of_arg_parse var))) ~loc)))
  | Int_p (i, loc), Int_s _ -> Int_t (i, loc)
  | Data_p (d, loc), String_s _ -> String_t (d, (Error.quote_position loc))
  | Data_p (d, loc), StringList_s _ -> StringList_t ([ d ], (Error.quote_position loc))
  | Data_p (d, loc), Type_s (sr, _) -> Type_t_s ((sr, d), (Error.quote_position loc))
  | Bool_p (b, loc), Bool_s _ -> Bool_t (b, loc)
  | VList_p (l, loc), LexList_s _ -> LexList_t ((List.map
    (fun e ->
      match e with
      | Vl_elem (id, loc) -> get_lex env id loc
      | Completion_list_val ->
        let used_names = List.filter_map
          (fun e ->
            match e with
            | Vl_elem (id, _) -> Some id
            | Completion_list_val -> None) l in
      raise (Completion (Compl_Arg_val (LexList_s None, used_names))))
     l), loc)
  | VList_p (l, loc), StringList_s _
  | StringList_p (l, loc), StringList_s _ -> StringList_t ((List.map
  (fun e ->
    match e with
    | Vl_elem (id, _) -> id
    | Completion_list_val -> raise (Completion (Compl_Arg_val (vspec, []))))
    l), loc)
  | Completion_val, _ -> raise (Completion (Compl_Arg_val (vspec, [])))
  | Int_p (_, loc), _
  | Bool_p (_, loc), _
  | VList_p (_, loc), _
  | StringList_p (_, loc), _
  | Data_p (_, loc), _ -> Errors.(TypeErrors.emit (Type_l.Literal (fname, name, (string_of_var_spec vspec), (string_of_arg_parse var))) ~loc)

let arg_parse_to_var_type_parse argp =
  match argp with
  | Int_p (_, loc) -> T_Int_p loc
  | Id_p (_, loc) -> T_Id_p loc
  | Data_p (_, loc) -> T_Data_p loc
  | Bool_p (_, loc) -> T_Bool_p loc
  | VList_p (_, loc) -> T_VListF_p loc
  | StringList_p (_, loc) -> T_StringListF_p (loc, None)
  | Completion_val -> raise (Completion Compl_None)

let var_type_parse_to_var_type vtp =
  match vtp with
  | T_Bool_p _ -> T_Bool
  | T_Int_p _ -> T_Int
  | T_Sig_p _ -> T_Sig
  | T_Lex_p _ -> T_Lex
  | T_Entry_p _ -> T_Entry
  | T_LexList_p _ -> T_LexList
  | T_LexListF_p _ -> T_LexList
  | T_String_p (_, ci)  -> T_String ci
  | T_StringList_p (_, ci) -> T_StringList ci
  | T_StringListF_p (_, Some ci) -> T_StringList ci
  | T_StringListF_p (_, None) -> T_StringList Ci_None
  | T_Type_p (Some sr, _) -> T_Type sr
  | T_Type_p (None, _) -> assert false
  | T_Id_p _
  | T_Data_p _
  | T_VListF_p _ -> assert false

let rec check_binding_list blist =
  match blist with
  | [] -> []
  | ((s, loc), Some vt, true) :: blist -> ((s, loc), var_type_parse_to_var_type vt) :: (check_binding_list blist)
  | ((s, loc), _, _) :: _ -> Errors.(ScriptErrors.emit (Script_l.UnusedVariable s) ~loc)

(* TODO compute default values automatically with other functions *)
let var_type_to_var_spec fname name vt ap env =
  match vt, ap with
  | T_Bool, None -> Bool_s None
  | T_Bool, Some (Id_p ("true", _)) -> Bool_s (Some true)
  | T_Bool, Some (Id_p ("false", _)) -> Bool_s (Some false)
  | T_Bool, Some (Id_p (_, loc)) -> Errors.(TypeErrors.emit (Type_l.DefaultValue (fname, name, (string_of_var_type vt), "an identifier")) ~loc)
  | T_Int, None -> Int_s None
  | T_Int, Some (Int_p (i, _)) -> Int_s (Some i)
  | T_String ci, None -> String_s (None, ci)
  | T_String ci, Some (Data_p (s, _)) -> String_s (Some s, ci)
  | T_String ci, Some (Id_p (id, _)) -> String_s (Some id, ci)
  | T_Sig, None -> Sig_s None
  | T_Sig, Some (Id_p (id, loc)) -> Sig_s (Some (get_sig env id loc))
  | T_Lex, None -> Lex_s None
  | T_Lex, Some (Id_p (id, loc)) -> Lex_s (Some (get_lex env id loc))
  | T_LexList, None -> LexList_s None
  | T_LexList, Some (VList_p (l, _)) ->
    LexList_s (Some (List.map (fun e ->
      match e with
      | Vl_elem (id, loc) -> get_lex env id loc
      | Completion_list_val -> assert false)
     l))
  | T_LexList, Some (Id_p (id, loc)) -> LexList_s (Some [ (get_lex env id loc) ])
  | T_StringList ci, None -> StringList_s (None, ci)
  | T_StringList ci, Some (VList_p (l, _))
  | T_StringList ci, Some (StringList_p (l, _)) ->
    StringList_s (Some (List.map (fun e ->
      match e with
      | Vl_elem (id, _loc) -> id
      | Completion_list_val -> assert false)
     l), ci)
  | T_StringList ci, Some (Id_p (id, _loc))
  | T_StringList ci, Some (Data_p (id, _loc)) -> StringList_s (Some [ id ], ci)
  | T_Type sr, None -> Type_s (sr, None)
  | T_Type (Real_sig sigg), Some (Data_p (ty_s, loc))
  | T_Type (Real_sig sigg), Some (Id_p (ty_s, loc)) ->
    let lexbuf = Sedlexing.Utf8.from_string ty_s in
    let () = Error.set_position lexbuf (fst loc) in
    let ty = (match Grammars.Parsers.parse_type lexbuf sigg with
      | None -> failwith "Type parsing error."
      | Some ty -> ty) in
    Type_s (Real_sig sigg, Some ty)
  | T_Type _, Some (Id_p (ty_s, loc))
  | T_Type _, Some (Data_p (ty_s, loc)) -> Errors.(ScriptErrors.emit (Script_l.NoSignatureType ty_s) ~loc)
  | _ -> assert false

let binding_list_to_binding_array blist =
  Array.of_list (List.map (fun e -> match e with
    | (s, Some (T_Type_p (_, loc)), b) -> (s, Some (T_Type_p (None, loc)), b)
    | e -> e) blist)

let typed_binding_list_to_arg_spec fname tblist args acg_env =
  let rec typed_binding_list_to_arg_spec_rec cl =
    match cl with
    | [] -> []
    | (((s, _), vt), (_, ap)) :: cl ->
      (s, var_type_to_var_spec fname s vt ap acg_env) :: (typed_binding_list_to_arg_spec_rec cl) in
  typed_binding_list_to_arg_spec_rec (List.combine tblist args)

let get_def_value vspec =
  match vspec with
  | Bool_s (Some b) -> Some (Bool_t (b, Error.dummy_pos))
  | Int_s (Some i) -> Some (Int_t (i, Error.dummy_pos))
  | Sig_s (Some sigg) -> Some (Sig_t (sigg, Error.dummy_pos))
  | Lex_s (Some lex) -> Some (Lex_t (lex, Error.dummy_pos))
  | Entry_s (Some e) -> Some (Entry_t (e, Error.dummy_pos))
  | LexList_s (Some l) -> Some (LexList_t (l, Error.dummy_pos))
  | StringList_s (Some l, _) -> Some (StringList_t (l, Error.dummy_pos))
  | String_s (Some s, _) -> Some (String_t (s, Error.dummy_pos))
  | Type_s (_, Some ty) -> Some (Type_t_r (ty, Error.dummy_pos))
  | _ -> None

let temp_to_arg vars var_t =
  match var_t with
  | Bool_t (b, loc) -> Bool_a (b, loc)
  | Int_t (i, loc) -> Int_a (i, loc)
  | Sig_t (sigg, loc) -> Sig_a (sigg, loc)
  | Lex_t (lex, loc) -> Lex_a (lex, loc)
  | Entry_t (e, loc) -> Entry_a (e, loc)
  | LexList_t (l, loc) -> LexList_a (l, loc)
  | StringList_t (l, loc) -> StringList_a (l, loc)
  | String_t (s, loc) -> String_a (s, loc)
  | Type_t_s ((Arg_sig i, ty_s), loc) ->
    let lexbuf = Sedlexing.Utf8.from_string ty_s in
    let () = Error.set_position lexbuf (fst loc) in
    (match List.nth vars i with
    | Sig_t (sigg, _) ->
      (match Grammars.Parsers.parse_type lexbuf sigg with
      | None -> failwith "Type parsing error"
      | Some ty -> Type_a (ty, loc))
    | Lex_t (lex, loc) ->
      (match Grammars.Parsers.parse_type lexbuf (fst (AcgLex.get_sig lex)) with
      | None -> failwith "Type parsing error"
      | Some ty -> Type_a (ty, loc))
    | Argument_t _ -> Errors.(ScriptErrors.emit (Script_l.NoSignatureType ty_s) ~loc)
    | _ -> assert false)
  | Type_t_s ((Real_sig sigg, ty_s), loc) ->
    let lexbuf = Sedlexing.Utf8.from_string ty_s in
    let () = Error.set_position lexbuf (fst loc) in
    (match Grammars.Parsers.parse_type lexbuf sigg with
    | None -> failwith "Type parsing error"
    | Some ty -> Type_a (ty, loc))
  | Type_t_r (ty, loc) -> Type_a (ty, loc)
  | Argument_t (id, t, loc) -> Argument_a (id, t, loc)

let bind_type_signature sr last_sr_o name loc args =
  match (sr, last_sr_o) with
  | Real_sig sigg, None -> Real_sig sigg
  | Real_sig sigg, Some (Real_sig last_sigg) ->
    if sigg = last_sigg then
      Real_sig sigg
    else
      Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, Some (sigg, last_sigg))) ~loc)
  | Arg_sig i, None ->
    (match List.nth args i with
    | Argument_t (fi, _, _) -> Arg_sig fi
    | Sig_t (sigg, _) -> Real_sig sigg
    | Lex_t (lex, _) -> Real_sig (fst (AcgLex.get_sig lex))
    | _ -> assert false)
  | Arg_sig i, Some (Arg_sig last_i) ->
    (match List.nth args i with
    | Argument_t (fi, _, _) ->
      if fi = last_i then
        Arg_sig fi
      else
        Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, None)) ~loc)
    | Sig_t _
    | Lex_t _ ->
        Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, None)) ~loc)
    | _ -> assert false)
  | _ -> Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, None)) ~loc)

let get_var_type_parse_pos vt =
  match vt with
  | T_Bool_p loc | T_Int_p loc | T_Sig_p loc | T_Lex_p loc | T_Entry_p loc
  | T_VListF_p loc | T_LexList_p loc | T_LexListF_p loc | T_StringList_p (loc, _)
  | T_StringListF_p (loc, _) | T_String_p (loc, _) | T_Type_p (_, loc)
  | T_Id_p loc | T_Data_p loc -> loc

(* We try to store the position of the first occurence of the variable, in order
   to be able to display the position of the first type assignement in errors *)
let binding_array_to_binding_list barr last_blist args =
  List.map2 (fun e le -> match e, le with
    | (sp, Some (T_Type_p (None, _)), b), (_, Some (T_Type_p (sr_o, loc)), _) ->
      (sp, Some (T_Type_p (sr_o, loc)), b)
    | ((s, ps), Some (T_Type_p (Some sr, _)), b), (_, Some (T_Type_p (last_sr_o, loc)), _) ->
      ((s, ps), Some (T_Type_p (Some (bind_type_signature sr last_sr_o s loc args), loc)), b)
    | ((s, ps), Some (T_Type_p (Some sr, _)), b), (_, (Some lvt), _) ->
      let loc = (get_var_type_parse_pos lvt) in
      ((s, ps), Some (T_Type_p (Some (bind_type_signature sr None s loc args), loc)), b)
    | ((s, ps), Some (T_Type_p (Some sr, loc)), b), (_, None, _) ->
      ((s, ps), Some (T_Type_p (Some (bind_type_signature sr None s loc args), loc)), b)
    | e, _ -> e)
  (Array.to_list barr) last_blist

let create_func func_type func =
  let unbox_vl vl_o =
    match vl_o with
    | Some vl -> vl
    | None -> assert false in
  match func_type with
  | Generation -> Generation_f (fun vl env -> let (res, _) = func vl env None in unbox_vl res)
  | Computation -> Computation_f (fun vl env v -> let (res, _) = func vl env (Some v) in unbox_vl res)
  | Consumption -> Consumption_f (fun vl env v -> let _ = func vl env (Some v) in ())
  | Special -> Special_f (fun vl env -> let (_, env) = func vl env None in env)
  | _ -> assert false

let add_fun env fname args _loc nloc f =
  match get_fun env fname with
  | Some _ -> Errors.(ScriptErrors.emit (Script_l.AlreadyExistingFun fname) ~loc:nloc)
  | None ->
    let blist = List.map (fun (aname, defval) -> (aname, Option.map arg_parse_to_var_type_parse defval, false)) args in
    let (func_type, blist2, func) = f All blist env in
    let tblist = check_binding_list blist2 in
    let args2 = typed_binding_list_to_arg_spec fname tblist args env in
    let new_fun_spec = { name = fname; help_text = ""; args =  args2 ; f = create_func func_type func} in
    { env with functions = new_fun_spec :: env.functions }

let list_fun_args env fname vt_o =
  match get_fun env fname with
  | Some f -> Some (List.filter_map (fun (a, vs) ->
      match vs, vt_o with
      | _, None -> Some a
      | Bool_s _, Some T_Bool -> Some a
      | Int_s _, Some T_Int -> Some a
      | Sig_s _, Some T_Sig -> Some a
      | Lex_s _, Some T_Lex -> Some a
      | Entry_s _, Some T_Entry -> Some a
      | LexList_s _, Some T_LexList -> Some a
      | String_s _, Some (T_String _) -> Some a
      | Type_s (sr1, _), Some T_Type sr2 when sr1 = sr2 -> Some a
      | _, _ -> None) f.args)
  | None -> None

let parse_args fname args spec loc blist env =
  let res = Array.make (List.length spec) None in
  let barr = binding_list_to_binding_array blist in

  let get_index f l =
    let rec get_index_rec f l i =
      match l with
      | e :: l -> if f e then Some (i, e) else get_index_rec f l (i + 1)
      | _ -> None
    in
    get_index_rec f l 0
  in

  (* We first set value of parameters whose value is given with its name *)
  let parse_args_named () =
    let place_named_arg name loc value =
      match get_index (fun (n, _) -> n = name) spec with
      | None -> Errors.(ScriptErrors.emit (Script_l.UnknownParameter (fname, name)) ~loc)
      | Some (pos, (_, vspec)) -> (
        match res.(pos) with
        | None -> res.(pos) <- Some (match_variable env name value vspec barr fname)
        | Some _ -> Errors.(ScriptErrors.emit (Script_l.ParameterRepeated (fname, name)) ~loc))
  in
  let rec parse_args_named_rec args seen =
    match args with
    | (Arg (Some (name, loc), value)) :: args ->
        place_named_arg name loc value;
        parse_args_named_rec args (name :: seen)
    | (Arg (None, _)) :: args -> parse_args_named_rec args seen
    | (Completion_name (vt_o, pref_suff)) :: _ -> raise (Completion (Compl_Arg_name (fname, pref_suff, vt_o, seen)))
    | [] -> ()
  in
  parse_args_named_rec args []
in

(* Then, we set values of remaining parameters with unnamed arguments in order *)
let parse_args_unnamed () =
  let rec parse_args_unnamed_rec args spec i =
    match spec with
    | [] ->
      (match args with
      | (Arg (Some _, _)) :: args -> parse_args_unnamed_rec args spec i
      | (Arg (None, ap)) :: _ -> Errors.(ScriptErrors.emit (Script_l.TooMuchArgs fname) ?loc:(pos_of_arg_parse ap))
      | _ -> ())
    | (vname, vspec) :: nspec ->
      match res.(i), args with
      | Some _, _ -> parse_args_unnamed_rec args nspec (i + 1)
      | None, (Arg (Some _, _)) :: args -> parse_args_unnamed_rec args spec i
      | None, (Arg (None, value)) :: args ->
          res.(i) <- Some (match_variable env vname value vspec barr fname);
          parse_args_unnamed_rec args nspec (i + 1)
      | None, [] -> ()
      | None, Completion_name _ :: _ -> assert false
  in
  parse_args_unnamed_rec args spec 0
in

(* Finally, we give to the last parameters their default values, if they have one. *)
(* If some parameter remains without a value, we throw an error. *)
let rec set_def_values spec i =
  if spec = [] then []
  else
    match (res.(i), spec) with
    | Some a, _ :: spec -> a :: set_def_values spec (i + 1)
    | None, (s, vspec) :: spec -> (match get_def_value vspec with
        | Some v -> v :: set_def_values spec (i + 1)
        | None -> Errors.(ScriptErrors.emit (Script_l.ArgumentMissing (s, fname)) ~loc))
      | _ -> []
  in

  let () = parse_args_named () in
  let () = parse_args_unnamed () in
  let result = set_def_values spec 0 in
  let blist_res = binding_array_to_binding_list barr blist result in
  (List.map (temp_to_arg result) result, blist_res)

let arg_to_real vl var_a =
  match var_a with
  | Bool_a (b, loc) -> Bool (b, loc)
  | Int_a (i, loc) -> Int (i, loc)
  | String_a (s, loc) -> String (s, loc)
  | Sig_a (sigg, loc) -> Sig (sigg, loc)
  | Lex_a (lex, loc) -> Lex (lex, loc)
  | Entry_a (e, loc) -> Entry (e, loc)
  | LexList_a (l, loc) -> LexList (l, loc)
  | StringList_a (l, loc) -> StringList (l, loc)
  | Type_a (ty, loc) -> Type (ty, loc)
  | Argument_a (i, T_LexList, _) ->
    let res =
      match List.nth vl i with
      | Lex (lex, loc) -> LexList ([ lex ], loc)
      | LexList (l, loc) -> LexList (l, loc)
      | _ -> assert false in
    res
  | Argument_a (i, _, _) -> List.nth vl i

let get_func_type f =
  match f with
  | Generation_f _ -> Generation
  | Computation_f _ -> Computation
  | Consumption_f _ -> Consumption
  | Special_f _ -> Special

let generate_fun_call f args =
  fun vl env v ->
    let real_args = List.map (arg_to_real vl) args in
    f real_args env v

let update_func_type_opt pft ft =
  match pft, ft with
  | All, ft -> Some ft
  | AtStart, Generation -> Some Generation
  | AtStart, Special -> Some Special
  | Generation, Computation -> Some Generation
  | Generation, Consumption -> Some Special
  | Computation, Computation -> Some Computation
  | Computation, Consumption -> Some Consumption
  | _ -> None

let update_func_type_err pft ft fname loc =
  match pft, ft with
  | All, ft -> ft
  | AtStart, Generation -> Generation
  | AtStart, Special -> Special
  | Generation, Computation -> Generation
  | Generation, Consumption -> Special
  | Computation, Computation -> Computation
  | Computation, Consumption -> Consumption
  | _, Special -> Errors.(ScriptErrors.emit (Script_l.InvalidSpecialFuncCall fname) ~loc)
  | AtStart, _ -> Errors.(ScriptErrors.emit (Script_l.MissingFuncTermList fname) ~loc)
  | Generation, _
  | Computation, _ -> Errors.(ScriptErrors.emit (Script_l.TermListNotAllowed fname) ~loc)
  | _ -> Errors.(ScriptErrors.emit (Script_l.EmptyPipe fname) ~loc)

let call_fun fname args loc nloc pft blist env =
  match get_fun env fname with
  | Some func ->
    let func_type = get_func_type func.f in
    let new_func_type = update_func_type_err pft func_type fname nloc in
    let prepare_vl vl_o =
      match vl_o with
      | Some vl -> vl
      | None -> LazyList.Nil in
    let callable_f = match func.f with
      | Generation_f f -> (fun vl env _ -> Some (f vl env), env)
      | Computation_f f -> (fun vl env v -> Some (f vl env (prepare_vl v)), env)
      | Consumption_f f -> (fun vl env v -> let () = f vl env (prepare_vl v) in None, env)
      | Special_f f -> (fun vl env _ -> None, f vl env) in
    let (args, new_blist) = parse_args fname args func.args loc blist env in
      (new_func_type, new_blist, generate_fun_call callable_f args)
  | None -> Errors.(ScriptErrors.emit (Script_l.UnknownFunction fname) ~loc:nloc)

let argspec_pp fmt aspec =
  match aspec with
  | Bool_s None -> Format.fprintf fmt ":bool"
  | Bool_s (Some true) -> Format.fprintf fmt "=true:bool"
  | Bool_s (Some false) -> Format.fprintf fmt "=false:bool"
  | Int_s None -> Format.fprintf fmt ":int"
  | Int_s (Some i) -> Format.fprintf fmt "=%i:int" i
  | Sig_s None -> Format.fprintf fmt ":sig"
  | Sig_s (Some s) -> Format.fprintf fmt "=%s:sig" (fst (AcgSig.name s))
  | Lex_s None -> Format.fprintf fmt ":lex"
  | Lex_s (Some l) -> Format.fprintf fmt "=%s:lex" (fst (AcgLex.name l))
  | Entry_s None -> Format.fprintf fmt ":entry"
  | Entry_s (Some e) ->
    let name =
      match e with
      | AcgEnv.Signature s -> (fst (AcgSig.name s))
      | AcgEnv.Lexicon l -> (fst (AcgLex.name l)) in
    Format.fprintf fmt "=%s:entry" name
  | LexList_s None -> Format.fprintf fmt ":lex+"
  | LexList_s (Some l) -> Format.fprintf fmt "=%a:lex+"
    (Utils.pp_list (fun fmt lex -> Format.fprintf fmt "%s" (fst (AcgLex.name lex)))) l
  | String_s (None, _) -> Format.fprintf fmt ":string"
  | String_s (Some s, _) -> Format.fprintf fmt "=\"%s\":string" s
  | StringList_s (None, _) -> Format.fprintf fmt ":string+"
  | StringList_s (Some l, _) -> Format.fprintf fmt "=%a:string+"
    (Utils.pp_list (fun fmt str -> Format.fprintf fmt "%s" str)) l
  | Type_s (_, None) -> Format.fprintf fmt ":type"
  | Type_s (Real_sig s, Some t) -> Format.fprintf fmt "=%a:type" (AcgSig.pp_type s) t
  | Type_s (Arg_sig _, Some _) -> assert false

let arg_pp fmt (aname, aspec) = Format.fprintf fmt "%a%a" Utils.blue_pp aname argspec_pp aspec

let fun_type_pp1 fmt f =
  match f with
   | Generation_f _
   | Special_f _ -> Format.fprintf fmt "         "
   | Computation_f _
   | Consumption_f _ -> Format.fprintf fmt "[%a] |" Utils.terms_pp "terms"

let fun_type_pp2 fmt f =
  match f with
   | Consumption_f _
   | Special_f _ -> ()
   | Computation_f _
   | Generation_f _ -> Format.fprintf fmt "| [%a]" Utils.terms_pp "terms"

let fun_pp fmt func =
  Format.fprintf fmt ("@[<v2>@[<hv4>%a@ %a@ %a@ %a@]@,@[<hov>%a@]@]")
    fun_type_pp1
    func.f
    Utils.fun_pp
    func.name
    (Utils.pp_list ~sep:"@;" arg_pp)
    func.args
    fun_type_pp2
    func.f
    Utils.pp_text
    func.help_text

let print_help env f_pattern =
  let fun_list = List.filter (fun f -> String.starts_with ~prefix:f_pattern f.name) env.functions in
  let () = List.iter
    (fun f -> Logs.app (fun m -> m "%a\n" fun_pp f))
    fun_list in
  if fun_list = [] then
    Errors.(ScriptErrors.emit (Script_l.EmptyHelp f_pattern))

let fun_doc_pp fmt func =
  Format.fprintf fmt ("@[{- {v\n%a %a %a %a\nv}\n\n%a}@]\n")
    fun_type_pp1
    func.f
    Utils.fun_pp
    func.name
    (Utils.pp_list ~sep:" " arg_pp)
    func.args
    fun_type_pp2
    func.f
    Utils.pp_text
    func.help_text

let doc_pp fmt fun_list =
  List.iter (fun f -> Format.fprintf fmt "{ul\n%a\n}\n" fun_doc_pp f) fun_list

let short_print env =
  AcgEnv.iter
    (fun e -> match e with
    | AcgEnv.Signature s -> Logs.app (fun m -> m "signature %a" Utils.sig_pp (fst (AcgSig.name s)))
    | AcgEnv.Lexicon l -> Logs.app (fun m -> m "%a" AcgLex.short_pp l))
    env.acg_env

type completion_element =
  | Ce_String of string * string * char
  | Ce_Path

let gen_completions compl text env =
  match compl with
  | Compl_Fun_name ft ->
    List.filter_map (fun f ->
      (match update_func_type_opt ft (get_func_type f.f) with
      | Some _ -> Some (Ce_String (f.name, f.name, ' '))
      | None -> None)) env.functions
  | Compl_Arg_name (fname, (pref, suff), ty_o, seen) ->
    (match list_fun_args env fname ty_o with
    | Some args ->
      List.filter_map
        (fun s ->
          if List.mem s seen then None else Some (Ce_String (pref ^ s, s, suff)))
        args
    | None -> [])
  | Compl_Arg_val (vs, seen) ->
    let l = match vs with
      | Bool_s _ -> [ Ce_String ("true", "true", ' ') ; Ce_String ("false", "false", ' ') ]
      | Type_s (_, _)
      | String_s (_, Ci_None)
      | StringList_s (_, Ci_None) -> []
      | StringList_s (_, Ci_Path)
      | String_s (_, Ci_Path) -> [ Ce_Path ]
      | String_s (_, Ci_List cl) -> List.map (fun s -> Ce_String (s, s, ' ')) cl
      | String_s (_, Ci_Fun) -> List.map (fun f -> Ce_String (f.name, f.name, ' ')) env.functions
      | StringList_s (_, Ci_List cl) ->
        let l = List.filter (fun s -> not (List.mem s seen)) cl in
        if List.length l = 1 then
          List.map (fun s -> Ce_String (s, s, ' ')) l
        else
          List.map (fun s -> Ce_String (s, s, Char.chr 0)) l
      | StringList_s (_, Ci_Fun) ->
        let l = List.filter (fun s -> not (List.mem s seen)) (List.map (fun f -> f.name) env.functions) in
        if List.length l = 1 then
          List.map (fun s -> Ce_String (s, s, ' ')) l
        else
          List.map (fun s -> Ce_String (s, s, Char.chr 0)) l
      | Int_s _ -> if Str.string_match (Str.regexp "[0-9]+$") text 0 then [ Ce_String (text, text, ' ') ] else []
      | Entry_s _
      | Sig_s _ ->
        let l = List.rev_append (AcgEnv.list_signatures env.acg_env) (AcgEnv.list_lexicons env.acg_env) in
        List.map (fun s -> Ce_String (s, s, ' ')) l
      | LexList_s _ ->
        let l = List.filter (fun s -> not (List.mem s seen)) (AcgEnv.list_lexicons env.acg_env) in
        if List.length l = 1 then
          List.map (fun s -> Ce_String (s, s, ' ')) l
        else
          List.map (fun s -> Ce_String (s, s, Char.chr 0)) l
      | Lex_s _ ->
        let l = AcgEnv.list_lexicons env.acg_env in
        List.map (fun s -> Ce_String (s, s, ' ')) l in
    l
  | Compl_None -> []
  | Compl_Custom cl -> List.map (fun s -> Ce_String (s, s, ' ')) cl