Result.hs

-- | Results of BASIC computations, including errors.

module Language.VintageBasic.Result(Result(..),RuntimeException(..),RuntimeError(..)) where

import Control.Monad.CPST.DurableTraps(ResultType(..))
import Language.VintageBasic.Printer(printVarName)
import Language.VintageBasic.Syntax(Label,VarName)
import Text.ParserCombinators.Parsec(sourceLine,sourceColumn)
import Text.ParserCombinators.Parsec.Error(ParseError,errorMessages,errorPos,showErrorMessages)

-- | The ultimate result value of a BASIC program.
data Result =
    Pass                                             -- ^ normal termination
    | ScanError ParseError                           -- ^ error in scanning line numbers
    | SyntaxError ParseError                         -- ^ tokenization or parsing error
    | LabeledRuntimeException Label RuntimeException -- ^ runtime exception (with line number)

instance ResultType Result where
    okValue = Pass

data RuntimeException =
    RuntimeError RuntimeError
    | Next (Maybe String)     -- ^ generated by @NEXT@
    | Return                  -- ^ generated by @RETURN@

instance Show Result where
    show Pass = "NORMAL TERMINATION"
    show (ScanError pe) = showParseError "LINE NUMBERING" "RAW LINE" "END OF FILE" pe
    show (SyntaxError pe) = showParseError "SYNTAX" "LINE" "END OF LINE" pe
    show (LabeledRuntimeException label x) = show x ++ " IN LINE " ++ show label

instance Show RuntimeException where
    show (RuntimeError err) = show err
    show (Next Nothing) = "!NEXT WITHOUT FOR ERROR"
    show (Next (Just s)) = "!NEXT WITHOUT FOR ERROR (VAR "++s++")"
    show Return = "!RETURN WITHOUT GOSUB ERROR"

data RuntimeError =
    TypeMismatchError
    | WrongNumberOfArgumentsError
    | InvalidArgumentError
    | DivisionByZeroError
    | BadGotoTargetError Label
    | BadGosubTargetError Label
    | BadRestoreTargetError Label
    | NegativeArrayDimError
    | ReDimensionedArrayError
    | MismatchedArrayDimensionsError
    | OutOfArrayBoundsError
    | UndefinedFunctionError VarName
    | OutOfDataError
    | EndOfInputError
  deriving Eq

instance Show RuntimeError where
    show TypeMismatchError = "!TYPE MISMATCH"
    show WrongNumberOfArgumentsError = "!WRONG NUMBER OF ARGUMENTS"
    show InvalidArgumentError = "!INVALID ARGUMENT"
    show DivisionByZeroError = "!DIVISION BY ZERO"
    show (BadGotoTargetError lab) = "!BAD GOTO TARGET " ++ show lab
    show (BadGosubTargetError lab) = "!BAD GOSUB TARGET " ++ show lab
    show (BadRestoreTargetError lab) = "!BAD RESTORE TARGET " ++ show lab
    show NegativeArrayDimError = "!NEGATIVE ARRAY DIM"
    show ReDimensionedArrayError = "!REDIM'D ARRAY"
    show MismatchedArrayDimensionsError = "!MISMATCHED ARRAY DIMENSIONS"
    show OutOfArrayBoundsError = "!OUT OF ARRAY BOUNDS"
    show (UndefinedFunctionError vn) = "!UNDEFINED FUNCTION " ++ printVarName vn
    show OutOfDataError = "!OUT OF DATA"
    show EndOfInputError = "!END OF INPUT"

showParseError
    :: String     -- ^ message describing the type of error
    -> String     -- ^ description of source line: @LINE@ or @RAW LINE@
    -> String     -- ^ what to call end of input
    -> ParseError -- ^ the parse error to show as text
    -> String
showParseError msgErrorType msgLine msgEndOfInput parseError =
    let pos = errorPos parseError
        messages = errorMessages parseError
        line = sourceLine pos
        col = sourceColumn pos
    in
        "!" ++ msgErrorType ++ " ERROR IN " ++ msgLine ++ " " ++ show line
        ++ ", COLUMN " ++ show col
        ++ showErrorMessages "OR" " UNKNOWN" " EXPECTING" " UNEXPECTED" msgEndOfInput messages