panic-0.4.0.1/0000755000000000000000000000000013312047103011124 5ustar0000000000000000panic-0.4.0.1/Setup.hs0000644000000000000000000000005613312047103012561 0ustar0000000000000000import Distribution.Simple main = defaultMain panic-0.4.0.1/ChangeLog.md0000644000000000000000000000015413312047103013275 0ustar0000000000000000# Revision history for panic ## 0.1.0.0 -- YYYY-mm-dd * First version. Released on an unsuspecting world. panic-0.4.0.1/LICENSE0000644000000000000000000000133413312047103012132 0ustar0000000000000000Copyright (c) 2018 Iavor Diatchki Permission to use, copy, modify, and/or distribute this software for any purpose with or without fee is hereby granted, provided that the above copyright notice and this permission notice appear in all copies. THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. panic-0.4.0.1/panic.cabal0000644000000000000000000000127613312047103013210 0ustar0000000000000000name: panic version: 0.4.0.1 synopsis: A convenient way to panic. description: A convenient way to panic. license: ISC license-file: LICENSE author: Iavor Diatchki maintainer: iavor.diatchki@gmail.com category: Development build-type: Simple extra-source-files: ChangeLog.md cabal-version: >=1.10 source-repository head type: git location: https://github.com/yav/panic.git library exposed-modules: Panic build-depends: base >= 4.5 && < 5.0, gitrev >= 1.0, template-haskell hs-source-dirs: src ghc-options: -Wall default-language: Haskell2010 panic-0.4.0.1/src/0000755000000000000000000000000013312047103011713 5ustar0000000000000000panic-0.4.0.1/src/Panic.hs0000644000000000000000000000567613312047103013317 0ustar0000000000000000{-# 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)