## unparse-package-language.pkg
# Compiled by:
# src/lib/compiler/front/typer/typer.sublib# modified to use Lib7 Lib pp. [dbm, 7/30/03])
stipulate
package mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg package pp = prettyprint; # prettyprint is from src/lib/prettyprint/big/src/prettyprint.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package sxe = symbolmapstack_entry; # symbolmapstack_entry is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack-entry.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkgherein
api Unparse_Package_Language {
#
unparse_api
:
pp::Stream
->
( mld::Api,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_package
:
pp::Stream
->
( mld::Package,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_open
:
pp::Stream
->
( symbol_path::Symbol_Path,
mld::Package,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_package_name
:
pp::Stream
->
( mld::Package,
syx::Symbolmapstack
)
->
Void;
unparse_generic
:
pp::Stream
->
( mld::Generic,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_generic_api
:
pp::Stream
->
( mld::Generic_Api,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_naming
:
pp::Stream
->
( sy::Symbol,
sxe::Symbolmapstack_Entry,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_dictionary
:
pp::Stream
->
( syx::Symbolmapstack,
syx::Symbolmapstack,
Int,
Null_Or( List( sy::Symbol ) )
)
->
Void;
# module internals
unparse_elements
:
( ( syx::Symbolmapstack,
Int,
Null_Or( mld::Typerstore )
)
)
-> pp::Stream
-> mld::Api_Elements
-> Void;
unparse_typechecked_package
:
pp::Stream
->
( mld::Typerstore_Entry,
syx::Symbolmapstack,
Int
)
->
Void;
unparse_typerstore
:
pp::Stream
->
( mld::Typerstore,
syx::Symbolmapstack,
Int
)
->
Void;
};
end;
stipulate
package bt = type_types; # type_types is from src/lib/compiler/front/typer/types/type-types.pkg package tro = typerstore; # typerstore is from src/lib/compiler/front/typer-stuff/modules/typerstore.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package lu = find_in_symbolmapstack; # find_in_symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/find-in-symbolmapstack.pkg package mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg package mj = module_junk; # module_junk is from src/lib/compiler/front/typer-stuff/modules/module-junk.pkg package pp = prettyprint; # prettyprint is from src/lib/prettyprint/big/src/prettyprint.pkg package sp = symbol_path; # symbol_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package sxe = symbolmapstack_entry; # symbolmapstack_entry is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack-entry.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkg package tu = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package ty = types; # types is from src/lib/compiler/front/typer-stuff/types/types.pkg package vac = variables_and_constructors; # variables_and_constructors is from src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkg # package ii = inlining_info
#
include prettyprint;
include unparse_junk;
herein
package unparse_package_language
: (weak) Unparse_Package_Language
{
# typer_control is from src/lib/compiler/front/typer/basics/typer-control.pkg internals
=
typer_control::internals;
fun bug msg
=
error_message::impossible("unparse_package_language: " + msg);
#
fun by f x y
=
f y x;
pps = pp::string;
unparse_type = unparse_type::unparse_type;
unparse_typ = unparse_type::unparse_typ;
unparse_type_scheme = unparse_type::unparse_type_scheme;
unparse_formals = unparse_type::unparse_formals;
result_id
=
sy::make_package_symbol "<result_package>";
#
fun pkg_to_dictionary ( mld::API { api_elements, ... }, entities)
=>
{ fun bind_element ((symbol, spec), symbolmapstack)
=
case spec
mld::TYP_IN_API { module_stamp, ... }
=>
{ typ = tro::find_typ_by_module_stamp (entities, module_stamp);
syx::bind (symbol, sxe::NAMED_TYPE typ, symbolmapstack );
};
mld::PACKAGE_IN_API { module_stamp, an_api, ... }
=>
{ typechecked_package
=
tro::find_package_by_module_stamp (entities, module_stamp);
syx::bind (
symbol,
sxe::NAMED_PACKAGE (
mld::A_PACKAGE {
an_api,
typechecked_package,
varhome => vh::null_varhome,
inlining_info => inlining_information::NULL
}
),
symbolmapstack
);
};
mld::VALCON_IN_API { datatype, ... }
=>
syx::bind (symbol, sxe::NAMED_CONSTRUCTOR datatype, symbolmapstack);
_ =>
symbolmapstack;
esac;
fold_left bind_element syx::empty api_elements;
};
pkg_to_dictionary _
=>
syx::empty;
end;
#
fun api_to_symbolmapstack ( mld::API { api_elements, ... } )
=>
{ fun bind_element ((symbol, spec), symbolmapstack)
=
case spec
mld::TYP_IN_API { typ, ... }
=>
syx::bind (symbol, sxe::NAMED_TYPE typ, symbolmapstack);
mld::PACKAGE_IN_API { an_api, slot, definition, module_stamp=>ev }
=>
syx::bind (
symbol,
sxe::NAMED_PACKAGE (
mld::PACKAGE_API {
an_api,
stamppath => [ev]
}
),
symbolmapstack
);
mld::VALCON_IN_API { datatype, ... }
=>
syx::bind (symbol, sxe::NAMED_CONSTRUCTOR datatype, symbolmapstack);
_ =>
symbolmapstack;
esac;
fold_left bind_element syx::empty api_elements;
};
api_to_symbolmapstack _
=>
bug "api_to_symbolmapstack";
end;
# Support for a hack to make sure that non-visible ConNamings don't
# cause spurious blank lines when prettyprint-ing apis.
#
fun is_prettyprintable_valcon_naming (ty::VALCON { form=>vh::EXCEPTION _, ... }, _)
=>
TRUE;
is_prettyprintable_valcon_naming (con, symbolmapstack)
=>
{ exception HIDDEN;
visible_dcon_typ
=
{ typ
=
tu::datatyp_to_typ con;
( tu::typ_equality
( lu::find_typ_via_symbol_path
( symbolmapstack,
sp::SYMBOL_PATH [ ip::last (tu::typ_path typ) ],
fn _ = raise exception HIDDEN
),
typ
)
except
HIDDEN = FALSE
);
};
( *internals or
not visible_dcon_typ
);
};
end;
#
fun all_prettyprintable_namings alist symbolmapstack
=
list::filter
fn (name, sxe::NAMED_CONSTRUCTOR con)
=>
is_prettyprintable_valcon_naming (con, symbolmapstack);
b =>
TRUE;
end
alist;
#
fun unparse_lty stream ( /* lambdaty, depth */ )
=
pps stream "<lambdaty>";
#
fun unparse_typechecked_package_variable stream module_stamp
=
pps stream (stamppath::module_stamp_to_string module_stamp);
#
fun unparse_stamppath stream stamppath
=
pps stream (stamppath::stamppath_to_string stamppath);
/* prettyprintClosedSequence ppstream
{ front=(fn stream => pps stream "["),
sep=(fn stream => (pps stream ", "; break stream { spaces=0, indent_on_wrap=0 } )),
back=(fn stream => pps stream "]"),
style=INCONSISTENT,
pr=prettyprintMacroExpansionVariable }
*/
#
fun unparse_typ_expression stream (typ_expression, depth)
=
if (depth <= 0)
pps stream "<typeConstructorExpression>";
else
case typ_expression
#
mld::TYPE_VARIABLE_TYP ep
=>
{ pps stream "te::V:"; break stream { spaces=>1, indent_on_wrap=>1 };
unparse_stamppath stream ep;
};
mld::CONSTANT_TYP typ
=>
{ pps stream "te::C:"; break stream { spaces=>1, indent_on_wrap=>1 };
unparse_typ syx::empty stream typ;
};
mld::FORMAL_TYP typ
=>
{ pps stream "te::FM:"; break stream { spaces=>1, indent_on_wrap=>1 };
unparse_typ syx::empty stream typ;
};
esac;
fi;
#
fun unparse_package_name stream (str, symbolmapstack)
=
{ inverse_path
=
case str
mld::A_PACKAGE { typechecked_package, ... }
=>
typechecked_package.inverse_path;
_ => bug "unparse_package_name";
esac;
#
fun get a
=
lu::find_package_via_symbol_path (
symbolmapstack,
a,
(fn _ = raise exception syx::UNBOUND)
);
#
fun check str'
=
mj::eq_origin (str', str);
my (syms, found)
=
find_path (inverse_path, check, get);
pps stream ( found ?? sp::to_string (sp::SYMBOL_PATH syms)
:: "?" + (sp::to_string (sp::SYMBOL_PATH syms))
);
};
#
fun unparse_variable stream
=
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, ... };
#
fun unparse_v ( vac::ORDINARY_VARIABLE { path, varhome, var_type, inlining_info },
symbolmapstack: syx::Symbolmapstack
)
=>
{ begin_horizontal_else_vertical_box 0;
pps (sp::to_string path);
if *internals
unparse_value::unparse_varhome stream varhome;
fi;
pps " : "; unparse_type symbolmapstack stream *var_type;
end_box ();
};
unparse_v (vac::OVERLOADED_IDENTIFIER { name, alternatives, type_scheme=>ty::TYPE_SCHEME { body, ... } }, symbolmapstack)
=>
{ begin_horizontal_else_vertical_box 0;
unparse_symbol stream (name); pps " : "; unparse_type symbolmapstack stream body;
pps " as ";
unparse_sequence
stream
{ sep => by pp::break { spaces=>1, indent_on_wrap=>0 },
pr => (fn stream = fn { variant, ... } = unparse_v (variant, symbolmapstack)),
style => CONSISTENT
}
*alternatives;
end_box ();
};
unparse_v (vac::ERRORVAR, _)
=>
pps "<ERRORVAR>";
end;
unparse_v;
};
#
fun unparse_con_naming stream
=
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, ... };
#
fun unparse_con (ty::VALCON { name, type, form=>vh::EXCEPTION _, ... }, symbolmapstack)
=>
{ begin_wrap_box 4;
pps "exception ";
unparse_symbol stream name;
if (type_types::is_arrow_type type)
# pps " of ";
pps " ";
unparse_type symbolmapstack stream (type_types::domain type);
fi;
end_box ();
};
unparse_con (con as ty::VALCON { name, type, ... }, symbolmapstack)
=>
if *internals
begin_wrap_box 4;
pps "Constructor ";
unparse_symbol stream name;
pps " : ";
unparse_type symbolmapstack stream type;
end_box ();
fi;
end;
unparse_con;
};
#
fun unparse_package stream (pkg, symbolmapstack, depth)
=
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, newline };
case pkg
#
mld::A_PACKAGE { an_api, typechecked_package as { typerstore, ... }, ... }
=>
if *internals
begin_horizontal_else_vertical_box 2;
pps "A_PACKAGE";
newline_indent stream 2;
begin_horizontal_else_vertical_box 0;
pps "an_api:";
break { spaces=>1, indent_on_wrap=>2 };
unparse_api0 stream (an_api, symbolmapstack, depth - 1, THE typerstore);
newline();
pps "typechecked_package:";
break { spaces=>1, indent_on_wrap=>2 };
unparse_generics_expansion stream (typechecked_package, symbolmapstack, depth - 1);
end_box ();
end_box ();
else
case an_api
#
mld::API { name => THE symbol, ... }
=>
( ( if ( mj::apis_equal (
an_api,
lu::find_api_by_symbol (
symbolmapstack,
symbol,
(fn _ = raise exception syx::UNBOUND)
)
)
)
unparse_symbol stream symbol;
else unparse_symbol stream symbol; pps "?"; fi
)
except
syx::UNBOUND
=
{ unparse_symbol stream symbol;
pps "?";
}
);
mld::API { name => NULL, ... }
=>
if (depth <= 1)
pps "<api>";
else
unparse_api0 stream
(an_api, symbolmapstack, depth - 1, THE typerstore);
fi;
mld::ERRONEOUS_API
=>
pps "<error sig>";
esac;
fi;
mld::PACKAGE_API _ => pps "<pkg_api>";
mld::ERRONEOUS_PACKAGE => pps "<error pkg>";
esac;
}
also
fun unparse_elements
(symbolmapstack, depth, typechecked_package_env_op)
stream
elements
=
{ fun pr first (symbol, spec)
=
case spec
mld::PACKAGE_IN_API { an_api, module_stamp, definition, slot }
=>
{ if (not first)
newline stream;
fi;
begin_horizontal_else_vertical_box stream;
pps stream "package ";
unparse_symbol stream symbol;
pps stream " :";
break stream { spaces=>1, indent_on_wrap=>2 };
begin_horizontal_else_vertical_box stream;
case typechecked_package_env_op
NULL
=>
unparse_api0
stream
( an_api,
symbolmapstack,
depth - 1,
NULL
);
THE eenv
=>
{ my { typerstore, ... }
=
case (tro::find_entry_by_module_stamp (eenv, module_stamp))
mld::PACKAGE_ENTRY e
=>
e;
_ => bug "prettyprintElements: PACKAGE_ENTRY";
esac;
unparse_api0 stream (an_api, symbolmapstack, depth - 1, THE typerstore);
};
esac;
if *internals
newline stream;
pps stream "module_stamp: ";
pps stream (stamppath::module_stamp_to_string module_stamp);
fi;
pps stream ";";
end_box stream;
end_box stream;
};
mld::GENERIC_IN_API { a_generic_api, module_stamp, slot }
=>
{ if (not first)
newline stream;
fi;
begin_horizontal_else_vertical_box stream;
pps stream "generic package ";
unparse_symbol stream symbol; pps stream " :";
break stream { spaces=>1, indent_on_wrap=>2 };
begin_horizontal_else_vertical_box stream;
unparse_generic_api stream (a_generic_api, symbolmapstack, depth - 1);
if *internals
newline stream;
pps stream "module_stamp: ";
pps stream (stamppath::module_stamp_to_string module_stamp);
fi;
pps stream ";";
end_box stream;
end_box stream;
};
mld::TYP_IN_API { typ=>spec, module_stamp, is_a_replica, scope }
=>
{ if (not first)
newline stream;
fi;
begin_horizontal_else_vertical_box stream;
case typechecked_package_env_op
NULL =>
if is_a_replica unparse_replicate_naming stream (spec, symbolmapstack);
else unparse_typ_bind stream (spec, symbolmapstack);
fi;
THE eenv
=>
case (tro::find_entry_by_module_stamp (eenv, module_stamp))
mld::TYP_ENTRY typ
=>
if (is_a_replica)
unparse_replicate_naming stream (typ, symbolmapstack);
else
unparse_typ_bind stream (typ, symbolmapstack);
fi;
mld::ERRONEOUS_ENTRY
=>
pps stream "<ERRONEOUS_ENTRY>";
_ =>
bug "prettyprintElements: TYP_ENTRY";
esac;
esac;
if *internals
newline stream;
pps stream "module_stamp: ";
pps stream (stamppath::module_stamp_to_string module_stamp);
newline stream;
pps stream "scope: ";
pps stream (int::to_string scope);
fi;
pps stream ";";
end_box stream;
};
mld::VALUE_IN_API { type, ... }
=>
{ if (not first)
newline stream;
fi;
begin_indented_wrap_box stream (pp::CURSOR_RELATIVE 4);
pps stream /*2007-12-08CrT:"my "*/"";
unparse_symbol stream symbol; pps stream " : ";
unparse_type symbolmapstack stream (type);
pps stream ";";
end_box stream;
};
mld::VALCON_IN_API {
datatype => dcon as ty::VALCON {
form => vh::EXCEPTION _,
...
},
...
}
=>
{ if (not first)
newline stream;
fi;
unparse_con_naming stream (dcon, symbolmapstack);
pps stream ";";
};
mld::VALCON_IN_API { datatype, ... }
=>
if *internals
if (not first)
newline stream;
fi;
unparse_con_naming stream (datatype, symbolmapstack);
pps stream ";";
fi; # Ordinary data constructor -- don't print.
esac;
begin_horizontal_else_vertical_box stream;
case elements
NIL => ();
first ! rest => { pr TRUE first;
apply (pr FALSE) rest;
};
esac;
end_box stream;
}
also
fun unparse_api0 stream (an_api, symbolmapstack, depth, typechecked_package_env_op)
=
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box,
begin_wrap_box,
end_box,
pps,
break,
newline
};
symbolmapstack
=
syx::atop
( case typechecked_package_env_op
NULL => api_to_symbolmapstack an_api;
THE typerstore
=>
pkg_to_dictionary (an_api, typerstore);
esac,
symbolmapstack
);
#
fun unparse_constraints (variety, constraints: List( mld::Share_Spec ))
=
{ begin_horizontal_else_vertical_box 0;
ppvseq stream 0 ""
(fn stream =
fn paths =
{ begin_wrap_box 2;
pps "sharing "; pps variety;
unparse_sequence stream
{ sep=>(fn stream = { pps " ="; break { spaces=>1, indent_on_wrap=>0 } ;}),
pr=>unparse_symbol_path,
style=>INCONSISTENT
}
paths;
end_box ();
}
)
constraints;
end_box ();
};
some_print = REF FALSE;
if (depth <= 0)
case an_api mld::API { name => THE symbol, ... } => { pps "<api "; unparse_symbol stream symbol; pps ">"; };
_ => pps "<api>;";
esac;
else
case an_api
#
mld::API { stamp, name, api_elements, type_sharing, package_sharing, ... }
=>
if *internals
#
begin_horizontal_else_vertical_box 0;
pps "BEGIN_API:";
newline_indent stream 2;
begin_horizontal_else_vertical_box 0;
pps "stamp: "; pps (stamp::to_short_string stamp);
newline();
pps "name: ";
case name NULL => pps "ANONYMOUS";
THE p => { pps "NAMED "; unparse_symbol stream p; };
esac;
case api_elements
#
NIL => ();
_ => { newline();
pps "elements:";
newline_indent stream 2;
unparse_elements (symbolmapstack, depth, typechecked_package_env_op) stream api_elements;
};
esac;
case package_sharing
#
NIL => ();
_ => { newline();
pps "package_sharing:";
newline_indent stream 2;
unparse_constraints("", package_sharing);
};
esac;
case type_sharing
#
NIL => ();
_ => { newline();
pps "typsharing:";
newline_indent stream 2;
unparse_constraints(/*2007-12-07CrT"type "*/"", type_sharing);
};
esac;
pps ";";
end_box ();
end_box ();
else
# not *internals
begin_horizontal_else_vertical_box 0;
pps "api";
begin_horizontal_else_vertical_box 0;
newline(); # 2008-01-03 CrT: Was: break { spaces=>1, indent_on_wrap=>2 };
pps " "; # 2008-01-03 CrT: A gross hack to line things up properly. XXX BUGGO FIXME.
case api_elements
#
NIL => ();
_ => { unparse_elements (symbolmapstack, depth, typechecked_package_env_op) stream api_elements;
some_print := TRUE;
};
esac;
case package_sharing
#
NIL => ();
_ => { if *some_print newline(); fi;
unparse_constraints("", package_sharing);
some_print := TRUE;
};
esac;
case type_sharing
#
NIL => ();
_ => { if *some_print newline(); fi;
unparse_constraints(/*2007-12-07CrT"type "*/"", type_sharing);
some_print := TRUE;
};
esac;
end_box ();
if *some_print
newline();
# break { spaces => 1, indent_on_wrap => 0 };
fi;
pps "end;";
end_box ();
fi;
mld::ERRONEOUS_API
=>
pps "<error api>;";
esac;
fi;
}
also
fun unparse_generic_api stream (an_api, symbolmapstack, depth)
=
{ my { begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, newline }
=
en_pp stream;
#
fun true_body_sig (orig as mld::API { api_elements => [(symbol, mld::PACKAGE_IN_API { an_api, ... } )],
...
}
)
=>
if (sy::eq (symbol, result_id)) an_api;
else orig;
fi;
true_body_sig orig
=>
orig;
end;
if (depth <= 0)
pps "<fctsig>";
else
case an_api
mld::GENERIC_API { parameter_api, parameter_variable, parameter_symbol, body_api, ... }
=>
if *internals
begin_horizontal_else_vertical_box 0;
pps "GENERIC_API:";
newline_indent stream 2;
begin_horizontal_else_vertical_box 0;
pps "psig: ";
unparse_api0 stream (parameter_api, symbolmapstack, depth - 1, NULL);
newline();
pps "pvar: ";
pps (stamppath::module_stamp_to_string parameter_variable);
newline();
pps "psym: ";
case parameter_symbol
NULL => pps "<anonymous>";
THE symbol => unparse_symbol stream symbol;
esac;
newline();
pps "bsig: ";
unparse_api0 stream (body_api, symbolmapstack, depth - 1, NULL);
end_box ();
end_box ();
else
begin_horizontal_else_vertical_box 0;
pps "(";
case parameter_symbol
THE x => pps (sy::name x);
_ => pps "<parameter>";
esac;
pps ": ";
unparse_api0 stream (parameter_api, symbolmapstack, depth - 1, NULL);
pps ") :";
break { spaces=>1, indent_on_wrap=>0 };
unparse_api0 stream (true_body_sig body_api, symbolmapstack, depth - 1, NULL);
end_box ();
fi;
mld::ERRONEOUS_GENERIC_API
=>
pps "<error fsig>";
esac;
fi;
}
also
fun unparse_generics_expansion stream (e, symbolmapstack, depth)
=
{ e -> { stamp, typerstore, property_list, inverse_path, stub };
my { begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, newline }
=
en_pp stream;
if (depth <= 1)
pps "<package typechecked_package>";
else
begin_horizontal_else_vertical_box 0;
pps "Typechecked_Package:";
newline_indent stream 2;
begin_horizontal_else_vertical_box 0;
pps "inverse_path: ";
pps (ip::to_string inverse_path);
newline();
pps "stamp: ";
pps (stamp::to_short_string stamp);
newline();
pps "typerstore:";
newline_indent stream 2;
unparse_typerstore stream (typerstore, symbolmapstack, depth - 1);
newline();
pps "lambdaty:";
newline_indent stream 2;
unparse_lty stream ( /* ModulePropLists::packageMacroExpansionLambdatype e, depth - 1 */);
end_box ();
end_box ();
fi;
}
also
fun unparse_typechecked_generic stream (e, symbolmapstack, depth)
=
{ e -> { stamp, generic_closure, property_list, typ_path, inverse_path, stub };
(en_pp stream) -> { begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, newline };
if (depth <= 1)
pps "<generic typechecked_package>";
else
begin_horizontal_else_vertical_box 0;
pps "Typechecked_Generic:";
newline_indent stream 2;
begin_horizontal_else_vertical_box 0;
pps "inverse_path: ";
pps (ip::to_string inverse_path);
newline();
pps "stamp: ";
pps (stamp::to_short_string stamp);
newline();
pps "generic_closure:";
break { spaces=>1, indent_on_wrap=>2 };
unparse_closure stream (generic_closure, depth - 1);
newline();
pps "lambdaty:";
break { spaces=>1, indent_on_wrap=>2 };
unparse_lty stream ( /* ModulePropLists::genericMacroExpansionLty e, depth - 1 */ );
pps "typ_path:";
break { spaces=>1, indent_on_wrap=>2 };
pps "--printing of Typ_Path not implemented yet--";
end_box ();
end_box ();
fi;
}
also
fun unparse_generic stream
=
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, newline };
#
fun unparse_f (mld::GENERIC { a_generic_api, typechecked_generic, ... }, symbolmapstack, depth)
=>
if (depth <= 1)
pps "<generic package>";
else
begin_horizontal_else_vertical_box 0;
pps "a_generic_api:";
newline_indent stream 2;
unparse_generic_api stream (a_generic_api, symbolmapstack, depth - 1);
newline();
pps "typechecked_generic:";
newline_indent stream 2;
unparse_typechecked_generic stream (typechecked_generic, symbolmapstack, depth - 1);
end_box ();
fi;
unparse_f (mld::ERRONEOUS_GENERIC, _, _)
=>
pps "<error generic package>";
end;
unparse_f;
}
also
fun unparse_typ_bind stream (typ, symbolmapstack)
=
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, newline };
#
fun visible_dcons (typ, dcons)
=
find dcons
where
fun check_con (vac::CONSTRUCTOR c) => c;
check_con _ => raise exception syx::UNBOUND;
end;
#
fun find ((actual as { name, form, domain } ) ! rest)
=>
{ found
=
check_con (lu::find_value_by_symbol
(symbolmapstack, name,
fn _ = raise exception syx::UNBOUND));
# Test whether the datatypes of actual and
# found constructor agree:
case (tu::datatyp_to_typ found)
typ1 as ty::PLAIN_TYP _
=>
# The expected form in packages
if (tu::typs_are_equal (typ, typ1))
found ! find rest;
else find rest;fi;
ty::TYP_BY_STAMPPATH _
=>
# The expected form in apis;
# we won't check visibility [David B MacQueen]
found ! find rest;
d_found
=>
# something's weird
{ old_internals = *internals;
internals := TRUE;
begin_horizontal_else_vertical_box 0;
pps "unparse_typ_bind failure: ";
newline();
unparse_typ symbolmapstack stream typ;
newline();
unparse_typ symbolmapstack stream d_found;
newline();
end_box ();
internals := old_internals;
find rest;
};
esac;
}
except
syx::UNBOUND = find rest;
find []
=>
[];
end;
end; # fun visible_dcons
#
fun strip_poly (ty::TYPE_SCHEME_TYPE { type_scheme => ty::TYPE_SCHEME { body, ... }, ... } )
=>
body;
strip_poly type
=>
type;
end;
#
fun unparse_dcon (ty::VALCON { name, type, ... } )
=
{ unparse_symbol stream name;
type = strip_poly type;
if (bt::is_arrow_type type)
#
# pps " of ";
pps " ";
unparse_type symbolmapstack stream (bt::domain type);
fi;
};
if *internals
#
begin_horizontal_else_vertical_box 0;
pps /*2007-12-07CrT"type "*/""; unparse_typ symbolmapstack stream typ;
end_box ();
else
case typ
#
ty::PLAIN_TYP { path, arity, eqtype_info, kind, ... }
=>
case (*eqtype_info, kind)
#
(ty::eq_type::EQ_ABSTRACT, _)
=>
# Abstype
{ begin_horizontal_else_vertical_box 0;
pps /*2007-12-07CrT"type "*/"";
unparse_symbol stream (ip::last path);
unparse_formals stream arity;
pps " ";
end_box ();
};
(_, ty::DATATYPE { index, family => { members, ... }, ... } )
=>
# Ordinary enum
#
{ (vector::get (members, index))
->
{ constructor_list, ... };
visdcons = visible_dcons (typ, constructor_list);
incomplete = length visdcons < length constructor_list;
begin_horizontal_else_vertical_box 0;
# pps "enum";
unparse_symbol stream (ip::last path);
unparse_formals stream arity;
pps " ";
case visdcons
NIL => pps " = ...";
first ! rest
=>
{ break { spaces=>1, indent_on_wrap=>2 };
begin_horizontal_else_vertical_box 0;
pps "= "; unparse_dcon first;
apply
(fn d = { break { spaces=>1, indent_on_wrap=>0 }; pps "| "; unparse_dcon d;})
rest;
if incomplete
break { spaces=>1, indent_on_wrap=>0 };
pps "... ";
fi;
end_box ();
};
esac;
end_box ();
};
_ =>
{ begin_horizontal_else_vertical_box 0;
if (eq_types::is_equality_typ typ)
pps "eqtype";
else pps /*2007-12-07CrT"type "*/"";
fi;
unparse_symbol stream (ip::last path);
unparse_formals stream arity;
pps " ";
end_box ();
};
esac;
ty::DEFINED_TYP { path, type_scheme => ty::TYPE_SCHEME { arity, body }, ... }
=>
{ begin_wrap_box 2;
pps /*2007-12-07CrT"type "*/"";
unparse_symbol stream (inverse_path::last path);
unparse_formals stream arity;
pps " =";
break { spaces=>1, indent_on_wrap=>0 };
unparse_type symbolmapstack stream body;
end_box ();
};
typ
=>
{ pps "strange typ: ";
unparse_typ symbolmapstack stream typ;
};
esac;
fi;
} # fun unparse_typ_bind stream
also
fun unparse_replicate_naming
stream
( ty::DEFINED_TYP {
type_scheme => ty::TYPE_SCHEME {
body => ty::TYPCON_TYPE (right_typ, _),
...
},
path,
...
},
symbolmapstack
)
=>
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, newline };
begin_wrap_box 2;
# pps "enum"; break { spaces => 1, indent_on_wrap => 0 };
unparse_symbol stream (ip::last path);
pps " ="; break { spaces => 1, indent_on_wrap => 0 };
# pps "enum"; break { spaces => 1, indent_on_wrap => 0 };
unparse_typ symbolmapstack stream right_typ;
end_box ();
};
unparse_replicate_naming _ _
=>
error_message::impossible "prettyprintReplicateNaming";
end
also
fun unparse_typechecked_package stream (typechecked_package, symbolmapstack, depth)
=
case typechecked_package
mld::TYP_ENTRY typ
=>
unparse_typ symbolmapstack stream typ;
mld::PACKAGE_ENTRY typechecked_package
=>
unparse_generics_expansion stream (typechecked_package, symbolmapstack, depth - 1);
mld::GENERIC_ENTRY typechecked_generic
=>
unparse_typechecked_generic stream (typechecked_generic, symbolmapstack, depth - 1);
mld::ERRONEOUS_ENTRY
=>
pps stream "ERRONEOUS_ENTRY";
esac
also
fun unparse_typerstore stream (typerstore, symbolmapstack, depth)
=
if (depth <= 1)
pps stream "<typerstore>";
else
(ppvseq
stream 2 ""
(fn stream =
fn (module_stamp, typechecked_package)
=
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, newline };
begin_horizontal_else_vertical_box 2;
pps (stamppath::module_stamp_to_string module_stamp);
pps ":";
newline_indent stream 2;
unparse_typechecked_package stream (typechecked_package, symbolmapstack, depth - 1);
newline();
end_box ();
}
)
(tro::to_list typerstore));
fi
also
fun unparse_module_declaration stream (module_declaration, depth)
=
if (depth <= 0)
#
pps stream "<module_declaration>";
else
case module_declaration
#
mld::TYP_DECLARATION ( module_stamp, typ_expression )
=>
{ pps stream "ed::T: ";
unparse_typechecked_package_variable stream module_stamp;
break stream { spaces=>1, indent_on_wrap=>1 };
unparse_typ_expression stream (typ_expression, depth - 1);
};
mld::PACKAGE_DECLARATION (module_stamp, package_expression, symbol)
=>
{ pps stream "ed::S: ";
unparse_typechecked_package_variable stream module_stamp;
break stream { spaces=>1, indent_on_wrap=>1 };
unparse_package_expression stream (package_expression, depth - 1);
break stream { spaces=>1, indent_on_wrap=>1 };
unparse_symbol stream symbol;
};
mld::GENERIC_DECLARATION (module_stamp, generic_expression)
=>
{ pps stream "ed::F: ";
unparse_typechecked_package_variable stream module_stamp;
break stream { spaces=>1, indent_on_wrap=>1 };
unparse_generic_expression stream (generic_expression, depth - 1);
};
mld::SEQUENTIAL_DECLARATIONS typechecked_package_decs
=>
ppvseq stream 0 ""
(fn stream =
fn module_declaration =
unparse_module_declaration stream (module_declaration, depth)
)
typechecked_package_decs;
mld::LOCAL_DECLARATION (typechecked_package_dec_l, typechecked_package_dec_b)
=>
pps stream "ed::L:";
mld::ERRONEOUS_ENTRY_DECLARATION
=>
pps stream "ed::ER:";
mld::EMPTY_GENERIC_EVALUATION_DECLARATION
=>
pps stream "ed::EM:";
esac;
fi
also
fun unparse_package_expression stream (package_expression, depth)
=
if (depth <= 0)
pps stream "<packageexpression>";
else
case package_expression
mld::VARIABLE_PACKAGE ep
=>
{ pps stream "syx::V:";
break stream { spaces=>1, indent_on_wrap=>1 };
unparse_stamppath stream ep;
};
mld::CONSTANT_PACKAGE { stamp, inverse_path, ... }
=>
{ pps stream "syx::C:"; break stream { spaces=>1, indent_on_wrap=>1 };
unparse_inverse_path stream inverse_path;
};
mld::PACKAGE { stamp, module_declaration }
=>
{ pps stream "syx::S:";
break stream { spaces=>1, indent_on_wrap=>1 };
unparse_module_declaration stream (module_declaration, depth - 1);
};
mld::APPLY (generic_expression, package_expression)
=>
{ begin_horizontal_else_vertical_box stream;
pps stream "syx::AP:"; break stream { spaces=>1, indent_on_wrap=>1 };
begin_horizontal_else_vertical_box stream;
pps stream "fct:"; unparse_generic_expression stream (generic_expression, depth - 1);
break stream { spaces=>1, indent_on_wrap=>0 };
pps stream "arg:"; unparse_package_expression stream (package_expression, depth - 1);
end_box stream;
end_box stream;
};
mld::PACKAGE_LET { declaration => module_declaration, expression => package_expression }
=>
{ begin_horizontal_else_vertical_box stream;
pps stream "syx::L:"; break stream { spaces=>1, indent_on_wrap=>1 };
begin_horizontal_else_vertical_box stream;
pps stream "stipulate:"; unparse_module_declaration stream (module_declaration, depth - 1);
break stream { spaces=>1, indent_on_wrap=>0 };
pps stream "herein:"; unparse_package_expression stream (package_expression, depth - 1);
end_box stream;
end_box stream;
};
mld::ABSTRACT_PACKAGE (an_api, package_expression)
=>
{ begin_horizontal_else_vertical_box stream;
pps stream "syx::AB:"; break stream { spaces=>1, indent_on_wrap=>1 };
begin_horizontal_else_vertical_box stream;
pps stream "an_api: <omitted>";
break stream { spaces=>1, indent_on_wrap=>0 };
pps stream "sexp:"; unparse_package_expression stream (package_expression, depth - 1);
end_box stream;
end_box stream;
};
mld::COERCED_PACKAGE { boundvar, raw, coercion }
=>
{ begin_horizontal_else_vertical_box stream;
pps stream "syx::CO:"; break stream { spaces=>1, indent_on_wrap=>1 };
begin_horizontal_else_vertical_box stream;
unparse_typechecked_package_variable stream boundvar; break stream { spaces=>1, indent_on_wrap=>1 };
pps stream "src:"; unparse_package_expression stream (raw, depth - 1);
break stream { spaces=>1, indent_on_wrap=>0 };
pps stream "tgt:"; unparse_package_expression stream (coercion, depth - 1);
end_box stream;
end_box stream;
};
mld::FORMAL_PACKAGE (an_api)
=>
pps stream "syx::FM:";
esac;
fi
also
fun unparse_generic_expression stream (generic_expression, depth)
=
if (depth <= 0)
pps stream "<genericexpression>";
else
case generic_expression
mld::VARIABLE_GENERIC ep
=>
{ pps stream "fe::V:";
unparse_stamppath stream ep;
};
mld::CONSTANT_GENERIC { inverse_path, ... }
=>
{ pps stream "fe::C:";
unparse_inverse_path stream inverse_path;
};
mld::LAMBDA_TP { parameter, body, ... }
=>
{ begin_horizontal_else_vertical_box stream;
pps stream "fe::LP:"; break stream { spaces=>1, indent_on_wrap=>1 };
begin_horizontal_else_vertical_box stream;
pps stream "par:"; unparse_typechecked_package_variable stream parameter;
break stream { spaces=>1, indent_on_wrap=>0 };
pps stream "bod:"; unparse_package_expression stream (body, depth - 1);
end_box stream;
end_box stream;
};
mld::LAMBDA { parameter, body }
=>
{ begin_horizontal_else_vertical_box stream;
pps stream "fe::L:"; break stream { spaces=>1, indent_on_wrap=>1 };
begin_horizontal_else_vertical_box stream;
pps stream "par:"; unparse_typechecked_package_variable stream parameter;
break stream { spaces=>1, indent_on_wrap=>0 };
pps stream "bod:"; unparse_package_expression stream (body, depth - 1);
end_box stream;
end_box stream;
};
mld::LET_GENERIC (module_declaration, generic_expression)
=>
{ begin_horizontal_else_vertical_box stream;
pps stream "fe::LT:"; break stream { spaces=>1, indent_on_wrap=>1 };
begin_horizontal_else_vertical_box stream;
pps stream "stipulate:"; unparse_module_declaration stream (module_declaration, depth - 1);
break stream { spaces=>1, indent_on_wrap=>0 };
pps stream "herein:"; unparse_generic_expression stream (generic_expression, depth - 1);
end_box stream;
end_box stream;
};
esac;
fi
/*
also prettyprintBodyExpression stream (bodyExpression, depth) =
if depth <= 0 then pps stream "<bodyExpression>" else
case bodyExpression
of mld::FLEX an_api => pps stream "be::F:"
| mld::OPAQ (an_api, packageexpression) =>
(begin_horizontal_else_vertical_box stream;
pps stream "be::O:"; break stream { spaces=1, indent_on_wrap=1 };
prettyprintPackageexpression stream (packageexpression, depth - 1);
end_box stream)
| mld::TNSP (an_api, packageexpression) =>
(begin_horizontal_else_vertical_box stream;
pps stream "be::T:"; break stream { spaces=1, indent_on_wrap=1 };
prettyprintPackageexpression stream (packageexpression, depth - 1);
end_box stream)
*/
also
fun unparse_closure stream (mld::GENERIC_CLOSURE { parameter_module_stamp => parameter,
body_package_expression => body,
typerstore => symbolmapstack
},
depth
)
=
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, newline, break, ... };
begin_horizontal_else_vertical_box 0;
pps "CL:"; break { spaces=>1, indent_on_wrap=>1 };
begin_horizontal_else_vertical_box 0;
pps "parameter: ";
unparse_typechecked_package_variable stream parameter;
newline();
pps "body: ";
unparse_package_expression stream (body, depth - 1);
newline();
pps "dictionary: ";
unparse_typerstore stream (symbolmapstack, syx::empty, depth - 1);
end_box ();
end_box ();
}
# Assumes no newline is needed before prettyprinting:
also
fun unparse_naming stream (name, naming: sxe::Symbolmapstack_Entry, symbolmapstack: syx::Symbolmapstack, depth: Int)
=
case naming
#
sxe::NAMED_VARIABLE var
=>
{ pps stream /*2007-12-08CrT:"my "*/"";
unparse_variable stream (var, symbolmapstack);
};
sxe::NAMED_CONSTRUCTOR con
=>
unparse_con_naming stream (con, symbolmapstack);
sxe::NAMED_TYPE typ
=>
unparse_typ_bind stream (typ, symbolmapstack);
sxe::NAMED_API an_api
=>
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, ... };
begin_horizontal_else_vertical_box 0;
pps "api ";
unparse_symbol stream name;
pps " =";
break { spaces=>1, indent_on_wrap=>2 };
unparse_api0 stream (an_api, symbolmapstack, depth, NULL);
end_box ();
};
sxe::NAMED_GENERIC_API fs
=>
{ my { begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, ... } = en_pp stream;
begin_horizontal_else_vertical_box 2;
pps "funsig ";
unparse_symbol stream name;
unparse_generic_api stream (fs, symbolmapstack, depth);
end_box ();
};
sxe::NAMED_PACKAGE str
=>
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, ... };
begin_horizontal_else_vertical_box 0;
pps "packageX ";
unparse_symbol stream name;
pps " :";
break { spaces=>1, indent_on_wrap=>2 };
unparse_package stream (str, symbolmapstack, depth);
end_box ();
};
sxe::NAMED_GENERIC fct
=>
{ (en_pp stream)
->
{ begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, ... };
begin_horizontal_else_vertical_box 0;
pps "generic package ";
unparse_symbol stream name;
pps " : <sig>"; # David B MacQueen -- should print the api XXX BUGGO FIXME
end_box ();
};
sxe::NAMED_FIXITY fixity
=>
{ pps stream (fixity::fixity_to_string fixity);
unparse_symbol stream name;
};
esac
# prettyprintDict: prettyprint a symbol table
# in the context of the top-level symbol table.
# The symbol table must either be for a api or be absolute (i.e.
# all types and packages have been interpreted)
# Note: I made a preliminary pass over namings to remove
# invisible con_namings -- Konrad.
# and invisible packages too -- PC
also
fun unparse_dictionary stream (symbolmapstack, topenv, depth, boundsyms)
=
{ namings
=
case boundsyms
NULL => syx::to_sorted_list symbolmapstack;
THE l => fold_right
(fn (x, bs)
=
(x, syx::get (symbolmapstack, x)) ! bs
except
syx::UNBOUND = bs
)
[]
l;
esac;
pp_env = syx::atop (symbolmapstack, topenv);
unparse_sequence stream
{ sep => newline,
style => CONSISTENT,
pr => (fn stream =
fn (name, naming)
=
unparse_naming stream (name, naming, pp_env, depth)
)
}
(all_prettyprintable_namings namings pp_env);
};
fun unparse_open stream (path, pkg, symbolmapstack, depth)
=
{ my { begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, newline }
=
en_pp stream;
begin_horizontal_else_vertical_box 0;
begin_horizontal_else_vertical_box 2;
pps "including ";
unparse_symbol_path stream path;
if (depth >= 1)
#
case pkg
#
mld::A_PACKAGE { an_api, typechecked_package as { typerstore, ... }, ... }
=>
case an_api
#
mld::API { api_elements => [], ... }
=>
();
mld::API { api_elements, ... }
=>
{ newline ();
begin_horizontal_else_vertical_box 0;
unparse_elements
( syx::atop (api_to_symbolmapstack an_api, symbolmapstack),
depth,
THE typerstore
)
stream
api_elements;
end_box ();
};
mld::ERRONEOUS_API
=>
();
esac;
mld::ERRONEOUS_PACKAGE => ();
mld::PACKAGE_API _ => bug "unparse_open";
esac;
fi;
end_box ();
newline ();
end_box ();
};
fun unparse_api stream (an_api, symbolmapstack, depth)
=
unparse_api0 stream (an_api, symbolmapstack, depth, NULL);
}; # package unparse_package_language
end; # stipulate