24 -> ((string -> string) * (string -> string)) option |
25 -> ((string -> string) * (string -> string)) option |
25 -> int * string -> CodegenThingol.iterm pretty_syntax; |
26 -> int * string -> CodegenThingol.iterm pretty_syntax; |
26 val pretty_ml_string: string -> string -> (string -> string) -> (string -> string) |
27 val pretty_ml_string: string -> string -> (string -> string) -> (string -> string) |
27 -> string -> CodegenThingol.iterm pretty_syntax; |
28 -> string -> CodegenThingol.iterm pretty_syntax; |
28 val serializers: { |
29 val serializers: { |
29 ml: string * (string -> serializer), |
30 SML: string * (string -> serializer), |
30 haskell: string * (string * string list -> serializer) |
31 Haskell: string * (string * string list -> serializer) |
31 }; |
32 }; |
32 val mk_flat_ml_resolver: string list -> string -> string; |
33 val mk_flat_ml_resolver: string list -> string -> string; |
33 val eval_term: string -> string -> string list list |
34 val eval_term: string -> string -> string list list |
34 -> (string -> CodegenThingol.itype pretty_syntax option) |
35 -> (string -> CodegenThingol.itype pretty_syntax option) |
35 * (string -> CodegenThingol.iterm pretty_syntax option) |
36 * (string -> CodegenThingol.iterm pretty_syntax option) |
175 case parse_mixfix reader s ctxt |
176 case parse_mixfix reader s ctxt |
176 of ([Pretty _], _) => |
177 of ([Pretty _], _) => |
177 error ("Mixfix contains just one pretty element; either declare as " |
178 error ("Mixfix contains just one pretty element; either declare as " |
178 ^ quote atomK ^ " or consider adding a break") |
179 ^ quote atomK ^ " or consider adding a break") |
179 | x => x; |
180 | x => x; |
180 val parse = OuterParse.$$$ "(" |-- ( |
181 val parse = ( |
181 OuterParse.$$$ infixK |-- OuterParse.nat |
182 OuterParse.$$$ infixK |-- OuterParse.nat |
182 >> (fn i => (parse_infix (INFX (i, X)), INFX (i, X))) |
183 >> (fn i => (parse_infix (INFX (i, X)), INFX (i, X))) |
183 || OuterParse.$$$ infixlK |-- OuterParse.nat |
184 || OuterParse.$$$ infixlK |-- OuterParse.nat |
184 >> (fn i => (parse_infix (INFX (i, L)), INFX (i, L))) |
185 >> (fn i => (parse_infix (INFX (i, L)), INFX (i, L))) |
185 || OuterParse.$$$ infixrK |-- OuterParse.nat |
186 || OuterParse.$$$ infixrK |-- OuterParse.nat |
186 >> (fn i => (parse_infix (INFX (i, R)), INFX (i, R))) |
187 >> (fn i => (parse_infix (INFX (i, R)), INFX (i, R))) |
187 || OuterParse.$$$ atomK |-- pair (parse_mixfix reader, NOBR) |
188 || OuterParse.$$$ atomK |-- pair (parse_mixfix reader, NOBR) |
188 || pair (parse_nonatomic, BR) |
189 || pair (parse_nonatomic, BR) |
189 ) -- OuterParse.string --| OuterParse.$$$ ")" >> (fn ((p, fxy), s) => (p s, fxy)); |
190 ) -- OuterParse.string >> (fn ((p, fxy), s) => (p s, fxy)); |
190 fun mk fixity mfx ctxt = |
191 fun mk fixity mfx ctxt = |
191 let |
192 let |
192 val i = (length o List.filter is_arg) mfx; |
193 val i = (length o List.filter is_arg) mfx; |
193 val _ = if i > num_args ctxt then error "Too many arguments in codegen syntax" else (); |
194 val _ = if i > num_args ctxt then error "Too many arguments in codegen syntax" else (); |
194 in (((i, i), fillin_mixfix fixity mfx), ctxt) end; |
195 in (((i, i), fillin_mixfix fixity mfx), ctxt) end; |
425 | from_lookup fxy ls p = |
426 | from_lookup fxy ls p = |
426 brackify fxy [ |
427 brackify fxy [ |
427 Pretty.enum " o" "(" ")" (map from_label ls), |
428 Pretty.enum " o" "(" ")" (map from_label ls), |
428 p |
429 p |
429 ]; |
430 ]; |
430 fun from_classlookup fxy (Instance (inst, lss)) = |
431 fun from_inst fxy (Instance (inst, lss)) = |
431 brackify fxy ( |
432 brackify fxy ( |
432 (str o resolv) inst |
433 (str o resolv) inst |
433 :: map (ml_from_sortlookup BR) lss |
434 :: map (ml_from_insts BR) lss |
434 ) |
435 ) |
435 | from_classlookup fxy (Lookup (classes, (v, ~1))) = |
436 | from_inst fxy (Context (classes, (v, ~1))) = |
436 from_lookup BR classes |
437 from_lookup BR classes |
437 ((str o ml_from_dictvar) v) |
438 ((str o ml_from_dictvar) v) |
438 | from_classlookup fxy (Lookup (classes, (v, i))) = |
439 | from_inst fxy (Context (classes, (v, i))) = |
439 from_lookup BR (string_of_int (i+1) :: classes) |
440 from_lookup BR (string_of_int (i+1) :: classes) |
440 ((str o ml_from_dictvar) v) |
441 ((str o ml_from_dictvar) v) |
441 in case lss |
442 in case lss |
442 of [] => str "()" |
443 of [] => str "()" |
443 | [ls] => from_classlookup fxy ls |
444 | [ls] => from_inst fxy ls |
444 | lss => (Pretty.list "(" ")" o map (from_classlookup NOBR)) lss |
445 | lss => (Pretty.list "(" ")" o map (from_inst NOBR)) lss |
445 end; |
446 end; |
446 fun ml_from_tycoexpr fxy (tyco, tys) = |
447 fun ml_from_tycoexpr fxy (tyco, tys) = |
447 let |
448 let |
448 val tyco' = (str o resolv) tyco |
449 val tyco' = (str o resolv) tyco |
449 in case map (ml_from_type BR) tys |
450 in case map (ml_from_type BR) tys |
549 if is_cons f andalso length es > 1 then |
550 if is_cons f andalso length es > 1 then |
550 [(str o resolv) f, Pretty.enum "," "(" ")" (map (ml_from_expr BR) es)] |
551 [(str o resolv) f, Pretty.enum "," "(" ")" (map (ml_from_expr BR) es)] |
551 else |
552 else |
552 (str o resolv) f :: map (ml_from_expr BR) es |
553 (str o resolv) f :: map (ml_from_expr BR) es |
553 and ml_from_app fxy (app_expr as ((c, (lss, ty)), es)) = |
554 and ml_from_app fxy (app_expr as ((c, (lss, ty)), es)) = |
554 case map (ml_from_sortlookup BR) lss |
555 case (map (ml_from_insts BR) o filter_out null) lss |
555 of [] => |
556 of [] => |
556 from_app ml_mk_app ml_from_expr const_syntax fxy app_expr |
557 from_app ml_mk_app ml_from_expr const_syntax fxy app_expr |
557 | lss => |
558 | lss => |
558 brackify fxy ( |
559 if (is_none o const_syntax) c then |
559 (str o resolv) c |
560 brackify fxy ( |
560 :: (lss |
561 (str o resolv) c |
561 @ map (ml_from_expr BR) es) |
562 :: (lss |
562 ); |
563 @ map (ml_from_expr BR) es) |
563 in (ml_from_label, ml_from_tyvar, ml_from_sortlookup, ml_from_tycoexpr, ml_from_type, ml_from_expr) end; |
564 ) |
|
565 else error ("Can't apply user defined serilization for function expecting dicitonaries: " ^ quote c) |
|
566 in (ml_from_label, ml_from_tyvar, ml_from_insts, ml_from_tycoexpr, ml_from_type, ml_from_expr) end; |
564 |
567 |
565 fun ml_fun_datatyp is_cons (tyco_syntax, const_syntax) resolv = |
568 fun ml_fun_datatyp is_cons (tyco_syntax, const_syntax) resolv = |
566 let |
569 let |
567 val (ml_from_label, ml_from_tyvar, ml_from_sortlookup, ml_from_tycoexpr, ml_from_type, ml_from_expr) = |
570 val (ml_from_label, ml_from_tyvar, ml_from_insts, ml_from_tycoexpr, ml_from_type, ml_from_expr) = |
568 ml_expr_seri is_cons (tyco_syntax, const_syntax) resolv; |
571 ml_expr_seri is_cons (tyco_syntax, const_syntax) resolv; |
569 fun chunk_defs ps = |
572 fun chunk_defs ps = |
570 let |
573 let |
571 val (p_init, p_last) = split_last ps |
574 val (p_init, p_last) = split_last ps |
572 in |
575 in |
573 Pretty.chunks (p_init @ [Pretty.block ([p_last, str ";"])]) |
576 Pretty.chunks (p_init @ [Pretty.block ([p_last, str ";"])]) |
574 end; |
577 end; |
575 fun eta_expand_poly_fun (funn as (_, (_::_, _))) = |
578 fun eta_expand_poly_fun (funn as (_, (_::_, _))) = |
576 funn |
579 funn |
577 | eta_expand_poly_fun (funn as (eqs, sctxt_ty as (_, ty))) = |
580 | eta_expand_poly_fun (funn as (eqs, tysm as (_, ty))) = |
578 let |
581 let |
579 fun no_eta (_::_, _) = I |
582 fun no_eta (_::_, _) = I |
580 | no_eta (_, _ `|-> _) = I |
583 | no_eta (_, _ `|-> _) = I |
581 | no_eta ([], e) = K false; |
584 | no_eta ([], e) = K false; |
582 fun has_tyvars (_ `%% tys) = |
585 fun has_tyvars (_ `%% tys) = |
587 has_tyvars ty1 orelse has_tyvars ty2; |
590 has_tyvars ty1 orelse has_tyvars ty2; |
588 in if (null o fst o CodegenThingol.unfold_fun) ty |
591 in if (null o fst o CodegenThingol.unfold_fun) ty |
589 orelse (not o has_tyvars) ty |
592 orelse (not o has_tyvars) ty |
590 orelse fold no_eta eqs true |
593 orelse fold no_eta eqs true |
591 then funn |
594 then funn |
592 else (map (fn ([], rhs) => ([IVar "x"], rhs `$ IVar "x")) eqs, sctxt_ty) |
595 else (map (fn ([], rhs) => ([IVar "x"], rhs `$ IVar "x")) eqs, tysm) |
593 end; |
596 end; |
594 fun ml_from_funs (defs as def::defs_tl) = |
597 fun ml_from_funs (defs as def::defs_tl) = |
595 let |
598 let |
596 fun mk_definer [] [] = "val" |
599 fun mk_definer [] [] = "val" |
597 | mk_definer _ _ = "fun"; |
600 | mk_definer (_::_) _ = "fun" |
598 fun check_args (_, ((pats, _)::_, (sortctxt, _))) NONE = |
601 | mk_definer [] vs = if (null o filter_out (null o snd)) vs then "val" else "fun"; |
599 SOME (mk_definer pats sortctxt) |
602 fun check_args (_, ((pats, _)::_, (vs, _))) NONE = |
600 | check_args (_, ((pats, _)::_, (sortctxt, _))) (SOME definer) = |
603 SOME (mk_definer pats vs) |
601 if mk_definer pats sortctxt = definer |
604 | check_args (_, ((pats, _)::_, (vs, _))) (SOME definer) = |
|
605 if mk_definer pats vs = definer |
602 then SOME definer |
606 then SOME definer |
603 else error ("Mixing simultaneous vals and funs not implemented"); |
607 else error ("Mixing simultaneous vals and funs not implemented"); |
604 fun mk_fun definer (name, (eqs as eq::eq_tl, (sortctxt, ty))) = |
608 fun mk_fun definer (name, (eqs as eq::eq_tl, (raw_vs, ty))) = |
605 let |
609 let |
|
610 val vs = filter_out (null o snd) raw_vs; |
606 val shift = if null eq_tl then I else |
611 val shift = if null eq_tl then I else |
607 map (Pretty.block o single o Pretty.block o single); |
612 map (Pretty.block o single o Pretty.block o single); |
608 fun mk_arg e ty = |
|
609 ml_from_expr BR e |
|
610 fun mk_eq definer (pats, expr) = |
613 fun mk_eq definer (pats, expr) = |
611 (Pretty.block o Pretty.breaks) ( |
614 (Pretty.block o Pretty.breaks) ( |
612 [str definer, (str o resolv) name] |
615 [str definer, (str o resolv) name] |
613 @ (if null pats andalso null sortctxt |
616 @ (if null pats andalso null vs |
|
617 andalso not (ty = ITyVar "_")(*for evaluation*) |
614 then [str ":", ml_from_type NOBR ty] |
618 then [str ":", ml_from_type NOBR ty] |
615 else |
619 else |
616 map ml_from_tyvar sortctxt |
620 map ml_from_tyvar vs |
617 @ map2 mk_arg pats |
621 @ map (ml_from_expr BR) pats) |
618 ((curry Library.take (length pats) o fst o CodegenThingol.unfold_fun) ty)) |
|
619 @ [str "=", ml_from_expr NOBR expr] |
622 @ [str "=", ml_from_expr NOBR expr] |
620 ) |
623 ) |
621 in |
624 in |
622 (Pretty.block o Pretty.fbreaks o shift) ( |
625 (Pretty.block o Pretty.fbreaks o shift) ( |
623 mk_eq definer eq |
626 mk_eq definer eq |
659 |
662 |
660 fun ml_from_defs is_cons |
663 fun ml_from_defs is_cons |
661 (_, tyco_syntax, const_syntax) resolver prefix defs = |
664 (_, tyco_syntax, const_syntax) resolver prefix defs = |
662 let |
665 let |
663 val resolv = resolver prefix; |
666 val resolv = resolver prefix; |
664 val (ml_from_label, ml_from_tyvar, ml_from_sortlookup, ml_from_tycoexpr, ml_from_type, ml_from_expr) = |
667 val (ml_from_label, ml_from_tyvar, ml_from_insts, ml_from_tycoexpr, ml_from_type, ml_from_expr) = |
665 ml_expr_seri is_cons (tyco_syntax, const_syntax) resolv; |
668 ml_expr_seri is_cons (tyco_syntax, const_syntax) resolv; |
666 val (ml_from_funs, ml_from_datatypes) = |
669 val (ml_from_funs, ml_from_datatypes) = |
667 ml_fun_datatyp is_cons (tyco_syntax, const_syntax) resolv; |
670 ml_fun_datatyp is_cons (tyco_syntax, const_syntax) resolv; |
668 val filter_datatype = |
671 val filter_datatype = |
669 map_filter |
672 map_filter |
833 val serializer = ml_serializer struct_name "ml" nsp_dtcon nspgrp |
836 val serializer = ml_serializer struct_name "ml" nsp_dtcon nspgrp |
834 (fn "" => (fn p => (use_text Context.ml_output (!eval_verbose) (output p); NONE)) |
837 (fn "" => (fn p => (use_text Context.ml_output (!eval_verbose) (output p); NONE)) |
835 | _ => SOME) (K NONE, syntax_tyco, syntax_const) (hidden, SOME [NameSpace.pack [nsp_eval, val_name]]); |
838 | _ => SOME) (K NONE, syntax_tyco, syntax_const) (hidden, SOME [NameSpace.pack [nsp_eval, val_name]]); |
836 val _ = serializer modl'; |
839 val _ = serializer modl'; |
837 val val_name_struct = NameSpace.append struct_name val_name; |
840 val val_name_struct = NameSpace.append struct_name val_name; |
838 val _ = use_text Context.ml_output (!eval_verbose) ("val _ = (" ^ ref_name ^ " := " ^ val_name_struct ^ "())"); |
841 val _ = use_text Context.ml_output (!eval_verbose) ("val _ = (" ^ ref_name ^ " := " ^ val_name_struct ^ ")"); |
839 val value = ! reff; |
842 val value = ! reff; |
840 in value end; |
843 in value end; |
841 |
844 |
842 fun mk_flat_ml_resolver names = |
845 fun mk_flat_ml_resolver names = |
843 let |
846 let |
868 fun hs_from_classop_name cls clsop = case class_syntax cls |
871 fun hs_from_classop_name cls clsop = case class_syntax cls |
869 of NONE => NameSpace.base clsop |
872 of NONE => NameSpace.base clsop |
870 | SOME (_, classop_syntax) => case classop_syntax clsop |
873 | SOME (_, classop_syntax) => case classop_syntax clsop |
871 of NONE => NameSpace.base clsop |
874 of NONE => NameSpace.base clsop |
872 | SOME clsop => clsop; |
875 | SOME clsop => clsop; |
873 fun hs_from_sctxt vs = |
876 fun hs_from_typparms vs = |
874 let |
877 let |
875 fun from_sctxt [] = str "" |
878 fun from_typparms [] = str "" |
876 | from_sctxt vs = |
879 | from_typparms vs = |
877 vs |
880 vs |
878 |> map (fn (v, cls) => str (hs_from_class cls ^ " " ^ v)) |
881 |> map (fn (v, cls) => str (hs_from_class cls ^ " " ^ v)) |
879 |> Pretty.enum "," "(" ")" |
882 |> Pretty.enum "," "(" ")" |
880 |> (fn p => Pretty.block [p, str " => "]) |
883 |> (fn p => Pretty.block [p, str " => "]) |
881 in |
884 in |
882 vs |
885 vs |
883 |> map (fn (v, sort) => map (pair v) sort) |
886 |> map (fn (v, sort) => map (pair v) sort) |
884 |> flat |
887 |> flat |
885 |> from_sctxt |
888 |> from_typparms |
886 end; |
889 end; |
887 fun hs_from_tycoexpr fxy (tyco, tys) = |
890 fun hs_from_tycoexpr fxy (tyco, tys) = |
888 brackify fxy (str tyco :: map (hs_from_type BR) tys) |
891 brackify fxy (str tyco :: map (hs_from_type BR) tys) |
889 and hs_from_type fxy (tycoexpr as tyco `%% tys) = |
892 and hs_from_type fxy (tycoexpr as tyco `%% tys) = |
890 (case tyco_syntax tyco |
893 (case tyco_syntax tyco |
903 str "->", |
906 str "->", |
904 hs_from_type (INFX (1, R)) t2 |
907 hs_from_type (INFX (1, R)) t2 |
905 ] |
908 ] |
906 | hs_from_type fxy (ITyVar v) = |
909 | hs_from_type fxy (ITyVar v) = |
907 str v; |
910 str v; |
908 fun hs_from_sctxt_tycoexpr (sctxt, tycoexpr) = |
911 fun hs_from_typparms_tycoexpr (vs, tycoexpr) = |
909 Pretty.block [hs_from_sctxt sctxt, hs_from_tycoexpr NOBR tycoexpr] |
912 Pretty.block [hs_from_typparms vs, hs_from_tycoexpr NOBR tycoexpr] |
910 fun hs_from_sctxt_type (sctxt, ty) = |
913 fun hs_from_typparms_type (vs, ty) = |
911 Pretty.block [hs_from_sctxt sctxt, hs_from_type NOBR ty] |
914 Pretty.block [hs_from_typparms vs, hs_from_type NOBR ty] |
912 fun hs_from_expr fxy (e as IConst x) = |
915 fun hs_from_expr fxy (e as IConst x) = |
913 hs_from_app fxy (x, []) |
916 hs_from_app fxy (x, []) |
914 | hs_from_expr fxy (e as (e1 `$ e2)) = |
917 | hs_from_expr fxy (e as (e1 `$ e2)) = |
915 (case CodegenThingol.unfold_const_app e |
918 (case CodegenThingol.unfold_const_app e |
916 of SOME x => hs_from_app fxy x |
919 of SOME x => hs_from_app fxy x |
984 str ("="), |
987 str ("="), |
985 Pretty.brk 1, |
988 Pretty.brk 1, |
986 hs_from_expr NOBR rhs |
989 hs_from_expr NOBR rhs |
987 ] |
990 ] |
988 in Pretty.chunks ((map from_eq o fst o snd o constructive_fun is_cons) def) end; |
991 in Pretty.chunks ((map from_eq o fst o snd o constructive_fun is_cons) def) end; |
989 fun hs_from_def (name, CodegenThingol.Fun (def as (_, (sctxt, ty)))) = |
992 fun hs_from_def (name, CodegenThingol.Fun (def as (_, (vs, ty)))) = |
990 let |
993 let |
991 val body = hs_from_funeqs (name, def); |
994 val body = hs_from_funeqs (name, def); |
992 in if with_typs then |
995 in if with_typs then |
993 Pretty.chunks [ |
996 Pretty.chunks [ |
994 Pretty.block [ |
997 Pretty.block [ |
995 (str o suffix " ::" o resolv_here) name, |
998 (str o suffix " ::" o resolv_here) name, |
996 Pretty.brk 1, |
999 Pretty.brk 1, |
997 hs_from_sctxt_type (sctxt, ty) |
1000 hs_from_typparms_type (vs, ty) |
998 ], |
1001 ], |
999 body |
1002 body |
1000 ] |> SOME |
1003 ] |> SOME |
1001 else SOME body end |
1004 else SOME body end |
1002 | hs_from_def (name, CodegenThingol.Typesyn (sctxt, ty)) = |
1005 | hs_from_def (name, CodegenThingol.Typesyn (vs, ty)) = |
1003 (Pretty.block o Pretty.breaks) [ |
1006 (Pretty.block o Pretty.breaks) [ |
1004 str "type", |
1007 str "type", |
1005 hs_from_sctxt_tycoexpr (sctxt, (resolv_here name, map (ITyVar o fst) sctxt)), |
1008 hs_from_typparms_tycoexpr (vs, (resolv_here name, map (ITyVar o fst) vs)), |
1006 str "=", |
1009 str "=", |
1007 hs_from_sctxt_type ([], ty) |
1010 hs_from_typparms_type ([], ty) |
1008 ] |> SOME |
1011 ] |> SOME |
1009 | hs_from_def (name, CodegenThingol.Datatype (sctxt, [(co, [ty])])) = |
1012 | hs_from_def (name, CodegenThingol.Datatype (vs, [(co, [ty])])) = |
1010 (Pretty.block o Pretty.breaks) [ |
1013 (Pretty.block o Pretty.breaks) [ |
1011 str "newtype", |
1014 str "newtype", |
1012 hs_from_sctxt_tycoexpr (sctxt, (resolv_here name, map (ITyVar o fst) sctxt)), |
1015 hs_from_typparms_tycoexpr (vs, (resolv_here name, map (ITyVar o fst) vs)), |
1013 str "=", |
1016 str "=", |
1014 (str o resolv_here) co, |
1017 (str o resolv_here) co, |
1015 hs_from_type BR ty |
1018 hs_from_type BR ty |
1016 ] |> SOME |
1019 ] |> SOME |
1017 | hs_from_def (name, CodegenThingol.Datatype (sctxt, constrs)) = |
1020 | hs_from_def (name, CodegenThingol.Datatype (vs, constrs)) = |
1018 let |
1021 let |
1019 fun mk_cons (co, tys) = |
1022 fun mk_cons (co, tys) = |
1020 (Pretty.block o Pretty.breaks) ( |
1023 (Pretty.block o Pretty.breaks) ( |
1021 (str o resolv_here) co |
1024 (str o resolv_here) co |
1022 :: map (hs_from_type BR) tys |
1025 :: map (hs_from_type BR) tys |
1023 ) |
1026 ) |
1024 in |
1027 in |
1025 (Pretty.block o Pretty.breaks) [ |
1028 (Pretty.block o Pretty.breaks) [ |
1026 str "data", |
1029 str "data", |
1027 hs_from_sctxt_tycoexpr (sctxt, (resolv_here name, map (ITyVar o fst) sctxt)), |
1030 hs_from_typparms_tycoexpr (vs, (resolv_here name, map (ITyVar o fst) vs)), |
1028 str "=", |
1031 str "=", |
1029 Pretty.block (separate (Pretty.block [Pretty.brk 1, str "| "]) (map mk_cons constrs)) |
1032 Pretty.block (separate (Pretty.block [Pretty.brk 1, str "| "]) (map mk_cons constrs)) |
1030 ] |
1033 ] |
1031 end |> SOME |
1034 end |> SOME |
1032 | hs_from_def (_, CodegenThingol.Datatypecons _) = |
1035 | hs_from_def (_, CodegenThingol.Datatypecons _) = |
1033 NONE |
1036 NONE |
1034 | hs_from_def (name, CodegenThingol.Class (supclasss, (v, membrs))) = |
1037 | hs_from_def (name, CodegenThingol.Class (supclasss, (v, membrs))) = |
1035 let |
1038 let |
1036 fun mk_member (m, (sctxt, ty)) = |
1039 fun mk_member (m, ty) = |
1037 Pretty.block [ |
1040 Pretty.block [ |
1038 str (resolv_here m ^ " ::"), |
1041 str (resolv_here m ^ " ::"), |
1039 Pretty.brk 1, |
1042 Pretty.brk 1, |
1040 hs_from_sctxt_type (sctxt, ty) |
1043 hs_from_type NOBR ty |
1041 ] |
1044 ] |
1042 in |
1045 in |
1043 Pretty.block [ |
1046 Pretty.block [ |
1044 str "class ", |
1047 str "class ", |
1045 hs_from_sctxt [(v, supclasss)], |
1048 hs_from_typparms [(v, supclasss)], |
1046 str (resolv_here name ^ " " ^ v), |
1049 str (resolv_here name ^ " " ^ v), |
1047 str " where", |
1050 str " where", |
1048 Pretty.fbrk, |
1051 Pretty.fbrk, |
1049 Pretty.chunks (map mk_member membrs) |
1052 Pretty.chunks (map mk_member membrs) |
1050 ] |> SOME |
1053 ] |> SOME |
1052 | hs_from_def (_, CodegenThingol.Classmember _) = |
1055 | hs_from_def (_, CodegenThingol.Classmember _) = |
1053 NONE |
1056 NONE |
1054 | hs_from_def (_, CodegenThingol.Classinst ((clsname, (tyco, arity)), (_, memdefs))) = |
1057 | hs_from_def (_, CodegenThingol.Classinst ((clsname, (tyco, arity)), (_, memdefs))) = |
1055 Pretty.block [ |
1058 Pretty.block [ |
1056 str "instance ", |
1059 str "instance ", |
1057 hs_from_sctxt arity, |
1060 hs_from_typparms arity, |
1058 str (hs_from_class clsname ^ " "), |
1061 str (hs_from_class clsname ^ " "), |
1059 hs_from_type BR (tyco `%% map (ITyVar o fst) arity), |
1062 hs_from_type BR (tyco `%% map (ITyVar o fst) arity), |
1060 str " where", |
1063 str " where", |
1061 Pretty.fbrk, |
1064 Pretty.fbrk, |
1062 Pretty.chunks (map (fn (m, e) => |
1065 Pretty.chunks (map (fn (m, e) => |