15.4.686  src/lib/compiler/src/print/prettyprint-table.pkg

# prettyprint-table.pkg 

# Compiled by:
#     src/lib/compiler/core.sublib


stipulate
    package pp  =  standard_prettyprinter;                      # standard_prettyprinter        is from   src/lib/prettyprint/big/src/standard-prettyprinter.pkg
herein

    api Unparse_Table {

       exception PP_NOT_INSTALLED;

       pp_chunk:  pp::Prettyprinter -> stamp::Stamp -> unsafe::unsafe_chunk::Chunk
                      -> Void;

       install_unparser:  List( String ) -> 
                       (pp::Prettyprinter -> unsafe::unsafe_chunk::Chunk -> Void) -> Void;
    };
end;



stipulate
    package fsx =  find_in_symbolmapstack;                      # find_in_symbolmapstack        is from   src/lib/compiler/front/typer-stuff/symbolmapstack/find-in-symbolmapstack.pkg
    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

    Pp = pp::Pp;
herein

    package   unparse_table
    : (weak)  Unparse_Table                                     # Unparse_Table                 is from   src/lib/compiler/src/print/prettyprint-table.pkg
    {
        package err= error_message;                             # error_message                 is from   src/lib/compiler/front/basics/errormsg/error-message.pkg

        #  The following code implements automatic prettyprinting of values. 
        #  The user defines a enum d, then defines a prettyprinter       
        #                                                                    
        #      Dp:  ppstream -> d -> Void                                    
        #                                                                    
        #  over d, perhaps using the Oppen primitives. Then dp is installed  
        #  in the "prettyprint table" via install_unparser. Subsequently, when a value of   
        #  type d comes to be printed out, we get in the table, find dp and 
        #  Apply it to the value. If it is not found, we print the value in  
        #  the default manner.                                               

        Chunk = unsafe::unsafe_chunk::Chunk;

        exception PP_NOT_INSTALLED;

        fun error msg
            = 
            {   err::error_no_file
                    (err::default_plaint_sink(), REF FALSE)
                    (0, 0) 
                    err::ERROR
                    msg
                    err::null_error_body;

                raise exception err::COMPILE_ERROR;
            };

        stipulate

            global_pp_table = REF stamp_map::empty;

        herein

            fun make_path ([s], p) => symbol_path::SYMBOL_PATH (reverse (symbol::make_type_symbol (s) ! p));
                make_path (s ! r, p) => make_path (r, symbol::make_package_symbol (s) ! p);
                make_path _ => error "install_unparser: empty path";
            end; 

            fun install_unparser (path_names: List( String ))
                           (p: pp::Prettyprinter -> Chunk -> Void)
                =
                {   sym_path = make_path (path_names,[]);

                    typ = fsx::find_type_via_symbol_path ((.symbolmapstack (compiler_state::combined())),
                          sym_path,
                          err::error_no_file (err::default_plaint_sink(), REF FALSE) (0, 0));

                    case typ
                        #                  
                        tdt::SUM_TYPE { stamp, ... }
                            =>
                            global_pp_table :=  stamp_map::set (*global_pp_table, stamp, p);

                        _ => error "install_unparser: nongenerative type constructor";
                    esac;
                };

            fun pp_chunk stream (s: stamp::Stamp) (chunk: Chunk)
                =
                case (stamp_map::get (*global_pp_table, s))
                    #              
                    THE p => p stream chunk;
                    NULL  => raise exception PP_NOT_INSTALLED;
                esac;

        end;

    };                                                          # package prettyprint_table 
end;


# Copyright 1992 by AT&T Bell Laboratories 
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.