{-# Language Trustworthy #-}
{-# Language ImplicitParams #-}
{-# Language TemplateHaskell #-}
module Panic
( Panic(..)
, PanicComponent(..)
, useGitRevision
, HasCallStack
, panic
) where
import Development.GitRev
import Language.Haskell.TH
import Data.Typeable
import Control.Exception(Exception, throw)
import Data.Maybe(fromMaybe,listToMaybe)
import GHC.Stack
panic :: (PanicComponent a, HasCallStack) =>
a ->
String ->
[String] ->
b
panic :: forall a b.
(PanicComponent a, HasCallStack) =>
a -> String -> [String] -> b
panic a
comp String
loc [String]
msg =
Panic a -> b
forall a e. Exception e => e -> a
throw Panic :: forall a. a -> String -> [String] -> CallStack -> Panic a
Panic { panicComponent :: a
panicComponent = a
comp
, panicLoc :: String
panicLoc = String
loc
, panicMsg :: [String]
panicMsg = [String]
msg
, panicStack :: CallStack
panicStack = CallStack -> CallStack
freezeCallStack HasCallStack
CallStack
?callStack
}
data Panic a = Panic { forall a. Panic a -> a
panicComponent :: a
, forall a. Panic a -> String
panicLoc :: String
, forall a. Panic a -> [String]
panicMsg :: [String]
, forall a. Panic a -> CallStack
panicStack :: CallStack
}
class Typeable a => PanicComponent a where
panicComponentName :: a -> String
panicComponentIssues :: a -> String
panicComponentRevision :: a -> (String,String)
useGitRevision :: Q Exp
useGitRevision :: Q Exp
useGitRevision = [| \_ -> ($gitHash, $gitBranch ++ $dirty) |]
where dirty :: Q Exp
dirty = [| if $gitDirty then " (uncommited files present)" else "" |]
instance (PanicComponent a) => Show (Panic a) where
show :: Panic a -> String
show Panic a
p = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
[ String
"You have encountered a bug in " String -> ShowS
forall a. [a] -> [a] -> [a]
++
a -> String
forall a. PanicComponent a => a -> String
panicComponentName a
comp String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"'s implementation."
, String
"*** Please create an issue at " String -> ShowS
forall a. [a] -> [a] -> [a]
++
a -> String
forall a. PanicComponent a => a -> String
panicComponentIssues a
comp
, String
""
, String
"%< --------------------------------------------------- "
] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
rev [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[ String
locLab String -> ShowS
forall a. [a] -> [a] -> [a]
++ Panic a -> String
forall a. Panic a -> String
panicLoc Panic a
p
, String
msgLab String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" ([String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe [String]
msgLines)
]
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
tabs String -> ShowS
forall a. [a] -> [a] -> [a]
++) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop Int
1 [String]
msgLines)
[String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ CallStack -> String
prettyCallStack (Panic a -> CallStack
forall a. Panic a -> CallStack
panicStack Panic a
p) ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
[ String
"%< --------------------------------------------------- "
]
where comp :: a
comp = Panic a -> a
forall a. Panic a -> a
panicComponent Panic a
p
msgLab :: String
msgLab = String
" Message: "
locLab :: String
locLab = String
" Location: "
revLab :: String
revLab = String
" Revision: "
branchLab :: String
branchLab = String
" Branch: "
msgLines :: [String]
msgLines = Panic a -> [String]
forall a. Panic a -> [String]
panicMsg Panic a
p
tabs :: String
tabs = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (Char -> Char -> Char
forall a b. a -> b -> a
const Char
' ') String
msgLab
(String
commitHash,String
commitBranch) = a -> (String, String)
forall a. PanicComponent a => a -> (String, String)
panicComponentRevision a
comp
rev :: [String]
rev | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
commitHash = []
| Bool
otherwise = [ String
revLab String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
commitHash
, String
branchLab String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
commitBranch
]
instance PanicComponent a => Exception (Panic a)