{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
module Control.Panic
  (Panic(..)
  , PrettyEx(..)
  , panic
  , unwrap
  , expect
  , withPanic) where

import Control.Monad.Catch
import Data.Fallible
import Data.Text.Prettyprint.Doc
import Data.Text.Prettyprint.Doc.Render.Terminal
import GHC.Stack
import System.IO (stderr)
import System.Exit (exitFailure)

data Panic = Panic !CallStack !(Doc AnsiStyle)
  deriving (Int -> Panic -> ShowS
[Panic] -> ShowS
Panic -> String
(Int -> Panic -> ShowS)
-> (Panic -> String) -> ([Panic] -> ShowS) -> Show Panic
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Panic] -> ShowS
$cshowList :: [Panic] -> ShowS
show :: Panic -> String
$cshow :: Panic -> String
showsPrec :: Int -> Panic -> ShowS
$cshowsPrec :: Int -> Panic -> ShowS
Show)
instance Exception Panic

class PrettyEx a where
  prettyEx :: a -> Doc AnsiStyle
  prettyExList :: [a] -> Doc AnsiStyle
  prettyExList = (a -> Doc AnsiStyle) -> [a] -> Doc AnsiStyle
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap a -> Doc AnsiStyle
forall a. PrettyEx a => a -> Doc AnsiStyle
prettyEx

instance (a ~ AnsiStyle) => PrettyEx (Doc a) where
  prettyEx :: Doc a -> Doc AnsiStyle
prettyEx = Doc a -> Doc AnsiStyle
forall a. a -> a
id

instance PrettyEx () where
  prettyEx :: () -> Doc AnsiStyle
prettyEx _ = "Nothing"

instance PrettyEx Char where
  prettyEx :: Char -> Doc AnsiStyle
prettyEx = Char -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty
  prettyExList :: String -> Doc AnsiStyle
prettyExList = String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty

instance PrettyEx a => PrettyEx [a] where
  prettyEx :: [a] -> Doc AnsiStyle
prettyEx = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Cyan) (Doc AnsiStyle -> Doc AnsiStyle)
-> ([a] -> Doc AnsiStyle) -> [a] -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> Doc AnsiStyle
forall a. PrettyEx a => [a] -> Doc AnsiStyle
prettyExList

instance PrettyEx CallStack where
  prettyEx :: CallStack -> Doc AnsiStyle
prettyEx = [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep ([Doc AnsiStyle] -> Doc AnsiStyle)
-> (CallStack -> [Doc AnsiStyle]) -> CallStack -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, SrcLoc) -> Doc AnsiStyle)
-> [(String, SrcLoc)] -> [Doc AnsiStyle]
forall a b. (a -> b) -> [a] -> [b]
map (String, SrcLoc) -> Doc AnsiStyle
forall a a. (Pretty a, PrettyEx a) => (a, a) -> Doc AnsiStyle
prettyCallSite ([(String, SrcLoc)] -> [Doc AnsiStyle])
-> (CallStack -> [(String, SrcLoc)])
-> CallStack
-> [Doc AnsiStyle]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> [(String, SrcLoc)]
getCallStack where
    prettyCallSite :: (a, a) -> Doc AnsiStyle
prettyCallSite (f :: a
f, loc :: a
loc) = AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate AnsiStyle
bold (a -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty a
f) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> ", called at " Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> a -> Doc AnsiStyle
forall a. PrettyEx a => a -> Doc AnsiStyle
prettyEx a
loc

instance PrettyEx SrcLoc where
  prettyEx :: SrcLoc -> Doc AnsiStyle
prettyEx SrcLoc {..} = [Doc AnsiStyle] -> Doc AnsiStyle
forall a. Monoid a => [a] -> a
mconcat
      [ AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Blue) (String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
srcLocFile), ":"
      , Int -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Int
srcLocStartLine, ":"
      , Int -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty Int
srcLocStartCol, " in "
      , AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Yellow) (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
srcLocPackage, ":", String -> Doc AnsiStyle
forall a ann. Pretty a => a -> Doc ann
pretty String
srcLocModule
      ]

instance PrettyEx Panic where
  prettyEx :: Panic -> Doc AnsiStyle
prettyEx (Panic stack :: CallStack
stack doc :: Doc AnsiStyle
doc) = [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vsep [AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. ann -> Doc ann -> Doc ann
annotate (Color -> AnsiStyle
color Color
Red AnsiStyle -> AnsiStyle -> AnsiStyle
forall a. Semigroup a => a -> a -> a
<> AnsiStyle
bold) "!!!Panic!!!", Doc AnsiStyle
doc, CallStack -> Doc AnsiStyle
forall a. PrettyEx a => a -> Doc AnsiStyle
prettyEx CallStack
stack]

-- | Throw an error with a pretty-printable message.
panic :: (MonadThrow m, HasCallStack) => Doc AnsiStyle -> m a
panic :: Doc AnsiStyle -> m a
panic = Panic -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (Panic -> m a) -> (Doc AnsiStyle -> Panic) -> Doc AnsiStyle -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> Doc AnsiStyle -> Panic
Panic (CallStack -> CallStack
popCallStack CallStack
HasCallStack => CallStack
callStack)
{-# INLINE panic #-}

-- | Try to obtain the result of a 'Fallible' value. If 'panic's it fails.
unwrap :: (Fallible f, PrettyEx (Failure f), MonadThrow m, HasCallStack)
  => f a -> m a
unwrap :: f a -> m a
unwrap = (Failure f -> m a) -> (a -> m a) -> Either (Failure f) a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Doc AnsiStyle -> m a
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
Doc AnsiStyle -> m a
panic (Doc AnsiStyle -> m a)
-> (Failure f -> Doc AnsiStyle) -> Failure f -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure f -> Doc AnsiStyle
forall a. PrettyEx a => a -> Doc AnsiStyle
prettyEx) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure f) a -> m a)
-> (f a -> Either (Failure f) a) -> f a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Either (Failure f) a
forall (f :: * -> *) a. Fallible f => f a -> Either (Failure f) a
tryFallible
{-# INLINE unwrap #-}

-- | Prepend a message if it fails to obtain the result.
expect :: (Fallible f, PrettyEx (Failure f), MonadThrow m, HasCallStack)
  => Doc AnsiStyle -> f a -> m a
expect :: Doc AnsiStyle -> f a -> m a
expect e :: Doc AnsiStyle
e = (Failure f -> m a) -> (a -> m a) -> Either (Failure f) a -> m a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Doc AnsiStyle -> m a
forall (m :: * -> *) a.
(MonadThrow m, HasCallStack) =>
Doc AnsiStyle -> m a
panic (Doc AnsiStyle -> m a)
-> (Failure f -> Doc AnsiStyle) -> Failure f -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc AnsiStyle
prefixDoc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<>) (Doc AnsiStyle -> Doc AnsiStyle)
-> (Failure f -> Doc AnsiStyle) -> Failure f -> Doc AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Failure f -> Doc AnsiStyle
forall a. PrettyEx a => a -> Doc AnsiStyle
prettyEx) a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (Failure f) a -> m a)
-> (f a -> Either (Failure f) a) -> f a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. f a -> Either (Failure f) a
forall (f :: * -> *) a. Fallible f => f a -> Either (Failure f) a
tryFallible where
  prefix :: Doc AnsiStyle
prefix = Doc AnsiStyle
e Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> ": "
{-# INLINE expect #-}

-- | Add an exception handler for 'Panic' with prettifed output.
withPanic :: IO a -> IO a
withPanic :: IO a -> IO a
withPanic m :: IO a
m = IO a
m IO a -> (Panic -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \e :: Panic
e -> do
  Handle -> Doc AnsiStyle -> IO ()
hPutDoc Handle
stderr (Doc AnsiStyle -> IO ()) -> Doc AnsiStyle -> IO ()
forall a b. (a -> b) -> a -> b
$ Panic -> Doc AnsiStyle
forall a. PrettyEx a => a -> Doc AnsiStyle
prettyEx (Panic
e :: Panic) Doc AnsiStyle -> Doc AnsiStyle -> Doc AnsiStyle
forall a. Semigroup a => a -> a -> a
<> Doc AnsiStyle
forall ann. Doc ann
hardline
  IO a
forall a. IO a
exitFailure