## 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 = prettyprint; # prettyprint is from src/lib/prettyprint/big/src/prettyprint.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::Stream
-> (ds::Case_Pattern, Int)
-> Void;
unparse_expression
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Stream
-> (ds::Deep_Expression, Int)
-> Void;
unparse_declaration
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Stream
-> (ds::Declaration, Int)
-> Void;
unparse_rule
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Stream
-> (ds::Case_Rule, Int)
-> Void;
unparse_named_value
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Stream
-> (ds::Named_Value, Int)
-> Void;
unparse_recursively_named_value
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Stream
-> (ds::Named_Recursive_Values, Int)
-> Void;
unparse_package_expression
:
(syx::Symbolmapstack, Null_Or( sci::Sourcecode_Info ))
-> pp::Stream
-> (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 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 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 #
include tuples;
include fixity;
include variables_and_constructors;
include types;
include prettyprint;
include unparse_junk; # unparse_junk is from src/lib/compiler/front/typer/print/unparse-junk.pkg include unparse_type; # unparse_type is from src/lib/compiler/front/typer/print/unparse-type.pkg include unparse_value; # unparse_value is from src/lib/compiler/front/typer/print/unparse-value.pkgherein
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";};
else ();fi;
fun bug msg
=
error_message::impossible("unparse_deep_syntax: " + msg);
internals = typer_control::internals;
lineprint = REF FALSE;
fun by f x y
=
f y x;
null_fix = INFIX (0, 0);
inf_fix = INFIX (1000000, 100000);
fun stronger_l (INFIX(_, m), INFIX (n, _)) => m >= n;
stronger_l _ => FALSE; # should not matter
end;
fun stronger_r (INFIX(_, m), INFIX (n, _)) => n > m;
stronger_r _ => TRUE; # should not matter
end;
fun prpos ( stream: pp::Stream,
source: sci::Sourcecode_Info,
charpos: Int
)
=
if *lineprint
my (file: String, line: Int, pos: Int)
=
sci::filepos source charpos;
pp::string stream (int::to_string line);
pp::string stream ".";
pp::string stream (int::to_string pos);
else
pp::string stream (int::to_string charpos);
fi;
fun checkpat (n, NIL)
=>
TRUE;
checkpat (n, (symbol, _) ! fields)
=>
sy::eq (symbol, 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, 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)
=
find_in_symbolmapstack::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 stream
=
{ ppsay = pp::string stream;
fun unparse_pattern' (_, 0) => ppsay "<pattern>";
# unparse_pattern' (ds::VARIABLE_IN_PATTERN v, _) => unparse_var stream v;
unparse_pattern' (ds::VARIABLE_IN_PATTERN v, _) => unparse_variable stream (symbolmapstack, v); # More verbose version of previous line.
unparse_pattern' (ds::WILDCARD_PATTERN, _) => ppsay "_";
unparse_pattern' (ds::INT_CONSTANT_IN_PATTERN (i, t), _) => ppsay (multiword_int::to_string i);
/* (begin_block stream INCONSISTENT 2;
ppsay "("; ppsay (multiword_int::to_string i);
ppsay " :"; break stream { spaces=1, indent_on_wrap=1 };
unparse_type symbolmapstack stream t; ppsay ")";
end_block stream)
*/
unparse_pattern' (ds::UNT_CONSTANT_IN_PATTERN (w, t), _)
=>
ppsay (multiword_int::to_string w);
/* (open_style_box INCONSISTENT stream (pp::CURSOR_RELATIVE 2);
ppsay "("; ppsay (multiword_int::to_string w);
ppsay " :"; break stream { spaces=1, indent_on_wrap=1 };
unparse_type symbolmapstack stream t; ppsay ")";
end_box stream)
*/
unparse_pattern' (ds::FLOAT_CONSTANT_IN_PATTERN r, _) => ppsay r;
unparse_pattern' (ds::STRING_CONSTANT_IN_PATTERN s, _) => unparse_mlstring stream s;
unparse_pattern' (ds::CHAR_CONSTANT_IN_PATTERN s, _) => unparse_mlstring' stream s;
unparse_pattern' (ds::AS_PATTERN (v, p), d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_pattern'(v, d); ppsay " as "; unparse_pattern'(p, d - 1);
end_box stream;
};
# Handle 0 length case specially to avoid {, ... }:
unparse_pattern' (ds::RECORD_PATTERN { fields => [], is_incomplete, ... }, _)
=>
if is_incomplete ppsay "{... }";
else ppsay "()";
fi;
unparse_pattern' (r as ds::RECORD_PATTERN { fields, is_incomplete, ... }, d)
=>
if (is_tuplepat r)
unparse_closed_sequence stream
{ front=>(by pp::string "("),
sep=>(fn stream = { pp::string stream ", ";
break stream { spaces=>0, indent_on_wrap=>0 };
}
),
back=>(by pp::string ")"),
pr=>(fn _ = fn (symbol, pattern) = unparse_pattern'(pattern, d - 1) ),
style=>INCONSISTENT
}
fields;
else
unparse_closed_sequence stream
{ front=>(by pp::string "{ "),
sep =>(fn stream = { pp::string stream ", ";
break stream { spaces=>0, indent_on_wrap=>0 };
}
),
back=>(fn stream = if is_incomplete pp::string stream ", ... }";
else pp::string stream "}";
fi
),
pr=>(fn stream = fn (symbol, pattern) =
{ unparse_symbol stream symbol;
pp::string stream " => ";
unparse_pattern'(pattern, d - 1);
}
),
style=>INCONSISTENT
}
fields;
fi;
unparse_pattern' (ds::VECTOR_PATTERN (NIL, _), d)
=>
ppsay "#[]";
unparse_pattern' (ds::VECTOR_PATTERN (pats, _), d)
=>
{ fun pr _ pattern
=
unparse_pattern'(pattern, d - 1);
unparse_closed_sequence stream
{ front => (by pp::string "#["),
sep => (fn stream => { pp::string stream ", ";
break stream { spaces=>0, indent_on_wrap=>0 } ;}; end ),
back => (by pp::string "]"),
pr,
style => INCONSISTENT
}
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 pr _ pattern
=
unparse_pattern' (pattern, d - 1);
unparse_closed_sequence stream
{
front => (by pp::string "("),
sep => fn stream => { break stream { spaces=>1, indent_on_wrap=>0 };
pp::string stream "| ";}; end ,
back => (by pp::string ")"),
pr,
style => INCONSISTENT
} (make_list pattern);
};
unparse_pattern' (ds::CONSTRUCTOR_PATTERN (e, _), _)
=>
unparse_dcon stream e;
unparse_pattern' (p as ds::APPLY_PATTERN _, d)
=>
unparse_dcon_pattern (symbolmapstack, stream) (p, null_fix, null_fix, d);
unparse_pattern' (ds::TYPE_CONSTRAINT_PATTERN (p, t), d)
=>
{ open_style_box INCONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_pattern'(p, d - 1); ppsay " :";
break stream { spaces=>1, indent_on_wrap=>2 };
unparse_type symbolmapstack stream t;
end_box stream;
};
unparse_pattern' _ => bug "unparse_pattern'";
end;
unparse_pattern';
}
also
fun unparse_dcon_pattern (symbolmapstack, stream)
=
{ ppsay = pp::string stream;
fun lpcond (atom) = if atom ppsay "("; fi;
fun rpcond (atom) = if atom ppsay ")"; fi;
fun unparse_dcon_pattern'(_, _, _, 0) => ppsay "<pattern>";
unparse_dcon_pattern' (ds::CONSTRUCTOR_PATTERN (VALCON { name, ... }, _), l: Fixity, r: Fixity, _)
=>
unparse_symbol stream name;
unparse_dcon_pattern'(ds::TYPE_CONSTRAINT_PATTERN (p, t), l, r, d)
=>
{ open_style_box INCONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppsay "(";
unparse_pattern symbolmapstack stream (p, d - 1);
ppsay " :";
break stream { spaces=>1, indent_on_wrap=>2 };
unparse_type symbolmapstack stream t;
ppsay ")";
end_box stream;
};
unparse_dcon_pattern'(ds::AS_PATTERN (v, p), l, r, d)
=>
{ open_style_box INCONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppsay "(";
unparse_pattern symbolmapstack stream (v, d);
break stream { spaces=>1, indent_on_wrap=>2 };
ppsay " as ";
unparse_pattern symbolmapstack stream (p, d - 1);
ppsay ")";
end_box stream;
};
unparse_dcon_pattern' (ds::APPLY_PATTERN (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 NONFIX => inf_fix; x => x; esac;
atom = stronger_r (eff_fix, r) or stronger_l (l, eff_fix);
open_style_box INCONSISTENT stream (pp::CURSOR_RELATIVE 2);
lpcond (atom);
case (this_fix, p)
#
(INFIX _, ds::RECORD_PATTERN { fields => [(_, pl), (_, pr)], ... } )
=>
{ my (left, right)
=
if atom (null_fix, null_fix);
else ( l, r); fi;
unparse_dcon_pattern' (pl, left, this_fix, d - 1);
break stream { spaces=>1, indent_on_wrap=>0 };
ppsay name';
break stream { spaces=>1, indent_on_wrap=>0 };
unparse_dcon_pattern' (pr, this_fix, right, d - 1);
};
_ =>
{ ppsay name';
break stream { spaces=>1, indent_on_wrap=>0 };
unparse_dcon_pattern'(p, inf_fix, inf_fix, d - 1);
};
esac;
rpcond atom;
end_box stream;
};
unparse_dcon_pattern' (p, _, _, d)
=>
unparse_pattern symbolmapstack stream (p, d);
end;
unparse_dcon_pattern';
};
fun trim [x] => [];
trim (a ! b) => a ! trim b;
trim [] => [];
end;
fun unparse_expression (context as (symbolmapstack, source_opt)) stream
=
{ ppsay = pp::string stream;
fun lparen () = ppsay "(";
fun rparen () = ppsay ")";
fun lpcond (atom) = if atom ppsay "("; fi;
fun rpcond (atom) = if atom ppsay ")"; fi;
fun unparse_expression' (_, _, 0) => ppsay "<expression>";
unparse_expression' (ds::VALCON_IN_EXPRESSION (con, _), _, _) => unparse_dcon stream con;
# unparse_expression' ( ds::VARIABLE_IN_EXPRESSION (REF var, _), _, _) => unparse_var stream var;
unparse_expression' ( ds::VARIABLE_IN_EXPRESSION (REF var, _), _, _) => unparse_variable stream (symbolmapstack, var); # More verbose version of previous line.
unparse_expression' ( ds::INT_CONSTANT_IN_EXPRESSION (i, t), _, _) => ppsay (multiword_int::to_string i);
unparse_expression' ( ds::UNT_CONSTANT_IN_EXPRESSION (w, t), _, _) => ppsay (multiword_int::to_string w);
unparse_expression' ( ds::FLOAT_CONSTANT_IN_EXPRESSION r, _, _) => ppsay r;
unparse_expression' (ds::STRING_CONSTANT_IN_EXPRESSION s, _, _) => unparse_mlstring stream s;
unparse_expression' ( ds::CHAR_CONSTANT_IN_EXPRESSION s, _, _) => unparse_mlstring' stream s;
unparse_expression' (r as ds::RECORD_IN_EXPRESSION fields, _, d)
=>
if (is_tupleexp r)
#
unparse_closed_sequence stream
{
front=>(by pp::string "("),
sep=>(fn stream = { pp::string stream ", ";
break stream { spaces=>0, indent_on_wrap=>0 }; } ),
back=>(by pp::string ")"),
pr=>(fn _ = fn (_, expression) = unparse_expression'(expression, FALSE, d - 1)),
style=>INCONSISTENT
}
fields;
else
unparse_closed_sequence stream
{ front=>(by pp::string "{ "),
sep=>(fn stream = { pp::string stream ", ";
break stream { spaces=>0, indent_on_wrap=>0 }; } ),
back=>(by pp::string "}"),
pr=>(fn stream =
fn (ds::NUMBERED_LABEL { name, ... }, expression) =
{ unparse_symbol stream name; ppsay "=";
unparse_expression'(expression, FALSE, d);
}
),
style=>INCONSISTENT
}
fields;
fi;
unparse_expression' (ds::RECORD_SELECTOR_EXPRESSION (ds::NUMBERED_LABEL { name, ... }, expression), atom, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
lpcond (atom);
ppsay "#"; unparse_symbol stream name;
unparse_expression'(expression, TRUE, d - 1); ppsay ">";
rpcond (atom);
end_box stream;
};
unparse_expression'(ds::VECTOR_IN_EXPRESSION (NIL, _), _, d)
=>
ppsay "#[]";
unparse_expression'(ds::VECTOR_IN_EXPRESSION (exps, _), _, d)
=>
{ fun pr _ expression = unparse_expression'(expression, FALSE, d - 1);
unparse_closed_sequence stream
{ front => (by pp::string "#["),
sep => (fn stream => { pp::string stream ", ";
break stream { spaces=>1, indent_on_wrap=>0 } ;}; end ),
back => (by pp::string "]"),
pr,
style => INCONSISTENT
}
exps;
};
unparse_expression'(ds::ABSTRACTION_PACKING_EXPRESSION (e, t, tcs), atom, d)
=>
if *internals
#
open_style_box INCONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppsay "<ABSTRACTION_PACKING_EXPRESSION: ";
unparse_expression'(e, FALSE, d);
ppsay "; ";
break stream { spaces=>1, indent_on_wrap=>2 };
unparse_type symbolmapstack stream t;
ppsay ">";
end_box stream;
else
unparse_expression'(e, atom, d);
fi;
unparse_expression'(ds::SEQUENTIAL_EXPRESSIONS exps, _, d)
=>
unparse_closed_sequence stream
{ front => (by pp::string "("),
sep => (fn stream => { pp::string stream ";";
break stream { spaces=>1, indent_on_wrap=>0 } ;}; end ),
back => (by pp::string ")"),
pr => (fn _ => fn expression => unparse_expression'(expression, FALSE, d - 1); end; end ),
style => INCONSISTENT
}
exps;
unparse_expression'(e as ds::APPLY_EXPRESSION _, atom, d)
=>
{ infix0 = 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)
=>
{ open_style_box INCONSISTENT stream (pp::CURSOR_RELATIVE 0);
lpcond (atom);
unparse_expression'(e, FALSE, d); ppsay ":";
break stream { spaces=>1, indent_on_wrap=>2 };
unparse_type symbolmapstack stream t;
rpcond (atom);
end_box stream;
};
unparse_expression'(ds::EXCEPT_EXPRESSION (expression, (rules, _)), atom, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
lpcond (atom);
unparse_expression'(expression, atom, d - 1); newline stream; ppsay "except ";
newline_indent stream 2;
ppvlist stream (" ", "| ",
(fn stream => fn r => unparse_rule context stream (r, d - 1); end; end ), rules);
rpcond (atom);
end_box stream;
};
unparse_expression'(ds::RAISE_EXPRESSION (expression, _), atom, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
lpcond (atom);
ppsay "raise exception "; unparse_expression'(expression, TRUE, d - 1);
rpcond (atom);
end_box stream;
};
unparse_expression'(ds::LET_EXPRESSION (declaration, expression), _, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppsay "stipulate ";
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_declaration context stream (declaration, d - 1);
end_box stream;
break stream { spaces=>1, indent_on_wrap=>0 };
ppsay "herein ";
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_expression'(expression, FALSE, d - 1);
end_box stream;
break stream { spaces=>1, indent_on_wrap=>0 };
ppsay "end;";
end_box stream;
};
unparse_expression'(ds::CASE_EXPRESSION (expression, rules, _), _, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppsay "case ("; unparse_expression'(expression, TRUE, d - 1); newline_indent stream 2;
ppvlist stream (") ", ";",
(fn stream = fn r = unparse_rule context stream (r, d - 1)),
trim rules);
rparen();
ppsay "esac";
end_box stream;
};
unparse_expression' (ds::IF_EXPRESSION { test_case, then_case, else_case }, atom, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
lpcond (atom);
ppsay "if ";
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_expression' (test_case, FALSE, d - 1);
end_box stream;
break stream { spaces=>1, indent_on_wrap=> 0 };
ppsay "then ";
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_expression' (then_case, FALSE, d - 1);
end_box stream;
break stream { spaces=>1, indent_on_wrap=> 0 };
ppsay "else ";
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_expression' (else_case, FALSE, d - 1);
end_box stream;
rpcond (atom);
end_box stream;
};
unparse_expression' (ds::AND_EXPRESSION (e1, e2), atom, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
lpcond (atom);
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_expression' (e1, TRUE, d - 1);
end_box stream;
break stream { spaces=>1, indent_on_wrap=> 0 };
ppsay "and ";
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_expression' (e2, TRUE, d - 1);
end_box stream;
rpcond (atom);
end_box stream;
};
unparse_expression' (ds::OR_EXPRESSION (e1, e2), atom, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
lpcond (atom);
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_expression' (e1, TRUE, d - 1);
end_box stream;
break stream { spaces=>1, indent_on_wrap=> 0 };
ppsay "or ";
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_expression' (e2, TRUE, d - 1);
end_box stream;
rpcond (atom);
end_box stream;
};
unparse_expression' (ds::WHILE_EXPRESSION { test, expression }, atom, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppsay "while ";
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_expression'(test, FALSE, d - 1);
end_box stream;
break stream { spaces=>1, indent_on_wrap=> 0 };
ppsay "do ";
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_expression'(expression, FALSE, d - 1);
end_box stream;
end_box stream;
};
unparse_expression'(ds::FN_EXPRESSION (rules, _), _, d)
=>
{ begin_horizontal_else_vertical_box stream;
ppvlist stream ("(fn ", " | ",
(fn stream => fn r =>
unparse_rule context stream (r, d - 1); end; end ),
trim rules);
rparen();
end_box stream;
};
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
#
ppsay "<MARK(";
prpos (stream, source, s);
ppsay ", ";
prpos (stream, source, e);
ppsay "): ";
unparse_expression'(expression, FALSE, d);
ppsay ">";
else
unparse_expression'(expression, atom, d);
fi;
esac;
end
also
fun unparse_app_expression (_, _, _, 0)
=>
pp::string stream "<expression>";
unparse_app_expression arg
=>
{ ppsay = pp::string stream;
fun fixitypp (symbol, operand, left_fix, right_fix, d)
=
{ name
=
symbol_path::to_string
(symbol_path::SYMBOL_PATH symbol);
this_fix
=
case symbol
[symbol] => get_fix (symbolmapstack, symbol);
_ => NONFIX;
esac;
fun pr_non expression
=
{ open_style_box INCONSISTENT stream (pp::CURSOR_RELATIVE 2);
ppsay name; break stream { spaces=>1, indent_on_wrap=>0 };
unparse_expression'(expression, TRUE, d - 1);
end_box stream;
};
case this_fix
#
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;
open_style_box INCONSISTENT stream (pp::CURSOR_RELATIVE 2);
lpcond (atom);
unparse_app_expression (pl, left, this_fix, d - 1);
break stream { spaces=>1, indent_on_wrap=>0 };
ppsay name;
break stream { spaces=>1, indent_on_wrap=>0 };
unparse_app_expression (pr, this_fix, right, d - 1);
rpcond (atom);
end_box stream;
};
e' => pr_non e';
esac;
NONFIX => pr_non operand;
esac;
};
fun apply_print (_, _, _, 0)
=>
ppsay "#";
apply_print (ds::APPLY_EXPRESSION (operator, operand), l, r, d)
=>
case (strip_source_code_region_data operator)
#
ds::VALCON_IN_EXPRESSION (VALCON { name, ... }, _)
=>
fixitypp ([name], operand, l, r, d);
ds::VARIABLE_IN_EXPRESSION (v, _)
=>
{ path
=
case *v
#
ORDINARY_VARIABLE { path=>symbol_path::SYMBOL_PATH path', ... } => path';
OVERLOADED_IDENTIFIER { name, ... } => [name];
errorvar => [sy::make_value_symbol "<errorvar>"];
esac;
fixitypp (path, operand, l, r, d);
};
operator
=>
{ open_style_box INCONSISTENT stream (pp::CURSOR_RELATIVE 2);
unparse_expression'(operator, TRUE, d - 1); break stream { spaces=>1, indent_on_wrap=>2 };
unparse_expression'(operand, TRUE, d - 1);
end_box stream;
};
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
#
ppsay "<MARK(";
prpos (stream, source, s); ppsay ", ";
prpos (stream, source, e); ppsay "): ";
unparse_expression'(expression, FALSE, d); ppsay ">";
else
apply_print (expression, l, r, d);
fi;
esac;
apply_print (e, _, _, d)
=>
unparse_expression'(e, TRUE, d);
end;
apply_print arg;
};
end;
(fn (expression, depth)
=
unparse_expression' (expression, FALSE, depth));
}
also
fun unparse_rule (context as (symbolmapstack, source_opt)) stream (ds::CASE_RULE (pattern, expression), d)
=
if (d > 0)
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_pattern symbolmapstack stream (pattern, d - 1);
pp::string stream " =>";
break stream { spaces=>1, indent_on_wrap=>2 };
unparse_expression context stream (expression, d - 1);
end_box stream;
else
pp::string stream "<rule>";
fi
also
fun unparse_named_value (context as (symbolmapstack, source_opt)) stream (ds::NAMED_VALUE { pattern, expression, ... }, d)
=
if (d > 0)
#
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_pattern symbolmapstack stream (pattern, d - 1);
pp::string stream " =";
break stream { spaces=>1, indent_on_wrap=>2 };
unparse_expression context stream (expression, d - 1);
end_box stream;
else
pp::string stream "<naming>";
fi
also
fun unparse_recursively_named_value context stream (ds::NAMED_RECURSIVE_VALUES { variable=>var, expression, ... }, d)
=
if (d > 0)
#
open_style_box INCONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_var stream var; pp::string stream " =";
break stream { spaces=>1, indent_on_wrap=>2 };
unparse_expression context stream (expression, d - 1);
end_box stream;
else
pp::string stream "<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)) stream
=
{ ppsay = pp::string stream;
fun unparse_declaration' (_, 0)
=>
ppsay "<declaration>";
unparse_declaration' (ds::VALUE_DECLARATIONS vbs, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppvlist stream ("my ", "also ",
(fn stream = fn named_value = unparse_named_value context stream (named_value, d - 1)), vbs);
end_box stream;
};
unparse_declaration' (ds::RECURSIVE_VALUE_DECLARATIONS rvbs, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppvlist stream ("my rec ", "also ",
(fn stream = fn named_recursive_values = unparse_recursively_named_value context stream (named_recursive_values, d - 1)), rvbs);
end_box stream;
};
unparse_declaration' (ds::TYPE_DECLARATIONS typs, d)
=>
{ fun f stream (DEFINED_TYP { path, type_scheme=>TYPE_SCHEME { arity, body }, ... } )
=>
{ case arity
0 => ();
1 => ppsay "'a ";
n => { unparse_tuple stream pp::string (type_formals n);
ppsay " ";
};
esac;
unparse_symbol
stream
(inverse_path::last path);
ppsay " = ";
unparse_type
symbolmapstack
stream
body;
};
f _ _
=>
bug "unparse_declaration' (TYPE_DECLARATIONS)";
end;
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppvlist stream (
"", # was "type "
" also ",
f,
typs
);
end_box stream;
};
unparse_declaration' (ds::ENUM_DECLARATIONS { datatyps, with_typs }, d)
=>
{ fun unparse_data stream (PLAIN_TYP { path, arity, kind, ... } )
=>
case kind
#
DATATYPE(_)
=>
{ case arity
0 => ();
1 => (ppsay "'a ");
n => { unparse_tuple stream pp::string (type_formals n);
ppsay " ";
};
esac;
unparse_symbol stream (inverse_path::last path); ppsay " = ...";
/*
unparse_sequence
stream
{ sep = (fn stream => (pp::string stream " |";
break stream { spaces=1, indent_on_wrap=0 } )),
pr = (fn stream =
fn (VALCON { name, ... } ) =
unparse_symbol stream name),
style = INCONSISTENT
}
dcons;
*/
};
_ =>
bug "unparse_declaration'(ENUM_DECLARATIONS) 1.1";
esac;
unparse_data _ _
=>
bug "unparse_declaration'(ENUM_DECLARATIONS) 1.2";
end;
fun unparse_with stream (DEFINED_TYP { path, type_scheme=>TYPE_SCHEME { arity, body }, ... } )
=>
{ case arity
0 => ();
1 => (ppsay "'a ");
n => { unparse_tuple stream pp::string (type_formals n);
ppsay " ";};
esac;
unparse_symbol stream (inverse_path::last path);
ppsay " = ";
unparse_type symbolmapstack stream body;
};
unparse_with _ _
=>
bug "unparse_declaration'(ENUM_DECLARATIONS) 2";
end;
# Could call PPDec::unparse_declaration here:
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppvlist stream (
"", # Was "enum "
"also ",
unparse_data,
datatyps
);
newline stream;
ppvlist stream ("withtype ", "also ", unparse_with, with_typs);
end_box stream;
};
unparse_declaration' (ds::ABSTRACT_TYPE_DECLARATION _, d)
=>
ppsay "abstype";
unparse_declaration' (ds::EXCEPTION_DECLARATIONS ebs, d)
=>
{ fun f stream ( ds::NAMED_EXCEPTION {
exception_constructor => VALCON { name, ... },
exception_type => etype,
...
}
)
=>
{ unparse_symbol stream name;
case etype
#
NULL => ();
THE type'
=>
{
# ppsay " of ";
unparse_type symbolmapstack stream type';
};
esac;
};
f stream (ds::DUPLICATE_NAMED_EXCEPTION { exception_constructor => VALCON { name, ... },
equal_to => VALCON { name=>name', ... }
}
)
=>
{ unparse_symbol stream name;
ppsay "=";
unparse_symbol stream name';
};
end;
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppvlist stream ("exception ", "also ", f, ebs);
end_box stream;
};
unparse_declaration' (ds::PACKAGE_DECLARATIONS sbs, d)
=>
{ fun f stream (ds::NAMED_PACKAGE { name_symbol=>name, a_package=>mld::A_PACKAGE { varhome, ... }, definition=>def } )
=>
{ unparse_symbol stream name;
unparse_varhome stream varhome;
ppsay " = ";
break stream { spaces=>1, indent_on_wrap=>2 };
unparse_package_expression context stream (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;
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppvlist stream ("package ", "also ", f, sbs);
end_box stream;
};
unparse_declaration' (ds::GENERIC_DECLARATIONS fbs, d)
=>
{ fun f stream (ds::NAMED_GENERIC { name_symbol=>fname, a_generic => mld::GENERIC { varhome, ... }, definition=>def } )
=>
{ unparse_symbol stream fname;
unparse_varhome stream varhome;
ppsay " = ";
break stream { spaces=>1, indent_on_wrap=> 2 };
unparse_generic_expression context stream (def, d - 1);
};
f _ _
=>
bug "unparse_declaration': GENERIC_DECLARATION";
end;
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppvlist stream ("generic package ", "also ", f, fbs);
end_box stream;
};
unparse_declaration' (ds::API_DECLARATIONS sigvars, d)
=>
{ fun f stream (mld::API { name, ... } )
=>
{ ppsay "api ";
case name
#
THE s => unparse_symbol stream s;
NULL => ppsay "ANONYMOUS";
esac;
};
f _ _
=>
bug "unparse_declaration': API_DECLARATIONS";
end;
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_sequence
stream
{ sep => newline,
pr => f,
style => CONSISTENT
}
sigvars;
end_box stream;
};
unparse_declaration'(ds::GENERIC_API_DECLARATIONS sigvars, d)
=>
{ fun f stream (mld::GENERIC_API { kind, ... } )
=>
{ ppsay "funsig ";
case kind
THE s => unparse_symbol stream s;
NULL => ppsay "ANONYMOUS";
esac;
};
f _ _
=>
bug "unparse_declaration': GENERIC_API_DECLARATIONS"; end;
open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_sequence
stream
{ sep => newline,
pr => f,
style => CONSISTENT
}
sigvars;
end_box stream;
};
unparse_declaration' (ds::LOCAL_DECLARATIONS (inner, outer), d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppsay "with";
newline_indent stream 2;
unparse_declaration'(inner, d - 1);
newline stream;
ppsay "do";
newline stream;
unparse_declaration'(outer, d - 1);
newline stream;
ppsay "end;";
end_box stream;
};
unparse_declaration' (ds::SEQUENTIAL_DECLARATIONS decs, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
unparse_sequence
stream
{ sep => newline,
pr => (fn stream => fn declaration => unparse_declaration'(declaration, d); end; end ),
style => CONSISTENT
}
decs;
end_box stream;
};
unparse_declaration' (ds::FIXITY_DECLARATION { fixity, ops }, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
case fixity
#
NONFIX => ppsay "nonfix ";
INFIX (i, _)
=>
{ if (i % 2 == 0 ) ppsay "infix ";
else ppsay "infixr "; fi;
if (i / 2 > 0 ) ppsay (int::to_string (i / 2));
ppsay " "; fi;
};
esac;
unparse_sequence
stream
{ sep => (fn stream = break stream { spaces=>1, indent_on_wrap=>0 }),
pr => unparse_symbol,
style => INCONSISTENT
}
ops;
end_box stream;
};
unparse_declaration' (ds::OVERLOADED_VARIABLE_DECLARATION overloaded_variable, d)
=>
{ ppsay "overloaded my ";
unparse_var stream overloaded_variable;
};
unparse_declaration' (ds::INCLUDE_DECLARATIONS named_packages, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppsay "use ";
unparse_sequence
stream
{ sep => (fn stream = break stream { spaces=>1, indent_on_wrap=>0 } ),
pr => (fn stream = fn (sp, _) = ppsay (symbol_path::to_string sp)),
style => INCONSISTENT
}
named_packages;
end_box stream;
};
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:
# ppsay "SOURCE_CODE_REGION_FOR_DECLARATION(";
unparse_declaration'(declaration, d);
# ppsay ", ";
# prpos (stream, source, s); # "s" for "start"
# ppsay ", ";
# prpos (stream, source, e); # "e" for "end"
# ppsay ")";
};
esac;
end;
unparse_declaration';
}
also
fun unparse_package_expression (context as (_, source_opt)) stream
=
{ ppsay = pp::string stream;
fun unparse_package_expression' (_, 0)
=>
ppsay "<package_expression>";
unparse_package_expression' (ds::PACKAGE_BY_NAME (mld::A_PACKAGE { varhome, ... } ), d)
=>
unparse_varhome stream varhome;
unparse_package_expression'
(
ds::COMPUTED_PACKAGE {
a_generic => mld::GENERIC { varhome => fa, ... },
generic_argument => mld::A_PACKAGE { varhome => sa, ... },
...
},
d
)
=>
{ unparse_varhome stream fa;
ppsay"(";
unparse_varhome stream sa;
ppsay")";
};
unparse_package_expression' (ds::PACKAGE_DEFINITION namings, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppsay "pkg"; newline_indent stream 2;
ppsay "...";
# unparse_naming not yet undefined
/*
unparse_sequence stream
{ sep=newline,
pr=(fn stream => fn b => unparse_naming context stream (b, d - 1)),
style=CONSISTENT }
namings;
*/
ppsay "end";
end_box stream;
};
unparse_package_expression' (ds::PACKAGE_LET { declaration, expression }, d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppsay "stipulate ";
newline stream;
unparse_declaration context stream (declaration, d - 1);
newline stream;
ppsay "herein";
newline stream;
unparse_package_expression'( expression, d - 1);
newline stream;
ppsay "end;";
end_box stream;
};
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:
# ppsay "SOURCE_CODE_REGION_FOR_PACKAGE(";
unparse_package_expression'(body, d);
# ppsay ", ";
# prpos (stream, source, s); # "s" for "start"
# ppsay ", ";
# prpos (stream, source, e); # "e" for "end"
# ppsay ")";
};
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)) stream
=
unparse_generic_expression'
where
ppsay = pp::string stream;
fun unparse_generic_expression' (_, 0)
=>
ppsay "<generic_expression>";
unparse_generic_expression' (ds::GENERIC_BY_NAME (mld::GENERIC { varhome, ... } ), d)
=>
unparse_varhome stream varhome;
unparse_generic_expression' (ds::GENERIC_DEFINITION { parameter=>mld::A_PACKAGE { varhome, ... }, definition=>def, ... }, d)
=>
{ ppsay " GENERIC(";
unparse_varhome stream varhome;
ppsay ") => "; newline stream;
unparse_package_expression context stream (def, d - 1);
};
unparse_generic_expression' (ds::GENERIC_LET (declaration, body), d)
=>
{ open_style_box CONSISTENT stream (pp::CURSOR_RELATIVE 0);
ppsay "stipulate ";
unparse_declaration context stream (declaration, d - 1);
newline stream;
ppsay "herein";
newline stream;
unparse_generic_expression'(body, d - 1);
newline stream;
ppsay "end;";
end_box stream;
};
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:
# ppsay "SOURCE_CODE_REGION_FOR_GENERIC(";
unparse_generic_expression'(body, d); ppsay ", ";
# prpos (stream, source, s); ppsay ", ";
# prpos (stream, 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