{-# 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 :: 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 { panicComponent :: a
panicComponent = a
comp
              , panicLoc :: String
panicLoc       = String
loc
              , panicMsg :: [String]
panicMsg       = [String]
msg
              , panicStack :: CallStack
panicStack     = CallStack -> CallStack
freezeCallStack HasCallStack
CallStack
?callStack
              }

-- | The exception thrown when panicing.
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
                     }

-- | 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 = [| \_ -> ($Q Exp
gitHash, $Q Exp
gitBranch ++ $Q Exp
dirty) |]
  where dirty :: Q Exp
dirty = [| if $Q Exp
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 a. [a] -> 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)