{-# 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 :: a -> String -> [String] -> b
panic comp :: a
comp loc :: String
loc msg :: [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 ?callStack::CallStack
CallStack
?callStack
}
data Panic a = Panic { Panic a -> a
panicComponent :: a
, Panic a -> String
panicLoc :: String
, Panic a -> [String]
panicMsg :: [String]
, 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 p :: Panic a
p = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
[ "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]
++ "'s implementation."
, "*** 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]
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] -> 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 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]
++
[ "%< --------------------------------------------------- "
]
where comp :: a
comp = Panic a -> a
forall a. Panic a -> a
panicComponent Panic a
p
msgLab :: String
msgLab = " Message: "
locLab :: String
locLab = " Location: "
revLab :: String
revLab = " Revision: "
branchLab :: String
branchLab = " 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 ' ') String
msgLab
(commitHash :: String
commitHash,commitBranch :: 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)