## unparse-deep-syntax.pkg
# Compiled by:
# src/lib/compiler/front/typer/typer.sublib### "Whenever the C++ language designers had two competing ideas as to how
### they should solve some problem, they said, "OK, we'll do them both."
###
### "So the language is too baroque for my taste."
###
### -- Donald E Knuth
# 2007-12-05 Crt: I'm not sure how this package relates to
#
# src/lib/compiler/src/print/unparse-interactive-deep-syntax-declaration.pkg#
# which also prints out deep syntax declarations.
stipulate
package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package sci = sourcecode_info; # sourcecode_info is from src/lib/compiler/front/basics/source/sourcecode-info.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkgherein
api Unparse_Deep_Syntax {
#
unparse_pattern
:
syx::Symbolmapstack
-> pp::Prettyprinter
-> (ds::Case_Pattern, Int)
-> Void;
unparse_expression
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Prettyprinter
-> (ds::Deep_Expression, Int)
-> Void;
unparse_declaration
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Prettyprinter
-> (ds::Declaration, Int)
-> Void;
unparse_rule
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Prettyprinter
-> (ds::Case_Rule, Int)
-> Void;
unparse_named_value
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Prettyprinter
-> (ds::Named_Value, Int)
-> Void;
unparse_recursively_named_value
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Prettyprinter
-> (ds::Named_Recursive_Value, Int)
-> Void;
unparse_package_expression
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Prettyprinter
-> (ds::Package_Expression, Int)
-> Void;
lineprint: Ref( Bool );
debugging: Ref( Bool );
}; # Api Unparse_Deep_Syntax
end;
stipulate
package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package fis = find_in_symbolmapstack; # find_in_symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/find-in-symbolmapstack.pkg package fxt = fixity; # fixity is from src/lib/compiler/front/basics/map/fixity.pkg package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package sci = sourcecode_info; # sourcecode_info is from src/lib/compiler/front/basics/source/sourcecode-info.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.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package tpl = tuples; # tuples is from src/lib/compiler/front/typer-stuff/types/tuples.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 uv = unparse_value; # unparse_value is from src/lib/compiler/front/typer/print/unparse-value.pkg package vac = variables_and_constructors; # variables_and_constructors is from src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg Pp = pp::Pp;
herein
package unparse_deep_syntax
: (weak) Unparse_Deep_Syntax # Unparse_Deep_Syntax is from src/lib/compiler/front/typer/print/unparse-deep-syntax.pkg {
# Debugging:
#
say = control_print::say;
debugging = REF FALSE;
fun if_debugging_say (msg: String)
=
if *debugging say msg; say "\n"; fi;
fun bug msg
=
err::impossible("unparse_deep_syntax: " + msg);
# internals = typer_control::internals;
internals = log::internals;
lineprint = REF FALSE;
fun by f x y
=
f y x;
null_fix = fxt::INFIX (0, 0);
inf_fix = fxt::INFIX (1000000, 100000);
fun stronger_l (fxt::INFIX(_, m), fxt::INFIX (n, _)) => m >= n;
stronger_l _ => FALSE; # should not matter
end;
fun stronger_r (fxt::INFIX(_, m), fxt::INFIX (n, _)) => n > m;
stronger_r _ => TRUE; # should not matter
end;
fun prpos ( pp: pp::Prettyprinter,
source: sci::Sourcecode_Info,
charpos: Int
)
=
if *lineprint
#
(sci::filepos source charpos)
->
( file: String,
line: Int,
pos: Int
);
pp.lit (int::to_string line);
pp.lit ".";
pp.lit (int::to_string pos);
else
pp.lit (int::to_string charpos);
fi;
fun checkpat (n, NIL)
=>
TRUE;
checkpat (n, (symbol, _) ! fields)
=>
sy::eq (symbol, tpl::number_to_label n) and checkpat (n+1, fields);
end;
fun checkexp (n, NIL)
=>
TRUE;
checkexp (n, (ds::NUMBERED_LABEL { name=>symbol, ... }, _) ! fields)
=>
sy::eq (symbol, tpl::number_to_label n) and checkexp (n+1, fields);
end;
fun is_tuplepat (ds::RECORD_PATTERN { fields => [_], ... } ) => FALSE;
is_tuplepat (ds::RECORD_PATTERN { is_incomplete => FALSE, fields, ... } ) => checkpat (1, fields);
is_tuplepat _ => FALSE;
end;
fun is_tupleexp (ds::RECORD_IN_EXPRESSION [_]) => FALSE;
is_tupleexp (ds::RECORD_IN_EXPRESSION fields) => checkexp (1, fields);
is_tupleexp (ds::SOURCE_CODE_REGION_FOR_EXPRESSION (a, _)) => is_tupleexp a;
is_tupleexp _ => FALSE;
end;
fun get_fix (symbolmapstack, symbol)
=
fis::find_fixity_by_symbol
(
symbolmapstack,
sy::make_fixity_symbol (sy::name symbol)
);
fun strip_source_code_region_data (ds::SOURCE_CODE_REGION_FOR_EXPRESSION (a, _)) => strip_source_code_region_data a;
strip_source_code_region_data x => x;
end;
fun unparse_pattern symbolmapstack pp
=
{ fun unparse_pattern' (_, 0) => pp.lit "<pattern>";
unparse_pattern' (ds::VARIABLE_IN_PATTERN v, _) => if *internals uv::unparse_variable pp (symbolmapstack, v); # More verbose version of next line.
else uv::unparse_var pp v;
fi;
unparse_pattern' (ds::WILDCARD_PATTERN, _) => pp.lit "_";
unparse_pattern' (ds::INT_CONSTANT_IN_PATTERN (i, t), _) => pp.lit (multiword_int::to_string i);
/* pp.box' 0 2 {. pp.rulename "udb1";
pp.lit "("; pp.lit (multiword_int::to_string i);
pp.lit " :"; pp.txt' 0 2 " ";
unparse_type symbolmapstack pp t; pp.lit ")";
};
*/
unparse_pattern' (ds::UNT_CONSTANT_IN_PATTERN (w, t), _)
=>
pp.lit (multiword_int::to_string w);
/* pp.cbox {. pp.rulename "udcb1";
pp.lit "("; pp.lit (multiword_int::to_string w);
pp.lit " :"; pp.txt' 0 2 " ";
unparse_type symbolmapstack pp t;
pp.lit ")";
};
*/
unparse_pattern' (ds::FLOAT_CONSTANT_IN_PATTERN r, _) => pp.lit r;
unparse_pattern' (ds::STRING_CONSTANT_IN_PATTERN s, _) => uj::unparse_mlstring pp s;
unparse_pattern' (ds::CHAR_CONSTANT_IN_PATTERN s, _) => uj::unparse_mlstring' pp s;
unparse_pattern' (ds::AS_PATTERN (v, p), d)
=>
{ pp.cbox {. pp.rulename "udcb2";
unparse_pattern'(v, d);
pp.lit " as ";
unparse_pattern'(p, d - 1);
};
};
# Handle 0 length case specially to avoid {, ... }:
unparse_pattern' (ds::RECORD_PATTERN { fields => [], is_incomplete, ... }, _)
=>
if is_incomplete pp.lit "{... }";
else pp.lit "()";
fi;
unparse_pattern' (r as ds::RECORD_PATTERN { fields, is_incomplete, ... }, d)
=>
if (is_tuplepat r)
#
uj::unparse_closed_sequence pp
{ front => \\ pp = pp.lit "(",
separator => \\ pp = pp.txt ", ",
back => \\ pp = pp.lit ")",
print_one => (\\ _ = \\ (symbol, pattern) = unparse_pattern'(pattern, d - 1) ),
breakstyle => uj::ALIGN
}
fields;
else
uj::unparse_closed_sequence pp
{ front => \\ pp = pp.lit "{ ",
separator => \\ pp = pp.txt ", ",
back => (\\ pp = if is_incomplete pp.txt ", ... }";
else pp.txt " }";
fi
),
print_one => (\\ pp = \\ (symbol, pattern) =
{ uj::unparse_symbol pp symbol;
pp.lit " => ";
unparse_pattern'(pattern, d - 1);
}
),
breakstyle => uj::ALIGN
}
fields;
fi;
unparse_pattern' (ds::VECTOR_PATTERN (NIL, _), d)
=>
pp.lit "#[]";
unparse_pattern' (ds::VECTOR_PATTERN (pats, _), d)
=>
{ fun print_one _ pattern
=
unparse_pattern'(pattern, d - 1);
uj::unparse_closed_sequence pp
{ front => \\ pp = pp.lit "#[",
separator => \\ pp = { pp.lit ", ";
pp.cut();
},
back => \\ pp = pp.lit "]",
print_one,
breakstyle => uj::ALIGN
}
pats;
};
unparse_pattern' (pattern as (ds::OR_PATTERN _), d)
=>
{ fun make_list (ds::OR_PATTERN (hd, tl)) => hd ! make_list tl;
make_list p => [p];
end;
fun print_one _ pattern
=
unparse_pattern' (pattern, d - 1);
uj::unparse_closed_sequence pp
{
front => \\ pp = pp.lit "(",
separator => \\ pp = { pp.txt " ";
pp.lit "| ";
},
back => \\ pp = pp.lit ")",
print_one,
breakstyle => uj::ALIGN
}
(make_list pattern);
};
unparse_pattern' (ds::CONSTRUCTOR_PATTERN (e, _), _)
=>
uv::unparse_valcon pp e;
unparse_pattern' (p as ds::APPLY_PATTERN _, d)
=>
unparse_valcon_pattern (symbolmapstack, pp) (p, null_fix, null_fix, d);
unparse_pattern' (ds::TYPE_CONSTRAINT_PATTERN (p, t), d)
=>
{ pp.cbox {. pp.rulename "udcb2";
unparse_pattern'(p, d - 1);
pp.lit " :";
pp.txt' 0 2 " ";
ut::unparse_typoid symbolmapstack pp t;
};
};
unparse_pattern' _ => bug "unparse_pattern'";
end;
unparse_pattern';
}
also
fun unparse_valcon_pattern (symbolmapstack, pp)
=
{ fun lpcond atom = if atom pp.lit "("; fi;
fun rpcond atom = if atom pp.lit ")"; fi;
fun unparse_valcon_pattern'(_, _, _, 0) => pp.lit "<pattern>";
#
unparse_valcon_pattern' (ds::CONSTRUCTOR_PATTERN (tdt::VALCON { name, ... }, _), l: fxt::Fixity, r: fxt::Fixity, _)
=>
uj::unparse_symbol pp name;
unparse_valcon_pattern'(ds::TYPE_CONSTRAINT_PATTERN (p, t), l, r, d)
=>
{ pp.box {. pp.rulename "udcb3";
pp.lit "(";
unparse_pattern symbolmapstack pp (p, d - 1);
pp.lit " :";
pp.txt' 0 2 " ";
ut::unparse_typoid symbolmapstack pp t;
pp.lit ")";
};
};
unparse_valcon_pattern'(ds::AS_PATTERN (v, p), l, r, d)
=>
{ pp.box {. pp.rulename "udcb4";
pp.lit "(";
unparse_pattern symbolmapstack pp (v, d);
pp.txt " as ";
unparse_pattern symbolmapstack pp (p, d - 1);
pp.lit ")";
};
};
unparse_valcon_pattern' (ds::APPLY_PATTERN (tdt::VALCON { name, ... }, _, p), l, r, d)
=>
{ name' = sy::name name;
# should really have original path, like for VARIABLE_IN_EXPRESSION
this_fix = get_fix (symbolmapstack, name);
eff_fix = case this_fix fxt::NONFIX => inf_fix; x => x; esac;
atom = stronger_r (eff_fix, r) or stronger_l (l, eff_fix);
pp.box {. pp.rulename "udcb5";
#
lpcond atom;
case (this_fix, p)
#
(fxt::INFIX _, ds::RECORD_PATTERN { fields => [(_, pl), (_, pr)], ... } )
=>
{ my (left, right)
=
if atom (null_fix, null_fix);
else ( l, r);
fi;
unparse_valcon_pattern' (pl, left, this_fix, d - 1);
pp.txt " ";
pp.lit name';
pp.txt " ";
unparse_valcon_pattern' (pr, this_fix, right, d - 1);
};
_ =>
{ pp.lit name';
pp.txt " ";
unparse_valcon_pattern'(p, inf_fix, inf_fix, d - 1);
};
esac;
rpcond atom;
};
};
unparse_valcon_pattern' (p, _, _, d)
=>
unparse_pattern symbolmapstack pp (p, d);
end;
unparse_valcon_pattern';
};
fun trim [x] => [];
trim (a ! b) => a ! trim b;
trim [] => [];
end;
fun unparse_expression (context as (symbolmapstack, source_opt)) pp
=
{ fun lparen () = pp.lit "(";
fun rparen () = pp.lit ")";
fun lpcond atom = if atom pp.lit "("; fi;
fun rpcond atom = if atom pp.lit ")"; fi;
fun unparse_expression' (_, _, 0) => pp.lit "<expression>";
#
unparse_expression' ( ds::VALCON_IN_EXPRESSION { valcon, ... }, _, _) => uv::unparse_valcon pp valcon;
unparse_expression' ( ds::VARIABLE_IN_EXPRESSION { var => REF var, ... }, _, _) => if *internals uv::unparse_variable pp (symbolmapstack, var); # More verbose version of next line.
else uv::unparse_var pp var;
fi;
unparse_expression' ( ds::INT_CONSTANT_IN_EXPRESSION (i, t), _, _) => pp.lit (multiword_int::to_string i);
unparse_expression' ( ds::UNT_CONSTANT_IN_EXPRESSION (w, t), _, _) => pp.lit (multiword_int::to_string w);
unparse_expression' ( ds::FLOAT_CONSTANT_IN_EXPRESSION r, _, _) => pp.lit r;
unparse_expression' (ds::STRING_CONSTANT_IN_EXPRESSION s, _, _) => uj::unparse_mlstring pp s;
unparse_expression' ( ds::CHAR_CONSTANT_IN_EXPRESSION s, _, _) => uj::unparse_mlstring' pp s;
unparse_expression' (r as ds::RECORD_IN_EXPRESSION fields, _, d)
=>
if (is_tupleexp r)
#
uj::unparse_closed_sequence pp
{
front => \\ pp = pp.lit "(",
separator => \\ pp = pp.txt ", ",
back => \\ pp = pp.lit ")",
#
print_one => (\\ _ = \\ (_, expression) = unparse_expression' (expression, FALSE, d - 1)),
breakstyle => uj::ALIGN
}
fields;
else
uj::unparse_closed_sequence pp
{ front => \\ pp = pp.lit "{ ",
separator => \\ pp = pp.txt ", ",
back => \\ pp = pp.lit "}",
print_one => (\\ pp = \\ (ds::NUMBERED_LABEL { name, ... }, expression)
=
{ uj::unparse_symbol pp name;
pp.lit " => ";
unparse_expression' (expression, FALSE, d);
}
),
breakstyle => uj::ALIGN
}
fields;
fi;
unparse_expression' (ds::RECORD_SELECTOR_EXPRESSION (ds::NUMBERED_LABEL { name, ... }, expression), atom, d)
=>
{ pp.box {. pp.rulename "udcb6";
lpcond atom;
pp.lit "#";
uj::unparse_symbol pp name;
pp.txt " ";
unparse_expression' (expression, TRUE, d - 1);
# pp.lit ">";
rpcond atom;
};
};
unparse_expression' (ds::VECTOR_IN_EXPRESSION (NIL, _), _, d)
=>
pp.lit "#[]";
unparse_expression' (ds::VECTOR_IN_EXPRESSION (exps, _), _, d)
=>
{ fun print_one _ expression
=
unparse_expression' (expression, FALSE, d - 1);
uj::unparse_closed_sequence pp
{ front => \\ pp = pp.txt "#[ ",
separator => \\ pp = pp.txt ", ",
back => \\ pp = pp.txt " ]",
print_one,
breakstyle => uj::ALIGN
}
exps;
};
unparse_expression' (ds::ABSTRACTION_PACKING_EXPRESSION (e, t, tcs), atom, d)
=>
if *internals
#
pp.box {. pp.rulename "udcb7";
pp.lit "<ABSTRACTION_PACKING_EXPRESSION: ";
unparse_expression' (e, FALSE, d);
pp.endlit ";";
pp.txt' 0 2 " ";
ut::unparse_typoid symbolmapstack pp t;
pp.lit ">";
};
else
unparse_expression' (e, atom, d);
fi;
unparse_expression' (ds::SEQUENTIAL_EXPRESSIONS exps, _, d)
=>
uj::unparse_closed_sequence pp
{ front => \\ pp = pp.lit "(",
separator => \\ pp = { pp.endlit ";";
pp.txt " ";
},
back => \\ pp = pp.lit ")",
print_one => (\\ _ = \\ expression = unparse_expression' (expression, FALSE, d - 1)),
breakstyle => uj::ALIGN
}
exps;
unparse_expression' (e as ds::APPLY_EXPRESSION _, atom, d)
=>
{ infix0 = fxt::INFIX (0, 0);
#
lpcond atom;
unparse_app_expression (e, null_fix, null_fix, d);
rpcond atom;
};
unparse_expression' (ds::TYPE_CONSTRAINT_EXPRESSION (e, t), atom, d)
=>
{ pp.box {. pp.rulename "udcb8";
lpcond atom;
unparse_expression' (e, FALSE, d);
pp.lit ":";
pp.txt' 0 2 " ";
ut::unparse_typoid symbolmapstack pp t;
rpcond atom;
};
};
unparse_expression' (ds::EXCEPT_EXPRESSION (expression, (rules, _)), atom, d)
=>
{ pp.box {. pp.rulename "udcb9";
lpcond atom;
unparse_expression' (expression, atom, d - 1);
pp.newline();
pp.lit "except ";
uj::newline_indent pp 2;
uj::ppvlist pp (" ", "| ",
(\\ pp = \\ r = unparse_rule context pp (r, d - 1)), rules);
rpcond atom;
};
};
unparse_expression' (ds::RAISE_EXPRESSION (expression, _), atom, d)
=>
{ pp.box {. pp.rulename "udcb10";
lpcond atom;
pp.lit "raise exception ";
unparse_expression' (expression, TRUE, d - 1);
rpcond atom;
};
};
unparse_expression' (ds::LET_EXPRESSION (declaration, expression), _, d)
=>
{ pp.box {. pp.rulename "udcb11";
pp.lit "stipulate ";
pp.cbox {. pp.rulename "udcb11a";
unparse_declaration context pp (declaration, d - 1);
};
pp.txt " ";
pp.lit "herein ";
pp.cbox {. pp.rulename "udcb11b";
unparse_expression' (expression, FALSE, d - 1);
};
pp.txt " ";
pp.lit "end;";
};
};
unparse_expression' (ds::CASE_EXPRESSION (expression, rules, _), _, d)
=>
{ pp.box {. pp.rulename "udcb12";
pp.lit "case (";
unparse_expression' (expression, TRUE, d - 1);
pp.lit ")";
pp.ind 4;
uj::ppvlist pp ( "",
"; ",
(\\ pp = \\ r = unparse_rule context pp (r, d - 1)),
trim rules
);
pp.ind 0;
pp.txt " ";
pp.lit "esac";
};
};
unparse_expression' (ds::IF_EXPRESSION { test_case, then_case, else_case }, atom, d)
=>
{ pp.box {. pp.rulename "udcb13";
# lpcond atom;
pp.lit "if ";
pp.box {. pp.rulename "udcb13a";
unparse_expression' (test_case, FALSE, d - 1);
};
pp.ind 4;
pp.box {. pp.rulename "udcb13b";
unparse_expression' (then_case, FALSE, d - 1);
};
pp.ind 0;
pp.txt " ";
pp.txt "else";
pp.ind 4;
pp.cbox {. pp.rulename "udcb13c";
unparse_expression' (else_case, FALSE, d - 1);
};
pp.ind 0;
pp.txt " ";
pp.txt "fi";
# rpcond atom;
};
};
unparse_expression' (ds::AND_EXPRESSION (e1, e2), atom, d)
=>
{ pp.box {. pp.rulename "udcb14";
lpcond atom;
pp.ind 4;
pp.box {. pp.rulename "udcb14a";
unparse_expression' (e1, TRUE, d - 1);
};
pp.ind 0;
pp.txt " ";
pp.lit "and";
pp.ind 4;
pp.box {. pp.rulename "udcb14b";
unparse_expression' (e2, TRUE, d - 1);
};
pp.ind 0;
pp.cut ();
rpcond atom;
};
};
unparse_expression' (ds::OR_EXPRESSION (e1, e2), atom, d)
=>
{ pp.box {. pp.rulename "udcb15";
lpcond atom;
pp.ind 4;
pp.box {. pp.rulename "udcb15a";
unparse_expression' (e1, TRUE, d - 1);
};
pp.ind 0;
pp.txt " ";
pp.lit "or";
pp.ind 4;
pp.box {. pp.rulename "udcb15b";
unparse_expression' (e2, TRUE, d - 1);
};
pp.ind 0;
pp.cut ();
rpcond atom;
};
};
unparse_expression' (ds::WHILE_EXPRESSION { test, expression }, atom, d)
=>
{ pp.box {. pp.rulename "udcb16";
pp.lit "for (";
pp.box {. pp.rulename "udcb16a";
unparse_expression' (test, FALSE, d - 1);
};
pp.txt ")";
pp.ind 4;
pp.box {. pp.rulename "udcb16b";
unparse_expression' (expression, FALSE, d - 1);
};
};
};
unparse_expression' (ds::FN_EXPRESSION (rules, _), _, d)
=>
{ pp.box {. pp.rulename "udb2";
uj::ppvlist pp ("(\\ ", " | ",
(\\ pp = \\ r =
unparse_rule context pp (r, d - 1)),
trim rules);
rparen();
};
};
unparse_expression' (ds::SOURCE_CODE_REGION_FOR_EXPRESSION (expression, (s, e)), atom, d)
=>
case source_opt
#
NULL => unparse_expression' (expression, atom, d);
THE source
=>
if *internals
#
pp.lit "<MARK(";
prpos (pp, source, s);
pp.lit ", ";
prpos (pp, source, e);
pp.lit "): ";
unparse_expression' (expression, FALSE, d);
pp.lit ">";
else
unparse_expression' (expression, atom, d);
fi;
esac;
end
also
fun unparse_app_expression (_, _, _, 0)
=>
pp.lit "<expression>";
unparse_app_expression arg
=>
apply_print arg
where
fun fixitypp (symbol, operand, left_fix, right_fix, d)
=
{ name = syp::to_string (syp::SYMBOL_PATH symbol);
#
this_fix = case symbol
[symbol] => get_fix (symbolmapstack, symbol);
_ => fxt::NONFIX;
esac;
fun pr_non expression
=
{ pp.box {. pp.rulename "udcb17";
pp.lit name;
pp.txt " ";
unparse_expression' (expression, TRUE, d - 1);
};
};
case this_fix
#
fxt::INFIX _ => case (strip_source_code_region_data operand)
#
ds::RECORD_IN_EXPRESSION [(_, pl), (_, pr)]
=>
{ atom = stronger_l (left_fix, this_fix)
or stronger_r (this_fix, right_fix);
my (left, right)
=
if atom (null_fix, null_fix );
else (left_fix, right_fix);
fi;
pp.box {. pp.rulename "udcb18";
lpcond atom;
unparse_app_expression (pl, left, this_fix, d - 1);
pp.txt " ";
pp.lit name;
pp.txt " ";
unparse_app_expression (pr, this_fix, right, d - 1);
rpcond atom;
};
};
e' => pr_non e';
esac;
fxt::NONFIX => pr_non operand;
esac;
};
fun apply_print (_, _, _, 0)
=>
pp.lit "#";
apply_print (ds::APPLY_EXPRESSION { operator, operand }, l, r, d)
=>
case (strip_source_code_region_data operator)
#
ds::VALCON_IN_EXPRESSION { valcon => tdt::VALCON { name, ... }, ... }
=>
fixitypp ([name], operand, l, r, d);
ds::VARIABLE_IN_EXPRESSION { var => v, ... }
=>
{ path = case *v
vac::PLAIN_VARIABLE { path=>syp::SYMBOL_PATH path', ... } => path';
vac::OVERLOADED_VARIABLE { name, ... } => [name];
errorvar => [sy::make_value_symbol "<errorvar>"];
esac;
fixitypp (path, operand, l, r, d);
};
operator
=>
{ pp.box {. pp.rulename "udcb19";
unparse_expression' (operator, TRUE, d - 1); pp.txt' 0 2 " ";
unparse_expression' (operand, TRUE, d - 1);
};
};
esac;
apply_print (ds::SOURCE_CODE_REGION_FOR_EXPRESSION (expression, (s, e)), l, r, d)
=>
case source_opt
#
NULL => apply_print (expression, l, r, d);
THE source
=>
if *internals
#
pp.box {.
pp.lit "<MARK(";
prpos (pp, source, s); pp.txt ", ";
prpos (pp, source, e); pp.txt "): ";
unparse_expression' (expression, FALSE, d); pp.endlit ">";
};
else
apply_print (expression, l, r, d);
fi;
esac;
apply_print (e, _, _, d)
=>
unparse_expression' (e, TRUE, d);
end;
end;
end;
(\\ (expression, depth)
=
unparse_expression' (expression, FALSE, depth));
}
also
fun unparse_rule (context as (symbolmapstack, source_opt)) pp (ds::CASE_RULE (pattern, expression), d)
=
if (d > 0)
#
pp.box {. pp.rulename "udcb120";
unparse_pattern symbolmapstack pp (pattern, d - 1);
pp.ind 4;
pp.txt "=> ";
unparse_expression context pp (expression, d - 1);
};
else
pp.lit "<rule>";
fi
also
fun unparse_named_value (context as (symbolmapstack, source_opt)) pp (ds::VALUE_NAMING { pattern, expression, ... }, d)
=
if (d > 0)
#
pp.box {. pp.rulename "udcb21";
unparse_pattern symbolmapstack pp (pattern, d - 1);
pp.ind 4;
pp.txt "= ";
unparse_expression context pp (expression, d - 1);
};
else
pp.lit "<naming>";
fi
also
fun unparse_recursively_named_value context pp (ds::NAMED_RECURSIVE_VALUE { variable=>var, expression, ... }, d)
=
if (d > 0)
#
pp.box {. pp.rulename "udcb22";
uv::unparse_var pp var;
pp.ind 4;
pp.txt "= ";
unparse_expression context pp (expression, d - 1);
};
else
pp.lit "<rec naming>";
fi
# NB: The original 1992 deep syntax unparser still exists, in
#
# src/lib/compiler/src/print/unparse-interactive-deep-syntax-declaration.pkg #
# It gets called only by
#
# src/lib/compiler/toplevel/interact/read-eval-print-loop-g.pkg #
# which uses it to display the results of interactive expression evaluation.
#
# The more recent version here gets used for everything else.
# It gets called from:
#
# src/lib/compiler/front/typer/main/type-core-language.pkg # src/lib/compiler/toplevel/main/translate-raw-syntax-to-execode-g.pkg # src/lib/compiler/toplevel/main/print-hooks.pkg #
also
fun unparse_declaration (context as (symbolmapstack, source_opt)) pp
=
{ fun unparse_declaration' (_, 0)
=>
pp.lit "<declaration>";
unparse_declaration' (ds::VALUE_DECLARATIONS value_declarations, d)
=>
{ pp.box {. pp.rulename "udcb23";
#
uj::ppvlist pp
( "my ",
"also ",
(\\ pp = \\ named_value = unparse_named_value context pp (named_value, d - 1)),
value_declarations
);
};
};
unparse_declaration' (ds::RECURSIVE_VALUE_DECLARATIONS recursive_value_declarations, d)
=>
{ pp.box {. pp.rulename "udcb24";
#
uj::ppvlist pp
( "my rec ",
"also ",
(\\ pp
=
\\ named_recursive_values
=
unparse_recursively_named_value context pp (named_recursive_values, d - 1)
),
recursive_value_declarations
);
};
};
unparse_declaration' (ds::TYPE_DECLARATIONS types, d)
=>
{ fun f pp (tdt::NAMED_TYPE { namepath, typescheme=>tdt::TYPESCHEME { arity, body }, ... } )
=>
{ case arity
#
0 => ();
1 => pp.lit "'a ";
n => { uj::unparse_tuple pp pp::lit (ut::type_formals n);
pp.lit " ";
};
esac;
uj::unparse_symbol pp (ip::last namepath);
pp.lit " = ";
ut::unparse_typoid symbolmapstack pp body;
};
f _ _ => bug "unparse_declaration' (TYPE_DECLARATIONS)";
end;
pp.box {. pp.rulename "udcb25";
#
uj::ppvlist pp (
"", # was "type "
" also ",
f,
types
);
};
};
unparse_declaration' (ds::SUMTYPE_DECLARATIONS { sumtypes, with_types }, d)
=>
{ fun unparse_data pp (tdt::SUM_TYPE { namepath, arity, kind, ... } )
=>
case kind
#
tdt::SUMTYPE(_)
=>
{ case arity
#
0 => ();
1 => pp.lit "'a ";
n => { uj::unparse_tuple pp pp::lit (ut::type_formals n);
pp.lit " ";
};
esac;
uj::unparse_symbol pp (ip::last namepath);
pp.lit " = ...";
/*
uj::unparse_sequence
pp
{ separator => (\\ pp = { pp.lit " |";
pp.txt " ";
}
),
print_one => (\\ pp =
\\ (tdt::VALCON { name, ... } ) =
uj::unparse_symbol pp name),
breakstyle => uj::ALIGN
}
dcons;
*/
};
_ =>
bug "unparse_declaration' (SUMTYPE_DECLARATIONS) 1.1";
esac;
unparse_data _ _
=>
bug "unparse_declaration' (SUMTYPE_DECLARATIONS) 1.2";
end;
fun unparse_with pp (tdt::NAMED_TYPE { namepath, typescheme=>tdt::TYPESCHEME { arity, body }, ... } )
=>
{ case arity
0 => ();
1 => pp.lit "'a ";
n => { uj::unparse_tuple pp pp::lit (ut::type_formals n);
pp.lit " ";
};
esac;
uj::unparse_symbol pp (ip::last namepath);
pp.lit " = ";
ut::unparse_typoid symbolmapstack pp body;
};
unparse_with _ _ => bug "unparse_declaration' (SUMTYPE_DECLARATIONS) 2";
end;
# Could call PPDec::unparse_declaration here:
pp.cbox {. pp.rulename "udcb26";
uj::ppvlist pp (
"", # Was "enum "
"also ",
unparse_data,
sumtypes
);
pp.newline();
uj::ppvlist pp ("withtype ", "also ", unparse_with, with_types);
};
};
unparse_declaration' (ds::EXCEPTION_DECLARATIONS ebs, d)
=>
{ fun f pp ( ds::NAMED_EXCEPTION {
exception_constructor => tdt::VALCON { name, ... },
exception_typoid => etype,
...
}
)
=>
pp.box {.
#
uj::unparse_symbol pp name;
case etype
#
NULL => ();
THE typoid => { pp.lit " of ";
ut::unparse_typoid symbolmapstack pp typoid;
};
esac;
};
f pp (ds::DUPLICATE_NAMED_EXCEPTION { exception_constructor => tdt::VALCON { name, ... },
equal_to => tdt::VALCON { name=>name', ... }
}
)
=>
pp.box {.
uj::unparse_symbol pp name;
pp.ind 4;
pp.txt "= ";
uj::unparse_symbol pp name';
};
end;
pp.cbox {. pp.rulename "udcb27";
uj::ppvlist pp ("exception ", "also ", f, ebs);
};
};
unparse_declaration' (ds::PACKAGE_DECLARATIONS sbs, d)
=>
{ fun f pp (ds::NAMED_PACKAGE { name_symbol=>name, a_package=>mld::A_PACKAGE { varhome, ... }, definition=>def } )
=>
pp.box {.
uj::unparse_symbol pp name;
uv::unparse_varhome pp varhome;
pp.ind 4;
pp.txt "= ";
unparse_package_expression context pp (def, d - 1);
};
f _ x
=>
{ case x
ds::NAMED_PACKAGE { a_package=>mld::A_PACKAGE _, ... } => printf "unparse_declaration: PACKAGE_DECLARATION: unsupported case: NAMED_PACKAGE.A_PACKAGE.\n";
ds::NAMED_PACKAGE { a_package=>mld::ERRONEOUS_PACKAGE, ... } => printf "unparse_declaration: PACKAGE_DECLARATION: unsupported case: NAMED_PACKAGE.ERRONEOUS_PACKAGE.\n";
ds::NAMED_PACKAGE { a_package=>mld::PACKAGE_API _, ... } => printf "unparse_declaration: PACKAGE_DECLARATION: unsupported case: NAMED_PACKAGE.PACKAGE_API.\n";
esac;
# bug "unparse_declaration: PACKAGE_DECLARATION: NAMED_PACKAGE";
};
end;
pp.box {. pp.rulename "udcb28";
uj::ppvlist pp ("package ", "also ", f, sbs);
};
};
unparse_declaration' (ds::GENERIC_DECLARATIONS fbs, d)
=>
{ fun f pp (ds::NAMED_GENERIC { name_symbol=>fname, a_generic => mld::GENERIC { varhome, ... }, definition=>def } )
=>
pp.box {.
uj::unparse_symbol pp fname;
uv::unparse_varhome pp varhome;
pp.ind 4;
pp.txt "= ";
unparse_generic_expression context pp (def, d - 1);
};
f _ _
=>
bug "unparse_declaration': GENERIC_DECLARATION";
end;
pp.cbox {. pp.rulename "udcb29";
uj::ppvlist pp ("generic package ", "also ", f, fbs);
};
};
unparse_declaration' (ds::API_DECLARATIONS sigvars, d)
=>
{ fun f pp (mld::API { name, ... } )
=>
pp.box {.
#
pp.lit "api ";
case name
#
THE s => uj::unparse_symbol pp s;
NULL => pp.lit "ANONYMOUS";
esac;
};
f _ _ => bug "unparse_declaration': API_DECLARATIONS";
end;
pp.box {. pp.rulename "udcb30";
#
uj::unparse_sequence
pp
{ separator => \\ pp = pp.txt " ",
print_one => f,
breakstyle => uj::ALIGN
}
sigvars;
};
};
unparse_declaration' (ds::GENERIC_API_DECLARATIONS sigvars, d)
=>
{ fun print_one pp (mld::GENERIC_API { kind, ... } )
=>
{ pp.lit "funsig ";
#
case kind
THE s => uj::unparse_symbol pp s;
NULL => pp.lit "ANONYMOUS";
esac;
};
print_one _ _ => bug "unparse_declaration': GENERIC_API_DECLARATIONS";
end;
pp.box {. pp.rulename "udcb31";
#
uj::unparse_sequence
pp
{ separator => pp::newline,
print_one,
breakstyle => uj::ALIGN
}
sigvars;
};
};
unparse_declaration' (ds::LOCAL_DECLARATIONS (inner, outer), d)
=>
{ pp.box {. pp.rulename "udcb32";
pp.lit "stipulate";
pp.ind 4;
unparse_declaration' (inner, d - 1);
pp.ind 0;
pp.txt " ";
pp.lit "herein";
pp.ind 4;
unparse_declaration' (outer, d - 1);
pp.ind 0;
pp.txt " ";
pp.lit "end;";
};
};
unparse_declaration' (ds::SEQUENTIAL_DECLARATIONS decs, d)
=>
{ pp.box {. pp.rulename "udcb33";
#
uj::unparse_sequence
pp
{ separator => \\ pp = pp.txt " ",
print_one => (\\ pp = \\ declaration = unparse_declaration' (declaration, d)),
breakstyle => uj::ALIGN
}
decs;
};
};
unparse_declaration' (ds::FIXITY_DECLARATION { fixity, ops }, d)
=>
{ pp.box {. pp.rulename "udcb34";
#
case fixity
#
fxt::NONFIX => pp.lit "nonfix ";
fxt::INFIX (i, _)
=>
{ if (i % 2 == 0 ) pp.lit "infix ";
else pp.lit "infixr ";
fi;
if (i / 2 > 0 )
#
pp.lit (int::to_string (i / 2));
pp.lit " ";
fi;
};
esac;
uj::unparse_sequence
pp
{ separator => (\\ pp = pp.txt " "),
print_one => uj::unparse_symbol,
breakstyle => uj::ALIGN
}
ops;
};
};
unparse_declaration' (ds::OVERLOADED_VARIABLE_DECLARATION overloaded_variable, d)
=>
{ pp.lit "overloaded my ";
uv::unparse_var pp overloaded_variable;
};
unparse_declaration' (ds::INCLUDE_DECLARATIONS named_packages, d)
=>
{ pp.box {. pp.rulename "udcb35";
pp.lit "include package ";
uj::unparse_sequence
pp
{ separator => \\ pp = pp.txt " ",
print_one => \\ pp = \\ (sp, _) = pp.lit (syp::to_string sp),
breakstyle => uj::ALIGN
}
named_packages;
};
};
unparse_declaration' (ds::SOURCE_CODE_REGION_FOR_DECLARATION (declaration, (s, e)), d)
=>
case source_opt
#
NULL => unparse_declaration' (declaration, d);
THE source
=>
{
# 2007-09-14CrT: Source region stuff commented out because it clutters the printout horribly:
# pp.lit "SOURCE_CODE_REGION_FOR_DECLARATION(";
unparse_declaration' (declaration, d);
# pp.lit ", ";
# prpos (pp, source, s); # "s" for "start"
# pp.lit ", ";
# prpos (pp, source, e); # "e" for "end"
# pp.lit ")";
};
esac;
end;
unparse_declaration';
}
also
fun unparse_package_expression (context as (_, source_opt)) pp
=
{ fun unparse_package_expression' (_, 0)
=>
pp.lit "<package_expression>";
unparse_package_expression' (ds::PACKAGE_BY_NAME (mld::A_PACKAGE { varhome, ... } ), d)
=>
uv::unparse_varhome pp varhome;
unparse_package_expression'
(
ds::COMPUTED_PACKAGE {
a_generic => mld::GENERIC { varhome => fa, ... },
generic_argument => mld::A_PACKAGE { varhome => sa, ... },
...
},
d
)
=>
pp.box {.
uv::unparse_varhome pp fa;
pp.txt "( ";
uv::unparse_varhome pp sa;
pp.txt " )";
};
unparse_package_expression' (ds::PACKAGE_DEFINITION namings, d)
=>
{ pp.box {. pp.rulename "udcb36";
pp.txt "pkg ";
pp.lit "...";
# unparse_naming not yet undefined
/*
uj::unparse_sequence pp
{ separator => pp::newline,
print_one => (\\ pp = \\ b = unparse_naming context pp (b, d - 1)),
breakstyle => uj::ALIGN
}
namings;
*/
pp.lit "end";
};
};
unparse_package_expression' (ds::PACKAGE_LET { declaration, expression }, d)
=>
{ pp.box {. pp.rulename "udcb37";
pp.txt "stipulate";
pp.ind 4;
unparse_declaration context pp (declaration, d - 1);
pp.ind 0;
pp.txt " ";
pp.lit "herein";
pp.ind 4;
unparse_package_expression' (expression, d - 1);
pp.ind 0;
pp.txt " ";
pp.lit "end;";
};
};
unparse_package_expression' (ds::SOURCE_CODE_REGION_FOR_PACKAGE (body, (s, e)), d)
=>
case source_opt
#
THE source
=>
{
# 2007-09-14CrT: Source region stuff commented out because it clutters the printout horribly:
# pp.lit "SOURCE_CODE_REGION_FOR_PACKAGE(";
unparse_package_expression' (body, d);
# pp.lit ", ";
# prpos (pp, source, s); # "s" for "start"
# pp.lit ", ";
# prpos (pp, source, e); # "e" for "end"
# pp.lit ")";
};
NULL => unparse_package_expression' (body, d);
esac;
unparse_package_expression' _
=>
bug "unexpected package expression in prettyprintStrexp'";
end;
unparse_package_expression';
}
also
fun unparse_generic_expression (context as (_, source_opt)) pp
=
unparse_generic_expression'
where
fun unparse_generic_expression' (_, 0)
=>
pp.lit "<generic_expression>";
unparse_generic_expression' (ds::GENERIC_BY_NAME (mld::GENERIC { varhome, ... } ), d)
=>
uv::unparse_varhome pp varhome;
unparse_generic_expression' (ds::GENERIC_DEFINITION { parameter=>mld::A_PACKAGE { varhome, ... }, definition=>def, ... }, d)
=>
{ pp.lit " GENERIC(";
uv::unparse_varhome pp varhome;
pp.lit ") => ";
pp.newline();
unparse_package_expression context pp (def, d - 1);
};
unparse_generic_expression' (ds::GENERIC_LET (declaration, body), d)
=>
{ pp.box {. pp.rulename "udcb38";
pp.lit "stipulate";
pp.ind 4;
unparse_declaration context pp (declaration, d - 1);
pp.ind 0;
pp.txt " ";
pp.lit "herein";
pp.ind 4;
unparse_generic_expression' (body, d - 1);
pp.ind 0;
pp.txt " ";
pp.lit "end;";
};
};
unparse_generic_expression' (ds::SOURCE_CODE_REGION_FOR_GENERIC (body, (s, e)), d)
=>
case source_opt
#
THE source
=>
{
# 2007-09-14CrT: Source region stuff commented out because it clutters the printout horribly:
# pp.lit "SOURCE_CODE_REGION_FOR_GENERIC(";
unparse_generic_expression' (body, d);
pp.lit ", ";
# prpos (pp, source, s); ppsay ", ";
# prpos (pp, source, e); ppsay ")";
};
NULL => unparse_generic_expression' (body, d);
esac;
unparse_generic_expression' _
=>
bug "unexpected generic package expression in unparse_generic_expression'";
end;
end;
}; # package unparse_deep_syntax
end; # top-level stipulate