PreviousUpNext

15.4.537  src/lib/compiler/front/basics/errormsg/error-message.pkg

## error-message.pkg
#
# Possible future improvement in error reporting (thanks to Joe Wells for suggestion):
#     A constraint system for a SML type error slicer
#     Vincent Rahli, J. B. Wells, Fairouz Kamareddine
#     http://www.macs.hw.ac.uk:8080/techreps/docs/files/HW-MACS-TR-0079.pdf
#     http://www2.macs.hw.ac.uk/~rahli/cgi-bin/slicer/html/concepts.html

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



###                "I learn by making mistakes.
###                 I've learned a LOT."
###
###                             -- Eric Beggs


stipulate
    package cp  =  control_print;                               # control_print                 is from   src/lib/compiler/front/basics/print/control-print.pkg
    package lnd =  line_number_db;                              # line_number_db                is from   src/lib/compiler/front/basics/source/line-number-db.pkg
    package pp  =  standard_prettyprinter;                      # standard_prettyprinter        is from   src/lib/prettyprint/big/src/standard-prettyprinter.pkg
    package sci =  sourcecode_info;                             # sourcecode_info               is from   src/lib/compiler/front/basics/source/sourcecode-info.pkg
herein

    package   error_message
    : (weak)  Error_Message                                     # Error_Message                 is from   src/lib/compiler/front/basics/errormsg/error-message.api
    {
        exception COMPILE_ERROR;                                # Error reporting.
        #
        Severity =  WARNING | ERROR;

        Plaint_Sink
            =
            Severity
            -> String
            -> (pp::Prettyprinter -> Void)
            -> Void
            ;


        Error_Function
            =
            lnd::Source_Code_Region -> Plaint_Sink;

        Errors =  { error_fn:     lnd::Source_Code_Region -> Plaint_Sink,
                    error_match:  lnd::Source_Code_Region -> String,
                    saw_errors:   Ref( Bool )
                  };


        fun default_plaint_sink ()                              # This matches Prettyprint_Consumer type in   src/lib/prettyprint/big/src/old-prettyprinter.pkg
            =                                                   # 
            { consumer  =>  control_print::say,
              flush     =>  control_print::flush,
              close     =>  \\ () = ()
            };

        null_error_body
            =
            \\ (buf: pp::Prettyprinter) = ();


        fun ppmsg                                                       # "ppmsg" == "prettyprint message"
                ( error_consumer,
                  location,
                  severity,
                  msg,
                  body
                )
            =
            case (*basic_control::print_warnings, severity)
                #
                (FALSE, WARNING)
                    =>
                    ();

                _   =>
                    {
                        pp::with_standard_prettyprinter
                            #
                            error_consumer      []
                            #
                            (\\ pp:  pp::Prettyprinter
                                =
                                {   pp.box' 0 -1 {.

                                        pp.newline();

                                        pp.lit location;

                                        # Print error label:
                                        # 
                                        pp.lit
                                            case severity
                                                #
                                                WARNING =>  " Warning: ";
                                                ERROR   =>  " Error: ";
                                            esac;

                                        pp.lit msg;
                                        body          pp;
                                    };
                                    pp.flush ();
                                }
                            );
                    };
            esac;


        fun record (ERROR, saw_errors)
                 =>
                 saw_errors := TRUE;

            record (WARNING, _)
                =>
                ();
        end;

        fun impossible msg
            =
            {   apply control_print::say ["Error: Compiler bug: ", msg, "\n"];
                control_print::flush ();
                raise exception COMPILE_ERROR;
            };



        #  With the advent of source-map resynchronization (a.k.a                   
        #  [[( *#line...* )]]), a contiguous region as seen by the compiler can     
        #  correspond to one or more contiguous regions in source code.             
        #  We can imagine myriad ways of displaying such information, but we        
        #  Confine ourselves to two:                                                
        #  \begin { itemize }                                                          
        #  \item                                                                    
        #  When there's just one source region,
        #  we have what we had in the old compiler,
        #  and we display it the same way:                                
        #  \begin { quote }                                                            
        #  {\tt \emph { name }:\emph { line }.\emph { col }} or\\                            
        #  {\tt \emph { name }:\emph { line1 }.\emph { col1 }-\emph { line2 }.\emph { col2 }}      
        #  \end { quote }                                                              
        #  \item                                                                    
        #  When there are two or more source regions, we use an ellipsis instead    
        #  of a dash, and if not all regions are from the same file, we provide     
        #  the file names of both endpoints (even if the endpoints are the same     
        #  file).                                                                   
        #  \end { itemize }                                                            
        #                                                                           
        #  <error-message.pkg>=                                                          
        #
        fun location_string
                #
                ( { line_number_db, file_opened, ... }: sci::Sourcecode_Info)
                #
                (p1, p2)
            =
            {   fun shortpoint
                        ( { line, column, ... }:   lnd::Sourceloc,
                          l
                        )
                    = 
                    int::to_string line ! "." ! int::to_string column ! l;              # int           is from   src/lib/std/int.pkg


                fun showpoint (p as { file_name, ... }:  lnd::Sourceloc, l)
                    = 
                    pathnames::trim file_name ! ":" ! shortpoint (p, l);                # pathnames     is from   src/lib/compiler/front/basics/source/pathnames.pkg


                fun allfiles (f, (src: lnd::Sourceloc, _) ! l)
                        =>
                        f == src.file_name   and
                        allfiles (f, l);

                    allfiles (f, [])
                        =>
                        TRUE;
                end;

                fun lastpos [(_, hi)] =>   hi;
                    lastpos (h ! t)   =>   lastpos t;
                    lastpos []        =>   impossible "lastpos botch in error_message::locationString";
                end;

                cat
                    case (lnd::fileregion line_number_db (p1, p2))
                        #                 
                        [(lo, hi)]
                            => 
                            if (p1+1 >= p2)   showpoint (lo, []);
                            else              showpoint (lo, "-" ! shortpoint (hi, []));
                            fi;
                        #
                        (lo, _) ! rest
                            =>
                            if (allfiles (lo.file_name, rest))   showpoint (lo, "..." ! shortpoint (lastpos rest, []));
                            else                                 showpoint (lo, "..." ! showpoint (lastpos rest, []));
                            fi;
                        #
                        []  =>
                            [pathnames::trim file_opened, ":<nullRegion>"];
                    esac;
            };



        # "Emulating my predecessors, I've
        #  gone to some trouble to avoid
        #  list appends and the consequent
        #  allocations":
        #
        fun error (source as { saw_errors, error_consumer, ... }: sci::Sourcecode_Info)
                  ( p1: Int,
                    p2: Int
                  )
                  (severity:  Severity)
                  (msg:       String)
                  (body:      pp::Prettyprinter -> Void)
            = 
            {   ppmsg
                    ( error_consumer,
                      (location_string source (p1, p2)),
                      severity,
                      msg,
                      body
                    );

                record (severity, saw_errors);
            };


        fun error_no_source
                (cons, any_e)
                locs
                severity
                msg
                body
            =
            {   ppmsg (cons, locs, severity, msg, body);
                record (severity, any_e);
            };


        fun error_no_file
                #
                (error_consumer, saw_errors)
                #
                ((p1, p2): lnd::Source_Code_Region)
                #
                severity
                msg
                body
            = 
            {   ppmsg
                    ( error_consumer,

                      p2 > 0   ??   cat [int::to_string p1, "-", int::to_string p2]
                               ::   "",

                      severity,
                      msg,
                      body
                    );

                record (severity, saw_errors);
            };

        fun impossible_with_body
                msg
                body
            =
            {   pp::with_standard_prettyprinter
                    #
                    (default_plaint_sink ())    []
                    #
                    (\\ pp:  pp::Prettyprinter
                        =
                        {   pp::lit pp "Error: Compiler bug: ";
                            pp::lit pp msg;
                            body pp;
                            pp::newline pp;
                        }
                    );

                raise exception COMPILE_ERROR;
            };

        match_error_string
            =
            location_string;

        fun errors source
            =
            { error_fn    =>   error  source,
              error_match =>   match_error_string  source,
              saw_errors  =>   source.saw_errors
            };

        fun saw_errors { saw_errors, error_fn, error_match }
            =
            *saw_errors;

        fun errors_no_file (consumer, saw_errors)
            =
            { error_fn    =>   error_no_file (consumer, saw_errors),
              error_match =>   \\ _ =  "MATCH",
              saw_errors
            };

    };          #  package error_message 
end;


Comments and suggestions to: bugs@mythryl.org

PreviousUpNext