242 of NONE => error ("no primitive definition for " ^ quote name) |
242 of NONE => error ("no primitive definition for " ^ quote name) |
243 | SOME ps => (case map pr ps |
243 | SOME ps => (case map pr ps |
244 of [] => NONE |
244 of [] => NONE |
245 | ps => (SOME o Pretty.block) ps) |
245 | ps => (SOME o Pretty.block) ps) |
246 end; |
246 end; |
247 fun from_module' imps ((name_qual, name), defs) = |
247 fun from_module' resolv imps ((name_qual, name), defs) = |
248 from_module imps ((name_qual, name), defs) |> postprocess name_qual; |
248 from_module resolv imps ((name_qual, name), defs) |
|
249 |> postprocess (resolv name_qual); |
249 in |
250 in |
250 module |
251 module |
251 |> debug 3 (fn _ => "selecting submodule...") |
252 |> debug_msg (fn _ => "selecting submodule...") |
252 |> (if is_some select then (CodegenThingol.partof o the) select else I) |
253 |> (if is_some select then (CodegenThingol.project_module o the) select else I) |
253 |> debug 3 (fn _ => "preprocessing...") |
254 |> debug_msg (fn _ => "preprocessing...") |
254 |> preprocess |
255 |> preprocess |
255 |> debug 3 (fn _ => "serializing...") |
256 |> debug_msg (fn _ => "serializing...") |
256 |> CodegenThingol.serialize (from_defs (pretty_of_prim, (class_syntax : string -> string option, tyco_syntax, const_syntax))) |
257 |> CodegenThingol.serialize (from_defs (pretty_of_prim, (class_syntax : string -> string option, tyco_syntax, const_syntax))) |
257 from_module' validator postproc nspgrp name_root |
258 from_module' validator postproc nspgrp name_root |
258 |> K () |
259 |> K () |
259 end; |
260 end; |
260 |
261 |
550 ml_from_expr NOBR se, |
554 ml_from_expr NOBR se, |
551 str "=>", |
555 str "=>", |
552 ml_from_expr NOBR be |
556 ml_from_expr NOBR be |
553 ] |
557 ] |
554 in brackify fxy ( |
558 in brackify fxy ( |
555 str "case" |
559 str "(case" |
556 :: typify dty (ml_from_expr NOBR de) |
560 :: typify dty (ml_from_expr NOBR de) |
557 :: mk_clause "of" bse |
561 :: mk_clause "of" bse |
558 :: map (mk_clause "|") bses |
562 :: map (mk_clause "|") bses |
|
563 @ [str ")"] |
559 ) end |
564 ) end |
560 | ml_from_expr _ e = |
565 | ml_from_expr _ e = |
561 error ("dubious expression: " ^ (Pretty.output o CodegenThingol.pretty_iexpr) e) |
566 error ("dubious expression: " ^ (Pretty.output o CodegenThingol.pretty_iexpr) e) |
562 and ml_mk_app f es = |
567 and ml_mk_app f es = |
563 if is_cons f andalso length es > 1 then |
568 if is_cons f andalso length es > 1 then |
804 |
809 |
805 in |
810 in |
806 |
811 |
807 fun ml_from_thingol target (nsp_dtcon, nsp_class, is_int_tyco) nspgrp = |
812 fun ml_from_thingol target (nsp_dtcon, nsp_class, is_int_tyco) nspgrp = |
808 let |
813 let |
809 fun ml_from_module _ ((_, name), ps) = |
814 fun ml_from_module resolv _ ((_, name), ps) = |
810 Pretty.chunks ([ |
815 Pretty.chunks ([ |
811 str ("structure " ^ name ^ " = "), |
816 str ("structure " ^ name ^ " = "), |
812 str "struct", |
817 str "struct", |
813 str "" |
818 str "" |
814 ] @ separate (str "") ps @ [ |
819 ] @ separate (str "") ps @ [ |
830 let val l = AList.lookup (op =) cs s |> the |> length |
835 let val l = AList.lookup (op =) cs s |> the |> length |
831 in if l >= 2 then l else 0 end |
836 in if l >= 2 then l else 0 end |
832 else 0; |
837 else 0; |
833 fun preprocess const_syntax module = |
838 fun preprocess const_syntax module = |
834 module |
839 module |
835 |> debug 3 (fn _ => "eta-expanding...") |
840 |> debug_msg (fn _ => "eta-expanding...") |
836 |> CodegenThingol.eta_expand (eta_expander module const_syntax) |
841 |> CodegenThingol.eta_expand (eta_expander module const_syntax) |
837 |> debug 3 (fn _ => "eta-expanding polydefs...") |
842 |> debug_msg (fn _ => "eta-expanding polydefs...") |
838 |> CodegenThingol.eta_expand_poly |
843 |> CodegenThingol.eta_expand_poly |
839 |> debug 3 (fn _ => "unclashing expression/type variables...") |
844 (*|> debug 3 (fn _ => "unclashing expression/type variables...") |
840 |> CodegenThingol.unclash_vars_tvars; |
845 |> CodegenThingol.unclash_vars_tvars*); |
841 val parse_multi = |
846 val parse_multi = |
842 OuterParse.name |
847 OuterParse.name |
843 #-> (fn "dir" => |
848 #-> (fn "dir" => |
844 parse_multi_file |
849 parse_multi_file |
845 (K o SOME o str o suffix ";" o prefix "val _ = use " |
850 (K o SOME o str o suffix ";" o prefix "val _ = use " |
869 local |
874 local |
870 |
875 |
871 fun hs_from_defs with_typs (from_prim, (class_syntax, tyco_syntax, const_syntax)) |
876 fun hs_from_defs with_typs (from_prim, (class_syntax, tyco_syntax, const_syntax)) |
872 resolver prefix defs = |
877 resolver prefix defs = |
873 let |
878 let |
874 fun resolv s = if NameSpace.is_qualified s |
879 val resolv = resolver ""; |
875 then resolver "" s |
880 val resolv_here = resolver prefix; |
876 else if nth_string s 0 = "~" |
|
877 then enclose "(" ")" ("negate " ^ unprefix "~" s) |
|
878 else s; |
|
879 val resolv_here = (resolver o NameSpace.base) prefix; |
|
880 fun hs_from_sctxt vs = |
881 fun hs_from_sctxt vs = |
881 let |
882 let |
882 fun from_class cls = |
883 fun from_class cls = |
883 class_syntax cls |
884 class_syntax cls |
884 |> the_default (resolv cls) |
885 |> the_default (resolv cls) |
893 |> map (fn (v, sort) => map (pair v) sort) |
894 |> map (fn (v, sort) => map (pair v) sort) |
894 |> Library.flat |
895 |> Library.flat |
895 |> from_sctxt |
896 |> from_sctxt |
896 end; |
897 end; |
897 fun hs_from_tycoexpr fxy (tyco, tys) = |
898 fun hs_from_tycoexpr fxy (tyco, tys) = |
898 brackify fxy ((str o resolv) tyco :: map (hs_from_type BR) tys) |
899 brackify fxy (str tyco :: map (hs_from_type BR) tys) |
899 and hs_from_type fxy (tycoexpr as tyco `%% tys) = |
900 and hs_from_type fxy (tycoexpr as tyco `%% tys) = |
900 (case tyco_syntax tyco |
901 (case tyco_syntax tyco |
901 of NONE => |
902 of NONE => |
902 hs_from_tycoexpr fxy (tyco, tys) |
903 hs_from_tycoexpr fxy (resolv tyco, tys) |
903 | SOME ((i, k), pr) => |
904 | SOME ((i, k), pr) => |
904 if not (i <= length tys andalso length tys <= k) |
905 if not (i <= length tys andalso length tys <= k) |
905 then error ("number of argument mismatch in customary serialization: " |
906 then error ("number of argument mismatch in customary serialization: " |
906 ^ (string_of_int o length) tys ^ " given, " |
907 ^ (string_of_int o length) tys ^ " given, " |
907 ^ string_of_int i ^ " to " ^ string_of_int k |
908 ^ string_of_int i ^ " to " ^ string_of_int k |
942 hs_from_expr NOBR e |
943 hs_from_expr NOBR e |
943 ]) |
944 ]) |
944 end |
945 end |
945 | hs_from_expr fxy (INum ((n, ty), _)) = |
946 | hs_from_expr fxy (INum ((n, ty), _)) = |
946 brackify BR [ |
947 brackify BR [ |
947 (str o IntInf.toString) n, |
948 (str o (fn s => if nth_string s 0 = "~" |
|
949 then enclose "(" ")" ("negate " ^ unprefix "~" s) else s) o IntInf.toString) n, |
948 str "::", |
950 str "::", |
949 hs_from_type NOBR ty |
951 hs_from_type NOBR ty |
950 ] |
952 ] |
951 | hs_from_expr fxy (e as IAbs _) = |
953 | hs_from_expr fxy (e as IAbs _) = |
952 let |
954 let |
1097 "import", "default", "forall", "let", "in", "class", "qualified", "data", |
1099 "import", "default", "forall", "let", "in", "class", "qualified", "data", |
1098 "newtype", "instance", "if", "then", "else", "type", "as", "do", "module" |
1100 "newtype", "instance", "if", "then", "else", "type", "as", "do", "module" |
1099 ] @ [ |
1101 ] @ [ |
1100 "Bool", "Integer", "Maybe", "True", "False", "Nothing", "Just", "not", "negate" |
1102 "Bool", "Integer", "Maybe", "True", "False", "Nothing", "Just", "not", "negate" |
1101 ]; |
1103 ]; |
1102 fun hs_from_module imps ((_, name), ps) = |
1104 fun hs_from_module resolv imps ((_, name), ps) = |
1103 (Pretty.chunks) ( |
1105 (Pretty.chunks) ( |
1104 str ("module " ^ name ^ " where") |
1106 str ("module " ^ name ^ " where") |
1105 :: map (str o prefix "import qualified ") imps @ ( |
1107 :: map (str o prefix "import qualified ") imps @ ( |
1106 str "" |
1108 str "" |
1107 :: separate (str "") ps |
1109 :: separate (str "") ps |
1119 const_syntax c |
1121 const_syntax c |
1120 |> Option.map (fst o fst) |
1122 |> Option.map (fst o fst) |
1121 |> the_default 0; |
1123 |> the_default 0; |
1122 fun preprocess const_syntax module = |
1124 fun preprocess const_syntax module = |
1123 module |
1125 module |
1124 |> debug 3 (fn _ => "eta-expanding...") |
1126 |> debug_msg (fn _ => "eta-expanding...") |
1125 |> CodegenThingol.eta_expand (eta_expander const_syntax) |
1127 |> CodegenThingol.eta_expand (eta_expander const_syntax) |
1126 in |
1128 in |
1127 (Scan.optional (OuterParse.name >> (fn "no_typs" => false | s => Scan.fail_with (fn _ => "illegal flag: " ^ quote s) true)) true |
1129 (Scan.optional (OuterParse.name >> (fn "no_typs" => false | s => Scan.fail_with (fn _ => "illegal flag: " ^ quote s) true)) true |
1128 #-> (fn with_typs => parse_multi_file ((K o K) NONE) "hs" (serializer with_typs))) |
1130 #-> (fn with_typs => parse_multi_file ((K o K) NONE) "hs" (serializer with_typs))) |
1129 >> (fn (seri) => fn (class_syntax, tyco_syntax, const_syntax) => seri |
1131 >> (fn (seri) => fn (class_syntax, tyco_syntax, const_syntax) => seri |