diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for require-callstack + +## 0.1.0.0 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2023 parsonsmatt + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,82 @@ +# `require-callstack` + +Haskell has opt-in call stacks through the use of the `HasCallStack` constraint. +One unfortunate aspect of this design is that the resulting `CallStack` can be truncated if any function in the call list omits the constraint. + +```haskell +foo :: HasCallStack => Int -> String +foo = error "oh no" + +bar :: HasCallStack => Int -> String +bar = foo . negate + +baz :: Int -> String +baz = bar . (* 2) + +main :: IO () +main = do + print $ baz 5 +``` + +Running this code will fail with an `ErrorCall "oh no"` exception. +The attached `CallStack` will only mention `foo` and `bar` - `baz` *will not* be present, nor will `main`. +A truncated `CallStack` isn't nearly as useful as you might like. + +One solution is the [`annotated-exception`](https://www.stackage.org/lts-21.1/package/annotated-exception-0.2.0.4) library, which can attach `CallStack` to any thrown exception, and `catch` is guaranteed to add a stack frame at the catch-site for any exception that passes through. +However, it's *still* nice to have `HasCallStack` entries on functions - then you get the name of the function, which makes diagnosing an error report easier. + +This library introduces a type `RequireCallStack`. +Unlike `HasCallStack`, this isn't automagically solved - if you call a function that has `RequireCallStack` in the constraint, you must either call `provideCallStack` to discharge the constraint, or add `RequireCallStack` to the signature of the function you're defining. + +```haskell +panic :: RequireCallStack => String -> a +panic = error + +foo :: RequireCallStack => Int -> String +foo = panic "oh no" + +bar :: RequireCallStack => Int -> String +bar = foo . negate + +baz :: Int -> String +baz = bar . (* 2) + +main :: IO () +main = do + print $ baz 5 +``` + +This code will fail with a compile-time error: + +> ``` +> /home/matt/Projects/require-callstack/test/Main.hs:30:5: error: [GHC-39999] +> • No instance for ‘RequireCallStack.Internal.Add_RequireCallStack_ToFunctionContext_OrUse_provideCallStack’ +> arising from a use of ‘bar’ +> .... +> | +> 30 | bar . (* 2) +> | ^^^ +> ``` + +The error message, read carefully, will tell you how to solve the issue. +If we then write: + +```haskell +panic :: RequireCallStack => String -> a +panic = error + +foo :: RequireCallStack => Int -> String +foo = panic "oh no" + +bar :: RequireCallStack => Int -> String +bar = foo . negate + +baz :: RequireCallStack => Int -> String +baz = bar . (* 2) + +main :: IO () +main = provideCallStack $ do + print $ baz 5 +``` + +Then the code compiles and works as expected. diff --git a/require-callstack.cabal b/require-callstack.cabal new file mode 100644 --- /dev/null +++ b/require-callstack.cabal @@ -0,0 +1,48 @@ +cabal-version: 3.0 +name: require-callstack +version: 0.1.0.0 +synopsis: Propagate HasCallStack with constraints +description: See the README for more information. +license: MIT +license-file: LICENSE +author: parsonsmatt +maintainer: parsonsmatt@gmail.com +-- copyright: +category: Development +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md +bug-reports: https://github.com/parsonsmatt/require-callstack/issues + +source-repository head + type: git + location: git://github.com/parsonsmatt/require-callstack.git + + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: + RequireCallStack + RequireCallStack.Internal + -- other-modules: + -- other-extensions: + build-depends: + base >= 4.12 && < 5 + hs-source-dirs: src + default-language: Haskell2010 + +test-suite require-callstack-test + import: warnings + default-language: Haskell2010 + -- other-modules: + -- other-extensions: + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: + base + , require-callstack diff --git a/src/RequireCallStack.hs b/src/RequireCallStack.hs new file mode 100644 --- /dev/null +++ b/src/RequireCallStack.hs @@ -0,0 +1,56 @@ +{-# language RankNTypes, FlexibleContexts, FlexibleInstances, ImpredicativeTypes, MultiParamTypeClasses, DataKinds, ConstraintKinds #-} + +-- | This module provides utilities to ensure that you propagate +-- 'HasCallStack' constraints by introducing a class 'RequireCallStack' +-- which can only be discharged using the 'provideCallStack' function. +-- +-- Let's say you have a custom prelude for your project, and you want +-- better callstack support. You replace the 'Prelude.error' with a custom +-- variant: +-- +-- @ +-- error :: RequireCallStack => String -> a +-- error = Prelude.error +-- @ +-- +-- Now, you will receive a compile-time error at every use site of 'error' +-- in your project. These errors will complain about a missing instance of +-- some weird class that gently suggests to add a 'RequireCallStack' +-- constraint, or use 'provideCallStack' to discharge it. You can add +-- 'RequireCallStack' constraints up the stack, until eventually, you have +-- complete provenance information. Or, if you want to make the work a bit +-- easier, you can use 'provideCallStack' to dismiss the constraint. +-- +-- @ +-- foo :: RequireCallStack => Int -> String +-- foo = error "oh no" +-- +-- bar :: Int -> String +-- bar i = provideCallStack $ foo i +-- @ +-- +-- Couple this with @annotated-exception@ library for excellent provenance +-- information on all thrown exceptions. +module RequireCallStack + ( RequireCallStack + , RequireCallStackImpl + , provideCallStack + , errorRequireCallStack + ) where + +import GHC.Stack +import RequireCallStack.Internal + +-- | This constraint is similar to 'HasCallStack' in that it's presence +-- will capture a stack frame for the call site of the function. This helps +-- to preserve callstack provenance, which +-- +-- @since 0.1.0.0 +type RequireCallStack = (HasCallStack, RequireCallStackImpl) + +-- | Raise an 'ErrorCall' and incur a 'RequireCallStack' constraint while +-- you do so. This +-- +-- @since 0.1.0.0 +errorRequireCallStack :: RequireCallStack => String -> x +errorRequireCallStack = error diff --git a/src/RequireCallStack/Internal.hs b/src/RequireCallStack/Internal.hs new file mode 100644 --- /dev/null +++ b/src/RequireCallStack/Internal.hs @@ -0,0 +1,64 @@ +{-# language RankNTypes, FlexibleContexts, FlexibleInstances, ImpredicativeTypes, MultiParamTypeClasses, DataKinds, ConstraintKinds #-} + +-- | The implementation details in this module are subject to change +-- and breaking without a corresponding PVP version bump. Import at your +-- own risk. +module RequireCallStack.Internal where + +import Unsafe.Coerce +import GHC.Stack + +-- | If you're running into this class, then you need to add +-- 'RequireCallStack' to your function's signature, or discharge the +-- constraint using 'provideCallStack'. +-- +-- I'd like to provide a 'TypeError' instance here with a good message, but +-- unfortunately, I won't be able to do that because it fails early. I need +-- @Unsatisfiable@ in GHC 9.8 for that. So, until I get that, you'll have +-- to see an error message that smuggles the suggestion in: +-- +-- > No instance for 'Add_RequireCallStack_ToFunctionContext_OrUse_provideCallStack' +-- +-- Which, hey, it is better than nothing! +-- +-- @since 0.1.0.0 +class Add_RequireCallStack_ToFunctionContext_OrUse_provideCallStack + +-- | An alias to make referring to +-- 'Add_RequireCallStack_ToFunctionContext_OrUse_provideCallStack' easier, +-- since it is a bit of a mouthful. +-- +-- If you see this, you probably need to either add 'RequireCallStack' to +-- the function constraints, or you need to call 'provideCallStack' to +-- discharge it. +-- +-- @since 0.1.0.0 +type RequireCallStackImpl = Add_RequireCallStack_ToFunctionContext_OrUse_provideCallStack + +-- | An internal detail. This is a specialization of the trick used in the +-- @reflection@ library to reify constraints. It's based on some GHC +-- trickery - notably, that dictionaries become runtime parameters, and +-- a no method dictionary has the same runtime rep as @()@. +-- +-- @since 0.1.0.0 +newtype MagicCallStack r = MagicCallStack (RequireCallStackImpl => r) + +-- | Satisfy a 'RequireCallStack' constraint for the given block. Can be +-- used instead of propagating a 'RequireCallStack' up the call graph. +-- +-- Usage: +-- +-- @ +-- main :: IO () +-- main = do +-- provideCallStack $ do +-- errorRequireCallStack "hello" +-- @ +-- +-- Note how 'main' does not have a 'HasCallStack' or 'RequireCallStack' +-- constraint. This function eliminates them, so that +-- 'errorRequireCallStack' can be called without compilation error. +-- +-- @since 0.1.0.0 +provideCallStack :: HasCallStack => (RequireCallStackImpl => r) -> r +provideCallStack r = (unsafeCoerce (MagicCallStack r) :: () -> r) () diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,34 @@ +{-# language FlexibleContexts #-} + +module Main (main) where + +import RequireCallStack (RequireCallStack, provideCallStack) +import Control.Exception + +panic :: RequireCallStack => String -> IO a +panic = error + +foo :: RequireCallStack => Int -> IO String +foo _ = panic "foo" + +bar :: RequireCallStack => Int -> IO String +bar = foo + +baz :: Int -> IO String +baz = provideCallStack bar + +main :: IO () +main = do + -- won't work, no callstack + -- panic "asdf" + + provideCallStack $ do + -- panic "one level of provide callstack" + pure () + + Left (ErrorCall "foo") <- try $ baz 3 + + + -- bar 3 + + pure ()