## 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 mtt = more_type_types; # more_type_types is from src/lib/compiler/front/typer/types/more-type-types.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.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 syp = symbol_path; # symbol_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkgherein
api Unparse_Package_Language {
#
unparse_api
:
pp::Prettyprinter
->
( mld::Api,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_package
:
pp::Prettyprinter
->
( mld::Package,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_open
:
pp::Prettyprinter
->
( syp::Symbol_Path,
mld::Package,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_package_name
:
pp::Prettyprinter
->
( mld::Package,
syx::Symbolmapstack
)
->
Void;
unparse_generic
:
pp::Prettyprinter
->
( mld::Generic,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_generic_api
:
pp::Prettyprinter
->
( mld::Generic_Api,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_naming
:
pp::Prettyprinter
->
( sy::Symbol,
sxe::Symbolmapstack_Entry,
syx::Symbolmapstack,
Int # Max prettyprint recursion depth
)
->
Void;
unparse_dictionary
:
pp::Prettyprinter
->
( syx::Symbolmapstack,
syx::Symbolmapstack,
Int,
Null_Or( List( sy::Symbol ) )
)
->
Void;
# module internals
unparse_elements
:
( ( syx::Symbolmapstack,
Int,
Null_Or( mld::Typerstore )
)
)
-> pp::Prettyprinter
-> mld::Api_Elements
-> Void;
unparse_typechecked_package
:
pp::Prettyprinter
->
( mld::Typerstore_Entry,
syx::Symbolmapstack,
Int
)
->
Void;
unparse_typerstore
:
pp::Prettyprinter
->
( mld::Typerstore,
syx::Symbolmapstack,
Int
)
->
Void;
};
end;
stipulate
package id = inlining_data; # inlining_data is from src/lib/compiler/front/typer-stuff/basics/inlining-data.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 mj = module_junk; # module_junk is from src/lib/compiler/front/typer-stuff/modules/module-junk.pkg package mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg package mtt = more_type_types; # more_type_types is from src/lib/compiler/front/typer/types/more-type-types.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package sp = symbol_path; # symbol_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.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 syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package tro = typerstore; # typerstore is from src/lib/compiler/front/typer-stuff/modules/typerstore.pkg package tu = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg package uj = unparse_junk; # unparse_junk is from src/lib/compiler/front/typer/print/unparse-junk.pkg package ut = unparse_type; # unparse_type is from src/lib/compiler/front/typer/print/unparse-type.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 #
Pp = pp::Pp;
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;
internals = log::internals;
fun bug msg
=
error_message::impossible("unparse_package_language: " + msg);
#
fun by f x y
=
f y x;
unparse_typoid = ut::unparse_typoid;
unparse_type = ut::unparse_type;
unparse_typescheme = ut::unparse_typescheme;
unparse_formals = ut::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::TYPE_IN_API { module_stamp, ... }
=>
{ type = tro::find_type_by_module_stamp (entities, module_stamp);
#
syx::bind (symbol, sxe::NAMED_TYPE type, 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_data => id::NIL
}
),
symbolmapstack
);
};
mld::VALCON_IN_API { sumtype, ... }
=>
syx::bind (symbol, sxe::NAMED_CONSTRUCTOR sumtype, symbolmapstack);
_ =>
symbolmapstack;
esac;
fold_forward 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::TYPE_IN_API { type, ... }
=>
syx::bind (symbol, sxe::NAMED_TYPE type, 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 { sumtype, ... }
=>
syx::bind (symbol, sxe::NAMED_CONSTRUCTOR sumtype, symbolmapstack);
_ =>
symbolmapstack;
esac;
fold_forward 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 (tdt::VALCON { form=>vh::EXCEPTION _, ... }, _)
=>
TRUE;
is_prettyprintable_valcon_naming (con, symbolmapstack)
=>
{ exception HIDDEN;
#
visible_valcon_type
=
{ type = tu::sumtype_to_type con;
( tu::type_equality
( lu::find_type_via_symbol_path
( symbolmapstack,
sp::SYMBOL_PATH [ ip::last (tu::namepath_of_type type) ],
\\ _ = raise exception HIDDEN
),
type
)
except
HIDDEN = FALSE
);
};
( *internals or
not visible_valcon_type
);
};
end;
#
fun all_prettyprintable_namings alist symbolmapstack
=
list::filter
\\ (name, sxe::NAMED_CONSTRUCTOR con)
=>
is_prettyprintable_valcon_naming (con, symbolmapstack);
b =>
TRUE;
end
alist;
#
fun unparse_lty (pp:Pp) ( /* lambdaty, depth */ )
=
pp.lit "<lambdaty>";
#
fun unparse_typechecked_package_variable (pp:Pp) module_stamp
=
pp.lit (stamppath::module_stamp_to_string module_stamp);
#
fun unparse_stamppath (pp:Pp) stamppath
=
pp.lit (stamppath::stamppath_to_string stamppath);
/* prettyprintClosedSequence pp
{ front=(\\ pp => pp.lit "["),
sep=(\\ pp => (pp.lit ", "; break pp { spaces=0, indent_on_wrap=0 } )),
back=(\\ pp => pp.lit "]"),
style=uj::WRAP,
pr=prettyprintMacroExpansionVariable }
*/
#
fun unparse_type_expression (pp:Pp) (type_expression, depth)
=
if (depth <= 0)
pp.lit "<typeConstructorExpression>";
else
case type_expression
#
mld::TYPEVAR_TYPE ep
=>
{ pp.lit "te::TYPEVAR_TYPE:";
pp.txt' 1 -1 " ";
unparse_stamppath pp ep;
};
mld::CONSTANT_TYPE type
=>
{ pp.lit "te::CONSTANT_TYPE:";
pp.txt' 1 -1 " ";
unparse_type syx::empty pp type;
};
mld::FORMAL_TYPE type
=>
{ pp.lit "te::FORMAL_TYPE:";
pp.txt' 1 -1 " ";
unparse_type syx::empty pp type;
};
esac;
fi;
#
fun unparse_package_name (pp:Pp) (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,
(\\ _ = raise exception syx::UNBOUND)
);
#
fun check str'
=
mj::eq_origin (str', str);
(uj::find_path (inverse_path, check, get))
->
(syms, found);
pp.lit ( found ?? sp::to_string (sp::SYMBOL_PATH syms)
:: "?" + (sp::to_string (sp::SYMBOL_PATH syms))
);
};
#
fun unparse_variable pp
=
{
#
fun unparse_v ( vac::PLAIN_VARIABLE { path, varhome, vartypoid_ref, inlining_data },
symbolmapstack: syx::Symbolmapstack
)
=>
{ pp.box' 0 -1 {. pp.rulename "upb1";
#
pp.lit (sp::to_string path);
if *internals
unparse_value::unparse_varhome pp varhome;
fi;
pp.txt " : ";
unparse_typoid symbolmapstack pp *vartypoid_ref;
};
};
unparse_v (vac::OVERLOADED_VARIABLE { name, alternatives, typescheme=>tdt::TYPESCHEME { body, ... } }, symbolmapstack)
=>
{ pp.box' 0 -1 {. pp.rulename "upb2";
#
uj::unparse_symbol pp (name);
pp.txt " : ";
unparse_typoid symbolmapstack pp body;
pp.txt " as ";
uj::unparse_sequence
pp
{ separator => \\ pp = pp.txt " ",
print_one => \\ pp = \\ { variant, ... } = unparse_v (variant, symbolmapstack),
breakstyle => uj::ALIGN
}
*alternatives;
};
};
unparse_v (vac::ERROR_VARIABLE, _)
=>
pp.lit "<ERROR_VARIABLE>";
end;
unparse_v;
};
#
fun unparse_con_naming pp
=
{
#
fun unparse_con (tdt::VALCON { name, typoid, form=>vh::EXCEPTION _, ... }, symbolmapstack)
=>
{
pp.wrap {. pp.rulename "upw1";
#
pp.txt "exception ";
uj::unparse_symbol pp name;
if (mtt::is_arrow_type typoid)
#
# pp.txt " of ";
pp.txt " ";
unparse_typoid symbolmapstack pp (mtt::domain typoid);
fi;
};
};
unparse_con (con as tdt::VALCON { name, typoid, ... }, symbolmapstack)
=>
if *internals
pp.wrap {. pp.rulename "upw2";
pp.txt "Constructor ";
uj::unparse_symbol pp name;
pp.txt " : ";
unparse_typoid symbolmapstack pp typoid;
};
fi;
end;
unparse_con;
};
#
fun unparse_package pp (pkg, symbolmapstack, depth)
=
{
case pkg
#
mld::A_PACKAGE { an_api, typechecked_package as { typerstore, ... }, ... }
=>
if *internals
#
pp.box {. pp.rulename "upb3";
pp.lit "A_PACKAGE";
uj::newline_indent pp 2;
pp.box' 0 -1 {. pp.rulename "upb3b";
pp.lit "an_api:";
pp.txt' 0 2 " ";
unparse_api0 pp (an_api, symbolmapstack, depth - 1, THE typerstore);
pp.newline();
pp.lit "typechecked_package:";
pp.txt' 0 2 " ";
unparse_generics_expansion pp (typechecked_package, symbolmapstack, depth - 1);
};
};
else
case an_api
#
mld::API { name => THE symbol, ... }
=>
( ( if ( mj::apis_equal (
an_api,
lu::find_api_by_symbol (
symbolmapstack,
symbol,
(\\ _ = raise exception syx::UNBOUND)
)
)
)
uj::unparse_symbol pp symbol;
else uj::unparse_symbol pp symbol; pp.lit "?";
fi
)
except
syx::UNBOUND
=
{ uj::unparse_symbol pp symbol;
pp.lit "?";
}
);
mld::API { name => NULL, ... }
=>
if (depth <= 1)
pp.lit "<api>";
else
unparse_api0 pp
(an_api, symbolmapstack, depth - 1, THE typerstore);
fi;
mld::ERRONEOUS_API
=>
pp.lit "<ERRONEOUS_API>";
esac;
fi;
mld::PACKAGE_API _ => pp.lit "<pkg_api>";
mld::ERRONEOUS_PACKAGE => pp.lit "<error pkg>";
esac;
}
also
fun unparse_elements
(symbolmapstack, depth, typechecked_package_env_op)
pp
elements
=
{ fun pr first (symbol, spec)
=
case spec
#
mld::PACKAGE_IN_API { an_api, module_stamp, definition, slot }
=>
{ if (not first) pp.newline(); fi;
#
pp.box {. pp.rulename "upb4";
pp.lit "package ";
uj::unparse_symbol pp symbol;
pp.lit " :";
pp.txt' 0 2 " ";
pp.box {. pp.rulename "upb4b";
#
case typechecked_package_env_op
#
NULL => unparse_api0
pp
( 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 pp (an_api, symbolmapstack, depth - 1, THE typerstore);
};
esac;
if *internals
#
pp.newline();
pp.lit "module_stamp: ";
pp.lit (stamppath::module_stamp_to_string module_stamp);
fi;
pp.lit ";";
};
};
};
mld::GENERIC_IN_API { a_generic_api, module_stamp, slot }
=>
{ if (not first) pp.newline(); fi;
#
pp.box {. pp.rulename "upb5";
pp.lit "generic package ";
uj::unparse_symbol pp symbol;
pp.lit " :";
pp.txt' 0 2 " ";
pp.box {. pp.rulename "upb5b";
unparse_generic_api pp (a_generic_api, symbolmapstack, depth - 1);
if *internals
#
pp.newline();
pp.lit "module_stamp: ";
pp.lit (stamppath::module_stamp_to_string module_stamp);
fi;
pp.endlit ";";
};
};
};
mld::TYPE_IN_API { type=>spec, module_stamp, is_a_replica, scope }
=>
{ if (not first)
pp.newline();
fi;
pp.box {. pp.rulename "upb6";
#
case typechecked_package_env_op
#
NULL =>
if is_a_replica unparse_replicate_naming pp (spec, symbolmapstack);
else unparse_type_bind pp (spec, symbolmapstack);
fi;
THE eenv
=>
case (tro::find_entry_by_module_stamp (eenv, module_stamp))
#
mld::TYPE_ENTRY type
=>
if (is_a_replica)
unparse_replicate_naming pp (type, symbolmapstack);
else
unparse_type_bind pp (type, symbolmapstack);
fi;
mld::ERRONEOUS_ENTRY
=>
pp.lit "<ERRONEOUS_ENTRY>";
_ =>
bug "prettyprintElements: TYPE_ENTRY";
esac;
esac;
if *internals
pp.newline();
pp.lit "module_stamp: ";
pp.lit (stamppath::module_stamp_to_string module_stamp);
pp.newline();
pp.lit "scope: ";
pp.lit (int::to_string scope);
fi;
pp.endlit ";";
};
};
mld::VALUE_IN_API { typoid, ... }
=>
{ if (not first) pp.newline(); fi;
#
pp.box' 0 -1 {. pp.rulename "upb38";
pp.lit /*2007-12-08CrT:"my "*/"";
uj::unparse_symbol pp symbol;
pp.txt' 1 0 " ";
pp.cbox {. pp.rulename "upcb1";
pp.lit ":";
pp.txt' 0 -1 " ";
unparse_typoid symbolmapstack pp typoid;
};
pp.endlit ";";
};
};
mld::VALCON_IN_API {
sumtype => valcon as tdt::VALCON {
form => vh::EXCEPTION _,
...
},
...
}
=>
{ if (not first) pp.newline(); fi;
#
unparse_con_naming pp (valcon, symbolmapstack);
pp.endlit ";";
};
mld::VALCON_IN_API { sumtype, ... }
=>
if *internals
#
if (not first) pp.newline(); fi;
unparse_con_naming pp (sumtype, symbolmapstack);
pp.endlit ";";
fi; # Ordinary data constructor -- don't print.
esac;
pp.box' 0 -1 {. pp.rulename "upb7";
#
case elements
#
NIL => ();
first ! rest => { pr TRUE first;
apply (pr FALSE) rest;
};
esac;
};
}
also
fun unparse_api0 pp (an_api, symbolmapstack, depth, typechecked_package_env_op)
=
{
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 ))
=
{ pp.box' 0 -1 {. pp.rulename "upb8";
#
uj::ppvseq pp 0 ""
(\\ pp =
\\ paths =
{ pp.wrap' 0 2 {. pp.rulename "upw3";
#
pp.lit "sharing ";
pp.lit variety;
uj::unparse_sequence pp
{ separator => \\ pp = { pp.lit " ="; pp.txt' 0 -1 " "; },
print_one => uj::unparse_symbol_path,
breakstyle => uj::WRAP
}
paths;
};
}
)
constraints;
};
};
some_print = REF FALSE;
if (depth <= 0)
#
case an_api mld::API { name => THE symbol, ... } => { pp.lit "<api "; uj::unparse_symbol pp symbol; pp.lit ">"; };
_ => pp.lit "<api>;";
esac;
else
case an_api
#
mld::API { stamp, name, api_elements, type_sharing, package_sharing, ... }
=>
if *internals
#
pp.box' 0 -1 {. pp.rulename "upb9";
#
pp.lit "BEGIN_API:";
uj::newline_indent pp 2;
pp.box' 0 -1 {. pp.rulename "upb9b";
pp.lit "stamp: ";
pp.lit (stamp::to_short_string stamp);
pp.newline();
pp.lit "name: ";
case name NULL => pp.lit "ANONYMOUS";
THE p => { pp.lit "NAMED "; uj::unparse_symbol pp p; };
esac;
case api_elements
#
NIL => ();
_ => { pp.newline();
pp.lit "elements:";
uj::newline_indent pp 2;
unparse_elements (symbolmapstack, depth, typechecked_package_env_op) pp api_elements;
};
esac;
case package_sharing
#
NIL => ();
_ => { pp.newline();
pp.lit "package_sharing:";
uj::newline_indent pp 2;
unparse_constraints("", package_sharing);
};
esac;
case type_sharing
#
NIL => ();
_ => { pp.newline();
pp.lit "typesharing:";
uj::newline_indent pp 2;
unparse_constraints(/*2007-12-07CrT"type "*/"", type_sharing);
};
esac;
pp.endlit ";";
};
};
else # not *internals
pp.box' 0 -1 {. pp.rulename "upb10";
#
pp.lit "api";
pp.box' 0 -1 {. pp.rulename "upb10b";
#
pp.newline(); # 2008-01-03 CrT: Was: break { spaces=>1, indent_on_wrap=>2 };
pp.lit " "; # 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) pp api_elements;
some_print := TRUE;
};
esac;
case package_sharing
#
NIL => ();
_ => { if *some_print pp.newline(); fi;
unparse_constraints("", package_sharing);
some_print := TRUE;
};
esac;
case type_sharing
#
NIL => ();
_ => { if *some_print pp.newline(); fi;
unparse_constraints(/*2007-12-07CrT"type "*/"", type_sharing);
some_print := TRUE;
};
esac;
};
if *some_print
pp.newline();
# pp.txt " ";
fi;
pp.lit "end;";
};
fi;
mld::ERRONEOUS_API
=>
pp.lit "<error api>;";
esac;
fi;
}
also
fun unparse_generic_api pp (an_api, symbolmapstack, depth)
=
{
#
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)
#
pp.lit "<fctsig>";
else
case an_api
#
mld::GENERIC_API { parameter_api, parameter_variable, parameter_symbol, body_api, ... }
=>
if *internals
#
pp.box' 0 -1 {. pp.rulename "upb11";
#
pp.lit "GENERIC_API:";
uj::newline_indent pp 2;
pp.box' 0 -1 {. pp.rulename "upb11b";
#
pp.lit "psig: ";
unparse_api0 pp (parameter_api, symbolmapstack, depth - 1, NULL);
pp.newline();
pp.lit "pvar: ";
pp.lit (stamppath::module_stamp_to_string parameter_variable);
pp.newline();
pp.lit "psym: ";
case parameter_symbol
#
NULL => pp.lit "<anonymous>";
THE symbol => uj::unparse_symbol pp symbol;
esac;
pp.newline();
pp.lit "bsig: ";
unparse_api0 pp (body_api, symbolmapstack, depth - 1, NULL);
};
};
else
pp.box' 0 -1 {. pp.rulename "upb12";
#
pp.lit "(";
case parameter_symbol
#
THE x => pp.lit (sy::name x);
_ => pp.lit "<parameter>";
esac;
pp.txt ": ";
unparse_api0 pp (parameter_api, symbolmapstack, depth - 1, NULL);
pp.txt ") : ";
unparse_api0 pp (true_body_sig body_api, symbolmapstack, depth - 1, NULL);
};
fi;
mld::ERRONEOUS_GENERIC_API
=>
pp.lit "<error fsig>";
esac;
fi;
}
also
fun unparse_generics_expansion pp (e, symbolmapstack, depth)
=
{ e -> { stamp, typerstore, property_list, inverse_path, stub };
#
if (depth <= 1)
#
pp.lit "<package typechecked_package>";
else
pp.box' 0 -1 {. pp.rulename "upb13";
#
pp.lit "Typechecked_Package:";
uj::newline_indent pp 2;
pp.box' 0 -1 {. pp.rulename "upb13b";
#
pp.lit "inverse_path: ";
pp.lit (ip::to_string inverse_path);
pp.newline();
pp.lit "stamp: ";
pp.lit (stamp::to_short_string stamp);
pp.newline();
pp.lit "typerstore:";
uj::newline_indent pp 2;
unparse_typerstore pp (typerstore, symbolmapstack, depth - 1);
pp.newline();
pp.lit "lambdaty:";
uj::newline_indent pp 2;
unparse_lty pp ( /* ModulePropLists::packageMacroExpansionLambdatype e, depth - 1 */);
};
};
fi;
}
also
fun unparse_typechecked_generic pp (e, symbolmapstack, depth)
=
{ e -> { stamp, generic_closure, property_list, typepath, inverse_path, stub };
#
if (depth <= 1)
#
pp.lit "<generic typechecked_package>";
else
pp.box' 0 -1 {. pp.rulename "upb14";
#
pp.lit "Typechecked_Generic:";
uj::newline_indent pp 2;
pp.box' 0 -1 {. pp.rulename "upb14b";
#
pp.lit "inverse_path: ";
pp.lit (ip::to_string inverse_path);
pp.newline();
pp.lit "stamp: ";
pp.lit (stamp::to_short_string stamp);
pp.newline();
pp.txt' 0 2 "generic_closure: ";
unparse_closure pp (generic_closure, depth - 1);
pp.newline();
pp.txt' 0 2 "lambdaty: ";
unparse_lty pp ( /* ModulePropLists::genericMacroExpansionLty e, depth - 1 */ );
pp.txt' 0 2 "typepath: ";
pp.lit "--printing of Typepath not implemented yet--";
};
};
fi;
}
also
fun unparse_generic pp
=
unparse_f
where
fun unparse_f (mld::GENERIC { a_generic_api, typechecked_generic, ... }, symbolmapstack, depth)
=>
if (depth <= 1)
#
pp.lit "<generic package>";
else
pp.box' 0 -1 {. pp.rulename "upb15";
pp.lit "a_generic_api:";
uj::newline_indent pp 2;
unparse_generic_api pp (a_generic_api, symbolmapstack, depth - 1);
pp.newline();
pp.lit "typechecked_generic:";
uj::newline_indent pp 2;
unparse_typechecked_generic pp (typechecked_generic, symbolmapstack, depth - 1);
};
fi;
unparse_f (mld::ERRONEOUS_GENERIC, _, _)
=>
pp.lit "<error generic package>";
end;
end
also
fun unparse_type_bind pp (type, symbolmapstack)
=
{
#
fun visible_dcons (type, 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,
\\ _ = raise exception syx::UNBOUND));
# Test whether the sumtypes of actual and
# found constructor agree:
case (tu::sumtype_to_type found)
#
type1 as tdt::SUM_TYPE _
=>
# The expected form in packages
if (tu::types_are_equal (type, type1))
found ! find rest;
else find rest;
fi;
tdt::TYPE_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;
pp.box' 0 -1 {. pp.rulename "upb16";
pp.lit "unparse_type_bind failure: ";
pp.newline();
unparse_type symbolmapstack pp type;
pp.newline();
unparse_type symbolmapstack pp d_found;
pp.newline();
};
internals := old_internals;
find rest;
};
esac;
}
except
syx::UNBOUND = find rest;
find []
=>
[];
end;
end; # fun visible_dcons
#
fun body_of_typescheme_else_nop (tdt::TYPESCHEME_TYPOID { typescheme => tdt::TYPESCHEME { body, ... }, ... } )
=>
body;
body_of_typescheme_else_nop type
=>
type;
end;
#
fun unparse_valcon (tdt::VALCON { name, typoid, ... } )
=
{ uj::unparse_symbol pp name;
#
type = body_of_typescheme_else_nop typoid;
if (mtt::is_arrow_type typoid)
#
# pps " of ";
pp.lit " ";
unparse_typoid symbolmapstack pp (mtt::domain typoid);
fi;
};
if *internals
#
pp.box' 0 -1 {. pp.rulename "upb17";
pp.lit /*2007-12-07CrT"type "*/"";
unparse_type symbolmapstack pp type;
};
else
case type
#
tdt::SUM_TYPE { namepath, arity, is_eqtype, kind, ... }
=>
case (*is_eqtype, kind)
#
(_, tdt::SUMTYPE { index, family => { members, ... }, ... } )
=>
# Ordinary enum
#
{ (vector::get (members, index))
->
{ valcons, ... };
visdcons = visible_dcons (type, valcons);
incomplete = length visdcons < length valcons;
pp.box' 0 -1 {. pp.rulename "upb19";
# pp.lit "enum";
uj::unparse_symbol pp (ip::last namepath);
unparse_formals pp arity;
pp.lit " ";
case visdcons
#
NIL => pp.lit " = ...";
first ! rest
=>
{ pp.txt' 0 2 " ";
#
pp.box' 0 -1 {. pp.rulename "upb20";
#
pp.lit "= ";
unparse_valcon first;
apply
(\\ d = { pp.txt " "; pp.lit "| "; unparse_valcon d; })
rest;
if incomplete
pp.txt " ";
pp.lit "... ";
fi;
};
};
esac;
};
};
_ =>
{ pp.box' 0 -1 {. pp.rulename "upb21";
#
if (eq_types::is_equality_type type)
pp.lit "eqtype";
else pp.lit /*2007-12-07CrT"type "*/"";
fi;
uj::unparse_symbol pp (ip::last namepath);
unparse_formals pp arity;
pp.lit " ";
};
};
esac;
tdt::NAMED_TYPE { namepath, typescheme => tdt::TYPESCHEME { arity, body }, ... }
=>
{ pp.wrap' 0 2 {. pp.rulename "upw4";
pp.lit /*2007-12-07CrT"type "*/"";
uj::unparse_symbol pp (ip::last namepath);
unparse_formals pp arity;
pp.lit " =";
pp.txt " ";
unparse_typoid symbolmapstack pp body;
};
};
type => { pp.lit "strange type: ";
unparse_type symbolmapstack pp type;
};
esac;
fi;
} # fun unparse_type_bind pp
also
fun unparse_replicate_naming
pp
( tdt::NAMED_TYPE {
typescheme => tdt::TYPESCHEME {
body => tdt::TYPCON_TYPOID (right_type, _),
...
},
namepath,
...
},
symbolmapstack
)
=>
{
pp.wrap' 0 2 {. pp.rulename "upbw5";
# pp.lit "enum"; pp.txt " ";
uj::unparse_symbol pp (ip::last namepath);
pp.lit " ="; pp.txt " ";
# pp.lit "enum"; pp.txt " ";
unparse_type symbolmapstack pp right_type;
};
};
unparse_replicate_naming _ _
=>
error_message::impossible "prettyprintReplicateNaming";
end
also
fun unparse_typechecked_package pp (typechecked_package, symbolmapstack, depth)
=
case typechecked_package
#
mld::TYPE_ENTRY type
=>
unparse_type symbolmapstack pp type;
mld::PACKAGE_ENTRY typechecked_package
=>
unparse_generics_expansion pp (typechecked_package, symbolmapstack, depth - 1);
mld::GENERIC_ENTRY typechecked_generic
=>
unparse_typechecked_generic pp (typechecked_generic, symbolmapstack, depth - 1);
mld::ERRONEOUS_ENTRY
=>
pp.lit "ERRONEOUS_ENTRY";
esac
also
fun unparse_typerstore pp (typerstore, symbolmapstack, depth)
=
if (depth <= 1)
#
pp.lit "<typerstore>";
else
(uj::ppvseq
pp 2 ""
(\\ pp =
\\ (module_stamp, typechecked_package)
=
pp.box' 0 2 {. pp.rulename "upb22";
pp.lit (stamppath::module_stamp_to_string module_stamp);
pp.lit ":";
uj::newline_indent pp 2;
unparse_typechecked_package pp (typechecked_package, symbolmapstack, depth - 1);
pp.newline();
}
)
(tro::to_list typerstore));
fi
also
fun unparse_module_declaration pp (module_declaration, depth)
=
if (depth <= 0)
#
pp.lit "<module_declaration>";
else
case module_declaration
#
mld::TYPE_DECLARATION ( module_stamp, type_expression )
=>
{ pp.lit "ed::TYPE_DECLARATIOn: ";
unparse_typechecked_package_variable pp module_stamp;
pp.txt' 1 0 " ";
unparse_type_expression pp (type_expression, depth - 1);
};
mld::PACKAGE_DECLARATION (module_stamp, package_expression, symbol)
=>
{ pp.lit "ed::PACKAGE_DECLARATION: ";
unparse_typechecked_package_variable pp module_stamp;
pp.txt' 1 0 " ";
unparse_package_expression pp (package_expression, depth - 1);
pp.txt' 1 0 " ";
uj::unparse_symbol pp symbol;
};
mld::GENERIC_DECLARATION (module_stamp, generic_expression)
=>
{ pp.lit "ed::GENERIC_DECLARATION: ";
unparse_typechecked_package_variable pp module_stamp;
pp.txt' 1 0 " ";
unparse_generic_expression pp (generic_expression, depth - 1);
};
mld::SEQUENTIAL_DECLARATIONS typechecked_package_decs
=>
uj::ppvseq pp 0 ""
(\\ pp =
\\ module_declaration =
unparse_module_declaration pp (module_declaration, depth)
)
typechecked_package_decs;
mld::LOCAL_DECLARATION (typechecked_package_dec_l, typechecked_package_dec_b)
=>
pp.lit "ed::LOCAL_DECLARATION:";
mld::ERRONEOUS_ENTRY_DECLARATION
=>
pp.lit "ed::ERRONEOUS_ENTRY_DECLARATION:";
mld::EMPTY_GENERIC_EVALUATION_DECLARATION
=>
pp.lit "ed::EMPTY_GENERIC_EVALUATION_DECLARATION:";
esac;
fi
also
fun unparse_package_expression pp (package_expression, depth)
=
if (depth <= 0)
#
pp.lit "<packageexpression>";
else
case package_expression
#
mld::VARIABLE_PACKAGE ep
=>
{ pp.lit "syx::VARIABLE_PACKAGE:";
pp.txt' 1 0 " ";
unparse_stamppath pp ep;
};
mld::CONSTANT_PACKAGE { stamp, inverse_path, ... }
=>
{ pp.lit "syx::CONSTANT_PACKAGE:";
pp.txt' 1 0 " ";
uj::unparse_inverse_path pp inverse_path;
};
mld::PACKAGE { stamp, module_declaration }
=>
{ pp.lit "syx::PACKAGE:";
pp.txt' 1 0 " ";
unparse_module_declaration pp (module_declaration, depth - 1);
};
mld::APPLY (generic_expression, package_expression)
=>
{ pp.box {. pp.rulename "upb23";
pp.lit "syx::AP:";
pp.txt' 1 0 " ";
pp.box {. pp.rulename "upb23b";
pp.lit "fct:"; unparse_generic_expression pp (generic_expression, depth - 1);
pp.txt " ";
pp.lit "arg:"; unparse_package_expression pp (package_expression, depth - 1);
};
};
};
mld::PACKAGE_LET { declaration => module_declaration, expression => package_expression }
=>
{ pp.box {. pp.rulename "upb24";
pp.lit "syx::PACKAGE_LET:";
pp.txt' 1 0 " ";
pp.box {. pp.rulename "upb24b";
pp.lit "stipulate:"; unparse_module_declaration pp (module_declaration, depth - 1);
pp.txt " ";
pp.lit "herein:"; unparse_package_expression pp (package_expression, depth - 1);
};
};
};
mld::ABSTRACT_PACKAGE (an_api, package_expression)
=>
{ pp.box {. pp.rulename "upb25";
pp.lit "syx::ABSTRACT_PACKAGE:";
pp.txt' 1 0 " ";
pp.box {. pp.rulename "upb25b";
pp.lit "an_api: <omitted>";
pp.txt " ";
pp.lit "sexp:"; unparse_package_expression pp (package_expression, depth - 1);
};
};
};
mld::COERCED_PACKAGE { boundvar, raw, coercion }
=>
{ pp.box {. pp.rulename "upb26";
pp.lit "syx::COERCED_PACKAGE:";
pp.txt' 1 -1 " ";
pp.box {. pp.rulename "upb26b";
unparse_typechecked_package_variable pp boundvar;
pp.txt' 1 0 " ";
pp.lit "src:"; unparse_package_expression pp (raw, depth - 1);
pp.txt " ";
pp.lit "tgt:"; unparse_package_expression pp (coercion, depth - 1);
};
};
};
mld::FORMAL_PACKAGE (an_api)
=>
pp.lit "syx::FORMAL_PACKAGE:";
esac;
fi
also
fun unparse_generic_expression pp (generic_expression, depth)
=
if (depth <= 0)
#
pp.lit "<genericexpression>";
else
case generic_expression
#
mld::VARIABLE_GENERIC ep
=>
{ pp.lit "fe::VARIABLE_GENERIC:";
unparse_stamppath pp ep;
};
mld::CONSTANT_GENERIC { inverse_path, ... }
=>
{ pp.lit "fe::CONSTANT_GENERIC:";
uj::unparse_inverse_path pp inverse_path;
};
mld::LAMBDA_TP { parameter, body, ... }
=>
{ pp.box {. pp.rulename "upb27";
pp.lit "fe::LAMBDA_TP:";
pp.txt' 1 0 " ";
pp.box {. pp.rulename "upb27b";
pp.lit "parameter:"; unparse_typechecked_package_variable pp parameter;
pp.txt " ";
pp.lit "body:"; unparse_package_expression pp (body, depth - 1);
};
};
};
mld::LAMBDA { parameter, body }
=>
{ pp.box {. pp.rulename "upb28";
pp.lit "fe::LAMBDA:";
pp.txt' 1 0 " ";
pp.box {. pp.rulename "upb28b";
pp.lit "parameter:"; unparse_typechecked_package_variable pp parameter;
pp.txt " ";
pp.lit "body:"; unparse_package_expression pp (body, depth - 1);
};
};
};
mld::LET_GENERIC (module_declaration, generic_expression)
=>
{ pp.box {. pp.rulename "upb29";
pp.lit "fe::LET_GENERIC:";
pp.txt' 1 0 " ";
pp.box {. pp.rulename "upb29b";
pp.lit "stipulate:"; unparse_module_declaration pp (module_declaration, depth - 1);
pp.txt " ";
pp.lit "herein:"; unparse_generic_expression pp (generic_expression, depth - 1);
};
};
};
esac;
fi
/*
also prettyprintBodyExpression pp (bodyExpression, depth) =
if depth <= 0 then pp.lit "<bodyExpression>" else
case bodyExpression
of mld::FLEX an_api => pp.lit "be::F:"
| mld::OPAQ (an_api, packageexpression) =>
(begin_align_box pp;
pp.lit "be::O:"; break pp { spaces=1, indent_on_wrap=1 };
prettyprintPackageexpression pp (packageexpression, depth - 1);
end_box pp)
| mld::TNSP (an_api, packageexpression) =>
(begin_align_box pp;
pp.lit "be::T:"; break pp { spaces=1, indent_on_wrap=1 };
prettyprintPackageexpression pp (packageexpression, depth - 1);
end_box pp)
*/
also
fun unparse_closure pp (mld::GENERIC_CLOSURE { parameter_module_stamp => parameter,
body_package_expression => body,
typerstore => symbolmapstack
},
depth
)
=
pp.box' 0 -1 {. pp.rulename "upb30";
#
pp.lit "GENERIC_CLOSURE:";
pp.txt' 1 0 " ";
pp.box' 0 -1 {. pp.rulename "upb30b";
pp.lit "parameter: ";
unparse_typechecked_package_variable pp parameter;
pp.newline();
pp.lit "body: "; unparse_package_expression pp (body, depth - 1);
pp.newline();
pp.lit "dictionary: "; unparse_typerstore pp (symbolmapstack, syx::empty, depth - 1);
};
}
# Assumes no newline is needed before prettyprinting:
also
fun unparse_naming pp (name, naming: sxe::Symbolmapstack_Entry, symbolmapstack: syx::Symbolmapstack, depth: Int)
=
case naming
#
sxe::NAMED_VARIABLE var
=>
{ pp.lit /*2007-12-08CrT:"my "*/"";
unparse_variable pp (var, symbolmapstack);
};
sxe::NAMED_CONSTRUCTOR con
=>
unparse_con_naming pp (con, symbolmapstack);
sxe::NAMED_TYPE type
=>
unparse_type_bind pp (type, symbolmapstack);
sxe::NAMED_API an_api
=>
pp.box' 0 -1 {. pp.rulename "upb31";
#
pp.lit "api ";
uj::unparse_symbol pp name;
pp.lit " =";
pp.txt' 2 -1 " ";
unparse_api0 pp (an_api, symbolmapstack, depth, NULL);
};
sxe::NAMED_GENERIC_API fs
=>
pp.box' 0 2 {. pp.rulename "upb32";
pp.lit "funsig ";
uj::unparse_symbol pp name;
unparse_generic_api pp (fs, symbolmapstack, depth);
};
sxe::NAMED_PACKAGE str
=>
pp.box' 0 -1 {. pp.rulename "upb33";
pp.lit "packageX ";
uj::unparse_symbol pp name;
pp.lit " :";
pp.txt' 2 -1 " ";
unparse_package pp (str, symbolmapstack, depth);
};
sxe::NAMED_GENERIC fct
=>
pp.box' 0 -1 {. pp.rulename "upb34";
pp.lit "generic package ";
uj::unparse_symbol pp name;
pp.lit " : <sig>"; # David B MacQueen -- should print the api XXX SUCKO FIXME
};
sxe::NAMED_FIXITY fixity
=>
{ pp.lit (fixity::fixity_to_string fixity);
uj::unparse_symbol pp 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 pp (symbolmapstack, topenv, depth, boundsyms)
=
{ namings = case boundsyms
#
NULL => syx::to_sorted_list symbolmapstack;
THE l => fold_backward
(\\ (x, bs)
=
(x, syx::get (symbolmapstack, x)) ! bs
except
syx::UNBOUND = bs
)
[]
l;
esac;
pp_env = syx::atop (symbolmapstack, topenv);
uj::unparse_sequence pp
{ separator => \\ pp = pp.newline(),
breakstyle => uj::ALIGN,
print_one => (\\ pp =
\\ (name, naming)
=
unparse_naming pp (name, naming, pp_env, depth)
)
}
(all_prettyprintable_namings namings pp_env);
};
fun unparse_open pp (path, pkg, symbolmapstack, depth)
=
pp.box' 0 -1 {. pp.rulename "upb35";
#
pp.lit "including ";
uj::unparse_symbol_path pp 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, ... }
=>
{ pp.newline();
pp.box' 0 -1 {. pp.rulename "upb37";
unparse_elements
( syx::atop (api_to_symbolmapstack an_api, symbolmapstack),
depth,
THE typerstore
)
pp
api_elements;
};
};
mld::ERRONEOUS_API
=>
();
esac;
mld::ERRONEOUS_PACKAGE => ();
mld::PACKAGE_API _ => bug "unparse_open";
esac;
fi;
pp.newline();
};
fun unparse_api pp (an_api, symbolmapstack, depth)
=
unparse_api0 pp (an_api, symbolmapstack, depth, NULL);
}; # package unparse_package_language
end; # stipulate