src/Tools/Code/code_scala.ML
changeset 39147 3c284a152bd6
parent 39102 4ae1d212100f
child 39148 b6530978c14d
equal deleted inserted replaced
39145:154fd9c06c63 39147:3c284a152bd6
   332     module_alias, class_syntax, tyco_syntax, const_syntax, program,
   332     module_alias, class_syntax, tyco_syntax, const_syntax, program,
   333     names } =
   333     names } =
   334   let
   334   let
   335 
   335 
   336     (* build program *)
   336     (* build program *)
   337     val { deresolver, hierarchical_program = sca_program } =
   337     val { deresolver, hierarchical_program = scala_program } =
   338       scala_program_of_program labelled_name (Name.make_context reserved_syms) module_alias program;
   338       scala_program_of_program labelled_name (Name.make_context reserved_syms) module_alias program;
   339 
   339 
   340     (* print statements *)
   340     (* print statements *)
   341     fun lookup_constr tyco constr = case Graph.get_node program tyco
   341     fun lookup_constr tyco constr = case Graph.get_node program tyco
   342      of Code_Thingol.Datatype (_, (_, constrs)) =>
   342      of Code_Thingol.Datatype (_, (_, constrs)) =>
   352           (length o fst o Code_Thingol.unfold_fun o the o AList.lookup (op =)
   352           (length o fst o Code_Thingol.unfold_fun o the o AList.lookup (op =)
   353             (classparams_of_class class)) c;
   353             (classparams_of_class class)) c;
   354     fun is_singleton_constr c = case Graph.get_node program c
   354     fun is_singleton_constr c = case Graph.get_node program c
   355      of Code_Thingol.Datatypecons (_, tyco) => null (lookup_constr tyco c)
   355      of Code_Thingol.Datatypecons (_, tyco) => null (lookup_constr tyco c)
   356       | _ => false;
   356       | _ => false;
   357     val print_stmt = print_scala_stmt labelled_name tyco_syntax const_syntax
   357     fun print_stmt prefix_fragments = print_scala_stmt labelled_name
   358       (make_vars reserved_syms) args_num is_singleton_constr;
   358       tyco_syntax const_syntax (make_vars reserved_syms) args_num
   359 
   359       is_singleton_constr (deresolver prefix_fragments, deresolver []);
   360     (* print nodes *)
   360 
   361     fun print_module base implicit_ps p = Pretty.chunks2
   361     (* print modules *)
   362       ([str ("object " ^ base ^ " {")]
       
   363         @ (if null implicit_ps then [] else (single o Pretty.block)
       
   364             (str "import /*implicits*/" :: Pretty.brk 1 :: commas implicit_ps))
       
   365         @ [p, str ("} /* object " ^ base ^ " */")]);
       
   366     fun print_implicit prefix_fragments implicit =
   362     fun print_implicit prefix_fragments implicit =
   367       let
   363       let
   368         val s = deresolver prefix_fragments implicit;
   364         val s = deresolver prefix_fragments implicit;
   369       in if length (Long_Name.explode s) = 1 then NONE else SOME (str s) end;
   365       in if length (Long_Name.explode s) = 1 then NONE else SOME (str s) end;
   370     fun print_node _ (_, Code_Namespace.Dummy) = NONE
   366     fun print_module prefix_fragments base implicits ps = Pretty.chunks2
   371       | print_node prefix_fragments (name, Code_Namespace.Stmt stmt) =
   367       ([str ("object " ^ base ^ " {")]
   372           SOME (markup_stmt name (print_stmt (deresolver prefix_fragments, deresolver []) (name, stmt)))
   368         @ (case map_filter (print_implicit prefix_fragments) implicits
   373       | print_node prefix_fragments (name_fragment, Code_Namespace.Module (implicits, nodes)) =
   369             of [] => [] | implicit_ps => (single o Pretty.block)
   374           let
   370             (str "import /*implicits*/" :: Pretty.brk 1 :: commas implicit_ps))
   375             val prefix_fragments' = prefix_fragments @ [name_fragment];
   371         @ ps @ [str ("} /* object " ^ base ^ " */")]);
   376           in
       
   377             Option.map (print_module name_fragment
       
   378               (map_filter (print_implicit prefix_fragments') implicits))
       
   379                 (print_nodes prefix_fragments' nodes)
       
   380           end
       
   381     and print_nodes prefix_fragments nodes = let
       
   382         val ps = map_filter (fn name => print_node prefix_fragments (name,
       
   383           snd (Graph.get_node nodes name)))
       
   384             ((rev o flat o Graph.strong_conn) nodes);
       
   385       in if null ps then NONE else SOME (Pretty.chunks2 ps) end;
       
   386 
   372 
   387     (* serialization *)
   373     (* serialization *)
   388     val p = Pretty.chunks2 (map snd includes @ the_list (print_nodes [] sca_program));
   374     val p = Pretty.chunks2 (map snd includes
       
   375       @ Code_Namespace.print_hierarchical {
       
   376         print_module = print_module, print_stmt = print_stmt,
       
   377         lift_markup = I } scala_program);
   389     fun write width NONE = writeln o format [] width
   378     fun write width NONE = writeln o format [] width
   390       | write width (SOME p) = File.write p o format [] width;
   379       | write width (SOME p) = File.write p o format [] width;
   391   in
   380   in
   392     Code_Target.serialization write (rpair (try (deresolver [])) ooo format) p
   381     Code_Target.serialization write (rpair (try (deresolver [])) ooo format) p
   393   end;
   382   end;