<commit_before>(* elpi: embedded lambda prolog interpreter                                  *)
(* license: GNU Lesser General Public License Version 2.1 or later           *)
(* ------------------------------------------------------------------------- *)

open Elpi_util
open Elpi_data
open Elpi_runtime_trace_off.Elpi_runtime
open Pp

(******************************************************************************
  "Compiler" from AST to program
 ******************************************************************************)

let modes = ref Constants.Map.empty

module SM = Map.Make(String)

module A = Elpi_ast

(* Function call spilling: from (g {f x}) to (sigma Y\ f x Y, g Y)
 *
 * Works on AST and needs to know the "types" of functors, i.e. their
 * arity in order to know how many extra arguments needs to be used *)
let spill types ast =

  let arity_of types t =
    let (c,ct), args =
      match t with
      | A.App (A.Const f,args) -> Constants.funct_of_ast f, args
      | A.App (A.Custom f,args) -> Constants.funct_of_ast f, args
      | A.Const c -> Constants.funct_of_ast c, []
      | A.Custom c -> Constants.funct_of_ast c, []
      | _ -> error ("only applications can be spilled: " ^ A.show_term t) in
    let nargs = List.length args in
    let missing_args =
      (* XXX This sucks: types and mode declarations should be merged XXX *)    
      try
        let _,_,ty = List.find (fun (t,_,_) -> t == c) types in
        let rec napp = function App(_,_,[x]) -> 1 + napp x | _ -> 0 in
        napp ty - nargs 
      with Not_found ->
        match Constants.Map.find c !modes with
        | Mono l ->
            let arity = List.length l in
            let missing = arity - nargs in
            let output_suffix =
              let rec aux = function false :: l -> 1 + aux l | _ -> 0 in
              aux (List.rev l) in
            if missing > output_suffix then
              error Printf.(sprintf
              "cannot spill %s: only %d out of %d missing arguments are outputs"
              (A.show_term t) output_suffix missing);
            missing
        | Multi _ -> error ("cannot spill multi mode relation " ^ Constants.show c)
        | exception Not_found ->
           error ("cannot spill, unknown arity of " ^ Constants.show c) in
    if missing_args <= 0 then
      error ("cannot spill fully applied " ^ A.show_term t);
    missing_args in

  let spilled_name = ref 0 in
  let rec mkSpilledNames n =
    if n == 0 then []
    else begin
      incr spilled_name;
      let name = F.from_string ("Spilled_" ^ string_of_int !spilled_name) in
      name :: mkSpilledNames (n-1)
    end in
  let add_spilled sp t =
    match sp with
    | [] -> [], [t]
    | _ ->
        let to_spill = map_filter snd sp in
        List.map (fun (x,_) -> x, None) sp,
        [A.(App(Const F.andf, to_spill @ [t]))] in

  let rec mapflat2 f l =
    let l1, l2 = List.(split (map f l)) in
    List.flatten l1, List.flatten l2 in

  let rec spaux toplevel = function
    | A.App(A.Const c,fcall :: rest) when F.(equal c spillf) ->
       let ns = mkSpilledNames (arity_of types fcall) in
       let fspills, fcall = spaux false fcall in
       assert(List.length fcall = 1);
       let fcall = List.hd fcall in
       let spills, args = mapflat2 (spaux false) rest in
       let args = List.map (fun x -> A.Const x) ns in
       fspills @ spills @ [ns,Some (A.mkApp (fcall :: args))], args
    | A.App(A.Const c, args)
       when F.(List.exists (equal c) [andf;andf2;orf;rimplf]) ->
       let spills, args = mapflat2 (spaux true) args in
       assert(map_filter snd spills = []);
       spills, [A.App(A.Const c, args)]
    | A.App(A.Const c, [A.Lam (n,arg)])
       when F.(List.exists (equal c) [pif;sigmaf]) ->
       let spills, arg = spaux true arg in
       assert(List.length arg = 1);
       let arg = List.hd arg in
       assert(map_filter snd spills = []);
       let arg = List.fold_left (fun acc (ns,_) ->
         List.fold_left (fun acc n ->
          A.(App(Const F.sigmaf, [Lam (n, acc)]))) acc ns) arg spills in
       [], [A.App(A.Const c, [A.Lam (n,arg)])]
    | A.App(A.Const c, args)
       when F.(List.exists (equal c) [implf;rimplf]) ->
       let spills, args = mapflat2 (spaux true) args in
       assert(map_filter snd spills = []);
       spills, [A.App(A.Const c, args)]
    | A.App(c,args) ->
       let spills, args = mapflat2 (spaux false) args in
       if toplevel then add_spilled spills (A.App(c, args))
       else spills, [A.App(c,args)]
    | (A.String _|A.Float _|A.Int _
      |A.Const _|A.Custom _|A.Quoted _) as x -> [], [x]
    | A.Lam(x,t) ->
       let sp, t = spaux false t in
       if sp <> [] then error "Not supported yet (spill lambda)";
       assert(List.length t = 1);
       let t = List.hd t in
       [], [A.Lam (x,t)]
  in
    let sp, t = spaux true ast in
    assert(List.length t = 1);
    let t = List.hd t in
    assert(map_filter snd sp = []);
    t
;;

(* To assign Arg (i.e. stack) slots to unif variables in clauses *)
type argmap = {
  max_arg : int;
  name2arg : (term * int) SM.t;       (* "X" -> Const "%Arg4", 4 *)
  argc2name : (string * int) Constants.Map.t; (* "%Arg4" -> "X", 4 *)
   (* constant used for symbolic pre-computation, real Arg number *)
}

let empty_amap = { max_arg = 0; name2arg = SM.empty; argc2name = Constants.Map.empty }

type varmap = term F.Map.t 
type quotation = depth:int -> ExtState.t -> string -> ExtState.t * term
let named_quotations = ref SM.empty
let default_quotation = ref None

let set_default_quotation f = default_quotation := Some f
let register_named_quotation n f =
  named_quotations := SM.add n f !named_quotations
 
let varmap = "elpi:varmap"
let get_varmap, set_varmap, update_varmap =
  ExtState.declare_extension varmap (fun () -> F.Map.empty)
;;
let argmap = "elpi:argmap"
let get_argmap, set_argmap, update_argmap =
  ExtState.declare_extension argmap (fun () -> empty_amap)
;;
let types = "elpi:types"
let get_types, set_types, update_types  =
  ExtState.declare_extension types (fun () -> [])
;;
let macros = "elpi:macros"
let get_macros, set_macros, update_macros =
  ExtState.declare_extension macros (fun () -> F.Map.empty)
;;

let is_Arg state x =
  let { argc2name } = get_argmap state in
  match x with
  | Const c -> Constants.Map.mem c argc2name
  | App(c,_,_) -> Constants.Map.mem c argc2name
  | _ -> false

(* Steps:
   1. from AST to AST: spilling {f x} -> sigma Y\ f x Y
   2. from AST to TERM:
      - @macro expansion (to enable substitution Args are coded as constants)
      - {{quotations}}
      - desugaring "f x -> y" and "X := f y"
      - bound names -> DB levels
   3. from TERM to TERM: (Const "%Arg4") -> (Arg 4)
*)

let mk_Arg state n =
  let { max_arg; name2arg } = get_argmap state in
  let cname = Printf.(sprintf "%%Arg%d" max_arg) in
  let n' = Constants.(from_string cname) in
  let nc = Constants.(from_stringc cname) in
  update_argmap state (fun { name2arg; argc2name } ->
    { max_arg = max_arg+1 ;
      name2arg = SM.add n (n',max_arg) name2arg;
      argc2name = Constants.Map.add nc (n,max_arg) argc2name }),
    n'

let fresh_Arg =
  let qargno = ref 0 in
  fun state ~name_hint:name ->
    incr qargno;
    mk_Arg state (Printf.sprintf "_Quotation_%s_%d_" name !qargno)

let stack_term_of_ast ?(inner_call=false) ~depth:arg_lvl state ast =
  let macro = get_macros state in
  let types = get_types state in

  (* XXX desugaring: XXX does not seem to be very useful... XXX
      - "f x -> y :- c" ---> "f x TMP :- TMP = y, c"
      - "X := f y" ---> "f y X"
      *)
  let desugar inner s args =
    let open Elpi_ast in
    let open Func in
    let varname = function Const x -> x | _ -> assert false in
    let last_is_arrow l =
      match List.rev l with
      | App(Const f,[_]) :: _ -> equal f arrowf
      | _ -> false in  
    let chop_last_app l =
      match List.rev l with
      | App(_,[x]) :: xs -> x, List.rev xs
      | _ -> assert false in
    match args with
    | [var;App(Const f,args)] when equal s letf -> f, (args @ [var]) 
    | [var;Const f] when equal s letf -> f, [var] 
    | [App(hd,args); hyps] when equal s rimplf && last_is_arrow args ->
      let res, args = chop_last_app args in
      let var = if inner then mkFreshName () else mkFreshUVar () in
      let args = [App(hd, args @ [var]) ;
                  App(Const andf, [App(Const eqf, [var;res]); hyps])] in
      if inner then pif, [Lam(varname var, App(Const s, args ))]
      else s, args
    | args when not (equal s rimplf) && last_is_arrow args ->
      let res, args = chop_last_app args in
      let var = if inner then mkFreshName () else mkFreshUVar () in
      let args = [App(Const s, args @ [var]) ; App(Const eqf, [var;res])] in
      if inner then pif, [Lam(varname var, App(Const rimplf, args))]
      else rimplf, args
    | _ -> s, args in
 
  let is_uvar_name f = 
     let c = (F.show f).[0] in
     ('A' <= c && c <= 'Z') || c = '_' in

  let is_macro_name f = 
     let c = (F.show f).[0] in
     c = '@' in

  let stack_arg_of_ast state n =
    let { name2arg } = get_argmap state in
    try state, fst (SM.find n name2arg)
    with Not_found -> mk_Arg state n in

  let rec stack_macro_of_ast inner lvl state f =
    try aux inner lvl state (F.Map.find f macro)
    with Not_found -> error ("Undeclared macro " ^ F.show f) 
  
  and stack_funct_of_ast inner curlvl state f =
    try state, F.Map.find f (get_varmap state)
    with Not_found ->
     if is_uvar_name f then
       stack_arg_of_ast state (F.show f)
     else if is_macro_name f then
       stack_macro_of_ast inner curlvl state f
     else state, snd (Constants.funct_of_ast f)

  and stack_custom_of_ast f =
    let cname = fst (Constants.funct_of_ast f) in
    if not (is_custom_declared cname) then warn("No custom named "^F.show f);
    cname
  
  and aux inner lvl state = function
    | A.Const f when F.(equal f nilf) -> state, Nil
    | A.Const f -> stack_funct_of_ast inner lvl state f
    | A.Custom f ->
       let cname = stack_custom_of_ast f in
       state, Custom (cname, [])
    | A.App(A.Const f, [hd;tl]) when F.(equal f consf) ->
       let state, hd = aux true lvl state hd in
       let state, tl = aux true lvl state tl in
       state, Cons(hd,tl)
    | A.App(A.Const f, tl) ->
       let f, tl = desugar inner f tl in
       let state, rev_tl =
         List.fold_left (fun (state, tl) t ->
           let state, t = aux true lvl state t in
           (state, t::tl))
          (state, []) tl in
       let tl = List.rev rev_tl in
       let state, c = stack_funct_of_ast inner lvl state f in
       begin match c with
       | Const c -> begin match tl with
          | hd2::tl -> state, App(c,hd2,tl)
          | _ -> anomaly "Application node with no arguments" end
       | App(c,hd1,tl1) -> (* FG: decurrying: is this the right place for it ?? *)
          state, App(c,hd1,tl1@tl)
       | Lam _ -> (* macro with args *)
          state, deref_appuv ~from:lvl ~to_:lvl tl c
       | _ -> error "Clause shape unsupported" end
    | A.App (A.Custom f,tl) ->
       let cname = stack_custom_of_ast f in
       let state, rev_tl =
         List.fold_left (fun (state, tl) t ->
            let state, t = aux true lvl state t in
            (state, t::tl))
          (state, []) tl in
       state, Custom(cname, List.rev rev_tl)
    | A.Lam (x,t) when A.Func.(equal x dummyname)->
       let state, t' = aux true (lvl+1) state t in
       state, Lam t'
    | A.Lam (x,t) ->
       let orig_varmap = get_varmap state in
       let state = update_varmap state (F.Map.add x (Constants.of_dbl lvl)) in
       let state, t' = aux true (lvl+1) state t in
       set_varmap state orig_varmap, Lam t'
    | A.App (A.App (f,l1),l2) ->
       aux inner lvl state (A.App (f, l1@l2))
    | A.String str -> state, CData (in_string str)
    | A.Int i -> state, CData (in_int i)
    | A.Float f -> state, CData (in_float f)
    | A.App (A.Lam _,_) -> error "Beta-redexes not in our language"
    | A.App (A.String _,_) -> type_error "Applied string value"
    | A.App (A.Int _,_) -> type_error "Applied integer value"
    | A.App (A.Float _,_) -> type_error "Applied float value"
    | A.Quoted { A.data; A.kind = None } ->
         let unquote =
           option_get ~err:"No default quotation" !default_quotation in
         unquote ~depth:lvl state data 
    | A.Quoted { A.data; A.kind = Some name } ->
         let unquote = 
           try SM.find name !named_quotations
           with Not_found -> anomaly ("No '"^name^"' quotation") in
         unquote ~depth:lvl state data 
    | A.App (A.Quoted _,_) -> type_error "Applied quotation"
  in

  (* Real Arg nodes: from "Const '%Arg3'" to "Arg 3" *)
  let argify { argc2name } t =
    let arg_cst amap c args =
      if Constants.Map.mem c amap then
        let _, argno = Constants.Map.find c amap in
        mkAppArg argno arg_lvl args
      else if args = [] then Constants.of_dbl c
      else App(c,List.hd args,List.tl args) in
    let rec argify amap = function
      | Const c -> arg_cst amap c []
      | App(c,x,xs) -> arg_cst amap c (List.map (argify amap) (x::xs))<commit_msg>Compiler: re-hashcons CData/string at compilation time.<commit_after>(* elpi: embedded lambda prolog interpreter                                  *)
(* license: GNU Lesser General Public License Version 2.1 or later           *)
(* ------------------------------------------------------------------------- *)

open Elpi_util
open Elpi_data
open Elpi_runtime_trace_off.Elpi_runtime
open Pp

(******************************************************************************
  "Compiler" from AST to program
 ******************************************************************************)

let modes = ref Constants.Map.empty

module SM = Map.Make(String)

module A = Elpi_ast

(* Function call spilling: from (g {f x}) to (sigma Y\ f x Y, g Y)
 *
 * Works on AST and needs to know the "types" of functors, i.e. their
 * arity in order to know how many extra arguments needs to be used *)
let spill types ast =

  let arity_of types t =
    let (c,ct), args =
      match t with
      | A.App (A.Const f,args) -> Constants.funct_of_ast f, args
      | A.App (A.Custom f,args) -> Constants.funct_of_ast f, args
      | A.Const c -> Constants.funct_of_ast c, []
      | A.Custom c -> Constants.funct_of_ast c, []
      | _ -> error ("only applications can be spilled: " ^ A.show_term t) in
    let nargs = List.length args in
    let missing_args =
      (* XXX This sucks: types and mode declarations should be merged XXX *)    
      try
        let _,_,ty = List.find (fun (t,_,_) -> t == c) types in
        let rec napp = function App(_,_,[x]) -> 1 + napp x | _ -> 0 in
        napp ty - nargs 
      with Not_found ->
        match Constants.Map.find c !modes with
        | Mono l ->
            let arity = List.length l in
            let missing = arity - nargs in
            let output_suffix =
              let rec aux = function false :: l -> 1 + aux l | _ -> 0 in
              aux (List.rev l) in
            if missing > output_suffix then
              error Printf.(sprintf
              "cannot spill %s: only %d out of %d missing arguments are outputs"
              (A.show_term t) output_suffix missing);
            missing
        | Multi _ -> error ("cannot spill multi mode relation " ^ Constants.show c)
        | exception Not_found ->
           error ("cannot spill, unknown arity of " ^ Constants.show c) in
    if missing_args <= 0 then
      error ("cannot spill fully applied " ^ A.show_term t);
    missing_args in

  let spilled_name = ref 0 in
  let rec mkSpilledNames n =
    if n == 0 then []
    else begin
      incr spilled_name;
      let name = F.from_string ("Spilled_" ^ string_of_int !spilled_name) in
      name :: mkSpilledNames (n-1)
    end in
  let add_spilled sp t =
    match sp with
    | [] -> [], [t]
    | _ ->
        let to_spill = map_filter snd sp in
        List.map (fun (x,_) -> x, None) sp,
        [A.(App(Const F.andf, to_spill @ [t]))] in

  let rec mapflat2 f l =
    let l1, l2 = List.(split (map f l)) in
    List.flatten l1, List.flatten l2 in

  let rec spaux toplevel = function
    | A.App(A.Const c,fcall :: rest) when F.(equal c spillf) ->
       let ns = mkSpilledNames (arity_of types fcall) in
       let fspills, fcall = spaux false fcall in
       assert(List.length fcall = 1);
       let fcall = List.hd fcall in
       let spills, args = mapflat2 (spaux false) rest in
       let args = List.map (fun x -> A.Const x) ns in
       fspills @ spills @ [ns,Some (A.mkApp (fcall :: args))], args
    | A.App(A.Const c, args)
       when F.(List.exists (equal c) [andf;andf2;orf;rimplf]) ->
       let spills, args = mapflat2 (spaux true) args in
       assert(map_filter snd spills = []);
       spills, [A.App(A.Const c, args)]
    | A.App(A.Const c, [A.Lam (n,arg)])
       when F.(List.exists (equal c) [pif;sigmaf]) ->
       let spills, arg = spaux true arg in
       assert(List.length arg = 1);
       let arg = List.hd arg in
       assert(map_filter snd spills = []);
       let arg = List.fold_left (fun acc (ns,_) ->
         List.fold_left (fun acc n ->
          A.(App(Const F.sigmaf, [Lam (n, acc)]))) acc ns) arg spills in
       [], [A.App(A.Const c, [A.Lam (n,arg)])]
    | A.App(A.Const c, args)
       when F.(List.exists (equal c) [implf;rimplf]) ->
       let spills, args = mapflat2 (spaux true) args in
       assert(map_filter snd spills = []);
       spills, [A.App(A.Const c, args)]
    | A.App(c,args) ->
       let spills, args = mapflat2 (spaux false) args in
       if toplevel then add_spilled spills (A.App(c, args))
       else spills, [A.App(c,args)]
    | (A.String _|A.Float _|A.Int _
      |A.Const _|A.Custom _|A.Quoted _) as x -> [], [x]
    | A.Lam(x,t) ->
       let sp, t = spaux false t in
       if sp <> [] then error "Not supported yet (spill lambda)";
       assert(List.length t = 1);
       let t = List.hd t in
       [], [A.Lam (x,t)]
  in
    let sp, t = spaux true ast in
    assert(List.length t = 1);
    let t = List.hd t in
    assert(map_filter snd sp = []);
    t
;;

(* To assign Arg (i.e. stack) slots to unif variables in clauses *)
type argmap = {
  max_arg : int;
  name2arg : (term * int) SM.t;       (* "X" -> Const "%Arg4", 4 *)
  argc2name : (string * int) Constants.Map.t; (* "%Arg4" -> "X", 4 *)
   (* constant used for symbolic pre-computation, real Arg number *)
}

let empty_amap = { max_arg = 0; name2arg = SM.empty; argc2name = Constants.Map.empty }

type varmap = term F.Map.t 
type quotation = depth:int -> ExtState.t -> string -> ExtState.t * term
let named_quotations = ref SM.empty
let default_quotation = ref None

let set_default_quotation f = default_quotation := Some f
let register_named_quotation n f =
  named_quotations := SM.add n f !named_quotations
 
let varmap = "elpi:varmap"
let get_varmap, set_varmap, update_varmap =
  ExtState.declare_extension varmap (fun () -> F.Map.empty)
;;
let argmap = "elpi:argmap"
let get_argmap, set_argmap, update_argmap =
  ExtState.declare_extension argmap (fun () -> empty_amap)
;;
let types = "elpi:types"
let get_types, set_types, update_types  =
  ExtState.declare_extension types (fun () -> [])
;;
let macros = "elpi:macros"
let get_macros, set_macros, update_macros =
  ExtState.declare_extension macros (fun () -> F.Map.empty)
;;

let is_Arg state x =
  let { argc2name } = get_argmap state in
  match x with
  | Const c -> Constants.Map.mem c argc2name
  | App(c,_,_) -> Constants.Map.mem c argc2name
  | _ -> false

(* Steps:
   1. from AST to AST: spilling {f x} -> sigma Y\ f x Y
   2. from AST to TERM:
      - @macro expansion (to enable substitution Args are coded as constants)
      - {{quotations}}
      - desugaring "f x -> y" and "X := f y"
      - bound names -> DB levels
   3. from TERM to TERM: (Const "%Arg4") -> (Arg 4)
*)

let mk_Arg state n =
  let { max_arg; name2arg } = get_argmap state in
  let cname = Printf.(sprintf "%%Arg%d" max_arg) in
  let n' = Constants.(from_string cname) in
  let nc = Constants.(from_stringc cname) in
  update_argmap state (fun { name2arg; argc2name } ->
    { max_arg = max_arg+1 ;
      name2arg = SM.add n (n',max_arg) name2arg;
      argc2name = Constants.Map.add nc (n,max_arg) argc2name }),
    n'

let fresh_Arg =
  let qargno = ref 0 in
  fun state ~name_hint:name ->
    incr qargno;
    mk_Arg state (Printf.sprintf "_Quotation_%s_%d_" name !qargno)

let stack_term_of_ast ?(inner_call=false) ~depth:arg_lvl state ast =
  let macro = get_macros state in
  let types = get_types state in

  (* XXX desugaring: XXX does not seem to be very useful... XXX
      - "f x -> y :- c" ---> "f x TMP :- TMP = y, c"
      - "X := f y" ---> "f y X"
      *)
  let desugar inner s args =
    let open Elpi_ast in
    let open Func in
    let varname = function Const x -> x | _ -> assert false in
    let last_is_arrow l =
      match List.rev l with
      | App(Const f,[_]) :: _ -> equal f arrowf
      | _ -> false in  
    let chop_last_app l =
      match List.rev l with
      | App(_,[x]) :: xs -> x, List.rev xs
      | _ -> assert false in
    match args with
    | [var;App(Const f,args)] when equal s letf -> f, (args @ [var]) 
    | [var;Const f] when equal s letf -> f, [var] 
    | [App(hd,args); hyps] when equal s rimplf && last_is_arrow args ->
      let res, args = chop_last_app args in
      let var = if inner then mkFreshName () else mkFreshUVar () in
      let args = [App(hd, args @ [var]) ;
                  App(Const andf, [App(Const eqf, [var;res]); hyps])] in
      if inner then pif, [Lam(varname var, App(Const s, args ))]
      else s, args
    | args when not (equal s rimplf) && last_is_arrow args ->
      let res, args = chop_last_app args in
      let var = if inner then mkFreshName () else mkFreshUVar () in
      let args = [App(Const s, args @ [var]) ; App(Const eqf, [var;res])] in
      if inner then pif, [Lam(varname var, App(Const rimplf, args))]
      else rimplf, args
    | _ -> s, args in
 
  let is_uvar_name f = 
     let c = (F.show f).[0] in
     ('A' <= c && c <= 'Z') || c = '_' in

  let is_macro_name f = 
     let c = (F.show f).[0] in
     c = '@' in

  let stack_arg_of_ast state n =
    let { name2arg } = get_argmap state in
    try state, fst (SM.find n name2arg)
    with Not_found -> mk_Arg state n in

  let rec stack_macro_of_ast inner lvl state f =
    try aux inner lvl state (F.Map.find f macro)
    with Not_found -> error ("Undeclared macro " ^ F.show f) 
  
  and stack_funct_of_ast inner curlvl state f =
    try state, F.Map.find f (get_varmap state)
    with Not_found ->
     if is_uvar_name f then
       stack_arg_of_ast state (F.show f)
     else if is_macro_name f then
       stack_macro_of_ast inner curlvl state f
     else state, snd (Constants.funct_of_ast f)

  and stack_custom_of_ast f =
    let cname = fst (Constants.funct_of_ast f) in
    if not (is_custom_declared cname) then warn("No custom named "^F.show f);
    cname
  
  and aux inner lvl state = function
    | A.Const f when F.(equal f nilf) -> state, Nil
    | A.Const f -> stack_funct_of_ast inner lvl state f
    | A.Custom f ->
       let cname = stack_custom_of_ast f in
       state, Custom (cname, [])
    | A.App(A.Const f, [hd;tl]) when F.(equal f consf) ->
       let state, hd = aux true lvl state hd in
       let state, tl = aux true lvl state tl in
       state, Cons(hd,tl)
    | A.App(A.Const f, tl) ->
       let f, tl = desugar inner f tl in
       let state, rev_tl =
         List.fold_left (fun (state, tl) t ->
           let state, t = aux true lvl state t in
           (state, t::tl))
          (state, []) tl in
       let tl = List.rev rev_tl in
       let state, c = stack_funct_of_ast inner lvl state f in
       begin match c with
       | Const c -> begin match tl with
          | hd2::tl -> state, App(c,hd2,tl)
          | _ -> anomaly "Application node with no arguments" end
       | App(c,hd1,tl1) -> (* FG: decurrying: is this the right place for it ?? *)
          state, App(c,hd1,tl1@tl)
       | Lam _ -> (* macro with args *)
          state, deref_appuv ~from:lvl ~to_:lvl tl c
       | _ -> error "Clause shape unsupported" end
    | A.App (A.Custom f,tl) ->
       let cname = stack_custom_of_ast f in
       let state, rev_tl =
         List.fold_left (fun (state, tl) t ->
            let state, t = aux true lvl state t in
            (state, t::tl))
          (state, []) tl in
       state, Custom(cname, List.rev rev_tl)
    | A.Lam (x,t) when A.Func.(equal x dummyname)->
       let state, t' = aux true (lvl+1) state t in
       state, Lam t'
    | A.Lam (x,t) ->
       let orig_varmap = get_varmap state in
       let state = update_varmap state (F.Map.add x (Constants.of_dbl lvl)) in
       let state, t' = aux true (lvl+1) state t in
       set_varmap state orig_varmap, Lam t'
    | A.App (A.App (f,l1),l2) ->
       aux inner lvl state (A.App (f, l1@l2))
    | A.String str -> state, CData (in_string (F.from_string (F.show str)))
    | A.Int i -> state, CData (in_int i)
    | A.Float f -> state, CData (in_float f)
    | A.App (A.Lam _,_) -> error "Beta-redexes not in our language"
    | A.App (A.String _,_) -> type_error "Applied string value"
    | A.App (A.Int _,_) -> type_error "Applied integer value"
    | A.App (A.Float _,_) -> type_error "Applied float value"
    | A.Quoted { A.data; A.kind = None } ->
         let unquote =
           option_get ~err:"No default quotation" !default_quotation in
         unquote ~depth:lvl state data 
    | A.Quoted { A.data; A.kind = Some name } ->
         let unquote = 
           try SM.find name !named_quotations
           with Not_found -> anomaly ("No '"^name^"' quotation") in
         unquote ~depth:lvl state data 
    | A.App (A.Quoted _,_) -> type_error "Applied quotation"
  in

  (* Real Arg nodes: from "Const '%Arg3'" to "Arg 3" *)
  let argify { argc2name } t =
    let arg_cst amap c args =
      if Constants.Map.mem c amap then
        let _, argno = Constants.Map.find c amap in
        mkAppArg argno arg_lvl args
      else if args = [] then Constants.of_dbl c
      else App(c,List.hd args,List.tl args) in
    let rec argify amap = function
      | Const c -> arg_cst amap c []
      | App(c,x,xs) -> arg_cst amap c (List.map (argify amap) (x::xs))
{'fraction_non_alphanumeric': 0.13662426428707045, 'fraction_numerical': 0.005240174672489083, 'mean_word_length': 2.2784762853230425, 'pattern_counts': {'":': 0, '<': 11, '<?xml version=': 0, '>': 191, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 2, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1508751', 'n_tokens_mistral': 9357, 'n_tokens_neox': 9136, 'n_words': 3100}