{-# 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 =
forall a e. Exception e => e -> a
throw Panic { panicComponent :: a
panicComponent = a
comp
, panicLoc :: String
panicLoc = String
loc
, panicMsg :: [String]
panicMsg = [String]
msg
, panicStack :: CallStack
panicStack = CallStack -> CallStack
freezeCallStack HasCallStack
?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 forall a b. (a -> b) -> a -> b
$
[ String
"You have encountered a bug in " forall a. [a] -> [a] -> [a]
++
forall a. PanicComponent a => a -> String
panicComponentName a
comp forall a. [a] -> [a] -> [a]
++ String
"'s implementation."
, String
"*** Please create an issue at " forall a. [a] -> [a] -> [a]
++
forall a. PanicComponent a => a -> String
panicComponentIssues a
comp
, String
""
, String
"%< --------------------------------------------------- "
] forall a. [a] -> [a] -> [a]
++ [String]
rev forall a. [a] -> [a] -> [a]
++
[ String
locLab forall a. [a] -> [a] -> [a]
++ forall a. Panic a -> String
panicLoc Panic a
p
, String
msgLab forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe String
"" (forall a. [a] -> Maybe a
listToMaybe [String]
msgLines)
]
forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (String
tabs forall a. [a] -> [a] -> [a]
++) (forall a. Int -> [a] -> [a]
drop Int
1 [String]
msgLines)
forall a. [a] -> [a] -> [a]
++ [ CallStack -> String
prettyCallStack (forall a. Panic a -> CallStack
panicStack Panic a
p) ] forall a. [a] -> [a] -> [a]
++
[ String
"%< --------------------------------------------------- "
]
where comp :: a
comp = 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 = forall a. Panic a -> [String]
panicMsg Panic a
p
tabs :: String
tabs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Char
' ') String
msgLab
(String
commitHash,String
commitBranch) = forall a. PanicComponent a => a -> (String, String)
panicComponentRevision a
comp
rev :: [String]
rev | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
commitHash = []
| Bool
otherwise = [ String
revLab forall a. [a] -> [a] -> [a]
++ String
commitHash
, String
branchLab forall a. [a] -> [a] -> [a]
++ String
commitBranch
]
instance PanicComponent a => Exception (Panic a)