    {-# 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

    -- | Throw an exception for the given component.
    panic :: (PanicComponent a, HasCallStack) =>
      a        {- ^ Component identification -} ->
      String   {- ^ Location of problem -} ->
      [String] {- ^ Problem description (lines) -} ->
      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
                  }

    -- | The exception thrown when panicing.
    data Panic a = Panic { Panic a -> a
    panicComponent :: a
                         , Panic a -> String
    panicLoc       :: String
                         , Panic a -> [String]
    panicMsg       :: [String]
                         , Panic a -> CallStack
    panicStack     :: CallStack
                         }

    -- | Description of a component.
    class Typeable a => PanicComponent a where
      panicComponentName     :: a -> String
      -- ^ Name of the panicing component.

      panicComponentIssues   :: a -> String
      -- ^ Issue tracker for the panicking component.

      panicComponentRevision :: a -> (String,String)
      -- ^ Information about the component's revision.
      -- (commit hash, branch info)

    -- | An expression of type @a -> (String,String)@.
    -- Uses template Haskell to query Git for the current state of the repo.
    -- Note that the state reported depends on when the module containing
    -- the splice was compiled.
    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)