PreviousUpNext

15.4.666  src/lib/compiler/front/typer/print/print-type-as-nada.pkg

## print-type-as-nada.pkg 
## Copyright 2003 by The SML/NJ Fellowship 

# Compiled by:
#     src/lib/compiler/front/typer/typer.sublib

#  modified to use Lib7 Lib pp. [dbm, 7/30/03]) 

api Print_Type_As_Lib7 {

     type_formals:  Int
                   -> List( String );

     tyvar_printname_as_nada:  types::Typevar_Ref
                      -> String;

     print_typ_as_nada:  symbolmapstack::Symbolmapstack
                        -> prettyprint::Stream 
                        -> types::Typ
                        -> Void;

     print_tyfun_as_nada:  symbolmapstack::Symbolmapstack
                        -> prettyprint::Stream 
                        -> types::Type_Scheme
                        -> Void; 

     print_type_as_nada:   symbolmapstack::Symbolmapstack
                        -> prettyprint::Stream 
                        -> types::Type
                        -> Void;

     print_dcon_domain_as_nada:  ((Vector( types::Datatype_Member ), List( types::Typ )) ) 
                             -> symbolmapstack::Symbolmapstack 
                             -> prettyprint::Stream
                             -> types::Type
                             -> Void;

     print_valcon_types_as_nada:  symbolmapstack::Symbolmapstack
                               -> prettyprint::Stream 
                               -> types::Typ
                               -> Void;

     reset_prettyprint_type:  Void
                   -> Void;

     print_formals_as_nada:  prettyprint::Stream
                          -> Int
                          -> Void;

     debugging: Ref( Bool );
     unalias:   Ref( Bool );

}; #  Api Print_Type_As_Lib7 



stipulate 
    package sp  =  symbol_path;         # symbol_path   is from   src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg
    package ip  =  inverse_path;        # inverse_path  is from   src/lib/compiler/front/typer-stuff/basics/symbol-path.pkg
    package bt  =  type_types;          # type_types    is from   src/lib/compiler/front/typer/types/type-types.pkg
    package t   =  types;               # types         is from   src/lib/compiler/front/typer-stuff/types/types.pkg
    package tu  =  type_junk;           # type_junk     is from   src/lib/compiler/front/typer-stuff/types/type-junk.pkg
    package pp  =  prettyprint;         # prettyprint   is from   src/lib/prettyprint/big/src/prettyprint.pkg

    include types;
    include print_as_nada_junk; 
herein

    package   print_type_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_type_as_nada: " + s);

        pps = pp::string;

        fun by f x y
            =
            f y x;

        internals = typer_control::internals;

        unit_path = ip::extend (ip::empty, symbol::make_type_symbol "Void");

        fun bound_type_variable_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
            =
            {   a = char::to_int 'Z'; #  use reverse order for meta vars 
            
                if   (k < 26)
                    
                     string::from_char (char::from_int (a - k));
                else 
                     implode [ char::from_int (a - (int::(/) (k, 26))), 
                               char::from_int (a - (int::(%) (k, 26)))
                             ];
                fi;
            };

        fun type_formals n
            =
            { fun loop i
                =
                if   (i>=n)

                     [];
                else 
                     (bound_type_variable_name i)  !  loop (i + 1);
                fi;
            
                loop 0;
            };

        fun literal_kind_printname (lk: t::Literal_Kind)
            =
            case lk
                t::INT    => "Int";     #  or "INT" 
                t::UNT    => "Unt";     #  or "WORD" 
                t::FLOAT  => "Float";   #  or "REAL" 
                t::CHAR   => "Char";    #  or "CHAR" 
                t::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_TYPE_VARIABLE (TYPE_VARIABLE_REF  (tv as { id, ref_typevar => _ }))
                             =>
                             (tyvar_printname_as_nada  tv)
                             +
                             (sprintf "[id%d]" id);

                         RESOLVED_TYPE_VARIABLE _
                             =>
                             "<RESOLVED_TYPE_VARIABLE ?>";

                         META_TYPE_VARIABLE { fn_nesting, eq }
                             =>
                             tv_head (eq, annotate (meta_tyvar_name tv,
                                                  "META",
                                                 THE fn_nesting));

                         INCOMPLETE_RECORD_TYPE_VARIABLE { fn_nesting, eq, known_fields }
                             =>
                             tv_head (eq, annotate (meta_tyvar_name tv,
                                                    "F",
                                                 THE fn_nesting));

                         USER_TYPE_VARIABLE { name, fn_nesting, eq }
                             =>
                             tv_head (eq, annotate (symbol::name name, "USER", THE fn_nesting));

                         LITERAL_TYPE_VARIABLE { kind, ... }
                             =>
                             annotate (literal_kind_printname kind, "LITERAL", NULL);

                         OVERLOADED_TYPE_VARIABLE eq
                          =>
                          tv_head (eq, annotate (meta_tyvar_name  tv, "OVERLOAD", NULL));

                         TYPE_VARIABLE_MARK _ => "<TYPE_VARIABLE_MARK ?>";
                    esac;
            
            end;

        /*
        fun ppkind stream kind =
            pps stream
              (case kind
                 of BASE _ => "BASE" | FORMAL => "FORMAL"
                  | FLEXIBLE_TYP _ => "FLEXIBLE_TYP" | ABSTRACT _ => "ABSTYC"
                  | DATATYPE _ => "DATATYPE" | TEMP => "TEMP")
        */

        fun ppkind stream kind
            =
            pps stream
               case kind
                   BASE _            => "P";
                   FORMAL            => "F";
                   FLEXIBLE_TYP _ => "X";
                   ABSTRACT _        => "A";
                   DATATYPE _        => "D";
                   TEMP              => "T";
               esac;

        fun effective_path (path, typ, dictionary) : String
            =
            {   fun typ_path (PLAIN_TYP { path, ... } | DEFINED_TYP { path, ... } | TYP_BY_STAMPPATH { path, ... } )
                        =>
                        THE path;

                    typ_path _
                        =>
                        NULL;
                end;

                fun find (path, typ)
                    =
                    (find_path (path,
                        (fn typ' => tu::typ_equality (typ', typ); end ),
                        (fn x = find_in_symbolmapstack::find_typ_via_symbol_path (dictionary, x,
                                                (fn _ =  raise exception symbolmapstack::UNBOUND)))));

                fun search (path, typ)
                    =
                    {   my (suffix, found) = find (path, typ);
                    
                        if   (found)
                            
                             (suffix, TRUE);
                        else
                             if   (not *unalias)
                                 
                                  (suffix, FALSE);
                             else
                                  case (tu::unwrap_definition_1 typ)

                                       THE typ'
                                           =>
                                           case (typ_path typ')

                                                 THE path'
                                                     =>
                                                     {   my x as (suffix', found')
                                                             =
                                                             search (path', typ');

                                                         if found'      x;
                                                         else           (suffix, FALSE);
                                                         fi;
                                                     };

                                                 NULL => (suffix, FALSE);
                                           esac;


                                      NULL => (suffix, FALSE);
                                esac;
                             fi;
                        fi;
                    };

                my (suffix, found) = search (path, typ);
                name = sp::to_string (sp::SYMBOL_PATH suffix);
            
                if   found      name;
                             else   "?." + name;fi;
            };

        arrow_stamp = bt::arrow_stamp;

        fun strength  type
            =
            case type
                #
                TYPE_VARIABLE_REF { id, ref_typevar => (REF (RESOLVED_TYPE_VARIABLE type')) }
                    =>
                    strength  type';

                TYPCON_TYPE (typ, args)
                    =>
                    case typ
                        #
                        PLAIN_TYP { stamp, kind => BASE _, ... }
                            =>
                            if (stamp::same_stamp (stamp, arrow_stamp))    0;
                            else                                           2;
                            fi;

                        RECORD_TYP (_ ! _)        #  excepting type unit 
                            =>
                            if (tuples::is_tuple_typ (typ) ) 1; else 2;fi;

                        _ => 2;
                    esac;

                _ => 2;
            esac;

        fun print_eq_prop_as_nada stream p
            =
            {   a = case p
                        eq_type::NO            => "NO";
                        eq_type::YES           => "YES";
                        eq_type::INDETERMINATE => "INDETERMINATE";
                        eq_type::CHUNK         => "CHUNK";
                        eq_type::DATA          => "DATA";
                        eq_type::EQ_ABSTRACT   => "EQ_ABSTRACT";
                        eq_type::UNDEF         => "UNDEF";
                    esac;
            
                pps stream a;
            };

        fun print_inverse_path_as_nada ppstream (inverse_path::INVERSE_PATH inverse_path: inverse_path::Inverse_Path)
            = 
            pp::string ppstream (symbol_path::to_string (symbol_path::SYMBOL_PATH (reverse inverse_path)));

        fun print_typ1_as_nada dictionary stream members_op
            =
            {   my  { begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, ... }
                    =
                    en_pp stream;

                fun print_typ_as_nada (typ as PLAIN_TYP { path, stamp, eqtype_info, kind, ... } )
                        =>
                        if *internals
                            #
                            begin_wrap_box 1;
                            print_inverse_path_as_nada stream path;
                            pps "[";
                            pps "G"; ppkind stream kind; pps ";"; 
                            pps (stamp::to_short_string stamp);
                            pps ";";
                            print_eq_prop_as_nada stream  *eqtype_info;
                            pps "]";
                            end_box();
                        else
                            pps (effective_path (path, typ, dictionary));
                        fi;

                    print_typ_as_nada (typ as DEFINED_TYP { path, type_scheme => TYPE_SCHEME { body, ... }, ... } )
                        =>
                        if *internals
                             begin_wrap_box 1;
                             print_inverse_path_as_nada stream path;
                             pps "["; pps "D;"; 
                             print_type_as_nada dictionary stream body;
                             pps "]";
                             end_box();
                        else
                             pps (effective_path (path, typ, dictionary));
                        fi;

                    print_typ_as_nada (RECORD_TYP labels)
                        =>
                        print_closed_sequence_as_nada stream 
                            { front=>by pp::string "{",
                             sep=>fn stream => { pp::string stream ", "; 
                                               pp::break stream { spaces=>0, indent_on_wrap=>0 } ;}; end ,
                             back=>by pp::string "}",
                             style=>INCONSISTENT,
                             pr=>print_symbol_as_nada
                            }
                            labels;

                    print_typ_as_nada (RECURSIVE_TYPE n)
                        =>
                        case members_op

                            THE (members, _)
                                => 
                                { my { typ_name, constructor_list, ... } = vector::get (members, n);
                                  print_symbol_as_nada stream typ_name;
                                };

                            NULL => pps (string::cat ["<RECURSIVE_TYPE ", int::to_string n, ">"]);
                        esac;

                    print_typ_as_nada (FREE_TYPE n)
                        =>
                        case members_op

                            THE (_, free_typs)
                                => 
                                {   typ
                                        =
                                        (   list::nth (free_typs, n)
                                            except _
                                                =
                                                bug "unexpected free_typs in print_typ_as_nada"
                                        );

                                     print_typ_as_nada typ;
                                 };

                            NULL
                                => 
                                pps (string::cat ["<FREE_TYPE ", int::to_string n, ">"]);
                        esac;

                    print_typ_as_nada (typ as TYP_BY_STAMPPATH { arity, stamppath, path } )
                        =>
                        if *internals
                            begin_wrap_box 1;
                            print_inverse_path_as_nada stream path; pps "[P;"; 
                            pps (stamppath::stamppath_to_string stamppath);
                            pps "]";
                            end_box();
                        else
                            print_inverse_path_as_nada stream path;
                        fi;

                    print_typ_as_nada ERRONEOUS_TYP
                        =>
                        pps "[E]";
                end;

            
                print_typ_as_nada;
            }


        also
        fun print_type1_as_mythryl7 dictionary stream (   type:      Type,
                                                    an_api:      t::Type_Scheme_Arg_Eq_Properties, 
                                                    members_op:  Null_Or( (Vector( t::Datatype_Member ), List( t::Typ )) )
                                                )
                                                : Void
            =
            {   my { begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, newline }
                    =
                    en_pp stream;

                fun prty type
                    =
                    case type

                         TYPE_VARIABLE_REF { id, ref_typevar => REF (RESOLVED_TYPE_VARIABLE  type') }
                             =>
                             prty  type';

                         TYPE_VARIABLE_REF  tv
                             =>
                             print_type_variable_as_nada  tv;

                         TYPE_SCHEME_ARG_I n
                             =>
                             { eq = list::nth (an_api, n) 
                                            except INDEX_OUT_OF_BOUNDS = FALSE;

                                 pps (tv_head (eq, (bound_type_variable_name n)));
                             };

                         TYPCON_TYPE (typ, args)
                             =>
                             {
                                 fun otherwise ()
                                     =
                                     { begin_wrap_box 2;
                                       print_type_args_as_nada args; 
                                       break { spaces=>0, indent_on_wrap=>0 };
                                       print_typ1_as_nada dictionary stream members_op typ;
                                       end_box();
                                     };

                                 case typ
                                     #
                                     PLAIN_TYP { stamp, kind, ... }
                                         =>
                                         case kind
                                             #
                                             BASE _ 
                                                 =>
                                                 if (stamp::same_stamp (stamp, arrow_stamp))
                                                     #
                                                     case args
                                                         #
                                                         [domain, range]
                                                             =>
                                                             {   begin_horizontal_else_vertical_box 0;

                                                                 if (strength domain == 0)
                                                                       begin_horizontal_else_vertical_box 1;
                                                                       pps "(";
                                                                       prty domain;
                                                                       pps ")";
                                                                       end_box();
                                                                 else
                                                                       prty domain;
                                                                 fi;
                                                                 break { spaces=>1, indent_on_wrap=>0 };
                                                                 pps "-> ";
                                                                 prty range;
                                                                 end_box();
                                                              };

                                                          _ => bug "TYPCON_TYPE: arity";
                                                      esac;
                                                 else
                                                     begin_wrap_box 2;
                                                     print_type_args_as_nada args;
                                                     break { spaces=>0, indent_on_wrap=>0 };
                                                     print_typ1_as_nada dictionary stream members_op typ;
                                                     end_box();
                                                fi;

                                           _ => otherwise ();
                                       esac;

                                      RECORD_TYP labels
                                          =>
                                          if (tuples::is_tuple_typ (typ))   print_tuple_ty_as_nada args;
                                          else                                    print_record_ty_as_nada (labels, args);
                                          fi;

                                      _ => otherwise ();
                                 esac;
                             };

                         TYPE_SCHEME_TYPE { type_scheme_arg_eq_properties => an_api,
                                            type_scheme => TYPE_SCHEME { arity, body }
                                          }
                             => 
                             print_type1_as_mythryl7 dictionary stream (body, an_api, members_op);

                         WILDCARD_TYPE  => pps "_";
                         UNDEFINED_TYPE => pps "undef";
                    esac

                also
                fun print_type_args_as_nada []
                        =>
                        ();

                    print_type_args_as_nada [type]
                        => 
                        {  if (strength type <= 1)
                                begin_wrap_box 1;
                                pps "("; 
                                prty type; 
                                pps ")";
                                end_box();
                           else
                                 prty type;
                           fi;
                           break { spaces=>1, indent_on_wrap=>0 } ;
                        };

                    print_type_args_as_nada tys
                        =>
                        print_closed_sequence_as_nada
                            stream 
                            {   front => by pp::string "(",
                                sep   => fn stream => { pp::string stream ", ";
                                             pp::break stream { spaces=>0, indent_on_wrap=>0 } ;}; end ,
                                back  => by pp::string ") ",
                                style => INCONSISTENT, 
                                pr    => fn _ => fn type => prty type; end;  end 
                            }
                            tys;
                    end 

                also
                fun print_tuple_ty_as_nada [] => pps (effective_path (unit_path, RECORD_TYP [], dictionary));

                   print_tuple_ty_as_nada tys
                    => 
                    print_sequence_as_nada
                       stream
                       {   sep   => fn stream => { pp::break stream { spaces=>1, indent_on_wrap=>0 };
                                          pp::string stream "* ";}; end ,
                           style => INCONSISTENT,
                           pr    => (fn _ =  fn type = if (strength type <= 1)
                                                               begin_wrap_box 1;
                                                               pps "("; 
                                                               prty type; 
                                                               pps ")";
                                                               end_box();
                                                         else 
                                                               prty type;
                                                         fi
                                   )
                       }
                       tys; end 

                also
                fun print_field_as_nada (lab, type)
                    =
                    {   begin_horizontal_else_vertical_box 0;
                        print_symbol_as_nada stream lab; 
                        pps ":";
                        prty type;
                        end_box()
                    ;}

                also
                fun print_record_ty_as_nada ([],[])
                    =>
                    pps (effective_path (unit_path, RECORD_TYP [], dictionary));
                      #  this case should not occur 

                   print_record_ty_as_nada (lab ! labels, arg ! args)
                    =>
                    {   begin_wrap_box 1;
                        pps "{";
                        print_field_as_nada (lab, arg);
                        paired_lists::apply 
                          (fn field' = { pps ", "; break { spaces=>1, indent_on_wrap=>0 }; print_field_as_nada field';})
                          (labels, args);
                        pps "}";
                        end_box()
                    ;};

                   print_record_ty_as_nada _
                    =>
                    bug "print_type_as_nada::print_record_ty_as_nada"; end 

                also
                fun print_type_variable_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_TYPE_VARIABLE { fn_nesting, eq, known_fields }
                                 =>
                                 case known_fields

                                      [] => { pps "{"; pps printname; pps "}";};

                                      field' ! fields
                                          =>
                                          {   begin_wrap_box 1;
                                              pps "{";
                                              print_field_as_nada field';
                                              apply (fn x => { pps ", ";
                                                            break { spaces=>1, indent_on_wrap=>0 };
                                                            print_field_as_nada x;}; end )
                                                   fields;
                                              pps ";";
                                              break { spaces=>1, indent_on_wrap=>0 };
                                              pps printname;
                                              pps "}";
                                              end_box();
                                          };
                                  esac;

                            _ => pps printname;

                        esac;
                    };
            
                prty type;
            }  #  print_type1_as_mythryl7 


        also
        fun print_type_as_nada (dictionary: symbolmapstack::Symbolmapstack) stream (type:  Type) : Void
            = 
            {   pp::begin_indented_wrap_box stream (pp::CURSOR_RELATIVE 1);
                print_type1_as_mythryl7 dictionary stream (type,[], NULL);
                pp::end_box stream;
            };


        fun print_dcon_domain_as_nada members (dictionary: symbolmapstack::Symbolmapstack) stream (type:  Type)
            : Void
            = 
            {   pp::begin_indented_wrap_box stream (pp::CURSOR_RELATIVE 1);
                print_type1_as_mythryl7 dictionary stream (type,[], THE members);
                pp::end_box stream;
            };


        fun print_typ_as_nada  dictionary stream      typ
            =
            print_typ1_as_nada dictionary stream NULL typ;


        fun print_tyfun_as_nada dictionary stream (TYPE_SCHEME { arity, body } )
            =
            {   my { begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, ... }
                    =
                    en_pp  stream;
            
                begin_wrap_box 2;
                pps "TYPE_SCHEME( { arity="; 
                print_int_as_nada stream arity; print_comma_as_nada stream;
                break { spaces=>0, indent_on_wrap=>0 };
                pps "body="; 
                print_type_as_nada dictionary stream body; 
                pps "} )";
                end_box();
            };

        fun print_formals_as_nada stream
            =
            print_formals_as_nada'
            where
                fun print_formals_as_nada' 0 => ();
                    print_formals_as_nada' 1 => pps stream " 'a";
                    print_formals_as_nada' n => { pps stream " ";
                             print_tuple_as_mythrl7 stream (fn stream =  fn s =  pps stream ("'" + s))
                                            (type_formals n);};
                end;
            end;

        fun print_valcon_types_as_nada dictionary stream (PLAIN_TYP { kind => DATATYPE dt, ... } )
            =>
            {   my { index, free_typs, family=> { members, ... }, ... } = dt;

                my { begin_horizontal_else_vertical_box, begin_wrap_box, end_box, pps, break, ... } = en_pp stream;

                my { constructor_list, ... } = vector::get (members, index);
            
                begin_horizontal_else_vertical_box 0;

                apply
                    (fn { name, domain, ... }
                        =
                        {   pps (symbol::name name);
                            pps ":";

                            case domain
                              
                                 THE type
                                     =>
                                     print_type1_as_mythryl7 dictionary stream (type,[], THE (members, free_typs));

                                 NULL
                                     =>
                                     pps "CONST";
                            esac;

                            break { spaces=>1, indent_on_wrap=>0 };
                        }
                    )
                    constructor_list;

                end_box();
            };

           print_valcon_types_as_nada dictionary stream _
            =>
            bug "print_valcon_types_as_nada";
        end;
    };                                                                  # package print_type_as_nada 
end;                                                                    # toplevel stipulate 



Comments and suggestions to: bugs@mythryl.org

PreviousUpNext