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" |