{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QualifiedDo #-}

-- | 'OrmoluException' type and surrounding definitions.
module Ormolu.Exception
  ( OrmoluException (..),
    printOrmoluException,
    withPrettyOrmoluExceptions,
  )
where

import Control.Exception
import Data.Foldable (for_)
import Data.List.NonEmpty (NonEmpty (..))
import Data.List.NonEmpty qualified as NE
import Data.Text (Text)
import Data.Text qualified as T
import Data.Void (Void)
import Distribution.Parsec.Error (PError, showPError)
import GHC.Types.SrcLoc
import Ormolu.Diff.Text (TextDiff, printTextDiff)
import Ormolu.Terminal
import Ormolu.Terminal.QualifiedDo qualified as Term
import System.Exit (ExitCode (..))
import System.IO
import Text.Megaparsec (ParseErrorBundle, errorBundlePretty)

-- | Ormolu exception representing all cases when Ormolu can fail.
data OrmoluException
  = -- | Parsing of original source code failed
    OrmoluParsingFailed SrcSpan String
  | -- | Parsing of formatted source code failed
    OrmoluOutputParsingFailed SrcSpan String
  | -- | Original and resulting ASTs differ
    OrmoluASTDiffers TextDiff [RealSrcSpan]
  | -- | Formatted source code is not idempotent
    OrmoluNonIdempotentOutput TextDiff
  | -- | Some GHC options were not recognized
    OrmoluUnrecognizedOpts (NonEmpty String)
  | -- | Cabal file parsing failed
    OrmoluCabalFileParsingFailed FilePath (NonEmpty PError)
  | -- | Missing input file path when using stdin input and
    -- accounting for .cabal files
    OrmoluMissingStdinInputFile
  | -- | A parse error in a fixity overrides file
    OrmoluFixityOverridesParseError (ParseErrorBundle Text Void)
  deriving (Int -> OrmoluException -> ShowS
[OrmoluException] -> ShowS
OrmoluException -> String
(Int -> OrmoluException -> ShowS)
-> (OrmoluException -> String)
-> ([OrmoluException] -> ShowS)
-> Show OrmoluException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OrmoluException -> ShowS
showsPrec :: Int -> OrmoluException -> ShowS
$cshow :: OrmoluException -> String
show :: OrmoluException -> String
$cshowList :: [OrmoluException] -> ShowS
showList :: [OrmoluException] -> ShowS
Show)

instance Exception OrmoluException where
  displayException :: OrmoluException -> String
displayException = Text -> String
T.unpack (Text -> String)
-> (OrmoluException -> Text) -> OrmoluException -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Text
runTermPure (Term -> Text)
-> (OrmoluException -> Term) -> OrmoluException -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OrmoluException -> Term
printOrmoluException

-- | Print an 'OrmoluException'.
printOrmoluException ::
  OrmoluException ->
  Term
printOrmoluException :: OrmoluException -> Term
printOrmoluException = \case
  OrmoluParsingFailed SrcSpan
s String
e -> Term.do
    Term -> Term
bold (SrcSpan -> Term
forall a. Outputable a => a -> Term
putOutputable SrcSpan
s)
    Term
newline
    Text -> Term
put Text
"  The GHC parser (in Haddock mode) failed:"
    Term
newline
    Text -> Term
put Text
"  "
    Text -> Term
put (String -> Text
T.pack String
e)
    Term
newline
  OrmoluOutputParsingFailed SrcSpan
s String
e -> Term.do
    Term -> Term
bold (SrcSpan -> Term
forall a. Outputable a => a -> Term
putOutputable SrcSpan
s)
    Term
newline
    Text -> Term
put Text
"  Parsing of formatted code failed:"
    Term
newline
    Text -> Term
put Text
"  "
    Text -> Term
put (String -> Text
T.pack String
e)
    Term
newline
  OrmoluASTDiffers TextDiff
diff [RealSrcSpan]
ss -> Term.do
    TextDiff -> Term
printTextDiff TextDiff
diff
    Term
newline
    Text -> Term
put Text
"  AST of input and AST of formatted code differ."
    Term
newline
    [RealSrcSpan] -> (RealSrcSpan -> Term) -> Term
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [RealSrcSpan]
ss ((RealSrcSpan -> Term) -> Term) -> (RealSrcSpan -> Term) -> Term
forall a b. (a -> b) -> a -> b
$ \RealSrcSpan
s -> Term.do
      Text -> Term
put Text
"    at "
      RealSrcSpan -> Term
forall a. Outputable a => a -> Term
putOutputable RealSrcSpan
s
      Term
newline
    Text -> Term
put Text
"  Please, consider reporting the bug."
    Term
newline
    Text -> Term
put Text
"  To format anyway, use --unsafe."
    Term
newline
  OrmoluNonIdempotentOutput TextDiff
diff -> Term.do
    TextDiff -> Term
printTextDiff TextDiff
diff
    Term
newline
    Text -> Term
put Text
"  Formatting is not idempotent."
    Term
newline
    Text -> Term
put Text
"  Please, consider reporting the bug."
    Term
newline
  OrmoluUnrecognizedOpts NonEmpty String
opts -> Term.do
    Text -> Term
put Text
"The following GHC options were not recognized:"
    Term
newline
    Text -> Term
put Text
"  "
    (Text -> Term
put (Text -> Term)
-> (NonEmpty String -> Text) -> NonEmpty String -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unwords ([Text] -> Text)
-> (NonEmpty String -> [Text]) -> NonEmpty String -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack ([String] -> [Text])
-> (NonEmpty String -> [String]) -> NonEmpty String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty String -> [String]
forall a. NonEmpty a -> [a]
NE.toList) NonEmpty String
opts
    Term
newline
  OrmoluCabalFileParsingFailed String
cabalFile NonEmpty PError
parseErrors -> Term.do
    Text -> Term
put Text
"Parsing this .cabal file failed:"
    Term
newline
    NonEmpty PError -> (PError -> Term) -> Term
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty PError
parseErrors ((PError -> Term) -> Term) -> (PError -> Term) -> Term
forall a b. (a -> b) -> a -> b
$ \PError
e -> Term.do
      Text -> Term
put (Text -> Term) -> (String -> Text) -> String -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Term) -> String -> Term
forall a b. (a -> b) -> a -> b
$ String
"  " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> PError -> String
showPError String
cabalFile PError
e
      Term
newline
  OrmoluException
OrmoluMissingStdinInputFile -> Term.do
    Text -> Term
put Text
"The --stdin-input-file option is necessary when using input"
    Term
newline
    Text -> Term
put Text
"from stdin and accounting for .cabal files"
    Term
newline
  OrmoluFixityOverridesParseError ParseErrorBundle Text Void
errorBundle -> Term.do
    Text -> Term
put (Text -> Term)
-> (ParseErrorBundle Text Void -> Text)
-> ParseErrorBundle Text Void
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text)
-> (ParseErrorBundle Text Void -> String)
-> ParseErrorBundle Text Void
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty (ParseErrorBundle Text Void -> Term)
-> ParseErrorBundle Text Void -> Term
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text Void
errorBundle
    Term
newline

-- | Inside this wrapper 'OrmoluException' will be caught and displayed
-- nicely.
withPrettyOrmoluExceptions ::
  -- | Color mode
  ColorMode ->
  -- | Action that may throw an exception
  IO ExitCode ->
  IO ExitCode
withPrettyOrmoluExceptions :: ColorMode -> IO ExitCode -> IO ExitCode
withPrettyOrmoluExceptions ColorMode
colorMode IO ExitCode
m = IO ExitCode
m IO ExitCode -> (OrmoluException -> IO ExitCode) -> IO ExitCode
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` OrmoluException -> IO ExitCode
h
  where
    h :: OrmoluException -> IO ExitCode
h OrmoluException
e = do
      Term -> ColorMode -> Handle -> IO ()
runTerm (OrmoluException -> Term
printOrmoluException OrmoluException
e) ColorMode
colorMode Handle
stderr
      ExitCode -> IO ExitCode
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode -> IO ExitCode)
-> (Int -> ExitCode) -> Int -> IO ExitCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ExitCode
ExitFailure (Int -> IO ExitCode) -> Int -> IO ExitCode
forall a b. (a -> b) -> a -> b
$
        case OrmoluException
e of
          -- Error code 1 is for 'error' or 'notImplemented'
          -- 2 used to be for erroring out on CPP
          OrmoluParsingFailed {} -> Int
3
          OrmoluOutputParsingFailed {} -> Int
4
          OrmoluASTDiffers {} -> Int
5
          OrmoluNonIdempotentOutput {} -> Int
6
          OrmoluUnrecognizedOpts {} -> Int
7
          OrmoluCabalFileParsingFailed {} -> Int
8
          OrmoluMissingStdinInputFile {} -> Int
9
          OrmoluFixityOverridesParseError {} -> Int
10