## 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 pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package cv = compiler_verbosity; # compiler_verbosity is from src/lib/compiler/front/basics/main/compiler-verbosity.pkg package tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkgherein
api Unparse_Interactive_Deep_Syntax_Declaration {
#
unparse_declaration: cms::Compiler_Mapstack_Set
-> (pp::Prettyprinter, cv::Compiler_Verbosity)
-> ( ( 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 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 tmp = highcode_codetemp; # highcode_codetemp is from src/lib/compiler/back/top/highcode/highcode-codetemp.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package cv = compiler_verbosity; # compiler_verbosity is from src/lib/compiler/front/basics/main/compiler-verbosity.pkg package sxe = symbolmapstack_entry; # symbolmapstack_entry is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack-entry.pkg package sy = symbol; # symbol is from src/lib/compiler/front/basics/map/symbol.pkg package syp = symbol_path; # symbol_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.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.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 uc = unparse_chunk; # unparse_chunk is from src/lib/compiler/src/print/unparse-chunk.pkg Pp = pp::Pp;
herein
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 (pp:Pp) pr
=
unparse
where
fun unparse [] => ();
unparse [el] => pr el;
unparse (el ! rest) => { pr el;
pp.newline();
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)
#
(pp: pp::Prettyprinter, cv: cv::Compiler_Verbosity)
#
( 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;
# 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
=
\\ _ = \\ _ = \\ _ = (bug "true_val_type: unbound");
case path
#
syp::SYMBOL_PATH [id]
=>
case (find_in_symbolmapstack::find_value_by_symbol
(
symbolmapstack,
id,
report_error
))
vac::VARIABLE (vac::PLAIN_VARIABLE { vartypoid_ref, ... } )
=>
*vartypoid_ref;
vac::VARIABLE (vac::OVERLOADED_VARIABLE { name, typescheme, ... } )
=>
{ print ("#true_val_type: OVERLOADED_VARIABLE" + symbol::name name + "\n");
raise exception OVERLOAD;
};
vac::VARIABLE (vac::ERROR_VARIABLE)
=>
bug "true_val_type: ERROR_VARIABLE\n";
vac::CONSTRUCTOR (tdt::VALCON { name, ... } )
=>
bug ("true_val_type: VALCON" + symbol::name name + "\n");
esac;
_ =>
bug "true_val_type: not singleton path";
esac;
};
#
fun true_type (path: ip::Inverse_Path) # "type" == "type constructor"
=
{ report_error
=
\\ _ = \\ _ = \\ _ = (bug "true_type: unbound ");
case (find_in_symbolmapstack::find_type_via_symbol_path
(
symbolmapstack,
invert_path::invert_ipath path,
report_error
))
tdt::NAMED_TYPE x => THE x;
_ => NULL;
esac;
};
#
fun is_lazy_bogus (syp::SYMBOL_PATH path)
=
case (reverse (string::explode (symbol::name (list::last path))))
#
'$' ! ',' ! _ => TRUE;
_ => FALSE;
esac;
#
fun unparse_variable
#
(vac::PLAIN_VARIABLE
{ path,
varhome,
vartypoid_ref => (t0 as REF type),
inlining_data
}
)
=>
if (not (is_lazy_bogus path))
#
pp.box {. pp.rulename "uib1";
#
pp.cwrap {. pp.rulename "uicw1";
#
# 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. "my ";
# uj::unparse_symbol_path pp path;
# pp.lit " =";
# pp.txt " ";
case varhome
#
vh::HIGHCODE_VARIABLE lv
=>
case (symbolmapstack::get
(
symbolmapstack,
syp::last path
))
sxe::NAMED_VARIABLE (vac::PLAIN_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);
uc::unparse_chunk symbolmapstack pp (chunk, type, *print_depth);
if cv.print_type_of_expression_value
#
# In interactive response to 'eval: 2+2;'
# print '4: Int' instead of just '4':
pp.txt " ";
pp.lit ": ";
ut::unparse_typoid symbolmapstack pp
( true_val_type path
except OVERLOAD = type
);
fi;
else
pp.lit "<hidden-value>";
pp.txt " ";
pp.lit ": ";
ut::unparse_typoid symbolmapstack pp type;
fi;
_ => pp.lit "<PPDec::get_val failure>";
esac;
# ** | PRIMOP _ => pp.lit "<baseop>"
_ =>
error_message::impossible "src/lib/compiler/src/print/unparse-interactive-deep-syntax-declaration.pkg: bug";
esac;
};
};
# pp.newline();
fi;
unparse_variable _ => ();
end;
#
fun unparse_named_value (ds::VALUE_NAMING { 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_VALUE { variable=>var, ... } )
=
unparse_variable var
also
fun unparse_named_type (tdt::NAMED_TYPE dt)
=>
{ (the_else (true_type dt.namepath, dt))
->
{ namepath, typescheme=>tdt::TYPESCHEME { arity, body }, ... };
pp.box {. pp.rulename "uib2";
#
pp.cwrap {. pp.rulename "uicw2";
# pp.lit "type";
uj::unparse_symbol pp (ip::last namepath);
ut::unparse_formals pp arity;
pp.lit " =";
pp.txt " ";
ut::unparse_typoid symbolmapstack pp body;
};
};
pp.newline();
};
unparse_named_type _
=>
bug "unparse_named_type: tdt::NAMED_TYPE";
end
also
fun unparse_abstract_type (tdt::SUM_TYPE { namepath, arity, is_eqtype, ... } )
=>
case *is_eqtype
# # Used to have tdt::e::EQ_ABSTRACT case here...
_ =>
{ pp.box {. pp.rulename "uib4";
pp.cwrap {. pp.rulename "uicw4";
# pp.lit "type";
uj::unparse_symbol pp (ip::last namepath);
ut::unparse_formals pp arity;
};
};
pp.newline();
};
esac;
unparse_abstract_type _
=>
bug "unexpected case in unparse_abstract_type";
end
also
fun unparse_constructor (tdt::SUM_TYPE
{ namepath,
arity,
kind => tdt::SUMTYPE { index, free_types, family=> { members, ... }, ... },
...
}
)
=>
{ fun unparse_constructor' NIL
=>
();
unparse_constructor' (first ! rest)
=>
{ fun unparse_valcon ( { name, domain, form } )
=
{ uj::unparse_symbol pp name;
#
case domain
#
THE dom
=>
{
# pp.lit " of ";
ut::unparse_sumtype_constructor_domain (members, free_types)
symbolmapstack pp dom;
};
NULL => ();
esac;
};
pp.lit "= ";
unparse_valcon first;
apply
(\\ d = { pp.txt " ";
pp.lit "| ";
unparse_valcon d;
}
)
rest;
};
end;
(vector::get (members, index))
->
{ name_symbol, valcons, ... };
pp.box {. pp.rulename "uib4";
pp.box {. pp.rulename "uib4a";
# pp.lit "enum";
uj::unparse_symbol pp (ip::last namepath);
ut::unparse_formals pp arity;
pp.txt' 0 2 " ";
pp.box {. pp.rulename "uib4b";
unparse_constructor' valcons;
};
};
};
pp.newline();
};
unparse_constructor _
=>
bug "unexpected case in prettyprintSumtypeConstructor";
end
also
fun unparse_named_exception (
ds::NAMED_EXCEPTION {
exception_constructor => tdt::VALCON { name, ... },
exception_typoid => etype,
...
}
)
=>
{ pp.box {. pp.rulename "uib5";
pp.cwrap {. pp.rulename "uicw5";
#
pp.lit "exception ";
uj::unparse_symbol pp name;
case etype
#
THE type' => { # pp.lit " of";
pp.txt " ";
ut::unparse_typoid symbolmapstack pp type';
};
#
NULL => ();
esac;
};
};
pp.newline();
};
unparse_named_exception (
ds::DUPLICATE_NAMED_EXCEPTION {
exception_constructor => tdt::VALCON { name, ... },
equal_to => tdt::VALCON { name => dname, ... } # dname == "duplicate name", likely.
}
)
=>
{ pp.box {. pp.rulename "uib6";
pp.cwrap {. pp.rulename "uicw6";
pp.lit "exception ";
uj::unparse_symbol pp name;
pp.lit " =";
pp.txt " ";
uj::unparse_symbol pp dname;
};
};
pp.newline();
};
end
also
fun unparse_named_package is_absolute ( ds::NAMED_PACKAGE { name_symbol=>name, a_package=>str, ... } ) # is_absolute strvar
=
{ pp.box {. pp.rulename "uib7";
pp.box {. pp.rulename "uib7a";
pp.lit "package ";
uj::unparse_symbol pp name;
pp.lit " :";
pp.txt' 0 2 " ";
unparse_package_language::unparse_package pp (str, symbolmapstack,*apis);
};
};
pp.newline();
}
also
fun unparse_named_generic (ds::NAMED_GENERIC { name_symbol=>name, a_generic=>fct, ... } )
=
{ pp.box {. pp.rulename "uib8";
pp.lit "generic package ";
uj::unparse_symbol pp name;
case fct
mld::GENERIC { a_generic_api, ... }
=>
unparse_package_language::unparse_generic_api pp (a_generic_api, symbolmapstack, *apis);
_ => pp.txt " : <api>"; # Blume: cannot (?) happen
esac;
};
pp.newline();
}
also
fun unparse_sigb an_api
=
{ name = case an_api
#
mld::API { name, ... } => the_else (name, anon_sym);
_ => anon_sym;
esac;
pp.box {. pp.rulename "uib9";
pp.box {. pp.rulename "uib9a";
pp.lit "api ";
uj::unparse_symbol pp name;
pp.lit " =";
pp.txt' 0 2 " ";
unparse_package_language::unparse_api pp (an_api, symbolmapstack,*apis);
};
};
pp.newline();
}
also
fun unparse_generic_api_naming fsig
=
{ name = case fsig
#
mld::GENERIC_API { kind=>THE s, ... }
=>
s;
_ => anon_fsym;
esac;
pp.box {. pp.rulename "uib10";
pp.lit "funsig ";
uj::unparse_symbol pp name;
unparse_package_language::unparse_generic_api pp (fsig, symbolmapstack,*apis);
};
pp.newline();
}
also
fun unparse_fixity { fixity, ops }
=
{ pp.box {. pp.rulename "uib11";
#
pp.lit (fixity::fixity_to_string fixity);
uj::unparse_sequence pp { separator => \\ pp = pp.txt " ",
print_one => uj::unparse_symbol,
breakstyle => uj::ALIGN
}
ops;
};
pp.newline();
}
also
fun unparse_open path_strs
=
if *print_includes
#
pp.box' 0 -1 {. pp.rulename "uib12";
#
apply
(\\ (path, str)
=
unparse_package_language::unparse_open
pp
(path, str, symbolmapstack, *apis)
)
path_strs;
};
else
pp.box' 0 -1 {. pp.rulename "uib13";
#
pp.lit "include package ";
uj::unparse_sequence
pp
{ separator => \\ pp = pp.txt " ",
breakstyle => uj::ALIGN,
print_one => \\ pp = \\ (path, _) = uj::unparse_symbol_path pp path
}
path_strs;
};
pp.newline();
fi
also
fun unparse_declaration0 declaration
=
case { ut::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::SUMTYPE_DECLARATIONS { sumtypes, with_types }
=>
{ apply unparse_constructor sumtypes;
apply unparse_named_type with_types;
};
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.lit "overloaded my";
pp.newline();
};
ds::SOURCE_CODE_REGION_FOR_DECLARATION (declaration, _)
=>
unparse_declaration0 declaration;
esac;
if cv.print_expression_value
#
pp.box' 0 -1 {. pp.rulename "uib14";
unparse_declaration0 declaration;
};
pp::flush_prettyprinter pp;
fi;
}; # unparse_declaration
}; # package unparse_interactive_deep_syntax_declaration
end; # stipulate