## unparse-interactive-deep-syntax-declaration.pkg
# Compiled by:
# src/lib/compiler/core.sublib# This is the original 1992 deep syntax unparser.
#
# It is used only by
#
# src/lib/compiler/toplevel/interact/read-eval-print-loop-g.pkg#
# for displaying results of interactive expression evaluation.
#
# Everywhere else we use the newer unparse_deep_syntax package from
#
# src/lib/compiler/front/typer/print/unparse-deep-syntax.pkg#
stipulate
package cms = compiler_mapstack_set; # compiler_mapstack_set is from src/lib/compiler/toplevel/compiler-state/compiler-mapstack-set.pkg package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package pp = prettyprint; # prettyprint is from src/lib/prettyprint/big/src/prettyprint.pkgherein
api Unparse_Interactive_Deep_Syntax_Declaration {
#
unparse_declaration: cms::Compiler_Mapstack_Set
-> pp::Stream
-> ( ( ds::Declaration,
List( tmp::Codetemp ) # Exported codetemps.
)
)
-> Void;
debugging: Ref( Bool );
}; # Api PPDEC
end;
# 2007-12-05 Crt: I'm not sure how this package relates to
#
# src/lib/compiler/front/typer/print/unparse-deep-syntax.pkg#
# which also prints out deep syntax declarations.
stipulate
package cms = compiler_mapstack_set; # compiler_mapstack_set is from src/lib/compiler/toplevel/compiler-state/compiler-mapstack-set.pkg package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg# package fix = 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 tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package pp = prettyprint; # prettyprint is from src/lib/prettyprint/big/src/prettyprint.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 ty = types; # types is from src/lib/compiler/front/typer-stuff/types/types.pkg package vac = variables_and_constructors; # variables_and_constructors is from src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkg package vh = varhome; # varhome is from src/lib/compiler/front/typer-stuff/basics/varhome.pkg include prettyprint; # prettyprint is from src/lib/prettyprint/big/src/prettyprint.pkg 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_chunk; # unparse_chunk is from src/lib/compiler/src/print/unparse-chunk.pkgherein
package unparse_interactive_deep_syntax_declaration
: (weak) Unparse_Interactive_Deep_Syntax_Declaration
{
# Debugging
say = global_controls::print::say;
#
debugging = REF FALSE;
#
fun if_debugging_say (msg: String)
=
if *debugging
say msg;
say "\n";
fi;
#
fun bug msg
=
error_message::impossible("PPDec: " + msg);
show_interactive_result_types = mythryl_parser::show_interactive_result_types;
Chunk = unsafe::unsafe_chunk::Chunk;
apis = global_controls::print::apis;
print_includes = global_controls::print::print_includes;
print_depth = global_controls::print::print_depth;
anon_sym = sy::make_package_symbol "<anonymous_api>";
anon_fsym = sy::make_generic_symbol "<anonymous_generic_api>";
#
fun pplist_nl stream pr
=
unparse
where
fun unparse [] => ();
unparse [el] => pr el;
unparse (el ! rest) => { pr el;
pp::newline stream;
unparse rest;
};
end;
end;
#
fun by f x y
=
f y x;
#
fun extract (v, pos)
=
unsafe::unsafe_chunk::nth (v, pos);
exception OVERLOAD;
# deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg # Compare with unparse_declaration from
#
# src/lib/compiler/front/typer/print/unparse-deep-syntax.pkg #
# We (only) get invoked from
#
# src/lib/compiler/toplevel/interact/read-eval-print-loop-g.pkg #
# to print out the result of each
# interactively evaluated expression:
#
fun unparse_declaration
#
( { symbolmapstack, linking_mapstack, ... }: cms::Compiler_Mapstack_Set)
#
(stream: pp::Stream)
#
( declaration: deep_syntax::Declaration,
exported_highcode_variables
)
=
{ # Return TRUE iff x is in given
# list of lambda variables:
#
fun is_export ( x: tmp::Codetemp,
[]
)
=>
FALSE;
is_export ( x,
a ! r
)
=>
x == a ?? TRUE
:: is_export (x, r);
end;
pps = pp::string stream;
# Get the type of the bound variable
# from symbolmapstack, since the stamps
# in the deep_syntax_tree haven't been
# converted by the pickler:
#
fun true_val_type path
=
{ report_error
=
fn _ = fn _ = fn _ = (bug "true_val_type: unbound");
case path
#
symbol_path::SYMBOL_PATH [id]
=>
case (find_in_symbolmapstack::find_value_by_symbol
(
symbolmapstack,
id,
report_error
))
vac::VARIABLE (vac::ORDINARY_VARIABLE { var_type, ... } )
=>
*var_type;
vac::VARIABLE (vac::OVERLOADED_IDENTIFIER { name, type_scheme, ... } )
=>
{ print ("#true_val_type: OVERLOADED_IDENTIFIER" + symbol::name name + "\n");
raise exception OVERLOAD;
};
vac::VARIABLE (vac::ERRORVAR)
=>
bug "true_val_type: ERRORVAR\n";
vac::CONSTRUCTOR (ty::VALCON { name, ... } )
=>
bug ("true_val_type: VALCON" + symbol::name name + "\n");
esac;
_ =>
bug "true_val_type: not singleton path";
esac;
};
#
fun true_typ (path: ip::Inverse_Path) # "typ" == "type constructor"
=
{ report_error
=
fn _ = fn _ = fn _ = (bug "true_typ: unbound ");
case (find_in_symbolmapstack::find_typ_via_symbol_path
(
symbolmapstack,
invert_path::invert_ipath path,
report_error
))
ty::DEFINED_TYP x => THE x;
_ => NULL;
esac;
};
#
fun is_lazy_bogus (symbol_path::SYMBOL_PATH path)
=
case (reverse (string::explode (symbol::name (list::last path))))
#
'$' ! ',' ! _ => TRUE;
_ => FALSE;
esac;
#
fun unparse_variable
#
(vac::ORDINARY_VARIABLE
{ path,
varhome,
var_type => (t0 as REF type),
inlining_data
}
)
=>
if (not (is_lazy_bogus path))
#
begin_horizontal_else_vertical_box stream;
begin_indented_wrap_box stream (pp::CURSOR_RELATIVE 2);
#
# 2008-01-03 CrT: Commented out some stuff here as a quick and dirty way of
# simplifying interactive result printing from the irritatingly verbose
# my it = 4 : int
# to nice simple
# 4
# Need to do something cleaner by and by. XXX BUGGO FIXME
#
# pp::string stream "my ";
# unparse_symbol_path stream path;
# pp::string stream " =";
# break stream { spaces=>1, indent_on_wrap=>0 };
case varhome
#
vh::HIGHCODE_VARIABLE lv
=>
case (symbolmapstack::get
(
symbolmapstack,
symbol_path::last path
))
sxe::NAMED_VARIABLE (vac::ORDINARY_VARIABLE { varhome=>vh::PATH (vh::EXTERN pid, pos), ... } )
=>
if (is_export (lv, exported_highcode_variables))
#
chunkv = the (linking_mapstack::get linking_mapstack pid);
chunk = extract (chunkv, pos);
unparse_chunk symbolmapstack stream
(chunk, type, *print_depth);
if *show_interactive_result_types
# In interactive response to 'eval: 2+2;'
# print '4: Int' instead of just '4':
break stream { spaces=>1, indent_on_wrap=>0 };
pp::string stream ": ";
unparse_type symbolmapstack stream
( true_val_type path
except OVERLOAD = type
);
fi;
else
pp::string stream "<hidden-value>";
break stream { spaces=>1, indent_on_wrap=>0 };
pp::string stream ": ";
unparse_type symbolmapstack stream type;
fi;
_ => pp::string stream "<PPDec::get_val failure>";
esac;
# ** | PRIMOP _ => pp::string stream "<baseop>"
_ =>
error_message::impossible "src/lib/compiler/src/print/unparse-interactive-deep-syntax-declaration.pkg: bug";
esac;
end_box stream;
end_box stream;
# pp::newline stream;
fi;
unparse_variable _ => ();
end;
#
fun unparse_named_value (ds::NAMED_VALUE { pattern, ... } )
=
unparse_bind pattern
where
#
fun unparse_bind (pattern)
=
case pattern
#
ds::VARIABLE_IN_PATTERN v => unparse_variable v;
ds::RECORD_PATTERN { fields, ... } => apply (unparse_bind o #2) fields;
ds::VECTOR_PATTERN (pats, _) => apply unparse_bind pats;
ds::APPLY_PATTERN(_, _, pattern) => unparse_bind pattern;
ds::TYPE_CONSTRAINT_PATTERN (pattern, _) => unparse_bind pattern;
ds::OR_PATTERN (p1, _) => unparse_bind p1;
ds::AS_PATTERN (pattern1, pattern2) => { unparse_bind pattern1;
unparse_bind pattern2;
};
_ => ();
esac;
end
also
fun unparse_named_recursive_values (ds::NAMED_RECURSIVE_VALUES { variable=>var, ... } )
=
unparse_variable var
also
fun unparse_named_type (ty::DEFINED_TYP dt)
=>
{ my { path, type_scheme=>ty::TYPE_SCHEME { arity, body }, ... }
=
the_else (true_typ dt.path, dt);
begin_horizontal_else_vertical_box stream;
begin_indented_wrap_box stream (pp::CURSOR_RELATIVE 2);
pp::string stream "type";
unparse_symbol stream (inverse_path::last path);
unparse_formals stream arity;
pp::string stream " =";
break stream { spaces=>1, indent_on_wrap=>0 };
unparse_type symbolmapstack stream body;
end_box stream;
end_box stream;
pp::newline stream;
};
unparse_named_type _
=>
bug "unparse_named_type: DEFINED_TYP";
end
also
fun unparse_abstract_type (ty::PLAIN_TYP { path, arity, eqtype_info, ... } )
=>
case *eqtype_info
#
ty::eq_type::EQ_ABSTRACT
=>
{ begin_horizontal_else_vertical_box stream;
begin_indented_wrap_box stream (pp::CURSOR_RELATIVE 2);
pp::string stream "type";
unparse_symbol stream (inverse_path::last path);
unparse_formals stream arity;
end_box stream;
end_box stream;
pp::newline stream;
};
_ =>
{ begin_horizontal_else_vertical_box stream;
begin_indented_wrap_box stream (pp::CURSOR_RELATIVE 2);
pp::string stream "type";
unparse_symbol stream (inverse_path::last path);
unparse_formals stream arity;
end_box stream;
end_box stream;
pp::newline stream;
};
esac;
unparse_abstract_type _
=>
bug "unexpected case in unparse_abstract_type";
end
also
fun unparse_constructor (ty::PLAIN_TYP
{ path,
arity,
kind => ty::DATATYPE { index, free_typs, family=> { members, ... }, ... },
...
}
)
=>
{ fun unparse_constructor' NIL
=>
();
unparse_constructor' (first ! rest)
=>
{ fun unparse_dcon ( { name, domain, form } )
=
{ unparse_symbol stream name;
case domain
#
THE dom
=>
{
# pp::string stream " of ";
unparse_enum_constructor_domain (members, free_typs)
symbolmapstack stream dom;
};
NULL => ();
esac;
};
pp::string stream "= "; unparse_dcon first;
apply
(fn d = { break stream { spaces=>1, indent_on_wrap=>0 };
pp::string stream "| "; unparse_dcon d;
}
)
rest;
};
end;
my { typ_name, constructor_list, ... }
=
vector::get (members, index);
begin_horizontal_else_vertical_box stream;
begin_horizontal_else_vertical_box stream;
# pp::string stream "enum";
unparse_symbol stream (inverse_path::last path);
unparse_formals stream arity;
break stream { spaces=>1, indent_on_wrap=>2 };
begin_horizontal_else_vertical_box stream;
unparse_constructor' constructor_list;
end_box stream;
end_box stream;
end_box stream;
pp::newline stream;
};
unparse_constructor _
=>
bug "unexpected case in prettyprintDataTypeConstructor";
end
also
fun unparse_named_exception (
ds::NAMED_EXCEPTION {
exception_constructor => ty::VALCON { name, ... },
exception_type => etype,
...
}
)
=>
{ begin_horizontal_else_vertical_box stream;
begin_indented_wrap_box stream (pp::CURSOR_RELATIVE 2);
pp::string stream "exception ";
unparse_symbol stream name;
case etype
#
NULL => ();
THE type'
=>
{
# pp::string stream " of";
break stream { spaces=>1, indent_on_wrap=>0 };
unparse_type symbolmapstack stream type';
};
esac;
end_box stream;
end_box stream;
pp::newline stream;
};
unparse_named_exception (
ds::DUPLICATE_NAMED_EXCEPTION {
exception_constructor => ty::VALCON { name, ... },
equal_to => ty::VALCON { name => dname, ... } # dname == "duplicate name", likely.
}
)
=>
{ begin_horizontal_else_vertical_box stream;
begin_indented_wrap_box stream (pp::CURSOR_RELATIVE 2);
pp::string stream "exception ";
unparse_symbol stream name;
pp::string stream " =";
break stream { spaces=>1, indent_on_wrap=>0 };
unparse_symbol stream dname;
end_box stream;
end_box stream;
pp::newline stream;
};
end
also
fun unparse_named_package is_absolute ( ds::NAMED_PACKAGE { name_symbol=>name, a_package=>str, ... } ) # is_absolute strvar
=
{ begin_horizontal_else_vertical_box stream;
begin_horizontal_else_vertical_box stream;
pps "package ";
unparse_symbol stream name;
pps " :";
break stream { spaces=>1, indent_on_wrap=>2 };
unparse_package_language::unparse_package stream (str, symbolmapstack,*apis);
end_box stream;
end_box stream;
pp::newline stream;
}
also
fun unparse_named_generic (ds::NAMED_GENERIC { name_symbol=>name, a_generic=>fct, ... } )
=
{ begin_horizontal_else_vertical_box stream;
pps "generic package ";
unparse_symbol stream name;
case fct
mld::GENERIC { a_generic_api, ... }
=>
unparse_package_language::unparse_generic_api stream (a_generic_api, symbolmapstack, *apis);
_ => pps " : <api>"; # Blume: cannot (?) happen
esac;
end_box stream;
pp::newline stream;
}
also
fun unparse_sigb an_api
=
{ name = case an_api
mld::API { name, ... } => the_else (name, anon_sym);
_ => anon_sym;
esac;
{ begin_horizontal_else_vertical_box stream;
begin_horizontal_else_vertical_box stream;
pps "api "; unparse_symbol stream name; pps " =";
break stream { spaces=>1, indent_on_wrap=>2 };
unparse_package_language::unparse_api stream (an_api, symbolmapstack,*apis);
end_box stream;
end_box stream;
pp::newline stream;
};
}
also
fun unparse_generic_api_naming fsig
=
{ name = case fsig
#
mld::GENERIC_API { kind=>THE s, ... }
=>
s;
_ => anon_fsym;
esac;
begin_horizontal_else_vertical_box stream;
pps "funsig ";
unparse_symbol stream name;
unparse_package_language::unparse_generic_api stream (fsig, symbolmapstack,*apis);
end_box stream;
pp::newline stream;
}
also
fun unparse_fixity { fixity, ops }
=
{ begin_horizontal_else_vertical_box stream;
begin_horizontal_else_vertical_box stream;
pp::string stream (fixity::fixity_to_string fixity);
unparse_junk::unparse_sequence stream { sep=>by break { spaces=>1, indent_on_wrap=>0 },
pr=>unparse_junk::unparse_symbol,
style=>INCONSISTENT }
ops;
end_box stream;
end_box stream;
pp::newline stream;
}
also
fun unparse_open (path_strs)
=
if *print_includes
#
begin_horizontal_else_vertical_box stream;
apply
(fn (path, str)
=
unparse_package_language::unparse_open
stream
(path, str, symbolmapstack, *apis)
)
path_strs;
end_box stream;
else
begin_horizontal_else_vertical_box stream;
begin_horizontal_else_vertical_box stream;
pp::string stream "use ";
unparse_sequence
stream
{ sep => by break { spaces=>1, indent_on_wrap=>0 },
style => INCONSISTENT,
pr => (fn stream = fn (path, _)
=
unparse_symbol_path stream path)
}
path_strs;
end_box stream;
end_box stream;
pp::newline stream;
fi
also
fun unparse_declaration0 declaration
=
case { reset_unparse_type (); declaration;}
#
ds::VALUE_DECLARATIONS vbs => apply unparse_named_value vbs;
ds::RECURSIVE_VALUE_DECLARATIONS rvbs => apply unparse_named_recursive_values rvbs;
ds::TYPE_DECLARATIONS tbs => apply unparse_named_type tbs;
ds::EXCEPTION_DECLARATIONS ebs => apply unparse_named_exception ebs;
ds::PACKAGE_DECLARATIONS named_packages => apply (unparse_named_package FALSE) named_packages;
ds::GENERIC_DECLARATIONS named_generics => apply unparse_named_generic named_generics;
ds::API_DECLARATIONS named_apis => apply unparse_sigb named_apis;
ds::GENERIC_API_DECLARATIONS fsigbs => apply unparse_generic_api_naming fsigbs;
ds::LOCAL_DECLARATIONS (dec_in, dec_out) => unparse_declaration0 dec_out;
ds::FIXITY_DECLARATION fixd => unparse_fixity fixd;
ds::INCLUDE_DECLARATIONS path_strs => unparse_open path_strs;
ds::ENUM_DECLARATIONS { datatyps, with_typs }
=>
{ apply unparse_constructor datatyps;
apply unparse_named_type with_typs;
};
ds::ABSTRACT_TYPE_DECLARATION { abstract_typs, with_typs, body }
=>
{ apply unparse_abstract_type abstract_typs;
apply unparse_named_type with_typs;
unparse_declaration0 body;
};
ds::SEQUENTIAL_DECLARATIONS decs
=>
case decs
#
ds::INCLUDE_DECLARATIONS path_strs ! rest
=>
unparse_open path_strs;
_ => apply unparse_declaration0 decs;
esac;
ds::OVERLOADED_VARIABLE_DECLARATION _
=>
{ pp::string stream "overloaded my";
pp::newline stream;
};
ds::SOURCE_CODE_REGION_FOR_DECLARATION (declaration, _)
=>
unparse_declaration0 declaration;
esac;
begin_horizontal_else_vertical_box stream;
unparse_declaration0 declaration;
end_box stream;
flush_stream stream;
}; # unparse_declaration
}; # package unparse_interactive_deep_syntax_declaration
end; # stipulate