{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}

module Jikka.Common.Format.Error
  ( prettyError,
    prettyError',
    prettyErrorWithText,
    hPrintError,
    hPrintErrorWithText,
  )
where

import Data.List (intercalate)
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Jikka.Common.Error
import Jikka.Common.Format.Color
import Jikka.Common.Format.Location
import Jikka.Common.Location
import System.IO (Handle, hPutStrLn)

-- | `unpackCombinedErrors` removes `ErrorAppend` ctor from the given `Error`.
unpackCombinedErrors :: Error -> [Error]
unpackCombinedErrors :: Error -> [Error]
unpackCombinedErrors = Error -> [Error]
go
  where
    go :: Error -> [Error]
    go :: Error -> [Error]
go = \case
      err :: Error
err@(Error String
_) -> [Error
err]
      ErrorAppend Error
err1 Error
err2 -> Error -> [Error]
go Error
err1 [Error] -> [Error] -> [Error]
forall a. [a] -> [a] -> [a]
++ Error -> [Error]
go Error
err2
      WithGroup ErrorGroup
group Error
err -> (Error -> Error) -> [Error] -> [Error]
forall a b. (a -> b) -> [a] -> [b]
map (ErrorGroup -> Error -> Error
WithGroup ErrorGroup
group) (Error -> [Error]
go Error
err)
      WithWrapped String
msg Error
err -> (Error -> Error) -> [Error] -> [Error]
forall a b. (a -> b) -> [a] -> [b]
map (String -> Error -> Error
WithWrapped String
msg) (Error -> [Error]
go Error
err)
      WithLocation Loc
loc Error
err -> (Error -> Error) -> [Error] -> [Error]
forall a b. (a -> b) -> [a] -> [b]
map (Loc -> Error -> Error
WithLocation Loc
loc) (Error -> [Error]
go Error
err)
      WithResponsibility Responsibility
resp Error
err -> (Error -> Error) -> [Error] -> [Error]
forall a b. (a -> b) -> [a] -> [b]
map (Responsibility -> Error -> Error
WithResponsibility Responsibility
resp) (Error -> [Error]
go Error
err)

prettyError :: ColorFlag -> Error -> [String]
prettyError :: ColorFlag -> Error -> [String]
prettyError ColorFlag
color = (Error -> String) -> [Error] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ColorFlag -> Error -> String
prettyError1 ColorFlag
color) ([Error] -> [String]) -> (Error -> [Error]) -> Error -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> [Error]
unpackCombinedErrors

prettyError' :: Error -> [String]
prettyError' :: Error -> [String]
prettyError' = ColorFlag -> Error -> [String]
prettyError ColorFlag
DisableColor

-- | @err@ must not have `ErrorAppend`.
prettyError1 :: ColorFlag -> Error -> String
prettyError1 :: ColorFlag -> Error -> String
prettyError1 ColorFlag
color Error
err = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
": " ((String
group String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
resp) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Error -> [String]
getMessages Error
err)
  where
    group :: String
group = ColorFlag -> Color -> String -> String
withColor ColorFlag
color Color
Red (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Maybe ErrorGroup -> String
prettyGroup (Error -> Maybe ErrorGroup
getErrorGroup Error
err)
    loc :: String
loc = case Error -> Maybe Loc
getLocation Error
err of
      Maybe Loc
Nothing -> String
""
      Just Loc
loc -> String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Loc -> String
prettyLoc Loc
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    resp :: String
resp = case Error -> Maybe Responsibility
getResponsibility Error
err of
      Just Responsibility
UserMistake -> String
" (user's mistake?)"
      Just Responsibility
ImplementationBug -> String
" (implementation's bug?)"
      Maybe Responsibility
Nothing -> String
""

prettyErrorWithText :: ColorFlag -> Text -> Error -> [String]
prettyErrorWithText :: ColorFlag -> Text -> Error -> [String]
prettyErrorWithText ColorFlag
color Text
text = [String] -> [[String]] -> [String]
forall a. [a] -> [[a]] -> [a]
intercalate [String
""] ([[String]] -> [String])
-> (Error -> [[String]]) -> Error -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Error -> [String]) -> [Error] -> [[String]]
forall a b. (a -> b) -> [a] -> [b]
map (ColorFlag -> Text -> Error -> [String]
prettyErrorWithText1 ColorFlag
color Text
text) ([Error] -> [[String]])
-> (Error -> [Error]) -> Error -> [[String]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Error -> [Error]
unpackCombinedErrors

-- | @err@ must not have `ErrorAppend`.
prettyErrorWithText1 :: ColorFlag -> Text -> Error -> [String]
prettyErrorWithText1 :: ColorFlag -> Text -> Error -> [String]
prettyErrorWithText1 ColorFlag
color Text
text Error
err = case Error -> Maybe Loc
getLocation Error
err of
  Maybe Loc
Nothing -> [ColorFlag -> Error -> String
prettyError1 ColorFlag
color Error
err]
  Just Loc
loc -> ColorFlag -> Error -> String
prettyError1 ColorFlag
color Error
err String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ColorFlag -> Text -> Loc -> [String]
prettyLocWithText ColorFlag
color Text
text Loc
loc

prettyGroup :: Maybe ErrorGroup -> String
prettyGroup :: Maybe ErrorGroup -> String
prettyGroup = \case
  Maybe ErrorGroup
Nothing -> String
"Error"
  Just ErrorGroup
LexicalError -> String
"Lexical Error"
  Just ErrorGroup
SyntaxError -> String
"Syntax Error"
  Just ErrorGroup
SemanticError -> String
"Semantic Error"
  Just ErrorGroup
SymbolError -> String
"Symbol Error"
  Just ErrorGroup
TypeError -> String
"Type Error"
  Just ErrorGroup
EvaluationError -> String
"Evaluation Error"
  Just ErrorGroup
RuntimeError -> String
"Runtime Error"
  Just ErrorGroup
AssertionError -> String
"Assertion Error"
  Just ErrorGroup
CommandLineError -> String
"Command Line Error"
  Just ErrorGroup
WrongInputError -> String
"Wrong Input Error"
  Just ErrorGroup
InternalError -> String
"Internal Error"

-- | @err@ must not have `ErrorAppend`.
getMessages :: Error -> [String]
getMessages :: Error -> [String]
getMessages = \case
  Error String
message -> [String
message]
  ErrorAppend Error
_ Error
_ -> String -> [String]
forall a. String -> a
bug String
"ErrorAppend is not allowed here."
  WithGroup ErrorGroup
_ Error
err -> Error -> [String]
getMessages Error
err
  WithWrapped String
message Error
err -> String
message String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Error -> [String]
getMessages Error
err
  WithLocation Loc
_ Error
err -> Error -> [String]
getMessages Error
err
  WithResponsibility Responsibility
_ Error
err -> Error -> [String]
getMessages Error
err

-- | @err@ must not have `ErrorAppend`.
getErrorGroup :: Error -> Maybe ErrorGroup
getErrorGroup :: Error -> Maybe ErrorGroup
getErrorGroup = \case
  Error String
_ -> Maybe ErrorGroup
forall a. Maybe a
Nothing
  ErrorAppend Error
_ Error
_ -> String -> Maybe ErrorGroup
forall a. String -> a
bug String
"ErrorAppend is not allowed here."
  WithGroup ErrorGroup
group Error
err -> ErrorGroup -> Maybe ErrorGroup
forall a. a -> Maybe a
Just (ErrorGroup -> Maybe ErrorGroup -> ErrorGroup
forall a. a -> Maybe a -> a
fromMaybe ErrorGroup
group (Error -> Maybe ErrorGroup
getErrorGroup Error
err))
  WithWrapped String
_ Error
err -> Error -> Maybe ErrorGroup
getErrorGroup Error
err
  WithLocation Loc
_ Error
err -> Error -> Maybe ErrorGroup
getErrorGroup Error
err
  WithResponsibility Responsibility
_ Error
err -> Error -> Maybe ErrorGroup
getErrorGroup Error
err

-- | @err@ must not have `ErrorAppend`.
getLocation :: Error -> Maybe Loc
getLocation :: Error -> Maybe Loc
getLocation = \case
  Error String
_ -> Maybe Loc
forall a. Maybe a
Nothing
  ErrorAppend Error
_ Error
_ -> String -> Maybe Loc
forall a. String -> a
bug String
"ErrorAppend is not allowed here."
  WithGroup ErrorGroup
_ Error
err -> Error -> Maybe Loc
getLocation Error
err
  WithWrapped String
_ Error
err -> Error -> Maybe Loc
getLocation Error
err
  WithLocation Loc
loc Error
err -> Loc -> Maybe Loc
forall a. a -> Maybe a
Just (Loc -> Maybe Loc -> Loc
forall a. a -> Maybe a -> a
fromMaybe Loc
loc (Error -> Maybe Loc
getLocation Error
err))
  WithResponsibility Responsibility
_ Error
err -> Error -> Maybe Loc
getLocation Error
err

getResponsibilityFromErrorGroup :: ErrorGroup -> Maybe Responsibility
getResponsibilityFromErrorGroup :: ErrorGroup -> Maybe Responsibility
getResponsibilityFromErrorGroup = \case
  ErrorGroup
CommandLineError -> Maybe Responsibility
forall a. Maybe a
Nothing
  ErrorGroup
WrongInputError -> Maybe Responsibility
forall a. Maybe a
Nothing
  ErrorGroup
InternalError -> Responsibility -> Maybe Responsibility
forall a. a -> Maybe a
Just Responsibility
ImplementationBug
  ErrorGroup
_ -> Responsibility -> Maybe Responsibility
forall a. a -> Maybe a
Just Responsibility
UserMistake

-- | @err@ must not have `ErrorAppend`.
getResponsibility :: Error -> Maybe Responsibility
getResponsibility :: Error -> Maybe Responsibility
getResponsibility = \case
  Error String
_ -> Maybe Responsibility
forall a. Maybe a
Nothing
  ErrorAppend Error
_ Error
_ -> String -> Maybe Responsibility
forall a. String -> a
bug String
"ErrorAppend is not allowed here."
  WithGroup ErrorGroup
group Error
err -> case Error -> Maybe Responsibility
getResponsibility Error
err of
    Just Responsibility
resp -> Responsibility -> Maybe Responsibility
forall a. a -> Maybe a
Just Responsibility
resp
    Maybe Responsibility
Nothing -> ErrorGroup -> Maybe Responsibility
getResponsibilityFromErrorGroup ErrorGroup
group
  WithWrapped String
_ Error
err -> Error -> Maybe Responsibility
getResponsibility Error
err
  WithLocation Loc
_ Error
err -> Error -> Maybe Responsibility
getResponsibility Error
err
  WithResponsibility Responsibility
resp Error
_ -> Responsibility -> Maybe Responsibility
forall a. a -> Maybe a
Just Responsibility
resp

hPrintError :: Handle -> Error -> IO ()
hPrintError :: Handle -> Error -> IO ()
hPrintError Handle
handle Error
err = do
  ColorFlag
color <- Handle -> IO ColorFlag
hGetColorFlag Handle
handle
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
handle) (ColorFlag -> Error -> [String]
prettyError ColorFlag
color Error
err)

hPrintErrorWithText :: Handle -> Text -> Error -> IO ()
hPrintErrorWithText :: Handle -> Text -> Error -> IO ()
hPrintErrorWithText Handle
handle Text
text Error
err = do
  ColorFlag
color <- Handle -> IO ColorFlag
hGetColorFlag Handle
handle
  (String -> IO ()) -> [String] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> String -> IO ()
hPutStrLn Handle
handle) (ColorFlag -> Text -> Error -> [String]
prettyErrorWithText ColorFlag
color Text
text Error
err)