src/Tools/Code/code_haskell.ML
changeset 38926 24f82786cc57
parent 38924 fcd1d0457e27
child 38928 0e6f54c9d201
equal deleted inserted replaced
38925:ced825abdc1d 38926:24f82786cc57
   311     fun deresolver name = (fst o the o AList.lookup (op =) ((fst o snd o the
   311     fun deresolver name = (fst o the o AList.lookup (op =) ((fst o snd o the
   312       o Symtab.lookup hs_program) ((mk_name_module o fst o dest_name) name))) name
   312       o Symtab.lookup hs_program) ((mk_name_module o fst o dest_name) name))) name
   313       handle Option => error ("Unknown statement name: " ^ labelled_name name);
   313       handle Option => error ("Unknown statement name: " ^ labelled_name name);
   314   in (deresolver, hs_program) end;
   314   in (deresolver, hs_program) end;
   315 
   315 
   316 fun serialize_haskell module_prefix string_classes labelled_name
   316 fun serialize_haskell module_prefix string_classes { labelled_name,
   317     raw_reserved includes single_module module_alias
   317     reserved_syms, includes, single_module, module_alias,
   318     class_syntax tyco_syntax const_syntax program
   318     class_syntax, tyco_syntax, const_syntax, program,
   319     (stmt_names, presentation_stmt_names) =
   319     names, presentation_names } =
   320   let
   320   let
   321     val reserved = fold (insert (op =) o fst) includes raw_reserved;
   321     val reserved = fold (insert (op =) o fst) includes reserved_syms;
   322     val (deresolver, hs_program) = haskell_program_of_program labelled_name
   322     val (deresolver, hs_program) = haskell_program_of_program labelled_name
   323       module_prefix reserved module_alias program;
   323       module_prefix reserved module_alias program;
   324     val contr_classparam_typs = Code_Thingol.contr_classparam_typs program;
   324     val contr_classparam_typs = Code_Thingol.contr_classparam_typs program;
   325     fun deriving_show tyco =
   325     fun deriving_show tyco =
   326       let
   326       let
   366               (fn (name, (_, SOME stmt)) => SOME (print_stmt qualified (name, stmt))
   366               (fn (name, (_, SOME stmt)) => SOME (print_stmt qualified (name, stmt))
   367                 | (_, (_, NONE)) => NONE) stmts
   367                 | (_, (_, NONE)) => NONE) stmts
   368           );
   368           );
   369       in print_module module_name' content end;
   369       in print_module module_name' content end;
   370     fun serialize_module2 (_, (_, (stmts, _))) = Pretty.chunks2 (map_filter
   370     fun serialize_module2 (_, (_, (stmts, _))) = Pretty.chunks2 (map_filter
   371         (fn (name, (_, SOME stmt)) => if null presentation_stmt_names
   371         (fn (name, (_, SOME stmt)) => if null presentation_names
   372               orelse member (op =) presentation_stmt_names name
   372               orelse member (op =) presentation_names name
   373               then SOME (print_stmt false (name, stmt))
   373               then SOME (print_stmt false (name, stmt))
   374               else NONE
   374               else NONE
   375           | (_, (_, NONE)) => NONE) stmts);
   375           | (_, (_, NONE)) => NONE) stmts);
   376     val serialize_module =
   376     val serialize_module =
   377       if null presentation_stmt_names then serialize_module1 else pair "" o serialize_module2;
   377       if null presentation_names then serialize_module1 else pair "" o serialize_module2;
   378     fun write_module width (SOME destination) (modlname, content) =
   378     fun write_module width (SOME destination) (modlname, content) =
   379           let
   379           let
   380             val _ = File.check destination;
   380             val _ = File.check destination;
   381             val filename = case modlname
   381             val filename = case modlname
   382              of "" => Path.explode "Main.hs"
   382              of "" => Path.explode "Main.hs"