src/Tools/Code/code_ml.ML
changeset 55681 7714287dc044
parent 55679 59244fc1a7ca
child 55682 def6575032df
     1.1 --- a/src/Tools/Code/code_ml.ML	Sun Feb 23 10:33:43 2014 +0100
     1.2 +++ b/src/Tools/Code/code_ml.ML	Sun Feb 23 10:33:43 2014 +0100
     1.3 @@ -242,7 +242,7 @@
     1.4                @@ print_dicttyp (class, tyco `%% map (ITyVar o fst) vs)
     1.5              ))
     1.6            end;
     1.7 -    fun print_stmt (ML_Exc (const, (vs_ty, n))) = pair
     1.8 +    fun print_stmt _ (ML_Exc (const, (vs_ty, n))) = pair
     1.9            [print_val_decl print_typscheme (Constant const, vs_ty)]
    1.10            ((semicolon o map str) (
    1.11              (if n = 0 then "val" else "fun")
    1.12 @@ -253,14 +253,14 @@
    1.13              :: "Fail"
    1.14              @@ ML_Syntax.print_string const
    1.15            ))
    1.16 -      | print_stmt (ML_Val binding) =
    1.17 +      | print_stmt _ (ML_Val binding) =
    1.18            let
    1.19              val (sig_p, p) = print_def (K false) true "val" binding
    1.20            in pair
    1.21              [sig_p]
    1.22              (semicolon [p])
    1.23            end
    1.24 -      | print_stmt (ML_Funs (binding :: bindings, pseudo_funs)) =
    1.25 +      | print_stmt _ (ML_Funs (binding :: bindings, pseudo_funs)) =
    1.26            let
    1.27              val print_def' = print_def (member (op =) pseudo_funs) false;
    1.28              fun print_pseudo_fun sym = concat [
    1.29 @@ -277,24 +277,28 @@
    1.30              sig_ps
    1.31              (Pretty.chunks (ps @ semicolon [p] :: pseudo_ps))
    1.32            end
    1.33 -     | print_stmt (ML_Datas [(tyco, (vs, []))]) =
    1.34 +     | print_stmt _ (ML_Datas [(tyco, (vs, []))]) =
    1.35            let
    1.36              val ty_p = print_tyco_expr (Type_Constructor tyco, map ITyVar vs);
    1.37            in
    1.38              pair
    1.39              [concat [str "type", ty_p]]
    1.40 -            (concat [str "datatype", ty_p, str "=", str "EMPTY__"])
    1.41 +            (semicolon [str "datatype", ty_p, str "=", str "EMPTY__"])
    1.42            end
    1.43 -     | print_stmt (ML_Datas (data :: datas)) = 
    1.44 +     | print_stmt export (ML_Datas (data :: datas)) = 
    1.45            let
    1.46 -            val sig_ps = print_datatype_decl "datatype" data
    1.47 +            val decl_ps = print_datatype_decl "datatype" data
    1.48                :: map (print_datatype_decl "and") datas;
    1.49 -            val (ps, p) = split_last sig_ps;
    1.50 +            val (ps, p) = split_last decl_ps;
    1.51            in pair
    1.52 -            sig_ps
    1.53 +            (if Code_Namespace.is_public export
    1.54 +              then decl_ps
    1.55 +              else map (fn (tyco, (vs, _)) =>
    1.56 +                concat [str "type", print_tyco_expr (Type_Constructor tyco, map ITyVar vs)])
    1.57 +                (data :: datas))
    1.58              (Pretty.chunks (ps @| semicolon [p]))
    1.59            end
    1.60 -     | print_stmt (ML_Class (class, (v, (classrels, classparams)))) =
    1.61 +     | print_stmt export (ML_Class (class, (v, (classrels, classparams)))) =
    1.62            let
    1.63              fun print_field s p = concat [str s, str ":", p];
    1.64              fun print_proj s p = semicolon
    1.65 @@ -317,12 +321,14 @@
    1.66                  (print_typscheme ([(v, [class])], ty));
    1.67            in pair
    1.68              (concat [str "type", print_dicttyp (class, ITyVar v)]
    1.69 -              :: map print_super_class_decl classrels
    1.70 -              @ map print_classparam_decl classparams)
    1.71 +              :: (if Code_Namespace.is_public export
    1.72 +                 then map print_super_class_decl classrels
    1.73 +                   @ map print_classparam_decl classparams
    1.74 +                 else []))
    1.75              (Pretty.chunks (
    1.76                concat [
    1.77 -                str ("type '" ^ v),
    1.78 -                (str o deresolve_class) class,
    1.79 +                str "type",
    1.80 +                print_dicttyp (class, ITyVar v),
    1.81                  str "=",
    1.82                  enum "," "{" "};" (
    1.83                    map print_super_class_field classrels
    1.84 @@ -582,7 +588,7 @@
    1.85                ]
    1.86              ))
    1.87            end;
    1.88 -     fun print_stmt (ML_Exc (const, (vs_ty, n))) = pair
    1.89 +     fun print_stmt _ (ML_Exc (const, (vs_ty, n))) = pair
    1.90            [print_val_decl print_typscheme (Constant const, vs_ty)]
    1.91            ((doublesemicolon o map str) (
    1.92              "let"
    1.93 @@ -592,14 +598,14 @@
    1.94              :: "failwith"
    1.95              @@ ML_Syntax.print_string const
    1.96            ))
    1.97 -      | print_stmt (ML_Val binding) =
    1.98 +      | print_stmt _ (ML_Val binding) =
    1.99            let
   1.100              val (sig_p, p) = print_def (K false) true "let" binding
   1.101            in pair
   1.102              [sig_p]
   1.103              (doublesemicolon [p])
   1.104            end
   1.105 -      | print_stmt (ML_Funs (binding :: bindings, pseudo_funs)) =
   1.106 +      | print_stmt _ (ML_Funs (binding :: bindings, pseudo_funs)) =
   1.107            let
   1.108              val print_def' = print_def (member (op =) pseudo_funs) false;
   1.109              fun print_pseudo_fun sym = concat [
   1.110 @@ -616,24 +622,28 @@
   1.111              sig_ps
   1.112              (Pretty.chunks (ps @ doublesemicolon [p] :: pseudo_ps))
   1.113            end
   1.114 -     | print_stmt (ML_Datas [(tyco, (vs, []))]) =
   1.115 +     | print_stmt _ (ML_Datas [(tyco, (vs, []))]) =
   1.116            let
   1.117              val ty_p = print_tyco_expr (Type_Constructor tyco, map ITyVar vs);
   1.118            in
   1.119              pair
   1.120              [concat [str "type", ty_p]]
   1.121 -            (concat [str "type", ty_p, str "=", str "EMPTY__"])
   1.122 +            (doublesemicolon [str "type", ty_p, str "=", str "EMPTY__"])
   1.123            end
   1.124 -     | print_stmt (ML_Datas (data :: datas)) = 
   1.125 +     | print_stmt export (ML_Datas (data :: datas)) = 
   1.126            let
   1.127 -            val sig_ps = print_datatype_decl "type" data
   1.128 +            val decl_ps = print_datatype_decl "type" data
   1.129                :: map (print_datatype_decl "and") datas;
   1.130 -            val (ps, p) = split_last sig_ps;
   1.131 +            val (ps, p) = split_last decl_ps;
   1.132            in pair
   1.133 -            sig_ps
   1.134 +            (if Code_Namespace.is_public export
   1.135 +              then decl_ps
   1.136 +              else map (fn (tyco, (vs, _)) =>
   1.137 +                concat [str "type", print_tyco_expr (Type_Constructor tyco, map ITyVar vs)])
   1.138 +                (data :: datas))
   1.139              (Pretty.chunks (ps @| doublesemicolon [p]))
   1.140            end
   1.141 -     | print_stmt (ML_Class (class, (v, (classrels, classparams)))) =
   1.142 +     | print_stmt export (ML_Class (class, (v, (classrels, classparams)))) =
   1.143            let
   1.144              fun print_field s p = concat [str s, str ":", p];
   1.145              fun print_super_class_field (classrel as (_, super_class)) =
   1.146 @@ -705,7 +715,7 @@
   1.147  
   1.148  (** SML/OCaml generic part **)
   1.149  
   1.150 -fun ml_program_of_program ctxt module_name reserved identifiers program =
   1.151 +fun ml_program_of_program ctxt module_name reserved identifiers =
   1.152    let
   1.153      fun namify_const upper base (nsp_const, nsp_type) =
   1.154        let
   1.155 @@ -782,7 +792,7 @@
   1.156      Code_Namespace.hierarchical_program ctxt {
   1.157        module_name = module_name, reserved = reserved, identifiers = identifiers,
   1.158        empty_nsp = (reserved, reserved), namify_module = pair, namify_stmt = namify_stmt,
   1.159 -      cyclic_modules = false, empty_data = (), memorize_data = K I, modify_stmts = modify_stmts } program
   1.160 +      cyclic_modules = false, empty_data = (), memorize_data = K I, modify_stmts = modify_stmts }
   1.161    end;
   1.162  
   1.163  fun serialize_ml print_ml_module print_ml_stmt ctxt
   1.164 @@ -792,13 +802,14 @@
   1.165  
   1.166      (* build program *)
   1.167      val { deresolver, hierarchical_program = ml_program } =
   1.168 -      ml_program_of_program ctxt module_name (Name.make_context reserved_syms) identifiers program;
   1.169 +      ml_program_of_program ctxt module_name (Name.make_context reserved_syms)
   1.170 +        identifiers program;
   1.171  
   1.172      (* print statements *)
   1.173      fun print_stmt prefix_fragments (_, (export, stmt)) = print_ml_stmt
   1.174        tyco_syntax const_syntax (make_vars reserved_syms)
   1.175 -      (Code_Thingol.is_constr program) (deresolver prefix_fragments) stmt
   1.176 -      |> apfst (fn decl => if export then SOME decl else NONE);
   1.177 +      (Code_Thingol.is_constr program) (deresolver prefix_fragments) export stmt
   1.178 +      |> apfst (fn decl => if Code_Namespace.not_private export then SOME decl else NONE);
   1.179  
   1.180      (* print modules *)
   1.181      fun print_module _ base _ xs =