panic-0.4.0.0: src/Panic.hs

{-# 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 comp loc msg =
  throw Panic { panicComponent = comp
              , panicLoc       = loc
              , panicMsg       = msg
              , panicStack     = freezeCallStack ?callStack
              }

-- | The exception thrown when panicing.
data Panic a = Panic { panicComponent :: a
                     , panicLoc       :: String
                     , panicMsg       :: [String]
                     , 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 = [| \_ -> ($gitHash, $gitBranch ++ $dirty) |]
  where dirty = [| if $gitDirty then " (uncommited files present)" else "" |]


instance (PanicComponent a) => Show (Panic a) where
  show p = unlines $
    [ "You have encountered a bug in " ++
        panicComponentName comp ++ "'s implementation."
    , "*** Please create an issue at " ++
        panicComponentIssues comp
    , ""
    , "%< --------------------------------------------------- "
    ] ++ rev ++
    [ locLab ++ panicLoc p
    , msgLab ++ fromMaybe "" (listToMaybe msgLines)
    ]
    ++ map (tabs ++) (drop 1 msgLines)
    ++ [ prettyCallStack (panicStack p) ] ++
    [ "%< --------------------------------------------------- "
    ]
    where comp      = panicComponent p
          msgLab    = "  Message:   "
          locLab    = "  Location:  "
          revLab    = "  Revision:  "
          branchLab = "  Branch:    "
          msgLines  = panicMsg p
          tabs      = map (const ' ') msgLab

          (commitHash,commitBranch) = panicComponentRevision comp

          rev | null commitHash = []
              | otherwise       = [ revLab ++ commitHash
                                  , branchLab ++ commitBranch
                                  ]


instance PanicComponent a => Exception (Panic a)