(*******************************************************)
(*                                                     *)
(* OCamlNS                                             *)
(*                                                     *)
(* Copyright (c) 2001, 2002.                           *)
(* E/AS Software Foundation                            *)
(*                                                     *)
(* Author(s):                                          *)
(*    Yurii A. Rashkovskii                             *)
(*                                                     *)
(* This program 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; version 2 of the License. *)
(*                                                     *)
(*******************************************************)

open Stdpp;;
open Pcaml;;

let mod_ident = Grammar.Entry.create gram "mod_ident";;
let module_binding = Grammar.Entry.create gram "module_binding";;


let rename_module = ref (fun loc -> <:str_item< open Pervasives >>);;

let gen_mod_name l =
    let nsname = ref "" in
    List.iter (fun x -> nsname := !nsname ^ (x ^ "_")) l ; 
    (String.sub !nsname 0 ((String.length !nsname)-1));;

let gen_ns_name l =
    let nsname = ref "" in
    List.iter (fun x -> nsname := !nsname ^ (x ^ "_")) l ; !nsname;;

let gen_ns_name_s ns =
    let slash s = Str.global_replace (Str.regexp "/") "_slash_" s and 
        colon s = Str.global_replace (Str.regexp ":") "_colon_" s and 
        amp s = Str.global_replace (Str.regexp "&") "_amp_" s and 
        q s = Str.global_replace (Str.regexp "?") "_q_" s and 
        qe s = Str.global_replace (Str.regexp "=") "_eq_" s and 
        p s = Str.global_replace (Str.regexp "%") "_p_" s and 
        d s = Str.global_replace (Str.regexp "#") "_d_" s and 
        at s = Str.global_replace (Str.regexp "@") "_at_" s and
        dot s = Str.global_replace (Str.regexp "\\.") "_dot_" s in
     (slash (colon (amp (q (qe (p (d (at (dot ns)))))))));; 

let gen_mod_name_s ns =
    if (String.sub (gen_ns_name_s ns) ((String.length (gen_ns_name_s ns))-1) 1)
     = "_" then
    (String.sub (gen_ns_name_s ns) 0 ((String.length (gen_ns_name_s ns))-1))
    else (gen_ns_name_s ns)
  
    
let gen_module loc mn ns me =
    let name = "caml_namespace___" ^ (gen_ns_name ns) ^ "__module___" ^ mn in
    <:str_item< module $uid:name$ = $me$ >>
;;    

let gen_module_s loc mn ns me =
    let name = "caml_namespace___" ^ (gen_ns_name_s ns) ^ "__module___" ^ mn in
    <:str_item< module $uid:name$ = $me$ >>
;;    

let gen_module_type loc mn ns mt =
    let name = "caml_namespace___" ^ (gen_ns_name ns) ^ "__moduletype___" ^ mn in
    <:str_item< module type$uid:name$ = $mt$ >>
;;    

let gen_module_type_s loc mn ns mt =
    let name = "caml_namespace___" ^ (gen_ns_name_s ns) ^ "__moduletype___" ^ mn in
    <:str_item< module type$uid:name$ = $mt$ >>
;;    

let gen_module_open loc mn ns =
    let name = "caml_namespace___" ^ (gen_ns_name ns) ^ "__module___" ^ mn in
    rename_module := (fun loc -> <:str_item< module $uid:mn$ = $uid:name$>>);    
    <:str_item< open $uid:name$>>
;;    

let gen_module_open_s loc mn ns =
    let name = "caml_namespace___" ^ (gen_ns_name_s ns) ^ "__module___" ^ mn in
    rename_module := (fun loc -> <:str_item< module $uid:mn$ = $uid:name$>>);    
    <:str_item< open $uid:name$>>
;;    

let gen_module_use loc ns =
    let name = (gen_mod_name ns) in
    <:str_item< open $uid:name$>>
;;    

let gen_module_use_s loc ns =
    let name = (gen_mod_name_s ns) in
    <:str_item< open $uid:name$>>
;;    

let gen_module_open_as loc mn ns asn =
    let name = "caml_namespace___" ^ (gen_ns_name ns) ^ "__module___" ^ mn in
    rename_module := (fun loc -> <:str_item< module $uid:asn$ = $uid:name$>>);    
    <:str_item< open $uid:name$>>
;;    

let gen_module_open_as_s loc mn ns asn =
    let name = "caml_namespace___" ^ (gen_ns_name_s ns) ^ "__module___" ^ mn in
    rename_module := (fun loc -> <:str_item< module $uid:asn$ = $uid:name$>>);    
    <:str_item< open $uid:name$>>
;;    

let gen_module_sig loc mn ns mt =
    let name = "caml_namespace___" ^ (gen_ns_name ns) ^ "__module___" ^ mn in
    <:sig_item< module $uid:name$ : $mt$ >>
;;    

let gen_module_sig_s loc mn ns mt =
    let name = "caml_namespace___" ^ (gen_ns_name_s ns) ^ "__module___" ^ mn in
    <:sig_item< module $uid:name$ : $mt$ >>
;;    

EXTEND

  mod_ident:
    [ RIGHTA
      [ i = UIDENT -> [i]
      | i = LIDENT -> [i]
      | i = UIDENT; "."; j = SELF -> i :: j ] ]
  ;

  module_binding:
    [ RIGHTA
      [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF ->
          <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >>
      | ":"; mt = module_type; "="; me = module_expr ->
          <:module_expr< ( $me$ : $mt$ ) >>
      | "="; me = module_expr -> <:module_expr< $me$ >> ] ]
  ;

  str_item: LEVEL "top"
  [
    [ "module"; i = UIDENT; "in" ; ns = mod_ident ; 
       me = module_binding ->
      gen_module loc i ns me
     |
      "module"; i = UIDENT; "in" ; ns = STRING ; 
       me = module_binding ->
      gen_module_s loc i ns me
     |
     "module";"type"; i = UIDENT; "in" ; ns = mod_ident ; "=";
       mt = module_type ->
      gen_module_type loc i ns mt
     |
     "module";"type"; i = UIDENT; "in" ; ns = STRING ; "=";
       mt = module_type ->
      gen_module_type_s loc i ns mt
     | 
     "open"; i = UIDENT; "in" ; ns = mod_ident ->
      gen_module_open loc i ns ; !rename_module loc
     | 
     "open"; i = UIDENT; "in" ; ns = STRING ->
      gen_module_open_s loc i ns ; !rename_module loc
     | 
     "open"; i = UIDENT; "in" ; ns = mod_ident ; "as" ; asn = UIDENT ->
      gen_module_open_as loc i ns asn; !rename_module loc
     | 
     "open"; i = UIDENT; "in" ; ns = STRING ; "as" ; asn = UIDENT ->
      gen_module_open_as_s loc i ns asn; !rename_module loc
     | 
     "use"; ns = mod_ident  ->
      gen_module_use loc ns
     | 
     "use"; ns = STRING  ->
      gen_module_use_s loc ns
    ]

  ];

  sig_item: LEVEL "top"
  [
    [ "module"; i = UIDENT; "in" ; ns = mod_ident ; ":" ; mt = module_type ->
      gen_module_sig loc i ns mt
     |
      "module"; i = UIDENT; "in" ; ns = STRING ; ":" ; mt = module_type ->
      gen_module_sig_s loc i ns mt
    ]

  ];

END
;