diff --git a/cryptol.cabal b/cryptol.cabal index a0c83422..19470438 100644 --- a/cryptol.cabal +++ b/cryptol.cabal @@ -65,7 +65,8 @@ library tf-random >= 0.5, transformers-base >= 0.4, mtl >= 2.2.1, - time >= 1.6.0.1 + time >= 1.6.0.1, + panic >= 0.3 Build-tools: alex, happy diff --git a/src/Cryptol/Utils/Panic.hs b/src/Cryptol/Utils/Panic.hs index 85d7fecc..2cc0e69a 100644 --- a/src/Cryptol/Utils/Panic.hs +++ b/src/Cryptol/Utils/Panic.hs @@ -6,53 +6,25 @@ -- Stability : provisional -- Portability : portable -{-# LANGUAGE Safe #-} -{-# LANGUAGE DeriveDataTypeable, RecordWildCards, ImplicitParams #-} -module Cryptol.Utils.Panic (HasCallStack, panic) where +{-# LANGUAGE Trustworthy, TemplateHaskell #-} +module Cryptol.Utils.Panic + (HasCallStack, CryptolPanic, Cryptol, Panic, panic) where -import Cryptol.Version +import Panic hiding (panic) +import qualified Panic as Panic -import Control.Exception as X -import Data.Typeable(Typeable) -import Data.Maybe(fromMaybe,listToMaybe) -import GHC.Stack +data Cryptol = Cryptol + +type CryptolPanic = Panic Cryptol panic :: HasCallStack => String -> [String] -> a -panic panicLoc panicMsg = - throw CryptolPanic { panicStack = freezeCallStack ?callStack, .. } +panic = Panic.panic Cryptol -data CryptolPanic = CryptolPanic { panicLoc :: String - , panicMsg :: [String] - , panicStack :: CallStack - } deriving Typeable +instance PanicComponent Cryptol where + panicComponentName _ = "Cryptol" + panicComponentIssues _ = "https://github.com/GaloisInc/cryptol/issues" -instance Show CryptolPanic where - show p = unlines $ - [ "You have encountered a bug in Cryptol's implementation." - , "*** Please create an issue at https://github.com/galoisinc/cryptol/issues" - , "" - , "%< --------------------------------------------------- " - ] ++ rev ++ - [ locLab ++ panicLoc p - , msgLab ++ fromMaybe "" (listToMaybe msgLines) - ] - ++ map (tabs ++) (drop 1 msgLines) - ++ [ prettyCallStack (panicStack p) ] ++ - [ "%< --------------------------------------------------- " - ] - where msgLab = " Message: " - revLab = " Revision: " - branchLab = " Branch: " - dirtyLab = " (non-committed files present during build)" - locLab = " Location: " - tabs = map (const ' ') msgLab - - msgLines = panicMsg p - - rev | null commitHash = [] - | otherwise = [ revLab ++ commitHash - , branchLab ++ commitBranch ++ dirtyLab ] - -instance Exception CryptolPanic + {-# Noinline panicComponentRevision #-} + panicComponentRevision = $useGitRevision