--  Compiler Toolkit: basic error management
--
--  Author : Manuel M. T. Chakravarty
--  Created: 20 February 95
--
--  Version $Revision: 1.2 $ from $Date: 2004/11/13 17:26:50 $
--
--  Copyright (c) [1995..2000] Manuel M. T. Chakravarty
--
--  This library is free software; you can redistribute it and/or
--  modify it under the terms of the GNU Library General Public
--  License as published by the Free Software Foundation; either
--  version 2 of the License, or (at your option) any later version.
--
--  This library is distributed in the hope that it will be useful,
--  but WITHOUT ANY WARRANTY; without even the implied warranty of
--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
--  Library General Public License for more details.
--
--- DESCRIPTION ---------------------------------------------------------------
--
--  This modules exports some auxilliary routines for error handling.
--
--- DOCU ----------------------------------------------------------------------
--
--  language: Haskell 98
--
--  *  the single lines of error messages shouldn't be to long as file name
--     and position are prepended at each line
--
--- TODO ----------------------------------------------------------------------
--

module Errors (
  -- handling of internal error
  --
  interr, todo,
  --
  -- errors in the compiled program
  --
  ErrorLvl(..), Error, makeError, errorLvl, showError, errorAtPos
) where

import Position (Position(..), isInternalPos)


-- internal errors
-- ---------------

-- raise a fatal internal error; message may have multiple lines (EXPORTED)
--
interr     :: String -> a
interr :: String -> a
interr String
msg  = String -> a
forall a. HasCallStack => String -> a
error (String
"INTERNAL COMPILER ERROR:\n"
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
indentMultilineString Int
2 String
msg
                     String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")

-- raise a error due to a implementation restriction; message may have multiple
-- lines (EXPORTED)
--
todo     :: String -> a
todo :: String -> a
todo String
msg  = String -> a
forall a. HasCallStack => String -> a
error (String
"Feature not yet implemented:\n"
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
indentMultilineString Int
2 String
msg
                   String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n")


-- errors in the compiled program
-- ------------------------------

-- the higher the level of an error, the more critical it is (EXPORTED)
--
data ErrorLvl = WarningErr              -- does not affect compilation
              | ErrorErr                -- cannot generate code
              | FatalErr                -- abort immediately
              deriving (ErrorLvl -> ErrorLvl -> Bool
(ErrorLvl -> ErrorLvl -> Bool)
-> (ErrorLvl -> ErrorLvl -> Bool) -> Eq ErrorLvl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ErrorLvl -> ErrorLvl -> Bool
$c/= :: ErrorLvl -> ErrorLvl -> Bool
== :: ErrorLvl -> ErrorLvl -> Bool
$c== :: ErrorLvl -> ErrorLvl -> Bool
Eq, Eq ErrorLvl
Eq ErrorLvl
-> (ErrorLvl -> ErrorLvl -> Ordering)
-> (ErrorLvl -> ErrorLvl -> Bool)
-> (ErrorLvl -> ErrorLvl -> Bool)
-> (ErrorLvl -> ErrorLvl -> Bool)
-> (ErrorLvl -> ErrorLvl -> Bool)
-> (ErrorLvl -> ErrorLvl -> ErrorLvl)
-> (ErrorLvl -> ErrorLvl -> ErrorLvl)
-> Ord ErrorLvl
ErrorLvl -> ErrorLvl -> Bool
ErrorLvl -> ErrorLvl -> Ordering
ErrorLvl -> ErrorLvl -> ErrorLvl
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ErrorLvl -> ErrorLvl -> ErrorLvl
$cmin :: ErrorLvl -> ErrorLvl -> ErrorLvl
max :: ErrorLvl -> ErrorLvl -> ErrorLvl
$cmax :: ErrorLvl -> ErrorLvl -> ErrorLvl
>= :: ErrorLvl -> ErrorLvl -> Bool
$c>= :: ErrorLvl -> ErrorLvl -> Bool
> :: ErrorLvl -> ErrorLvl -> Bool
$c> :: ErrorLvl -> ErrorLvl -> Bool
<= :: ErrorLvl -> ErrorLvl -> Bool
$c<= :: ErrorLvl -> ErrorLvl -> Bool
< :: ErrorLvl -> ErrorLvl -> Bool
$c< :: ErrorLvl -> ErrorLvl -> Bool
compare :: ErrorLvl -> ErrorLvl -> Ordering
$ccompare :: ErrorLvl -> ErrorLvl -> Ordering
$cp1Ord :: Eq ErrorLvl
Ord)

data Error = Error ErrorLvl Position [String]  -- (EXPORTED ABSTRACTLY)

-- note that the equality to on errors takes into account only the error level
-- and position (not the error text)
--
-- note that these comparisions are expensive (the positions contain the file
-- names as strings)
--
instance Eq Error where
  (Error ErrorLvl
lvl1 Position
pos1 [String]
_) == :: Error -> Error -> Bool
== (Error ErrorLvl
lvl2 Position
pos2 [String]
_) = ErrorLvl
lvl1 ErrorLvl -> ErrorLvl -> Bool
forall a. Eq a => a -> a -> Bool
== ErrorLvl
lvl2 Bool -> Bool -> Bool
&& Position
pos1 Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
pos2

instance Ord Error where
  (Error ErrorLvl
lvl1 Position
pos1 [String]
_) < :: Error -> Error -> Bool
<  (Error ErrorLvl
lvl2 Position
pos2 [String]
_) = Position
pos1 Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
< Position
pos2
                                               Bool -> Bool -> Bool
|| (Position
pos1 Position -> Position -> Bool
forall a. Eq a => a -> a -> Bool
== Position
pos2 Bool -> Bool -> Bool
&& ErrorLvl
lvl1 ErrorLvl -> ErrorLvl -> Bool
forall a. Ord a => a -> a -> Bool
< ErrorLvl
lvl2)
  Error
e1                  <= :: Error -> Error -> Bool
<= Error
e2                  = Error
e1 Error -> Error -> Bool
forall a. Ord a => a -> a -> Bool
< Error
e2 Bool -> Bool -> Bool
|| Error
e1 Error -> Error -> Bool
forall a. Eq a => a -> a -> Bool
== Error
e2


-- produce an `Error', given its level, position, and a list of lines of
-- the error message that must not be empty (EXPORTED)
--
makeError :: ErrorLvl -> Position -> [String] -> Error
makeError :: ErrorLvl -> Position -> [String] -> Error
makeError  = ErrorLvl -> Position -> [String] -> Error
Error

-- inquire the error level (EXPORTED)
--
errorLvl                 :: Error -> ErrorLvl
errorLvl :: Error -> ErrorLvl
errorLvl (Error ErrorLvl
lvl Position
_ [String]
_)  = ErrorLvl
lvl

-- converts an error into a string using a fixed format (EXPORTED)
--
--  * the list of lines of the error message must not be empty
--
--  * the format is
--
--     <fname>:<row>: (column <col>) [<err lvl>]
--       >>> <line_1>
--       <line_2>
--         ...
--       <line_n>
--
--  * internal errors (identified by a special position value) are formatted as
--
--     INTERNAL ERROR!
--       >>> <line_1>
--       <line_2>
--         ...
--       <line_n>
--
showError :: Error -> String
showError :: Error -> String
showError (Error ErrorLvl
_   Position
pos               (String
l:[String]
ls))  | Position -> Bool
isInternalPos Position
pos =
  String
"INTERNAL ERROR!\n"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  >>> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String -> String
indentMultilineString Int
2 (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines) [String]
ls
showError (Error ErrorLvl
lvl (Position String
fname Int
row Int
col) (String
l:[String]
ls))  =
  let
    prefix :: String
prefix = String
fname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
row::Int) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(column "
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
col::Int)
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ["
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ ErrorLvl -> String
showErrorLvl ErrorLvl
lvl
             String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"] "
    showErrorLvl :: ErrorLvl -> String
showErrorLvl ErrorLvl
WarningErr = String
"WARNING"
    showErrorLvl ErrorLvl
ErrorErr   = String
"ERROR"
    showErrorLvl ErrorLvl
FatalErr   = String
"FATAL"
  in
  String
prefix String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"  >>> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
  String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Int -> String -> String
indentMultilineString Int
2 (String -> String) -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines) [String]
ls
showError (Error ErrorLvl
_  Position
_                  []   )   = String -> String
forall a. String -> a
interr String
"Errors: showError:\
                                                        \ Empty error message!"

errorAtPos         :: Position -> [String] -> a
errorAtPos :: Position -> [String] -> a
errorAtPos Position
pos [String]
msg  = (String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> ([String] -> String) -> [String] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> String
showError (Error -> String) -> ([String] -> Error) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErrorLvl -> Position -> [String] -> Error
makeError ErrorLvl
ErrorErr Position
pos) [String]
msg

-- indent the given multiline text by the given number of spaces
--
indentMultilineString   :: Int -> String -> String
indentMultilineString :: Int -> String -> String
indentMultilineString Int
n  = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
spacesString -> String -> String
forall a. [a] -> [a] -> [a]
++)) ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
                           where
                             spaces :: String
spaces = Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
n (Char -> String
forall a. a -> [a]
repeat Char
' ')