{-# 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 = go
  where
    go :: Error -> [Error]
    go = \case
      err@(Error _) -> [err]
      ErrorAppend err1 err2 -> go err1 ++ go err2
      WithGroup group err -> map (WithGroup group) (go err)
      WithWrapped msg err -> map (WithWrapped msg) (go err)
      WithLocation loc err -> map (WithLocation loc) (go err)
      WithResponsibility resp err -> map (WithResponsibility resp) (go err)

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

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

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

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

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

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

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

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

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

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

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

hPrintError :: Handle -> Error -> IO ()
hPrintError handle err = do
  color <- hGetColorFlag handle
  mapM_ (hPutStrLn handle) (prettyError color err)

hPrintErrorWithText :: Handle -> Text -> Error -> IO ()
hPrintErrorWithText handle text err = do
  color <- hGetColorFlag handle
  mapM_ (hPutStrLn handle) (prettyErrorWithText color text err)