## print-type-as-nada.pkg
# Compiled by:
# src/lib/compiler/front/typer/typer.sublib# modified to use Lib7 Lib pp. [dbm, 7/30/03])
stipulate
package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkgherein
api Print_Type_As_Lib7 {
#
type_formals: Int
-> List( String );
tyvar_printname_as_nada: tdt::Typevar_Ref
-> String;
print_type_as_nada: syx::Symbolmapstack
-> pp::Prettyprinter
-> tdt::Type
-> Void;
print_tyfun_as_nada: syx::Symbolmapstack
-> pp::Prettyprinter
-> tdt::Typescheme
-> Void;
print_typoid_as_nada: syx::Symbolmapstack
-> pp::Prettyprinter
-> tdt::Typoid
-> Void;
print_valcon_domain_as_nada: ((Vector( tdt::Sumtype_Member ), List( tdt::Type )) )
-> syx::Symbolmapstack
-> pp::Prettyprinter
-> tdt::Typoid
-> Void;
print_valcon_types_as_nada: syx::Symbolmapstack
-> pp::Prettyprinter
-> tdt::Type
-> Void;
reset_prettyprint_type: Void
-> Void;
print_formals_as_nada: pp::Prettyprinter
-> Int
-> Void;
debugging: Ref( Bool );
unalias: Ref( Bool );
}; # Api Print_Type_As_Lib7
end;
stipulate
package ip = inverse_path; # inverse_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package mtt = more_type_types; # more_type_types is from src/lib/compiler/front/typer/types/more-type-types.pkg package pp = standard_prettyprinter; # standard_prettyprinter is from src/lib/prettyprint/big/src/standard-prettyprinter.pkg package sp = symbol_path; # symbol_path is from src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg package syx = symbolmapstack; # symbolmapstack is from src/lib/compiler/front/typer-stuff/symbolmapstack/symbolmapstack.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package tu = type_junk; # type_junk is from src/lib/compiler/front/typer-stuff/types/type-junk.pkg Pp = pp::Pp;
include package type_declaration_types;
include package print_as_nada_junk;
herein
package print_typoid_as_nada
: (weak) Print_Type_As_Lib7 # Print_Type_As_Lib7 is from src/lib/compiler/front/typer/print/print-type-as-nada.pkg {
debugging = REF FALSE;
unalias = REF TRUE;
fun bug s = error_message::impossible ("print_typoid_as_nada: " + s);
fun by f x y
=
f y x;
# internals = typer_control::internals;
internals = log::internals;
unit_path = ip::extend (ip::empty, symbol::make_type_symbol "Void");
fun bound_typevar_name k
=
{ a = char::to_int 'a';
#
if (k < 26)
#
string::from_char (char::from_int (k+a));
else
implode [ char::from_int (int::(/) (k, 26) + a),
char::from_int (int::(%) (k, 26) + a)
];
fi;
};
fun meta_tyvar_name' k
=
{ z = char::to_int 'Z'; # use reverse order for meta vars
#
if (k < 26)
#
string::from_char (char::from_int (z - k));
else
implode [ char::from_int (z - (int::(/) (k, 26))),
char::from_int (z - (int::(%) (k, 26)))
];
fi;
};
fun type_formals n
=
loop 0
where
fun loop i
=
if (i>=n) [];
else (bound_typevar_name i) ! loop (i + 1);
fi;
end;
fun literal_kind_printname (lk: tdt::Literal_Kind)
=
case lk
tdt::INT => "Int"; # or "INT"
tdt::UNT => "Unt"; # or "WORD"
tdt::FLOAT => "Float"; # or "REAL"
tdt::CHAR => "Char"; # or "CHAR"
tdt::STRING => "String"; # or "STRING"
esac;
stipulate # WARNING -- compiler global variables
count = REF(-1);
meta_tyvars = REF([]:List( Typevar_Ref ));
herein
fun meta_tyvar_name (tv: Typevar_Ref)
=
{ fun find ([], _)
=>
{ meta_tyvars := tv ! *meta_tyvars;
count := *count+1;
*count;
};
find (tv' ! rest, k)
=>
if (tv == tv')
*count - k;
else find (rest, k+1);
fi;
end;
meta_tyvar_name' (find (*meta_tyvars, 0));
};
fun reset_prettyprint_type ()
=
{ count := -1;
meta_tyvars := []
;};
end;
fun tv_head (eq, base)
=
(if eq "''";
else "'";
fi
)
+
base;
fun annotate (name, annotation, maybe_fn_nesting)
=
if *internals
#
cat ( name
! "."
! annotation
! case maybe_fn_nesting
THE fn_nesting => ["[fn_nesting == ", (int::to_string fn_nesting), "]"];
NULL => NIL;
esac
);
else
name;
fi;
fun tyvar_printname_as_nada (tv as { id => _, ref_typevar })
=
pr_kind *ref_typevar
where
fun pr_kind info
=
case info
#
RESOLVED_TYPEVAR (TYPEVAR_REF (tv as { id, ref_typevar => _ }))
=>
(tyvar_printname_as_nada tv)
+
(sprintf "[id%d]" id);
RESOLVED_TYPEVAR _
=>
"<RESOLVED_TYPEVAR ?>";
META_TYPEVAR { fn_nesting, eq }
=>
tv_head (eq, annotate (meta_tyvar_name tv,
"META",
THE fn_nesting));
INCOMPLETE_RECORD_TYPEVAR { fn_nesting, eq, known_fields }
=>
tv_head (eq, annotate (meta_tyvar_name tv,
"F",
THE fn_nesting));
USER_TYPEVAR { name, fn_nesting, eq }
=>
tv_head (eq, annotate (symbol::name name, "USER", THE fn_nesting));
LITERAL_TYPEVAR { kind, ... }
=>
annotate (literal_kind_printname kind, "LITERAL", NULL);
OVERLOADED_TYPEVAR eq
=>
tv_head (eq, annotate (meta_tyvar_name tv, "OVERLOAD", NULL));
TYPEVAR_MARK _ => "<TYPEVAR_MARK ?>";
esac;
end;
/*
fun ppkind pp kind =
pp.lit
(case kind
of BASE _ => "BASE" | FORMAL => "FORMAL"
| FLEXIBLE_TYPE _ => "FLEXIBLE_TYPE" | ABSTRACT _ => "ABSTYC"
| SUMTYPE _ => "SUMTYPE" | TEMP => "TEMP")
*/
fun ppkind (pp:Pp) kind
=
pp.lit
case kind
BASE _ => "P";
FORMAL => "F";
FLEXIBLE_TYPE _ => "X";
ABSTRACT _ => "A";
SUMTYPE _ => "D";
TEMP => "T";
esac;
fun effective_path (path, type, dictionary) : String
=
{ fun namepath_of_type (tdt::SUM_TYPE { namepath, ... } | tdt::NAMED_TYPE { namepath, ... } | TYPE_BY_STAMPPATH { namepath, ... } )
=>
THE namepath;
namepath_of_type _
=>
NULL;
end;
fun find (path, type)
=
(find_path (path,
(\\ type' = tu::type_equality (type', type)),
(\\ x = find_in_symbolmapstack::find_type_via_symbol_path (dictionary, x,
(\\ _ = raise exception syx::UNBOUND)))));
fun search (path, type)
=
{ (find (path, type))
->
(suffix, found);
if (found)
#
(suffix, TRUE);
else
if (not *unalias)
#
(suffix, FALSE);
else
case (tu::unwrap_definition_1 type)
#
THE type' => case (namepath_of_type type')
#
THE path'
=>
{ (search (path', type'))
->
x as (suffix', found');
if found' x;
else (suffix, FALSE);
fi;
};
NULL => (suffix, FALSE);
esac;
NULL => (suffix, FALSE);
esac;
fi;
fi;
};
(search (path, type)) -> (suffix, found);
name = sp::to_string (sp::SYMBOL_PATH suffix);
if found name;
else "?." + name;
fi;
};
arrow_stamp = mtt::arrow_stamp;
fun strength type
=
case type
#
TYPEVAR_REF { id, ref_typevar => (REF (RESOLVED_TYPEVAR type')) }
=>
strength type';
TYPCON_TYPOID (type, args)
=>
case type
#
tdt::SUM_TYPE { stamp, kind => BASE _, ... }
=>
if (stamp::same_stamp (stamp, arrow_stamp)) 0;
else 2;
fi;
RECORD_TYPE (_ ! _) # excepting type unit
=>
if (tuples::is_tuple_type type) 1;
else 2;
fi;
_ => 2;
esac;
_ => 2;
esac;
fun print_eq_prop_as_nada (pp:Pp) p
=
{ a = case p
e::NO => "NO";
e::YES => "YES";
e::INDETERMINATE => "INDETERMINATE";
e::CHUNK => "CHUNK";
e::DATA => "DATA";
e::UNDEF => "UNDEF";
esac;
pp.lit a;
};
fun print_inverse_path_as_nada (pp:Pp) (inverse_path::INVERSE_PATH inverse_path: inverse_path::Inverse_Path)
=
pp.lit (symbol_path::to_string (symbol_path::SYMBOL_PATH (reverse inverse_path)));
fun print_type1_as_nada dictionary pp members_op
=
{ fun print_type_as_nada (type as tdt::SUM_TYPE { namepath, stamp, is_eqtype, kind, ... } )
=>
if *internals
#
pp.wrap {. pp.rulename "pptw10";
print_inverse_path_as_nada pp namepath;
pp.lit "[";
pp.lit "SUM_TYPE"; ppkind pp kind; pp.endlit ";";
pp.lit (stamp::to_short_string stamp);
pp.endlit ";";
print_eq_prop_as_nada pp *is_eqtype;
pp.lit "]";
};
else
pp.lit (effective_path (namepath, type, dictionary));
fi;
print_type_as_nada (type as tdt::NAMED_TYPE { namepath, typescheme => TYPESCHEME { body, ... }, ... } )
=>
if *internals
#
pp.wrap {. pp.rulename "pptw11";
print_inverse_path_as_nada pp namepath;
pp.lit "["; pp.lit "NAMED_TYPE;";
print_typoid_as_nada dictionary pp body;
pp.lit "]";
};
else
pp.lit (effective_path (namepath, type, dictionary));
fi;
print_type_as_nada (RECORD_TYPE labels)
=>
print_closed_sequence_as_nada pp
{ front=> \\ pp = pp.lit "{",
sep=> \\ pp = { pp.lit ", ";
pp.cut();
},
back=> \\ pp = pp.lit "}",
style=>INCONSISTENT,
pr=>print_symbol_as_nada
}
labels;
print_type_as_nada (RECURSIVE_TYPE n)
=>
case members_op
#
THE (members, _)
=>
{ (vector::get (members, n)) -> { name_symbol, valcons, ... };
#
print_symbol_as_nada pp name_symbol;
};
NULL => pp.lit (string::cat ["<RECURSIVE_TYPE ", int::to_string n, ">"]);
esac;
print_type_as_nada (FREE_TYPE n)
=>
case members_op
#
THE (_, free_types)
=>
{ type = ( list::nth (free_types, n)
except
_ = bug "unexpected free_types in print_type_as_nada"
);
print_type_as_nada type;
};
NULL => pp.lit (string::cat ["<FREE_TYPE ", int::to_string n, ">"]);
esac;
print_type_as_nada (type as TYPE_BY_STAMPPATH { arity, stamppath, namepath } )
=>
if *internals
#
pp.wrap {. pp.rulename "pptw12";
print_inverse_path_as_nada pp namepath; pp.lit "[TYPE_BY_STAMPPATH;";
pp.lit (stamppath::stamppath_to_string stamppath);
pp.lit "]";
};
else
print_inverse_path_as_nada pp namepath;
fi;
print_type_as_nada ERRONEOUS_TYPE
=>
pp.lit "[ERRONEOUS_TYPE]";
end;
print_type_as_nada;
}
also
fun print_type1_as_mythryl7 dictionary pp ( type: Typoid,
an_api: tdt::Typescheme_Eqflags,
members_op: Null_Or( (Vector( tdt::Sumtype_Member ), List( tdt::Type )) )
)
: Void
=
{ fun prty type
=
case type
#
TYPEVAR_REF { id, ref_typevar => REF (RESOLVED_TYPEVAR type') }
=>
prty type';
TYPEVAR_REF tv
=>
print_typevar_as_nada tv;
TYPESCHEME_ARG n
=>
{ eq = list::nth (an_api, n)
except INDEX_OUT_OF_BOUNDS = FALSE;
pp.lit (tv_head (eq, (bound_typevar_name n)));
};
TYPCON_TYPOID (type, args)
=>
{
fun otherwise ()
=
{ pp.wrap' 0 2 {. pp.rulename "pptw22";
print_type_args_as_nada args;
pp.cut();
print_type1_as_nada dictionary pp members_op type;
};
};
case type
#
tdt::SUM_TYPE { stamp, kind, ... }
=>
case kind
#
BASE _
=>
if (stamp::same_stamp (stamp, arrow_stamp))
#
case args
#
[domain, range]
=>
{ pp.box' 0 -1 {. pp.rulename "ppv11";
#
if (strength domain == 0)
pp.box {. pp.rulename "ppv12";
pp.lit "(";
prty domain;
pp.lit ")";
};
else
prty domain;
fi;
pp.txt " ";
pp.lit "-> ";
prty range;
};
};
_ => bug "TYPCON_TYPE: arity";
esac;
else
pp.wrap' 0 2 {. pp.rulename "pptw23";
print_type_args_as_nada args;
pp.cut ();
print_type1_as_nada dictionary pp members_op type;
};
fi;
_ => otherwise ();
esac;
RECORD_TYPE labels
=>
if (tuples::is_tuple_type type) print_tuple_ty_as_nada args;
else print_record_ty_as_nada (labels, args);
fi;
_ => otherwise ();
esac;
};
TYPESCHEME_TYPOID { typescheme_eqflags => an_api,
typescheme => TYPESCHEME { arity, body }
}
=>
print_type1_as_mythryl7 dictionary pp (body, an_api, members_op);
WILDCARD_TYPOID => pp.lit "_";
UNDEFINED_TYPOID => pp.lit "undef";
esac
also
fun print_type_args_as_nada []
=>
();
print_type_args_as_nada [type]
=>
{ if (strength type <= 1)
pp.wrap {. pp.rulename "pptw24";
pp.lit "(";
prty type;
pp.lit ")";
};
else
prty type;
fi;
pp.txt " ";
};
print_type_args_as_nada tys
=>
print_closed_sequence_as_nada
pp
{ front => \\ pp = pp.lit "(",
sep => \\ pp = { pp.lit ", ";
pp.cut();
},
back => \\ pp = pp.lit ") ",
style => INCONSISTENT,
pr => \\ _ = \\ type = prty type
}
tys;
end
also
fun print_tuple_ty_as_nada [] => pp.lit (effective_path (unit_path, RECORD_TYPE [], dictionary));
print_tuple_ty_as_nada tys
=>
print_sequence_as_nada
pp
{ sep => \\ pp = { pp.txt " ";
pp.lit "* ";
},
style => INCONSISTENT,
pr => (\\ _ = \\ type = if (strength type <= 1)
pp.wrap {. pp.rulename "pptw25";
pp.lit "(";
prty type;
pp.lit ")";
};
else
prty type;
fi
)
}
tys; end
also
fun print_field_as_nada (lab, type)
=
{ pp.box' 0 -1 {.
print_symbol_as_nada pp lab;
pp.lit ":";
prty type;
};
}
also
fun print_record_ty_as_nada ([],[])
=>
pp.lit (effective_path (unit_path, RECORD_TYPE [], dictionary));
# this case should not occur
print_record_ty_as_nada (lab ! labels, arg ! args)
=>
{ pp.wrap {. pp.rulename "pptw26";
pp.lit "{";
print_field_as_nada (lab, arg);
paired_lists::apply
(\\ field' = { pp.lit ", "; pp.txt " "; print_field_as_nada field';})
(labels, args);
pp.lit "}";
};
};
print_record_ty_as_nada _
=>
bug "print_typoid_as_nada::print_record_ty_as_nada";
end
also
fun print_typevar_as_nada (tv as { id, ref_typevar => (ref_info as REF info) }:Typevar_Ref) :Void
=
{ printname = tyvar_printname_as_nada tv;
#
case info
#
INCOMPLETE_RECORD_TYPEVAR { fn_nesting, eq, known_fields }
=>
case known_fields
#
[] => { pp.lit "{"; pp.lit printname; pp.lit "}"; };
field' ! fields
=>
{ pp.wrap {. pp.rulename "pptw27";
pp.lit "{";
print_field_as_nada field';
apply (\\ x = { pp.lit ", ";
pp.txt " ";
print_field_as_nada x;}
)
fields;
pp.lit ";";
pp.txt " ";
pp.lit printname;
pp.lit "}";
};
};
esac;
_ => pp.lit printname;
esac;
};
prty type;
} # print_type1_as_mythryl7
also
fun print_typoid_as_nada (dictionary: syx::Symbolmapstack) pp (typoid: Typoid) : Void
=
{ pp.cwrap {.
print_type1_as_mythryl7 dictionary pp (typoid,[], NULL);
};
};
fun print_valcon_domain_as_nada members (dictionary: syx::Symbolmapstack) pp (typoid: Typoid)
: Void
=
{ pp.cwrap {.
print_type1_as_mythryl7 dictionary pp (typoid,[], THE members);
};
};
fun print_type_as_nada dictionary pp type
=
print_type1_as_nada dictionary pp NULL type;
fun print_tyfun_as_nada dictionary pp (TYPESCHEME { arity, body } )
=
{ pp.wrap' 0 2 {. pp.rulename "pptw1";
pp.lit "TYPESCHEME( { arity=";
print_int_as_nada pp arity; print_comma_as_nada pp;
pp.cut ();
pp.lit "body=";
print_typoid_as_nada dictionary pp body;
pp.lit "} )";
};
};
fun print_formals_as_nada pp
=
print_formals_as_nada'
where
fun print_formals_as_nada' 0 => ();
print_formals_as_nada' 1 => pp.lit " 'a";
print_formals_as_nada' n => { pp.lit " ";
print_tuple_as_mythrl7 pp (\\ pp = \\ s = pp.lit ("'" + s))
(type_formals n);};
end;
end;
fun print_valcon_types_as_nada dictionary pp (tdt::SUM_TYPE { kind => SUMTYPE dt, ... } )
=>
{ dt -> { index, free_types, family=> { members, ... }, ... };
#
(vector::get (members, index))
->
{ valcons, ... };
pp.box' 0 -1 {.
apply
(\\ { name, domain, ... }
=
{ pp.lit (symbol::name name);
pp.lit ":";
case domain
#
THE type
=>
print_type1_as_mythryl7 dictionary pp (type,[], THE (members, free_types));
NULL => pp.lit "CONST";
esac;
pp.txt " ";
}
)
valcons;
};
};
print_valcon_types_as_nada dictionary pp _
=>
bug "print_valcon_types_as_nada";
end;
}; # package print_typoid_as_nada
end; # toplevel stipulate