panic (empty) → 0.2.0.0

raw patch · 5 files changed

+124/−0 lines, 5 filesdep +basedep +gitrevdep +template-haskellsetup-changed

Dependencies added: base, gitrev, template-haskell

Files

• ChangeLog.md +5/−0
• LICENSE +13/−0
• Setup.hs +2/−0
• panic.cabal +23/−0
• src/Panic.hs +81/−0

@@ -0,0 +1,5 @@+# Revision history for panic++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.

@@ -0,0 +1,13 @@+Copyright (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.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,23 @@+name:                panic+version:             0.2.0.0+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

@@ -0,0 +1,81 @@+{-# Language Trustworthy #-}+{-# Language ImplicitParams #-}+{-# Language TemplateHaskell #-}+module Panic (HasCallStack, panic, PanicComponent(..), useGitRevision) 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 comp loc msg =+  throw Panic { panicComponent = comp+              , panicLoc       = loc+              , panicMsg       = msg+              , panicStack     = freezeCallStack ?callStack+              }++data Panic a = Panic { panicComponent :: a+                     , panicLoc       :: String+                     , panicMsg       :: [String]+                     , panicStack     :: CallStack+                     }++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 (Typeable a, 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)+