## prettyprint-value.pkg
#
# This is a very quick-and-dirty partial conversion of unparse-value.pkg into prettyprint-value.pkg.
#
# The intended distinction between unparsing and prettyprinting is:
#
# o unparsing strives to produce something as close as possible
# to the original input -- Mythryl syntax code -- whereas
#
# o prettyprinting strives to produce a clear display of the
# datastructures in question -- mainly the parsetree.
#
# Unparsing is useful for showing what is being processed in compact
# and human-readable fashion; prettyprinting is useful for showing
# all the gory details of the intermediate representation so as to
# facilitate debugging detailed processing of it. -- 2013-09-24 CrT
# Compiled by:
# src/lib/compiler/front/typer/typer.sublib# Modified to use Lib7 Lib pp. [dbm, 7/30/03])
stipulate
package id = inlining_data; # inlining_data is from src/lib/compiler/front/typer-stuff/basics/inlining-data.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 tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-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.pkgherein
api Prettyprint_Value {
#
prettyprint_constructor_representation: pp::Prettyprinter
-> vh::Valcon_Form
-> Void;
prettyprint_varhome: pp::Prettyprinter -> vh::Varhome -> Void;
prettyprint_valcon: pp::Prettyprinter -> tdt::Valcon -> Void;
prettyprint_var: pp::Prettyprinter -> vac::Variable -> Void;
prettyprint_variable
:
pp::Prettyprinter
-> (syx::Symbolmapstack, vac::Variable)
-> Void
;
prettyprint_debug_valcon
#
: pp::Prettyprinter
-> syx::Symbolmapstack
-> tdt::Valcon
-> Void
;
prettyprint_constructor
:
pp::Prettyprinter
-> syx::Symbolmapstack
-> tdt::Valcon
-> Void
;
prettyprint_debug_var
:
pp::Prettyprinter
-> syx::Symbolmapstack
-> vac::Variable
-> Void
;
prettyprint_inlining_data
:
pp::Prettyprinter
-> syx::Symbolmapstack
-> id::Inlining_Data
-> Void
;
}; # Api Prettyprint_Value
end;
stipulate
package fis = find_in_symbolmapstack; # find_in_symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/find-in-symbolmapstack.pkg 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 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 ppt = prettyprint_type; # prettyprint_type is from src/lib/compiler/front/typer/print/prettyprint-type.pkg package syp = 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 tc = typer_control; # typer_control is from src/lib/compiler/front/typer/basics/typer-control.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package tys = 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;
prettyprint_typoid = ppt::prettyprint_typoid;
prettyprint_type = ppt::prettyprint_type;
prettyprint_typescheme = ppt::prettyprint_typescheme;
herein
package prettyprint_value
: (weak) Prettyprint_Value
{
# internals = tc::internals;
internals = log::internals;
fun by f x y
=
f y x;
fun prettyprint_varhome (pp:Pp) a
=
pp.lit ( " ["
+ (vh::print_varhome a)
+ "]"
);
fun prettyprint_constructor_representation (pp:Pp) representation
=
pp.lit (vh::print_representation representation);
fun prettyprint_csig (pp:Pp) csig
=
pp.lit (vh::print_constructor_api csig);
fun prettyprint_valcon pp
=
prettyprint_d
where
fun prettyprint_d ( tdt::VALCON { name, form => vh::EXCEPTION acc, ... } )
=>
{ uj::unparse_symbol pp name;
#
if *internals prettyprint_varhome pp acc; fi;
};
prettyprint_d (tdt::VALCON { name, ... } )
=>
uj::unparse_symbol pp name;
end;
end;
fun prettyprint_debug_valcon pp symbolmapstack (tdt::VALCON { name, form, is_constant, typoid, signature, is_lazy } )
=
{ unparse_symbol = uj::unparse_symbol pp;
#
pp.box' 0 0 {. pp.rulename "ppv1";
#
pp.lit "VALCON {";
pp.ind 2;
pp.box {. pp.txt "name= "; unparse_symbol name; }; pp.txt ", ";
pp.box {. pp.txt "is_constant= "; pp.lit (bool::to_string is_constant); }; pp.txt ", ";
pp.box {. pp.txt "typoid= "; prettyprint_typoid symbolmapstack pp typoid; }; pp.txt ", ";
pp.box {. pp.txt "is_lazy= "; pp.lit (bool::to_string is_lazy); }; pp.txt ", ";
pp.box {. pp.txt "pick_valcon_form= "; prettyprint_constructor_representation pp form; }; pp.txt ", ";
pp.box {. pp.txt "signature= ["; prettyprint_csig pp signature; pp.lit "]"; };
pp.ind 0;
pp.txt " ";
pp.lit "}";
};
};
fun prettyprint_constructor pp symbolmapstack (tdt::VALCON { name, form, is_constant, typoid, signature, is_lazy } )
=
{ unparse_symbol = uj::unparse_symbol pp;
#
pp.box {. pp.rulename "ppv2";
unparse_symbol name;
pp.txt ": ";
prettyprint_typoid symbolmapstack pp typoid;
};
};
fun prettyprint_inlining_data pp symbolmapstack inlining_data
=
{ (id::get_inlining_data_for_prettyprinting inlining_data)
->
(baseop, typoid);
pp.box {.
pp.lit "{";
pp.ind 4;
pp.box {.
pp.lit "baseop =>";
pp.txt " ";
pp.lit baseop;
pp.endlit ",";
};
pp.txt " ";
pp.box {.
pp.lit "typoid =>";
pp.txt " ";
prettyprint_typoid symbolmapstack pp typoid;
};
pp.ind 0;
pp.txt " ";
pp.lit "}";
};
};
fun prettyprint_sumtype
(
symbolmapstack: syx::Symbolmapstack,
tdt::VALCON { name, typoid, ... }
)
pp
=
pp.box' 0 -1 {. pp.rulename "pptw8";
uj::unparse_symbol pp name;
pp.txt ": ";
prettyprint_typoid symbolmapstack pp typoid;
};
# Is this ever used?
fun prettyprint_constructor_naming pp
=
prettyprint_constructor
where
fun prettyprint_constructor (tdt::VALCON { name, typoid, form=>vh::EXCEPTION _, ... }, symbolmapstack)
=>
{ pp.box' 0 -1 {. pp.rulename "ppv3";
#
pp.lit "exception ";
uj::unparse_symbol pp name;
if (mtt::is_arrow_type typoid)
#
pp.txt " ";
prettyprint_typoid symbolmapstack pp (mtt::domain typoid);
fi;
pp.endlit ";";
};
};
prettyprint_constructor (con, symbolmapstack)
=>
{ exception HIDDEN;
#
visible_valcon_type
=
{ type = tys::sumtype_to_type con;
#
( type_junk::type_equality (
fis::find_type_via_symbol_path
( symbolmapstack,
syp::SYMBOL_PATH
[ ip::last (type_junk::namepath_of_type type) ],
\\ _ = raise exception HIDDEN
),
type
)
except
HIDDEN = FALSE
);
};
if (*internals
or
not visible_valcon_type
)
pp.box' 0 -1 {. pp.rulename "ppv4";
pp.lit "constructor ";
prettyprint_sumtype (symbolmapstack, con) pp;
pp.endlit ";";
};
fi;
};
end;
end;
fun prettyprint_var pp (vac::PLAIN_VARIABLE { varhome, path, ... } )
=>
{ pp.lit (syp::to_string path);
#
if *internals
prettyprint_varhome pp varhome;
fi;
};
prettyprint_var pp (vac::OVERLOADED_VARIABLE { name, ... } )
=>
uj::unparse_symbol pp name;
prettyprint_var pp errorvar
=>
pp.lit "<errorvar>";
end;
fun prettyprint_debug_var pp symbolmapstack
=
{ prettyprint_varhome = prettyprint_varhome pp;
prettyprint_inlining_data = prettyprint_inlining_data pp symbolmapstack;
fun prettyprintdebugvar (vac::PLAIN_VARIABLE { varhome, path, vartypoid_ref, inlining_data } )
=>
{ pp.box' 0 0 {. pp.rulename "ppv5";
pp.lit "vac::PLAIN_VARIABLE ( {";
pp.ind 2;
pp.box {. pp.txt "varhome =>"; pp.lit " "; prettyprint_varhome varhome; }; pp.txt ", ";
pp.box {. pp.txt "inlining_data =>"; pp.lit " "; prettyprint_inlining_data inlining_data; }; pp.txt ", ";
pp.box {. pp.txt "path =>"; pp.lit " "; pp.lit (syp::to_string path); }; pp.txt ", ";
pp.box {. pp.txt "vartypoid_ref =>"; pp.lit " REF "; prettyprint_typoid symbolmapstack pp *vartypoid_ref; };
pp.ind 0;
pp.txt " ";
pp.lit "} )";
};
};
prettyprintdebugvar (vac::OVERLOADED_VARIABLE { name, alternatives, typescheme } )
=>
{ pp.box' 0 0 {. pp.rulename "ppv7";
#
pp.lit "vac::OVERLOADED_VARIABLE ( {";
pp.ind 2;
pp.box {.
pp.lit "name=";
pp.txt " ";
uj::unparse_symbol pp (name);
};
pp.txt ", ";
pp.box {.
pp.lit "alternative=[";
pp.ind 4;
(uj::ppvseq pp 0 ", "
(\\ pp = \\ { indicator, variant }
=
{
pp.box {.
pp.lit "{";
pp.ind 4;
pp.box {.
pp.lit "indicator=";
pp.txt " ";
prettyprint_typoid symbolmapstack pp indicator;
};
pp.txt ", ";
pp.box {.
pp.lit "variant=";
pp.txt " ";
prettyprint_debug_var pp symbolmapstack variant;
};
pp.ind 0;
pp.txt " ";
pp.lit "}";
};
}
)
*alternatives);
pp.ind 0;
pp.txt " ";
pp.lit "]";
};
pp.txt ", ";
pp.box {.
pp.lit "typescheme=";
pp.txt " ";
prettyprint_typescheme symbolmapstack pp typescheme;
};
pp.ind 0;
pp.txt " ";
pp.lit "} )";
};
};
prettyprintdebugvar (errorvar) => pp.lit "<ERRORvar>";
end;
prettyprintdebugvar;
};
fun prettyprint_variable pp
=
prettyprint_variable'
where
#
fun prettyprint_variable'
(
symbolmapstack: syx::Symbolmapstack,
vac::PLAIN_VARIABLE { path, varhome, vartypoid_ref, inlining_data }
)
=>
{
pp::record pp "vac::PLAIN_VARIABLE"
[
("path", {. pp.lit (syp::to_string path); }),
("varhome", {. prettyprint_varhome pp varhome; }),
("inlining_data", {. prettyprint_inlining_data pp symbolmapstack inlining_data; }),
("vartypoid_ref", {. prettyprint_typoid symbolmapstack pp *vartypoid_ref; })
];
};
prettyprint_variable'
(
symbolmapstack,
vac::OVERLOADED_VARIABLE { name, alternatives=>REF alternatives, typescheme=>tdt::TYPESCHEME { body, arity } }
)
=>
{
pp::record pp "vac::OVERLOADED_VARIABLE"
[
("name", {. uj::unparse_symbol pp name; }),
("typescheme", {. pp::record pp "tdt::TYPESCHEME"
[
("arity", {. pp.lit (sprintf "%d" arity); }),
("body", {. prettyprint_typoid symbolmapstack pp body; })
];
}
),
("alternatives", {.
pp.lit "REF ";
pp.cbox' 0 0 {.
uj::unparse_sequence
pp
{ separator => \\ pp = pp.txt " ",
print_one => \\ pp = \\ { variant, ... } = prettyprint_variable' (symbolmapstack, variant),
breakstyle => uj::ALIGN
}
alternatives;
};
}
)
];
};
prettyprint_variable' (_, errorvar)
=>
pp.lit "<ERRORvar>;";
end;
end;
}; # package prettyprint_value
end; # stipulate