<commit_before>
(**************************************************************************
 *  Copyright (C) 2012-2013
 *  <NAME> (<EMAIL>), St.Petersburg State University
 *  Universitetskii pr., 28, St.Petersburg, 198504, RUSSIA    
 *
 *  This library is free software; you can redistribute it and/or
 *  modify it under the terms of the GNU Lesser General Public
 *  License as published by the Free Software Foundation; either
 *  version 2.1 of the License, or (at your option) any later version.
 *
 *  This library is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 *  Lesser General Public License for more details.
 *
 *  You should have received a copy of the GNU Lesser General Public
 *  License along with this library; if not, write to the Free Software
 *  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
 *
 *  See the GNU Lesser General Public License version 2.1 for more details
 *  (enclosed in the file COPYING).
 **************************************************************************)

#load "pa_extend.cmo";;
#load "q_MLast.cmo";;

open List
open Printf
open Pcaml
open MLast
open Ploc
     
let get_val (VaVal x) = x 

module S = Set.Make (String)

let name_generator list =
  let s = ref (fold_right S.add list S.empty) in
  object(self)
    method generate prompt =
      if S.mem prompt !s 
      then self#generate ("_" ^ prompt)
      else (
        s := S.add prompt !s;
        prompt
      )
  end

let cata  name  = name ^ "_gcata"
let others      = "others"
let cmethod c   = "m_" ^ c
let apply       = "apply"
let opened name = name ^ "'"
let closed name = name

let rec replace_t loc opened_version a n typ =
  let replace_t = replace_t loc opened_version a n in 
  let replace_pv lpv = 
    map 
      (function <:poly_variant< `$name$ of $flag:f$ $list:args$ >> -> 
         let args = map replace_t args in
         <:poly_variant< `$name$ of $flag:f$ $list:args$ >>
      ) 
      lpv 
  in
  match typ with
  | <:ctyp< $t1$ as $t2$ >> -> <:ctyp< $replace_t t1$ as $replace_t t2$ >>           
  | <:ctyp< $t1$ $t2$ >> -> 
      (match t1 with
       | <:ctyp< $lid:s$ >> as typ when s = n ->
            if opened_version
            then 
              let t1 = <:ctyp< $lid:opened s$ >> in
              <:ctyp< $t1$ $replace_t t2$ >>
            else  
              let rec inner args t =
                match args, t with
                | [arg], <:ctyp< ' $b$ >> -> if arg = b then <:ctyp< ' $hd a$ >> else typ
                | arg::args, <:ctyp< $t1$ $t2$ >> ->
                    (match t1 with 
                     | <:ctyp< ' $b$ >> when arg = b -> inner args t2
                     | _ -> typ
                    )
                | _ -> typ
                in
                inner a t2
       | _ -> <:ctyp< $replace_t t1$ $replace_t t2$ >>
      )
  | <:ctyp< $t1$ -> $t2$ >> -> <:ctyp< $replace_t t1$ -> $replace_t t2$ >>
  | <:ctyp< ~$s$: $t$ >> -> <:ctyp< ~$s$: $replace_t t$ >>
  | <:ctyp< $t1$ == private $t2$ >> -> <:ctyp< $replace_t t1$ == private $replace_t t2$ >>
  | <:ctyp< $t1$ == $t2$ >> -> <:ctyp< $replace_t t1$ == $replace_t t2$ >>
  | <:ctyp< ?$s$: $t$ >> -> <:ctyp< ?$s$: $replace_t t$ >>
  | <:ctyp< ( $list:lt$ ) >> -> <:ctyp< ( $list:map replace_t lt$ ) >> 
  | <:ctyp< [ > $list:lpv$ ] >> -> <:ctyp< [ > $list:replace_pv lpv$ ] >>
  | <:ctyp< [ < $list:lpv$ ] >> -> <:ctyp< [ < $list:replace_pv lpv$ ] >>
  | <:ctyp< < $list:lst$ > >> -> <:ctyp< < $list:map (fun (s, t) -> s, replace_t t) lst$ > >>
  | <:ctyp< < $list:lst$ .. > >> -> <:ctyp< < $list:map (fun (s, t) -> s, replace_t t) lst$ .. > >>  
  | typ -> typ
    
EXTEND
  GLOBAL: str_item; 

  str_item: LEVEL "top" [
    [ "generic"; t=LIST1 t_decl SEP "and" -> 
      let make_call g f args =
        fold_left (fun e a -> <:expr< $e$ $g a$ >>) f args
      in
      let make_fun g args body =
        fold_right 
          (fun arg expr -> <:expr< fun [ $list:[g arg, VaVal None, expr]$ ] >>)                  
          args
          body
      in
      let id x = x in
      let t, d = split   t in
      let t    = flatten t in
      let get_cata =
        let s = fold_left (fun s (_, n, _) -> S.add n s) S.empty d in
        fun name -> 
          if S.mem name s then <:expr< $lid:cata name$ >> 
                          else let name, gcata = <:expr< $lid:name$ >>, <:expr< $lid:"gcata"$ >> in
                               <:expr< $name$ . $gcata$ >>
      in
      let g     = name_generator (map (fun (_, n, _) -> n) d) in
      let trans = g#generate "t"   in
      let ext   = g#generate "ext" in
      let farg  = 
        let module M = Map.Make (String) in
        let m = ref M.empty in<commit_msg>Added opened type reference symbol<commit_after>
(**************************************************************************
 *  Copyright (C) 2012-2013
 *  <NAME> (<EMAIL>), St.Petersburg State University
 *  Universitetskii pr., 28, St.Petersburg, 198504, RUSSIA    
 *
 *  This library is free software; you can redistribute it and/or
 *  modify it under the terms of the GNU Lesser General Public
 *  License as published by the Free Software Foundation; either
 *  version 2.1 of the License, or (at your option) any later version.
 *
 *  This library is distributed in the hope that it will be useful,
 *  but WITHOUT ANY WARRANTY; without even the implied warranty of
 *  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 *  Lesser General Public License for more details.
 *
 *  You should have received a copy of the GNU Lesser General Public
 *  License along with this library; if not, write to the Free Software
 *  Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
 *
 *  See the GNU Lesser General Public License version 2.1 for more details
 *  (enclosed in the file COPYING).
 **************************************************************************)

#load "pa_extend.cmo";;
#load "q_MLast.cmo";;

open List
open Printf
open Pcaml
open MLast
open Ploc
     
let get_val (VaVal x) = x 

module S = Set.Make (String)

let name_generator list =
  let s = ref (fold_right S.add list S.empty) in
  object(self)
    method generate prompt =
      if S.mem prompt !s 
      then self#generate ("_" ^ prompt)
      else (
        s := S.add prompt !s;
        prompt
      )
  end

let cata  name  = name ^ "_gcata"
let others      = "others"
let cmethod c   = "m_" ^ c
let apply       = "apply"
let opened name = name ^ "'"
let closed name = name

let rec replace_t loc opened_version a n typ =
  let replace_t = replace_t loc opened_version a n in 
  let replace_pv lpv = 
    map 
      (function <:poly_variant< `$name$ of $flag:f$ $list:args$ >> -> 
         let args = map replace_t args in
         <:poly_variant< `$name$ of $flag:f$ $list:args$ >>
      ) 
      lpv 
  in
  match typ with
  | <:ctyp< $t1$ as $t2$ >> -> <:ctyp< $replace_t t1$ as $replace_t t2$ >>           
  | <:ctyp< $t1$ $t2$ >> -> 
      (match t1 with
       | <:ctyp< $lid:s$ >> as typ when s = n ->
            if opened_version
            then 
              let t1 = <:ctyp< $lid:opened s$ >> in
              <:ctyp< $t1$ $replace_t t2$ >>
            else  
              let rec inner args t =
                match args, t with
                | [arg], <:ctyp< ' $b$ >> -> if arg = b then <:ctyp< ' $hd a$ >> else typ
                | arg::args, <:ctyp< $t1$ $t2$ >> ->
                    (match t1 with 
                     | <:ctyp< ' $b$ >> when arg = b -> inner args t2
                     | _ -> typ
                    )
                | _ -> typ
                in
                inner a t2
       | _ -> <:ctyp< $replace_t t1$ $replace_t t2$ >>
      )
  | <:ctyp< $t1$ -> $t2$ >> -> <:ctyp< $replace_t t1$ -> $replace_t t2$ >>
  | <:ctyp< ~$s$: $t$ >> -> <:ctyp< ~$s$: $replace_t t$ >>
  | <:ctyp< $t1$ == private $t2$ >> -> <:ctyp< $replace_t t1$ == private $replace_t t2$ >>
  | <:ctyp< $t1$ == $t2$ >> -> <:ctyp< $replace_t t1$ == $replace_t t2$ >>
  | <:ctyp< ?$s$: $t$ >> -> <:ctyp< ?$s$: $replace_t t$ >>
  | <:ctyp< ( $list:lt$ ) >> -> <:ctyp< ( $list:map replace_t lt$ ) >> 
  | <:ctyp< [ > $list:lpv$ ] >> -> <:ctyp< [ > $list:replace_pv lpv$ ] >>
  | <:ctyp< [ < $list:lpv$ ] >> -> <:ctyp< [ < $list:replace_pv lpv$ ] >>
  | <:ctyp< < $list:lst$ > >> -> <:ctyp< < $list:map (fun (s, t) -> s, replace_t t) lst$ > >>
  | <:ctyp< < $list:lst$ .. > >> -> <:ctyp< < $list:map (fun (s, t) -> s, replace_t t) lst$ .. > >>  
  | typ -> typ
    
EXTEND
  GLOBAL: str_item ctyp; 

  ctyp: [
    [ ">"; t=ctyp -> 
      let rec inner = function
      | <:ctyp< $q$ . $t$ >> -> <:ctyp< $q$ . $inner t$ >>
      | <:ctyp< $t$ $a$ >> -> <:ctyp< $inner t$ $a$ >>
      | <:ctyp< $lid:name$ >> -> <:ctyp< $lid:opened name$ >>
      | t -> Ploc.raise loc (Invalid_argument "application or qualified name expected")
      in
      inner t
    ]
  ];

  str_item: LEVEL "top" [
    [ "generic"; t=LIST1 t_decl SEP "and" -> 
      let make_call g f args =
        fold_left (fun e a -> <:expr< $e$ $g a$ >>) f args
      in
      let make_fun g args body =
        fold_right 
          (fun arg expr -> <:expr< fun [ $list:[g arg, VaVal None, expr]$ ] >>)                  
          args
          body
      in
      let id x = x in
      let t, d = split   t in
      let t    = flatten t in
      let get_cata =
        let s = fold_left (fun s (_, n, _) -> S.add n s) S.empty d in
        fun name -> 
          if S.mem name s then <:expr< $lid:cata name$ >> 
                          else let name, gcata = <:expr< $lid:name$ >>, <:expr< $lid:"gcata"$ >> in
                               <:expr< $name$ . $gcata$ >>
      in
      let g     = name_generator (map (fun (_, n, _) -> n) d) in
      let trans = g#generate "t"   in
      let ext   = g#generate "ext" in
      let farg  = 
        let module M = Map.Make (String) in
        let m = ref M.empty in
{'fraction_non_alphanumeric': 0.17764729299363058, 'fraction_numerical': 0.01214171974522293, 'mean_word_length': 2.0140971805638874, 'pattern_counts': {'":': 0, '<': 187, '<?xml version=': 0, '>': 255, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '1253206', 'n_tokens_mistral': 3642, 'n_tokens_neox': 3506, 'n_words': 1163}